mirror of
https://github.com/vishapoberon/compiler.git
synced 2026-04-06 23:52:25 +00:00
445 lines
14 KiB
Modula-2
445 lines
14 KiB
Modula-2
(* Ulm's Oberon Library
|
|
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
|
|
----------------------------------------------------------------------------
|
|
Ulm's Oberon Library is free software; you can redistribute it
|
|
and/or modify it under the terms of the GNU Library General Public
|
|
License as published by the Free Software Foundation; either version
|
|
2 of the License, or (at your option) any later version.
|
|
|
|
Ulm's Oberon Library is distributed in the hope that it will be
|
|
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
|
|
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
Library General Public License for more details.
|
|
|
|
You should have received a copy of the GNU Library General Public
|
|
License along with this library; if not, write to the Free Software
|
|
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
----------------------------------------------------------------------------
|
|
E-mail contact: oberon@mathematik.uni-ulm.de
|
|
----------------------------------------------------------------------------
|
|
$Id: 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, SYS := SYSTEM;
|
|
|
|
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*)
|
|
WITH source: Measure DO IF target IS Measure THEN (* WITH is replaced by IS -- noch *)
|
|
(* target is already initialized but possibly to a dummy operand
|
|
by CreateOperand
|
|
*)
|
|
IF target(Measure).type = undefined THEN (* type guard introduced *)
|
|
(* init target with the scale of source *)
|
|
CreateMeasure(source.scale, SYS.VAL(Measure, target), source.type); (* need to cast *)
|
|
END;
|
|
IF target(Measure).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, SYS.VAL(Measure, target), source.type);
|
|
END;
|
|
IF target(Measure).type # source.type THEN
|
|
(* adapt measure type from source *)
|
|
CreateMeasure(target(Measure).scale, SYS.VAL(Measure, target), source.type);
|
|
END;
|
|
source.scale.if.assign(SYS.VAL(Measure, 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*)
|
|
IF op1 IS Measure THEN IF op2 IS Measure THEN
|
|
CASE op OF
|
|
| Operations.add: (* only abs + abs is invalid *)
|
|
ok := (op1(Measure).type = relative) OR
|
|
(op2(Measure).type = relative);
|
|
IF op1(Measure).type = op2(Measure).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(Measure).type <= op2(Measure).type;
|
|
IF op1(Measure).type # op2(Measure).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 *)
|
|
IF result IS Measure THEN
|
|
CheckTypes(restype);
|
|
CheckCompatibility(op1, op2, m1, m2);
|
|
CreateMeasure(m1.scale, SYS.VAL(Measure, result), restype);
|
|
m1.scale.if.op(op, m1, m2, SYS.VAL(Measure, 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.
|