vishapoberon/compiler
1
0
Fork 0
mirror of https://github.com/vishapoberon/compiler.git synced 2026-04-05 23:22:25 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

ported ulmLoader, ulmNetIO, ulmPersistentDisciplines, ulmPersistentObjects, ulmScales

Browse source 
fixed ulmConstStrings
This commit is contained in:
Norayr Chilingarian 2013-10-29 17:15:11 +04:00
parent 841d00e9d0
commit e76b8bf27c
7 changed files with 2680 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

5
makefile
View file

@ -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

2
src/lib/ulm/ulmConstStrings.Mod
View file

@ -69,7 +69,7 @@ MODULE ulmConstStrings;
next: Buffer;
END;
String = POINTER TO StringRec;
String* = POINTER TO StringRec;
StringRec* =
RECORD
(Disciplines.ObjectRec)

216
src/lib/ulm/ulmLoader.Mod Normal file
View 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
View 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
View 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
View file

File diff suppressed because it is too large Load diff

443
src/lib/ulm/ulmScales.Mod Normal file
View 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.