diff --git a/makefile b/makefile index 0119f235..340e21ec 100644 --- a/makefile +++ b/makefile @@ -172,6 +172,11 @@ stage6: $(VOCSTATIC) -sP ulmErrors.Mod $(VOCSTATIC) -sP ulmSysErrors.Mod $(VOCSTATIC) -sP ulmSysIO.Mod + $(VOCSTATIC) -sP ulmLoader.Mod + $(VOCSTATIC) -sP ulmNetIO.Mod + $(VOCSTATIC) -sP ulmPersistentObjects.Mod + $(VOCSTATIC) -sP ulmPersistentDisciplines.Mod + $(VOCSTATIC) -sP ulmOperations.Mod #pow32 libs diff --git a/src/lib/ulm/ulmConstStrings.Mod b/src/lib/ulm/ulmConstStrings.Mod index 86a5bf81..3b4de5ba 100644 --- a/src/lib/ulm/ulmConstStrings.Mod +++ b/src/lib/ulm/ulmConstStrings.Mod @@ -69,7 +69,7 @@ MODULE ulmConstStrings; next: Buffer; END; - String = POINTER TO StringRec; + String* = POINTER TO StringRec; StringRec* = RECORD (Disciplines.ObjectRec) diff --git a/src/lib/ulm/ulmLoader.Mod b/src/lib/ulm/ulmLoader.Mod new file mode 100644 index 00000000..16493459 --- /dev/null +++ b/src/lib/ulm/ulmLoader.Mod @@ -0,0 +1,216 @@ +(* Ulm's Oberon Library + Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. + + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: Loader.om,v 1.3 2004/09/03 09:46:50 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: Loader.om,v $ + Revision 1.3 2004/09/03 09:46:50 borchert + error events are also raised as global events + (this allows to log all failed loading operations) + + Revision 1.2 1996/01/04 16:48:33 borchert + support for dynamic loading of service providers added + + Revision 1.1 1994/02/22 20:08:13 borchert + Initial revision + + ---------------------------------------------------------------------------- + AFB 6/93 + ---------------------------------------------------------------------------- +*) + +MODULE ulmLoader; + + (* load and initialize modules *) + + IMPORT ASCII := ulmASCII , Events := ulmEvents, Priorities := ulmPriorities, RelatedEvents := ulmRelatedEvents, Services := ulmServices; + + CONST + loadService* = 0; + TYPE + CapabilitySet* = SET; (* loadService..loadService *) + LoadProc* = PROCEDURE (module: ARRAY OF CHAR; + errors: RelatedEvents.Object) : BOOLEAN; + LoadServiceProc* = PROCEDURE (service, for: ARRAY OF CHAR; + errors: RelatedEvents.Object) : BOOLEAN; + Interface* = POINTER TO InterfaceRec; + InterfaceRec* = + RECORD + load*: LoadProc; + loadService*: LoadServiceProc; + END; + + CONST + noInterface* = 0; (* SetInterface has not been called yet *) + moduleNotLoaded* = 1; (* interface procedure returned FALSE *) + servicesNotSupported* = 2; (* no dynamic loading of service providers *) + serviceNotLoaded* = 3; (* interface procedure returned FALSE *) + errorcodes* = 4; + TYPE + ErrorEvent* = POINTER TO ErrorEventRec; + ErrorEventRec* = + RECORD + (Events.EventRec) + errorcode*: SHORTINT; + module*: Events.Message; (* module or service name *) + for*: Events.Message; (* type name for serviceNotLoaded *) + END; + VAR + errormsg*: ARRAY errorcodes OF Events.Message; + error*: Events.EventType; + + VAR + loadif: Interface; loadcaps: CapabilitySet; + + (* commented out because Loader must not import Streams, Errors + and Strings to avoid reference cycles + + PROCEDURE WriteErrorEvent(s: Streams.Stream; event: Events.Event); + + PROCEDURE WriteString(string: ARRAY OF CHAR); + BEGIN + IF ~Streams.WritePart(s, string, 0, Strings.Len(string)) THEN END; + END WriteString; + + PROCEDURE WriteChar(ch: CHAR); + BEGIN + IF ~Streams.WriteByte(s, ch) THEN END; + END WriteChar; + + BEGIN + WITH event: ErrorEvent DO + WriteChar(ASCII.quote); + WriteString(event.module); + WriteChar(ASCII.quote); + IF event.for # "" THEN + WriteString(" for "); + WriteChar(ASCII.quote); + WriteString(event.for); + WriteChar(ASCII.quote); + END; + WriteString(": "); + WriteString(event.message); + END; + END WriteErrorEvent; + + *) + + PROCEDURE InitErrorHandling; + BEGIN + Events.Define(error); + Events.SetPriority(error, Priorities.liberrors); + Events.Ignore(error); + (* Errors.AssignWriteProcedure(error, WriteErrorEvent); *) + errormsg[noInterface] := "Loader.SetInterface has not been called yet"; + errormsg[moduleNotLoaded] := "module cannot be loaded"; + errormsg[servicesNotSupported] := + "dynamic loading of service providers is not supported"; + errormsg[serviceNotLoaded] := + "serving module cannot be loaded"; + END InitErrorHandling; + + PROCEDURE SetInterface*(if: Interface; caps: CapabilitySet); + BEGIN + loadif := if; loadcaps := caps; + END SetInterface; + + PROCEDURE Load*(module: ARRAY OF CHAR; + errors: RelatedEvents.Object) : BOOLEAN; + + PROCEDURE Error(errorcode: SHORTINT); + VAR + event: ErrorEvent; + BEGIN + NEW(event); + event.type := error; + event.message := errormsg[errorcode]; + event.errorcode := errorcode; + COPY(module, event.module); + event.for[0] := 0X; + RelatedEvents.Raise(errors, event); + Events.Raise(event); + END Error; + + BEGIN + IF loadif = NIL THEN + Error(noInterface); RETURN FALSE + ELSE + IF ~loadif.load(module, errors) THEN + Error(moduleNotLoaded); RETURN FALSE + END; + RETURN TRUE + END; + END Load; + + PROCEDURE LoadService*(service, for: ARRAY OF CHAR; + errors: RelatedEvents.Object) : BOOLEAN; + + PROCEDURE Error(errorcode: SHORTINT); + VAR + event: ErrorEvent; + BEGIN + NEW(event); + event.type := error; + event.message := errormsg[errorcode]; + event.errorcode := errorcode; + COPY(service, event.module); + COPY(for, event.for); + RelatedEvents.Raise(errors, event); + Events.Raise(event); + END Error; + + BEGIN + IF loadif = NIL THEN + Error(noInterface); RETURN FALSE + ELSIF ~(loadService IN loadcaps) THEN + Error(servicesNotSupported); RETURN FALSE + ELSIF ~loadif.loadService(service, for, errors) THEN + Error(serviceNotLoaded); RETURN FALSE + ELSE + RETURN TRUE + END; + END LoadService; + + (* === support of Services =========================================== *) + + PROCEDURE LService(service, for: ARRAY OF CHAR) : BOOLEAN; + BEGIN + RETURN LoadService(service, for, RelatedEvents.null) + END LService; + + PROCEDURE LModule(module: ARRAY OF CHAR) : BOOLEAN; + BEGIN + RETURN Load(module, RelatedEvents.null) + END LModule; + + PROCEDURE InitServices; + VAR + if: Services.LoaderInterface; + BEGIN + NEW(if); + if.loadService := LService; + if.loadModule := LModule; + Services.InitLoader(if); + END InitServices; + +BEGIN + loadif := NIL; loadcaps := {}; + InitErrorHandling; + InitServices; +END ulmLoader. diff --git a/src/lib/ulm/ulmNetIO.Mod b/src/lib/ulm/ulmNetIO.Mod new file mode 100644 index 00000000..0d0d44a0 --- /dev/null +++ b/src/lib/ulm/ulmNetIO.Mod @@ -0,0 +1,546 @@ +(* Ulm's Oberon Library + Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. + + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: NetIO.om,v 1.4 2004/05/21 15:19:03 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: NetIO.om,v $ + Revision 1.4 2004/05/21 15:19:03 borchert + performance improvements: + - ReadConstStringD prefers Streams.ReadPart and ConstStrings.CreateD, + if possible + (based on code by Christian Ehrhardt) + - WriteConstString uses Streams.Copy instead of a loop that uses + Streams.ReadByte and Streams.WriteByte + + Revision 1.3 1995/03/17 16:28:20 borchert + - SizeOf stuff removed + - support of const strings added + - support of Forwarders added + + Revision 1.2 1994/07/18 14:18:37 borchert + unused variables of WriteString (ch + index) removed + + Revision 1.1 1994/02/22 20:08:43 borchert + Initial revision + + ---------------------------------------------------------------------------- + AFB 6/93 + ---------------------------------------------------------------------------- +*) + +MODULE ulmNetIO; + + (* abstraction for the exchange of Oberon base types which + are components of persistent data structures + *) + + IMPORT ConstStrings := ulmConstStrings, Disciplines := ulmDisciplines, Forwarders := ulmForwarders, Streams := ulmStreams, Strings := ulmStrings, + SYS := SYSTEM, Types := ulmTypes; + + TYPE + Byte* = Types.Byte; + + TYPE + ReadByteProc* = + PROCEDURE (s: Streams.Stream; VAR byte: Byte) : BOOLEAN; + ReadCharProc* = + PROCEDURE (s: Streams.Stream; VAR char: CHAR) : BOOLEAN; + ReadBooleanProc* = + PROCEDURE (s: Streams.Stream; VAR boolean: BOOLEAN) : BOOLEAN; + ReadShortIntProc* = + PROCEDURE (s: Streams.Stream; VAR shortint: SHORTINT) : BOOLEAN; + ReadIntegerProc* = + PROCEDURE (s: Streams.Stream; VAR integer: INTEGER) : BOOLEAN; + ReadLongIntProc* = + PROCEDURE (s: Streams.Stream; VAR longint: LONGINT) : BOOLEAN; + ReadRealProc* = + PROCEDURE (s: Streams.Stream; VAR real: REAL) : BOOLEAN; + ReadLongRealProc* = + PROCEDURE (s: Streams.Stream; VAR longreal: LONGREAL) : BOOLEAN; + ReadSetProc* = + PROCEDURE (s: Streams.Stream; VAR set: SET) : BOOLEAN; + ReadStringProc* = + PROCEDURE (s: Streams.Stream; VAR string: ARRAY OF CHAR) : BOOLEAN; + ReadConstStringProc* = + PROCEDURE (s: Streams.Stream; domain: ConstStrings.Domain; + VAR string: ConstStrings.String) : BOOLEAN; + + WriteByteProc* = + PROCEDURE (s: Streams.Stream; byte: Byte) : BOOLEAN; + WriteCharProc* = + PROCEDURE (s: Streams.Stream; char: CHAR) : BOOLEAN; + WriteBooleanProc* = + PROCEDURE (s: Streams.Stream; boolean: BOOLEAN) : BOOLEAN; + WriteShortIntProc* = + PROCEDURE (s: Streams.Stream; shortint: SHORTINT) : BOOLEAN; + WriteIntegerProc* = + PROCEDURE (s: Streams.Stream; integer: INTEGER) : BOOLEAN; + WriteLongIntProc* = + PROCEDURE (s: Streams.Stream; longint: LONGINT) : BOOLEAN; + WriteRealProc* = + PROCEDURE (s: Streams.Stream; real: REAL) : BOOLEAN; + WriteLongRealProc* = + PROCEDURE (s: Streams.Stream; longreal: LONGREAL) : BOOLEAN; + WriteSetProc* = + PROCEDURE (s: Streams.Stream; set: SET) : BOOLEAN; + WriteStringProc* = + PROCEDURE (s: Streams.Stream; string: ARRAY OF CHAR) : BOOLEAN; + WriteConstStringProc* = + PROCEDURE (s: Streams.Stream; + string: ConstStrings.String) : BOOLEAN; + + Interface* = POINTER TO InterfaceRec; + InterfaceRec* = + RECORD + readByte*: ReadByteProc; + readChar*: ReadCharProc; + readBoolean*: ReadBooleanProc; + readShortInt*: ReadShortIntProc; + readInteger*: ReadIntegerProc; + readLongInt*: ReadLongIntProc; + readReal*: ReadRealProc; + readLongReal*: ReadLongRealProc; + readSet*: ReadSetProc; + readString*: ReadStringProc; + readConstString*: ReadConstStringProc; + + writeByte*: WriteByteProc; + writeChar*: WriteCharProc; + writeBoolean*: WriteBooleanProc; + writeShortInt*: WriteShortIntProc; + writeInteger*: WriteIntegerProc; + writeLongInt*: WriteLongIntProc; + writeReal*: WriteRealProc; + writeLongReal*: WriteLongRealProc; + writeSet*: WriteSetProc; + writeString*: WriteStringProc; + writeConstString*: WriteConstStringProc; + END; + + (* private data structures *) + TYPE + Discipline = POINTER TO DisciplineRec; + DisciplineRec = + RECORD + (Disciplines.DisciplineRec) + if: Interface; + END; + VAR + discID: Disciplines.Identifier; + + PROCEDURE Swap (VAR a : ARRAY OF SYS.BYTE); + VAR + i,j : LONGINT; + tmp : SYS.BYTE; + BEGIN + i := 0; j := LEN (a) - 1; + WHILE i < j DO + tmp := a[i]; a[i] := a[j]; a[j] := tmp; + INC (i); DEC (j); + END; + END Swap; + + PROCEDURE BitSwap (VAR a : ARRAY OF SYS.BYTE); + VAR + i,old, bit : LONGINT; + new : LONGINT; + + BEGIN + i := 0; + WHILE i < LEN (a) DO + old := ORD (SYS.VAL (CHAR, a[i])); + new := 0; bit := 080H; + WHILE old # 0 DO + IF ODD (old) THEN + INC (new, bit); + END; + bit := ASH (bit, -1);; + old := ASH (old, -1); + END; + a[i] := SYS.VAL (SYS.BYTE, new); + INC (i); + END; + END BitSwap; + + PROCEDURE ^ Forward(from, to: Forwarders.Object); + + PROCEDURE AttachInterface*(s: Streams.Stream; if: Interface); + VAR + disc: Discipline; + BEGIN + IF if # NIL THEN + NEW(disc); disc.id := discID; disc.if := if; + Disciplines.Add(s, disc); + ELSE + Disciplines.Remove(s, discID); + END; + Forwarders.Update(s, Forward); + END AttachInterface; + + PROCEDURE GetInterface(s: Streams.Stream; VAR if: Interface); + VAR + disc: Discipline; + BEGIN + IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN + if := disc.if; + ELSE + if := NIL; + END; + END GetInterface; + + PROCEDURE CopyInterface*(from, to: Streams.Stream); + VAR + if: Interface; + BEGIN + GetInterface(from, if); + AttachInterface(to, if); + END CopyInterface; + + PROCEDURE Forward(from, to: Forwarders.Object); + BEGIN + (* this check is necessary because of Forwarders.Update *) + IF ~(from IS Streams.Stream) OR ~(to IS Streams.Stream) THEN + RETURN + END; + + WITH from: Streams.Stream DO WITH to: Streams.Stream DO + (* be careful here, from & to must be reversed *) + CopyInterface(to, from); + END; END; + END Forward; + + PROCEDURE ReadByte*(s: Streams.Stream; VAR byte: Byte) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN + RETURN disc.if.readByte(s, byte) + ELSE + RETURN Streams.ReadByte(s, byte) + END; + END ReadByte; + + PROCEDURE ReadChar*(s: Streams.Stream; VAR char: CHAR) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN + RETURN disc.if.readChar(s, char) + ELSE + RETURN Streams.ReadByte(s, char) + END; + END ReadChar; + + PROCEDURE ReadBoolean*(s: Streams.Stream; VAR boolean: BOOLEAN) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN + RETURN disc.if.readBoolean(s, boolean) + ELSE + RETURN Streams.Read(s, boolean) + END; + END ReadBoolean; + + PROCEDURE ReadShortInt*(s: Streams.Stream; VAR shortint: SHORTINT) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN + RETURN disc.if.readShortInt(s, shortint) + ELSE + RETURN Streams.ReadByte(s, shortint) + END; + END ReadShortInt; + + PROCEDURE ReadInteger*(s: Streams.Stream; VAR integer: INTEGER) : BOOLEAN; + VAR + disc: Discipline; + ret : BOOLEAN; + BEGIN + IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN + RETURN disc.if.readInteger(s, integer) + ELSE + ret := Streams.Read(s, integer); + IF Types.byteorder = Types.littleEndian THEN + Swap (integer); + END; + RETURN ret; + END; + END ReadInteger; + + PROCEDURE ReadLongInt*(s: Streams.Stream; VAR longint: LONGINT) : BOOLEAN; + VAR + disc: Discipline; + ret : BOOLEAN; + BEGIN + IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN + RETURN disc.if.readLongInt(s, longint) + ELSE + ret := Streams.Read(s, longint); + IF Types.byteorder = Types.littleEndian THEN + Swap (longint); + END; + RETURN ret; + END; + END ReadLongInt; + + PROCEDURE ReadReal*(s: Streams.Stream; VAR real: REAL) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN + RETURN disc.if.readReal(s, real) + ELSE + RETURN Streams.Read(s, real) + END; + END ReadReal; + + PROCEDURE ReadLongReal*(s: Streams.Stream; VAR longreal: LONGREAL) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN + RETURN disc.if.readLongReal(s, longreal) + ELSE + RETURN Streams.Read(s, longreal) + END; + END ReadLongReal; + + PROCEDURE ReadSet*(s: Streams.Stream; VAR set: SET) : BOOLEAN; + VAR + disc: Discipline; + ret : BOOLEAN; + BEGIN + IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN + RETURN disc.if.readSet(s, set) + ELSE + ret := Streams.Read(s, set); + IF Types.byteorder = Types.littleEndian THEN + BitSwap (set); + END; + RETURN ret; + END; + END ReadSet; + + PROCEDURE ReadString*(s: Streams.Stream; VAR string: ARRAY OF CHAR) : BOOLEAN; + VAR + disc: Discipline; + ch: CHAR; index: LONGINT; + BEGIN + IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN + RETURN disc.if.readString(s, string) + ELSE + index := 0; + WHILE Streams.ReadByte(s, ch) & (ch # 0X) DO + IF index + 1 < LEN(string) THEN + string[index] := ch; INC(index); + END; + END; + string[index] := 0X; + RETURN ~s.error + END; + END ReadString; + + PROCEDURE ReadConstStringD*(s: Streams.Stream; + domain: ConstStrings.Domain; + VAR string: ConstStrings.String) : BOOLEAN; + CONST + bufsize = 512; + VAR + length: LONGINT; + buf: Streams.Stream; + ch: CHAR; + disc: Discipline; + stringbuf: ARRAY bufsize OF CHAR; + BEGIN + IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN + RETURN disc.if.readConstString(s, domain, string) + ELSE + IF ReadLongInt(s, length) THEN + IF length >= bufsize THEN + ConstStrings.Init(buf); + IF ~Streams.Copy(s, buf, length) THEN + RETURN FALSE + END; + ConstStrings.CloseD(buf, domain, string); + RETURN length = s.count; + ELSE + IF ~Streams.ReadPart(s, stringbuf, 0, length) THEN + RETURN FALSE + END; + stringbuf[length] := 0X; + ConstStrings.CreateD(string, domain, stringbuf); + RETURN TRUE + END; + ELSE + RETURN FALSE + END; + END; + END ReadConstStringD; + + PROCEDURE ReadConstString*(s: Streams.Stream; + VAR string: ConstStrings.String) : BOOLEAN; + BEGIN + RETURN ReadConstStringD(s, ConstStrings.std, string) + END ReadConstString; + + PROCEDURE WriteByte*(s: Streams.Stream; byte: Byte) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN + RETURN disc.if.writeByte(s, byte) + ELSE + RETURN Streams.WriteByte(s, byte) + END; + END WriteByte; + + PROCEDURE WriteChar*(s: Streams.Stream; char: CHAR) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN + RETURN disc.if.writeChar(s, char) + ELSE + RETURN Streams.WriteByte(s, char) + END; + END WriteChar; + + PROCEDURE WriteBoolean*(s: Streams.Stream; boolean: BOOLEAN) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN + RETURN disc.if.writeBoolean(s, boolean) + ELSE + RETURN Streams.Write(s, boolean) + END; + END WriteBoolean; + + PROCEDURE WriteShortInt*(s: Streams.Stream; shortint: SHORTINT) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN + RETURN disc.if.writeShortInt(s, shortint) + ELSE + RETURN Streams.WriteByte(s, shortint) + END; + END WriteShortInt; + + PROCEDURE WriteInteger*(s: Streams.Stream; integer: INTEGER) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN + RETURN disc.if.writeInteger(s, integer) + ELSE + IF Types.byteorder = Types.littleEndian THEN + Swap (integer); + END; + RETURN Streams.Write(s, integer); + END; + END WriteInteger; + + PROCEDURE WriteLongInt*(s: Streams.Stream; longint: LONGINT) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN + RETURN disc.if.writeLongInt(s, longint) + ELSE + IF Types.byteorder = Types.littleEndian THEN + Swap (longint); + END; + RETURN Streams.Write(s, longint); + END; + END WriteLongInt; + + PROCEDURE WriteReal*(s: Streams.Stream; real: REAL) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN + RETURN disc.if.writeReal(s, real) + ELSE + RETURN Streams.Write(s, real) + END; + END WriteReal; + + PROCEDURE WriteLongReal*(s: Streams.Stream; longreal: LONGREAL) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN + RETURN disc.if.writeLongReal(s, longreal) + ELSE + RETURN Streams.Write(s, longreal) + END; + END WriteLongReal; + + PROCEDURE WriteSet*(s: Streams.Stream; set: SET) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN + RETURN disc.if.writeSet(s, set) + ELSE + IF Types.byteorder = Types.littleEndian THEN + BitSwap (set); + END; + RETURN Streams.Write(s, set) + END; + END WriteSet; + + PROCEDURE WriteString*(s: Streams.Stream; string: ARRAY OF CHAR) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN + RETURN disc.if.writeString(s, string) + ELSE + RETURN Streams.WritePart(s, string, 0, Strings.Len(string)) & + Streams.WriteByte(s, 0X) + END; + END WriteString; + + PROCEDURE WriteConstString*(s: Streams.Stream; + string: ConstStrings.String) : BOOLEAN; + VAR + ch: CHAR; + buf: Streams.Stream; + disc: Discipline; + BEGIN + IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN + RETURN disc.if.writeConstString(s, string) + ELSE + IF WriteLongInt(s, string.len) THEN + ConstStrings.Open(buf, string); + RETURN Streams.Copy(buf, s, string.len) + ELSE + RETURN FALSE + END; + END; + END WriteConstString; + +BEGIN + discID := Disciplines.Unique(); + Forwarders.Register("Streams.Stream", Forward); +END ulmNetIO. diff --git a/src/lib/ulm/ulmPersistentDisciplines.Mod b/src/lib/ulm/ulmPersistentDisciplines.Mod new file mode 100644 index 00000000..8f37d4ce --- /dev/null +++ b/src/lib/ulm/ulmPersistentDisciplines.Mod @@ -0,0 +1,391 @@ +(* Ulm's Oberon Library + Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. + + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: PersistentD.om,v 1.4 1998/02/22 10:25:22 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: PersistentD.om,v $ + Revision 1.4 1998/02/22 10:25:22 borchert + bug fix in GetObject: Disciplines.Add was missing if the main object + is just an extension of Disciplines.Object and not of + PersistentDisciplines.Object + + Revision 1.3 1996/07/24 07:41:28 borchert + bug fix: count component was not initialized (with the + exception of CreateObject) -- detected by Martin Hasch + + Revision 1.2 1995/03/17 16:13:33 borchert + - persistent disciplines may now be attached to non-persistent objects + - some fixes due to changes of PersistentObjects + + Revision 1.1 1994/02/22 20:09:12 borchert + Initial revision + + ---------------------------------------------------------------------------- +*) + +MODULE ulmPersistentDisciplines; + + IMPORT Disciplines := ulmDisciplines, Forwarders := ulmForwarders, NetIO := ulmNetIO, Objects := ulmObjects, PersistentObjects := ulmPersistentObjects, + Services := ulmServices, Streams := ulmStreams, SYS := SYSTEM; + + CONST + objectName = "PersistentDisciplines.Object"; + disciplineName = "PersistentDisciplines.Discipline"; + + TYPE + Identifier* = LONGINT; + + Discipline* = POINTER TO DisciplineRec; + DisciplineRec* = + RECORD + (PersistentObjects.ObjectRec) + id*: Identifier; (* should be unique for all types of disciplines *) + END; + + DisciplineList = POINTER TO DisciplineListRec; + DisciplineListRec = + RECORD + discipline: Discipline; + id: Identifier; (* copied from discipline.id *) + next: DisciplineList; + END; + + Interface = POINTER TO InterfaceRec; + Object = POINTER TO ObjectRec; + ObjectRec* = + RECORD + (PersistentObjects.ObjectRec) + (* private part *) + count: LONGINT; (* number of attached disciplines *) + list: DisciplineList; (* set of disciplines *) + if: Interface; (* overrides builtins if # NIL *) + forwardTo: Object; + usedBy: Object; (* used as target of UseInterfaceOf *) + (* very restrictive way of avoiding reference cycles: + forwardTo references must be built from inner to + outer objects and not vice versa + *) + END; + + TYPE + VolatileDiscipline = POINTER TO VolatileDisciplineRec; + VolatileDisciplineRec = + RECORD + (Disciplines.DisciplineRec) + object: Object; + END; + VAR + volDiscID: Disciplines.Identifier; + + TYPE + AddProc* = PROCEDURE (object: Disciplines.Object; discipline: Discipline); + RemoveProc* = PROCEDURE (object: Disciplines.Object; id: Identifier); + SeekProc* = PROCEDURE (object: Disciplines.Object; id: Identifier; + VAR discipline: Discipline) : BOOLEAN; + InterfaceRec* = + RECORD + (Objects.ObjectRec) + add*: AddProc; + remove*: RemoveProc; + seek*: SeekProc; + END; + + VAR + unique: Identifier; + objIf: PersistentObjects.Interface; + objDatatype, discDatatype: Services.Type; + + CONST + hashtabsize = 32; + TYPE + Sample = POINTER TO SampleRec; + SampleRec = + RECORD + id: Identifier; + sample: Discipline; + next: Sample; + END; + BucketTable = ARRAY hashtabsize OF Sample; + VAR + samples: BucketTable; + + PROCEDURE CreateObject*(VAR object: Object); + (* creates a new object; this procedures should be called instead of + NEW for objects of type `Object' + *) + BEGIN + NEW(object); + object.count := 0; (* up to now, there are no attached disciplines *) + object.list := NIL; + object.if := NIL; + PersistentObjects.Init(object, objDatatype); + END CreateObject; + + PROCEDURE GetObject(obj: Disciplines.Object; VAR object: Object); + VAR + disc: VolatileDiscipline; + BEGIN + IF obj IS Object THEN + object := obj(Object); + (* initialize private components now if not done already; + we assume here that pointers which have not been + initialized yet are defined to be NIL + (because of the garbage collection); + a similar assumption does not necessarily hold for + other types (e.g. integers) + *) + IF object.list = NIL THEN + object.count := 0; + END; + ELSIF Disciplines.Seek(obj, volDiscID, SYS.VAL(Disciplines.Discipline, disc)) THEN + object := disc.object; + ELSE + CreateObject(object); + NEW(disc); disc.id := volDiscID; disc.object := object; + Disciplines.Add(obj, disc); + END; + END GetObject; + + (* === normal stuff for disciplines ===================================== *) + + PROCEDURE Unique*(sample: Discipline) : Identifier; + (* returns a unique identifier; + this procedure should be called during initialization by + all modules defining a discipline type; + a sample of the associated discipline has to be provided + *) + VAR + hashval: Identifier; + entry: Sample; + BEGIN + INC(unique); + NEW(entry); entry.id := unique; entry.sample := sample; + hashval := unique MOD hashtabsize; + entry.next := samples[hashval]; samples[hashval] := entry; + RETURN unique + END Unique; + + PROCEDURE GetSample*(id: Identifier) : Discipline; + (* return sample for the given identifier; + NIL will be returned if id has not yet been returned by Unique + *) + VAR + hashval: Identifier; + ptr: Sample; + BEGIN + hashval := id MOD hashtabsize; + ptr := samples[hashval]; + WHILE (ptr # NIL) & (ptr.id # id) DO + ptr := ptr.next; + END; + IF ptr # NIL THEN + RETURN ptr.sample + ELSE + RETURN NIL + END; + END GetSample; + + PROCEDURE AttachInterface*(object: Disciplines.Object; if: Interface); + (* override the builtin implementations of Add, Remove and + Seek for `object' with the implementations given by `if' + *) + VAR + po: Object; + BEGIN + GetObject(object, po); + IF (po.list = NIL) & (po.forwardTo = NIL) THEN + po.if := if; + END; + END AttachInterface; + + PROCEDURE UseInterfaceOf*(object, host: Disciplines.Object); + (* forward Add, Remove and Seek operations from object to host *) + VAR + po, phost: Object; + BEGIN + GetObject(object, po); GetObject(host, phost); + IF (po.list = NIL) & (po.forwardTo = NIL) & + (po.usedBy = NIL) THEN + po.forwardTo := phost; + phost.usedBy := po; (* avoid reference cycles *) + END; + END UseInterfaceOf; + + PROCEDURE Forward(from, to: Forwarders.Object); + BEGIN + UseInterfaceOf(from, to); + END Forward; + + PROCEDURE Remove*(object: Disciplines.Object; id: Identifier); + (* remove the discipline with the given id from object, if it exists *) + VAR + po: Object; + prev, dl: DisciplineList; + BEGIN + GetObject(object, po); + WHILE po.forwardTo # NIL DO + po := po.forwardTo; + END; + IF po.if = NIL THEN + prev := NIL; + dl := po.list; + WHILE (dl # NIL) & (dl.id # id) DO + prev := dl; dl := dl.next; + END; + IF dl # NIL THEN + IF prev = NIL THEN + po.list := dl.next; + ELSE + prev.next := dl.next; + END; + DEC(po.count); (* discipline removed *) + END; + ELSE + po.if.remove(po, id); + END; + END Remove; + + PROCEDURE Add*(object: Disciplines.Object; discipline: Discipline); + (* adds a new discipline to the given object; + if already a discipline with the same identifier exist + it is deleted first + *) + VAR + po: Object; + dl: DisciplineList; + BEGIN + GetObject(object, po); + WHILE po.forwardTo # NIL DO + po := po.forwardTo; + END; + IF po.if = NIL THEN + dl := po.list; + WHILE (dl # NIL) & (dl.id # discipline.id) DO + dl := dl.next; + END; + IF dl = NIL THEN + NEW(dl); + dl.id := discipline.id; + dl.next := po.list; + po.list := dl; + INC(po.count); (* discipline added *) + END; + dl.discipline := discipline; + ELSE + po.if.add(po, discipline); + END; + END Add; + + PROCEDURE Seek*(object: Disciplines.Object; id: Identifier; + VAR discipline: Discipline) : BOOLEAN; + (* returns TRUE if a discipline with the given id is found *) + VAR + po: Object; + dl: DisciplineList; + BEGIN + GetObject(object, po); + WHILE po.forwardTo # NIL DO + po := po.forwardTo; + END; + IF po.if = NIL THEN + dl := po.list; + WHILE (dl # NIL) & (dl.id # id) DO + dl := dl.next; + END; + IF dl # NIL THEN + discipline := dl.discipline; + ELSE + discipline := NIL; + END; + RETURN discipline # NIL + ELSE + RETURN po.if.seek(po, id, discipline) + END; + END Seek; + + (* === interface procedures for PersistentObjects for Object === *) + + PROCEDURE ReadObjectData(stream: Streams.Stream; + object: PersistentObjects.Object) : BOOLEAN; + (* read data and attached disciplines of given object from stream *) + VAR + discipline: Discipline; + count: LONGINT; + BEGIN + (* get number of attached disciplines *) + IF ~NetIO.ReadLongInt(stream, count) THEN + RETURN FALSE; + END; + (* read all disciplines from `stream' and attach them to `object' *) + WHILE count > 0 DO + IF ~PersistentObjects.Read(stream, SYS.VAL(PersistentObjects.Object, discipline)) THEN + RETURN FALSE; + END; + Add(object(Object), discipline); + DEC(count); + END; + RETURN TRUE; + END ReadObjectData; + + PROCEDURE WriteObjectData(stream: Streams.Stream; + object: PersistentObjects.Object) : BOOLEAN; + (* write data and attached disciplines of given object to stream *) + VAR + dl: DisciplineList; + BEGIN + WITH object: Object DO + (* write number of attached disciplines to `stream' *) + IF ~NetIO.WriteLongInt(stream, object.count) THEN + RETURN FALSE; + END; + (* write all attached disciplines to the stream *) + dl := object.list; + WHILE dl # NIL DO + IF ~PersistentObjects.Write(stream, dl.discipline) THEN + RETURN FALSE; + END; + dl := dl.next; + END; + END; + RETURN TRUE; + END WriteObjectData; + + PROCEDURE InternalCreate(VAR obj: PersistentObjects.Object); + VAR + myObject: Object; + BEGIN + CreateObject(myObject); + obj := myObject; + END InternalCreate; + +BEGIN + unique := 0; + + NEW(objIf); + objIf.read := ReadObjectData; + objIf.write := WriteObjectData; + objIf.create := InternalCreate; + objIf.createAndRead := NIL; + PersistentObjects.RegisterType(objDatatype, objectName, "", objIf); + PersistentObjects.RegisterType(discDatatype, disciplineName, "", NIL); + + volDiscID := Disciplines.Unique(); + + Forwarders.Register("", Forward); +END ulmPersistentDisciplines. diff --git a/src/lib/ulm/ulmPersistentObjects.Mod b/src/lib/ulm/ulmPersistentObjects.Mod new file mode 100644 index 00000000..5e23487a --- /dev/null +++ b/src/lib/ulm/ulmPersistentObjects.Mod @@ -0,0 +1,1078 @@ +(* 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: PersistentO.om,v 1.8 2004/03/30 13:14:16 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: PersistentO.om,v $ + Revision 1.8 2004/03/30 13:14:16 borchert + introduced more elaborate error events for cannotReadData + + Revision 1.7 1998/04/09 16:55:48 borchert + bug fix: ReadTypeInfo failed on hierarchical mode if none of the + types were known by returning TRUE with type set to NIL + + Revision 1.6 1998/03/24 22:42:28 borchert + improvements: + - it is now acceptable that read and write if procedures are given + but neither create nor createAndRead -- this is fine for + abstractions that maintain some components + - Read operates now immediately on the given object to support + LinearizedStructures -- otherwise it would be nearly impossible + to reconstruct self-referential data structures; + note that this is *not supported* by GuardedRead + + Revision 1.5 1995/04/04 12:36:39 borchert + major redesign of PersistentObjects: + - new type encoding schemes + - size if proc removed + - support for NIL and guards added + + Revision 1.4 1994/07/18 14:19:13 borchert + bug fix: SizeOf used uninitialized variable (name) and added the + length of all type names of the hierarchy to the sum + + Revision 1.3 1994/07/05 08:47:26 borchert + bug fix: modifications due to last bug fix didn't work correctly in + in all cases + code cleaned up at several locations + + Revision 1.2 1994/03/25 15:54:09 borchert + bug fix: the complete type hierarchy together with all abstract types + was written -- this caused a NIL-procedure to be called in + case of projections. Now, we write shorter type hierarchies and + GetCreate checks the create-procedure against NIL + + Revision 1.1 1994/02/22 20:09:21 borchert + Initial revision + + ---------------------------------------------------------------------------- + DB 7/93 + ---------------------------------------------------------------------------- +*) + +MODULE ulmPersistentObjects; + + (* handling of persistent objects *) + + IMPORT ASCII := ulmASCII, ConstStrings := ulmConstStrings, Disciplines := ulmDisciplines, Errors := ulmErrors, Events := ulmEvents, Forwarders := ulmForwarders, + IndirectDisciplines := ulmIndirectDisciplines, Loader := ulmLoader, NetIO := ulmNetIO, Objects := ulmObjects, Priorities := ulmPriorities, + RelatedEvents := ulmRelatedEvents, Services := ulmServices, StreamDisciplines := ulmStreamDisciplines, Streams := ulmStreams, Strings := ulmStrings, Texts := ulmTexts, SYS := SYSTEM; + + CONST + maxNameLen = 128; (* max length of data type names *) + TYPE + TypeName = ARRAY maxNameLen OF CHAR; (* for temporary use only *) + ShortTypeName = ARRAY 32 OF CHAR; (* for error messages only *) + + CONST + cannotReadData* = 0; + cannotWriteData* = 1; + cannotReadType* = 2; + cannotWriteType* = 3; + invalidType* = 4; + unknownType* = 5; + otherTypeHier* = 6; + eofReached* = 7; + cannotSkip* = 8; + typeGuardFailure* = 9; (* GuardedRead failed to type guard failure *) + errorcodes* = 10; (* number of error codes *) + + (* how are types specified: fullTypeName, typeCode, incrTypeCode + with or without size info: withSize, withoutSize + with or without type hier: withHier, withoutHier + + combinations are given as additions, + e.g. typeCode + withSize + withHier + *) + fullTypeName* = 1; typeCode* = 2; incrTypeCode* = 3; + withSize* = 4; withoutSize* = 0; + withHier* = 8; withoutHier* = 0; + + defaultMode = fullTypeName + withSize + withHier; + (* provide all informations on default *) + + (* forms: + type spec: codeF | incrF | nameF | incrhierF | hierF + size spec: sizeF | noSizeF + add specs, eg. codeF + sizeF + *) + codeF = 1; (* just a type code *) + incrF = 2; (* type name + code given *) + nameF = 3; (* type name given *) + incrhierF = 4; (* type hierarchy with codes *) + hierF = 5; (* type hierarchy without codes *) + sizeF = 8; (* size information given *) + noSizeF = 0; (* no size information given *) + maskF = 8; + maxF = 13; (* maximal valid form code *) + + TYPE + Mode* = SHORTINT; + Form = SHORTINT; + + Object* = POINTER TO ObjectRec; + Type = POINTER TO TypeRec; + + ReadProc* = PROCEDURE (s: Streams.Stream; o: Object) : BOOLEAN; + WriteProc* = PROCEDURE (s: Streams.Stream; o: Object) : BOOLEAN; + CreateProc* = PROCEDURE (VAR o: Object); + CreateAndReadProc* = PROCEDURE (s: Streams.Stream; + create: BOOLEAN; + VAR o: Object) : BOOLEAN; + + Interface* = POINTER TO InterfaceRec; + InterfaceRec* = + RECORD + (Objects.ObjectRec) + create*: CreateProc; (* create object *) + read*: ReadProc; (* read data from stream *) + write*: WriteProc; (* write data to stream *) + createAndRead*: CreateAndReadProc; (* replaces create & read *) + END; + + ObjectRec* = + RECORD + (Services.ObjectRec) + (* private data *) + type: Type; + projected: BOOLEAN; (* set after Read *) + END; + + CONST + ttlen = 16; + TYPE + TypeEntry = POINTER TO TypeEntryRec; + TypeEntryRec = + RECORD + code: LONGINT; + type: Type; + next: TypeEntry; + END; + TypeTable = ARRAY ttlen OF TypeEntry; + StreamDiscipline = POINTER TO StreamDisciplineRec; + StreamDisciplineRec = + RECORD + (Disciplines.DisciplineRec) + mode: Mode; (* type encoding mode for the stream *) + rtypes, wtypes: TypeTable; + END; + + InterfaceList = POINTER TO InterfaceListRec; + InterfaceListRec = + RECORD + if: Interface; + next: InterfaceList; (* points to next extension *) + END; + TypeRec = + RECORD + (Services.TypeRec) + baseType: Type; (* the next non-abstract base type *) + if: Interface; (* may be = NIL for abstract types *) + ifs: InterfaceList; (* list of interfaces in reverse order *) + code: LONGINT; (* unique number *) + END; + + (* this list is used for storing the base type list of an object during + reading this object + *) + BaseTypeList = POINTER TO BaseTypeRec; + BaseTypeRec = + RECORD + name: ConstStrings.String; (* name of the base type *) + next: BaseTypeList; + END; + + (* each error causes an event; the error number is stored in + event.errorcode; the associated text can be taken from event.message + *) + ErrorCode = SHORTINT; + Event = POINTER TO EventRec; + EventRec* = + RECORD + (Events.EventRec) + stream*: Streams.Stream; + errorcode*: ErrorCode; + END; + UnknownTypeEvent = POINTER TO UnknownTypeEventRec; + UnknownTypeEventRec = + RECORD + (EventRec) + typeName: ARRAY 80 OF CHAR; + END; + DecodeFailureEvent = POINTER TO DecodeFailureEventRec; + DecodeFailureEventRec = + RECORD + (EventRec) + objectType: Services.Type; + END; + TypeGuardFailureEvent = POINTER TO TypeGuardFailureEventRec; + TypeGuardFailureEventRec = + RECORD + (EventRec) + found, expected: Services.Type; + END; + + VAR + id: Disciplines.Identifier; + nextTypeCode: LONGINT; (* for the generation of unique numbers *) + potype: Services.Type; + + errormsg*: ARRAY errorcodes OF Events.Message; + (* readable text for error codes *) + error*: Events.EventType; + (* raised on failed stream operations; ignored by default *) + + (* ===== for internal use only ========================================== *) + + PROCEDURE Error(stream: Streams.Stream; code: ErrorCode); + (* raise an error event with the error code `code' *) + VAR + event: Event; + BEGIN + stream.count := 0; + NEW(event); + event.type := error; + event.message := errormsg[code]; + event.stream := stream; + event.errorcode := code; + RelatedEvents.Raise(stream, event); + END Error; + + PROCEDURE UnknownType(stream: Streams.Stream; typeName: ARRAY OF CHAR); + VAR + event: UnknownTypeEvent; + BEGIN + stream.count := 0; + NEW(event); + event.type := error; + event.message := errormsg[unknownType]; + event.stream := stream; + event.errorcode := unknownType; + COPY(typeName, event.typeName); + RelatedEvents.Raise(stream, event); + END UnknownType; + + PROCEDURE TypeGuardFailure(stream: Streams.Stream; + found, expected: Services.Type); + VAR + event: TypeGuardFailureEvent; + BEGIN + stream.count := 0; + NEW(event); + event.type := error; + event.message := errormsg[typeGuardFailure]; + event.stream := stream; + event.errorcode := typeGuardFailure; + event.found := found; + event.expected := expected; + RelatedEvents.Raise(stream, event); + END TypeGuardFailure; + + PROCEDURE WriteEvent(s: Streams.Stream; event: Events.Event); + + VAR + typename: ARRAY 128 OF CHAR; + + PROCEDURE WriteString(s: Streams.Stream; + string: ARRAY OF CHAR) : BOOLEAN; + BEGIN + RETURN Streams.WritePart(s, string, 0, Strings.Len(string)) + END WriteString; + + PROCEDURE WriteLn(s: Streams.Stream) : BOOLEAN; + VAR + lineterm: StreamDisciplines.LineTerminator; + width: INTEGER; + BEGIN + StreamDisciplines.GetLineTerm(s, lineterm); + IF ~WriteString(s, lineterm) THEN RETURN FALSE END; + StreamDisciplines.GetIndentationWidth(s, width); + WHILE width > 0 DO + IF ~Streams.WriteByte(s, " ") THEN RETURN FALSE END; + DEC(width); + END; + RETURN TRUE + END WriteLn; + + PROCEDURE WriteType(s: Streams.Stream; + type: Services.Type) : BOOLEAN; + VAR + name: TypeName; + BEGIN + Services.GetTypeName(type, name); + RETURN Streams.WriteByte(s, ASCII.quote) & + WriteString(s, name) & + Streams.WriteByte(s, ASCII.quote) + END WriteType; + + BEGIN + IF event IS UnknownTypeEvent THEN + WITH event: UnknownTypeEvent DO + IF WriteString(s, event.message) & + WriteString(s, ": ") & + Streams.WriteByte(s, ASCII.quote) & + WriteString(s, event.typeName) & + Streams.WriteByte(s, ASCII.quote) THEN + END; + END; + ELSIF event IS TypeGuardFailureEvent THEN + WITH event: TypeGuardFailureEvent DO + IF WriteString(s, event.message) & + WriteString(s, ":") & + WriteLn(s) & + WriteString(s, "expected extension of ") & + WriteType(s, event.expected) & + WriteString(s, " but got ") & + WriteType(s, event.found) THEN + END; + END; + ELSIF event IS DecodeFailureEvent THEN + WITH event: DecodeFailureEvent DO + Services.GetTypeName(event.objectType, typename); + IF WriteString(s, event.message) & + WriteString(s, ":") & + WriteLn(s) & + WriteString(s, "unable to parse object of type ") & + Streams.WriteByte(s, ASCII.quote) & + WriteString(s, typename) & + Streams.WriteByte(s, ASCII.quote) THEN + END; + END; + ELSE + IF WriteString(s, event.message) THEN END; + END; + END WriteEvent; + + PROCEDURE InitErrorHandling; + BEGIN + errormsg[cannotReadData] := "cannot read data part of persistent object"; + errormsg[cannotWriteData] := "cannot write data part of persistent object"; + errormsg[cannotReadType] := "cannot read type of persistent object"; + errormsg[cannotWriteType] := "cannot write type of persistent object"; + errormsg[invalidType] := "invalid type form read"; + errormsg[unknownType] := "unknown type information found"; + errormsg[otherTypeHier] := "different & nonconforming type hierarchy found"; + errormsg[eofReached] := "unexpected EOF encountered during reading"; + errormsg[cannotSkip] := "unable to skip unknown data parts"; + errormsg[typeGuardFailure] := "read object is of unexpected type"; + + Events.Define(error); + Events.SetPriority(error, Priorities.liberrors); + Events.Ignore(error); + Errors.AssignWriteProcedure(error, WriteEvent); + END InitErrorHandling; + + (* ==== marshalling procedures ======================================== *) + + (* encoding scheme: + + Object = Form Type Size ObjectInfo . + Form = SHORTINT; + Type = Code (* codeF *) | + Code TypeName (* incrF *) | + TypeName (* nameF *) | + Code TypeName { Code TypeName } 0 (* incrhierF *) | + TypeName { TypeName } 0X (* hierF *) . + Size = (* noSizeF *) | + Size (* sizeF *) . (* size of object info in bytes *) + ObjectInfo = { Byte } . + *) + + PROCEDURE DecodeForm(form: Form; + VAR nameGiven, codeGiven, hier, size: BOOLEAN); + VAR + typeform: SHORTINT; + sizeform: SHORTINT; + BEGIN + typeform := form MOD maskF; sizeform := form DIV maskF; + nameGiven := typeform IN {incrF, nameF, hierF, incrhierF}; + codeGiven := typeform IN {codeF, incrF, incrhierF}; + hier := (typeform = incrhierF) OR (typeform = hierF); + size := (sizeform = sizeF); + END DecodeForm; + + 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; + + PROCEDURE Failure(s: Streams.Stream; code: ErrorCode); + BEGIN + IF s.eof THEN + Error(s, eofReached); + ELSE + Error(s, code); + END; + END Failure; + + PROCEDURE DecodeFailure(s: Streams.Stream; type: Services.Type); + VAR + event: DecodeFailureEvent; + BEGIN + IF s.eof THEN + Error(s, eofReached); + ELSE + NEW(event); + event.type := error; + event.message := errormsg[cannotReadData]; + event.stream := s; + event.errorcode := cannotReadData; + event.objectType := type; + RelatedEvents.Raise(s, event); + END; + END DecodeFailure; + + PROCEDURE GetStreamDisc(s: Streams.Stream; VAR disc: StreamDiscipline); + BEGIN + IF ~IndirectDisciplines.Seek(s, id, SYS.VAL(IndirectDisciplines.Discipline, disc)) THEN + NEW(disc); disc.id := id; disc.mode := defaultMode; + IndirectDisciplines.Add(s, disc); + END; + END GetStreamDisc; + + PROCEDURE ReadTypeInfo(s: Streams.Stream; VAR type: Type; + VAR projection: BOOLEAN; + VAR size: Streams.Count) : BOOLEAN; + VAR + form: Form; + btype: Type; + nameGiven, codeGiven, hier, sizeGiven: BOOLEAN; + disc: StreamDiscipline; + sentinelFound, unknownTypeFound: BOOLEAN; + lastType: Type; + + PROCEDURE ReadType(s: Streams.Stream; VAR type: Type; + VAR sentinelFound, unknownTypeFound: BOOLEAN) : BOOLEAN; + VAR + code: LONGINT; + entry: TypeEntry; + typeName: TypeName; + btype: Type; + + PROCEDURE SeekType(typeName: ARRAY OF CHAR; + VAR type: Type) : BOOLEAN; + VAR + t: Services.Type; + module: TypeName; + BEGIN + Services.SeekType(typeName, t); + IF t = NIL THEN + GetModule(typeName, module); + IF Loader.Load(module, s) THEN + (* maybe the type is now registered *) + Services.SeekType(typeName, t); + END; + END; + IF (t # NIL) & (t IS Type) THEN + type := t(Type); RETURN TRUE + END; + RETURN FALSE + END SeekType; + + BEGIN (* ReadType *) + sentinelFound := FALSE; unknownTypeFound := FALSE; + type := NIL; + IF codeGiven THEN + IF ~NetIO.ReadLongInt(s, code) THEN + Failure(s, cannotReadType); RETURN FALSE + END; + IF code = 0 THEN sentinelFound := TRUE; RETURN FALSE END; + entry := disc.rtypes[code MOD ttlen]; + WHILE (entry # NIL) & (entry.code # code) DO + entry := entry.next; + END; + IF entry # NIL THEN + type := entry.type; + END; + IF (entry = NIL) & ~nameGiven THEN + Failure(s, unknownType); unknownTypeFound := TRUE; RETURN FALSE + END; + END; + IF nameGiven THEN + IF ~NetIO.ReadString(s, typeName) THEN + Failure(s, cannotReadType); RETURN FALSE + END; + IF typeName[0] = 0X THEN sentinelFound := TRUE; RETURN FALSE END; + IF (type = NIL) & ~SeekType(typeName, type) THEN + UnknownType(s, typeName); unknownTypeFound := TRUE; RETURN FALSE + END; + END; + IF codeGiven & (entry = NIL) THEN + NEW(entry); + entry.code := code; + entry.type := type; + entry.next := disc.rtypes[code MOD ttlen]; + disc.rtypes[code MOD ttlen] := entry; + END; + RETURN TRUE + END ReadType; + + BEGIN (* ReadTypeInfo *) + (* read & check form of type info *) + IF ~NetIO.ReadShortInt(s, form) THEN + Failure(s, cannotReadType); RETURN FALSE + END; + IF (form <= 0) OR (form > maxF) THEN + Failure(s, invalidType); RETURN FALSE + END; + DecodeForm(form, nameGiven, codeGiven, hier, sizeGiven); + IF codeGiven THEN + GetStreamDisc(s, disc); + END; + + (* read first type information *) + IF ~ReadType(s, type, sentinelFound, unknownTypeFound) & ~hier THEN + RETURN FALSE + END; + + (* read type hierarchy, if any *) + projection := FALSE; + IF hier THEN + IF sentinelFound THEN + Failure(s, invalidType); RETURN FALSE + END; + lastType := type; + LOOP (* until type hierarchy is read *) + IF ReadType(s, btype, sentinelFound, unknownTypeFound) THEN + IF (lastType # NIL) & (lastType.baseType # btype) THEN + Failure(s, otherTypeHier); RETURN FALSE + END; + IF type = NIL THEN + projection := TRUE; + type := btype; + END; + lastType := btype; + ELSIF sentinelFound THEN + EXIT + ELSIF unknownTypeFound THEN + IF lastType # NIL THEN + Failure(s, otherTypeHier); RETURN FALSE + END; + ELSE + RETURN FALSE + END; + END; + IF type = NIL THEN + (* error events already generated by ReadType *) + RETURN FALSE + END; + END; + + (* read size information, if any *) + IF sizeGiven THEN + IF ~NetIO.ReadLongInt(s, size) THEN + Failure(s, cannotReadType); RETURN FALSE + END; + IF size < 0 THEN + Failure(s, invalidType); RETURN FALSE + END; + ELSE + size := -1; + END; + RETURN TRUE + END ReadTypeInfo; + + PROCEDURE ReadData(s: Streams.Stream; VAR object: Object) : BOOLEAN; + (* use the interface list to read all data in the right order *) + VAR + ifList: InterfaceList; + BEGIN + ifList := object.type.ifs; + WHILE ifList # NIL DO + IF ~ifList.if.read(s, object) THEN + (* error handling is done by the calling procedure *) + RETURN FALSE + END; + ifList := ifList.next; + END; + RETURN (object.type.if.read = NIL) OR object.type.if.read(s, object) + END ReadData; + + PROCEDURE EncodeForm(s: Streams.Stream; type: Type; VAR form: Form); + VAR + mode: Mode; + disc: StreamDiscipline; + hier: BOOLEAN; + + PROCEDURE KnownType() : BOOLEAN; + VAR + p: TypeEntry; + BEGIN + p := disc.wtypes[type.code MOD ttlen]; + WHILE (p # NIL) & (p.type # type) DO + p := p.next; + END; + RETURN p # NIL + END KnownType; + + BEGIN + IF ~IndirectDisciplines.Seek(s, id, SYS.VAL(IndirectDisciplines.Discipline, disc)) THEN + mode := defaultMode; disc := NIL; + ELSE + mode := disc.mode; + END; + form := 0; + hier := mode DIV 8 MOD 2 > 0; + CASE mode MOD 4 OF + | fullTypeName: IF hier THEN form := hierF ELSE form := nameF END; + | typeCode: form := codeF; ASSERT(~hier); + | incrTypeCode: IF KnownType() THEN + form := codeF; + ELSIF hier THEN + form := incrhierF; + ELSE + form := incrF; + END; + END; + IF mode DIV 4 MOD 2 > 0 THEN + INC(form, sizeF); + ELSE + INC(form, noSizeF); + END; + END EncodeForm; + + PROCEDURE WriteTypeInfo(s: Streams.Stream; type: Type; + VAR giveSize: BOOLEAN) : BOOLEAN; + (* write type information without size *) + VAR + form: Form; + giveName, giveCode, hier: BOOLEAN; + mode: Mode; incr: BOOLEAN; + disc: StreamDiscipline; + btype: Type; + + PROCEDURE WriteType(s: Streams.Stream; type: Type) : BOOLEAN; + VAR + typeName: TypeName; + entry: TypeEntry; + BEGIN + IF giveCode THEN + IF ~NetIO.WriteLongInt(s, type.code) THEN + Error(s, cannotWriteType); RETURN FALSE + END; + END; + IF giveName THEN + Services.GetTypeName(type, typeName); + IF ~NetIO.WriteString(s, typeName) THEN + Error(s, cannotWriteType); RETURN FALSE + END; + END; + IF incr THEN + NEW(entry); entry.type := type; entry.code := type.code; + entry.next := disc.wtypes[type.code MOD ttlen]; + disc.wtypes[type.code MOD ttlen] := entry; + END; + RETURN TRUE + END WriteType; + + BEGIN (* WriteTypeInfo *) + EncodeForm(s, type, form); + IF ~NetIO.WriteShortInt(s, form) THEN + Error(s, cannotWriteType); + END; + DecodeForm(form, giveName, giveCode, hier, giveSize); + IF ~IndirectDisciplines.Seek(s, id, SYS.VAL(IndirectDisciplines.Discipline, disc)) THEN + mode := defaultMode; + END; + incr := giveName & giveCode; + + IF ~WriteType(s, type) THEN RETURN FALSE END; + + IF hier THEN + btype := type.baseType; + WHILE btype # NIL DO + IF ~WriteType(s, btype) THEN RETURN FALSE END; + btype := btype.baseType; + END; + (* write sentinel *) + IF giveCode THEN + IF ~NetIO.WriteLongInt(s, 0) THEN + Error(s, cannotWriteType); + RETURN FALSE + END; + ELSE + IF ~NetIO.WriteString(s, "") THEN + Error(s, cannotWriteType); + RETURN FALSE + END; + END; + END; + + RETURN TRUE + END WriteTypeInfo; + + PROCEDURE WriteData(s: Streams.Stream; object: Object) : BOOLEAN; + (* use the interface list to write all data in the right order *) + VAR + ifList: InterfaceList; + BEGIN + ifList := object.type.ifs; + WHILE ifList # NIL DO + IF ~ifList.if.write(s, object) THEN + (* error handling is done by the calling procedure *) + RETURN FALSE + END; + ifList := ifList.next; + END; + RETURN (object.type.if.write = NIL) OR object.type.if.write(s, object) + END WriteData; + + (* ===== exported procedures ============================================ *) + + PROCEDURE RegisterType*(VAR type: Services.Type; + name, baseName: ARRAY OF CHAR; + if: Interface); + VAR + newtype: Type; + baseType: Services.Type; + member: InterfaceList; + bt: Type; + ifval: INTEGER; + BEGIN + (* check the parameters *) + ASSERT(name[0] # 0X); + IF if # NIL THEN + ifval := 0; + IF if.create # NIL THEN INC(ifval, 1) END; + IF if.read # NIL THEN INC(ifval, 2) END; + IF if.write # NIL THEN INC(ifval, 4) END; + IF if.createAndRead # NIL THEN INC(ifval, 8) END; + (* legal variants: + + if = NIL abstract data type + + create read write createAndRead + #NIL NIL NIL NIL 1 empty data type + NIL #NIL #NIL NIL 6 abstract data type + #NIL #NIL #NIL NIL 7 normal case + NIL NIL #NIL #NIL 12 special case + + note that the special case must not be given as base type! + *) + ASSERT(ifval IN {1, 6, 7, 12}); + END; + + (* create type and determine next non-abstract base type *) + NEW(newtype); + newtype.code := nextTypeCode; INC(nextTypeCode); + newtype.if := if; + IF baseName = "" THEN + Services.InitType(newtype, name, "PersistentObjects.Object"); + ELSE + Services.InitType(newtype, name, baseName); + END; + IF baseName = "" THEN + newtype.baseType := NIL; + ELSE + Services.GetBaseType(newtype, baseType); + ASSERT((baseType # NIL) & (baseType IS Type)); + WHILE (baseType # NIL) & (baseType IS Type) & + (baseType(Type).if = NIL) DO + Services.GetBaseType(baseType, baseType); + END; + IF (baseType = NIL) OR ~(baseType IS Type) THEN + newtype.baseType := NIL; + ELSE + newtype.baseType := baseType(Type); + ASSERT(newtype.baseType.if.createAndRead = NIL); + END; + END; + + (* build up list of interfaces *) + newtype.ifs := NIL; bt := newtype.baseType; + WHILE bt # NIL DO + NEW(member); member.if := bt.if; + member.next := newtype.ifs; newtype.ifs := member; + bt := bt.baseType; + END; + + type := newtype; + END RegisterType; + + PROCEDURE Init*(object: Object; type: Services.Type); + BEGIN + ASSERT(type IS Type); + WITH type: Type DO + ASSERT((type.if.create # NIL) OR (type.if.createAndRead # NIL)); + object.type := type; + object.projected := FALSE; + Services.Init(object, type); + END; + END Init; + + PROCEDURE SetMode*(s: Streams.Stream; mode: Mode); + VAR + disc: StreamDiscipline; + BEGIN + IF ~Disciplines.Seek(s, id, SYS.VAL(Disciplines.Discipline, disc)) THEN + NEW(disc); disc.id := id; + END; + disc.mode := mode; + Disciplines.Add(s, disc); + END SetMode; + + PROCEDURE GetMode*(s: Streams.Stream; VAR mode: Mode); + (* return the current mode for the given stream *) + VAR + disc: StreamDiscipline; + BEGIN + IF Disciplines.Seek(s, id, SYS.VAL(Disciplines.Discipline, disc)) THEN + mode := disc.mode; + ELSE + mode := defaultMode; + END; + END GetMode; + + PROCEDURE IsProjected*(object: Object) : BOOLEAN; + (* show whether the object was a victim of projection or not *) + BEGIN + RETURN object.projected + END IsProjected; + + PROCEDURE InternalRead(s: Streams.Stream; create: BOOLEAN; + VAR object: Object) : BOOLEAN; + (* read `object' from `s'; + note that we have to operate on `object' directly because + LinearizedStructures relies on this in case of cyclic + references + *) + VAR + streamCaps: Streams.CapabilitySet; + type, objectType: Type; + projection: BOOLEAN; (* necessary due to unknown types? *) + size: Streams.Count; (* size information, if unknown it equals -1 *) + skipUnknownParts: BOOLEAN; (* are we able to skip data if necessary? *) + + (* these vars are used for skipping unknown data areas *) + oldPos, newPos: Streams.Count; + textbuf: Texts.Text; + + BEGIN (* InternalRead *) + IF ~ReadTypeInfo(s, type, projection, size) THEN RETURN FALSE END; + IF ~create & (type.if.createAndRead = NIL) THEN + (* projection necessary due to target object? *) + Services.GetType(object, SYS.VAL(Services.Type, objectType)); + IF ~Services.IsExtensionOf(type, objectType) THEN + TypeGuardFailure(s, type, objectType); RETURN FALSE + END; + projection := projection OR (type # objectType); + END; + skipUnknownParts := projection & (size > 0); + streamCaps := Streams.Capabilities(s); + IF skipUnknownParts THEN + IF Streams.tell IN streamCaps THEN + Streams.GetPos(s, oldPos); + ELSE + Texts.Open(SYS.VAL(Streams.Stream, textbuf)); + IF ~Streams.Copy(s, textbuf, size) THEN + Failure(s, cannotReadData); RETURN FALSE + END; + Forwarders.Forward(textbuf, s); + RelatedEvents.Forward(textbuf, s); + s := textbuf; + skipUnknownParts := FALSE; + END; + END; + + IF type.if.createAndRead # NIL THEN + IF ~type.if.createAndRead(s, create, object) THEN + DecodeFailure(s, type); object := NIL; RETURN FALSE + END; + ELSE + IF create THEN + type.if.create(object); + END; + IF ~ReadData(s, object) THEN + DecodeFailure(s, type); + object := NIL; + RETURN FALSE + END; + END; + + (* store information about projection into object *) + object.projected := projection; + + IF skipUnknownParts THEN + IF Streams.seek IN streamCaps THEN + Streams.SetPos(s, oldPos + size); + ELSE + Streams.GetPos(s, newPos); + IF ~Streams.Copy(s, Streams.null, size - newPos + oldPos) THEN + Failure(s, cannotSkip); RETURN FALSE + END; + END; + ELSIF projection & (size < 0) THEN + Error(s, cannotSkip); RETURN FALSE + END; + + s.count := 1; (* show success *) + RETURN TRUE + END InternalRead; + + PROCEDURE Read*(s: Streams.Stream; VAR object: Object) : BOOLEAN; + (* read `object' from `s'; object # NIL on success *) + BEGIN + RETURN InternalRead(s, (* create = *) TRUE, object) + END Read; + + PROCEDURE ReadInto*(s: Streams.Stream; object: Object) : BOOLEAN; + (* read an object from `s' and assign it to `object'; + this fails if `object' doesn't has the IDENTICAL type + (thus projections are not supported here) + *) + BEGIN + RETURN InternalRead(s, (* create = *) FALSE, object) + END ReadInto; + + PROCEDURE GuardedRead*(s: Streams.Stream; guard: Services.Type; + VAR object: Object) : BOOLEAN; + (* read an object from `s' and return it, provided + the type of the read object is an extension of `guard' + *) + VAR + testObject: Object; + type: Services.Type; + BEGIN + IF ~Read(s, testObject) THEN RETURN FALSE END; + Services.GetType(testObject, type); + IF Services.IsExtensionOf(type, guard) THEN + object := testObject; RETURN TRUE + ELSE + TypeGuardFailure(s, type, guard); + RETURN FALSE + END; + END GuardedRead; + + PROCEDURE Write*(s: Streams.Stream; object: Object) : BOOLEAN; + (* write `obj' to `s' *) + VAR + giveSize: BOOLEAN; + streamCaps: Streams.CapabilitySet; + patchSize: BOOLEAN; + sizePos, beginPos, endPos: Streams.Count; + textbuf, origStream: Streams.Stream; + mode: Mode; + BEGIN + IF ~WriteTypeInfo(s, object.type, giveSize) THEN RETURN FALSE END; + IF giveSize THEN + streamCaps := Streams.Capabilities(s); + patchSize := ({Streams.tell, Streams.seek} - streamCaps = {}) & + Streams.Tell(s, sizePos); + IF patchSize THEN + IF ~NetIO.WriteLongInt(s, 0) THEN + Error(s, cannotWriteData); RETURN FALSE + END; + Streams.GetPos(s, beginPos); + ELSE + Texts.Open(textbuf); + Forwarders.Forward(textbuf, s); + RelatedEvents.Forward(textbuf, s); + GetMode(s, mode); SetMode(textbuf, mode); + origStream := s; s := textbuf; + END; + END; + + IF object.type.if.createAndRead # NIL THEN + IF ~object.type.if.write(s, object) THEN + Error(s, cannotWriteData); RETURN FALSE + END; + ELSE + IF ~WriteData(s, object) THEN + Error(s, cannotWriteData); RETURN FALSE + END; + END; + + IF giveSize THEN + IF patchSize THEN + Streams.GetPos(s, endPos); + Streams.SetPos(s, sizePos); + IF ~NetIO.WriteLongInt(s, endPos - beginPos) THEN + Streams.SetPos(s, endPos); + Error(s, cannotWriteData); + RETURN FALSE + END; + Streams.SetPos(s, endPos); + ELSE + Streams.GetPos(textbuf, endPos); + Streams.SetPos(textbuf, 0); + s := origStream; + IF ~NetIO.WriteLongInt(s, endPos) OR + ~Streams.Copy(textbuf, s, endPos) THEN + Error(s, cannotWriteData); + END; + END; + END; + s.count := 1; + RETURN TRUE + END Write; + + PROCEDURE ReadObjectOrNIL*(s: Streams.Stream; VAR object: Object) : BOOLEAN; + VAR + nil: BOOLEAN; + BEGIN + object := NIL; + RETURN NetIO.ReadBoolean(s, nil) & (nil OR Read(s, object)) + END ReadObjectOrNIL; + + PROCEDURE GuardedReadObjectOrNIL*(s: Streams.Stream; guard: Services.Type; + VAR object: Object) : BOOLEAN; + (* may be used instead of ReadObjectOrNIL *) + VAR + testObject: Object; + type: Services.Type; + nil: BOOLEAN; + BEGIN + IF ~NetIO.ReadBoolean(s, nil) THEN RETURN FALSE END; + IF nil THEN + object := NIL; + RETURN TRUE + END; + IF ~Read(s, testObject) THEN RETURN FALSE END; + IF testObject = NIL THEN RETURN TRUE END; + Services.GetType(testObject, type); + IF Services.IsExtensionOf(type, guard) THEN + object := testObject; RETURN TRUE + ELSE + TypeGuardFailure(s, type, guard); + RETURN FALSE + END; + END GuardedReadObjectOrNIL; + + PROCEDURE WriteObjectOrNIL*(s: Streams.Stream; object: Object) : BOOLEAN; + VAR + nil: BOOLEAN; + BEGIN + nil := object = NIL; + RETURN NetIO.WriteBoolean(s, nil) & (nil OR Write(s, object)) + END WriteObjectOrNIL; + +BEGIN + id := Disciplines.Unique(); + nextTypeCode := 1; + InitErrorHandling; + Services.CreateType(potype, "PersistentObjects.Object", ""); +END ulmPersistentObjects. diff --git a/src/lib/ulm/ulmScales.Mod b/src/lib/ulm/ulmScales.Mod new file mode 100644 index 00000000..e12d2c23 --- /dev/null +++ b/src/lib/ulm/ulmScales.Mod @@ -0,0 +1,443 @@ +(* Ulm's Oberon Library + Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. + + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: Scales.om,v 1.3 2004/09/03 09:31:53 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: Scales.om,v $ + Revision 1.3 2004/09/03 09:31:53 borchert + bug fixes: Services.Init added in CreateOperand + Scales.Measure changed to Measure + + Revision 1.2 1995/01/16 21:40:39 borchert + - assertions of Assertions converted into real assertions + - fixes due to changed if of PersistentObjects + + Revision 1.1 1994/02/22 20:10:03 borchert + Initial revision + + ---------------------------------------------------------------------------- + AFB 12/91 + ---------------------------------------------------------------------------- +*) + +MODULE ulmScales; + + IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Objects := ulmObjects, Operations := ulmOperations, PersistentObjects := ulmPersistentObjects, + RelatedEvents := ulmRelatedEvents, Services := ulmServices; + + TYPE + Scale* = POINTER TO ScaleRec; + Family* = POINTER TO FamilyRec; + FamilyRec* = + RECORD + (Disciplines.ObjectRec) + (* private components *) + reference: Scale; + END; + + TYPE + Unit* = POINTER TO UnitRec; + UnitList = POINTER TO UnitListRec; + UnitListRec = + RECORD + unit: Unit; + next: UnitList; + END; + Interface = POINTER TO InterfaceRec; + ScaleRec* = + RECORD + (Disciplines.ObjectRec) + (* private components *) + if: Interface; + family: Family; + head, tail: UnitList; + nextUnit: UnitList; + END; + + CONST + unitNameLength* = 32; + TYPE + UnitName* = ARRAY unitNameLength OF CHAR; + UnitRec* = RECORD + (Disciplines.ObjectRec) + name: UnitName; + scale: Scale; + END; + + CONST + undefined = 0; absolute* = 1; relative* = 2; + TYPE + Measure* = POINTER TO MeasureRec; + MeasureRec* = + RECORD + (Operations.OperandRec) + scale: Scale; + type: SHORTINT; (* absolute or relative? *) + END; + VAR + measureType: Services.Type; + + TYPE + Value* = LONGINT; + + CONST + add* = Operations.add; sub* = Operations.sub; + TYPE + Operation* = SHORTINT; (* add or sub *) + TYPE + CreateProc* = PROCEDURE (scale: Scale; VAR measure: Measure; abs: BOOLEAN); + GetValueProc* = PROCEDURE (measure: Measure; unit: Unit; VAR value: Value); + SetValueProc* = PROCEDURE (measure: Measure; unit: Unit; value: Value); + AssignProc* = PROCEDURE (target: Measure; source: Measure); + OperatorProc* = PROCEDURE (op: Operation; op1, op2, result: Measure); + CompareProc* = PROCEDURE (op1, op2: Measure) : INTEGER; + ConvertProc* = PROCEDURE (from, to: Measure); + + InterfaceRec* = + RECORD + (Objects.ObjectRec) + create*: CreateProc; + getvalue*: GetValueProc; + setvalue*: SetValueProc; + assign*: AssignProc; + op*: OperatorProc; + compare*: CompareProc; + (* the conversion routines are only to be provided + if the scaling system belongs to a family + *) + scaleToReference*: ConvertProc; + referenceToScale*: ConvertProc; + END; + + VAR + invalidOperation*: Events.EventType; + (* operation cannot be performed for the given combination + of types (absolute or relative) + *) + incompatibleScales*: Events.EventType; + (* the scales of the operands do not belong to the same family *) + badCombination*: Events.EventType; + (* SetValue or GetValue: + given measure and unit do not belong to the same scaling system + *) + + (* our interface to Operations *) + opif: Operations.Interface; + opcaps: Operations.CapabilitySet; + + (* ======= private procedures ===================================== *) + + PROCEDURE DummyConversion(from, to: Measure); + BEGIN + from.scale.if.assign(to, from); + END DummyConversion; + + (* ======== exported procedures ==================================== *) + + PROCEDURE InitFamily*(family: Family; reference: Scale); + BEGIN + family.reference := reference; + (* the reference scale becomes now a member of the family *) + reference.family := family; + reference.if.scaleToReference := DummyConversion; + reference.if.referenceToScale := DummyConversion; + END InitFamily; + + PROCEDURE Init*(scale: Scale; family: Family; if: Interface); + (* reference scales are to be initialized with family = NIL *) + BEGIN + scale.if := if; + scale.family := family; + scale.head := NIL; scale.tail := NIL; + scale.nextUnit := NIL; + END Init; + + PROCEDURE InitUnit*(scale: Scale; unit: Unit; name: UnitName); + VAR + listp: UnitList; + BEGIN + unit.name := name; + unit.scale := scale; + NEW(listp); listp.unit := unit; listp.next := NIL; + IF scale.head # NIL THEN + scale.tail.next := listp; + ELSE + scale.head := listp; + END; + scale.tail := listp; + END InitUnit; + + PROCEDURE CreateMeasure*(scale: Scale; VAR measure: Measure; type: SHORTINT); + BEGIN + scale.if.create(scale, measure, type = absolute); + Operations.Init(measure, opif, opcaps); + measure.scale := scale; + measure.type := type; + END CreateMeasure; + + PROCEDURE CreateAbsMeasure*(scale: Scale; VAR measure: Measure); + (* init measure to the origin of the given system *) + BEGIN + CreateMeasure(scale, measure, absolute); + END CreateAbsMeasure; + + PROCEDURE CreateRelMeasure*(scale: Scale; VAR measure: Measure); + (* init relative measure to 0 *) + BEGIN + CreateMeasure(scale, measure, relative); + END CreateRelMeasure; + + PROCEDURE ConvertMeasure*(scale: Scale; VAR measure: Measure); + (* convert measure to the given scale which must belong + to the same family as the original scale of measure + *) + VAR + newMeasure: Measure; + refMeasure: Measure; + reference: Scale; + BEGIN + IF scale = measure.scale THEN + (* trivial case -- nothing is to be done *) + RETURN + END; + (* check that both scales belong to the same family *) + ASSERT((scale.family # NIL) & (scale.family = measure.scale.family)); + CreateMeasure(scale, newMeasure, measure.type); + reference := scale.family.reference; + CreateMeasure(reference, refMeasure, measure.type); + measure.scale.if.scaleToReference(measure, refMeasure); + scale.if.referenceToScale(refMeasure, newMeasure); + measure := newMeasure; + END ConvertMeasure; + + PROCEDURE GetReference*(family: Family; VAR reference: Scale); + BEGIN + reference := family.reference; + END GetReference; + + PROCEDURE GetFamily*(scale: Scale; VAR family: Family); + BEGIN + family := scale.family; + END GetFamily; + + PROCEDURE GetScaleOfUnit*(unit: Unit; VAR scale: Scale); + BEGIN + scale := unit.scale; + END GetScaleOfUnit; + + PROCEDURE GetScale*(measure: Measure; VAR scale: Scale); + BEGIN + scale := measure.scale; + END GetScale; + + PROCEDURE TraverseUnits*(scale: Scale); + BEGIN + scale.nextUnit := scale.head; + END TraverseUnits; + + PROCEDURE NextUnit*(scale: Scale; VAR unit: Unit) : BOOLEAN; + BEGIN + IF scale.nextUnit # NIL THEN + unit := scale.nextUnit.unit; + scale.nextUnit := scale.nextUnit.next; + RETURN TRUE + ELSE + RETURN FALSE + END; + END NextUnit; + + PROCEDURE GetName*(unit: Unit; VAR name: UnitName); + BEGIN + name := unit.name; + END GetName; + + PROCEDURE GetValue*(measure: Measure; unit: Unit; VAR value: Value); + VAR + scale: Scale; + BEGIN + scale := measure.scale; + ASSERT(unit.scale = scale); + scale.if.getvalue(measure, unit, value); + END GetValue; + + PROCEDURE SetValue*(measure: Measure; unit: Unit; value: Value); + VAR + scale: Scale; + BEGIN + scale := measure.scale; + ASSERT(unit.scale = scale); + scale.if.setvalue(measure, unit, value); + END SetValue; + + PROCEDURE IsAbsolute*(measure: Measure) : BOOLEAN; + BEGIN + RETURN measure.type = absolute + END IsAbsolute; + + PROCEDURE IsRelative*(measure: Measure) : BOOLEAN; + BEGIN + RETURN measure.type = relative + END IsRelative; + + PROCEDURE MeasureType*(measure: Measure) : SHORTINT; + BEGIN + RETURN measure.type + END MeasureType; + + (* ======== interface procedures for Operations ================= *) + + PROCEDURE CreateOperand(VAR op: Operations.Operand); + (* at this time we don't know anything about the + associated scale -- so we've have to delay this decision + *) + VAR + measure: Measure; + BEGIN + NEW(measure); + measure.type := undefined; + measure.scale := NIL; + Services.Init(measure, measureType); + op := measure; + Operations.Init(op, opif, {Operations.add..Operations.cmp}); + END CreateOperand; + + PROCEDURE Assign(VAR target: Operations.Operand; source: Operations.Operand); + BEGIN + WITH source: Measure DO WITH target: Measure DO + (* target is already initialized but possibly to a dummy operand + by CreateOperand + *) + IF target.type = undefined THEN + (* init target with the scale of source *) + CreateMeasure(source.scale, target, source.type); + END; + IF target.scale # source.scale THEN + (* adapt scale type from source -- + this could lead to a type guard failure if + target is not of the appropiate type + *) + CreateMeasure(source.scale, target, source.type); + END; + IF target.type # source.type THEN + (* adapt measure type from source *) + CreateMeasure(target.scale, target, source.type); + END; + source.scale.if.assign(target, source); + END; END; + END Assign; + + PROCEDURE CheckCompatibility(op1, op2: Operations.Operand; + VAR m1, m2: Measure); + (* is needed by Op and Compare: + both operands are checked to be members of the same family; + if they have different scales of the same family a + conversion is done; + *) + VAR + scale1, scale2: Scale; + BEGIN + WITH op1: Measure DO WITH op2: Measure DO + scale1 := op1.scale; scale2 := op2.scale; + IF scale1 # scale2 THEN + ASSERT((scale1.family # NIL) & (scale1.family = scale2.family)); + (* convert both operands to the reference scale *) + CreateMeasure(scale1.family.reference, m1, op1.type); + scale1.if.scaleToReference(op1, m1); + CreateMeasure(scale2.family.reference, m2, op2.type); + scale2.if.scaleToReference(op2, m2); + ELSE + m1 := op1; + m2 := op2; + END; + END; END; + END CheckCompatibility; + + PROCEDURE Op(op: Operations.Operation; op1, op2: Operations.Operand; + VAR result: Operations.Operand); + VAR + restype: SHORTINT; (* type of result -- set by CheckTypes *) + m1, m2: Measure; + + PROCEDURE CheckTypes(VAR restype: SHORTINT); + (* check operands for correct typing; + sets restype to the correct result type; + *) + VAR ok: BOOLEAN; + BEGIN + WITH op1: Measure DO WITH op2: Measure DO + CASE op OF + | Operations.add: (* only abs + abs is invalid *) + ok := (op1.type = relative) OR + (op2.type = relative); + IF op1.type = op2.type THEN + (* both are relative *) + restype := relative; + ELSE + (* exactly one absolute type is involved *) + restype := absolute; + END; + | Operations.sub: (* only rel - abs is invalid *) + ok := op1.type <= op2.type; + IF op1.type # op2.type THEN + (* abs - rel *) + restype := absolute; + ELSE + (* abs - abs or rel - rel *) + restype := relative; + END; + END; + ASSERT(ok); (* invalid operation *) + END; END; + END CheckTypes; + + BEGIN (* Op *) + (* result is already of type Measure; this is guaranteed by Operations *) + WITH result: Measure DO + CheckTypes(restype); + CheckCompatibility(op1, op2, m1, m2); + CreateMeasure(m1.scale, result, restype); + m1.scale.if.op(op, m1, m2, result); + END; + END Op; + + PROCEDURE Compare(op1, op2: Operations.Operand) : INTEGER; + VAR + m1, m2: Measure; + BEGIN + CheckCompatibility(op1, op2, m1, m2); + ASSERT(m1.type = m2.type); + CheckCompatibility(op1, op2, m1, m2); + RETURN m1.scale.if.compare(m1, m2) + END Compare; + + PROCEDURE InitInterface; + BEGIN + NEW(opif); + opif.create := CreateOperand; + opif.assign := Assign; + opif.op := Op; + opif.compare := Compare; + opcaps := {Operations.add, Operations.sub, Operations.cmp}; + END InitInterface; + +BEGIN + InitInterface; + PersistentObjects.RegisterType(measureType, + "Scales.Measure", "Operations.Operand", NIL); +END ulmScales.