mirror of
https://github.com/vishapoberon/compiler.git
synced 2026-04-06 04:02:25 +00:00
ported ulmLoader, ulmNetIO, ulmPersistentDisciplines, ulmPersistentObjects, ulmScales
fixed ulmConstStrings
Former-commit-id: e76b8bf27c
This commit is contained in:
Norayr Chilingarian
parent
4e45337b83
commit
e989e42d42
7 changed files with 2680 additions and 1 deletions
5
makefile
5
makefile
|
|
@ -172,6 +172,11 @@ stage6:
|
||||||
$(VOCSTATIC) -sP ulmErrors.Mod
|
$(VOCSTATIC) -sP ulmErrors.Mod
|
||||||
$(VOCSTATIC) -sP ulmSysErrors.Mod
|
$(VOCSTATIC) -sP ulmSysErrors.Mod
|
||||||
$(VOCSTATIC) -sP ulmSysIO.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
|
#pow32 libs
|
||||||
|
|
|
||||||
|
|
@ -69,7 +69,7 @@ MODULE ulmConstStrings;
|
||||||
next: Buffer;
|
next: Buffer;
|
||||||
END;
|
END;
|
||||||
|
|
||||||
String = POINTER TO StringRec;
|
String* = POINTER TO StringRec;
|
||||||
StringRec* =
|
StringRec* =
|
||||||
RECORD
|
RECORD
|
||||||
(Disciplines.ObjectRec)
|
(Disciplines.ObjectRec)
|
||||||
|
|
|
||||||
216
src/lib/ulm/ulmLoader.Mod
Normal file
216
src/lib/ulm/ulmLoader.Mod
Normal file
|
|
@ -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.
|
||||||
546
src/lib/ulm/ulmNetIO.Mod
Normal file
546
src/lib/ulm/ulmNetIO.Mod
Normal file
|
|
@ -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.
|
||||||
391
src/lib/ulm/ulmPersistentDisciplines.Mod
Normal file
391
src/lib/ulm/ulmPersistentDisciplines.Mod
Normal file
|
|
@ -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.
|
||||||
1078
src/lib/ulm/ulmPersistentObjects.Mod
Normal file
1078
src/lib/ulm/ulmPersistentObjects.Mod
Normal file
File diff suppressed because it is too large
Load diff
443
src/lib/ulm/ulmScales.Mod
Normal file
443
src/lib/ulm/ulmScales.Mod
Normal file
|
|
@ -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.
|
||||||
Loading…
Add table
Add a link
Reference in a new issue