mirror of
https://github.com/vishapoberon/compiler.git
synced 2026-04-07 03:22:24 +00:00
422 lines
13 KiB
Modula-2
422 lines
13 KiB
Modula-2
(* 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.
|