mirror of
https://github.com/vishapoberon/compiler.git
synced 2026-04-06 23:52:25 +00:00
391 lines
11 KiB
Modula-2
391 lines
11 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: PersistentD.om,v 1.4 1998/02/22 10:25:22 borchert Exp $
|
|
----------------------------------------------------------------------------
|
|
$Log: PersistentD.om,v $
|
|
Revision 1.4 1998/02/22 10:25:22 borchert
|
|
bug fix in GetObject: Disciplines.Add was missing if the main object
|
|
is just an extension of Disciplines.Object and not of
|
|
PersistentDisciplines.Object
|
|
|
|
Revision 1.3 1996/07/24 07:41:28 borchert
|
|
bug fix: count component was not initialized (with the
|
|
exception of CreateObject) -- detected by Martin Hasch
|
|
|
|
Revision 1.2 1995/03/17 16:13:33 borchert
|
|
- persistent disciplines may now be attached to non-persistent objects
|
|
- some fixes due to changes of PersistentObjects
|
|
|
|
Revision 1.1 1994/02/22 20:09:12 borchert
|
|
Initial revision
|
|
|
|
----------------------------------------------------------------------------
|
|
*)
|
|
|
|
MODULE ulmPersistentDisciplines;
|
|
|
|
IMPORT Disciplines := ulmDisciplines, Forwarders := ulmForwarders, NetIO := ulmNetIO, Objects := ulmObjects, PersistentObjects := ulmPersistentObjects,
|
|
Services := ulmServices, Streams := ulmStreams, SYS := SYSTEM;
|
|
|
|
CONST
|
|
objectName = "PersistentDisciplines.Object";
|
|
disciplineName = "PersistentDisciplines.Discipline";
|
|
|
|
TYPE
|
|
Identifier* = LONGINT;
|
|
|
|
Discipline* = POINTER TO DisciplineRec;
|
|
DisciplineRec* =
|
|
RECORD
|
|
(PersistentObjects.ObjectRec)
|
|
id*: Identifier; (* should be unique for all types of disciplines *)
|
|
END;
|
|
|
|
DisciplineList = POINTER TO DisciplineListRec;
|
|
DisciplineListRec =
|
|
RECORD
|
|
discipline: Discipline;
|
|
id: Identifier; (* copied from discipline.id *)
|
|
next: DisciplineList;
|
|
END;
|
|
|
|
Interface = POINTER TO InterfaceRec;
|
|
Object = POINTER TO ObjectRec;
|
|
ObjectRec* =
|
|
RECORD
|
|
(PersistentObjects.ObjectRec)
|
|
(* private part *)
|
|
count: LONGINT; (* number of attached disciplines *)
|
|
list: DisciplineList; (* set of disciplines *)
|
|
if: Interface; (* overrides builtins if # NIL *)
|
|
forwardTo: Object;
|
|
usedBy: Object; (* used as target of UseInterfaceOf *)
|
|
(* very restrictive way of avoiding reference cycles:
|
|
forwardTo references must be built from inner to
|
|
outer objects and not vice versa
|
|
*)
|
|
END;
|
|
|
|
TYPE
|
|
VolatileDiscipline = POINTER TO VolatileDisciplineRec;
|
|
VolatileDisciplineRec =
|
|
RECORD
|
|
(Disciplines.DisciplineRec)
|
|
object: Object;
|
|
END;
|
|
VAR
|
|
volDiscID: Disciplines.Identifier;
|
|
|
|
TYPE
|
|
AddProc* = PROCEDURE (object: Disciplines.Object; discipline: Discipline);
|
|
RemoveProc* = PROCEDURE (object: Disciplines.Object; id: Identifier);
|
|
SeekProc* = PROCEDURE (object: Disciplines.Object; id: Identifier;
|
|
VAR discipline: Discipline) : BOOLEAN;
|
|
InterfaceRec* =
|
|
RECORD
|
|
(Objects.ObjectRec)
|
|
add*: AddProc;
|
|
remove*: RemoveProc;
|
|
seek*: SeekProc;
|
|
END;
|
|
|
|
VAR
|
|
unique: Identifier;
|
|
objIf: PersistentObjects.Interface;
|
|
objDatatype, discDatatype: Services.Type;
|
|
|
|
CONST
|
|
hashtabsize = 32;
|
|
TYPE
|
|
Sample = POINTER TO SampleRec;
|
|
SampleRec =
|
|
RECORD
|
|
id: Identifier;
|
|
sample: Discipline;
|
|
next: Sample;
|
|
END;
|
|
BucketTable = ARRAY hashtabsize OF Sample;
|
|
VAR
|
|
samples: BucketTable;
|
|
|
|
PROCEDURE CreateObject*(VAR object: Object);
|
|
(* creates a new object; this procedures should be called instead of
|
|
NEW for objects of type `Object'
|
|
*)
|
|
BEGIN
|
|
NEW(object);
|
|
object.count := 0; (* up to now, there are no attached disciplines *)
|
|
object.list := NIL;
|
|
object.if := NIL;
|
|
PersistentObjects.Init(object, objDatatype);
|
|
END CreateObject;
|
|
|
|
PROCEDURE GetObject(obj: Disciplines.Object; VAR object: Object);
|
|
VAR
|
|
disc: VolatileDiscipline;
|
|
BEGIN
|
|
IF obj IS Object THEN
|
|
object := obj(Object);
|
|
(* initialize private components now if not done already;
|
|
we assume here that pointers which have not been
|
|
initialized yet are defined to be NIL
|
|
(because of the garbage collection);
|
|
a similar assumption does not necessarily hold for
|
|
other types (e.g. integers)
|
|
*)
|
|
IF object.list = NIL THEN
|
|
object.count := 0;
|
|
END;
|
|
ELSIF Disciplines.Seek(obj, volDiscID, SYS.VAL(Disciplines.Discipline, disc)) THEN
|
|
object := disc.object;
|
|
ELSE
|
|
CreateObject(object);
|
|
NEW(disc); disc.id := volDiscID; disc.object := object;
|
|
Disciplines.Add(obj, disc);
|
|
END;
|
|
END GetObject;
|
|
|
|
(* === normal stuff for disciplines ===================================== *)
|
|
|
|
PROCEDURE Unique*(sample: Discipline) : Identifier;
|
|
(* returns a unique identifier;
|
|
this procedure should be called during initialization by
|
|
all modules defining a discipline type;
|
|
a sample of the associated discipline has to be provided
|
|
*)
|
|
VAR
|
|
hashval: Identifier;
|
|
entry: Sample;
|
|
BEGIN
|
|
INC(unique);
|
|
NEW(entry); entry.id := unique; entry.sample := sample;
|
|
hashval := unique MOD hashtabsize;
|
|
entry.next := samples[hashval]; samples[hashval] := entry;
|
|
RETURN unique
|
|
END Unique;
|
|
|
|
PROCEDURE GetSample*(id: Identifier) : Discipline;
|
|
(* return sample for the given identifier;
|
|
NIL will be returned if id has not yet been returned by Unique
|
|
*)
|
|
VAR
|
|
hashval: Identifier;
|
|
ptr: Sample;
|
|
BEGIN
|
|
hashval := id MOD hashtabsize;
|
|
ptr := samples[hashval];
|
|
WHILE (ptr # NIL) & (ptr.id # id) DO
|
|
ptr := ptr.next;
|
|
END;
|
|
IF ptr # NIL THEN
|
|
RETURN ptr.sample
|
|
ELSE
|
|
RETURN NIL
|
|
END;
|
|
END GetSample;
|
|
|
|
PROCEDURE AttachInterface*(object: Disciplines.Object; if: Interface);
|
|
(* override the builtin implementations of Add, Remove and
|
|
Seek for `object' with the implementations given by `if'
|
|
*)
|
|
VAR
|
|
po: Object;
|
|
BEGIN
|
|
GetObject(object, po);
|
|
IF (po.list = NIL) & (po.forwardTo = NIL) THEN
|
|
po.if := if;
|
|
END;
|
|
END AttachInterface;
|
|
|
|
PROCEDURE UseInterfaceOf*(object, host: Disciplines.Object);
|
|
(* forward Add, Remove and Seek operations from object to host *)
|
|
VAR
|
|
po, phost: Object;
|
|
BEGIN
|
|
GetObject(object, po); GetObject(host, phost);
|
|
IF (po.list = NIL) & (po.forwardTo = NIL) &
|
|
(po.usedBy = NIL) THEN
|
|
po.forwardTo := phost;
|
|
phost.usedBy := po; (* avoid reference cycles *)
|
|
END;
|
|
END UseInterfaceOf;
|
|
|
|
PROCEDURE Forward(from, to: Forwarders.Object);
|
|
BEGIN
|
|
UseInterfaceOf(from, to);
|
|
END Forward;
|
|
|
|
PROCEDURE Remove*(object: Disciplines.Object; id: Identifier);
|
|
(* remove the discipline with the given id from object, if it exists *)
|
|
VAR
|
|
po: Object;
|
|
prev, dl: DisciplineList;
|
|
BEGIN
|
|
GetObject(object, po);
|
|
WHILE po.forwardTo # NIL DO
|
|
po := po.forwardTo;
|
|
END;
|
|
IF po.if = NIL THEN
|
|
prev := NIL;
|
|
dl := po.list;
|
|
WHILE (dl # NIL) & (dl.id # id) DO
|
|
prev := dl; dl := dl.next;
|
|
END;
|
|
IF dl # NIL THEN
|
|
IF prev = NIL THEN
|
|
po.list := dl.next;
|
|
ELSE
|
|
prev.next := dl.next;
|
|
END;
|
|
DEC(po.count); (* discipline removed *)
|
|
END;
|
|
ELSE
|
|
po.if.remove(po, id);
|
|
END;
|
|
END Remove;
|
|
|
|
PROCEDURE Add*(object: Disciplines.Object; discipline: Discipline);
|
|
(* adds a new discipline to the given object;
|
|
if already a discipline with the same identifier exist
|
|
it is deleted first
|
|
*)
|
|
VAR
|
|
po: Object;
|
|
dl: DisciplineList;
|
|
BEGIN
|
|
GetObject(object, po);
|
|
WHILE po.forwardTo # NIL DO
|
|
po := po.forwardTo;
|
|
END;
|
|
IF po.if = NIL THEN
|
|
dl := po.list;
|
|
WHILE (dl # NIL) & (dl.id # discipline.id) DO
|
|
dl := dl.next;
|
|
END;
|
|
IF dl = NIL THEN
|
|
NEW(dl);
|
|
dl.id := discipline.id;
|
|
dl.next := po.list;
|
|
po.list := dl;
|
|
INC(po.count); (* discipline added *)
|
|
END;
|
|
dl.discipline := discipline;
|
|
ELSE
|
|
po.if.add(po, discipline);
|
|
END;
|
|
END Add;
|
|
|
|
PROCEDURE Seek*(object: Disciplines.Object; id: Identifier;
|
|
VAR discipline: Discipline) : BOOLEAN;
|
|
(* returns TRUE if a discipline with the given id is found *)
|
|
VAR
|
|
po: Object;
|
|
dl: DisciplineList;
|
|
BEGIN
|
|
GetObject(object, po);
|
|
WHILE po.forwardTo # NIL DO
|
|
po := po.forwardTo;
|
|
END;
|
|
IF po.if = NIL THEN
|
|
dl := po.list;
|
|
WHILE (dl # NIL) & (dl.id # id) DO
|
|
dl := dl.next;
|
|
END;
|
|
IF dl # NIL THEN
|
|
discipline := dl.discipline;
|
|
ELSE
|
|
discipline := NIL;
|
|
END;
|
|
RETURN discipline # NIL
|
|
ELSE
|
|
RETURN po.if.seek(po, id, discipline)
|
|
END;
|
|
END Seek;
|
|
|
|
(* === interface procedures for PersistentObjects for Object === *)
|
|
|
|
PROCEDURE ReadObjectData(stream: Streams.Stream;
|
|
object: PersistentObjects.Object) : BOOLEAN;
|
|
(* read data and attached disciplines of given object from stream *)
|
|
VAR
|
|
discipline: Discipline;
|
|
count: LONGINT;
|
|
BEGIN
|
|
(* get number of attached disciplines *)
|
|
IF ~NetIO.ReadLongInt(stream, count) THEN
|
|
RETURN FALSE;
|
|
END;
|
|
(* read all disciplines from `stream' and attach them to `object' *)
|
|
WHILE count > 0 DO
|
|
IF ~PersistentObjects.Read(stream, SYS.VAL(PersistentObjects.Object, discipline)) THEN
|
|
RETURN FALSE;
|
|
END;
|
|
Add(object(Object), discipline);
|
|
DEC(count);
|
|
END;
|
|
RETURN TRUE;
|
|
END ReadObjectData;
|
|
|
|
PROCEDURE WriteObjectData(stream: Streams.Stream;
|
|
object: PersistentObjects.Object) : BOOLEAN;
|
|
(* write data and attached disciplines of given object to stream *)
|
|
VAR
|
|
dl: DisciplineList;
|
|
BEGIN
|
|
WITH object: Object DO
|
|
(* write number of attached disciplines to `stream' *)
|
|
IF ~NetIO.WriteLongInt(stream, object.count) THEN
|
|
RETURN FALSE;
|
|
END;
|
|
(* write all attached disciplines to the stream *)
|
|
dl := object.list;
|
|
WHILE dl # NIL DO
|
|
IF ~PersistentObjects.Write(stream, dl.discipline) THEN
|
|
RETURN FALSE;
|
|
END;
|
|
dl := dl.next;
|
|
END;
|
|
END;
|
|
RETURN TRUE;
|
|
END WriteObjectData;
|
|
|
|
PROCEDURE InternalCreate(VAR obj: PersistentObjects.Object);
|
|
VAR
|
|
myObject: Object;
|
|
BEGIN
|
|
CreateObject(myObject);
|
|
obj := myObject;
|
|
END InternalCreate;
|
|
|
|
BEGIN
|
|
unique := 0;
|
|
|
|
NEW(objIf);
|
|
objIf.read := ReadObjectData;
|
|
objIf.write := WriteObjectData;
|
|
objIf.create := InternalCreate;
|
|
objIf.createAndRead := NIL;
|
|
PersistentObjects.RegisterType(objDatatype, objectName, "", objIf);
|
|
PersistentObjects.RegisterType(discDatatype, disciplineName, "", NIL);
|
|
|
|
volDiscID := Disciplines.Unique();
|
|
|
|
Forwarders.Register("", Forward);
|
|
END ulmPersistentDisciplines.
|