mirror of
https://github.com/vishapoberon/compiler.git
synced 2026-04-06 14:32:24 +00:00
244 lines
8 KiB
Modula-2
244 lines
8 KiB
Modula-2
(* 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.
|