vishapoberon/compiler
1
0
Fork 0
mirror of https://github.com/vishapoberon/compiler.git synced 2026-04-06 15:42:25 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

Rename lib to library.

Browse source
This commit is contained in:
David Brown 2016-06-16 13:56:12 +01:00
parent b7536a8446
commit 1304822769
130 changed files with 0 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

60
src/library/ulm/ulmASCII.Mod Normal file
View file

@ -0,0 +1,60 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: ASCII.om,v 1.1 1994/02/22 20:01:03 borchert Exp $
----------------------------------------------------------------------------
$Log: ASCII.om,v $
Revision 1.1 1994/02/22 20:01:03 borchert
Initial revision
----------------------------------------------------------------------------
AFB 12/90
----------------------------------------------------------------------------
*)
MODULE ulmASCII;
CONST
(* control characters *)
nul* = 000X; soh* = 001X; stx* = 002X; etx* = 003X; eot* = 004X;
enq* = 005X; ack* = 006X; bel* = 007X; bs* = 008X; ht* = 009X;
nl* = 00AX; vt* = 00BX; np* = 00CX; cr* = 00DX; so* = 00EX;
si* = 00FX; dle* = 010X; dc1* = 011X; dc2* = 012X; dc3* = 013X;
dc4* = 014X; nak* = 015X; syn* = 016X; etb* = 017X; can* = 018X;
em* = 019X; sub* = 01AX; esc* = 01BX; fs* = 01CX; gs* = 01DX;
rs* = 01EX; us* = 01FX; sp* = 020X; del* = 07FX;
CtrlA* = 01X; CtrlB* = 02X; CtrlC* = 03X; CtrlD* = 04X; CtrlE* = 05X;
CtrlF* = 06X; CtrlG* = 07X; CtrlH* = 08X; CtrlI* = 09X; CtrlJ* = 0AX;
CtrlK* = 0BX; CtrlL* = 0CX; CtrlM* = 0DX; CtrlN* = 0EX; CtrlO* = 0FX;
CtrlP* = 10X; CtrlQ* = 11X; CtrlR* = 12X; CtrlS* = 13X; CtrlT* = 14X;
CtrlU* = 15X; CtrlV* = 16X; CtrlW* = 17X; CtrlX* = 18X; CtrlY* = 19X;
CtrlZ* = 1AX;
(* other usual names *)
EOL* = nl;
null* = nul;
bell* = bel;
tab* = ht;
lf* = nl;
ff* = np;
quote* = 22X;
END ulmASCII.

121
src/library/ulm/ulmAssertions.Mod Normal file
View file

@ -0,0 +1,121 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Assertions.om,v 1.2 1996/01/04 16:50:59 borchert Exp $
----------------------------------------------------------------------------
$Log: Assertions.om,v $
Revision 1.2 1996/01/04 16:50:59 borchert
some fixes because event types are now an extension of Services.Object
Revision 1.1 1994/02/22 20:06:01 borchert
Initial revision
----------------------------------------------------------------------------
AFB 11/91
----------------------------------------------------------------------------
*)
MODULE ulmAssertions;
(* general error handling of library routines *)
IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, IO := ulmIO, Priorities := ulmPriorities, RelatedEvents := ulmRelatedEvents, Services := ulmServices;
TYPE
Object = Disciplines.Object;
Identifier* = ARRAY 32 OF CHAR; (* should be sufficient *)
Event* = POINTER TO EventRec;
EventRec* =
RECORD
(Events.EventRec)
object*: Object; (* may be NIL *)
module*: Identifier;
proc*: Identifier;
END;
EventType = POINTER TO EventTypeRec;
EventTypeRec* =
RECORD
(Events.EventTypeRec)
(* private components *)
module: Identifier;
END;
VAR
failedAssertion*: Events.EventType;
eventTypeType: Services.Type;
PROCEDURE Define*(VAR type: Events.EventType; module: ARRAY OF CHAR);
(* create a new event type which will be of type Assertions.EventType *)
VAR
newtype: EventType;
BEGIN
NEW(newtype);
Services.Init(newtype, eventTypeType);
Events.Init(newtype);
Events.SetPriority(newtype, Priorities.assertions);
COPY(module, newtype.module);
type := newtype;
END Define;
PROCEDURE Raise*(object: RelatedEvents.Object;
type: Events.EventType;
proc: ARRAY OF CHAR;
text: ARRAY OF CHAR);
(* raise Assertions.failedAssertion;
create a event of the given type and pass it
to RelatedEvents.Raise (if object # NIL)
or Events.Raise (if object = NIL);
*)
VAR
event: Event;
PROCEDURE CreateEvent(VAR event: Event; etype: Events.EventType);
BEGIN
NEW(event);
event.type := etype;
COPY(text, event.message);
event.object := object;
IF type IS EventType THEN
COPY(type(EventType).module, event.module);
ELSE
event.module[0] := 0X;
END;
COPY(proc, event.proc);
END CreateEvent;
BEGIN
IO.WriteString("assertion failed: ");
IO.WriteString(text); IO.WriteString(" in procedure ");
IO.WriteString(proc); IO.WriteLn;
CreateEvent(event, failedAssertion); Events.Raise(event);
CreateEvent(event, type);
IF object = NIL THEN
Events.Raise(event);
ELSE
RelatedEvents.Raise(object, event);
END;
END Raise;
BEGIN
Events.Define(failedAssertion);
Events.SetPriority(failedAssertion, Priorities.assertions);
Events.Ignore(failedAssertion);
Services.CreateType(eventTypeType,
"Assertions.EventType", "Events.EventType");
END ulmAssertions.

174
src/library/ulm/ulmAsymmetricCiphers.Mod Normal file
View file

@ -0,0 +1,174 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1997 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: AsymmetricC.om,v 1.1 1997/04/02 11:52:05 borchert Exp borchert $
----------------------------------------------------------------------------
$Log: AsymmetricC.om,v $
Revision 1.1 1997/04/02 11:52:05 borchert
Initial revision
----------------------------------------------------------------------------
*)
MODULE ulmAsymmetricCiphers; (* Michael Szczuka *)
(* abstraction for the use of public key ciphers *)
IMPORT BlockCiphers := ulmBlockCiphers, Ciphers := ulmCiphers, NetIO := ulmNetIO, PersistentObjects := ulmPersistentObjects, Services := ulmServices, Streams := ulmStreams;
CONST
composed* = 0; isPrivateKey* = 1;
TYPE
CapabilitySet* = SET;
TYPE
Cipher* = POINTER TO CipherRec;
SplitProc* = PROCEDURE (VAR public: Cipher; key: Cipher);
RandomStreamProc* = PROCEDURE (s: Streams.Stream);
Interface* = POINTER TO InterfaceRec;
InterfaceRec* = RECORD
(Ciphers.InterfaceRec)
(* public *)
compencrypt* : Ciphers.CryptProc;
split* : SplitProc;
randomStream* : RandomStreamProc;
END;
CipherRec* = RECORD
(BlockCiphers.CipherRec)
(* private *)
cap : CapabilitySet;
asymIf : Interface;
END;
VAR
asymmetricCipherType : Services.Type;
if : PersistentObjects.Interface;
(* need to have this in case anyone wants to decrypt something with
a public cipher ... *)
PROCEDURE Identity(in: Streams.Stream; key: Ciphers.Cipher;
length: INTEGER; out: Streams.Stream) : BOOLEAN;
BEGIN
RETURN Streams.Copy(in, out, length);
END Identity;
PROCEDURE Init* (key: Cipher; if: Interface;
cap: CapabilitySet; inLength, outLength: INTEGER);
BEGIN
IF if.decrypt = NIL THEN
(* decrypt is not defined, so we have only the public part of a cipher;
we can use the identity instead of a decrypting function
in this case
*)
if.decrypt := Identity;
END;
BlockCiphers.Init(key, if, inLength, outLength);
key.cap := cap;
key.asymIf := if;
IF (key.asymIf.compencrypt = NIL) OR ~(composed IN cap) THEN
(* so the cipher's composed function is not defined; therefor it must be
the identical function *)
key.asymIf.compencrypt := Identity;
END;
END Init;
PROCEDURE Capabilities* (key: Cipher) : CapabilitySet;
BEGIN
RETURN key.cap;
END Capabilities;
PROCEDURE IsPublicKey* (key: Cipher) : BOOLEAN;
BEGIN
RETURN ~(isPrivateKey IN key.cap);
END IsPublicKey;
PROCEDURE Split* (VAR public: Cipher; key: Cipher);
BEGIN
IF IsPublicKey(key) THEN
(* trying to extract a public part from a key that already IS a public
cipher? well, if you really want to ... *)
public := key;
RETURN;
END;
key.asymIf.split(public, key);
(* define the extracted part as public *)
public.cap := public.cap - {isPrivateKey};
END Split;
(* encrypts a given stream msg with the composed map of the key *)
PROCEDURE ComposedEncrypt* (in: Streams.Stream; key: Cipher;
out: Streams.Stream) : BOOLEAN;
BEGIN
RETURN key.asymIf.compencrypt(in, key, -1, out);
END ComposedEncrypt;
PROCEDURE ComposedEncryptPart* (in: Streams.Stream; key: Cipher;
length: INTEGER;
out: Streams.Stream) : BOOLEAN;
BEGIN
RETURN key.asymIf.compencrypt(in, key, length, out);
END ComposedEncryptPart;
PROCEDURE ComposedEncryptBlock* (in: Streams.Stream; key: Cipher;
out: Streams.Stream) : BOOLEAN;
VAR
length : INTEGER;
BEGIN
length := BlockCiphers.GetInLength(key);
RETURN key.asymIf.compencrypt(in, key, length, out);
END ComposedEncryptBlock;
PROCEDURE RandomStream*(s: Streams.Stream; key: Cipher);
BEGIN
key.asymIf.randomStream(s);
END RandomStream;
PROCEDURE Create (VAR obj: PersistentObjects.Object);
VAR
cipher : Cipher;
BEGIN
NEW(cipher);
PersistentObjects.Init(cipher, asymmetricCipherType);
obj := cipher;
END Create;
PROCEDURE Write (s: Streams.Stream; obj: PersistentObjects.Object) : BOOLEAN;
BEGIN
WITH obj:Cipher DO
RETURN NetIO.WriteSet(s, obj.cap);
END;
END Write;
PROCEDURE Read (s: Streams.Stream; obj: PersistentObjects.Object) : BOOLEAN;
BEGIN
WITH obj:Cipher DO
RETURN NetIO.ReadSet(s, obj.cap);
END;
END Read;
BEGIN
NEW(if);
if.create := Create; if.write := Write; if.read := Read;
if.createAndRead := NIL;
PersistentObjects.RegisterType(asymmetricCipherType,
"AsymmetricCiphers.Cipher", "BlockCiphers.Cipher", if);
END ulmAsymmetricCiphers.

123
src/library/ulm/ulmBlockCiphers.Mod Normal file
View file

@ -0,0 +1,123 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1997 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: BlockCipher.om,v 1.1 1997/04/02 11:52:59 borchert Exp borchert $
----------------------------------------------------------------------------
$Log: BlockCipher.om,v $
Revision 1.1 1997/04/02 11:52:59 borchert
Initial revision
----------------------------------------------------------------------------
*)
MODULE ulmBlockCiphers; (* Michael Szczuka *)
(* abstraction for the use of block ciphers *)
IMPORT Ciphers := ulmCiphers, NetIO := ulmNetIO, PersistentObjects := ulmPersistentObjects, Services := ulmServices, Streams := ulmStreams;
TYPE
Cipher* = POINTER TO CipherRec;
CipherRec* = RECORD
(Ciphers.CipherRec)
(* private *)
inLength: INTEGER;
outLength: INTEGER;
END;
VAR
blockCipherType : Services.Type;
if : PersistentObjects.Interface;
PROCEDURE Init* (key: Cipher; if: Ciphers.Interface;
inLength, outLength: INTEGER);
(* init a block cipher with its special interface *)
BEGIN
Ciphers.Init(key, if);
ASSERT(inLength > 0);
ASSERT(outLength > 0);
key.inLength := inLength;
key.outLength := outLength;
END Init;
PROCEDURE GetInLength* (key: Cipher) : INTEGER;
(* returns the input block length of a block cipher *)
BEGIN
RETURN key.inLength;
END GetInLength;
PROCEDURE GetOutLength* (key: Cipher) : INTEGER;
(* returns the output block length of a block cipher *)
BEGIN
RETURN key.outLength;
END GetOutLength;
PROCEDURE EncryptBlock* (in: Streams.Stream; key: Cipher;
out: Streams.Stream) : BOOLEAN;
VAR
length : INTEGER;
BEGIN
length := GetInLength(key);
RETURN Ciphers.EncryptPart(in, key, length, out);
END EncryptBlock;
PROCEDURE DecryptBlock* (in: Streams.Stream; key: Cipher;
out: Streams.Stream) : BOOLEAN;
VAR
length : INTEGER;
BEGIN
length := GetOutLength(key);
RETURN Ciphers.DecryptPart(in, key, length, out);
END DecryptBlock;
PROCEDURE Create(VAR obj: PersistentObjects.Object);
VAR
key : Cipher;
BEGIN
NEW(key);
PersistentObjects.Init(key, blockCipherType);
obj := key;
END Create;
PROCEDURE Write(s: Streams.Stream; obj: PersistentObjects.Object) : BOOLEAN;
BEGIN
WITH obj:Cipher DO
RETURN NetIO.WriteInteger(s, obj.inLength) &
NetIO.WriteInteger(s, obj.outLength);
END;
END Write;
PROCEDURE Read(s: Streams.Stream; obj: PersistentObjects.Object) : BOOLEAN;
BEGIN
WITH obj:Cipher DO
RETURN NetIO.ReadInteger(s, obj.inLength) &
NetIO.ReadInteger(s, obj.outLength);
END;
END Read;
BEGIN
NEW(if);
if.create := Create;
if.write := Write;
if.read := Read;
if.createAndRead := NIL;
PersistentObjects.RegisterType(blockCipherType, "BlockCiphers.Cipher",
"Ciphers.Cipher", if);
END ulmBlockCiphers.

67
src/library/ulm/ulmCipherOps.Mod Normal file
View file

@ -0,0 +1,67 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1997 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: CipherOps.om,v 1.1 1997/04/02 11:53:20 borchert Exp borchert $
----------------------------------------------------------------------------
$Log: CipherOps.om,v $
Revision 1.1 1997/04/02 11:53:20 borchert
Initial revision
----------------------------------------------------------------------------
*)
MODULE ulmCipherOps; (* Michael Szczuka *)
(* useful functions for stream ciphers *)
IMPORT Streams := ulmStreams, SYS := SYSTEM, Write := ulmWrite;
PROCEDURE XorByte* (b1, b2: SYS.BYTE) : SYS.BYTE;
(* adds two bytes bitwise modulo 2 *)
BEGIN
RETURN SYS.VAL(SYS.BYTE, SYS.VAL(SET, b1) / SYS.VAL(SET, b2))
END XorByte;
PROCEDURE XorStream* (in1, in2, out: Streams.Stream;
length: INTEGER) : BOOLEAN;
(* adds two streams bitwise modulo 2; restricted to length bytes *)
VAR
b1, b2, res : SYS.BYTE;
wholeStream : BOOLEAN;
BEGIN
IF length < 0 THEN
wholeStream := TRUE;
ELSE
wholeStream := FALSE;
END;
WHILE wholeStream OR (length > 0) DO
IF Streams.ReadByte(in1, b1) & Streams.ReadByte(in2, b2) THEN
res := XorByte(b1, b2);
IF ~Streams.WriteByte(out, res) THEN
RETURN FALSE
END;
ELSE
RETURN wholeStream
END;
DEC(length);
END;
RETURN TRUE
END XorStream;
END ulmCipherOps.

94
src/library/ulm/ulmCiphers.Mod Normal file
View file

@ -0,0 +1,94 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1997 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Ciphers.om,v 1.1 1997/04/02 11:51:15 borchert Exp $
----------------------------------------------------------------------------
$Log: Ciphers.om,v $
Revision 1.1 1997/04/02 11:51:15 borchert
Initial revision
----------------------------------------------------------------------------
*)
(* abstraction for the use of ciphers and cryptographic methods *)
MODULE ulmCiphers;
IMPORT Objects := ulmObjects, PersistentObjects := ulmPersistentObjects, PersistentDisciplines := ulmPersistentDisciplines, Services := ulmServices,
Streams := ulmStreams, Write := ulmWrite;
TYPE
Cipher* = POINTER TO CipherRec;
TYPE
CryptProc* = PROCEDURE (in: Streams.Stream; key: Cipher;
length: INTEGER; out: Streams.Stream) : BOOLEAN;
TYPE
Interface* = POINTER TO InterfaceRec;
InterfaceRec* = RECORD
(Objects.ObjectRec)
(* public *)
encrypt*, decrypt* : CryptProc;
END;
TYPE
CipherRec* = RECORD
(PersistentDisciplines.ObjectRec)
(* private *)
if : Interface
END;
VAR
cipherType, interfaceType : Services.Type;
PROCEDURE Init*(key: Cipher; if: Interface);
BEGIN
ASSERT(if # NIL);
ASSERT(if.encrypt # NIL);
key.if := if;
END Init;
PROCEDURE Encrypt*(in: Streams.Stream; key: Cipher;
out: Streams.Stream) : BOOLEAN;
BEGIN
RETURN key.if.encrypt(in, key, -1, out);
END Encrypt;
PROCEDURE Decrypt*(in: Streams.Stream; key: Cipher;
out: Streams.Stream) : BOOLEAN;
BEGIN
RETURN key.if.decrypt(in, key, -1, out);
END Decrypt;
PROCEDURE EncryptPart*(in: Streams.Stream; key: Cipher;
length: INTEGER; out: Streams.Stream) : BOOLEAN;
BEGIN
RETURN key.if.encrypt(in, key, length, out);
END EncryptPart;
PROCEDURE DecryptPart*(in: Streams.Stream; key: Cipher;
length: INTEGER; out: Streams.Stream) : BOOLEAN;
BEGIN
RETURN key.if.decrypt(in, key, length, out);
END DecryptPart;
BEGIN
PersistentObjects.RegisterType(cipherType, "Ciphers.Cipher",
"PersistentDisciplines.Object", NIL);
END ulmCiphers.

277
src/library/ulm/ulmClocks.Mod Normal file
View file

@ -0,0 +1,277 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Clocks.om,v 1.3 2004/02/19 15:21:17 borchert Exp $
----------------------------------------------------------------------------
$Log: Clocks.om,v $
Revision 1.3 2004/02/19 15:21:17 borchert
Passed added including passed capability
Revision 1.2 1996/01/04 16:50:25 borchert
clocks are now an extension of Services.Object
Revision 1.1 1994/02/22 20:06:13 borchert
Initial revision
----------------------------------------------------------------------------
AFB 1/92
----------------------------------------------------------------------------
*)
MODULE ulmClocks;
IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Objects := ulmObjects, Op := ulmOperations, Priorities := ulmPriorities,
RelatedEvents := ulmRelatedEvents, Services := ulmServices, Times := ulmTimes;
TYPE
Clock* = POINTER TO ClockRec;
CONST
settime* = 0; timer* = 1; passed* = 2;
TYPE
CapabilitySet* = SET; (* OF [settime..passed] *)
TYPE
GetTimeProc* = PROCEDURE (clock: Clock; VAR time: Times.Time);
SetTimeProc* = PROCEDURE (clock: Clock; time: Times.Time);
PassedProc* = PROCEDURE (clock: Clock; time: Times.Time) : BOOLEAN;
TimerOnProc* = PROCEDURE (clock: Clock; time: Times.Time;
event: Events.Event);
TimerOffProc* = PROCEDURE (clock: Clock);
GetPriorityProc* = PROCEDURE (clock: Clock;
VAR priority: Priorities.Priority);
Interface* = POINTER TO InterfaceRec;
InterfaceRec* =
RECORD
(Objects.ObjectRec)
gettime*: GetTimeProc;
settime*: SetTimeProc;
passed*: PassedProc;
timeron*: TimerOnProc;
timeroff*: TimerOffProc;
getpriority*: GetPriorityProc;
END;
TYPE
ClockRec* =
RECORD
(Services.ObjectRec)
if: Interface;
caps: CapabilitySet;
END;
VAR
clockType: Services.Type;
TYPE
StaticClock = POINTER TO StaticClockRec;
StaticClockRec =
RECORD
(ClockRec)
time: Times.Time;
timerOn: BOOLEAN;
timer: Times.Time;
event: Events.Event;
END;
VAR
staticClockType: Services.Type;
VAR
system*: Clock; (* the clock of the operating system *)
CONST
cannotSetTime* = 0; (* SetTime not implemented *)
cannotSetTimer* = 1; (* timer not implemented *)
errorcodes* = 2;
TYPE
ErrorEvent* = POINTER TO ErrorEventRec;
ErrorEventRec* =
RECORD
(Events.EventRec)
errorcode*: SHORTINT;
END;
VAR
errormsg*: ARRAY errorcodes OF Events.Message;
error*: Events.EventType;
PROCEDURE Error(clock: Clock; code: SHORTINT);
VAR
event: ErrorEvent;
BEGIN
NEW(event);
event.type := error;
event.message := errormsg[code];
event.errorcode := code;
RelatedEvents.Raise(clock, event);
END Error;
PROCEDURE InitErrorHandling;
BEGIN
errormsg[cannotSetTime] := "SetTime not implemented for this clock";
errormsg[cannotSetTimer] := "timer not implemented for this clock";
Events.Define(error);
Events.SetPriority(error, Priorities.liberrors);
END InitErrorHandling;
PROCEDURE Init*(clock: Clock; if: Interface; caps: CapabilitySet);
VAR
type: Services.Type;
BEGIN
Services.GetType(clock, type);
ASSERT(type # NIL);
ASSERT(if.gettime # NIL);
ASSERT(~(passed IN caps) OR (if.passed # NIL));
ASSERT(~(settime IN caps) OR (if.settime # NIL));
IF timer IN caps THEN
ASSERT((if.timeron # NIL) & (if.timeroff # NIL) &
(if.getpriority # NIL));
END;
clock.if := if;
clock.caps := caps;
RelatedEvents.QueueEvents(clock);
END Init;
PROCEDURE Capabilities*(clock: Clock) : CapabilitySet;
BEGIN
RETURN clock.caps
END Capabilities;
PROCEDURE GetTime*(clock: Clock; VAR time: Times.Time);
BEGIN
clock.if.gettime(clock, time);
END GetTime;
PROCEDURE SetTime*(clock: Clock; time: Times.Time);
BEGIN
IF settime IN clock.caps THEN
clock.if.settime(clock, time);
ELSE
Error(clock, cannotSetTime);
END;
END SetTime;
PROCEDURE Passed*(clock: Clock; time: Times.Time) : BOOLEAN;
VAR
currentTime: Times.Time;
BEGIN
IF passed IN clock.caps THEN
RETURN clock.if.passed(clock, time)
ELSE
GetTime(clock, currentTime);
RETURN Op.Compare(currentTime, time) >= 0
END;
END Passed;
PROCEDURE TimerOn*(clock: Clock; time: Times.Time; event: Events.Event);
BEGIN
IF timer IN clock.caps THEN
clock.if.timeron(clock, time, event);
ELSE
Error(clock, cannotSetTimer);
END;
END TimerOn;
PROCEDURE TimerOff*(clock: Clock);
BEGIN
IF timer IN clock.caps THEN
clock.if.timeroff(clock);
ELSE
Error(clock, cannotSetTimer);
END;
END TimerOff;
PROCEDURE GetPriority*(clock: Clock; VAR priority: Priorities.Priority);
(* return Priorities.base in case of static clocks *)
BEGIN
IF timer IN clock.caps THEN
clock.if.getpriority(clock, priority);
ELSE
Error(clock, cannotSetTimer);
END;
END GetPriority;
(* ========= implementation of static clocks ========== *)
PROCEDURE StaticGetTime(clock: Clock; VAR time: Times.Time);
BEGIN
time := clock(StaticClock).time;
END StaticGetTime;
PROCEDURE StaticSetTime(clock: Clock; time: Times.Time);
BEGIN
WITH clock: StaticClock DO
clock.time := time;
IF clock.timerOn & (Op.Compare(clock.time, clock.timer) >= 0) THEN
clock.timerOn := FALSE;
Events.Raise(clock.event);
END;
END;
END StaticSetTime;
PROCEDURE StaticTimerOn(clock: Clock; time: Times.Time; event: Events.Event);
BEGIN
WITH clock: StaticClock DO
IF Op.Compare(time, clock.time) < 0 THEN
Events.Raise(event);
ELSE
clock.timerOn := TRUE;
clock.timer := time;
clock.event := event;
END;
END;
END StaticTimerOn;
PROCEDURE StaticTimerOff(clock: Clock);
BEGIN
WITH clock: StaticClock DO
clock.timerOn := FALSE;
END;
END StaticTimerOff;
PROCEDURE StaticGetPriority(clock: Clock; VAR priority: Priorities.Priority);
BEGIN
priority := Priorities.base;
END StaticGetPriority;
PROCEDURE CreateStaticClock*(VAR clock: Clock);
VAR
if: Interface;
staticClock: StaticClock;
BEGIN
NEW(staticClock);
Services.Init(staticClock, staticClockType);
Times.Create(staticClock.time, Times.absolute);
staticClock.timerOn := FALSE;
NEW(if);
if.gettime := StaticGetTime;
if.settime := StaticSetTime;
if.timeron := StaticTimerOn;
if.timeroff := StaticTimerOff;
if.getpriority := StaticGetPriority;
Init(staticClock, if, {settime, timer});
clock := staticClock;
END CreateStaticClock;
BEGIN
InitErrorHandling;
Services.CreateType(clockType, "Clocks.Clock", "");
Services.CreateType(staticClockType, "Clocks.StaticClock", "Clocks.Clock");
(* system is hopefully re-initialized by another module which interfaces
the real system clock
*)
CreateStaticClock(system);
END ulmClocks.

169
src/library/ulm/ulmConclusions.Mod Normal file
View file

@ -0,0 +1,169 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Conclusions.om,v 1.2 1994/07/05 12:50:01 borchert Exp $
----------------------------------------------------------------------------
$Log: Conclusions.om,v $
Revision 1.2 1994/07/05 12:50:01 borchert
formatting of error messages depends now on the indentation width
of StreamDisciplines
Revision 1.1 1994/02/23 07:46:17 borchert
Initial revision
----------------------------------------------------------------------------
AFB 11/91
----------------------------------------------------------------------------
*)
MODULE ulmConclusions;
(* convert errors and events into conclusions,
i.e. a final message and reaction
*)
IMPORT Errors := ulmErrors, Events := ulmEvents, Process := ulmProcess, RelatedEvents := ulmRelatedEvents, StreamDisciplines := ulmStreamDisciplines,
Streams := ulmStreams, Strings := ulmStrings, Write := ulmWrite;
VAR
handlerSet*: Errors.HandlerSet;
errors*: INTEGER; (* number of errors *)
fatalcode*: INTEGER; (* exit code on fatal events *)
(* private variables *)
cmdName: Process.Name; (* should be sufficient for a base name *)
cmdNameLen: INTEGER; (* Strings.Len(cmdName) *)
(* private procedures *)
PROCEDURE GeneralHandler(event: Events.Event; kind: Errors.Kind);
VAR
width: INTEGER;
BEGIN
IF event # NIL THEN
Write.IndentS(Streams.stderr);
Write.StringS(Streams.stderr, cmdName);
Write.StringS(Streams.stderr, ": ");
width := SHORT(Strings.Len(cmdName) + 2);
StreamDisciplines.IncrIndentationWidth(Streams.stderr, width);
IF kind # Errors.message THEN
Write.StringS(Streams.stderr, Errors.kindText[kind]);
Write.StringS(Streams.stderr, ": ");
END;
Errors.Write(Streams.stderr, event); Write.LnS(Streams.stderr);
StreamDisciplines.IncrIndentationWidth(Streams.stderr, -width);
END;
CASE kind OF
| Errors.error: INC(errors);
| Errors.fatal: Process.Exit(fatalcode);
| Errors.bug: Process.Abort;
ELSE
(* no further actions *)
END;
END GeneralHandler;
PROCEDURE AbortHandler(event: Events.Event);
BEGIN
GeneralHandler(event, Errors.bug);
END AbortHandler;
PROCEDURE Init;
VAR
messageKind: Errors.Kind;
BEGIN
fatalcode := 1;
errors := 0;
cmdName := Process.name;
cmdNameLen := SHORT(Strings.Len(cmdName));
messageKind := 0;
Errors.CreateHandlerSet(handlerSet);
WHILE messageKind < Errors.nkinds DO
Errors.InstallHandler(handlerSet, messageKind, GeneralHandler);
INC(messageKind);
END;
Events.AbortHandler(AbortHandler);
END Init;
(* public procedures *)
PROCEDURE CatchEvent*(type: Events.EventType; kind: Errors.Kind);
BEGIN
Errors.CatchEvent(handlerSet, kind, type);
END CatchEvent;
PROCEDURE ConcludeS*(s: Streams.Stream;
object: RelatedEvents.Object; kind: Errors.Kind;
text: ARRAY OF CHAR);
VAR
queue: RelatedEvents.Queue;
width: INTEGER;
PROCEDURE ReverseQueue(VAR queue: RelatedEvents.Queue);
VAR
ptr, prev, next: RelatedEvents.Queue;
BEGIN
ptr := queue; prev := NIL;
WHILE ptr # NIL DO
next := ptr.next;
ptr.next := prev;
prev := ptr;
ptr := next;
END;
queue := prev;
END ReverseQueue;
BEGIN
RelatedEvents.GetQueue(object, queue);
Write.IndentS(s);
Write.StringS(s, cmdName); Write.StringS(s, ": ");
IF kind # Errors.message THEN
Write.StringS(s, Errors.kindText[kind]); Write.StringS(s, ": ");
END;
IF text # "" THEN
Write.StringS(s, text); Write.StringS(s, ": ");
END;
IF queue = NIL THEN
Write.StringS(s, "*no error messages found*"); Write.LnS(s);
ELSE
width := cmdNameLen + (* ": " *) 2;
StreamDisciplines.IncrIndentationWidth(s, width);
(* convert FIFO into LIFO *)
ReverseQueue(queue);
LOOP
Errors.Write(s, queue.event); Write.LnS(s);
queue := queue.next;
(**)IF queue = NIL THEN EXIT END;
Write.IndentS(s);
END;
StreamDisciplines.IncrIndentationWidth(s, -width);
END;
GeneralHandler(NIL, kind);
END ConcludeS;
PROCEDURE Conclude*(object: RelatedEvents.Object; kind: Errors.Kind;
text: ARRAY OF CHAR);
BEGIN
ConcludeS(Streams.stderr, object, kind, text);
END Conclude;
BEGIN
Init;
END ulmConclusions.

967
src/library/ulm/ulmConditions.Mod Normal file
View file

@ -0,0 +1,967 @@
(* Ulm's Oberon Library
Copyright (C) 1989-2005 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Conditions.om,v 1.7 2005/02/09 09:53:25 borchert Exp $
----------------------------------------------------------------------------
$Log: Conditions.om,v $
Revision 1.7 2005/02/09 09:53:25 borchert
bug fix: we have to enter a busy loop even in case of interrupting
events as there is a window between setup and Process.Pause
Revision 1.6 2005/02/06 22:26:59 borchert
bug fix: assure that the priority of asynchronous events exceeds
those of interrupting events
Revision 1.5 2004/09/03 08:59:34 borchert
hash tab size for ConditionSet changed from 128 to 64
Revision 1.4 2004/09/01 13:32:18 borchert
performance improvement: condition sets are now based on hashes
Revision 1.3 2001/05/18 21:59:01 borchert
SetupAsyncEvents checks now all conditions to add as much conditions
as possible to setOfTrueConditions
Revision 1.2 1996/01/04 16:59:56 borchert
- conditions are now extensions of Disciplines.Object
- some renamings: timecond -> timelimit, hint -> timecond
- errors events have been replaced by assertions
- WaitForAndSelect has been renamed to WaitFor (the old version
of WaitFor vanished)
- conditions are now tagged to allow some optimizations of the
condition set operations
- optimized support of async capability
- redesign of blocking algorithm
Revision 1.1 1994/02/22 20:06:25 borchert
Initial revision
----------------------------------------------------------------------------
AFB 12/91
----------------------------------------------------------------------------
*)
MODULE ulmConditions;
IMPORT Clocks := ulmClocks, Disciplines := ulmDisciplines, Events := ulmEvents, Objects := ulmObjects, Op := ulmOperations,
Priorities := ulmPriorities, Process := ulmProcess, RelatedEvents := ulmRelatedEvents, Scales := ulmScales, Timers := ulmTimers, Times := ulmTimes, SYSTEM;
CONST
tags = 64;
TYPE
Tag = INTEGER; (* 0..tags-1 *)
(* tags are used for the hashs *)
VAR
nextTag: Tag; (* 0..tags-1, 0..tags-1, ... *)
TYPE
Domain* = POINTER TO DomainRec;
Condition* = POINTER TO ConditionRec;
ConditionRec* =
RECORD
(Disciplines.ObjectRec)
domain: Domain;
tag: Tag;
waitingForEvent: BOOLEAN;
gotEvent: BOOLEAN;
END;
(* disjunctive list of conditions *)
ConditionList = POINTER TO ConditionListRec;
ConditionListRec =
RECORD
cond: Condition;
next: ConditionList;
END;
BucketTable = ARRAY tags OF ConditionList;
ConditionSet* = POINTER TO ConditionSetRec;
ConditionSetRec* =
RECORD
(Objects.ObjectRec)
cardinality: INTEGER;
bucket: BucketTable;
(* for the iterator *)
next: ConditionList; i: INTEGER;
END;
CONST
select* = 0; timelimit* = 1; async* = 2; timecond* = 3; preconditions* = 4;
TYPE
CapabilitySet* = SET; (* OF [select..preconditions] *)
TYPE
SelectProc* = PROCEDURE (domain: Domain; conditionSet: ConditionSet;
time: Times.Time;
VAR setOfTrueConditions: ConditionSet;
errors: RelatedEvents.Object;
retry: BOOLEAN;
VAR interrupted: BOOLEAN) : BOOLEAN;
(* needs only to be provided if select is in caps;
if timelimit isn't in caps then time is guaranteed to
be equal to NIL
*)
TestProc* = PROCEDURE (domain: Domain; condition: Condition;
errors: RelatedEvents.Object) : BOOLEAN;
SendEventProc* = PROCEDURE (domain: Domain; condition: Condition;
event: Events.Event;
errors: RelatedEvents.Object) : BOOLEAN;
(* sendevent needs only to be provided if async is in caps *)
GetTimeProc* = PROCEDURE (domain: Domain; conditionSet: ConditionSet;
VAR nextTime: Times.Time;
VAR nextCond: Condition;
errors: RelatedEvents.Object);
(* needs only to be provided if timecond is in caps *)
PreConditionsProc* = PROCEDURE (domain: Domain; condition: Condition;
VAR preconds: ConditionSet;
errors: RelatedEvents.Object) : BOOLEAN;
(* needs only to be provided if preconditions is in caps *)
Interface* = POINTER TO InterfaceRec;
InterfaceRec* =
RECORD
(Objects.ObjectRec)
test*: TestProc;
select*: SelectProc;
sendevent*: SendEventProc;
gettime*: GetTimeProc;
preconditions*: PreConditionsProc;
END;
Description* = POINTER TO DescriptionRec;
DescriptionRec* =
RECORD
(Objects.ObjectRec)
caps*: CapabilitySet;
internal*: BOOLEAN; (* value does not change during Process.Pause? *)
END;
TYPE
DomainRec* =
RECORD
(Disciplines.ObjectRec)
if: Interface;
desc: Description;
END;
TYPE
GetTimeOfNextTryProc* = PROCEDURE (iteration: INTEGER;
VAR time: Times.Time);
(* return a relative time measure *)
VAR
getTimeOfNextTry: GetTimeOfNextTryProc;
TYPE
WakeupEvent = POINTER TO WakeupEventRec;
WakeupEventRec =
RECORD
(Events.EventRec)
condition: Condition;
END;
VAR
nodelay: Times.Time;
wakeupEventType: Events.EventType; (* used for busy loops only *)
PROCEDURE WakeupHandler(event: Events.Event);
BEGIN
WITH event: WakeupEvent DO
event.condition.gotEvent := TRUE;
END;
END WakeupHandler;
PROCEDURE SetGetTimeOfNextTryProc*(p: GetTimeOfNextTryProc);
BEGIN
getTimeOfNextTry := p;
END SetGetTimeOfNextTryProc;
PROCEDURE GetTimeOfNextTry(iteration: INTEGER; VAR time: Times.Time);
BEGIN
Times.CreateAndSet(time, Times.relative, 0, 1, 0);
iteration := iteration DIV 5;
IF iteration > 8 THEN
iteration := 8;
END;
WHILE iteration > 0 DO
Op.Add2(SYSTEM.VAL(Op.Operand, time), time);
DEC(iteration);
END;
END GetTimeOfNextTry;
PROCEDURE CreateSet*(VAR conditionSet: ConditionSet);
VAR
i: INTEGER;
cset: ConditionSet;
BEGIN
NEW(cset);
cset.cardinality := 0;
(*
commented out for reasons of efficiency
as NEW delivers 0-initialized areas anyway
i := 0;
WHILE i < tags DO
conditionSet.bucket[i] := NIL;
INC(i);
END;
*)
cset.next := NIL; cset.i := 0;
conditionSet := cset;
END CreateSet;
PROCEDURE Incl*(conditionSet: ConditionSet; condition: Condition);
VAR
listp: ConditionList;
new: ConditionList;
i: INTEGER;
BEGIN
(* check if condition is already present in conditionSet *)
i := condition.tag;
listp := conditionSet.bucket[i];
WHILE (listp # NIL) & (listp.cond # condition) DO
listp := listp.next;
END;
IF listp # NIL THEN (* already in set *) RETURN END;
NEW(new); new.cond := condition;
new.next := conditionSet.bucket[i];
conditionSet.bucket[i] := new;
INC(conditionSet.cardinality);
END Incl;
PROCEDURE Excl*(conditionSet: ConditionSet; condition: Condition);
VAR
prev, listp: ConditionList;
i: INTEGER;
BEGIN
i := condition.tag;
listp := conditionSet.bucket[i]; prev := NIL;
WHILE (listp # NIL) & (listp.cond # condition) DO
prev := listp; listp := listp.next;
END;
IF listp = NIL THEN (* condition not in set *) RETURN END;
IF prev = NIL THEN
conditionSet.bucket[i] := listp.next;
ELSE
prev.next := listp.next;
END;
DEC(conditionSet.cardinality);
(* make the iterator more robust *)
IF conditionSet.next = listp THEN
conditionSet.next := listp.next;
END;
END Excl;
PROCEDURE In*(conditionSet: ConditionSet; condition: Condition) : BOOLEAN;
VAR
listp: ConditionList;
BEGIN
listp := conditionSet.bucket[condition.tag];
WHILE (listp # NIL) & (listp.cond # condition) DO
listp := listp.next;
END;
RETURN listp # NIL
END In;
PROCEDURE Union*(result: ConditionSet; set: ConditionSet);
VAR
listp: ConditionList;
newelem, newelems: ConditionList;
count: INTEGER; (* # of added elements in newelems *)
i: INTEGER;
BEGIN
count := 0;
i := 0;
WHILE i < tags DO
listp := set.bucket[i];
newelems := result.bucket[i];
IF newelems = NIL THEN
WHILE listp # NIL DO
NEW(newelem); newelem.cond := listp.cond;
newelem.next := newelems;
newelems := newelem;
INC(count);
listp := listp.next;
END;
ELSE
WHILE listp # NIL DO
IF ~In(result, listp.cond) THEN
NEW(newelem); newelem.cond := listp.cond;
newelem.next := newelems;
newelems := newelem;
INC(count);
END;
listp := listp.next;
END;
END;
result.bucket[i] := newelems;
INC(i);
END;
INC(result.cardinality, count);
END Union;
PROCEDURE Union3*(VAR result: ConditionSet; set1, set2: ConditionSet);
BEGIN
CreateSet(result); Union(result, set1); Union(result, set2);
END Union3;
PROCEDURE Card*(conditionSet: ConditionSet) : INTEGER;
BEGIN
RETURN conditionSet.cardinality
END Card;
PROCEDURE ExamineConditions*(conditionSet: ConditionSet);
BEGIN
conditionSet.next := NIL;
conditionSet.i := 0;
END ExamineConditions;
PROCEDURE GetNextCondition*(conditionSet: ConditionSet;
VAR condition: Condition) : BOOLEAN;
VAR
i: INTEGER;
BEGIN
IF conditionSet.next = NIL THEN
i := conditionSet.i;
WHILE (i < tags) & (conditionSet.bucket[i] = NIL) DO
INC(i);
END;
conditionSet.i := i + 1;
IF i >= tags THEN
RETURN FALSE
END;
conditionSet.next := conditionSet.bucket[i];
END;
condition := conditionSet.next.cond;
conditionSet.next := conditionSet.next.next;
RETURN TRUE
END GetNextCondition;
PROCEDURE InitDomain*(domain: Domain; if: Interface; desc: Description);
BEGIN
domain.if := if;
domain.desc := desc;
END InitDomain;
PROCEDURE Init*(condition: Condition; domain: Domain);
BEGIN
condition.domain := domain;
condition.tag := nextTag;
nextTag := (nextTag + 1) MOD tags;
condition.waitingForEvent := FALSE;
condition.gotEvent := FALSE;
END Init;
PROCEDURE Test*(condition: Condition; errors: RelatedEvents.Object) : BOOLEAN;
BEGIN
IF condition.waitingForEvent & ~condition.gotEvent THEN
RETURN FALSE
ELSE
RETURN condition.domain.if.test(condition.domain, condition, errors)
END;
END Test;
PROCEDURE CommonDomain(cset: ConditionSet;
VAR domain: Domain) : BOOLEAN;
VAR
dom: Domain;
i: INTEGER;
listp: ConditionList;
BEGIN
dom := NIL;
i := 0;
WHILE i < tags DO
listp := cset.bucket[i];
WHILE listp # NIL DO
IF dom = NIL THEN
dom := listp.cond.domain;
ELSIF dom # listp.cond.domain THEN
RETURN FALSE
END;
listp := listp.next;
END;
INC(i);
END;
domain := dom;
RETURN dom # NIL
END CommonDomain;
PROCEDURE SimpleWaitForAndSelect(
conditionSet: ConditionSet;
VAR setOfTrueConditions: ConditionSet;
errors: RelatedEvents.Object);
(* simple means that we don't need to take care of preconditions *)
TYPE
List = POINTER TO ListRec;
Element = POINTER TO ElementRec;
ListRec =
RECORD
head: Element;
END;
Ring = POINTER TO RingRec;
RingRec =
RECORD
(ListRec)
tail: Element;
END;
ElementRec =
RECORD
next: Element;
domain: Domain;
cset: ConditionSet;
END;
VAR
domain: Domain;
interrupted: BOOLEAN;
ok: BOOLEAN;
PROCEDURE SortConditions(VAR asyncList, timeList, others: List;
VAR ring: Ring;
VAR otherAreInternal: BOOLEAN);
(* sort conditions into several lists:
ayncList: list of conditions for which we can setup an event;
after this setup we needn't to take care of them
timeList: list of time conditions (based on system clock)
ring: conditions which support select & timelimit
otherAreInternal:
is set to TRUE if all other conditions which
are not put into one of the lists above remain
unaffected while pausing
*)
VAR
listp: ConditionList;
i: INTEGER;
PROCEDURE CreateList(VAR list: List);
BEGIN
NEW(list); list.head := NIL;
END CreateList;
PROCEDURE CreateRing(VAR ring: Ring);
BEGIN
NEW(ring); ring.head := NIL; ring.tail := NIL;
END CreateRing;
PROCEDURE Add(condition: Condition);
VAR
domain: Domain;
PROCEDURE AddTo(list: List);
VAR
elp: Element;
BEGIN
elp := list.head;
WHILE (elp # NIL) & (elp.domain # domain) DO
elp := elp.next;
END;
IF elp = NIL THEN
NEW(elp);
elp.next := list.head;
elp.domain := condition.domain;
CreateSet(elp.cset);
list.head := elp;
IF list IS Ring THEN
WITH list: Ring DO
IF list.tail = NIL THEN
list.tail := elp;
END;
list.tail.next := list.head;
END;
END;
END;
Incl(elp.cset, condition);
END AddTo;
BEGIN (* Add *)
domain := condition.domain;
IF timecond IN domain.desc.caps THEN
IF timeList = NIL THEN
CreateList(timeList);
END;
AddTo(timeList);
ELSIF async IN domain.desc.caps THEN
IF asyncList = NIL THEN
CreateList(asyncList);
END;
AddTo(asyncList);
ELSIF (select IN domain.desc.caps) &
(timelimit IN domain.desc.caps) THEN
IF ring = NIL THEN
CreateRing(ring);
END;
AddTo(ring);
ELSE
IF others = NIL THEN
CreateList(others);
END;
AddTo(others);
IF ~domain.desc.internal THEN
otherAreInternal := FALSE;
END;
END;
END Add;
BEGIN (* SortConditions *)
asyncList := NIL; timeList := NIL; ring := NIL;
otherAreInternal := TRUE;
i := 0;
WHILE i < tags DO
listp := conditionSet.bucket[i];
WHILE listp # NIL DO
Add(listp.cond);
listp := listp.next;
END;
INC(i);
END;
END SortConditions;
PROCEDURE SetupEventHandling(condition: Condition;
VAR wakeupEvent: WakeupEvent);
VAR
wakeup: Events.EventType;
priority: Priorities.Priority;
BEGIN
Events.Define(wakeup);
priority := Events.GetPriority() + 1;
IF priority < Priorities.interrupts + 1 THEN
priority := Priorities.interrupts + 1;
END;
Events.SetPriority(wakeup, priority);
Events.Handler(wakeup, WakeupHandler);
NEW(wakeupEvent); wakeupEvent.type := wakeup;
wakeupEvent.condition := condition;
condition.waitingForEvent := TRUE;
condition.gotEvent := FALSE;
END SetupEventHandling;
PROCEDURE SetupAsyncEvents(list: List) : BOOLEAN;
VAR
elp: Element;
listp: ConditionList; i: INTEGER;
wakeupEvent: WakeupEvent;
sendevent: SendEventProc;
anythingTrue: BOOLEAN;
BEGIN
anythingTrue := FALSE;
elp := list.head;
WHILE elp # NIL DO
sendevent := elp.domain.if.sendevent;
i := 0;
WHILE i < tags DO
listp := elp.cset.bucket[i];
WHILE listp # NIL DO
IF ~listp.cond.waitingForEvent OR listp.cond.gotEvent THEN
SetupEventHandling(listp.cond, wakeupEvent);
IF ~sendevent(elp.domain, listp.cond,
wakeupEvent, errors) THEN
IF ~anythingTrue THEN
CreateSet(setOfTrueConditions);
END;
Incl(setOfTrueConditions, listp.cond);
listp.cond.waitingForEvent := FALSE;
anythingTrue := TRUE;
END;
END;
listp := listp.next;
END;
INC(i);
END;
elp := elp.next;
END;
RETURN ~anythingTrue
END SetupAsyncEvents;
PROCEDURE Block;
(* block until one of the conditions becomes TRUE *)
VAR
asyncList: List; (* list of domains which supports async events *)
timeList: List; (* list of domains which supports timecond *)
ring: Ring; (* ring of domains which support select+timelimit *)
largeRing: BOOLEAN; (* >=2 ring members *)
ringMember: Element; (* current ring member *)
others: List; (* those which are not member of the other lists *)
otherAreInternal: BOOLEAN;
waitErrors: RelatedEvents.Object;
queue: RelatedEvents.Queue; (* queue of waitErrors *)
busyLoop: BOOLEAN; (* TRUE if we have to resort to a busy loop *)
wakeupEvent: Events.Event; (* iteration event for busy loops *)
loopCnt: INTEGER; (* number of iterations *)
nextTime: Times.Time;
minTime: Times.Time;
minTimeCond: Condition;
interrupted: BOOLEAN; (* interrupted select? *)
highPriority: BOOLEAN; (* priority >= Priorities.interrupt? *)
PROCEDURE FixToRelTime(VAR time: Times.Time);
VAR
currentTime: Times.Time;
relTime: Times.Time;
BEGIN
Clocks.GetTime(Clocks.system, currentTime);
Op.Sub3(SYSTEM.VAL(Op.Operand, relTime), time, currentTime);
time := relTime;
END FixToRelTime;
PROCEDURE GetMinTime(VAR nextTime: Times.Time;
VAR minCond: Condition);
VAR
elp: Element;
time: Times.Time;
condition: Condition;
BEGIN (* GetMinTime *)
nextTime := NIL; minCond := NIL;
IF timeList # NIL THEN
elp := timeList.head;
WHILE elp # NIL DO
elp.domain.if.gettime(domain, elp.cset,
time, condition, waitErrors);
IF Scales.IsAbsolute(time) THEN
FixToRelTime(time);
END;
IF (nextTime = NIL) OR (Op.Compare(time, nextTime) < 0) THEN
nextTime := time; minCond := condition;
END;
elp := elp.next;
END;
END;
END GetMinTime;
PROCEDURE UpdateMinTime(VAR nextTime: Times.Time;
VAR minCond: Condition);
VAR
set: ConditionSet;
time: Times.Time;
cond: Condition;
BEGIN
IF minCond = NIL THEN
nextTime := NIL;
ELSE
CreateSet(set);
Incl(set, minCond);
minCond.domain.if.gettime(minCond.domain, set,
time, cond, waitErrors);
IF Scales.IsAbsolute(time) THEN
FixToRelTime(time);
END;
nextTime := time;
END;
END UpdateMinTime;
PROCEDURE TestNonRingMembers() : BOOLEAN;
PROCEDURE TestList(list: List) : BOOLEAN;
VAR
domain: Domain;
element: Element;
selected: ConditionSet;
interrupted: BOOLEAN;
PROCEDURE TestAndSelect(conditionSet: ConditionSet;
VAR setOfTrueConditions: ConditionSet;
errors: RelatedEvents.Object) : BOOLEAN;
VAR
listp: ConditionList; i: INTEGER;
condition: Condition;
anythingTrue: BOOLEAN;
BEGIN (* TestAndSelect *)
anythingTrue := FALSE;
CreateSet(setOfTrueConditions);
i := 0;
WHILE i < tags DO
listp := conditionSet.bucket[i];
WHILE listp # NIL DO
condition := listp.cond;
IF domain.if.test(domain, condition, errors) THEN
Incl(setOfTrueConditions, condition);
anythingTrue := TRUE;
END;
listp := listp.next;
END;
INC(i);
END;
RETURN anythingTrue
END TestAndSelect;
BEGIN (* TestList *)
IF list = NIL THEN RETURN FALSE END;
element := list.head;
WHILE element # NIL DO
domain := element.domain;
IF (select IN domain.desc.caps) &
(timelimit IN domain.desc.caps) THEN
IF domain.if.select(domain, element.cset, nodelay,
selected, waitErrors, FALSE, interrupted) THEN
ASSERT(Card(selected) > 0);
Union(setOfTrueConditions, selected);
RETURN TRUE
END;
ELSE
IF TestAndSelect(element.cset, selected, waitErrors) THEN
Union(setOfTrueConditions, selected);
RETURN TRUE
END;
END;
element := element.next;
END;
RETURN FALSE
END TestList;
PROCEDURE TestAsyncList(list: List) : BOOLEAN;
VAR
element: Element;
listp: ConditionList; i: INTEGER;
condition: Condition;
anythingFound: BOOLEAN;
BEGIN
IF list = NIL THEN RETURN FALSE END;
anythingFound := FALSE;
element := list.head;
WHILE element # NIL DO
i := 0;
WHILE i < tags DO
listp := element.cset.bucket[i];
WHILE listp # NIL DO
condition := listp.cond;
IF condition.gotEvent THEN
Incl(setOfTrueConditions, condition);
anythingFound := TRUE;
END;
listp := listp.next;
END;
INC(i);
END;
element := element.next;
END;
RETURN anythingFound
END TestAsyncList;
BEGIN (* TestNonRingMembers *)
CreateSet(setOfTrueConditions);
RETURN TestAsyncList(asyncList) OR TestList(others)
END TestNonRingMembers;
BEGIN (* Block *)
NEW(waitErrors); RelatedEvents.QueueEvents(waitErrors);
SortConditions(asyncList, timeList, others, ring, otherAreInternal);
IF asyncList # NIL THEN
(* set up asynchronous events for these conditions --
this should be done before the first call of
TestNonRingMembers() to avoid redundant test calls
*)
IF ~SetupAsyncEvents(asyncList) THEN
(* one of them happened to be TRUE now *)
RETURN
END;
END;
IF TestNonRingMembers() THEN
RETURN
END;
(* check for deadlock *)
ASSERT((asyncList # NIL) OR (timeList # NIL) OR (ring # NIL) OR
~otherAreInternal);
highPriority := Events.GetPriority() >= Priorities.interrupts;
IF ring # NIL THEN
ringMember := ring.head;
largeRing := ring.head # ring.head.next;
ELSE
ringMember := NIL; largeRing := FALSE;
END;
GetMinTime(minTime, minTimeCond);
busyLoop := largeRing OR ~otherAreInternal OR (asyncList # NIL);
loopCnt := 0;
LOOP (* until one of the conditions becomes TRUE *)
(* determine timelimit parameter for select *)
IF busyLoop THEN
getTimeOfNextTry(loopCnt + 1, nextTime);
ASSERT(Op.Compare(nextTime, nodelay) > 0);
IF timeList # NIL THEN
IF Op.Compare(minTime, nextTime) < 0 THEN
nextTime := minTime;
END;
END;
ELSIF timeList # NIL THEN
nextTime := minTime;
ELSE
nextTime := NIL; minTime := NIL; minTimeCond := NIL;
END;
IF (minTime # NIL) & (Op.Compare(minTime, nodelay) <= 0) THEN
CreateSet(setOfTrueConditions);
Incl(setOfTrueConditions, minTimeCond);
EXIT
END;
IF ringMember = NIL THEN
ASSERT(~highPriority);
IF nextTime # NIL THEN
NEW(wakeupEvent);
wakeupEvent.type := wakeupEventType;
Events.SetPriority(wakeupEventType, Events.GetPriority() + 1);
Timers.Schedule(Clocks.system, nextTime, wakeupEvent);
END;
Process.Pause;
ELSE
IF ringMember.domain.if.select
(ringMember.domain, ringMember.cset, nextTime,
setOfTrueConditions, waitErrors,
(* retry = *) FALSE, interrupted) THEN
ASSERT(Card(setOfTrueConditions) > 0);
EXIT
END;
(* timelimit exceeded or interrupted *)
ASSERT(interrupted OR (nextTime # NIL));
IF interrupted THEN
(* remove error event *)
RelatedEvents.GetQueue(waitErrors, queue);
ELSIF (minTimeCond # NIL) & ~busyLoop THEN
(* timelimit exceeded: minTimeCond is now TRUE *)
CreateSet(setOfTrueConditions);
Incl(setOfTrueConditions, minTimeCond);
EXIT
END;
END;
IF TestNonRingMembers() THEN
EXIT
END;
IF timeList # NIL THEN
UpdateMinTime(minTime, minTimeCond);
END;
INC(loopCnt);
END;
(* forward error events to error parameter of SimpleWaitForAndSelect *)
RelatedEvents.GetQueue(waitErrors, queue);
RelatedEvents.AppendQueue(errors, queue);
END Block;
BEGIN (* SimpleWaitForAndSelect *)
IF CommonDomain(conditionSet, domain) &
(select IN domain.desc.caps) THEN
ok := domain.if.select
(domain, conditionSet, NIL, setOfTrueConditions,
errors, (* retry = *) TRUE, interrupted);
(* a return value of FALSE is only to be expected
if a time limit is given or if retry = FALSE
*)
ASSERT(ok);
ELSE
Block;
END;
END SimpleWaitForAndSelect;
PROCEDURE WaitFor*(conditionSet: ConditionSet;
VAR setOfTrueConditions: ConditionSet;
errors: RelatedEvents.Object);
VAR
listp: ConditionList; i: INTEGER;
testSet: ConditionSet;
preconds: ConditionSet;
domain: Domain;
selected: ConditionSet;
anyPreconditions: BOOLEAN;
PROCEDURE PretestClosure(testSet, preconds: ConditionSet);
VAR
listp: ConditionList; i: INTEGER;
domain: Domain;
morePreconditions: ConditionSet;
evenMorePreconditions: ConditionSet;
BEGIN
REPEAT
CreateSet(morePreconditions);
i := 0;
WHILE i < tags DO
listp := preconds.bucket[i];
WHILE listp # NIL DO
domain := listp.cond.domain;
IF (preconditions IN domain.desc.caps) &
domain.if.preconditions(domain, listp.cond,
evenMorePreconditions, errors) &
(evenMorePreconditions # NIL) &
(Card(evenMorePreconditions) > 0) THEN
Union(morePreconditions, evenMorePreconditions);
ELSE
Incl(testSet, listp.cond);
END;
listp := listp.next;
END;
INC(i);
END;
preconds := morePreconditions;
UNTIL Card(preconds) = 0
END PretestClosure;
BEGIN (* WaitFor *)
ASSERT(conditionSet.cardinality > 0);
LOOP
CreateSet(testSet);
anyPreconditions := FALSE;
i := 0;
WHILE i < tags DO
listp := conditionSet.bucket[i];
WHILE listp # NIL DO
domain := listp.cond.domain;
IF (preconditions IN domain.desc.caps) &
domain.if.preconditions(domain,
listp.cond, preconds, errors) &
(preconds # NIL) & (Card(preconds) > 0) THEN
PretestClosure(testSet, preconds);
anyPreconditions := TRUE;
ELSE
Incl(testSet, listp.cond);
END;
listp := listp.next;
END;
INC(i);
END;
SimpleWaitForAndSelect(testSet, selected, errors);
IF ~anyPreconditions THEN
setOfTrueConditions := selected;
EXIT
END;
i := 0;
WHILE i < tags DO
listp := selected.bucket[i];
WHILE listp # NIL DO
IF ~In(conditionSet, listp.cond) THEN
Excl(selected, listp.cond);
END;
listp := listp.next;
END;
INC(i);
END;
IF Card(selected) > 0 THEN
setOfTrueConditions := selected;
EXIT
END;
END;
ASSERT(Card(setOfTrueConditions) > 0);
END WaitFor;
BEGIN
SetGetTimeOfNextTryProc(GetTimeOfNextTry);
Times.CreateAndSet(nodelay, Times.relative, 0, 0, 0);
nextTag := 0;
Events.Define(wakeupEventType);
Events.Handler(wakeupEventType, Events.NilHandler);
END ulmConditions.

575
src/library/ulm/ulmConstStrings.Mod Normal file
View file

@ -0,0 +1,575 @@
(* Ulm's Oberon Library
Copyright (C) 1989-2004 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: ConstString.om,v 1.5 2004/05/21 14:22:04 borchert Exp $
----------------------------------------------------------------------------
$Log: ConstString.om,v $
Revision 1.5 2004/05/21 14:22:04 borchert
various performance improvements:
- support of ReadBuf interface procedure of Streams
- CreateD is no longer based on CloseD
- Write takes advantage of Streams.WritePart
(partially based on code and suggestions by Christian Ehrhardt)
Revision 1.4 1997/04/02 07:34:53 borchert
ConstStrings are now an extension of Disciplines.Object
Revision 1.3 1996/01/04 17:03:26 borchert
- const strings are now an extension of Disciplines.Object
- domains added
Revision 1.2 1994/07/18 14:15:42 borchert
unused variables of Close (buf & offset) removed
Revision 1.1 1994/02/22 20:06:38 borchert
Initial revision
----------------------------------------------------------------------------
AFB 10/90
----------------------------------------------------------------------------
*)
MODULE ulmConstStrings;
(* WORM-device for strings *)
IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Objects := ulmObjects, Process := ulmProcess, Services := ulmServices, Streams := ulmStreams, Strings := ulmStrings,
Texts := ulmTexts, Types := ulmTypes;
CONST
tabsize = 1031; (* should be a prime number *)
bufsize = 512;
TYPE
Domain* = POINTER TO DomainRec;
TYPE
Byte = Types.Byte;
Buffer = POINTER TO BufferRec;
BufferRec =
RECORD
buf: ARRAY bufsize OF CHAR;
free: INTEGER; (* buf[free..bufsize-1] is unused *)
next: Buffer;
END;
String* = POINTER TO StringRec;
StringRec* =
RECORD
(Disciplines.ObjectRec)
(* read-only *)
len-: Streams.Count; (* length of string in bytes *)
hashval-: LONGINT; (* hash value *)
(* private part *)
domain: Domain;
length: Streams.Count; (* private copy of length *)
buf: Buffer; (* first buffer containing the string *)
offset: INTEGER; (* offset into buf *)
next: String; (* list of strings with same hash value *)
END;
TYPE
DomainRec* =
RECORD
(Disciplines.ObjectRec)
bucket: ARRAY tabsize OF String;
head, tail: Buffer;
END;
VAR
std*: Domain; (* default domain *)
TYPE
StreamList = POINTER TO StreamListRec;
StreamListRec =
RECORD
stream: Streams.Stream;
next: StreamList;
END;
ReadStream = POINTER TO ReadStreamRec;
ReadStreamRec =
RECORD
(Streams.StreamRec)
string: String;
buf: Buffer; (* current buffer *)
offset: INTEGER; (* index in current buffer *)
pos: Streams.Count; (* current position *)
END;
VAR
freelist: StreamList; (* list of unused streams *)
if: Streams.Interface;
caps: Streams.CapabilitySet;
type: Services.Type; (* ReadStream *)
(* === internal procedures =========================================== *)
PROCEDURE HashVal(s: Streams.Stream; len: Streams.Count;
VAR hashval, orighashval: LONGINT);
(* compute the hash value of the first `len' bytes of `s';
the hash value is returned in two variants:
hashval: hash value MOD tabsize
orighashval: unmodified hash value
*)
CONST
shift = 4;
VAR
ordval: INTEGER;
ch: CHAR;
index: Streams.Count;
BEGIN
Streams.SetPos(s, 0);
hashval := len;
index := 0;
WHILE (index < len) & Streams.ReadByte(s, ch) DO
IF ch >= " " THEN
ordval := ORD(ch) - ORD(" ");
ELSE
ordval := ORD(MAX(CHAR)) - ORD(" ") + ORD(ch);
END;
hashval := ASH(hashval, shift) + ordval;
INC(index);
END;
(* assert: index = len *)
orighashval := hashval;
hashval := hashval MOD tabsize;
END HashVal;
PROCEDURE Equal(s: Streams.Stream; len: Streams.Count;
string: String) : BOOLEAN;
(* consider `s' to be a stream providing `len' bytes;
return TRUE iff the byte sequence of `s' equals that of `string'
*)
VAR
ch: CHAR;
buf: Buffer; offset: INTEGER;
index: Streams.Count;
BEGIN
Streams.SetPos(s, 0);
IF len # string.length THEN
RETURN FALSE
END;
index := 0;
buf := string.buf; offset := string.offset;
WHILE (index < len) & Streams.ReadByte(s, ch) DO
IF ch # buf.buf[offset] THEN
RETURN FALSE
END;
INC(offset);
IF offset >= bufsize THEN
buf := buf.next; offset := 0;
END;
INC(index);
END;
(* assert: index = len *)
RETURN TRUE
END Equal;
PROCEDURE Allocate(domain: Domain; len: Streams.Count;
VAR buf: Buffer; VAR offset: INTEGER);
(* allocate space for `len' bytes;
`buf' and `offset' are returned, designating the
begin of the allocated area; note that
if the space within `buf' is not sufficient its
subsequent buffers are to be used
*)
PROCEDURE NewBuffer;
VAR
buf: Buffer;
BEGIN
NEW(buf);
buf.free := 0;
buf.next := NIL;
IF domain.head = NIL THEN
domain.head := buf;
ELSE
domain.tail.next := buf;
END;
domain.tail := buf;
END NewBuffer;
BEGIN (* Allocate *)
IF (domain.head = NIL) OR (domain.tail.free = bufsize) THEN
NewBuffer;
END;
buf := domain.tail;
offset := buf.free;
WHILE len > 0 DO
IF len <= bufsize - domain.tail.free THEN
INC(domain.tail.free, SHORT(len)); len := 0;
ELSE
DEC(len, bufsize - LONG(domain.tail.free));
domain.tail.free := bufsize;
NewBuffer;
END;
END;
END Allocate;
PROCEDURE CopyString(s: Streams.Stream; length: Streams.Count;
buf: Buffer; offset: INTEGER);
(* copy `length' bytes from `s' to `buf' at the given offset
and its subsequent buffers
*)
VAR
ok: BOOLEAN;
bytes: Streams.Count;
BEGIN
Streams.SetPos(s, 0);
WHILE length > 0 DO
bytes := bufsize - offset;
IF bytes > length THEN
bytes := length;
END;
IF bytes > bufsize - offset THEN
bytes := bufsize - offset;
END;
ok := Streams.ReadPart(s, buf.buf, offset, bytes); ASSERT(ok);
offset := 0;
buf := buf.next;
DEC(length, bytes);
END;
END CopyString;
PROCEDURE InternalCreateD(s: Streams.Stream;
length: Streams.Count;
domain: Domain;
VAR string: String);
(* common part of CloseD and CreateD *)
VAR
orighashval, hashval: LONGINT;
str: String;
BEGIN
HashVal(s, length, hashval, orighashval);
IF domain.bucket[hashval] # NIL THEN
str := domain.bucket[hashval];
WHILE str # NIL DO
IF Equal(s, length, str) THEN
string := str;
RETURN
END;
str := str.next;
END;
END;
NEW(str);
str.domain := domain;
str.len := length; str.length := length;
str.hashval := orighashval;
(* enter new string into the table *)
Allocate(domain, length, str.buf, str.offset);
CopyString(s, length, str.buf, str.offset);
str.next := domain.bucket[hashval];
domain.bucket[hashval] := str;
string := str;
END InternalCreateD;
(* === exported procedures =========================================== *)
PROCEDURE CreateDomain*(VAR domain: Domain);
BEGIN
NEW(domain); domain.head := NIL; domain.tail := NIL;
END CreateDomain;
PROCEDURE Init*(VAR s: Streams.Stream);
(* open s for writing *)
BEGIN
IF freelist # NIL THEN
s := freelist.stream;
freelist := freelist.next;
Streams.SetPos(s, 0);
ELSE
Texts.Open(s);
END;
END Init;
PROCEDURE CloseD*(s: Streams.Stream; domain: Domain; VAR string: String);
(* must be called instead of Streams.Close to get
the resulting string
*)
VAR
length: Streams.Count;
PROCEDURE FreeText;
VAR
free: StreamList;
BEGIN
NEW(free); free.stream := s;
free.next := freelist; freelist := free;
END FreeText;
BEGIN (* CloseD *)
Streams.GetPos(s, length);
InternalCreateD(s, length, domain, string);
FreeText;
END CloseD;
PROCEDURE Close*(s: Streams.Stream; VAR string: String);
BEGIN
CloseD(s, std, string);
END Close;
PROCEDURE CreateD*(VAR string: String; domain: Domain; s: ARRAY OF CHAR);
VAR
length: Streams.Count;
stream: Streams.Stream;
BEGIN
length := 0;
WHILE (length < LEN(s)) & (s[length] # 0X) DO
INC(length);
END;
Strings.Open(stream, s);
InternalCreateD(stream, length, domain, string);
END CreateD;
PROCEDURE Create*(VAR string: String; s: ARRAY OF CHAR);
BEGIN
CreateD(string, std, s);
END Create;
PROCEDURE Open*(VAR s: Streams.Stream; string: String);
(* open s for reading *)
VAR
rs: ReadStream;
BEGIN
NEW(rs);
Services.Init(rs, type);
Streams.Init(rs, if, caps, Streams.nobuf);
rs.string := string;
rs.buf := string.buf;
rs.offset := string.offset;
rs.pos := 0;
s := rs;
END Open;
PROCEDURE Compare*(string1, string2: String) : INTEGER;
(* returns < 0: if string1 < string2
= 0: if string1 = string2 (see note above)
> 0: if string1 > string2
*)
VAR
ch1, ch2: CHAR;
buf1, buf2: Buffer;
offset1, offset2: INTEGER;
len1, len2: Streams.Count;
PROCEDURE Next(VAR buf: Buffer; VAR offset: INTEGER; VAR ch: CHAR);
BEGIN
ch := buf.buf[offset];
INC(offset);
IF offset >= bufsize THEN
buf := buf.next;
offset := 0;
END;
END Next;
BEGIN (* Compare *)
IF string1 = string2 THEN
RETURN 0
END;
len1 := string1.length; len2 := string2.length;
buf1 := string1.buf; buf2 := string2.buf;
offset1 := string1.offset; offset2 := string2.offset;
WHILE (len1 > 0) & (len2 > 0) DO
Next(buf1, offset1, ch1);
Next(buf2, offset2, ch2);
IF ch1 # ch2 THEN
RETURN ORD(ch1) - ORD(ch2)
END;
DEC(len1); DEC(len2);
END;
(* RETURN len1 - len2 does not work because of the return type *)
IF len1 < len2 THEN
RETURN -1
ELSIF len1 > len2 THEN
RETURN 1
ELSE
RETURN 0
END;
END Compare;
PROCEDURE Write*(s: Streams.Stream; string: String);
(* copy contents of `string' to `s' *)
VAR
len: Streams.Count;
buf: Buffer;
offset: INTEGER;
count: Streams.Count;
bytes: Streams.Count;
BEGIN
len := string.length;
buf := string.buf;
offset := string.offset;
count := 0;
LOOP
IF len = 0 THEN EXIT END;
bytes := len;
IF bytes > bufsize - offset THEN
bytes := bufsize - offset;
END;
IF ~Streams.WritePart(s, buf.buf, offset, bytes) THEN
INC(count, s.count);
EXIT
END;
INC(count, bytes); DEC(len, bytes); INC(offset, SHORT(bytes));
IF offset >= bufsize THEN
buf := buf.next;
offset := 0;
END;
END;
s.count := count;
END Write;
PROCEDURE Extract*(VAR s: ARRAY OF CHAR; string: String);
(* copy contents of `string' to `s' *)
VAR
len: Streams.Count;
buf: Buffer;
offset: INTEGER;
index: Streams.Count;
BEGIN
len := string.length;
buf := string.buf;
offset := string.offset;
index := 0;
WHILE (index+1 < LEN(s)) & (len > 0) DO
s[index] := buf.buf[offset];
INC(index);
DEC(len);
INC(offset);
IF offset >= bufsize THEN
buf := buf.next;
offset := 0;
END;
END;
s[index] := 0X;
END Extract;
(* ========= interface procedures for ReadStream ===================== *)
PROCEDURE ReadByte(s: Streams.Stream; VAR byte: Byte) : BOOLEAN;
BEGIN
WITH s: ReadStream DO
IF s.pos >= s.string.length THEN
RETURN FALSE
END;
byte := s.buf.buf[s.offset];
INC(s.offset);
IF s.offset >= bufsize THEN
s.offset := 0;
s.buf := s.buf.next;
END;
INC(s.pos);
RETURN TRUE
END;
END ReadByte;
PROCEDURE ReadBuf(s: Streams.Stream; VAR buf: ARRAY OF Types.Byte(*BYTE*);
off, cnt: Streams.Count) : Streams.Count;
VAR
bytes, max: Streams.Count;
BEGIN
WITH s: ReadStream DO
IF s.pos >= s.string.length THEN
RETURN 0
END;
bytes := s.string.length - s.pos;
IF bytes > cnt THEN
bytes := cnt;
END;
IF bytes > bufsize - s.offset THEN
bytes := bufsize - s.offset;
END;
max := off + bytes;
WHILE off < max DO
buf[off] := s.buf.buf[s.offset];
INC(off); INC(s.offset);
END;
IF s.offset >= bufsize THEN
s.offset := 0;
s.buf := s.buf.next;
END;
INC(s.pos, bytes);
RETURN bytes
END;
END ReadBuf;
PROCEDURE Seek(s: Streams.Stream;
cnt: Streams.Count; whence: Streams.Whence) : BOOLEAN;
VAR
realpos: Streams.Count;
BEGIN
WITH s: ReadStream DO
CASE whence OF
| Streams.fromStart: realpos := cnt;
| Streams.fromPos: realpos := s.pos + cnt;
| Streams.fromEnd: realpos := s.string.length + cnt;
END;
IF (realpos < 0) OR (realpos > s.string.length) THEN
RETURN FALSE
END;
IF realpos # s.pos THEN
IF realpos < s.pos THEN
s.pos := 0; s.offset := s.string.offset; s.buf := s.string.buf;
END;
WHILE s.pos < realpos DO
IF realpos - s.pos < bufsize - s.offset THEN
INC(s.offset, SHORT(realpos - s.pos));
s.pos := realpos;
ELSE
INC(s.pos, LONG(bufsize - s.offset));
s.offset := 0;
s.buf := s.buf.next;
END;
END;
END;
RETURN TRUE
END;
END Seek;
PROCEDURE Tell(s: Streams.Stream; VAR cnt: Streams.Count) : BOOLEAN;
BEGIN
WITH s: ReadStream DO
cnt := s.pos;
RETURN TRUE
END;
END Tell;
(* =================================================================== *)
PROCEDURE FreeHandler(event: Events.Event);
(* set free list to NIL to return the associated storage
to the garbage collector
*)
BEGIN
freelist := NIL;
END FreeHandler;
BEGIN
freelist := NIL;
CreateDomain(std);
caps := {Streams.read, Streams.seek, Streams.tell, Streams.bufio};
NEW(if);
if.read := ReadByte;
if.bufread := ReadBuf;
if.seek := Seek;
if.tell := Tell;
Events.Handler(Process.startOfGarbageCollection, FreeHandler);
Services.CreateType(type, "ConstStrings.ReadStream", "Streams.Stream");
END ulmConstStrings.

140
src/library/ulm/ulmDisciplines.Mod Normal file
View file

@ -0,0 +1,140 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Disciplines.om,v 1.1 1994/02/22 20:07:03 borchert Exp $
----------------------------------------------------------------------------
$Log: Disciplines.om,v $
Revision 1.1 1994/02/22 20:07:03 borchert
Initial revision
----------------------------------------------------------------------------
AFB 5/91
----------------------------------------------------------------------------
*)
MODULE ulmDisciplines;
(* Disciplines allows to attach additional data structures to
abstract datatypes like Streams;
these added data structures permit to parametrize operations
which are provided by other modules (e.g. Read or Write for Streams)
*)
IMPORT Objects := ulmObjects;
TYPE
Identifier* = LONGINT;
Discipline* = POINTER TO DisciplineRec;
DisciplineRec* =
RECORD
(Objects.ObjectRec)
id*: Identifier; (* should be unique for all types of disciplines *)
END;
DisciplineList = POINTER TO DisciplineListRec;
DisciplineListRec =
RECORD
discipline: Discipline;
id: Identifier; (* copied from discipline.id *)
next: DisciplineList;
END;
Object* = POINTER TO ObjectRec;
ObjectRec* =
RECORD
(Objects.ObjectRec)
(* private part *)
list: DisciplineList; (* set of disciplines *)
END;
VAR
unique: Identifier;
PROCEDURE Unique*() : Identifier;
(* returns a unique identifier;
this procedure should be called during initialization by
all modules defining a discipline type
*)
BEGIN
INC(unique);
RETURN unique
END Unique;
PROCEDURE Remove*(object: Object; id: Identifier);
(* remove the discipline with the given id from object, if it exists *)
VAR
prev, dl: DisciplineList;
BEGIN
prev := NIL;
dl := object.list;
WHILE (dl # NIL) & (dl.id # id) DO
prev := dl; dl := dl.next;
END;
IF dl # NIL THEN
IF prev = NIL THEN
object.list := dl.next;
ELSE
prev.next := dl.next;
END;
END;
END Remove;
PROCEDURE Add*(object: Object; discipline: Discipline);
(* adds a new discipline to the given object;
if already a discipline with the same identifier exist
it is deleted first
*)
VAR
dl: DisciplineList;
BEGIN
dl := object.list;
WHILE (dl # NIL) & (dl.id # discipline.id) DO
dl := dl.next;
END;
IF dl = NIL THEN
NEW(dl);
dl.id := discipline.id;
dl.next := object.list;
object.list := dl;
END;
dl.discipline := discipline;
END Add;
PROCEDURE Seek*(object: Object; id: Identifier;
VAR discipline: Discipline) : BOOLEAN;
(* returns TRUE if a discipline with the given id is found *)
VAR
dl: DisciplineList;
BEGIN
dl := object.list;
WHILE (dl # NIL) & (dl.id # id) DO
dl := dl.next;
END;
IF dl # NIL THEN
discipline := dl.discipline;
ELSE
discipline := NIL;
END;
RETURN discipline # NIL
END Seek;
BEGIN
unique := 0;
END ulmDisciplines.

158
src/library/ulm/ulmErrors.Mod Normal file
View file

@ -0,0 +1,158 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Errors.om,v 1.2 1994/07/18 14:16:33 borchert Exp $
----------------------------------------------------------------------------
$Log: Errors.om,v $
Revision 1.2 1994/07/18 14:16:33 borchert
unused variables of Write (ch & index) removed
Revision 1.1 1994/02/22 20:07:15 borchert
Initial revision
----------------------------------------------------------------------------
AFB 11/91
----------------------------------------------------------------------------
*)
MODULE ulmErrors;
(* translate events to errors *)
IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Objects := ulmObjects, RelatedEvents := ulmRelatedEvents, Streams := ulmStreams, Strings := ulmStrings,
SYS := SYSTEM;
CONST
(* Kind = (debug, message, warning, error, fatal, bug) *)
debug* = 0;
message* = 1;
warning* = 2;
error* = 3;
fatal* = 4;
bug* = 5;
nkinds* = 6;
TYPE
Kind* = SHORTINT; (* debug..bug *)
VAR
kindText*: ARRAY nkinds OF ARRAY 12 OF CHAR;
TYPE
Handler* = PROCEDURE (event: Events.Event; kind: Kind);
HandlerSet* = POINTER TO HandlerSetRec;
HandlerSetRec* =
RECORD
(Disciplines.ObjectRec)
(* private components *)
handlerSet: SET; (* set of installed handlers *)
handler: ARRAY nkinds OF Handler;
END;
(* ========== write discipline ========================================= *)
TYPE
WriteProcedure* = PROCEDURE (s: Streams.Stream; event: Events.Event);
WriteDiscipline = POINTER TO WriteDisciplineRec;
WriteDisciplineRec =
RECORD
(Disciplines.DisciplineRec)
write: WriteProcedure;
END;
VAR
writeDiscId: Disciplines.Identifier;
(* ========== handler discipline ======================================= *)
TYPE
HandlerDiscipline = POINTER TO HandlerDisciplineRec;
HandlerDisciplineRec =
RECORD
(Disciplines.DisciplineRec)
hs: HandlerSet;
kind: Kind;
END;
VAR
handlerDiscId: Disciplines.Identifier;
VAR
null*: HandlerSet; (* empty handler set *)
PROCEDURE CreateHandlerSet*(VAR hs: HandlerSet);
BEGIN
NEW(hs); hs.handlerSet := {};
END CreateHandlerSet;
PROCEDURE InstallHandler*(hs: HandlerSet; kind: Kind; handler: Handler);
BEGIN
hs.handler[kind] := handler;
INCL(hs.handlerSet, kind);
END InstallHandler;
PROCEDURE AssignWriteProcedure*(eventType: Events.EventType;
write: WriteProcedure);
VAR
writeDiscipline: WriteDiscipline;
BEGIN
NEW(writeDiscipline);
writeDiscipline.id := writeDiscId;
writeDiscipline.write := write;
Disciplines.Add(eventType, writeDiscipline);
END AssignWriteProcedure;
PROCEDURE Write*(s: Streams.Stream; event: Events.Event);
VAR
writeDiscipline: WriteDiscipline;
BEGIN
IF Disciplines.Seek(event.type, writeDiscId, SYS.VAL(Disciplines.Discipline, writeDiscipline)) THEN
writeDiscipline.write(s, event);
ELSE
IF ~Streams.WritePart(s, event.message, 0,
Strings.Len(event.message)) THEN
END;
END;
END Write;
PROCEDURE GeneralEventHandler(event: Events.Event);
VAR
disc: HandlerDiscipline;
BEGIN
IF Disciplines.Seek(event.type, handlerDiscId, SYS.VAL(Disciplines.Discipline, disc)) &
(disc.kind IN disc.hs.handlerSet) THEN
disc.hs.handler[disc.kind](event, disc.kind);
END;
END GeneralEventHandler;
PROCEDURE CatchEvent*(hs: HandlerSet; kind: Kind; type: Events.EventType);
VAR
handlerDiscipline: HandlerDiscipline;
BEGIN
NEW(handlerDiscipline); handlerDiscipline.id := handlerDiscId;
handlerDiscipline.hs := hs; handlerDiscipline.kind := kind;
Disciplines.Add(type, handlerDiscipline);
Events.Handler(type, GeneralEventHandler);
END CatchEvent;
BEGIN
writeDiscId := Disciplines.Unique();
handlerDiscId := Disciplines.Unique();
CreateHandlerSet(null);
kindText[debug] := "debug";
kindText[message] := "message";
kindText[warning] := "warning";
kindText[error] := "error";
kindText[fatal] := "fatal";
kindText[bug] := "bug";
END ulmErrors.

567
src/library/ulm/ulmEvents.Mod Normal file
View file

@ -0,0 +1,567 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Events.om,v 1.4 2004/03/30 17:48:14 borchert Exp $
----------------------------------------------------------------------------
$Log: Events.om,v $
Revision 1.4 2004/03/30 17:48:14 borchert
support of external queue handling added
Revision 1.3 1996/01/04 17:07:20 borchert
event types are now an extension of Services.Object
Revision 1.2 1994/07/18 14:17:17 borchert
unused variables of Raise (oldevent + newevent) removed
Revision 1.1 1994/02/22 20:07:41 borchert
Initial revision
----------------------------------------------------------------------------
AFB 8/89
----------------------------------------------------------------------------
*)
MODULE ulmEvents;
IMPORT Objects := ulmObjects, Priorities := ulmPriorities, Services := ulmServices, SYS := ulmSYSTEM;
TYPE
EventType* = POINTER TO EventTypeRec;
CONST
(* possibilities on receipt of an event: *)
default* = 0; (* causes abortion *)
ignore* = 1; (* ignore event *)
funcs* = 2; (* call associated event handlers *)
TYPE
Reaction* = INTEGER; (* one of default, ignore, or funcs *)
Message* = ARRAY 80 OF CHAR;
Event* = POINTER TO EventRec;
EventRec* =
RECORD
(Objects.ObjectRec)
type*: EventType;
message*: Message;
(* private part *)
next: Event; (* queue *)
END;
EventHandler = PROCEDURE (event: Event);
(* event managers are needed if there is any action necessary
on changing the kind of reaction
*)
EventManager = PROCEDURE (type: EventType; reaction: Reaction);
Priority = INTEGER; (* must be non-negative *)
(* every event with reaction `funcs' has a handler list;
the list is in calling order which is reverse to
the order of `Handler'-calls
*)
HandlerList = POINTER TO HandlerRec;
HandlerRec* =
RECORD
(Objects.ObjectRec)
handler*: EventHandler;
next*: HandlerList;
END;
SaveList = POINTER TO SaveRec;
SaveRec =
RECORD
reaction: Reaction;
handlers: HandlerList;
next: SaveList;
END;
EventTypeRec* =
RECORD
(Services.ObjectRec)
(* private components *)
handlers: HandlerList;
priority: Priority;
reaction: Reaction;
manager: EventManager;
savelist: SaveList;
END;
Queue = POINTER TO QueueRec;
QueueRec =
RECORD
priority: INTEGER; (* queue for this priority *)
head, tail: Event;
next: Queue; (* queue with lower priority *)
END;
VAR
eventTypeType: Services.Type;
CONST
priotabsize = 256; (* size of a priority table *)
maxnestlevel = 1024; (* of Raise-calls (avoids endless recursion) *)
TYPE
(* in some cases coroutines uses local priority systems *)
PrioritySystem* = POINTER TO PrioritySystemRec;
PrioritySystemRec* =
RECORD
(Objects.ObjectRec)
(* private part *)
currentPriority: Priority;
priotab: ARRAY priotabsize OF Priority;
priotop: INTEGER;
overflow: INTEGER; (* of priority table *)
END;
CONST
priorityViolation* = 0; (* priority violation (EnterPriority *)
unbalancedExitPriority* = 1; (* unbalanced call of ExitPriority *)
unbalancedRestoreReaction* = 2; (* unbalanced call of RestoreReaction *)
negPriority* = 3; (* negative priority given to SetPriority *)
errorcodes* = 4;
TYPE
ErrorEvent* = POINTER TO ErrorEventRec;
ErrorEventRec* =
RECORD
(EventRec)
errorcode*: SHORTINT;
END;
VAR
errormsg*: ARRAY errorcodes OF Message;
error*: EventType;
VAR
(* private part *)
abort, log, queueHandler: EventHandler;
nestlevel: INTEGER; (* of Raise calls *)
queue: Queue;
lock: BOOLEAN; (* lock critical operations *)
psys: PrioritySystem; (* current priority system *)
PROCEDURE ^ Define*(VAR type: EventType);
PROCEDURE ^ SetPriority*(type: EventType; priority: Priority);
PROCEDURE ^ Raise*(event: Event);
PROCEDURE InitErrorHandling;
BEGIN
Define(error); SetPriority(error, Priorities.liberrors);
errormsg[priorityViolation] :=
"priority violation (Events.EnterPriority)";
errormsg[unbalancedExitPriority] :=
"unbalanced call of Events.ExitPriority";
errormsg[unbalancedRestoreReaction] :=
"unbalanced call of Events.RestoreReaction";
errormsg[negPriority] :=
"negative priority given to Events.SetPriority";
END InitErrorHandling;
PROCEDURE Error(code: SHORTINT);
VAR event: ErrorEvent;
BEGIN
NEW(event); event.type := error;
event.message := errormsg[code];
event.errorcode := code;
Raise(event);
END Error;
PROCEDURE NilEventManager(type: EventType; reaction: Reaction);
END NilEventManager;
PROCEDURE Init*(type: EventType);
VAR
stype: Services.Type;
BEGIN
Services.GetType(type, stype); ASSERT(stype # NIL);
type.handlers := NIL;
type.priority := Priorities.default;
type.reaction := default;
type.manager := NilEventManager;
type.savelist := NIL;
END Init;
PROCEDURE Define*(VAR type: EventType);
(* definition of a new event;
an unique event number is returned;
the reaction on receipt of `type' is defined to be `default'
*)
BEGIN
NEW(type);
Services.Init(type, eventTypeType);
Init(type);
END Define;
PROCEDURE GetReaction*(type: EventType) : Reaction;
(* returns either `default', `ignore', or `funcs' *)
BEGIN
RETURN type.reaction
END GetReaction;
PROCEDURE SetPriority*(type: EventType; priority: Priority);
(* (re-)defines the priority of an event *)
BEGIN
IF priority <= 0 THEN
Error(negPriority);
ELSE
type.priority := priority;
END;
END SetPriority;
PROCEDURE GetEventPriority*(type: EventType) : Priority;
(* return the priority of the given event *)
BEGIN
RETURN type.priority
END GetEventPriority;
PROCEDURE Manager*(type: EventType; manager: EventManager);
BEGIN
type.manager := manager;
END Manager;
PROCEDURE Handler*(type: EventType; handler: EventHandler);
(* add `handler' to the list of handlers for event `type' *)
VAR
newhandler: HandlerList;
BEGIN
NEW(newhandler);
newhandler.handler := handler; newhandler.next := type.handlers;
type.handlers := newhandler;
IF type.reaction # funcs THEN
type.reaction := funcs; type.manager(type, funcs);
END;
END Handler;
PROCEDURE RemoveHandlers*(type: EventType);
(* remove list of handlers for event `type';
implies default reaction (abortion) on
receipt of `type'
*)
BEGIN
type.handlers := NIL;
IF type.reaction # default THEN
type.reaction := default; type.manager(type, default);
END;
END RemoveHandlers;
PROCEDURE Ignore*(type: EventType);
(* implies RemoveHandlers(type) and causes receipt
of `type' to be ignored
*)
BEGIN
type.handlers := NIL;
IF type.reaction # ignore THEN
type.reaction := ignore; type.manager(type, ignore);
END;
END Ignore;
PROCEDURE GetHandlers*(type: EventType; handlers: HandlerList);
(* returns the list of handlers in `handlers';
the reaction of `type' must be `funcs'
*)
BEGIN
handlers := type.handlers;
END GetHandlers;
PROCEDURE Log*(loghandler: EventHandler);
(* call `loghandler' for every event;
subsequent calls of `Log' replace the loghandler;
the loghandler is not called on default and ignore
*)
BEGIN
log := loghandler;
END Log;
PROCEDURE GetLog*(VAR loghandler: EventHandler);
(* returns the loghandler set by `Log' *)
BEGIN
loghandler := log;
END GetLog;
PROCEDURE NilHandler*(event: Event);
(* an empty event handler *)
END NilHandler;
(* now QueueHandler will translate partly like
BOOLEAN b;
handler_EventHandler tmphandler;
LONGINT i, j;
i = (LONGINT)handler;
tmphandler = handler_NilHandler;
j = (LONGINT)tmphandler;
b = i != j;
*)
(* changed because voc cannot compara handler and NilHandler -- noch *)
PROCEDURE QueueHandler*(handler: EventHandler);
(* setup an alternative handler of events
that cannot be processed now because
of their unsufficient priority
*)
VAR b : BOOLEAN; (* noch *)
tmphandler : EventHandler;
(*i,j : LONGINT;*)
BEGIN
(*i := SYSTEM.VAL(LONGINT, handler);*)
tmphandler := NilHandler;
(*b := tmphandler = handler;*)
(*j := SYSTEM.VAL(LONGINT, tmphandler);
b := i # j;*)
b := handler # tmphandler;
(*ASSERT (handler # NilHandler);*)
ASSERT(b);
queueHandler := handler;
END QueueHandler;
PROCEDURE AbortHandler*(handler: EventHandler);
(* defines the handler to be called on abortion *)
BEGIN
abort := handler;
END AbortHandler;
PROCEDURE GetAbortHandler*(VAR handler: EventHandler);
(* returns the handler set by `AbortHandler' *)
BEGIN
handler := abort;
END GetAbortHandler;
PROCEDURE ^ CallHandlers(event: Event);
PROCEDURE WorkupQueue;
VAR
ptr: Event;
BEGIN
WHILE (queue # NIL) & (queue.priority > psys.currentPriority) DO
IF SYS.TAS(lock) THEN RETURN END;
ptr := queue.head; queue := queue.next;
lock := FALSE;
WHILE ptr # NIL DO
CallHandlers(ptr);
ptr := ptr.next;
END;
END;
END WorkupQueue;
PROCEDURE CallHandlers(event: Event);
VAR
ptr: HandlerList;
oldPriority: Priority;
BEGIN
CASE event.type.reaction OF
| default: abort(event);
| ignore:
| funcs: oldPriority := psys.currentPriority;
psys.currentPriority := event.type.priority;
log(event);
ptr := event.type.handlers;
WHILE ptr # NIL DO
ptr.handler(event);
ptr := ptr.next;
END;
psys.currentPriority := oldPriority;
END;
END CallHandlers;
PROCEDURE Raise*(event: Event);
(* call all event handlers (in reverse order)
associated with event.type;
abort if there are none;
some system events may abort in another way
(i.e. they do not cause the abortion handler to be called)
*)
VAR
priority: Priority;
PROCEDURE AddToQueue(event: Event);
VAR
prev, ptr: Queue;
BEGIN
event.next := NIL;
ptr := queue; prev := NIL;
WHILE (ptr # NIL) & (ptr.priority > priority) DO
prev := ptr;
ptr := ptr.next;
END;
IF (ptr # NIL) & (ptr.priority = priority) THEN
ptr.tail.next := event;
ptr.tail := event;
ELSE
NEW(ptr);
ptr.priority := priority;
ptr.head := event; ptr.tail := event;
IF prev = NIL THEN
ptr.next := queue;
queue := ptr;
ELSE
ptr.next := prev.next;
prev.next := ptr;
END;
END;
END AddToQueue;
BEGIN (* Raise *)
INC(nestlevel);
IF nestlevel >= maxnestlevel THEN
abort(event);
ELSE
IF event.type.reaction # ignore THEN
priority := event.type.priority;
IF psys.currentPriority < priority THEN
CallHandlers(event); WorkupQueue;
ELSIF queueHandler # NIL THEN
queueHandler(event);
ELSIF ~SYS.TAS(lock) THEN
AddToQueue(event);
lock := FALSE;
END;
END;
END;
DEC(nestlevel);
END Raise;
PROCEDURE CreatePrioritySystem*(VAR prioritySystem: PrioritySystem);
(* create and initialize a new priority system *)
BEGIN
NEW(prioritySystem);
prioritySystem.currentPriority := Priorities.base;
prioritySystem.priotop := 0;
END CreatePrioritySystem;
PROCEDURE CurrentPrioritySystem*() : PrioritySystem;
(* return the priority system currently active *)
BEGIN
RETURN psys
END CurrentPrioritySystem;
PROCEDURE SwitchPrioritySystem*(prioritySystem: PrioritySystem);
(* switch to another priority system; this is typically
done in case of task switches
*)
BEGIN
psys := prioritySystem;
END SwitchPrioritySystem;
PROCEDURE EnterPriority*(priority: Priority);
(* sets the current priority to `priority';
it is an error to give a priority less than
the current priority (event `badpriority')
*)
BEGIN
IF psys.currentPriority <= priority THEN
IF (psys.overflow = 0) & (psys.priotop < priotabsize) THEN
psys.priotab[psys.priotop] := psys.currentPriority;
INC(psys.priotop);
psys.currentPriority := priority;
ELSE
INC(psys.overflow);
END;
ELSE
Error(priorityViolation);
INC(psys.overflow);
END;
END EnterPriority;
PROCEDURE AssertPriority*(priority: Priority);
(* current priority
< priority: set the current priority to `priority'
>= priority: the current priority remains unchanged
*)
BEGIN
IF (psys.overflow = 0) & (psys.priotop < priotabsize) THEN
psys.priotab[psys.priotop] := psys.currentPriority; INC(psys.priotop);
IF psys.currentPriority < priority THEN
psys.currentPriority := priority;
END;
ELSE
INC(psys.overflow);
END;
END AssertPriority;
PROCEDURE ExitPriority*;
(* causes the priority before the last effective call
of SetPriority or AssertPriority to be restored
*)
BEGIN
IF psys.overflow > 0 THEN
DEC(psys.overflow);
ELSIF psys.priotop = 0 THEN
Error(unbalancedExitPriority);
ELSE
DEC(psys.priotop); psys.currentPriority := psys.priotab[psys.priotop];
WorkupQueue;
END;
END ExitPriority;
PROCEDURE GetPriority*() : Priority;
(* returns the current priority *)
BEGIN
RETURN psys.currentPriority
END GetPriority;
PROCEDURE SaveReaction*(type: EventType);
(* saves current reaction until call of RestoreReaction;
the new reaction of `type' is defined to be `ignore'
but can be changed by Events.Handler or Events.RemoveHandlers
*)
VAR
savelist: SaveList;
BEGIN
NEW(savelist);
savelist.reaction := type.reaction;
savelist.handlers := type.handlers;
savelist.next := type.savelist;
type.savelist := savelist;
type.handlers := NIL;
IF type.reaction # ignore THEN
type.reaction := ignore; type.manager(type, ignore);
END;
END SaveReaction;
PROCEDURE RestoreReaction*(type: EventType);
(* restores old reaction;
must be properly nested
*)
VAR
savelist: SaveList;
BEGIN
IF type.savelist = NIL THEN
Error(unbalancedRestoreReaction);
ELSE
savelist := type.savelist;
type.savelist := savelist.next;
type.handlers := savelist.handlers;
IF type.reaction # savelist.reaction THEN
type.reaction := savelist.reaction;
type.manager(type, savelist.reaction);
END;
END;
END RestoreReaction;
BEGIN
CreatePrioritySystem(psys);
Services.CreateType(eventTypeType, "Events.EventType", "");
abort := NilHandler; log := NilHandler; queueHandler := NIL;
nestlevel := 0;
queue := NIL;
lock := FALSE;
InitErrorHandling;
END ulmEvents.

244
src/library/ulm/ulmForwarders.Mod Normal file
View file

@ -0,0 +1,244 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1995 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Forwarders.om,v 1.1 1996/01/04 16:40:57 borchert Exp $
----------------------------------------------------------------------------
$Log: Forwarders.om,v $
Revision 1.1 1996/01/04 16:40:57 borchert
Initial revision
----------------------------------------------------------------------------
*)
MODULE ulmForwarders; (* AFB 3/95 *)
IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Resources := ulmResources, Services := ulmServices, SYSTEM;
(* SYSTEM is necessary to cast to Disciplines.Discipline; noch *)
TYPE
Object* = Services.Object;
ForwardProc* = PROCEDURE (from, to: Object);
TYPE
ListOfForwarders = POINTER TO ListOfForwardersRec;
ListOfForwardersRec =
RECORD
forward: ForwardProc;
next: ListOfForwarders;
END;
ListOfDependants = POINTER TO ListOfDependantsRec;
ListOfDependantsRec =
RECORD
dependant: Object;
next: ListOfDependants;
END;
TypeDiscipline = POINTER TO TypeDisciplineRec;
TypeDisciplineRec =
RECORD
(Disciplines.DisciplineRec)
list: ListOfForwarders;
END;
ObjectDiscipline = POINTER TO ObjectDisciplineRec;
ObjectDisciplineRec =
RECORD
(Disciplines.DisciplineRec)
dependants: ListOfDependants;
forwarders: ListOfForwarders;
dependsOn: Object;
END;
VAR
genlist: ListOfForwarders; (* list which applies to all types *)
typeDiscID: Disciplines.Identifier;
objectDiscID: Disciplines.Identifier;
(* === private procedures ============================================ *)
PROCEDURE RemoveDependant(VAR list: ListOfDependants; dependant: Object);
VAR
prev, p: ListOfDependants;
BEGIN
prev := NIL; p := list;
WHILE (p # NIL) & (p.dependant # dependant) DO
prev := p; p := p.next;
END;
IF p # NIL THEN
IF prev = NIL THEN
list := p.next;
ELSE
prev.next := p.next;
END;
END;
END RemoveDependant;
PROCEDURE TerminationHandler(event: Events.Event);
(* remove list of dependants in case of termination and
remove event.resource from the list of dependants of that
object it depends on
*)
VAR
odisc: ObjectDiscipline;
dependsOn: Object;
BEGIN
WITH event: Resources.Event DO
IF event.change = Resources.terminated THEN
IF Disciplines.Seek(event.resource, objectDiscID, SYSTEM.VAL(Disciplines.Discipline, odisc)) THEN (* noch *)
Disciplines.Remove(event.resource, objectDiscID);
dependsOn := odisc.dependsOn;
IF (dependsOn # NIL) & ~Resources.Terminated(dependsOn) &
Disciplines.Seek(dependsOn, objectDiscID, SYSTEM.VAL(Disciplines.Discipline, odisc)) THEN (* noch *)
RemoveDependant(odisc.dependants, event.resource(Object));
END;
END;
END;
END;
END TerminationHandler;
PROCEDURE Insert(VAR list: ListOfForwarders; forward: ForwardProc);
VAR
member: ListOfForwarders;
BEGIN
NEW(member); member.forward := forward;
member.next := list; list := member;
END Insert;
PROCEDURE GetObjectDiscipline(object: Object; VAR odisc: ObjectDiscipline);
VAR
resourceNotification: Events.EventType;
BEGIN
IF ~Disciplines.Seek(object, objectDiscID, SYSTEM.VAL(Disciplines.Discipline, odisc)) THEN (* noch *)
NEW(odisc); odisc.id := objectDiscID; odisc.dependants := NIL;
odisc.forwarders := NIL; odisc.dependsOn := NIL;
(* let's state our interest in termination of `object' if
we see this object the first time
*)
Resources.TakeInterest(object, resourceNotification);
Events.Handler(resourceNotification, TerminationHandler);
Disciplines.Add(object, odisc);
END;
END GetObjectDiscipline;
(* === exported procedures =========================================== *)
PROCEDURE Register*(for: ARRAY OF CHAR; forward: ForwardProc);
(* register a forwarder which is to be called for all
forward operations which affects extensions of `for';
"" may be given for Services.Object
*)
VAR
type: Services.Type;
tdisc: TypeDiscipline;
BEGIN (* Register *)
IF for = "" THEN
Insert(genlist, forward);
ELSE
Services.SeekType(for, type);
ASSERT(type # NIL);
IF ~Disciplines.Seek(type, typeDiscID, SYSTEM.VAL(Disciplines.Discipline, tdisc)) THEN
NEW(tdisc); tdisc.id := typeDiscID; tdisc.list := NIL;
END;
Insert(tdisc.list, forward);
Disciplines.Add(type, tdisc);
END;
END Register;
PROCEDURE RegisterObject*(object: Object; forward: ForwardProc);
(* to be called instead of Register if specific objects
are supported only and not all extensions of a type
*)
VAR
odisc: ObjectDiscipline;
BEGIN
GetObjectDiscipline(object, odisc);
Insert(odisc.forwarders, forward);
END RegisterObject;
PROCEDURE Update*(object: Object; forward: ForwardProc);
(* is to be called by one of the registered forwarders if
an interface for object has been newly installed or changed
in a way which needs forward to be called for each of
the filter objects which delegate to `object'
*)
VAR
odisc: ObjectDiscipline;
client: ListOfDependants;
BEGIN
IF Disciplines.Seek(object, objectDiscID, SYSTEM.VAL(Disciplines.Discipline, odisc)) THEN (* noch *)
client := odisc.dependants;
WHILE client # NIL DO
forward(client.dependant, object);
client := client.next;
END;
END;
END Update;
PROCEDURE Forward*(from, to: Object);
(* forward (as far as supported) all operations from `from' to `to' *)
VAR
type, otherType, baseType: Services.Type;
tdisc: TypeDiscipline;
odisc: ObjectDiscipline;
client: ListOfDependants;
forwarder: ListOfForwarders;
PROCEDURE CallForwarders(list: ListOfForwarders);
BEGIN
WHILE list # NIL DO
list.forward(from, to);
list := list.next;
END;
END CallForwarders;
BEGIN (* Forward *)
Services.GetType(from, type);
Services.GetType(to, otherType);
ASSERT((type # NIL) & (otherType # NIL));
IF Resources.Terminated(to) OR Resources.Terminated(from) THEN
(* forwarding operations is no longer useful *)
RETURN
END;
Resources.DependsOn(from, to);
(* update the list of dependants for `to' *)
GetObjectDiscipline(to, odisc);
NEW(client); client.dependant := from;
client.next := odisc.dependants; odisc.dependants := client;
(* call object-specific forwarders *)
CallForwarders(odisc.forwarders);
LOOP (* go through the list of base types in descending order *)
IF Disciplines.Seek(type, typeDiscID, SYSTEM.VAL(Disciplines.Discipline, tdisc)) & (* noch *)
Services.IsExtensionOf(otherType, type) THEN
CallForwarders(tdisc.list);
END;
Services.GetBaseType(type, baseType);
IF baseType = NIL THEN EXIT END;
type := baseType;
END;
CallForwarders(genlist);
END Forward;
BEGIN
genlist := NIL;
typeDiscID := Disciplines.Unique();
objectDiscID := Disciplines.Unique();
END ulmForwarders.

142
src/library/ulm/ulmIEEE.Mod Normal file
View file

@ -0,0 +1,142 @@
(* Ulm's Oberon Library
Copyright (C) 1989-2005 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: IEEE.om,v 1.1 1994/02/23 07:45:22 borchert Exp $
----------------------------------------------------------------------------
$Log: IEEE.om,v $
Revision 1.1 1994/02/23 07:45:22 borchert
Initial revision
----------------------------------------------------------------------------
AFB 7/89
----------------------------------------------------------------------------
*)
MODULE ulmIEEE;
(* this module is portable as far as a IEEE floating point processor
is present
implementation for the I386 architecture
assumptions:
{0} is the most significant bit
MAX(SET) = 31
double precision binary real format (REAL):
0 1..11 12 .. 63
+-+-----+---------------+
|S| exp | fraction |
+-+-----+---------------+
normalized numbers: min < exp < max
denormalized numbers: exp = 0 and nonzero mantissa
zero: exp = 0 and mantissa = 0
infinity: exp = max and mantissa = 0
not-a-number: exp = max and mantissa # 0
*)
IMPORT SYS := SYSTEM;
CONST
(*patternlen = SYS.SIZE(LONGREAL) DIV SYS.SIZE(SET);*)
patternlen = SIZE(LONGREAL) DIV SIZE(SET) + 23; (* in ulm Oberon system, size of longreal is 12, size of set is 4, so this will be 3
in voc 32 bit we have it as 8 DIV 4
in voc 64 bit we have it as 8 DIV 8
may be it worth just to add some number to the result of division -- noch
*)
VAR
plusInfinity*: REAL;
minusInfinity*: REAL;
nan*: REAL; (* Not-A-Number *)
snan*: REAL; (* Signaling Not-A-Number *)
(*PROCEDURE Convert(VAR from, to: ARRAY OF BYTE);*)
PROCEDURE Convert(VAR from, to: ARRAY OF SYS.BYTE);
VAR i: INTEGER;
BEGIN
i := 0;
WHILE i < LEN(to) DO
to[i] := from[i]; INC(i);
END;
END Convert;
PROCEDURE Normalized*(real: LONGREAL) : BOOLEAN;
VAR pattern: ARRAY patternlen OF SET;
BEGIN
Convert(real, pattern);
pattern[1] := pattern[1] * {20..30};
RETURN (pattern[1] # {}) & (pattern[1] # {20..30})
END Normalized;
PROCEDURE Valid*(real: LONGREAL) : BOOLEAN;
(* returns TRUE if real is normalized or denormalized
but FALSE for infinity and Not-A-Numbers
*)
VAR pattern: ARRAY patternlen OF SET;
BEGIN
Convert(real, pattern);
pattern[1] := pattern[1] * {20..30};
RETURN pattern[1] # {20..30}
END Valid;
PROCEDURE NotANumber*(real: LONGREAL) : BOOLEAN;
(* returns TRUE if real is a (signaling) Not-A-Number *)
VAR pattern: ARRAY patternlen OF SET;
BEGIN
Convert(real, pattern);
RETURN (pattern[1] * {20..30} = {20..30}) &
((pattern[0] * {0..MAX(SET)} # {}) OR
(pattern[1] * {0..19} # {}))
END NotANumber;
PROCEDURE SetReal(VAR real: REAL;
sign: BOOLEAN; expbits: BOOLEAN;
msb: BOOLEAN; otherbits: BOOLEAN);
VAR
pattern: ARRAY 2 OF SET;
BEGIN
pattern[0] := {}; pattern[1] := {};
IF sign THEN
INCL(pattern[1], 31);
END;
IF expbits THEN
pattern[1] := pattern[1] + {20..30};
END;
IF msb THEN
INCL(pattern[1], 19);
END;
IF otherbits THEN
pattern[1] := pattern[1] + {0..18};
pattern[0] := {0..MAX(SET)};
END;
Convert(pattern, real);
END SetReal;
BEGIN
(* sign exp msb mantissa *)
SetReal(plusInfinity, FALSE, TRUE, FALSE, FALSE);
SetReal(minusInfinity, TRUE, TRUE, FALSE, FALSE);
SetReal(nan, FALSE, TRUE, TRUE, TRUE);
SetReal(snan, FALSE, TRUE, FALSE, TRUE);
END ulmIEEE.

244
src/library/ulm/ulmIO.Mod Normal file
View file

@ -0,0 +1,244 @@
MODULE ulmIO;
IMPORT SYS := ulmSYSTEM, SYSTEM;
CONST nl = 0AX;
(* conversions *)
CONST
oct = 0;
dec = 1;
hex = 2;
TYPE
Basetype = SHORTINT; (* oct..hex *)
(* basic IO *)
VAR
Done*: BOOLEAN;
oldch: CHAR;
readAgain: BOOLEAN;
(* ==================== conversions ================================= *)
PROCEDURE ConvertNumber(num, len: LONGINT; btyp: Basetype; neg: BOOLEAN;
VAR str: ARRAY OF CHAR);
(* conversion of a number into a string of characters *)
(* num must get the absolute value of the number *)
(* len is the minimal length of the generated string *)
(* neg means: "the number is negative" for btyp = dec *)
(*CONST
NumberLen = 11;*)
(* we need it as variable to change the value depending on architecture; -- noch *)
VAR
(*digits : ARRAY NumberLen+1 OF CHAR;*)
digits : POINTER TO ARRAY OF CHAR;
base : INTEGER;
cnt, ix : INTEGER;
maxlen : LONGINT;
dig : LONGINT;
NumberLen : SHORTINT;
BEGIN
IF SIZE(LONGINT) = 4 THEN
NumberLen := 11
ELSIF SIZE(LONGINT) = 8 THEN
NumberLen := 21
ELSE
NumberLen := 11 (* default value, corresponds to 32 bit *)
END;
NEW(digits, NumberLen + 1 );
ASSERT(num >= 0);
ix := 1;
WHILE ix <= NumberLen DO
digits[ix] := "0";
INC(ix);
END; (* initialisation *)
IF btyp = oct THEN
base := 8;
ELSIF btyp = dec THEN
base := 10;
ELSIF btyp = hex THEN
base := 10H;
END;
cnt := 0;
REPEAT
INC(cnt);
dig := num MOD base;
num := num DIV base;
IF dig < 10 THEN
dig := dig + ORD("0");
ELSE
dig := dig - 10 + ORD("A");
END;
digits[cnt] := CHR(dig);
UNTIL num = 0;
(* (* i don't like this *)
IF btyp = oct THEN
cnt := 11;
ELSIF btyp = hex THEN
cnt := 8;
ELSIF neg THEN
*)
IF neg THEN
INC(cnt);
digits[cnt] := "-";
END;
maxlen := LEN(str); (* get maximal length *)
IF len > maxlen THEN
len := SHORT(maxlen);
END;
IF cnt > maxlen THEN
cnt := SHORT(maxlen);
END;
ix := 0;
WHILE len > cnt DO
str[ix] := " ";
INC(ix);
DEC(len);
END;
WHILE cnt > 0 DO
str[ix] := digits[cnt];
INC(ix);
DEC(cnt);
END;
IF ix < maxlen THEN
str[ix] := 0X;
END;
END ConvertNumber;
PROCEDURE ConvertInteger(num: LONGINT; len: INTEGER; VAR str: ARRAY OF
CHAR);
(* conversion of an integer decimal number to a string *)
BEGIN
ConvertNumber(ABS(num),len,dec,num < 0,str);
END ConvertInteger;
(* ========================= terminal ============================ *)
PROCEDURE ReadChar(VAR ch: CHAR) : BOOLEAN;
CONST read = 3;
(*VAR r0, r1: INTEGER;*)
VAR r0, r1: LONGINT; (* in ulm system INTEGER and LONGINT have the same 4 byte size; -- noch *)
BEGIN
RETURN SYS.UNIXCALL(read, r0, r1, 0, SYSTEM.ADR(ch), 1) & (r0 > 0)
END ReadChar;
PROCEDURE WriteChar(ch: CHAR) : BOOLEAN;
CONST write = 4;
(*VAR r0, r1: INTEGER;*)
VAR r0, r1: LONGINT; (* same here *)
BEGIN
RETURN SYS.UNIXCALL(write, r0, r1, 1, SYSTEM.ADR(ch), 1)
END WriteChar;
PROCEDURE Read*(VAR ch: CHAR);
BEGIN
Done := TRUE;
IF readAgain THEN
ch := oldch;
readAgain := FALSE;
ELSIF ~ReadChar(ch) THEN
Done := FALSE;
ch := 0X;
ELSE
oldch := ch;
END;
END Read;
PROCEDURE ReadAgain*;
BEGIN
IF readAgain THEN
Done := FALSE;
ELSE
Done := TRUE;
readAgain := TRUE;
END;
END ReadAgain;
PROCEDURE Write*(ch: CHAR);
BEGIN
Done := WriteChar(ch);
END Write;
PROCEDURE WriteLn*;
CONST nl = 0AX;
BEGIN
Write(nl);
END WriteLn;
PROCEDURE WriteString*(s: ARRAY OF CHAR);
VAR i: INTEGER;
BEGIN
i := 0;
WHILE (i < LEN(s)) & (s[i] # 0X) DO
Write(s[i]);
INC(i);
END;
END WriteString;
PROCEDURE InitIO;
BEGIN
readAgain := FALSE;
Done := TRUE;
END InitIO;
PROCEDURE WriteInt*(arg: LONGINT);
VAR field: ARRAY 23 OF CHAR;
BEGIN (* the field size should be big enough to hold the long number. it was 12 to hold just 32 bit numbers, now it can hold 64 bit numbers; need to be more for 128bit numbers; -- noch *)
ConvertInteger(arg, 1, field);
WriteString(field);
END WriteInt;
PROCEDURE ReadInt*(VAR arg: LONGINT);
VAR ch: CHAR;
minus: BOOLEAN;
BEGIN
minus := FALSE;
REPEAT
Read(ch);
IF ~Done THEN RETURN END;
IF ch = "-" THEN
minus := TRUE;
ELSIF (ch # " ") & (ch # nl) & ((ch < "0") OR (ch > "9")) THEN
WriteString("--- Integer expected on input"); WriteLn;
END;
UNTIL (ch >= "0") & (ch <= "9");
arg := ORD(ch) - ORD("0");
REPEAT
Read(ch);
IF ~Done THEN RETURN END;
IF (ch >= "0") & (ch <= "9") THEN
arg := arg*10 + (ORD(ch) - ORD("0"));
END;
UNTIL (ch < "0") OR (ch > "9");
ReadAgain;
IF minus THEN arg := -arg; END;
END ReadInt;
PROCEDURE ReadLine*(VAR string: ARRAY OF CHAR);
VAR
index: INTEGER;
ch: CHAR;
ok: BOOLEAN;
BEGIN
index := 0; ok := TRUE;
LOOP
IF ~ReadChar(ch) THEN ok := FALSE; EXIT END;
IF ch = nl THEN EXIT END;
IF index < LEN(string) THEN
string[index] := ch; INC(index);
END;
END;
IF index < LEN(string) THEN
string[index] := 0X;
END;
Done := ok OR (index > 0);
END ReadLine;
BEGIN
InitIO;
END ulmIO.

122
src/library/ulm/ulmIndirectDisciplines.Mod Normal file
View file

@ -0,0 +1,122 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: IndirectDis.om,v 1.2 1995/03/17 13:56:51 borchert Exp $
----------------------------------------------------------------------------
$Log: IndirectDis.om,v $
Revision 1.2 1995/03/17 13:56:51 borchert
support of Forwarders added
Revision 1.1 1994/06/27 09:50:43 borchert
Initial revision
----------------------------------------------------------------------------
*)
MODULE ulmIndirectDisciplines;
IMPORT Disciplines := ulmDisciplines, Forwarders := ulmForwarders, SYSTEM;
TYPE
Object* = Disciplines.Object;
ObjectRec* = Disciplines.ObjectRec;
Discipline* = Disciplines.Discipline;
DisciplineRec* = Disciplines.DisciplineRec;
Identifier* = Disciplines.Identifier;
TYPE
IndDiscipline = POINTER TO IndDisciplineRec;
IndDisciplineRec =
RECORD
(DisciplineRec)
forwardTo: Object;
END;
VAR
discID: Identifier;
PROCEDURE Forward*(from, to: Object);
VAR
disc: IndDiscipline;
BEGIN
IF to = NIL THEN
Disciplines.Remove(from, discID);
ELSE
NEW(disc); disc.id := discID;
disc.forwardTo := to;
Disciplines.Add(from, disc);
END;
END Forward;
PROCEDURE InternalForward(from, to: Forwarders.Object);
BEGIN
Forward(from, to);
END InternalForward;
PROCEDURE Add*(object: Object; discipline: Discipline);
VAR
disc: IndDiscipline;
BEGIN
WHILE Disciplines.Seek(object, discID, SYSTEM.VAL(Disciplines.Discipline, disc)) DO
object := disc.forwardTo;
END;
Disciplines.Add(object, discipline);
END Add;
PROCEDURE Remove*(object: Object; id: Identifier);
VAR
dummy: Discipline;
disc: IndDiscipline;
BEGIN
LOOP
IF Disciplines.Seek(object, id, dummy) THEN
Disciplines.Remove(object, id);
EXIT
END;
IF ~Disciplines.Seek(object, discID, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN
EXIT
END;
object := disc.forwardTo;
END;
END Remove;
PROCEDURE Seek*(object: Object; id: Identifier;
VAR discipline: Discipline) : BOOLEAN;
VAR
disc: IndDiscipline;
BEGIN
LOOP
IF Disciplines.Seek(object, id, discipline) THEN
RETURN TRUE
END;
IF ~Disciplines.Seek(object, discID, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN
RETURN FALSE
END;
object := disc.forwardTo;
END;
END Seek;
PROCEDURE Unique*() : Identifier;
BEGIN
RETURN Disciplines.Unique()
END Unique;
BEGIN
discID := Disciplines.Unique();
Forwarders.Register("", InternalForward);
END ulmIndirectDisciplines.

353
src/library/ulm/ulmIntOperations.Mod Normal file
View file

@ -0,0 +1,353 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1997 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: IntOperatio.om,v 1.1 1997/04/03 09:38:51 borchert Exp $
----------------------------------------------------------------------------
$Log: IntOperatio.om,v $
Revision 1.1 1997/04/03 09:38:51 borchert
Initial revision
----------------------------------------------------------------------------
*)
MODULE ulmIntOperations; (* Frank B.J. Fischer *)
IMPORT Operations := ulmOperations, PersistentObjects := ulmPersistentObjects, Services := ulmServices, Streams := ulmStreams, Types := ulmTypes, SYSTEM;
(* SYSTEM added to make casts necessary to port ulm library because ulm compiler is not as strict (read it's wrong) as it had to be --noch *)
CONST
mod* = 5; pow* = 6; inc* = 7; dec* = 8; mmul* = 9; mpow* = 10;
odd* = 11; shift* = 12;
TYPE
Operation* = Operations.Operation; (* Operations.add..mpow *)
Operand* = POINTER TO OperandRec;
TYPE
CapabilitySet* = Operations.CapabilitySet;
(* SET of [Operations.add..shift] *)
IsLargeEnoughForProc* = PROCEDURE (op: Operations.Operand;
n: LONGINT): BOOLEAN;
UnsignedProc* = PROCEDURE (op: Operations.Operand): BOOLEAN;
IntToOpProc* = PROCEDURE (int32: Types.Int32; VAR op: Operations.Operand);
OpToIntProc* = PROCEDURE (op: Operations.Operand; VAR int32: Types.Int32);
Log2Proc* = PROCEDURE (op: Operations.Operand): LONGINT;
OddProc* = PROCEDURE (op: Operations.Operand): BOOLEAN;
ShiftProc* = PROCEDURE (op: Operations.Operand;
n: INTEGER): Operations.Operand;
IntOperatorProc* = PROCEDURE(op: Operation;
op1, op2, op3: Operations.Operand;
VAR result: Operations.Operand);
Interface* = POINTER TO InterfaceRec;
InterfaceRec* = RECORD
(Operations.InterfaceRec)
isLargeEnoughFor*: IsLargeEnoughForProc;
unsigned* : UnsignedProc;
intToOp* : IntToOpProc;
opToInt* : OpToIntProc;
log2* : Log2Proc;
odd* : OddProc;
shift* : ShiftProc;
intOp* : IntOperatorProc;
END;
TYPE
OperandRec* = RECORD
(Operations.OperandRec);
(* private components *)
if : Interface;
caps: CapabilitySet;
END;
VAR
operandType: Services.Type;
PROCEDURE Init*(op: Operand; if: Interface; caps: CapabilitySet);
BEGIN
Operations.Init(op, if, caps);
op.if := if;
op.caps := caps;
END Init;
PROCEDURE Capabilities*(op: Operand): CapabilitySet;
BEGIN
RETURN op.caps
END Capabilities;
PROCEDURE IsLargeEnoughFor*(op: Operations.Operand; n: LONGINT): BOOLEAN;
BEGIN
WITH op: Operand DO
RETURN op.if.isLargeEnoughFor(op, n)
END;
END IsLargeEnoughFor;
PROCEDURE Unsigned*(op: Operations.Operand): BOOLEAN;
BEGIN
WITH op: Operand DO
RETURN op.if.unsigned(op)
END;
END Unsigned;
PROCEDURE IntToOp*(int32: Types.Int32; VAR op: Operations.Operand);
(* converts int32 into operand type, and stores result in already
initialized op
*)
BEGIN
(*WITH op: Operand DO*)
(*
with original ulm source we were getting:
WITH op: Operand DO
^
pos 4101 err 245 guarded pointer variable may be manipulated by non-local operations; use auxiliary pointer variable
thus we considered changing WITH op: Operand by op(Operand)
-- noch
*)
(*ASSERT(op.if # NIL);*)
ASSERT(op(Operand).if # NIL);
(*op.if.intToOp(int32, op);*)
op(Operand).if.intToOp(int32, op(Operations.Operand));
(*END;*)
END IntToOp;
PROCEDURE OpToInt*(op: Operations.Operand; VAR int32: Types.Int32);
(* converts op into int32 *)
BEGIN
WITH op: Operand DO
op.if.opToInt(op, int32);
END;
END OpToInt;
PROCEDURE Log2*(op: Operations.Operand): LONGINT;
BEGIN
WITH op: Operand DO
RETURN op.if.log2(op)
END;
END Log2;
PROCEDURE Odd*(op: Operations.Operand): BOOLEAN;
BEGIN
WITH op: Operand DO
ASSERT(odd IN op.caps);
RETURN op.if.odd(op)
END;
END Odd;
PROCEDURE Op(op: Operation; op1, op2, op3: Operations.Operand;
VAR result: Operations.Operand);
VAR
tmpresult: Operations.Operand;
BEGIN
WITH op1: Operand DO
IF (op2#NIL) & (op3#NIL) THEN
ASSERT((op1.if = op2(Operand).if) &
(op2(Operand).if = op3(Operand).if));
ELSIF (op2#NIL) THEN
ASSERT(op1.if = op2(Operand).if);
END;
ASSERT(op IN op1.caps);
op1.if.create(tmpresult);
op1.if.intOp(op, op1, op2, op3, tmpresult);
result := tmpresult;
END;
END Op;
PROCEDURE Shift*(op1: Operations.Operand; n: INTEGER): Operations.Operand;
BEGIN
WITH op1: Operand DO
ASSERT(shift IN op1.caps);
RETURN op1.if.shift(op1,n);
END;
END Shift;
PROCEDURE Shift2*(VAR op1: Operations.Operand; n: INTEGER);
BEGIN
op1 := Shift(op1, n);
END Shift2;
PROCEDURE Shift3*(VAR result: Operations.Operand; op1: Operations.Operand;
n : INTEGER);
VAR
tmpresult: Operations.Operand;
BEGIN
WITH op1: Operand DO
op1.if.create(tmpresult);
tmpresult := Shift(op1, n);
result := tmpresult;
END;
END Shift3;
PROCEDURE Inc*(op1: Operations.Operand): Operations.Operand;
VAR
result: Operations.Operand;
BEGIN
result := NIL;
Op(inc,op1,NIL,NIL,result);
RETURN result
END Inc;
PROCEDURE Inc2*(VAR op1: Operations.Operand);
BEGIN
Op(inc,op1,NIL,NIL,op1);
END Inc2;
PROCEDURE Inc3*(VAR result: Operations.Operand; op1: Operations.Operand);
BEGIN
Op(inc,op1,NIL,NIL,result);
END Inc3;
PROCEDURE Dec*(op1: Operations.Operand): Operations.Operand;
VAR
result: Operations.Operand;
BEGIN
result := NIL;
Op(dec,op1,NIL,NIL,result);
RETURN result
END Dec;
PROCEDURE Dec2*(VAR op1: Operations.Operand);
BEGIN
Op(dec,op1,NIL,NIL,op1);
END Dec2;
PROCEDURE Dec3*(VAR result: Operations.Operand; op1: Operations.Operand);
BEGIN
Op(dec,op1,NIL,NIL,result);
END Dec3;
PROCEDURE Mod*(op1, op2: Operations.Operand): Operations.Operand;
VAR
result: Operations.Operand;
BEGIN
result := NIL;
Op(mod, op1, op2, NIL, result);
RETURN result
END Mod;
PROCEDURE Mod2*(VAR op1: Operations.Operand; op2: Operations.Operand);
BEGIN
Op(mod, op1, op2, NIL, op1);
END Mod2;
PROCEDURE Mod3*(VAR result: Operations.Operand; op1, op2: Operations.Operand);
BEGIN
Op(mod, op1, op2, NIL, result);
END Mod3;
PROCEDURE Pow*(op1, op2: Operations.Operand): Operations.Operand;
VAR
result : Operand;
BEGIN
result := NIL;
(*Op(pow, op1, op2, NIL, result);*)
Op(pow, op1, op2, NIL, SYSTEM.VAL(Operations.Operand, result)); (* -- noch *)
RETURN result
END Pow;
PROCEDURE Pow2*(VAR op1: Operations.Operand; op2: Operations.Operand);
BEGIN
Op(pow, op1, op2, NIL, op1);
END Pow2;
PROCEDURE Pow3*(VAR result: Operations.Operand; op1, op2: Operations.Operand);
BEGIN
Op(pow, op1, op2, NIL, result);
END Pow3;
PROCEDURE MMul*(op1, op2, op3: Operations.Operand): Operations.Operand;
VAR
result : Operand;
BEGIN
result := NIL;
(*Op(mmul, op1, op2, op3, result); *)
Op(mmul, op1, op2, op3, SYSTEM.VAL(Operations.Operand, result)); (* --noch*)
RETURN result
END MMul;
PROCEDURE MMul2*(VAR op1: Operations.Operand; op2, op3: Operations.Operand);
BEGIN
Op(mmul, op1, op2, op3, op1);
END MMul2;
PROCEDURE MMul3*(VAR result: Operations.Operand;
op1, op2, op3: Operations.Operand);
BEGIN
Op(mmul, op1, op2, op3, result);
END MMul3;
PROCEDURE MPow*(op1, op2, op3: Operations.Operand): Operations.Operand;
VAR
result : Operand;
BEGIN
result := NIL;
(*Op(mpow, op1, op2, op3, result); *)
Op(mpow, op1, op2, op3, SYSTEM.VAL(Operations.Operand, result)); (* -- noch*)
RETURN result
END MPow;
PROCEDURE MPow2*(VAR op1: Operations.Operand; op2, op3: Operations.Operand);
BEGIN
Op(mpow, op1, op2, op3, op1);
END MPow2;
PROCEDURE MPow3*(VAR result: Operations.Operand;
op1, op2, op3: Operations.Operand);
BEGIN
Op(mpow, op1, op2, op3, result);
END MPow3;
BEGIN
PersistentObjects.RegisterType(operandType,"IntOperations.Operand",
"Operations.Operand", NIL);
END ulmIntOperations.

216
src/library/ulm/ulmLoader.Mod Normal file
View file

@ -0,0 +1,216 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Loader.om,v 1.3 2004/09/03 09:46:50 borchert Exp $
----------------------------------------------------------------------------
$Log: Loader.om,v $
Revision 1.3 2004/09/03 09:46:50 borchert
error events are also raised as global events
(this allows to log all failed loading operations)
Revision 1.2 1996/01/04 16:48:33 borchert
support for dynamic loading of service providers added
Revision 1.1 1994/02/22 20:08:13 borchert
Initial revision
----------------------------------------------------------------------------
AFB 6/93
----------------------------------------------------------------------------
*)
MODULE ulmLoader;
(* load and initialize modules *)
IMPORT ASCII := ulmASCII , Events := ulmEvents, Priorities := ulmPriorities, RelatedEvents := ulmRelatedEvents, Services := ulmServices;
CONST
loadService* = 0;
TYPE
CapabilitySet* = SET; (* loadService..loadService *)
LoadProc* = PROCEDURE (module: ARRAY OF CHAR;
errors: RelatedEvents.Object) : BOOLEAN;
LoadServiceProc* = PROCEDURE (service, for: ARRAY OF CHAR;
errors: RelatedEvents.Object) : BOOLEAN;
Interface* = POINTER TO InterfaceRec;
InterfaceRec* =
RECORD
load*: LoadProc;
loadService*: LoadServiceProc;
END;
CONST
noInterface* = 0; (* SetInterface has not been called yet *)
moduleNotLoaded* = 1; (* interface procedure returned FALSE *)
servicesNotSupported* = 2; (* no dynamic loading of service providers *)
serviceNotLoaded* = 3; (* interface procedure returned FALSE *)
errorcodes* = 4;
TYPE
ErrorEvent* = POINTER TO ErrorEventRec;
ErrorEventRec* =
RECORD
(Events.EventRec)
errorcode*: SHORTINT;
module*: Events.Message; (* module or service name *)
for*: Events.Message; (* type name for serviceNotLoaded *)
END;
VAR
errormsg*: ARRAY errorcodes OF Events.Message;
error*: Events.EventType;
VAR
loadif: Interface; loadcaps: CapabilitySet;
(* commented out because Loader must not import Streams, Errors
and Strings to avoid reference cycles
PROCEDURE WriteErrorEvent(s: Streams.Stream; event: Events.Event);
PROCEDURE WriteString(string: ARRAY OF CHAR);
BEGIN
IF ~Streams.WritePart(s, string, 0, Strings.Len(string)) THEN END;
END WriteString;
PROCEDURE WriteChar(ch: CHAR);
BEGIN
IF ~Streams.WriteByte(s, ch) THEN END;
END WriteChar;
BEGIN
WITH event: ErrorEvent DO
WriteChar(ASCII.quote);
WriteString(event.module);
WriteChar(ASCII.quote);
IF event.for # "" THEN
WriteString(" for ");
WriteChar(ASCII.quote);
WriteString(event.for);
WriteChar(ASCII.quote);
END;
WriteString(": ");
WriteString(event.message);
END;
END WriteErrorEvent;
*)
PROCEDURE InitErrorHandling;
BEGIN
Events.Define(error);
Events.SetPriority(error, Priorities.liberrors);
Events.Ignore(error);
(* Errors.AssignWriteProcedure(error, WriteErrorEvent); *)
errormsg[noInterface] := "Loader.SetInterface has not been called yet";
errormsg[moduleNotLoaded] := "module cannot be loaded";
errormsg[servicesNotSupported] :=
"dynamic loading of service providers is not supported";
errormsg[serviceNotLoaded] :=
"serving module cannot be loaded";
END InitErrorHandling;
PROCEDURE SetInterface*(if: Interface; caps: CapabilitySet);
BEGIN
loadif := if; loadcaps := caps;
END SetInterface;
PROCEDURE Load*(module: ARRAY OF CHAR;
errors: RelatedEvents.Object) : BOOLEAN;
PROCEDURE Error(errorcode: SHORTINT);
VAR
event: ErrorEvent;
BEGIN
NEW(event);
event.type := error;
event.message := errormsg[errorcode];
event.errorcode := errorcode;
COPY(module, event.module);
event.for[0] := 0X;
RelatedEvents.Raise(errors, event);
Events.Raise(event);
END Error;
BEGIN
IF loadif = NIL THEN
Error(noInterface); RETURN FALSE
ELSE
IF ~loadif.load(module, errors) THEN
Error(moduleNotLoaded); RETURN FALSE
END;
RETURN TRUE
END;
END Load;
PROCEDURE LoadService*(service, for: ARRAY OF CHAR;
errors: RelatedEvents.Object) : BOOLEAN;
PROCEDURE Error(errorcode: SHORTINT);
VAR
event: ErrorEvent;
BEGIN
NEW(event);
event.type := error;
event.message := errormsg[errorcode];
event.errorcode := errorcode;
COPY(service, event.module);
COPY(for, event.for);
RelatedEvents.Raise(errors, event);
Events.Raise(event);
END Error;
BEGIN
IF loadif = NIL THEN
Error(noInterface); RETURN FALSE
ELSIF ~(loadService IN loadcaps) THEN
Error(servicesNotSupported); RETURN FALSE
ELSIF ~loadif.loadService(service, for, errors) THEN
Error(serviceNotLoaded); RETURN FALSE
ELSE
RETURN TRUE
END;
END LoadService;
(* === support of Services =========================================== *)
PROCEDURE LService(service, for: ARRAY OF CHAR) : BOOLEAN;
BEGIN
RETURN LoadService(service, for, RelatedEvents.null)
END LService;
PROCEDURE LModule(module: ARRAY OF CHAR) : BOOLEAN;
BEGIN
RETURN Load(module, RelatedEvents.null)
END LModule;
PROCEDURE InitServices;
VAR
if: Services.LoaderInterface;
BEGIN
NEW(if);
if.loadService := LService;
if.loadModule := LModule;
Services.InitLoader(if);
END InitServices;
BEGIN
loadif := NIL; loadcaps := {};
InitErrorHandling;
InitServices;
END ulmLoader.

183
src/library/ulm/ulmMC68881.Mod Normal file
View file

@ -0,0 +1,183 @@
(* Oberon Library - SunOS 4.1 - AFB 8/90 *)
(* (c) University of Ulm, Sektion Informatik, D-7900 Ulm *)
MODULE ulmMC68881;
(* library interface to MC68881 instructions *)
IMPORT SYS := SYSTEM;
CONST
available* = FALSE; (* TRUE if MC68881 present *)
(* rounding modes *)
toNearest* = 0;
towardZero* = 1;
towardMinusInfinity* = 2;
towardPlusInfinity* = 3;
(* rounding precision *)
extended* = 0;
single* = 1;
double* = 2;
(* exceptions *)
branchOnUnordered* = 0;
signalingNotANumber* = 1;
operandError* = 2;
overflow* = 3;
underflow* = 4;
divideByZero* = 5;
inexactOperation* = 6;
inexactDecimalInput* = 7;
CONST
floatlen* = 4; (* length of a single precision real number *)
(* monadic operations *)
PROCEDURE FACOS*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FACOS;
PROCEDURE FASIN*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FASIN;
PROCEDURE FATAN*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FATAN;
PROCEDURE FATANH*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FATANH;
PROCEDURE FCOS*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FCOS;
PROCEDURE FCOSH*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FCOSH;
PROCEDURE FETOX*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FETOX;
PROCEDURE FETOXM1*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FETOXM1;
PROCEDURE FGETEXP*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FGETEXP;
PROCEDURE FGETMAN*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FGETMAN;
PROCEDURE FLOG10*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FLOG10;
PROCEDURE FLOG2*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FLOG2;
PROCEDURE FLOGN*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FLOGN;
PROCEDURE FLOGNP1*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FLOGNP1;
PROCEDURE FSIN*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FSIN;
PROCEDURE FSINH*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FSINH;
PROCEDURE FSQRT*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FSQRT;
PROCEDURE FTAN*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FTAN;
PROCEDURE FTANH*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FTANH;
PROCEDURE FTENTOX*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FTENTOX;
PROCEDURE FTWOTOX*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FTWOTOX;
PROCEDURE GetExceptionEnable*(VAR exceptions: SET);
BEGIN
exceptions := {};
END GetExceptionEnable;
PROCEDURE SetExceptionEnable*(exceptions: SET);
BEGIN
exceptions := {};
END SetExceptionEnable;
PROCEDURE GetRoundingMode*(VAR precision, mode: INTEGER);
BEGIN
precision := 1;
mode := 2;
END GetRoundingMode;
PROCEDURE SetRoundingMode*(precision, mode: INTEGER);
BEGIN
precision := 1;
mode := 2;
END SetRoundingMode;
(* conversions to and from single precision (C's float);
float must consist of at least floatlen bytes
*)
PROCEDURE RealToFloat*(real: LONGREAL; VAR float: ARRAY OF SYS.BYTE);
BEGIN
(*SYS.WMOVE(SYS.ADR(real), SYS.ADR(float), floatlen DIV 4);*)
END RealToFloat;
PROCEDURE FloatToReal*(float: ARRAY OF SYS.BYTE; VAR real: LONGREAL);
BEGIN
(*SYS.WMOVE(SYS.ADR(float), SYS.ADR(real), floatlen DIV 4);*)
END FloatToReal;
END ulmMC68881.

546
src/library/ulm/ulmNetIO.Mod Normal file
View file

@ -0,0 +1,546 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: NetIO.om,v 1.4 2004/05/21 15:19:03 borchert Exp $
----------------------------------------------------------------------------
$Log: NetIO.om,v $
Revision 1.4 2004/05/21 15:19:03 borchert
performance improvements:
- ReadConstStringD prefers Streams.ReadPart and ConstStrings.CreateD,
if possible
(based on code by Christian Ehrhardt)
- WriteConstString uses Streams.Copy instead of a loop that uses
Streams.ReadByte and Streams.WriteByte
Revision 1.3 1995/03/17 16:28:20 borchert
- SizeOf stuff removed
- support of const strings added
- support of Forwarders added
Revision 1.2 1994/07/18 14:18:37 borchert
unused variables of WriteString (ch + index) removed
Revision 1.1 1994/02/22 20:08:43 borchert
Initial revision
----------------------------------------------------------------------------
AFB 6/93
----------------------------------------------------------------------------
*)
MODULE ulmNetIO;
(* abstraction for the exchange of Oberon base types which
are components of persistent data structures
*)
IMPORT ConstStrings := ulmConstStrings, Disciplines := ulmDisciplines, Forwarders := ulmForwarders, Streams := ulmStreams, Strings := ulmStrings,
SYS := SYSTEM, Types := ulmTypes;
TYPE
Byte* = Types.Byte;
TYPE
ReadByteProc* =
PROCEDURE (s: Streams.Stream; VAR byte: Byte) : BOOLEAN;
ReadCharProc* =
PROCEDURE (s: Streams.Stream; VAR char: CHAR) : BOOLEAN;
ReadBooleanProc* =
PROCEDURE (s: Streams.Stream; VAR boolean: BOOLEAN) : BOOLEAN;
ReadShortIntProc* =
PROCEDURE (s: Streams.Stream; VAR shortint: SHORTINT) : BOOLEAN;
ReadIntegerProc* =
PROCEDURE (s: Streams.Stream; VAR integer: INTEGER) : BOOLEAN;
ReadLongIntProc* =
PROCEDURE (s: Streams.Stream; VAR longint: LONGINT) : BOOLEAN;
ReadRealProc* =
PROCEDURE (s: Streams.Stream; VAR real: REAL) : BOOLEAN;
ReadLongRealProc* =
PROCEDURE (s: Streams.Stream; VAR longreal: LONGREAL) : BOOLEAN;
ReadSetProc* =
PROCEDURE (s: Streams.Stream; VAR set: SET) : BOOLEAN;
ReadStringProc* =
PROCEDURE (s: Streams.Stream; VAR string: ARRAY OF CHAR) : BOOLEAN;
ReadConstStringProc* =
PROCEDURE (s: Streams.Stream; domain: ConstStrings.Domain;
VAR string: ConstStrings.String) : BOOLEAN;
WriteByteProc* =
PROCEDURE (s: Streams.Stream; byte: Byte) : BOOLEAN;
WriteCharProc* =
PROCEDURE (s: Streams.Stream; char: CHAR) : BOOLEAN;
WriteBooleanProc* =
PROCEDURE (s: Streams.Stream; boolean: BOOLEAN) : BOOLEAN;
WriteShortIntProc* =
PROCEDURE (s: Streams.Stream; shortint: SHORTINT) : BOOLEAN;
WriteIntegerProc* =
PROCEDURE (s: Streams.Stream; integer: INTEGER) : BOOLEAN;
WriteLongIntProc* =
PROCEDURE (s: Streams.Stream; longint: LONGINT) : BOOLEAN;
WriteRealProc* =
PROCEDURE (s: Streams.Stream; real: REAL) : BOOLEAN;
WriteLongRealProc* =
PROCEDURE (s: Streams.Stream; longreal: LONGREAL) : BOOLEAN;
WriteSetProc* =
PROCEDURE (s: Streams.Stream; set: SET) : BOOLEAN;
WriteStringProc* =
PROCEDURE (s: Streams.Stream; string: ARRAY OF CHAR) : BOOLEAN;
WriteConstStringProc* =
PROCEDURE (s: Streams.Stream;
string: ConstStrings.String) : BOOLEAN;
Interface* = POINTER TO InterfaceRec;
InterfaceRec* =
RECORD
readByte*: ReadByteProc;
readChar*: ReadCharProc;
readBoolean*: ReadBooleanProc;
readShortInt*: ReadShortIntProc;
readInteger*: ReadIntegerProc;
readLongInt*: ReadLongIntProc;
readReal*: ReadRealProc;
readLongReal*: ReadLongRealProc;
readSet*: ReadSetProc;
readString*: ReadStringProc;
readConstString*: ReadConstStringProc;
writeByte*: WriteByteProc;
writeChar*: WriteCharProc;
writeBoolean*: WriteBooleanProc;
writeShortInt*: WriteShortIntProc;
writeInteger*: WriteIntegerProc;
writeLongInt*: WriteLongIntProc;
writeReal*: WriteRealProc;
writeLongReal*: WriteLongRealProc;
writeSet*: WriteSetProc;
writeString*: WriteStringProc;
writeConstString*: WriteConstStringProc;
END;
(* private data structures *)
TYPE
Discipline = POINTER TO DisciplineRec;
DisciplineRec =
RECORD
(Disciplines.DisciplineRec)
if: Interface;
END;
VAR
discID: Disciplines.Identifier;
PROCEDURE Swap (VAR a : ARRAY OF SYS.BYTE);
VAR
i,j : LONGINT;
tmp : SYS.BYTE;
BEGIN
i := 0; j := LEN (a) - 1;
WHILE i < j DO
tmp := a[i]; a[i] := a[j]; a[j] := tmp;
INC (i); DEC (j);
END;
END Swap;
PROCEDURE BitSwap (VAR a : ARRAY OF SYS.BYTE);
VAR
i,old, bit : LONGINT;
new : LONGINT;
BEGIN
i := 0;
WHILE i < LEN (a) DO
old := ORD (SYS.VAL (CHAR, a[i]));
new := 0; bit := 080H;
WHILE old # 0 DO
IF ODD (old) THEN
INC (new, bit);
END;
bit := ASH (bit, -1);;
old := ASH (old, -1);
END;
a[i] := SYS.VAL (SYS.BYTE, new);
INC (i);
END;
END BitSwap;
PROCEDURE ^ Forward(from, to: Forwarders.Object);
PROCEDURE AttachInterface*(s: Streams.Stream; if: Interface);
VAR
disc: Discipline;
BEGIN
IF if # NIL THEN
NEW(disc); disc.id := discID; disc.if := if;
Disciplines.Add(s, disc);
ELSE
Disciplines.Remove(s, discID);
END;
Forwarders.Update(s, Forward);
END AttachInterface;
PROCEDURE GetInterface(s: Streams.Stream; VAR if: Interface);
VAR
disc: Discipline;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
if := disc.if;
ELSE
if := NIL;
END;
END GetInterface;
PROCEDURE CopyInterface*(from, to: Streams.Stream);
VAR
if: Interface;
BEGIN
GetInterface(from, if);
AttachInterface(to, if);
END CopyInterface;
PROCEDURE Forward(from, to: Forwarders.Object);
BEGIN
(* this check is necessary because of Forwarders.Update *)
IF ~(from IS Streams.Stream) OR ~(to IS Streams.Stream) THEN
RETURN
END;
WITH from: Streams.Stream DO WITH to: Streams.Stream DO
(* be careful here, from & to must be reversed *)
CopyInterface(to, from);
END; END;
END Forward;
PROCEDURE ReadByte*(s: Streams.Stream; VAR byte: Byte) : BOOLEAN;
VAR
disc: Discipline;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.readByte(s, byte)
ELSE
RETURN Streams.ReadByte(s, byte)
END;
END ReadByte;
PROCEDURE ReadChar*(s: Streams.Stream; VAR char: CHAR) : BOOLEAN;
VAR
disc: Discipline;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.readChar(s, char)
ELSE
RETURN Streams.ReadByte(s, char)
END;
END ReadChar;
PROCEDURE ReadBoolean*(s: Streams.Stream; VAR boolean: BOOLEAN) : BOOLEAN;
VAR
disc: Discipline;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.readBoolean(s, boolean)
ELSE
RETURN Streams.Read(s, boolean)
END;
END ReadBoolean;
PROCEDURE ReadShortInt*(s: Streams.Stream; VAR shortint: SHORTINT) : BOOLEAN;
VAR
disc: Discipline;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.readShortInt(s, shortint)
ELSE
RETURN Streams.ReadByte(s, shortint)
END;
END ReadShortInt;
PROCEDURE ReadInteger*(s: Streams.Stream; VAR integer: INTEGER) : BOOLEAN;
VAR
disc: Discipline;
ret : BOOLEAN;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.readInteger(s, integer)
ELSE
ret := Streams.Read(s, integer);
IF Types.byteorder = Types.littleEndian THEN
Swap (integer);
END;
RETURN ret;
END;
END ReadInteger;
PROCEDURE ReadLongInt*(s: Streams.Stream; VAR longint: LONGINT) : BOOLEAN;
VAR
disc: Discipline;
ret : BOOLEAN;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.readLongInt(s, longint)
ELSE
ret := Streams.Read(s, longint);
IF Types.byteorder = Types.littleEndian THEN
Swap (longint);
END;
RETURN ret;
END;
END ReadLongInt;
PROCEDURE ReadReal*(s: Streams.Stream; VAR real: REAL) : BOOLEAN;
VAR
disc: Discipline;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.readReal(s, real)
ELSE
RETURN Streams.Read(s, real)
END;
END ReadReal;
PROCEDURE ReadLongReal*(s: Streams.Stream; VAR longreal: LONGREAL) : BOOLEAN;
VAR
disc: Discipline;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.readLongReal(s, longreal)
ELSE
RETURN Streams.Read(s, longreal)
END;
END ReadLongReal;
PROCEDURE ReadSet*(s: Streams.Stream; VAR set: SET) : BOOLEAN;
VAR
disc: Discipline;
ret : BOOLEAN;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.readSet(s, set)
ELSE
ret := Streams.Read(s, set);
IF Types.byteorder = Types.littleEndian THEN
BitSwap (set);
END;
RETURN ret;
END;
END ReadSet;
PROCEDURE ReadString*(s: Streams.Stream; VAR string: ARRAY OF CHAR) : BOOLEAN;
VAR
disc: Discipline;
ch: CHAR; index: LONGINT;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.readString(s, string)
ELSE
index := 0;
WHILE Streams.ReadByte(s, ch) & (ch # 0X) DO
IF index + 1 < LEN(string) THEN
string[index] := ch; INC(index);
END;
END;
string[index] := 0X;
RETURN ~s.error
END;
END ReadString;
PROCEDURE ReadConstStringD*(s: Streams.Stream;
domain: ConstStrings.Domain;
VAR string: ConstStrings.String) : BOOLEAN;
CONST
bufsize = 512;
VAR
length: LONGINT;
buf: Streams.Stream;
ch: CHAR;
disc: Discipline;
stringbuf: ARRAY bufsize OF CHAR;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.readConstString(s, domain, string)
ELSE
IF ReadLongInt(s, length) THEN
IF length >= bufsize THEN
ConstStrings.Init(buf);
IF ~Streams.Copy(s, buf, length) THEN
RETURN FALSE
END;
ConstStrings.CloseD(buf, domain, string);
RETURN length = s.count;
ELSE
IF ~Streams.ReadPart(s, stringbuf, 0, length) THEN
RETURN FALSE
END;
stringbuf[length] := 0X;
ConstStrings.CreateD(string, domain, stringbuf);
RETURN TRUE
END;
ELSE
RETURN FALSE
END;
END;
END ReadConstStringD;
PROCEDURE ReadConstString*(s: Streams.Stream;
VAR string: ConstStrings.String) : BOOLEAN;
BEGIN
RETURN ReadConstStringD(s, ConstStrings.std, string)
END ReadConstString;
PROCEDURE WriteByte*(s: Streams.Stream; byte: Byte) : BOOLEAN;
VAR
disc: Discipline;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.writeByte(s, byte)
ELSE
RETURN Streams.WriteByte(s, byte)
END;
END WriteByte;
PROCEDURE WriteChar*(s: Streams.Stream; char: CHAR) : BOOLEAN;
VAR
disc: Discipline;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.writeChar(s, char)
ELSE
RETURN Streams.WriteByte(s, char)
END;
END WriteChar;
PROCEDURE WriteBoolean*(s: Streams.Stream; boolean: BOOLEAN) : BOOLEAN;
VAR
disc: Discipline;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.writeBoolean(s, boolean)
ELSE
RETURN Streams.Write(s, boolean)
END;
END WriteBoolean;
PROCEDURE WriteShortInt*(s: Streams.Stream; shortint: SHORTINT) : BOOLEAN;
VAR
disc: Discipline;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.writeShortInt(s, shortint)
ELSE
RETURN Streams.WriteByte(s, shortint)
END;
END WriteShortInt;
PROCEDURE WriteInteger*(s: Streams.Stream; integer: INTEGER) : BOOLEAN;
VAR
disc: Discipline;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.writeInteger(s, integer)
ELSE
IF Types.byteorder = Types.littleEndian THEN
Swap (integer);
END;
RETURN Streams.Write(s, integer);
END;
END WriteInteger;
PROCEDURE WriteLongInt*(s: Streams.Stream; longint: LONGINT) : BOOLEAN;
VAR
disc: Discipline;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.writeLongInt(s, longint)
ELSE
IF Types.byteorder = Types.littleEndian THEN
Swap (longint);
END;
RETURN Streams.Write(s, longint);
END;
END WriteLongInt;
PROCEDURE WriteReal*(s: Streams.Stream; real: REAL) : BOOLEAN;
VAR
disc: Discipline;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.writeReal(s, real)
ELSE
RETURN Streams.Write(s, real)
END;
END WriteReal;
PROCEDURE WriteLongReal*(s: Streams.Stream; longreal: LONGREAL) : BOOLEAN;
VAR
disc: Discipline;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.writeLongReal(s, longreal)
ELSE
RETURN Streams.Write(s, longreal)
END;
END WriteLongReal;
PROCEDURE WriteSet*(s: Streams.Stream; set: SET) : BOOLEAN;
VAR
disc: Discipline;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.writeSet(s, set)
ELSE
IF Types.byteorder = Types.littleEndian THEN
BitSwap (set);
END;
RETURN Streams.Write(s, set)
END;
END WriteSet;
PROCEDURE WriteString*(s: Streams.Stream; string: ARRAY OF CHAR) : BOOLEAN;
VAR
disc: Discipline;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.writeString(s, string)
ELSE
RETURN Streams.WritePart(s, string, 0, Strings.Len(string)) &
Streams.WriteByte(s, 0X)
END;
END WriteString;
PROCEDURE WriteConstString*(s: Streams.Stream;
string: ConstStrings.String) : BOOLEAN;
VAR
ch: CHAR;
buf: Streams.Stream;
disc: Discipline;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.writeConstString(s, string)
ELSE
IF WriteLongInt(s, string.len) THEN
ConstStrings.Open(buf, string);
RETURN Streams.Copy(buf, s, string.len)
ELSE
RETURN FALSE
END;
END;
END WriteConstString;
BEGIN
discID := Disciplines.Unique();
Forwarders.Register("Streams.Stream", Forward);
END ulmNetIO.

39
src/library/ulm/ulmObjects.Mod Normal file
View file

@ -0,0 +1,39 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Objects.om,v 1.1 1994/02/22 20:08:53 borchert Exp $
----------------------------------------------------------------------------
$Log: Objects.om,v $
Revision 1.1 1994/02/22 20:08:53 borchert
Initial revision
----------------------------------------------------------------------------
AFB 6/89
----------------------------------------------------------------------------
*)
MODULE ulmObjects;
(* common base of all record definitions of the library *)
TYPE
Object* = POINTER TO ObjectRec;
ObjectRec* = RECORD END;
END ulmObjects.

234
src/library/ulm/ulmOperations.Mod Normal file
View file

@ -0,0 +1,234 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Operations.om,v 1.4 2004/09/16 18:31:54 borchert Exp $
----------------------------------------------------------------------------
$Log: Operations.om,v $
Revision 1.4 2004/09/16 18:31:54 borchert
optimization for Assign added in case of a non-NIL target
and identical types for target and source
Revision 1.3 1997/02/05 16:27:45 borchert
Init asserts now that Services.Init hat been called previously
for ``op''
Revision 1.2 1995/01/16 21:39:50 borchert
- assertions of Assertions have been converted into real assertions
- some fixes due to changes of PersistentObjects
Revision 1.1 1994/02/22 20:09:03 borchert
Initial revision
----------------------------------------------------------------------------
AFB 12/91
----------------------------------------------------------------------------
*)
MODULE ulmOperations;
(* generic support of arithmetic operations *)
IMPORT Events := ulmEvents, Objects := ulmObjects, PersistentDisciplines := ulmPersistentDisciplines, PersistentObjects := ulmPersistentObjects, Services := ulmServices;
CONST
add* = 0; sub* = 1; mul* = 2; div* = 3; cmp* = 4;
TYPE
Operation* = SHORTINT; (* add..cmp *)
Operand* = POINTER TO OperandRec;
TYPE
CapabilitySet* = SET; (* SET OF [add..cmp] *)
CreateProc* = PROCEDURE (VAR op: Operand);
(* should call Operations.Init for op *)
OperatorProc* = PROCEDURE (op: Operation; op1, op2: Operand;
VAR result: Operand);
AssignProc* = PROCEDURE (VAR target: Operand; source: Operand);
CompareProc* = PROCEDURE (op1, op2: Operand) : INTEGER;
Interface* = POINTER TO InterfaceRec;
InterfaceRec* =
RECORD
(Objects.ObjectRec)
create*: CreateProc;
assign*: AssignProc;
op*: OperatorProc;
compare*: CompareProc;
END;
TYPE
OperandRec* =
RECORD
(PersistentDisciplines.ObjectRec)
if: Interface;
caps: CapabilitySet;
END;
VAR
operandType: Services.Type;
PROCEDURE Init*(op: Operand; if: Interface; caps: CapabilitySet);
VAR
type: Services.Type;
BEGIN
Services.GetType(op, type); ASSERT(type # NIL);
op.if := if; op.caps := caps;
END Init;
PROCEDURE Capabilities*(op: Operand) : CapabilitySet;
BEGIN
RETURN op.caps
END Capabilities;
PROCEDURE Compatible*(op1, op2: Operand) : BOOLEAN;
(* return TRUE if both operands have the same interface *)
BEGIN
RETURN op1.if = op2.if
END Compatible;
(* the interface of the first operand must match the interface
of all other operands;
the result parameter must be either NIL or already initialized
with the same interface
*)
PROCEDURE Op(op: Operation; op1, op2: Operand; VAR result: Operand);
VAR
tmpresult: Operand;
BEGIN
ASSERT(op1.if = op2.if);
ASSERT(op IN op1.caps);
(* we are very defensive here because the type of tmpresult
is perhaps not identical to result or an extension of it;
op1.if.create(result) will not work in all cases
because of type guard failures
*)
op1.if.create(tmpresult);
op1.if.op(op, op1, op2, tmpresult);
result := tmpresult;
END Op;
PROCEDURE Add*(op1, op2: Operand) : Operand;
VAR result: Operand;
BEGIN
result := NIL;
Op(add, op1, op2, result);
RETURN result
END Add;
PROCEDURE Add2*(VAR op1: Operand; op2: Operand);
BEGIN
Op(add, op1, op2, op1);
END Add2;
PROCEDURE Add3*(VAR result: Operand; op1, op2: Operand);
BEGIN
Op(add, op1, op2, result);
END Add3;
PROCEDURE Sub*(op1, op2: Operand) : Operand;
VAR result: Operand;
BEGIN
result := NIL;
Op(sub, op1, op2, result);
RETURN result
END Sub;
PROCEDURE Sub2*(VAR op1: Operand; op2: Operand);
BEGIN
Op(sub, op1, op2, op1);
END Sub2;
PROCEDURE Sub3*(VAR result: Operand; op1, op2: Operand);
BEGIN
Op(sub, op1, op2, result);
END Sub3;
PROCEDURE Mul*(op1, op2: Operand) : Operand;
VAR result: Operand;
BEGIN
result := NIL;
Op(mul, op1, op2, result);
RETURN result
END Mul;
PROCEDURE Mul2*(VAR op1: Operand; op2: Operand);
BEGIN
Op(mul, op1, op2, op1);
END Mul2;
PROCEDURE Mul3*(VAR result: Operand; op1, op2: Operand);
BEGIN
Op(mul, op1, op2, result);
END Mul3;
PROCEDURE Div*(op1, op2: Operand) : Operand;
VAR result: Operand;
BEGIN
result := NIL;
Op(div, op1, op2, result);
RETURN result
END Div;
PROCEDURE Div2*(VAR op1: Operand; op2: Operand);
BEGIN
Op(div, op1, op2, op1);
END Div2;
PROCEDURE Div3*(VAR result: Operand; op1, op2: Operand);
BEGIN
Op(div, op1, op2, result);
END Div3;
PROCEDURE Compare*(op1, op2: Operand) : INTEGER;
BEGIN
ASSERT(op1.if = op2.if);
ASSERT(cmp IN op1.caps);
RETURN op1.if.compare(op1, op2)
END Compare;
PROCEDURE Assign*(VAR target: Operand; source: Operand);
VAR
tmpTarget: Operand;
typesIdentical: BOOLEAN;
targetType, sourceType: Services.Type;
BEGIN
IF (target # NIL) & (target.if = source.if) THEN
Services.GetType(target, targetType);
Services.GetType(source, sourceType);
typesIdentical := targetType = sourceType;
ELSE
typesIdentical := FALSE;
END;
IF typesIdentical THEN
source.if.assign(target, source);
ELSE
source.if.create(tmpTarget);
source.if.assign(tmpTarget, source);
target := tmpTarget;
END;
END Assign;
PROCEDURE Copy*(source, target: Operand);
BEGIN
source.if.assign(target, source);
END Copy;
BEGIN
PersistentObjects.RegisterType(operandType,
"Operations.Operand", "PersistentDisciplines.Object", NIL);
END ulmOperations.

391
src/library/ulm/ulmPersistentDisciplines.Mod Normal file
View file

@ -0,0 +1,391 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: PersistentD.om,v 1.4 1998/02/22 10:25:22 borchert Exp $
----------------------------------------------------------------------------
$Log: PersistentD.om,v $
Revision 1.4 1998/02/22 10:25:22 borchert
bug fix in GetObject: Disciplines.Add was missing if the main object
is just an extension of Disciplines.Object and not of
PersistentDisciplines.Object
Revision 1.3 1996/07/24 07:41:28 borchert
bug fix: count component was not initialized (with the
exception of CreateObject) -- detected by Martin Hasch
Revision 1.2 1995/03/17 16:13:33 borchert
- persistent disciplines may now be attached to non-persistent objects
- some fixes due to changes of PersistentObjects
Revision 1.1 1994/02/22 20:09:12 borchert
Initial revision
----------------------------------------------------------------------------
*)
MODULE ulmPersistentDisciplines;
IMPORT Disciplines := ulmDisciplines, Forwarders := ulmForwarders, NetIO := ulmNetIO, Objects := ulmObjects, PersistentObjects := ulmPersistentObjects,
Services := ulmServices, Streams := ulmStreams, SYS := SYSTEM;
CONST
objectName = "PersistentDisciplines.Object";
disciplineName = "PersistentDisciplines.Discipline";
TYPE
Identifier* = LONGINT;
Discipline* = POINTER TO DisciplineRec;
DisciplineRec* =
RECORD
(PersistentObjects.ObjectRec)
id*: Identifier; (* should be unique for all types of disciplines *)
END;
DisciplineList = POINTER TO DisciplineListRec;
DisciplineListRec =
RECORD
discipline: Discipline;
id: Identifier; (* copied from discipline.id *)
next: DisciplineList;
END;
Interface = POINTER TO InterfaceRec;
Object = POINTER TO ObjectRec;
ObjectRec* =
RECORD
(PersistentObjects.ObjectRec)
(* private part *)
count: LONGINT; (* number of attached disciplines *)
list: DisciplineList; (* set of disciplines *)
if: Interface; (* overrides builtins if # NIL *)
forwardTo: Object;
usedBy: Object; (* used as target of UseInterfaceOf *)
(* very restrictive way of avoiding reference cycles:
forwardTo references must be built from inner to
outer objects and not vice versa
*)
END;
TYPE
VolatileDiscipline = POINTER TO VolatileDisciplineRec;
VolatileDisciplineRec =
RECORD
(Disciplines.DisciplineRec)
object: Object;
END;
VAR
volDiscID: Disciplines.Identifier;
TYPE
AddProc* = PROCEDURE (object: Disciplines.Object; discipline: Discipline);
RemoveProc* = PROCEDURE (object: Disciplines.Object; id: Identifier);
SeekProc* = PROCEDURE (object: Disciplines.Object; id: Identifier;
VAR discipline: Discipline) : BOOLEAN;
InterfaceRec* =
RECORD
(Objects.ObjectRec)
add*: AddProc;
remove*: RemoveProc;
seek*: SeekProc;
END;
VAR
unique: Identifier;
objIf: PersistentObjects.Interface;
objDatatype, discDatatype: Services.Type;
CONST
hashtabsize = 32;
TYPE
Sample = POINTER TO SampleRec;
SampleRec =
RECORD
id: Identifier;
sample: Discipline;
next: Sample;
END;
BucketTable = ARRAY hashtabsize OF Sample;
VAR
samples: BucketTable;
PROCEDURE CreateObject*(VAR object: Object);
(* creates a new object; this procedures should be called instead of
NEW for objects of type `Object'
*)
BEGIN
NEW(object);
object.count := 0; (* up to now, there are no attached disciplines *)
object.list := NIL;
object.if := NIL;
PersistentObjects.Init(object, objDatatype);
END CreateObject;
PROCEDURE GetObject(obj: Disciplines.Object; VAR object: Object);
VAR
disc: VolatileDiscipline;
BEGIN
IF obj IS Object THEN
object := obj(Object);
(* initialize private components now if not done already;
we assume here that pointers which have not been
initialized yet are defined to be NIL
(because of the garbage collection);
a similar assumption does not necessarily hold for
other types (e.g. integers)
*)
IF object.list = NIL THEN
object.count := 0;
END;
ELSIF Disciplines.Seek(obj, volDiscID, SYS.VAL(Disciplines.Discipline, disc)) THEN
object := disc.object;
ELSE
CreateObject(object);
NEW(disc); disc.id := volDiscID; disc.object := object;
Disciplines.Add(obj, disc);
END;
END GetObject;
(* === normal stuff for disciplines ===================================== *)
PROCEDURE Unique*(sample: Discipline) : Identifier;
(* returns a unique identifier;
this procedure should be called during initialization by
all modules defining a discipline type;
a sample of the associated discipline has to be provided
*)
VAR
hashval: Identifier;
entry: Sample;
BEGIN
INC(unique);
NEW(entry); entry.id := unique; entry.sample := sample;
hashval := unique MOD hashtabsize;
entry.next := samples[hashval]; samples[hashval] := entry;
RETURN unique
END Unique;
PROCEDURE GetSample*(id: Identifier) : Discipline;
(* return sample for the given identifier;
NIL will be returned if id has not yet been returned by Unique
*)
VAR
hashval: Identifier;
ptr: Sample;
BEGIN
hashval := id MOD hashtabsize;
ptr := samples[hashval];
WHILE (ptr # NIL) & (ptr.id # id) DO
ptr := ptr.next;
END;
IF ptr # NIL THEN
RETURN ptr.sample
ELSE
RETURN NIL
END;
END GetSample;
PROCEDURE AttachInterface*(object: Disciplines.Object; if: Interface);
(* override the builtin implementations of Add, Remove and
Seek for `object' with the implementations given by `if'
*)
VAR
po: Object;
BEGIN
GetObject(object, po);
IF (po.list = NIL) & (po.forwardTo = NIL) THEN
po.if := if;
END;
END AttachInterface;
PROCEDURE UseInterfaceOf*(object, host: Disciplines.Object);
(* forward Add, Remove and Seek operations from object to host *)
VAR
po, phost: Object;
BEGIN
GetObject(object, po); GetObject(host, phost);
IF (po.list = NIL) & (po.forwardTo = NIL) &
(po.usedBy = NIL) THEN
po.forwardTo := phost;
phost.usedBy := po; (* avoid reference cycles *)
END;
END UseInterfaceOf;
PROCEDURE Forward(from, to: Forwarders.Object);
BEGIN
UseInterfaceOf(from, to);
END Forward;
PROCEDURE Remove*(object: Disciplines.Object; id: Identifier);
(* remove the discipline with the given id from object, if it exists *)
VAR
po: Object;
prev, dl: DisciplineList;
BEGIN
GetObject(object, po);
WHILE po.forwardTo # NIL DO
po := po.forwardTo;
END;
IF po.if = NIL THEN
prev := NIL;
dl := po.list;
WHILE (dl # NIL) & (dl.id # id) DO
prev := dl; dl := dl.next;
END;
IF dl # NIL THEN
IF prev = NIL THEN
po.list := dl.next;
ELSE
prev.next := dl.next;
END;
DEC(po.count); (* discipline removed *)
END;
ELSE
po.if.remove(po, id);
END;
END Remove;
PROCEDURE Add*(object: Disciplines.Object; discipline: Discipline);
(* adds a new discipline to the given object;
if already a discipline with the same identifier exist
it is deleted first
*)
VAR
po: Object;
dl: DisciplineList;
BEGIN
GetObject(object, po);
WHILE po.forwardTo # NIL DO
po := po.forwardTo;
END;
IF po.if = NIL THEN
dl := po.list;
WHILE (dl # NIL) & (dl.id # discipline.id) DO
dl := dl.next;
END;
IF dl = NIL THEN
NEW(dl);
dl.id := discipline.id;
dl.next := po.list;
po.list := dl;
INC(po.count); (* discipline added *)
END;
dl.discipline := discipline;
ELSE
po.if.add(po, discipline);
END;
END Add;
PROCEDURE Seek*(object: Disciplines.Object; id: Identifier;
VAR discipline: Discipline) : BOOLEAN;
(* returns TRUE if a discipline with the given id is found *)
VAR
po: Object;
dl: DisciplineList;
BEGIN
GetObject(object, po);
WHILE po.forwardTo # NIL DO
po := po.forwardTo;
END;
IF po.if = NIL THEN
dl := po.list;
WHILE (dl # NIL) & (dl.id # id) DO
dl := dl.next;
END;
IF dl # NIL THEN
discipline := dl.discipline;
ELSE
discipline := NIL;
END;
RETURN discipline # NIL
ELSE
RETURN po.if.seek(po, id, discipline)
END;
END Seek;
(* === interface procedures for PersistentObjects for Object === *)
PROCEDURE ReadObjectData(stream: Streams.Stream;
object: PersistentObjects.Object) : BOOLEAN;
(* read data and attached disciplines of given object from stream *)
VAR
discipline: Discipline;
count: LONGINT;
BEGIN
(* get number of attached disciplines *)
IF ~NetIO.ReadLongInt(stream, count) THEN
RETURN FALSE;
END;
(* read all disciplines from `stream' and attach them to `object' *)
WHILE count > 0 DO
IF ~PersistentObjects.Read(stream, SYS.VAL(PersistentObjects.Object, discipline)) THEN
RETURN FALSE;
END;
Add(object(Object), discipline);
DEC(count);
END;
RETURN TRUE;
END ReadObjectData;
PROCEDURE WriteObjectData(stream: Streams.Stream;
object: PersistentObjects.Object) : BOOLEAN;
(* write data and attached disciplines of given object to stream *)
VAR
dl: DisciplineList;
BEGIN
WITH object: Object DO
(* write number of attached disciplines to `stream' *)
IF ~NetIO.WriteLongInt(stream, object.count) THEN
RETURN FALSE;
END;
(* write all attached disciplines to the stream *)
dl := object.list;
WHILE dl # NIL DO
IF ~PersistentObjects.Write(stream, dl.discipline) THEN
RETURN FALSE;
END;
dl := dl.next;
END;
END;
RETURN TRUE;
END WriteObjectData;
PROCEDURE InternalCreate(VAR obj: PersistentObjects.Object);
VAR
myObject: Object;
BEGIN
CreateObject(myObject);
obj := myObject;
END InternalCreate;
BEGIN
unique := 0;
NEW(objIf);
objIf.read := ReadObjectData;
objIf.write := WriteObjectData;
objIf.create := InternalCreate;
objIf.createAndRead := NIL;
PersistentObjects.RegisterType(objDatatype, objectName, "", objIf);
PersistentObjects.RegisterType(discDatatype, disciplineName, "", NIL);
volDiscID := Disciplines.Unique();
Forwarders.Register("", Forward);
END ulmPersistentDisciplines.

1078
src/library/ulm/ulmPersistentObjects.Mod Normal file
View file

File diff suppressed because it is too large Load diff

268
src/library/ulm/ulmPlotters.Mod Normal file
View file

@ -0,0 +1,268 @@
(* Ulm's Oberon Library
Copyright (C) 1989-2004 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Plotters.om,v 1.1 2004/04/08 12:30:29 borchert Exp borchert $
----------------------------------------------------------------------------
$Log: Plotters.om,v $
Revision 1.1 2004/04/08 12:30:29 borchert
Initial revision
----------------------------------------------------------------------------
*)
MODULE ulmPlotters;
IMPORT Events := ulmEvents, Objects := ulmObjects, Resources := ulmResources, Services := ulmServices, SYS := ulmSYSTEM;
TYPE
Plotter* = POINTER TO PlotterRec;
CONST
solid* = 0;
dotted* = 1;
dotdashed* = 2;
shortdashed* = 3;
longdashed* = 4;
lineModes* = 5;
TYPE
LineMode* = SHORTINT; (* solid ... *)
CONST
setspace* = 0;
erase* = 1;
string* = 2;
linemodes* = 3;
linewidth* = 4;
TYPE
CapabilitySet* = SET; (* OF setspace, erase ... *)
TYPE
Description* = POINTER TO DescriptionRec;
DescriptionRec* =
RECORD
(Objects.ObjectRec)
xmin*, ymin, xmax, ymax: INTEGER; (* maximal supported range *)
END;
TYPE
GetSpaceProc* = PROCEDURE (
plotter: Plotter;
VAR xmin, ymin, xmax, ymax: INTEGER);
SetSpaceProc* = PROCEDURE (
plotter: Plotter;
xmin, ymin, xmax, ymax: INTEGER);
EraseProc* = PROCEDURE (plotter: Plotter);
MoveProc* = PROCEDURE (plotter: Plotter; xto, yto: INTEGER);
LineProc* = PROCEDURE (plotter: Plotter; xfrom, yfrom, xto, yto: INTEGER);
ArcProc* = PROCEDURE (
plotter: Plotter;
xcenter, ycenter, xstart, ystart, xend, yend: INTEGER);
CircleProc* = PROCEDURE (
plotter: Plotter; xcenter, ycenter, radius: INTEGER);
StringProc* = PROCEDURE (plotter: Plotter; str: ARRAY OF CHAR);
SetLineModeProc* = PROCEDURE (plotter: Plotter; mode: LineMode);
SetLineWidthProc* = PROCEDURE (plotter: Plotter; width: INTEGER);
CloseProc* = PROCEDURE (plotter: Plotter);
TYPE
Interface* = POINTER TO InterfaceRec;
InterfaceRec* =
RECORD
(Objects.ObjectRec)
setSpace*: SetSpaceProc;
erase*: EraseProc;
move*: MoveProc;
cont*: MoveProc;
point*: MoveProc;
line*: LineProc;
arc*: ArcProc;
circle*: CircleProc;
string*: StringProc;
setLineMode*: SetLineModeProc;
setLineWidth*: SetLineWidthProc;
close*: CloseProc;
END;
TYPE
PlotterRec* =
RECORD
(Services.ObjectRec)
if: Interface;
caps: CapabilitySet;
desc: Description;
xmin, ymin, xmax, ymax: INTEGER; (* current range *)
terminated: BOOLEAN;
END;
VAR
plotterType: Services.Type;
PROCEDURE InitModule;
BEGIN
Services.CreateType(plotterType, "Plotters.Plotter", "");
END InitModule;
PROCEDURE ^ Close*(plotter: Plotter);
PROCEDURE TerminationHandler(event: Events.Event);
VAR
plotter: Plotter;
BEGIN
WITH event: Resources.Event DO
IF event.change IN {Resources.terminated, Resources.unreferenced} THEN
Close(event.resource(Plotter));
END;
END;
END TerminationHandler;
PROCEDURE Init*(plotter: Plotter; if: Interface;
caps: CapabilitySet; desc: Description);
VAR
eventType: Events.EventType;
BEGIN
ASSERT((if # NIL) & (if.move # NIL) & (if.cont # NIL) &
(if.point # NIL) & (if.line # NIL) & (if.arc # NIL) &
(if.circle # NIL));
ASSERT(~(setspace IN caps) OR (if.setSpace # NIL));
ASSERT(~(erase IN caps) OR (if.erase # NIL));
ASSERT(~(string IN caps) OR (if.string # NIL));
ASSERT(~(linemodes IN caps) OR (if.setLineMode # NIL));
ASSERT(~(linewidth IN caps) OR (if.setLineWidth # NIL));
ASSERT((desc.xmin < desc.xmax) & (desc.ymin < desc.ymax));
plotter.if := if;
plotter.caps := caps;
plotter.desc := desc;
plotter.xmin := desc.xmin;
plotter.xmax := desc.xmax;
plotter.ymin := desc.ymin;
plotter.ymax := desc.ymax;
plotter.terminated := FALSE;
Resources.TakeInterest(plotter, eventType);
Events.Handler(eventType, TerminationHandler);
END Init;
PROCEDURE GetCapabilities*(plotter: Plotter) : CapabilitySet;
BEGIN
RETURN plotter.caps
END GetCapabilities;
PROCEDURE GetSpace*(plotter: Plotter;
VAR xmin, ymin,
xmax, ymax: INTEGER);
BEGIN
xmin := plotter.xmin;
xmax := plotter.xmax;
ymin := plotter.ymin;
ymax := plotter.ymax;
END GetSpace;
PROCEDURE GetMaxSpace*(plotter: Plotter;
VAR xmin, ymin,
xmax, ymax: INTEGER);
BEGIN
xmin := plotter.desc.xmin;
xmax := plotter.desc.xmax;
ymin := plotter.desc.ymin;
ymax := plotter.desc.ymax;
END GetMaxSpace;
PROCEDURE SetSpace*(plotter: Plotter;
xmin, ymin,
xmax, ymax: INTEGER);
BEGIN
ASSERT((xmin < xmax) & (ymin < ymax));
ASSERT((xmin >= plotter.desc.xmin) &
(xmax <= plotter.desc.xmax) &
(ymin >= plotter.desc.ymin) &
(ymax <= plotter.desc.ymax));
ASSERT(setspace IN plotter.caps);
plotter.if.setSpace(plotter, xmin, ymin, xmax, ymax);
plotter.xmin := xmin;
plotter.ymin := ymin;
plotter.xmax := xmax;
plotter.ymax := ymax;
END SetSpace;
PROCEDURE Erase*(plotter: Plotter);
BEGIN
ASSERT(erase IN plotter.caps);
plotter.if.erase(plotter);
END Erase;
PROCEDURE Move*(plotter: Plotter; xto, yto: INTEGER);
BEGIN
plotter.if.move(plotter, xto, yto);
END Move;
PROCEDURE Cont*(plotter: Plotter; xto, yto: INTEGER);
BEGIN
plotter.if.cont(plotter, xto, yto);
END Cont;
PROCEDURE Point*(plotter: Plotter; xpoint, ypoint: INTEGER);
BEGIN
plotter.if.point(plotter, xpoint, ypoint);
END Point;
PROCEDURE Line*(plotter: Plotter; xfrom, yfrom, xto, yto: INTEGER);
BEGIN
plotter.if.line(plotter, xfrom, yfrom, xto, yto);
END Line;
PROCEDURE Arc*(plotter: Plotter;
xcenter, ycenter, xstart, ystart, xend, yend: INTEGER);
BEGIN
plotter.if.arc(plotter, xcenter, ycenter, xstart, ystart, xend, yend);
END Arc;
PROCEDURE Circle*(plotter: Plotter; xcenter, ycenter, radius: INTEGER);
BEGIN
plotter.if.circle(plotter, xcenter, ycenter, radius);
END Circle;
PROCEDURE String*(plotter: Plotter; str: ARRAY OF CHAR);
BEGIN
ASSERT(string IN plotter.caps);
plotter.if.string(plotter, str);
END String;
PROCEDURE SetLineMode*(plotter: Plotter; mode: LineMode);
BEGIN
ASSERT((linemodes IN plotter.caps) & (mode >= 0) & (mode < lineModes));
plotter.if.setLineMode(plotter, mode);
END SetLineMode;
PROCEDURE SetLineWidth*(plotter: Plotter; width: INTEGER);
BEGIN
ASSERT((linewidth IN plotter.caps) & (width > 0));
plotter.if.setLineWidth(plotter, width);
END SetLineWidth;
PROCEDURE Close*(plotter: Plotter);
BEGIN
IF ~SYS.TAS(plotter.terminated) THEN
IF plotter.if.close # NIL THEN
plotter.if.close(plotter);
END;
Resources.Notify(plotter, Resources.terminated);
plotter.if := NIL; plotter.desc := NIL;
END;
END Close;
BEGIN
InitModule;
END ulmPlotters.

964
src/library/ulm/ulmPrint.Mod Normal file
View file

@ -0,0 +1,964 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Print.om,v 1.3 2004/05/21 12:08:43 borchert Exp $
----------------------------------------------------------------------------
$Log: Print.om,v $
Revision 1.3 2004/05/21 12:08:43 borchert
bug fix: NaNs and other invalid floating point numbers weren't
checked for
Revision 1.2 1996/09/18 07:47:41 borchert
support of SYSTEM.INT16 added
Revision 1.1 1994/02/23 07:46:28 borchert
Initial revision
----------------------------------------------------------------------------
AFB 6/89
----------------------------------------------------------------------------
*)
MODULE ulmPrint;
(* formatted printing;
Print.F[0-9] prints to Streams.stdout
formats are close to those of printf(3)
*)
IMPORT Events := ulmEvents, IEEE := ulmIEEE, Priorities := ulmPriorities, Reals := ulmReals, RelatedEvents := ulmRelatedEvents, StreamDisciplines := ulmStreamDisciplines,
Streams := ulmStreams, SYS := SYSTEM;
CONST
tooManyArgs* = 0; (* too many arguments given *)
tooFewArgs* = 1; (* too few arguments given *)
badFormat* = 2; (* syntax error in format string *)
badArgumentSize* = 3; (* bad size of argument *)
errors* = 4;
TYPE
FormatString* = ARRAY 128 OF CHAR;
ErrorCode* = SHORTINT;
ErrorEvent* = POINTER TO ErrorEventRec;
ErrorEventRec* =
RECORD
(Events.EventRec)
errorcode*: ErrorCode;
format*: FormatString;
errpos*: LONGINT;
nargs*: INTEGER;
END;
VAR
error*: Events.EventType;
errormsg*: ARRAY errors OF Events.Message;
(* === private part ============================================= *)
PROCEDURE InitErrorHandling;
BEGIN
Events.Define(error); Events.SetPriority(error, Priorities.liberrors);
errormsg[tooManyArgs] := "too many arguments given";
errormsg[tooFewArgs] := "too few arguments given";
errormsg[badFormat] := "syntax error in format string";
errormsg[badArgumentSize] :=
"size of argument doesn't conform to the corresponding format element";
END InitErrorHandling;
PROCEDURE Out(out: Streams.Stream; VAR fmt: ARRAY OF CHAR; nargs: INTEGER;
VAR p1,p2,p3,p4,p5,p6,p7,p8,p9: ARRAY OF SYS.BYTE;
errors: RelatedEvents.Object);
CONST
maxargs = 9; (* maximal number of arguments *)
maxargsize = SIZE(LONGREAL); (* maximal arg size (except strings) *)
fmtcmd = "%";
escape = "\";
VAR
arglen: ARRAY maxargs OF LONGINT;
nextarg: INTEGER;
fmtindex: LONGINT;
fmtchar: CHAR;
hexcharval: LONGINT;
PROCEDURE Error(errorcode: ErrorCode);
VAR
event: ErrorEvent;
BEGIN
NEW(event);
event.type := error;
event.message := errormsg[errorcode];
event.errorcode := errorcode;
COPY(fmt, event.format);
event.errpos := fmtindex;
event.nargs := nargs;
RelatedEvents.Raise(errors, event);
END Error;
PROCEDURE Next() : BOOLEAN;
BEGIN
IF fmtindex < LEN(fmt) THEN
fmtchar := fmt[fmtindex]; INC(fmtindex);
IF fmtchar = 0X THEN
fmtindex := LEN(fmt);
RETURN FALSE
ELSE
RETURN TRUE
END;
ELSE
RETURN FALSE
END;
END Next;
PROCEDURE Unget;
BEGIN
IF (fmtindex > 0) & (fmtindex < LEN(fmt)) THEN
DEC(fmtindex); fmtchar := fmt[fmtindex];
ELSE
fmtchar := 0X;
END;
END Unget;
PROCEDURE Write(byte: SYS.BYTE);
BEGIN
IF Streams.WriteByte(out, byte) THEN
INC(out.count);
END;
END Write;
PROCEDURE WriteLn;
VAR
lineterm: StreamDisciplines.LineTerminator;
i: INTEGER;
BEGIN
StreamDisciplines.GetLineTerm(out, lineterm);
Write(lineterm[0]);
i := 1;
WHILE (i < LEN(lineterm)) & (lineterm[i] # 0X) DO
Write(lineterm[i]); INC(i);
END;
END WriteLn;
PROCEDURE Int(VAR int: LONGINT; base: INTEGER) : BOOLEAN;
PROCEDURE ValidDigit(ch: CHAR) : BOOLEAN;
BEGIN
RETURN (ch >= "0") & (ch <= "9") OR
(base = 16) & (CAP(ch) >= "A") & (CAP(ch) <= "F")
END ValidDigit;
BEGIN
int := 0;
REPEAT
int := int * base;
IF (fmtchar >= "0") & (fmtchar <= "9") THEN
INC(int, LONG(ORD(fmtchar) - ORD("0")));
ELSIF (base = 16) &
(CAP(fmtchar) >= "A") & (CAP(fmtchar) <= "F") THEN
INC(int, LONG(10 + ORD(CAP(fmtchar)) - ORD("A")));
ELSE
RETURN FALSE
END;
UNTIL ~Next() OR ~ValidDigit(fmtchar);
RETURN TRUE
END Int;
PROCEDURE SetSize;
VAR
index: INTEGER;
BEGIN
index := 0;
WHILE index < nargs DO
CASE index OF
| 0: arglen[index] := LEN(p1);
| 1: arglen[index] := LEN(p2);
| 2: arglen[index] := LEN(p3);
| 3: arglen[index] := LEN(p4);
| 4: arglen[index] := LEN(p5);
| 5: arglen[index] := LEN(p6);
| 6: arglen[index] := LEN(p7);
| 7: arglen[index] := LEN(p8);
| 8: arglen[index] := LEN(p9);
END;
INC(index);
END;
END SetSize;
PROCEDURE Access(par: INTEGER; at: LONGINT) : SYS.BYTE;
BEGIN
CASE par OF
| 0: RETURN p1[at]
| 1: RETURN p2[at]
| 2: RETURN p3[at]
| 3: RETURN p4[at]
| 4: RETURN p5[at]
| 5: RETURN p6[at]
| 6: RETURN p7[at]
| 7: RETURN p8[at]
| 8: RETURN p9[at]
END;
END Access;
PROCEDURE Convert(from: INTEGER; VAR to: ARRAY OF SYS.BYTE);
VAR i: INTEGER;
BEGIN
i := 0;
WHILE i < arglen[from] DO
to[i] := Access(from, i); INC(i);
END;
END Convert;
PROCEDURE GetInt(index: INTEGER; VAR long: LONGINT) : BOOLEAN;
(* access index-th parameter (counted from 0);
fails if arglen[index] > SIZE(LONGINT)
*)
VAR
short: SHORTINT;
(*int16: SYS.INT16;*)
int: INTEGER;
BEGIN
IF arglen[index] = SIZE(SHORTINT) THEN
Convert(index, short); long := short;
(*ELSIF arglen[index] = SIZE(SYS.INT16) THEN
Convert(index, int16); long := int16;*)
ELSIF arglen[index] = SIZE(INTEGER) THEN
Convert(index, int); long := int;
ELSIF arglen[index] = SIZE(LONGINT) THEN
Convert(index, long);
ELSE
Error(badArgumentSize);
RETURN FALSE
END;
RETURN TRUE
END GetInt;
PROCEDURE Format() : BOOLEAN;
VAR
fillch: CHAR; (* filling character *)
insert: BOOLEAN; (* insert between sign and 1st digit *)
sign: BOOLEAN; (* sign even positive values *)
leftaligned: BOOLEAN; (* output left aligned *)
width, scale: LONGINT;
PROCEDURE NextArg(VAR index: INTEGER) : BOOLEAN;
BEGIN
IF nextarg < nargs THEN
index := nextarg; INC(nextarg); RETURN TRUE
ELSE
RETURN FALSE
END;
END NextArg;
PROCEDURE Flags() : BOOLEAN;
BEGIN
fillch := " "; insert := FALSE; sign := FALSE;
leftaligned := FALSE;
REPEAT
CASE fmtchar OF
| "+": sign := TRUE;
| "0": fillch := "0"; insert := TRUE;
| "-": leftaligned := TRUE;
| "^": insert := TRUE;
| "\": IF ~Next() THEN RETURN FALSE END; fillch := fmtchar;
ELSE
RETURN TRUE
END;
UNTIL ~Next();
Error(badFormat);
RETURN FALSE (* unexpected end *)
END Flags;
PROCEDURE FetchInt(VAR int: LONGINT) : BOOLEAN;
VAR
index: INTEGER;
BEGIN
RETURN (fmtchar = "*") & Next() &
NextArg(index) & GetInt(index, int) OR
Int(int, 10) & (int >= 0)
END FetchInt;
PROCEDURE Width() : BOOLEAN;
BEGIN
IF (fmtchar >= "0") & (fmtchar <= "9") OR (fmtchar = "*") THEN
IF FetchInt(width) THEN
RETURN TRUE
END;
Error(badFormat); RETURN FALSE
ELSE
width := 0;
RETURN TRUE
END;
END Width;
PROCEDURE Scale() : BOOLEAN;
BEGIN
IF fmtchar = "." THEN
IF Next() & FetchInt(scale) THEN
RETURN TRUE
ELSE
Error(badFormat); RETURN FALSE
END;
ELSE
scale := -1; RETURN TRUE
END;
END Scale;
PROCEDURE Conversion() : BOOLEAN;
PROCEDURE Fill(cnt: LONGINT);
(* cnt: space used by normal output *)
VAR i: LONGINT;
BEGIN
IF cnt < width THEN
i := width - cnt;
WHILE i > 0 DO
Write(fillch);
DEC(i);
END;
END;
END Fill;
PROCEDURE FillLeft(cnt: LONGINT);
BEGIN
IF ~leftaligned THEN
Fill(cnt);
END;
END FillLeft;
PROCEDURE FillRight(cnt: LONGINT);
BEGIN
IF leftaligned THEN
Fill(cnt);
END;
END FillRight;
PROCEDURE WriteBool(true, false: ARRAY OF CHAR) : BOOLEAN;
VAR index: INTEGER; val: LONGINT;
PROCEDURE WriteString(VAR s: ARRAY OF CHAR);
VAR i, len: INTEGER;
BEGIN
len := 0;
WHILE (len < LEN(s)) & (s[len] # 0X) DO
INC(len);
END;
FillLeft(len);
i := 0;
WHILE i < len DO
Write(s[i]); INC(i);
END;
FillRight(len);
END WriteString;
BEGIN
IF NextArg(index) & GetInt(index, val) THEN
IF val = 0 THEN
WriteString(false); RETURN TRUE
ELSIF val = 1 THEN
WriteString(true); RETURN TRUE
END;
END;
RETURN FALSE
END WriteBool;
PROCEDURE WriteChar() : BOOLEAN;
VAR
val: LONGINT;
index: INTEGER;
BEGIN
IF NextArg(index) & GetInt(index, val) &
(val >= 0) & (val <= ORD(MAX(CHAR))) THEN
FillLeft(1);
Write(CHR(val));
FillRight(1);
RETURN TRUE
END;
RETURN FALSE
END WriteChar;
PROCEDURE WriteInt(base: INTEGER) : BOOLEAN;
VAR
index: INTEGER;
val: LONGINT;
neg: BOOLEAN; (* set by Convert *)
buf: ARRAY 12 OF CHAR; (* filled by Convert *)
i: INTEGER;
len: INTEGER; (* space needed for val *)
signcnt: INTEGER; (* =1 if sign printed; else 0 *)
signch: CHAR;
PROCEDURE Convert;
VAR
index: INTEGER;
digit: LONGINT;
BEGIN
neg := val < 0;
index := 0;
REPEAT
digit := val MOD base;
val := val DIV base;
IF neg & (digit > 0) THEN
digit := base - digit;
INC(val);
END;
IF digit < 10 THEN
buf[index] := CHR(ORD("0") + digit);
ELSE
buf[index] := CHR(ORD("A") + digit - 10);
END;
INC(index);
UNTIL val = 0;
len := index;
END Convert;
BEGIN (* WriteInt *)
IF NextArg(index) & GetInt(index, val) THEN
Convert;
IF sign OR neg THEN
signcnt := 1;
IF neg THEN
signch := "-";
ELSE
signch := "+";
END;
ELSE
signcnt := 0;
END;
IF insert & (signcnt = 1) THEN
Write(signch);
END;
FillLeft(len+signcnt);
IF ~insert & (signcnt = 1) THEN
Write(signch);
END;
i := len;
WHILE i > 0 DO
DEC(i); Write(buf[i]);
END;
FillRight(len+signcnt);
RETURN TRUE
END;
RETURN FALSE
END WriteInt;
PROCEDURE WriteReal(format: CHAR) : BOOLEAN;
(* format either "f", "e", or "g" *)
CONST
defaultscale = 6;
VAR
index: INTEGER;
lr: LONGREAL;
r: REAL;
shortint: SHORTINT; int: INTEGER; longint: LONGINT;
(*int16: SYS.INT16;*)
long: BOOLEAN;
exponent: INTEGER;
mantissa: LONGREAL;
digits: ARRAY Reals.maxlongdignum OF CHAR;
neg: BOOLEAN;
ndigits: INTEGER;
decpt: INTEGER;
PROCEDURE Print(decpt: INTEGER; withexp: BOOLEAN; exp: INTEGER);
(* decpt: position of decimal point
= 0: just before the digits
> 0: after decpt digits
< 0: ABS(decpt) zeroes before digits needed
*)
VAR
needed: INTEGER; (* space needed *)
index: INTEGER;
count: LONGINT;
PROCEDURE WriteExp(exp: INTEGER);
CONST
base = 10;
VAR
power: INTEGER;
digit: INTEGER;
BEGIN
IF long THEN
Write("D");
ELSE
Write("E");
END;
IF exp < 0 THEN
Write("-"); exp := - exp;
ELSE
Write("+");
END;
IF long THEN
power := 1000;
ELSE
power := 100;
END;
WHILE power > 0 DO
digit := (exp DIV power) MOD base;
Write(CHR(digit+ORD("0")));
power := power DIV base;
END;
END WriteExp;
BEGIN (* Print *)
(* leading digits *)
IF decpt > 0 THEN
needed := decpt;
ELSE
needed := 1;
END;
IF neg OR sign THEN
INC(needed);
END;
IF withexp OR (scale # 0) THEN
INC(needed); (* decimal point *)
END;
IF withexp THEN
INC(needed, 2); (* E[+-] *)
IF long THEN
INC(needed, 4);
ELSE
INC(needed, 3);
END;
END;
INC(needed, SHORT(scale));
FillLeft(needed);
IF neg THEN
Write("-");
ELSIF sign THEN
Write("+");
END;
IF decpt <= 0 THEN
Write("0");
ELSE
index := 0;
WHILE index < decpt DO
IF index < ndigits THEN
Write(digits[index]);
ELSE
Write("0");
END;
INC(index);
END;
END;
IF withexp OR (scale > 0) THEN
Write(".");
END;
IF scale > 0 THEN
count := scale;
index := decpt;
WHILE (index < 0) & (count > 0) DO
Write("0"); INC(index); DEC(count);
END;
WHILE (index < ndigits) & (count > 0) DO
Write(digits[index]); INC(index); DEC(count);
END;
WHILE count > 0 DO
Write("0"); DEC(count);
END;
END;
IF withexp THEN
WriteExp(exp);
END;
FillRight(needed);
END Print;
BEGIN (* WriteReal *)
IF NextArg(index) THEN
IF arglen[index] = SIZE(LONGREAL) THEN
long := TRUE;
Convert(index, lr);
ELSIF arglen[index] = SIZE(REAL) THEN
long := FALSE;
Convert(index, r);
lr := r;
ELSIF arglen[index] = SIZE(LONGINT) THEN
long := FALSE;
Convert(index, longint);
lr := longint;
ELSIF arglen[index] = SIZE(INTEGER) THEN
long := FALSE;
Convert(index, int);
lr := int;
(*ELSIF arglen[index] = SIZE(SYS.INT16) THEN
long := FALSE;
Convert(index, int16);
lr := int16;*)
ELSIF arglen[index] = SIZE(SHORTINT) THEN
long := FALSE;
Convert(index, shortint);
lr := shortint;
ELSE
Error(badArgumentSize); RETURN FALSE
END;
IF scale = -1 THEN
scale := defaultscale;
END;
(* check for NaNs and other invalid numbers *)
IF ~IEEE.Valid(lr) THEN
IF IEEE.NotANumber(lr) THEN
Write("N"); Write("a"); Write("N");
RETURN TRUE
ELSE
IF lr < 0 THEN
Write("-");
ELSE
Write("+");
END;
Write("i"); Write("n"); Write("f");
END;
RETURN TRUE
END;
(* real value in `lr' *)
Reals.ExpAndMan(lr, long, 10, exponent, mantissa);
CASE format OF
| "e": ndigits := SHORT(scale)+1;
| "f": ndigits := SHORT(scale)+exponent+1;
IF ndigits <= 0 THEN
ndigits := 1;
END;
| "g": ndigits := SHORT(scale);
END;
Reals.Digits(mantissa, 10, digits, neg,
(* force = *) format # "g", ndigits);
decpt := 1;
CASE format OF
| "e": Print(decpt, (* withexp = *) TRUE, exponent);
| "f": INC(decpt, exponent);
Print(decpt, (* withexp = *) FALSE, 0);
| "g": IF (exponent < -4) OR (exponent > scale) THEN
scale := ndigits-1;
Print(decpt, (* withexp = *) TRUE, exponent);
ELSE
INC(decpt, exponent);
scale := ndigits-1;
DEC(scale, LONG(exponent));
IF scale < 0 THEN
scale := 0;
END;
Print(decpt, (* withexp = *) FALSE, 0);
END;
END;
RETURN TRUE
ELSE
RETURN FALSE
END;
END WriteReal;
PROCEDURE WriteString() : BOOLEAN;
VAR
index: INTEGER;
i: LONGINT;
byte: SYS.BYTE;
len: LONGINT;
BEGIN
IF NextArg(index) THEN
len := 0;
WHILE (len < arglen[index]) &
((scale = -1) OR (len < scale)) &
((*CHR*)SYS.VAL(CHAR, (Access(index, len))) # 0X) DO
INC(len);
END;
FillLeft(len);
i := 0;
WHILE i < len DO
byte := Access(index, i);
Write(byte);
INC(i);
END;
FillRight(len);
RETURN TRUE
END;
RETURN FALSE
END WriteString;
BEGIN (* Conversion *)
CASE fmtchar OF
| "b": RETURN WriteBool("TRUE", "FALSE")
| "c": RETURN WriteChar()
| "d": RETURN WriteInt(10)
| "e",
"f",
"g": RETURN WriteReal(fmtchar)
| "j": RETURN WriteBool("ja", "nein")
| "o": RETURN WriteInt(8)
| "s": RETURN WriteString()
| "x": RETURN WriteInt(16)
| "y": RETURN WriteBool("yes", "no")
ELSE
Error(badFormat); RETURN FALSE
END;
END Conversion;
BEGIN
IF ~Next() THEN RETURN FALSE END;
IF fmtchar = fmtcmd THEN Write(fmtcmd); RETURN TRUE END;
RETURN Flags() & Width() & Scale() & Conversion()
END Format;
BEGIN
out.count := 0; out.error := FALSE;
SetSize;
nextarg := 0;
fmtindex := 0;
WHILE Next() DO
IF fmtchar = fmtcmd THEN
IF ~Format() THEN
RETURN
END;
ELSIF (fmtchar = "\") & Next() THEN
CASE fmtchar OF
| "0".."9", "A".."F":
IF ~Int(hexcharval, 16) THEN
(* Error(s, BadFormat); *) RETURN
END;
Unget;
Write(CHR(hexcharval));
| "b": Write(08X); (* back space *)
| "e": Write(1BX); (* escape *)
| "f": Write(0CX); (* form feed *)
| "n": WriteLn;
| "q": Write("'");
| "Q": Write(22X); (* double quote: " *)
| "r": Write(0DX); (* carriage return *)
| "t": Write(09X); (* horizontal tab *)
| "&": Write(07X); (* bell *)
ELSE
Write(fmtchar);
END;
ELSE
Write(fmtchar);
END;
END;
IF nextarg < nargs THEN
Error(tooManyArgs);
ELSIF nextarg > nargs THEN
Error(tooFewArgs);
END;
END Out;
(* === public part ============================================== *)
PROCEDURE F*(fmt: ARRAY OF CHAR);
VAR x: INTEGER;
BEGIN
Out(Streams.stdout, fmt, 0, x,x,x,x,x,x,x,x,x, NIL);
END F;
PROCEDURE F1*(fmt: ARRAY OF CHAR; p1: ARRAY OF SYS.BYTE);
VAR x: INTEGER;
BEGIN
Out(Streams.stdout, fmt, 1, p1, x,x,x,x,x,x,x,x, NIL);
END F1;
PROCEDURE F2*(fmt: ARRAY OF CHAR; p1, p2: ARRAY OF SYS.BYTE);
VAR x: INTEGER;
BEGIN
Out(Streams.stdout, fmt, 2, p1,p2, x,x,x,x,x,x,x, NIL);
END F2;
PROCEDURE F3*(fmt: ARRAY OF CHAR; p1, p2, p3: ARRAY OF SYS.BYTE);
VAR x: INTEGER;
BEGIN
Out(Streams.stdout, fmt, 3, p1,p2,p3, x,x,x,x,x,x, NIL);
END F3;
PROCEDURE F4*(fmt: ARRAY OF CHAR; p1, p2, p3, p4: ARRAY OF SYS.BYTE);
VAR x: INTEGER;
BEGIN
Out(Streams.stdout, fmt, 4, p1,p2,p3,p4, x,x,x,x,x, NIL);
END F4;
PROCEDURE F5*(fmt: ARRAY OF CHAR; p1, p2, p3, p4, p5: ARRAY OF SYS.BYTE);
VAR x: INTEGER;
BEGIN
Out(Streams.stdout, fmt, 5, p1,p2,p3,p4,p5, x,x,x,x, NIL);
END F5;
PROCEDURE F6*(fmt: ARRAY OF CHAR; p1, p2, p3, p4, p5, p6: ARRAY OF SYS.BYTE);
VAR x: INTEGER;
BEGIN
Out(Streams.stdout, fmt, 6, p1,p2,p3,p4,p5,p6, x,x,x, NIL);
END F6;
PROCEDURE F7*(fmt: ARRAY OF CHAR; p1, p2, p3, p4, p5, p6, p7: ARRAY OF SYS.BYTE);
VAR x: INTEGER;
BEGIN
Out(Streams.stdout, fmt, 7, p1,p2,p3,p4,p5,p6,p7, x,x, NIL);
END F7;
PROCEDURE F8*(fmt: ARRAY OF CHAR;
p1, p2, p3, p4, p5, p6, p7, p8: ARRAY OF SYS.BYTE);
VAR x: INTEGER;
BEGIN
Out(Streams.stdout, fmt, 8, p1,p2,p3,p4,p5,p6,p7,p8, x, NIL);
END F8;
PROCEDURE F9*(fmt: ARRAY OF CHAR;
p1, p2, p3, p4, p5, p6, p7, p8, p9: ARRAY OF SYS.BYTE);
BEGIN
Out(Streams.stdout, fmt, 9, p1,p2,p3,p4,p5,p6,p7,p8,p9, NIL);
END F9;
PROCEDURE S*(out: Streams.Stream; fmt: ARRAY OF CHAR);
VAR x: INTEGER;
BEGIN
Out(out, fmt, 0, x,x,x,x,x,x,x,x,x, NIL);
END S;
PROCEDURE S1*(out: Streams.Stream; fmt: ARRAY OF CHAR; p1: ARRAY OF SYS.BYTE);
VAR x: INTEGER;
BEGIN
Out(out, fmt, 1, p1, x,x,x,x,x,x,x,x, NIL);
END S1;
PROCEDURE S2*(out: Streams.Stream; fmt: ARRAY OF CHAR; p1, p2: ARRAY OF SYS.BYTE);
VAR x: INTEGER;
BEGIN
Out(out, fmt, 2, p1,p2, x,x,x,x,x,x,x, NIL);
END S2;
PROCEDURE S3*(out: Streams.Stream; fmt: ARRAY OF CHAR; p1, p2, p3: ARRAY OF SYS.BYTE);
VAR x: INTEGER;
BEGIN
Out(out, fmt, 3, p1,p2,p3, x,x,x,x,x,x, NIL);
END S3;
PROCEDURE S4*(out: Streams.Stream; fmt: ARRAY OF CHAR;
p1, p2, p3, p4: ARRAY OF SYS.BYTE);
VAR x: INTEGER;
BEGIN
Out(out, fmt, 4, p1,p2,p3,p4, x,x,x,x,x, NIL);
END S4;
PROCEDURE S5*(out: Streams.Stream; fmt: ARRAY OF CHAR;
p1, p2, p3, p4, p5: ARRAY OF SYS.BYTE);
VAR x: INTEGER;
BEGIN
Out(out, fmt, 5, p1,p2,p3,p4,p5, x,x,x,x, NIL);
END S5;
PROCEDURE S6*(out: Streams.Stream; fmt: ARRAY OF CHAR;
p1, p2, p3, p4, p5, p6: ARRAY OF SYS.BYTE);
VAR x: INTEGER;
BEGIN
Out(out, fmt, 6, p1,p2,p3,p4,p5,p6, x,x,x, NIL);
END S6;
PROCEDURE S7*(out: Streams.Stream; fmt: ARRAY OF CHAR;
p1, p2, p3, p4, p5, p6, p7: ARRAY OF SYS.BYTE);
VAR x: INTEGER;
BEGIN
Out(out, fmt, 7, p1,p2,p3,p4,p5,p6,p7, x,x, NIL);
END S7;
PROCEDURE S8*(out: Streams.Stream; fmt: ARRAY OF CHAR;
p1, p2, p3, p4, p5, p6, p7, p8: ARRAY OF SYS.BYTE);
VAR x: INTEGER;
BEGIN
Out(out, fmt, 8, p1,p2,p3,p4,p5,p6,p7,p8, x, NIL);
END S8;
PROCEDURE S9*(out: Streams.Stream; fmt: ARRAY OF CHAR;
p1, p2, p3, p4, p5, p6, p7, p8, p9: ARRAY OF SYS.BYTE);
BEGIN
Out(out, fmt, 9, p1,p2,p3,p4,p5,p6,p7,p8,p9, NIL);
END S9;
PROCEDURE SE*(out: Streams.Stream; fmt: ARRAY OF CHAR;
errors: RelatedEvents.Object);
VAR x: INTEGER;
BEGIN
Out(out, fmt, 0, x,x,x,x,x,x,x,x,x, NIL);
END SE;
PROCEDURE SE1*(out: Streams.Stream; fmt: ARRAY OF CHAR; p1: ARRAY OF SYS.BYTE;
errors: RelatedEvents.Object);
VAR x: INTEGER;
BEGIN
Out(out, fmt, 1, p1, x,x,x,x,x,x,x,x, errors);
END SE1;
PROCEDURE SE2*(out: Streams.Stream; fmt: ARRAY OF CHAR; p1, p2: ARRAY OF SYS.BYTE;
errors: RelatedEvents.Object);
VAR x: INTEGER;
BEGIN
Out(out, fmt, 2, p1,p2, x,x,x,x,x,x,x, errors);
END SE2;
PROCEDURE SE3*(out: Streams.Stream; fmt: ARRAY OF CHAR;
p1, p2, p3: ARRAY OF SYS.BYTE;
errors: RelatedEvents.Object);
VAR x: INTEGER;
BEGIN
Out(out, fmt, 3, p1,p2,p3, x,x,x,x,x,x, errors);
END SE3;
PROCEDURE SE4*(out: Streams.Stream; fmt: ARRAY OF CHAR;
p1, p2, p3, p4: ARRAY OF SYS.BYTE;
errors: RelatedEvents.Object);
VAR x: INTEGER;
BEGIN
Out(out, fmt, 4, p1,p2,p3,p4, x,x,x,x,x, errors);
END SE4;
PROCEDURE SE5*(out: Streams.Stream; fmt: ARRAY OF CHAR;
p1, p2, p3, p4, p5: ARRAY OF SYS.BYTE;
errors: RelatedEvents.Object);
VAR x: INTEGER;
BEGIN
Out(out, fmt, 5, p1,p2,p3,p4,p5, x,x,x,x, errors);
END SE5;
PROCEDURE SE6*(out: Streams.Stream; fmt: ARRAY OF CHAR;
p1, p2, p3, p4, p5, p6: ARRAY OF SYS.BYTE;
errors: RelatedEvents.Object);
VAR x: INTEGER;
BEGIN
Out(out, fmt, 6, p1,p2,p3,p4,p5,p6, x,x,x, errors);
END SE6;
PROCEDURE SE7*(out: Streams.Stream; fmt: ARRAY OF CHAR;
p1, p2, p3, p4, p5, p6, p7: ARRAY OF SYS.BYTE;
errors: RelatedEvents.Object);
VAR x: INTEGER;
BEGIN
Out(out, fmt, 7, p1,p2,p3,p4,p5,p6,p7, x,x, errors);
END SE7;
PROCEDURE SE8*(out: Streams.Stream; fmt: ARRAY OF CHAR;
p1, p2, p3, p4, p5, p6, p7, p8: ARRAY OF SYS.BYTE;
errors: RelatedEvents.Object);
VAR x: INTEGER;
BEGIN
Out(out, fmt, 8, p1,p2,p3,p4,p5,p6,p7,p8, x, errors);
END SE8;
PROCEDURE SE9*(out: Streams.Stream; fmt: ARRAY OF CHAR;
p1, p2, p3, p4, p5, p6, p7, p8, p9: ARRAY OF SYS.BYTE;
errors: RelatedEvents.Object);
BEGIN
Out(out, fmt, 9, p1,p2,p3,p4,p5,p6,p7,p8,p9, errors);
END SE9;
BEGIN
InitErrorHandling;
END ulmPrint.

155
src/library/ulm/ulmPriorities.Mod Normal file
View file

@ -0,0 +1,155 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Priorities.om,v 1.1 1994/02/22 20:09:33 borchert Exp $
----------------------------------------------------------------------------
$Log: Priorities.om,v $
Revision 1.1 1994/02/22 20:09:33 borchert
Initial revision
----------------------------------------------------------------------------
AFB 9/89
----------------------------------------------------------------------------
*)
MODULE ulmPriorities;
(* defines priority system per initialized variables;
all priorities needed by the Oberon-library (base, sys, and std) are
defined in this module;
the original module of this definition can be copied
and modified to match the needs of a specific application;
the default priority should range in [null..error);
setting the default priority to null allows to take advantage
of default error handling routines in small applications;
the priority system must be open for extensions:
- each priority below defines a base value of a priority region;
the region size is defined by `region';
e.g. legal library error priorities range from
liberrors to liberrors+region-1
- gap defines the minimum distance between two priority regions
defined in this module
*)
CONST
region* = 10;
gap* = 10;
null* = 0; (* lowest priority possible;
this is not a legal priority for events
*)
TYPE
Priority* = INTEGER;
VAR
(* current priority at begin of execution (after init of Events);
this is the lowest priority possible during execution (>= null);
every event with priority less than `base' is ignored
automatically
*)
base*: Priority;
(* default priority of events (if not changed by Events.SetPriority)*)
default*: Priority;
(* priority of messages which do not indicate an error *)
message*: Priority;
(* priority of system call errors *)
syserrors*: Priority;
(* priority of library errors;
e.g. usage errors or failed system calls;
library errors should have higher priority than syserrors
*)
liberrors*: Priority;
(* priority of assertions of library modules *)
assertions*: Priority;
(* priority of (application) error messages or warnings *)
error*: Priority;
(* priority of asynchronous interrupts like
break key, alarm clock, etc.
*)
interrupts*: Priority;
(* priority of ``out of space'' events (SysStorage) *)
storage*: Priority;
(* priority of run time errors *)
rtserrors*: Priority;
(* priority of fatal errors (error message & exit) *)
fatal*: Priority;
(* priority of fatal signals;
e.g. segmentation violation, alignment faults, illegal instructions;
these signals must not be ignored, and
event handlers must not return on such events
(this would cause an infinite loop)
*)
fatalsignals*: Priority;
(* priority of bugs and (failed) assertions;
bugs are error messages followed by exit (with core dump if possible)
*)
bug*: Priority;
(* priority of task switches are at very high priority to
allow the necessary bookkeeping
*)
taskswitch*: Priority;
(* priority of exit and abort;
actions on this priority level should be minimized
and (if possible) error-free
*)
exit*: Priority;
next: Priority; (* next legal priority value *)
PROCEDURE Set(VAR base: Priority);
BEGIN
base := next; INC(next, region+gap);
END Set;
BEGIN
next := null;
Set(base);
Set(default);
Set(message);
Set(syserrors);
Set(liberrors);
Set(assertions);
Set(error);
Set(interrupts);
Set(storage);
Set(rtserrors);
Set(fatal);
Set(fatalsignals);
Set(bug);
Set(taskswitch);
Set(exit);
END ulmPriorities.

203
src/library/ulm/ulmProcess.Mod Normal file
View file

@ -0,0 +1,203 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Process.om,v 1.3 2004/09/10 16:42:31 borchert Exp $
----------------------------------------------------------------------------
$Log: Process.om,v $
Revision 1.3 2004/09/10 16:42:31 borchert
id and host added
Revision 1.2 2004/04/02 17:58:26 borchert
softTermination and TerminateSoftly added
Revision 1.1 1994/02/22 20:09:43 borchert
Initial revision
----------------------------------------------------------------------------
AFB 3/92
----------------------------------------------------------------------------
*)
MODULE ulmProcess;
IMPORT Events := ulmEvents, Priorities := ulmPriorities;
(* user readable name of our process *)
TYPE
Name* = ARRAY 128 OF CHAR;
VAR
name*: Name;
id*: Name; (* something that identifies our process on our host *)
host*: Name; (* something that identifies our host, may be "" *)
(* exit codes *)
TYPE
ExitCode* = INTEGER;
VAR
indicateSuccess*: ExitCode;
indicateFailure*: ExitCode;
(* process events *)
TYPE
ExitEvent* = POINTER TO ExitEventRec;
ExitEventRec* =
RECORD
(Events.EventRec)
exitcode*: ExitCode;
END;
VAR
softTermination*: Events.EventType;
termination*: Events.EventType;
abort*: Events.EventType;
startOfGarbageCollection*, endOfGarbageCollection: Events.EventType;
(* these events indicate beginning and end of a garbage collection *)
TYPE
ExitProc* = PROCEDURE (code: ExitCode);
AbortProc* = PROCEDURE;
PauseProc* = PROCEDURE;
Interface* = POINTER TO InterfaceRec;
InterfaceRec* =
RECORD
exit*: ExitProc;
abort*: AbortProc;
pause*: PauseProc;
END;
(* private declarations *)
VAR
handlers: Interface;
nestlevel: INTEGER;
PROCEDURE SetHandlers*(if: Interface);
BEGIN
handlers := if;
END SetHandlers;
PROCEDURE Exit*(code: ExitCode);
VAR
event: ExitEvent;
BEGIN
INC(nestlevel);
IF nestlevel = 1 THEN
NEW(event);
event.type := termination;
event.message := "exit";
event.exitcode := code;
Events.Raise(event);
END;
handlers.exit(code);
handlers.pause;
LOOP END;
END Exit;
PROCEDURE TerminateSoftly*;
VAR
event: Events.Event;
BEGIN
NEW(event);
event.type := softTermination;
event.message := "terminate, please!";
Events.Raise(event);
END TerminateSoftly;
PROCEDURE Terminate*;
BEGIN
Exit(indicateSuccess);
END Terminate;
PROCEDURE Abort*;
VAR
event: Events.Event;
BEGIN
INC(nestlevel);
IF nestlevel = 1 THEN
NEW(event);
event.type := abort;
event.message := "abort";
Events.Raise(event);
END;
handlers.abort;
handlers.exit(indicateFailure);
handlers.pause;
LOOP END;
END Abort;
PROCEDURE Pause*;
BEGIN
handlers.pause;
END Pause;
(* =============================================================== *)
PROCEDURE AbortHandler(event: Events.Event);
BEGIN
Abort;
END AbortHandler;
(* =============================================================== *)
PROCEDURE DummyExit(code: ExitCode);
BEGIN
LOOP END;
END DummyExit;
PROCEDURE DummyAbort;
BEGIN
LOOP END;
END DummyAbort;
PROCEDURE DummyPause;
BEGIN
LOOP END;
END DummyPause;
BEGIN
nestlevel := 0;
name := "Process.name";
indicateSuccess := 0; indicateFailure := 1;
NEW(handlers);
handlers.exit := DummyExit;
handlers.abort := DummyAbort;
handlers.pause := DummyPause;
Events.Define(termination);
Events.SetPriority(termination, Priorities.exit);
Events.Handler(termination, Events.NilHandler);
Events.Define(abort);
Events.SetPriority(abort, Priorities.exit);
Events.Handler(abort, Events.NilHandler);
Events.Define(softTermination);
Events.SetPriority(softTermination, Priorities.message);
Events.Handler(softTermination, Events.NilHandler);
Events.AbortHandler(AbortHandler);
Events.Define(startOfGarbageCollection);
Events.SetPriority(startOfGarbageCollection, Priorities.message);
Events.Ignore(startOfGarbageCollection);
Events.Define(endOfGarbageCollection);
Events.SetPriority(endOfGarbageCollection, Priorities.message);
Events.Ignore(endOfGarbageCollection);
END ulmProcess.

419
src/library/ulm/ulmRandomGenerators.Mod Normal file
View file

@ -0,0 +1,419 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: RandomGener.om,v 1.9 2004/03/09 21:44:12 borchert Exp $
----------------------------------------------------------------------------
$Log: RandomGener.om,v $
Revision 1.9 2004/03/09 21:44:12 borchert
unpredictable added to the standard set of PRNGs
Revision 1.8 2004/03/06 07:22:09 borchert
Init asserts that the sequence has been registered at Services
Revision 1.7 1998/02/14 22:04:09 martin
Missing calls of Services.Init and Services.CreateType added.
Revision 1.6 1997/10/11 21:22:03 martin
assertion in ValS added, obsolete variable removed
Revision 1.5 1997/10/10 16:26:49 martin
RestartSequence added, range conversions improved,
default implementation replaced.
Revision 1.4 1997/04/01 16:33:41 borchert
major revision of Random:
- module renamed to RandomGenerators
- abstraction instead of simple implementation (work by Frank Fischer)
Revision 1.3 1994/09/01 18:15:41 borchert
bug fix: avoid arithmetic overflow in ValS
Revision 1.2 1994/08/30 09:48:00 borchert
sequences added
Revision 1.1 1994/02/23 07:25:30 borchert
Initial revision
----------------------------------------------------------------------------
original implementation by AFB 2/90
conversion to abstraction by Frank B.J. Fischer 3/97
----------------------------------------------------------------------------
*)
MODULE ulmRandomGenerators;
(* Anyone who considers arithmetical
methods of producing random digits
is, of course, in a state of sin.
- John von Neumann (1951)
*)
IMPORT
Clocks := ulmClocks, Disciplines := ulmDisciplines, Objects := ulmObjects, Operations := ulmOperations, Process := ulmProcess, Services := ulmServices, Times := ulmTimes,
Types := ulmTypes, S := SYSTEM;
TYPE
Sequence* = POINTER TO SequenceRec;
Int32ValSProc* = PROCEDURE (sequence: Sequence): Types.Int32;
LongRealValSProc* = PROCEDURE (sequence: Sequence): LONGREAL;
RewindSequenceProc* = PROCEDURE (sequence: Sequence);
RestartSequenceProc* = PROCEDURE (sequence, seed: Sequence);
SetValSProc* = PROCEDURE (sequence: Sequence; value: Operations.Operand);
CONST
int32ValS* = 0; longRealValS* = 1; rewindSequence* = 2; restartSequence* = 3;
TYPE
CapabilitySet* = SET; (* of [int32ValS..restartSequence] *)
Interface* = POINTER TO InterfaceRec;
InterfaceRec* =
RECORD
(Objects.ObjectRec)
int32ValS* : Int32ValSProc; (* at least one of ... *)
longRealValS* : LongRealValSProc; (* ... these required *)
rewindSequence* : RewindSequenceProc; (* optional *)
restartSequence*: RestartSequenceProc; (* optional *)
END;
SequenceRec* =
RECORD
(Services.ObjectRec)
(* private components *)
if : Interface;
caps: CapabilitySet;
END;
VAR
std* : Sequence; (* default sequence *)
seed*: Sequence; (* sequence of seed values *)
unpredictable*: Sequence;
(* reasonably fast sequence of unpredictable values;
is initially NIL
*)
(* ----- private definitions ----- *)
CONST
modulus1 = 2147483647; (* a Mersenne prime *)
factor1 = 48271; (* passes spectral test *)
quotient1 = modulus1 DIV factor1; (* 44488 *)
remainder1 = modulus1 MOD factor1; (* 3399; must be < quotient1 *)
modulus2 = 2147483399; (* a non-Mersenne prime *)
factor2 = 40692; (* also passes spectral test *)
quotient2 = modulus2 DIV factor2; (* 52774 *)
remainder2 = modulus2 MOD factor2; (* 3791; must be < quotient2 *)
TYPE
DefaultSequence = POINTER TO DefaultSequenceRec;
DefaultSequenceRec =
RECORD
(SequenceRec)
seed1, seed2: LONGINT;
value1, value2: LONGINT;
END;
ServiceDiscipline = POINTER TO ServiceDisciplineRec;
ServiceDisciplineRec =
RECORD
(Disciplines.DisciplineRec)
setValS: SetValSProc;
END;
VAR
service : Services.Service;
serviceDiscID: Disciplines.Identifier;
sequenceType,
defaultSequenceType: Services.Type;
(* ----- bug workaround ----- *)
PROCEDURE Entier(value: LONGREAL): LONGINT;
VAR
result: LONGINT;
BEGIN
result := ENTIER(value);
IF result > value THEN
DEC(result);
END;
RETURN result
END Entier;
(* ----- exported procedures ----- *)
PROCEDURE Init*(sequence: Sequence; if: Interface; caps: CapabilitySet);
(* initialize sequence *)
VAR
type: Services.Type;
BEGIN
ASSERT((if.int32ValS # NIL) OR (if.longRealValS # NIL));
ASSERT(~(int32ValS IN caps) OR (if.int32ValS # NIL));
ASSERT(~(longRealValS IN caps) OR (if.longRealValS # NIL));
ASSERT(~(rewindSequence IN caps) OR (if.rewindSequence # NIL));
Services.GetType(sequence, type); ASSERT(type # NIL);
sequence.if := if;
sequence.caps := caps;
END Init;
PROCEDURE Capabilities*(sequence: Sequence): CapabilitySet;
(* tell which procedures are implemented *)
BEGIN
RETURN sequence.caps
END Capabilities;
PROCEDURE RewindSequence*(sequence: Sequence);
(* re-examine sequence *)
BEGIN
ASSERT(rewindSequence IN sequence.caps);
sequence.if.rewindSequence(sequence);
END RewindSequence;
PROCEDURE RestartSequence*(sequence, seed: Sequence);
(* restart sequence with new seed values *)
BEGIN
ASSERT(restartSequence IN sequence.caps);
sequence.if.restartSequence(sequence, seed);
END RestartSequence;
PROCEDURE ^ LongRealValS*(sequence: Sequence): LONGREAL;
PROCEDURE Int32ValS*(sequence: Sequence): Types.Int32;
(* get random 32-bit value from sequence *)
VAR
real: LONGREAL;
BEGIN
IF int32ValS IN sequence.caps THEN
RETURN sequence.if.int32ValS(sequence)
ELSE
real := LongRealValS(sequence);
RETURN SHORT(Entier( (1. - real - real) * MIN(Types.Int32) ))
END;
END Int32ValS;
PROCEDURE Int32Val*(): Types.Int32;
(* get random 32-bit value from std sequence *)
BEGIN
RETURN Int32ValS(std);
END Int32Val;
PROCEDURE LongRealValS*(sequence: Sequence): LONGREAL;
(* get a uniformly distributed longreal value in [0..1) *)
BEGIN
IF longRealValS IN sequence.caps THEN
RETURN sequence.if.longRealValS(sequence)
ELSE
RETURN 0.5 +
Int32ValS(sequence) / (0. - MIN(Types.Int32) - MIN(Types.Int32))
END;
END LongRealValS;
PROCEDURE LongRealVal*(): LONGREAL;
(* get a uniformly distributed longreal value in [0..1) *)
BEGIN
RETURN LongRealValS(std)
END LongRealVal;
PROCEDURE RealValS*(sequence: Sequence): REAL;
(* get a uniformly distributed real value in [0..1) *)
BEGIN
RETURN SHORT(LongRealValS(sequence))
END RealValS;
PROCEDURE RealVal*(): REAL;
(* get a uniformly distributed real value in [0..1) *)
BEGIN
RETURN SHORT(LongRealValS(std))
END RealVal;
PROCEDURE ValS*(sequence: Sequence; low, high: LONGINT): LONGINT;
(* get a uniformly distributed integer in [low..high] *)
BEGIN
ASSERT(low <= high);
RETURN Entier( low + LongRealValS(sequence) * (1. + high - low) )
END ValS;
PROCEDURE Val*(low, high: LONGINT): LONGINT;
(* get a uniformly distributed integer in [low..high] *)
BEGIN
RETURN ValS(std, low, high)
END Val;
PROCEDURE FlipS*(sequence: Sequence): BOOLEAN;
(* return TRUE or FALSE *)
BEGIN
IF int32ValS IN sequence.caps THEN
RETURN sequence.if.int32ValS(sequence) >= 0
ELSE
RETURN sequence.if.longRealValS(sequence) >= 0.5
END;
END FlipS;
PROCEDURE Flip*(): BOOLEAN;
(* return TRUE or FALSE *)
BEGIN
RETURN FlipS(std)
END Flip;
PROCEDURE Support*(type: Services.Type; setValS: SetValSProc);
(* support service for type *)
VAR
serviceDisc: ServiceDiscipline;
BEGIN
NEW(serviceDisc);
serviceDisc.id := serviceDiscID;
serviceDisc.setValS := setValS;
Disciplines.Add(type, serviceDisc);
Services.Define(type, service, NIL);
END Support;
PROCEDURE SetValS*(sequence: Sequence; value: Operations.Operand);
(* store random value from sequence into already initialized value *)
VAR
baseType : Services.Type;
serviceDisc: ServiceDiscipline;
ok : BOOLEAN;
BEGIN
Services.GetSupportedBaseType(value, service, baseType);
ok := Disciplines.Seek(baseType, serviceDiscID, S.VAL(Disciplines.Discipline, serviceDisc));
ASSERT(ok);
serviceDisc.setValS(sequence, value);
END SetValS;
PROCEDURE SetVal*(value: Operations.Operand);
(* store random value from std sequence into already initialized value *)
BEGIN
SetValS(std, value);
END SetVal;
(* ----- DefaultSequence ----- *)
PROCEDURE CongruentialStep(VAR value1, value2: LONGINT);
BEGIN
value1 :=
factor1 * (value1 MOD quotient1) - remainder1 * (value1 DIV quotient1);
IF value1 < 0 THEN
INC(value1, modulus1);
END;
value2 :=
factor2 * (value2 MOD quotient2) - remainder2 * (value2 DIV quotient2);
IF value2 < 0 THEN
INC(value2, modulus2);
END;
END CongruentialStep;
PROCEDURE DefaultSequenceValue(sequence: Sequence): LONGREAL;
VAR
value: LONGINT;
BEGIN
WITH sequence: DefaultSequence DO
CongruentialStep(sequence.value1, sequence.value2);
value := sequence.value1 - sequence.value2;
IF value <= 0 THEN
INC(value, modulus1);
END;
RETURN (value - 1.) / (modulus1 - 1.)
END;
END DefaultSequenceValue;
PROCEDURE DefaultSequenceRewind(sequence: Sequence);
BEGIN
WITH sequence: DefaultSequence DO
sequence.value1 := sequence.seed1;
sequence.value2 := sequence.seed2;
END;
END DefaultSequenceRewind;
PROCEDURE DefaultSequenceRestart(sequence, seed: Sequence);
BEGIN
WITH sequence: DefaultSequence DO
sequence.seed1 := ValS(seed, 1, modulus1-1);
sequence.seed2 := ValS(seed, 1, modulus2-1);
sequence.value1 := sequence.seed1;
sequence.value2 := sequence.seed2;
END;
END DefaultSequenceRestart;
PROCEDURE CreateDefaultSequences;
VAR
mySeed, myStd: DefaultSequence;
if: Interface;
daytime: Times.Time;
timeval: Times.TimeValueRec;
count: LONGINT;
PROCEDURE Hash(str: ARRAY OF CHAR): LONGINT;
VAR
index,
val: LONGINT;
BEGIN
val := 27567352;
index := 0;
WHILE str[index] # 0X DO
val := (val MOD 16777216) * 128 +
(val DIV 16777216 + ORD(str[index])) MOD 128;
INC(index);
END; (*WHILE*)
RETURN val
END Hash;
BEGIN
(* define interface for all default sequences *)
NEW(if);
if.longRealValS := DefaultSequenceValue;
if.rewindSequence := DefaultSequenceRewind;
if.restartSequence := DefaultSequenceRestart;
(* fake initial randomness using some portably accessible sources *)
NEW(mySeed);
Services.Init(mySeed, defaultSequenceType);
Init(mySeed, if, {longRealValS});
Clocks.GetTime(Clocks.system, daytime);
Times.GetValue(daytime, timeval);
(* extract those 31 bits from daytime that are most likely to vary *)
mySeed.value1 := timeval.usec * 2048 + timeval.second MOD 65536 + 1;
(* generate 31 more bits from the process name *)
mySeed.value2 := Hash(Process.name) MOD (modulus2 - 1) + 1;
(* scramble these values *)
count := 0;
WHILE count < 4 DO
CongruentialStep(mySeed.value1, mySeed.value2);
INC(count);
END;
(* mix them together *)
DefaultSequenceRestart(mySeed, mySeed);
seed := mySeed;
(* now use our seed to initialize std sequence *)
NEW(myStd);
Services.Init(myStd, defaultSequenceType);
Init(myStd, if, {longRealValS, rewindSequence, restartSequence});
DefaultSequenceRestart(myStd, mySeed);
std := myStd;
unpredictable := NIL;
END CreateDefaultSequences;
BEGIN
serviceDiscID := Disciplines.Unique();
Services.Create(service, "RandomGenerators");
Services.CreateType(sequenceType, "RandomGenerators.Sequence", "");
Services.CreateType(defaultSequenceType, "RandomGenerators.DefaultSequence",
"RandomGenerators.Sequence");
CreateDefaultSequences;
END ulmRandomGenerators.

313
src/library/ulm/ulmReals.Mod Normal file
View file

@ -0,0 +1,313 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Reals.om,v 1.2 2004/03/09 21:38:50 borchert Exp $
----------------------------------------------------------------------------
$Log: Reals.om,v $
Revision 1.2 2004/03/09 21:38:50 borchert
maxlongexp, minlongexp, and maxlongdignum adapted to SPARC architecture
Revision 1.1 1994/02/23 07:45:40 borchert
Initial revision
----------------------------------------------------------------------------
AFB 6/89
----------------------------------------------------------------------------
*)
MODULE ulmReals;
IMPORT IEEE := ulmIEEE, MC68881 := ulmMC68881;
CONST
(* for REAL *)
maxexp* = 309;
minexp* = -323;
maxdignum* = 16;
(* for LONGREAL *)
(*
maxlongexp = 4932;
minlongexp = -4951;
maxlongdignum = 19;
*)
maxlongexp* = 309;
minlongexp* = -323;
maxlongdignum* = 16;
powers = 6;
maxbase = 16;
TYPE
PowerRec =
RECORD
p10: LONGREAL;
n: INTEGER;
END;
VAR
powtab: ARRAY powers OF PowerRec;
sigdigits: ARRAY maxbase+1 OF INTEGER; (* valid range: [2..maxbase] *)
PROCEDURE ExpAndMan*(r: LONGREAL; long: BOOLEAN; base: INTEGER;
VAR exponent: INTEGER; VAR mantissa: LONGREAL);
(* get exponent and mantissa from `r':
(1.0 >= ABS(mantissa)) & (ABS(mantissa) < base)
r = mantissa * base^exponent
long should be false if a REAL-value is passed to `r'
valid values of base: 2, 8, 10, and 16
*)
VAR
neg: BOOLEAN;
index: INTEGER;
roundoff: LONGREAL;
i: INTEGER;
ndigits: INTEGER;
BEGIN
IF r = 0.0 THEN
exponent := 0; mantissa := 0; RETURN
ELSIF r = IEEE.plusInfinity THEN
IF long THEN
exponent := 9999;
ELSE
exponent := 999;
END;
mantissa := 1;
RETURN
ELSIF r = IEEE.minusInfinity THEN
IF long THEN
exponent := 9999;
ELSE
exponent := 999;
END;
mantissa := -1;
RETURN
ELSIF IEEE.NotANumber(r) THEN
exponent := 0;
mantissa := 0;
RETURN
END;
neg := r < 0.0;
IF neg THEN
r := ABS(r);
END;
exponent := 0; mantissa := r;
IF base = 10 THEN
IF MC68881.available THEN
exponent := SHORT(ENTIER(MC68881.FLOG10(r)));
mantissa := r / MC68881.FTENTOX(exponent);
ELSE
(* use powtab *)
index := 0;
WHILE mantissa < 1.0 DO
WHILE mantissa * powtab[index].p10 < 10 DO
DEC(exponent, powtab[index].n);
mantissa := mantissa * powtab[index].p10;
END;
INC(index);
END;
WHILE mantissa >= 10 DO
WHILE mantissa >= powtab[index].p10 DO
INC(exponent, powtab[index].n);
mantissa := mantissa / powtab[index].p10;
END;
INC(index);
END;
END;
ELSE (* general case *)
WHILE mantissa < 1.0 DO
DEC(exponent); mantissa := mantissa * base;
END;
WHILE mantissa >= base DO
INC(exponent); mantissa := mantissa / base;
END;
END;
IF ~(base IN {2, 4, 16}) THEN
(* roundoff *)
roundoff := base/2;
IF ~long & (base = 10) THEN
ndigits := maxdignum;
ELSE
ndigits := sigdigits[base];
END;
i := 0;
WHILE i < ndigits DO
roundoff := roundoff/base; INC(i);
END;
mantissa := mantissa + roundoff;
IF mantissa >= base THEN
mantissa := mantissa / base;
INC(exponent);
ELSIF mantissa < 1 THEN
mantissa := mantissa * base;
DEC(exponent);
END;
END;
IF neg THEN
mantissa := -mantissa;
END;
END ExpAndMan;
PROCEDURE Power*(base: LONGREAL; exp: INTEGER) : LONGREAL;
(* efficient calculation of base^exp *)
VAR
r, res: LONGREAL;
neg: BOOLEAN; (* negative exponent? *)
BEGIN
IF MC68881.available & (base = 10) THEN
RETURN MC68881.FTENTOX(exp)
ELSIF MC68881.available & (base = 2) THEN
RETURN MC68881.FTWOTOX(exp)
ELSE
res := 1.0;
r := base;
neg := exp < 0;
exp := ABS(exp);
LOOP
IF ODD(exp) THEN
res := res * r;
END;
exp := exp DIV 2;
IF exp = 0 THEN
EXIT
END;
r := r * r;
END;
IF neg THEN
RETURN 1 / res
ELSE
RETURN res
END;
END;
END Power;
PROCEDURE Digits*(mantissa: LONGREAL; base: INTEGER;
VAR buf: ARRAY OF CHAR;
VAR neg: BOOLEAN;
force: BOOLEAN; VAR ndigits: INTEGER);
(* PRE:
mantissa holds the post-condition of ExpAndMan;
valid values for base are 2, 8, 10, and 16
ndigits > 0: maximal number of digits
POST:
the mantissa is converted into digits 0-9 and A-F (if base = 16);
buf consists of ndigits digits and
is guaranteed to be 0X-terminated;
neg is set to TRUE if mantissa < 0
force = FALSE:
there are no leading zeroes except on mantissa = 0;
force = TRUE
ndigits is unchanged
*)
VAR
index: INTEGER; (* of buf *)
i: INTEGER; roundoff: LONGREAL;
lastnz: INTEGER; (* last index with buf[index] # "0" *)
ch: CHAR;
digit: LONGINT;
maxdig: CHAR; (* base-1 converted *)
BEGIN
index := 0;
IF (ndigits <= 0) OR (ndigits+1 >= LEN(buf)) THEN
ndigits := SHORT(LEN(buf) - 1);
END;
IF ~force & (ndigits > sigdigits[base]) THEN
ndigits := sigdigits[base];
END;
neg := mantissa < 0;
mantissa := ABS(mantissa);
IF mantissa = 0 THEN
buf[index] := "0"; INC(index);
ELSE
(* roundoff *)
roundoff := base/2;
i := 0;
WHILE i < ndigits DO
roundoff := roundoff/base; INC(i);
END;
IF mantissa + roundoff < base THEN
mantissa := mantissa + roundoff;
END;
(* conversion *)
lastnz := 0;
WHILE (index < ndigits) & (mantissa # 0) DO
digit := ENTIER(mantissa);
(* digit in [0..base-1] *)
IF digit <= 9 THEN
ch := CHR(digit + ORD("0"));
ELSIF digit <= 16 THEN
ch := CHR(digit - 10 + ORD("A"));
ELSE
ch := "?";
END;
buf[index] := ch; INC(index);
mantissa := (mantissa - digit) * base;
IF ch # "0" THEN
lastnz := index;
END;
END;
index := lastnz;
END;
buf[index] := 0X; ndigits := index;
END Digits;
PROCEDURE Convert*(digits: ARRAY OF CHAR; base: INTEGER; neg: BOOLEAN;
VAR mantissa: LONGREAL);
(* convert normalized `digits' (decimal point after 1st digit)
into `mantissa'
*)
VAR
index: INTEGER;
factor: LONGREAL;
BEGIN
IF digits = "0" THEN
mantissa := 0;
ELSE
mantissa := ORD(digits[0]) - ORD("0");
factor := 1 / base;
index := 1;
WHILE (index < LEN(digits)) & (index < sigdigits[base]) &
(digits[index] # 0X) & (factor > 0) DO
mantissa := mantissa + (ORD(digits[index]) - ORD("0")) * factor;
factor := factor / base;
INC(index);
END;
IF neg THEN
mantissa := -mantissa;
END;
END;
END Convert;
BEGIN
powtab[0].p10 := 1.0D32; powtab[0].n := 32;
powtab[1].p10 := 1.0D16; powtab[1].n := 16;
powtab[2].p10 := 1.0D8; powtab[2].n := 8;
powtab[3].p10 := 1.0D4; powtab[3].n := 4;
powtab[4].p10 := 1.0D2; powtab[4].n := 2;
powtab[5].p10 := 1.0D1; powtab[5].n := 1;
(* for LONGREAL *)
sigdigits[2] := 64; sigdigits[3] := 40; sigdigits[4] := 32;
sigdigits[5] := 27; sigdigits[6] := 24; sigdigits[7] := 22;
sigdigits[8] := 21; sigdigits[9] := 20; sigdigits[10] := 19;
sigdigits[11] := 18; sigdigits[12] := 17; sigdigits[13] := 17;
sigdigits[14] := 16; sigdigits[15] := 16; sigdigits[16] := 16;
END ulmReals.

422
src/library/ulm/ulmRelatedEvents.Mod Normal file
View file

@ -0,0 +1,422 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: RelatedEven.om,v 1.8 2005/04/28 08:30:09 borchert Exp $
----------------------------------------------------------------------------
$Log: RelatedEven.om,v $
Revision 1.8 2005/04/28 08:30:09 borchert
added assertion to Forward that takes care that from # to
(otherwise we get a nasty infinite loop)
Revision 1.7 2004/09/09 21:04:24 borchert
undoing change of Revision 1.5:
fields dependants and dependson must not be subject of
Save/Restore as this makes it impossible to undo the
dependencies within the TerminationHandler
we no longer remove the discipline in case of terminated
objects as this causes a list of error events to be lost
Revision 1.6 2004/02/18 17:01:59 borchert
Raise asserts now that event.type # NIL
Revision 1.5 2004/02/18 16:53:48 borchert
fields dependants and dependson moved from discipline to state
object to support them for Save/Restore
Revision 1.4 1998/01/12 14:39:18 borchert
some bug fixes around RelatedEvents.null
Revision 1.3 1995/03/20 17:05:13 borchert
- Save & Restore added
- support for Forwarders & Resources added
Revision 1.2 1994/08/27 14:49:44 borchert
null object added
Revision 1.1 1994/02/22 20:09:53 borchert
Initial revision
----------------------------------------------------------------------------
AFB 11/91
----------------------------------------------------------------------------
*)
MODULE ulmRelatedEvents;
(* relate events to objects *)
IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Forwarders := ulmForwarders, Objects := ulmObjects, Priorities := ulmPriorities, Resources := ulmResources, SYSTEM;
CONST
(* possible directions of propagated events *)
forward = 0; (* forward along the forwardTo chain, if given *)
backward = 1; (* forward event to all dependants, if present *)
both = 2; (* forward event to both directions *)
TYPE
Direction = SHORTINT; (* forward, backward, both *)
TYPE
Object* = Disciplines.Object;
Event* = POINTER TO EventRec;
EventRec* =
RECORD
(Events.EventRec)
object*: Object;
event*: Events.Event;
END;
Queue* = POINTER TO QueueRec;
QueueRec* =
RECORD
(Objects.ObjectRec)
event*: Events.Event;
next*: Queue;
END;
ObjectList = POINTER TO ObjectListRec;
ObjectListRec =
RECORD
object: Object;
next: ObjectList;
END;
TYPE
State = POINTER TO StateRec;
StateRec =
RECORD
default: BOOLEAN; (* default reaction? *)
eventType: Events.EventType; (* may be NIL *)
queue: BOOLEAN; (* are events to be queued? *)
forwardto: Object;
head, tail: Queue;
saved: State;
END;
Discipline = POINTER TO DisciplineRec;
DisciplineRec =
RECORD
(Disciplines.DisciplineRec)
state: State;
dependants: ObjectList;
dependsOn: Object;
END;
VAR
id: Disciplines.Identifier;
VAR
null*: Object; (* object which ignores all related events *)
nullevent: Events.EventType;
PROCEDURE RemoveDependant(VAR list: ObjectList; dependant: Object);
VAR
prev, p: ObjectList;
BEGIN
prev := NIL; p := list;
WHILE (p # NIL) & (p.object # dependant) DO
prev := p; p := p.next;
END;
IF p # NIL THEN
IF prev = NIL THEN
list := p.next;
ELSE
prev.next := p.next;
END;
END;
END RemoveDependant;
PROCEDURE TerminationHandler(event: Events.Event);
VAR
disc: Discipline;
BEGIN
WITH event: Resources.Event DO
IF (event.change = Resources.terminated) &
Disciplines.Seek(event.resource, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *)
IF (disc.dependsOn # NIL) &
Disciplines.Seek(disc.dependsOn, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *)
RemoveDependant(disc.dependants, event.resource);
disc.dependsOn := NIL;
END;
(*
afb 9/2004:
do not remove this discipline for dead objects
as this makes it impossible to retrieve the final
list of error events
Disciplines.Remove(event.resource, id);
*)
END;
END;
END TerminationHandler;
PROCEDURE CreateState(VAR state: State);
BEGIN
NEW(state);
state.eventType := NIL;
state.queue := FALSE; state.head := NIL; state.tail := NIL;
state.forwardto := NIL;
state.default := TRUE;
state.saved := NIL;
END CreateState;
PROCEDURE CreateDiscipline(VAR disc: Discipline);
BEGIN
NEW(disc); disc.id := id; CreateState(disc.state);
END CreateDiscipline;
PROCEDURE GetEventType*(object: Object; VAR eventType: Events.EventType);
(* returns an event type for the given object;
all events related to the object are also handled by this event type
*)
VAR
disc: Discipline;
state: State;
BEGIN
IF object = null THEN
eventType := nullevent;
ELSE
IF ~Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *)
CreateDiscipline(disc);
Disciplines.Add(object, disc);
END;
state := disc.state;
state.default := FALSE;
IF state.eventType = NIL THEN
Events.Define(state.eventType);
Events.SetPriority(state.eventType, Priorities.liberrors + 1);
Events.Ignore(state.eventType);
END;
eventType := state.eventType;
END;
END GetEventType;
PROCEDURE Forward*(from, to: Object);
(* causes all events related to `from' to be forwarded to `to' *)
VAR
disc: Discipline;
BEGIN
IF (from # NIL) & (from # null) THEN
ASSERT(from # to);
IF ~Disciplines.Seek(from, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *)
CreateDiscipline(disc);
Disciplines.Add(from, disc);
END;
IF to = null THEN
to := NIL;
END;
disc.state.forwardto := to;
disc.state.default := FALSE;
END;
END Forward;
PROCEDURE ForwardToDependants(from, to: Forwarders.Object);
(* is called by Forwarders.Forward:
build a backward chain from `to' to `from'
*)
VAR
fromDisc, toDisc: Discipline;
member: ObjectList;
eventType: Events.EventType;
BEGIN
IF (from = null) OR (to = null) THEN RETURN END;
IF ~Disciplines.Seek(from, id, SYSTEM.VAL(Disciplines.Discipline, fromDisc)) THEN (* noch *)
CreateDiscipline(fromDisc); Disciplines.Add(from, fromDisc);
END;
IF fromDisc.dependsOn # NIL THEN RETURN END;
fromDisc.dependsOn := to;
Resources.TakeInterest(from, eventType);
Events.Handler(eventType, TerminationHandler);
IF ~Disciplines.Seek(to, id, SYSTEM.VAL(Disciplines.Discipline, toDisc)) THEN (* noch *)
CreateDiscipline(toDisc); Disciplines.Add(to, toDisc);
END;
NEW(member); member.object := from;
member.next := toDisc.dependants; toDisc.dependants := member;
END ForwardToDependants;
PROCEDURE QueueEvents*(object: Object);
(* put all incoming events into a queue *)
VAR
disc: Discipline;
state: State;
BEGIN
IF (object # NIL) & (object # null) THEN
IF ~Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN
CreateDiscipline(disc);
Disciplines.Add(object, disc);
END;
state := disc.state;
state.default := FALSE;
IF ~state.queue THEN
state.queue := TRUE; state.head := NIL; state.tail := NIL;
END;
END;
END QueueEvents;
PROCEDURE GetQueue*(object: Object; VAR queue: Queue);
(* return queue of related events which is removed
from the object;
object must have been prepared by QueueEvents
*)
VAR
disc: Discipline;
state: State;
BEGIN
IF (object # NIL) & (object # null) &
Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) & disc.state.queue THEN (* noch *)
state := disc.state;
queue := state.head; state.head := NIL; state.tail := NIL;
ELSE
queue := NIL;
END;
END GetQueue;
PROCEDURE EventsPending*(object: Object) : BOOLEAN;
(* return TRUE if GetQueue will return a queue # NIL *)
VAR
disc: Discipline;
BEGIN
IF (object # NIL) & (object # null) &
Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) & disc.state.queue THEN (* noch *)
RETURN disc.state.head # NIL
ELSE
RETURN FALSE
END;
END EventsPending;
PROCEDURE Reset*(object: Object);
(* return to default behaviour *)
VAR
disc: Discipline;
state: State;
BEGIN
IF object # null THEN
IF Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *)
IF (disc.state.saved = NIL) &
(disc.dependsOn = NIL) &
(disc.dependants = NIL) THEN
Disciplines.Remove(object, id);
ELSE
state := disc.state;
state.queue := FALSE; state.head := NIL; state.tail := NIL;
state.eventType := NIL; state.forwardto := NIL;
state.default := TRUE;
END;
END;
END;
END Reset;
PROCEDURE Save*(object: Object);
(* save current status of the given object and reset to
default behaviour;
the status includes the reaction types and event queues;
Save operations may be nested
*)
VAR
disc: Discipline;
state: State;
BEGIN
IF object # null THEN
IF ~Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *)
CreateDiscipline(disc);
Disciplines.Add(object, disc);
END;
CreateState(state);
state.saved := disc.state; disc.state := state;
END;
END Save;
PROCEDURE Restore*(object: Object);
(* restore status saved earlier by Save *)
VAR
disc: Discipline;
BEGIN
IF Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) & (disc.state.saved # NIL) THEN (* noch *)
disc.state := disc.state.saved;
END;
END Restore;
PROCEDURE InternalRaise(object: Object; dir: Direction; event: Events.Event);
VAR
disc: Discipline;
state: State;
relEvent: Event;
element: Queue; (* new element of queue *)
dependant: ObjectList;
BEGIN
IF (object = null) OR ~Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN RETURN END;
(* backward chaining *)
IF (disc.dependants # NIL) & (dir IN {backward, both}) THEN
dependant := disc.dependants;
WHILE dependant # NIL DO
InternalRaise(dependant.object, backward, event);
dependant := dependant.next;
END;
END;
(* local handling & forward chaining *)
IF ~disc.state.default THEN
state := disc.state;
IF state.queue THEN
NEW(element); element.next := NIL; element.event := event;
IF state.tail # NIL THEN
state.tail.next := element;
ELSE
state.head := element;
END;
state.tail := element;
END;
IF state.eventType # NIL THEN
NEW(relEvent);
relEvent.message := event.message;
relEvent.type := state.eventType;
relEvent.object := object;
relEvent.event := event;
Events.Raise(relEvent);
END;
IF (state.forwardto # NIL) & (dir IN {both, forward}) THEN
InternalRaise(state.forwardto, forward, event);
END;
END;
END InternalRaise;
PROCEDURE Raise*(object: Object; event: Events.Event);
VAR
disc: Discipline;
BEGIN
ASSERT(event.type # NIL);
IF object # null THEN
IF (object = NIL) OR ~Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *)
Events.Raise(event);
ELSE
InternalRaise(object, both, event);
END;
END;
END Raise;
PROCEDURE AppendQueue*(object: Object; queue: Queue);
(* Raise(object, event) for all events of the queue *)
BEGIN
WHILE queue # NIL DO
Raise(object, queue.event);
queue := queue.next;
END;
END AppendQueue;
BEGIN
id := Disciplines.Unique();
NEW(null);
Events.Define(nullevent);
Forwarders.Register("", ForwardToDependants);
END ulmRelatedEvents.

354
src/library/ulm/ulmResources.Mod Normal file
View file

@ -0,0 +1,354 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Resources.om,v 1.2 1998/03/24 22:51:29 borchert Exp $
----------------------------------------------------------------------------
$Log: Resources.om,v $
Revision 1.2 1998/03/24 22:51:29 borchert
bug fix: do not create a relationship to dead or unreferenced objects
but propagate terminations immediately to dependants
Revision 1.1 1996/01/04 16:44:44 borchert
Initial revision
----------------------------------------------------------------------------
*)
MODULE ulmResources;
(* general interface for objects which are shared and need
some cooperative termination/cleanup handling
*)
IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Objects := ulmObjects, SYSTEM;
TYPE
Resource* = Disciplines.Object;
(* notification of state changes:
initially, resources are alive;
later the communication to an object may be temporarily
stopped (communicationStopped) and resumed (communicationResumed) --
the effect of calling operations during the communicationStopped
state is undefined: possible variants are (1) immediate failure
and (2) being blocked until the state changes to communicationResumed;
unreferenced objects are still alive but no longer in use by
our side -- some cleanup actions may be associated with this state change;
terminated objects are no longer alive and all operations for
them will fail
*)
CONST
(* state changes *)
terminated* = 0;
unreferenced* = 1;
communicationStopped* = 2;
communicationResumed* = 3;
(* states *)
alive = 4; (* private extension *)
TYPE
StateChange* = SHORTINT; (* terminated..communicationResumed *)
State = SHORTINT; (* alive, unreferenced, or alive *)
(* whether objects are stopped or not is maintained separately *)
Event* = POINTER TO EventRec; (* notification of state changes *)
EventRec* =
RECORD
(Events.EventRec)
change*: StateChange; (* new state *)
resource*: Resource;
END;
TYPE
Key* = POINTER TO KeyRec;
KeyRec* =
RECORD
(Objects.ObjectRec)
valid: BOOLEAN;
resource: Resource;
END;
TYPE
List = POINTER TO ListRec;
ListRec =
RECORD
resource: Resource;
next: List;
END;
Discipline = POINTER TO DisciplineRec;
DisciplineRec =
RECORD
(Disciplines.DisciplineRec)
state: State; (* alive, unreferenced, or terminated *)
stopped: BOOLEAN; (* may be TRUE, if alive or unreferenced *)
refcnt: LONGINT; (* # of Attach - # of Detach *)
eventType: Events.EventType; (* may be NIL *)
dependants: List; (* list of resources which depends on us *)
dependsOn: Resource; (* we depend on this resource *)
key: Key; (* attach key for dependsOn *)
END;
VAR
discID: Disciplines.Identifier;
(* === private procedures ============================================ *)
PROCEDURE GetDisc(resource: Resource; VAR disc: Discipline);
BEGIN
(*IF ~Disciplines.Seek(resource, discID, disc) THEN*)
(* this line causes error
err 123 type of actual parameter is not identical with that of formal VAR-parameter
because Discipline defined in this module is an extention of the same type in module Disciplines
Disciplines.Seek expects Disciplines.Discipline, not the extended type.
voc (ofront, OP2, as well as oo2c) behaves right by not allowing this, while Ulm's Oberon system
accepts this.
So we introduce here a workaround, which makes usage of this module unsafe;
noch
*)
IF ~Disciplines.Seek(resource, discID, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *)
NEW(disc); disc.id := discID;
disc.state := alive; disc.refcnt := 0;
disc.eventType := NIL;
disc.dependants := NIL; disc.dependsOn := NIL;
Disciplines.Add(resource, disc);
END;
END GetDisc;
PROCEDURE GenEvent(resource: Resource; change: StateChange);
VAR
disc: Discipline;
event: Event;
BEGIN
GetDisc(resource, disc);
IF disc.eventType # NIL THEN
NEW(event);
event.type := disc.eventType;
event.message := "Resources: state change notification";
event.change := change;
event.resource := resource;
Events.Raise(event);
END;
END GenEvent;
PROCEDURE ^ Detach*(resource: Resource; key: Key);
PROCEDURE Unlink(dependant, resource: Resource);
(* undo DependsOn operation *)
VAR
dependantDisc, resourceDisc: Discipline;
prev, member: List;
BEGIN
GetDisc(resource, resourceDisc);
IF resourceDisc.state = terminated THEN
(* no necessity for clean up *)
RETURN
END;
GetDisc(dependant, dependantDisc);
prev := NIL; member := resourceDisc.dependants;
WHILE member.resource # dependant DO
prev := member; member := member.next;
END;
IF prev = NIL THEN
resourceDisc.dependants := member.next;
ELSE
prev.next := member.next;
END;
(* Detach reference from dependant to resource *)
Detach(dependantDisc.dependsOn, dependantDisc.key);
dependantDisc.dependsOn := NIL; dependantDisc.key := NIL;
END Unlink;
PROCEDURE InternalNotify(resource: Resource; change: StateChange);
VAR
disc: Discipline;
event: Event;
dependant: List;
BEGIN
GetDisc(resource, disc);
CASE change OF
| communicationResumed: disc.stopped := FALSE;
| communicationStopped: disc.stopped := TRUE;
| terminated: disc.stopped := FALSE; disc.state := terminated;
END;
GenEvent(resource, change);
(* notify all dependants *)
dependant := disc.dependants;
WHILE dependant # NIL DO
InternalNotify(dependant.resource, change);
dependant := dependant.next;
END;
(* remove dependency relation in case of termination, if present *)
IF (change = terminated) & (disc.dependsOn # NIL) THEN
Unlink(resource, disc.dependsOn);
END;
END InternalNotify;
(* === exported procedures =========================================== *)
PROCEDURE TakeInterest*(resource: Resource; VAR eventType: Events.EventType);
(* return resource specific event type for state notifications;
eventType is guaranteed to be # NIL even if
the given resource is already terminated
*)
VAR
disc: Discipline;
BEGIN
GetDisc(resource, disc);
IF disc.eventType = NIL THEN
Events.Define(disc.eventType);
Events.Ignore(disc.eventType);
END;
eventType := disc.eventType;
END TakeInterest;
PROCEDURE Attach*(resource: Resource; VAR key: Key);
(* mark the resource as being used until Detach gets called *)
VAR
disc: Discipline;
BEGIN
GetDisc(resource, disc);
IF disc.state IN {terminated, unreferenced} THEN
key := NIL;
ELSE
INC(disc.refcnt); NEW(key); key.valid := TRUE;
key.resource := resource;
END;
END Attach;
PROCEDURE Detach*(resource: Resource; key: Key);
(* mark the resource as unused; the returned key of Attach must
be given -- this allows to check for proper balances
of Attach/Detach calls;
the last Detach operation causes a state change to unreferenced
*)
VAR
disc: Discipline;
BEGIN
IF (key # NIL) & key.valid & (key.resource = resource) THEN
GetDisc(resource, disc);
IF disc.state # terminated THEN
key.valid := FALSE; DEC(disc.refcnt);
IF disc.refcnt = 0 THEN
GenEvent(resource, unreferenced);
disc.state := unreferenced;
IF disc.dependsOn # NIL THEN
Unlink(resource, disc.dependsOn);
END;
END;
END;
END;
END Detach;
PROCEDURE Notify*(resource: Resource; change: StateChange);
(* notify all interested parties about the new state;
only valid state changes are accepted:
- Notify doesn't accept any changes after termination
- unreferenced is generated conditionally by Detach only
- communicationResumed is valid after communicationStopped only
valid notifications are propagated to all dependants (see below);
*)
VAR
disc: Discipline;
event: Event;
dependant: List;
BEGIN
IF change # unreferenced THEN
GetDisc(resource, disc);
IF (disc.state # terminated) & (disc.state # change) &
((change # communicationResumed) OR disc.stopped) THEN
InternalNotify(resource, change);
END;
END;
END Notify;
PROCEDURE DependsOn*(dependant, resource: Resource);
(* states that `dependant' depends entirely on `resource' --
this is usually the case if operations on `dependant'
are delegated to `resource';
only one call of DependsOn may be given per `dependant' while
several DependsOn for one resource are valid;
DependsOn calls implicitly Attach for resource and
detaches if the dependant becomes unreferenced;
all other state changes propagate from `resource' to
`dependant'
*)
VAR
dependantDisc, resourceDisc: Discipline;
member: List;
BEGIN
GetDisc(resource, resourceDisc);
IF resourceDisc.state <= unreferenced THEN
(* do not create a relationship to dead or unreferenced objects
but propagate a termination immediately to dependant
*)
IF resourceDisc.state = terminated THEN
Notify(dependant, resourceDisc.state);
END;
RETURN
END;
GetDisc(dependant, dependantDisc);
IF dependantDisc.dependsOn # NIL THEN
(* don't accept changes *)
RETURN
END;
dependantDisc.dependsOn := resource;
NEW(member); member.resource := dependant;
member.next := resourceDisc.dependants;
resourceDisc.dependants := member;
Attach(resource, dependantDisc.key);
END DependsOn;
PROCEDURE Alive*(resource: Resource) : BOOLEAN;
(* returns TRUE if the resource is not yet terminated
and ready for communication (i.e. not communicationStopped)
*)
VAR
disc: Discipline;
BEGIN
GetDisc(resource, disc);
RETURN ~disc.stopped & (disc.state IN {alive, unreferenced})
END Alive;
PROCEDURE Stopped*(resource: Resource) : BOOLEAN;
(* returns TRUE if the object is currently not responsive
and not yet terminated
*)
VAR
disc: Discipline;
BEGIN
GetDisc(resource, disc);
RETURN disc.stopped
END Stopped;
PROCEDURE Terminated*(resource: Resource) : BOOLEAN;
(* returns TRUE if the resource is terminated *)
VAR
disc: Discipline;
BEGIN
GetDisc(resource, disc);
RETURN disc.state = terminated
END Terminated;
BEGIN
discID := Disciplines.Unique();
END ulmResources.

137
src/library/ulm/ulmSYSTEM.Mod Normal file
View file

@ -0,0 +1,137 @@
MODULE ulmSYSTEM;
IMPORT SYSTEM, Unix, Sys := ulmSys;
TYPE pchar = POINTER TO ARRAY 1 OF CHAR;
pstring = POINTER TO ARRAY 1024 OF CHAR;
pstatus = POINTER TO Unix.Status;
TYPE bytearray* = ARRAY SIZE(LONGINT) OF SYSTEM.BYTE; (* need this because voc does not convert implicitly LONGINT to ARRAY OF BYTE; -- noch *)
pbytearray* = POINTER TO bytearray;
TYPE longrealarray* = ARRAY SIZE(LONGREAL) OF SYSTEM.BYTE; (* need this because voc does not convert implicitly LONGINT to ARRAY OF BYTE; -- noch *)
plongrealarray* = POINTER TO bytearray;
PROCEDURE LongToByteArr* ( l : LONGINT; VAR bar : bytearray); (* noch *)
VAR b : SYSTEM.BYTE;
p : pbytearray;
i : LONGINT;
BEGIN
p := SYSTEM.VAL(pbytearray, SYSTEM.ADR(l));
FOR i := 0 TO SIZE(LONGINT) -1 DO
b := p^[i]; bar[i] := b;
END
END LongToByteArr;
PROCEDURE LRealToByteArr* ( l : LONGREAL; VAR lar : longrealarray); (* noch *)
VAR b : SYSTEM.BYTE;
p : plongrealarray;
i : LONGINT;
BEGIN
p := SYSTEM.VAL(plongrealarray, SYSTEM.ADR(l));
FOR i := 0 TO SIZE(LONGREAL) -1 DO
b := p^[i]; lar[i] := b;
END
END LRealToByteArr;
(*
PROCEDURE -Write(adr, n: LONGINT): LONGINT
"write(1/*stdout*/, adr, n)";
PROCEDURE -read(VAR ch: CHAR): LONGINT
"read(0/*stdin*/, ch, 1)";
*)
PROCEDURE TAS*(VAR flag:BOOLEAN): BOOLEAN; (* added for compatibility with ulmSYSTEM module; noch *)
VAR oldflag : BOOLEAN;
BEGIN
oldflag := flag;
flag := TRUE;
RETURN oldflag;
END TAS;
PROCEDURE UNIXCALL*(syscall: LONGINT; VAR d0, d1: LONGINT; (* in ulm version both LONGINT and INTEGER are 4 byte size *)
arg1, arg2, arg3: LONGINT) : BOOLEAN;
VAR
n : LONGINT;
ch : CHAR;
pch : pchar;
pstr : pstring;
pst : pstatus;
BEGIN
IF syscall = Sys.read THEN
d0 := Unix.Read(SHORT(arg1), arg2, arg3);
IF d0 >= 0 THEN RETURN TRUE ELSE RETURN FALSE END
(*NEW(pch);
pch := SYSTEM.VAL(pchar, arg2);
ch := pch^[0];
n := read(ch);
IF n # 1 THEN
ch := 0X;
RETURN FALSE
ELSE
pch^[0] := ch;
RETURN TRUE
END;
*)
ELSIF syscall = Sys.write THEN
d0 := Unix.Write(SHORT(arg1), arg2, arg3);
IF d0 >= 0 THEN RETURN TRUE ELSE RETURN FALSE END
(*NEW(pch);
pch := SYSTEM.VAL(pchar, arg2);
n := Write(SYSTEM.VAL(LONGINT, pch), 1);
IF n # 1 THEN RETURN FALSE ELSE RETURN TRUE END
*)
ELSIF syscall = Sys.open THEN
pstr := SYSTEM.VAL(pstring, arg1);
d0 := Unix.Open(pstr^, SHORT(arg3), arg2);
IF d0 >= 0 THEN RETURN TRUE ELSE RETURN FALSE END
ELSIF syscall = Sys.close THEN
d0 := Unix.Close(SHORT(arg1));
IF d0 = 0 THEN RETURN TRUE ELSE RETURN FALSE END
ELSIF syscall = Sys.lseek THEN
d0 := Unix.Lseek(SHORT(arg1), arg2, SHORT(arg3));
IF d0 >= 0 THEN RETURN TRUE ELSE RETURN FALSE END
ELSIF syscall = Sys.ioctl THEN
d0 := Unix.Ioctl(SHORT(arg1), SHORT(arg2), arg3);
RETURN d0 >= 0;
ELSIF syscall = Sys.fcntl THEN
d0 := Unix.Fcntl (SHORT(arg1), SHORT(arg2), arg3);
RETURN d0 >= 0;
ELSIF syscall = Sys.dup THEN
d0 := Unix.Dup(SHORT(arg1));
RETURN d0 > 0;
ELSIF syscall = Sys.pipe THEN
d0 := Unix.Pipe(arg1);
RETURN d0 >= 0;
ELSIF syscall = Sys.newstat THEN
pst := SYSTEM.VAL(pstatus, arg2);
pstr := SYSTEM.VAL(pstring, arg1);
d0 := Unix.Stat(pstr^, pst^);
RETURN d0 >= 0
ELSIF syscall = Sys.newfstat THEN
pst := SYSTEM.VAL(pstatus, arg2);
d0 := Unix.Fstat(SHORT(arg1), pst^);
RETURN d0 >= 0;
END
END UNIXCALL;
PROCEDURE UNIXFORK(VAR pid: LONGINT) : BOOLEAN;
BEGIN
END UNIXFORK;
PROCEDURE UNIXSIGNAL(signo: INTEGER; p: PROCEDURE;
VAR old: PROCEDURE; VAR error: INTEGER) : BOOLEAN;
BEGIN
END UNIXSIGNAL;
PROCEDURE WMOVE*(from, to, n : LONGINT);
VAR l : LONGINT;
BEGIN
SYSTEM.MOVE(from, to, n);
END WMOVE;
END ulmSYSTEM.

445
src/library/ulm/ulmScales.Mod Normal file
View file

@ -0,0 +1,445 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Scales.om,v 1.3 2004/09/03 09:31:53 borchert Exp $
----------------------------------------------------------------------------
$Log: Scales.om,v $
Revision 1.3 2004/09/03 09:31:53 borchert
bug fixes: Services.Init added in CreateOperand
Scales.Measure changed to Measure
Revision 1.2 1995/01/16 21:40:39 borchert
- assertions of Assertions converted into real assertions
- fixes due to changed if of PersistentObjects
Revision 1.1 1994/02/22 20:10:03 borchert
Initial revision
----------------------------------------------------------------------------
AFB 12/91
----------------------------------------------------------------------------
*)
MODULE ulmScales;
IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Objects := ulmObjects, Operations := ulmOperations, PersistentObjects := ulmPersistentObjects,
RelatedEvents := ulmRelatedEvents, Services := ulmServices, SYS := SYSTEM;
TYPE
Scale* = POINTER TO ScaleRec;
Family* = POINTER TO FamilyRec;
FamilyRec* =
RECORD
(Disciplines.ObjectRec)
(* private components *)
reference: Scale;
END;
TYPE
Unit* = POINTER TO UnitRec;
UnitList = POINTER TO UnitListRec;
UnitListRec =
RECORD
unit: Unit;
next: UnitList;
END;
Interface* = POINTER TO InterfaceRec;
ScaleRec* =
RECORD
(Disciplines.ObjectRec)
(* private components *)
if: Interface;
family: Family;
head, tail: UnitList;
nextUnit: UnitList;
END;
CONST
unitNameLength* = 32;
TYPE
UnitName* = ARRAY unitNameLength OF CHAR;
UnitRec* = RECORD
(Disciplines.ObjectRec)
name: UnitName;
scale: Scale;
END;
CONST
undefined = 0; absolute* = 1; relative* = 2;
TYPE
Measure* = POINTER TO MeasureRec;
MeasureRec* =
RECORD
(Operations.OperandRec)
scale: Scale;
type: SHORTINT; (* absolute or relative? *)
END;
VAR
measureType: Services.Type;
TYPE
Value* = LONGINT;
CONST
add* = Operations.add; sub* = Operations.sub;
TYPE
Operation* = SHORTINT; (* add or sub *)
TYPE
CreateProc* = PROCEDURE (scale: Scale; VAR measure: Measure; abs: BOOLEAN);
GetValueProc* = PROCEDURE (measure: Measure; unit: Unit; VAR value: Value);
SetValueProc* = PROCEDURE (measure: Measure; unit: Unit; value: Value);
AssignProc* = PROCEDURE (target: Measure; source: Measure);
OperatorProc* = PROCEDURE (op: Operation; op1, op2, result: Measure);
CompareProc* = PROCEDURE (op1, op2: Measure) : INTEGER;
ConvertProc* = PROCEDURE (from, to: Measure);
InterfaceRec* =
RECORD
(Objects.ObjectRec)
create*: CreateProc;
getvalue*: GetValueProc;
setvalue*: SetValueProc;
assign*: AssignProc;
op*: OperatorProc;
compare*: CompareProc;
(* the conversion routines are only to be provided
if the scaling system belongs to a family
*)
scaleToReference*: ConvertProc;
referenceToScale*: ConvertProc;
END;
VAR
invalidOperation*: Events.EventType;
(* operation cannot be performed for the given combination
of types (absolute or relative)
*)
incompatibleScales*: Events.EventType;
(* the scales of the operands do not belong to the same family *)
badCombination*: Events.EventType;
(* SetValue or GetValue:
given measure and unit do not belong to the same scaling system
*)
(* our interface to Operations *)
opif: Operations.Interface;
opcaps: Operations.CapabilitySet;
(* ======= private procedures ===================================== *)
PROCEDURE DummyConversion(from, to: Measure);
BEGIN
from.scale.if.assign(to, from);
END DummyConversion;
(* ======== exported procedures ==================================== *)
PROCEDURE InitFamily*(family: Family; reference: Scale);
BEGIN
family.reference := reference;
(* the reference scale becomes now a member of the family *)
reference.family := family;
reference.if.scaleToReference := DummyConversion;
reference.if.referenceToScale := DummyConversion;
END InitFamily;
PROCEDURE Init*(scale: Scale; family: Family; if: Interface);
(* reference scales are to be initialized with family = NIL *)
BEGIN
scale.if := if;
scale.family := family;
scale.head := NIL; scale.tail := NIL;
scale.nextUnit := NIL;
END Init;
PROCEDURE InitUnit*(scale: Scale; unit: Unit; name: UnitName);
VAR
listp: UnitList;
BEGIN
unit.name := name;
unit.scale := scale;
NEW(listp); listp.unit := unit; listp.next := NIL;
IF scale.head # NIL THEN
scale.tail.next := listp;
ELSE
scale.head := listp;
END;
scale.tail := listp;
END InitUnit;
PROCEDURE CreateMeasure*(scale: Scale; VAR measure: Measure; type: SHORTINT);
BEGIN
scale.if.create(scale, measure, type = absolute);
Operations.Init(measure, opif, opcaps);
measure.scale := scale;
measure.type := type;
END CreateMeasure;
PROCEDURE CreateAbsMeasure*(scale: Scale; VAR measure: Measure);
(* init measure to the origin of the given system *)
BEGIN
CreateMeasure(scale, measure, absolute);
END CreateAbsMeasure;
PROCEDURE CreateRelMeasure*(scale: Scale; VAR measure: Measure);
(* init relative measure to 0 *)
BEGIN
CreateMeasure(scale, measure, relative);
END CreateRelMeasure;
PROCEDURE ConvertMeasure*(scale: Scale; VAR measure: Measure);
(* convert measure to the given scale which must belong
to the same family as the original scale of measure
*)
VAR
newMeasure: Measure;
refMeasure: Measure;
reference: Scale;
BEGIN
IF scale = measure.scale THEN
(* trivial case -- nothing is to be done *)
RETURN
END;
(* check that both scales belong to the same family *)
ASSERT((scale.family # NIL) & (scale.family = measure.scale.family));
CreateMeasure(scale, newMeasure, measure.type);
reference := scale.family.reference;
CreateMeasure(reference, refMeasure, measure.type);
measure.scale.if.scaleToReference(measure, refMeasure);
scale.if.referenceToScale(refMeasure, newMeasure);
measure := newMeasure;
END ConvertMeasure;
PROCEDURE GetReference*(family: Family; VAR reference: Scale);
BEGIN
reference := family.reference;
END GetReference;
PROCEDURE GetFamily*(scale: Scale; VAR family: Family);
BEGIN
family := scale.family;
END GetFamily;
PROCEDURE GetScaleOfUnit*(unit: Unit; VAR scale: Scale);
BEGIN
scale := unit.scale;
END GetScaleOfUnit;
PROCEDURE GetScale*(measure: Measure; VAR scale: Scale);
BEGIN
scale := measure.scale;
END GetScale;
PROCEDURE TraverseUnits*(scale: Scale);
BEGIN
scale.nextUnit := scale.head;
END TraverseUnits;
PROCEDURE NextUnit*(scale: Scale; VAR unit: Unit) : BOOLEAN;
BEGIN
IF scale.nextUnit # NIL THEN
unit := scale.nextUnit.unit;
scale.nextUnit := scale.nextUnit.next;
RETURN TRUE
ELSE
RETURN FALSE
END;
END NextUnit;
PROCEDURE GetName*(unit: Unit; VAR name: UnitName);
BEGIN
name := unit.name;
END GetName;
PROCEDURE GetValue*(measure: Measure; unit: Unit; VAR value: Value);
VAR
scale: Scale;
BEGIN
scale := measure.scale;
ASSERT(unit.scale = scale);
scale.if.getvalue(measure, unit, value);
END GetValue;
PROCEDURE SetValue*(measure: Measure; unit: Unit; value: Value);
VAR
scale: Scale;
BEGIN
scale := measure.scale;
ASSERT(unit.scale = scale);
scale.if.setvalue(measure, unit, value);
END SetValue;
PROCEDURE IsAbsolute*(measure: Measure) : BOOLEAN;
BEGIN
RETURN measure.type = absolute
END IsAbsolute;
PROCEDURE IsRelative*(measure: Measure) : BOOLEAN;
BEGIN
RETURN measure.type = relative
END IsRelative;
PROCEDURE MeasureType*(measure: Measure) : SHORTINT;
BEGIN
RETURN measure.type
END MeasureType;
(* ======== interface procedures for Operations ================= *)
PROCEDURE CreateOperand(VAR op: Operations.Operand);
(* at this time we don't know anything about the
associated scale -- so we've have to delay this decision
*)
VAR
measure: Measure;
BEGIN
NEW(measure);
measure.type := undefined;
measure.scale := NIL;
Services.Init(measure, measureType);
op := measure;
Operations.Init(op, opif, {Operations.add..Operations.cmp});
END CreateOperand;
PROCEDURE Assign(VAR target: Operations.Operand; source: Operations.Operand);
BEGIN
(*WITH source: Measure DO WITH target: Measure DO*)
WITH source: Measure DO IF target IS Measure THEN (* WITH is replaced by IS -- noch *)
(* target is already initialized but possibly to a dummy operand
by CreateOperand
*)
IF target(Measure).type = undefined THEN (* type guard introduced *)
(* init target with the scale of source *)
CreateMeasure(source.scale, SYS.VAL(Measure, target), source.type); (* need to cast *)
END;
IF target(Measure).scale # source.scale THEN
(* adapt scale type from source --
this could lead to a type guard failure if
target is not of the appropiate type
*)
CreateMeasure(source.scale, SYS.VAL(Measure, target), source.type);
END;
IF target(Measure).type # source.type THEN
(* adapt measure type from source *)
CreateMeasure(target(Measure).scale, SYS.VAL(Measure, target), source.type);
END;
source.scale.if.assign(SYS.VAL(Measure, target), source);
END; END;
END Assign;
PROCEDURE CheckCompatibility(op1, op2: Operations.Operand;
VAR m1, m2: Measure);
(* is needed by Op and Compare:
both operands are checked to be members of the same family;
if they have different scales of the same family a
conversion is done;
*)
VAR
scale1, scale2: Scale;
BEGIN
WITH op1: Measure DO WITH op2: Measure DO
scale1 := op1.scale; scale2 := op2.scale;
IF scale1 # scale2 THEN
ASSERT((scale1.family # NIL) & (scale1.family = scale2.family));
(* convert both operands to the reference scale *)
CreateMeasure(scale1.family.reference, m1, op1.type);
scale1.if.scaleToReference(op1, m1);
CreateMeasure(scale2.family.reference, m2, op2.type);
scale2.if.scaleToReference(op2, m2);
ELSE
m1 := op1;
m2 := op2;
END;
END; END;
END CheckCompatibility;
PROCEDURE Op(op: Operations.Operation; op1, op2: Operations.Operand;
VAR result: Operations.Operand);
VAR
restype: SHORTINT; (* type of result -- set by CheckTypes *)
m1, m2: Measure;
PROCEDURE CheckTypes(VAR restype: SHORTINT);
(* check operands for correct typing;
sets restype to the correct result type;
*)
VAR ok: BOOLEAN;
BEGIN
(*WITH op1: Measure DO WITH op2: Measure DO*)
IF op1 IS Measure THEN IF op2 IS Measure THEN
CASE op OF
| Operations.add: (* only abs + abs is invalid *)
ok := (op1(Measure).type = relative) OR
(op2(Measure).type = relative);
IF op1(Measure).type = op2(Measure).type THEN
(* both are relative *)
restype := relative;
ELSE
(* exactly one absolute type is involved *)
restype := absolute;
END;
| Operations.sub: (* only rel - abs is invalid *)
ok := op1(Measure).type <= op2(Measure).type;
IF op1(Measure).type # op2(Measure).type THEN
(* abs - rel *)
restype := absolute;
ELSE
(* abs - abs or rel - rel *)
restype := relative;
END;
END;
ASSERT(ok); (* invalid operation *)
END; END;
END CheckTypes;
BEGIN (* Op *)
(* result is already of type Measure; this is guaranteed by Operations *)
IF result IS Measure THEN
CheckTypes(restype);
CheckCompatibility(op1, op2, m1, m2);
CreateMeasure(m1.scale, SYS.VAL(Measure, result), restype);
m1.scale.if.op(op, m1, m2, SYS.VAL(Measure, result));
END;
END Op;
PROCEDURE Compare(op1, op2: Operations.Operand) : INTEGER;
VAR
m1, m2: Measure;
BEGIN
CheckCompatibility(op1, op2, m1, m2);
ASSERT(m1.type = m2.type);
CheckCompatibility(op1, op2, m1, m2);
RETURN m1.scale.if.compare(m1, m2)
END Compare;
PROCEDURE InitInterface;
BEGIN
NEW(opif);
opif.create := CreateOperand;
opif.assign := Assign;
opif.op := Op;
opif.compare := Compare;
opcaps := {Operations.add, Operations.sub, Operations.cmp};
END InitInterface;
BEGIN
InitInterface;
PersistentObjects.RegisterType(measureType,
"Scales.Measure", "Operations.Operand", NIL);
END ulmScales.

520
src/library/ulm/ulmServices.Mod Normal file
View file

@ -0,0 +1,520 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Services.om,v 1.2 2004/09/03 09:34:24 borchert Exp $
----------------------------------------------------------------------------
$Log: Services.om,v $
Revision 1.2 2004/09/03 09:34:24 borchert
cache results of LoadService to avoid further attempts
Revision 1.1 1995/03/03 09:32:15 borchert
Initial revision
----------------------------------------------------------------------------
*)
MODULE ulmServices;
IMPORT Disciplines := ulmDisciplines, Objects := ulmObjects;
TYPE
Type* = POINTER TO TypeRec;
ServiceList = POINTER TO ServiceListRec;
Service* = POINTER TO ServiceRec;
Object* = POINTER TO ObjectRec;
ObjectRec* =
RECORD
(Disciplines.ObjectRec)
type: Type;
installed: ServiceList; (* set of installed services *)
END;
InstallProc = PROCEDURE (object: Object; service: Service);
ServiceRec* =
RECORD
(Disciplines.ObjectRec)
name: ARRAY 64 OF CHAR;
next: Service;
END;
ServiceListRec =
RECORD
service: Service;
type: Type;
install: InstallProc;
next: ServiceList;
END;
VAR
services: Service;
(* list of services -- needed to support Seek *)
TYPE
LoadModuleProc* = PROCEDURE (module: ARRAY OF CHAR) : BOOLEAN;
LoadServiceProc* = PROCEDURE (service, for: ARRAY OF CHAR) : BOOLEAN;
LoaderInterface* = POINTER TO LoaderInterfaceRec;
LoaderInterfaceRec* =
RECORD
loadModule*: LoadModuleProc;
loadService*: LoadServiceProc;
END;
VAR
loaderIF: LoaderInterface;
(* ==== name tables ================================================== *)
CONST
bufsize = 512; (* length of a name buffer in bytes *)
tabsize = 1171;
TYPE
BufferPosition = INTEGER;
Length = LONGINT;
HashValue = INTEGER;
Buffer = ARRAY bufsize OF CHAR;
NameList = POINTER TO NameListRec;
NameListRec =
RECORD
buffer: Buffer;
next: NameList;
END;
VAR
currentBuf: NameList; currentPos: BufferPosition;
TYPE
TypeRec* =
RECORD
(Disciplines.ObjectRec)
baseType: Type;
services: ServiceList;
cachedservices: ServiceList; (* of base types *)
(* table management *)
hashval: HashValue;
length: Length;
begin: NameList;
pos: BufferPosition;
next: Type; (* next type with same hash value *)
END;
BucketTable = ARRAY tabsize OF Type;
VAR
bucket: BucketTable;
(* ==== name table management ======================================== *)
PROCEDURE Hash(name: ARRAY OF CHAR; length: LONGINT) : HashValue;
CONST
shift = 4;
VAR
index: LONGINT;
val: LONGINT;
ch: CHAR;
ordval: INTEGER;
BEGIN
index := 0; val := length;
WHILE index < length DO
ch := name[index];
IF ch >= " " THEN
ordval := ORD(ch) - ORD(" ");
ELSE
ordval := ORD(MAX(CHAR)) - ORD(" ") + ORD(ch);
END;
val := ASH(val, shift) + ordval;
INC(index);
END;
val := val MOD tabsize;
RETURN SHORT(val)
END Hash;
PROCEDURE CreateBuf(VAR buf: NameList);
BEGIN
NEW(buf); buf.next := NIL;
IF currentBuf # NIL THEN
currentBuf.next := buf;
END;
currentBuf := buf;
currentPos := 0;
END CreateBuf;
PROCEDURE StringLength(string: ARRAY OF CHAR) : LONGINT;
VAR
index: LONGINT;
BEGIN
index := 0;
WHILE (index < LEN(string)) & (string[index] # 0X) DO
INC(index);
END;
RETURN index
END StringLength;
PROCEDURE InitName(name: Type; string: ARRAY OF CHAR);
VAR
index, length: LONGINT;
firstbuf, buf: NameList;
startpos: BufferPosition;
BEGIN
IF currentBuf = NIL THEN
CreateBuf(buf);
ELSE
buf := currentBuf;
END;
firstbuf := buf; startpos := currentPos;
index := 0;
WHILE (index < LEN(string)) & (string[index] # 0X) DO
IF currentPos = bufsize THEN
CreateBuf(buf);
END;
buf.buffer[currentPos] := string[index]; INC(currentPos);
INC(index);
END;
length := index;
name.hashval := Hash(string, length);
name.length := length;
name.begin := firstbuf;
name.pos := startpos;
name.next := bucket[name.hashval];
bucket[name.hashval] := name;
END InitName;
PROCEDURE EqualName(name: Type; string: ARRAY OF CHAR) : BOOLEAN;
(* precondition: both have the same length *)
VAR
index: LONGINT;
buf: NameList;
pos: INTEGER;
BEGIN
buf := name.begin; pos := name.pos;
index := 0;
WHILE index < name.length DO
IF pos = bufsize THEN
buf := buf.next; pos := 0;
END;
IF string[index] # buf.buffer[pos] THEN
RETURN FALSE
END;
INC(pos);
INC(index);
END;
RETURN TRUE
END EqualName;
PROCEDURE SeekName(string: ARRAY OF CHAR; VAR name: Type) : BOOLEAN;
VAR
length: LONGINT;
hashval: HashValue;
p: Type;
BEGIN
length := StringLength(string);
hashval := Hash(string, length);
p := bucket[hashval];
WHILE (p # NIL) & ((length # p.length) OR ~EqualName(p, string)) DO
p := p.next;
END;
name := p;
RETURN p # NIL
END SeekName;
PROCEDURE ExtractName(name: Type; VAR string: ARRAY OF CHAR);
VAR
index: LONGINT;
buf: NameList;
pos: INTEGER;
BEGIN
buf := name.begin; pos := name.pos;
index := 0;
WHILE (index + 1 < LEN(string)) & (index < name.length) DO
IF pos = bufsize THEN
buf := buf.next; pos := 0;
END;
string[index] := buf.buffer[pos];
INC(pos);
INC(index);
END;
string[index] := 0X;
END ExtractName;
PROCEDURE LoadModule(module: ARRAY OF CHAR) : BOOLEAN;
BEGIN
IF (loaderIF # NIL) & (loaderIF.loadModule # NIL) THEN
RETURN loaderIF.loadModule(module)
ELSE
RETURN FALSE
END;
END LoadModule;
PROCEDURE LoadService(service, for: ARRAY OF CHAR) : BOOLEAN;
BEGIN
IF (loaderIF # NIL) & (loaderIF.loadService # NIL) THEN
RETURN loaderIF.loadService(service, for)
ELSE
RETURN FALSE
END;
END LoadService;
PROCEDURE MemberOf(list: ServiceList; service: Service;
VAR member: ServiceList) : BOOLEAN;
VAR
p: ServiceList;
BEGIN
p := list;
WHILE (p # NIL) & (p.service # service) DO
p := p.next;
END;
member := p;
RETURN p # NIL
END MemberOf;
PROCEDURE SeekService(type: Type; service: Service;
VAR member: ServiceList;
VAR baseType: Type) : BOOLEAN;
VAR
btype: Type;
cachedservice: ServiceList;
PROCEDURE Seek(type: Type; service: Service;
VAR member: ServiceList) : BOOLEAN;
VAR
typeName: ARRAY 512 OF CHAR;
BEGIN
IF MemberOf(type.services, service, member) OR
MemberOf(type.cachedservices, service, member) THEN
RETURN TRUE
END;
ExtractName(type, typeName);
RETURN LoadService(service.name, typeName) &
MemberOf(type.services, service, member)
END Seek;
BEGIN (* SeekService *)
btype := type;
WHILE (btype # NIL) & ~Seek(btype, service, member) DO
btype := btype.baseType;
END;
IF (member # NIL) & (btype # type) THEN
(* cache result to avoid further tries to load
a more fitting variant dynamically
*)
NEW(cachedservice);
cachedservice.service := service;
cachedservice.type := member.type;
cachedservice.install := member.install;
cachedservice.next := type.cachedservices;
type.cachedservices := cachedservice;
baseType := member.type;
RETURN TRUE
END;
IF member = NIL THEN
RETURN FALSE
ELSE
baseType := member.type;
RETURN TRUE
END;
END SeekService;
PROCEDURE GetModule(name: ARRAY OF CHAR; VAR module: ARRAY OF CHAR);
(* get the name of the module where 'name' was defined *)
VAR
index: INTEGER;
BEGIN
index := 0;
WHILE (name[index] # ".") & (name[index] # 0X) &
(index < LEN(module)-1) DO
module[index] := name[index]; INC(index);
END;
module[index] := 0X;
END GetModule;
(* ==== exported procedures ========================================== *)
PROCEDURE InitLoader*(if: LoaderInterface);
BEGIN
ASSERT((loaderIF = NIL) & (if # NIL));
loaderIF := if;
END InitLoader;
PROCEDURE InitType*(type: Type; name, baseName: ARRAY OF CHAR);
VAR
baseType: Type;
otherType: Type;
ok: BOOLEAN;
BEGIN
IF baseName = "" THEN
baseType := NIL;
ELSE
ok := SeekName(baseName, baseType); ASSERT(ok);
END;
ASSERT(~SeekName(name, otherType));
InitName(type, name);
type.baseType := baseType;
type.services := NIL;
type.cachedservices := NIL;
END InitType;
PROCEDURE CreateType*(VAR type: Type; name, baseName: ARRAY OF CHAR);
BEGIN
NEW(type); InitType(type, name, baseName);
END CreateType;
PROCEDURE Init*(object: Object; type: Type);
BEGIN
ASSERT(type # NIL);
ASSERT(object.type = NIL);
object.type := type;
object.installed := NIL;
END Init;
PROCEDURE GetType*(object: Object; VAR type: Type);
BEGIN
type := object.type;
END GetType;
PROCEDURE GetTypeName*(type: Type; VAR name: ARRAY OF CHAR);
BEGIN
ExtractName(type, name);
END GetTypeName;
PROCEDURE GetBaseType*(type: Type; VAR baseType: Type);
BEGIN
baseType := type.baseType;
END GetBaseType;
PROCEDURE IsExtensionOf*(type, baseType: Type) : BOOLEAN;
BEGIN
ASSERT(baseType # NIL);
WHILE (type # NIL) & (type # baseType) DO
type := type.baseType;
END;
RETURN type = baseType
END IsExtensionOf;
PROCEDURE SeekType*(name: ARRAY OF CHAR; VAR type: Type);
VAR
module: ARRAY 64 OF CHAR;
BEGIN
IF ~SeekName(name, type) THEN
(* try to load the associated module *)
GetModule(name, module);
IF ~LoadModule(module) OR ~SeekName(name, type) THEN
type := NIL;
END;
END;
END SeekType;
PROCEDURE Seek*(name: ARRAY OF CHAR; VAR service: Service);
BEGIN
service := services;
WHILE (service # NIL) & (service.name # name) DO
service := service.next;
END;
(* try to load a module named after `name', if not successful *)
IF (service = NIL) & LoadModule(name) THEN
service := services;
WHILE (service # NIL) & (service.name # name) DO
service := service.next;
END;
END;
END Seek;
PROCEDURE Create*(VAR service: Service; name: ARRAY OF CHAR);
PROCEDURE Created(name: ARRAY OF CHAR) : BOOLEAN;
VAR
service: Service;
BEGIN
service := services;
WHILE (service # NIL) & (service.name # name) DO
service := service.next;
END;
RETURN service # NIL
END Created;
BEGIN
ASSERT(~Created(name));
NEW(service);
COPY(name, service.name);
service.next := services; services := service;
END Create;
PROCEDURE Define*(type: Type; service: Service; install: InstallProc);
VAR
member: ServiceList;
BEGIN
ASSERT(service # NIL);
(* protect against multiple definitions: *)
ASSERT(~MemberOf(type.services, service, member));
NEW(member); member.service := service;
member.install := install; member.type := type;
member.next := type.services; type.services := member;
END Define;
PROCEDURE Install*(object: Object; service: Service) : BOOLEAN;
VAR
member, installed: ServiceList;
baseType: Type;
BEGIN
IF object.type = NIL THEN RETURN FALSE END;
IF ~SeekService(object.type, service, member, baseType) THEN
(* service not supported for this object type *)
RETURN FALSE
END;
IF ~MemberOf(object.installed, service, installed) THEN
(* install services only once *)
IF member.install # NIL THEN
member.install(object, service);
END;
NEW(installed);
installed.service := service;
installed.next := object.installed;
object.installed := installed;
END;
RETURN TRUE
END Install;
PROCEDURE Supported*(object: Object; service: Service) : BOOLEAN;
VAR
member: ServiceList;
baseType: Type;
BEGIN
RETURN (object.type # NIL) &
SeekService(object.type, service, member, baseType)
END Supported;
PROCEDURE Installed*(object: Object; service: Service) : BOOLEAN;
VAR
member: ServiceList;
BEGIN
RETURN MemberOf(object.installed, service, member)
END Installed;
PROCEDURE GetSupportedBaseType*(object: Object; service: Service;
VAR baseType: Type);
VAR
member: ServiceList;
BEGIN
IF ~SeekService(object.type, service, member, baseType) THEN
baseType := NIL;
END;
END GetSupportedBaseType;
BEGIN
currentBuf := NIL; currentPos := 0; loaderIF := NIL;
END ulmServices.

208
src/library/ulm/ulmSets.Mod Normal file
View file

@ -0,0 +1,208 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Sets.om,v 1.3 1999/06/06 06:44:56 borchert Exp $
----------------------------------------------------------------------------
$Log: Sets.om,v $
Revision 1.3 1999/06/06 06:44:56 borchert
bug fix: CharSet was too small
Revision 1.2 1995/03/16 16:25:33 borchert
assertions of Assertions replaced by real assertions
Revision 1.1 1994/02/22 20:10:14 borchert
Initial revision
----------------------------------------------------------------------------
AFB 9/89
----------------------------------------------------------------------------
*)
MODULE ulmSets;
CONST
setsize* = MAX(SET) + 1;
TYPE
CharSet* = ARRAY ORD(MAX(CHAR)) + 1 DIV setsize OF SET;
PROCEDURE InitSet*(VAR set: ARRAY OF SET);
VAR i: LONGINT;
BEGIN
i := 0;
WHILE i < LEN(set) DO
set[i] := {}; INC(i);
END;
END InitSet;
PROCEDURE Complement*(VAR set: ARRAY OF SET);
VAR i: LONGINT;
BEGIN
i := 0;
WHILE i < LEN(set) DO
set[i] := - set[i]; INC(i);
END;
END Complement;
PROCEDURE In*(VAR set: ARRAY OF SET; i: LONGINT) : BOOLEAN;
BEGIN
RETURN (i MOD setsize) IN set[i DIV setsize]
END In;
PROCEDURE Incl*(VAR set: ARRAY OF SET; i: LONGINT);
BEGIN
INCL(set[i DIV setsize], i MOD setsize);
END Incl;
PROCEDURE Excl*(VAR set: ARRAY OF SET; i: LONGINT);
BEGIN
EXCL(set[i DIV setsize], i MOD setsize);
END Excl;
PROCEDURE CharIn*(VAR charset: CharSet; ch: CHAR) : BOOLEAN;
BEGIN
RETURN (ORD(ch) MOD setsize) IN charset[ORD(ch) DIV setsize]
END CharIn;
PROCEDURE InclChar*(VAR charset: CharSet; ch: CHAR);
BEGIN
INCL(charset[ORD(ch) DIV setsize], ORD(ch) MOD setsize);
END InclChar;
PROCEDURE ExclChar*(VAR charset: CharSet; ch: CHAR);
BEGIN
EXCL(charset[ORD(ch) DIV setsize], ORD(ch) MOD setsize);
END ExclChar;
PROCEDURE Intersection*(set1, set2: ARRAY OF SET; VAR result: ARRAY OF SET);
VAR
index: INTEGER;
BEGIN
ASSERT((LEN(result) = LEN(set1)) & (LEN(result) = LEN(set2)));
index := 0;
WHILE index < LEN(result) DO
result[index] := set1[index] * set2[index];
INC(index);
END;
END Intersection;
PROCEDURE SymDifference*(set1, set2: ARRAY OF SET; VAR result: ARRAY OF SET);
VAR
index: INTEGER;
BEGIN
ASSERT((LEN(result) = LEN(set1)) & (LEN(result) = LEN(set2)));
index := 0;
WHILE index < LEN(result) DO
result[index] := set1[index] / set2[index];
INC(index);
END;
END SymDifference;
PROCEDURE Union*(set1, set2: ARRAY OF SET; VAR result: ARRAY OF SET);
VAR
index: INTEGER;
BEGIN
ASSERT((LEN(result) = LEN(set1)) & (LEN(result) = LEN(set2)));
index := 0;
WHILE index < LEN(result) DO
result[index] := set1[index] + set2[index];
INC(index);
END;
END Union;
PROCEDURE Difference*(set1, set2: ARRAY OF SET; VAR result: ARRAY OF SET);
VAR
index: INTEGER;
BEGIN
ASSERT((LEN(result) = LEN(set1)) & (LEN(result) = LEN(set2)));
index := 0;
WHILE index < LEN(result) DO
result[index] := set1[index] - set2[index];
INC(index);
END;
END Difference;
PROCEDURE Equal*(set1, set2: ARRAY OF SET) : BOOLEAN;
VAR
index: INTEGER;
BEGIN
index := 0;
WHILE (index < LEN(set1)) & (index < LEN(set2)) DO
IF set1[index] # set2[index] THEN
RETURN FALSE
END;
INC(index);
END;
WHILE index < LEN(set1) DO
IF set1[index] # {} THEN
RETURN FALSE
END;
INC(index);
END;
WHILE index < LEN(set2) DO
IF set2[index] # {} THEN
RETURN FALSE
END;
INC(index);
END;
RETURN TRUE
END Equal;
PROCEDURE Subset*(set1, set2: ARRAY OF SET) : BOOLEAN;
VAR
index: INTEGER;
BEGIN
index := 0;
WHILE (index < LEN(set1)) & (index < LEN(set2)) DO
IF set1[index] - set2[index] # {} THEN
RETURN FALSE
END;
INC(index);
END;
WHILE index < LEN(set1) DO
IF set1[index] # {} THEN
RETURN FALSE
END;
INC(index);
END;
RETURN TRUE
END Subset;
PROCEDURE Card*(set: ARRAY OF SET) : INTEGER;
VAR
index: INTEGER;
i: INTEGER;
card: INTEGER;
BEGIN
card := 0;
index := 0;
WHILE index < LEN(set) DO
i := 0;
WHILE i <= MAX(SET) DO
IF i IN set[index] THEN
INC(card);
END;
INC(i);
END;
INC(index);
END;
RETURN card
END Card;
END ulmSets.

173
src/library/ulm/ulmStreamConditions.Mod Normal file
View file

@ -0,0 +1,173 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: StreamCondi.om,v 1.1 1994/02/22 20:10:24 borchert Exp $
----------------------------------------------------------------------------
$Log: StreamCondi.om,v $
Revision 1.1 1994/02/22 20:10:24 borchert
Initial revision
----------------------------------------------------------------------------
AFB 1/92
----------------------------------------------------------------------------
*)
MODULE ulmStreamConditions;
IMPORT Conditions := ulmConditions, Events := ulmEvents, Priorities := ulmPriorities, RelatedEvents := ulmRelatedEvents, Streams := ulmStreams;
CONST
msgFailed* = 0; (* message was not processed by the implementation *)
invalidOp* = 1; (* operation was not read or write *)
errorcodes* = 2;
TYPE
ErrorEvent* = POINTER TO ErrorEventRec;
ErrorEventRec* =
RECORD
(Events.EventRec)
errorcode*: SHORTINT;
END;
VAR
errormsg*: ARRAY errorcodes OF Events.Message;
error*: Events.EventType;
CONST
read* = 0; write* = 1; (* operations *)
TYPE
Operation* = SHORTINT; (* read or write *)
TYPE
CreateConditionMessage* =
RECORD
(Streams.Message)
(* in-parameters *)
operation*: Operation; (* read or write *)
(* out-parameters *)
condition*: Conditions.Condition; (* return value *)
stream*: Streams.Stream; (* message processed for this stream *)
msgProcessed*: BOOLEAN; (* initially FALSE; has to be set to TRUE *)
END;
TestConditionMessage* =
RECORD
(Streams.Message)
(* in-parameters *)
operation*: Operation; (* read or write *)
errors*: RelatedEvents.Object; (* relate errors to this object *)
(* out-parameters *)
wouldblock*: BOOLEAN;
msgProcessed*: BOOLEAN;
END;
TYPE
Condition = POINTER TO ConditionRec;
ConditionRec =
RECORD
(Conditions.ConditionRec)
stream: Streams.Stream;
operation: Operation;
END;
VAR
domain: Conditions.Domain;
PROCEDURE InitErrorHandling;
BEGIN
Events.Define(error);
Events.SetPriority(error, Priorities.liberrors);
errormsg[msgFailed] :=
"operation not processed by underlying stream implementation";
errormsg[invalidOp] := "invalid operation (read or write expected)";
END InitErrorHandling;
PROCEDURE Error(object: RelatedEvents.Object; errorcode: SHORTINT);
VAR
event: ErrorEvent;
BEGIN
NEW(event); event.type := error; event.message := errormsg[errorcode];
event.errorcode := errorcode;
RelatedEvents.Raise(object, event);
END Error;
PROCEDURE Test(domain: Conditions.Domain; condition: Conditions.Condition;
errors: RelatedEvents.Object) : BOOLEAN;
VAR
msg: TestConditionMessage;
BEGIN
WITH condition: Condition DO
CASE condition.operation OF
| read: IF Streams.InputInBuffer(condition.stream) THEN
RETURN TRUE
END;
| write: IF Streams.OutputWillBeBuffered(condition.stream) THEN
RETURN TRUE
END;
END;
msg.operation := condition.operation;
msg.errors := errors;
msg.wouldblock := TRUE;
msg.msgProcessed := FALSE;
Streams.Send(condition.stream, msg);
IF ~msg.msgProcessed THEN
Error(errors, msgFailed); RETURN FALSE
END;
RETURN ~msg.wouldblock
END;
END Test;
PROCEDURE InitDomain;
VAR
if: Conditions.Interface;
desc: Conditions.Description;
BEGIN
NEW(if); if.test := Test;
NEW(desc); desc.caps := {}; desc.internal := TRUE;
NEW(domain); Conditions.InitDomain(domain, if, desc);
END InitDomain;
PROCEDURE Create*(VAR condition: Conditions.Condition;
s: Streams.Stream; operation: Operation);
(* condition = NIL in error case, eg if the associated
stream implementation does not interpret such messages
*)
VAR
msg: CreateConditionMessage;
newcond: Condition;
BEGIN
IF (operation # read) & (operation # write) THEN
condition := NIL; Error(s, invalidOp); RETURN
END;
msg.operation := operation; msg.condition := NIL;
msg.stream := s; msg.msgProcessed := FALSE;
Streams.Send(s, msg);
IF ~msg.msgProcessed THEN
Error(s, msgFailed); condition := NIL; RETURN
END;
IF (msg.condition # NIL) & (msg.stream = s) THEN
(* underlying implementation has its own domain and
defines it own conditions
*)
condition := msg.condition; RETURN
END;
NEW(newcond); newcond.stream := s; newcond.operation := operation;
Conditions.Init(newcond, domain);
condition := newcond;
END Create;
BEGIN
InitErrorHandling;
InitDomain;
END ulmStreamConditions.

246
src/library/ulm/ulmStreamDisciplines.Mod Normal file
View file

@ -0,0 +1,246 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: StreamDisci.om,v 1.2 1994/07/04 14:53:25 borchert Exp $
----------------------------------------------------------------------------
$Log: StreamDisci.om,v $
Revision 1.2 1994/07/04 14:53:25 borchert
parameter for indentation width added
Revision 1.1 1994/02/22 20:10:34 borchert
Initial revision
----------------------------------------------------------------------------
AFB 10/91
----------------------------------------------------------------------------
*)
MODULE ulmStreamDisciplines;
(* definition of general-purpose disciplines for streams *)
IMPORT ASCII := ulmASCII, Disciplines := ulmIndirectDisciplines, Events := ulmEvents, Sets := ulmSets, Streams := ulmStreams, SYSTEM;
TYPE
LineTerminator* = ARRAY 4 OF CHAR;
VAR
badfieldsepset*: Events.EventType;
TYPE
StreamDiscipline = POINTER TO StreamDisciplineRec;
StreamDisciplineRec =
RECORD
(Disciplines.DisciplineRec)
lineterm: LineTerminator;
fieldseps: Sets.CharSet;
fieldsep: CHAR; (* one of them *)
whitespace: Sets.CharSet;
indentwidth: INTEGER;
END;
VAR
id: Disciplines.Identifier;
(* default values *)
defaultFieldSeps: Sets.CharSet;
defaultFieldSep: CHAR;
defaultLineTerm: LineTerminator;
defaultWhiteSpace: Sets.CharSet;
defaultIndentWidth: INTEGER;
PROCEDURE InitDiscipline(VAR disc: StreamDiscipline);
BEGIN
NEW(disc); disc.id := id;
disc.fieldseps := defaultFieldSeps;
disc.fieldsep := defaultFieldSep;
disc.lineterm := defaultLineTerm;
disc.whitespace := defaultWhiteSpace;
disc.indentwidth := defaultIndentWidth;
END InitDiscipline;
PROCEDURE SetLineTerm*(s: Streams.Stream; lineterm: LineTerminator);
VAR
disc: StreamDiscipline;
BEGIN
IF ~Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN
InitDiscipline(disc);
END;
disc.lineterm := lineterm;
Disciplines.Add(s, disc);
END SetLineTerm;
PROCEDURE GetLineTerm*(s: Streams.Stream; VAR lineterm: LineTerminator);
(* default line terminator is ASCII.nl *)
VAR
disc: StreamDiscipline;
BEGIN
IF Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN
lineterm := disc.lineterm;
ELSE
lineterm := defaultLineTerm;
END;
END GetLineTerm;
PROCEDURE SetFieldSepSet*(s: Streams.Stream; fieldsepset: Sets.CharSet);
(* cardinality of fieldsepset must be >= 1 *)
VAR
disc: StreamDiscipline;
ch: CHAR; found: BOOLEAN;
fieldsep: CHAR;
event: Events.Event;
BEGIN
ch := 0X;
LOOP (* seek for the first element inside fieldsepset *)
IF Sets.CharIn(fieldsepset, ch) THEN
found := TRUE; fieldsep := ch; EXIT
END;
IF ch = MAX(CHAR) THEN
found := FALSE; EXIT
END;
ch := CHR(ORD(ch) + 1);
END;
IF ~found THEN
NEW(event);
event.message := "StreamDisciplines.SetFieldSepSet: empty fieldsepset";
event.type := badfieldsepset;
Events.Raise(event);
RETURN
END;
IF ~Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN
InitDiscipline(disc);
END;
disc.fieldseps := fieldsepset;
disc.fieldsep := fieldsep;
Disciplines.Add(s, disc);
END SetFieldSepSet;
PROCEDURE GetFieldSepSet*(s: Streams.Stream; VAR fieldsepset: Sets.CharSet);
(* default field separators are ASCII.tab and ASCII.sp *)
VAR
disc: StreamDiscipline;
BEGIN
IF Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN
fieldsepset := disc.fieldseps;
ELSE
fieldsepset := defaultFieldSeps;
END;
END GetFieldSepSet;
PROCEDURE SetFieldSep*(s: Streams.Stream; fieldsep: CHAR);
VAR
disc: StreamDiscipline;
BEGIN
IF ~Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN
InitDiscipline(disc);
END;
Sets.InclChar(disc.fieldseps, fieldsep);
disc.fieldsep := fieldsep;
Disciplines.Add(s, disc);
END SetFieldSep;
PROCEDURE GetFieldSep*(s: Streams.Stream; VAR fieldsep: CHAR);
(* default field separator is ASCII.tab;
if a set of field separators has been given via SetFieldSepSet,
one of them is returned
*)
VAR
disc: StreamDiscipline;
BEGIN
IF Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN
fieldsep := disc.fieldsep;
ELSE
fieldsep := defaultFieldSep;
END;
END GetFieldSep;
PROCEDURE GetWhiteSpace*(s: Streams.Stream; VAR whitespace: Sets.CharSet);
(* default: ASCII.tab, ASCII.sp, ASCII.np and ASCII.nl *)
VAR
disc: StreamDiscipline;
BEGIN
IF Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN
whitespace := disc.whitespace;
ELSE
whitespace := defaultWhiteSpace;
END;
END GetWhiteSpace;
PROCEDURE SetWhiteSpace*(s: Streams.Stream; whitespace: Sets.CharSet);
VAR
disc: StreamDiscipline;
BEGIN
IF ~Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN
InitDiscipline(disc);
END;
disc.whitespace := whitespace;
Disciplines.Add(s, disc);
END SetWhiteSpace;
PROCEDURE SetIndentationWidth*(s: Streams.Stream; indentwidth: INTEGER);
VAR
disc: StreamDiscipline;
BEGIN
IF indentwidth >= 0 THEN
IF ~Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN
InitDiscipline(disc);
END;
disc.indentwidth := indentwidth;
Disciplines.Add(s, disc);
END;
END SetIndentationWidth;
PROCEDURE GetIndentationWidth*(s: Streams.Stream; VAR indentwidth: INTEGER);
VAR
disc: StreamDiscipline;
BEGIN
IF Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN
indentwidth := disc.indentwidth;
ELSE
indentwidth := defaultIndentWidth;
END;
END GetIndentationWidth;
PROCEDURE IncrIndentationWidth*(s: Streams.Stream; incr: INTEGER);
VAR
disc: StreamDiscipline;
BEGIN
IF ~Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN
InitDiscipline(disc);
END;
IF disc.indentwidth + incr >= 0 THEN
INC(disc.indentwidth, incr);;
END;
Disciplines.Add(s, disc);
END IncrIndentationWidth;
BEGIN
Events.Define(badfieldsepset);
id := Disciplines.Unique();
Sets.InitSet(defaultFieldSeps);
Sets.InclChar(defaultFieldSeps, ASCII.tab);
Sets.InclChar(defaultFieldSeps, ASCII.sp);
defaultFieldSep := ASCII.tab;
defaultLineTerm[0] := ASCII.nl; defaultLineTerm[1] := 0X;
Sets.InitSet(defaultWhiteSpace);
Sets.InclChar(defaultWhiteSpace, ASCII.tab);
Sets.InclChar(defaultWhiteSpace, ASCII.sp);
Sets.InclChar(defaultWhiteSpace, ASCII.np);
Sets.InclChar(defaultWhiteSpace, ASCII.nl);
defaultIndentWidth := 0;
END ulmStreamDisciplines.

2149
src/library/ulm/ulmStreams.Mod Normal file
View file

File diff suppressed because it is too large Load diff

382
src/library/ulm/ulmStrings.Mod Normal file
View file

@ -0,0 +1,382 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Strings.om,v 1.3 1995/01/04 16:44:31 borchert Exp $
----------------------------------------------------------------------------
$Log: Strings.om,v $
Revision 1.3 1995/01/04 16:44:31 borchert
some fixes because streams are now an extension of Services.Object
Revision 1.2 1994/07/05 08:27:25 borchert
Flush operation added to stream interface to support Streams.Touch
Revision 1.1 1994/02/22 20:10:56 borchert
Initial revision
----------------------------------------------------------------------------
AFB 9/89
----------------------------------------------------------------------------
*)
MODULE ulmStrings;
IMPORT Events := ulmEvents, Priorities := ulmPriorities, RelatedEvents := ulmRelatedEvents, Services := ulmServices, Streams := ulmStreams,
SYS := SYSTEM, Types := ulmTypes;
TYPE
Address = Types.Address;
Count = Types.Count;
Byte = Types.Byte;
Stream* = POINTER TO StreamRec;
StreamRec* =
RECORD
(Streams.StreamRec)
(* private part *)
addr: Address; (* SYS.ADR(string[0]) *)
len: Count; (* LEN(string) *)
termindex: Count; (* position of 0X *)
pos: Count; (* 0 <= pos <= termindex < len *)
END;
VAR
type: Services.Type; (* Strings.Stream *)
CONST
(* error codes *)
endOfStringReached* = 0; (* write failure: end of string reached *)
outOfRange* = 1; (* seek failure: position out of range *)
badParameter* = 2; (* illegal parameter value (eg whence) *)
posOutside* = 3; (* trunc failure: position beyond trunc pos *)
errorcodes* = 4;
TYPE
ErrorCode* = SHORTINT;
Event* = POINTER TO EventRec;
EventRec* =
RECORD
(Events.EventRec)
stream*: Streams.Stream;
errorcode*: ErrorCode;
END;
VAR
errormsg*: ARRAY errorcodes OF Events.Message;
error*: Events.EventType;
(* raised on errorneous stream operations;
ignored by default
*)
VAR
if: Streams.Interface;
caps: Streams.CapabilitySet;
(* 1st parameter: destination
2nd parameter: source
resulting strings are guaranteed to be 0X-terminated
*)
(* ======= string to stream operations =========================== *)
PROCEDURE WritePart*(stream: Streams.Stream; string: ARRAY OF CHAR;
sourceIndex: LONGINT);
(* seek to position 0 of `stream' and
copy string[sourceIndex..] to it;
the file pointer of `stream' is left on position 0
*)
VAR
index: LONGINT;
BEGIN
IF ~Streams.Seek(stream, 0, Streams.fromStart) OR
~Streams.Trunc(stream, 0) THEN
RETURN
END;
index := sourceIndex;
WHILE (index < LEN(string)) & (string[index] # 0X) DO
INC(index);
END;
IF ~Streams.WritePart(stream, string, sourceIndex, index-sourceIndex) OR
~Streams.Seek(stream, 0, Streams.fromStart) THEN
END;
END WritePart;
PROCEDURE Write*(stream: Streams.Stream; string: ARRAY OF CHAR);
(* seek to position 0 of `stream' and
copy 0X-terminated string to `stream'
*)
BEGIN
WritePart(stream, string, 0);
END Write;
(* ======= stream to string operations =========================== *)
PROCEDURE ReadPart*(VAR string: ARRAY OF CHAR; destIndex: LONGINT;
stream: Streams.Stream);
(* like `Read' but fill string[destIndex..] *)
VAR
len: LONGINT;
endIndex: LONGINT;
BEGIN
len := LEN(string);
IF Streams.Seek(stream, 0, Streams.fromStart) & (destIndex < len) THEN
IF ~Streams.ReadPart(stream, string, destIndex, len-destIndex) THEN
(* ReadPart fails if less than len-destIndex can be read *)
END;
endIndex := destIndex + stream.count;
IF endIndex >= len THEN
endIndex := len-1;
END;
IF ~Streams.Seek(stream, 0, Streams.fromStart) THEN
END;
ELSE
endIndex := 0;
END;
string[endIndex] := 0X;
END ReadPart;
PROCEDURE Read*(VAR string: ARRAY OF CHAR; stream: Streams.Stream);
(* copy contents of `stream' from position 0 until end of file;
`string' is guaranteed to be 0X-terminated;
the file pointer of `stream' is left on position 0
*)
BEGIN
ReadPart(string, 0, stream);
END Read;
(* ======= string to string operations =========================== *)
PROCEDURE Copy*(VAR destination: ARRAY OF CHAR;
source: ARRAY OF CHAR);
VAR
index: LONGINT;
minlen: LONGINT;
BEGIN
minlen := LEN(destination);
IF minlen > LEN(source) THEN
minlen := LEN(source);
END;
(* minlen is guaranteed to be positive here
because "ARRAY 0 OF CHAR" is not a legal type
*)
DEC(minlen);
index := 0;
WHILE (index < minlen) & (source[index] # 0X) DO
destination[index] := source[index];
INC(index);
END;
destination[index] := 0X;
END Copy;
PROCEDURE PartCopy*(VAR destination: ARRAY OF CHAR; destIndex: LONGINT;
source: ARRAY OF CHAR; sourceIndex: LONGINT);
(* copy source[sourceIndex..] to destination[destIndex..] *)
BEGIN
WHILE (destIndex+1 < LEN(destination)) &
(sourceIndex < LEN(source)) &
(source[sourceIndex] # 0X) DO
destination[destIndex] := source[sourceIndex];
INC(destIndex); INC(sourceIndex);
END;
IF destIndex < LEN(destination) THEN
destination[destIndex] := 0X;
END;
END PartCopy;
PROCEDURE Len*(string: ARRAY OF CHAR) : LONGINT;
(* returns the number of characters (without terminating 0X) *)
VAR
len: LONGINT;
BEGIN
len := 0;
WHILE (len < LEN(string)) & (string[len] # 0X) DO
INC(len);
END;
RETURN len
END Len;
PROCEDURE Concatenate*(VAR destination: ARRAY OF CHAR;
source: ARRAY OF CHAR);
(* append source to destination;
PartCopy(destination, Len(destination), source, 0);
*)
BEGIN
PartCopy(destination, Len(destination), source, 0);
END Concatenate;
(* ======= strings as streams ==================================== *)
PROCEDURE Error(stream: Streams.Stream; code: ErrorCode);
VAR
event: Event;
BEGIN
NEW(event);
event.type := error;
event.message := errormsg[code];
event.stream := stream;
event.errorcode := code;
RelatedEvents.Raise(stream, event);
END Error;
PROCEDURE ReadByte(stream: Streams.Stream; VAR byte: Byte) : BOOLEAN;
BEGIN
WITH stream: Stream DO
IF stream.pos < stream.termindex THEN
SYS.GET(stream.addr + stream.pos, byte);
INC(stream.pos);
RETURN TRUE
ELSE
RETURN FALSE
END;
END;
END ReadByte;
PROCEDURE WriteByte(stream: Streams.Stream; byte: Byte) : BOOLEAN;
BEGIN
WITH stream: Stream DO
IF ORD(SYS.VAL(CHAR, byte)) = 0 THEN RETURN FALSE END;
IF stream.pos < stream.termindex THEN
SYS.PUT(stream.addr + stream.pos, byte);
INC(stream.pos);
ELSIF (stream.pos = stream.termindex) &
(stream.termindex+1 < stream.len) THEN
SYS.PUT(stream.addr + stream.pos, byte);
INC(stream.pos);
INC(stream.termindex);
SYS.PUT(stream.addr + stream.termindex, 0X);
ELSE
Error(stream, endOfStringReached);
RETURN FALSE
END;
RETURN TRUE
END;
END WriteByte;
PROCEDURE Seek(stream: Streams.Stream;
offset: Streams.Count; whence: Streams.Whence) : BOOLEAN;
VAR
newpos: Streams.Count;
BEGIN
WITH stream: Stream DO
CASE whence OF
| Streams.fromStart: newpos := offset;
| Streams.fromPos: newpos := stream.pos + offset;
| Streams.fromEnd: newpos := stream.termindex + offset;
ELSE
Error(stream, badParameter);
RETURN FALSE
END;
IF (newpos < 0) OR (newpos > stream.termindex) THEN
Error(stream, outOfRange);
RETURN FALSE
END;
stream.pos := newpos;
RETURN TRUE
END;
END Seek;
PROCEDURE Tell(stream: Streams.Stream; VAR pos: Streams.Count) : BOOLEAN;
BEGIN
WITH stream: Stream DO
pos := stream.pos;
RETURN TRUE
END;
END Tell;
PROCEDURE Trunc(stream: Streams.Stream; length: Streams.Count) : BOOLEAN;
BEGIN
WITH stream: Stream DO
IF (length >= 0) & (length <= stream.termindex) &
(stream.pos <= length) THEN
stream.termindex := length;
SYS.PUT(stream.addr + stream.termindex, 0X);
RETURN TRUE
ELSE
IF (length >= 0) & (length <= stream.termindex) THEN
Error(stream, outOfRange);
ELSE
Error(stream, posOutside);
END;
RETURN FALSE
END;
END;
END Trunc;
PROCEDURE Flush(s: Streams.Stream) : BOOLEAN;
VAR
len: LONGINT;
ch: CHAR;
BEGIN
WITH s: Stream DO
len := 0;
LOOP
IF len = s.len THEN EXIT END;
SYS.GET(s.addr + len, ch);
IF ch = 0X THEN EXIT END;
INC(len);
END;
s.termindex := len;
IF s.termindex = s.len THEN
(* enforce 0X-termination *)
DEC(s.termindex);
SYS.PUT(s.addr + s.termindex, 0X);
END;
IF s.pos > s.termindex THEN
s.pos := s.termindex;
END;
END;
RETURN TRUE
END Flush;
PROCEDURE Open*(VAR stream: Streams.Stream; VAR string: ARRAY OF CHAR);
(* opens string for reading and writing; seek & tell are permitted;
0X-termination of string is guaranteed;
*)
VAR
newstream: Stream;
BEGIN
NEW(newstream);
Services.Init(newstream, type);
Streams.Init(newstream, if, caps, Streams.nobuf);
newstream.addr := SYS.ADR(string);
newstream.len := LEN(string);
newstream.termindex := Len(string);
IF newstream.termindex = LEN(string) THEN
(* enforce 0X-termination *)
DEC(newstream.termindex);
string[newstream.termindex] := 0X;
END;
newstream.pos := 0;
RelatedEvents.QueueEvents(newstream);
stream := newstream;
END Open;
BEGIN
NEW(if);
if.read := ReadByte; if.write := WriteByte;
if.seek := Seek; if.tell := Tell; if.trunc := Trunc; if.flush := Flush;
caps := {Streams.read, Streams.write, Streams.seek, Streams.tell,
Streams.trunc, Streams.flush};
Services.CreateType(type, "Strings.Stream", "Streams.Stream");
errormsg[endOfStringReached] := "end of string reached";
errormsg[outOfRange] := "position out of range";
errormsg[badParameter] := "illegal parameter value";
errormsg[posOutside] := "current position beyond intended trunc position";
Events.Define(error);
Events.SetPriority(error, Priorities.liberrors);
Events.Ignore(error);
END ulmStrings.

316
src/library/ulm/ulmSys.Mod Normal file
View file

@ -0,0 +1,316 @@
(* DO NOT EDIT! Generated by Sys.pl. *)
MODULE ulmSys;
CONST
(* nisyscall = 0; *) statfs* = 99;
exit* = 1; fstatfs* = 100;
fork* = 2; ioperm* = 101;
read* = 3; socketcall* = 102;
write* = 4; syslog* = 103;
open* = 5; setitimer* = 104;
close* = 6; getitimer* = 105;
waitpid* = 7; newstat* = 106;
creat* = 8; newlstat* = 107;
link* = 9; newfstat* = 108;
unlink* = 10; uname* = 109;
execve* = 11; iopl* = 110;
chdir* = 12; vhangup* = 111;
time* = 13; idle* = 112;
mknod* = 14; vm86old* = 113;
chmod* = 15; wait4* = 114;
lchown* = 16; swapoff* = 115;
(* nisyscall = 17; *) sysinfo* = 116;
stat* = 18; ipc* = 117;
lseek* = 19; fsync* = 118;
getpid* = 20; sigreturn* = 119;
mount* = 21; clone* = 120;
oldumount* = 22; setdomainname* = 121;
setuid* = 23; newuname* = 122;
getuid* = 24; modifyldt* = 123;
stime* = 25; adjtimex* = 124;
ptrace* = 26; mprotect* = 125;
alarm* = 27; sigprocmask* = 126;
fstat* = 28; createmodule* = 127;
pause* = 29; initmodule* = 128;
utime* = 30; deletemodule* = 129;
(* nisyscall = 31; *) getkernelsyms* = 130;
(* nisyscall = 32; *) quotactl* = 131;
access* = 33; getpgid* = 132;
nice* = 34; fchdir* = 133;
(* nisyscall = 35; *) bdflush* = 134;
sync* = 36; sysfs* = 135;
kill* = 37; personality* = 136;
rename* = 38; (* nisyscall = 137; *)
mkdir* = 39; setfsuid* = 138;
rmdir* = 40; setfsgid* = 139;
dup* = 41; llseek* = 140;
pipe* = 42; getdents* = 141;
times* = 43; select* = 142;
(* nisyscall = 44; *) flock* = 143;
brk* = 45; msync* = 144;
setgid* = 46; readv* = 145;
getgid* = 47; writev* = 146;
signal* = 48; getsid* = 147;
geteuid* = 49; fdatasync* = 148;
getegid* = 50; sysctl* = 149;
acct* = 51; mlock* = 150;
umount* = 52; munlock* = 151;
(* nisyscall = 53; *) mlockall* = 152;
ioctl* = 54; munlockall* = 153;
fcntl* = 55; schedsetparam* = 154;
(* nisyscall = 56; *) schedgetparam* = 155;
setpgid* = 57; schedsetscheduler* = 156;
(* nisyscall = 58; *) schedgetscheduler* = 157;
olduname* = 59; schedyield* = 158;
umask* = 60; schedgetprioritymax* = 159;
chroot* = 61; schedgetprioritymin* = 160;
ustat* = 62; schedrrgetinterval* = 161;
dup2* = 63; nanosleep* = 162;
getppid* = 64; mremap* = 163;
getpgrp* = 65; setresuid* = 164;
setsid* = 66; getresuid* = 165;
sigaction* = 67; vm86* = 166;
sgetmask* = 68; querymodule* = 167;
ssetmask* = 69; poll* = 168;
setreuid* = 70; nfsservctl* = 169;
setregid* = 71; setresgid* = 170;
sigsuspend* = 72; getresgid* = 171;
sigpending* = 73; prctl* = 172;
sethostname* = 74; rtsigreturn* = 173;
setrlimit* = 75; rtsigaction* = 174;
getrlimit* = 76; rtsigprocmask* = 175;
getrusage* = 77; rtsigpending* = 176;
gettimeofday* = 78; rtsigtimedwait* = 177;
settimeofday* = 79; rtsigqueueinfo* = 178;
getgroups* = 80; rtsigsuspend* = 179;
setgroups* = 81; pread* = 180;
oldselect* = 82; pwrite* = 181;
symlink* = 83; chown* = 182;
lstat* = 84; getcwd* = 183;
readlink* = 85; capget* = 184;
uselib* = 86; capset* = 185;
swapon* = 87; sigaltstack* = 186;
reboot* = 88; sendfile* = 187;
oldreaddir* = 89; (* nisyscall = 188; *)
oldmmap* = 90; (* nisyscall = 189; *)
munmap* = 91; vfork* = 190;
truncate* = 92; (* nisyscall = 191; *)
ftruncate* = 93; mmap2* = 192;
fchmod* = 94; truncate64* = 193;
fchown* = 95; ftruncate64* = 194;
getpriority* = 96; stat64* = 195;
setpriority* = 97; lstat64* = 196;
(* nisyscall = 98; *) fstat64* = 197;
ncalls* = 198;
namelen* = 20;
TYPE
Name* = ARRAY namelen OF CHAR;
VAR
name*: ARRAY ncalls OF Name;
BEGIN
name[0] := "NOSYS";
name[1] := "exit";
name[2] := "fork";
name[3] := "read";
name[4] := "write";
name[5] := "open";
name[6] := "close";
name[7] := "waitpid";
name[8] := "creat";
name[9] := "link";
name[10] := "unlink";
name[11] := "execve";
name[12] := "chdir";
name[13] := "time";
name[14] := "mknod";
name[15] := "chmod";
name[16] := "lchown";
name[17] := "NOSYS";
name[18] := "stat";
name[19] := "lseek";
name[20] := "getpid";
name[21] := "mount";
name[22] := "oldumount";
name[23] := "setuid";
name[24] := "getuid";
name[25] := "stime";
name[26] := "ptrace";
name[27] := "alarm";
name[28] := "fstat";
name[29] := "pause";
name[30] := "utime";
name[31] := "NOSYS";
name[32] := "NOSYS";
name[33] := "access";
name[34] := "nice";
name[35] := "NOSYS";
name[36] := "sync";
name[37] := "kill";
name[38] := "rename";
name[39] := "mkdir";
name[40] := "rmdir";
name[41] := "dup";
name[42] := "pipe";
name[43] := "times";
name[44] := "NOSYS";
name[45] := "brk";
name[46] := "setgid";
name[47] := "getgid";
name[48] := "signal";
name[49] := "geteuid";
name[50] := "getegid";
name[51] := "acct";
name[52] := "umount";
name[53] := "NOSYS";
name[54] := "ioctl";
name[55] := "fcntl";
name[56] := "NOSYS";
name[57] := "setpgid";
name[58] := "NOSYS";
name[59] := "olduname";
name[60] := "umask";
name[61] := "chroot";
name[62] := "ustat";
name[63] := "dup2";
name[64] := "getppid";
name[65] := "getpgrp";
name[66] := "setsid";
name[67] := "sigaction";
name[68] := "sgetmask";
name[69] := "ssetmask";
name[70] := "setreuid";
name[71] := "setregid";
name[72] := "sigsuspend";
name[73] := "sigpending";
name[74] := "sethostname";
name[75] := "setrlimit";
name[76] := "getrlimit";
name[77] := "getrusage";
name[78] := "gettimeofday";
name[79] := "settimeofday";
name[80] := "getgroups";
name[81] := "setgroups";
name[82] := "oldselect";
name[83] := "symlink";
name[84] := "lstat";
name[85] := "readlink";
name[86] := "uselib";
name[87] := "swapon";
name[88] := "reboot";
name[89] := "oldreaddir";
name[90] := "oldmmap";
name[91] := "munmap";
name[92] := "truncate";
name[93] := "ftruncate";
name[94] := "fchmod";
name[95] := "fchown";
name[96] := "getpriority";
name[97] := "setpriority";
name[98] := "NOSYS";
name[99] := "statfs";
name[100] := "fstatfs";
name[101] := "ioperm";
name[102] := "socketcall";
name[103] := "syslog";
name[104] := "setitimer";
name[105] := "getitimer";
name[106] := "newstat";
name[107] := "newlstat";
name[108] := "newfstat";
name[109] := "uname";
name[110] := "iopl";
name[111] := "vhangup";
name[112] := "idle";
name[113] := "vm86old";
name[114] := "wait4";
name[115] := "swapoff";
name[116] := "sysinfo";
name[117] := "ipc";
name[118] := "fsync";
name[119] := "sigreturn";
name[120] := "clone";
name[121] := "setdomainname";
name[122] := "newuname";
name[123] := "modifyldt";
name[124] := "adjtimex";
name[125] := "mprotect";
name[126] := "sigprocmask";
name[127] := "createmodule";
name[128] := "initmodule";
name[129] := "deletemodule";
name[130] := "getkernelsyms";
name[131] := "quotactl";
name[132] := "getpgid";
name[133] := "fchdir";
name[134] := "bdflush";
name[135] := "sysfs";
name[136] := "personality";
name[137] := "NOSYS";
name[138] := "setfsuid";
name[139] := "setfsgid";
name[140] := "llseek";
name[141] := "getdents";
name[142] := "select";
name[143] := "flock";
name[144] := "msync";
name[145] := "readv";
name[146] := "writev";
name[147] := "getsid";
name[148] := "fdatasync";
name[149] := "sysctl";
name[150] := "mlock";
name[151] := "munlock";
name[152] := "mlockall";
name[153] := "munlockall";
name[154] := "schedsetparam";
name[155] := "schedgetparam";
name[156] := "schedsetscheduler";
name[157] := "schedgetscheduler";
name[158] := "schedyield";
name[159] := "schedgetprioritymax";
name[160] := "schedgetprioritymin";
name[161] := "schedrrgetinterval";
name[162] := "nanosleep";
name[163] := "mremap";
name[164] := "setresuid";
name[165] := "getresuid";
name[166] := "vm86";
name[167] := "querymodule";
name[168] := "poll";
name[169] := "nfsservctl";
name[170] := "setresgid";
name[171] := "getresgid";
name[172] := "prctl";
name[173] := "rtsigreturn";
name[174] := "rtsigaction";
name[175] := "rtsigprocmask";
name[176] := "rtsigpending";
name[177] := "rtsigtimedwait";
name[178] := "rtsigqueueinfo";
name[179] := "rtsigsuspend";
name[180] := "pread";
name[181] := "pwrite";
name[182] := "chown";
name[183] := "getcwd";
name[184] := "capget";
name[185] := "capset";
name[186] := "sigaltstack";
name[187] := "sendfile";
name[188] := "NOSYS";
name[189] := "NOSYS";
name[190] := "vfork";
name[191] := "NOSYS";
name[192] := "mmap2";
name[193] := "truncate64";
name[194] := "ftruncate64";
name[195] := "stat64";
name[196] := "lstat64";
name[197] := "fstat64";
END ulmSys.

574
src/library/ulm/ulmSysConversions.Mod Normal file
View file

@ -0,0 +1,574 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: SysConversi.om,v 1.2 1997/07/30 09:38:16 borchert Exp $
----------------------------------------------------------------------------
$Log: SysConversi.om,v $
Revision 1.2 1997/07/30 09:38:16 borchert
bug in ReadConv fixed: cv.flags was used but not set for
counts > 1
Revision 1.1 1994/02/23 07:58:28 borchert
Initial revision
----------------------------------------------------------------------------
AFB 8/90
adapted to linux cae 02/01
----------------------------------------------------------------------------
*)
MODULE ulmSysConversions;
(* convert Oberon records to/from C structures *)
IMPORT Events := ulmEvents, Objects := ulmObjects, Priorities := ulmPriorities, Streams := ulmStreams, Strings := ulmStrings,
SYS := SYSTEM, SysTypes := ulmSysTypes, Texts := ulmTexts;
TYPE
Address* = SysTypes.Address;
Size* = Address;
(* format:
Format = Conversion { "/" Conversion } .
Conversion = [ Factors ] ConvChars [ Comment ] .
Factors = Array | Factor | Array Factor | Factor Array .
Array = Integer ":" .
Factor = Integer "*" .
ConvChars = OberonType CType | Skip CType | OberonType Skip .
OberonType = "a" | "b" | "c" | "s" | "i" | "l" | "S" .
CType = "a" | "c" | "s" | "i" | "l" .
Integer = Digit { Digit } .
Digit = "0" | "1" | "2" | "3" | "4" | "5" | "6" | "7" | "8" | "9" .
Skip = "-" .
Comment = "=" { AnyChar } .
AnyChar = (* all characters except "/" *) .
Oberon data types:
a: Address
b: SYS.BYTE
B: BOOLEAN
c: CHAR
s: SHORTINT
i: INTEGER
l: LONGINT
S: SET
C data types:
a: char *
c: /* signed */ char
C: unsigned char
s: short int
S: unsigned short int
i: int
I: unsigned int
u: unsigned int
l: long int
L: unsigned long int
example:
conversion from
Rec =
RECORD
a, b: INTEGER;
c: CHAR;
s: SET;
f: ARRAY 3 OF INTEGER;
END;
to
struct rec {
short a, b;
char c;
int xx; /* to be skipped on conversion */
int s;
int f[3];
};
or vice versa:
"2*is=a,b/cc=c/-i=xx/Si=s/3:ii=f"
The comments allow to give the field names.
*)
CONST
(* conversion flags *)
unsigned = 0; (* suppress sign extension *)
boolean = 1; (* convert anything # 0 to 1 *)
TYPE
Flags = SET;
Event* = POINTER TO EventRec;
EventRec* =
RECORD
(Events.EventRec)
format*: Events.Message;
END;
ConvStream = POINTER TO ConvStreamRec;
ConvStreamRec =
RECORD
fmt: Texts.Text;
char: CHAR;
eof: BOOLEAN;
(* 1: Oberon type
2: C type
*)
type1, type2: CHAR; length: INTEGER; left: INTEGER;
offset1, offset2: Address;
size1, size2: Address; elementsleft: INTEGER; flags: Flags;
END;
Format* = POINTER TO FormatRec;
FormatRec* =
RECORD
(Objects.ObjectRec)
offset1, offset2: Address;
size1, size2: Address;
flags: Flags;
next: Format;
END;
VAR
badformat*: Events.EventType;
PROCEDURE Error(cv: ConvStream; msg: ARRAY OF CHAR);
VAR
event: Event;
BEGIN
NEW(event);
event.type := badformat;
event.message := "SysConversions: ";
Strings.Concatenate(event.message, msg);
Strings.Read(event.format, cv.fmt);
Events.Raise(event);
cv.eof := TRUE;
cv.char := 0X;
cv.left := 0;
cv.elementsleft := 0;
END Error;
PROCEDURE SizeError(msg, format: ARRAY OF CHAR);
VAR
event: Event;
BEGIN
NEW(event);
event.type := badformat;
event.message := "SysConversions: ";
Strings.Concatenate(event.message, msg);
COPY(format, event.format);
Events.Raise(event);
END SizeError;
PROCEDURE NextCh(cv: ConvStream);
BEGIN
cv.eof := cv.eof OR ~Streams.ReadByte(cv.fmt, cv.char) OR (cv.char = 0X);
IF cv.eof THEN
cv.char := 0X;
END;
END NextCh;
PROCEDURE IsDigit(ch: CHAR) : BOOLEAN;
BEGIN
RETURN (ch >= "0") & (ch <= "9")
END IsDigit;
PROCEDURE ReadInt(cv: ConvStream; VAR i: INTEGER);
BEGIN
i := 0;
REPEAT
i := 10 * i + ORD(cv.char) - ORD("0");
NextCh(cv);
UNTIL ~IsDigit(cv.char);
END ReadInt;
PROCEDURE Open(VAR cv: ConvStream; format: ARRAY OF CHAR);
BEGIN
NEW(cv);
Texts.Open(SYS.VAL(Streams.Stream, cv.fmt));
Strings.Write(cv.fmt, format);
cv.left := 0; cv.elementsleft := 0;
cv.offset1 := 0; cv.offset2 := 0;
cv.eof := FALSE;
NextCh(cv);
END Open;
PROCEDURE Close(VAR cv: ConvStream);
BEGIN
IF ~Streams.Close(cv.fmt) THEN END;
END Close;
PROCEDURE ScanConv(cv: ConvStream;
VAR type1, type2: CHAR;
VAR length: INTEGER) : BOOLEAN;
VAR
i: INTEGER;
factor: INTEGER;
BEGIN
IF cv.left > 0 THEN
type1 := cv.type1;
type2 := cv.type2;
length := cv.length;
DEC(cv.left);
RETURN TRUE
END;
IF cv.char = "/" THEN
NextCh(cv);
END;
IF cv.eof THEN
RETURN FALSE
END;
factor := 0; length := 0;
WHILE IsDigit(cv.char) DO
ReadInt(cv, i);
IF i <= 0 THEN
Error(cv, "integer must be positive"); RETURN FALSE
END;
IF cv.char = ":" THEN
IF length # 0 THEN
Error(cv, "multiple length specification"); RETURN FALSE
END;
length := i;
NextCh(cv);
ELSIF cv.char = "*" THEN
IF factor # 0 THEN
Error(cv, "multiple factor specification"); RETURN FALSE
END;
factor := i; cv.left := factor - 1;
NextCh(cv);
ELSE
Error(cv, "factor or length expected"); RETURN FALSE
END;
END;
type1 := cv.char; NextCh(cv);
type2 := cv.char; NextCh(cv);
IF cv.left > 0 THEN
cv.type1 := type1; cv.type2 := type2; cv.length := length;
END;
IF cv.char = "=" THEN (* comment *)
REPEAT
NextCh(cv);
UNTIL cv.eof OR (cv.char = "/");
END;
RETURN TRUE
END ScanConv;
PROCEDURE Align(VAR offset: Address; boundary: Address);
BEGIN
IF SYS.VAL (INTEGER, offset) MOD SYS.VAL (INTEGER, boundary) # 0 THEN
offset := SYS.VAL (INTEGER, offset) + (SYS.VAL (INTEGER, boundary) - SYS.VAL (INTEGER, offset) MOD SYS.VAL (INTEGER, boundary));
END;
END Align;
PROCEDURE ReadConv(cv: ConvStream;
VAR offset1, offset2: Address;
VAR size1, size2: Address;
VAR flags: Flags) : BOOLEAN;
VAR
type1, type2: CHAR;
length: INTEGER;
align: BOOLEAN;
boundary: INTEGER;
BEGIN
IF cv.elementsleft > 0 THEN
DEC(cv.elementsleft);
(* Oberon type *)
IF size1 > SIZE(SYS.BYTE) THEN
Align(cv.offset1, SIZE(INTEGER));
END;
offset1 := cv.offset1; cv.offset1 := SYS.VAL (INTEGER, cv.offset1) + size1;
size1 := cv.size1; size2 := cv.size2; flags := cv.flags;
IF (size1 > 0) & (cv.elementsleft = 0) THEN
Align(cv.offset1, SIZE(INTEGER));
END;
(* C type *)
IF size2 > 1 THEN
Align(cv.offset2, 2);
END;
offset2 := cv.offset2; cv.offset2 := SYS.VAL (INTEGER, cv.offset2) + SYS.VAL (INTEGER, size2);
RETURN TRUE
END;
IF ScanConv(cv, type1, type2, length) THEN
flags := {};
(* Oberon type *)
CASE type1 OF
| "a": size1 := SIZE(Address); INCL(flags, unsigned);
| "b": size1 := SIZE(SYS.BYTE); INCL(flags, unsigned);
| "B": size1 := SIZE(BOOLEAN); INCL(flags, boolean);
| "c": size1 := SIZE(CHAR); INCL(flags, unsigned);
| "s": size1 := SIZE(SHORTINT);
| "i": size1 := SIZE(INTEGER);
| "l": size1 := SIZE(LONGINT);
| "S": size1 := SIZE(SET); INCL(flags, unsigned);
| "-": size1 := 0;
ELSE Error(cv, "bad Oberon type specifier"); RETURN FALSE
END;
IF size1 > 0 THEN
IF length > 0 THEN
Align(cv.offset1, SIZE(INTEGER));
ELSIF size1 > SIZE(SYS.BYTE) THEN
Align(cv.offset1, SIZE(INTEGER));
END;
END;
offset1 := cv.offset1; cv.offset1 := SYS.VAL (INTEGER, cv.offset1) + size1;
(* C type *)
CASE type2 OF
| "a": size2 := 8; INCL(flags, unsigned); (* char* *)
| "c": size2 := 1; (* /* signed */ char *)
| "C": size2 := 1; INCL(flags, unsigned); (* unsigned char *)
| "s": size2 := 2; (* short int *)
| "S": size2 := 2; INCL(flags, unsigned); (* unsigned short int *)
| "i": size2 := 4; (* int *)
| "I": size2 := 4; INCL(flags, unsigned); (* unsigned int *)
| "u": size2 := 4; INCL(flags, unsigned); (* unsigned int *)
| "l": size2 := 8; (* long int *)
| "L": size2 := 8; INCL(flags, unsigned); (* long int *)
| "-": size2 := 0;
ELSE Error(cv, "bad C type specifier"); RETURN FALSE
END;
IF size2 > 1 THEN
Align(cv.offset2, size2);
END;
offset2 := cv.offset2; cv.offset2 := SYS.VAL (INTEGER, cv.offset2) + SYS.VAL (INTEGER, size2);
cv.size1 := size1; cv.size2 := size2;
IF length > 0 THEN
cv.elementsleft := length - 1;
cv.flags := flags;
END;
RETURN TRUE
ELSE
RETURN FALSE
END;
END ReadConv;
PROCEDURE Convert(from, to: Address; ssize, dsize: Address; flags: Flags);
TYPE
Bytes = ARRAY 8 OF CHAR;
Pointer = POINTER TO Bytes;
VAR
dest, source: Pointer;
dindex, sindex: INTEGER;
nonzero: BOOLEAN;
fill : CHAR;
BEGIN
IF ssize > 0 THEN
dest := SYS.VAL(Pointer, to);
source := SYS.VAL(Pointer, from);
dindex := 0; sindex := 0;
IF boolean IN flags THEN
nonzero := FALSE;
WHILE ssize > 0 DO
nonzero := nonzero OR (source[sindex] # 0X);
INC(sindex); ssize := SYS.VAL (INTEGER, ssize) - 1;
END;
IF dsize > 0 THEN
IF nonzero THEN
dest[dindex] := 1X;
ELSE
dest[dindex] := 0X;
END;
dsize := dsize - 1; INC (dindex);
END;
WHILE dsize > 0 DO
dest[dindex] := 0X;
dsize := SYS.VAL (INTEGER, dsize) - 1; INC(dindex);
END;
ELSE
WHILE (dsize > 0) & (ssize > 0) DO
dest[dindex] := source[sindex];
ssize := SYS.VAL (INTEGER, ssize) - 1;
dsize := dsize - 1;
INC(dindex); INC(sindex);
END;
IF dsize > 0 THEN
(* sindex has been incremented at least once because
* ssize and dsize were greater than 0, i.e. sindex-1
* is a valid inex. *)
fill := 0X;
IF ~(unsigned IN flags) & (source[sindex-1] >= 080X) THEN
fill := 0FFX;
END;
END;
WHILE dsize > 0 DO
dest[dindex] := fill;
dsize := SYS.VAL (INTEGER, dsize) - 1; INC(dindex);
END;
END;
END;
END Convert;
PROCEDURE ByAddrToC*(from, to: Address; format: ARRAY OF CHAR);
VAR
cv: ConvStream;
offset1, offset2, size1, size2: Address;
flags: Flags;
BEGIN
Open(cv, format);
WHILE ReadConv(cv, offset1, offset2, size1, size2, flags) DO
Convert(from + offset1, to + offset2, size1, size2, flags);
END;
Close(cv);
END ByAddrToC;
PROCEDURE ByAddrFromC*(from, to: Address; format: ARRAY OF CHAR);
VAR
cv: ConvStream;
offset1, offset2, size1, size2: Address;
flags: Flags;
BEGIN
Open(cv, format);
WHILE ReadConv(cv, offset1, offset2, size1, size2, flags) DO
Convert(from + offset2, to + offset1, size2, size1, flags);
END;
Close(cv);
END ByAddrFromC;
PROCEDURE CSize*(format: ARRAY OF CHAR) : Size;
(* returns the size of the C-structure described by `format' *)
VAR
cv: ConvStream;
offset1, offset2, size1, size2: Address;
size: Address;
flags: Flags;
BEGIN
Open(cv, format);
WHILE ReadConv(cv, offset1, offset2, size1, size2, flags) DO END;
Close(cv);
size := offset2 + size2;
Align(size, 2);
RETURN size
END CSize;
PROCEDURE OberonSize*(format: ARRAY OF CHAR) : Size;
(* returns the size of the Oberon-structure described by `format' *)
VAR
cv: ConvStream;
offset1, offset2, size1, size2: Address;
size: Address;
flags: Flags;
BEGIN
Open(cv, format);
WHILE ReadConv(cv, offset1, offset2, size1, size2, flags) DO END;
Close(cv);
size := offset1 + size1;
Align(size, SIZE(INTEGER));
RETURN size
END OberonSize;
PROCEDURE ToC*(VAR from, to: ARRAY OF SYS.BYTE; format: ARRAY OF CHAR);
BEGIN
IF OberonSize(format) > LEN(from) THEN
SizeError("Oberon record is too small", format); RETURN
END;
IF CSize(format) > LEN(to) THEN
SizeError("C structure is too small", format); RETURN
END;
ByAddrToC(SYS.ADR(from), SYS.ADR(to), format);
END ToC;
PROCEDURE FromC*(VAR from, to: ARRAY OF SYS.BYTE; format: ARRAY OF CHAR);
BEGIN
IF OberonSize(format) > LEN(to) THEN
SizeError("Oberon record is too small", format); RETURN
END;
IF CSize(format) > LEN(from) THEN
SizeError("C structure is too small", format); RETURN
END;
ByAddrFromC(SYS.ADR(from), SYS.ADR(to), format);
END FromC;
PROCEDURE Compile*(VAR fmt: Format; format: ARRAY OF CHAR);
(* translate format into an internal representation
which is later referenced by fmt;
ByFmtToC and ByFmtFromC are faster than ToC and FromC
*)
VAR
cv: ConvStream;
offset1, offset2, size1, size2: Address;
flags: Flags;
element: Format;
head, tail: Format;
BEGIN
Open(cv, format);
head := NIL; tail := NIL;
WHILE ReadConv(cv, offset1, offset2, size1, size2, flags) DO
NEW(element);
element.offset1 := offset1;
element.offset2 := offset2;
element.size1 := size1;
element.size2 := size2;
element.flags := flags;
element.next := NIL;
IF tail # NIL THEN
tail.next := element;
ELSE
head := element;
END;
tail := element;
END;
fmt := head;
Close(cv);
END Compile;
PROCEDURE ByFmtAndAddrToC*(from, to: Address; format: Format);
VAR
offset1, offset2, size1, size2: Address;
flags: Flags;
BEGIN
WHILE format # NIL DO
Convert(from + format.offset1, to + format.offset2,
format.size1, format.size2, format.flags);
format := format.next;
END;
END ByFmtAndAddrToC;
PROCEDURE ByFmtAndAddrFromC*(from, to: Address; format: Format);
VAR
offset1, offset2, size1, size2: Address;
flags: Flags;
BEGIN
WHILE format # NIL DO
Convert(from + format.offset2, to + format.offset1,
format.size2, format.size1, format.flags);
format := format.next;
END;
END ByFmtAndAddrFromC;
PROCEDURE ByFmtToC*(VAR from, to: ARRAY OF SYS.BYTE; format: Format);
BEGIN
ByFmtAndAddrToC(SYS.ADR(from), SYS.ADR(to), format);
END ByFmtToC;
PROCEDURE ByFmtFromC*(VAR from, to: ARRAY OF SYS.BYTE; format: Format);
BEGIN
ByFmtAndAddrFromC(SYS.ADR(from), SYS.ADR(to), format);
END ByFmtFromC;
BEGIN
Events.Define(badformat);
Events.SetPriority(badformat, Priorities.liberrors);
END ulmSysConversions.

496
src/library/ulm/ulmSysErrors.Mod Normal file
View file

@ -0,0 +1,496 @@
MODULE ulmSysErrors;
IMPORT Errors := ulmErrors, Events := ulmEvents, Priorities := ulmPriorities, RelatedEvents := ulmRelatedEvents, Streams := ulmStreams, Strings := ulmStrings, Sys := ulmSys;
CONST
perm* = 1;
noent* = 2;
srch* = 3;
intr* = 4;
io* = 5;
nxio* = 6;
toobig* = 7;
noexec* = 8;
badf* = 9;
child* = 10;
again* = 11;
nomem* = 12;
acces* = 13;
fault* = 14;
notblk* = 15;
busy* = 16;
exist* = 17;
xdev* = 18;
nodev* = 19;
notdir* = 20;
isdir* = 21;
inval* = 22;
nfile* = 23;
mfile* = 24;
notty* = 25;
txtbsy* = 26;
fbig* = 27;
nospc* = 28;
spipe* = 29;
rofs* = 30;
mlink* = 31;
pipe* = 32;
dom* = 33;
range* = 34;
deadlk* = 35;
nametoolong* = 36;
nolck* = 37;
nosys* = 38;
notempty* = 39;
loop* = 40;
wouldblock* = again;
nomsg* = 42;
idrm* = 43;
chrng* = 44;
l2nsync* = 45;
l3hlt* = 46;
l3rst* = 47;
lnrng* = 48;
unatch* = 49;
nocsi* = 50;
l2hlt* = 51;
bade* = 52;
badr* = 53;
xfull* = 54;
noano* = 55;
badrqc* = 56;
badslt* = 57;
deadlock* = deadlk;
bfont* = 59;
nostr* = 60;
nodata* = 61;
time* = 62;
nosr* = 63;
nonet* = 64;
nopkg* = 65;
remote* = 66;
nolink* = 67;
adv* = 68;
srmnt* = 69;
comm* = 70;
proto* = 71;
multihop* = 72;
dotdot* = 73;
badmsg* = 74;
overflow* = 75;
notuniq* = 76;
badfd* = 77;
remchg* = 78;
libacc* = 79;
libbad* = 80;
libscn* = 81;
libmax* = 82;
libexec* = 83;
ilseq* = 84;
restart* = 85;
strpipe* = 86;
users* = 87;
notsock* = 88;
destaddrreq* = 89;
msgsize* = 90;
prototype* = 91;
noprotoopt* = 92;
protonosupport* = 93;
socktnosupport* = 94;
opnotsupp* = 95;
pfnosupport* = 96;
afnosupport* = 97;
addrinuse* = 98;
addrnotavail* = 99;
netdown* = 100;
netunreach* = 101;
netreset* = 102;
connaborted* = 103;
connreset* = 104;
nobufs* = 105;
isconn* = 106;
notconn* = 107;
shutdown* = 108;
toomanyrefs* = 109;
timedout* = 110;
connrefused* = 111;
hostdown* = 112;
hostunreach* = 113;
already* = 114;
inprogress* = 115;
stale* = 116;
uclean* = 117;
notnam* = 118;
navail* = 119;
isnam* = 120;
remoteio* = 121;
dquot* = 122;
nomedium* = 123;
mediumtype* = 124;
ncodes* = 126; (* number of error codes *)
textlen* = 512;
TYPE
Name* = ARRAY 20 OF CHAR;
Event* = POINTER TO EventRec;
EventRec* =
RECORD
(Events.EventRec)
errno*: (*INTEGER*)LONGINT;
syscall*: (*INTEGER*)LONGINT; (* number of system call *)
text*: ARRAY textlen OF CHAR;
END;
VAR
message*: ARRAY ncodes OF Events.Message;
name*: ARRAY ncodes OF Name;
syserrors*: Events.EventType;
syserror*: ARRAY ncodes OF Events.EventType;
PROCEDURE Raise*(errors: RelatedEvents.Object;
errno, syscall: (*INTEGER*)LONGINT; text: ARRAY OF CHAR); (* in ulm's system INTEGER and LONGINT have the same size *)
(* raises the events syserrors and syserrors[syscall];
`text' contains additional information (e.g. filenames);
further, the syserrors[syscall] event is passed to
RelatedEvents if object # NIL
*)
VAR
event: Event;
PROCEDURE InitEvent(VAR event: Event; type: Events.EventType);
BEGIN
NEW(event);
event.type := type;
event.message := message[errno];
event.errno := errno;
event.syscall := syscall;
COPY(text, event.text);
END InitEvent;
BEGIN
IF (errno > 0) & (errno < ncodes) THEN
InitEvent(event, syserrors); Events.Raise(event);
InitEvent(event, syserror[errno]); Events.Raise(event);
IF errors # NIL THEN
InitEvent(event, syserrors);
RelatedEvents.Raise(errors, event);
END;
END;
END Raise;
PROCEDURE Write(s: Streams.Stream; event: Events.Event);
PROCEDURE WriteString(txt: ARRAY OF CHAR);
BEGIN
IF ~Streams.WritePart(s, txt, 0, Strings.Len(txt)) THEN END;
END WriteString;
PROCEDURE Write(ch: CHAR);
BEGIN
IF ~Streams.WriteByte(s, ch) THEN END;
END Write;
PROCEDURE WriteInt(intval: LONGINT);
VAR
rest: LONGINT;
BEGIN
rest := intval DIV 10;
IF rest > 0 THEN
WriteInt(rest);
END;
Write(CHR(ORD("0") + intval MOD 10));
END WriteInt;
BEGIN
IF event IS Event THEN
WITH event: Event DO
IF event.text[0] # 0X THEN
WriteString(event.text);
WriteString(": ");
END;
IF event.errno = 0 THEN
WriteString("no error (");
WriteString(Sys.name[event.syscall]); Write(")");
ELSIF (event.errno >= ncodes) OR (message[event.errno][0] = 0X) THEN
WriteString("unknown error (");
WriteString(Sys.name[event.syscall]);
WriteString(": "); WriteInt(event.errno); Write(")");
ELSE
WriteString(message[event.errno]);
WriteString(" (");
WriteString(Sys.name[event.syscall]); WriteString(": ");
WriteString(name[event.errno]); Write(")");
END;
END;
ELSE
WriteString(event.message);
END;
END Write;
PROCEDURE InitEvents;
VAR
errno: INTEGER;
BEGIN
syserror[0] := NIL;
errno := 1;
WHILE errno < ncodes DO
Events.Define(syserror[errno]);
Events.Ignore(syserror[errno]);
Events.SetPriority(syserror[errno], Priorities.syserrors);
INC(errno);
END;
Events.Define(syserrors);
Events.Ignore(syserrors);
Events.SetPriority(syserrors, Priorities.syserrors);
Errors.AssignWriteProcedure(syserrors, Write);
END InitEvents;
BEGIN
InitEvents;
name[perm] := "EPERM";
message[perm] := "Operation not permitted";
name[noent] := "ENOENT";
message[noent] := "No such file or directory";
name[srch] := "ESRCH";
message[srch] := "No such process";
name[intr] := "EINTR";
message[intr] := "Interrupted system call";
name[io] := "EIO";
message[io] := "I/O error";
name[nxio] := "ENXIO";
message[nxio] := "No such device or address";
name[toobig] := "E2BIG";
message[toobig] := "Arg list too long";
name[noexec] := "ENOEXEC";
message[noexec] := "Exec format error";
name[badf] := "EBADF";
message[badf] := "Bad file number";
name[child] := "ECHILD";
message[child] := "No child processes";
name[again] := "EAGAIN";
message[again] := "Try again";
name[nomem] := "ENOMEM";
message[nomem] := "Out of memory";
name[acces] := "EACCES";
message[acces] := "Permission denied";
name[fault] := "EFAULT";
message[fault] := "Bad address";
name[notblk] := "ENOTBLK";
message[notblk] := "Block device required";
name[busy] := "EBUSY";
message[busy] := "Device or resource busy";
name[exist] := "EEXIST";
message[exist] := "File exists";
name[xdev] := "EXDEV";
message[xdev] := "Cross-device link";
name[nodev] := "ENODEV";
message[nodev] := "No such device";
name[notdir] := "ENOTDIR";
message[notdir] := "Not a directory";
name[isdir] := "EISDIR";
message[isdir] := "Is a directory";
name[inval] := "EINVAL";
message[inval] := "Invalid argument";
name[nfile] := "ENFILE";
message[nfile] := "File table overflow";
name[mfile] := "EMFILE";
message[mfile] := "Too many open files";
name[notty] := "ENOTTY";
message[notty] := "Not a typewriter";
name[txtbsy] := "ETXTBSY";
message[txtbsy] := "Text file busy";
name[fbig] := "EFBIG";
message[fbig] := "File too large";
name[nospc] := "ENOSPC";
message[nospc] := "No space left on device";
name[spipe] := "ESPIPE";
message[spipe] := "Illegal seek";
name[rofs] := "EROFS";
message[rofs] := "Read-only file system";
name[mlink] := "EMLINK";
message[mlink] := "Too many links";
name[pipe] := "EPIPE";
message[pipe] := "Broken pipe";
name[dom] := "EDOM";
message[dom] := "Math argument out of domain of func";
name[range] := "ERANGE";
message[range] := "Math result not representable";
name[deadlk] := "EDEADLK";
message[deadlk] := "Resource deadlock would occur";
name[nametoolong] := "ENAMETOOLONG";
message[nametoolong] := "File name too long";
name[nolck] := "ENOLCK";
message[nolck] := "No record locks available";
name[nosys] := "ENOSYS";
message[nosys] := "Function not implemented";
name[notempty] := "ENOTEMPTY";
message[notempty] := "Directory not empty";
name[loop] := "ELOOP";
message[loop] := "Too many symbolic links encountered";
name[nomsg] := "ENOMSG";
message[nomsg] := "No message of desired type";
name[idrm] := "EIDRM";
message[idrm] := "Identifier removed";
name[chrng] := "ECHRNG";
message[chrng] := "Channel number out of range";
name[l2nsync] := "EL2NSYNC";
message[l2nsync] := "Level 2 not synchronized";
name[l3hlt] := "EL3HLT";
message[l3hlt] := "Level 3 halted";
name[l3rst] := "EL3RST";
message[l3rst] := "Level 3 reset";
name[lnrng] := "ELNRNG";
message[lnrng] := "Link number out of range";
name[unatch] := "EUNATCH";
message[unatch] := "Protocol driver not attached";
name[nocsi] := "ENOCSI";
message[nocsi] := "No CSI structure available";
name[l2hlt] := "EL2HLT";
message[l2hlt] := "Level 2 halted";
name[bade] := "EBADE";
message[bade] := "Invalid exchange";
name[badr] := "EBADR";
message[badr] := "Invalid request descriptor";
name[xfull] := "EXFULL";
message[xfull] := "Exchange full";
name[noano] := "ENOANO";
message[noano] := "No anode";
name[badrqc] := "EBADRQC";
message[badrqc] := "Invalid request code";
name[badslt] := "EBADSLT";
message[badslt] := "Invalid slot";
name[bfont] := "EBFONT";
message[bfont] := "Bad font file format";
name[nostr] := "ENOSTR";
message[nostr] := "Device not a stream";
name[nodata] := "ENODATA";
message[nodata] := "No data available";
name[time] := "ETIME";
message[time] := "Timer expired";
name[nosr] := "ENOSR";
message[nosr] := "Out of streams resources";
name[nonet] := "ENONET";
message[nonet] := "Machine is not on the network";
name[nopkg] := "ENOPKG";
message[nopkg] := "Package not installed";
name[remote] := "EREMOTE";
message[remote] := "Object is remote";
name[nolink] := "ENOLINK";
message[nolink] := "Link has been severed";
name[adv] := "EADV";
message[adv] := "Advertise error";
name[srmnt] := "ESRMNT";
message[srmnt] := "Srmount error";
name[comm] := "ECOMM";
message[comm] := "Communication error on send";
name[proto] := "EPROTO";
message[proto] := "Protocol error";
name[multihop] := "EMULTIHOP";
message[multihop] := "Multihop attempted";
name[dotdot] := "EDOTDOT";
message[dotdot] := "RFS specific error";
name[badmsg] := "EBADMSG";
message[badmsg] := "Not a data message";
name[overflow] := "EOVERFLOW";
message[overflow] := "Value too large for defined data type";
name[notuniq] := "ENOTUNIQ";
message[notuniq] := "Name not unique on network";
name[badfd] := "EBADFD";
message[badfd] := "File descriptor in bad state";
name[remchg] := "EREMCHG";
message[remchg] := "Remote address changed";
name[libacc] := "ELIBACC";
message[libacc] := "Can not access a needed shared library";
name[libbad] := "ELIBBAD";
message[libbad] := "Accessing a corrupted shared library";
name[libscn] := "ELIBSCN";
message[libscn] := ".lib section in a.out corrupted";
name[libmax] := "ELIBMAX";
message[libmax] := "Attempting to link in too many shared libraries";
name[libexec] := "ELIBEXEC";
message[libexec] := "Cannot exec a shared library directly";
name[ilseq] := "EILSEQ";
message[ilseq] := "Illegal byte sequence";
name[restart] := "ERESTART";
message[restart] := "Interrupted system call should be restarted";
name[strpipe] := "ESTRPIPE";
message[strpipe] := "Streams pipe error";
name[users] := "EUSERS";
message[users] := "Too many users";
name[notsock] := "ENOTSOCK";
message[notsock] := "Socket operation on non-socket";
name[destaddrreq] := "EDESTADDRREQ";
message[destaddrreq] := "Destination address required";
name[msgsize] := "EMSGSIZE";
message[msgsize] := "Message too long";
name[prototype] := "EPROTOTYPE";
message[prototype] := "Protocol wrong type for socket";
name[noprotoopt] := "ENOPROTOOPT";
message[noprotoopt] := "Protocol not available";
name[protonosupport] := "EPROTONOSUPPORT";
message[protonosupport] := "Protocol not supported";
name[socktnosupport] := "ESOCKTNOSUPPORT";
message[socktnosupport] := "Socket type not supported";
name[opnotsupp] := "EOPNOTSUPP";
message[opnotsupp] := "Operation not supported on transport endpoint";
name[pfnosupport] := "EPFNOSUPPORT";
message[pfnosupport] := "Protocol family not supported";
name[afnosupport] := "EAFNOSUPPORT";
message[afnosupport] := "Address family not supported by protocol";
name[addrinuse] := "EADDRINUSE";
message[addrinuse] := "Address already in use";
name[addrnotavail] := "EADDRNOTAVAIL";
message[addrnotavail] := "Cannot assign requested address";
name[netdown] := "ENETDOWN";
message[netdown] := "Network is down";
name[netunreach] := "ENETUNREACH";
message[netunreach] := "Network is unreachable";
name[netreset] := "ENETRESET";
message[netreset] := "Network dropped connection because of reset";
name[connaborted] := "ECONNABORTED";
message[connaborted] := "Software caused connection abort";
name[connreset] := "ECONNRESET";
message[connreset] := "Connection reset by peer";
name[nobufs] := "ENOBUFS";
message[nobufs] := "No buffer space available";
name[isconn] := "EISCONN";
message[isconn] := "Transport endpoint is already connected";
name[notconn] := "ENOTCONN";
message[notconn] := "Transport endpoint is not connected";
name[shutdown] := "ESHUTDOWN";
message[shutdown] := "Cannot send after transport endpoint shutdown";
name[toomanyrefs] := "ETOOMANYREFS";
message[toomanyrefs] := "Too many references: cannot splice";
name[timedout] := "ETIMEDOUT";
message[timedout] := "Connection timed out";
name[connrefused] := "ECONNREFUSED";
message[connrefused] := "Connection refused";
name[hostdown] := "EHOSTDOWN";
message[hostdown] := "Host is down";
name[hostunreach] := "EHOSTUNREACH";
message[hostunreach] := "No route to host";
name[already] := "EALREADY";
message[already] := "Operation already in progress";
name[inprogress] := "EINPROGRESS";
message[inprogress] := "Operation now in progress";
name[stale] := "ESTALE";
message[stale] := "Stale NFS file handle";
name[uclean] := "EUCLEAN";
message[uclean] := "Structure needs cleaning";
name[notnam] := "ENOTNAM";
message[notnam] := "Not a XENIX named type file";
name[navail] := "ENAVAIL";
message[navail] := "No XENIX semaphores available";
name[isnam] := "EISNAM";
message[isnam] := "Is a named type file";
name[remoteio] := "EREMOTEIO";
message[remoteio] := "Remote I/O error";
name[dquot] := "EDQUOT";
message[dquot] := "Quota exceeded";
name[nomedium] := "ENOMEDIUM";
message[nomedium] := "No medium found";
name[mediumtype] := "EMEDIUMTYPE";
message[mediumtype] := "Wrong medium type";
END ulmSysErrors.

343
src/library/ulm/ulmSysIO.Mod Normal file
View file

@ -0,0 +1,343 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: SysIO.om,v 1.1 1994/02/23 07:59:15 borchert Exp $
----------------------------------------------------------------------------
$Log: SysIO.om,v $
Revision 1.1 1994/02/23 07:59:15 borchert
Initial revision
----------------------------------------------------------------------------
AFB 6/89
----------------------------------------------------------------------------
*)
MODULE ulmSysIO;
IMPORT RelatedEvents := ulmRelatedEvents, Sys := ulmSys, SYS := SYSTEM, ulmSYSTEM, SysErrors := ulmSysErrors, SysTypes := ulmSysTypes;
CONST
(* file control options: arguments of Fcntl and Open *)
rdonly* = {};
wronly* = { 0 };
rdwr* = { 1 };
append* = { 10 };
ndelay* = { 11 }; (* O_NONBLOCK that works like former O_NDELAY *)
creat* = { 6 };
trunc* = { 9 };
excl* = { 7 };
noctty* = { 8 };
sync* = { 12 };
fasync* = { 13 };
direct* = { 14 };
largefile* = { 15 };
directory* = { 16 };
nofollow* = { 17 };
(* Whence = (fromStart, fromPos, fromEnd); *)
fromStart* = 0;
fromPos* = 1;
fromEnd* = 2;
(* file descriptor flags *)
closeonexec* = { 0 };
(* Fcntl requests *)
dupfd* = 0; (* duplicate file descriptor *)
getfd* = 1; (* get file desc flags (close-on-exec) *)
setfd* = 2; (* set file desc flags (close-on-exec) *)
getfl* = 3; (* get file flags *)
setfl* = 4; (* set file flags (ndelay, append) *)
getlk* = 5; (* get file lock *)
setlk* = 6; (* set file lock *)
setlkw* = 7; (* set file lock and wait *)
setown* = 8; (* set owner (async IO) *)
getown* = 9; (* get owner (async IO) *)
setsig* = 10; (* set SIGIO replacement *)
getsig* = 11; (* get SIGIO replacement *)
TYPE
File* = SysTypes.File; (* file descriptor *)
Address* = SysTypes.Address;
Count* = SysTypes.Count;
Protection* = LONGINT;
Whence* = LONGINT;
PROCEDURE OpenCreat*(VAR fd: File;
filename: ARRAY OF CHAR; options: SET;
protection: Protection;
errors: RelatedEvents.Object;
retry: BOOLEAN; VAR interrupted: BOOLEAN) : BOOLEAN;
(* the filename must be 0X-terminated *)
VAR
d0, d1: (*INTEGER*)LONGINT;
BEGIN
interrupted := FALSE;
LOOP
IF ulmSYSTEM.UNIXCALL(Sys.open, d0, d1,
SYS.ADR(filename), SYS.VAL(LONGINT, options), protection) THEN
fd := d0;
RETURN TRUE
ELSE
IF d0 = SysErrors.intr THEN
interrupted := TRUE;
END;
IF (d0 # SysErrors.intr) OR ~retry THEN
SysErrors.Raise(errors, d0, Sys.open, filename);
RETURN FALSE
END;
END;
END;
END OpenCreat;
PROCEDURE Open*(VAR fd: File;
filename: ARRAY OF CHAR; options: SET;
errors: RelatedEvents.Object;
retry: BOOLEAN; VAR interrupted: BOOLEAN) : BOOLEAN;
(* the filename must be 0X-terminated *)
BEGIN
RETURN OpenCreat(fd, filename, options, 0, errors, retry, interrupted)
END Open;
PROCEDURE Close*(fd: File;
errors: RelatedEvents.Object;
retry: BOOLEAN; VAR interrupted: BOOLEAN) : BOOLEAN;
VAR
d0, d1: LONGINT;
a0, a1 : LONGINT; (* just to match UNIXCALL interface *)
BEGIN
interrupted := FALSE;
LOOP
IF ulmSYSTEM.UNIXCALL(Sys.close, d0, d1, fd, a0, a1) THEN
(*IF ulmSYSTEM.UNIXCALL(Sys.close, d0, d1, fd) THEN*)
RETURN TRUE
ELSE
IF d0 = SysErrors.intr THEN
interrupted := TRUE;
END;
IF (d0 # SysErrors.intr) OR ~retry THEN
SysErrors.Raise(errors, d0, Sys.close, "");
RETURN FALSE
END;
END;
END;
END Close;
PROCEDURE Read*(fd: File; buf: Address; cnt: Count;
errors: RelatedEvents.Object;
retry: BOOLEAN; VAR interrupted: BOOLEAN) : Count;
(* return value of 0: EOF
-1: I/O error
>0: number of bytes read
*)
VAR
d0, d1: LONGINT;
BEGIN
interrupted := FALSE;
LOOP
IF ulmSYSTEM.UNIXCALL(Sys.read, d0, d1, fd, buf, cnt) THEN
RETURN d0
ELSE
IF d0 = SysErrors.intr THEN
interrupted := TRUE;
END;
IF (d0 # SysErrors.intr) OR ~retry THEN
SysErrors.Raise(errors, d0, Sys.read, "");
RETURN -1
END;
END;
END;
END Read;
PROCEDURE Write*(fd: File; buf: Address; cnt: Count;
errors: RelatedEvents.Object;
retry: BOOLEAN; VAR interrupted: BOOLEAN) : Count;
(* return value of -1: I/O error
>=0: number of bytes written
*)
VAR
d0, d1: LONGINT;
BEGIN
interrupted := FALSE;
LOOP
IF ulmSYSTEM.UNIXCALL(Sys.write, d0, d1, fd, buf, cnt) THEN
RETURN d0
ELSE
IF d0 = SysErrors.intr THEN
interrupted := TRUE;
END;
IF (d0 # SysErrors.intr) OR ~retry THEN
SysErrors.Raise(errors, d0, Sys.write, "");
RETURN -1
END;
END;
END;
END Write;
PROCEDURE Seek*(fd: File; offset: Count; whence: Whence;
errors: RelatedEvents.Object) : BOOLEAN;
VAR
d0, d1: LONGINT;
BEGIN
IF ulmSYSTEM.UNIXCALL(Sys.lseek, d0, d1, fd, offset, whence) THEN
RETURN TRUE
ELSE
SysErrors.Raise(errors, d0, Sys.lseek, "");
RETURN FALSE
END;
END Seek;
PROCEDURE Tell*(fd: File; VAR offset: Count;
errors: RelatedEvents.Object) : BOOLEAN;
VAR
d0, d1: LONGINT;
BEGIN
IF ulmSYSTEM.UNIXCALL(Sys.lseek, d0, d1, fd, 0, fromPos) THEN
offset := d0;
RETURN TRUE
ELSE
SysErrors.Raise(errors, d0, Sys.lseek, "");
RETURN FALSE
END;
END Tell;
PROCEDURE Isatty*(fd: File) : BOOLEAN;
CONST
sizeofStructTermIO = 18;
tcgeta = 00005405H;
VAR
d0, d1: LONGINT;
buf: ARRAY 32 OF SYS.BYTE; (* Should be more than sufficient *)
BEGIN
(* following system call fails for non-tty's *)
RETURN ulmSYSTEM.UNIXCALL(Sys.ioctl, d0, d1, fd, tcgeta, SYS.ADR(buf))
END Isatty;
PROCEDURE Fcntl*(fd: File; request: INTEGER; VAR arg: LONGINT;
errors: RelatedEvents.Object;
retry: BOOLEAN; VAR interrupted: BOOLEAN) : BOOLEAN;
VAR
d0, d1: LONGINT;
BEGIN
interrupted := FALSE;
LOOP
IF ulmSYSTEM.UNIXCALL(Sys.fcntl, d0, d1, fd, request, arg) THEN
arg := d0;
RETURN TRUE
ELSE
IF d0 = SysErrors.intr THEN
interrupted := TRUE;
END;
IF (d0 # SysErrors.intr) OR ~retry THEN
SysErrors.Raise(errors, d0, Sys.fcntl, "");
RETURN FALSE
END;
END;
END;
END Fcntl;
PROCEDURE FcntlSet*(fd: File; request: INTEGER; flags: SET;
errors: RelatedEvents.Object;
retry: BOOLEAN; VAR interrupted: BOOLEAN) : BOOLEAN;
VAR
d0, d1: LONGINT;
BEGIN
interrupted := FALSE;
LOOP
IF ulmSYSTEM.UNIXCALL(Sys.fcntl, d0, d1, fd, request, SYS.VAL(LONGINT, flags)) THEN
RETURN TRUE
ELSE
IF d0 = SysErrors.intr THEN
interrupted := TRUE;
END;
IF (d0 # SysErrors.intr) OR ~retry THEN
SysErrors.Raise(errors, d0, Sys.fcntl, "");
RETURN FALSE
END;
END;
END;
END FcntlSet;
PROCEDURE FcntlGet*(fd: File; request: INTEGER; VAR flags: SET;
errors: RelatedEvents.Object) : BOOLEAN;
VAR
d0, d1: LONGINT;
BEGIN
IF ulmSYSTEM.UNIXCALL(Sys.fcntl, d0, d1, fd, request, 0) THEN
ulmSYSTEM.WMOVE(SYS.ADR(d0), SYS.ADR(flags), 1);
RETURN TRUE
ELSE
SysErrors.Raise(errors, d0, Sys.fcntl, "");
RETURN FALSE
END;
END FcntlGet;
PROCEDURE Dup*(fd: File; VAR newfd: File;
errors: RelatedEvents.Object) : BOOLEAN;
VAR
d0, d1: LONGINT;
a0, a1: LONGINT;
BEGIN
IF ulmSYSTEM.UNIXCALL(Sys.dup, d0, d1, fd, a0, a1) THEN
newfd := d0;
RETURN TRUE
ELSE
SysErrors.Raise(errors, d0, Sys.dup, "");
RETURN FALSE
END;
END Dup;
PROCEDURE Dup2*(fd, newfd: File; errors: RelatedEvents.Object) : BOOLEAN;
VAR
d0, d1: LONGINT;
a0, a1: LONGINT;
fd2: File;
interrupted: BOOLEAN;
BEGIN
fd2 := newfd;
(* handmade close to avoid unnecessary events *)
IF ~ulmSYSTEM.UNIXCALL(Sys.close, d0, d1, newfd, a0, a1) THEN END;
IF Fcntl(fd, dupfd, fd2, errors, TRUE, interrupted) THEN
IF fd2 = newfd THEN
RETURN TRUE
ELSE
RETURN Close(fd2, errors, TRUE, interrupted) & FALSE
END;
ELSE
RETURN FALSE
END;
END Dup2;
PROCEDURE Pipe*(VAR readfd, writefd: File;
errors: RelatedEvents.Object) : BOOLEAN;
VAR
d0, d1: LONGINT;
a0, a1: LONGINT;
fds : ARRAY 2 OF (*File*)INTEGER; (* it needs int pipefd[2], and int is 4 bytes long on x86_64 -- noch *)
BEGIN
IF ulmSYSTEM.UNIXCALL(Sys.pipe, d0, d1, SYS.ADR (fds), a0, a1) THEN
readfd := fds[0]; writefd := fds[1];
RETURN TRUE
ELSE
SysErrors.Raise(errors, d0, Sys.pipe, "");
RETURN FALSE
END;
END Pipe;
END ulmSysIO.

227
src/library/ulm/ulmSysStat.Mod Normal file
View file

@ -0,0 +1,227 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: SysStat.om,v 1.3 2000/11/12 13:02:09 borchert Exp $
----------------------------------------------------------------------------
$Log: SysStat.om,v $
Revision 1.3 2000/11/12 13:02:09 borchert
door file type added
Revision 1.2 2000/11/12 12:48:07 borchert
- conversion adapted to Solaris 2.x
- Lstat added
Revision 1.1 1994/02/23 08:00:48 borchert
Initial revision
----------------------------------------------------------------------------
AFB 9/89
----------------------------------------------------------------------------
*)
MODULE ulmSysStat;
(* examine inode: stat(2) and fstat(2) *)
IMPORT RelatedEvents := ulmRelatedEvents, Sys := ulmSys, SYS := SYSTEM, uSYS := ulmSYSTEM, SysConversions := ulmSysConversions, SysErrors := ulmSysErrors,
SysTypes := ulmSysTypes;
CONST
(* file mode:
bit 0 = 1<<0 bit 31 = 1<<31
user group other
3 1 1111 11
1 ... 6 5432 109 876 543 210
+--------+------+-----+-----+-----+-----+
| unused | type | sst | rwx | rwx | rwx |
+--------+------+-----+-----+-----+-----+
*)
type* = {12..15};
prot* = {0..8};
(* file types; example: (stat.mode * type = dir) *)
reg* = {15}; (* regular *)
dir* = {14}; (* directory *)
chr* = {13}; (* character special *)
fifo* = {12}; (* fifo *)
blk* = {13..14}; (* block special *)
symlink* = {13, 15}; (* symbolic link *)
socket* = {14, 15}; (* socket *)
(* special *)
setuid* = 11; (* set user id on execution *)
setgid* = 10; (* set group id on execution *)
savetext* = 9; (* save swapped text even after use *)
(* protection *)
uread* = 8; (* read permission owner *)
uwrite* = 7; (* write permission owner *)
uexec* = 6; (* execute/search permission owner *)
gread* = 5; (* read permission group *)
gwrite* = 4; (* write permission group *)
gexec* = 3; (* execute/search permission group *)
oread* = 2; (* read permission other *)
owrite* = 1; (* write permission other *)
oexec* = 0; (* execute/search permission other *)
(* example for "r-xr-x---": (read + exec) * (owner + group) *)
owner* = {uread, uwrite, uexec};
group* = {gread, gwrite, gexec};
other* = {oread, owrite, oexec};
read* = {uread, gread, oread};
write* = {uwrite, gwrite, owrite};
exec* = {uexec, gexec, oexec};
rwx* = prot;
TYPE
StatRec* = (* result of stat(2) and fstat(2) *)
RECORD
device*: SysTypes.Device; (* ID of device containing
a directory entry for this file *)
inode*: SysTypes.Inode; (* inode number *)
nlinks*: LONGINT(*INTEGER*); (* number of links *)
mode*: SET; (* file mode; see mknod(2) *)
uid*: INTEGER; (* user id of the file's owner *)
gid*: INTEGER; (* group id of the file's group *)
rdev*: SysTypes.Device; (* ID of device
this entry is defined only for
character special or block
special files
*)
size*: SysTypes.Offset; (* file size in bytes *)
blksize*: LONGINT; (* preferred blocksize *)
blocks*: LONGINT; (* # of blocks allocated *)
atime*: SysTypes.Time; (* time of last access *)
mtime*: SysTypes.Time; (* time of last data modification *)
ctime*: SysTypes.Time; (* time of last file status change *)
END;
(* StatRec* = (* result of stat(2) and fstat(2) *)
RECORD
device*: SysTypes.Device; (* ID of device containing
a directory entry for this file *)
inode*: SysTypes.Inode; (* inode number *)
nlinks*: LONGINT; (* number of links *)
mode*: INTEGER(*SET*); (* file mode; see mknod(2) *)
uid*: INTEGER; (* user id of the file's owner *)
gid*: INTEGER; (* group id of the file's group *)
pad0: INTEGER;
rdev*: SysTypes.Device; (* ID of device
this entry is defined only for
character special or block
special files
*)
size*: SysTypes.Offset; (* file size in bytes *)
blksize*: LONGINT; (* preferred blocksize *)
blocks*: LONGINT; (* # of blocks allocated *)
atime*: SysTypes.Time; (* time of last access *)
atimences* : LONGINT;
mtime*: SysTypes.Time; (* time of last data modification *)
mtimensec* : LONGINT;
ctime*: SysTypes.Time; (* time of last file status change *)
ctimensec* : LONGINT;
unused0*, unused1*, unused2*: LONGINT;
END;
*)
(* Linux kernel struct stat (2.2.17)
struct stat {
unsigned short st_dev;
unsigned short __pad1;
unsigned long st_ino;
unsigned short st_mode;
unsigned short st_nlink;
unsigned short st_uid;
unsigned short st_gid;
unsigned short st_rdev;
unsigned short __pad2;
unsigned long st_size;
unsigned long st_blksize;
unsigned long st_blocks;
unsigned long st_atime;
unsigned long __unused1;
unsigned long st_mtime;
unsigned long __unused2;
unsigned long st_ctime;
unsigned long __unused3;
unsigned long __unused4;
unsigned long __unused5;
};
*)
CONST
statbufsize = 144(*64*); (* see <sys/stat.h> *) (* sizeof struct stat gives us 144 on x86_64 and 88 or x86; -- noch *)
TYPE
UnixStatRec = ARRAY statbufsize OF SYS.BYTE;
CONST
statbufconv =
(*"is=dev/-s=pad1/ll=ino/Ss=mode/4*is=nlink+uid+gid+rdev/-s=pad2/ll=size/2*ll=blksize,blocks/il=atime/-l/il=mtime/-l/il=ctime/3*-l";*)
"lL=dev/lL=ino/lL=nlink/Su=mode/2*iu=uid+gid/-i=pad0/lL=rdev/ll=size/2*ll=blksize,blocks/lL=atime/-l/lL=mtime/-l/lL=ctime/3*-l"; (* noch *)
VAR
statbuffmt: SysConversions.Format;
PROCEDURE Stat*(path: ARRAY OF CHAR; VAR buf: StatRec;
errors: RelatedEvents.Object) : BOOLEAN;
VAR
d0, d1, d2: LONGINT;
origbuf: UnixStatRec;
BEGIN
IF uSYS.UNIXCALL(Sys.newstat, d0, d1, SYS.ADR(path), SYS.ADR(origbuf), d2) THEN
SysConversions.ByFmtFromC(origbuf, buf, statbuffmt);
RETURN TRUE
ELSE
SysErrors.Raise(errors, d0, Sys.newstat, path);
RETURN FALSE
END;
END Stat;
(* commented temporarily, it is used only in FTPUnixDirLister module *) (*
PROCEDURE Lstat*(path: ARRAY OF CHAR; VAR buf: StatRec;
errors: RelatedEvents.Object) : BOOLEAN;
VAR
d0, d1: INTEGER;
origbuf: UnixStatRec;
BEGIN
IF SYS.UNIXCALL(Sys.newlstat, d0, d1, SYS.ADR(path), SYS.ADR(origbuf)) THEN
SysConversions.ByFmtFromC(origbuf, buf, statbuffmt);
RETURN TRUE
ELSE
SysErrors.Raise(errors, d0, Sys.newlstat, path);
RETURN FALSE
END;
END Lstat;
*)
PROCEDURE Fstat*(fd: SysTypes.File; VAR buf: StatRec;
errors: RelatedEvents.Object) : BOOLEAN;
VAR
d0, d1, d2: LONGINT;
origbuf: UnixStatRec;
BEGIN
IF uSYS.UNIXCALL(Sys.newfstat, d0, d1, fd, SYS.ADR(origbuf), d2) THEN
SysConversions.ByFmtFromC(origbuf, buf, statbuffmt);
RETURN TRUE
ELSE
SysErrors.Raise(errors, d0, Sys.newfstat, "");
RETURN FALSE
END;
END Fstat;
BEGIN
SysConversions.Compile(statbuffmt, statbufconv);
END ulmSysStat.

70
src/library/ulm/ulmSysTypes.Mod Normal file
View file

@ -0,0 +1,70 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: SysTypes.om,v 1.1 1994/02/23 08:01:38 borchert Exp $
----------------------------------------------------------------------------
$Log: SysTypes.om,v $
Revision 1.1 1994/02/23 08:01:38 borchert
Initial revision
----------------------------------------------------------------------------
AFB 9/89
----------------------------------------------------------------------------
*)
MODULE ulmSysTypes;
IMPORT Types := ulmTypes;
TYPE
Address* = Types.Address;
UntracedAddress* = Types.UntracedAddress;
Count* = Types.Count;
Size* = Types.Size;
Byte* = Types.Byte;
File* = (*INTEGER*)LONGINT; (* in ulm's system both INTEGER and LONGINT are 4 bytes long *)
Offset* = LONGINT;
Device* = LONGINT;
Inode* = LONGINT;
Time* = LONGINT;
Word* = INTEGER; (* must have the size of C's int-type *)
(* Note: linux supports wait4 but not waitid, i.e. these
* constants aren't needed. *)
(*
CONST
(* possible values of the idtype parameter (4 bytes),
see <sys/procset.h>
*)
idPid = 0; (* a process identifier *)
idPpid = 1; (* a parent process identifier *)
idPgid = 2; (* a process group (job control group) identifier *)
idSid = 3; (* a session identifier *)
idCid = 4; (* a scheduling class identifier *)
idUid = 5; (* a user identifier *)
idGid = 6; (* a group identifier *)
idAll = 7; (* all processes *)
idLwpid = 8; (* an LWP identifier *)
TYPE
IdType = INTEGER; (* idPid .. idLwpid *)
*)
END ulmSysTypes.

1762
src/library/ulm/ulmTCrypt.Mod Normal file
View file

File diff suppressed because it is too large Load diff

310
src/library/ulm/ulmTexts.Mod Normal file
View file

@ -0,0 +1,310 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Texts.om,v 1.3 1995/03/17 19:37:52 borchert Exp $
----------------------------------------------------------------------------
$Log: Texts.om,v $
Revision 1.3 1995/03/17 19:37:52 borchert
- error events added
- some fixes because streams are now an extension of Services.Object
Revision 1.2 1994/07/18 14:21:13 borchert
buggy free buffer handling removed
Revision 1.1 1994/02/22 20:11:07 borchert
Initial revision
----------------------------------------------------------------------------
AFB 8/89
----------------------------------------------------------------------------
*)
MODULE ulmTexts;
(* management of texts (dynamic strings) *)
IMPORT Events := ulmEvents, Priorities := ulmPriorities, RelatedEvents := ulmRelatedEvents, Services := ulmServices, Streams := ulmStreams;
CONST
bufsize = 512;
TYPE
Count = Streams.Count;
Address = Streams.Address;
Byte = Streams.Byte;
Stream = Streams.Stream;
Whence = Streams.Whence;
BufferLink = POINTER TO Buffer;
Buffer =
RECORD
cont: ARRAY bufsize OF Byte;
next: BufferLink;
END;
Text* = POINTER TO TextRec;
TextRec* =
RECORD
(Streams.StreamRec)
pos: Count; (* current position *)
len: Count; (* total length in bytes *)
cnt: Count; (* number of buffers *)
head, tail: BufferLink; (* list of buffers *)
END;
VAR
if: Streams.Interface; (* parameters of Streams.Init *)
caps: Streams.CapabilitySet;
type: Services.Type; (* Texts.Text *)
(* === error handling =============================================== *)
CONST
posBeyondCurrentLength* = 0;
invalidTruncPos* = 1;
errors* = 2;
TYPE
ErrorEvent* = POINTER TO ErrorEventRec;
ErrorEventRec* =
RECORD
(Events.EventRec)
errorcode*: SHORTINT;
END;
VAR
errormsg*: ARRAY errors OF Events.Message;
error*: Events.EventType;
PROCEDURE InitErrorHandling;
BEGIN
Events.Define(error);
Events.SetPriority(error, Priorities.liberrors);
errormsg[posBeyondCurrentLength] :=
"desired position is beyond the current length";
errormsg[invalidTruncPos] := "invalid trunc position";
END InitErrorHandling;
PROCEDURE Error(s: Streams.Stream; code: SHORTINT);
VAR
event: ErrorEvent;
BEGIN
NEW(event);
event.type := error;
event.message := errormsg[code];
event.errorcode := code;
RelatedEvents.Raise(s, event);
END Error;
(* === buffer management ============================================ *)
PROCEDURE Access(t: Text; VAR buffer: BufferLink);
VAR i: Count;
BEGIN
IF t.pos >= bufsize * t.cnt THEN
NEW(buffer);
buffer.next := NIL;
IF t.tail = NIL THEN
t.head := buffer;
ELSE
t.tail.next := buffer;
END;
t.tail := buffer;
INC(t.cnt);
ELSE
buffer := t.head;
i := 0;
WHILE i < t.pos DIV bufsize DO
buffer := buffer.next;
INC(i);
END;
END;
END Access;
(* === interface procedures ========================================= *)
PROCEDURE BufRead(s: Stream; VAR buf: ARRAY OF Byte;
off, cnt: Count) : Count;
VAR
buffer: BufferLink;
index: Count;
i, count: Count;
BEGIN
WITH s: Text DO
count := cnt;
IF count > s.len - s.pos THEN
count := s.len - s.pos;
END;
IF count > 0 THEN
Access(s, buffer); index := s.pos MOD bufsize;
i := off;
WHILE i < off + count DO
buf[i] := buffer.cont[index];
INC(i); INC(index); INC(s.pos);
IF index MOD bufsize = 0 THEN
Access(s, buffer); index := 0;
END;
END;
END;
END;
RETURN count
END BufRead;
PROCEDURE BufWrite(s: Stream; VAR buf: ARRAY OF Byte;
off, cnt: Count) : Count;
VAR
buffer: BufferLink;
index: Count;
i: Count;
BEGIN
WITH s: Text DO
IF cnt > 0 THEN
Access(s, buffer); index := s.pos MOD bufsize;
i := off;
WHILE i < off + cnt DO
buffer.cont[index] := buf[i];
INC(i); INC(index); INC(s.pos);
IF s.pos > s.len THEN
s.len := s.pos;
END;
IF index MOD bufsize = 0 THEN
Access(s, buffer); index := 0;
END;
END;
END;
END;
RETURN cnt
END BufWrite;
PROCEDURE Read(s: Stream; VAR byte: Byte) : BOOLEAN;
VAR
buffer: BufferLink;
BEGIN
WITH s: Text DO
IF s.pos < s.len THEN
Access(s, buffer);
byte := buffer.cont[s.pos MOD bufsize];
INC(s.pos);
RETURN TRUE
ELSE
RETURN FALSE
END;
END;
END Read;
PROCEDURE Write(s: Stream; byte: Byte) : BOOLEAN;
VAR
buffer: BufferLink;
BEGIN
WITH s: Text DO
Access(s, buffer);
buffer.cont[s.pos MOD bufsize] := byte;
INC(s.pos);
IF s.pos > s.len THEN
s.len := s.pos;
END;
RETURN TRUE
END;
END Write;
PROCEDURE Seek(s: Stream; count: Count; whence: Whence) : BOOLEAN;
VAR
pos: Count;
BEGIN
WITH s: Text DO
CASE whence OF
| Streams.fromStart: pos := count;
| Streams.fromPos: pos := count + s.pos;
| Streams.fromEnd: pos := count + s.len;
END;
IF (pos >= 0) & (pos <= s.len) THEN
s.pos := pos;
RETURN TRUE
ELSE
Error(s, posBeyondCurrentLength);
RETURN FALSE (* holes are not permitted *)
END;
END;
END Seek;
PROCEDURE Tell(s: Stream; VAR count: Count) : BOOLEAN;
BEGIN
count := s(Text).pos;
RETURN TRUE
END Tell;
PROCEDURE Close(s: Stream) : BOOLEAN;
BEGIN
WITH s: Text DO
s.pos := 0; s.len := 0;
IF s.cnt > 0 THEN
s.cnt := 0;
s.head := NIL; s.tail := NIL;
END;
END;
RETURN TRUE
END Close;
PROCEDURE Trunc(s: Stream; length: Count) : BOOLEAN;
VAR
i: Count;
buffer: BufferLink;
BEGIN
WITH s: Text DO
IF (length >= 0) & (length <= s.len) & (s.pos <= length) THEN
IF length DIV bufsize < s.len DIV bufsize THEN
(* release truncated buffers *)
i := 0; buffer := s.head;
WHILE i < length DIV bufsize DO
buffer := buffer.next; INC(i);
END;
s.tail := buffer; s.tail.next := NIL;
s.cnt := i;
END;
s.len := length;
RETURN TRUE
ELSE
Error(s, invalidTruncPos);
RETURN FALSE
END;
END;
END Trunc;
PROCEDURE Open*(VAR text: Streams.Stream);
(* for reading and writing *)
VAR
newtext: Text;
BEGIN
NEW(newtext);
Services.Init(newtext, type);
Streams.Init(newtext, if, caps, Streams.nobuf);
RelatedEvents.QueueEvents(newtext);
newtext.pos := 0; newtext.len := 0;
newtext.cnt := 0; newtext.head := NIL; newtext.tail := NIL;
text := newtext;
END Open;
BEGIN
NEW(if);
if.bufread := BufRead; if.bufwrite := BufWrite;
if.read := Read; if.write := Write;
if.seek := Seek; if.tell := Tell;
if.trunc := Trunc; if.close := Close;
caps := {Streams.read, Streams.write, Streams.bufio,
Streams.seek, Streams.tell, Streams.trunc, Streams.close};
Services.CreateType(type, "Texts.Text", "Streams.Stream");
InitErrorHandling;
END ulmTexts.

406
src/library/ulm/ulmTimeConditions.Mod Normal file
View file

@ -0,0 +1,406 @@
(* Ulm's Oberon Library
Copyright (C) 1989-2004 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: TimeConditi.om,v 1.5 2004/04/05 16:23:37 borchert Exp $
----------------------------------------------------------------------------
$Log: TimeConditi.om,v $
Revision 1.5 2004/04/05 16:23:37 borchert
bug fix: Test must not call anything which causes directly or
indirectly WaitFor to be called; hence we schedule
a timer event in all cases where this is possible;
the only exception remains Clocks.system where we
take it for granted that the clock operations are
that simple that they do not lead to WaitFor
(was necessary to get RemoteClocks working again)
Revision 1.4 2004/02/19 15:23:10 borchert
- Init added to support extensions of TimeConditions.Condition
- using Clocks.Passed instead of Clocks.GetTime in some instances
to reduce the number of system calls needed
- Timers event is only generated now if strictly needed,
i.e. if SendEvent has been called
Revision 1.3 2001/04/30 15:25:12 borchert
several improvements / bug fixes in context of domain-oriented
condition handling
Revision 1.2 1995/04/06 14:36:16 borchert
fixes due to changed if & semantics of Conditions
Revision 1.1 1994/02/22 20:11:18 borchert
Initial revision
----------------------------------------------------------------------------
AFB 1/92
----------------------------------------------------------------------------
*)
MODULE ulmTimeConditions;
IMPORT Clocks := ulmClocks, Conditions := ulmConditions, Disciplines := ulmDisciplines, Events := ulmEvents, Op := ulmOperations,
Priorities := ulmPriorities, Process := ulmProcess, RelatedEvents := ulmRelatedEvents, Scales := ulmScales, Timers := ulmTimers, Times := ulmTimes, SYSTEM;
TYPE
Domain = POINTER TO DomainRec;
DomainRec =
RECORD
(Conditions.DomainRec)
clock: Clocks.Clock;
alarm: Events.EventType;
event: Events.Event; (* event of SendEvent *)
END;
Condition = POINTER TO ConditionRec;
ConditionRec* =
RECORD
(Conditions.ConditionRec)
time: Times.Time;
passed: BOOLEAN; (* becomes TRUE if the time has passed *)
scheduled: BOOLEAN; (* Timer event scheduled? *)
domain: Domain;
END;
TYPE
(* this discpline will be attached to clocks *)
Discipline = POINTER TO DisciplineRec;
DisciplineRec =
RECORD
(Disciplines.DisciplineRec)
domain: Domain;
END;
VAR
disciplineId: Disciplines.Identifier;
TYPE
WakeupEvent = POINTER TO WakeupEventRec;
WakeupEventRec =
RECORD
(Events.EventRec)
condition: Condition;
awaked: BOOLEAN; (* set to true by Wakeup event handler *)
END;
VAR
if: Conditions.Interface;
PROCEDURE FixTime(VAR time: Times.Time;
currentTime: Times.Time;
clock: Clocks.Clock);
(* convert relative time measures into absolute time specs *)
BEGIN
IF Scales.IsRelative(time) THEN
Clocks.GetTime(clock, currentTime);
Op.Add3(SYSTEM.VAL(Op.Operand, time), currentTime, time);
END;
END FixTime;
PROCEDURE Wakeup(event: Events.Event);
(* note that we strictly rely on the capability of the
underlying clock to raise this event at the appropriate
time; we are unable to verify it because that could
deadlock us in case of remote clocks
*)
VAR
condevent: Events.Event; (* event requested by SendEvent *)
BEGIN
WITH event: WakeupEvent DO
event.awaked := TRUE;
IF event.condition # NIL THEN
event.condition.passed := TRUE;
event.condition.scheduled := FALSE;
condevent := event.condition.domain.event;
IF condevent # NIL THEN
event.condition.domain.event := NIL;
Events.Raise(condevent);
END;
END;
END;
END Wakeup;
PROCEDURE ScheduleEvent(condition: Condition);
VAR
wakeup: WakeupEvent;
domain: Domain;
BEGIN
IF ~condition.scheduled THEN
domain := condition.domain;
ASSERT(domain.alarm # NIL);
NEW(wakeup); wakeup.type := domain.alarm;
wakeup.awaked := FALSE; wakeup.condition := condition;
condition.scheduled := TRUE;
Timers.Schedule(domain.clock, condition.time, wakeup);
END;
END ScheduleEvent;
PROCEDURE Init*(condition: Condition; clock: Clocks.Clock; time: Times.Time);
(* like Create but without NEW *)
VAR
clockDisc: Discipline;
domain: Domain;
desc: Conditions.Description;
priorityOfClock: Priorities.Priority;
currentTime: Times.Time;
BEGIN
IF Disciplines.Seek(clock, disciplineId, SYSTEM.VAL(Disciplines.Discipline, clockDisc)) THEN
domain := clockDisc.domain;
ELSE
(* create new domain *)
NEW(desc); desc.caps := {}; desc.internal := TRUE;
IF clock = Clocks.system THEN
desc.caps := desc.caps +
{Conditions.timelimit, Conditions.timecond};
END;
IF Clocks.timer IN Clocks.Capabilities(clock) THEN
Clocks.GetPriority(clock, priorityOfClock);
IF priorityOfClock > Priorities.base THEN
desc.caps := desc.caps + {Conditions.select, Conditions.async};
desc.internal := priorityOfClock < Priorities.interrupts;
END;
END;
NEW(domain); Conditions.InitDomain(domain, if, desc);
domain.clock := clock;
IF Clocks.timer IN Clocks.Capabilities(clock) THEN
Events.Define(domain.alarm);
Events.SetPriority(domain.alarm, priorityOfClock + 1);
Events.Handler(domain.alarm, Wakeup);
ELSE
domain.alarm := NIL;
END;
NEW(clockDisc); clockDisc.id := disciplineId;
clockDisc.domain := domain;
Disciplines.Add(clock, clockDisc);
domain.event := NIL;
END;
Conditions.Init(condition, domain);
FixTime(time, currentTime, clock); condition.time := time;
condition.domain := domain;
condition.passed := Clocks.Passed(clock, time);
condition.scheduled := FALSE;
IF ~condition.passed &
(domain.alarm # NIL) & (clock # Clocks.system) THEN
ScheduleEvent(condition);
END;
END Init;
PROCEDURE Create*(VAR condition: Conditions.Condition;
clock: Clocks.Clock; time: Times.Time);
(* create and initialize a time condition:
is the current time of the clock greater than or
equal to `time';
if time is relative then it is taken relative to the current time
*)
VAR
timeCond: Condition;
BEGIN
NEW(timeCond);
Init(timeCond, clock, time);
condition := timeCond;
END Create;
(* ======== interface procedures ================================ *)
PROCEDURE GetTime(clock: Clocks.Clock;
VAR currentTime: Times.Time;
errors: RelatedEvents.Object) : BOOLEAN;
(* get the current time of clock and check for errors *)
VAR
oldEvents, newEvents: RelatedEvents.Queue;
BEGIN
RelatedEvents.GetQueue(clock, oldEvents);
Clocks.GetTime(clock, currentTime);
RelatedEvents.GetQueue(clock, newEvents);
IF newEvents # NIL THEN
RelatedEvents.AppendQueue(errors, newEvents);
END;
IF oldEvents # NIL THEN
RelatedEvents.AppendQueue(clock, oldEvents);
END;
IF newEvents # NIL THEN
RelatedEvents.AppendQueue(clock, newEvents);
END;
RETURN newEvents = NIL
END GetTime;
PROCEDURE Passed(clock: Clocks.Clock;
time: Times.Time;
VAR passed: BOOLEAN;
errors: RelatedEvents.Object) : BOOLEAN;
VAR
oldEvents, newEvents: RelatedEvents.Queue;
BEGIN
RelatedEvents.GetQueue(clock, oldEvents);
passed := Clocks.Passed(clock, time);
RelatedEvents.GetQueue(clock, newEvents);
IF newEvents # NIL THEN
RelatedEvents.AppendQueue(errors, newEvents);
END;
IF oldEvents # NIL THEN
RelatedEvents.AppendQueue(clock, oldEvents);
END;
IF newEvents # NIL THEN
RelatedEvents.AppendQueue(clock, newEvents);
END;
RETURN newEvents = NIL
END Passed;
PROCEDURE Test(domain: Conditions.Domain; condition: Conditions.Condition;
errors: RelatedEvents.Object) : BOOLEAN;
VAR
currentTime: Times.Time;
BEGIN
WITH domain: Domain DO WITH condition: Condition DO
IF condition.passed THEN RETURN TRUE END;
IF condition.domain.event # NIL THEN RETURN FALSE END;
IF condition.scheduled THEN RETURN FALSE END;
IF ~Passed(domain.clock, condition.time,
condition.passed, errors) THEN
condition.passed := TRUE;
RETURN TRUE
END;
RETURN condition.passed
END; END;
END Test;
PROCEDURE GetMinTime(conditionSet: Conditions.ConditionSet;
VAR minTime: Times.Time;
VAR minCond: Condition);
VAR
condition: Condition;
BEGIN
minTime := NIL;
Conditions.ExamineConditions(conditionSet);
WHILE Conditions.GetNextCondition(conditionSet, SYSTEM.VAL(Conditions.Condition, condition)) DO
IF (minTime = NIL) OR (Op.Compare(condition.time, minTime) < 0) THEN
minTime := condition.time; minCond := condition;
END;
END;
Op.Assign(SYSTEM.VAL(Op.Operand, minTime), minTime); (* take a copy *)
END GetMinTime;
PROCEDURE Select(domain: Conditions.Domain;
conditionSet: Conditions.ConditionSet;
time: Times.Time;
VAR setOfTrueConditions: Conditions.ConditionSet;
errors: RelatedEvents.Object;
retry: BOOLEAN;
VAR interrupted: BOOLEAN) : BOOLEAN;
VAR
minTime: Times.Time;
minCond: Condition;
currentTime: Times.Time; (* of Clocks.system *)
condition: Condition;
wakeup: WakeupEvent;
anythingTrue: BOOLEAN;
PROCEDURE Failure;
(* we are unable to retrieve the time;
so we have to mark all conditions as passed
and to return the whole set
*)
VAR
condition: Condition;
BEGIN
Conditions.CreateSet(setOfTrueConditions);
Conditions.ExamineConditions(conditionSet);
WHILE Conditions.GetNextCondition(conditionSet, SYSTEM.VAL(Conditions.Condition, condition)) DO
condition.passed := TRUE;
Conditions.Incl(setOfTrueConditions, condition);
END;
END Failure;
BEGIN (* Select *)
WITH domain: Domain DO
GetMinTime(conditionSet, minTime, minCond);
(* block current process, if necessary *)
interrupted := FALSE;
IF time # NIL THEN
Clocks.GetTime(Clocks.system, currentTime);
FixTime(time, currentTime, Clocks.system);
NEW(wakeup); wakeup.type := domain.alarm;
wakeup.condition := NIL; wakeup.awaked := FALSE;
Timers.Schedule(Clocks.system, time, wakeup);
END;
IF ~GetTime(domain.clock, currentTime, errors) THEN
Failure; RETURN TRUE
END;
IF ~minCond.passed THEN
LOOP (* goes only into loop if retry = TRUE & we get interrupted *)
Process.Pause;
IF wakeup.awaked THEN EXIT END;
interrupted := ~minCond.passed;
IF ~interrupted THEN EXIT END;
IF ~retry THEN RETURN FALSE END;
END;
END;
anythingTrue := FALSE;
Conditions.CreateSet(setOfTrueConditions);
Conditions.ExamineConditions(conditionSet);
WHILE Conditions.GetNextCondition(conditionSet, SYSTEM.VAL(Conditions.Condition, condition)) DO
IF condition.passed THEN
Conditions.Incl(setOfTrueConditions, condition);
anythingTrue := TRUE;
END;
END;
RETURN anythingTrue
END;
END Select;
PROCEDURE SendEvent(domain: Conditions.Domain;
condition: Conditions.Condition;
event: Events.Event;
errors: RelatedEvents.Object) : BOOLEAN;
BEGIN
WITH domain: Domain DO WITH condition: Condition DO
IF condition.passed THEN
RETURN FALSE
ELSE
domain.event := event;
ScheduleEvent(condition);
RETURN TRUE
END;
END; END;
END SendEvent;
PROCEDURE GetNextTime(domain: Conditions.Domain;
conditionSet: Conditions.ConditionSet;
VAR nextTime: Times.Time;
VAR nextCond: Conditions.Condition;
errors: RelatedEvents.Object);
VAR
condition: Condition;
BEGIN
GetMinTime(conditionSet, nextTime, condition);
nextCond := condition;
END GetNextTime;
PROCEDURE InitInterface;
BEGIN
NEW(if);
if.test := Test;
if.select := Select;
if.sendevent := SendEvent;
if.gettime := GetNextTime;
END InitInterface;
BEGIN
disciplineId := Disciplines.Unique();
InitInterface;
END ulmTimeConditions.

336
src/library/ulm/ulmTimers.Mod Normal file
View file

@ -0,0 +1,336 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Timers.om,v 1.3 2001/04/30 14:58:18 borchert Exp $
----------------------------------------------------------------------------
$Log: Timers.om,v $
Revision 1.3 2001/04/30 14:58:18 borchert
bug fix: recursion via Clocks.TimerOn was not possible
Revision 1.2 1994/07/18 14:21:51 borchert
bug fix: CreateQueue took uninitialized priority variable instead of
queue.priority
Revision 1.1 1994/02/22 20:11:37 borchert
Initial revision
----------------------------------------------------------------------------
AFB 1/92
----------------------------------------------------------------------------
*)
MODULE ulmTimers;
IMPORT Clocks := ulmClocks, Disciplines := ulmDisciplines, Events := ulmEvents, Objects := ulmObjects, Op := ulmOperations, Priorities := ulmPriorities,
SYS := ulmSYSTEM, SYSTEM, RelatedEvents := ulmRelatedEvents, Scales := ulmScales, Times := ulmTimes;
TYPE
Queue = POINTER TO QueueRec;
Timer* = POINTER TO TimerRec;
TimerRec* =
RECORD
(Objects.ObjectRec)
valid: BOOLEAN; (* a valid timer entry? *)
queue: Queue; (* timer belongs to this queue *)
prev, next: Timer; (* double-linked and sorted list *)
time: Times.Time; (* key *)
event: Events.Event; (* raise this event at the given time *)
END;
QueueRec =
RECORD
(Disciplines.ObjectRec)
clock: Clocks.Clock; (* queue of this clock *)
priority: Priorities.Priority; (* priority of the clock *)
checkQueue: Events.EventType; (* check queue on this event *)
head, tail: Timer; (* sorted list of timers *)
lock: BOOLEAN;
END;
TYPE
CheckQueueEvent = POINTER TO CheckQueueEventRec;
CheckQueueEventRec =
RECORD
(Events.EventRec)
queue: Queue;
END;
TYPE
ClockDiscipline = POINTER TO ClockDisciplineRec;
ClockDisciplineRec =
RECORD
(Disciplines.DisciplineRec)
queue: Queue;
END;
VAR
clockDisciplineId: Disciplines.Identifier;
CONST
invalidTimer* = 0; (* timer is no longer valid *)
queueLocked* = 1; (* the queue is currently locked *)
badClock* = 2; (* clock is unable to maintain a timer *)
errorcodes* = 3;
TYPE
ErrorEvent* = POINTER TO ErrorEventRec;
ErrorEventRec* =
RECORD
(Events.EventRec)
errorcode*: SHORTINT;
END;
VAR
errormsg*: ARRAY errorcodes OF Events.Message;
error*: Events.EventType;
PROCEDURE InitErrorHandling;
BEGIN
errormsg[invalidTimer] := "invalid timer given to Timers.Remove";
errormsg[queueLocked] := "the queue is currently locked";
errormsg[badClock] := "clock is unable to maintain a timer";
Events.Define(error); Events.SetPriority(error, Priorities.liberrors);
END InitErrorHandling;
PROCEDURE Error(errors: RelatedEvents.Object; code: SHORTINT);
VAR
event: ErrorEvent;
BEGIN
NEW(event);
event.type := error;
event.message := errormsg[code];
event.errorcode := code;
RelatedEvents.Raise(errors, event);
END Error;
PROCEDURE CheckQueue(queue: Queue);
VAR
currentTime: Times.Time;
oldTimers: Timer;
p, prev: Timer;
checkQueueEvent: CheckQueueEvent;
nextTimer: Timer;
BEGIN
IF queue.head = NIL THEN queue.lock := FALSE; RETURN END;
Clocks.GetTime(queue.clock, currentTime);
(* remove old timers from queue *)
oldTimers := queue.head;
p := queue.head; prev := NIL;
WHILE (p # NIL) & (Op.Compare(currentTime, p.time) >= 0) DO
prev := p; p := p.next;
END;
IF p = NIL THEN
queue.head := NIL; queue.tail := NIL;
ELSE
queue.head := p;
p.prev := NIL;
END;
IF prev = NIL THEN
oldTimers := NIL;
ELSE
prev.next := NIL;
END;
(* set up next check-queue-event, if necessary *)
nextTimer := queue.head;
queue.lock := FALSE;
(* unlock queue now to allow recursion via Clocks.TimerOn *)
IF nextTimer # NIL THEN
NEW(checkQueueEvent);
checkQueueEvent.type := queue.checkQueue;
checkQueueEvent.message := "check queue of timer";
checkQueueEvent.queue := queue;
Clocks.TimerOn(queue.clock, nextTimer.time, checkQueueEvent);
ELSE
Clocks.TimerOff(queue.clock);
END;
(* process old timers *)
p := oldTimers;
WHILE p # NIL DO
p.valid := FALSE;
Events.Raise(p.event);
p := p.next;
END;
END CheckQueue;
PROCEDURE CatchCheckQueueEvents(event: Events.Event);
BEGIN
WITH event: CheckQueueEvent DO
IF ~SYS.TAS(event.queue.lock) THEN
CheckQueue(event.queue);
(* event.queue.lock := FALSE; (* done by CheckQueue *) *)
END;
END;
END CatchCheckQueueEvents;
PROCEDURE CreateQueue(errors: RelatedEvents.Object;
VAR queue: Queue; clock: Clocks.Clock) : BOOLEAN;
VAR
clockDiscipline: ClockDiscipline;
BEGIN
IF ~(Clocks.timer IN Clocks.Capabilities(clock)) THEN
Error(errors, badClock); RETURN FALSE
END;
NEW(queue);
queue.clock := clock;
queue.head := NIL; queue.tail := NIL;
queue.lock := FALSE;
Events.Define(queue.checkQueue);
Events.Handler(queue.checkQueue, CatchCheckQueueEvents);
Clocks.GetPriority(clock, queue.priority);
IF queue.priority > Priorities.base THEN
Events.SetPriority(queue.checkQueue, queue.priority + 1);
ELSE
queue.priority := Priorities.default;
END;
NEW(clockDiscipline); clockDiscipline.id := clockDisciplineId;
clockDiscipline.queue := queue;
Disciplines.Add(clock, clockDiscipline);
RETURN TRUE
END CreateQueue;
PROCEDURE Add*(clock: Clocks.Clock; time: Times.Time; event: Events.Event;
VAR timer: Timer);
VAR
queue: Queue;
clockDiscipline: ClockDiscipline;
p: Timer;
absTime: Times.Time;
BEGIN
IF Disciplines.Seek(clock, clockDisciplineId, SYSTEM.VAL(Disciplines.Discipline, clockDiscipline)) THEN
queue := clockDiscipline.queue;
ELSIF ~CreateQueue(clock, queue, clock) THEN
RETURN
END;
IF SYS.TAS(queue.lock) THEN
Error(clock, queueLocked); RETURN
END;
Events.AssertPriority(queue.priority);
IF Scales.IsRelative(time) THEN
(* take relative time to be relative to the current time *)
Clocks.GetTime(clock, absTime);
Op.Add2(SYSTEM.VAL(Op.Operand, absTime), time);
ELSE
(* create a copy of time *)
absTime := NIL; Op.Assign(SYSTEM.VAL(Op.Operand, absTime), time);
END;
time := absTime;
NEW(timer); timer.time := time; timer.event := event;
timer.queue := queue; timer.valid := TRUE;
(* look for the insertion point *)
p := queue.head;
WHILE (p # NIL) & (Op.Compare(time, p.time) > 0) DO
p := p.next;
END;
(* insert timer in front of p *)
timer.next := p;
IF p = NIL THEN
(* append timer at the end of the queue *)
timer.prev := queue.tail;
IF queue.tail = NIL THEN
queue.head := timer;
ELSE
queue.tail.next := timer;
END;
queue.tail := timer;
ELSE
timer.prev := p.prev;
timer.next := p;
IF p = queue.head THEN
queue.head := timer;
ELSE
p.prev.next := timer;
END;
p.prev := timer;
END;
CheckQueue(queue);
(* queue.lock := FALSE; (* done by CheckQueue *) *)
Events.ExitPriority;
END Add;
PROCEDURE Remove*(timer: Timer);
VAR
queue: Queue;
BEGIN
IF timer.valid THEN
queue := timer.queue;
IF SYS.TAS(queue.lock) THEN
Error(queue.clock, queueLocked); RETURN
END;
Events.AssertPriority(queue.priority);
timer.valid := FALSE;
IF timer.prev = NIL THEN
queue.head := timer.next;
ELSE
timer.prev.next := timer.next;
END;
IF timer.next = NIL THEN
queue.tail := timer.prev;
ELSE
timer.next.prev := timer.prev;
END;
CheckQueue(queue);
(* queue.lock := FALSE; (* done by CheckQueue *) *)
Events.ExitPriority;
ELSE
Error(timer.queue.clock, invalidTimer);
END;
END Remove;
PROCEDURE Schedule*(clock: Clocks.Clock;
time: Times.Time; event: Events.Event);
VAR
timer: Timer;
BEGIN
Add(clock, time, event, timer);
END Schedule;
PROCEDURE NextEvent*(clock: Clocks.Clock; VAR time: Times.Time) : BOOLEAN;
VAR
rval: BOOLEAN;
queue: Queue;
clockDiscipline: ClockDiscipline;
BEGIN
IF ~Disciplines.Seek(clock, clockDisciplineId, SYSTEM.VAL(Disciplines.Discipline, clockDiscipline)) THEN
RETURN FALSE
END;
queue := clockDiscipline.queue;
IF SYS.TAS(queue.lock) THEN
Error(clock, queueLocked); RETURN FALSE
END;
CheckQueue(queue);
IF queue.head # NIL THEN
time := queue.head.time;
rval := TRUE;
ELSE
rval := FALSE
END;
(* queue.lock := FALSE; (* done by CheckQueue *) *)
RETURN rval
END NextEvent;
BEGIN
InitErrorHandling;
clockDisciplineId := Disciplines.Unique();
END ulmTimers.

392
src/library/ulm/ulmTimes.Mod Normal file
View file

@ -0,0 +1,392 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Times.om,v 1.3 2001/04/30 14:54:44 borchert Exp $
----------------------------------------------------------------------------
$Log: Times.om,v $
Revision 1.3 2001/04/30 14:54:44 borchert
bug fix: base type is TimeRec instead of Times.TimeRec
(invalid self-reference)
Revision 1.2 1995/04/07 13:25:07 borchert
fixes due to changed if of PersistentObjects
Revision 1.1 1994/02/22 20:12:02 borchert
Initial revision
----------------------------------------------------------------------------
AFB 12/91
----------------------------------------------------------------------------
*)
MODULE ulmTimes;
IMPORT NetIO := ulmNetIO, Objects := ulmObjects, Operations := ulmOperations, PersistentObjects := ulmPersistentObjects, Scales := ulmScales,
Services := ulmServices, Streams := ulmStreams, SYSTEM;
CONST
relative* = Scales.relative;
absolute* = Scales.absolute;
TYPE
(* the common base type of all time measures *)
Time* = POINTER TO TimeRec;
TimeRec* = RECORD (Scales.MeasureRec) END;
CONST
usecsPerSec = 1000000; (* 10^6 *)
TYPE
(* units of the reference implementation:
epoch, second and usec
*)
TimeValueRec* =
RECORD
(Objects.ObjectRec)
(* epoch 0: Jan. 1, 1970;
each epoch has a length of MAX(Scales.Value) + 1 seconds;
epoch may be negative:
-1 is the epoch just before 1970
*)
epoch*: Scales.Value;
(* seconds and ... *)
second*: Scales.Value;
(* ... microseconds since the beginning of the epoch *)
usec*: Scales.Value;
END;
(* ==== private datatypes for the reference scale *)
TYPE
ReferenceTime = POINTER TO ReferenceTimeRec;
ReferenceTimeRec =
RECORD
(TimeRec)
timeval: TimeValueRec;
END;
VAR
absType, relType: Services.Type;
CONST
epochUnit = 0; secondUnit = 1; usecUnit = 2;
TYPE
Unit = POINTER TO UnitRec;
UnitRec =
RECORD
(Scales.UnitRec)
index: SHORTINT; (* epochUnit..usecUnit *)
END;
VAR
scale*: Scales.Scale; (* reference scale *)
family*: Scales.Family; (* family of time scales *)
if: Scales.Interface;
PROCEDURE Create*(VAR time: Time; type: SHORTINT);
(* type = absolute or relative *)
VAR
m: Scales.Measure;
BEGIN
Scales.CreateMeasure(scale, m, type);
time := m(Time);
END Create;
PROCEDURE Normalize(VAR timeval: TimeValueRec);
(* make sure that second and usec >= 0 *)
VAR
toomanysecs: Scales.Value;
secs: Scales.Value;
BEGIN
IF timeval.second < 0 THEN
INC(timeval.second, 1);
INC(timeval.second, MAX(Scales.Value));
DEC(timeval.epoch);
END;
IF timeval.usec < 0 THEN
toomanysecs := timeval.usec DIV usecsPerSec;
IF toomanysecs > timeval.second THEN
timeval.second := - toomanysecs + MAX(Scales.Value) + 1 +
timeval.second;
DEC(timeval.epoch);
ELSE
DEC(timeval.second, toomanysecs);
END;
timeval.usec := timeval.usec MOD usecsPerSec;
ELSIF timeval.usec >= usecsPerSec THEN
secs := timeval.usec DIV usecsPerSec;
IF MAX(Scales.Value) - timeval.second <= secs THEN
INC(timeval.second, secs);
ELSE
timeval.second := secs - (MAX(Scales.Value) - timeval.second);
INC(timeval.epoch);
END;
timeval.usec := timeval.usec MOD usecsPerSec;
END;
END Normalize;
PROCEDURE SetValue*(time: Time; value: TimeValueRec);
VAR
refTime: Time;
scaleOfTime: Scales.Scale;
BEGIN
Normalize(value);
IF time IS ReferenceTime THEN
WITH time: ReferenceTime DO
time.timeval := value;
END;
ELSE
Create(refTime, Scales.MeasureType(time));
refTime(ReferenceTime).timeval := value;
Scales.GetScale(time, scaleOfTime);
Scales.ConvertMeasure(scaleOfTime, SYSTEM.VAL(Scales.Measure, refTime));
Operations.Copy(refTime, time);
END;
END SetValue;
PROCEDURE CreateAndSet*(VAR time: Time; type: SHORTINT;
epoch, second, usec: Scales.Value);
VAR
timeval: TimeValueRec;
BEGIN
Create(time, type);
timeval.epoch := epoch; timeval.second := second; timeval.usec := usec;
SetValue(time, timeval);
END CreateAndSet;
PROCEDURE GetValue*(time: Time; VAR value: TimeValueRec);
BEGIN
IF ~(time IS ReferenceTime) THEN
Scales.ConvertMeasure(scale, SYSTEM.VAL(Scales.Measure, time));
END;
value := time(ReferenceTime).timeval;
END GetValue;
(* ===== interface procedures =================================== *)
PROCEDURE InternalCreate(scale: Scales.Scale;
VAR measure: Scales.Measure; abs: BOOLEAN);
VAR
time: ReferenceTime;
BEGIN
NEW(time);
time.timeval.epoch := 0;
time.timeval.second := 0;
time.timeval.usec := 0;
IF abs THEN
PersistentObjects.Init(time, absType);
ELSE
PersistentObjects.Init(time, relType);
END;
measure := time;
END InternalCreate;
PROCEDURE InternalGetValue(measure: Scales.Measure; unit: Scales.Unit;
VAR value: Scales.Value);
BEGIN
WITH measure: ReferenceTime DO WITH unit: Unit DO
CASE unit.index OF
| epochUnit: value := measure.timeval.epoch;
| secondUnit: value := measure.timeval.second;
| usecUnit: value := measure.timeval.usec;
END;
END; END;
END InternalGetValue;
PROCEDURE InternalSetValue(measure: Scales.Measure; unit: Scales.Unit;
value: Scales.Value);
BEGIN
WITH measure: ReferenceTime DO WITH unit: Unit DO
CASE unit.index OF
| epochUnit: measure.timeval.epoch := value;
| secondUnit: measure.timeval.second := value;
| usecUnit: measure.timeval.usec := value;
END;
Normalize(measure.timeval);
END; END;
END InternalSetValue;
PROCEDURE Assign(target: Scales.Measure; source: Scales.Measure);
BEGIN
WITH target: ReferenceTime DO WITH source: ReferenceTime DO
target.timeval := source.timeval;
END; END;
END Assign;
PROCEDURE Op(op: Scales.Operation; op1, op2, result: Scales.Measure);
PROCEDURE Add(op1, op2: TimeValueRec; VAR result: TimeValueRec);
BEGIN
result.epoch := op1.epoch + op2.epoch;
IF op1.second > MAX(Scales.Value) - op2.second THEN
INC(result.epoch);
result.second := op1.second - MAX(Scales.Value) - 1 +
op2.second;
ELSE
result.second := op1.second + op2.second;
END;
result.usec := op1.usec + op2.usec;
IF result.usec > usecsPerSec THEN
DEC(result.usec, usecsPerSec);
IF result.second = MAX(Scales.Value) THEN
result.second := 0; INC(result.epoch);
ELSE
INC(result.second);
END;
END;
END Add;
PROCEDURE Sub(op1, op2: TimeValueRec; VAR result: TimeValueRec);
BEGIN
result.epoch := op1.epoch - op2.epoch;
IF op1.second >= op2.second THEN
result.second := op1.second - op2.second;
ELSE
DEC(result.epoch);
result.second := - op2.second + MAX(Scales.Value) + 1 + op1.second;
END;
result.usec := op1.usec - op2.usec;
IF result.usec < 0 THEN
INC(result.usec, usecsPerSec);
IF result.second = 0 THEN
result.second := MAX(Scales.Value);
DEC(result.epoch);
ELSE
DEC(result.second);
END;
END;
END Sub;
BEGIN
WITH op1: ReferenceTime DO WITH op2: ReferenceTime DO
WITH result: ReferenceTime DO
CASE op OF
| Scales.add: Add(op1.timeval, op2.timeval, result.timeval);
| Scales.sub: Sub(op1.timeval, op2.timeval, result.timeval);
END;
END;
END; END;
END Op;
PROCEDURE Compare(op1, op2: Scales.Measure) : INTEGER;
PROCEDURE ReturnVal(val1, val2: Scales.Value) : INTEGER;
BEGIN
IF val1 < val2 THEN
RETURN -1
ELSIF val1 > val2 THEN
RETURN 1
ELSE
RETURN 0
END;
END ReturnVal;
BEGIN
WITH op1: ReferenceTime DO WITH op2: ReferenceTime DO
IF op1.timeval.epoch # op2.timeval.epoch THEN
RETURN ReturnVal(op1.timeval.epoch, op2.timeval.epoch)
ELSIF op1.timeval.second # op2.timeval.second THEN
RETURN ReturnVal(op1.timeval.second, op2.timeval.second)
ELSE
RETURN ReturnVal(op1.timeval.usec, op2.timeval.usec)
END;
END; END;
END Compare;
(* ========= initialization procedures ========================== *)
PROCEDURE InitInterface;
VAR
timeType: Services.Type;
BEGIN
NEW(if);
if.create := InternalCreate;
if.getvalue := InternalGetValue; if.setvalue := InternalSetValue;
if.assign := Assign; if.op := Op; if.compare := Compare;
(* conversion procedures are not necessary *)
PersistentObjects.RegisterType(timeType, "Times.Time", "Scales.Measure",
NIL);
END InitInterface;
PROCEDURE CreateAbs(VAR object: PersistentObjects.Object);
VAR
measure: Scales.Measure;
BEGIN
Scales.CreateAbsMeasure(scale, measure);
object := measure;
END CreateAbs;
PROCEDURE CreateRel(VAR object: PersistentObjects.Object);
VAR
measure: Scales.Measure;
BEGIN
Scales.CreateRelMeasure(scale, measure);
object := measure;
END CreateRel;
PROCEDURE Write(s: Streams.Stream;
object: PersistentObjects.Object) : BOOLEAN;
BEGIN
WITH object: ReferenceTime DO
RETURN NetIO.WriteLongInt(s, object.timeval.epoch) &
NetIO.WriteLongInt(s, object.timeval.second) &
NetIO.WriteLongInt(s, object.timeval.usec)
END;
END Write;
PROCEDURE Read(s: Streams.Stream;
object: PersistentObjects.Object) : BOOLEAN;
BEGIN
WITH object: ReferenceTime DO
RETURN NetIO.ReadLongInt(s, object.timeval.epoch) &
NetIO.ReadLongInt(s, object.timeval.second) &
NetIO.ReadLongInt(s, object.timeval.usec)
END;
END Read;
PROCEDURE InitRefScale;
VAR
poif: PersistentObjects.Interface;
PROCEDURE InitUnit(unitIndex: SHORTINT; name: Scales.UnitName);
VAR
unit: Unit;
BEGIN
NEW(unit); unit.index := unitIndex;
Scales.InitUnit(scale, unit, name);
END InitUnit;
BEGIN
NEW(scale); Scales.Init(scale, NIL, if);
InitUnit(epochUnit, "epoch");
InitUnit(secondUnit, "second");
InitUnit(usecUnit, "usec");
NEW(poif); poif.read := Read; poif.write := Write;
poif.create := CreateAbs; poif.createAndRead := NIL;
PersistentObjects.RegisterType(absType,
"Times.AbsReferenceTime", "Times.Time", poif);
NEW(poif); poif.read := Read; poif.write := Write;
poif.create := CreateRel; poif.createAndRead := NIL;
PersistentObjects.RegisterType(relType,
"Times.RelReferenceTime", "Times.Time", poif);
END InitRefScale;
BEGIN
InitInterface;
InitRefScale;
NEW(family); Scales.InitFamily(family, scale);
END ulmTimes.

141
src/library/ulm/ulmTypes.Mod Normal file
View file

@ -0,0 +1,141 @@
(* Ulm's Oberon Library
Copyright (C) 1989-2000 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Types.om,v 1.5 2000/12/13 10:03:00 borchert Exp $
----------------------------------------------------------------------------
$Log: Types.om,v $
Revision 1.5 2000/12/13 10:03:00 borchert
SetInt type used in msb constant
Revision 1.4 2000/12/13 09:51:57 borchert
constants and types for the relationship of INTEGER and SET added
Revision 1.3 1998/09/25 15:23:09 borchert
Real32..Real128 added
Revision 1.2 1994/07/01 11:08:04 borchert
IntAddress, Int8/16/32, ToInt8/16/32 and bit/little endian stuff added
Revision 1.1 1994/02/22 20:12:14 borchert
Initial revision
----------------------------------------------------------------------------
AFB 9/93
----------------------------------------------------------------------------
*)
MODULE ulmTypes;
(* compiler-dependent type definitions;
this version works for Ulm's Oberon Compilers on
following architectures: m68k and sparc
*)
IMPORT SYS := SYSTEM;
TYPE
Address* = (*SYS.PTR*) LONGINT (*SYS.ADDRESS*);
(* ulm compiler can accept
VAR p : SYSTEM.ADDRESS; // SYSTEM.PTR in ETH and V4 versions
...
p := SYSTEM.ADR(something);
and this is how it is used in ulm oberon system library,
while SYSTEM.ADR returns LONGINT in ETH and V4 versions.
Thus I leave it as LONGINT for now, before coming up with better solution -- noch *)
UntracedAddress* = POINTER[1] TO UntracedAddressDesc; (*SYS.UNTRACEDADDRESS;*)
UntracedAddressDesc* = RECORD[1] END;
intarr64 = ARRAY 8 OF SYS.BYTE; (* to emulate int16 on x86_64; -- noch *)
intarr16 = ARRAY 2 OF SYS.BYTE;
Count* = LONGINT;
Size* = Count;
Byte* = SYS.BYTE;
IntAddress* = LONGINT;
Int8* = SHORTINT;
Int16* = intarr16(*INTEGER*); (* we don't have 16 bit integer in x86_64 version of voc *)
Int32* = INTEGER;
Real32* = REAL;
Real64* = LONGREAL;
CONST
bigEndian* = 0; (* SPARC, M68K etc *)
littleEndian* = 1; (* Intel 80x86, VAX etc *)
byteorder* = littleEndian; (* machine-dependent constant *)
TYPE
ByteOrder* = SHORTINT; (* bigEndian or littleEndian *)
(* following constants and type definitions try to make
conversions from INTEGER to SET and vice versa more portable
to allow for bit operations on INTEGER values
*)
TYPE
SetInt* = LONGINT; (* INTEGER type that corresponds to SET *)
VAR msb* : SET;
msbIsMax*, msbIs0*: SHORTINT;
msbindex*, lsbindex*, nofbits*: LONGINT;
PROCEDURE ToInt8*(int: LONGINT) : Int8;
BEGIN
RETURN SHORT(SHORT(int))
END ToInt8;
PROCEDURE ToInt16*(int: LONGINT; VAR int16: Int16)(* : Int16*);
VAR longintarr : intarr64;
BEGIN
(*RETURN SYS.VAL(Int16, int)*)
longintarr := SYS.VAL(intarr64, int);
int16[0] := longintarr[0];
int16[1] := longintarr[1]; (* this will work for little endian -- noch *)
END ToInt16;
PROCEDURE ToInt32*(int: LONGINT) : Int32;
BEGIN
RETURN SHORT(int)
END ToInt32;
PROCEDURE ToReal32*(real: LONGREAL) : Real32;
BEGIN
RETURN SHORT(real)
END ToReal32;
PROCEDURE ToReal64*(real: LONGREAL) : Real64;
BEGIN
RETURN real
END ToReal64;
BEGIN
msb := SYS.VAL(SET, MIN(SetInt));
(* most significant bit, converted to a SET *)
(* we expect msbIsMax XOR msbIs0 to be 1;
this is checked for by an assertion
*)
msbIsMax := SYS.VAL(SHORTINT, (msb = {MAX(SET)}));
(* is 1, if msb equals {MAX(SET)} *)
msbIs0 := SYS.VAL(SHORTINT, (msb = {0}));
(* is 0, if msb equals {0} *)
msbindex := msbIsMax * MAX(SET);
(* set element that corresponds to the most-significant-bit *)
lsbindex := MAX(SET) - msbindex;
(* set element that corresponds to the lowest-significant-bit *)
nofbits := MAX(SET) + 1;
(* number of elements in SETs *)
ASSERT((msbIs0 = 1) & (msbIsMax = 0) OR (msbIs0 = 0) & (msbIsMax = 1));
END ulmTypes.

224
src/library/ulm/ulmWrite.Mod Normal file
View file

@ -0,0 +1,224 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Write.om,v 1.2 1994/07/05 12:52:27 borchert Exp $
----------------------------------------------------------------------------
$Log: Write.om,v $
Revision 1.2 1994/07/05 12:52:27 borchert
Indent/IndentS added
Revision 1.1 1994/02/23 07:47:04 borchert
Initial revision
----------------------------------------------------------------------------
AFB 7/89
----------------------------------------------------------------------------
*)
MODULE ulmWrite;
IMPORT ASCII := ulmASCII, Print := ulmPrint, StreamDisciplines := ulmStreamDisciplines, Streams := ulmStreams, SYSTEM, SYS := ulmSYSTEM;
(*
TYPE barr = ARRAY SIZE(LONGINT) OF SYSTEM.BYTE; (* need this because voc does not convert implicitly LONGINT to ARRAY OF BYTE; -- noch *)
pbarr = POINTER TO barr;
TYPE lrarr = ARRAY SIZE(LONGREAL) OF SYSTEM.BYTE; (* need this because voc does not convert implicitly LONGINT to ARRAY OF BYTE; -- noch *)
plrarr = POINTER TO barr;
PROCEDURE LongToByteArr ( l : LONGINT; VAR bar : barr); (* noch *)
VAR b : SYSTEM.BYTE;
p : pbarr;
i : LONGINT;
BEGIN
p := SYSTEM.VAL(pbarr, SYSTEM.ADR(l));
FOR i := 0 TO SIZE(LONGINT) -1 DO
b := p^[i]; bar[i] := b;
END
END LongToByteArr;
PROCEDURE LRealToByteArr ( l : LONGREAL; VAR lar : lrarr); (* noch *)
VAR b : SYSTEM.BYTE;
p : plrarr;
i : LONGINT;
BEGIN
p := SYSTEM.VAL(plrarr, SYSTEM.ADR(l));
FOR i := 0 TO SIZE(LONGREAL) -1 DO
b := p^[i]; lar[i] := b;
END
END LRealToByteArr;
*)
PROCEDURE IntS*(s: Streams.Stream; int: LONGINT; width: LONGINT);
VAR b, b0 : SYS.bytearray;
BEGIN
SYS.LongToByteArr(int, b);
SYS.LongToByteArr(width, b0);
Print.S2(s, "%*d", b0, b);
END IntS;
PROCEDURE RealS*(s: Streams.Stream; real: LONGREAL; width: LONGINT);
VAR b : SYS.bytearray; lr : SYS.longrealarray;
BEGIN
SYS.LRealToByteArr(real, lr);
SYS.LongToByteArr(width, b);
Print.S2(s, "%*e", b, lr);
END RealS;
PROCEDURE CharS*(s: Streams.Stream; ch: CHAR);
BEGIN
IF ~Streams.WriteByte(s, ch) THEN END;
END CharS;
PROCEDURE ByteS*(s: Streams.Stream; byte: SYSTEM.BYTE);
BEGIN
IF ~Streams.WriteByte(s, byte) THEN END;
END ByteS;
PROCEDURE LineS*(s: Streams.Stream; str: ARRAY OF CHAR);
VAR
count: LONGINT;
nlOK: BOOLEAN;
cnt: LONGINT;
lineterm: StreamDisciplines.LineTerminator;
len: INTEGER; i: INTEGER;
BEGIN
cnt := 0;
WHILE (cnt < LEN(str)) & (str[cnt] # 0X) DO
INC(cnt);
END;
StreamDisciplines.GetLineTerm(s, lineterm);
(* determine length of line terminator *)
len := 1;
WHILE (len < LEN(lineterm)) & (lineterm[len] # 0X) DO
INC(len);
END;
(* append line terminator to str (if possible) for
reasons of efficiency
*)
IF cnt+len < LEN(str) THEN
i := 0;
WHILE i < len DO
str[cnt] := lineterm[i]; INC(cnt); INC(i);
END;
nlOK := TRUE;
ELSE
nlOK := FALSE;
END;
count := 0;
IF cnt > 0 THEN
IF ~Streams.WritePart(s, str, 0, cnt) THEN
RETURN
END;
count := s.count;
END;
IF ~nlOK THEN
IF ~Streams.WritePart(s, lineterm, 0, len) THEN END;
INC(count, s.count);
END;
s.count := count;
END LineS;
PROCEDURE LnS*(s: Streams.Stream);
VAR
lineterm: StreamDisciplines.LineTerminator;
len: INTEGER;
BEGIN
StreamDisciplines.GetLineTerm(s, lineterm);
IF lineterm[1] = 0X THEN
IF ~Streams.WriteByte(s, lineterm[0]) THEN END;
ELSE
len := 1;
WHILE (len < LEN(lineterm)) & (lineterm[len] # 0X) DO
INC(len);
END;
IF ~Streams.WritePart(s, lineterm, 0, len) THEN END;
END;
END LnS;
PROCEDURE StringS*(s: Streams.Stream; str: ARRAY OF CHAR);
VAR
cnt: LONGINT;
BEGIN
cnt := 0;
WHILE (cnt < LEN(str)) & (str[cnt] # 0X) DO
INC(cnt);
END;
IF (cnt > 0) & ~Streams.WritePart(s, str, 0, cnt) THEN END;
END StringS;
PROCEDURE IndentS*(s: Streams.Stream);
VAR
indentwidth: INTEGER;
BEGIN
StreamDisciplines.GetIndentationWidth(s, indentwidth);
WHILE (indentwidth > 0) & Streams.WriteByte(s, " ") DO
DEC(indentwidth);
END;
END IndentS;
(* procedures writing to Streams.stdout *)
PROCEDURE Int*(int: LONGINT; width: LONGINT);
BEGIN
IntS(Streams.stdout, int, width);
END Int;
PROCEDURE Real*(real: LONGREAL; width: LONGINT);
(* write real in exponential format *)
BEGIN
RealS(Streams.stdout, real, width);
END Real;
PROCEDURE Char*(ch: CHAR);
BEGIN
CharS(Streams.stdout, ch);
END Char;
PROCEDURE Byte*(byte: SYSTEM.BYTE);
BEGIN
ByteS(Streams.stdout, byte);
END Byte;
PROCEDURE Line*(s: ARRAY OF CHAR);
BEGIN
LineS(Streams.stdout, s);
END Line;
PROCEDURE Ln*;
BEGIN
LnS(Streams.stdout);
END Ln;
PROCEDURE String*(s: ARRAY OF CHAR);
BEGIN
StringS(Streams.stdout, s);
END String;
PROCEDURE Indent*;
BEGIN
IndentS(Streams.stdout);
END Indent;
END ulmWrite.