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

voc compiler first commit

Browse source
This commit is contained in:
Norayr Chilingarian 2013-09-27 22:34:17 +04:00
parent 4a7dc4b549
commit 760d826948
119 changed files with 30394 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

565
src/lib/ulm/gnuc/ulmEvents.Mod Normal file
View file

@ -0,0 +1,565 @@
(* 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, SYSTEM;
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;
(* noch *)
PROCEDURE -getaddr(handler: EventHandler): LONGINT
"(LONGINT)&handler";
PROCEDURE NilHandler*(event: Event);
(* an empty event handler *)
END NilHandler;
(* now QueueHandler will translate partly like
i = (long)&handler;
j = (long)&ulmEvents_NilHandler;
b = i != j;
if (!(b)) {SYSTEM_assert = 0; SYSTEM_HALT(-1);};
; 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 *)
i,j : LONGINT;
BEGIN
i := getaddr(handler);
j := getaddr(NilHandler);
b := i # j;
(*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.

60
src/lib/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.

140
src/lib/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.

244
src/lib/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.

138
src/lib/ulm/ulmIEEE.Mod Normal file
View file

@ -0,0 +1,138 @@
(* 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);
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.

39
src/lib/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.

155
src/lib/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.

422
src/lib/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/lib/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.

54
src/lib/ulm/ulmSYSTEM.Mod Normal file
View file

@ -0,0 +1,54 @@
MODULE ulmSYSTEM;
IMPORT SYSTEM(*, ulmObjects, ulmDisciplines, Console*);
(* test *)
(*
VAR d0, d1 : ulmDisciplines.Discipline;
*)
(* noch *)
(* PROCEDURE -getaddr*(obj: ulmObjects.Object): LONGINT
"(LONGINT)&obj";*)
(*
PROCEDURE -assignObjectPointers* (VAR src, dst : ulmObjects.Object)
"*dst=*src";
PROCEDURE assignObjectPointer*(src, dst : ulmObjects.Object);
BEGIN
assignObjectPointers(src, dst);
END assignObjectPointer;
PROCEDURE assignDisciplinePointer (src, dst : ulmDisciplines.Discipline);
BEGIN
assignObjectPointers(src, dst);
END assignDisciplinePointer;
*)
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;
(*
BEGIN
NEW (d0);
NEW (d1);
d0.id := 0;
d1.id := 1;
Console.String ("d0.id=");Console.Int (d0.id, 0); Console.Ln;
Console.String ("d1.id=");Console.Int (d1.id, 0); Console.Ln;
(*
assignDisciplinePointer(d0, d1);
*)
Console.String ("d0.id=");Console.Int (d0.id, 0); Console.Ln;
Console.String ("d1.id=");Console.Int (d1.id, 0); Console.Ln;
*)
END ulmSYSTEM.

520
src/lib/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/lib/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.