vishapoberon/compiler
1
0
Fork 0
mirror of https://github.com/vishapoberon/compiler.git synced 2026-04-06 07:32:24 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

Reenable library files, fix LONGREAL constants and type casts.

Browse source
This commit is contained in:
David Brown 2016-09-26 19:01:59 +01:00
parent ef0a447a68
commit 9ffafc59b4
229 changed files with 11147 additions and 11288 deletions
Download patch file Download diff file Expand all files Collapse all files

290
src/library/ooc/oocLRealMath.Mod
View file

@ -1,42 +1,42 @@
MODULE oocLRealMath;
(*
LRealMath - Target independent mathematical functions for LONGREAL
LRealMath - Target independent mathematical functions for LONGREAL
(IEEE double-precision) numbers.
Numerical approximations are taken from "Software Manual for the
Elementary Functions" by Cody & Waite and "Computer Approximations"
by Hart et al.
by Hart et al.
Copyright (C) 1996-1998 Michael Griebling
This module is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2 of the
License, or (at your option) any later version.
This module 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 Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*)
IMPORT l := oocLowLReal, m := oocRealMath;
IMPORT l := oocLowLReal, m := oocRealMath, SYSTEM;
CONST
pi* = 3.1415926535897932384626433832795028841972D0;
exp1* = 2.7182818284590452353602874713526624977572D0;
ZERO=0.0D0; ONE=1.0D0; HALF=0.5D0; TWO=2.0D0; (* local constants *)
ZERO=0.0D0; ONE=1.0D0; HALF=0.5D0; TWO=2.0D0; (* local constants *)
(* internally-used constants *)
huge=l.large; (* largest number this package accepts *)
miny=l.small; (* smallest number this package accepts *)
miny=l.small; (* smallest number this package accepts *)
sqrtHalf=0.70710678118654752440D0;
Limit=1.0536712D-8; (* 2**(-MantBits/2) *)
eps=5.5511151D-17; (* 2**(-MantBits-1) *)
@ -44,30 +44,30 @@ CONST
piByTwo=1.57079632679489661923D0;
lnv=0.6931610107421875D0; (* should be exact *)
vbytwo=0.13830277879601902638D-4; (* used in sinh/cosh *)
ln2Inv=1.44269504088896340735992468100189213D0;
ln2Inv=1.44269504088896340735992468100189213D0;
(* error/exception codes *)
NoError*=m.NoError; IllegalRoot*=m.IllegalRoot; IllegalLog*=m.IllegalLog; Overflow*=m.Overflow;
IllegalPower*=m.IllegalPower; IllegalLogBase*=m.IllegalLogBase; IllegalTrig*=m.IllegalTrig;
IllegalInvTrig*=m.IllegalInvTrig; HypInvTrigClipped*=m.HypInvTrigClipped;
NoError*=m.NoError; IllegalRoot*=m.IllegalRoot; IllegalLog*=m.IllegalLog; Overflow*=m.Overflow;
IllegalPower*=m.IllegalPower; IllegalLogBase*=m.IllegalLogBase; IllegalTrig*=m.IllegalTrig;
IllegalInvTrig*=m.IllegalInvTrig; HypInvTrigClipped*=m.HypInvTrigClipped;
IllegalHypInvTrig*=m.IllegalHypInvTrig; LossOfAccuracy*=m.LossOfAccuracy;
VAR
a1: ARRAY 18 OF LONGREAL; (* lookup table for power function *)
a2: ARRAY 9 OF LONGREAL; (* lookup table for power function *)
em: LONGREAL; (* largest number such that 1+epsilon > 1.0 *)
a2: ARRAY 9 OF LONGREAL; (* lookup table for power function *)
em: LONGREAL; (* largest number such that 1+epsilon > 1.0 *)
LnInfinity: LONGREAL; (* natural log of infinity *)
LnSmall: LONGREAL; (* natural log of very small number *)
SqrtInfinity: LONGREAL; (* square root of infinity *)
TanhMax: LONGREAL; (* maximum Tanh value *)
t: LONGREAL; (* internal variables *)
(* internally used support routines *)
PROCEDURE SinCos (x, y, sign: LONGREAL): LONGREAL;
CONST
ymax=210828714; (* ENTIER(pi*2**(MantBits/2)) *)
c1=3.1416015625D0;
c1=3.1416015625D0;
c2=-8.908910206761537356617D-6;
r1=-0.16666666666666665052D+0;
r2= 0.83333333333331650314D-2;
@ -77,24 +77,24 @@ PROCEDURE SinCos (x, y, sign: LONGREAL): LONGREAL;
r6= 0.16058936490371589114D-9;
r7=-0.76429178068910467734D-12;
r8= 0.27204790957888846175D-14;
VAR
n: LONGINT; xn, f, x1, g: LONGREAL;
VAR
n: LONGINT; xn, f, x1, g: LONGREAL;
BEGIN
IF y>=ymax THEN l.ErrorHandler(LossOfAccuracy); RETURN ZERO END;
(* determine the reduced number *)
n:=ENTIER(y*piInv+HALF); xn:=n;
IF ODD(n) THEN sign:=-sign END;
x:=ABS(x);
IF x#y THEN xn:=xn-HALF END;
(* fractional part of reduced number *)
x1:=ENTIER(x);
f:=((x1-xn*c1)+(x-x1))-xn*c2;
(* Pre: |f| <= pi/2 *)
IF ABS(f)<Limit THEN RETURN sign*f END;
(* evaluate polynomial approximation of sin *)
g:=f*f; g:=(((((((r8*g+r7)*g+r6)*g+r5)*g+r4)*g+r3)*g+r2)*g+r1)*g;
g:=f+f*g; (* don't use less accurate f(1+g) *)
@ -106,43 +106,43 @@ PROCEDURE div (x, y : LONGINT) : LONGINT;
BEGIN
IF x < 0 THEN RETURN -ABS(x) DIV y ELSE RETURN x DIV y END
END div;
(* forward declarations *)
PROCEDURE^ arctan2* (xn, xd: LONGREAL): LONGREAL;
PROCEDURE^ sincos* (x: LONGREAL; VAR Sin, Cos: LONGREAL);
PROCEDURE sqrt*(x: LONGREAL): LONGREAL;
(* Returns the positive square root of x where x >= 0 *)
CONST
CONST
P0=0.41731; P1=0.59016;
VAR
xMant, yEst, z: LONGREAL; xExp: INTEGER;
VAR
xMant, yEst, z: LONGREAL; xExp: INTEGER;
BEGIN
(* optimize zeros and check for illegal negative roots *)
IF x=ZERO THEN RETURN ZERO END;
IF x<ZERO THEN l.ErrorHandler(IllegalRoot); x:=-x END;
(* reduce the input number to the range 0.5 <= x <= 1.0 *)
xMant:=l.fraction(x)*HALF; xExp:=l.exponent(x)+1;
(* initial estimate of the square root *)
yEst:=P0+P1*xMant;
(* perform three newtonian iterations *)
z:=(yEst+xMant/yEst); yEst:=0.25*z+xMant/z;
yEst:=HALF*(yEst+xMant/yEst);
(* adjust for odd exponents *)
IF ODD(xExp) THEN yEst:=yEst*sqrtHalf; INC(xExp) END;
(* single Newtonian iteration to produce real number accuracy *)
RETURN l.scale(yEst, xExp DIV 2)
RETURN l.scale(yEst, xExp DIV 2)
END sqrt;
PROCEDURE exp*(x: LONGREAL): LONGREAL;
(* Returns the exponential of x for x < Ln(MAX(REAL) *)
CONST
CONST
c1=0.693359375D0; c2=-2.1219444005469058277D-4;
P0=0.249999999999999993D+0; P1=0.694360001511792852D-2; P2=0.165203300268279130D-4;
Q1=0.555538666969001188D-1; Q2=0.495862884905441294D-3;
@ -153,18 +153,18 @@ BEGIN
ELSIF x<LnSmall THEN RETURN ZERO
ELSIF ABS(x)<eps THEN RETURN ONE
END;
(* Decompose and scale the number *)
IF x>=ZERO THEN n:=SHORT(ENTIER(ln2Inv*x+HALF))
ELSE n:=SHORT(ENTIER(ln2Inv*x-HALF))
END;
xn:=n; g:=(x-xn*c1)-xn*c2;
(* Calculate exp(g)/2 from "Software Manual for the Elementary Functions" *)
z:=g*g; p:=((P2*z+P1)*z+P0)*g; q:=(Q2*z+Q1)*z+HALF;
RETURN l.scale(HALF+p/(q-p), n+1)
END exp;
PROCEDURE ln*(x: LONGREAL): LONGREAL;
(* Returns the natural logarithm of x for x > 0 *)
CONST
@ -175,27 +175,27 @@ PROCEDURE ln*(x: LONGREAL): LONGREAL;
BEGIN
(* ensure illegal inputs are trapped and handled *)
IF x<=ZERO THEN l.ErrorHandler(IllegalLog); RETURN -huge END;
(* reduce the range of the input *)
f:=l.fraction(x)*HALF; n:=l.exponent(x)+1;
IF f>sqrtHalf THEN zn:=(f-HALF)-HALF; zd:=f*HALF+HALF
ELSE zn:=f-HALF; zd:=zn*HALF+HALF; DEC(n)
ELSE zn:=f-HALF; zd:=zn*HALF+HALF; DEC(n)
END;
(* evaluate rational approximation from "Software Manual for the Elementary Functions" *)
z:=zn/zd; w:=z*z; q:=((w+Q2)*w+Q1)*w+Q0; p:=w*((P2*w+P1)*w+P0); r:=z+z*(p/q);
(* scale the output *)
xn:=n;
xn:=n;
RETURN (xn*c2+r)+xn*c1
END ln;
(* The angle in all trigonometric functions is measured in radians *)
PROCEDURE sin* (x: LONGREAL): LONGREAL;
BEGIN
IF x<ZERO THEN RETURN SinCos(x, -x, -ONE)
IF x<ZERO THEN RETURN SinCos(x, -x, -ONE)
ELSE RETURN SinCos(x, x, ONE)
END
END sin;
@ -204,7 +204,7 @@ PROCEDURE cos* (x: LONGREAL): LONGREAL;
BEGIN
RETURN SinCos(x, ABS(x)+piByTwo, ONE)
END cos;
PROCEDURE tan*(x: LONGREAL): LONGREAL;
(* Returns the tangent of x where x cannot be an odd multiple of pi/2 *)
VAR Sin, Cos: LONGREAL;
@ -214,7 +214,7 @@ BEGIN
ELSE RETURN Sin/Cos
END
END tan;
PROCEDURE arcsin*(x: LONGREAL): LONGREAL;
(* Returns the arcsine of x, in the range [-pi/2, pi/2] where -1 <= x <= 1 *)
BEGIN
@ -222,7 +222,7 @@ BEGIN
ELSE RETURN arctan2(x, sqrt(ONE-x*x))
END
END arcsin;
PROCEDURE arccos*(x: LONGREAL): LONGREAL;
(* Returns the arccosine of x, in the range [0, pi] where -1 <= x <= 1 *)
BEGIN
@ -230,49 +230,49 @@ BEGIN
ELSE RETURN arctan2(sqrt(ONE-x*x), x)
END
END arccos;
PROCEDURE arctan*(x: LONGREAL): LONGREAL;
(* Returns the arctangent of x, in the range [-pi/2, pi/2] for all x *)
BEGIN
RETURN arctan2(x, ONE)
END arctan;
PROCEDURE power*(base, exponent: LONGREAL): LONGREAL;
(* Returns the value of the number base raised to the power exponent
(* Returns the value of the number base raised to the power exponent
for base > 0 *)
CONST
P1=0.83333333333333211405D-1; P2=0.12500000000503799174D-1;
P3=0.22321421285924258967D-2; P4=0.43445775672163119635D-3;
K=0.44269504088896340736D0;
Q1=0.69314718055994529629D+0; Q2=0.24022650695909537056D+0;
CONST
P1=0.83333333333333211405D-1; P2=0.12500000000503799174D-1;
P3=0.22321421285924258967D-2; P4=0.43445775672163119635D-3;
K=0.44269504088896340736D0;
Q1=0.69314718055994529629D+0; Q2=0.24022650695909537056D+0;
Q3=0.55504108664085595326D-1; Q4=0.96181290595172416964D-2;
Q5=0.13333541313585784703D-2; Q6=0.15400290440989764601D-3;
Q7=0.14928852680595608186D-4;
OneOver16=0.0625D0; XMAX=16*l.expoMax-1; (*XMIN=16*l.expoMin+1;*) XMIN=-16351; (* noch *)
VAR z, g, R, v, u2, u1, w1, w2, y1, y2, w: LONGREAL; m, p, i: INTEGER; mp, pp, iw1: LONGINT;
VAR z, g, R, v, u2, u1, w1, w2, y1, y2, w: LONGREAL; m, p, i: INTEGER; mp, pp, iw1: LONGINT;
BEGIN
(* handle all possible error conditions *)
IF ABS(exponent)<miny THEN RETURN ONE (* base**0 = 1 *)
ELSIF base<ZERO THEN l.ErrorHandler(IllegalPower); RETURN -huge
ELSIF ABS(base)<miny THEN
ELSIF ABS(base)<miny THEN
IF exponent>ZERO THEN RETURN ZERO ELSE l.ErrorHandler(Overflow); RETURN -huge END
END;
(* extract the exponent of base to m and clear exponent of base in g *)
g:=l.fraction(base)*HALF; m:=l.exponent(base)+1;
(* determine p table offset with an unrolled binary search *)
p:=1;
IF g<=a1[9] THEN p:=9 END;
IF g<=a1[p+4] THEN INC(p, 4) END;
IF g<=a1[p+2] THEN INC(p, 2) END;
(* compute scaled z so that |z| <= 0.044 *)
z:=((g-a1[p+1])-a2[(p+1) DIV 2])/(g+a1[p+1]); z:=z+z;
(* approximation for log2(z) from "Software Manual for the Elementary Functions" *)
v:=z*z; R:=(((P4*v+P3)*v+P2)*v+P1)*v*z; R:=R+K*R; u2:=(R+z*K)+z; u1:=(m*16-p)*OneOver16;
v:=z*z; R:=(((P4*v+P3)*v+P2)*v+P1)*v*z; R:=R+K*R; u2:=(R+z*K)+z; u1:=(m*16-p)*OneOver16;
(* generate w with extra precision calculations *)
y1:=ENTIER(16*exponent)*OneOver16; y2:=exponent-y1; w:=u2*exponent+u1*y2;
w1:=ENTIER(16*w)*OneOver16; w2:=w-w1; w:=w1+u1*y1;
@ -283,14 +283,14 @@ BEGIN
IF iw1>XMAX THEN l.ErrorHandler(Overflow); RETURN huge
ELSIF iw1<XMIN THEN RETURN ZERO (* underflow *)
END;
(* final approximation 2**w2-1 where -0.0625 <= w2 <= 0 *)
IF w2>ZERO THEN INC(iw1); w2:=w2-OneOver16 END; IF iw1<0 THEN i:=0 ELSE i:=1 END;
mp:=div(iw1, 16)+i; pp:=16*mp-iw1;
z:=((((((Q7*w2+Q6)*w2+Q5)*w2+Q4)*w2+Q3)*w2+Q2)*w2+Q1)*w2; z:=a1[pp+1]+a1[pp+1]*z;
mp:=div(iw1, 16)+i; pp:=16*mp-iw1;
z:=((((((Q7*w2+Q6)*w2+Q5)*w2+Q4)*w2+Q3)*w2+Q2)*w2+Q1)*w2; z:=a1[pp+1]+a1[pp+1]*z;
RETURN l.scale(z, SHORT(mp))
END power;
PROCEDURE round*(x: LONGREAL): LONGINT;
(* Returns the value of x rounded to the nearest integer *)
BEGIN
@ -298,7 +298,7 @@ BEGIN
ELSE RETURN ENTIER(x+HALF)
END
END round;
PROCEDURE IsRMathException*(): BOOLEAN;
(* Returns TRUE if the current coroutine is in the exceptional execution state
because of the raising of the RealMath exception; otherwise returns FALSE.
@ -307,15 +307,15 @@ BEGIN
RETURN FALSE
END IsRMathException;
(*
(*
Following routines are provided as extensions to the ISO standard.
They are either used as the basis of other functions or provide
useful functions which are not part of the ISO standard.
useful functions which are not part of the ISO standard.
*)
PROCEDURE log* (x, base: LONGREAL): LONGREAL;
(* log(x,base) is the logarithm of x base b. All positive arguments are
(* log(x,base) is the logarithm of x base b. All positive arguments are
allowed but base > 0 and base # 1. *)
BEGIN
(* log(x, base) = log2(x) / log2(base) *)
@ -324,9 +324,9 @@ BEGIN
END
END log;
PROCEDURE ipower* (x: LONGREAL; base: INTEGER): LONGREAL;
PROCEDURE ipower* (x: LONGREAL; base: INTEGER): LONGREAL;
(* ipower(x, base) returns the x to the integer power base where base*Log2(x) < Log2(Max) *)
VAR y: LONGREAL; neg: BOOLEAN; Exp: LONGINT;
VAR y: LONGREAL; neg: BOOLEAN; Exp: LONGINT;
PROCEDURE Adjust(xadj: LONGREAL): LONGREAL;
BEGIN
@ -336,17 +336,17 @@ PROCEDURE ipower* (x: LONGREAL; base: INTEGER): LONGREAL;
BEGIN
(* handle all possible error conditions *)
IF base=0 THEN RETURN ONE (* x**0 = 1 *)
ELSIF ABS(x)<miny THEN
ELSIF ABS(x)<miny THEN
IF base>0 THEN RETURN ZERO ELSE l.ErrorHandler(Overflow); RETURN Adjust(huge) END
END;
(* trap potential overflows and underflows *)
Exp:=(l.exponent(x)+1)*base; y:=LnInfinity*ln2Inv;
Exp:=(l.exponent(x)+1)*base; y:=LnInfinity*ln2Inv;
IF Exp>y THEN l.ErrorHandler(Overflow); RETURN Adjust(huge)
ELSIF Exp<-y THEN RETURN ZERO
END;
(* compute x**base using an optimised algorithm from Knuth, slightly
END;
(* compute x**base using an optimised algorithm from Knuth, slightly
altered : p442, The Art Of Computer Programming, Vol 2 *)
y:=ONE; IF base<0 THEN neg:=TRUE; base := -base ELSE neg:= FALSE END;
LOOP
@ -355,19 +355,19 @@ BEGIN
x:=x*x;
END;
IF neg THEN RETURN ONE/y ELSE RETURN y END
END ipower;
END ipower;
PROCEDURE sincos* (x: LONGREAL; VAR Sin, Cos: LONGREAL);
(* More efficient sin/cos implementation if both values are needed. *)
BEGIN
Sin:=sin(x); Cos:=sqrt(ONE-Sin*Sin)
END sincos;
END sincos;
PROCEDURE arctan2* (xn, xd: LONGREAL): LONGREAL;
(* arctan2(xn,xd) is the quadrant-correct arc tangent atan(xn/xd). If the
(* arctan2(xn,xd) is the quadrant-correct arc tangent atan(xn/xd). If the
denominator xd is zero, then the numerator xn must not be zero. All
arguments are legal except xn = xd = 0. *)
CONST
CONST
P0=0.216062307897242551884D+3; P1=0.3226620700132512059245D+3;
P2=0.13270239816397674701D+3; P3=0.1288838303415727934D+2;
Q0=0.2160623078972426128957D+3; Q1=0.3946828393122829592162D+3;
@ -387,15 +387,15 @@ BEGIN
IF ABS(xn)>ABS(xd) THEN z:=ABS(xd/xn); Quadrant:=2
ELSE z:=ABS(xn/xd); Quadrant:=0
END;
(* further reduce range to within 0 to 2-sqrt(3) *)
IF z>TWO-Sqrt3 THEN z:=(z*Sqrt3-ONE)/(Sqrt3+z); INC(Quadrant) END;
(* approximation from "Computer Approximations" table ARCTN 5075 *)
IF ABS(z)<Limit THEN atan:=z (* for small values of z2, return this value *)
ELSE z2:=z*z; p:=(((P3*z2+P2)*z2+P1)*z2+P0)*z; q:=(((z2+Q3)*z2+Q2)*z2+Q1)*z2+Q0; atan:=p/q;
END;
(* adjust for z's quadrant *)
IF Quadrant>1 THEN atan:=-atan END;
CASE Quadrant OF
@ -405,20 +405,20 @@ BEGIN
| ELSE (* angle is correct *)
END
END;
(* map negative xds into the correct quadrant *)
IF xd<ZERO THEN atan:=pi-atan END
END;
(* map negative xns into the correct quadrant *)
IF xn<ZERO THEN atan:=-atan END;
RETURN atan
RETURN atan
END arctan2;
PROCEDURE sinh* (x: LONGREAL): LONGREAL;
(* sinh(x) is the hyperbolic sine of x. The argument x must not be so large
(* sinh(x) is the hyperbolic sine of x. The argument x must not be so large
that exp(|x|) overflows. *)
CONST
CONST
P0=-0.35181283430177117881D+6; P1=-0.11563521196851768270D+5;
P2=-0.16375798202630751372D+3; P3=-0.78966127417357099479D+0;
Q0=-0.21108770058106271242D+7; Q1= 0.36162723109421836460D+5;
@ -427,43 +427,43 @@ PROCEDURE sinh* (x: LONGREAL): LONGREAL;
BEGIN y:=ABS(x);
IF y<=ONE THEN (* handle small arguments *)
IF y<Limit THEN RETURN x END;
(* use approximation from "Software Manual for the Elementary Functions" *)
f:=y*y; p:=((P3*f+P2)*f+P1)*f+P0; q:=((f+Q2)*f+Q1)*f+Q0; y:=f*(p/q); RETURN x+x*y
ELSIF y>LnInfinity THEN (* handle exp overflows *)
y:=y-lnv;
IF y>LnInfinity-lnv+0.69 THEN l.ErrorHandler(Overflow);
IF y>LnInfinity-lnv+0.69 THEN l.ErrorHandler(Overflow);
IF x>ZERO THEN RETURN huge ELSE RETURN -huge END
ELSE f:=exp(y); f:=f+f*vbytwo (* don't change to f(1+vbytwo) *)
END
ELSE f:=exp(y); f:=(f-ONE/f)*HALF
END;
(* reach here when 1 < ABS(x) < LnInfinity-lnv+0.69 *)
IF x>ZERO THEN RETURN f ELSE RETURN -f END
(* reach here when 1 < ABS(x) < LnInfinity-lnv+0.69 *)
IF x>ZERO THEN RETURN f ELSE RETURN -f END
END sinh;
PROCEDURE cosh* (x: LONGREAL): LONGREAL;
(* cosh(x) is the hyperbolic cosine of x. The argument x must not be so large
that exp(|x|) overflows. *)
that exp(|x|) overflows. *)
VAR y, f: LONGREAL;
BEGIN y:=ABS(x);
IF y>LnInfinity THEN (* handle exp overflows *)
y:=y-lnv;
IF y>LnInfinity-lnv+0.69 THEN l.ErrorHandler(Overflow);
IF y>LnInfinity-lnv+0.69 THEN l.ErrorHandler(Overflow);
IF x>ZERO THEN RETURN huge ELSE RETURN -huge END
ELSE f:=exp(y); RETURN f+f*vbytwo (* don't change to f(1+vbytwo) *)
END
ELSE f:=exp(y); RETURN (f+ONE/f)*HALF
END
END cosh;
PROCEDURE tanh* (x: LONGREAL): LONGREAL;
(* tanh(x) is the hyperbolic tangent of x. All arguments are legal. *)
CONST
P0=-0.16134119023996228053D+4; P1=-0.99225929672236083313D+2; P2=-0.96437492777225469787D+0;
CONST
P0=-0.16134119023996228053D+4; P1=-0.99225929672236083313D+2; P2=-0.96437492777225469787D+0;
Q0= 0.48402357071988688686D+4; Q1= 0.22337720718962312926D+4; Q2= 0.11274474380534949335D+3;
ln3over2=0.54930614433405484570D0;
ln3over2=0.54930614433405484570D0;
BIG=19.06154747D0; (* (ln(2)+(t+1)*ln(B))/2 where t=mantissa bits, B=base *)
VAR f, t: LONGREAL;
BEGIN f:=ABS(x);
@ -487,7 +487,7 @@ BEGIN
END arcsinh;
PROCEDURE arccosh* (x: LONGREAL): LONGREAL;
(* arccosh(x) is the arc hyperbolic cosine of x. All arguments greater than
(* arccosh(x) is the arc hyperbolic cosine of x. All arguments greater than
or equal to 1 are legal. *)
BEGIN
IF x<ONE THEN l.ErrorHandler(IllegalHypInvTrig); RETURN ZERO
@ -495,10 +495,10 @@ BEGIN
ELSE RETURN ln(x+sqrt(x*x-ONE))
END
END arccosh;
PROCEDURE arctanh* (x: LONGREAL): LONGREAL;
(* arctanh(x) is the arc hyperbolic tangent of x. |x| < 1 - sqrt(em), where
em is machine epsilon. Note that |x| must not be so close to 1 that the
(* arctanh(x) is the arc hyperbolic tangent of x. |x| < 1 - sqrt(em), where
em is machine epsilon. Note that |x| must not be so close to 1 that the
result is less accurate than half precision. *)
CONST TanhLimit=0.999984991D0; (* Tanh(5.9) *)
VAR t: LONGREAL;
@ -510,10 +510,8 @@ BEGIN t:=ABS(x);
RETURN arcsinh(x/sqrt(ONE-x*x))
END arctanh;
PROCEDURE ToLONGREAL (hi, lo: LONGINT): LONGREAL;
VAR ra: ARRAY 2 OF LONGINT;
BEGIN ra[0]:=hi; ra[1]:=lo;
RETURN l.Real(ra)
PROCEDURE ToLONGREAL(h: HUGEINT): LONGREAL;
BEGIN RETURN SYSTEM.VAL(LONGREAL, h)
END ToLONGREAL;
BEGIN
@ -523,38 +521,38 @@ BEGIN
LnSmall:=ln(miny);
SqrtInfinity:=sqrt(huge);
t:=l.pred(ONE)/sqrt(em); TanhMax:=ln(t+sqrt(t*t+ONE));
(* initialize some tables for the power() function a1[i]=2**((1-i)/16) *)
(* disable compiler warnings about 32-bit negative integers *)
(*<* PUSH; Warnings := FALSE *>*)
a1[ 1]:=ONE;
a1[ 2]:=ToLONGREAL(3FEEA4AFH, 0A2A490DAH);
a1[ 3]:=ToLONGREAL(3FED5818H, 0DCFBA487H);
a1[ 4]:=ToLONGREAL(3FEC199BH, 0DD85529CH);
a1[ 5]:=ToLONGREAL(3FEAE89FH, 0995AD3ADH);
a1[ 6]:=ToLONGREAL(3FE9C491H, 082A3F090H);
a1[ 7]:=ToLONGREAL(3FE8ACE5H, 0422AA0DBH);
a1[ 8]:=ToLONGREAL(3FE7A114H, 073EB0186H);
a1[ 9]:=ToLONGREAL(3FE6A09EH, 0667F3BCCH);
a1[10]:=ToLONGREAL(3FE5AB07H, 0DD485429H);
a1[11]:=ToLONGREAL(3FE4BFDAH, 0D5362A27H);
a1[12]:=ToLONGREAL(3FE3DEA6H, 04C123422H);
a1[13]:=ToLONGREAL(3FE306FEH, 00A31B715H);
a1[14]:=ToLONGREAL(3FE2387AH, 06E756238H);
a1[15]:=ToLONGREAL(3FE172B8H, 03C7D517AH);
a1[16]:=ToLONGREAL(3FE0B558H, 06CF9890FH);
a1[17]:=HALF;
a1[ 1] := ONE;
a1[ 2] := ToLONGREAL(3FEEA4AFA2A490DAH); (* ToLONGREAL(3FEEA4AFH, 0A2A490DAH); *)
a1[ 3] := ToLONGREAL(3FED5818DCFBA487H); (* ToLONGREAL(3FED5818H, 0DCFBA487H); *)
a1[ 4] := ToLONGREAL(3FEC199BDD85529CH); (* ToLONGREAL(3FEC199BH, 0DD85529CH); *)
a1[ 5] := ToLONGREAL(3FEAE89F995AD3ADH); (* ToLONGREAL(3FEAE89FH, 0995AD3ADH); *)
a1[ 6] := ToLONGREAL(3FE9C49182A3F090H); (* ToLONGREAL(3FE9C491H, 082A3F090H); *)
a1[ 7] := ToLONGREAL(3FE8ACE5422AA0DBH); (* ToLONGREAL(3FE8ACE5H, 0422AA0DBH); *)
a1[ 8] := ToLONGREAL(3FE7A11473EB0186H); (* ToLONGREAL(3FE7A114H, 073EB0186H); *)
a1[ 9] := ToLONGREAL(3FE6A09E667F3BCCH); (* ToLONGREAL(3FE6A09EH, 0667F3BCCH); *)
a1[10] := ToLONGREAL(3FE5AB07DD485429H); (* ToLONGREAL(3FE5AB07H, 0DD485429H); *)
a1[11] := ToLONGREAL(3FE4BFDAD5362A27H); (* ToLONGREAL(3FE4BFDAH, 0D5362A27H); *)
a1[12] := ToLONGREAL(3FE3DEA64C123422H); (* ToLONGREAL(3FE3DEA6H, 04C123422H); *)
a1[13] := ToLONGREAL(3FE306FE0A31B715H); (* ToLONGREAL(3FE306FEH, 00A31B715H); *)
a1[14] := ToLONGREAL(3FE2387A6E756238H); (* ToLONGREAL(3FE2387AH, 06E756238H); *)
a1[15] := ToLONGREAL(3FE172B83C7D517AH); (* ToLONGREAL(3FE172B8H, 03C7D517AH); *)
a1[16] := ToLONGREAL(3FE0B5586CF9890FH); (* ToLONGREAL(3FE0B558H, 06CF9890FH); *)
a1[17] := HALF;
(* a2[i]=2**[(1-2i)/16] - a1[2i]; delta resolution *)
a2[1]:=ToLONGREAL(3C90B1EEH, 074320000H);
a2[2]:=ToLONGREAL(3C711065H, 089500000H);
a2[3]:=ToLONGREAL(3C6C7C46H, 0B0700000H);
a2[4]:=ToLONGREAL(3C9AFAA2H, 0047F0000H);
a2[5]:=ToLONGREAL(3C86324CH, 005460000H);
a2[6]:=ToLONGREAL(3C7ADA09H, 011F00000H);
a2[7]:=ToLONGREAL(3C89B07EH, 0B6C80000H);
a2[8]:=ToLONGREAL(3C88A62EH, 04ADC0000H);
a2[1] := ToLONGREAL(3C90B1EE74320000H); (* ToLONGREAL(3C90B1EEH, 074320000H); *)
a2[2] := ToLONGREAL(3C71106589500000H); (* ToLONGREAL(3C711065H, 089500000H); *)
a2[3] := ToLONGREAL(3C6C7C46B0700000H); (* ToLONGREAL(3C6C7C46H, 0B0700000H); *)
a2[4] := ToLONGREAL(3C9AFAA2047F0000H); (* ToLONGREAL(3C9AFAA2H, 0047F0000H); *)
a2[5] := ToLONGREAL(3C86324C05460000H); (* ToLONGREAL(3C86324CH, 005460000H); *)
a2[6] := ToLONGREAL(3C7ADA0911F00000H); (* ToLONGREAL(3C7ADA09H, 011F00000H); *)
a2[7] := ToLONGREAL(3C89B07EB6C80000H); (* ToLONGREAL(3C89B07EH, 0B6C80000H); *)
a2[8] := ToLONGREAL(3C88A62E4ADC0000H); (* ToLONGREAL(3C88A62EH, 04ADC0000H); *)
(* reenable compiler warnings *)
(*<* POP *>*)
END oocLRealMath.

4
src/library/ooc/oocLowReal.Mod
View file

@ -216,7 +216,7 @@ BEGIN
IF x<ZERO THEN RETURN -ONE ELSE RETURN ONE END
END sign;
(*** Refactor for 64 bit support.
PROCEDURE scale*(x: REAL; n: INTEGER): REAL;
(*
The value of the call scale(x,n) shall be the value x*radix^n if such
@ -335,7 +335,7 @@ PROCEDURE synthesize*(expart: INTEGER; frapart: REAL): REAL;
BEGIN
RETURN scale(frapart, expart)
END synthesize;
*)
PROCEDURE setMode*(m: Modes);
(*

138
src/library/s3/ethReals.Mod
View file

@ -3,10 +3,10 @@ Refer to the "General ETH Oberon System Source License" contract available at: h
MODULE ethReals; (** portable *)
(** Implementation of the non-portable components of IEEE REAL and
LONGREAL manipulation. The routines here are required to do conversion
of reals to strings and back.
Implemented by Bernd Moesli, Seminar for Applied Mathematics,
(** Implementation of the non-portable components of IEEE REAL and
LONGREAL manipulation. The routines here are required to do conversion
of reals to strings and back.
Implemented by Bernd Moesli, Seminar for Applied Mathematics,
Swiss Federal Institute of Technology Z…rich.
*)
@ -100,7 +100,7 @@ END SetExpoL;
(** Convert hexadecimal to REAL. *)
PROCEDURE Real* (h: LONGINT): REAL;
VAR x: REAL;
BEGIN
BEGIN
IF SIZE(LONGINT) = 4 THEN
SYSTEM.PUT(SYSTEM.ADR(x), h)
ELSIF SIZE(INTEGER) = 4 THEN
@ -113,12 +113,12 @@ END Real;
(** Convert hexadecimal to LONGREAL. h and l are the high and low parts.*)
PROCEDURE RealL* (h, l: LONGINT): LONGREAL;
VAR x: LONGREAL;
BEGIN
BEGIN
IF SIZE(LONGINT) = 4 THEN
SYSTEM.PUT(SYSTEM.ADR(x) + H, h);
SYSTEM.PUT(SYSTEM.ADR(x) + H, h);
SYSTEM.PUT(SYSTEM.ADR(x) + L, l)
ELSIF SIZE(INTEGER) = 4 THEN
SYSTEM.PUT(SYSTEM.ADR(x) + H, SYSTEM.VAL(INTEGER, h));
SYSTEM.PUT(SYSTEM.ADR(x) + H, SYSTEM.VAL(INTEGER, h));
SYSTEM.PUT(SYSTEM.ADR(x) + L, SYSTEM.VAL(INTEGER, l))
ELSE Platform.Halt(-15)
END;
@ -128,7 +128,7 @@ END RealL;
(** Convert REAL to hexadecimal. *)
PROCEDURE Int* (x: REAL): LONGINT;
VAR i: INTEGER; l: LONGINT;
BEGIN
BEGIN
IF SIZE(LONGINT) = 4 THEN
SYSTEM.PUT(SYSTEM.ADR(l), x); RETURN l
ELSIF SIZE(INTEGER) = 4 THEN
@ -140,12 +140,12 @@ END Int;
(** Convert LONGREAL to hexadecimal. h and l are the high and low parts. *)
PROCEDURE IntL* (x: LONGREAL; VAR h, l: LONGINT);
VAR i: INTEGER;
BEGIN
BEGIN
IF SIZE(LONGINT) = 4 THEN
SYSTEM.GET(SYSTEM.ADR(x) + H, h);
SYSTEM.GET(SYSTEM.ADR(x) + H, h);
SYSTEM.GET(SYSTEM.ADR(x) + L, l)
ELSIF SIZE(INTEGER) = 4 THEN
SYSTEM.GET(SYSTEM.ADR(x) + H, i); h := i;
SYSTEM.GET(SYSTEM.ADR(x) + H, i); h := i;
SYSTEM.GET(SYSTEM.ADR(x) + L, i); l := i
ELSE Platform.Halt(-15)
END
@ -218,69 +218,63 @@ BEGIN
END SetFCR;
*)
PROCEDURE RealX (h, l: LONGINT; adr: LONGINT);
BEGIN
IF SIZE(LONGINT) = 4 THEN
SYSTEM.PUT(adr + H, h); SYSTEM.PUT(adr + L, l);
ELSIF SIZE(INTEGER) = 4 THEN
SYSTEM.PUT(adr + H, SYSTEM.VAL(INTEGER, h));
SYSTEM.PUT(adr + L, SYSTEM.VAL(INTEGER, l));
ELSE Platform.Halt(-15)
END
PROCEDURE RealX (v: HUGEINT; VAR lr: LONGREAL);
BEGIN lr := SYSTEM.VAL(LONGREAL, v)
END RealX;
BEGIN
RealX(03FF00000H, 000000000H, SYSTEM.ADR(tene[0]));
RealX(040240000H, 000000000H, SYSTEM.ADR(tene[1])); (* 1 *)
RealX(040590000H, 000000000H, SYSTEM.ADR(tene[2])); (* 2 *)
RealX(0408F4000H, 000000000H, SYSTEM.ADR(tene[3])); (* 3 *)
RealX(040C38800H, 000000000H, SYSTEM.ADR(tene[4])); (* 4 *)
RealX(040F86A00H, 000000000H, SYSTEM.ADR(tene[5])); (* 5 *)
RealX(0412E8480H, 000000000H, SYSTEM.ADR(tene[6])); (* 6 *)
RealX(0416312D0H, 000000000H, SYSTEM.ADR(tene[7])); (* 7 *)
RealX(04197D784H, 000000000H, SYSTEM.ADR(tene[8])); (* 8 *)
RealX(041CDCD65H, 000000000H, SYSTEM.ADR(tene[9])); (* 9 *)
RealX(04202A05FH, 020000000H, SYSTEM.ADR(tene[10])); (* 10 *)
RealX(042374876H, 0E8000000H, SYSTEM.ADR(tene[11])); (* 11 *)
RealX(0426D1A94H, 0A2000000H, SYSTEM.ADR(tene[12])); (* 12 *)
RealX(042A2309CH, 0E5400000H, SYSTEM.ADR(tene[13])); (* 13 *)
RealX(042D6BCC4H, 01E900000H, SYSTEM.ADR(tene[14])); (* 14 *)
RealX(0430C6BF5H, 026340000H, SYSTEM.ADR(tene[15])); (* 15 *)
RealX(04341C379H, 037E08000H, SYSTEM.ADR(tene[16])); (* 16 *)
RealX(043763457H, 085D8A000H, SYSTEM.ADR(tene[17])); (* 17 *)
RealX(043ABC16DH, 0674EC800H, SYSTEM.ADR(tene[18])); (* 18 *)
RealX(043E158E4H, 060913D00H, SYSTEM.ADR(tene[19])); (* 19 *)
RealX(04415AF1DH, 078B58C40H, SYSTEM.ADR(tene[20])); (* 20 *)
RealX(0444B1AE4H, 0D6E2EF50H, SYSTEM.ADR(tene[21])); (* 21 *)
RealX(04480F0CFH, 0064DD592H, SYSTEM.ADR(tene[22])); (* 22 *)
RealX(00031FA18H, 02C40C60DH, SYSTEM.ADR(ten[0])); (* -307 *)
RealX(004F7CAD2H, 03DE82D7BH, SYSTEM.ADR(ten[1])); (* -284 *)
RealX(009BF7D22H, 08322BAF5H, SYSTEM.ADR(ten[2])); (* -261 *)
RealX(00E84D669H, 05B193BF8H, SYSTEM.ADR(ten[3])); (* -238 *)
RealX(0134B9408H, 0EEFEA839H, SYSTEM.ADR(ten[4])); (* -215 *)
RealX(018123FF0H, 06EEA847AH, SYSTEM.ADR(ten[5])); (* -192 *)
RealX(01CD82742H, 091C6065BH, SYSTEM.ADR(ten[6])); (* -169 *)
RealX(0219FF779H, 0FD329CB9H, SYSTEM.ADR(ten[7])); (* -146 *)
RealX(02665275EH, 0D8D8F36CH, SYSTEM.ADR(ten[8])); (* -123 *)
RealX(02B2BFF2EH, 0E48E0530H, SYSTEM.ADR(ten[9])); (* -100 *)
RealX(02FF286D8H, 00EC190DCH, SYSTEM.ADR(ten[10])); (* -77 *)
RealX(034B8851AH, 00B548EA4H, SYSTEM.ADR(ten[11])); (* -54 *)
RealX(0398039D6H, 065896880H, SYSTEM.ADR(ten[12])); (* -31 *)
RealX(03E45798EH, 0E2308C3AH, SYSTEM.ADR(ten[13])); (* -8 *)
RealX(0430C6BF5H, 026340000H, SYSTEM.ADR(ten[14])); (* 15 *)
RealX(047D2CED3H, 02A16A1B1H, SYSTEM.ADR(ten[15])); (* 38 *)
RealX(04C98E45EH, 01DF3B015H, SYSTEM.ADR(ten[16])); (* 61 *)
RealX(0516078E1H, 011C3556DH, SYSTEM.ADR(ten[17])); (* 84 *)
RealX(05625CCFEH, 03D35D80EH, SYSTEM.ADR(ten[18])); (* 107 *)
RealX(05AECDA62H, 0055B2D9EH, SYSTEM.ADR(ten[19])); (* 130 *)
RealX(05FB317E5H, 0EF3AB327H, SYSTEM.ADR(ten[20])); (* 153 *)
RealX(064794514H, 05230B378H, SYSTEM.ADR(ten[21])); (* 176 *)
RealX(06940B8E0H, 0ACAC4EAFH, SYSTEM.ADR(ten[22])); (* 199 *)
RealX(06E0621B1H, 0C28AC20CH, SYSTEM.ADR(ten[23])); (* 222 *)
RealX(072CD4A7BH, 0EBFA31ABH, SYSTEM.ADR(ten[24])); (* 245 *)
RealX(077936214H, 09CBD3226H, SYSTEM.ADR(ten[25])); (* 268 *)
RealX(07C59A742H, 0461887F6H, SYSTEM.ADR(ten[26])); (* 291 *)
RealX(03FF0000000000000H, tene[0]);
RealX(04024000000000000H, tene[1]); (* 1 *)
RealX(04059000000000000H, tene[2]); (* 2 *)
RealX(0408F400000000000H, tene[3]); (* 3 *)
RealX(040C3880000000000H, tene[4]); (* 4 *)
RealX(040F86A0000000000H, tene[5]); (* 5 *)
RealX(0412E848000000000H, tene[6]); (* 6 *)
RealX(0416312D000000000H, tene[7]); (* 7 *)
RealX(04197D78400000000H, tene[8]); (* 8 *)
RealX(041CDCD6500000000H, tene[9]); (* 9 *)
RealX(04202A05F20000000H, tene[10]); (* 10 *)
RealX(042374876E8000000H, tene[11]); (* 11 *)
RealX(0426D1A94A2000000H, tene[12]); (* 12 *)
RealX(042A2309CE5400000H, tene[13]); (* 13 *)
RealX(042D6BCC41E900000H, tene[14]); (* 14 *)
RealX(0430C6BF526340000H, tene[15]); (* 15 *)
RealX(04341C37937E08000H, tene[16]); (* 16 *)
RealX(04376345785D8A000H, tene[17]); (* 17 *)
RealX(043ABC16D674EC800H, tene[18]); (* 18 *)
RealX(043E158E460913D00H, tene[19]); (* 19 *)
RealX(04415AF1D78B58C40H, tene[20]); (* 20 *)
RealX(0444B1AE4D6E2EF50H, tene[21]); (* 21 *)
RealX(04480F0CF064DD592H, tene[22]); (* 22 *)
RealX(00031FA182C40C60DH, ten[0]); (* -307 *)
RealX(004F7CAD23DE82D7BH, ten[1]); (* -284 *)
RealX(009BF7D228322BAF5H, ten[2]); (* -261 *)
RealX(00E84D6695B193BF8H, ten[3]); (* -238 *)
RealX(0134B9408EEFEA839H, ten[4]); (* -215 *)
RealX(018123FF06EEA847AH, ten[5]); (* -192 *)
RealX(01CD8274291C6065BH, ten[6]); (* -169 *)
RealX(0219FF779FD329CB9H, ten[7]); (* -146 *)
RealX(02665275ED8D8F36CH, ten[8]); (* -123 *)
RealX(02B2BFF2EE48E0530H, ten[9]); (* -100 *)
RealX(02FF286D80EC190DCH, ten[10]); (* -77 *)
RealX(034B8851A0B548EA4H, ten[11]); (* -54 *)
RealX(0398039D665896880H, ten[12]); (* -31 *)
RealX(03E45798EE2308C3AH, ten[13]); (* -8 *)
RealX(0430C6BF526340000H, ten[14]); (* 15 *)
RealX(047D2CED32A16A1B1H, ten[15]); (* 38 *)
RealX(04C98E45E1DF3B015H, ten[16]); (* 61 *)
RealX(0516078E111C3556DH, ten[17]); (* 84 *)
RealX(05625CCFE3D35D80EH, ten[18]); (* 107 *)
RealX(05AECDA62055B2D9EH, ten[19]); (* 130 *)
RealX(05FB317E5EF3AB327H, ten[20]); (* 153 *)
RealX(0647945145230B378H, ten[21]); (* 176 *)
RealX(06940B8E0ACAC4EAFH, ten[22]); (* 199 *)
RealX(06E0621B1C28AC20CH, ten[23]); (* 222 *)
RealX(072CD4A7BEBFA31ABH, ten[24]); (* 245 *)
RealX(0779362149CBD3226H, ten[25]); (* 268 *)
RealX(07C59A742461887F6H, ten[26]); (* 291 *)
eq[0]:= {0, 3, 4, 5, 9, 16, 23, 25, 26, 28, 31};
eq[1]:= {2, 5, 6, 8, 9, 10, 11, 12, 13, 14, 15, 17, 18, 19, 20, 21, 23, 24, 25, 27, 28, 29, 30, 31};

106
src/library/ulm/ulmCipherOps.Mod
View file

@ -1,67 +1,69 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1997 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.
Copyright (C) 1989-1997 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.
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: CipherOps.om,v 1.1 1997/04/02 11:53:20 borchert Exp borchert $
----------------------------------------------------------------------------
$Log: CipherOps.om,v $
Revision 1.1 1997/04/02 11:53:20 borchert
Initial revision
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: CipherOps.om,v 1.1 1997/04/02 11:53:20 borchert Exp borchert $
----------------------------------------------------------------------------
$Log: CipherOps.om,v $
Revision 1.1 1997/04/02 11:53:20 borchert
Initial revision
----------------------------------------------------------------------------
----------------------------------------------------------------------------
*)
MODULE ulmCipherOps; (* Michael Szczuka *)
(* useful functions for stream ciphers *)
(* useful functions for stream ciphers *)
IMPORT Streams := ulmStreams, SYS := SYSTEM, Write := ulmWrite;
IMPORT Streams := ulmStreams, SYS := SYSTEM, Write := ulmWrite;
PROCEDURE XorByte* (b1, b2: SYS.BYTE) : SYS.BYTE;
(* adds two bytes bitwise modulo 2 *)
BEGIN
RETURN SYS.VAL(SYS.BYTE, SYS.VAL(SET, b1) / SYS.VAL(SET, b2))
END XorByte;
PROCEDURE XorByte* (b1, b2: SYS.BYTE) : SYS.BYTE;
(* adds two bytes bitwise modulo 2 *)
BEGIN
(*RETURN SYS.VAL(SYS.BYTE, SYS.VAL(SET, LONG(b1)) / SYS.VAL(SET, LONG(b2)))*)
RETURN SYS.VAL(SYS.BYTE, SYS.VAL(SET, LONG(LONG(SYS.VAL(SHORTINT, b1))))
/ SYS.VAL(SET, LONG(LONG(SYS.VAL(SHORTINT, b2)))))
END XorByte;
PROCEDURE XorStream* (in1, in2, out: Streams.Stream;
length: INTEGER) : BOOLEAN;
(* adds two streams bitwise modulo 2; restricted to length bytes *)
VAR
b1, b2, res : SYS.BYTE;
wholeStream : BOOLEAN;
BEGIN
IF length < 0 THEN
wholeStream := TRUE;
PROCEDURE XorStream* (in1, in2, out: Streams.Stream;
length: INTEGER) : BOOLEAN;
(* adds two streams bitwise modulo 2; restricted to length bytes *)
VAR
b1, b2, res : SYS.BYTE;
wholeStream : BOOLEAN;
BEGIN
IF length < 0 THEN
wholeStream := TRUE;
ELSE
wholeStream := FALSE;
END;
WHILE wholeStream OR (length > 0) DO
IF Streams.ReadByte(in1, b1) & Streams.ReadByte(in2, b2) THEN
res := XorByte(b1, b2);
IF ~Streams.WriteByte(out, res) THEN
RETURN FALSE
END;
ELSE
wholeStream := FALSE;
RETURN wholeStream
END;
WHILE wholeStream OR (length > 0) DO
IF Streams.ReadByte(in1, b1) & Streams.ReadByte(in2, b2) THEN
res := XorByte(b1, b2);
IF ~Streams.WriteByte(out, res) THEN
RETURN FALSE
END;
ELSE
RETURN wholeStream
END;
DEC(length);
END;
RETURN TRUE
END XorStream;
DEC(length);
END;
RETURN TRUE
END XorStream;
END ulmCipherOps.

28
src/library/ulm/ulmCiphers.Mod
View file

@ -29,15 +29,15 @@
(* abstraction for the use of ciphers and cryptographic methods *)
MODULE ulmCiphers;
IMPORT Objects := ulmObjects, PersistentObjects := ulmPersistentObjects, PersistentDisciplines := ulmPersistentDisciplines, Services := ulmServices,
IMPORT Objects := ulmObjects, PersistentObjects := ulmPersistentObjects, PersistentDisciplines := ulmPersistentDisciplines, Services := ulmServices,
Streams := ulmStreams, Write := ulmWrite;
TYPE
Cipher* = POINTER TO CipherRec;
TYPE
CryptProc* = PROCEDURE (in: Streams.Stream; key: Cipher;
length: INTEGER; out: Streams.Stream) : BOOLEAN;
TYPE
CryptProc* = PROCEDURE (in: Streams.Stream; key: Cipher;
length: INTEGER; out: Streams.Stream) : BOOLEAN;
TYPE
Interface* = POINTER TO InterfaceRec;
@ -48,7 +48,7 @@ TYPE
END;
TYPE
CipherRec* = RECORD
CipherRec* = RECORD
(PersistentDisciplines.ObjectRec)
(* private *)
if : Interface
@ -64,31 +64,31 @@ BEGIN
key.if := if;
END Init;
PROCEDURE Encrypt*(in: Streams.Stream; key: Cipher;
out: Streams.Stream) : BOOLEAN;
PROCEDURE Encrypt*(in: Streams.Stream; key: Cipher;
out: Streams.Stream) : BOOLEAN;
BEGIN
RETURN key.if.encrypt(in, key, -1, out);
END Encrypt;
PROCEDURE Decrypt*(in: Streams.Stream; key: Cipher;
out: Streams.Stream) : BOOLEAN;
PROCEDURE Decrypt*(in: Streams.Stream; key: Cipher;
out: Streams.Stream) : BOOLEAN;
BEGIN
RETURN key.if.decrypt(in, key, -1, out);
END Decrypt;
PROCEDURE EncryptPart*(in: Streams.Stream; key: Cipher;
length: INTEGER; out: Streams.Stream) : BOOLEAN;
PROCEDURE EncryptPart*(in: Streams.Stream; key: Cipher;
length: INTEGER; out: Streams.Stream) : BOOLEAN;
BEGIN
RETURN key.if.encrypt(in, key, length, out);
END EncryptPart;
PROCEDURE DecryptPart*(in: Streams.Stream; key: Cipher;
length: INTEGER; out: Streams.Stream) : BOOLEAN;
PROCEDURE DecryptPart*(in: Streams.Stream; key: Cipher;
length: INTEGER; out: Streams.Stream) : BOOLEAN;
BEGIN
RETURN key.if.decrypt(in, key, length, out);
END DecryptPart;
BEGIN
PersistentObjects.RegisterType(cipherType, "Ciphers.Cipher",
PersistentObjects.RegisterType(cipherType, "Ciphers.Cipher",
"PersistentDisciplines.Object", NIL);
END ulmCiphers.

238
src/library/ulm/ulmDisciplines.Mod
View file

@ -1,140 +1,140 @@
(* 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.
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.
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: Disciplines.om,v 1.1 1994/02/22 20:07:03 borchert Exp $
----------------------------------------------------------------------------
$Log: Disciplines.om,v $
Revision 1.1 1994/02/22 20:07:03 borchert
Initial revision
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: Disciplines.om,v 1.1 1994/02/22 20:07:03 borchert Exp $
----------------------------------------------------------------------------
$Log: Disciplines.om,v $
Revision 1.1 1994/02/22 20:07:03 borchert
Initial revision
----------------------------------------------------------------------------
AFB 5/91
----------------------------------------------------------------------------
----------------------------------------------------------------------------
AFB 5/91
----------------------------------------------------------------------------
*)
MODULE ulmDisciplines;
(* Disciplines allows to attach additional data structures to
abstract datatypes like Streams;
these added data structures permit to parametrize operations
which are provided by other modules (e.g. Read or Write for Streams)
*)
(* Disciplines allows to attach additional data structures to
abstract datatypes like Streams;
these added data structures permit to parametrize operations
which are provided by other modules (e.g. Read or Write for Streams)
*)
IMPORT Objects := ulmObjects;
IMPORT Objects := ulmObjects;
TYPE
Identifier* = LONGINT;
TYPE
Identifier* = LONGINT;
Discipline* = POINTER TO DisciplineRec;
DisciplineRec* =
RECORD
(Objects.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;
Object* = POINTER TO ObjectRec;
ObjectRec* =
RECORD
(Objects.ObjectRec)
(* private part *)
list: DisciplineList; (* set of disciplines *)
END;
VAR
unique: Identifier;
PROCEDURE Unique*() : Identifier;
(* returns a unique identifier;
this procedure should be called during initialization by
all modules defining a discipline type
*)
BEGIN
INC(unique);
RETURN unique
END Unique;
PROCEDURE Remove*(object: Object; id: Identifier);
(* remove the discipline with the given id from object, if it exists *)
VAR
prev, dl: DisciplineList;
BEGIN
prev := NIL;
dl := object.list;
WHILE (dl # NIL) & (dl.id # id) DO
prev := dl; dl := dl.next;
Discipline* = POINTER TO DisciplineRec;
DisciplineRec* =
RECORD
(Objects.ObjectRec)
id*: Identifier; (* should be unique for all types of disciplines *)
END;
IF dl # NIL THEN
IF prev = NIL THEN
object.list := dl.next;
ELSE
prev.next := dl.next;
END;
END;
END Remove;
PROCEDURE Add*(object: 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
dl: DisciplineList;
BEGIN
dl := object.list;
WHILE (dl # NIL) & (dl.id # discipline.id) DO
dl := dl.next;
DisciplineList = POINTER TO DisciplineListRec;
DisciplineListRec =
RECORD
discipline: Discipline;
id: Identifier; (* copied from discipline.id *)
next: DisciplineList;
END;
IF dl = NIL THEN
NEW(dl);
dl.id := discipline.id;
dl.next := object.list;
object.list := dl;
END;
dl.discipline := discipline;
END Add;
PROCEDURE Seek*(object: Object; id: Identifier;
VAR discipline: Discipline) : BOOLEAN;
(* returns TRUE if a discipline with the given id is found *)
VAR
dl: DisciplineList;
BEGIN
dl := object.list;
WHILE (dl # NIL) & (dl.id # id) DO
dl := dl.next;
Object* = POINTER TO ObjectRec;
ObjectRec* =
RECORD
(Objects.ObjectRec)
(* private part *)
list: DisciplineList; (* set of disciplines *)
END;
IF dl # NIL THEN
discipline := dl.discipline;
VAR
unique: Identifier;
PROCEDURE Unique*() : Identifier;
(* returns a unique identifier;
this procedure should be called during initialization by
all modules defining a discipline type
*)
BEGIN
INC(unique);
RETURN unique
END Unique;
PROCEDURE Remove*(object: Object; id: Identifier);
(* remove the discipline with the given id from object, if it exists *)
VAR
prev, dl: DisciplineList;
BEGIN
prev := NIL;
dl := object.list;
WHILE (dl # NIL) & (dl.id # id) DO
prev := dl; dl := dl.next;
END;
IF dl # NIL THEN
IF prev = NIL THEN
object.list := dl.next;
ELSE
discipline := NIL;
prev.next := dl.next;
END;
RETURN discipline # NIL
END Seek;
END;
END Remove;
PROCEDURE Add*(object: 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
dl: DisciplineList;
BEGIN
dl := object.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 := object.list;
object.list := dl;
END;
dl.discipline := discipline;
END Add;
PROCEDURE Seek*(object: Object; id: Identifier;
VAR discipline: Discipline) : BOOLEAN;
(* returns TRUE if a discipline with the given id is found *)
VAR
dl: DisciplineList;
BEGIN
dl := object.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
END Seek;
BEGIN
unique := 0;
unique := 0;
END ulmDisciplines.

281
src/library/ulm/ulmErrors.Mod
View file

@ -1,158 +1,161 @@
(* 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.
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.
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: Errors.om,v 1.2 1994/07/18 14:16:33 borchert Exp $
----------------------------------------------------------------------------
$Log: Errors.om,v $
Revision 1.2 1994/07/18 14:16:33 borchert
unused variables of Write (ch & index) removed
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: Errors.om,v 1.2 1994/07/18 14:16:33 borchert Exp $
----------------------------------------------------------------------------
$Log: Errors.om,v $
Revision 1.2 1994/07/18 14:16:33 borchert
unused variables of Write (ch & index) removed
Revision 1.1 1994/02/22 20:07:15 borchert
Initial revision
Revision 1.1 1994/02/22 20:07:15 borchert
Initial revision
----------------------------------------------------------------------------
AFB 11/91
----------------------------------------------------------------------------
----------------------------------------------------------------------------
AFB 11/91
----------------------------------------------------------------------------
*)
MODULE ulmErrors;
(* translate events to errors *)
(* translate events to errors *)
IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Objects := ulmObjects, RelatedEvents := ulmRelatedEvents, Streams := ulmStreams, Strings := ulmStrings,
SYS := SYSTEM;
IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Objects := ulmObjects, RelatedEvents := ulmRelatedEvents, Streams := ulmStreams, Strings := ulmStrings,
SYS := SYSTEM;
CONST
(* Kind = (debug, message, warning, error, fatal, bug) *)
debug* = 0;
message* = 1;
warning* = 2;
error* = 3;
fatal* = 4;
bug* = 5;
nkinds* = 6;
TYPE
Kind* = SHORTINT; (* debug..bug *)
VAR
kindText*: ARRAY nkinds OF ARRAY 12 OF CHAR;
CONST
(* Kind = (debug, message, warning, error, fatal, bug) *)
debug* = 0;
message* = 1;
warning* = 2;
error* = 3;
fatal* = 4;
bug* = 5;
nkinds* = 6;
TYPE
Kind* = SHORTINT; (* debug..bug *)
VAR
kindText*: ARRAY nkinds OF ARRAY 12 OF CHAR;
TYPE
Handler* = PROCEDURE (event: Events.Event; kind: Kind);
HandlerSet* = POINTER TO HandlerSetRec;
HandlerSetRec* =
RECORD
(Disciplines.ObjectRec)
(* private components *)
handlerSet: SET; (* set of installed handlers *)
handler: ARRAY nkinds OF Handler;
END;
(* ========== write discipline ========================================= *)
TYPE
WriteProcedure* = PROCEDURE (s: Streams.Stream; event: Events.Event);
WriteDiscipline = POINTER TO WriteDisciplineRec;
WriteDisciplineRec =
RECORD
(Disciplines.DisciplineRec)
write: WriteProcedure;
END;
VAR
writeDiscId: Disciplines.Identifier;
(* ========== handler discipline ======================================= *)
TYPE
HandlerDiscipline = POINTER TO HandlerDisciplineRec;
HandlerDisciplineRec =
RECORD
(Disciplines.DisciplineRec)
hs: HandlerSet;
kind: Kind;
END;
VAR
handlerDiscId: Disciplines.Identifier;
VAR
null*: HandlerSet; (* empty handler set *)
PROCEDURE CreateHandlerSet*(VAR hs: HandlerSet);
BEGIN
NEW(hs); hs.handlerSet := {};
END CreateHandlerSet;
PROCEDURE InstallHandler*(hs: HandlerSet; kind: Kind; handler: Handler);
BEGIN
hs.handler[kind] := handler;
INCL(hs.handlerSet, kind);
END InstallHandler;
PROCEDURE AssignWriteProcedure*(eventType: Events.EventType;
write: WriteProcedure);
VAR
writeDiscipline: WriteDiscipline;
BEGIN
NEW(writeDiscipline);
writeDiscipline.id := writeDiscId;
writeDiscipline.write := write;
Disciplines.Add(eventType, writeDiscipline);
END AssignWriteProcedure;
PROCEDURE Write*(s: Streams.Stream; event: Events.Event);
VAR
writeDiscipline: WriteDiscipline;
BEGIN
IF Disciplines.Seek(event.type, writeDiscId, SYS.VAL(Disciplines.Discipline, writeDiscipline)) THEN
writeDiscipline.write(s, event);
ELSE
IF ~Streams.WritePart(s, event.message, 0,
Strings.Len(event.message)) THEN
END;
TYPE
Handler* = PROCEDURE (event: Events.Event; kind: Kind);
HandlerSet* = POINTER TO HandlerSetRec;
HandlerSetRec* =
RECORD
(Disciplines.ObjectRec)
(* private components *)
handlerSet: SET; (* set of installed handlers *)
handler: ARRAY nkinds OF Handler;
END;
END Write;
PROCEDURE GeneralEventHandler(event: Events.Event);
VAR
disc: HandlerDiscipline;
BEGIN
IF Disciplines.Seek(event.type, handlerDiscId, SYS.VAL(Disciplines.Discipline, disc)) &
(disc.kind IN disc.hs.handlerSet) THEN
disc.hs.handler[disc.kind](event, disc.kind);
(* ========== write discipline ========================================= *)
TYPE
WriteProcedure* = PROCEDURE (s: Streams.Stream; event: Events.Event);
WriteDiscipline = POINTER TO WriteDisciplineRec;
WriteDisciplineRec =
RECORD
(Disciplines.DisciplineRec)
write: WriteProcedure;
END;
END GeneralEventHandler;
VAR
writeDiscId: Disciplines.Identifier;
PROCEDURE CatchEvent*(hs: HandlerSet; kind: Kind; type: Events.EventType);
VAR
handlerDiscipline: HandlerDiscipline;
BEGIN
NEW(handlerDiscipline); handlerDiscipline.id := handlerDiscId;
handlerDiscipline.hs := hs; handlerDiscipline.kind := kind;
Disciplines.Add(type, handlerDiscipline);
Events.Handler(type, GeneralEventHandler);
END CatchEvent;
(* ========== handler discipline ======================================= *)
TYPE
HandlerDiscipline = POINTER TO HandlerDisciplineRec;
HandlerDisciplineRec =
RECORD
(Disciplines.DisciplineRec)
hs: HandlerSet;
kind: Kind;
END;
VAR
handlerDiscId: Disciplines.Identifier;
VAR
null*: HandlerSet; (* empty handler set *)
PROCEDURE CreateHandlerSet*(VAR hs: HandlerSet);
BEGIN
NEW(hs); hs.handlerSet := {};
END CreateHandlerSet;
PROCEDURE InstallHandler*(hs: HandlerSet; kind: Kind; handler: Handler);
BEGIN
hs.handler[kind] := handler;
INCL(hs.handlerSet, kind);
END InstallHandler;
PROCEDURE AssignWriteProcedure*(eventType: Events.EventType;
write: WriteProcedure);
VAR
writeDiscipline: WriteDiscipline;
BEGIN
NEW(writeDiscipline);
writeDiscipline.id := writeDiscId;
writeDiscipline.write := write;
Disciplines.Add(eventType, writeDiscipline);
END AssignWriteProcedure;
PROCEDURE Write*(s: Streams.Stream; event: Events.Event);
VAR
writeDiscipline: Disciplines.Discipline;
BEGIN
IF Disciplines.Seek(event.type, writeDiscId, writeDiscipline) THEN
writeDiscipline(WriteDiscipline).write(s, event);
ELSE
IF ~Streams.WritePart(s, event.message, 0,
Strings.Len(event.message)) THEN
END;
END;
END Write;
PROCEDURE GeneralEventHandler(event: Events.Event);
VAR
disc: Disciplines.Discipline;
hdisc: HandlerDiscipline;
BEGIN
IF Disciplines.Seek(event.type, handlerDiscId, disc) THEN
hdisc := disc(HandlerDiscipline);
IF hdisc.kind IN hdisc.hs.handlerSet THEN
hdisc.hs.handler[hdisc.kind](event, hdisc.kind)
END
END;
END GeneralEventHandler;
PROCEDURE CatchEvent*(hs: HandlerSet; kind: Kind; type: Events.EventType);
VAR
handlerDiscipline: HandlerDiscipline;
BEGIN
NEW(handlerDiscipline); handlerDiscipline.id := handlerDiscId;
handlerDiscipline.hs := hs; handlerDiscipline.kind := kind;
Disciplines.Add(type, handlerDiscipline);
Events.Handler(type, GeneralEventHandler);
END CatchEvent;
BEGIN
writeDiscId := Disciplines.Unique();
handlerDiscId := Disciplines.Unique();
CreateHandlerSet(null);
kindText[debug] := "debug";
kindText[message] := "message";
kindText[warning] := "warning";
kindText[error] := "error";
kindText[fatal] := "fatal";
kindText[bug] := "bug";
writeDiscId := Disciplines.Unique();
handlerDiscId := Disciplines.Unique();
CreateHandlerSet(null);
kindText[debug] := "debug";
kindText[message] := "message";
kindText[warning] := "warning";
kindText[error] := "error";
kindText[fatal] := "fatal";
kindText[bug] := "bug";
END ulmErrors.

346
src/library/ulm/ulmEvents.Mod
View file

@ -46,88 +46,88 @@ MODULE ulmEvents;
CONST
(* possibilities on receipt of an event: *)
default* = 0; (* causes abortion *)
ignore* = 1; (* ignore event *)
funcs* = 2; (* call associated event handlers *)
default* = 0; (* causes abortion *)
ignore* = 1; (* ignore event *)
funcs* = 2; (* call associated event handlers *)
TYPE
Reaction* = INTEGER; (* one of default, ignore, or funcs *)
Reaction* = INTEGER; (* one of default, ignore, or funcs *)
Message* = ARRAY 80 OF CHAR;
Event* = POINTER TO EventRec;
EventRec* =
RECORD
(Objects.ObjectRec)
type*: EventType;
message*: Message;
(* private part *)
next: Event; (* queue *)
END;
RECORD
(Objects.ObjectRec)
type*: EventType;
message*: Message;
(* private part *)
next: Event; (* queue *)
END;
EventHandler = PROCEDURE (event: Event);
(* event managers are needed if there is any action necessary
on changing the kind of reaction
on changing the kind of reaction
*)
EventManager = PROCEDURE (type: EventType; reaction: Reaction);
Priority = INTEGER; (* must be non-negative *)
(* every event with reaction `funcs' has a handler list;
the list is in calling order which is reverse to
the order of `Handler'-calls
the list is in calling order which is reverse to
the order of `Handler'-calls
*)
HandlerList = POINTER TO HandlerRec;
HandlerRec* =
RECORD
(Objects.ObjectRec)
handler*: EventHandler;
next*: HandlerList;
END;
RECORD
(Objects.ObjectRec)
handler*: EventHandler;
next*: HandlerList;
END;
SaveList = POINTER TO SaveRec;
SaveRec =
RECORD
reaction: Reaction;
handlers: HandlerList;
next: SaveList;
END;
RECORD
reaction: Reaction;
handlers: HandlerList;
next: SaveList;
END;
EventTypeRec* =
RECORD
(Services.ObjectRec)
(* private components *)
handlers: HandlerList;
priority: Priority;
reaction: Reaction;
manager: EventManager;
savelist: SaveList;
END;
RECORD
(Services.ObjectRec)
(* private components *)
handlers: HandlerList;
priority: Priority;
reaction: Reaction;
manager: EventManager;
savelist: SaveList;
END;
Queue = POINTER TO QueueRec;
QueueRec =
RECORD
priority: INTEGER; (* queue for this priority *)
head, tail: Event;
next: Queue; (* queue with lower priority *)
END;
RECORD
priority: INTEGER; (* queue for this priority *)
head, tail: Event;
next: Queue; (* queue with lower priority *)
END;
VAR
eventTypeType: Services.Type;
CONST
priotabsize = 256; (* size of a priority table *)
maxnestlevel = 1024; (* of Raise-calls (avoids endless recursion) *)
priotabsize = 256; (* size of a priority table *)
maxnestlevel = 1024; (* of Raise-calls (avoids endless recursion) *)
TYPE
(* in some cases coroutines uses local priority systems *)
PrioritySystem* = POINTER TO PrioritySystemRec;
PrioritySystemRec* =
RECORD
(Objects.ObjectRec)
(* private part *)
currentPriority: Priority;
priotab: ARRAY priotabsize OF Priority;
priotop: INTEGER;
overflow: INTEGER; (* of priority table *)
END;
RECORD
(Objects.ObjectRec)
(* private part *)
currentPriority: Priority;
priotab: ARRAY priotabsize OF Priority;
priotop: INTEGER;
overflow: INTEGER; (* of priority table *)
END;
CONST
priorityViolation* = 0; (* priority violation (EnterPriority *)
@ -139,10 +139,10 @@ MODULE ulmEvents;
TYPE
ErrorEvent* = POINTER TO ErrorEventRec;
ErrorEventRec* =
RECORD
(EventRec)
errorcode*: SHORTINT;
END;
RECORD
(EventRec)
errorcode*: SHORTINT;
END;
VAR
errormsg*: ARRAY errorcodes OF Message;
@ -151,10 +151,10 @@ MODULE ulmEvents;
VAR
(* private part *)
abort, log, queueHandler: EventHandler;
nestlevel: INTEGER; (* of Raise calls *)
nestlevel: INTEGER; (* of Raise calls *)
queue: Queue;
lock: BOOLEAN; (* lock critical operations *)
psys: PrioritySystem; (* current priority system *)
lock: BOOLEAN; (* lock critical operations *)
psys: PrioritySystem; (* current priority system *)
PROCEDURE ^ Define*(VAR type: EventType);
PROCEDURE ^ SetPriority*(type: EventType; priority: Priority);
@ -164,13 +164,13 @@ MODULE ulmEvents;
BEGIN
Define(error); SetPriority(error, Priorities.liberrors);
errormsg[priorityViolation] :=
"priority violation (Events.EnterPriority)";
"priority violation (Events.EnterPriority)";
errormsg[unbalancedExitPriority] :=
"unbalanced call of Events.ExitPriority";
"unbalanced call of Events.ExitPriority";
errormsg[unbalancedRestoreReaction] :=
"unbalanced call of Events.RestoreReaction";
"unbalanced call of Events.RestoreReaction";
errormsg[negPriority] :=
"negative priority given to Events.SetPriority";
"negative priority given to Events.SetPriority";
END InitErrorHandling;
PROCEDURE Error(code: SHORTINT);
@ -187,7 +187,7 @@ MODULE ulmEvents;
PROCEDURE Init*(type: EventType);
VAR
stype: Services.Type;
stype: Services.Type;
BEGIN
Services.GetType(type, stype); ASSERT(stype # NIL);
type.handlers := NIL;
@ -199,8 +199,8 @@ MODULE ulmEvents;
PROCEDURE Define*(VAR type: EventType);
(* definition of a new event;
an unique event number is returned;
the reaction on receipt of `type' is defined to be `default'
an unique event number is returned;
the reaction on receipt of `type' is defined to be `default'
*)
BEGIN
NEW(type);
@ -218,9 +218,9 @@ MODULE ulmEvents;
(* (re-)defines the priority of an event *)
BEGIN
IF priority <= 0 THEN
Error(negPriority);
Error(negPriority);
ELSE
type.priority := priority;
type.priority := priority;
END;
END SetPriority;
@ -238,42 +238,42 @@ MODULE ulmEvents;
PROCEDURE Handler*(type: EventType; handler: EventHandler);
(* add `handler' to the list of handlers for event `type' *)
VAR
newhandler: HandlerList;
newhandler: HandlerList;
BEGIN
NEW(newhandler);
newhandler.handler := handler; newhandler.next := type.handlers;
type.handlers := newhandler;
IF type.reaction # funcs THEN
type.reaction := funcs; type.manager(type, funcs);
type.reaction := funcs; type.manager(type, funcs);
END;
END Handler;
PROCEDURE RemoveHandlers*(type: EventType);
(* remove list of handlers for event `type';
implies default reaction (abortion) on
receipt of `type'
implies default reaction (abortion) on
receipt of `type'
*)
BEGIN
type.handlers := NIL;
IF type.reaction # default THEN
type.reaction := default; type.manager(type, default);
type.reaction := default; type.manager(type, default);
END;
END RemoveHandlers;
PROCEDURE Ignore*(type: EventType);
(* implies RemoveHandlers(type) and causes receipt
of `type' to be ignored
of `type' to be ignored
*)
BEGIN
type.handlers := NIL;
IF type.reaction # ignore THEN
type.reaction := ignore; type.manager(type, ignore);
type.reaction := ignore; type.manager(type, ignore);
END;
END Ignore;
PROCEDURE GetHandlers*(type: EventType; handlers: HandlerList);
(* returns the list of handlers in `handlers';
the reaction of `type' must be `funcs'
the reaction of `type' must be `funcs'
*)
BEGIN
handlers := type.handlers;
@ -281,8 +281,8 @@ MODULE ulmEvents;
PROCEDURE Log*(loghandler: EventHandler);
(* call `loghandler' for every event;
subsequent calls of `Log' replace the loghandler;
the loghandler is not called on default and ignore
subsequent calls of `Log' replace the loghandler;
the loghandler is not called on default and ignore
*)
BEGIN
log := loghandler;
@ -311,8 +311,8 @@ MODULE ulmEvents;
PROCEDURE QueueHandler*(handler: EventHandler);
(* setup an alternative handler of events
that cannot be processed now because
of their unsufficient priority
that cannot be processed now because
of their unsufficient priority
*)
VAR b : BOOLEAN; (* noch *)
tmphandler : EventHandler;
@ -345,93 +345,93 @@ MODULE ulmEvents;
PROCEDURE WorkupQueue;
VAR
ptr: Event;
ptr: Event;
BEGIN
WHILE (queue # NIL) & (queue.priority > psys.currentPriority) DO
IF SYS.TAS(lock) THEN RETURN END;
ptr := queue.head; queue := queue.next;
lock := FALSE;
WHILE ptr # NIL DO
CallHandlers(ptr);
ptr := ptr.next;
END;
IF SYS.TAS(lock) THEN RETURN END;
ptr := queue.head; queue := queue.next;
lock := FALSE;
WHILE ptr # NIL DO
CallHandlers(ptr);
ptr := ptr.next;
END;
END;
END WorkupQueue;
PROCEDURE CallHandlers(event: Event);
VAR
ptr: HandlerList;
oldPriority: Priority;
ptr: HandlerList;
oldPriority: Priority;
BEGIN
CASE event.type.reaction OF
| default: abort(event);
| ignore:
| funcs: oldPriority := psys.currentPriority;
psys.currentPriority := event.type.priority;
log(event);
ptr := event.type.handlers;
WHILE ptr # NIL DO
ptr.handler(event);
ptr := ptr.next;
END;
psys.currentPriority := oldPriority;
psys.currentPriority := event.type.priority;
log(event);
ptr := event.type.handlers;
WHILE ptr # NIL DO
ptr.handler(event);
ptr := ptr.next;
END;
psys.currentPriority := oldPriority;
ELSE (* Explicitly ignore unhandled even type reactions *)
END;
END CallHandlers;
PROCEDURE Raise*(event: Event);
(* call all event handlers (in reverse order)
associated with event.type;
abort if there are none;
some system events may abort in another way
(i.e. they do not cause the abortion handler to be called)
associated with event.type;
abort if there are none;
some system events may abort in another way
(i.e. they do not cause the abortion handler to be called)
*)
VAR
priority: Priority;
priority: Priority;
PROCEDURE AddToQueue(event: Event);
VAR
prev, ptr: Queue;
VAR
prev, ptr: Queue;
BEGIN
event.next := NIL;
ptr := queue; prev := NIL;
WHILE (ptr # NIL) & (ptr.priority > priority) DO
prev := ptr;
ptr := ptr.next;
END;
IF (ptr # NIL) & (ptr.priority = priority) THEN
ptr.tail.next := event;
ptr.tail := event;
ELSE
NEW(ptr);
ptr.priority := priority;
ptr.head := event; ptr.tail := event;
IF prev = NIL THEN
ptr.next := queue;
queue := ptr;
ELSE
ptr.next := prev.next;
prev.next := ptr;
END;
END;
event.next := NIL;
ptr := queue; prev := NIL;
WHILE (ptr # NIL) & (ptr.priority > priority) DO
prev := ptr;
ptr := ptr.next;
END;
IF (ptr # NIL) & (ptr.priority = priority) THEN
ptr.tail.next := event;
ptr.tail := event;
ELSE
NEW(ptr);
ptr.priority := priority;
ptr.head := event; ptr.tail := event;
IF prev = NIL THEN
ptr.next := queue;
queue := ptr;
ELSE
ptr.next := prev.next;
prev.next := ptr;
END;
END;
END AddToQueue;
BEGIN (* Raise *)
INC(nestlevel);
IF nestlevel >= maxnestlevel THEN
abort(event);
abort(event);
ELSE
IF event.type.reaction # ignore THEN
priority := event.type.priority;
IF psys.currentPriority < priority THEN
CallHandlers(event); WorkupQueue;
ELSIF queueHandler # NIL THEN
queueHandler(event);
ELSIF ~SYS.TAS(lock) THEN
AddToQueue(event);
lock := FALSE;
END;
END;
IF event.type.reaction # ignore THEN
priority := event.type.priority;
IF psys.currentPriority < priority THEN
CallHandlers(event); WorkupQueue;
ELSIF queueHandler # NIL THEN
queueHandler(event);
ELSIF ~SYS.TAS(lock) THEN
AddToQueue(event);
lock := FALSE;
END;
END;
END;
DEC(nestlevel);
END Raise;
@ -452,7 +452,7 @@ MODULE ulmEvents;
PROCEDURE SwitchPrioritySystem*(prioritySystem: PrioritySystem);
(* switch to another priority system; this is typically
done in case of task switches
done in case of task switches
*)
BEGIN
psys := prioritySystem;
@ -460,52 +460,52 @@ MODULE ulmEvents;
PROCEDURE EnterPriority*(priority: Priority);
(* sets the current priority to `priority';
it is an error to give a priority less than
the current priority (event `badpriority')
it is an error to give a priority less than
the current priority (event `badpriority')
*)
BEGIN
IF psys.currentPriority <= priority THEN
IF (psys.overflow = 0) & (psys.priotop < priotabsize) THEN
psys.priotab[psys.priotop] := psys.currentPriority;
INC(psys.priotop);
psys.currentPriority := priority;
ELSE
INC(psys.overflow);
END;
IF (psys.overflow = 0) & (psys.priotop < priotabsize) THEN
psys.priotab[psys.priotop] := psys.currentPriority;
INC(psys.priotop);
psys.currentPriority := priority;
ELSE
INC(psys.overflow);
END;
ELSE
Error(priorityViolation);
INC(psys.overflow);
Error(priorityViolation);
INC(psys.overflow);
END;
END EnterPriority;
PROCEDURE AssertPriority*(priority: Priority);
(* current priority
< priority: set the current priority to `priority'
>= priority: the current priority remains unchanged
< priority: set the current priority to `priority'
>= priority: the current priority remains unchanged
*)
BEGIN
IF (psys.overflow = 0) & (psys.priotop < priotabsize) THEN
psys.priotab[psys.priotop] := psys.currentPriority; INC(psys.priotop);
IF psys.currentPriority < priority THEN
psys.currentPriority := priority;
END;
psys.priotab[psys.priotop] := psys.currentPriority; INC(psys.priotop);
IF psys.currentPriority < priority THEN
psys.currentPriority := priority;
END;
ELSE
INC(psys.overflow);
INC(psys.overflow);
END;
END AssertPriority;
PROCEDURE ExitPriority*;
(* causes the priority before the last effective call
of SetPriority or AssertPriority to be restored
of SetPriority or AssertPriority to be restored
*)
BEGIN
IF psys.overflow > 0 THEN
DEC(psys.overflow);
DEC(psys.overflow);
ELSIF psys.priotop = 0 THEN
Error(unbalancedExitPriority);
Error(unbalancedExitPriority);
ELSE
DEC(psys.priotop); psys.currentPriority := psys.priotab[psys.priotop];
WorkupQueue;
DEC(psys.priotop); psys.currentPriority := psys.priotab[psys.priotop];
WorkupQueue;
END;
END ExitPriority;
@ -517,11 +517,11 @@ MODULE ulmEvents;
PROCEDURE SaveReaction*(type: EventType);
(* saves current reaction until call of RestoreReaction;
the new reaction of `type' is defined to be `ignore'
but can be changed by Events.Handler or Events.RemoveHandlers
the new reaction of `type' is defined to be `ignore'
but can be changed by Events.Handler or Events.RemoveHandlers
*)
VAR
savelist: SaveList;
savelist: SaveList;
BEGIN
NEW(savelist);
savelist.reaction := type.reaction;
@ -530,27 +530,27 @@ MODULE ulmEvents;
type.savelist := savelist;
type.handlers := NIL;
IF type.reaction # ignore THEN
type.reaction := ignore; type.manager(type, ignore);
type.reaction := ignore; type.manager(type, ignore);
END;
END SaveReaction;
PROCEDURE RestoreReaction*(type: EventType);
(* restores old reaction;
must be properly nested
must be properly nested
*)
VAR
savelist: SaveList;
savelist: SaveList;
BEGIN
IF type.savelist = NIL THEN
Error(unbalancedRestoreReaction);
Error(unbalancedRestoreReaction);
ELSE
savelist := type.savelist;
type.savelist := savelist.next;
type.handlers := savelist.handlers;
IF type.reaction # savelist.reaction THEN
type.reaction := savelist.reaction;
type.manager(type, savelist.reaction);
END;
savelist := type.savelist;
type.savelist := savelist.next;
type.handlers := savelist.handlers;
IF type.reaction # savelist.reaction THEN
type.reaction := savelist.reaction;
type.manager(type, savelist.reaction);
END;
END;
END RestoreReaction;

434
src/library/ulm/ulmForwarders.Mod
View file

@ -1,244 +1,252 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1995 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.
Copyright (C) 1989-1995 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.
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: Forwarders.om,v 1.1 1996/01/04 16:40:57 borchert Exp $
----------------------------------------------------------------------------
$Log: Forwarders.om,v $
Revision 1.1 1996/01/04 16:40:57 borchert
Initial revision
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: Forwarders.om,v 1.1 1996/01/04 16:40:57 borchert Exp $
----------------------------------------------------------------------------
$Log: Forwarders.om,v $
Revision 1.1 1996/01/04 16:40:57 borchert
Initial revision
----------------------------------------------------------------------------
----------------------------------------------------------------------------
*)
MODULE ulmForwarders; (* AFB 3/95 *)
IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Resources := ulmResources, Services := ulmServices, SYSTEM;
(* SYSTEM is necessary to cast to Disciplines.Discipline; noch *)
IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Resources := ulmResources, Services := ulmServices;
TYPE
Object* = Services.Object;
ForwardProc* = PROCEDURE (from, to: Object);
TYPE
Object* = Services.Object;
ForwardProc* = PROCEDURE (from, to: Object);
TYPE
ListOfForwarders = POINTER TO ListOfForwardersRec;
ListOfForwardersRec =
RECORD
forward: ForwardProc;
next: ListOfForwarders;
END;
ListOfDependants = POINTER TO ListOfDependantsRec;
ListOfDependantsRec =
RECORD
dependant: Object;
next: ListOfDependants;
END;
TypeDiscipline = POINTER TO TypeDisciplineRec;
TypeDisciplineRec =
RECORD
(Disciplines.DisciplineRec)
list: ListOfForwarders;
END;
ObjectDiscipline = POINTER TO ObjectDisciplineRec;
ObjectDisciplineRec =
RECORD
(Disciplines.DisciplineRec)
dependants: ListOfDependants;
forwarders: ListOfForwarders;
dependsOn: Object;
END;
VAR
genlist: ListOfForwarders; (* list which applies to all types *)
typeDiscID: Disciplines.Identifier;
objectDiscID: Disciplines.Identifier;
(* === private procedures ============================================ *)
PROCEDURE RemoveDependant(VAR list: ListOfDependants; dependant: Object);
VAR
prev, p: ListOfDependants;
BEGIN
prev := NIL; p := list;
WHILE (p # NIL) & (p.dependant # dependant) DO
prev := p; p := p.next;
TYPE
ListOfForwarders = POINTER TO ListOfForwardersRec;
ListOfForwardersRec =
RECORD
forward: ForwardProc;
next: ListOfForwarders;
END;
IF p # NIL THEN
IF prev = NIL THEN
list := p.next;
ELSE
prev.next := p.next;
END;
ListOfDependants = POINTER TO ListOfDependantsRec;
ListOfDependantsRec =
RECORD
dependant: Object;
next: ListOfDependants;
END;
END RemoveDependant;
PROCEDURE TerminationHandler(event: Events.Event);
(* remove list of dependants in case of termination and
remove event.resource from the list of dependants of that
object it depends on
*)
VAR
odisc: ObjectDiscipline;
dependsOn: Object;
BEGIN
WITH event: Resources.Event DO
IF event.change = Resources.terminated THEN
IF Disciplines.Seek(event.resource, objectDiscID, SYSTEM.VAL(Disciplines.Discipline, odisc)) THEN (* noch *)
Disciplines.Remove(event.resource, objectDiscID);
dependsOn := odisc.dependsOn;
IF (dependsOn # NIL) & ~Resources.Terminated(dependsOn) &
Disciplines.Seek(dependsOn, objectDiscID, SYSTEM.VAL(Disciplines.Discipline, odisc)) THEN (* noch *)
RemoveDependant(odisc.dependants, event.resource(Object));
END;
END;
END;
TypeDiscipline = POINTER TO TypeDisciplineRec;
TypeDisciplineRec =
RECORD
(Disciplines.DisciplineRec)
list: ListOfForwarders;
END;
END TerminationHandler;
PROCEDURE Insert(VAR list: ListOfForwarders; forward: ForwardProc);
VAR
member: ListOfForwarders;
BEGIN
NEW(member); member.forward := forward;
member.next := list; list := member;
END Insert;
PROCEDURE GetObjectDiscipline(object: Object; VAR odisc: ObjectDiscipline);
VAR
resourceNotification: Events.EventType;
BEGIN
IF ~Disciplines.Seek(object, objectDiscID, SYSTEM.VAL(Disciplines.Discipline, odisc)) THEN (* noch *)
NEW(odisc); odisc.id := objectDiscID; odisc.dependants := NIL;
odisc.forwarders := NIL; odisc.dependsOn := NIL;
(* let's state our interest in termination of `object' if
we see this object the first time
*)
Resources.TakeInterest(object, resourceNotification);
Events.Handler(resourceNotification, TerminationHandler);
Disciplines.Add(object, odisc);
ObjectDiscipline = POINTER TO ObjectDisciplineRec;
ObjectDisciplineRec =
RECORD
(Disciplines.DisciplineRec)
dependants: ListOfDependants;
forwarders: ListOfForwarders;
dependsOn: Object;
END;
END GetObjectDiscipline;
VAR
genlist: ListOfForwarders; (* list which applies to all types *)
typeDiscID: Disciplines.Identifier;
objectDiscID: Disciplines.Identifier;
(* === exported procedures =========================================== *)
(* === private procedures ============================================ *)
PROCEDURE Register*(for: ARRAY OF CHAR; forward: ForwardProc);
(* register a forwarder which is to be called for all
forward operations which affects extensions of `for';
"" may be given for Services.Object
*)
VAR
type: Services.Type;
tdisc: TypeDiscipline;
BEGIN (* Register *)
IF for = "" THEN
Insert(genlist, forward);
PROCEDURE RemoveDependant(VAR list: ListOfDependants; dependant: Object);
VAR
prev, p: ListOfDependants;
BEGIN
prev := NIL; p := list;
WHILE (p # NIL) & (p.dependant # dependant) DO
prev := p; p := p.next;
END;
IF p # NIL THEN
IF prev = NIL THEN
list := p.next;
ELSE
Services.SeekType(for, type);
ASSERT(type # NIL);
IF ~Disciplines.Seek(type, typeDiscID, SYSTEM.VAL(Disciplines.Discipline, tdisc)) THEN
NEW(tdisc); tdisc.id := typeDiscID; tdisc.list := NIL;
END;
Insert(tdisc.list, forward);
Disciplines.Add(type, tdisc);
prev.next := p.next;
END;
END Register;
END;
END RemoveDependant;
PROCEDURE RegisterObject*(object: Object; forward: ForwardProc);
(* to be called instead of Register if specific objects
are supported only and not all extensions of a type
PROCEDURE TerminationHandler(event: Events.Event);
(* remove list of dependants in case of termination and
remove event.resource from the list of dependants of that
object it depends on
*)
VAR
odisc: Disciplines.Discipline;
dependsOn: Object;
BEGIN
WITH event: Resources.Event DO
IF event.change = Resources.terminated THEN
IF Disciplines.Seek(event.resource, objectDiscID, odisc) THEN
Disciplines.Remove(event.resource, objectDiscID);
dependsOn := odisc(ObjectDiscipline).dependsOn;
IF (dependsOn # NIL) & ~Resources.Terminated(dependsOn) &
Disciplines.Seek(dependsOn, objectDiscID, odisc) THEN
RemoveDependant(odisc(ObjectDiscipline).dependants, event.resource(Object));
END;
END;
END;
END;
END TerminationHandler;
PROCEDURE Insert(VAR list: ListOfForwarders; forward: ForwardProc);
VAR
member: ListOfForwarders;
BEGIN
NEW(member); member.forward := forward;
member.next := list; list := member;
END Insert;
PROCEDURE GetObjectDiscipline(object: Object; VAR odisc: ObjectDiscipline);
VAR
disc: Disciplines.Discipline;
resourceNotification: Events.EventType;
BEGIN
IF Disciplines.Seek(object, objectDiscID, disc) THEN
odisc := disc(ObjectDiscipline)
ELSE
NEW(odisc); odisc.id := objectDiscID; odisc.dependants := NIL;
odisc.forwarders := NIL; odisc.dependsOn := NIL;
(* let's state our interest in termination of `object' if
we see this object the first time
*)
VAR
odisc: ObjectDiscipline;
BEGIN
GetObjectDiscipline(object, odisc);
Insert(odisc.forwarders, forward);
END RegisterObject;
Resources.TakeInterest(object, resourceNotification);
Events.Handler(resourceNotification, TerminationHandler);
Disciplines.Add(object, odisc);
END;
END GetObjectDiscipline;
PROCEDURE Update*(object: Object; forward: ForwardProc);
(* is to be called by one of the registered forwarders if
an interface for object has been newly installed or changed
in a way which needs forward to be called for each of
the filter objects which delegate to `object'
*)
VAR
odisc: ObjectDiscipline;
client: ListOfDependants;
BEGIN
IF Disciplines.Seek(object, objectDiscID, SYSTEM.VAL(Disciplines.Discipline, odisc)) THEN (* noch *)
client := odisc.dependants;
WHILE client # NIL DO
forward(client.dependant, object);
client := client.next;
END;
(* === exported procedures =========================================== *)
PROCEDURE Register*(for: ARRAY OF CHAR; forward: ForwardProc);
(* register a forwarder which is to be called for all
forward operations which affects extensions of `for';
"" may be given for Services.Object
*)
VAR
type: Services.Type;
tdisc: TypeDiscipline;
disc: Disciplines.Discipline;
BEGIN (* Register *)
IF for = "" THEN
Insert(genlist, forward);
ELSE
Services.SeekType(for, type);
ASSERT(type # NIL);
IF Disciplines.Seek(type, typeDiscID, disc) THEN
tdisc := disc(TypeDiscipline)
ELSE
NEW(tdisc); tdisc.id := typeDiscID; tdisc.list := NIL;
END;
END Update;
Insert(tdisc.list, forward);
Disciplines.Add(type, tdisc);
END;
END Register;
PROCEDURE Forward*(from, to: Object);
(* forward (as far as supported) all operations from `from' to `to' *)
VAR
type, otherType, baseType: Services.Type;
tdisc: TypeDiscipline;
odisc: ObjectDiscipline;
client: ListOfDependants;
forwarder: ListOfForwarders;
PROCEDURE RegisterObject*(object: Object; forward: ForwardProc);
(* to be called instead of Register if specific objects
are supported only and not all extensions of a type
*)
VAR
odisc: ObjectDiscipline;
BEGIN
GetObjectDiscipline(object, odisc);
Insert(odisc.forwarders, forward);
END RegisterObject;
PROCEDURE CallForwarders(list: ListOfForwarders);
BEGIN
WHILE list # NIL DO
list.forward(from, to);
list := list.next;
END;
END CallForwarders;
BEGIN (* Forward *)
Services.GetType(from, type);
Services.GetType(to, otherType);
ASSERT((type # NIL) & (otherType # NIL));
IF Resources.Terminated(to) OR Resources.Terminated(from) THEN
(* forwarding operations is no longer useful *)
RETURN
PROCEDURE Update*(object: Object; forward: ForwardProc);
(* is to be called by one of the registered forwarders if
an interface for object has been newly installed or changed
in a way which needs forward to be called for each of
the filter objects which delegate to `object'
*)
VAR
odisc: ObjectDiscipline;
disc: Disciplines.Discipline;
client: ListOfDependants;
BEGIN
IF Disciplines.Seek(object, objectDiscID, disc) THEN
odisc := disc(ObjectDiscipline);
client := odisc.dependants;
WHILE client # NIL DO
forward(client.dependant, object);
client := client.next;
END;
Resources.DependsOn(from, to);
END;
END Update;
(* update the list of dependants for `to' *)
GetObjectDiscipline(to, odisc);
NEW(client); client.dependant := from;
client.next := odisc.dependants; odisc.dependants := client;
PROCEDURE Forward*(from, to: Object);
(* forward (as far as supported) all operations from `from' to `to' *)
VAR
type, otherType, baseType: Services.Type;
disc: Disciplines.Discipline;
tdisc: TypeDiscipline;
odisc: ObjectDiscipline;
client: ListOfDependants;
forwarder: ListOfForwarders;
(* call object-specific forwarders *)
CallForwarders(odisc.forwarders);
LOOP (* go through the list of base types in descending order *)
IF Disciplines.Seek(type, typeDiscID, SYSTEM.VAL(Disciplines.Discipline, tdisc)) & (* noch *)
Services.IsExtensionOf(otherType, type) THEN
CallForwarders(tdisc.list);
END;
Services.GetBaseType(type, baseType);
IF baseType = NIL THEN EXIT END;
type := baseType;
PROCEDURE CallForwarders(list: ListOfForwarders);
BEGIN
WHILE list # NIL DO
list.forward(from, to);
list := list.next;
END;
CallForwarders(genlist);
END Forward;
END CallForwarders;
BEGIN (* Forward *)
Services.GetType(from, type);
Services.GetType(to, otherType);
ASSERT((type # NIL) & (otherType # NIL));
IF Resources.Terminated(to) OR Resources.Terminated(from) THEN
(* forwarding operations is no longer useful *)
RETURN
END;
Resources.DependsOn(from, to);
(* update the list of dependants for `to' *)
GetObjectDiscipline(to, odisc);
NEW(client); client.dependant := from;
client.next := odisc.dependants; odisc.dependants := client;
(* call object-specific forwarders *)
CallForwarders(odisc.forwarders);
LOOP (* go through the list of base types in descending order *)
IF Disciplines.Seek(type, typeDiscID, disc) & Services.IsExtensionOf(otherType, type) THEN
tdisc := disc(TypeDiscipline);
CallForwarders(tdisc.list);
END;
Services.GetBaseType(type, baseType);
IF baseType = NIL THEN EXIT END;
type := baseType;
END;
CallForwarders(genlist);
END Forward;
BEGIN
genlist := NIL;
typeDiscID := Disciplines.Unique();
objectDiscID := Disciplines.Unique();
genlist := NIL;
typeDiscID := Disciplines.Unique();
objectDiscID := Disciplines.Unique();
END ulmForwarders.

4
src/library/ulm/ulmIO.Mod
View file

@ -42,9 +42,7 @@ MODULE ulmIO;
dig : LONGINT;
NumberLen : SHORTINT;
BEGIN
IF SIZE(LONGINT) = 4 THEN
NumberLen := 11
ELSIF SIZE(LONGINT) = 8 THEN
IF SIZE(LONGINT) = 8 THEN
NumberLen := 21
ELSE
NumberLen := 11 (* default value, corresponds to 32 bit *)

62
src/library/ulm/ulmIndirectDisciplines.Mod
View file

@ -43,23 +43,24 @@ MODULE ulmIndirectDisciplines;
TYPE
IndDiscipline = POINTER TO IndDisciplineRec;
IndDisciplineRec =
RECORD
(DisciplineRec)
forwardTo: Object;
END;
RECORD
(DisciplineRec)
forwardTo: Object;
END;
VAR
discID: Identifier;
PROCEDURE Forward*(from, to: Object);
VAR
disc: IndDiscipline;
disc: IndDiscipline;
BEGIN
IF to = NIL THEN
Disciplines.Remove(from, discID);
Disciplines.Remove(from, discID);
ELSE
NEW(disc); disc.id := discID;
disc.forwardTo := to;
Disciplines.Add(from, disc);
NEW(disc); disc.id := discID;
disc.forwardTo := to;
Disciplines.Add(from, disc);
END;
END Forward;
@ -70,44 +71,43 @@ MODULE ulmIndirectDisciplines;
PROCEDURE Add*(object: Object; discipline: Discipline);
VAR
disc: IndDiscipline;
disc: Discipline;
BEGIN
WHILE Disciplines.Seek(object, discID, SYSTEM.VAL(Disciplines.Discipline, disc)) DO
object := disc.forwardTo;
WHILE Disciplines.Seek(object, discID, disc) DO
object := disc(IndDiscipline).forwardTo;
END;
Disciplines.Add(object, discipline);
END Add;
PROCEDURE Remove*(object: Object; id: Identifier);
VAR
dummy: Discipline;
disc: IndDiscipline;
dummy, disc: Discipline;
BEGIN
LOOP
IF Disciplines.Seek(object, id, dummy) THEN
Disciplines.Remove(object, id);
EXIT
END;
IF ~Disciplines.Seek(object, discID, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN
EXIT
END;
object := disc.forwardTo;
IF Disciplines.Seek(object, id, dummy) THEN
Disciplines.Remove(object, id);
EXIT
END;
IF ~Disciplines.Seek(object, discID, disc) THEN
EXIT
END;
object := disc(IndDiscipline).forwardTo;
END;
END Remove;
PROCEDURE Seek*(object: Object; id: Identifier;
VAR discipline: Discipline) : BOOLEAN;
VAR discipline: Discipline) : BOOLEAN;
VAR
disc: IndDiscipline;
disc: Discipline;
BEGIN
LOOP
IF Disciplines.Seek(object, id, discipline) THEN
RETURN TRUE
END;
IF ~Disciplines.Seek(object, discID, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN
RETURN FALSE
END;
object := disc.forwardTo;
IF Disciplines.Seek(object, id, discipline) THEN
RETURN TRUE
END;
IF ~Disciplines.Seek(object, discID, disc) THEN
RETURN FALSE
END;
object := disc(IndDiscipline).forwardTo;
END;
END Seek;

144
src/library/ulm/ulmIntOperations.Mod
View file

@ -28,52 +28,53 @@
MODULE ulmIntOperations; (* Frank B.J. Fischer *)
IMPORT Operations := ulmOperations, PersistentObjects := ulmPersistentObjects, Services := ulmServices, Streams := ulmStreams, Types := ulmTypes, SYSTEM;
IMPORT
Operations := ulmOperations, PersistentObjects := ulmPersistentObjects,
Services := ulmServices, Streams := ulmStreams,
Types := ulmTypes;
(* SYSTEM added to make casts necessary to port ulm library because ulm compiler is not as strict (read it's wrong) as it had to be --noch *)
CONST
CONST
mod* = 5; pow* = 6; inc* = 7; dec* = 8; mmul* = 9; mpow* = 10;
odd* = 11; shift* = 12;
TYPE
TYPE
Operation* = Operations.Operation; (* Operations.add..mpow *)
Operand* = POINTER TO OperandRec;
TYPE
CapabilitySet* = Operations.CapabilitySet;
(* SET of [Operations.add..shift] *)
CapabilitySet* = Operations.CapabilitySet;
(* SET of [Operations.add..shift] *)
IsLargeEnoughForProc* = PROCEDURE (op: Operations.Operand;
n: LONGINT): BOOLEAN;
n: LONGINT): BOOLEAN;
UnsignedProc* = PROCEDURE (op: Operations.Operand): BOOLEAN;
IntToOpProc* = PROCEDURE (int32: Types.Int32; VAR op: Operations.Operand);
OpToIntProc* = PROCEDURE (op: Operations.Operand; VAR int32: Types.Int32);
Log2Proc* = PROCEDURE (op: Operations.Operand): LONGINT;
OddProc* = PROCEDURE (op: Operations.Operand): BOOLEAN;
ShiftProc* = PROCEDURE (op: Operations.Operand;
n: INTEGER): Operations.Operand;
IntOperatorProc* = PROCEDURE(op: Operation;
op1, op2, op3: Operations.Operand;
VAR result: Operations.Operand);
ShiftProc* = PROCEDURE (op: Operations.Operand;
n: INTEGER): Operations.Operand;
IntOperatorProc* = PROCEDURE(op: Operation;
op1, op2, op3: Operations.Operand;
VAR result: Operations.Operand);
Interface* = POINTER TO InterfaceRec;
InterfaceRec* = RECORD
(Operations.InterfaceRec)
isLargeEnoughFor*: IsLargeEnoughForProc;
unsigned* : UnsignedProc;
intToOp* : IntToOpProc;
opToInt* : OpToIntProc;
log2* : Log2Proc;
odd* : OddProc;
shift* : ShiftProc;
intOp* : IntOperatorProc;
(Operations.InterfaceRec)
isLargeEnoughFor*: IsLargeEnoughForProc;
unsigned* : UnsignedProc;
intToOp* : IntToOpProc;
opToInt* : OpToIntProc;
log2* : Log2Proc;
odd* : OddProc;
shift* : ShiftProc;
intOp* : IntOperatorProc;
END;
TYPE
OperandRec* = RECORD
(Operations.OperandRec);
(* private components *)
if : Interface;
caps: CapabilitySet;
(Operations.OperandRec);
(* private components *)
if : Interface;
caps: CapabilitySet;
END;
VAR
@ -97,7 +98,7 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *)
PROCEDURE IsLargeEnoughFor*(op: Operations.Operand; n: LONGINT): BOOLEAN;
BEGIN
WITH op: Operand DO
RETURN op.if.isLargeEnoughFor(op, n)
RETURN op.if.isLargeEnoughFor(op, n)
END;
END IsLargeEnoughFor;
@ -105,34 +106,18 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *)
PROCEDURE Unsigned*(op: Operations.Operand): BOOLEAN;
BEGIN
WITH op: Operand DO
RETURN op.if.unsigned(op)
RETURN op.if.unsigned(op)
END;
END Unsigned;
PROCEDURE IntToOp*(int32: Types.Int32; VAR op: Operations.Operand);
(* converts int32 into operand type, and stores result in already
initialized op
initialized op
*)
BEGIN
(*WITH op: Operand DO*)
(*
with original ulm source we were getting:
WITH op: Operand DO
^
pos 4101 err 245 guarded pointer variable may be manipulated by non-local operations; use auxiliary pointer variable
thus we considered changing WITH op: Operand by op(Operand)
-- noch
*)
(*ASSERT(op.if # NIL);*)
ASSERT(op(Operand).if # NIL);
(*op.if.intToOp(int32, op);*)
op(Operand).if.intToOp(int32, op(Operations.Operand));
(*END;*)
ASSERT(op(Operand).if # NIL);
op(Operand).if.intToOp(int32, op);
END IntToOp;
@ -140,7 +125,7 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *)
(* converts op into int32 *)
BEGIN
WITH op: Operand DO
op.if.opToInt(op, int32);
op.if.opToInt(op, int32);
END;
END OpToInt;
@ -148,7 +133,7 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *)
PROCEDURE Log2*(op: Operations.Operand): LONGINT;
BEGIN
WITH op: Operand DO
RETURN op.if.log2(op)
RETURN op.if.log2(op)
END;
END Log2;
@ -162,22 +147,22 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *)
END Odd;
PROCEDURE Op(op: Operation; op1, op2, op3: Operations.Operand;
VAR result: Operations.Operand);
PROCEDURE Op(op: Operation; op1, op2, op3: Operations.Operand;
VAR result: Operations.Operand);
VAR
tmpresult: Operations.Operand;
BEGIN
WITH op1: Operand DO
IF (op2#NIL) & (op3#NIL) THEN
ASSERT((op1.if = op2(Operand).if) &
(op2(Operand).if = op3(Operand).if));
ELSIF (op2#NIL) THEN
ASSERT(op1.if = op2(Operand).if);
END;
ASSERT(op IN op1.caps);
op1.if.create(tmpresult);
op1.if.intOp(op, op1, op2, op3, tmpresult);
result := tmpresult;
IF (op2#NIL) & (op3#NIL) THEN
ASSERT((op1.if = op2(Operand).if) &
(op2(Operand).if = op3(Operand).if));
ELSIF (op2#NIL) THEN
ASSERT(op1.if = op2(Operand).if);
END;
ASSERT(op IN op1.caps);
op1.if.create(tmpresult);
op1.if.intOp(op, op1, op2, op3, tmpresult);
result := tmpresult;
END;
END Op;
@ -197,15 +182,15 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *)
END Shift2;
PROCEDURE Shift3*(VAR result: Operations.Operand; op1: Operations.Operand;
n : INTEGER);
PROCEDURE Shift3*(VAR result: Operations.Operand; op1: Operations.Operand;
n : INTEGER);
VAR
tmpresult: Operations.Operand;
BEGIN
WITH op1: Operand DO
op1.if.create(tmpresult);
tmpresult := Shift(op1, n);
result := tmpresult;
op1.if.create(tmpresult);
tmpresult := Shift(op1, n);
result := tmpresult;
END;
END Shift3;
@ -230,7 +215,7 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *)
BEGIN
Op(inc,op1,NIL,NIL,result);
END Inc3;
PROCEDURE Dec*(op1: Operations.Operand): Operations.Operand;
VAR
@ -252,7 +237,7 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *)
BEGIN
Op(dec,op1,NIL,NIL,result);
END Dec3;
PROCEDURE Mod*(op1, op2: Operations.Operand): Operations.Operand;
VAR
@ -278,11 +263,10 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *)
PROCEDURE Pow*(op1, op2: Operations.Operand): Operations.Operand;
VAR
result : Operand;
result: Operations.Operand;
BEGIN
result := NIL;
(*Op(pow, op1, op2, NIL, result);*)
Op(pow, op1, op2, NIL, SYSTEM.VAL(Operations.Operand, result)); (* -- noch *)
Op(pow, op1, op2, NIL, result);
RETURN result
END Pow;
@ -301,11 +285,10 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *)
PROCEDURE MMul*(op1, op2, op3: Operations.Operand): Operations.Operand;
VAR
result : Operand;
result : Operations.Operand;
BEGIN
result := NIL;
(*Op(mmul, op1, op2, op3, result); *)
Op(mmul, op1, op2, op3, SYSTEM.VAL(Operations.Operand, result)); (* --noch*)
Op(mmul, op1, op2, op3, result);
RETURN result
END MMul;
@ -316,8 +299,8 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *)
END MMul2;
PROCEDURE MMul3*(VAR result: Operations.Operand;
op1, op2, op3: Operations.Operand);
PROCEDURE MMul3*(VAR result: Operations.Operand;
op1, op2, op3: Operations.Operand);
BEGIN
Op(mmul, op1, op2, op3, result);
END MMul3;
@ -325,11 +308,10 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *)
PROCEDURE MPow*(op1, op2, op3: Operations.Operand): Operations.Operand;
VAR
result : Operand;
result : Operations.Operand;
BEGIN
result := NIL;
(*Op(mpow, op1, op2, op3, result); *)
Op(mpow, op1, op2, op3, SYSTEM.VAL(Operations.Operand, result)); (* -- noch*)
Op(mpow, op1, op2, op3, result);
RETURN result
END MPow;
@ -340,8 +322,8 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *)
END MPow2;
PROCEDURE MPow3*(VAR result: Operations.Operand;
op1, op2, op3: Operations.Operand);
PROCEDURE MPow3*(VAR result: Operations.Operand;
op1, op2, op3: Operations.Operand);
BEGIN
Op(mpow, op1, op2, op3, result);
END MPow3;

1040
src/library/ulm/ulmNetIO.Mod
View file

File diff suppressed because it is too large Load diff

428
src/library/ulm/ulmOperations.Mod
View file

@ -1,234 +1,234 @@
(* 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.
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.
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: Operations.om,v 1.4 2004/09/16 18:31:54 borchert Exp $
----------------------------------------------------------------------------
$Log: Operations.om,v $
Revision 1.4 2004/09/16 18:31:54 borchert
optimization for Assign added in case of a non-NIL target
and identical types for target and source
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: Operations.om,v 1.4 2004/09/16 18:31:54 borchert Exp $
----------------------------------------------------------------------------
$Log: Operations.om,v $
Revision 1.4 2004/09/16 18:31:54 borchert
optimization for Assign added in case of a non-NIL target
and identical types for target and source
Revision 1.3 1997/02/05 16:27:45 borchert
Init asserts now that Services.Init hat been called previously
for ``op''
Revision 1.3 1997/02/05 16:27:45 borchert
Init asserts now that Services.Init hat been called previously
for ``op''
Revision 1.2 1995/01/16 21:39:50 borchert
- assertions of Assertions have been converted into real assertions
- some fixes due to changes of PersistentObjects
Revision 1.2 1995/01/16 21:39:50 borchert
- assertions of Assertions have been converted into real assertions
- some fixes due to changes of PersistentObjects
Revision 1.1 1994/02/22 20:09:03 borchert
Initial revision
Revision 1.1 1994/02/22 20:09:03 borchert
Initial revision
----------------------------------------------------------------------------
AFB 12/91
----------------------------------------------------------------------------
----------------------------------------------------------------------------
AFB 12/91
----------------------------------------------------------------------------
*)
MODULE ulmOperations;
(* generic support of arithmetic operations *)
(* generic support of arithmetic operations *)
IMPORT Events := ulmEvents, Objects := ulmObjects, PersistentDisciplines := ulmPersistentDisciplines, PersistentObjects := ulmPersistentObjects, Services := ulmServices;
IMPORT Events := ulmEvents, Objects := ulmObjects, PersistentDisciplines := ulmPersistentDisciplines, PersistentObjects := ulmPersistentObjects, Services := ulmServices;
CONST
add* = 0; sub* = 1; mul* = 2; div* = 3; cmp* = 4;
TYPE
Operation* = SHORTINT; (* add..cmp *)
Operand* = POINTER TO OperandRec;
CONST
add* = 0; sub* = 1; mul* = 2; div* = 3; cmp* = 4;
TYPE
Operation* = SHORTINT; (* add..cmp *)
Operand* = POINTER TO OperandRec;
TYPE
CapabilitySet* = SET; (* SET OF [add..cmp] *)
CreateProc* = PROCEDURE (VAR op: Operand);
(* should call Operations.Init for op *)
OperatorProc* = PROCEDURE (op: Operation; op1, op2: Operand;
VAR result: Operand);
AssignProc* = PROCEDURE (VAR target: Operand; source: Operand);
CompareProc* = PROCEDURE (op1, op2: Operand) : INTEGER;
Interface* = POINTER TO InterfaceRec;
InterfaceRec* =
RECORD
(Objects.ObjectRec)
create*: CreateProc;
assign*: AssignProc;
op*: OperatorProc;
compare*: CompareProc;
END;
TYPE
OperandRec* =
RECORD
(PersistentDisciplines.ObjectRec)
if: Interface;
caps: CapabilitySet;
END;
VAR
operandType: Services.Type;
PROCEDURE Init*(op: Operand; if: Interface; caps: CapabilitySet);
VAR
type: Services.Type;
BEGIN
Services.GetType(op, type); ASSERT(type # NIL);
op.if := if; op.caps := caps;
END Init;
PROCEDURE Capabilities*(op: Operand) : CapabilitySet;
BEGIN
RETURN op.caps
END Capabilities;
PROCEDURE Compatible*(op1, op2: Operand) : BOOLEAN;
(* return TRUE if both operands have the same interface *)
BEGIN
RETURN op1.if = op2.if
END Compatible;
(* the interface of the first operand must match the interface
of all other operands;
the result parameter must be either NIL or already initialized
with the same interface
*)
PROCEDURE Op(op: Operation; op1, op2: Operand; VAR result: Operand);
VAR
tmpresult: Operand;
BEGIN
ASSERT(op1.if = op2.if);
ASSERT(op IN op1.caps);
(* we are very defensive here because the type of tmpresult
is perhaps not identical to result or an extension of it;
op1.if.create(result) will not work in all cases
because of type guard failures
*)
op1.if.create(tmpresult);
op1.if.op(op, op1, op2, tmpresult);
result := tmpresult;
END Op;
PROCEDURE Add*(op1, op2: Operand) : Operand;
VAR result: Operand;
BEGIN
result := NIL;
Op(add, op1, op2, result);
RETURN result
END Add;
PROCEDURE Add2*(VAR op1: Operand; op2: Operand);
BEGIN
Op(add, op1, op2, op1);
END Add2;
PROCEDURE Add3*(VAR result: Operand; op1, op2: Operand);
BEGIN
Op(add, op1, op2, result);
END Add3;
PROCEDURE Sub*(op1, op2: Operand) : Operand;
VAR result: Operand;
BEGIN
result := NIL;
Op(sub, op1, op2, result);
RETURN result
END Sub;
PROCEDURE Sub2*(VAR op1: Operand; op2: Operand);
BEGIN
Op(sub, op1, op2, op1);
END Sub2;
PROCEDURE Sub3*(VAR result: Operand; op1, op2: Operand);
BEGIN
Op(sub, op1, op2, result);
END Sub3;
PROCEDURE Mul*(op1, op2: Operand) : Operand;
VAR result: Operand;
BEGIN
result := NIL;
Op(mul, op1, op2, result);
RETURN result
END Mul;
PROCEDURE Mul2*(VAR op1: Operand; op2: Operand);
BEGIN
Op(mul, op1, op2, op1);
END Mul2;
PROCEDURE Mul3*(VAR result: Operand; op1, op2: Operand);
BEGIN
Op(mul, op1, op2, result);
END Mul3;
PROCEDURE Div*(op1, op2: Operand) : Operand;
VAR result: Operand;
BEGIN
result := NIL;
Op(div, op1, op2, result);
RETURN result
END Div;
PROCEDURE Div2*(VAR op1: Operand; op2: Operand);
BEGIN
Op(div, op1, op2, op1);
END Div2;
PROCEDURE Div3*(VAR result: Operand; op1, op2: Operand);
BEGIN
Op(div, op1, op2, result);
END Div3;
PROCEDURE Compare*(op1, op2: Operand) : INTEGER;
BEGIN
ASSERT(op1.if = op2.if);
ASSERT(cmp IN op1.caps);
RETURN op1.if.compare(op1, op2)
END Compare;
PROCEDURE Assign*(VAR target: Operand; source: Operand);
VAR
tmpTarget: Operand;
typesIdentical: BOOLEAN;
targetType, sourceType: Services.Type;
BEGIN
IF (target # NIL) & (target.if = source.if) THEN
Services.GetType(target, targetType);
Services.GetType(source, sourceType);
typesIdentical := targetType = sourceType;
ELSE
typesIdentical := FALSE;
TYPE
CapabilitySet* = SET; (* SET OF [add..cmp] *)
CreateProc* = PROCEDURE (VAR op: Operand);
(* should call Operations.Init for op *)
OperatorProc* = PROCEDURE (op: Operation; op1, op2: Operand;
VAR result: Operand);
AssignProc* = PROCEDURE (VAR target: Operand; source: Operand);
CompareProc* = PROCEDURE (op1, op2: Operand) : INTEGER;
Interface* = POINTER TO InterfaceRec;
InterfaceRec* =
RECORD
(Objects.ObjectRec)
create*: CreateProc;
assign*: AssignProc;
op*: OperatorProc;
compare*: CompareProc;
END;
IF typesIdentical THEN
source.if.assign(target, source);
ELSE
source.if.create(tmpTarget);
source.if.assign(tmpTarget, source);
target := tmpTarget;
END;
END Assign;
PROCEDURE Copy*(source, target: Operand);
BEGIN
TYPE
OperandRec* =
RECORD
(PersistentDisciplines.ObjectRec)
if: Interface;
caps: CapabilitySet;
END;
VAR
operandType: Services.Type;
PROCEDURE Init*(op: Operand; if: Interface; caps: CapabilitySet);
VAR
type: Services.Type;
BEGIN
Services.GetType(op, type); ASSERT(type # NIL);
op.if := if; op.caps := caps;
END Init;
PROCEDURE Capabilities*(op: Operand) : CapabilitySet;
BEGIN
RETURN op.caps
END Capabilities;
PROCEDURE Compatible*(op1, op2: Operand) : BOOLEAN;
(* return TRUE if both operands have the same interface *)
BEGIN
RETURN op1.if = op2.if
END Compatible;
(* the interface of the first operand must match the interface
of all other operands;
the result parameter must be either NIL or already initialized
with the same interface
*)
PROCEDURE Op(op: Operation; op1, op2: Operand; VAR result: Operand);
VAR
tmpresult: Operand;
BEGIN
ASSERT(op1.if = op2.if);
ASSERT(op IN op1.caps);
(* we are very defensive here because the type of tmpresult
is perhaps not identical to result or an extension of it;
op1.if.create(result) will not work in all cases
because of type guard failures
*)
op1.if.create(tmpresult);
op1.if.op(op, op1, op2, tmpresult);
result := tmpresult;
END Op;
PROCEDURE Add*(op1, op2: Operand) : Operand;
VAR result: Operand;
BEGIN
result := NIL;
Op(add, op1, op2, result);
RETURN result
END Add;
PROCEDURE Add2*(VAR op1: Operand; op2: Operand);
BEGIN
Op(add, op1, op2, op1);
END Add2;
PROCEDURE Add3*(VAR result: Operand; op1, op2: Operand);
BEGIN
Op(add, op1, op2, result);
END Add3;
PROCEDURE Sub*(op1, op2: Operand) : Operand;
VAR result: Operand;
BEGIN
result := NIL;
Op(sub, op1, op2, result);
RETURN result
END Sub;
PROCEDURE Sub2*(VAR op1: Operand; op2: Operand);
BEGIN
Op(sub, op1, op2, op1);
END Sub2;
PROCEDURE Sub3*(VAR result: Operand; op1, op2: Operand);
BEGIN
Op(sub, op1, op2, result);
END Sub3;
PROCEDURE Mul*(op1, op2: Operand) : Operand;
VAR result: Operand;
BEGIN
result := NIL;
Op(mul, op1, op2, result);
RETURN result
END Mul;
PROCEDURE Mul2*(VAR op1: Operand; op2: Operand);
BEGIN
Op(mul, op1, op2, op1);
END Mul2;
PROCEDURE Mul3*(VAR result: Operand; op1, op2: Operand);
BEGIN
Op(mul, op1, op2, result);
END Mul3;
PROCEDURE Div*(op1, op2: Operand) : Operand;
VAR result: Operand;
BEGIN
result := NIL;
Op(div, op1, op2, result);
RETURN result
END Div;
PROCEDURE Div2*(VAR op1: Operand; op2: Operand);
BEGIN
Op(div, op1, op2, op1);
END Div2;
PROCEDURE Div3*(VAR result: Operand; op1, op2: Operand);
BEGIN
Op(div, op1, op2, result);
END Div3;
PROCEDURE Compare*(op1, op2: Operand) : INTEGER;
BEGIN
ASSERT(op1.if = op2.if);
ASSERT(cmp IN op1.caps);
RETURN op1.if.compare(op1, op2)
END Compare;
PROCEDURE Assign*(VAR target: Operand; source: Operand);
VAR
tmpTarget: Operand;
typesIdentical: BOOLEAN;
targetType, sourceType: Services.Type;
BEGIN
IF (target # NIL) & (target.if = source.if) THEN
Services.GetType(target, targetType);
Services.GetType(source, sourceType);
typesIdentical := targetType = sourceType;
ELSE
typesIdentical := FALSE;
END;
IF typesIdentical THEN
source.if.assign(target, source);
END Copy;
ELSE
source.if.create(tmpTarget);
source.if.assign(tmpTarget, source);
target := tmpTarget;
END;
END Assign;
PROCEDURE Copy*(source, target: Operand);
BEGIN
source.if.assign(target, source);
END Copy;
BEGIN
PersistentObjects.RegisterType(operandType,
"Operations.Operand", "PersistentDisciplines.Object", NIL);
PersistentObjects.RegisterType(operandType,
"Operations.Operand", "PersistentDisciplines.Object", NIL);
END ulmOperations.

709
src/library/ulm/ulmPersistentDisciplines.Mod
View file

@ -1,391 +1,392 @@
(* 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.
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.
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
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.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.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
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;
IMPORT Disciplines := ulmDisciplines, Forwarders := ulmForwarders, NetIO := ulmNetIO, Objects := ulmObjects, PersistentObjects := ulmPersistentObjects,
Services := ulmServices, Streams := ulmStreams;
CONST
objectName = "PersistentDisciplines.Object";
disciplineName = "PersistentDisciplines.Discipline";
CONST
objectName = "PersistentDisciplines.Object";
disciplineName = "PersistentDisciplines.Discipline";
TYPE
Identifier* = LONGINT;
TYPE
Identifier* = LONGINT;
Discipline* = POINTER TO DisciplineRec;
DisciplineRec* =
RECORD
(PersistentObjects.ObjectRec)
id*: Identifier; (* should be unique for all types of disciplines *)
END;
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;
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;
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
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;
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;
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;
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'
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: Disciplines.Discipline;
vdisc: 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)
*)
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;
IF object.list = NIL THEN
object.count := 0;
END;
ELSIF Disciplines.Seek(obj, volDiscID, disc) THEN
object := disc(VolatileDiscipline).object;
ELSE
CreateObject(object);
NEW(vdisc); vdisc.id := volDiscID; vdisc.object := object;
Disciplines.Add(obj, vdisc);
END;
END GetObject;
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;
(* === 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
CreateObject(object);
NEW(disc); disc.id := volDiscID; disc.object := object;
Disciplines.Add(obj, disc);
discipline := NIL;
END;
END GetObject;
RETURN discipline # NIL
ELSE
RETURN po.if.seek(po, id, discipline)
END;
END Seek;
(* === normal stuff for disciplines ===================================== *)
(* === interface procedures for PersistentObjects for Object === *)
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 ReadObjectData(stream: Streams.Stream;
object: PersistentObjects.Object) : BOOLEAN;
(* read data and attached disciplines of given object from stream *)
VAR
discipline: PersistentObjects.Object; (* 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, discipline) THEN
RETURN FALSE;
END;
Add(object(Object), discipline(Discipline));
DEC(count);
END;
RETURN TRUE;
END ReadObjectData;
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;
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;
IF ptr # NIL THEN
RETURN ptr.sample
ELSE
RETURN NIL
(* 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 GetSample;
END;
RETURN TRUE;
END WriteObjectData;
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;
PROCEDURE InternalCreate(VAR obj: PersistentObjects.Object);
VAR
myObject: Object;
BEGIN
CreateObject(myObject);
obj := myObject;
END InternalCreate;
BEGIN
unique := 0;
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);
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();
volDiscID := Disciplines.Unique();
Forwarders.Register("", Forward);
Forwarders.Register("", Forward);
END ulmPersistentDisciplines.

1995
src/library/ulm/ulmPersistentObjects.Mod
View file

File diff suppressed because it is too large Load diff

764
src/library/ulm/ulmRandomGenerators.Mod
View file

@ -1,419 +1,421 @@
(* 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.
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.
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: RandomGener.om,v 1.9 2004/03/09 21:44:12 borchert Exp $
----------------------------------------------------------------------------
$Log: RandomGener.om,v $
Revision 1.9 2004/03/09 21:44:12 borchert
unpredictable added to the standard set of PRNGs
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: RandomGener.om,v 1.9 2004/03/09 21:44:12 borchert Exp $
----------------------------------------------------------------------------
$Log: RandomGener.om,v $
Revision 1.9 2004/03/09 21:44:12 borchert
unpredictable added to the standard set of PRNGs
Revision 1.8 2004/03/06 07:22:09 borchert
Init asserts that the sequence has been registered at Services
Revision 1.8 2004/03/06 07:22:09 borchert
Init asserts that the sequence has been registered at Services
Revision 1.7 1998/02/14 22:04:09 martin
Missing calls of Services.Init and Services.CreateType added.
Revision 1.7 1998/02/14 22:04:09 martin
Missing calls of Services.Init and Services.CreateType added.
Revision 1.6 1997/10/11 21:22:03 martin
assertion in ValS added, obsolete variable removed
Revision 1.6 1997/10/11 21:22:03 martin
assertion in ValS added, obsolete variable removed
Revision 1.5 1997/10/10 16:26:49 martin
RestartSequence added, range conversions improved,
default implementation replaced.
Revision 1.5 1997/10/10 16:26:49 martin
RestartSequence added, range conversions improved,
default implementation replaced.
Revision 1.4 1997/04/01 16:33:41 borchert
major revision of Random:
- module renamed to RandomGenerators
- abstraction instead of simple implementation (work by Frank Fischer)
Revision 1.4 1997/04/01 16:33:41 borchert
major revision of Random:
- module renamed to RandomGenerators
- abstraction instead of simple implementation (work by Frank Fischer)
Revision 1.3 1994/09/01 18:15:41 borchert
bug fix: avoid arithmetic overflow in ValS
Revision 1.3 1994/09/01 18:15:41 borchert
bug fix: avoid arithmetic overflow in ValS
Revision 1.2 1994/08/30 09:48:00 borchert
sequences added
Revision 1.2 1994/08/30 09:48:00 borchert
sequences added
Revision 1.1 1994/02/23 07:25:30 borchert
Initial revision
Revision 1.1 1994/02/23 07:25:30 borchert
Initial revision
----------------------------------------------------------------------------
original implementation by AFB 2/90
conversion to abstraction by Frank B.J. Fischer 3/97
----------------------------------------------------------------------------
----------------------------------------------------------------------------
original implementation by AFB 2/90
conversion to abstraction by Frank B.J. Fischer 3/97
----------------------------------------------------------------------------
*)
MODULE ulmRandomGenerators;
(* Anyone who considers arithmetical
methods of producing random digits
is, of course, in a state of sin.
- John von Neumann (1951)
*)
(* Anyone who considers arithmetical
methods of producing random digits
is, of course, in a state of sin.
- John von Neumann (1951)
*)
IMPORT
Clocks := ulmClocks, Disciplines := ulmDisciplines, Objects := ulmObjects, Operations := ulmOperations, Process := ulmProcess, Services := ulmServices, Times := ulmTimes,
Types := ulmTypes, S := SYSTEM;
IMPORT
Clocks := ulmClocks, Disciplines := ulmDisciplines,
Objects := ulmObjects, Operations := ulmOperations,
Process := ulmProcess, Services := ulmServices,
Times := ulmTimes, Types := ulmTypes;
TYPE
Sequence* = POINTER TO SequenceRec;
TYPE
Sequence* = POINTER TO SequenceRec;
Int32ValSProc* = PROCEDURE (sequence: Sequence): Types.Int32;
LongRealValSProc* = PROCEDURE (sequence: Sequence): LONGREAL;
RewindSequenceProc* = PROCEDURE (sequence: Sequence);
RestartSequenceProc* = PROCEDURE (sequence, seed: Sequence);
SetValSProc* = PROCEDURE (sequence: Sequence; value: Operations.Operand);
Int32ValSProc* = PROCEDURE (sequence: Sequence): Types.Int32;
LongRealValSProc* = PROCEDURE (sequence: Sequence): LONGREAL;
RewindSequenceProc* = PROCEDURE (sequence: Sequence);
RestartSequenceProc* = PROCEDURE (sequence, seed: Sequence);
SetValSProc* = PROCEDURE (sequence: Sequence; value: Operations.Operand);
CONST
int32ValS* = 0; longRealValS* = 1; rewindSequence* = 2; restartSequence* = 3;
CONST
int32ValS* = 0; longRealValS* = 1; rewindSequence* = 2; restartSequence* = 3;
TYPE
CapabilitySet* = SET; (* of [int32ValS..restartSequence] *)
Interface* = POINTER TO InterfaceRec;
InterfaceRec* =
RECORD
(Objects.ObjectRec)
int32ValS* : Int32ValSProc; (* at least one of ... *)
longRealValS* : LongRealValSProc; (* ... these required *)
rewindSequence* : RewindSequenceProc; (* optional *)
restartSequence*: RestartSequenceProc; (* optional *)
END;
TYPE
CapabilitySet* = SET; (* of [int32ValS..restartSequence] *)
Interface* = POINTER TO InterfaceRec;
InterfaceRec* =
RECORD
(Objects.ObjectRec)
int32ValS* : Int32ValSProc; (* at least one of ... *)
longRealValS* : LongRealValSProc; (* ... these required *)
rewindSequence* : RewindSequenceProc; (* optional *)
restartSequence*: RestartSequenceProc; (* optional *)
END;
SequenceRec* =
RECORD
(Services.ObjectRec)
(* private components *)
if : Interface;
caps: CapabilitySet;
END;
SequenceRec* =
RECORD
(Services.ObjectRec)
(* private components *)
if : Interface;
caps: CapabilitySet;
END;
VAR
std* : Sequence; (* default sequence *)
seed*: Sequence; (* sequence of seed values *)
unpredictable*: Sequence;
(* reasonably fast sequence of unpredictable values;
is initially NIL
*)
VAR
std* : Sequence; (* default sequence *)
seed*: Sequence; (* sequence of seed values *)
unpredictable*: Sequence;
(* reasonably fast sequence of unpredictable values;
is initially NIL
*)
(* ----- private definitions ----- *)
(* ----- private definitions ----- *)
CONST
modulus1 = 2147483647; (* a Mersenne prime *)
factor1 = 48271; (* passes spectral test *)
quotient1 = modulus1 DIV factor1; (* 44488 *)
remainder1 = modulus1 MOD factor1; (* 3399; must be < quotient1 *)
modulus2 = 2147483399; (* a non-Mersenne prime *)
factor2 = 40692; (* also passes spectral test *)
quotient2 = modulus2 DIV factor2; (* 52774 *)
remainder2 = modulus2 MOD factor2; (* 3791; must be < quotient2 *)
CONST
modulus1 = 2147483647; (* a Mersenne prime *)
factor1 = 48271; (* passes spectral test *)
quotient1 = modulus1 DIV factor1; (* 44488 *)
remainder1 = modulus1 MOD factor1; (* 3399; must be < quotient1 *)
modulus2 = 2147483399; (* a non-Mersenne prime *)
factor2 = 40692; (* also passes spectral test *)
quotient2 = modulus2 DIV factor2; (* 52774 *)
remainder2 = modulus2 MOD factor2; (* 3791; must be < quotient2 *)
TYPE
DefaultSequence = POINTER TO DefaultSequenceRec;
DefaultSequenceRec =
RECORD
(SequenceRec)
seed1, seed2: LONGINT;
value1, value2: LONGINT;
END;
TYPE
DefaultSequence = POINTER TO DefaultSequenceRec;
DefaultSequenceRec =
RECORD
(SequenceRec)
seed1, seed2: LONGINT;
value1, value2: LONGINT;
END;
ServiceDiscipline = POINTER TO ServiceDisciplineRec;
ServiceDisciplineRec =
RECORD
(Disciplines.DisciplineRec)
setValS: SetValSProc;
END;
ServiceDiscipline = POINTER TO ServiceDisciplineRec;
ServiceDisciplineRec =
RECORD
(Disciplines.DisciplineRec)
setValS: SetValSProc;
END;
VAR
service : Services.Service;
serviceDiscID: Disciplines.Identifier;
sequenceType,
defaultSequenceType: Services.Type;
VAR
service : Services.Service;
serviceDiscID: Disciplines.Identifier;
sequenceType,
defaultSequenceType: Services.Type;
(* ----- bug workaround ----- *)
(* ----- bug workaround ----- *)
PROCEDURE Entier(value: LONGREAL): LONGINT;
PROCEDURE Entier(value: LONGREAL): LONGINT;
VAR
result: LONGINT;
BEGIN
result := ENTIER(value);
IF result > value THEN
DEC(result);
END;
RETURN result
END Entier;
(* ----- exported procedures ----- *)
PROCEDURE Init*(sequence: Sequence; if: Interface; caps: CapabilitySet);
(* initialize sequence *)
VAR
type: Services.Type;
BEGIN
ASSERT((if.int32ValS # NIL) OR (if.longRealValS # NIL));
ASSERT(~(int32ValS IN caps) OR (if.int32ValS # NIL));
ASSERT(~(longRealValS IN caps) OR (if.longRealValS # NIL));
ASSERT(~(rewindSequence IN caps) OR (if.rewindSequence # NIL));
Services.GetType(sequence, type); ASSERT(type # NIL);
sequence.if := if;
sequence.caps := caps;
END Init;
PROCEDURE Capabilities*(sequence: Sequence): CapabilitySet;
(* tell which procedures are implemented *)
BEGIN
RETURN sequence.caps
END Capabilities;
PROCEDURE RewindSequence*(sequence: Sequence);
(* re-examine sequence *)
BEGIN
ASSERT(rewindSequence IN sequence.caps);
sequence.if.rewindSequence(sequence);
END RewindSequence;
PROCEDURE RestartSequence*(sequence, seed: Sequence);
(* restart sequence with new seed values *)
BEGIN
ASSERT(restartSequence IN sequence.caps);
sequence.if.restartSequence(sequence, seed);
END RestartSequence;
PROCEDURE ^ LongRealValS*(sequence: Sequence): LONGREAL;
PROCEDURE Int32ValS*(sequence: Sequence): Types.Int32;
(* get random 32-bit value from sequence *)
VAR
real: LONGREAL;
BEGIN
IF int32ValS IN sequence.caps THEN
RETURN sequence.if.int32ValS(sequence)
ELSE
real := LongRealValS(sequence);
RETURN SHORT(Entier( (1. - real - real) * MIN(Types.Int32) ))
END;
END Int32ValS;
PROCEDURE Int32Val*(): Types.Int32;
(* get random 32-bit value from std sequence *)
BEGIN
RETURN Int32ValS(std);
END Int32Val;
PROCEDURE LongRealValS*(sequence: Sequence): LONGREAL;
(* get a uniformly distributed longreal value in [0..1) *)
BEGIN
IF longRealValS IN sequence.caps THEN
RETURN sequence.if.longRealValS(sequence)
ELSE
RETURN 0.5 +
Int32ValS(sequence) / (0. - MIN(Types.Int32) - MIN(Types.Int32))
END;
END LongRealValS;
PROCEDURE LongRealVal*(): LONGREAL;
(* get a uniformly distributed longreal value in [0..1) *)
BEGIN
RETURN LongRealValS(std)
END LongRealVal;
PROCEDURE RealValS*(sequence: Sequence): REAL;
(* get a uniformly distributed real value in [0..1) *)
BEGIN
RETURN SHORT(LongRealValS(sequence))
END RealValS;
PROCEDURE RealVal*(): REAL;
(* get a uniformly distributed real value in [0..1) *)
BEGIN
RETURN SHORT(LongRealValS(std))
END RealVal;
PROCEDURE ValS*(sequence: Sequence; low, high: LONGINT): LONGINT;
(* get a uniformly distributed integer in [low..high] *)
BEGIN
ASSERT(low <= high);
RETURN Entier( low + LongRealValS(sequence) * (1. + high - low) )
END ValS;
PROCEDURE Val*(low, high: LONGINT): LONGINT;
(* get a uniformly distributed integer in [low..high] *)
BEGIN
RETURN ValS(std, low, high)
END Val;
PROCEDURE FlipS*(sequence: Sequence): BOOLEAN;
(* return TRUE or FALSE *)
BEGIN
IF int32ValS IN sequence.caps THEN
RETURN sequence.if.int32ValS(sequence) >= 0
ELSE
RETURN sequence.if.longRealValS(sequence) >= 0.5
END;
END FlipS;
PROCEDURE Flip*(): BOOLEAN;
(* return TRUE or FALSE *)
BEGIN
RETURN FlipS(std)
END Flip;
PROCEDURE Support*(type: Services.Type; setValS: SetValSProc);
(* support service for type *)
VAR
serviceDisc: ServiceDiscipline;
BEGIN
NEW(serviceDisc);
serviceDisc.id := serviceDiscID;
serviceDisc.setValS := setValS;
Disciplines.Add(type, serviceDisc);
Services.Define(type, service, NIL);
END Support;
PROCEDURE SetValS*(sequence: Sequence; value: Operations.Operand);
(* store random value from sequence into already initialized value *)
VAR
baseType : Services.Type;
serviceDisc: Disciplines.Discipline; (* ServiceDiscipline *)
ok : BOOLEAN;
BEGIN
Services.GetSupportedBaseType(value, service, baseType);
ok := Disciplines.Seek(baseType, serviceDiscID, serviceDisc);
ASSERT(ok);
serviceDisc(ServiceDiscipline).setValS(sequence, value);
END SetValS;
PROCEDURE SetVal*(value: Operations.Operand);
(* store random value from std sequence into already initialized value *)
BEGIN
SetValS(std, value);
END SetVal;
(* ----- DefaultSequence ----- *)
PROCEDURE CongruentialStep(VAR value1, value2: LONGINT);
BEGIN
value1 :=
factor1 * (value1 MOD quotient1) - remainder1 * (value1 DIV quotient1);
IF value1 < 0 THEN
INC(value1, modulus1);
END;
value2 :=
factor2 * (value2 MOD quotient2) - remainder2 * (value2 DIV quotient2);
IF value2 < 0 THEN
INC(value2, modulus2);
END;
END CongruentialStep;
PROCEDURE DefaultSequenceValue(sequence: Sequence): LONGREAL;
VAR
value: LONGINT;
BEGIN
WITH sequence: DefaultSequence DO
CongruentialStep(sequence.value1, sequence.value2);
value := sequence.value1 - sequence.value2;
IF value <= 0 THEN
INC(value, modulus1);
END;
RETURN (value - 1.) / (modulus1 - 1.)
END;
END DefaultSequenceValue;
PROCEDURE DefaultSequenceRewind(sequence: Sequence);
BEGIN
WITH sequence: DefaultSequence DO
sequence.value1 := sequence.seed1;
sequence.value2 := sequence.seed2;
END;
END DefaultSequenceRewind;
PROCEDURE DefaultSequenceRestart(sequence, seed: Sequence);
BEGIN
WITH sequence: DefaultSequence DO
sequence.seed1 := ValS(seed, 1, modulus1-1);
sequence.seed2 := ValS(seed, 1, modulus2-1);
sequence.value1 := sequence.seed1;
sequence.value2 := sequence.seed2;
END;
END DefaultSequenceRestart;
PROCEDURE CreateDefaultSequences;
VAR
mySeed, myStd: DefaultSequence;
if: Interface;
daytime: Times.Time;
timeval: Times.TimeValueRec;
count: LONGINT;
PROCEDURE Hash(str: ARRAY OF CHAR): LONGINT;
VAR
result: LONGINT;
BEGIN
result := ENTIER(value);
IF result > value THEN
DEC(result);
END;
RETURN result
END Entier;
index,
val: LONGINT;
BEGIN
val := 27567352;
index := 0;
WHILE str[index] # 0X DO
val := (val MOD 16777216) * 128 +
(val DIV 16777216 + ORD(str[index])) MOD 128;
INC(index);
END; (*WHILE*)
RETURN val
END Hash;
(* ----- exported procedures ----- *)
BEGIN
(* define interface for all default sequences *)
NEW(if);
if.longRealValS := DefaultSequenceValue;
if.rewindSequence := DefaultSequenceRewind;
if.restartSequence := DefaultSequenceRestart;
PROCEDURE Init*(sequence: Sequence; if: Interface; caps: CapabilitySet);
(* initialize sequence *)
VAR
type: Services.Type;
BEGIN
ASSERT((if.int32ValS # NIL) OR (if.longRealValS # NIL));
ASSERT(~(int32ValS IN caps) OR (if.int32ValS # NIL));
ASSERT(~(longRealValS IN caps) OR (if.longRealValS # NIL));
ASSERT(~(rewindSequence IN caps) OR (if.rewindSequence # NIL));
Services.GetType(sequence, type); ASSERT(type # NIL);
sequence.if := if;
sequence.caps := caps;
END Init;
(* fake initial randomness using some portably accessible sources *)
NEW(mySeed);
Services.Init(mySeed, defaultSequenceType);
Init(mySeed, if, {longRealValS});
Clocks.GetTime(Clocks.system, daytime);
Times.GetValue(daytime, timeval);
(* extract those 31 bits from daytime that are most likely to vary *)
mySeed.value1 := timeval.usec * 2048 + timeval.second MOD 65536 + 1;
(* generate 31 more bits from the process name *)
mySeed.value2 := Hash(Process.name) MOD (modulus2 - 1) + 1;
(* scramble these values *)
count := 0;
WHILE count < 4 DO
CongruentialStep(mySeed.value1, mySeed.value2);
INC(count);
END;
(* mix them together *)
DefaultSequenceRestart(mySeed, mySeed);
seed := mySeed;
PROCEDURE Capabilities*(sequence: Sequence): CapabilitySet;
(* tell which procedures are implemented *)
BEGIN
RETURN sequence.caps
END Capabilities;
(* now use our seed to initialize std sequence *)
NEW(myStd);
Services.Init(myStd, defaultSequenceType);
Init(myStd, if, {longRealValS, rewindSequence, restartSequence});
DefaultSequenceRestart(myStd, mySeed);
std := myStd;
PROCEDURE RewindSequence*(sequence: Sequence);
(* re-examine sequence *)
BEGIN
ASSERT(rewindSequence IN sequence.caps);
sequence.if.rewindSequence(sequence);
END RewindSequence;
PROCEDURE RestartSequence*(sequence, seed: Sequence);
(* restart sequence with new seed values *)
BEGIN
ASSERT(restartSequence IN sequence.caps);
sequence.if.restartSequence(sequence, seed);
END RestartSequence;
PROCEDURE ^ LongRealValS*(sequence: Sequence): LONGREAL;
PROCEDURE Int32ValS*(sequence: Sequence): Types.Int32;
(* get random 32-bit value from sequence *)
VAR
real: LONGREAL;
BEGIN
IF int32ValS IN sequence.caps THEN
RETURN sequence.if.int32ValS(sequence)
ELSE
real := LongRealValS(sequence);
RETURN SHORT(Entier( (1. - real - real) * MIN(Types.Int32) ))
END;
END Int32ValS;
PROCEDURE Int32Val*(): Types.Int32;
(* get random 32-bit value from std sequence *)
BEGIN
RETURN Int32ValS(std);
END Int32Val;
PROCEDURE LongRealValS*(sequence: Sequence): LONGREAL;
(* get a uniformly distributed longreal value in [0..1) *)
BEGIN
IF longRealValS IN sequence.caps THEN
RETURN sequence.if.longRealValS(sequence)
ELSE
RETURN 0.5 +
Int32ValS(sequence) / (0. - MIN(Types.Int32) - MIN(Types.Int32))
END;
END LongRealValS;
PROCEDURE LongRealVal*(): LONGREAL;
(* get a uniformly distributed longreal value in [0..1) *)
BEGIN
RETURN LongRealValS(std)
END LongRealVal;
PROCEDURE RealValS*(sequence: Sequence): REAL;
(* get a uniformly distributed real value in [0..1) *)
BEGIN
RETURN SHORT(LongRealValS(sequence))
END RealValS;
PROCEDURE RealVal*(): REAL;
(* get a uniformly distributed real value in [0..1) *)
BEGIN
RETURN SHORT(LongRealValS(std))
END RealVal;
PROCEDURE ValS*(sequence: Sequence; low, high: LONGINT): LONGINT;
(* get a uniformly distributed integer in [low..high] *)
BEGIN
ASSERT(low <= high);
RETURN Entier( low + LongRealValS(sequence) * (1. + high - low) )
END ValS;
PROCEDURE Val*(low, high: LONGINT): LONGINT;
(* get a uniformly distributed integer in [low..high] *)
BEGIN
RETURN ValS(std, low, high)
END Val;
PROCEDURE FlipS*(sequence: Sequence): BOOLEAN;
(* return TRUE or FALSE *)
BEGIN
IF int32ValS IN sequence.caps THEN
RETURN sequence.if.int32ValS(sequence) >= 0
ELSE
RETURN sequence.if.longRealValS(sequence) >= 0.5
END;
END FlipS;
PROCEDURE Flip*(): BOOLEAN;
(* return TRUE or FALSE *)
BEGIN
RETURN FlipS(std)
END Flip;
PROCEDURE Support*(type: Services.Type; setValS: SetValSProc);
(* support service for type *)
VAR
serviceDisc: ServiceDiscipline;
BEGIN
NEW(serviceDisc);
serviceDisc.id := serviceDiscID;
serviceDisc.setValS := setValS;
Disciplines.Add(type, serviceDisc);
Services.Define(type, service, NIL);
END Support;
PROCEDURE SetValS*(sequence: Sequence; value: Operations.Operand);
(* store random value from sequence into already initialized value *)
VAR
baseType : Services.Type;
serviceDisc: ServiceDiscipline;
ok : BOOLEAN;
BEGIN
Services.GetSupportedBaseType(value, service, baseType);
ok := Disciplines.Seek(baseType, serviceDiscID, S.VAL(Disciplines.Discipline, serviceDisc));
ASSERT(ok);
serviceDisc.setValS(sequence, value);
END SetValS;
PROCEDURE SetVal*(value: Operations.Operand);
(* store random value from std sequence into already initialized value *)
BEGIN
SetValS(std, value);
END SetVal;
(* ----- DefaultSequence ----- *)
PROCEDURE CongruentialStep(VAR value1, value2: LONGINT);
BEGIN
value1 :=
factor1 * (value1 MOD quotient1) - remainder1 * (value1 DIV quotient1);
IF value1 < 0 THEN
INC(value1, modulus1);
END;
value2 :=
factor2 * (value2 MOD quotient2) - remainder2 * (value2 DIV quotient2);
IF value2 < 0 THEN
INC(value2, modulus2);
END;
END CongruentialStep;
PROCEDURE DefaultSequenceValue(sequence: Sequence): LONGREAL;
VAR
value: LONGINT;
BEGIN
WITH sequence: DefaultSequence DO
CongruentialStep(sequence.value1, sequence.value2);
value := sequence.value1 - sequence.value2;
IF value <= 0 THEN
INC(value, modulus1);
END;
RETURN (value - 1.) / (modulus1 - 1.)
END;
END DefaultSequenceValue;
PROCEDURE DefaultSequenceRewind(sequence: Sequence);
BEGIN
WITH sequence: DefaultSequence DO
sequence.value1 := sequence.seed1;
sequence.value2 := sequence.seed2;
END;
END DefaultSequenceRewind;
PROCEDURE DefaultSequenceRestart(sequence, seed: Sequence);
BEGIN
WITH sequence: DefaultSequence DO
sequence.seed1 := ValS(seed, 1, modulus1-1);
sequence.seed2 := ValS(seed, 1, modulus2-1);
sequence.value1 := sequence.seed1;
sequence.value2 := sequence.seed2;
END;
END DefaultSequenceRestart;
PROCEDURE CreateDefaultSequences;
VAR
mySeed, myStd: DefaultSequence;
if: Interface;
daytime: Times.Time;
timeval: Times.TimeValueRec;
count: LONGINT;
PROCEDURE Hash(str: ARRAY OF CHAR): LONGINT;
VAR
index,
val: LONGINT;
BEGIN
val := 27567352;
index := 0;
WHILE str[index] # 0X DO
val := (val MOD 16777216) * 128 +
(val DIV 16777216 + ORD(str[index])) MOD 128;
INC(index);
END; (*WHILE*)
RETURN val
END Hash;
BEGIN
(* define interface for all default sequences *)
NEW(if);
if.longRealValS := DefaultSequenceValue;
if.rewindSequence := DefaultSequenceRewind;
if.restartSequence := DefaultSequenceRestart;
(* fake initial randomness using some portably accessible sources *)
NEW(mySeed);
Services.Init(mySeed, defaultSequenceType);
Init(mySeed, if, {longRealValS});
Clocks.GetTime(Clocks.system, daytime);
Times.GetValue(daytime, timeval);
(* extract those 31 bits from daytime that are most likely to vary *)
mySeed.value1 := timeval.usec * 2048 + timeval.second MOD 65536 + 1;
(* generate 31 more bits from the process name *)
mySeed.value2 := Hash(Process.name) MOD (modulus2 - 1) + 1;
(* scramble these values *)
count := 0;
WHILE count < 4 DO
CongruentialStep(mySeed.value1, mySeed.value2);
INC(count);
END;
(* mix them together *)
DefaultSequenceRestart(mySeed, mySeed);
seed := mySeed;
(* now use our seed to initialize std sequence *)
NEW(myStd);
Services.Init(myStd, defaultSequenceType);
Init(myStd, if, {longRealValS, rewindSequence, restartSequence});
DefaultSequenceRestart(myStd, mySeed);
std := myStd;
unpredictable := NIL;
END CreateDefaultSequences;
unpredictable := NIL;
END CreateDefaultSequences;
BEGIN
serviceDiscID := Disciplines.Unique();
Services.Create(service, "RandomGenerators");
Services.CreateType(sequenceType, "RandomGenerators.Sequence", "");
Services.CreateType(defaultSequenceType, "RandomGenerators.DefaultSequence",
"RandomGenerators.Sequence");
CreateDefaultSequences;
serviceDiscID := Disciplines.Unique();
Services.Create(service, "RandomGenerators");
Services.CreateType(sequenceType, "RandomGenerators.Sequence", "");
Services.CreateType(defaultSequenceType, "RandomGenerators.DefaultSequence",
"RandomGenerators.Sequence");
CreateDefaultSequences;
END ulmRandomGenerators.

773
src/library/ulm/ulmRelatedEvents.Mod
View file

@ -1,422 +1,429 @@
(* 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.
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.
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: RelatedEven.om,v 1.8 2005/04/28 08:30:09 borchert Exp $
----------------------------------------------------------------------------
$Log: RelatedEven.om,v $
Revision 1.8 2005/04/28 08:30:09 borchert
added assertion to Forward that takes care that from # to
(otherwise we get a nasty infinite loop)
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: RelatedEven.om,v 1.8 2005/04/28 08:30:09 borchert Exp $
----------------------------------------------------------------------------
$Log: RelatedEven.om,v $
Revision 1.8 2005/04/28 08:30:09 borchert
added assertion to Forward that takes care that from # to
(otherwise we get a nasty infinite loop)
Revision 1.7 2004/09/09 21:04:24 borchert
undoing change of Revision 1.5:
fields dependants and dependson must not be subject of
Save/Restore as this makes it impossible to undo the
dependencies within the TerminationHandler
we no longer remove the discipline in case of terminated
objects as this causes a list of error events to be lost
Revision 1.7 2004/09/09 21:04:24 borchert
undoing change of Revision 1.5:
fields dependants and dependson must not be subject of
Save/Restore as this makes it impossible to undo the
dependencies within the TerminationHandler
we no longer remove the discipline in case of terminated
objects as this causes a list of error events to be lost
Revision 1.6 2004/02/18 17:01:59 borchert
Raise asserts now that event.type # NIL
Revision 1.6 2004/02/18 17:01:59 borchert
Raise asserts now that event.type # NIL
Revision 1.5 2004/02/18 16:53:48 borchert
fields dependants and dependson moved from discipline to state
object to support them for Save/Restore
Revision 1.5 2004/02/18 16:53:48 borchert
fields dependants and dependson moved from discipline to state
object to support them for Save/Restore
Revision 1.4 1998/01/12 14:39:18 borchert
some bug fixes around RelatedEvents.null
Revision 1.4 1998/01/12 14:39:18 borchert
some bug fixes around RelatedEvents.null
Revision 1.3 1995/03/20 17:05:13 borchert
- Save & Restore added
- support for Forwarders & Resources added
Revision 1.3 1995/03/20 17:05:13 borchert
- Save & Restore added
- support for Forwarders & Resources added
Revision 1.2 1994/08/27 14:49:44 borchert
null object added
Revision 1.2 1994/08/27 14:49:44 borchert
null object added
Revision 1.1 1994/02/22 20:09:53 borchert
Initial revision
Revision 1.1 1994/02/22 20:09:53 borchert
Initial revision
----------------------------------------------------------------------------
AFB 11/91
----------------------------------------------------------------------------
----------------------------------------------------------------------------
AFB 11/91
----------------------------------------------------------------------------
*)
MODULE ulmRelatedEvents;
(* relate events to objects *)
(* relate events to objects *)
IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Forwarders := ulmForwarders, Objects := ulmObjects, Priorities := ulmPriorities, Resources := ulmResources, SYSTEM;
IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Forwarders := ulmForwarders, Objects := ulmObjects, Priorities := ulmPriorities, Resources := ulmResources, SYSTEM;
CONST
(* possible directions of propagated events *)
forward = 0; (* forward along the forwardTo chain, if given *)
backward = 1; (* forward event to all dependants, if present *)
both = 2; (* forward event to both directions *)
TYPE
Direction = SHORTINT; (* forward, backward, both *)
CONST
(* possible directions of propagated events *)
forward = 0; (* forward along the forwardTo chain, if given *)
backward = 1; (* forward event to all dependants, if present *)
both = 2; (* forward event to both directions *)
TYPE
Direction = SHORTINT; (* forward, backward, both *)
TYPE
Object* = Disciplines.Object;
Event* = POINTER TO EventRec;
EventRec* =
RECORD
(Events.EventRec)
object*: Object;
event*: Events.Event;
END;
Queue* = POINTER TO QueueRec;
QueueRec* =
RECORD
(Objects.ObjectRec)
event*: Events.Event;
next*: Queue;
END;
ObjectList = POINTER TO ObjectListRec;
ObjectListRec =
RECORD
object: Object;
next: ObjectList;
END;
TYPE
State = POINTER TO StateRec;
StateRec =
RECORD
default: BOOLEAN; (* default reaction? *)
eventType: Events.EventType; (* may be NIL *)
queue: BOOLEAN; (* are events to be queued? *)
forwardto: Object;
head, tail: Queue;
saved: State;
END;
Discipline = POINTER TO DisciplineRec;
DisciplineRec =
RECORD
(Disciplines.DisciplineRec)
state: State;
dependants: ObjectList;
dependsOn: Object;
END;
VAR
id: Disciplines.Identifier;
VAR
null*: Object; (* object which ignores all related events *)
nullevent: Events.EventType;
PROCEDURE RemoveDependant(VAR list: ObjectList; dependant: Object);
VAR
prev, p: ObjectList;
BEGIN
prev := NIL; p := list;
WHILE (p # NIL) & (p.object # dependant) DO
prev := p; p := p.next;
TYPE
Object* = Disciplines.Object;
Event* = POINTER TO EventRec;
EventRec* =
RECORD
(Events.EventRec)
object*: Object;
event*: Events.Event;
END;
IF p # NIL THEN
IF prev = NIL THEN
list := p.next;
ELSE
prev.next := p.next;
END;
Queue* = POINTER TO QueueRec;
QueueRec* =
RECORD
(Objects.ObjectRec)
event*: Events.Event;
next*: Queue;
END;
END RemoveDependant;
PROCEDURE TerminationHandler(event: Events.Event);
VAR
disc: Discipline;
BEGIN
WITH event: Resources.Event DO
IF (event.change = Resources.terminated) &
Disciplines.Seek(event.resource, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *)
IF (disc.dependsOn # NIL) &
Disciplines.Seek(disc.dependsOn, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *)
RemoveDependant(disc.dependants, event.resource);
disc.dependsOn := NIL;
END;
(*
afb 9/2004:
do not remove this discipline for dead objects
as this makes it impossible to retrieve the final
list of error events
Disciplines.Remove(event.resource, id);
*)
END;
ObjectList = POINTER TO ObjectListRec;
ObjectListRec =
RECORD
object: Object;
next: ObjectList;
END;
END TerminationHandler;
PROCEDURE CreateState(VAR state: State);
BEGIN
NEW(state);
state.eventType := NIL;
state.queue := FALSE; state.head := NIL; state.tail := NIL;
state.forwardto := NIL;
state.default := TRUE;
state.saved := NIL;
END CreateState;
TYPE
State = POINTER TO StateRec;
StateRec =
RECORD
default: BOOLEAN; (* default reaction? *)
eventType: Events.EventType; (* may be NIL *)
queue: BOOLEAN; (* are events to be queued? *)
forwardto: Object;
head, tail: Queue;
saved: State;
END;
Discipline = POINTER TO DisciplineRec;
DisciplineRec =
RECORD
(Disciplines.DisciplineRec)
state: State;
dependants: ObjectList;
dependsOn: Object;
END;
VAR
id: Disciplines.Identifier;
VAR
null*: Object; (* object which ignores all related events *)
nullevent: Events.EventType;
PROCEDURE CreateDiscipline(VAR disc: Discipline);
BEGIN
NEW(disc); disc.id := id; CreateState(disc.state);
END CreateDiscipline;
PROCEDURE GetEventType*(object: Object; VAR eventType: Events.EventType);
(* returns an event type for the given object;
all events related to the object are also handled by this event type
*)
VAR
disc: Discipline;
state: State;
BEGIN
IF object = null THEN
eventType := nullevent;
PROCEDURE RemoveDependant(VAR list: ObjectList; dependant: Object);
VAR
prev, p: ObjectList;
BEGIN
prev := NIL; p := list;
WHILE (p # NIL) & (p.object # dependant) DO
prev := p; p := p.next;
END;
IF p # NIL THEN
IF prev = NIL THEN
list := p.next;
ELSE
IF ~Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *)
CreateDiscipline(disc);
Disciplines.Add(object, disc);
END;
state := disc.state;
state.default := FALSE;
IF state.eventType = NIL THEN
Events.Define(state.eventType);
Events.SetPriority(state.eventType, Priorities.liberrors + 1);
Events.Ignore(state.eventType);
END;
eventType := state.eventType;
prev.next := p.next;
END;
END GetEventType;
END;
END RemoveDependant;
PROCEDURE Forward*(from, to: Object);
(* causes all events related to `from' to be forwarded to `to' *)
VAR
disc: Discipline;
BEGIN
IF (from # NIL) & (from # null) THEN
ASSERT(from # to);
IF ~Disciplines.Seek(from, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *)
CreateDiscipline(disc);
Disciplines.Add(from, disc);
END;
IF to = null THEN
to := NIL;
END;
disc.state.forwardto := to;
disc.state.default := FALSE;
PROCEDURE Seek(object: Object; id: Disciplines.Identifier;
VAR discipline: Discipline): BOOLEAN;
VAR
disc: Disciplines.Discipline;
result: BOOLEAN;
BEGIN
result := Disciplines.Seek(object, id, disc);
IF result THEN discipline := disc(Discipline) ELSE discipline := NIL END;
RETURN result
END Seek;
PROCEDURE TerminationHandler(event: Events.Event);
VAR
disc: Discipline;
BEGIN
WITH event: Resources.Event DO
IF (event.change = Resources.terminated) & Seek(event.resource, id, disc) THEN
IF (disc.dependsOn # NIL) & Seek(disc.dependsOn, id, disc) THEN
RemoveDependant(disc.dependants, event.resource);
disc.dependsOn := NIL;
END;
(*
afb 9/2004:
do not remove this discipline for dead objects
as this makes it impossible to retrieve the final
list of error events
Disciplines.Remove(event.resource, id);
*)
END;
END Forward;
END;
END TerminationHandler;
PROCEDURE ForwardToDependants(from, to: Forwarders.Object);
(* is called by Forwarders.Forward:
build a backward chain from `to' to `from'
*)
VAR
fromDisc, toDisc: Discipline;
member: ObjectList;
eventType: Events.EventType;
BEGIN
IF (from = null) OR (to = null) THEN RETURN END;
IF ~Disciplines.Seek(from, id, SYSTEM.VAL(Disciplines.Discipline, fromDisc)) THEN (* noch *)
CreateDiscipline(fromDisc); Disciplines.Add(from, fromDisc);
PROCEDURE CreateState(VAR state: State);
BEGIN
NEW(state);
state.eventType := NIL;
state.queue := FALSE; state.head := NIL; state.tail := NIL;
state.forwardto := NIL;
state.default := TRUE;
state.saved := NIL;
END CreateState;
PROCEDURE CreateDiscipline(VAR disc: Discipline);
BEGIN
NEW(disc); disc.id := id; CreateState(disc.state);
END CreateDiscipline;
PROCEDURE GetEventType*(object: Object; VAR eventType: Events.EventType);
(* returns an event type for the given object;
all events related to the object are also handled by this event type
*)
VAR
disc: Discipline;
state: State;
BEGIN
IF object = null THEN
eventType := nullevent;
ELSE
IF ~Seek(object, id, disc) THEN
CreateDiscipline(disc);
Disciplines.Add(object, disc);
END;
IF fromDisc.dependsOn # NIL THEN RETURN END;
fromDisc.dependsOn := to;
Resources.TakeInterest(from, eventType);
Events.Handler(eventType, TerminationHandler);
IF ~Disciplines.Seek(to, id, SYSTEM.VAL(Disciplines.Discipline, toDisc)) THEN (* noch *)
CreateDiscipline(toDisc); Disciplines.Add(to, toDisc);
state := disc.state;
state.default := FALSE;
IF state.eventType = NIL THEN
Events.Define(state.eventType);
Events.SetPriority(state.eventType, Priorities.liberrors + 1);
Events.Ignore(state.eventType);
END;
NEW(member); member.object := from;
member.next := toDisc.dependants; toDisc.dependants := member;
END ForwardToDependants;
eventType := state.eventType;
END;
END GetEventType;
PROCEDURE QueueEvents*(object: Object);
(* put all incoming events into a queue *)
VAR
disc: Discipline;
state: State;
BEGIN
IF (object # NIL) & (object # null) THEN
IF ~Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN
CreateDiscipline(disc);
Disciplines.Add(object, disc);
END;
state := disc.state;
state.default := FALSE;
IF ~state.queue THEN
state.queue := TRUE; state.head := NIL; state.tail := NIL;
END;
PROCEDURE Forward*(from, to: Object);
(* causes all events related to `from' to be forwarded to `to' *)
VAR
disc: Discipline;
BEGIN
IF (from # NIL) & (from # null) THEN
ASSERT(from # to);
IF ~Seek(from, id, disc) THEN
CreateDiscipline(disc);
Disciplines.Add(from, disc);
END;
END QueueEvents;
IF to = null THEN
to := NIL;
END;
disc.state.forwardto := to;
disc.state.default := FALSE;
END;
END Forward;
PROCEDURE GetQueue*(object: Object; VAR queue: Queue);
(* return queue of related events which is removed
from the object;
object must have been prepared by QueueEvents
*)
VAR
disc: Discipline;
state: State;
BEGIN
IF (object # NIL) & (object # null) &
Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) & disc.state.queue THEN (* noch *)
state := disc.state;
queue := state.head; state.head := NIL; state.tail := NIL;
PROCEDURE ForwardToDependants(from, to: Forwarders.Object);
(* is called by Forwarders.Forward:
build a backward chain from `to' to `from'
*)
VAR
fromDisc, toDisc: Discipline;
member: ObjectList;
eventType: Events.EventType;
BEGIN
IF (from = null) OR (to = null) THEN RETURN END;
IF ~Seek(from, id, fromDisc) THEN
CreateDiscipline(fromDisc); Disciplines.Add(from, fromDisc);
END;
IF fromDisc.dependsOn # NIL THEN RETURN END;
fromDisc.dependsOn := to;
Resources.TakeInterest(from, eventType);
Events.Handler(eventType, TerminationHandler);
IF ~Seek(to, id, toDisc) THEN
CreateDiscipline(toDisc); Disciplines.Add(to, toDisc);
END;
NEW(member); member.object := from;
member.next := toDisc.dependants; toDisc.dependants := member;
END ForwardToDependants;
PROCEDURE QueueEvents*(object: Object);
(* put all incoming events into a queue *)
VAR
disc: Discipline;
state: State;
BEGIN
IF (object # NIL) & (object # null) THEN
IF ~Seek(object, id, disc) THEN
CreateDiscipline(disc);
Disciplines.Add(object, disc);
END;
state := disc.state;
state.default := FALSE;
IF ~state.queue THEN
state.queue := TRUE; state.head := NIL; state.tail := NIL;
END;
END;
END QueueEvents;
PROCEDURE GetQueue*(object: Object; VAR queue: Queue);
(* return queue of related events which is removed
from the object;
object must have been prepared by QueueEvents
*)
VAR
disc: Discipline;
state: State;
BEGIN
IF (object # NIL) & (object # null) & Seek(object, id, disc) & disc.state.queue THEN
state := disc.state;
queue := state.head; state.head := NIL; state.tail := NIL;
ELSE
queue := NIL;
END;
END GetQueue;
PROCEDURE EventsPending*(object: Object) : BOOLEAN;
(* return TRUE if GetQueue will return a queue # NIL *)
VAR
disc: Discipline;
BEGIN
IF (object # NIL) & (object # null) & Seek(object, id, disc) & disc.state.queue THEN
RETURN disc.state.head # NIL
ELSE
RETURN FALSE
END;
END EventsPending;
PROCEDURE Reset*(object: Object);
(* return to default behaviour *)
VAR
disc: Discipline;
state: State;
BEGIN
IF object # null THEN
IF Seek(object, id, disc) THEN
IF (disc.state.saved = NIL) &
(disc.dependsOn = NIL) &
(disc.dependants = NIL) THEN
Disciplines.Remove(object, id);
ELSE
state := disc.state;
state.queue := FALSE; state.head := NIL; state.tail := NIL;
state.eventType := NIL; state.forwardto := NIL;
state.default := TRUE;
END;
END;
END;
END Reset;
PROCEDURE Save*(object: Object);
(* save current status of the given object and reset to
default behaviour;
the status includes the reaction types and event queues;
Save operations may be nested
*)
VAR
disc: Discipline;
state: State;
BEGIN
IF object # null THEN
IF ~Seek(object, id, disc) THEN
CreateDiscipline(disc);
Disciplines.Add(object, disc);
END;
CreateState(state);
state.saved := disc.state; disc.state := state;
END;
END Save;
PROCEDURE Restore*(object: Object);
(* restore status saved earlier by Save *)
VAR
disc: Discipline;
BEGIN
IF Seek(object, id, disc) & (disc.state.saved # NIL) THEN
disc.state := disc.state.saved;
END;
END Restore;
PROCEDURE InternalRaise(object: Object; dir: Direction; event: Events.Event);
VAR
disc: Discipline;
state: State;
relEvent: Event;
element: Queue; (* new element of queue *)
dependant: ObjectList;
BEGIN
IF (object = null) OR ~Seek(object, id, disc) THEN RETURN END;
(* backward chaining *)
IF (disc.dependants # NIL) & (dir IN {backward, both}) THEN
dependant := disc.dependants;
WHILE dependant # NIL DO
InternalRaise(dependant.object, backward, event);
dependant := dependant.next;
END;
END;
(* local handling & forward chaining *)
IF ~disc.state.default THEN
state := disc.state;
IF state.queue THEN
NEW(element); element.next := NIL; element.event := event;
IF state.tail # NIL THEN
state.tail.next := element;
ELSE
state.head := element;
END;
state.tail := element;
END;
IF state.eventType # NIL THEN
NEW(relEvent);
relEvent.message := event.message;
relEvent.type := state.eventType;
relEvent.object := object;
relEvent.event := event;
Events.Raise(relEvent);
END;
IF (state.forwardto # NIL) & (dir IN {both, forward}) THEN
InternalRaise(state.forwardto, forward, event);
END;
END;
END InternalRaise;
PROCEDURE Raise*(object: Object; event: Events.Event);
VAR
disc: Discipline;
BEGIN
ASSERT(event.type # NIL);
IF object # null THEN
IF (object = NIL) OR ~Seek(object, id, disc) THEN
Events.Raise(event);
ELSE
queue := NIL;
InternalRaise(object, both, event);
END;
END GetQueue;
END;
END Raise;
PROCEDURE EventsPending*(object: Object) : BOOLEAN;
(* return TRUE if GetQueue will return a queue # NIL *)
VAR
disc: Discipline;
BEGIN
IF (object # NIL) & (object # null) &
Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) & disc.state.queue THEN (* noch *)
RETURN disc.state.head # NIL
ELSE
RETURN FALSE
END;
END EventsPending;
PROCEDURE Reset*(object: Object);
(* return to default behaviour *)
VAR
disc: Discipline;
state: State;
BEGIN
IF object # null THEN
IF Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *)
IF (disc.state.saved = NIL) &
(disc.dependsOn = NIL) &
(disc.dependants = NIL) THEN
Disciplines.Remove(object, id);
ELSE
state := disc.state;
state.queue := FALSE; state.head := NIL; state.tail := NIL;
state.eventType := NIL; state.forwardto := NIL;
state.default := TRUE;
END;
END;
END;
END Reset;
PROCEDURE Save*(object: Object);
(* save current status of the given object and reset to
default behaviour;
the status includes the reaction types and event queues;
Save operations may be nested
*)
VAR
disc: Discipline;
state: State;
BEGIN
IF object # null THEN
IF ~Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *)
CreateDiscipline(disc);
Disciplines.Add(object, disc);
END;
CreateState(state);
state.saved := disc.state; disc.state := state;
END;
END Save;
PROCEDURE Restore*(object: Object);
(* restore status saved earlier by Save *)
VAR
disc: Discipline;
BEGIN
IF Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) & (disc.state.saved # NIL) THEN (* noch *)
disc.state := disc.state.saved;
END;
END Restore;
PROCEDURE InternalRaise(object: Object; dir: Direction; event: Events.Event);
VAR
disc: Discipline;
state: State;
relEvent: Event;
element: Queue; (* new element of queue *)
dependant: ObjectList;
BEGIN
IF (object = null) OR ~Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN RETURN END;
(* backward chaining *)
IF (disc.dependants # NIL) & (dir IN {backward, both}) THEN
dependant := disc.dependants;
WHILE dependant # NIL DO
InternalRaise(dependant.object, backward, event);
dependant := dependant.next;
END;
END;
(* local handling & forward chaining *)
IF ~disc.state.default THEN
state := disc.state;
IF state.queue THEN
NEW(element); element.next := NIL; element.event := event;
IF state.tail # NIL THEN
state.tail.next := element;
ELSE
state.head := element;
END;
state.tail := element;
END;
IF state.eventType # NIL THEN
NEW(relEvent);
relEvent.message := event.message;
relEvent.type := state.eventType;
relEvent.object := object;
relEvent.event := event;
Events.Raise(relEvent);
END;
IF (state.forwardto # NIL) & (dir IN {both, forward}) THEN
InternalRaise(state.forwardto, forward, event);
END;
END;
END InternalRaise;
PROCEDURE Raise*(object: Object; event: Events.Event);
VAR
disc: Discipline;
BEGIN
ASSERT(event.type # NIL);
IF object # null THEN
IF (object = NIL) OR ~Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *)
Events.Raise(event);
ELSE
InternalRaise(object, both, event);
END;
END;
END Raise;
PROCEDURE AppendQueue*(object: Object; queue: Queue);
(* Raise(object, event) for all events of the queue *)
BEGIN
WHILE queue # NIL DO
Raise(object, queue.event);
queue := queue.next;
END;
END AppendQueue;
PROCEDURE AppendQueue*(object: Object; queue: Queue);
(* Raise(object, event) for all events of the queue *)
BEGIN
WHILE queue # NIL DO
Raise(object, queue.event);
queue := queue.next;
END;
END AppendQueue;
BEGIN
id := Disciplines.Unique();
NEW(null);
Events.Define(nullevent);
Forwarders.Register("", ForwardToDependants);
id := Disciplines.Unique();
NEW(null);
Events.Define(nullevent);
Forwarders.Register("", ForwardToDependants);
END ulmRelatedEvents.

16
src/library/ulm/ulmResources.Mod
View file

@ -107,19 +107,11 @@ MODULE ulmResources;
(* === private procedures ============================================ *)
PROCEDURE GetDisc(resource: Resource; VAR disc: Discipline);
VAR d: Disciplines.Discipline;
BEGIN
(*IF ~Disciplines.Seek(resource, discID, disc) THEN*)
(* this line causes error
err 123 type of actual parameter is not identical with that of formal VAR-parameter
because Discipline defined in this module is an extention of the same type in module Disciplines
Disciplines.Seek expects Disciplines.Discipline, not the extended type.
voc (ofront, OP2, as well as oo2c) behaves right by not allowing this, while Ulm's Oberon system
accepts this.
So we introduce here a workaround, which makes usage of this module unsafe;
noch
*)
IF ~Disciplines.Seek(resource, discID, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *)
IF Disciplines.Seek(resource, discID, d) THEN
disc := d(Discipline)
ELSE
NEW(disc); disc.id := discID;
disc.state := alive; disc.refcnt := 0;
disc.eventType := NIL;

822
src/library/ulm/ulmScales.Mod
View file

@ -1,446 +1,446 @@
(* 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.
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.
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
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.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
Revision 1.1 1994/02/22 20:10:03 borchert
Initial revision
----------------------------------------------------------------------------
AFB 12/91
----------------------------------------------------------------------------
----------------------------------------------------------------------------
AFB 12/91
----------------------------------------------------------------------------
*)
MODULE ulmScales;
IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Objects := ulmObjects, Operations := ulmOperations, PersistentObjects := ulmPersistentObjects,
RelatedEvents := ulmRelatedEvents, Services := ulmServices, SYS := SYSTEM;
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;
TYPE
Scale* = POINTER TO ScaleRec;
Family* = POINTER TO FamilyRec;
FamilyRec* =
RECORD
(Disciplines.ObjectRec)
(* private components *)
reference: 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
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;
TYPE
Value* = LONGINT;
CONST
unitNameLength* = 32;
TYPE
UnitName* = ARRAY unitNameLength OF CHAR;
UnitRec* = RECORD
(Disciplines.ObjectRec)
name: UnitName;
scale: Scale;
END;
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;
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;
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
*)
TYPE
Value* = LONGINT;
(* our interface to Operations *)
opif: Operations.Interface;
opcaps: Operations.CapabilitySet;
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);
(* ======= private procedures ===================================== *)
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;
PROCEDURE DummyConversion(from, to: Measure);
BEGIN
from.scale.if.assign(to, from);
END DummyConversion;
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
*)
(* ======== exported procedures ==================================== *)
(* our interface to Operations *)
opif: Operations.Interface;
opcaps: Operations.CapabilitySet;
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;
(* ======= private procedures ===================================== *)
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 DummyConversion(from, to: Measure);
BEGIN
from.scale.if.assign(to, from);
END DummyConversion;
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;
(* ======== 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
scale.head := listp;
m1 := op1;
m2 := op2;
END;
scale.tail := listp;
END InitUnit;
END; END;
END CheckCompatibility;
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 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 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
PROCEDURE CheckTypes(VAR restype: SHORTINT);
(* check operands for correct typing;
sets restype to the correct result type;
*)
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);
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;
ELSE
END;
ASSERT(ok); (* invalid operation *)
END; END;
END Assign;
END CheckTypes;
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;
ELSE
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
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);
ASSERT(m1.type = m2.type);
CheckCompatibility(op1, op2, m1, m2);
RETURN m1.scale.if.compare(m1, m2)
END Compare;
CreateMeasure(m1.scale, SYS.VAL(Measure, result), restype);
m1.scale.if.op(op, m1, m2, SYS.VAL(Measure, result));
END;
END Op;
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;
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);
InitInterface;
PersistentObjects.RegisterType(measureType,
"Scales.Measure", "Operations.Operand", NIL);
END ulmScales.

950
src/library/ulm/ulmServices.Mod
View file

@ -1,520 +1,520 @@
(* 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.
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.
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: Services.om,v 1.2 2004/09/03 09:34:24 borchert Exp $
----------------------------------------------------------------------------
$Log: Services.om,v $
Revision 1.2 2004/09/03 09:34:24 borchert
cache results of LoadService to avoid further attempts
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: Services.om,v 1.2 2004/09/03 09:34:24 borchert Exp $
----------------------------------------------------------------------------
$Log: Services.om,v $
Revision 1.2 2004/09/03 09:34:24 borchert
cache results of LoadService to avoid further attempts
Revision 1.1 1995/03/03 09:32:15 borchert
Initial revision
Revision 1.1 1995/03/03 09:32:15 borchert
Initial revision
----------------------------------------------------------------------------
----------------------------------------------------------------------------
*)
MODULE ulmServices;
IMPORT Disciplines := ulmDisciplines, Objects := ulmObjects;
IMPORT Disciplines := ulmDisciplines, Objects := ulmObjects;
TYPE
Type* = POINTER TO TypeRec;
ServiceList = POINTER TO ServiceListRec;
Service* = POINTER TO ServiceRec;
Object* = POINTER TO ObjectRec;
ObjectRec* =
RECORD
(Disciplines.ObjectRec)
type: Type;
installed: ServiceList; (* set of installed services *)
END;
InstallProc = PROCEDURE (object: Object; service: Service);
ServiceRec* =
RECORD
(Disciplines.ObjectRec)
name: ARRAY 64 OF CHAR;
next: Service;
END;
ServiceListRec =
RECORD
service: Service;
type: Type;
install: InstallProc;
next: ServiceList;
END;
VAR
services: Service;
(* list of services -- needed to support Seek *)
TYPE
LoadModuleProc* = PROCEDURE (module: ARRAY OF CHAR) : BOOLEAN;
LoadServiceProc* = PROCEDURE (service, for: ARRAY OF CHAR) : BOOLEAN;
LoaderInterface* = POINTER TO LoaderInterfaceRec;
LoaderInterfaceRec* =
RECORD
loadModule*: LoadModuleProc;
loadService*: LoadServiceProc;
END;
VAR
loaderIF: LoaderInterface;
(* ==== name tables ================================================== *)
CONST
bufsize = 512; (* length of a name buffer in bytes *)
tabsize = 1171;
TYPE
BufferPosition = INTEGER;
Length = LONGINT;
HashValue = INTEGER;
Buffer = ARRAY bufsize OF CHAR;
NameList = POINTER TO NameListRec;
NameListRec =
RECORD
buffer: Buffer;
next: NameList;
END;
VAR
currentBuf: NameList; currentPos: BufferPosition;
TYPE
TypeRec* =
RECORD
(Disciplines.ObjectRec)
baseType: Type;
services: ServiceList;
cachedservices: ServiceList; (* of base types *)
(* table management *)
hashval: HashValue;
length: Length;
begin: NameList;
pos: BufferPosition;
next: Type; (* next type with same hash value *)
END;
BucketTable = ARRAY tabsize OF Type;
VAR
bucket: BucketTable;
(* ==== name table management ======================================== *)
PROCEDURE Hash(name: ARRAY OF CHAR; length: LONGINT) : HashValue;
CONST
shift = 4;
VAR
index: LONGINT;
val: LONGINT;
ch: CHAR;
ordval: INTEGER;
BEGIN
index := 0; val := length;
WHILE index < length DO
ch := name[index];
IF ch >= " " THEN
ordval := ORD(ch) - ORD(" ");
ELSE
ordval := ORD(MAX(CHAR)) - ORD(" ") + ORD(ch);
END;
val := ASH(val, shift) + ordval;
INC(index);
TYPE
Type* = POINTER TO TypeRec;
ServiceList = POINTER TO ServiceListRec;
Service* = POINTER TO ServiceRec;
Object* = POINTER TO ObjectRec;
ObjectRec* =
RECORD
(Disciplines.ObjectRec)
type: Type;
installed: ServiceList; (* set of installed services *)
END;
val := val MOD tabsize;
RETURN SHORT(val)
END Hash;
PROCEDURE CreateBuf(VAR buf: NameList);
BEGIN
NEW(buf); buf.next := NIL;
IF currentBuf # NIL THEN
currentBuf.next := buf;
InstallProc = PROCEDURE (object: Object; service: Service);
ServiceRec* =
RECORD
(Disciplines.ObjectRec)
name: ARRAY 64 OF CHAR;
next: Service;
END;
currentBuf := buf;
currentPos := 0;
END CreateBuf;
PROCEDURE StringLength(string: ARRAY OF CHAR) : LONGINT;
VAR
index: LONGINT;
BEGIN
index := 0;
WHILE (index < LEN(string)) & (string[index] # 0X) DO
INC(index);
ServiceListRec =
RECORD
service: Service;
type: Type;
install: InstallProc;
next: ServiceList;
END;
RETURN index
END StringLength;
PROCEDURE InitName(name: Type; string: ARRAY OF CHAR);
VAR
index, length: LONGINT;
firstbuf, buf: NameList;
startpos: BufferPosition;
BEGIN
IF currentBuf = NIL THEN
CreateBuf(buf);
VAR
services: Service;
(* list of services -- needed to support Seek *)
TYPE
LoadModuleProc* = PROCEDURE (module: ARRAY OF CHAR) : BOOLEAN;
LoadServiceProc* = PROCEDURE (service, for: ARRAY OF CHAR) : BOOLEAN;
LoaderInterface* = POINTER TO LoaderInterfaceRec;
LoaderInterfaceRec* =
RECORD
loadModule*: LoadModuleProc;
loadService*: LoadServiceProc;
END;
VAR
loaderIF: LoaderInterface;
(* ==== name tables ================================================== *)
CONST
bufsize = 512; (* length of a name buffer in bytes *)
tabsize = 1171;
TYPE
BufferPosition = INTEGER;
Length = LONGINT;
HashValue = INTEGER;
Buffer = ARRAY bufsize OF CHAR;
NameList = POINTER TO NameListRec;
NameListRec =
RECORD
buffer: Buffer;
next: NameList;
END;
VAR
currentBuf: NameList; currentPos: BufferPosition;
TYPE
TypeRec* =
RECORD
(Disciplines.ObjectRec)
baseType: Type;
services: ServiceList;
cachedservices: ServiceList; (* of base types *)
(* table management *)
hashval: HashValue;
length: Length;
begin: NameList;
pos: BufferPosition;
next: Type; (* next type with same hash value *)
END;
BucketTable = ARRAY tabsize OF Type;
VAR
bucket: BucketTable;
(* ==== name table management ======================================== *)
PROCEDURE Hash(name: ARRAY OF CHAR; length: LONGINT) : HashValue;
CONST
shift = 4;
VAR
index: LONGINT;
val: LONGINT;
ch: CHAR;
ordval: INTEGER;
BEGIN
index := 0; val := length;
WHILE index < length DO
ch := name[index];
IF ch >= " " THEN
ordval := ORD(ch) - ORD(" ");
ELSE
buf := currentBuf;
ordval := ORD(MAX(CHAR)) - ORD(" ") + ORD(ch);
END;
val := ASH(val, shift) + ordval;
INC(index);
END;
val := val MOD tabsize;
RETURN SHORT(val)
END Hash;
firstbuf := buf; startpos := currentPos;
index := 0;
WHILE (index < LEN(string)) & (string[index] # 0X) DO
IF currentPos = bufsize THEN
CreateBuf(buf);
END;
buf.buffer[currentPos] := string[index]; INC(currentPos);
INC(index);
PROCEDURE CreateBuf(VAR buf: NameList);
BEGIN
NEW(buf); buf.next := NIL;
IF currentBuf # NIL THEN
currentBuf.next := buf;
END;
currentBuf := buf;
currentPos := 0;
END CreateBuf;
PROCEDURE StringLength(string: ARRAY OF CHAR) : LONGINT;
VAR
index: LONGINT;
BEGIN
index := 0;
WHILE (index < LEN(string)) & (string[index] # 0X) DO
INC(index);
END;
RETURN index
END StringLength;
PROCEDURE InitName(name: Type; string: ARRAY OF CHAR);
VAR
index, length: LONGINT;
firstbuf, buf: NameList;
startpos: BufferPosition;
BEGIN
IF currentBuf = NIL THEN
CreateBuf(buf);
ELSE
buf := currentBuf;
END;
firstbuf := buf; startpos := currentPos;
index := 0;
WHILE (index < LEN(string)) & (string[index] # 0X) DO
IF currentPos = bufsize THEN
CreateBuf(buf);
END;
length := index;
buf.buffer[currentPos] := string[index]; INC(currentPos);
INC(index);
END;
length := index;
name.hashval := Hash(string, length);
name.length := length;
name.begin := firstbuf;
name.pos := startpos;
name.next := bucket[name.hashval];
bucket[name.hashval] := name;
END InitName;
name.hashval := Hash(string, length);
name.length := length;
name.begin := firstbuf;
name.pos := startpos;
name.next := bucket[name.hashval];
bucket[name.hashval] := name;
END InitName;
PROCEDURE EqualName(name: Type; string: ARRAY OF CHAR) : BOOLEAN;
(* precondition: both have the same length *)
PROCEDURE EqualName(name: Type; string: ARRAY OF CHAR) : BOOLEAN;
(* precondition: both have the same length *)
VAR
index: LONGINT;
buf: NameList;
pos: INTEGER;
BEGIN
buf := name.begin; pos := name.pos;
index := 0;
WHILE index < name.length DO
IF pos = bufsize THEN
buf := buf.next; pos := 0;
END;
IF string[index] # buf.buffer[pos] THEN
RETURN FALSE
END;
INC(pos);
INC(index);
END;
RETURN TRUE
END EqualName;
PROCEDURE SeekName(string: ARRAY OF CHAR; VAR name: Type) : BOOLEAN;
VAR
length: LONGINT;
hashval: HashValue;
p: Type;
BEGIN
length := StringLength(string);
hashval := Hash(string, length);
p := bucket[hashval];
WHILE (p # NIL) & ((length # p.length) OR ~EqualName(p, string)) DO
p := p.next;
END;
name := p;
RETURN p # NIL
END SeekName;
PROCEDURE ExtractName(name: Type; VAR string: ARRAY OF CHAR);
VAR
index: LONGINT;
buf: NameList;
pos: INTEGER;
BEGIN
buf := name.begin; pos := name.pos;
index := 0;
WHILE (index + 1 < LEN(string)) & (index < name.length) DO
IF pos = bufsize THEN
buf := buf.next; pos := 0;
END;
string[index] := buf.buffer[pos];
INC(pos);
INC(index);
END;
string[index] := 0X;
END ExtractName;
PROCEDURE LoadModule(module: ARRAY OF CHAR) : BOOLEAN;
BEGIN
IF (loaderIF # NIL) & (loaderIF.loadModule # NIL) THEN
RETURN loaderIF.loadModule(module)
ELSE
RETURN FALSE
END;
END LoadModule;
PROCEDURE LoadService(service, for: ARRAY OF CHAR) : BOOLEAN;
BEGIN
IF (loaderIF # NIL) & (loaderIF.loadService # NIL) THEN
RETURN loaderIF.loadService(service, for)
ELSE
RETURN FALSE
END;
END LoadService;
PROCEDURE MemberOf(list: ServiceList; service: Service;
VAR member: ServiceList) : BOOLEAN;
VAR
p: ServiceList;
BEGIN
p := list;
WHILE (p # NIL) & (p.service # service) DO
p := p.next;
END;
member := p;
RETURN p # NIL
END MemberOf;
PROCEDURE SeekService(type: Type; service: Service;
VAR member: ServiceList;
VAR baseType: Type) : BOOLEAN;
VAR
btype: Type;
cachedservice: ServiceList;
PROCEDURE Seek(type: Type; service: Service;
VAR member: ServiceList) : BOOLEAN;
VAR
index: LONGINT;
buf: NameList;
pos: INTEGER;
BEGIN
buf := name.begin; pos := name.pos;
index := 0;
WHILE index < name.length DO
IF pos = bufsize THEN
buf := buf.next; pos := 0;
END;
IF string[index] # buf.buffer[pos] THEN
RETURN FALSE
END;
INC(pos);
INC(index);
typeName: ARRAY 512 OF CHAR;
BEGIN
IF MemberOf(type.services, service, member) OR
MemberOf(type.cachedservices, service, member) THEN
RETURN TRUE
END;
ExtractName(type, typeName);
RETURN LoadService(service.name, typeName) &
MemberOf(type.services, service, member)
END Seek;
BEGIN (* SeekService *)
btype := type;
WHILE (btype # NIL) & ~Seek(btype, service, member) DO
btype := btype.baseType;
END;
IF (member # NIL) & (btype # type) THEN
(* cache result to avoid further tries to load
a more fitting variant dynamically
*)
NEW(cachedservice);
cachedservice.service := service;
cachedservice.type := member.type;
cachedservice.install := member.install;
cachedservice.next := type.cachedservices;
type.cachedservices := cachedservice;
baseType := member.type;
RETURN TRUE
END EqualName;
END;
IF member = NIL THEN
RETURN FALSE
ELSE
baseType := member.type;
RETURN TRUE
END;
END SeekService;
PROCEDURE SeekName(string: ARRAY OF CHAR; VAR name: Type) : BOOLEAN;
VAR
length: LONGINT;
hashval: HashValue;
p: Type;
BEGIN
length := StringLength(string);
hashval := Hash(string, length);
p := bucket[hashval];
WHILE (p # NIL) & ((length # p.length) OR ~EqualName(p, string)) DO
p := p.next;
PROCEDURE GetModule(name: ARRAY OF CHAR; VAR module: ARRAY OF CHAR);
(* get the name of the module where 'name' was defined *)
VAR
index: INTEGER;
BEGIN
index := 0;
WHILE (name[index] # ".") & (name[index] # 0X) &
(index < LEN(module)-1) DO
module[index] := name[index]; INC(index);
END;
module[index] := 0X;
END GetModule;
(* ==== exported procedures ========================================== *)
PROCEDURE InitLoader*(if: LoaderInterface);
BEGIN
ASSERT((loaderIF = NIL) & (if # NIL));
loaderIF := if;
END InitLoader;
PROCEDURE InitType*(type: Type; name, baseName: ARRAY OF CHAR);
VAR
baseType: Type;
otherType: Type;
ok: BOOLEAN;
BEGIN
IF baseName = "" THEN
baseType := NIL;
ELSE
ok := SeekName(baseName, baseType); ASSERT(ok);
END;
ASSERT(~SeekName(name, otherType));
InitName(type, name);
type.baseType := baseType;
type.services := NIL;
type.cachedservices := NIL;
END InitType;
PROCEDURE CreateType*(VAR type: Type; name, baseName: ARRAY OF CHAR);
BEGIN
NEW(type); InitType(type, name, baseName);
END CreateType;
PROCEDURE Init*(object: Object; type: Type);
BEGIN
ASSERT(type # NIL);
ASSERT(object.type = NIL);
object.type := type;
object.installed := NIL;
END Init;
PROCEDURE GetType*(object: Object; VAR type: Type);
BEGIN
type := object.type;
END GetType;
PROCEDURE GetTypeName*(type: Type; VAR name: ARRAY OF CHAR);
BEGIN
ExtractName(type, name);
END GetTypeName;
PROCEDURE GetBaseType*(type: Type; VAR baseType: Type);
BEGIN
baseType := type.baseType;
END GetBaseType;
PROCEDURE IsExtensionOf*(type, baseType: Type) : BOOLEAN;
BEGIN
ASSERT(baseType # NIL);
WHILE (type # NIL) & (type # baseType) DO
type := type.baseType;
END;
RETURN type = baseType
END IsExtensionOf;
PROCEDURE SeekType*(name: ARRAY OF CHAR; VAR type: Type);
VAR
module: ARRAY 64 OF CHAR;
BEGIN
IF ~SeekName(name, type) THEN
(* try to load the associated module *)
GetModule(name, module);
IF ~LoadModule(module) OR ~SeekName(name, type) THEN
type := NIL;
END;
name := p;
RETURN p # NIL
END SeekName;
END;
END SeekType;
PROCEDURE ExtractName(name: Type; VAR string: ARRAY OF CHAR);
VAR
index: LONGINT;
buf: NameList;
pos: INTEGER;
BEGIN
buf := name.begin; pos := name.pos;
index := 0;
WHILE (index + 1 < LEN(string)) & (index < name.length) DO
IF pos = bufsize THEN
buf := buf.next; pos := 0;
END;
string[index] := buf.buffer[pos];
INC(pos);
INC(index);
END;
string[index] := 0X;
END ExtractName;
PROCEDURE Seek*(name: ARRAY OF CHAR; VAR service: Service);
BEGIN
service := services;
WHILE (service # NIL) & (service.name # name) DO
service := service.next;
END;
PROCEDURE LoadModule(module: ARRAY OF CHAR) : BOOLEAN;
BEGIN
IF (loaderIF # NIL) & (loaderIF.loadModule # NIL) THEN
RETURN loaderIF.loadModule(module)
ELSE
RETURN FALSE
END;
END LoadModule;
PROCEDURE LoadService(service, for: ARRAY OF CHAR) : BOOLEAN;
BEGIN
IF (loaderIF # NIL) & (loaderIF.loadService # NIL) THEN
RETURN loaderIF.loadService(service, for)
ELSE
RETURN FALSE
END;
END LoadService;
PROCEDURE MemberOf(list: ServiceList; service: Service;
VAR member: ServiceList) : BOOLEAN;
VAR
p: ServiceList;
BEGIN
p := list;
WHILE (p # NIL) & (p.service # service) DO
p := p.next;
END;
member := p;
RETURN p # NIL
END MemberOf;
PROCEDURE SeekService(type: Type; service: Service;
VAR member: ServiceList;
VAR baseType: Type) : BOOLEAN;
VAR
btype: Type;
cachedservice: ServiceList;
PROCEDURE Seek(type: Type; service: Service;
VAR member: ServiceList) : BOOLEAN;
VAR
typeName: ARRAY 512 OF CHAR;
BEGIN
IF MemberOf(type.services, service, member) OR
MemberOf(type.cachedservices, service, member) THEN
RETURN TRUE
END;
ExtractName(type, typeName);
RETURN LoadService(service.name, typeName) &
MemberOf(type.services, service, member)
END Seek;
BEGIN (* SeekService *)
btype := type;
WHILE (btype # NIL) & ~Seek(btype, service, member) DO
btype := btype.baseType;
END;
IF (member # NIL) & (btype # type) THEN
(* cache result to avoid further tries to load
a more fitting variant dynamically
*)
NEW(cachedservice);
cachedservice.service := service;
cachedservice.type := member.type;
cachedservice.install := member.install;
cachedservice.next := type.cachedservices;
type.cachedservices := cachedservice;
baseType := member.type;
RETURN TRUE
END;
IF member = NIL THEN
RETURN FALSE
ELSE
baseType := member.type;
RETURN TRUE
END;
END SeekService;
PROCEDURE GetModule(name: ARRAY OF CHAR; VAR module: ARRAY OF CHAR);
(* get the name of the module where 'name' was defined *)
VAR
index: INTEGER;
BEGIN
index := 0;
WHILE (name[index] # ".") & (name[index] # 0X) &
(index < LEN(module)-1) DO
module[index] := name[index]; INC(index);
END;
module[index] := 0X;
END GetModule;
(* ==== exported procedures ========================================== *)
PROCEDURE InitLoader*(if: LoaderInterface);
BEGIN
ASSERT((loaderIF = NIL) & (if # NIL));
loaderIF := if;
END InitLoader;
PROCEDURE InitType*(type: Type; name, baseName: ARRAY OF CHAR);
VAR
baseType: Type;
otherType: Type;
ok: BOOLEAN;
BEGIN
IF baseName = "" THEN
baseType := NIL;
ELSE
ok := SeekName(baseName, baseType); ASSERT(ok);
END;
ASSERT(~SeekName(name, otherType));
InitName(type, name);
type.baseType := baseType;
type.services := NIL;
type.cachedservices := NIL;
END InitType;
PROCEDURE CreateType*(VAR type: Type; name, baseName: ARRAY OF CHAR);
BEGIN
NEW(type); InitType(type, name, baseName);
END CreateType;
PROCEDURE Init*(object: Object; type: Type);
BEGIN
ASSERT(type # NIL);
ASSERT(object.type = NIL);
object.type := type;
object.installed := NIL;
END Init;
PROCEDURE GetType*(object: Object; VAR type: Type);
BEGIN
type := object.type;
END GetType;
PROCEDURE GetTypeName*(type: Type; VAR name: ARRAY OF CHAR);
BEGIN
ExtractName(type, name);
END GetTypeName;
PROCEDURE GetBaseType*(type: Type; VAR baseType: Type);
BEGIN
baseType := type.baseType;
END GetBaseType;
PROCEDURE IsExtensionOf*(type, baseType: Type) : BOOLEAN;
BEGIN
ASSERT(baseType # NIL);
WHILE (type # NIL) & (type # baseType) DO
type := type.baseType;
END;
RETURN type = baseType
END IsExtensionOf;
PROCEDURE SeekType*(name: ARRAY OF CHAR; VAR type: Type);
VAR
module: ARRAY 64 OF CHAR;
BEGIN
IF ~SeekName(name, type) THEN
(* try to load the associated module *)
GetModule(name, module);
IF ~LoadModule(module) OR ~SeekName(name, type) THEN
type := NIL;
END;
END;
END SeekType;
PROCEDURE Seek*(name: ARRAY OF CHAR; VAR service: Service);
BEGIN
(* try to load a module named after `name', if not successful *)
IF (service = NIL) & LoadModule(name) THEN
service := services;
WHILE (service # NIL) & (service.name # name) DO
service := service.next;
service := service.next;
END;
END;
END Seek;
(* try to load a module named after `name', if not successful *)
IF (service = NIL) & LoadModule(name) THEN
service := services;
WHILE (service # NIL) & (service.name # name) DO
service := service.next;
END;
PROCEDURE Create*(VAR service: Service; name: ARRAY OF CHAR);
PROCEDURE Created(name: ARRAY OF CHAR) : BOOLEAN;
VAR
service: Service;
BEGIN
service := services;
WHILE (service # NIL) & (service.name # name) DO
service := service.next;
END;
END Seek;
RETURN service # NIL
END Created;
PROCEDURE Create*(VAR service: Service; name: ARRAY OF CHAR);
BEGIN
ASSERT(~Created(name));
NEW(service);
COPY(name, service.name);
service.next := services; services := service;
END Create;
PROCEDURE Created(name: ARRAY OF CHAR) : BOOLEAN;
VAR
service: Service;
BEGIN
service := services;
WHILE (service # NIL) & (service.name # name) DO
service := service.next;
END;
RETURN service # NIL
END Created;
PROCEDURE Define*(type: Type; service: Service; install: InstallProc);
VAR
member: ServiceList;
BEGIN
ASSERT(service # NIL);
(* protect against multiple definitions: *)
ASSERT(~MemberOf(type.services, service, member));
BEGIN
ASSERT(~Created(name));
NEW(service);
COPY(name, service.name);
service.next := services; services := service;
END Create;
NEW(member); member.service := service;
member.install := install; member.type := type;
member.next := type.services; type.services := member;
END Define;
PROCEDURE Define*(type: Type; service: Service; install: InstallProc);
VAR
member: ServiceList;
BEGIN
ASSERT(service # NIL);
(* protect against multiple definitions: *)
ASSERT(~MemberOf(type.services, service, member));
NEW(member); member.service := service;
member.install := install; member.type := type;
member.next := type.services; type.services := member;
END Define;
PROCEDURE Install*(object: Object; service: Service) : BOOLEAN;
VAR
member, installed: ServiceList;
baseType: Type;
BEGIN
IF object.type = NIL THEN RETURN FALSE END;
IF ~SeekService(object.type, service, member, baseType) THEN
(* service not supported for this object type *)
RETURN FALSE
PROCEDURE Install*(object: Object; service: Service) : BOOLEAN;
VAR
member, installed: ServiceList;
baseType: Type;
BEGIN
IF object.type = NIL THEN RETURN FALSE END;
IF ~SeekService(object.type, service, member, baseType) THEN
(* service not supported for this object type *)
RETURN FALSE
END;
IF ~MemberOf(object.installed, service, installed) THEN
(* install services only once *)
IF member.install # NIL THEN
member.install(object, service);
END;
IF ~MemberOf(object.installed, service, installed) THEN
(* install services only once *)
IF member.install # NIL THEN
member.install(object, service);
END;
NEW(installed);
installed.service := service;
installed.next := object.installed;
object.installed := installed;
END;
RETURN TRUE
END Install;
NEW(installed);
installed.service := service;
installed.next := object.installed;
object.installed := installed;
END;
RETURN TRUE
END Install;
PROCEDURE Supported*(object: Object; service: Service) : BOOLEAN;
VAR
member: ServiceList;
baseType: Type;
BEGIN
RETURN (object.type # NIL) &
SeekService(object.type, service, member, baseType)
END Supported;
PROCEDURE Supported*(object: Object; service: Service) : BOOLEAN;
VAR
member: ServiceList;
baseType: Type;
BEGIN
RETURN (object.type # NIL) &
SeekService(object.type, service, member, baseType)
END Supported;
PROCEDURE Installed*(object: Object; service: Service) : BOOLEAN;
VAR
member: ServiceList;
BEGIN
RETURN MemberOf(object.installed, service, member)
END Installed;
PROCEDURE Installed*(object: Object; service: Service) : BOOLEAN;
VAR
member: ServiceList;
BEGIN
RETURN MemberOf(object.installed, service, member)
END Installed;
PROCEDURE GetSupportedBaseType*(object: Object; service: Service;
VAR baseType: Type);
VAR
member: ServiceList;
BEGIN
IF ~SeekService(object.type, service, member, baseType) THEN
baseType := NIL;
END;
END GetSupportedBaseType;
PROCEDURE GetSupportedBaseType*(object: Object; service: Service;
VAR baseType: Type);
VAR
member: ServiceList;
BEGIN
IF ~SeekService(object.type, service, member, baseType) THEN
baseType := NIL;
END;
END GetSupportedBaseType;
BEGIN
currentBuf := NIL; currentPos := 0; loaderIF := NIL;
currentBuf := NIL; currentPos := 0; loaderIF := NIL;
END ulmServices.

455
src/library/ulm/ulmStreamDisciplines.Mod
View file

@ -1,246 +1,249 @@
(* 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.
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.
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: StreamDisci.om,v 1.2 1994/07/04 14:53:25 borchert Exp $
----------------------------------------------------------------------------
$Log: StreamDisci.om,v $
Revision 1.2 1994/07/04 14:53:25 borchert
parameter for indentation width added
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: StreamDisci.om,v 1.2 1994/07/04 14:53:25 borchert Exp $
----------------------------------------------------------------------------
$Log: StreamDisci.om,v $
Revision 1.2 1994/07/04 14:53:25 borchert
parameter for indentation width added
Revision 1.1 1994/02/22 20:10:34 borchert
Initial revision
Revision 1.1 1994/02/22 20:10:34 borchert
Initial revision
----------------------------------------------------------------------------
AFB 10/91
----------------------------------------------------------------------------
----------------------------------------------------------------------------
AFB 10/91
----------------------------------------------------------------------------
*)
MODULE ulmStreamDisciplines;
(* definition of general-purpose disciplines for streams *)
(* definition of general-purpose disciplines for streams *)
IMPORT ASCII := ulmASCII, Disciplines := ulmIndirectDisciplines, Events := ulmEvents, Sets := ulmSets, Streams := ulmStreams, SYSTEM;
IMPORT ASCII := ulmASCII, Disciplines := ulmIndirectDisciplines, Events := ulmEvents, Sets := ulmSets, Streams := ulmStreams, SYSTEM;
TYPE
LineTerminator* = ARRAY 4 OF CHAR;
VAR
badfieldsepset*: Events.EventType;
TYPE
LineTerminator* = ARRAY 4 OF CHAR;
VAR
badfieldsepset*: Events.EventType;
TYPE
StreamDiscipline = POINTER TO StreamDisciplineRec;
StreamDisciplineRec =
RECORD
(Disciplines.DisciplineRec)
lineterm: LineTerminator;
fieldseps: Sets.CharSet;
fieldsep: CHAR; (* one of them *)
whitespace: Sets.CharSet;
indentwidth: INTEGER;
END;
VAR
id: Disciplines.Identifier;
(* default values *)
defaultFieldSeps: Sets.CharSet;
defaultFieldSep: CHAR;
defaultLineTerm: LineTerminator;
defaultWhiteSpace: Sets.CharSet;
defaultIndentWidth: INTEGER;
PROCEDURE InitDiscipline(VAR disc: StreamDiscipline);
BEGIN
NEW(disc); disc.id := id;
disc.fieldseps := defaultFieldSeps;
disc.fieldsep := defaultFieldSep;
disc.lineterm := defaultLineTerm;
disc.whitespace := defaultWhiteSpace;
disc.indentwidth := defaultIndentWidth;
END InitDiscipline;
PROCEDURE SetLineTerm*(s: Streams.Stream; lineterm: LineTerminator);
VAR
disc: StreamDiscipline;
BEGIN
IF ~Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN
InitDiscipline(disc);
TYPE
StreamDiscipline = POINTER TO StreamDisciplineRec;
StreamDisciplineRec =
RECORD
(Disciplines.DisciplineRec)
lineterm: LineTerminator;
fieldseps: Sets.CharSet;
fieldsep: CHAR; (* one of them *)
whitespace: Sets.CharSet;
indentwidth: INTEGER;
END;
disc.lineterm := lineterm;
VAR
id: Disciplines.Identifier;
(* default values *)
defaultFieldSeps: Sets.CharSet;
defaultFieldSep: CHAR;
defaultLineTerm: LineTerminator;
defaultWhiteSpace: Sets.CharSet;
defaultIndentWidth: INTEGER;
PROCEDURE InitDiscipline(VAR disc: Disciplines.Discipline);
VAR
sdisc: StreamDiscipline;
BEGIN
NEW(sdisc); sdisc.id := id;
sdisc.fieldseps := defaultFieldSeps;
sdisc.fieldsep := defaultFieldSep;
sdisc.lineterm := defaultLineTerm;
sdisc.whitespace := defaultWhiteSpace;
sdisc.indentwidth := defaultIndentWidth;
disc := sdisc
END InitDiscipline;
PROCEDURE SetLineTerm*(s: Streams.Stream; lineterm: LineTerminator);
VAR
disc: Disciplines.Discipline;
BEGIN
IF ~Disciplines.Seek(s, id, disc) THEN
InitDiscipline(disc);
END;
disc(StreamDiscipline).lineterm := lineterm;
Disciplines.Add(s, disc);
END SetLineTerm;
PROCEDURE GetLineTerm*(s: Streams.Stream; VAR lineterm: LineTerminator);
(* default line terminator is ASCII.nl *)
VAR
disc: Disciplines.Discipline;
BEGIN
IF Disciplines.Seek(s, id, disc) THEN
lineterm := disc(StreamDiscipline).lineterm;
ELSE
lineterm := defaultLineTerm;
END;
END GetLineTerm;
PROCEDURE SetFieldSepSet*(s: Streams.Stream; fieldsepset: Sets.CharSet);
(* cardinality of fieldsepset must be >= 1 *)
VAR
disc: Disciplines.Discipline;
ch: CHAR; found: BOOLEAN;
fieldsep: CHAR;
event: Events.Event;
BEGIN
ch := 0X;
LOOP (* seek for the first element inside fieldsepset *)
IF Sets.CharIn(fieldsepset, ch) THEN
found := TRUE; fieldsep := ch; EXIT
END;
IF ch = MAX(CHAR) THEN
found := FALSE; EXIT
END;
ch := CHR(ORD(ch) + 1);
END;
IF ~found THEN
NEW(event);
event.message := "StreamDisciplines.SetFieldSepSet: empty fieldsepset";
event.type := badfieldsepset;
Events.Raise(event);
RETURN
END;
IF ~Disciplines.Seek(s, id, disc) THEN
InitDiscipline(disc);
END;
disc(StreamDiscipline).fieldseps := fieldsepset;
disc(StreamDiscipline).fieldsep := fieldsep;
Disciplines.Add(s, disc);
END SetFieldSepSet;
PROCEDURE GetFieldSepSet*(s: Streams.Stream; VAR fieldsepset: Sets.CharSet);
(* default field separators are ASCII.tab and ASCII.sp *)
VAR
disc: Disciplines.Discipline;
BEGIN
IF Disciplines.Seek(s, id, disc) THEN
fieldsepset := disc(StreamDiscipline).fieldseps;
ELSE
fieldsepset := defaultFieldSeps;
END;
END GetFieldSepSet;
PROCEDURE SetFieldSep*(s: Streams.Stream; fieldsep: CHAR);
VAR
disc: Disciplines.Discipline;
BEGIN
IF ~Disciplines.Seek(s, id, disc) THEN
InitDiscipline(disc);
END;
Sets.InclChar(disc(StreamDiscipline).fieldseps, fieldsep);
disc(StreamDiscipline).fieldsep := fieldsep;
Disciplines.Add(s, disc);
END SetFieldSep;
PROCEDURE GetFieldSep*(s: Streams.Stream; VAR fieldsep: CHAR);
(* default field separator is ASCII.tab;
if a set of field separators has been given via SetFieldSepSet,
one of them is returned
*)
VAR
disc: Disciplines.Discipline;
BEGIN
IF Disciplines.Seek(s, id, disc) THEN
fieldsep := disc(StreamDiscipline).fieldsep;
ELSE
fieldsep := defaultFieldSep;
END;
END GetFieldSep;
PROCEDURE GetWhiteSpace*(s: Streams.Stream; VAR whitespace: Sets.CharSet);
(* default: ASCII.tab, ASCII.sp, ASCII.np and ASCII.nl *)
VAR
disc: Disciplines.Discipline;
BEGIN
IF Disciplines.Seek(s, id, disc) THEN
whitespace := disc(StreamDiscipline).whitespace;
ELSE
whitespace := defaultWhiteSpace;
END;
END GetWhiteSpace;
PROCEDURE SetWhiteSpace*(s: Streams.Stream; whitespace: Sets.CharSet);
VAR
disc: Disciplines.Discipline;
BEGIN
IF ~Disciplines.Seek(s, id, disc) THEN
InitDiscipline(disc);
END;
disc(StreamDiscipline).whitespace := whitespace;
Disciplines.Add(s, disc);
END SetWhiteSpace;
PROCEDURE SetIndentationWidth*(s: Streams.Stream; indentwidth: INTEGER);
VAR
disc: Disciplines.Discipline;
BEGIN
IF indentwidth >= 0 THEN
IF ~Disciplines.Seek(s, id, disc) THEN
InitDiscipline(disc);
END;
disc(StreamDiscipline).indentwidth := indentwidth;
Disciplines.Add(s, disc);
END SetLineTerm;
END;
END SetIndentationWidth;
PROCEDURE GetLineTerm*(s: Streams.Stream; VAR lineterm: LineTerminator);
(* default line terminator is ASCII.nl *)
VAR
disc: StreamDiscipline;
BEGIN
IF Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN
lineterm := disc.lineterm;
ELSE
lineterm := defaultLineTerm;
END;
END GetLineTerm;
PROCEDURE GetIndentationWidth*(s: Streams.Stream; VAR indentwidth: INTEGER);
VAR
disc: Disciplines.Discipline;
BEGIN
IF Disciplines.Seek(s, id, disc) THEN
indentwidth := disc(StreamDiscipline).indentwidth;
ELSE
indentwidth := defaultIndentWidth;
END;
END GetIndentationWidth;
PROCEDURE SetFieldSepSet*(s: Streams.Stream; fieldsepset: Sets.CharSet);
(* cardinality of fieldsepset must be >= 1 *)
VAR
disc: StreamDiscipline;
ch: CHAR; found: BOOLEAN;
fieldsep: CHAR;
event: Events.Event;
BEGIN
ch := 0X;
LOOP (* seek for the first element inside fieldsepset *)
IF Sets.CharIn(fieldsepset, ch) THEN
found := TRUE; fieldsep := ch; EXIT
END;
IF ch = MAX(CHAR) THEN
found := FALSE; EXIT
END;
ch := CHR(ORD(ch) + 1);
END;
IF ~found THEN
NEW(event);
event.message := "StreamDisciplines.SetFieldSepSet: empty fieldsepset";
event.type := badfieldsepset;
Events.Raise(event);
RETURN
END;
IF ~Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN
InitDiscipline(disc);
END;
disc.fieldseps := fieldsepset;
disc.fieldsep := fieldsep;
Disciplines.Add(s, disc);
END SetFieldSepSet;
PROCEDURE GetFieldSepSet*(s: Streams.Stream; VAR fieldsepset: Sets.CharSet);
(* default field separators are ASCII.tab and ASCII.sp *)
VAR
disc: StreamDiscipline;
BEGIN
IF Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN
fieldsepset := disc.fieldseps;
ELSE
fieldsepset := defaultFieldSeps;
END;
END GetFieldSepSet;
PROCEDURE SetFieldSep*(s: Streams.Stream; fieldsep: CHAR);
VAR
disc: StreamDiscipline;
BEGIN
IF ~Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN
InitDiscipline(disc);
END;
Sets.InclChar(disc.fieldseps, fieldsep);
disc.fieldsep := fieldsep;
Disciplines.Add(s, disc);
END SetFieldSep;
PROCEDURE GetFieldSep*(s: Streams.Stream; VAR fieldsep: CHAR);
(* default field separator is ASCII.tab;
if a set of field separators has been given via SetFieldSepSet,
one of them is returned
*)
VAR
disc: StreamDiscipline;
BEGIN
IF Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN
fieldsep := disc.fieldsep;
ELSE
fieldsep := defaultFieldSep;
END;
END GetFieldSep;
PROCEDURE GetWhiteSpace*(s: Streams.Stream; VAR whitespace: Sets.CharSet);
(* default: ASCII.tab, ASCII.sp, ASCII.np and ASCII.nl *)
VAR
disc: StreamDiscipline;
BEGIN
IF Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN
whitespace := disc.whitespace;
ELSE
whitespace := defaultWhiteSpace;
END;
END GetWhiteSpace;
PROCEDURE SetWhiteSpace*(s: Streams.Stream; whitespace: Sets.CharSet);
VAR
disc: StreamDiscipline;
BEGIN
IF ~Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN
InitDiscipline(disc);
END;
disc.whitespace := whitespace;
Disciplines.Add(s, disc);
END SetWhiteSpace;
PROCEDURE SetIndentationWidth*(s: Streams.Stream; indentwidth: INTEGER);
VAR
disc: StreamDiscipline;
BEGIN
IF indentwidth >= 0 THEN
IF ~Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN
InitDiscipline(disc);
END;
disc.indentwidth := indentwidth;
Disciplines.Add(s, disc);
END;
END SetIndentationWidth;
PROCEDURE GetIndentationWidth*(s: Streams.Stream; VAR indentwidth: INTEGER);
VAR
disc: StreamDiscipline;
BEGIN
IF Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN
indentwidth := disc.indentwidth;
ELSE
indentwidth := defaultIndentWidth;
END;
END GetIndentationWidth;
PROCEDURE IncrIndentationWidth*(s: Streams.Stream; incr: INTEGER);
VAR
disc: StreamDiscipline;
BEGIN
IF ~Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN
InitDiscipline(disc);
END;
IF disc.indentwidth + incr >= 0 THEN
INC(disc.indentwidth, incr);;
END;
Disciplines.Add(s, disc);
END IncrIndentationWidth;
PROCEDURE IncrIndentationWidth*(s: Streams.Stream; incr: INTEGER);
VAR
disc: Disciplines.Discipline;
BEGIN
IF ~Disciplines.Seek(s, id, disc) THEN
InitDiscipline(disc);
END;
IF disc(StreamDiscipline).indentwidth + incr >= 0 THEN
INC(disc(StreamDiscipline).indentwidth, incr);;
END;
Disciplines.Add(s, disc);
END IncrIndentationWidth;
BEGIN
Events.Define(badfieldsepset);
Events.Define(badfieldsepset);
id := Disciplines.Unique();
Sets.InitSet(defaultFieldSeps);
Sets.InclChar(defaultFieldSeps, ASCII.tab);
Sets.InclChar(defaultFieldSeps, ASCII.sp);
defaultFieldSep := ASCII.tab;
defaultLineTerm[0] := ASCII.nl; defaultLineTerm[1] := 0X;
Sets.InitSet(defaultWhiteSpace);
Sets.InclChar(defaultWhiteSpace, ASCII.tab);
Sets.InclChar(defaultWhiteSpace, ASCII.sp);
Sets.InclChar(defaultWhiteSpace, ASCII.np);
Sets.InclChar(defaultWhiteSpace, ASCII.nl);
defaultIndentWidth := 0;
id := Disciplines.Unique();
Sets.InitSet(defaultFieldSeps);
Sets.InclChar(defaultFieldSeps, ASCII.tab);
Sets.InclChar(defaultFieldSeps, ASCII.sp);
defaultFieldSep := ASCII.tab;
defaultLineTerm[0] := ASCII.nl; defaultLineTerm[1] := 0X;
Sets.InitSet(defaultWhiteSpace);
Sets.InclChar(defaultWhiteSpace, ASCII.tab);
Sets.InclChar(defaultWhiteSpace, ASCII.sp);
Sets.InclChar(defaultWhiteSpace, ASCII.np);
Sets.InclChar(defaultWhiteSpace, ASCII.nl);
defaultIndentWidth := 0;
END ulmStreamDisciplines.

4110
src/library/ulm/ulmStreams.Mod
View file

File diff suppressed because it is too large Load diff

79
src/library/ulm/ulmSysIO.Mod
View file

@ -30,7 +30,10 @@
MODULE ulmSysIO;
IMPORT RelatedEvents := ulmRelatedEvents, Sys := ulmSys, SYS := SYSTEM, ulmSYSTEM, SysErrors := ulmSysErrors, SysTypes := ulmSysTypes;
IMPORT RelatedEvents := ulmRelatedEvents,
Sys := ulmSys, SYS := SYSTEM, ulmSYSTEM,
SysErrors := ulmSysErrors, SysTypes := ulmSysTypes,
Platform;
CONST
(* file control options: arguments of Fcntl and Open *)
@ -86,20 +89,20 @@ MODULE ulmSysIO;
retry: BOOLEAN; VAR interrupted: BOOLEAN) : BOOLEAN;
(* the filename must be 0X-terminated *)
VAR
d0, d1: (*INTEGER*)LONGINT;
error: Platform.ErrorCode;
BEGIN
interrupted := FALSE;
LOOP
IF ulmSYSTEM.UNIXCALL(Sys.open, d0, d1,
SYS.ADR(filename), SYS.VAL(LONGINT, options), protection) THEN
fd := d0;
RETURN TRUE
IF options * creat # {} THEN error := Platform.New(filename, fd)
ELSIF options * (rdwr+wronly) # {} THEN error := Platform.OldRW(filename, fd)
ELSE error := Platform.OldRO(filename, fd) END;
IF error = 0 THEN RETURN TRUE
ELSE
IF d0 = SysErrors.intr THEN
IF Platform.Interrupted(error) THEN
interrupted := TRUE;
END;
IF (d0 # SysErrors.intr) OR ~retry THEN
SysErrors.Raise(errors, d0, Sys.open, filename);
IF ~Platform.Interrupted(error) OR ~retry THEN
SysErrors.Raise(errors, error, Sys.open, filename);
RETURN FALSE
END;
END;
@ -119,21 +122,18 @@ MODULE ulmSysIO;
errors: RelatedEvents.Object;
retry: BOOLEAN; VAR interrupted: BOOLEAN) : BOOLEAN;
VAR
d0, d1: LONGINT;
a0, a1 : LONGINT; (* just to match UNIXCALL interface *)
error: Platform.ErrorCode;
BEGIN
interrupted := FALSE;
a0 := 0; a1 := 0; (* Initialised to disable compiler warning. *)
LOOP
IF ulmSYSTEM.UNIXCALL(Sys.close, d0, d1, fd, a0, a1) THEN
(*IF ulmSYSTEM.UNIXCALL(Sys.close, d0, d1, fd) THEN*)
RETURN TRUE
error := Platform.Close(fd);
IF error = 0 THEN RETURN TRUE
ELSE
IF d0 = SysErrors.intr THEN
IF Platform.Interrupted(error) THEN
interrupted := TRUE;
END;
IF (d0 # SysErrors.intr) OR ~retry THEN
SysErrors.Raise(errors, d0, Sys.close, "");
IF ~Platform.Interrupted(error) OR ~retry THEN
SysErrors.Raise(errors, error, Sys.close, "");
RETURN FALSE
END;
END;
@ -148,18 +148,19 @@ MODULE ulmSysIO;
>0: number of bytes read
*)
VAR
d0, d1: LONGINT;
error: Platform.ErrorCode;
bytesread: Count;
BEGIN
interrupted := FALSE;
LOOP
IF ulmSYSTEM.UNIXCALL(Sys.read, d0, d1, fd, buf, cnt) THEN
RETURN d0
error := Platform.Read(fd, buf, cnt, bytesread);
IF error = 0 THEN RETURN bytesread
ELSE
IF d0 = SysErrors.intr THEN
IF Platform.Interrupted(error) THEN
interrupted := TRUE;
END;
IF (d0 # SysErrors.intr) OR ~retry THEN
SysErrors.Raise(errors, d0, Sys.read, "");
IF ~Platform.Interrupted(error) OR ~retry THEN
SysErrors.Raise(errors, error, Sys.read, "");
RETURN -1
END;
END;
@ -173,18 +174,19 @@ MODULE ulmSysIO;
>=0: number of bytes written
*)
VAR
d0, d1: LONGINT;
error: Platform.ErrorCode;
byteswritten: Count;
BEGIN
interrupted := FALSE;
LOOP
IF ulmSYSTEM.UNIXCALL(Sys.write, d0, d1, fd, buf, cnt) THEN
RETURN d0
error := Platform.Write(fd, buf, cnt);
IF error = 0 THEN RETURN cnt (* todo: Upfate Platform.Write to return actual length written. *)
ELSE
IF d0 = SysErrors.intr THEN
IF Platform.Interrupted(error) THEN
interrupted := TRUE;
END;
IF (d0 # SysErrors.intr) OR ~retry THEN
SysErrors.Raise(errors, d0, Sys.write, "");
IF ~Platform.Interrupted(error) OR ~retry THEN
SysErrors.Raise(errors, error, Sys.write, "");
RETURN -1
END;
END;
@ -194,16 +196,23 @@ MODULE ulmSysIO;
PROCEDURE Seek*(fd: File; offset: Count; whence: Whence;
errors: RelatedEvents.Object) : BOOLEAN;
VAR
d0, d1: LONGINT;
error: Platform.ErrorCode; relativity: INTEGER;
BEGIN
IF ulmSYSTEM.UNIXCALL(Sys.lseek, d0, d1, fd, offset, whence) THEN
RETURN TRUE
CASE whence OF
|fromPos: relativity := Platform.SeekCur
|fromEnd: relativity := Platform.SeekEnd
ELSE relativity := Platform.SeekSet
END;
error := Platform.Seek(fd, offset, relativity);
IF error = 0 THEN RETURN TRUE
ELSE
SysErrors.Raise(errors, d0, Sys.lseek, "");
SysErrors.Raise(errors, error, Sys.lseek, "");
RETURN FALSE
END;
END Seek;
(*
PROCEDURE Tell*(fd: File; VAR offset: Count;
errors: RelatedEvents.Object) : BOOLEAN;
VAR
@ -229,7 +238,6 @@ MODULE ulmSysIO;
(* following system call fails for non-tty's *)
RETURN ulmSYSTEM.UNIXCALL(Sys.ioctl, d0, d1, fd, tcgeta, SYS.ADR(buf))
END Isatty;
PROCEDURE Fcntl*(fd: File; request: INTEGER; VAR arg: LONGINT;
errors: RelatedEvents.Object;
retry: BOOLEAN; VAR interrupted: BOOLEAN) : BOOLEAN;
@ -343,5 +351,6 @@ MODULE ulmSysIO;
RETURN FALSE
END;
END Pipe;
*)
END ulmSysIO.

12
src/library/ulm/ulmSysTypes.Mod
View file

@ -30,7 +30,7 @@
MODULE ulmSysTypes;
IMPORT Types := ulmTypes;
IMPORT Types := ulmTypes, Platform;
TYPE
Address* = Types.Address;
@ -39,17 +39,17 @@ MODULE ulmSysTypes;
Size* = Types.Size;
Byte* = Types.Byte;
File* = (*INTEGER*)LONGINT; (* in ulm's system both INTEGER and LONGINT are 4 bytes long *)
File* = Platform.FileHandle;
Offset* = LONGINT;
Device* = LONGINT;
Inode* = LONGINT;
Time* = LONGINT;
Inode* = LONGINT;
Time* = LONGINT;
Word* = INTEGER; (* must have the size of C's int-type *)
Word* = INTEGER; (* must have the size of C's int-type *)
(* Note: linux supports wait4 but not waitid, i.e. these
* constants aren't needed. *)
(*
(*
CONST
(* possible values of the idtype parameter (4 bytes),
see <sys/procset.h>

3300
src/library/ulm/ulmTCrypt.Mod
View file

File diff suppressed because it is too large Load diff

742
src/library/ulm/ulmTimeConditions.Mod
View file

@ -1,406 +1,412 @@
(* Ulm's Oberon Library
Copyright (C) 1989-2004 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.
Copyright (C) 1989-2004 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.
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: TimeConditi.om,v 1.5 2004/04/05 16:23:37 borchert Exp $
----------------------------------------------------------------------------
$Log: TimeConditi.om,v $
Revision 1.5 2004/04/05 16:23:37 borchert
bug fix: Test must not call anything which causes directly or
indirectly WaitFor to be called; hence we schedule
a timer event in all cases where this is possible;
the only exception remains Clocks.system where we
take it for granted that the clock operations are
that simple that they do not lead to WaitFor
(was necessary to get RemoteClocks working again)
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: TimeConditi.om,v 1.5 2004/04/05 16:23:37 borchert Exp $
----------------------------------------------------------------------------
$Log: TimeConditi.om,v $
Revision 1.5 2004/04/05 16:23:37 borchert
bug fix: Test must not call anything which causes directly or
indirectly WaitFor to be called; hence we schedule
a timer event in all cases where this is possible;
the only exception remains Clocks.system where we
take it for granted that the clock operations are
that simple that they do not lead to WaitFor
(was necessary to get RemoteClocks working again)
Revision 1.4 2004/02/19 15:23:10 borchert
- Init added to support extensions of TimeConditions.Condition
- using Clocks.Passed instead of Clocks.GetTime in some instances
to reduce the number of system calls needed
- Timers event is only generated now if strictly needed,
i.e. if SendEvent has been called
Revision 1.4 2004/02/19 15:23:10 borchert
- Init added to support extensions of TimeConditions.Condition
- using Clocks.Passed instead of Clocks.GetTime in some instances
to reduce the number of system calls needed
- Timers event is only generated now if strictly needed,
i.e. if SendEvent has been called
Revision 1.3 2001/04/30 15:25:12 borchert
several improvements / bug fixes in context of domain-oriented
condition handling
Revision 1.3 2001/04/30 15:25:12 borchert
several improvements / bug fixes in context of domain-oriented
condition handling
Revision 1.2 1995/04/06 14:36:16 borchert
fixes due to changed if & semantics of Conditions
Revision 1.2 1995/04/06 14:36:16 borchert
fixes due to changed if & semantics of Conditions
Revision 1.1 1994/02/22 20:11:18 borchert
Initial revision
Revision 1.1 1994/02/22 20:11:18 borchert
Initial revision
----------------------------------------------------------------------------
AFB 1/92
----------------------------------------------------------------------------
----------------------------------------------------------------------------
AFB 1/92
----------------------------------------------------------------------------
*)
MODULE ulmTimeConditions;
IMPORT Clocks := ulmClocks, Conditions := ulmConditions, Disciplines := ulmDisciplines, Events := ulmEvents, Op := ulmOperations,
Priorities := ulmPriorities, Process := ulmProcess, RelatedEvents := ulmRelatedEvents, Scales := ulmScales, Timers := ulmTimers, Times := ulmTimes, SYSTEM;
IMPORT
Clocks := ulmClocks, Conditions := ulmConditions, Disciplines := ulmDisciplines,
Events := ulmEvents, Op := ulmOperations, Priorities := ulmPriorities,
Process := ulmProcess, RelatedEvents := ulmRelatedEvents, Scales := ulmScales,
Timers := ulmTimers, Times := ulmTimes;
TYPE
Domain = POINTER TO DomainRec;
DomainRec =
RECORD
(Conditions.DomainRec)
clock: Clocks.Clock;
alarm: Events.EventType;
event: Events.Event; (* event of SendEvent *)
END;
Condition = POINTER TO ConditionRec;
ConditionRec* =
RECORD
(Conditions.ConditionRec)
time: Times.Time;
passed: BOOLEAN; (* becomes TRUE if the time has passed *)
scheduled: BOOLEAN; (* Timer event scheduled? *)
domain: Domain;
END;
TYPE
(* this discpline will be attached to clocks *)
Discipline = POINTER TO DisciplineRec;
DisciplineRec =
RECORD
(Disciplines.DisciplineRec)
domain: Domain;
END;
VAR
disciplineId: Disciplines.Identifier;
TYPE
WakeupEvent = POINTER TO WakeupEventRec;
WakeupEventRec =
RECORD
(Events.EventRec)
condition: Condition;
awaked: BOOLEAN; (* set to true by Wakeup event handler *)
END;
VAR
if: Conditions.Interface;
PROCEDURE FixTime(VAR time: Times.Time;
currentTime: Times.Time;
clock: Clocks.Clock);
(* convert relative time measures into absolute time specs *)
BEGIN
IF Scales.IsRelative(time) THEN
Clocks.GetTime(clock, currentTime);
Op.Add3(SYSTEM.VAL(Op.Operand, time), currentTime, time);
TYPE
Domain = POINTER TO DomainRec;
DomainRec =
RECORD
(Conditions.DomainRec)
clock: Clocks.Clock;
alarm: Events.EventType;
event: Events.Event; (* event of SendEvent *)
END;
END FixTime;
PROCEDURE Wakeup(event: Events.Event);
(* note that we strictly rely on the capability of the
underlying clock to raise this event at the appropriate
time; we are unable to verify it because that could
deadlock us in case of remote clocks
*)
VAR
condevent: Events.Event; (* event requested by SendEvent *)
BEGIN
WITH event: WakeupEvent DO
event.awaked := TRUE;
IF event.condition # NIL THEN
event.condition.passed := TRUE;
event.condition.scheduled := FALSE;
condevent := event.condition.domain.event;
IF condevent # NIL THEN
event.condition.domain.event := NIL;
Events.Raise(condevent);
END;
END;
Condition = POINTER TO ConditionRec;
ConditionRec* =
RECORD
(Conditions.ConditionRec)
time: Times.Time;
passed: BOOLEAN; (* becomes TRUE if the time has passed *)
scheduled: BOOLEAN; (* Timer event scheduled? *)
domain: Domain;
END;
END Wakeup;
PROCEDURE ScheduleEvent(condition: Condition);
VAR
wakeup: WakeupEvent;
domain: Domain;
BEGIN
IF ~condition.scheduled THEN
domain := condition.domain;
ASSERT(domain.alarm # NIL);
NEW(wakeup); wakeup.type := domain.alarm;
wakeup.awaked := FALSE; wakeup.condition := condition;
condition.scheduled := TRUE;
Timers.Schedule(domain.clock, condition.time, wakeup);
TYPE
(* this discpline will be attached to clocks *)
Discipline = POINTER TO DisciplineRec;
DisciplineRec =
RECORD
(Disciplines.DisciplineRec)
domain: Domain;
END;
END ScheduleEvent;
VAR
disciplineId: Disciplines.Identifier;
PROCEDURE Init*(condition: Condition; clock: Clocks.Clock; time: Times.Time);
(* like Create but without NEW *)
VAR
clockDisc: Discipline;
domain: Domain;
desc: Conditions.Description;
priorityOfClock: Priorities.Priority;
currentTime: Times.Time;
BEGIN
IF Disciplines.Seek(clock, disciplineId, SYSTEM.VAL(Disciplines.Discipline, clockDisc)) THEN
domain := clockDisc.domain;
ELSE
(* create new domain *)
NEW(desc); desc.caps := {}; desc.internal := TRUE;
IF clock = Clocks.system THEN
desc.caps := desc.caps +
{Conditions.timelimit, Conditions.timecond};
END;
IF Clocks.timer IN Clocks.Capabilities(clock) THEN
Clocks.GetPriority(clock, priorityOfClock);
IF priorityOfClock > Priorities.base THEN
desc.caps := desc.caps + {Conditions.select, Conditions.async};
desc.internal := priorityOfClock < Priorities.interrupts;
END;
END;
NEW(domain); Conditions.InitDomain(domain, if, desc);
domain.clock := clock;
IF Clocks.timer IN Clocks.Capabilities(clock) THEN
Events.Define(domain.alarm);
Events.SetPriority(domain.alarm, priorityOfClock + 1);
Events.Handler(domain.alarm, Wakeup);
ELSE
domain.alarm := NIL;
END;
NEW(clockDisc); clockDisc.id := disciplineId;
clockDisc.domain := domain;
Disciplines.Add(clock, clockDisc);
domain.event := NIL;
TYPE
WakeupEvent = POINTER TO WakeupEventRec;
WakeupEventRec =
RECORD
(Events.EventRec)
condition: Condition;
awaked: BOOLEAN; (* set to true by Wakeup event handler *)
END;
Conditions.Init(condition, domain);
FixTime(time, currentTime, clock); condition.time := time;
condition.domain := domain;
condition.passed := Clocks.Passed(clock, time);
condition.scheduled := FALSE;
IF ~condition.passed &
(domain.alarm # NIL) & (clock # Clocks.system) THEN
ScheduleEvent(condition);
END;
END Init;
PROCEDURE Create*(VAR condition: Conditions.Condition;
clock: Clocks.Clock; time: Times.Time);
(* create and initialize a time condition:
is the current time of the clock greater than or
equal to `time';
if time is relative then it is taken relative to the current time
*)
VAR
timeCond: Condition;
BEGIN
NEW(timeCond);
Init(timeCond, clock, time);
condition := timeCond;
END Create;
VAR
if: Conditions.Interface;
(* ======== interface procedures ================================ *)
PROCEDURE GetTime(clock: Clocks.Clock;
VAR currentTime: Times.Time;
errors: RelatedEvents.Object) : BOOLEAN;
(* get the current time of clock and check for errors *)
VAR
oldEvents, newEvents: RelatedEvents.Queue;
BEGIN
RelatedEvents.GetQueue(clock, oldEvents);
PROCEDURE FixTime(VAR time: Times.Time;
currentTime: Times.Time;
clock: Clocks.Clock);
(* convert relative time measures into absolute time specs *)
VAR op: Op.Operand;
BEGIN
IF Scales.IsRelative(time) THEN
Clocks.GetTime(clock, currentTime);
RelatedEvents.GetQueue(clock, newEvents);
IF newEvents # NIL THEN
RelatedEvents.AppendQueue(errors, newEvents);
END;
IF oldEvents # NIL THEN
RelatedEvents.AppendQueue(clock, oldEvents);
END;
IF newEvents # NIL THEN
RelatedEvents.AppendQueue(clock, newEvents);
END;
RETURN newEvents = NIL
END GetTime;
op := time; Op.Add3(op, currentTime, time); time := op(Times.Time)
END;
END FixTime;
PROCEDURE Passed(clock: Clocks.Clock;
time: Times.Time;
VAR passed: BOOLEAN;
errors: RelatedEvents.Object) : BOOLEAN;
VAR
oldEvents, newEvents: RelatedEvents.Queue;
BEGIN
RelatedEvents.GetQueue(clock, oldEvents);
passed := Clocks.Passed(clock, time);
RelatedEvents.GetQueue(clock, newEvents);
IF newEvents # NIL THEN
RelatedEvents.AppendQueue(errors, newEvents);
PROCEDURE Wakeup(event: Events.Event);
(* note that we strictly rely on the capability of the
underlying clock to raise this event at the appropriate
time; we are unable to verify it because that could
deadlock us in case of remote clocks
*)
VAR
condevent: Events.Event; (* event requested by SendEvent *)
BEGIN
WITH event: WakeupEvent DO
event.awaked := TRUE;
IF event.condition # NIL THEN
event.condition.passed := TRUE;
event.condition.scheduled := FALSE;
condevent := event.condition.domain.event;
IF condevent # NIL THEN
event.condition.domain.event := NIL;
Events.Raise(condevent);
END;
END;
IF oldEvents # NIL THEN
RelatedEvents.AppendQueue(clock, oldEvents);
END;
IF newEvents # NIL THEN
RelatedEvents.AppendQueue(clock, newEvents);
END;
RETURN newEvents = NIL
END Passed;
END;
END Wakeup;
PROCEDURE Test(domain: Conditions.Domain; condition: Conditions.Condition;
errors: RelatedEvents.Object) : BOOLEAN;
VAR
currentTime: Times.Time;
BEGIN
WITH domain: Domain DO WITH condition: Condition DO
IF condition.passed THEN RETURN TRUE END;
IF condition.domain.event # NIL THEN RETURN FALSE END;
IF condition.scheduled THEN RETURN FALSE END;
IF ~Passed(domain.clock, condition.time,
condition.passed, errors) THEN
condition.passed := TRUE;
RETURN TRUE
END;
RETURN condition.passed
END; END;
END Test;
PROCEDURE ScheduleEvent(condition: Condition);
VAR
wakeup: WakeupEvent;
domain: Domain;
BEGIN
IF ~condition.scheduled THEN
domain := condition.domain;
ASSERT(domain.alarm # NIL);
NEW(wakeup); wakeup.type := domain.alarm;
wakeup.awaked := FALSE; wakeup.condition := condition;
condition.scheduled := TRUE;
Timers.Schedule(domain.clock, condition.time, wakeup);
END;
END ScheduleEvent;
PROCEDURE GetMinTime(conditionSet: Conditions.ConditionSet;
VAR minTime: Times.Time;
VAR minCond: Condition);
PROCEDURE Init*(condition: Condition; clock: Clocks.Clock; time: Times.Time);
(* like Create but without NEW *)
VAR
clockDisc: Discipline;
disc: Disciplines.Discipline;
domain: Domain;
desc: Conditions.Description;
priorityOfClock: Priorities.Priority;
currentTime: Times.Time;
BEGIN
IF Disciplines.Seek(clock, disciplineId, disc) THEN
domain := disc(Discipline).domain;
ELSE
(* create new domain *)
NEW(desc); desc.caps := {}; desc.internal := TRUE;
IF clock = Clocks.system THEN
desc.caps := desc.caps +
{Conditions.timelimit, Conditions.timecond};
END;
IF Clocks.timer IN Clocks.Capabilities(clock) THEN
Clocks.GetPriority(clock, priorityOfClock);
IF priorityOfClock > Priorities.base THEN
desc.caps := desc.caps + {Conditions.select, Conditions.async};
desc.internal := priorityOfClock < Priorities.interrupts;
END;
END;
NEW(domain); Conditions.InitDomain(domain, if, desc);
domain.clock := clock;
IF Clocks.timer IN Clocks.Capabilities(clock) THEN
Events.Define(domain.alarm);
Events.SetPriority(domain.alarm, priorityOfClock + 1);
Events.Handler(domain.alarm, Wakeup);
ELSE
domain.alarm := NIL;
END;
NEW(clockDisc); clockDisc.id := disciplineId;
clockDisc.domain := domain;
Disciplines.Add(clock, clockDisc);
domain.event := NIL;
END;
Conditions.Init(condition, domain);
FixTime(time, currentTime, clock); condition.time := time;
condition.domain := domain;
condition.passed := Clocks.Passed(clock, time);
condition.scheduled := FALSE;
IF ~condition.passed &
(domain.alarm # NIL) & (clock # Clocks.system) THEN
ScheduleEvent(condition);
END;
END Init;
PROCEDURE Create*(VAR condition: Conditions.Condition;
clock: Clocks.Clock; time: Times.Time);
(* create and initialize a time condition:
is the current time of the clock greater than or
equal to `time';
if time is relative then it is taken relative to the current time
*)
VAR
timeCond: Condition;
BEGIN
NEW(timeCond);
Init(timeCond, clock, time);
condition := timeCond;
END Create;
(* ======== interface procedures ================================ *)
PROCEDURE GetTime(clock: Clocks.Clock;
VAR currentTime: Times.Time;
errors: RelatedEvents.Object) : BOOLEAN;
(* get the current time of clock and check for errors *)
VAR
oldEvents, newEvents: RelatedEvents.Queue;
BEGIN
RelatedEvents.GetQueue(clock, oldEvents);
Clocks.GetTime(clock, currentTime);
RelatedEvents.GetQueue(clock, newEvents);
IF newEvents # NIL THEN
RelatedEvents.AppendQueue(errors, newEvents);
END;
IF oldEvents # NIL THEN
RelatedEvents.AppendQueue(clock, oldEvents);
END;
IF newEvents # NIL THEN
RelatedEvents.AppendQueue(clock, newEvents);
END;
RETURN newEvents = NIL
END GetTime;
PROCEDURE Passed(clock: Clocks.Clock;
time: Times.Time;
VAR passed: BOOLEAN;
errors: RelatedEvents.Object) : BOOLEAN;
VAR
oldEvents, newEvents: RelatedEvents.Queue;
BEGIN
RelatedEvents.GetQueue(clock, oldEvents);
passed := Clocks.Passed(clock, time);
RelatedEvents.GetQueue(clock, newEvents);
IF newEvents # NIL THEN
RelatedEvents.AppendQueue(errors, newEvents);
END;
IF oldEvents # NIL THEN
RelatedEvents.AppendQueue(clock, oldEvents);
END;
IF newEvents # NIL THEN
RelatedEvents.AppendQueue(clock, newEvents);
END;
RETURN newEvents = NIL
END Passed;
PROCEDURE Test(domain: Conditions.Domain; condition: Conditions.Condition;
errors: RelatedEvents.Object) : BOOLEAN;
VAR
currentTime: Times.Time;
BEGIN
WITH domain: Domain DO WITH condition: Condition DO
IF condition.passed THEN RETURN TRUE END;
IF condition.domain.event # NIL THEN RETURN FALSE END;
IF condition.scheduled THEN RETURN FALSE END;
IF ~Passed(domain.clock, condition.time,
condition.passed, errors) THEN
condition.passed := TRUE;
RETURN TRUE
END;
RETURN condition.passed
END; END;
END Test;
PROCEDURE GetMinTime(conditionSet: Conditions.ConditionSet;
VAR minTime: Times.Time;
VAR minCond: Condition);
VAR
condition: Conditions.Condition; (* Condition *)
op: Op.Operand;
BEGIN
minTime := NIL;
Conditions.ExamineConditions(conditionSet);
WHILE Conditions.GetNextCondition(conditionSet, condition) DO
IF (minTime = NIL) OR (Op.Compare(condition(Condition).time, minTime) < 0) THEN
minTime := condition(Condition).time; minCond := condition(Condition)
END;
END;
op := minTime; Op.Assign(op, minTime); minTime := op(Times.Time) (* take a copy *)
END GetMinTime;
PROCEDURE Select(domain: Conditions.Domain;
conditionSet: Conditions.ConditionSet;
time: Times.Time;
VAR setOfTrueConditions: Conditions.ConditionSet;
errors: RelatedEvents.Object;
retry: BOOLEAN;
VAR interrupted: BOOLEAN) : BOOLEAN;
VAR
minTime: Times.Time;
minCond: Condition;
currentTime: Times.Time; (* of Clocks.system *)
condition: Conditions.Condition; (* Condition *)
wakeup: WakeupEvent;
anythingTrue: BOOLEAN;
PROCEDURE Failure;
(* we are unable to retrieve the time;
so we have to mark all conditions as passed
and to return the whole set
*)
VAR
condition: Condition;
BEGIN
minTime := NIL;
condition: Conditions.Condition; (* Condition *)
BEGIN
Conditions.CreateSet(setOfTrueConditions);
Conditions.ExamineConditions(conditionSet);
WHILE Conditions.GetNextCondition(conditionSet, SYSTEM.VAL(Conditions.Condition, condition)) DO
IF (minTime = NIL) OR (Op.Compare(condition.time, minTime) < 0) THEN
minTime := condition.time; minCond := condition;
END;
WHILE Conditions.GetNextCondition(conditionSet, condition) DO
condition(Condition).passed := TRUE;
Conditions.Incl(setOfTrueConditions, condition(Condition));
END;
Op.Assign(SYSTEM.VAL(Op.Operand, minTime), minTime); (* take a copy *)
END GetMinTime;
END Failure;
PROCEDURE Select(domain: Conditions.Domain;
conditionSet: Conditions.ConditionSet;
time: Times.Time;
VAR setOfTrueConditions: Conditions.ConditionSet;
errors: RelatedEvents.Object;
retry: BOOLEAN;
VAR interrupted: BOOLEAN) : BOOLEAN;
VAR
minTime: Times.Time;
minCond: Condition;
currentTime: Times.Time; (* of Clocks.system *)
condition: Condition;
wakeup: WakeupEvent;
anythingTrue: BOOLEAN;
BEGIN (* Select *)
WITH domain: Domain DO
GetMinTime(conditionSet, minTime, minCond);
PROCEDURE Failure;
(* we are unable to retrieve the time;
so we have to mark all conditions as passed
and to return the whole set
*)
VAR
condition: Condition;
BEGIN
Conditions.CreateSet(setOfTrueConditions);
Conditions.ExamineConditions(conditionSet);
WHILE Conditions.GetNextCondition(conditionSet, SYSTEM.VAL(Conditions.Condition, condition)) DO
condition.passed := TRUE;
Conditions.Incl(setOfTrueConditions, condition);
END;
END Failure;
BEGIN (* Select *)
WITH domain: Domain DO
GetMinTime(conditionSet, minTime, minCond);
(* block current process, if necessary *)
interrupted := FALSE;
IF time # NIL THEN
Clocks.GetTime(Clocks.system, currentTime);
FixTime(time, currentTime, Clocks.system);
NEW(wakeup); wakeup.type := domain.alarm;
wakeup.condition := NIL; wakeup.awaked := FALSE;
Timers.Schedule(Clocks.system, time, wakeup);
END;
IF ~GetTime(domain.clock, currentTime, errors) THEN
Failure; RETURN TRUE
END;
IF ~minCond.passed THEN
LOOP (* goes only into loop if retry = TRUE & we get interrupted *)
Process.Pause;
IF wakeup.awaked THEN EXIT END;
interrupted := ~minCond.passed;
IF ~interrupted THEN EXIT END;
IF ~retry THEN RETURN FALSE END;
END;
END;
anythingTrue := FALSE;
Conditions.CreateSet(setOfTrueConditions);
Conditions.ExamineConditions(conditionSet);
WHILE Conditions.GetNextCondition(conditionSet, SYSTEM.VAL(Conditions.Condition, condition)) DO
IF condition.passed THEN
Conditions.Incl(setOfTrueConditions, condition);
anythingTrue := TRUE;
END;
END;
RETURN anythingTrue
(* block current process, if necessary *)
interrupted := FALSE;
IF time # NIL THEN
Clocks.GetTime(Clocks.system, currentTime);
FixTime(time, currentTime, Clocks.system);
NEW(wakeup); wakeup.type := domain.alarm;
wakeup.condition := NIL; wakeup.awaked := FALSE;
Timers.Schedule(Clocks.system, time, wakeup);
END;
IF ~GetTime(domain.clock, currentTime, errors) THEN
Failure; RETURN TRUE
END;
END Select;
PROCEDURE SendEvent(domain: Conditions.Domain;
condition: Conditions.Condition;
event: Events.Event;
errors: RelatedEvents.Object) : BOOLEAN;
BEGIN
WITH domain: Domain DO WITH condition: Condition DO
IF condition.passed THEN
RETURN FALSE
ELSE
domain.event := event;
ScheduleEvent(condition);
RETURN TRUE
END;
END; END;
END SendEvent;
IF ~minCond.passed THEN
LOOP (* goes only into loop if retry = TRUE & we get interrupted *)
Process.Pause;
IF wakeup.awaked THEN EXIT END;
interrupted := ~minCond.passed;
IF ~interrupted THEN EXIT END;
IF ~retry THEN RETURN FALSE END;
END;
END;
PROCEDURE GetNextTime(domain: Conditions.Domain;
conditionSet: Conditions.ConditionSet;
VAR nextTime: Times.Time;
VAR nextCond: Conditions.Condition;
errors: RelatedEvents.Object);
VAR
condition: Condition;
BEGIN
GetMinTime(conditionSet, nextTime, condition);
nextCond := condition;
END GetNextTime;
anythingTrue := FALSE;
Conditions.CreateSet(setOfTrueConditions);
Conditions.ExamineConditions(conditionSet);
WHILE Conditions.GetNextCondition(conditionSet, condition) DO
IF condition(Condition).passed THEN
Conditions.Incl(setOfTrueConditions, condition(Condition));
anythingTrue := TRUE;
END;
END;
RETURN anythingTrue
END;
END Select;
PROCEDURE InitInterface;
BEGIN
NEW(if);
if.test := Test;
if.select := Select;
if.sendevent := SendEvent;
if.gettime := GetNextTime;
END InitInterface;
PROCEDURE SendEvent(domain: Conditions.Domain;
condition: Conditions.Condition;
event: Events.Event;
errors: RelatedEvents.Object) : BOOLEAN;
BEGIN
WITH domain: Domain DO WITH condition: Condition DO
IF condition.passed THEN
RETURN FALSE
ELSE
domain.event := event;
ScheduleEvent(condition);
RETURN TRUE
END;
END; END;
END SendEvent;
PROCEDURE GetNextTime(domain: Conditions.Domain;
conditionSet: Conditions.ConditionSet;
VAR nextTime: Times.Time;
VAR nextCond: Conditions.Condition;
errors: RelatedEvents.Object);
VAR
condition: Condition;
BEGIN
GetMinTime(conditionSet, nextTime, condition);
nextCond := condition;
END GetNextTime;
PROCEDURE InitInterface;
BEGIN
NEW(if);
if.test := Test;
if.select := Select;
if.sendevent := SendEvent;
if.gettime := GetNextTime;
END InitInterface;
BEGIN
disciplineId := Disciplines.Unique();
InitInterface;
disciplineId := Disciplines.Unique();
InitInterface;
END ulmTimeConditions.

592
src/library/ulm/ulmTimers.Mod
View file

@ -1,336 +1,338 @@
(* 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.
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.
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: Timers.om,v 1.3 2001/04/30 14:58:18 borchert Exp $
----------------------------------------------------------------------------
$Log: Timers.om,v $
Revision 1.3 2001/04/30 14:58:18 borchert
bug fix: recursion via Clocks.TimerOn was not possible
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: Timers.om,v 1.3 2001/04/30 14:58:18 borchert Exp $
----------------------------------------------------------------------------
$Log: Timers.om,v $
Revision 1.3 2001/04/30 14:58:18 borchert
bug fix: recursion via Clocks.TimerOn was not possible
Revision 1.2 1994/07/18 14:21:51 borchert
bug fix: CreateQueue took uninitialized priority variable instead of
queue.priority
Revision 1.2 1994/07/18 14:21:51 borchert
bug fix: CreateQueue took uninitialized priority variable instead of
queue.priority
Revision 1.1 1994/02/22 20:11:37 borchert
Initial revision
Revision 1.1 1994/02/22 20:11:37 borchert
Initial revision
----------------------------------------------------------------------------
AFB 1/92
----------------------------------------------------------------------------
----------------------------------------------------------------------------
AFB 1/92
----------------------------------------------------------------------------
*)
MODULE ulmTimers;
IMPORT Clocks := ulmClocks, Disciplines := ulmDisciplines, Events := ulmEvents, Objects := ulmObjects, Op := ulmOperations, Priorities := ulmPriorities,
SYS := ulmSYSTEM, SYSTEM, RelatedEvents := ulmRelatedEvents, Scales := ulmScales, Times := ulmTimes;
IMPORT Clocks := ulmClocks, Disciplines := ulmDisciplines, Events := ulmEvents, Objects := ulmObjects, Op := ulmOperations, Priorities := ulmPriorities,
SYS := ulmSYSTEM, RelatedEvents := ulmRelatedEvents, Scales := ulmScales, Times := ulmTimes;
TYPE
Queue = POINTER TO QueueRec;
Timer* = POINTER TO TimerRec;
TimerRec* =
RECORD
(Objects.ObjectRec)
valid: BOOLEAN; (* a valid timer entry? *)
queue: Queue; (* timer belongs to this queue *)
prev, next: Timer; (* double-linked and sorted list *)
time: Times.Time; (* key *)
event: Events.Event; (* raise this event at the given time *)
END;
QueueRec =
RECORD
(Disciplines.ObjectRec)
clock: Clocks.Clock; (* queue of this clock *)
priority: Priorities.Priority; (* priority of the clock *)
checkQueue: Events.EventType; (* check queue on this event *)
head, tail: Timer; (* sorted list of timers *)
lock: BOOLEAN;
END;
TYPE
CheckQueueEvent = POINTER TO CheckQueueEventRec;
CheckQueueEventRec =
RECORD
(Events.EventRec)
queue: Queue;
END;
TYPE
ClockDiscipline = POINTER TO ClockDisciplineRec;
ClockDisciplineRec =
RECORD
(Disciplines.DisciplineRec)
queue: Queue;
END;
VAR
clockDisciplineId: Disciplines.Identifier;
CONST
invalidTimer* = 0; (* timer is no longer valid *)
queueLocked* = 1; (* the queue is currently locked *)
badClock* = 2; (* clock is unable to maintain a timer *)
errorcodes* = 3;
TYPE
ErrorEvent* = POINTER TO ErrorEventRec;
ErrorEventRec* =
RECORD
(Events.EventRec)
errorcode*: SHORTINT;
END;
VAR
errormsg*: ARRAY errorcodes OF Events.Message;
error*: Events.EventType;
PROCEDURE InitErrorHandling;
BEGIN
errormsg[invalidTimer] := "invalid timer given to Timers.Remove";
errormsg[queueLocked] := "the queue is currently locked";
errormsg[badClock] := "clock is unable to maintain a timer";
Events.Define(error); Events.SetPriority(error, Priorities.liberrors);
END InitErrorHandling;
PROCEDURE Error(errors: RelatedEvents.Object; code: SHORTINT);
VAR
event: ErrorEvent;
BEGIN
NEW(event);
event.type := error;
event.message := errormsg[code];
event.errorcode := code;
RelatedEvents.Raise(errors, event);
END Error;
PROCEDURE CheckQueue(queue: Queue);
VAR
currentTime: Times.Time;
oldTimers: Timer;
p, prev: Timer;
checkQueueEvent: CheckQueueEvent;
nextTimer: Timer;
BEGIN
IF queue.head = NIL THEN queue.lock := FALSE; RETURN END;
Clocks.GetTime(queue.clock, currentTime);
(* remove old timers from queue *)
oldTimers := queue.head;
p := queue.head; prev := NIL;
WHILE (p # NIL) & (Op.Compare(currentTime, p.time) >= 0) DO
prev := p; p := p.next;
TYPE
Queue = POINTER TO QueueRec;
Timer* = POINTER TO TimerRec;
TimerRec* =
RECORD
(Objects.ObjectRec)
valid: BOOLEAN; (* a valid timer entry? *)
queue: Queue; (* timer belongs to this queue *)
prev, next: Timer; (* double-linked and sorted list *)
time: Times.Time; (* key *)
event: Events.Event; (* raise this event at the given time *)
END;
IF p = NIL THEN
queue.head := NIL; queue.tail := NIL;
ELSE
queue.head := p;
p.prev := NIL;
QueueRec =
RECORD
(Disciplines.ObjectRec)
clock: Clocks.Clock; (* queue of this clock *)
priority: Priorities.Priority; (* priority of the clock *)
checkQueue: Events.EventType; (* check queue on this event *)
head, tail: Timer; (* sorted list of timers *)
lock: BOOLEAN;
END;
IF prev = NIL THEN
oldTimers := NIL;
ELSE
prev.next := NIL;
TYPE
CheckQueueEvent = POINTER TO CheckQueueEventRec;
CheckQueueEventRec =
RECORD
(Events.EventRec)
queue: Queue;
END;
TYPE
ClockDiscipline = POINTER TO ClockDisciplineRec;
ClockDisciplineRec =
RECORD
(Disciplines.DisciplineRec)
queue: Queue;
END;
VAR
clockDisciplineId: Disciplines.Identifier;
(* set up next check-queue-event, if necessary *)
nextTimer := queue.head;
queue.lock := FALSE;
(* unlock queue now to allow recursion via Clocks.TimerOn *)
IF nextTimer # NIL THEN
NEW(checkQueueEvent);
checkQueueEvent.type := queue.checkQueue;
checkQueueEvent.message := "check queue of timer";
checkQueueEvent.queue := queue;
Clocks.TimerOn(queue.clock, nextTimer.time, checkQueueEvent);
ELSE
Clocks.TimerOff(queue.clock);
CONST
invalidTimer* = 0; (* timer is no longer valid *)
queueLocked* = 1; (* the queue is currently locked *)
badClock* = 2; (* clock is unable to maintain a timer *)
errorcodes* = 3;
TYPE
ErrorEvent* = POINTER TO ErrorEventRec;
ErrorEventRec* =
RECORD
(Events.EventRec)
errorcode*: SHORTINT;
END;
VAR
errormsg*: ARRAY errorcodes OF Events.Message;
error*: Events.EventType;
(* process old timers *)
p := oldTimers;
WHILE p # NIL DO
p.valid := FALSE;
Events.Raise(p.event);
p := p.next;
END;
END CheckQueue;
PROCEDURE InitErrorHandling;
BEGIN
errormsg[invalidTimer] := "invalid timer given to Timers.Remove";
errormsg[queueLocked] := "the queue is currently locked";
errormsg[badClock] := "clock is unable to maintain a timer";
Events.Define(error); Events.SetPriority(error, Priorities.liberrors);
END InitErrorHandling;
PROCEDURE CatchCheckQueueEvents(event: Events.Event);
BEGIN
WITH event: CheckQueueEvent DO
IF ~SYS.TAS(event.queue.lock) THEN
CheckQueue(event.queue);
(* event.queue.lock := FALSE; (* done by CheckQueue *) *)
END;
END;
END CatchCheckQueueEvents;
PROCEDURE Error(errors: RelatedEvents.Object; code: SHORTINT);
VAR
event: ErrorEvent;
BEGIN
NEW(event);
event.type := error;
event.message := errormsg[code];
event.errorcode := code;
RelatedEvents.Raise(errors, event);
END Error;
PROCEDURE CreateQueue(errors: RelatedEvents.Object;
VAR queue: Queue; clock: Clocks.Clock) : BOOLEAN;
VAR
clockDiscipline: ClockDiscipline;
BEGIN
IF ~(Clocks.timer IN Clocks.Capabilities(clock)) THEN
Error(errors, badClock); RETURN FALSE
END;
PROCEDURE CheckQueue(queue: Queue);
VAR
currentTime: Times.Time;
oldTimers: Timer;
p, prev: Timer;
checkQueueEvent: CheckQueueEvent;
nextTimer: Timer;
BEGIN
IF queue.head = NIL THEN queue.lock := FALSE; RETURN END;
NEW(queue);
queue.clock := clock;
Clocks.GetTime(queue.clock, currentTime);
(* remove old timers from queue *)
oldTimers := queue.head;
p := queue.head; prev := NIL;
WHILE (p # NIL) & (Op.Compare(currentTime, p.time) >= 0) DO
prev := p; p := p.next;
END;
IF p = NIL THEN
queue.head := NIL; queue.tail := NIL;
queue.lock := FALSE;
Events.Define(queue.checkQueue);
Events.Handler(queue.checkQueue, CatchCheckQueueEvents);
Clocks.GetPriority(clock, queue.priority);
IF queue.priority > Priorities.base THEN
Events.SetPriority(queue.checkQueue, queue.priority + 1);
ELSE
queue.head := p;
p.prev := NIL;
END;
IF prev = NIL THEN
oldTimers := NIL;
ELSE
prev.next := NIL;
END;
(* set up next check-queue-event, if necessary *)
nextTimer := queue.head;
queue.lock := FALSE;
(* unlock queue now to allow recursion via Clocks.TimerOn *)
IF nextTimer # NIL THEN
NEW(checkQueueEvent);
checkQueueEvent.type := queue.checkQueue;
checkQueueEvent.message := "check queue of timer";
checkQueueEvent.queue := queue;
Clocks.TimerOn(queue.clock, nextTimer.time, checkQueueEvent);
ELSE
Clocks.TimerOff(queue.clock);
END;
(* process old timers *)
p := oldTimers;
WHILE p # NIL DO
p.valid := FALSE;
Events.Raise(p.event);
p := p.next;
END;
END CheckQueue;
PROCEDURE CatchCheckQueueEvents(event: Events.Event);
BEGIN
WITH event: CheckQueueEvent DO
IF ~SYS.TAS(event.queue.lock) THEN
CheckQueue(event.queue);
(* event.queue.lock := FALSE; (* done by CheckQueue *) *)
END;
END;
END CatchCheckQueueEvents;
PROCEDURE CreateQueue(errors: RelatedEvents.Object;
VAR queue: Queue; clock: Clocks.Clock) : BOOLEAN;
VAR
clockDiscipline: ClockDiscipline;
BEGIN
IF ~(Clocks.timer IN Clocks.Capabilities(clock)) THEN
Error(errors, badClock); RETURN FALSE
END;
NEW(queue);
queue.clock := clock;
queue.head := NIL; queue.tail := NIL;
queue.lock := FALSE;
Events.Define(queue.checkQueue);
Events.Handler(queue.checkQueue, CatchCheckQueueEvents);
Clocks.GetPriority(clock, queue.priority);
IF queue.priority > Priorities.base THEN
Events.SetPriority(queue.checkQueue, queue.priority + 1);
ELSE
queue.priority := Priorities.default;
END;
NEW(clockDiscipline); clockDiscipline.id := clockDisciplineId;
clockDiscipline.queue := queue;
Disciplines.Add(clock, clockDiscipline);
RETURN TRUE
END CreateQueue;
PROCEDURE Add*(clock: Clocks.Clock; time: Times.Time; event: Events.Event;
VAR timer: Timer);
VAR
queue: Queue;
clockDiscipline: Disciplines.Discipline; (* ClockDiscipline *)
p: Timer;
absTime: Times.Time;
op: Op.Operand;
BEGIN
IF Disciplines.Seek(clock, clockDisciplineId, clockDiscipline) THEN
queue := clockDiscipline(ClockDiscipline).queue;
ELSIF ~CreateQueue(clock, queue, clock) THEN
RETURN
END;
IF SYS.TAS(queue.lock) THEN
Error(clock, queueLocked); RETURN
END;
Events.AssertPriority(queue.priority);
IF Scales.IsRelative(time) THEN
(* take relative time to be relative to the current time *)
Clocks.GetTime(clock, absTime);
(* Op.Add2(SYSTEM.VAL(Op.Operand, absTime), time); *)
op := absTime; Op.Add2(op, time); absTime := op(Times.Time);
ELSE
(* create a copy of time *)
op := NIL; Op.Assign(op, time); absTime := op(Times.Time);
END;
time := absTime;
NEW(timer); timer.time := time; timer.event := event;
timer.queue := queue; timer.valid := TRUE;
(* look for the insertion point *)
p := queue.head;
WHILE (p # NIL) & (Op.Compare(time, p.time) > 0) DO
p := p.next;
END;
(* insert timer in front of p *)
timer.next := p;
IF p = NIL THEN
(* append timer at the end of the queue *)
timer.prev := queue.tail;
IF queue.tail = NIL THEN
queue.head := timer;
ELSE
queue.priority := Priorities.default;
queue.tail.next := timer;
END;
NEW(clockDiscipline); clockDiscipline.id := clockDisciplineId;
clockDiscipline.queue := queue;
Disciplines.Add(clock, clockDiscipline);
RETURN TRUE
END CreateQueue;
PROCEDURE Add*(clock: Clocks.Clock; time: Times.Time; event: Events.Event;
VAR timer: Timer);
VAR
queue: Queue;
clockDiscipline: ClockDiscipline;
p: Timer;
absTime: Times.Time;
BEGIN
IF Disciplines.Seek(clock, clockDisciplineId, SYSTEM.VAL(Disciplines.Discipline, clockDiscipline)) THEN
queue := clockDiscipline.queue;
ELSIF ~CreateQueue(clock, queue, clock) THEN
RETURN
queue.tail := timer;
ELSE
timer.prev := p.prev;
timer.next := p;
IF p = queue.head THEN
queue.head := timer;
ELSE
p.prev.next := timer;
END;
p.prev := timer;
END;
CheckQueue(queue);
(* queue.lock := FALSE; (* done by CheckQueue *) *)
Events.ExitPriority;
END Add;
PROCEDURE Remove*(timer: Timer);
VAR
queue: Queue;
BEGIN
IF timer.valid THEN
queue := timer.queue;
IF SYS.TAS(queue.lock) THEN
Error(clock, queueLocked); RETURN
Error(queue.clock, queueLocked); RETURN
END;
Events.AssertPriority(queue.priority);
IF Scales.IsRelative(time) THEN
(* take relative time to be relative to the current time *)
Clocks.GetTime(clock, absTime);
Op.Add2(SYSTEM.VAL(Op.Operand, absTime), time);
timer.valid := FALSE;
IF timer.prev = NIL THEN
queue.head := timer.next;
ELSE
(* create a copy of time *)
absTime := NIL; Op.Assign(SYSTEM.VAL(Op.Operand, absTime), time);
timer.prev.next := timer.next;
END;
time := absTime;
NEW(timer); timer.time := time; timer.event := event;
timer.queue := queue; timer.valid := TRUE;
(* look for the insertion point *)
p := queue.head;
WHILE (p # NIL) & (Op.Compare(time, p.time) > 0) DO
p := p.next;
END;
(* insert timer in front of p *)
timer.next := p;
IF p = NIL THEN
(* append timer at the end of the queue *)
timer.prev := queue.tail;
IF queue.tail = NIL THEN
queue.head := timer;
ELSE
queue.tail.next := timer;
END;
queue.tail := timer;
IF timer.next = NIL THEN
queue.tail := timer.prev;
ELSE
timer.prev := p.prev;
timer.next := p;
IF p = queue.head THEN
queue.head := timer;
ELSE
p.prev.next := timer;
END;
p.prev := timer;
timer.next.prev := timer.prev;
END;
CheckQueue(queue);
(* queue.lock := FALSE; (* done by CheckQueue *) *)
Events.ExitPriority;
END Add;
ELSE
Error(timer.queue.clock, invalidTimer);
END;
END Remove;
PROCEDURE Remove*(timer: Timer);
VAR
queue: Queue;
BEGIN
IF timer.valid THEN
queue := timer.queue;
IF SYS.TAS(queue.lock) THEN
Error(queue.clock, queueLocked); RETURN
END;
Events.AssertPriority(queue.priority);
timer.valid := FALSE;
IF timer.prev = NIL THEN
queue.head := timer.next;
ELSE
timer.prev.next := timer.next;
END;
IF timer.next = NIL THEN
queue.tail := timer.prev;
ELSE
timer.next.prev := timer.prev;
END;
CheckQueue(queue);
(* queue.lock := FALSE; (* done by CheckQueue *) *)
Events.ExitPriority;
ELSE
Error(timer.queue.clock, invalidTimer);
END;
END Remove;
PROCEDURE Schedule*(clock: Clocks.Clock;
time: Times.Time; event: Events.Event);
VAR
timer: Timer;
BEGIN
Add(clock, time, event, timer);
END Schedule;
PROCEDURE Schedule*(clock: Clocks.Clock;
time: Times.Time; event: Events.Event);
VAR
timer: Timer;
BEGIN
Add(clock, time, event, timer);
END Schedule;
PROCEDURE NextEvent*(clock: Clocks.Clock; VAR time: Times.Time) : BOOLEAN;
VAR
rval: BOOLEAN;
queue: Queue;
clockDiscipline: Disciplines.Discipline; (* ClockDiscipline *)
BEGIN
IF ~Disciplines.Seek(clock, clockDisciplineId, clockDiscipline) THEN
RETURN FALSE
END;
queue := clockDiscipline(ClockDiscipline).queue;
PROCEDURE NextEvent*(clock: Clocks.Clock; VAR time: Times.Time) : BOOLEAN;
VAR
rval: BOOLEAN;
queue: Queue;
clockDiscipline: ClockDiscipline;
BEGIN
IF ~Disciplines.Seek(clock, clockDisciplineId, SYSTEM.VAL(Disciplines.Discipline, clockDiscipline)) THEN
RETURN FALSE
END;
queue := clockDiscipline.queue;
IF SYS.TAS(queue.lock) THEN
Error(clock, queueLocked); RETURN FALSE
END;
CheckQueue(queue);
IF queue.head # NIL THEN
time := queue.head.time;
rval := TRUE;
ELSE
rval := FALSE
END;
(* queue.lock := FALSE; (* done by CheckQueue *) *)
RETURN rval
END NextEvent;
IF SYS.TAS(queue.lock) THEN
Error(clock, queueLocked); RETURN FALSE
END;
CheckQueue(queue);
IF queue.head # NIL THEN
time := queue.head.time;
rval := TRUE;
ELSE
rval := FALSE
END;
(* queue.lock := FALSE; (* done by CheckQueue *) *)
RETURN rval
END NextEvent;
BEGIN
InitErrorHandling;
clockDisciplineId := Disciplines.Unique();
InitErrorHandling;
clockDisciplineId := Disciplines.Unique();
END ulmTimers.

727
src/library/ulm/ulmTimes.Mod
View file

@ -1,398 +1,401 @@
(* 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.
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.
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: Times.om,v 1.3 2001/04/30 14:54:44 borchert Exp $
----------------------------------------------------------------------------
$Log: Times.om,v $
Revision 1.3 2001/04/30 14:54:44 borchert
bug fix: base type is TimeRec instead of Times.TimeRec
(invalid self-reference)
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: Times.om,v 1.3 2001/04/30 14:54:44 borchert Exp $
----------------------------------------------------------------------------
$Log: Times.om,v $
Revision 1.3 2001/04/30 14:54:44 borchert
bug fix: base type is TimeRec instead of Times.TimeRec
(invalid self-reference)
Revision 1.2 1995/04/07 13:25:07 borchert
fixes due to changed if of PersistentObjects
Revision 1.2 1995/04/07 13:25:07 borchert
fixes due to changed if of PersistentObjects
Revision 1.1 1994/02/22 20:12:02 borchert
Initial revision
Revision 1.1 1994/02/22 20:12:02 borchert
Initial revision
----------------------------------------------------------------------------
AFB 12/91
----------------------------------------------------------------------------
----------------------------------------------------------------------------
AFB 12/91
----------------------------------------------------------------------------
*)
MODULE ulmTimes;
IMPORT NetIO := ulmNetIO, Objects := ulmObjects, Operations := ulmOperations, PersistentObjects := ulmPersistentObjects, Scales := ulmScales,
Services := ulmServices, Streams := ulmStreams, SYSTEM;
IMPORT NetIO := ulmNetIO, Objects := ulmObjects, Operations := ulmOperations, PersistentObjects := ulmPersistentObjects, Scales := ulmScales,
Services := ulmServices, Streams := ulmStreams;
CONST
relative* = Scales.relative;
absolute* = Scales.absolute;
TYPE
(* the common base type of all time measures *)
Time* = POINTER TO TimeRec;
TimeRec* = RECORD (Scales.MeasureRec) END;
CONST
relative* = Scales.relative;
absolute* = Scales.absolute;
TYPE
(* the common base type of all time measures *)
Time* = POINTER TO TimeRec;
TimeRec* = RECORD (Scales.MeasureRec) END;
CONST
usecsPerSec = 1000000; (* 10^6 *)
TYPE
(* units of the reference implementation:
epoch, second and usec
*)
TimeValueRec* =
RECORD
(Objects.ObjectRec)
(* epoch 0: Jan. 1, 1970;
each epoch has a length of MAX(Scales.Value) + 1 seconds;
epoch may be negative:
-1 is the epoch just before 1970
*)
epoch*: Scales.Value;
(* seconds and ... *)
second*: Scales.Value;
(* ... microseconds since the beginning of the epoch *)
usec*: Scales.Value;
END;
(* ==== private datatypes for the reference scale *)
TYPE
ReferenceTime = POINTER TO ReferenceTimeRec;
ReferenceTimeRec =
RECORD
(TimeRec)
timeval: TimeValueRec;
END;
VAR
absType, relType: Services.Type;
CONST
epochUnit = 0; secondUnit = 1; usecUnit = 2;
TYPE
Unit = POINTER TO UnitRec;
UnitRec =
RECORD
(Scales.UnitRec)
index: SHORTINT; (* epochUnit..usecUnit *)
END;
VAR
scale*: Scales.Scale; (* reference scale *)
family*: Scales.Family; (* family of time scales *)
if: Scales.Interface;
PROCEDURE Create*(VAR time: Time; type: SHORTINT);
(* type = absolute or relative *)
VAR
m: Scales.Measure;
BEGIN
Scales.CreateMeasure(scale, m, type);
time := m(Time);
END Create;
PROCEDURE Normalize(VAR timeval: TimeValueRec);
(* make sure that second and usec >= 0 *)
VAR
toomanysecs: Scales.Value;
secs: Scales.Value;
BEGIN
IF timeval.second < 0 THEN
INC(timeval.second, 1);
INC(timeval.second, MAX(Scales.Value));
DEC(timeval.epoch);
CONST
usecsPerSec = 1000000; (* 10^6 *)
TYPE
(* units of the reference implementation:
epoch, second and usec
*)
TimeValueRec* =
RECORD
(Objects.ObjectRec)
(* epoch 0: Jan. 1, 1970;
each epoch has a length of MAX(Scales.Value) + 1 seconds;
epoch may be negative:
-1 is the epoch just before 1970
*)
epoch*: Scales.Value;
(* seconds and ... *)
second*: Scales.Value;
(* ... microseconds since the beginning of the epoch *)
usec*: Scales.Value;
END;
IF timeval.usec < 0 THEN
toomanysecs := timeval.usec DIV usecsPerSec;
IF toomanysecs > timeval.second THEN
timeval.second := - toomanysecs + MAX(Scales.Value) + 1 +
timeval.second;
DEC(timeval.epoch);
ELSE
DEC(timeval.second, toomanysecs);
END;
timeval.usec := timeval.usec MOD usecsPerSec;
ELSIF timeval.usec >= usecsPerSec THEN
secs := timeval.usec DIV usecsPerSec;
IF MAX(Scales.Value) - timeval.second <= secs THEN
INC(timeval.second, secs);
ELSE
timeval.second := secs - (MAX(Scales.Value) - timeval.second);
INC(timeval.epoch);
END;
timeval.usec := timeval.usec MOD usecsPerSec;
END;
END Normalize;
PROCEDURE SetValue*(time: Time; value: TimeValueRec);
VAR
refTime: Time;
scaleOfTime: Scales.Scale;
BEGIN
Normalize(value);
IF time IS ReferenceTime THEN
WITH time: ReferenceTime DO
time.timeval := value;
END;
(* ==== private datatypes for the reference scale *)
TYPE
ReferenceTime = POINTER TO ReferenceTimeRec;
ReferenceTimeRec =
RECORD
(TimeRec)
timeval: TimeValueRec;
END;
VAR
absType, relType: Services.Type;
CONST
epochUnit = 0; secondUnit = 1; usecUnit = 2;
TYPE
Unit = POINTER TO UnitRec;
UnitRec =
RECORD
(Scales.UnitRec)
index: SHORTINT; (* epochUnit..usecUnit *)
END;
VAR
scale*: Scales.Scale; (* reference scale *)
family*: Scales.Family; (* family of time scales *)
if: Scales.Interface;
PROCEDURE Create*(VAR time: Time; type: SHORTINT);
(* type = absolute or relative *)
VAR
m: Scales.Measure;
BEGIN
Scales.CreateMeasure(scale, m, type);
time := m(Time);
END Create;
PROCEDURE Normalize(VAR timeval: TimeValueRec);
(* make sure that second and usec >= 0 *)
VAR
toomanysecs: Scales.Value;
secs: Scales.Value;
BEGIN
IF timeval.second < 0 THEN
INC(timeval.second, 1);
INC(timeval.second, MAX(Scales.Value));
DEC(timeval.epoch);
END;
IF timeval.usec < 0 THEN
toomanysecs := timeval.usec DIV usecsPerSec;
IF toomanysecs > timeval.second THEN
timeval.second := - toomanysecs + MAX(Scales.Value) + 1 +
timeval.second;
DEC(timeval.epoch);
ELSE
Create(refTime, Scales.MeasureType(time));
refTime(ReferenceTime).timeval := value;
Scales.GetScale(time, scaleOfTime);
Scales.ConvertMeasure(scaleOfTime, SYSTEM.VAL(Scales.Measure, refTime));
Operations.Copy(refTime, time);
DEC(timeval.second, toomanysecs);
END;
END SetValue;
PROCEDURE CreateAndSet*(VAR time: Time; type: SHORTINT;
epoch, second, usec: Scales.Value);
VAR
timeval: TimeValueRec;
BEGIN
Create(time, type);
timeval.epoch := epoch; timeval.second := second; timeval.usec := usec;
SetValue(time, timeval);
END CreateAndSet;
PROCEDURE GetValue*(time: Time; VAR value: TimeValueRec);
BEGIN
IF ~(time IS ReferenceTime) THEN
Scales.ConvertMeasure(scale, SYSTEM.VAL(Scales.Measure, time));
END;
value := time(ReferenceTime).timeval;
END GetValue;
(* ===== interface procedures =================================== *)
PROCEDURE InternalCreate(scale: Scales.Scale;
VAR measure: Scales.Measure; abs: BOOLEAN);
VAR
time: ReferenceTime;
BEGIN
NEW(time);
time.timeval.epoch := 0;
time.timeval.second := 0;
time.timeval.usec := 0;
IF abs THEN
PersistentObjects.Init(time, absType);
timeval.usec := timeval.usec MOD usecsPerSec;
ELSIF timeval.usec >= usecsPerSec THEN
secs := timeval.usec DIV usecsPerSec;
IF MAX(Scales.Value) - timeval.second <= secs THEN
INC(timeval.second, secs);
ELSE
PersistentObjects.Init(time, relType);
timeval.second := secs - (MAX(Scales.Value) - timeval.second);
INC(timeval.epoch);
END;
measure := time;
END InternalCreate;
timeval.usec := timeval.usec MOD usecsPerSec;
END;
END Normalize;
PROCEDURE InternalGetValue(measure: Scales.Measure; unit: Scales.Unit;
VAR value: Scales.Value);
BEGIN
WITH measure: ReferenceTime DO WITH unit: Unit DO
CASE unit.index OF
| epochUnit: value := measure.timeval.epoch;
| secondUnit: value := measure.timeval.second;
| usecUnit: value := measure.timeval.usec;
PROCEDURE SetValue*(time: Time; value: TimeValueRec);
VAR
refTime: Time;
measure: Scales.Measure;
scaleOfTime: Scales.Scale;
BEGIN
Normalize(value);
IF time IS ReferenceTime THEN
WITH time: ReferenceTime DO
time.timeval := value;
END;
ELSE
END;
END; END;
END InternalGetValue;
Create(refTime, Scales.MeasureType(time));
refTime(ReferenceTime).timeval := value;
Scales.GetScale(time, scaleOfTime);
measure := refTime;
Scales.ConvertMeasure(scaleOfTime, measure);
Operations.Copy(measure, time);
END;
END SetValue;
PROCEDURE InternalSetValue(measure: Scales.Measure; unit: Scales.Unit;
value: Scales.Value);
BEGIN
WITH measure: ReferenceTime DO WITH unit: Unit DO
CASE unit.index OF
| epochUnit: measure.timeval.epoch := value;
| secondUnit: measure.timeval.second := value;
| usecUnit: measure.timeval.usec := value;
PROCEDURE CreateAndSet*(VAR time: Time; type: SHORTINT;
epoch, second, usec: Scales.Value);
VAR
timeval: TimeValueRec;
BEGIN
Create(time, type);
timeval.epoch := epoch; timeval.second := second; timeval.usec := usec;
SetValue(time, timeval);
END CreateAndSet;
PROCEDURE GetValue*(time: Time; VAR value: TimeValueRec);
VAR mtime: Scales.Measure;
BEGIN
IF ~(time IS ReferenceTime) THEN
Scales.ConvertMeasure(scale, mtime); time := mtime(Time)
END;
value := time(ReferenceTime).timeval;
END GetValue;
(* ===== interface procedures =================================== *)
PROCEDURE InternalCreate(scale: Scales.Scale;
VAR measure: Scales.Measure; abs: BOOLEAN);
VAR
time: ReferenceTime;
BEGIN
NEW(time);
time.timeval.epoch := 0;
time.timeval.second := 0;
time.timeval.usec := 0;
IF abs THEN
PersistentObjects.Init(time, absType);
ELSE
END;
Normalize(measure.timeval);
END; END;
END InternalSetValue;
PersistentObjects.Init(time, relType);
END;
measure := time;
END InternalCreate;
PROCEDURE Assign(target: Scales.Measure; source: Scales.Measure);
BEGIN
WITH target: ReferenceTime DO WITH source: ReferenceTime DO
target.timeval := source.timeval;
END; END;
END Assign;
PROCEDURE Op(op: Scales.Operation; op1, op2, result: Scales.Measure);
PROCEDURE Add(op1, op2: TimeValueRec; VAR result: TimeValueRec);
BEGIN
result.epoch := op1.epoch + op2.epoch;
IF op1.second > MAX(Scales.Value) - op2.second THEN
INC(result.epoch);
result.second := op1.second - MAX(Scales.Value) - 1 +
op2.second;
ELSE
result.second := op1.second + op2.second;
END;
result.usec := op1.usec + op2.usec;
IF result.usec > usecsPerSec THEN
DEC(result.usec, usecsPerSec);
IF result.second = MAX(Scales.Value) THEN
result.second := 0; INC(result.epoch);
ELSE
INC(result.second);
END;
END;
END Add;
PROCEDURE Sub(op1, op2: TimeValueRec; VAR result: TimeValueRec);
BEGIN
result.epoch := op1.epoch - op2.epoch;
IF op1.second >= op2.second THEN
result.second := op1.second - op2.second;
ELSE
DEC(result.epoch);
result.second := - op2.second + MAX(Scales.Value) + 1 + op1.second;
END;
result.usec := op1.usec - op2.usec;
IF result.usec < 0 THEN
INC(result.usec, usecsPerSec);
IF result.second = 0 THEN
result.second := MAX(Scales.Value);
DEC(result.epoch);
ELSE
DEC(result.second);
END;
END;
END Sub;
BEGIN
WITH op1: ReferenceTime DO WITH op2: ReferenceTime DO
WITH result: ReferenceTime DO
CASE op OF
| Scales.add: Add(op1.timeval, op2.timeval, result.timeval);
| Scales.sub: Sub(op1.timeval, op2.timeval, result.timeval);
ELSE
END;
END;
END; END;
END Op;
PROCEDURE Compare(op1, op2: Scales.Measure) : INTEGER;
PROCEDURE ReturnVal(val1, val2: Scales.Value) : INTEGER;
BEGIN
IF val1 < val2 THEN
RETURN -1
ELSIF val1 > val2 THEN
RETURN 1
ELSE
RETURN 0
END;
END ReturnVal;
BEGIN
WITH op1: ReferenceTime DO
WITH op2: ReferenceTime DO
IF op1.timeval.epoch # op2.timeval.epoch THEN
RETURN ReturnVal(op1.timeval.epoch, op2.timeval.epoch)
ELSIF op1.timeval.second # op2.timeval.second THEN
RETURN ReturnVal(op1.timeval.second, op2.timeval.second)
ELSE
RETURN ReturnVal(op1.timeval.usec, op2.timeval.usec)
END;
END;
PROCEDURE InternalGetValue(measure: Scales.Measure; unit: Scales.Unit;
VAR value: Scales.Value);
BEGIN
WITH measure: ReferenceTime DO WITH unit: Unit DO
CASE unit.index OF
| epochUnit: value := measure.timeval.epoch;
| secondUnit: value := measure.timeval.second;
| usecUnit: value := measure.timeval.usec;
ELSE
END;
RETURN 0;
END Compare;
END; END;
END InternalGetValue;
(* ========= initialization procedures ========================== *)
PROCEDURE InitInterface;
VAR
timeType: Services.Type;
BEGIN
NEW(if);
if.create := InternalCreate;
if.getvalue := InternalGetValue; if.setvalue := InternalSetValue;
if.assign := Assign; if.op := Op; if.compare := Compare;
(* conversion procedures are not necessary *)
PersistentObjects.RegisterType(timeType, "Times.Time", "Scales.Measure",
NIL);
END InitInterface;
PROCEDURE CreateAbs(VAR object: PersistentObjects.Object);
VAR
measure: Scales.Measure;
BEGIN
Scales.CreateAbsMeasure(scale, measure);
object := measure;
END CreateAbs;
PROCEDURE CreateRel(VAR object: PersistentObjects.Object);
VAR
measure: Scales.Measure;
BEGIN
Scales.CreateRelMeasure(scale, measure);
object := measure;
END CreateRel;
PROCEDURE Write(s: Streams.Stream;
object: PersistentObjects.Object) : BOOLEAN;
BEGIN
WITH object: ReferenceTime DO
RETURN NetIO.WriteLongInt(s, object.timeval.epoch) &
NetIO.WriteLongInt(s, object.timeval.second) &
NetIO.WriteLongInt(s, object.timeval.usec)
PROCEDURE InternalSetValue(measure: Scales.Measure; unit: Scales.Unit;
value: Scales.Value);
BEGIN
WITH measure: ReferenceTime DO WITH unit: Unit DO
CASE unit.index OF
| epochUnit: measure.timeval.epoch := value;
| secondUnit: measure.timeval.second := value;
| usecUnit: measure.timeval.usec := value;
ELSE
END;
END Write;
Normalize(measure.timeval);
END; END;
END InternalSetValue;
PROCEDURE Read(s: Streams.Stream;
object: PersistentObjects.Object) : BOOLEAN;
BEGIN
WITH object: ReferenceTime DO
RETURN NetIO.ReadLongInt(s, object.timeval.epoch) &
NetIO.ReadLongInt(s, object.timeval.second) &
NetIO.ReadLongInt(s, object.timeval.usec)
PROCEDURE Assign(target: Scales.Measure; source: Scales.Measure);
BEGIN
WITH target: ReferenceTime DO WITH source: ReferenceTime DO
target.timeval := source.timeval;
END; END;
END Assign;
PROCEDURE Op(op: Scales.Operation; op1, op2, result: Scales.Measure);
PROCEDURE Add(op1, op2: TimeValueRec; VAR result: TimeValueRec);
BEGIN
result.epoch := op1.epoch + op2.epoch;
IF op1.second > MAX(Scales.Value) - op2.second THEN
INC(result.epoch);
result.second := op1.second - MAX(Scales.Value) - 1 +
op2.second;
ELSE
result.second := op1.second + op2.second;
END;
END Read;
result.usec := op1.usec + op2.usec;
IF result.usec > usecsPerSec THEN
DEC(result.usec, usecsPerSec);
IF result.second = MAX(Scales.Value) THEN
result.second := 0; INC(result.epoch);
ELSE
INC(result.second);
END;
END;
END Add;
PROCEDURE InitRefScale;
PROCEDURE Sub(op1, op2: TimeValueRec; VAR result: TimeValueRec);
BEGIN
result.epoch := op1.epoch - op2.epoch;
IF op1.second >= op2.second THEN
result.second := op1.second - op2.second;
ELSE
DEC(result.epoch);
result.second := - op2.second + MAX(Scales.Value) + 1 + op1.second;
END;
result.usec := op1.usec - op2.usec;
IF result.usec < 0 THEN
INC(result.usec, usecsPerSec);
IF result.second = 0 THEN
result.second := MAX(Scales.Value);
DEC(result.epoch);
ELSE
DEC(result.second);
END;
END;
END Sub;
BEGIN
WITH op1: ReferenceTime DO WITH op2: ReferenceTime DO
WITH result: ReferenceTime DO
CASE op OF
| Scales.add: Add(op1.timeval, op2.timeval, result.timeval);
| Scales.sub: Sub(op1.timeval, op2.timeval, result.timeval);
ELSE
END;
END;
END; END;
END Op;
PROCEDURE Compare(op1, op2: Scales.Measure) : INTEGER;
PROCEDURE ReturnVal(val1, val2: Scales.Value) : INTEGER;
BEGIN
IF val1 < val2 THEN
RETURN -1
ELSIF val1 > val2 THEN
RETURN 1
ELSE
RETURN 0
END;
END ReturnVal;
BEGIN
WITH op1: ReferenceTime DO
WITH op2: ReferenceTime DO
IF op1.timeval.epoch # op2.timeval.epoch THEN
RETURN ReturnVal(op1.timeval.epoch, op2.timeval.epoch)
ELSIF op1.timeval.second # op2.timeval.second THEN
RETURN ReturnVal(op1.timeval.second, op2.timeval.second)
ELSE
RETURN ReturnVal(op1.timeval.usec, op2.timeval.usec)
END;
END;
END;
RETURN 0;
END Compare;
(* ========= initialization procedures ========================== *)
PROCEDURE InitInterface;
VAR
timeType: Services.Type;
BEGIN
NEW(if);
if.create := InternalCreate;
if.getvalue := InternalGetValue; if.setvalue := InternalSetValue;
if.assign := Assign; if.op := Op; if.compare := Compare;
(* conversion procedures are not necessary *)
PersistentObjects.RegisterType(timeType, "Times.Time", "Scales.Measure",
NIL);
END InitInterface;
PROCEDURE CreateAbs(VAR object: PersistentObjects.Object);
VAR
measure: Scales.Measure;
BEGIN
Scales.CreateAbsMeasure(scale, measure);
object := measure;
END CreateAbs;
PROCEDURE CreateRel(VAR object: PersistentObjects.Object);
VAR
measure: Scales.Measure;
BEGIN
Scales.CreateRelMeasure(scale, measure);
object := measure;
END CreateRel;
PROCEDURE Write(s: Streams.Stream;
object: PersistentObjects.Object) : BOOLEAN;
BEGIN
WITH object: ReferenceTime DO
RETURN NetIO.WriteLongInt(s, object.timeval.epoch) &
NetIO.WriteLongInt(s, object.timeval.second) &
NetIO.WriteLongInt(s, object.timeval.usec)
END;
END Write;
PROCEDURE Read(s: Streams.Stream;
object: PersistentObjects.Object) : BOOLEAN;
BEGIN
WITH object: ReferenceTime DO
RETURN NetIO.ReadLongInt(s, object.timeval.epoch) &
NetIO.ReadLongInt(s, object.timeval.second) &
NetIO.ReadLongInt(s, object.timeval.usec)
END;
END Read;
PROCEDURE InitRefScale;
VAR
poif: PersistentObjects.Interface;
PROCEDURE InitUnit(unitIndex: SHORTINT; name: Scales.UnitName);
VAR
poif: PersistentObjects.Interface;
unit: Unit;
BEGIN
NEW(unit); unit.index := unitIndex;
Scales.InitUnit(scale, unit, name);
END InitUnit;
PROCEDURE InitUnit(unitIndex: SHORTINT; name: Scales.UnitName);
VAR
unit: Unit;
BEGIN
NEW(unit); unit.index := unitIndex;
Scales.InitUnit(scale, unit, name);
END InitUnit;
BEGIN
NEW(scale); Scales.Init(scale, NIL, if);
InitUnit(epochUnit, "epoch");
InitUnit(secondUnit, "second");
InitUnit(usecUnit, "usec");
BEGIN
NEW(scale); Scales.Init(scale, NIL, if);
InitUnit(epochUnit, "epoch");
InitUnit(secondUnit, "second");
InitUnit(usecUnit, "usec");
NEW(poif); poif.read := Read; poif.write := Write;
poif.create := CreateAbs; poif.createAndRead := NIL;
PersistentObjects.RegisterType(absType,
"Times.AbsReferenceTime", "Times.Time", poif);
NEW(poif); poif.read := Read; poif.write := Write;
poif.create := CreateRel; poif.createAndRead := NIL;
PersistentObjects.RegisterType(relType,
"Times.RelReferenceTime", "Times.Time", poif);
END InitRefScale;
NEW(poif); poif.read := Read; poif.write := Write;
poif.create := CreateAbs; poif.createAndRead := NIL;
PersistentObjects.RegisterType(absType,
"Times.AbsReferenceTime", "Times.Time", poif);
NEW(poif); poif.read := Read; poif.write := Write;
poif.create := CreateRel; poif.createAndRead := NIL;
PersistentObjects.RegisterType(relType,
"Times.RelReferenceTime", "Times.Time", poif);
END InitRefScale;
BEGIN
InitInterface;
InitRefScale;
NEW(family); Scales.InitFamily(family, scale);
InitInterface;
InitRefScale;
NEW(family); Scales.InitFamily(family, scale);
END ulmTimes.

11
src/library/ulm/ulmTypes.Mod
View file

@ -50,15 +50,8 @@ MODULE ulmTypes;
IMPORT SYS := SYSTEM;
TYPE
Address* = LONGINT (*SYS.ADDRESS*);
(* ulm compiler can accept
VAR p : SYSTEM.ADDRESS; // SYSTEM.PTR in ETH and V4 versions
...
p := SYSTEM.ADR(something);
and this is how it is used in ulm oberon system library,
while SYSTEM.ADR returns LONGINT in ETH and V4 versions.
Thus I leave it as LONGINT for now, before coming up with better solution -- noch *)
Address* = SYS.ADDRESS;
UntracedAddress* = POINTER[1] TO UntracedAddressDesc; (*SYS.UNTRACEDADDRESS;*)
UntracedAddressDesc* = RECORD[1] END;