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

Rename lib to library.

Browse source
This commit is contained in:
David Brown 2016-06-16 13:56:12 +01:00
parent b7536a8446
commit 1304822769
130 changed files with 0 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

61
src/library/misc/Listen.Mod Normal file
View file

@ -0,0 +1,61 @@
(*
Module taken from http://www.dg.bnv-bamberg.de/seiten/faecher/informat/oberon/aachen/listen.htm
Author: zita@pegasus.dvz.fh-aachen.de
*)
MODULE Listen;
TYPE
Element* = POINTER TO ElementDesc;
ElementDesc* = RECORD END;
Liste* = POINTER TO ListDesc;
ListDesc = RECORD
e: Element;
rest: Liste
END;
CompareProc=PROCEDURE(e1,e2:Element):BOOLEAN;
PROCEDURE Concat*(head: Element; tail: Liste): Liste;
VAR temp:Liste;
BEGIN
NEW(temp); temp.e := head; temp.rest := tail;
RETURN temp
END Concat;
PROCEDURE Head* (l:Liste):Element;
BEGIN
RETURN l.e
END Head;
PROCEDURE Tail* (l:Liste):Liste;
BEGIN
RETURN l.rest
END Tail;
PROCEDURE Append* (list: Liste; e: Element): Liste;
BEGIN
IF list = NIL THEN
RETURN Concat(e, NIL) ELSE
RETURN Concat(Head(list),Append(Tail(list),e))
END;
END Append;
PROCEDURE IsElement*(e:Element;l:Liste;equal:CompareProc):BOOLEAN;
BEGIN
IF l = NIL THEN RETURN FALSE
ELSIF equal(e,Head(l)) THEN RETURN TRUE
ELSE RETURN IsElement(e,Tail(l),equal)
END
END IsElement;
PROCEDURE Find*(e:Element;l:Liste;equal:CompareProc):Element;
BEGIN
IF l = NIL THEN RETURN NIL
ELSIF equal(e,Head(l)) THEN RETURN Head(l)
ELSE RETURN Find(e,Tail(l),equal)
END
END Find;
END Listen.

243
src/library/misc/MersenneTwister.Mod Normal file
View file

@ -0,0 +1,243 @@
(*<* O2EXTENSIONS + *>
<* IOVERFLOW - *>*)
MODULE MersenneTwister;
IMPORT
SYS:=SYSTEM,(*Win:=Windows*) SysClock := oocSysClock, MathL := oocLRealMath;
CONST
(* Period parameter *)
MT19937N*=624;
(* Period parameters *)
MT19937M=397;
(*MT19937MATRIXA =SYS.VAL(SET,-1727483681(*9908b0dfH*)); (* -- constant vector a*)
MT19937UPPERMASK=SYS.VAL(SET,80000000H); (* -- most significant w-r bits*)
MT19937LOWERMASK=SYS.VAL(SET,7fffffffH); (* -- least significant r bits*)
(* Tempering parameters *)
TEMPERINGMASKB=SYS.VAL(SET,9d2c5680H);
TEMPERINGMASKC=SYS.VAL(SET,0efc60000H);
*)
Seed0=4357;
TYPE
tMT19937StateArray=ARRAY MT19937N OF SET; (*-- the array for the state vector*)
VAR
Seed-:LONGINT;
MT19937MATRIXA, MT19937UPPERMASK, MT19937LOWERMASK : SET;
TEMPERINGMASKB, TEMPERINGMASKC : SET;
mt : tMT19937StateArray;
mti: LONGINT; (*-- mti=MT19937N+1 means mt[] is not initialized*)
GaussRandomBuf:LONGREAL;
GaussRandomBufFilled:BOOLEAN;
(* Initializing the array with a seed *)
PROCEDURE SetSeed*(seed:LONGINT);(* sgenrand_MT19937 *)
(*CONST
HighBits=SYS.VAL(SET, 0ffff0000H);*)
VAR
HighBits : SET;
i:LONGINT;
BEGIN
HighBits := SYS.VAL(SET, -65536(*0ffff0000H*));
Seed:=seed;
FOR i:=0 TO MT19937N-1 DO
mt[i]:=SYS.VAL(SET,seed) * HighBits;
seed:=69069*seed+1;
(*mt[i]:=mt[i] + (SYS.SHIFT(SYS.VAL(SET,seed) * HighBits,-16));*)
mt[i]:=mt[i] + SYS.VAL(SET, (SYS.LSH(seed * SYS.VAL(LONGINT, HighBits),-16)));
seed:=69069*seed+1;
END;
mti := MT19937N;
END SetSeed;
(* Initialization by array of seeds *)
PROCEDURE SetSeeds*(seedarray:tMT19937StateArray); (* lsgenrand_MT19937 *)
VAR
i:LONGINT;
BEGIN
FOR i:=0 TO MT19937N-1 DO
mt[i]:=seedarray[i];
END;
mti:=MT19937N;
END SetSeeds;
(* random longint (full range) *)
PROCEDURE Int*():LONGINT; (* genrand_MT19937 *)
TYPE
ar=ARRAY 2 OF SET;
VAR
mag01:ARRAY 2 OF SET;
y:SET;
kk:LONGINT;
BEGIN
mag01[0]:={};
mag01[1]:=MT19937MATRIXA;
IF mti>=MT19937N THEN (* generate MT19937N longints at one time *)
IF mti=(MT19937N+1) THEN (*-- if sgenrand_MT19937() has not been called,*)
SetSeed(Seed0); (*-- default initial seed is used*)
END;
FOR kk:=0 TO MT19937N-MT19937M-1 DO
y:=(mt[kk] * MT19937UPPERMASK) + (mt[kk+1] * MT19937LOWERMASK);
(*mt[kk]:=mt[kk+MT19937M]/SYS.SHIFT(y,-1)/mag01[SYS.VAL(LONGINT,y * {0})];*)
(*mt[kk]:=mt[kk+MT19937M]/SYS.LSH(y,-1)/mag01[SYS.VAL(LONGINT,y * {0})];*)
mt[kk]:=mt[kk+MT19937M]/SYS.VAL(SET, SYS.LSH(SYS.VAL(LONGINT, y),-1))/mag01[SYS.VAL(LONGINT,y * {0})];
(*mt[kk] := mt[kk+MT19937M];
mt[kk] := mt[kk]/SYS.VAL(SET, SYS.LSH(SYS.VAL(LONGINT, y),-1));
mt[kk] := mt[kk] / mag01[SYS.VAL(LONGINT,y * {0})];*)
END;
FOR kk:=MT19937N-MT19937M TO MT19937N-2 DO
y:=(mt[kk] * MT19937UPPERMASK) + (mt[kk+1] * MT19937LOWERMASK);
(*mt[kk]:=mt[kk+(MT19937M-MT19937N)]/SYS.LSH(y,-1)/mag01[SYS.VAL(LONGINT,y * {0})];*)
mt[kk]:=mt[kk+(MT19937M-MT19937N)]/SYS.VAL(SET, SYS.LSH(SYS.VAL(LONGINT, y),-1))/mag01[SYS.VAL(LONGINT,y * {0})];
END;
y:=(mt[MT19937N-1] * MT19937UPPERMASK) + (mt[0] * MT19937LOWERMASK);
(*mt[MT19937N-1]:=mt[MT19937M-1]/SYS.LSH(y,-1)/mag01[SYS.VAL(LONGINT,y* {0})];*)
mt[MT19937N-1]:=mt[MT19937M-1]/SYS.VAL(SET, SYS.LSH(SYS.VAL(LONGINT, y),-1))/mag01[SYS.VAL(LONGINT,y* {0})];
mti:=0;
END;
y:=mt[mti]; INC(mti);
y:=y/SYS.VAL(SET, SYS.LSH(SYS.VAL(LONGINT, y),-11));
y:=y/(SYS.VAL(SET, SYS.LSH(SYS.VAL(LONGINT, y),7)) * TEMPERINGMASKB);
y:=y/(SYS.VAL(SET, SYS.LSH(SYS.VAL(LONGINT, y),15)) * TEMPERINGMASKC);
y:=y/SYS.VAL(SET, SYS.LSH(SYS.VAL(LONGINT, y),-18));
RETURN SYS.VAL(LONGINT,y);
END Int;
(*randomization*)
PROCEDURE Randomize*(); (* Randomize_MT19937 *)
VAR sec, usec, l : LONGINT;
(*ST:Win.SYSTEMTIME;*)
BEGIN
(*Win.GetSYS.emTime(ST);
SetSeed(((SYS.VAL(LONGINT,ST.wHour)*60+ST.wMinute)*60+ST.wSecond)*1000+S
T.wMilliseconds);*)
l := SysClock.GetTimeOfDay(sec, usec);
IF l = 0 THEN SetSeed(sec*usec) ELSE HALT(1) END
(*IF l = 0 THEN SetSeed(sec*1000 + usec / 1000) ELSE HALT(1) END*) (* this way it'll repeat every 24 days; -- noch *)
(*IF l = 0 THEN SetSeed(sec*100 + usec / 100) ELSE HALT(1) END*) (* this way it'll repeat every 248 days; -- noch *)
END Randomize;
(*integer RANDOM with positive range*)
(*-- bug fixed 21.6.2000.*)
PROCEDURE IntRange*(Range:LONGINT):LONGINT; (* RandInt_MT19937 *)
TYPE
VAR
(*X:SYS.CARD64;*)
X:LONGINT;
BEGIN
X:=Range;
(*X:=X * SYS.VAL(SYS.CARD64,Int());*)
X:=X * Int();
SYS.MOVE(SYS.ADR(X)+SIZE(INTEGER)(*4*),SYS.ADR(Range),SIZE(INTEGER)(*4*));
RETURN Range;
END IntRange;
(*float RANDOM on 0..1 interval*)
PROCEDURE Real*():LONGREAL; (* RandFloat_MT19937 *)
VAR l : LONGINT;
BEGIN
(*RETURN SYS.VAL(SYS.CARD32,Int())/(1.0*MAX(SYS.CARD32)+1)*)
l := Int();
RETURN l/(1.0*MAX(LONGINT)+1)
END Real;
PROCEDURE Gauss*(mean,std:LONGREAL):LONGREAL;
VAR
r1,r2,s,result:LONGREAL;
BEGIN
IF GaussRandomBufFilled THEN
result:=GaussRandomBuf*std+mean
ELSE
REPEAT
r1:=2*Real()-1;
r2:=2*Real()-1;
s:=r1*r1+r2*r2;
UNTIL s<1;
s:=MathL.sqrt((-2*MathL.ln(s))/s);
result:=r1*s*std+mean;
GaussRandomBuf:=r2*s;
END;
(*GaussRandomBufFilled:=NOT GaussRandomBufFilled;*)
GaussRandomBufFilled := ~GaussRandomBufFilled;
RETURN result
END Gauss;
BEGIN
MT19937MATRIXA := SYS.VAL(SET,-1727483681)(*9908b0dfH*); (* -- constant vector a*)
MT19937UPPERMASK := SYS.VAL(SET,80000000H); (* -- most significant w-r bits*)
MT19937LOWERMASK := SYS.VAL(SET, 2147483647 (* 7fffffffH*)); (* -- least significant r bits*)
(* Tempering parameters *)
TEMPERINGMASKB := SYS.VAL(SET, -1658038656 (*9d2c5680H*));
TEMPERINGMASKC := SYS.VAL(SET, -272236544 (*0efc60000H*));
Seed:=Seed0;
mti:=MT19937N+1;
GaussRandomBufFilled:=FALSE;
END MersenneTwister.
(*----------------------------------------------------------------------
Mersenne Twister: A 623-Dimensionally Equidistributed Uniform
Pseudo-Random Number Generator.
What is Mersenne Twister?
Mersenne Twister(MT) is a pseudorandom number generator developped by
Makoto Matsumoto and Takuji Nishimura (alphabetical order) during
1996-1997. MT has the following merits:
It is designed with consideration on the flaws of various existing
generators.
Far longer period and far higher order of equidistribution than any
other implemented generators. (It is proved that the period is 2^19937-1,
and 623-dimensional equidistribution property is assured.)
Fast generation. (Although it depends on the system, it is reported that
MT is sometimes faster than the standard ANSI-C library in a system
with pipeline and cache memory.)
Efficient use of the memory. (The implemented C-code mt19937.c
consumes only 624 words of working area.)
home page
http://www.math.keio.ac.jp/~matumoto/emt.html
original c source
http://www.math.keio.ac.jp/~nisimura/random/int/mt19937int.c
Coded by Takuji Nishimura, considering the suggestions by
Topher Cooper and Marc Rieffel in July-Aug. 1997.
This 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.
This 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 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
02111-1307 USA
Copyright (C) 1997, 1999 Makoto Matsumoto and Takuji Nishimura.
When you use this, send an email to: matumoto@math.keio.ac.jp
with an appropriate reference to your work.
REFERENCE
M. Matsumoto and T. Nishimura,
"Mersenne Twister: A 623-Dimensionally Equidistributed Uniform
Pseudo-Random Number Generator",
ACM Transactions on Modeling and Computer Simulation,
Vol. 8, No. 1, January 1998, pp 3--30.
Translated to OP and Delphi interface added by Roman Krejci (6.12.1999)
http://www.rksolution.cz/delphi/tips.htm
Revised 21.6.2000: Bug in the function RandInt_MT19937 fixed
----------------------------------------------------------------------*)

549
src/library/misc/MultiArrayRiders.Mod Normal file
View file

@ -0,0 +1,549 @@
(* Copyright 1999-2001, Patrick Hunziker
This 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 any later version.
This 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.
Patrick Hunziker,Basel.
email Patrick.Hunziker@unibas.ch
*)
(** Version 1.0, 19.1.2001 *)
MODULE MultiArrayRiders; (** Patrick Hunziker, Basel, **)
(** Implements an array rider access mechanism for multidimensional arrays of arbitrary
dimensions defined in MultiArrays*)
IMPORT MultiArrays, Out:= Console, Input := Kernel;
CONST (** behaviour of array rider at end of array line;
not yet completely implemented.
The seemingly more exotic variants are especially useful in image processing *)
halt = 0;
zeropadding = 1; (* not yet implemented *)
constant = 2; (* not yet implemented *)
circular* = 3; (** after finishing one line, the same line is restarted *)
mirror = 4; (* not yet implemented *)
incremental* = 5; (** after finishing one line, the next line is started *)
(** rider has not passed any border of the array *)
noteol* = MAX(LONGINT);
TYPE
(** Array riders allow traversal of arbitrary dimensional array using procedures Inc() and Dec(),
and can be positioned using Set(). *)
Rider* = RECORD
array-: MultiArrays.Array; (** points to the array the rider is based on *)
order-: LONGINT; (** dimensionality of array *)
offset- : LONGINT; (** Rider position in linear array representation *)
eol*: LONGINT; (** Rider has gone beyond the border of the
line of indicated dimension .
if eol=noteol, rider is inside array *)
eolBehaviour*: INTEGER; (** What to do when reaching eol. Not yet completely satisfactory *)
dimension, (* dimensions of Array, in vector notation *)
pos, (* position of rider in Array, in vector notation *)
step: MultiArrays.SizeVector; (* unit increment for offset in each dimension, in vector notation *)
END;
PROCEDURE CalculatePos (pos, dimension: MultiArrays.SizeVector): LONGINT;
VAR maxI, res, i: LONGINT;
BEGIN
maxI := LEN(dimension^)-1;
ASSERT(LEN(pos^) = LEN(dimension^));
res := pos[maxI];
FOR i := 1 TO maxI DO res := res*dimension[maxI-i]+pos[maxI-i] END;
RETURN res
END CalculatePos;
PROCEDURE InitRider* (VAR R: Rider; A: MultiArrays.Array; pos: MultiArrays.SizeVector);
(** Sets array rider in position pos in array A *)
VAR i, step: LONGINT;
BEGIN
ASSERT(MultiArrays.Order(A) = LEN(pos^));
R.array := A;
R.order := MultiArrays.Order(A);
NEW(R.pos,R.order);
NEW(R.step,R.order);
NEW(R.dimension,R.order);
step := 1;
FOR i := 0 TO R.order-1 DO
ASSERT(pos[i] <= MultiArrays.Len(A,i));
R.pos[i] := pos[i];
R.step[i] := step; step := step*MultiArrays.Len(A,i);
R.dimension[i] := MultiArrays.Len(A,i)
END;
R.eol := noteol;
R.offset := CalculatePos(R.pos,MultiArrays.Size(A));
R.eolBehaviour := incremental
END InitRider;
PROCEDURE SetRider* (VAR R: Rider; pos: MultiArrays.SizeVector);
VAR i: LONGINT;
BEGIN
ASSERT(R.array # NIL);
ASSERT(LEN(pos^) = R.order);
FOR i := 0 TO R.order-1 DO ASSERT(pos[i] < R.dimension[i]); R.pos[i] := pos[i] END;
R.offset := CalculatePos(pos,R.dimension);
R.eol := noteol
END SetRider;
PROCEDURE Inc* (VAR R: Rider; Dim: LONGINT);
(** array rider advances one element in dimension Dim;
at end of line, eol is assigned the number of the dimension overflown *)
BEGIN
ASSERT(Dim < R.order);
IF R.pos[Dim] < R.dimension[Dim]-1
THEN INC(R.pos[Dim]); INC(R.offset, R.step[Dim]);
ELSE
R.eol := Dim;
CASE R.eolBehaviour OF
halt: HALT(100);
| zeropadding: HALT(100); (* not yet implemented *)
| constant:
| mirror: HALT(100); (* not yet implemented *)
| incremental:
R.pos[Dim] := 0;
IF Dim < R.order-1
THEN
INC(R.offset, R.step[Dim]-R.step[Dim+1]);
Inc(R, R.eol+1)
ELSE INC(R.offset, R.step[Dim]-R.array.len)
END
| circular:
R.pos[Dim] := 0;
IF Dim < R.order-1
THEN INC(R.offset, R.step[Dim]-R.step[Dim+1])
ELSE INC(R.offset, R.step[Dim]-R.array.len)
END
ELSE HALT(100)
END
END
END Inc;
PROCEDURE Dec* (VAR R: Rider; Dim: LONGINT);
(** array rider goes back one element in dimension Dim *)
BEGIN
ASSERT(Dim < R.order);
IF R.pos[Dim] > 0
THEN DEC(R.pos[Dim]); DEC(R.offset, R.step[Dim]);
ELSE R.eol := Dim;
CASE R.eolBehaviour OF
halt: HALT(100);
| zeropadding: HALT(100); (* not yet implemented *)
| constant:
| mirror: HALT(100); (* not yet implemented *)
| incremental:
R.pos[Dim] := R.dimension[Dim]-1;
IF Dim > 0
THEN
DEC(R.offset, R.step[Dim]-R.step[Dim+1]);
Dec(R, R.eol+1)
ELSE DEC(R.offset, R.step[Dim]-R.array.len)
END
| circular:
R.pos[Dim] := R.dimension[Dim]-1;
IF Dim > 0
THEN DEC(R.offset, R.step[Dim]-R.step[Dim+1])
ELSE DEC(R.offset, R.step[Dim]-R.array.len)
END
ELSE HALT(100)
END
END
END Dec;
PROCEDURE Pos* (R: Rider): MultiArrays.SizeVector;
(** gives actual position of R in its associated array *)
VAR i: LONGINT; res: MultiArrays.SizeVector;
BEGIN
NEW(res,R.order);
FOR i := 0 TO R.order-1 DO res[i] := R.pos[i] END;
RETURN res
END Pos;
(** elementwise reading from Array Rider, followed by advancing the rider by
one step in direction "dir"; with specific "eolBehaviour" (see above) at border of array *)
PROCEDURE ReadSInt* (VAR R: Rider; dir: LONGINT; VAR s: SHORTINT);
BEGIN
IF R.array IS MultiArrays.SIntArray
THEN s := R.array(MultiArrays.SIntArray).s[R.offset]; Inc(R, dir)
ELSE HALT(100)
END
END ReadSInt;
PROCEDURE ReadSIntRun* (VAR R: Rider; dir: LONGINT;
VAR srun: ARRAY OF SHORTINT; n: LONGINT);
VAR i, step, offset, pos, dim: LONGINT; array: MultiArrays.SIntArray;
BEGIN
ASSERT(LEN(srun) >= n);
ASSERT(dir < R.order);
ASSERT(R.array IS MultiArrays.SIntArray);
array := R.array(MultiArrays.SIntArray);
offset := R.offset;
step := R.step[dir];
pos := R.pos[dir];
dim := R.dimension[dir];
CASE R.eolBehaviour OF
halt: HALT(100); (* not yet implemented *)
| incremental:
IF offset+(n-1)*step < R.array.len
THEN FOR i := 0 TO n-1 DO srun[i] := array.s[offset]; INC(offset, step) END
ELSE HALT(100) (* not yet implemented *)
END
| circular:
IF R.pos[dir]+n-1 < dim
THEN FOR i := 0 TO n-1 DO srun[i] := array.s[offset]; INC(offset, step) END
ELSE
FOR i := 0 TO n-1 DO
srun[i] := array.s[offset+((pos+i) MOD dim)*step] (* can further be optimized *)
END
END
ELSE HALT(100) (* not yet implemented *)
END
END ReadSIntRun;
PROCEDURE ReadInt* (VAR R: Rider; dir: LONGINT; VAR i: INTEGER);
BEGIN
IF R.array IS MultiArrays.IntArray
THEN i := R.array(MultiArrays.IntArray).i[R.offset]; Inc(R, dir);
ELSE HALT(100)
END
END ReadInt;
PROCEDURE ReadLInt* (VAR R: Rider; dir: LONGINT; VAR j: LONGINT);
BEGIN
IF R.array IS MultiArrays.LIntArray
THEN j := R.array(MultiArrays.LIntArray).j[R.offset]; Inc(R, dir)
ELSE HALT(100)
END
END ReadLInt;
(* PROCEDURE ReadHInt* (VAR R: Rider; dir: LONGINT; VAR h: HUGEINT);
BEGIN
HALT(100) (* yet to implement *)
END ReadHInt; *)
PROCEDURE ReadReal* (VAR R: Rider; dir: LONGINT; VAR x: REAL);
BEGIN
IF R.array IS MultiArrays.RealArray
THEN x := R.array(MultiArrays.RealArray).x[R.offset]; Inc(R, dir)
ELSE HALT(100)
END;
END ReadReal;
PROCEDURE ReadRealRun* (VAR R: Rider; dir: LONGINT;
VAR srun: ARRAY OF REAL; n: LONGINT);
VAR i, step, offset, pos, dim: LONGINT; array: MultiArrays.RealArray;
BEGIN
ASSERT(LEN(srun) >= n);
ASSERT(dir < R.order);
ASSERT(R.array IS MultiArrays.RealArray);
array := R.array(MultiArrays.RealArray);
offset := R.offset;
step := R.step[dir];
pos := R.pos[dir];
dim := R.dimension[dir];
CASE R.eolBehaviour OF
halt: HALT(100); (* not yet implemented *)
| incremental:
IF offset+(n-1)*step < R.array.len
THEN FOR i := 0 TO n-1 DO srun[i] := array.x[offset]; INC(offset, step) END
ELSE HALT(100) (* not yet implemented *)
END;
| circular:
IF R.pos[dir]+n-1 < dim
THEN FOR i := 0 TO n-1 DO srun[i] := array.x[offset]; INC(offset, step) END
ELSE
FOR i := 0 TO n-1 DO
srun[i] := array.x[offset+((pos+i) MOD dim)*step] (* can further be optimized *)
END
END
ELSE HALT(100) (* not yet implemented *)
END
END ReadRealRun;
PROCEDURE ReadLReal* (VAR R: Rider; dir: LONGINT; VAR y: LONGREAL);
BEGIN
IF R.array IS MultiArrays.LRealArray
THEN y := R.array(MultiArrays.LRealArray).y[R.offset]; Inc(R, dir)
ELSE HALT(100)
END
END ReadLReal;
(* PROCEDURE ReadBool* (VAR R: Rider; dir: LONGINT; VAR b: BOOLEAN);
BEGIN
HALT(100) (* to implement *)
END ReadBool; *)
(* PROCEDURE ReadComplex* (VAR R: Rider; dir: LONGINT; VAR z: MultiArrays.Complex);
BEGIN
HALT(100) (* yet to implement *)
END ReadComplex; *)
PROCEDURE WriteSInt* (VAR R: Rider; dir: LONGINT; s: SHORTINT);
BEGIN
IF R.array IS MultiArrays.SIntArray
THEN R.array(MultiArrays.SIntArray).s[R.offset] := s; Inc(R, dir)
ELSE HALT(100) END
END WriteSInt;
PROCEDURE WriteInt* (VAR R: Rider; dir: LONGINT; i: INTEGER);
BEGIN
IF R.array IS MultiArrays.IntArray
THEN R.array(MultiArrays.IntArray).i[R.offset] := i; Inc(R, dir)
ELSE HALT(100) END
END WriteInt;
PROCEDURE WriteLInt* (VAR R: Rider; dir: LONGINT; j: LONGINT);
BEGIN
IF R.array IS MultiArrays.LIntArray
THEN R.array(MultiArrays.LIntArray).j[R.offset] := j; Inc(R, dir)
ELSE HALT(100) END
END WriteLInt;
(* PROCEDURE WriteHInt* (VAR R: Rider; dir: LONGINT; h: HUGEINT);
BEGIN
HALT(100); (* yet to implement *) END
END WriteHInt; *)
PROCEDURE WriteReal* (VAR R: Rider; dir: LONGINT; x: REAL);
BEGIN
IF R.array IS MultiArrays.RealArray
THEN R.array(MultiArrays.RealArray).x[R.offset] := x; Inc(R, dir)
ELSE HALT(100) END
END WriteReal;
PROCEDURE WriteRealRun* (VAR R: Rider; dir: LONGINT; srun: ARRAY OF REAL; n: LONGINT);
VAR i, step, offset, pos, dim: LONGINT; array: MultiArrays.RealArray;
BEGIN
ASSERT(LEN(srun) >= n);
ASSERT(dir < R.order);
ASSERT(R.array IS MultiArrays.RealArray);
array := R.array(MultiArrays.RealArray);
offset := R.offset;
step := R.step[dir];
pos := R.pos[dir];
dim := R.dimension[dir];
CASE R.eolBehaviour OF
halt: HALT(100); (* not yet implemented *)
| incremental:
IF offset+(n-1)*step < R.array.len
THEN
FOR i := 0 TO n-1 DO array.x[offset] := srun[i]; INC(offset, step) END
ELSE HALT(100) (* not yet implemented *)
END
| circular:
IF R.pos[dir]+n-1 < dim
THEN
FOR i := 0 TO n-1 DO array.x[offset] := srun[i]; INC(offset, step) END
ELSE
FOR i := 0 TO n-1 DO
array.x[offset+((pos+i) MOD dim)*step] := srun[i] (* can further be optimized *)
END
END
ELSE HALT(100) (* not yet implemented *)
END
END WriteRealRun;
PROCEDURE WriteLReal* (VAR R: Rider; dir: LONGINT; y: LONGREAL);
BEGIN
IF R.array IS MultiArrays.LRealArray
THEN R.array(MultiArrays.LRealArray).y[R.offset] := y; Inc(R, dir)
ELSE HALT(100) END
END WriteLReal;
PROCEDURE WriteBool* (VAR R: Rider; dir: LONGINT; b: BOOLEAN);
BEGIN
IF R.array IS MultiArrays.BoolArray
THEN R.array(MultiArrays.BoolArray).b[R.offset] := b; Inc(R, dir)
ELSE HALT(100) END
END WriteBool;
(* PROCEDURE WriteComplex* (VAR R: Rider; dir: LONGINT; VAR z: MultiArrays.Complex);
BEGIN
HALT(100) (* yet to implement *)
END WriteComplex; *)
PROCEDURE InvertSign (s: SHORTINT): SHORTINT; (* Test procedure for unary operations *)
BEGIN
RETURN -s
END InvertSign;
PROCEDURE Assign (VAR S: SHORTINT;s: SHORTINT); (* Testing *)
BEGIN
S := s
END Assign;
PROCEDURE Test*; (** Tests if eol mechanism is working correctly *)
VAR pos, dimension: MultiArrays.SizeVector; A: MultiArrays.Array;
i, j: LONGINT; R: Rider;
BEGIN
MultiArrays.SizeVector4(dimension, 10, 10, 10, 10);
MultiArrays.SizeVector4(pos, 2, 3, 4, 5);
NEW(A); MultiArrays.InitInt(A, dimension, NIL, FALSE);
InitRider(R,A,pos);
R.eolBehaviour := circular;
FOR j := 0 TO 3 DO
FOR i := 1 TO 10 DO
Inc(R, j); Out.Int(CalculatePos(R.pos,MultiArrays.Size(A)), 5); Out.Ln;
IF R.eol#noteol THEN
Out.String("R.eol:"); Out.Int(R.eol, 5); Out.Ln;
R.eol := noteol
END
END;
Out.String("----"); Out.Ln
END
END Test;
PROCEDURE Test1*;
VAR A1: MultiArrays.Array;
SA: ARRAY 256 OF SHORTINT;
R1: Rider;
dim0, dim1: MultiArrays.SizeVector;
starttime, endtime, a, b, c, d, opcount1, opcount2: LONGINT;
A3: POINTER TO ARRAY OF ARRAY OF ARRAY OF ARRAY OF SHORTINT;
s: SHORTINT;
BEGIN
Out.Ln;
Out.String("**********************************"); Out.Ln;
Out.String(" Benchmark:"); Out.Ln;
Out.String(" Arbitrary arrays with riders vs. ARRAY[x,y,z,...] concept"); Out.Ln;
Out.String("----------------------------------"); Out.Ln;
Out.String("----------------------------------"); Out.Ln;
MultiArrays.SizeVector4(dim0, 0, 0, 0, 0);
MultiArrays.SizeVector4(dim1, 256, 128, 8, 8);
MultiArrays.InitSInt(A1, dim1, NIL, FALSE);
InitRider(R1, A1, dim0);
R1.eolBehaviour := incremental;
opcount1 := 0;
(* ASSIGN *)
starttime := Input.Time();
REPEAT (* main loop of elementwise rider writing *)
ReadSInt(R1,0,s);
INC(opcount1);
UNTIL R1.eol=R1.order-1;
endtime := Input.Time();
Out.String("ASSIGN:");Out.Ln;
Out.String("Arbitrary multidimensional array: elementwise writing:"); Out.Ln;
Out.String(" time: "); Out.Int(endtime-starttime,5);
Out.String(" opcount: "); Out.Int(opcount1, 5); Out.Ln;
Out.String("----------------------------------"); Out.Ln;
MultiArrays.SizeVector4(dim0,0,0,0,0);
MultiArrays.SizeVector4(dim1,256,128,8,8);
SetRider(R1,dim0); R1.eolBehaviour := circular;
opcount2 := 0;
dim0[0] := 0;
starttime := Input.Time();
FOR b := 0 TO dim1[1]-1 DO (* main loop of linewise reading *)
dim0[1] := b;
FOR c := 0 TO dim1[2]-1 DO
dim0[2] := c;
FOR d := 0 TO dim1[3]-1 DO
dim0[3] := d;
SetRider(R1,dim0);
ReadSIntRun(R1,0,SA,256);
INC(opcount2, 256)
END
END
END;
endtime := Input.Time();
Out.String(" Arbitrary multidimensional array: line reading with rider"); Out.Ln;
Out.String(" time: ");
Out.Int(endtime-starttime, 5);
Out.String(" opcount: "); Out.Int(opcount2, 5); Out.Ln;
Out.String("----------------------------------"); Out.Ln;
NEW(A3, 256, 128, 8, 8 );
starttime := Input.Time();
opcount2 := 0;
FOR a := 0 TO LEN(A3^,0)-1 DO (* main loop of conventional array handling *)
FOR b := 0 TO LEN(A3^,1)-1 DO
FOR c := 0 TO LEN(A3^,2)-1 DO
FOR d := 0 TO LEN(A3^,3)-1 DO
SA[a] := A3[a,b,c,d]; INC(opcount2)
END
END
END
END;
endtime := Input.Time();
Out.String(" conventional multidimensional array: index line reading:"); Out.Ln;
Out.String(" time: ");
Out.Int(endtime-starttime, 5);
Out.String(" opcount: "); Out.Int(opcount2, 5); Out.Ln;
Out.String("**********************************"); Out.Ln
END Test1;
(* Intel may have register problems with the following procedure *)
(* PROCEDURE Test2*;
VAR A1, A2: MultiArrays.Array;
R1: Rider;
dim0, dim1: MultiArrays.SizeVector;
i, starttime, endtime, a, b, c, d, e, f, dir, opcount1, opcount2: LONGINT;
A3: POINTER TO ARRAY OF ARRAY OF ARRAY OF ARRAY OF ARRAY OF ARRAY OF SHORTINT;
s: SHORTINT;
BEGIN
Out.Ln;
Out.String("**********************************"); Out.Ln;
Out.String(" Benchmark:"); Out.Ln;
Out.String(" Arbitrary arrays with riders vs. ARRAY[x,y,z,...] concept"); Out.Ln;
Out.String("----------------------------------"); Out.Ln;
NEW(dim0, 6); FOR i := 0 TO 5 DO dim0[i] := 0 END;
NEW(dim1, 6);
dim1[0] := 64; dim1[1] := 32; dim1[2] := 16; dim1[3] := 16;
dim1[4] := 2; dim1[5] := 2;
MultiArrays.InitSInt(A1, dim1, NIL, FALSE);
InitRider(R1, A1, dim0);
R1.eolBehaviour := incremental;
opcount1 := 0;
(* ASSIGN *)
starttime := Input.Time();
REPEAT
WriteSInt(R1,0,1);
INC(opcount1);
UNTIL R1.eol=5;
endtime := Input.Time();
Out.String("ASSIGN:");Out.Ln;
Out.String("arbitrary array rider assignement:"); Out.Ln;
Out.String(" time: "); Out.Int(endtime-starttime, 5);
Out.String(" opcount: "); Out.Int(opcount1, 5); Out.Ln;
Out.String("----------------------------------"); Out.Ln;
NEW(A3, 64,32,16,16, 2,2);
starttime := Input.Time();
opcount2 := 0;
FOR a := 0 TO LEN(A3^,0)-1 DO
FOR b := 0 TO LEN(A3^,1)-1 DO
FOR c := 0 TO LEN(A3^,2)-1 DO
FOR d := 0 TO LEN(A3^,3)-1 DO
FOR e := 0 TO LEN(A3^,4)-1 DO
FOR f := 0 TO LEN(A3^,5)-1 DO
Assign(A3[a,b,c,d,e,f],1); INC(opcount2)
END
END
END
END
END
END;
endtime := Input.Time();
Out.String("multidim index assignement:"); Out.Ln;
Out.String(" time: ");
Out.Int(endtime-starttime, 5);
Out.String(" opcount: "); Out.Int(opcount2, 5); Out.Ln
END Test2;
*)
BEGIN
END MultiArrayRiders.
MultiArrayRiders.Test1 (4D), MultiArrayRiders.Test2 (6D)
Compares execution times for
-arbitrary dimensional approach with riders
-conventional ARRAY [x,y,z,...] approach
This is done for elementwise assignements and reading of "runs" of data.

747
src/library/misc/MultiArrays.Mod Normal file
View file

@ -0,0 +1,747 @@
MODULE MultiArrays; (** P. Hunziker, Basel, **)
(**
AIM: To provide a library solution for
a multidimensional array type for numbers of arbitrary dimensions,
with the following features:
-compatible types for 1,2,3..n dimensions, allowing exchangeable use in procedure headers etc
-> generic/OO procedures for multidimensional array handling can be implemented
-arrays can be accessed in multiple ways:
-a) conventional indexing (though not by using brackets[ ], but using procedure IndexN. )
-b) in a linear fashion (fast)
-c) using an "ALL()" procedure without need for index handling by the user (very fast !)
-d) using array riders movable along arbitrary axis (Module MultiArrayRiders)
-e) by reading "runs" of data with rider (Module MultiArrayRiders)
A type 'scalar' is also based on the same base type as arrays, to allow mixing of arrays and scalars
in procedure headers, for more generic procedure headers when e.g. defining array operations:
(e.g. PROCEDURE Add(d1, d2: Data): Data;
can be used for mixed expressions of arrays and numbers).
This is in the hope that a family of array handling modules similar to the functionality of
MATLAB or APL will be based on these types in the future. (Help is welcome !).
See 'Test', 'Test1', procedures in both modules for insight how to use them.
*)
(** Copyright 1999-2001, Patrick Hunziker
This 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 any later version.
This 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.
Patrick Hunziker,Basel.
email Patrick.Hunziker@unibas.ch
*)
(** Version 0.9, 19.1.2001 *)
IMPORT Out:= Console, Input:= Kernel; (* Import only needed for Demo purposes *)
TYPE
SIntPtr* = POINTER TO ARRAY OF SHORTINT;
IntPtr* = POINTER TO ARRAY OF INTEGER;
LIntPtr* = POINTER TO ARRAY OF LONGINT;
(* HIntPtr* = POINTER TO ARRAY OF HUGEINT; *)
RealPtr* = POINTER TO ARRAY OF REAL;
LRealPtr* = POINTER TO ARRAY OF LONGREAL;
BoolPtr* = POINTER TO ARRAY OF BOOLEAN;
(* ComplxPtr* = POINTER TO ARRAY OF COMPLEX; *)
Data* = POINTER TO DataDesc; (** abstract base type, not containing data.
This could be an Objects.Object for S3 *)
DataDesc* = RECORD END;
Scalar* = POINTER TO ScalarDesc; (** abstract base type, not containing data. *)
ScalarDesc* = RECORD (DataDesc) END;
SInt* = POINTER TO SIntDesc;
SIntDesc* = RECORD (ScalarDesc)
s*: SHORTINT;
END;
Int* = POINTER TO IntDesc;
IntDesc* = RECORD (ScalarDesc)
i*: INTEGER;
END;
LInt* = POINTER TO LIntDesc;
LIntDesc* = RECORD (ScalarDesc)
j*: LONGINT;
END;
(* HInt* = POINTER TO HIntDesc;
HIntDesc* = RECORD (ScalarDesc)
h*: HUGEINT;
END;
*)
Real* = POINTER TO RealDesc;
RealDesc* = RECORD (ScalarDesc)
x*: REAL;
END;
LReal* = POINTER TO LRealDesc;
LRealDesc* = RECORD (ScalarDesc)
y*: LONGREAL;
END;
Bool* = POINTER TO BoolDesc;
BoolDesc* = RECORD (ScalarDesc)
b*: BOOLEAN;
END;
Complex* = POINTER TO ComplexDesc;
ComplexDesc* = RECORD (ScalarDesc)
r*, i*: REAL;
END;
SizeVector* = POINTER TO SizeVectorDesc; (* used for description of array size; eventually = CATLIntVector *)
SizeVectorDesc* = ARRAY OF LONGINT;
Array* = POINTER TO ArrayDesc; (** abstract base type, not containing data *)
ArrayDesc* = RECORD (DataDesc)
(*ARRAY of arbitrary dimensionality *)
dimension: SizeVector; (* dimension vector *)
len-: LONGINT; (* Overall number of array elements *)
END;
SIntArray* = POINTER TO SIntArrayDesc;
SIntArrayDesc* = RECORD (ArrayDesc)
s-: SIntPtr;
END;
IntArray* = POINTER TO IntArrayDesc;
IntArrayDesc* = RECORD (ArrayDesc)
i-: IntPtr;
END;
LIntArray* = POINTER TO LIntArrayDesc;
LIntArrayDesc* = RECORD (ArrayDesc)
j-: LIntPtr;
END;
(* HIntArray* = POINTER TO HIntArrayDesc;
HIntArrayDesc* = RECORD (ArrayDesc)
h-: HIntPtr;
END;
*)
RealArray* = POINTER TO RealArrayDesc;
RealArrayDesc* = RECORD (ArrayDesc)
x-: RealPtr;
END;
LRealArray* = POINTER TO LRealArrayDesc;
LRealArrayDesc* = RECORD (ArrayDesc)
y-: LRealPtr;
END;
BoolArray* = POINTER TO BoolArrayDesc;
BoolArrayDesc* = RECORD (ArrayDesc)
b-: BoolPtr;
END;
ComplexArray* = POINTER TO ComplexArrayDesc;
ComplexArrayDesc* = RECORD (ArrayDesc)
r-, i-: RealPtr;
END;
PROCEDURE Order* (A: Array): LONGINT;
(** returns Nr of dimensions of array A *)
BEGIN
RETURN LEN(A.dimension^)
END Order;
PROCEDURE Size* (A: Array): SizeVector;
(** returns dimension vector *)
VAR i: LONGINT; res: SizeVector;
BEGIN
NEW(res,LEN(A.dimension^));
FOR i := 0 TO LEN(A.dimension^)-1 DO res[i] := A.dimension[i] END;
RETURN res
END Size;
PROCEDURE Len* (A: Array; dim: LONGINT): LONGINT;
(** returns length of dimension Nr 'dim' *)
BEGIN
IF dim >= LEN(A.dimension^) THEN HALT(100)
ELSE RETURN A.dimension[dim]
END
END Len;
PROCEDURE Index*(pos, dimension: ARRAY OF LONGINT): LONGINT;
VAR maxI,res,i: LONGINT;
BEGIN
maxI := LEN(dimension)-1;
ASSERT(LEN(pos) = LEN(dimension));
res := pos[maxI];
FOR i := 1 TO maxI DO res := res*dimension[maxI-i]+pos[maxI-i] END;
RETURN res
END Index;
PROCEDURE Index1*(A: Array; x: LONGINT): LONGINT;
BEGIN
ASSERT(Order(A) = 1);
ASSERT(x < A.len);
RETURN x
END Index1;
PROCEDURE Index2*(A: Array; x,y: LONGINT): LONGINT;
BEGIN
ASSERT(Order(A) = 2);
ASSERT(x < Len(A,0));
ASSERT(y < Len(A,1));
RETURN y*Len(A,0)+x
END Index2;
PROCEDURE Index3*(A: Array; x,y,z: LONGINT): LONGINT;
BEGIN
ASSERT(Order(A) = 3);
ASSERT(x < Len(A,0));
ASSERT(y < Len(A,1));
ASSERT(z < Len(A,2));
RETURN (z*Len(A,1)+y)*Len(A,0)+x
END Index3;
PROCEDURE Index4*(A: Array; x,y,z,u: LONGINT): LONGINT;
BEGIN
ASSERT(Order(A) = 4);
ASSERT(x < Len(A,0));
ASSERT(y < Len(A,1));
ASSERT(z < Len(A,2));
ASSERT(u < Len(A,3));
RETURN ((u*Len(A,2)+z)*Len(A,1)+y)*Len(A,0)+x
END Index4;
PROCEDURE SizeVector1*(VAR Vec: SizeVector; x: LONGINT);
BEGIN
IF (Vec=NIL) OR (LEN(Vec^)#1) THEN NEW(Vec,1) END;
Vec[0] := x
END SizeVector1;
PROCEDURE SizeVector2*(VAR Vec: SizeVector; x,y: LONGINT);
BEGIN
IF (Vec=NIL) OR (LEN(Vec^)#2) THEN NEW(Vec,2) END;
Vec[0] := x; Vec[1] := y
END SizeVector2;
PROCEDURE SizeVector3*(VAR Vec: SizeVector; x,y,z: LONGINT);
BEGIN
IF (Vec=NIL) OR (LEN(Vec^)#3) THEN NEW(Vec,3) END;
Vec[0] := x; Vec[1] := y; Vec[2] := z
END SizeVector3;
PROCEDURE SizeVector4*(VAR Vec: SizeVector; x,y,z,u: LONGINT);
BEGIN
IF (Vec=NIL) OR (LEN(Vec^)#4) THEN NEW(Vec,4) END;
Vec[0] := x; Vec[1] := y; Vec[2] := z; Vec[3] := u
END SizeVector4;
PROCEDURE CalculatePos*(Index: LONGINT; dimension: ARRAY OF LONGINT): SizeVector;
VAR maxI, n, i: LONGINT;
res: SizeVector;
BEGIN
n := Index;
maxI := LEN(dimension)-1;
FOR i := 0 TO maxI-1 DO
res[maxI-i] := n MOD dimension[maxI-i];
n := n DIV dimension[maxI-i]
END;
RETURN res
END CalculatePos;
PROCEDURE InitSInt* (VAR A: Array; dimension: SizeVector; data: SIntPtr; copy: BOOLEAN);
VAR i, n: LONGINT;
AA: SIntArray;
BEGIN
IF (A=NIL) OR ~(A IS SIntArray) THEN NEW(AA) ELSE IF A IS SIntArray THEN AA := A(SIntArray) END END;
n := 1;
FOR i := 0 TO LEN(dimension^)-1 DO n := n*dimension[i] END;
IF data=NIL THEN NEW(data,n); copy := FALSE END;
ASSERT (LEN(data^)=n);
NEW(AA.dimension,LEN(dimension^));
FOR i := 0 TO LEN(dimension^)-1 DO AA.dimension[i] := dimension[i]; END;
AA.len := n;
IF copy
THEN NEW (AA.s,n); FOR i := 0 TO n-1 DO AA.s[i] := data[i] END;
ELSE AA.s := data
END;
A := AA
END InitSInt;
PROCEDURE InitInt* (VAR A: Array; dimension: SizeVector; data: IntPtr; copy: BOOLEAN);
VAR i, n: LONGINT;
AA: IntArray;
BEGIN
IF (A=NIL) OR ~(A IS IntArray) THEN NEW(AA) ELSE IF A IS IntArray THEN AA := A(IntArray) END END;
n := 1;
FOR i := 0 TO LEN(dimension^)-1 DO n := n*dimension[i] END;
IF data=NIL THEN NEW(data,n); copy := FALSE END;
ASSERT (LEN(data^)=n);
NEW(AA.dimension,LEN(dimension^));
FOR i := 0 TO LEN(dimension^)-1 DO AA.dimension[i] := dimension[i]; END;
AA.len := n;
IF copy
THEN NEW (AA.i,n); FOR i := 0 TO n-1 DO AA.i[i] := data[i] END;
ELSE AA.i := data
END;
A := AA
END InitInt;
PROCEDURE InitLInt* (VAR A: Array; dimension: SizeVector; data: LIntPtr; copy: BOOLEAN);
VAR i, n: LONGINT;
AA: LIntArray;
BEGIN
IF (A=NIL) OR ~(A IS LIntArray) THEN NEW(AA) ELSE IF A IS LIntArray THEN AA := A(LIntArray) END END;
n := 1;
FOR i := 0 TO LEN(dimension^)-1 DO n := n*dimension[i] END;
IF data=NIL THEN NEW(data,n); copy := FALSE END;
ASSERT (LEN(data^)=n);
NEW(AA.dimension,LEN(dimension^));
FOR i := 0 TO LEN(dimension^)-1 DO AA.dimension[i] := dimension[i]; END;
AA.len := n;
IF copy
THEN NEW (AA.j,n); FOR i := 0 TO n-1 DO AA.j[i] := data[i] END;
ELSE AA.j := data
END;
A := AA
END InitLInt;
(* PROCEDURE InitHInt* (VAR A: Array; dimension: SizeVector; data: HIntPtr; copy: BOOLEAN);
VAR i, n: LONGINT;
AA: HIntArray;
BEGIN
IF (A=NIL) OR ~(A IS HIntArray) THEN NEW(AA) ELSE WITH A: HIntArray DO AA := A END END;
n := 1;
FOR i := 0 TO LEN(dimension^)-1 DO n := n*dimension[i] END;
IF data=NIL THEN NEW(data,n); copy := FALSE END;
ASSERT (LEN(data^)=n);
NEW(AA.dimension,LEN(dimension^));
FOR i := 0 TO LEN(dimension^)-1 DO AA.dimension[i] := dimension[i]; END;
AA.len := n;
IF copy
THEN NEW (AA.h,n); FOR i := 0 TO n-1 DO AA.h[i] := data[i] END;
ELSE AA.h := data
END;
A := AA
END InitHInt; *)
PROCEDURE InitReal* (VAR A: Array; dimension: SizeVector; data: RealPtr; copy: BOOLEAN);
VAR i, n:LONGINT;
AA:RealArray;
BEGIN
IF (A=NIL) OR ~(A IS RealArray) THEN NEW(AA) ELSE IF A IS RealArray THEN AA := A(RealArray) END END;
n := 1;
FOR i := 0 TO LEN(dimension^)-1 DO n := n*dimension[i] END;
IF data=NIL THEN NEW(data,n); copy := FALSE END;
ASSERT (LEN(data^)=n);
NEW(AA.dimension,LEN(dimension^));
FOR i := 0 TO LEN(dimension^)-1 DO AA.dimension[i] := dimension[i]; END;
AA.len := n;
IF copy
THEN NEW (AA.x,n); FOR i := 0 TO n-1 DO AA.x[i] := data[i] END;
ELSE AA.x := data
END;
A := AA
END InitReal;
PROCEDURE InitLReal* (VAR A: Array; dimension: SizeVector; data: LRealPtr; copy: BOOLEAN);
VAR i, n: LONGINT;
AA: LRealArray;
BEGIN
IF (A=NIL) OR ~(A IS LRealArray) THEN NEW(AA) ELSE IF A IS LRealArray THEN AA := A(LRealArray) END END;
n := 1;
FOR i := 0 TO LEN(dimension^)-1 DO n := n*dimension[i] END;
IF data=NIL THEN NEW(data,n); copy := FALSE END;
ASSERT (LEN(data^)=n);
NEW(AA.dimension,LEN(dimension^));
FOR i := 0 TO LEN(dimension^)-1 DO AA.dimension[i] := dimension[i]; END;
AA.len := n;
IF copy
THEN NEW (AA.y,n); FOR i := 0 TO n-1 DO AA.y[i] := data[i] END;
ELSE AA.y := data
END;
A := AA
END InitLReal;
PROCEDURE InitBool* (VAR A: Array; dimension: SizeVector; data: BoolPtr; copy: BOOLEAN);
VAR i, n: LONGINT;
AA: BoolArray;
BEGIN
IF (A=NIL) OR ~(A IS BoolArray) THEN NEW(AA) ELSE IF A IS BoolArray THEN AA := A(BoolArray) END END;
n := 1;
FOR i := 0 TO LEN(dimension^)-1 DO n := n*dimension[i] END;
IF data=NIL THEN NEW(data,n); copy := FALSE END;
ASSERT (LEN(data^)=n);
NEW(AA.dimension,LEN(dimension^));
FOR i := 0 TO LEN(dimension^)-1 DO AA.dimension[i] := dimension[i]; END;
AA.len := n;
IF copy
THEN NEW (AA.b,n); FOR i := 0 TO n-1 DO AA.b[i] := data[i] END
ELSE AA.b := data
END;
A := AA
END InitBool;
PROCEDURE InitComplex* (VAR A:Array; dimension: SizeVector;
dataR,dataI: RealPtr; copy:BOOLEAN);
VAR i, n: LONGINT;
AA: ComplexArray;
BEGIN
IF (A=NIL) OR ~(A IS ComplexArray) THEN NEW(AA) ELSE IF A IS ComplexArray THEN AA := A(ComplexArray) END END;
n := 1;
FOR i := 0 TO LEN(dimension^)-1 DO n := n*dimension[i] END;
ASSERT (LEN(dataR^)=n); ASSERT (LEN(dataI^)=n);
NEW(AA.dimension,LEN(dimension^));
FOR i := 0 TO LEN(dimension^)-1 DO AA.dimension[i] := dimension[i]; END;
AA.len := n;
IF copy
THEN NEW (AA.r,n); NEW (AA.i,n);
FOR i := 0 TO n-1 DO AA.r[i] := dataR[i]; AA.i[i] := dataI[i] END
ELSE AA.r := dataR; AA.i := dataI
END;
A := AA
END InitComplex;
PROCEDURE Copy* (From,To:Array);
BEGIN
WITH
From: SIntArray DO InitSInt(To,From.dimension,From.s,TRUE) ;
| From: IntArray DO InitInt(To,From.dimension,From.i,TRUE);
| From: LIntArray DO InitLInt(To,From.dimension,From.j,TRUE);
(* | From: HIntArray DO HALT(100) *)
| From: RealArray DO InitReal(To,From.dimension,From.x,TRUE);
| From: LRealArray DO InitLReal(To,From.dimension,From.y,TRUE);
| From: BoolArray DO InitBool(To,From.dimension,From.b,TRUE);
| From: ComplexArray DO InitComplex(To,From.dimension,From.r,From.i,TRUE);
ELSE HALT(100)
END
END Copy;
(* PROCEDURE CopySubArray* (A1,A2:Array; start,dimension:ARRAY OF LONGINT);
(** Copies subrange of Array A1, beginning at 'start' with 'dimension' to (usually smaller) array A2 *)
BEGIN
WITH A1: ...
ELSE HALT(100)
END
END CopySubarray; *)
PROCEDURE GetSInt* (A: Array; position: SizeVector): SHORTINT;
BEGIN
IF A IS SIntArray THEN RETURN A(SIntArray).s[Index(position^,A.dimension^)]
ELSE HALT (100) END
END GetSInt;
PROCEDURE GetInt* (A: Array; position: SizeVector): INTEGER;
BEGIN
IF A IS IntArray THEN RETURN A(IntArray).i[Index(position^,A.dimension^)]
ELSE HALT (100) END
END GetInt;
PROCEDURE GetLInt* (A: Array; position: SizeVector): LONGINT;
BEGIN
IF A IS LIntArray THEN RETURN A(LIntArray).j[Index(position^,A.dimension^)]
ELSE HALT (100) END
END GetLInt;
(*PROCEDURE GetHInt* (A: Array; position: SizeVector): HUGEINT;
BEGIN
IF A IS HIntArray THEN RETURN A(HIntArray).h[Index(position^,A.dimension^)]
ELSE HALT (100) END
END GetHInt; *)
PROCEDURE GetReal* (A: Array; position: SizeVector): REAL;
BEGIN
IF A IS RealArray THEN RETURN A(RealArray).x[Index(position^,A.dimension^)]
ELSE HALT (100) END
END GetReal;
PROCEDURE GetLReal* (A: Array; position: SizeVector): LONGREAL;
BEGIN
IF A IS LRealArray THEN RETURN A(LRealArray).y[Index(position^,A.dimension^)]
ELSE HALT (100) END
END GetLReal;
PROCEDURE GetBool* (A: Array; position: SizeVector): BOOLEAN;
BEGIN
IF A IS BoolArray THEN RETURN A(BoolArray).b[Index(position^,A.dimension^)]
ELSE HALT (100) END
END GetBool;
PROCEDURE GetComplex* (A: Array; position: SizeVector): Complex;
VAR res: Complex;
BEGIN
IF A IS ComplexArray
THEN
NEW(res);
res.r := A(ComplexArray).r[Index(position^,A.dimension^)];
res.i := A(ComplexArray).i[Index(position^,A.dimension^)];
RETURN res
ELSE HALT (100)
END
END GetComplex;
(* PROCEDURE Store* (R: Files.Rider; A: Array);
(* S3 specific ->eliminate from this module, into utility module *)
(** not yet implemented *)
BEGIN
(**)
END Store;
PROCEDURE Load* (R: Files.Rider; VAR A: Array);
(* S3 specific ->eliminate from this module, into utility module *)
(** not yet implemented *)
BEGIN
(**)
END Load;
*)
PROCEDURE AllSInt1* (A: Array; f: PROCEDURE(s:SHORTINT): SHORTINT);
VAR n: LONGINT;
BEGIN
WITH A: SIntArray DO FOR n := 0 TO A.len-1 DO A.s[n] := f(A.s[n]) END
ELSE HALT(100)
END
END AllSInt1;
PROCEDURE AllSInt2* (A,B: Array; f: PROCEDURE(s1,s2:SHORTINT): SHORTINT);
VAR n: LONGINT;
BEGIN
WITH A: SIntArray DO
WITH B: SIntArray DO
FOR n := 0 TO A.len-1 DO A.s[n] := f(A.s[n],B.s[n]) END
ELSE HALT(100)
END
ELSE HALT(100)
END;
END AllSInt2;
PROCEDURE AllInt1* (A: Array; f: PROCEDURE(i:INTEGER): INTEGER);
VAR n: LONGINT;
BEGIN
WITH A: IntArray DO FOR n := 0 TO A.len-1 DO A.i[n] := f(A.i[n]) END
ELSE HALT(100)
END
END AllInt1;
PROCEDURE AllInt2* (A,B: Array; f: PROCEDURE(i1,i2:INTEGER): INTEGER);
VAR n: LONGINT;
BEGIN
WITH A: IntArray DO
WITH B: IntArray DO
FOR n := 0 TO A.len-1 DO A.i[n] := f(A.i[n],B.i[n]) END
ELSE HALT(100)
END;
ELSE HALT(100)
END
END AllInt2;
PROCEDURE AllLInt1* (A: Array; f: PROCEDURE(j:LONGINT): LONGINT);
VAR n: LONGINT;
BEGIN
WITH A: LIntArray DO FOR n := 0 TO A.len-1 DO A.j[n] := f(A.j[n]) END
ELSE HALT(100)
END
END AllLInt1;
PROCEDURE AllLInt2* (A,B: Array; f: PROCEDURE(j1,j2:LONGINT): LONGINT);
VAR n: LONGINT;
BEGIN
WITH A: LIntArray DO
WITH B: LIntArray DO
FOR n := 0 TO A.len-1 DO A.j[n] := f(A.j[n],B.j[n]) END
ELSE HALT(100)
END;
ELSE HALT(100)
END;
END AllLInt2;
PROCEDURE AllReal1* (A: Array; f: PROCEDURE(x:REAL): REAL);
VAR n: LONGINT;
BEGIN
WITH A: RealArray DO FOR n := 0 TO A.len-1 DO A.x[n] := f(A.x[n]) END
ELSE HALT(100)
END
END AllReal1;
PROCEDURE AllReal2* (A,B: Array; f: PROCEDURE(x1,x2:REAL): REAL);
VAR n: LONGINT;
BEGIN
WITH A: RealArray DO
WITH B: RealArray DO
FOR n := 0 TO A.len-1 DO A.x[n] := f(A.x[n],B.x[n]) END
ELSE HALT(100)
END;
ELSE HALT(100)
END
END AllReal2;
PROCEDURE AllLReal1* (A: Array; f: PROCEDURE(y:LONGREAL): LONGREAL);
VAR n: LONGINT;
BEGIN
WITH A: LRealArray DO FOR n := 0 TO A.len-1 DO A.y[n] := f(A.y[n]) END
ELSE HALT(100)
END
END AllLReal1;
PROCEDURE AllLReal2* (A,B: Array; f: PROCEDURE(y1,y2:LONGREAL): LONGREAL);
VAR n: LONGINT;
BEGIN
WITH A: LRealArray DO
WITH B: LRealArray DO
FOR n := 0 TO A.len-1 DO A.y[n] := f(A.y[n],B.y[n]) END
ELSE HALT(100)
END
ELSE HALT(100)
END
END AllLReal2;
PROCEDURE InvertSign (s: SHORTINT): SHORTINT; (* Test procedure for unary operations *)
BEGIN
RETURN -s
END InvertSign;
PROCEDURE Add (s1,s2: SHORTINT): SHORTINT; (* Test procedure for unary operations *)
BEGIN
RETURN s1+s2
END Add;
PROCEDURE Test*;
(** Compares "Allxxx" procedure with conventional indexing scheme *)
VAR A1: Array;
A2: POINTER TO ARRAY OF ARRAY OF ARRAY OF ARRAY OF SHORTINT;
data: SIntPtr;
dim1: SizeVector;
i, starttime, endtime, a, b, c, d: LONGINT;
BEGIN
(* ALL ELEMENT OPERATIONS *)
Out.String("----------------------------------"); Out.Ln;
NEW(A1);
SizeVector4(dim1, 64, 32, 32, 32);
NEW(data, dim1[0]*dim1[1]*dim1[2]*dim1[3]);
InitSInt(A1, dim1, data, FALSE);
starttime := Input.Time();
WITH A1: SIntArray DO
FOR i := 0 TO A1.len-1 DO A1.s[i] := InvertSign(A1.s[i]); END (* linear array access *)
END;
endtime := Input.Time();
Out.String("ALL ELEMENT MONADIC OPERATION:"); Out.Ln;
Out.String("arbitrary array, linear access, invert sign:"); Out.String(" time: ");
Out.Int(endtime-starttime, 5); Out.String("ms for "); Out.Int(A1.len, 10);
Out.String(" elements"); Out.Ln;
starttime := Input.Time();
AllSInt1(A1, InvertSign); (* monadic proc. using "All" procedure *)
endtime := Input.Time();
Out.String("arbitrary array 'ALL procedure', invert sign:"); Out.String(" time: ");
Out.Int(endtime-starttime, 5); Out.String("ms for "); Out.Int(A1.len, 10);
Out.String(" elements"); Out.Ln;
NEW(A2, 64, 32, 32, 32);
starttime := Input.Time();
FOR a := 0 TO LEN(A2^, 0)-1 DO (* monadic proc. using conventional indices *)
FOR b := 0 TO LEN(A2^, 1)-1 DO
FOR c := 0 TO LEN(A2^, 2)-1 DO
FOR d := 0 TO LEN(A2^, 3)-1 DO
A2[a, b, c, d] := InvertSign(A2[a, b, c, d])
END
END
END
END;
endtime := Input.Time();
Out.String("conventional indexed array invert sign:"); Out.String(" time: ");
Out.Int(endtime-starttime, 5); Out.String("ms for "); Out.Int(A1.len, 10);
Out.String(" elements"); Out.Ln;
Out.String("**********************************"); Out.Ln;
starttime := Input.Time();
AllSInt2(A1, A1, Add); (* dyadic proc. using "All" procedure *)
endtime := Input.Time();
Out.String("ALL ELEMENT DYADIC OPERATION:"); Out.Ln;
Out.String("arbitrary array ,'ALL procedure, addition:"); Out.String(" time: ");
Out.Int(endtime-starttime, 5); Out.String("ms for "); Out.Int(A1.len, 10);
Out.String(" elements"); Out.Ln;
starttime := Input.Time();
FOR a := 0 TO LEN(A2^, 0)-1 DO (* dyadic proc. using conventional approach *)
FOR b := 0 TO LEN(A2^, 1)-1 DO
FOR c := 0 TO LEN(A2^, 2)-1 DO
FOR d := 0 TO LEN(A2^, 3)-1 DO
A2[a, b, c, d] := Add(A2[a, b, c, d], A2[a, b, c, d])
END
END
END
END;
endtime := Input.Time();
Out.String("conventional indexed array, addition:"); Out.String(" time: ");
Out.Int(endtime-starttime, 5); Out.String("ms for "); Out.Int(A1.len, 10);
Out.String(" elements"); Out.Ln;
Out.String("**********************************"); Out.Ln
END Test;
(*PROCEDURE Test2*; (* insufficient registers with Intel *)
VAR A, B: ARRAY 2, 2, 2, 2, 2, 2 OF INTEGER;
i, j, k, l, m, n, o, p, q, r: INTEGER;
BEGIN
Out.String('Test2: ... ');
FOR i := 0 TO 1 DO
FOR j := 0 TO 1 DO
FOR k := 0 TO 1 DO
FOR l := 0 TO 1 DO
FOR m := 0 TO 1 DO
FOR n := 0 TO 1 DO
A[i, j, k, l, m, n] := B[i, j, k, l, m, n]+1
END
END
END
END
END
END
Out.String('done'); Out.Ln
END Test2; *)
(*PROCEDURE Test3*; (* insufficient registers with Intel *)
VAR A, B: ARRAY 2,2,2,2,2,2,2,2,2,2 OF INTEGER;
i, j, k, l, m, n, o, p, q, r: INTEGER;
BEGIN
Out.String('Test3: ... ');
FOR i := 0 TO 1 DO
FOR j := 0 TO 1 DO
FOR k := 0 TO 1 DO
FOR l := 0 TO 1 DO
FOR m := 0 TO 1 DO
FOR n := 0 TO 1 DO
FOR o := 0 TO 1 DO
FOR p := 0 TO 1 DO
FOR q := 0 TO 1 DO
FOR r := 0 TO 1 DO
A[i, j, k, l, m, n, o, p, q, r] := B[i, j, k, l, m, n, o, p, q, r]+1
END
END
END
END
END
END
END
END
END
END
Out.String('done'); Out.Ln
END Test3; *)
BEGIN
END MultiArrays.
MultiArrays.Test
MultiArrays.Test2
MultiArrays.Test3
Compiler.Compile \xc MultiArrays.Mod ~
System.Free MultiArrays~

187
src/library/misc/crt.Mod Normal file
View file

@ -0,0 +1,187 @@
MODULE crt;
IMPORT vt100, Unix, Console,
Strings; (* strings to remove later ? *)
CONST
(* Foreground and background color constants *)
Black* = 0;
Blue* = 1;
Green* = 2;
Cyan* = 3;
Red* = 4;
Magenta* = 5;
Brown* = 6;
LightGray* = 7;
(* Foreground color constants *)
DarkGray* = 8;
LightBlue* = 9;
LightGreen* = 10;
LightCyan* = 11;
LightRed* = 12;
LightMagenta* = 13;
Yellow* = 14;
White* = 15;
(* Add-in for blinking *)
Blink* = 128;
TYPE
PFdSet = POINTER TO Unix.FdSet;
VAR tmpstr : ARRAY 23 OF CHAR;
PROCEDURE EraseDisplay*;
BEGIN
vt100.ED(2);
END EraseDisplay;
PROCEDURE ClrScr*;
BEGIN
vt100.ED(2);
END ClrScr;
PROCEDURE ClrEol*;
BEGIN
vt100.EL(0);
END ClrEol;
PROCEDURE cursoroff*;
BEGIN
vt100.DECTCEMl;
END cursoroff;
PROCEDURE cursoron*;
BEGIN
vt100.DECTCEMh;
END cursoron;
PROCEDURE Delay*( ms : INTEGER);
VAR i : LONGINT;
tv : Unix.Timeval;
pfd : PFdSet;
BEGIN
tv.sec := 0;
tv.usec := ms * 1000;
pfd := NIL;
i := Unix.Select(0, pfd^, pfd^, pfd^, tv);
END Delay;
PROCEDURE GotoXY* (x, y: INTEGER);
BEGIN
vt100.CUP (y, x);
END GotoXY;
PROCEDURE HighVideo*;
VAR tmpstr: ARRAY 5 OF CHAR;
BEGIN
COPY (vt100.CSI, tmpstr);
Strings.Append(vt100.Bold, tmpstr);
Console.String(tmpstr);
END HighVideo;
PROCEDURE DelLine*;
BEGIN
vt100.EL(2);
END DelLine;
PROCEDURE InsLine*;
BEGIN
vt100.SCP;
Console.Ln;
vt100.RCP;
END InsLine;
PROCEDURE LowVideo*;
VAR tmpstr : ARRAY 7 OF CHAR;
BEGIN
COPY (vt100.CSI, tmpstr);
Strings.Append(vt100.ResetBold, tmpstr);
Console.String(tmpstr);
END LowVideo;
PROCEDURE NormVideo*;
VAR tmpstr : ARRAY 7 OF CHAR;
BEGIN
COPY(vt100.CSI, tmpstr);
Strings.Append(vt100.ResetAll, tmpstr);
Console.String(tmpstr);
END NormVideo;
PROCEDURE TextBackground*(color : SHORTINT);
BEGIN
IF color = Black THEN
vt100.SetAttr(vt100.BBlack)
ELSIF color = Blue THEN
vt100.SetAttr(vt100.BBlue)
ELSIF color = Green THEN
vt100.SetAttr(vt100.BGreen)
ELSIF color = Cyan THEN
vt100.SetAttr(vt100.BCyan)
ELSIF color = Red THEN
vt100.SetAttr(vt100.BRed)
ELSIF color = Magenta THEN
vt100.SetAttr(vt100.BMagenta)
ELSIF color = Brown THEN
vt100.SetAttr(vt100.BYellow)
ELSIF color = LightGray THEN
vt100.SetAttr(vt100.BLightGray)
ELSIF color = DarkGray THEN
vt100.SetAttr(vt100.BDarkGray)
ELSIF color = LightBlue THEN
vt100.SetAttr(vt100.BLightBlue)
ELSIF color = LightGreen THEN
vt100.SetAttr(vt100.BLightBlue)
ELSIF color = LightCyan THEN
vt100.SetAttr(vt100.BLightCyan)
ELSIF color = LightRed THEN
vt100.SetAttr(vt100.BLightRed)
ELSIF color = LightMagenta THEN
vt100.SetAttr(vt100.BLightMagenta)
ELSIF color = Yellow THEN
vt100.SetAttr(vt100.BLightYellow)
ELSIF color = White THEN
vt100.SetAttr(vt100.BWhite)
END;
END TextBackground;
PROCEDURE TextColor*(color : SHORTINT);
BEGIN
IF color = Black THEN
vt100.SetAttr(vt100.Black)
ELSIF color = Blue THEN
vt100.SetAttr(vt100.Blue)
ELSIF color = Green THEN
vt100.SetAttr(vt100.Green)
ELSIF color = Cyan THEN
vt100.SetAttr(vt100.Cyan)
ELSIF color = Red THEN
vt100.SetAttr(vt100.Red)
ELSIF color = Magenta THEN
vt100.SetAttr(vt100.Magenta)
ELSIF color = Brown THEN
vt100.SetAttr(vt100.Yellow)
ELSIF color = LightGray THEN
vt100.SetAttr(vt100.LightGray)
ELSIF color = DarkGray THEN
vt100.SetAttr(vt100.DarkGray)
ELSIF color = LightBlue THEN
vt100.SetAttr(vt100.LightBlue)
ELSIF color = LightGreen THEN
vt100.SetAttr(vt100.LightBlue)
ELSIF color = LightCyan THEN
vt100.SetAttr(vt100.LightCyan)
ELSIF color = LightRed THEN
vt100.SetAttr(vt100.LightRed)
ELSIF color = LightMagenta THEN
vt100.SetAttr(vt100.LightMagenta)
ELSIF color = Yellow THEN
vt100.SetAttr(vt100.LightYellow)
ELSIF color = White THEN
vt100.SetAttr(vt100.White)
END;
END TextColor;
END crt.

342
src/library/misc/vt100.Mod Normal file
View file

@ -0,0 +1,342 @@
MODULE vt100;
IMPORT Console, Strings;
(* reference http://en.wikipedia.org/wiki/ANSI_escape_code
& http://misc.flogisoft.com/bash/tip_colors_and_formatting
*)
CONST
Escape* = 1BX;
SynchronousIdle* = 16X;
LeftCrotchet* = '[';
(* formatting *)
Bold* = "1m";
Dim* = "2m";
Underlined* = "4m";
Blink* = "5m"; (* does not work with most emulators, works in tty and xterm *)
Reverse* = "7m"; (* invert the foreground and background colors *)
Hidden* = "8m"; (* useful for passwords *)
(* reset *)
ResetAll* = "0m";
ResetBold* = "21m";
ResetDim* = "22m";
ResetUnderlined* = "24m";
ResetBlink* = "25m";
ResetReverse* = "27m";
ResetHidden* = "28m";
(* foreground colors *)
Black* = "30m";
Red* = "31m";
Green* = "32m";
Yellow* = "33m";
Blue* = "34m";
Magenta* = "35m";
Cyan* = "36m";
LightGray* = "37m";
Default* = "39m";
DarkGray* = "90m";
LightRed* = "91m";
LightGreen* = "92m";
LightYellow* = "93m";
LightBlue* = "94m";
LightMagenta* = "95m";
LightCyan* = "96m";
White* = "97m";
(* background colors *)
BBlack* = "40m";
BRed* = "41m";
BGreen* = "42m";
BYellow* = "43m";
BBlue* = "44m";
BMagenta* = "45m";
BCyan* = "46m";
BLightGray* = "47m";
BDefault* = "49m";
BDarkGray* = "100m";
BLightRed* = "101m";
BLightGreen* = "102m";
BLightYellow* = "103m";
BLightBlue* = "104m";
BLightMagenta*= "105m";
BLightCyan* = "106m";
BWhite* = "107m";
VAR
CSI* : ARRAY 5 OF CHAR;
tmpstr : ARRAY 32 OF CHAR;
(* IntToStr routine taken from
https://github.com/romiras/Oberon-F-components/blob/master/Ott/Mod/IntStr.cp
and modified to work on 64bit system,
in order to avoid using oocIntStr, which has many dependencies *)
PROCEDURE Reverse0 (VAR str : ARRAY OF CHAR; start, end : INTEGER);
(* Reverses order of characters in the interval [start..end]. *)
VAR
h : CHAR;
BEGIN
WHILE start < end DO
h := str[start]; str[start] := str[end]; str[end] := h;
INC(start); DEC(end)
END
END Reverse0;
PROCEDURE IntToStr*(int: LONGINT; VAR str: ARRAY OF CHAR);
(* Converts the value of `int' to string form and copies the possibly truncated
result to `str'. *)
VAR
b : ARRAY 21 OF CHAR;
s, e: INTEGER;
maxLength : SHORTINT; (* maximum number of digits representing a LONGINT value *)
BEGIN
IF SIZE(LONGINT) = 4 THEN maxLength := 11 END;
IF SIZE(LONGINT) = 8 THEN maxLength := 20 END;
(* build representation in string 'b' *)
IF int = MIN(LONGINT) THEN (* smallest LONGINT, -int is an overflow *)
IF SIZE(LONGINT) = 4 THEN
b := "-2147483648";
e := 11
ELSE (* SIZE(LONGINT) = 8 *)
b := "-9223372036854775808";
e := 20
END
ELSE
IF int < 0 THEN (* negative sign *)
b[0] := "-"; int := -int; s := 1
ELSE (* no sign *)
s := 0
END;
e := s; (* 's' holds starting position of string *)
REPEAT
b[e] := CHR(int MOD 10+ORD("0"));
int := int DIV 10;
INC(e)
UNTIL int = 0;
b[e] := 0X;
Reverse0(b, s, e-1);
END;
COPY(b, str) (* truncate output if necessary *)
END IntToStr;
PROCEDURE EscSeq0 (letter : ARRAY OF CHAR);
VAR
cmd : ARRAY 9 OF CHAR;
BEGIN
COPY(CSI, cmd);
Strings.Append (letter, cmd);
Console.String (cmd);
END EscSeq0;
PROCEDURE EscSeq (n : INTEGER; letter : ARRAY OF CHAR);
VAR nstr : ARRAY 2 OF CHAR;
cmd : ARRAY 7 OF CHAR;
BEGIN
IntToStr (n, nstr);
COPY(CSI, cmd);
Strings.Append (nstr, cmd);
Strings.Append (letter, cmd);
Console.String (cmd);
END EscSeq;
PROCEDURE EscSeqSwapped (n : INTEGER; letter : ARRAY OF CHAR);
VAR nstr : ARRAY 2 OF CHAR;
cmd : ARRAY 7 OF CHAR;
BEGIN
IntToStr (n, nstr);
COPY(CSI, cmd);
Strings.Append (letter, cmd);
Strings.Append (nstr, cmd);
Console.String (cmd);
END EscSeqSwapped;
PROCEDURE EscSeq2(n, m : INTEGER; letter : ARRAY OF CHAR);
VAR nstr, mstr : ARRAY 5 OF CHAR;
cmd : ARRAY 12 OF CHAR;
BEGIN
IntToStr(n, nstr);
IntToStr(m, mstr);
COPY (CSI, cmd);
Strings.Append (nstr, cmd);
Strings.Append (';', cmd);
Strings.Append (mstr, cmd);
Strings.Append (letter, cmd);
Console.String (cmd);
END EscSeq2;
(* Cursor up
moves cursor n cells in the given direction. if the cursor is already at the edge of the screen, this has no effect *)
PROCEDURE CUU*(n : INTEGER);
BEGIN
EscSeq (n, 'A');
END CUU;
(* Cursor down
moves cursor n cells in the given direction. if the cursor is already at the edge of the screen, this has no effect *)
PROCEDURE CUD*(n : INTEGER);
BEGIN
EscSeq (n, 'B');
END CUD;
(* Cursor forward
moves cursor n cells in the given direction. if the cursor is already at the edge of the screen, this has no effect *)
PROCEDURE CUF*(n : INTEGER);
BEGIN
EscSeq (n, 'C');
END CUF;
(* Cursor back
moves cursor n cells in the given direction. if the cursor is already at the edge of the screen, this has no effect *)
PROCEDURE CUB*(n : INTEGER);
BEGIN
EscSeq (n, 'D');
END CUB;
(* Curnser Next Line
moves cursor to beginning of the line n lines down *)
PROCEDURE CNL*( n: INTEGER);
BEGIN
EscSeq (n, 'E');
END CNL;
(* Cursor Previous Line
Moves cursor to beginning of the line n lines down *)
PROCEDURE CPL*( n : INTEGER);
BEGIN
EscSeq (n, 'F');
END CPL;
(* Cursor Horizontal Absolute
Moves the cursor to column n *)
PROCEDURE CHA*( n : INTEGER);
BEGIN
EscSeq (n, 'G');
END CHA;
(* Cursor position, moves cursor to row n, column m *)
PROCEDURE CUP*(n, m : INTEGER);
BEGIN
EscSeq2 (n, m, 'H');
END CUP;
(* Erase Display
if n = 0 then clears from cursor to end of the screen
if n = 1 then clears from cursor to beginning of the screen
if n = 2 then clears entire screen *)
PROCEDURE ED* (n : INTEGER);
BEGIN
EscSeq(n, 'J');
END ED;
(* Erase in Line
Erases part of the line. If n is zero, clear from cursor to the end of the line. If n is one, clear from cursor to beginning of the line. If n is two, clear entire line. Cursor position does not change *)
PROCEDURE EL*( n : INTEGER);
BEGIN
EscSeq(n, 'K');
END EL;
(* Scroll Up
Scroll whole page up by n lines. New lines are added at the bottom *)
PROCEDURE SU*( n : INTEGER);
BEGIN
EscSeq(n, 'S')
END SU;
(* Scroll Down
Scroll whole page down by n (default 1) lines. New lines are added at the top *)
PROCEDURE SD*( n : INTEGER);
BEGIN
EscSeq(n, 'T');
END SD;
(* Horizontal and Vertical Position,
Moves the cursor to row n, column m. Both default to 1 if omitted. Same as CUP *)
PROCEDURE HVP*(n, m : INTEGER);
BEGIN
EscSeq2 (n, m, 'f');
END HVP;
(* Select Graphic Rendition
Sets SGR parameters, including text color. After CSI can be zero or more parameters separated with ;. With no parameters, CSI m is treated as CSI 0 m (reset / normal), which is typical of most of the ANSI escape sequences *)
PROCEDURE SGR*( n : INTEGER);
BEGIN
EscSeq(n, 'm');
END SGR;
PROCEDURE SGR2*( n, m : INTEGER);
BEGIN
EscSeq2(n, m, 'm');
END SGR2;
(* Device Status Report
Reports the cursor position (CPR) to the application as (as though typed at the keyboard) ESC[n;mR, where n is the row and m is the column.) *)
PROCEDURE DSR*(n : INTEGER);
BEGIN
EscSeq(6, 'n');
END DSR;
(* Save Cursor Position *)
PROCEDURE SCP*;
BEGIN
EscSeq0('s');
END SCP;
(* Restore Cursor Position *)
PROCEDURE RCP*;
BEGIN
EscSeq0('u');
END RCP;
(* Hide the cursor *)
PROCEDURE DECTCEMl*;
BEGIN
EscSeq0("?25l")
END DECTCEMl;
(* shows the cursor *)
PROCEDURE DECTCEMh*;
BEGIN
EscSeq0("?25h")
END DECTCEMh;
PROCEDURE SetAttr*(attr : ARRAY OF CHAR);
VAR tmpstr : ARRAY 16 OF CHAR;
BEGIN
COPY(CSI, tmpstr);
Strings.Append(attr, tmpstr);
Console.String(tmpstr);
END SetAttr;
BEGIN
(* init CSI sequence *)
COPY(Escape, CSI);
Strings.Append(LeftCrotchet, CSI);
(*
EraseDisplay;
GotoXY (0, 0);
COPY(CSI, tmpstr);
Strings.Append(Green, tmpstr);
Strings.Append("hello", tmpstr);
Console.String(tmpstr); Console.Ln;
*)
END vt100.

20
src/library/ooc/oocAscii.Mod Normal file
View file

@ -0,0 +1,20 @@
(* $Id: Ascii.Mod,v 1.1 1997/02/07 07:45:32 oberon1 Exp $ *)
MODULE oocAscii; (* Standard short character names for control chars. *)
CONST
nul* = 00X; soh* = 01X; stx* = 02X; etx* = 03X;
eot* = 04X; enq* = 05X; ack* = 06X; bel* = 07X;
bs * = 08X; ht * = 09X; lf * = 0AX; vt * = 0BX;
ff * = 0CX; cr * = 0DX; so * = 0EX; si * = 0FX;
dle* = 01X; dc1* = 11X; dc2* = 12X; dc3* = 13X;
dc4* = 14X; nak* = 15X; syn* = 16X; etb* = 17X;
can* = 18X; em * = 19X; sub* = 1AX; esc* = 1BX;
fs * = 1CX; gs * = 1DX; rs * = 1EX; us * = 1FX;
del* = 7FX;
CONST (* often used synonyms *)
sp * = " ";
xon* = dc1;
xoff* = dc3;
END oocAscii.

529
src/library/ooc/oocBinaryRider.Mod Normal file
View file

@ -0,0 +1,529 @@
(* $Id: BinaryRider.Mod,v 1.10 1999/10/31 13:49:45 ooc-devel Exp $ *)
MODULE oocBinaryRider (*[OOC_EXTENSIONS]*);
(*
BinaryRider - Binary-level input/output of Oberon variables.
Copyright (C) 1998, 1999 Michael van Acken
Copyright (C) 1997 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
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
Strings := oocStrings, Channel := oocChannel, SYSTEM, Msg := oocMsg;
CONST
(* result codes *)
done* = Channel.done;
invalidFormat* = Channel.invalidFormat;
readAfterEnd* = Channel.readAfterEnd;
(* possible endian settings *)
nativeEndian* = 0; (* do whatever the host machine uses *)
littleEndian* = 1; (* read/write least significant byte first *)
bigEndian* = 2; (* read/write most significant byte first *)
TYPE
Reader* = POINTER TO ReaderDesc;
ReaderDesc* = RECORD
res*: Msg.Msg; (* READ-ONLY *)
byteOrder-: SHORTINT; (* endian settings for the reader *)
byteReader-: Channel.Reader; (* only to be used by extensions of Reader *)
base-: Channel.Channel;
END;
Writer* = POINTER TO WriterDesc;
WriterDesc* = RECORD
res*: Msg.Msg; (* READ-ONLY *)
byteOrder-: SHORTINT; (* endian settings for the writer *)
byteWriter-: Channel.Writer; (* only to be used by extensions of Writer *)
base-: Channel.Channel;
END;
VAR
systemByteOrder: SHORTINT; (* default CPU endian setting *)
TYPE
ErrorContext = POINTER TO ErrorContextDesc;
ErrorContextDesc* = RECORD
(* this record is exported, so that extensions of Channel can access the
error descriptions by extending `ErrorContextDesc' *)
(Channel.ErrorContextDesc)
END;
VAR
errorContext: ErrorContext;
PROCEDURE GetError (code: Msg.Code): Msg.Msg;
BEGIN
RETURN Msg.New (errorContext, code)
END GetError;
(* Reader methods
------------------------------------------------------------------------ *)
(* The following methods read a value of the given type from the current
position in the BinaryReader.
Iff the value is invalid for its type, 'r.res' is 'invalidFormat'
Iff there aren't enough bytes to satisfy the request, 'r.res' is
'readAfterEnd'.
*)
PROCEDURE (r: Reader) Pos* () : LONGINT;
BEGIN
RETURN r.byteReader.Pos()
END Pos;
PROCEDURE (r: Reader) SetPos* (newPos: LONGINT);
BEGIN
IF (r. res = done) THEN
r.byteReader.SetPos(newPos);
r.res := r.byteReader.res
END
END SetPos;
PROCEDURE (r: Reader) ClearError*;
BEGIN
r.byteReader.ClearError;
r.res := done
END ClearError;
PROCEDURE (r: Reader) Available * () : LONGINT;
BEGIN
RETURN r.byteReader.Available()
END Available;
PROCEDURE (r: Reader) ReadBytes * (VAR x: ARRAY OF SYSTEM.BYTE;
start, n: LONGINT);
(* Read the bytes according to the native machine byte order. *)
BEGIN
IF (r.res = done) THEN
r.byteReader.ReadBytes(x, start, n);
r.res := r.byteReader.res
END
END ReadBytes;
PROCEDURE (r: Reader) ReadBytesOrdered (VAR x: ARRAY OF SYSTEM.BYTE);
(* Read the bytes according to the Reader byte order setting. *)
VAR i: LONGINT;
BEGIN
IF (r.byteOrder=nativeEndian) OR (r.byteOrder=systemByteOrder) THEN
r.byteReader.ReadBytes(x, 0, LEN(x))
ELSE (* swap bytes of value *)
FOR i:=LEN(x)-1 TO 0 BY -1 DO r.byteReader.ReadByte(x[i]) END
END
END ReadBytesOrdered;
PROCEDURE (r: Reader) ReadBool*(VAR bool: BOOLEAN);
VAR byte: SHORTINT;
BEGIN
IF (r.res = done) THEN
r. byteReader. ReadByte (byte);
IF (r. byteReader. res = done) & (byte # 0) & (byte # 1) THEN
r. res := GetError (invalidFormat)
ELSE
r. res := r. byteReader. res
END;
bool := (byte # 0)
END
END ReadBool;
PROCEDURE (r: Reader) ReadChar* (VAR ch: CHAR);
BEGIN
IF (r.res = done) THEN
r. byteReader.ReadByte (ch);
r.res := r.byteReader.res
END
END ReadChar;
PROCEDURE (r: Reader) ReadLChar*(VAR ch: CHAR);
BEGIN
IF (r.res = done) THEN
r. ReadBytesOrdered (ch);
r.res := r.byteReader.res
END
END ReadLChar;
PROCEDURE (r: Reader) ReadString* (VAR s: ARRAY OF CHAR);
(* A string is filled until 0X is encountered, there are no more characters
in the channel or the string is filled. It is always terminated with 0X.
*)
VAR
cnt, len: INTEGER;
BEGIN
IF (r.res = done) THEN
len:=SHORT(LEN(s)-1); cnt:=-1;
REPEAT
INC(cnt); r.ReadChar(s[cnt])
UNTIL (s[cnt]=0X) OR (r.byteReader.res#done) OR (cnt=len);
IF (r. byteReader. res = done) & (s[cnt] # 0X) THEN
r.byteReader.res := GetError (invalidFormat);
s[cnt]:=0X
ELSE
r.res := r.byteReader.res
END
END
END ReadString;
PROCEDURE (r: Reader) ReadLString* (VAR s: ARRAY OF CHAR);
(* A string is filled until 0X is encountered, there are no more characters
in the channel or the string is filled. It is always terminated with 0X.
*)
VAR
cnt, len: INTEGER;
BEGIN
IF (r.res = done) THEN
len:=SHORT(LEN(s)-1); cnt:=-1;
REPEAT
INC(cnt); r.ReadLChar(s[cnt])
UNTIL (s[cnt]=0X) OR (r.byteReader.res#done) OR (cnt=len);
IF (r. byteReader. res = done) & (s[cnt] # 0X) THEN
r.byteReader.res := GetError (invalidFormat);
s[cnt]:=0X
ELSE
r.res := r.byteReader.res
END
END
END ReadLString;
PROCEDURE (r: Reader) ReadSInt*(VAR sint: SHORTINT);
BEGIN
IF (r.res = done) THEN
r.byteReader.ReadByte(sint); (* SIZE(SYSTEM.BYTE) = SIZE(SHORTINT) *) ;
r.res := r.byteReader.res
END
END ReadSInt;
PROCEDURE (r: Reader) ReadInt*(VAR int: INTEGER);
BEGIN
IF (r.res = done) THEN
r.ReadBytesOrdered(int);
r.res := r.byteReader.res
END
END ReadInt;
PROCEDURE (r: Reader) ReadLInt*(VAR lint: LONGINT);
(* see ReadInt *)
BEGIN
IF (r.res = done) THEN
r.ReadBytesOrdered(lint);
r.res := r.byteReader.res
END
END ReadLInt;
PROCEDURE (r: Reader) ReadNum*(VAR num: LONGINT);
(* Read integers in a compressed and portable format. *)
VAR s: SHORTINT; x: CHAR; y: LONGINT;
BEGIN
s:=0; y:=0; r.ReadChar(x);
WHILE (s < 28) & (x >= 80X) DO
INC(y, ASH(LONG(ORD(x))-128, s)); INC(s, 7);
r.ReadChar(x)
END;
(* Q: (s = 28) OR (x < 80X) *)
IF (x >= 80X) OR (* with s=28 this means we have more than 5 digits *)
(s = 28) & (8X <= x) & (x < 78X) & (* overflow in most sig byte *)
(r. byteReader. res = done) THEN
r. res := GetError (invalidFormat)
ELSE
num:=ASH(SYSTEM.LSH(LONG(ORD(x)), 25), s-25)+y;
r. res := r. byteReader. res
END
END ReadNum;
PROCEDURE (r: Reader) ReadReal*(VAR real: REAL);
(* see ReadInt *)
BEGIN
IF (r.res = done) THEN
r.ReadBytesOrdered(real);
r.res := r.byteReader.res
END
END ReadReal;
PROCEDURE (r: Reader) ReadLReal*(VAR lreal: LONGREAL);
(* see ReadInt *)
BEGIN
IF (r.res = done) THEN
r.ReadBytesOrdered(lreal);
r.res := r.byteReader.res
END
END ReadLReal;
PROCEDURE (r: Reader) ReadSet*(VAR s: SET);
BEGIN
IF (r.res = done) THEN
r.ReadBytesOrdered(s);
r.res := r.byteReader.res
END
END ReadSet;
PROCEDURE (r: Reader) SetByteOrder* (order: SHORTINT);
BEGIN
ASSERT((order>=nativeEndian) & (order<=bigEndian));
r.byteOrder:=order
END SetByteOrder;
(* Writer methods
------------------------------------------------------------------------ *)
(* The Write-methods write the value to the underlying channel. It is
possible that only part of the value is written
*)
PROCEDURE (w: Writer) Pos* () : LONGINT;
BEGIN
RETURN w.byteWriter.Pos()
END Pos;
PROCEDURE (w: Writer) SetPos* (newPos: LONGINT);
BEGIN
IF (w.res = done) THEN
w.byteWriter.SetPos(newPos);
w.res := w.byteWriter.res
END
END SetPos;
PROCEDURE (w: Writer) ClearError*;
BEGIN
w.byteWriter.ClearError;
w.res := done
END ClearError;
PROCEDURE (w: Writer) WriteBytes * (VAR x: ARRAY OF SYSTEM.BYTE;
start, n: LONGINT);
(* Write the bytes according to the native machine byte order. *)
BEGIN
IF (w.res = done) THEN
w.byteWriter.WriteBytes(x, start, n);
w.res := w.byteWriter.res
END
END WriteBytes;
PROCEDURE (w: Writer) WriteBytesOrdered (VAR x: ARRAY OF SYSTEM.BYTE);
(* Write the bytes according to the Writer byte order setting. *)
VAR i: LONGINT;
BEGIN
IF (w.byteOrder=nativeEndian) OR (w.byteOrder=systemByteOrder) THEN
w.byteWriter.WriteBytes(x, 0, LEN(x))
ELSE
FOR i:=LEN(x)-1 TO 0 BY -1 DO w.byteWriter.WriteByte(x[i]) END
END
END WriteBytesOrdered;
PROCEDURE (w: Writer) WriteBool*(bool: BOOLEAN);
BEGIN
IF (w.res = done) THEN
IF bool THEN
w. byteWriter. WriteByte (1)
ELSE
w. byteWriter. WriteByte (0)
END;
w. res := w. byteWriter. res
END
END WriteBool;
PROCEDURE (w: Writer) WriteChar*(ch: CHAR);
BEGIN
IF (w.res = done) THEN
w. byteWriter. WriteByte(ch);
w.res := w.byteWriter.res
END
END WriteChar;
PROCEDURE (w: Writer) WriteLChar*(ch: CHAR);
BEGIN
IF (w.res = done) THEN
w. WriteBytesOrdered (ch);
w.res := w.byteWriter.res
END
END WriteLChar;
PROCEDURE (w: Writer) WriteString*(s(*[NO_COPY]*): ARRAY OF CHAR);
(* The terminating 0X is also written *)
BEGIN
IF (w.res = done) THEN
w.byteWriter.WriteBytes (s, 0, Strings.Length (s)+1);
w.res := w.byteWriter.res
END
END WriteString;
PROCEDURE (w: Writer) WriteLString*(s(*[NO_COPY]*): ARRAY OF CHAR);
(* The terminating 0X is also written *)
VAR
i: LONGINT;
BEGIN
IF (w.res = done) THEN
i := -1;
REPEAT
INC (i);
w. WriteLChar (s[i])
UNTIL (s[i] = 0X);
w.res := w.byteWriter.res
END
END WriteLString;
PROCEDURE (w: Writer) WriteSInt*(sint: SHORTINT);
BEGIN
IF (w.res = done) THEN
w.byteWriter.WriteByte(sint);
w.res := w.byteWriter.res
END
END WriteSInt;
PROCEDURE (w: Writer) WriteInt*(int: INTEGER);
BEGIN
IF (w.res = done) THEN
w.WriteBytesOrdered(int);
w.res := w.byteWriter.res
END
END WriteInt;
PROCEDURE (w: Writer) WriteLInt*(lint: LONGINT);
(* see WriteInt *)
BEGIN
IF (w.res = done) THEN
w.WriteBytesOrdered(lint);
w.res := w.byteWriter.res
END
END WriteLInt;
PROCEDURE (w: Writer) WriteNum*(lint: LONGINT);
(* Write integers in a compressed and portable format. *)
BEGIN
IF (w.res = done) THEN
WHILE (lint<-64) OR (lint>63) DO
w.WriteChar(CHR(lint MOD 128+128));
lint:=lint DIV 128
END;
w.WriteChar(CHR(lint MOD 128));
w.res := w.byteWriter.res
END
END WriteNum;
(* see WriteInt *)
PROCEDURE (w: Writer) WriteReal*(real: REAL);
BEGIN
IF (w.res = done) THEN
w.WriteBytesOrdered(real);
w.res := w.byteWriter.res
END
END WriteReal;
PROCEDURE (w: Writer) WriteLReal*(lreal: LONGREAL);
(* see WriteInt *)
BEGIN
IF (w.res = done) THEN
w.WriteBytesOrdered(lreal);
w.res := w.byteWriter.res
END
END WriteLReal;
PROCEDURE (w: Writer) WriteSet*(s: SET);
BEGIN
IF (w.res = done) THEN
w.WriteBytesOrdered(s);
w.res := w.byteWriter.res
END
END WriteSet;
PROCEDURE (w: Writer) SetByteOrder* (order: SHORTINT);
BEGIN
ASSERT((order>=nativeEndian) & (order<=bigEndian));
w.byteOrder:=order
END SetByteOrder;
(* Reader Procedures
------------------------------------------------------------------------ *)
(* Create a new Reader and attach it to the Channel ch. NIL is
returned when it is not possible to read from the channel.
The Reader is positioned at the beginning for positionable
channels and at the current position for non-positionable channels.
*)
PROCEDURE InitReader* (r: Reader; ch: Channel.Channel; byteOrder: SHORTINT);
BEGIN
r. res := done;
r. byteReader := ch. NewReader();
r. byteOrder := byteOrder;
r. base := ch;
END InitReader;
PROCEDURE ConnectReader*(ch: Channel.Channel): Reader;
VAR
r: Reader;
BEGIN
NEW (r);
InitReader (r, ch, littleEndian);
IF (r. byteReader = NIL) THEN
RETURN NIL
ELSE
RETURN r
END
END ConnectReader;
(* Writer Procedures
------------------------------------------------------------------------ *)
(* Create a new Writer and attach it to the Channel ch. NIL is
returned when it is not possible to write to the channel.
The Writer is positioned at the beginning for positionable
channels and at the current position for non-positionable channels.
*)
PROCEDURE InitWriter* (w: Writer; ch: Channel.Channel; byteOrder: SHORTINT);
BEGIN
w. res := done;
w. byteWriter := ch. NewWriter();
w. byteOrder := byteOrder;
w. base := ch;
END InitWriter;
PROCEDURE ConnectWriter*(ch: Channel.Channel): Writer;
VAR
w: Writer;
BEGIN
NEW (w);
InitWriter (w, ch, littleEndian);
IF (w. byteWriter = NIL) THEN
RETURN NIL
ELSE
RETURN w
END
END ConnectWriter;
PROCEDURE SetDefaultByteOrder(VAR x: ARRAY OF SYSTEM.BYTE);
BEGIN
IF SYSTEM.VAL(CHAR, x[0])=1X THEN
systemByteOrder:=littleEndian
ELSE
systemByteOrder:=bigEndian
END
END SetDefaultByteOrder;
PROCEDURE Init;
VAR i: INTEGER;
BEGIN
i:=1; SetDefaultByteOrder(i)
END Init;
BEGIN
NEW (errorContext);
Msg.InitContext (errorContext, "OOC:Core:BinaryRider");
Init
END oocBinaryRider.

72
src/library/ooc/oocCILP32.Mod Normal file
View file

@ -0,0 +1,72 @@
(* $Id: C.Mod,v 1.9 1999/10/03 11:46:01 ooc-devel Exp $ *)
MODULE oocC;
(* Basic data types for interfacing to C code.
Copyright (C) 1997-1998 Michael van Acken
This module is free software; you can redistribute it and/or
modify 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 OOC. If not, write to the Free Software Foundation,
59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
IMPORT
SYSTEM;
(*
These types are intended to be equivalent to their C counterparts.
They may vary depending on your system, but as long as you stick to a 32 Bit
Unix they should be fairly safe.
*)
TYPE
char* = CHAR;
signedchar* = SHORTINT; (* signed char *)
shortint* = INTEGER; (* short int *)
int* = LONGINT;
set* = SET; (* unsigned int, used as set *)
longint* = LONGINT; (* long int *)
(*longset* = SYSTEM.SET64; *) (* unsigned long, used as set *)
longset* = SET;
address* = LONGINT;
float* = REAL;
double* = LONGREAL;
enum1* = int;
enum2* = int;
enum4* = int;
(* if your C compiler uses short enumerations, you'll have to replace the
declarations above with
enum1* = SHORTINT;
enum2* = INTEGER;
enum4* = LONGINT;
*)
FILE* = address; (* this is acually a replacement for `FILE*', i.e., for a pointer type *)
sizet* = longint;
uidt* = int;
gidt* = int;
TYPE (* some commonly used C array types *)
charPtr1d* = POINTER TO ARRAY OF char;
charPtr2d* = POINTER TO ARRAY OF charPtr1d;
intPtr1d* = POINTER TO ARRAY OF int;
TYPE (* C string type, assignment compatible with character arrays and
string constants *)
string* = POINTER TO ARRAY OF char;
TYPE
Proc* = PROCEDURE;
END oocC.

71
src/library/ooc/oocCLLP64.Mod Normal file
View file

@ -0,0 +1,71 @@
(* $Id: C.Mod,v 1.9 1999/10/03 11:46:01 ooc-devel Exp $ *)
MODULE oocC;
(* Basic data types for interfacing to C code.
Copyright (C) 1997-1998 Michael van Acken
This module is free software; you can redistribute it and/or
modify 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 OOC. If not, write to the Free Software Foundation,
59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
IMPORT
SYSTEM;
(*
These types are intended to be equivalent to their C counterparts.
They may vary depending on your system, but as long as you stick to a 32 Bit
Unix they should be fairly safe.
*)
TYPE
char* = CHAR;
signedchar* = SHORTINT; (* signed char *)
shortint* = RECORD a,b : SYSTEM.BYTE END; (* 2 bytes on x64_64 *) (* short int *)
int* = INTEGER;
set* = INTEGER;(*SET;*) (* unsigned int, used as set *)
longint* = LONGINT; (* long int *)
longset* = SET; (*SYSTEM.SET64; *) (* unsigned long, used as set *)
address* = LONGINT; (*SYSTEM.ADDRESS;*)
float* = REAL;
double* = LONGREAL;
enum1* = int;
enum2* = int;
enum4* = int;
(* if your C compiler uses short enumerations, you'll have to replace the
declarations above with
enum1* = SHORTINT;
enum2* = INTEGER;
enum4* = LONGINT;
*)
FILE* = address; (* this is acually a replacement for `FILE*', i.e., for a pointer type *)
sizet* = longint;
uidt* = int;
gidt* = int;
TYPE (* some commonly used C array types *)
charPtr1d* = POINTER TO ARRAY OF char;
charPtr2d* = POINTER TO ARRAY OF charPtr1d;
intPtr1d* = POINTER TO ARRAY OF int;
TYPE (* C string type, assignment compatible with character arrays and
string constants *)
string* = POINTER (*[CSTRING]*) TO ARRAY OF char;
TYPE
Proc* = PROCEDURE;
END oocC.

71
src/library/ooc/oocCLP64.Mod Normal file
View file

@ -0,0 +1,71 @@
(* $Id: C.Mod,v 1.9 1999/10/03 11:46:01 ooc-devel Exp $ *)
MODULE oocC;
(* Basic data types for interfacing to C code.
Copyright (C) 1997-1998 Michael van Acken
This module is free software; you can redistribute it and/or
modify 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 OOC. If not, write to the Free Software Foundation,
59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
IMPORT
SYSTEM;
(*
These types are intended to be equivalent to their C counterparts.
They may vary depending on your system, but as long as you stick to a 32 Bit
Unix they should be fairly safe.
*)
TYPE
char* = CHAR;
signedchar* = SHORTINT; (* signed char *)
shortint* = RECORD a,b : SYSTEM.BYTE END; (* 2 bytes on x64_64 *) (* short int *)
int* = INTEGER;
set* = INTEGER;(*SET;*) (* unsigned int, used as set *)
longint* = LONGINT; (* long int *)
longset* = SET; (*SYSTEM.SET64; *) (* unsigned long, used as set *)
address* = LONGINT; (*SYSTEM.ADDRESS;*)
float* = REAL;
double* = LONGREAL;
enum1* = int;
enum2* = int;
enum4* = int;
(* if your C compiler uses short enumerations, you'll have to replace the
declarations above with
enum1* = SHORTINT;
enum2* = INTEGER;
enum4* = LONGINT;
*)
FILE* = address; (* this is acually a replacement for `FILE*', i.e., for a pointer type *)
sizet* = longint;
uidt* = int;
gidt* = int;
TYPE (* some commonly used C array types *)
charPtr1d* = POINTER TO ARRAY OF char;
charPtr2d* = POINTER TO ARRAY OF charPtr1d;
intPtr1d* = POINTER TO ARRAY OF int;
TYPE (* C string type, assignment compatible with character arrays and
string constants *)
string* = POINTER (*[CSTRING]*) TO ARRAY OF char;
TYPE
Proc* = PROCEDURE;
END oocC.

611
src/library/ooc/oocChannel.Mod Normal file
View file

@ -0,0 +1,611 @@
(* $Id: Channel.Mod,v 1.10 1999/10/31 13:35:12 ooc-devel Exp $ *)
MODULE oocChannel;
(* Provides abstract data types Channel, Reader, and Writer for stream I/O.
Copyright (C) 1997-1999 Michael van Acken
This module is free software; you can redistribute it and/or
modify 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 OOC. If not, write to the Free Software Foundation,
59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
(*
Note 0:
All types and procedures declared in this module have to be considered
abstract, i.e., they are never instanciated or called. The provided procedure
bodies are nothing but hints how a specific channel could start implementing
them.
Note 1:
A module implementing specific channels (e.g., files, or TCP streams) will
provide the procedures
PROCEDURE New* (...): Channel;
and (optionally)
PROCEDURE Old* (...): Channel.
For channels that correspond to a piece of data that can be both read
and changed, the first procedure will create a new channel for the
given data location, deleting all data previously contained in it.
The latter will open a channel to the existing data.
For channels representing a unidirectional byte stream (like output to
/ input from terminal, or a TCP stream), only a procedure New is
provided. It will create a connection with the designated location.
The formal parameters of these procedures will include some kind of
reference to the data being opened (e.g. a file name) and, optionally,
flags that modify the way the channel is opened (e.g. read-only,
write-only, etc). Their interface therefore depends on the channel
and is not part of this specification. The standard way to create new
channels is to call the type-bound procedures Locator.New and
Locator.Old (which in turn will call the above mentioned procedures).
Note 2:
A channel implementation should state how many channels can be open
simultaneously. It's common for the OS to support just so many open files or
so many open sockets at the same time. Since this value isn't a constant, it's
only required to give a statement on the number of open connections for the
best case, and which factors can lower this number.
Note 3:
A number of record fields in Channel, Reader, and Writer are exported
with write permissions. This is done to permit specializations of the
classes to change these fields. The user should consider them
read-only.
*)
IMPORT
SYSTEM, Strings := oocStrings, Time := oocTime, Msg := oocMsg;
TYPE
Result* = Msg.Msg;
CONST
noLength* = -1;
(* result value of Channel.Length if the queried channel has no fixed length
(e.g., if it models input from keybord, or output to terminal) *)
noPosition* = -2;
(* result value of Reader/Writer.Pos if the queried rider has no concept of
an indexed reading resp. writing position (e.g., if it models input from
keybord, or output to terminal) *)
(* Note: The below list of error codes only covers the most typical errors.
A specific channel implementation (like Files) will define its own list
own codes, containing aliases for the codes below (when appropriate) plus
error codes of its own. Every module will provide an error context (an
instance of Msg.Context) to translate any code into a human readable
message. *)
(* a `res' value of `done' means successful completion of the I/O
operation: *)
done* = NIL;
(* the following values may appear in the `res.code' field of `Channel',
`Reader', or `Writer': *)
(* indicates successful completion of last operation *)
invalidChannel* = 1;
(* the channel channel isn't valid, e.g. because it wasn't opened in the
first place or was corrupted somehow; for a rider this refers to the
channel in the `base' field *)
writeError* = 2;
(* a write error occured; usually this error happens with a writer, but for
buffered channels this may also occur during a `Flush' or a `Close' *)
noRoom* = 3;
(* set if a write operation failed because there isn't any space left on the
device, e.g. if the disk is full or you exeeded your quota; usually this
error happens with a writer, but for buffered channels this may also
occur during a `Flush' or a `Close' *)
(* symbolic values for `Reader.res.code' resp. `Writer.res.code': *)
outOfRange* = 4;
(* set if `SetPos' has been called with a negative argument or it has been
called on a rider that doesn't support positioning *)
readAfterEnd* = 5;
(* set if a call to `ReadByte' or `ReadBytes' tries to access a byte beyond
the end of the file (resp. channel); this means that there weren't enough
bytes left or the read operation started at (or after) the end *)
channelClosed* = 6;
(* set if the rider's channel has been closed, preventing any further read or
write operations; this means you called Channel.Close() (in which case you
made a programming error), or the process at the other end of the channel
closed the connection (examples for this are pipes, FIFOs, tcp streams) *)
readError* = 7;
(* unspecified read error *)
invalidFormat* = 8;
(* set by an interpreting Reader (e.g., TextRiders.Reader) if the byte stream
at the current reading position doesn't represent an object of the
requested type *)
(* symbolic values for `Channel.res.code': *)
noReadAccess* = 9;
(* set if NewReader was called to create a reader on a channel that doesn't
allow reading access *)
noWriteAccess* = 10;
(* set if NewWriter was called to create a reader on a channel that doesn't
allow reading access *)
closeError* = 11;
(* set if closing the channel failed for some reason *)
noModTime* = 12;
(* set if no modification time is available for the given channel *)
noTmpName* = 13;
(* creation of a temporary file failed because the system was unable to
assign an unique name to it; closing or registering an existing temporary
file beforehand might help *)
freeErrorCode* = 14;
(* specific channel implemenatations can start defining their own additional
error codes for Channel.res, Reader.res, and Writer.res here *)
TYPE
Channel* = POINTER TO ChannelDesc;
ChannelDesc* = RECORD (*[ABSTRACT]*)
res*: Result; (* READ-ONLY *)
(* Error flag signalling failure of a call to NewReader, NewWriter, Flush,
or Close. Initialized to `done' when creating the channel. Every
operation sets this to `done' on success, or to a message object to
indicate the error source. *)
readable*: BOOLEAN; (* READ-ONLY *)
(* TRUE iff readers can be attached to this channel with NewReader *)
writable*: BOOLEAN; (* READ-ONLY *)
(* TRUE iff writers can be attached to this channel with NewWriter *)
open*: BOOLEAN; (* READ-ONLY *)
(* Channel status. Set to TRUE on channel creation, set to FALSE by
calling Close. Closing a channel prevents all further read or write
operations on it. *)
END;
TYPE
Reader* = POINTER TO ReaderDesc;
ReaderDesc* = RECORD (*[ABSTRACT]*)
base*: Channel; (* READ-ONLY *)
(* This field refers to the channel the Reader is connected to. *)
res*: Result; (* READ-ONLY *)
(* Error flag signalling failure of a call to ReadByte, ReadBytes, or
SetPos. Initialized to `done' when creating a Reader or by calling
ClearError. The first failed reading (or SetPos) operation changes this
to indicate the error, all further calls to ReadByte, ReadBytes, or
SetPos will be ignored until ClearError resets this flag. This means
that the successful completion of an arbitrary complex sequence of read
operations can be ensured by asserting that `res' equals `done'
beforehand and also after the last operation. *)
bytesRead*: LONGINT; (* READ-ONLY *)
(* Set by ReadByte and ReadBytes to indicate the number of bytes that were
successfully read. *)
positionable*: BOOLEAN; (* READ-ONLY *)
(* TRUE iff the Reader can be moved to another position with `SetPos'; for
channels that can only be read sequentially, like input from keyboard,
this is FALSE. *)
END;
TYPE
Writer* = POINTER TO WriterDesc;
WriterDesc* = RECORD (*[ABSTRACT]*)
base*: Channel; (* READ-ONLY *)
(* This field refers to the channel the Writer is connected to. *)
res*: Result; (* READ-ONLY *)
(* Error flag signalling failure of a call to WriteByte, WriteBytes, or
SetPos. Initialized to `done' when creating a Writer or by calling
ClearError. The first failed writing (or SetPos) operation changes this
to indicate the error, all further calls to WriteByte, WriteBytes, or
SetPos will be ignored until ClearError resets this flag. This means
that the successful completion of an arbitrary complex sequence of write
operations can be ensured by asserting that `res' equals `done'
beforehand and also after the last operation. Note that due to
buffering a write error may occur when flushing or closing the
underlying file, so you have to check the channel's `res' field after
any Flush() or the final Close(), too. *)
bytesWritten*: LONGINT; (* READ-ONLY *)
(* Set by WriteByte and WriteBytes to indicate the number of bytes that
were successfully written. *)
positionable*: BOOLEAN; (* READ-ONLY *)
(* TRUE iff the Writer can be moved to another position with `SetPos'; for
channels that can only be written sequentially, like output to terminal,
this is FALSE. *)
END;
TYPE
ErrorContext = POINTER TO ErrorContextDesc;
ErrorContextDesc* = RECORD
(* this record is exported, so that extensions of Channel can access the
error descriptions by extending `ErrorContextDesc' *)
(Msg.ContextDesc)
END;
VAR
errorContext: ErrorContext;
PROCEDURE GetError (code: Msg.Code): Result;
BEGIN
RETURN Msg.New (errorContext, code)
END GetError;
PROCEDURE (context: ErrorContext) GetTemplate* (msg: Msg.Msg; VAR templ: Msg.LString);
(* Translates this module's error codes into strings. The string usually
contains a short error description, possibly followed by some attributes
to provide additional information for the problem.
The method should not be called directly by the user. It is invoked by
`res.GetText()' or `res.GetLText'. *)
VAR
str: ARRAY 128 OF CHAR;
BEGIN
CASE msg. code OF
| invalidChannel: str := "Invalid channel descriptor"
| writeError: str := "Write error"
| noRoom: str := "No space left on device"
| outOfRange: str := "Trying to set invalid position"
| readAfterEnd: str := "Trying to read past the end of the file"
| channelClosed: str := "Channel has been closed"
| readError: str := "Read error"
| invalidFormat: str := "Invalid token type in input stream"
| noReadAccess: str := "No read permission for channel"
| noWriteAccess: str := "No write permission for channel"
| closeError: str := "Error while closing the channel"
| noModTime: str := "No modification time available"
| noTmpName: str := "Failed to create unique name for temporary file"
ELSE
str := "[unknown error code]"
END;
COPY (str, templ)
END GetTemplate;
(* Reader methods
------------------------------------------------------------------------ *)
PROCEDURE (r: Reader) (*[ABSTRACT]*) Pos*(): LONGINT;
(* Returns the current reading position associated with the reader `r' in
channel `r.base', i.e. the index of the first byte that is read by the
next call to ReadByte resp. ReadBytes. This procedure will return
`noPosition' if the reader has no concept of a reading position (e.g. if it
corresponds to input from keyboard), otherwise the result is not negative.*)
END Pos;
PROCEDURE (r: Reader) (*[ABSTRACT]*) Available*(): LONGINT;
(* Returns the number of bytes available for the next reading operation. For
a file this is the length of the channel `r.base' minus the current reading
position, for an sequential channel (or a channel designed to handle slow
transfer rates) this is the number of bytes that can be accessed without
additional waiting. The result is -1 if Close() was called for the channel,
or no more byte are available and the remote end of the channel has been
closed.
Note that the number of bytes returned is always a lower approximation of
the number that could be read at once; for some channels or systems it might
be as low as 1 even if tons of bytes are waiting to be processed. *)
(* example:
BEGIN
IF r. base. open THEN
i := r. base. Length() - r. Pos();
IF (i < 0) THEN
RETURN 0
ELSE
RETURN i
END
ELSE
RETURN -1
END
*)
END Available;
PROCEDURE (r: Reader) (*[ABSTRACT]*) SetPos* (newPos: LONGINT);
(* Sets the reading position to `newPos'. A negative value of `newPos' or
calling this procedure for a reader that doesn't allow positioning will set
`r.res' to `outOfRange'. A value larger than the channel's length is legal,
but the following read operation will most likely fail with an
`readAfterEnd' error unless the channel has grown beyond this position in
the meantime.
Calls to this procedure while `r.res # done' will be ignored, in particular
a call with `r.res.code = readAfterEnd' error will not reset `res' to
`done'. *)
(* example:
BEGIN
IF (r. res = done) THEN
IF ~r. positionable OR (newPos < 0) THEN
r. res := GetError (outOfRange)
ELSIF r. base. open THEN
(* ... *)
ELSE (* channel has been closed *)
r. res := GetError (channelClosed)
END
END
*)
END SetPos;
PROCEDURE (r: Reader) (*[ABSTRACT]*) ReadByte* (VAR x: SYSTEM.BYTE);
(* Reads a single byte from the channel `r.base' at the reading position
associated with `r' and places it in `x'. The reading position is moved
forward by one byte on success, otherwise `r.res' is changed to indicate
the error cause. Calling this procedure with the reader `r' placed at the
end (or beyond the end) of the channel will set `r.res' to `readAfterEnd'.
`r.bytesRead' will be 1 on success and 0 on failure.
Calls to this procedure while `r.res # done' will be ignored. *)
(* example:
BEGIN
IF (r. res = done) THEN
IF r. base. open THEN
(* ... *)
ELSE (* channel has been closed *)
r. res := GetError (channelClosed);
r. bytesRead := 0
END
ELSE
r. bytesRead := 0
END
*)
END ReadByte;
PROCEDURE (r: Reader) (*[ABSTRACT]*) ReadBytes* (VAR x: ARRAY OF SYSTEM.BYTE;
start, n: LONGINT);
(* Reads `n' bytes from the channel `r.base' at the reading position associated
with `r' and places them in `x', starting at index `start'. The
reading position is moved forward by `n' bytes on success, otherwise
`r.res' is changed to indicate the error cause. Calling this procedure with
the reader `r' placed less than `n' bytes before the end of the channel will
will set `r.res' to `readAfterEnd'. `r.bytesRead' will hold the number of
bytes that were actually read (being equal to `n' on success).
Calls to this procedure while `r.res # done' will be ignored.
pre: (n >= 0) & (0 <= start) & (start+n <= LEN (x)) *)
(* example:
BEGIN
ASSERT ((n >= 0) & (0 <= start) & (start+n <= LEN (x)));
IF (r. res = done) THEN
IF r. base. open THEN
(* ... *)
ELSE (* channel has been closed *)
r. res := GetError (channelClosed);
r. bytesRead := 0
END
ELSE
r. bytesRead := 0
END
*)
END ReadBytes;
PROCEDURE (r: Reader) ClearError*;
(* Sets the result flag `r.res' to `done', re-enabling further read operations
on `r'. *)
BEGIN
r. res := done
END ClearError;
(* Writer methods
------------------------------------------------------------------------ *)
PROCEDURE (w: Writer) (*[ABSTRACT]*) Pos*(): LONGINT;
(* Returns the current writing position associated with the writer `w' in
channel `w.base', i.e. the index of the first byte that is written by the
next call to WriteByte resp. WriteBytes. This procedure will return
`noPosition' if the writer has no concept of a writing position (e.g. if it
corresponds to output to terminal), otherwise the result is not negative. *)
END Pos;
PROCEDURE (w: Writer) (*[ABSTRACT]*) SetPos* (newPos: LONGINT);
(* Sets the writing position to `newPos'. A negative value of `newPos' or
calling this procedure for a writer that doesn't allow positioning will set
`w.res' to `outOfRange'. A value larger than the channel's length is legal,
the following write operation will fill the gap between the end of the
channel and this position with zero bytes.
Calls to this procedure while `w.res # done' will be ignored. *)
(* example:
BEGIN
IF (w. res = done) THEN
IF ~w. positionable OR (newPos < 0) THEN
w. res := GetError (outOfRange)
ELSIF w. base. open THEN
(* ... *)
ELSE (* channel has been closed *)
w. res := GetError (channelClosed)
END
END
*)
END SetPos;
PROCEDURE (w: Writer) (*[ABSTRACT]*) WriteByte* (x: SYSTEM.BYTE);
(* Writes a single byte `x' to the channel `w.base' at the writing position
associated with `w'. The writing position is moved forward by one byte on
success, otherwise `w.res' is changed to indicate the error cause.
`w.bytesWritten' will be 1 on success and 0 on failure.
Calls to this procedure while `w.res # done' will be ignored. *)
(* example:
BEGIN
IF (w. res = done) THEN
IF w. base. open THEN
(* ... *)
ELSE (* channel has been closed *)
w. res := GetError (channelClosed);
w. bytesWritten := 0
END
ELSE
w. bytesWritten := 0
END
*)
END WriteByte;
PROCEDURE (w: Writer) (*[ABSTRACT]*) WriteBytes* (VAR x: ARRAY OF SYSTEM.BYTE;
start, n: LONGINT);
(* Writes `n' bytes from `x', starting at position `start', to the channel
`w.base' at the writing position associated with `w'. The writing position
is moved forward by `n' bytes on success, otherwise `w.res' is changed to
indicate the error cause. `w.bytesWritten' will hold the number of bytes
that were actually written (being equal to `n' on success).
Calls to this procedure while `w.res # done' will be ignored.
pre: (n >= 0) & (0 <= start) & (start+n <= LEN (x)) *)
(* example:
BEGIN
ASSERT ((n >= 0) & (0 <= start) & (start+n <= LEN (x)));
IF (w. res = done) THEN
IF w. base. open THEN
(* ... *)
ELSE (* channel has been closed *)
w. res := GetError (channelClosed);
w. bytesWritten := 0
END
ELSE
w. bytesWritten := 0
END
*)
END WriteBytes;
PROCEDURE (w: Writer) ClearError*;
(* Sets the result flag `w.res' to `done', re-enabling further write operations
on `w'. *)
BEGIN
w. res := done
END ClearError;
(* Channel methods
------------------------------------------------------------------------ *)
PROCEDURE (ch: Channel) (*[ABSTRACT]*) Length*(): LONGINT;
(* Result is the number of bytes of data that this channel refers to. If `ch'
represents a file, then this value is the file's size. If `ch' has no fixed
length (e.g. because it's interactive), the result is `noLength'. *)
END Length;
PROCEDURE (ch: Channel) (*[ABSTRACT]*) GetModTime* (VAR mtime: Time.TimeStamp);
(* Retrieves the modification time of the data accessed by the given channel.
If no such information is avaiblable, `ch.res' is set to `noModTime',
otherwise to `done'. *)
END GetModTime;
PROCEDURE (ch: Channel) NewReader*(): Reader;
(* Attaches a new reader to the channel `ch'. It is placed at the very start
of the channel, and its `res' field is initialized to `done'. `ch.res' is
set to `done' on success and the new reader is returned. Otherwise result
is NIL and `ch.res' is changed to indicate the error cause.
Note that always the same reader is returned if the channel does not support
multiple reading positions. *)
(* example:
BEGIN
IF ch. open THEN
IF ch. readable THEN
(* ... *)
ch. ClearError
ELSE
ch. res := noReadAccess;
RETURN NIL
END
ELSE
ch. res := channelClosed;
RETURN NIL
END
*)
BEGIN (* default: channel does not have read access *)
IF ch. open THEN
ch. res := GetError (noReadAccess)
ELSE
ch. res := GetError (channelClosed)
END;
RETURN NIL
END NewReader;
PROCEDURE (ch: Channel) NewWriter*(): Writer;
(* Attaches a new writer to the channel `ch'. It is placed at the very start
of the channel, and its `res' field is initialized to `done'. `ch.res' is
set to `done' on success and the new writer is returned. Otherwise result
is NIL and `ch.res' is changed to indicate the error cause.
Note that always the same reader is returned if the channel does not support
multiple writing positions. *)
(* example:
BEGIN
IF ch. open THEN
IF ch. writable THEN
(* ... *)
ch. ClearError
ELSE
ch. res := GetError (noWriteAccess);
RETURN NIL
END
ELSE
ch. res := GetError (channelClosed);
RETURN NIL
END
*)
BEGIN (* default: channel does not have write access *)
IF ch. open THEN
ch. res := GetError (noWriteAccess)
ELSE
ch. res := GetError (channelClosed)
END;
RETURN NIL
END NewWriter;
PROCEDURE (ch: Channel) (*[ABSTRACT]*) Flush*;
(* Flushes all buffers related to this channel. Any pending write operations
are passed to the underlying OS and all buffers are marked as invalid. The
next read operation will get its data directly from the channel instead of
the buffer. If a writing error occurs during flushing, the field `ch.res'
will be changed to `writeError', otherwise it's assigned `done'. Note that
you have to check the channel's `res' flag after an explicit flush yourself,
since none of the attached writers will notice any write error in this
case. *)
(* example:
BEGIN
(* ... *)
IF (* write error ... *) FALSE THEN
ch. res := GetError (writeError)
ELSE
ch. ClearError
END
*)
END Flush;
PROCEDURE (ch: Channel) (*[ABSTRACT]*) Close*;
(* Flushes all buffers associated with `ch', closes the channel, and frees all
system resources allocated to it. This invalidates all riders attached to
`ch', they can't be used further. On success, i.e. if all read and write
operations (including flush) completed successfully, `ch.res' is set to
`done'. An opened channel can only be closed once, successive calls of
`Close' are undefined.
Note that unlike the Oberon System all opened channels have to be closed
explicitly. Otherwise resources allocated to them will remain blocked. *)
(* example:
BEGIN
ch. Flush;
IF (ch. res = done) THEN
(* ... *)
END;
ch. open := FALSE
*)
END Close;
PROCEDURE (ch: Channel) ClearError*;
(* Sets the result flag `ch.res' to `done'. *)
BEGIN
ch. res := done
END ClearError;
BEGIN
NEW (errorContext);
Msg.InitContext (errorContext, "OOC:Core:Channel")
END oocChannel.

95
src/library/ooc/oocCharClass.Mod Normal file
View file

@ -0,0 +1,95 @@
(* $Id: CharClass.Mod,v 1.6 1999/10/03 11:43:57 ooc-devel Exp $ *)
MODULE oocCharClass;
(* Classification of values of the type CHAR.
Copyright (C) 1997-1998 Michael van Acken
This module is free software; you can redistribute it and/or
modify 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 OOC. If not, write to the Free Software Foundation,
59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
(*
Notes:
- This module boldly assumes ASCII character encoding. ;-)
- The value `eol' and the procedure `IsEOL' are not part of the Modula-2
DIS. OOC defines them to fixed values for all its implementations,
independent of the target system. The string `systemEol' holds the target
system's end of line marker, which can be longer than one byte (but cannot
contain 0X).
*)
IMPORT
Ascii := oocAscii;
CONST
eol* = Ascii.lf;
(* the implementation-defined character used to represent end of line
internally for OOC *)
VAR
systemEol-: ARRAY 3 OF CHAR;
(* End of line marker used by the target system for text files. The string
defined here can contain more than one character. For one character eol
markers, `systemEol' must not necessarily equal `eol'. Note that the
string cannot contain the termination character 0X. *)
PROCEDURE IsNumeric* (ch: CHAR): BOOLEAN;
(* Returns TRUE if and only if ch is classified as a numeric character *)
BEGIN
RETURN ("0" <= ch) & (ch <= "9")
END IsNumeric;
PROCEDURE IsLetter* (ch: CHAR): BOOLEAN;
(* Returns TRUE if and only if ch is classified as a letter *)
BEGIN
RETURN ("a" <= ch) & (ch <= "z") OR ("A" <= ch) & (ch <= "Z")
END IsLetter;
PROCEDURE IsUpper* (ch: CHAR): BOOLEAN;
(* Returns TRUE if and only if ch is classified as an upper case letter *)
BEGIN
RETURN ("A" <= ch) & (ch <= "Z")
END IsUpper;
PROCEDURE IsLower* (ch: CHAR): BOOLEAN;
(* Returns TRUE if and only if ch is classified as a lower case letter *)
BEGIN
RETURN ("a" <= ch) & (ch <= "z")
END IsLower;
PROCEDURE IsControl* (ch: CHAR): BOOLEAN;
(* Returns TRUE if and only if ch represents a control function *)
BEGIN
RETURN (ch < Ascii.sp)
END IsControl;
PROCEDURE IsWhiteSpace* (ch: CHAR): BOOLEAN;
(* Returns TRUE if and only if ch represents a space character or a format
effector *)
BEGIN
RETURN (ch = Ascii.sp) OR (ch = Ascii.ff) OR (ch = Ascii.lf) OR
(ch = Ascii.cr) OR (ch = Ascii.ht) OR (ch = Ascii.vt)
END IsWhiteSpace;
PROCEDURE IsEol* (ch: CHAR): BOOLEAN;
(* Returns TRUE if and only if ch is the implementation-defined character used
to represent end of line internally for OOC. *)
BEGIN
RETURN (ch = eol)
END IsEol;
BEGIN
systemEol[0] := Ascii.lf; systemEol[1] := 0X
END oocCharClass.

274
src/library/ooc/oocComplexMath.Mod Normal file
View file

@ -0,0 +1,274 @@
(* $Id: ComplexMath.Mod,v 1.5 1999/09/02 13:05:36 acken Exp $ *)
MODULE oocComplexMath;
(*
ComplexMath - Mathematical functions for the type COMPLEX.
Copyright (C) 1995-1996 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
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 m := oocRealMath;
TYPE
COMPLEX * = POINTER TO COMPLEXDesc;
COMPLEXDesc = RECORD
r, i : REAL
END;
CONST
ZERO=0.0; HALF=0.5; ONE=1.0; TWO=2.0;
VAR
i-, one-, zero- : COMPLEX;
PROCEDURE CMPLX * (r, i: REAL): COMPLEX;
VAR c: COMPLEX;
BEGIN
NEW(c); c.r:=r; c.i:=i;
RETURN c
END CMPLX;
(*
NOTE: This function provides the only way
of reliably assigning COMPLEX numbers. DO
NOT use ` a := b' where a, b are COMPLEX!
*)
PROCEDURE Copy * (z: COMPLEX): COMPLEX;
BEGIN
RETURN CMPLX(z.r, z.i)
END Copy;
PROCEDURE RealPart * (z: COMPLEX): REAL;
BEGIN
RETURN z.r
END RealPart;
PROCEDURE ImagPart * (z: COMPLEX): REAL;
BEGIN
RETURN z.i
END ImagPart;
PROCEDURE add * (z1, z2: COMPLEX): COMPLEX;
BEGIN
RETURN CMPLX(z1.r+z2.r, z1.i+z2.i)
END add;
PROCEDURE sub * (z1, z2: COMPLEX): COMPLEX;
BEGIN
RETURN CMPLX(z1.r-z2.r, z1.i-z2.i)
END sub;
PROCEDURE mul * (z1, z2: COMPLEX): COMPLEX;
BEGIN
RETURN CMPLX(z1.r*z2.r-z1.i*z2.i, z1.r*z2.i+z1.i*z2.r)
END mul;
PROCEDURE div * (z1, z2: COMPLEX): COMPLEX;
VAR d, h: REAL;
BEGIN
(* Note: this algorith avoids overflow by avoiding
multiplications and using divisions instead so that:
Re(z1/z2) = (z1.r*z2.r+z1.i*z2.i)/(z2.r^2+z2.i^2)
= (z1.r+z1.i*z2.i/z2.r)/(z2.r+z2.i^2/z2.r)
= (z1.r+h*z1.i)/(z2.r+h*z2.i)
Im(z1/z2) = (z1.i*z2.r-z1.r*z2.i)/(z2.r^2+z2.i^2)
= (z1.i-z1.r*z2.i/z2.r)/(z2.r+z2.i^2/z2.r)
= (z1.i-h*z1.r)/(z2.r+h*z2.i)
where h=z2.i/z2.r, provided z2.i<=z2.r and similarly
for z2.i>z2.r we have:
Re(z1/z2) = (h*z1.r+z1.i)/(h*z2.r+z2.i)
Im(z1/z2) = (h*z1.i-z1.r)/(h*z2.r+z2.i)
where h=z2.r/z2.i *)
(* we always guarantee h<=1 *)
IF ABS(z2.r)>ABS(z2.i) THEN
h:=z2.i/z2.r; d:=z2.r+h*z2.i;
RETURN CMPLX((z1.r+h*z1.i)/d, (z1.i-h*z1.r)/d)
ELSE
h:=z2.r/z2.i; d:=h*z2.r+z2.i;
RETURN CMPLX((h*z1.r+z1.i)/d, (h*z1.i-z1.r)/d)
END
END div;
PROCEDURE abs * (z: COMPLEX): REAL;
(* Returns the length of z *)
VAR
r, i, h: REAL;
BEGIN
(* Note: this algorithm avoids overflow by avoiding
multiplications and using divisions instead so that:
abs(z) = sqrt(z.r*z.r+z.i*z.i)
= sqrt(z.r^2*(1+(z.i/z.r)^2))
= z.r*sqrt(1+(z.i/z.r)^2)
where z.i/z.r <= 1.0 by swapping z.r & z.i so that
for z.r>z.i we have z.r*sqrt(1+(z.i/z.r)^2) and
otherwise we have z.i*sqrt(1+(z.r/z.i)^2) *)
r:=ABS(z.r); i:=ABS(z.i);
IF i>r THEN h:=i; i:=r; r:=h END; (* guarantees i<=r *)
IF i=ZERO THEN RETURN r END; (* i=0, so sqrt(0+r^2)=r *)
h:=i/r;
RETURN r*m.sqrt(ONE+h*h) (* r*sqrt(1+(i/r)^2) *)
END abs;
PROCEDURE arg * (z: COMPLEX): REAL;
(* Returns the angle that z subtends to the positive real axis, in the range [-pi, pi] *)
BEGIN
RETURN m.arctan2(z.i, z.r)
END arg;
PROCEDURE conj * (z: COMPLEX): COMPLEX;
(* Returns the complex conjugate of z *)
BEGIN
RETURN CMPLX(z.r, -z.i)
END conj;
PROCEDURE power * (base: COMPLEX; exponent: REAL): COMPLEX;
(* Returns the value of the number base raised to the power exponent *)
VAR c, s, r: REAL;
BEGIN
m.sincos(arg(base)*exponent, s, c); r:=m.power(abs(base), exponent);
RETURN CMPLX(c*r, s*r)
END power;
PROCEDURE sqrt * (z: COMPLEX): COMPLEX;
(* Returns the principal square root of z, with arg in the range [-pi/2, pi/2] *)
VAR u, v: REAL;
BEGIN
(* Note: the following algorithm is more efficient since
it doesn't require a sincos or arctan evaluation:
Re(sqrt(z)) = sqrt((abs(z)+z.r)/2), Im(sqrt(z)) = +/-sqrt((abs(z)-z.r)/2)
= u = +/-v
where z.r >= 0 and z.i = 2*u*v and unknown sign is sign of z.i *)
(* initially force z.r >= 0 to calculate u, v *)
u:=m.sqrt((abs(z)+ABS(z.r))*HALF);
IF z.i#ZERO THEN v:=(HALF*z.i)/u ELSE v:=ZERO END; (* slight optimization *)
(* adjust u, v for the signs of z.r and z.i *)
IF z.r>=ZERO THEN RETURN CMPLX(u, v) (* no change *)
ELSIF z.i>=ZERO THEN RETURN CMPLX(v, u) (* z.r<0 so swap u, v *)
ELSE RETURN CMPLX(-v, -u) (* z.r<0, z.i<0 *)
END
END sqrt;
PROCEDURE exp * (z: COMPLEX): COMPLEX;
(* Returns the complex exponential of z *)
VAR c, s, e: REAL;
BEGIN
m.sincos(z.i, s, c); e:=m.exp(z.r);
RETURN CMPLX(e*c, e*s)
END exp;
PROCEDURE ln * (z: COMPLEX): COMPLEX;
(* Returns the principal value of the natural logarithm of z *)
BEGIN
RETURN CMPLX(m.ln(abs(z)), arg(z))
END ln;
PROCEDURE sin * (z: COMPLEX): COMPLEX;
(* Returns the sine of z *)
VAR s, c: REAL;
BEGIN
m.sincos(z.r, s, c);
RETURN CMPLX(s*m.cosh(z.i), c*m.sinh(z.i))
END sin;
PROCEDURE cos * (z: COMPLEX): COMPLEX;
(* Returns the cosine of z *)
VAR s, c: REAL;
BEGIN
m.sincos(z.r, s, c);
RETURN CMPLX(c*m.cosh(z.i), -s*m.sinh(z.i))
END cos;
PROCEDURE tan * (z: COMPLEX): COMPLEX;
(* Returns the tangent of z *)
VAR s, c, y, d: REAL;
BEGIN
m.sincos(TWO*z.r, s, c);
y:=TWO*z.i; d:=c+m.cosh(y);
RETURN CMPLX(s/d, m.sinh(y)/d)
END tan;
PROCEDURE CalcAlphaBeta(z: COMPLEX; VAR a, b: REAL);
VAR x, x2, y, r, t: REAL;
BEGIN x:=z.r+ONE; x:=x*x; y:=z.i*z.i;
x2:=z.r-ONE; x2:=x2*x2;
r:=m.sqrt(x+y); t:=m.sqrt(x2+y);
a:=HALF*(r+t); b:=HALF*(r-t);
END CalcAlphaBeta;
PROCEDURE arcsin * (z: COMPLEX): COMPLEX;
(* Returns the arcsine of z *)
VAR a, b: REAL;
BEGIN
CalcAlphaBeta(z, a, b);
RETURN CMPLX(m.arcsin(b), m.ln(a+m.sqrt(a*a-1)))
END arcsin;
PROCEDURE arccos * (z: COMPLEX): COMPLEX;
(* Returns the arccosine of z *)
VAR a, b: REAL;
BEGIN
CalcAlphaBeta(z, a, b);
RETURN CMPLX(m.arccos(b), -m.ln(a+m.sqrt(a*a-1)))
END arccos;
PROCEDURE arctan * (z: COMPLEX): COMPLEX;
(* Returns the arctangent of z *)
VAR x, y, yp, x2, y2: REAL;
BEGIN
x:=TWO*z.r; y:=z.i+ONE; y:=y*y;
yp:=z.i-ONE; yp:=yp*yp;
x2:=z.r*z.r; y2:=z.i*z.i;
RETURN CMPLX(HALF*m.arctan(x/(ONE-x2-y2)), 0.25*m.ln((x2+y)/(x2+yp)))
END arctan;
PROCEDURE polarToComplex * (abs, arg: REAL): COMPLEX;
(* Returns the complex number with the specified polar coordinates *)
BEGIN
RETURN CMPLX(abs*m.cos(arg), abs*m.sin(arg))
END polarToComplex;
PROCEDURE scalarMult * (scalar: REAL; z: COMPLEX): COMPLEX;
(* Returns the scalar product of scalar with z *)
BEGIN
RETURN CMPLX(z.r*scalar, z.i*scalar)
END scalarMult;
PROCEDURE IsCMathException * (): BOOLEAN;
(* Returns TRUE if the current coroutine is in the exceptional execution state
because of the ComplexMath exception; otherwise returns FALSE.
*)
BEGIN
RETURN FALSE
END IsCMathException;
BEGIN
i:=CMPLX (ZERO, ONE);
one:=CMPLX (ONE, ZERO);
zero:=CMPLX (ZERO, ZERO)
END oocComplexMath.

33
src/library/ooc/oocConvTypes.Mod Normal file
View file

@ -0,0 +1,33 @@
(* $Id: ConvTypes.Mod,v 1.1 1997/02/07 07:45:32 oberon1 Exp $ *)
MODULE oocConvTypes;
(* Common types used in the string conversion modules *)
TYPE
ConvResults*= SHORTINT; (* Values of this type are used to express the format of a string *)
CONST
strAllRight*=0; (* the string format is correct for the corresponding conversion *)
strOutOfRange*=1; (* the string is well-formed but the value cannot be represented *)
strWrongFormat*=2; (* the string is in the wrong format for the conversion *)
strEmpty*=3; (* the given string is empty *)
TYPE
ScanClass*= SHORTINT; (* Values of this type are used to classify input to finite state scanners *)
CONST
padding*=0; (* a leading or padding character at this point in the scan - ignore it *)
valid*=1; (* a valid character at this point in the scan - accept it *)
invalid*=2; (* an invalid character at this point in the scan - reject it *)
terminator*=3; (* a terminating character at this point in the scan (not part of token) *)
TYPE
ScanState*=POINTER TO ScanDesc;
ScanDesc*= (* The type of lexical scanning control procedures *)
RECORD
p*: PROCEDURE (ch: CHAR; VAR cl: ScanClass; VAR st: ScanState);
END;
END oocConvTypes.

188
src/library/ooc/oocFilenames.Mod Normal file
View file

@ -0,0 +1,188 @@
(* This module is obsolete. Don't use it. *)
MODULE oocFilenames;
(* Note: It is not checked whether the concatenated strings fit into the
variables given for them or not *)
IMPORT
Strings := oocStrings, Strings2 := oocStrings2, Rts := oocRts;
PROCEDURE LocateCharLast(str: ARRAY OF CHAR; ch: CHAR): INTEGER;
(* Result is the position of the last occurence of 'ch' in the string 'str'.
If 'ch' does not occur in 'str', then -1 is returned *)
VAR
pos: INTEGER;
BEGIN
pos:=Strings.Length(str);
WHILE (pos >= 0) DO
IF (str[pos] = ch) THEN
RETURN(pos);
ELSE
DEC(pos);
END; (* IF *)
END; (* WHILE *)
RETURN -1
END LocateCharLast;
PROCEDURE SplitRChar(str: ARRAY OF CHAR; VAR str1, str2: ARRAY OF CHAR; ch: CHAR);
(* pre : 'str' contains the string to be splited after the rightmost 'ch' *)
(* post: 'str1' contains the left part (including 'ch') of 'str',
iff occurs(ch,str), otherwise "",
'str2' contains the right part of 'str'.
*)
(*
example:
str = "/aksdf/asdf/gasdfg/esscgd.asdfg"
result: str2 = "esscgd.asdfg"
str1 = "/aksdf/asdf/gasdfg/"
*)
VAR
len,pos: INTEGER;
BEGIN
len:=Strings.Length(str);
(* search for the rightmost occurence of 'ch' and
store it's position in 'pos' *)
pos:=LocateCharLast(str,ch);
COPY(str,str2); (* that has to be done all time *)
IF (pos >= 0) THEN
(* 'ch' occurs in 'str', (str[pos]=ch)=TRUE *)
COPY(str,str1); (* copy the whole string 'str' to 'str1' *)
INC(pos); (* we want to split _after_ 'ch' *)
Strings.Delete(str2,0,pos); (* remove left part from 'str2' *)
Strings.Delete(str1,pos,(len-pos)); (* remove right part from 'str1' *)
ELSE (* there is no pathinfo in 'file' *)
COPY("",str1); (* make 'str1' the empty string *)
END; (* IF *)
END SplitRChar;
(******************************)
(* decomposition of filenames *)
(******************************)
PROCEDURE GetPath*(full: ARRAY OF CHAR; VAR path, file: ARRAY OF CHAR);
(*
pre : "full" contains the (maybe) absolute path to a file.
post: "file" contains only the filename, "path" the path for it.
example:
pre : full = "/aksdf/asdf/gasdfg/esscgd.asdfg"
post: file = "esscgd.asdfg"
path = "/aksdf/asdf/gasdfg/"
*)
BEGIN
SplitRChar(full,path,file,Rts.pathSeperator);
END GetPath;
PROCEDURE GetExt*(full: ARRAY OF CHAR; VAR file, ext: ARRAY OF CHAR);
BEGIN
IF (LocateCharLast(full,Rts.pathSeperator) < LocateCharLast(full,".")) THEN
(* there is a "real" extension *)
SplitRChar(full,file,ext,".");
Strings.Delete(file,Strings.Length(file)-1,1); (* delete "." at the end of 'file' *)
ELSE
COPY(full,file);
COPY("",ext);
END; (* IF *)
END GetExt;
PROCEDURE GetFile*(full: ARRAY OF CHAR; VAR file: ARRAY OF CHAR);
(* removes both path & extension from 'full' and stores the result in 'file' *)
(* example:
GetFile("/tools/public/o2c-1.2/lib/Filenames.Mod",myname)
results in
myname="Filenames"
*)
VAR
dummy: ARRAY 256 OF CHAR; (* that should be enough... *)
BEGIN
GetPath(full,dummy,file);
GetExt(file,file,dummy);
END GetFile;
(****************************)
(* composition of filenames *)
(****************************)
PROCEDURE AddExt*(VAR full: ARRAY OF CHAR; file, ext: ARRAY OF CHAR);
(* pre : 'file' is a filename
'ext' is some extension
*)
(* post: 'full' contains 'file'"."'ext', iff 'ext'#"",
otherwise 'file'
*)
BEGIN
COPY(file,full);
IF (ext[0] # 0X) THEN
(* we only append 'real', i.e. nonempty extensions *)
Strings2.AppendChar(".", full);
Strings.Append(ext, full);
END; (* IF *)
END AddExt;
PROCEDURE AddPath*(VAR full: ARRAY OF CHAR; path, file: ARRAY OF CHAR);
(* pre : 'file' is a filename
'path' is a path (will not be interpreted) or ""
*)
(* post: 'full' will contain the contents of 'file' with
addition of 'path' at the beginning.
*)
BEGIN
COPY(file,full);
IF (path[0] # 0X) THEN
(* we only add something if there is something... *)
IF (path[Strings.Length(path) - 1] # Rts.pathSeperator) THEN
(* add a seperator, if none is at the end of 'path' *)
Strings.Insert(Rts.pathSeperator, 0, full);
END; (* IF *)
Strings.Insert(path, 0, full)
END; (* IF *)
END AddPath;
PROCEDURE BuildFilename*(VAR full: ARRAY OF CHAR; path, file, ext: ARRAY OF CHAR);
(* pre : 'file' is the name of a file,
'path' is its path and
'ext' is the extension to be added
*)
(* post: 'full' contains concatenation of 'path' with ('file' with 'ext')
*)
BEGIN
AddExt(full,file,ext);
AddPath(full,path,full);
END BuildFilename;
PROCEDURE ExpandPath*(VAR full: ARRAY OF CHAR; path: ARRAY OF CHAR);
(* Expands "~/" and "~user/" at the beginning of 'path' to it's
intended strings.
"~/" will result in the path to the current user's home,
"~user" will result in the path of "user"'s home. *)
VAR
len, posSep, posSuffix: INTEGER;
suffix, userpath: ARRAY 256 OF CHAR;
username: ARRAY 32 OF CHAR;
BEGIN
COPY (path, full);
IF (path[0] = "~") THEN (* we have to expand something *)
posSep := Strings2.PosChar (Rts.pathSeperator, path);
len := Strings.Length (path);
IF (posSep < 0) THEN (* no '/' in file name, just the path *)
posSep := len;
posSuffix := len
ELSE
posSuffix := posSep+1
END;
Strings.Extract (path, posSuffix, len-posSuffix, suffix);
Strings.Extract (path, 1, posSep-1, username);
Rts.GetUserHome (userpath, username);
IF (userpath[0] # 0X) THEN (* sucessfull search *)
AddPath (full, userpath, suffix)
END
END
END ExpandPath;
END oocFilenames.

240
src/library/ooc/oocIntConv.Mod Normal file
View file

@ -0,0 +1,240 @@
(* $Id: IntConv.Mod,v 1.5 2002/05/10 23:06:58 ooc-devel Exp $ *)
MODULE oocIntConv;
(*
IntConv - Low-level integer/string conversions.
Copyright (C) 1995 Michael Griebling
Copyright (C) 2000, 2002 Michael van Acken
This module is free software; you can redistribute it and/or modify
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
Char := oocCharClass, Str := oocStrings, Conv := oocConvTypes;
TYPE
ConvResults = Conv.ConvResults; (* strAllRight, strOutOfRange, strWrongFormat, strEmpty *)
CONST
strAllRight*=Conv.strAllRight; (* the string format is correct for the corresponding conversion *)
strOutOfRange*=Conv.strOutOfRange; (* the string is well-formed but the value cannot be represented *)
strWrongFormat*=Conv.strWrongFormat; (* the string is in the wrong format for the conversion *)
strEmpty*=Conv.strEmpty; (* the given string is empty *)
VAR
W, S, SI: Conv.ScanState;
(* internal state machine procedures *)
PROCEDURE WState(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
BEGIN
IF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=W
ELSE chClass:=Conv.terminator; nextState:=NIL
END
END WState;
PROCEDURE SState(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
BEGIN
IF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=W
ELSE chClass:=Conv.invalid; nextState:=S
END
END SState;
PROCEDURE ScanInt*(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
(*
Represents the start state of a finite state scanner for signed whole
numbers - assigns class of inputCh to chClass and a procedure
representing the next state to nextState.
The call of ScanInt(inputCh,chClass,nextState) shall assign values to
`chClass' and `nextState' depending upon the value of `inputCh' as
shown in the following table.
Procedure inputCh chClass nextState (a procedure
with behaviour of)
--------- --------- -------- ---------
ScanInt space padding ScanInt
sign valid SState
decimal digit valid WState
other invalid ScanInt
SState decimal digit valid WState
other invalid SState
WState decimal digit valid WState
other terminator --
NOTE 1 -- The procedure `ScanInt' corresponds to the start state of a
finite state machine to scan for a character sequence that forms a
signed whole number. Like `ScanCard' and the corresponding procedures
in the other low-level string conversion modules, it may be used to
control the actions of a finite state interpreter. As long as the
value of `chClass' is other than `terminator' or `invalid', the
interpreter should call the procedure whose value is assigned to
`nextState' by the previous call, supplying the next character from
the sequence to be scanned. It may be appropriate for the interpreter
to ignore characters classified as `invalid', and proceed with the
scan. This would be the case, for example, with interactive input, if
only valid characters are being echoed in order to give interactive
users an immediate indication of badly-formed data.
If the character sequence end before one is classified as a
terminator, the string-terminator character should be supplied as
input to the finite state scanner. If the preceeding character
sequence formed a complete number, the string-terminator will be
classified as `terminator', otherwise it will be classified as
`invalid'.
For examples of how ScanInt is used, refer to the FormatInt and
ValueInt procedures below.
*)
BEGIN
IF Char.IsWhiteSpace(inputCh) THEN chClass:=Conv.padding; nextState:=SI
ELSIF (inputCh="+") OR (inputCh="-") THEN chClass:=Conv.valid; nextState:=S
ELSIF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=W
ELSE chClass:=Conv.invalid; nextState:=SI
END
END ScanInt;
PROCEDURE FormatInt*(str: ARRAY OF CHAR): ConvResults;
(* Returns the format of the string value for conversion to LONGINT. *)
VAR
ch: CHAR;
int: LONGINT;
len, index, digit: INTEGER;
state: Conv.ScanState;
positive: BOOLEAN;
prev, class: Conv.ScanClass;
BEGIN
len:=Str.Length(str); index:=0;
class:=Conv.padding; prev:=class;
state:=SI; int:=0; positive:=TRUE;
LOOP
ch:=str[index];
state.p(ch, class, state);
CASE class OF
| Conv.padding: (* nothing to do *)
| Conv.valid:
IF ch="-" THEN positive:=FALSE
ELSIF ch="+" THEN positive:=TRUE
ELSE (* must be a digit *)
digit:=ORD(ch)-ORD("0");
IF positive THEN
IF int>(MAX(LONGINT)-digit) DIV 10 THEN RETURN strOutOfRange END;
int:=int*10+digit
ELSE
IF int>(MIN(LONGINT)+digit) DIV 10 THEN
int:=int*10-digit
ELSIF (int < (MIN(LONGINT)+digit) DIV 10) OR
((int = (MIN(LONGINT)+digit) DIV 10) &
((MIN(LONGINT)+digit) MOD 10 # 0)) THEN
RETURN strOutOfRange
ELSE
int:=int*10-digit
END
END
END
| Conv.invalid:
IF (prev = Conv.padding) THEN
RETURN strEmpty;
ELSE
RETURN strWrongFormat;
END;
| Conv.terminator:
IF (ch = 0X) THEN
RETURN strAllRight;
ELSE
RETURN strWrongFormat;
END;
END;
prev:=class; INC(index)
END;
END FormatInt;
PROCEDURE ValueInt*(str: ARRAY OF CHAR): LONGINT;
(*
Returns the value corresponding to the signed whole number string value
str if str is well-formed; otherwise raises the WholeConv exception.
*)
VAR
ch: CHAR;
len, index, digit: INTEGER;
int: LONGINT;
state: Conv.ScanState;
positive: BOOLEAN;
class: Conv.ScanClass;
BEGIN
IF FormatInt(str)=strAllRight THEN
len:=Str.Length(str); index:=0;
state:=SI; int:=0; positive:=TRUE;
FOR index:=0 TO len-1 DO
ch:=str[index];
state.p(ch, class, state);
IF class=Conv.valid THEN
IF ch="-" THEN positive:=FALSE
ELSIF ch="+" THEN positive:=TRUE
ELSE (* must be a digit *)
digit:=ORD(ch)-ORD("0");
IF positive THEN int:=int*10+digit
ELSE int:=int*10-digit
END
END
END
END;
RETURN int
ELSE RETURN 0 (* raise exception here *)
END
END ValueInt;
PROCEDURE LengthInt*(int: LONGINT): INTEGER;
(*
Returns the number of characters in the string representation of int.
This value corresponds to the capacity of an array `str' which is
of the minimum capacity needed to avoid truncation of the result in
the call IntStr.IntToStr(int,str).
*)
VAR
cnt: INTEGER;
BEGIN
IF int=MIN(LONGINT) THEN int:=-(int+1); cnt:=1 (* argh!! *)
ELSIF int<=0 THEN int:=-int; cnt:=1
ELSE cnt:=0
END;
WHILE int>0 DO INC(cnt); int:=int DIV 10 END;
RETURN cnt
END LengthInt;
PROCEDURE IsIntConvException*(): BOOLEAN;
(* Returns TRUE if the current coroutine is in the exceptional execution
state because of the raising of the IntConv exception; otherwise
returns FALSE.
*)
BEGIN
RETURN FALSE
END IsIntConvException;
BEGIN
(* kludge necessary because of recursive procedure declaration *)
NEW(S); NEW(W); NEW(SI);
S.p:=SState; W.p:=WState; SI.p:=ScanInt
END oocIntConv.

100
src/library/ooc/oocIntStr.Mod Normal file
View file

@ -0,0 +1,100 @@
(* $Id: IntStr.Mod,v 1.4 1999/09/02 13:07:47 acken Exp $ *)
MODULE oocIntStr;
(* IntStr - Integer-number/string conversions.
Copyright (C) 1995 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
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
Conv := oocConvTypes, IntConv := oocIntConv;
TYPE
ConvResults*= Conv.ConvResults;
(* possible values: strAllRight, strOutOfRange, strWrongFormat, strEmpty *)
CONST
strAllRight*=Conv.strAllRight;
(* the string format is correct for the corresponding conversion *)
strOutOfRange*=Conv.strOutOfRange;
(* the string is well-formed but the value cannot be represented *)
strWrongFormat*=Conv.strWrongFormat;
(* the string is in the wrong format for the conversion *)
strEmpty*=Conv.strEmpty;
(* the given string is empty *)
(* the string form of a signed whole number is
["+" | "-"] decimal_digit {decimal_digit}
*)
PROCEDURE StrToInt*(str: ARRAY OF CHAR; VAR int: LONGINT; VAR res: ConvResults);
(* Ignores any leading spaces in `str'. If the subsequent characters in `str'
are in the format of a signed whole number, assigns a corresponding value to
`int'. Assigns a value indicating the format of `str' to `res'. *)
BEGIN
res:=IntConv.FormatInt(str);
IF (res = strAllRight) THEN
int:=IntConv.ValueInt(str)
END
END StrToInt;
PROCEDURE Reverse (VAR str : ARRAY OF CHAR; start, end : INTEGER);
(* Reverses order of characters in the interval [start..end]. *)
VAR
h : CHAR;
BEGIN
WHILE start < end DO
h := str[start]; str[start] := str[end]; str[end] := h;
INC(start); DEC(end)
END
END Reverse;
PROCEDURE IntToStr*(int: LONGINT; VAR str: ARRAY OF CHAR);
(* Converts the value of `int' to string form and copies the possibly truncated
result to `str'. *)
CONST
maxLength = 11; (* maximum number of digits representing a LONGINT value *)
VAR
b : ARRAY maxLength+1 OF CHAR;
s, e: INTEGER;
BEGIN
(* build representation in string 'b' *)
IF int = MIN(LONGINT) THEN (* smallest LONGINT, -int is an overflow *)
b := "-2147483648";
e := 11
ELSE
IF int < 0 THEN (* negative sign *)
b[0] := "-"; int := -int; s := 1
ELSE (* no sign *)
s := 0
END;
e := s; (* 's' holds starting position of string *)
REPEAT
b[e] := CHR(int MOD 10+ORD("0"));
int := int DIV 10;
INC(e)
UNTIL int = 0;
b[e] := 0X;
Reverse(b, s, e-1)
END;
COPY(b, str) (* truncate output if necessary *)
END IntToStr;
END oocIntStr.

132
src/library/ooc/oocJulianDay.Mod Normal file
View file

@ -0,0 +1,132 @@
(* $Id: JulianDay.Mod,v 1.4 1999/09/02 13:08:31 acken Exp $ *)
MODULE oocJulianDay;
(*
JulianDay - convert to/from day/month/year and modified Julian days.
Copyright (C) 1996 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
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
*)
CONST
daysPerYear = 365.25D0; (* used in Julian date calculations *)
daysPerMonth = 30.6001D0;
startMJD* = 2400000.5D0; (* zero basis for modified Julian Day in Julian days *)
startTJD* = startMJD+40000.0D0; (* zero basis for truncated modified Julian Day *)
VAR
UseGregorian-: BOOLEAN; (* TRUE when Gregorian calendar is in use *)
startGregor: LONGREAL; (* start of the Gregorian calendar in Julian days *)
(* ------------------------------------------------------------- *)
(* Conversion functions *)
PROCEDURE DateToJD * (day, month: SHORTINT; year: INTEGER) : LONGREAL;
(* Returns a Julian date in days for the given `day', `month',
and `year' at 0000 UTC. Any date with a positive year is valid.
Algorithm by William H. Jefferys (with some modifications) at:
http://quasar.as.utexas.edu/BillInfo/JulianDatesG.html *)
VAR
A, B, C: LONGINT; JD: LONGREAL;
BEGIN
IF month<3 THEN DEC(year); INC(month, 12) END;
IF UseGregorian THEN A:=year DIV 100; B:=A DIV 4; C:=2-A+B
ELSE C:=0
END;
JD:=C+day+ENTIER(daysPerYear*(year+4716))+ENTIER(daysPerMonth*(month+1))-1524.5D0;
IF UseGregorian & (JD>=startGregor) THEN RETURN JD
ELSE RETURN JD-C
END
END DateToJD;
PROCEDURE DateToDays * (day, month: SHORTINT; year: INTEGER) : LONGINT;
(* Returns a modified Julian date in days for the given `day', `month',
and `year' at 0000 UTC. Any date with a positive year is valid.
The returned value is the number of days since 17 November 1858. *)
BEGIN
RETURN ENTIER(DateToJD(day, month, year)-startMJD)
END DateToDays;
PROCEDURE DateToTJD * (day, month: SHORTINT; year: INTEGER) : LONGINT;
(* Returns a truncated modified Julian date in days for the given `day',
`month', and `year' at 0000 UTC. Any date with a positive year is
valid. The returned value is the *)
BEGIN
RETURN ENTIER(DateToJD(day, month, year)-startTJD)
END DateToTJD;
PROCEDURE JDToDate * (jd: LONGREAL; VAR day, month: SHORTINT; VAR year: INTEGER);
(* Converts a Julian date in days to a date given by the `day', `month', and
`year'. Algorithm by William H. Jefferys (with some modifications) at
http://quasar.as.utexas.edu/BillInfo/JulianDatesG.html *)
VAR
W, D, B: LONGINT;
BEGIN
jd:=jd+0.5;
IF UseGregorian & (jd>=startGregor) THEN
W:=ENTIER((jd-1867216.25D0)/36524.25D0);
B:=ENTIER(jd+1525+W-ENTIER(W/4.0D0))
ELSE B:=ENTIER(jd+1524)
END;
year:=SHORT(ENTIER((B-122.1D0)/daysPerYear));
D:=ENTIER(daysPerYear*year);
month:=SHORT(SHORT(ENTIER((B-D)/daysPerMonth)));
day:=SHORT(SHORT(B-D-ENTIER(daysPerMonth*month)));
IF month>13 THEN DEC(month, 13) ELSE DEC(month) END;
IF month<3 THEN DEC(year, 4715) ELSE DEC(year, 4716) END
END JDToDate;
PROCEDURE DaysToDate * (jd: LONGINT; VAR day, month: SHORTINT; VAR year: INTEGER);
(* Converts a modified Julian date in days to a date given by the `day',
`month', and `year'. *)
BEGIN
JDToDate(jd+startMJD, day, month, year)
END DaysToDate;
PROCEDURE TJDToDate * (jd: LONGINT; VAR day, month: SHORTINT; VAR year: INTEGER);
(* Converts a truncated modified Julian date in days to a date given by the `day',
`month', and `year'. *)
BEGIN
JDToDate(jd+startTJD, day, month, year)
END TJDToDate;
PROCEDURE SetGregorianStart * (day, month: SHORTINT; year: INTEGER);
(* Sets the start date when the Gregorian calendar was first used
where the date in `d' is in the Julian calendar. The default
date used is 3 Sep 1752 (when the calendar correction occurred
according to the Julian calendar).
The Gregorian calendar was introduced in 4 Oct 1582 by Pope
Gregory XIII but was not adopted by many Protestant countries
until 2 Sep 1752. In all cases, to make up for an inaccuracy
in the calendar, 10 days were skipped during adoption of the
new calendar. *)
VAR
gFlag: BOOLEAN;
BEGIN
gFlag:=UseGregorian; UseGregorian:=FALSE; (* use Julian calendar *)
startGregor:=DateToJD(day, month, year);
UseGregorian:=gFlag (* back to default *)
END SetGregorianStart;
BEGIN
(* by default we use the Gregorian calendar *)
UseGregorian:=TRUE; startGregor:=0;
(* Gregorian calendar default start date *)
SetGregorianStart(3, 9, 1752)
END oocJulianDay.

284
src/library/ooc/oocLComplexMath.Mod Normal file
View file

@ -0,0 +1,284 @@
(* $Id: LComplexMath.Mod,v 1.5 1999/09/02 13:08:49 acken Exp $ *)
MODULE oocLComplexMath;
(*
LComplexMath - Mathematical functions for the type LONGCOMPLEX.
Copyright (C) 1995-1996 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
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 c := oocComplexMath, m := oocLRealMath;
TYPE
LONGCOMPLEX * = POINTER TO LONGCOMPLEXDesc;
LONGCOMPLEXDesc = RECORD
r, i : LONGREAL
END;
CONST
ZERO=0.0D0; HALF=0.5D0; ONE=1.0D0; TWO=2.0D0;
VAR
i-, one-, zero- : LONGCOMPLEX;
PROCEDURE CMPLX * (r, i: LONGREAL): LONGCOMPLEX;
VAR c: LONGCOMPLEX;
BEGIN
NEW(c); c.r:=r; c.i:=i;
RETURN c
END CMPLX;
(*
NOTE: This function provides the only way
of reliably assigning COMPLEX numbers. DO
NOT use ` a := b' where a, b are LONGCOMPLEX!
*)
PROCEDURE Copy * (z: LONGCOMPLEX): LONGCOMPLEX;
BEGIN
RETURN CMPLX(z.r, z.i)
END Copy;
PROCEDURE Long * (z: c.COMPLEX): LONGCOMPLEX;
BEGIN
RETURN CMPLX(c.RealPart(z), c.ImagPart(z))
END Long;
PROCEDURE Short * (z: LONGCOMPLEX): c.COMPLEX;
BEGIN
RETURN c.CMPLX(SHORT(z.r), SHORT(z.i))
END Short;
PROCEDURE RealPart * (z: LONGCOMPLEX): LONGREAL;
BEGIN
RETURN z.r
END RealPart;
PROCEDURE ImagPart * (z: LONGCOMPLEX): LONGREAL;
BEGIN
RETURN z.i
END ImagPart;
PROCEDURE add * (z1, z2: LONGCOMPLEX): LONGCOMPLEX;
BEGIN
RETURN CMPLX(z1.r+z2.r, z1.i+z2.i)
END add;
PROCEDURE sub * (z1, z2: LONGCOMPLEX): LONGCOMPLEX;
BEGIN
RETURN CMPLX(z1.r-z2.r, z1.i-z2.i)
END sub;
PROCEDURE mul * (z1, z2: LONGCOMPLEX): LONGCOMPLEX;
BEGIN
RETURN CMPLX(z1.r*z2.r-z1.i*z2.i, z1.r*z2.i+z1.i*z2.r)
END mul;
PROCEDURE div * (z1, z2: LONGCOMPLEX): LONGCOMPLEX;
VAR d, h: LONGREAL;
BEGIN
(* Note: this algorith avoids overflow by avoiding
multiplications and using divisions instead so that:
Re(z1/z2) = (z1.r*z2.r+z1.i*z2.i)/(z2.r^2+z2.i^2)
= (z1.r+z1.i*z2.i/z2.r)/(z2.r+z2.i^2/z2.r)
= (z1.r+h*z1.i)/(z2.r+h*z2.i)
Im(z1/z2) = (z1.i*z2.r-z1.r*z2.i)/(z2.r^2+z2.i^2)
= (z1.i-z1.r*z2.i/z2.r)/(z2.r+z2.i^2/z2.r)
= (z1.i-h*z1.r)/(z2.r+h*z2.i)
where h=z2.i/z2.r, provided z2.i<=z2.r and similarly
for z2.i>z2.r we have:
Re(z1/z2) = (h*z1.r+z1.i)/(h*z2.r+z2.i)
Im(z1/z2) = (h*z1.i-z1.r)/(h*z2.r+z2.i)
where h=z2.r/z2.i *)
(* we always guarantee h<=1 *)
IF ABS(z2.r)>ABS(z2.i) THEN
h:=z2.i/z2.r; d:=z2.r+h*z2.i;
RETURN CMPLX((z1.r+h*z1.i)/d, (z1.i-h*z1.r)/d)
ELSE
h:=z2.r/z2.i; d:=h*z2.r+z2.i;
RETURN CMPLX((h*z1.r+z1.i)/d, (h*z1.i-z1.r)/d)
END
END div;
PROCEDURE abs * (z: LONGCOMPLEX): LONGREAL;
(* Returns the length of z *)
VAR
r, i, h: LONGREAL;
BEGIN
(* Note: this algorithm avoids overflow by avoiding
multiplications and using divisions instead so that:
abs(z) = sqrt(z.r*z.r+z.i*z.i)
= sqrt(z.r^2*(1+(z.i/z.r)^2))
= z.r*sqrt(1+(z.i/z.r)^2)
where z.i/z.r <= 1.0 by swapping z.r & z.i so that
for z.r>z.i we have z.r*sqrt(1+(z.i/z.r)^2) and
otherwise we have z.i*sqrt(1+(z.r/z.i)^2) *)
r:=ABS(z.r); i:=ABS(z.i);
IF i>r THEN h:=i; i:=r; r:=h END; (* guarantees i<=r *)
IF i=ZERO THEN RETURN r END; (* i=0, so sqrt(0+r^2)=r *)
h:=i/r;
RETURN r*m.sqrt(ONE+h*h) (* r*sqrt(1+(i/r)^2) *)
END abs;
PROCEDURE arg * (z: LONGCOMPLEX): LONGREAL;
(* Returns the angle that z subtends to the positive real axis, in the range [-pi, pi] *)
BEGIN
RETURN m.arctan2(z.i, z.r)
END arg;
PROCEDURE conj * (z: LONGCOMPLEX): LONGCOMPLEX;
(* Returns the complex conjugate of z *)
BEGIN
RETURN CMPLX(z.r, -z.i)
END conj;
PROCEDURE power * (base: LONGCOMPLEX; exponent: LONGREAL): LONGCOMPLEX;
(* Returns the value of the number base raised to the power exponent *)
VAR c, s, r: LONGREAL;
BEGIN
m.sincos(arg(base)*exponent, s, c); r:=m.power(abs(base), exponent);
RETURN CMPLX(c*r, s*r)
END power;
PROCEDURE sqrt * (z: LONGCOMPLEX): LONGCOMPLEX;
(* Returns the principal square root of z, with arg in the range [-pi/2, pi/2] *)
VAR u, v: LONGREAL;
BEGIN
(* Note: the following algorithm is more efficient since
it doesn't require a sincos or arctan evaluation:
Re(sqrt(z)) = sqrt((abs(z)+z.r)/2), Im(sqrt(z)) = +/-sqrt((abs(z)-z.r)/2)
= u = +/-v
where z.r >= 0 and z.i = 2*u*v and unknown sign is sign of z.i *)
(* initially force z.r >= 0 to calculate u, v *)
u:=m.sqrt((abs(z)+ABS(z.r))*HALF);
IF z.i#ZERO THEN v:=(HALF*z.i)/u ELSE v:=ZERO END; (* slight optimization *)
(* adjust u, v for the signs of z.r and z.i *)
IF z.r>=ZERO THEN RETURN CMPLX(u, v) (* no change *)
ELSIF z.i>=ZERO THEN RETURN CMPLX(v, u) (* z.r<0 so swap u, v *)
ELSE RETURN CMPLX(-v, -u) (* z.r<0, z.i<0 *)
END
END sqrt;
PROCEDURE exp * (z: LONGCOMPLEX): LONGCOMPLEX;
(* Returns the complex exponential of z *)
VAR c, s, e: LONGREAL;
BEGIN
m.sincos(z.i, s, c); e:=m.exp(z.r);
RETURN CMPLX(e*c, e*s)
END exp;
PROCEDURE ln * (z: LONGCOMPLEX): LONGCOMPLEX;
(* Returns the principal value of the natural logarithm of z *)
BEGIN
RETURN CMPLX(m.ln(abs(z)), arg(z))
END ln;
PROCEDURE sin * (z: LONGCOMPLEX): LONGCOMPLEX;
(* Returns the sine of z *)
VAR s, c: LONGREAL;
BEGIN
m.sincos(z.r, s, c);
RETURN CMPLX(s*m.cosh(z.i), c*m.sinh(z.i))
END sin;
PROCEDURE cos * (z: LONGCOMPLEX): LONGCOMPLEX;
(* Returns the cosine of z *)
VAR s, c: LONGREAL;
BEGIN
m.sincos(z.r, s, c);
RETURN CMPLX(c*m.cosh(z.i), -s*m.sinh(z.i))
END cos;
PROCEDURE tan * (z: LONGCOMPLEX): LONGCOMPLEX;
(* Returns the tangent of z *)
VAR s, c, y, d: LONGREAL;
BEGIN
m.sincos(TWO*z.r, s, c);
y:=TWO*z.i; d:=c+m.cosh(y);
RETURN CMPLX(s/d, m.sinh(y)/d)
END tan;
PROCEDURE CalcAlphaBeta(z: LONGCOMPLEX; VAR a, b: LONGREAL);
VAR x, x2, y, r, t: LONGREAL;
BEGIN x:=z.r+ONE; x:=x*x; y:=z.i*z.i;
x2:=z.r-ONE; x2:=x2*x2;
r:=m.sqrt(x+y); t:=m.sqrt(x2+y);
a:=HALF*(r+t); b:=HALF*(r-t);
END CalcAlphaBeta;
PROCEDURE arcsin * (z: LONGCOMPLEX): LONGCOMPLEX;
(* Returns the arcsine of z *)
VAR a, b: LONGREAL;
BEGIN
CalcAlphaBeta(z, a, b);
RETURN CMPLX(m.arcsin(b), m.ln(a+m.sqrt(a*a-1)))
END arcsin;
PROCEDURE arccos * (z: LONGCOMPLEX): LONGCOMPLEX;
(* Returns the arccosine of z *)
VAR a, b: LONGREAL;
BEGIN
CalcAlphaBeta(z, a, b);
RETURN CMPLX(m.arccos(b), -m.ln(a+m.sqrt(a*a-1)))
END arccos;
PROCEDURE arctan * (z: LONGCOMPLEX): LONGCOMPLEX;
(* Returns the arctangent of z *)
VAR x, y, yp, x2, y2: LONGREAL;
BEGIN
x:=TWO*z.r; y:=z.i+ONE; y:=y*y;
yp:=z.i-ONE; yp:=yp*yp;
x2:=z.r*z.r; y2:=z.i*z.i;
RETURN CMPLX(HALF*m.arctan(x/(ONE-x2-y2)), 0.25D0*m.ln((x2+y)/(x2+yp)))
END arctan;
PROCEDURE polarToComplex * (abs, arg: LONGREAL): LONGCOMPLEX;
(* Returns the complex number with the specified polar coordinates *)
BEGIN
RETURN CMPLX(abs*m.cos(arg), abs*m.sin(arg))
END polarToComplex;
PROCEDURE scalarMult * (scalar: LONGREAL; z: LONGCOMPLEX): LONGCOMPLEX;
(* Returns the scalar product of scalar with z *)
BEGIN
RETURN CMPLX(z.r*scalar, z.i*scalar)
END scalarMult;
PROCEDURE IsCMathException * (): BOOLEAN;
(* Returns TRUE if the current coroutine is in the exceptional execution state
because of the LComplexMath exception; otherwise returns FALSE.
*)
BEGIN
RETURN FALSE
END IsCMathException;
BEGIN
i:=CMPLX (ZERO, ONE);
one:=CMPLX (ONE, ZERO);
zero:=CMPLX (ZERO, ZERO)
END oocLComplexMath.

414
src/library/ooc/oocLRealConv.Mod Normal file
View file

@ -0,0 +1,414 @@
(* $Id: LRealConv.Mod,v 1.7 1999/10/12 07:17:54 ooc-devel Exp $ *)
MODULE oocLRealConv;
(*
LRealConv - Low-level LONGREAL/string conversions.
Copyright (C) 1996 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
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
Char := oocCharClass, Low := oocLowLReal, Str := oocStrings, Conv := oocConvTypes,
LInt := oocLongInts, SYSTEM;
CONST
ZERO=0.0D0;
SigFigs*=15; (* accuracy of LONGREALs *)
DEBUG = FALSE;
TYPE
ConvResults*= Conv.ConvResults; (* strAllRight, strOutOfRange, strWrongFormat, strEmpty *)
LongInt=LInt.LongInt;
CONST
strAllRight*=Conv.strAllRight; (* the string format is correct for the corresponding conversion *)
strOutOfRange*=Conv.strOutOfRange; (* the string is well-formed but the value cannot be represented *)
strWrongFormat*=Conv.strWrongFormat; (* the string is in the wrong format for the conversion *)
strEmpty*=Conv.strEmpty; (* the given string is empty *)
VAR
RS, P, F, E, SE, WE, SR: Conv.ScanState;
PROCEDURE IsExponent (ch: CHAR) : BOOLEAN;
BEGIN
RETURN (ch="E") OR (ch="D")
END IsExponent;
PROCEDURE IsSign (ch: CHAR): BOOLEAN;
(* Return TRUE for '+' or '-' *)
BEGIN
RETURN (ch='+')OR(ch='-')
END IsSign;
(* internal state machine procedures *)
PROCEDURE RSState(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
BEGIN
IF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=P
ELSE chClass:=Conv.invalid; nextState:=RS
END
END RSState;
PROCEDURE PState(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
BEGIN
IF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=P
ELSIF inputCh="." THEN chClass:=Conv.valid; nextState:=F
ELSIF IsExponent(inputCh) THEN chClass:=Conv.valid; nextState:=E
ELSE chClass:=Conv.terminator; nextState:=NIL
END
END PState;
PROCEDURE FState(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
BEGIN
IF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=F
ELSIF IsExponent(inputCh) THEN chClass:=Conv.valid; nextState:=E
ELSE chClass:=Conv.terminator; nextState:=NIL
END
END FState;
PROCEDURE EState(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
BEGIN
IF IsSign(inputCh) THEN chClass:=Conv.valid; nextState:=SE
ELSIF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=WE
ELSE chClass:=Conv.invalid; nextState:=E
END
END EState;
PROCEDURE SEState(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
BEGIN
IF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=WE
ELSE chClass:=Conv.invalid; nextState:=SE
END
END SEState;
PROCEDURE WEState(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
BEGIN
IF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=WE
ELSE chClass:=Conv.terminator; nextState:=NIL
END
END WEState;
PROCEDURE Real (VAR x: LongInt; exp, digits: LONGINT; VAR outOfRange: BOOLEAN): LONGREAL;
CONST BR=LInt.B+ZERO; InvLOGB=0.221461873; (* real version *)
VAR cnt, len, scale, Bscale, start, bexp, max: LONGINT; r: LONGREAL;
BEGIN
(* scale by the exponent *)
scale:=exp+digits;
IF scale>=ABS(digits) THEN
Bscale:=0; LInt.TenPower(x, SHORT(scale))
ELSE
Bscale:=ENTIER(-scale*InvLOGB)+6;
LInt.BPower(x, SHORT(Bscale)); (* x*B^Bscale *)
LInt.TenPower(x, SHORT(scale)); (* x*B^BScale*10^scale *)
END;
(* prescale to left-justify the number *)
start:=LInt.MinDigit(x); bexp:=0; (* find starting digit *)
IF (start=LEN(x)-1)&(x[start]=0) THEN (* exit here for zero *)
outOfRange:=FALSE; RETURN ZERO
END;
WHILE x[start]<LInt.B DIV 2 DO
LInt.MultDigit(x, 2, 0); INC(bexp) (* normalize *)
END;
(* convert to a LONGREAL *)
r:=ZERO; len:=LEN(x)-1; max:=start+3;
IF max>len THEN max:=len END;
FOR cnt:=start TO max DO r:=r*BR+x[cnt] END;
(* post scaling *)
INC(bexp, (Bscale-len+max)*15);
(* quick check for overflow *)
max:=Low.exponent(r)-SHORT(bexp);
IF (max>Low.expoMax) OR (max<Low.expoMin) THEN
outOfRange:=TRUE;
RETURN ZERO
ELSE
outOfRange:=FALSE;
RETURN Low.scale(r, -SHORT(bexp))
END
END Real;
PROCEDURE ScanReal*(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
(*
Represents the start state of a finite state scanner for real numbers - assigns
class of inputCh to chClass and a procedure representing the next state to
nextState.
The call of ScanReal(inputCh,chClass,nextState) shall assign values to
`chClass' and `nextState' depending upon the value of `inputCh' as
shown in the following table.
Procedure inputCh chClass nextState (a procedure
with behaviour of)
--------- --------- -------- ---------
ScanReal space padding ScanReal
sign valid RSState
decimal digit valid PState
other invalid ScanReal
RSState decimal digit valid PState
other invalid RSState
PState decimal digit valid PState
"." valid FState
"E", "D" valid EState
other terminator --
FState decimal digit valid FState
"E", "D" valid EState
other terminator --
EState sign valid SEState
decimal digit valid WEState
other invalid EState
SEState decimal digit valid WEState
other invalid SEState
WEState decimal digit valid WEState
other terminator --
For examples of how to use ScanReal, refer to FormatReal and
ValueReal below.
*)
BEGIN
IF Char.IsWhiteSpace(inputCh) THEN chClass:=Conv.padding; nextState:=SR
ELSIF IsSign(inputCh) THEN chClass:=Conv.valid; nextState:=RS
ELSIF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=P
ELSE chClass:=Conv.invalid; nextState:=SR
END
END ScanReal;
PROCEDURE FormatReal*(str: ARRAY OF CHAR): ConvResults;
(* Returns the format of the string value for conversion to LONGREAL. *)
VAR
ch: CHAR;
rn: LONGREAL;
len, index, digit, nexp, exp: INTEGER;
state: Conv.ScanState;
inExp, posExp, decExp, outOfRange: BOOLEAN;
prev, class: Conv.ScanClass;
int: LongInt;
BEGIN
state:=SR; rn:=0.0; exp:=0; nexp:= 0;
class:=Conv.padding; prev:=class;
inExp:=FALSE; posExp:=TRUE; decExp:=FALSE;
(*FOR len:=0 TO SHORT(LEN(int))-1 DO int[len]:=0 END;*)
FOR len:=0 TO (LEN(int))-1 DO int[len]:=0 END; (* I don't understand why to SHORT it. LEN(int) will return 170 (defined in LongInts as ARRAY 170 OF INTEGER) both with voc and oo2c the same way; -- noch *)
len:=Str.Length(str); index:=0;
LOOP
IF index=len THEN EXIT END;
ch:=str[index];
state.p(ch, class, state);
CASE class OF
| Conv.padding: (* nothing to do *)
| Conv.valid:
IF inExp THEN
IF IsSign(ch) THEN posExp:=ch="+"
ELSE (* must be digits *)
digit:=ORD(ch)-ORD("0");
IF posExp THEN exp:=exp*10+digit
ELSE exp:=exp*10-digit
END
END
ELSIF IsExponent(ch) THEN inExp:=TRUE
ELSIF ch="." THEN decExp:=TRUE
ELSE (* must be a digit *)
LInt.MultDigit(int, 10, ORD(ch)-ORD("0"));
IF decExp THEN DEC(nexp) END;
END
| Conv.invalid, Conv.terminator: EXIT
END;
prev:=class; INC(index)
END;
IF class IN {Conv.invalid, Conv.terminator} THEN
RETURN strWrongFormat
ELSIF prev=Conv.padding THEN
RETURN strEmpty
ELSE
rn:=Real(int, exp, nexp, outOfRange);
IF outOfRange THEN RETURN strOutOfRange
ELSE RETURN strAllRight
END
END
END FormatReal;
PROCEDURE ValueReal*(str: ARRAY OF CHAR): LONGREAL;
VAR
ch: CHAR;
rn: LONGREAL;
len, index, digit, nexp, exp: INTEGER;
state: Conv.ScanState;
inExp, positive, posExp, decExp, outOfRange: BOOLEAN;
prev, class: Conv.ScanClass;
int: LongInt;
BEGIN
state:=SR; rn:=0.0; exp:=0; nexp:= 0;
class:=Conv.padding; prev:=class;
positive:=TRUE; inExp:=FALSE; posExp:=TRUE; decExp:=FALSE;
(*FOR len:=0 TO SHORT(LEN(int))-1 DO int[len]:=0 END;*)
FOR len:=0 TO (LEN(int))-1 DO int[len]:=0 END; (* I don't understand why to SHORT it; -- noch *)
len:=Str.Length(str); index:=0;
LOOP
IF index=len THEN EXIT END;
ch:=str[index];
state.p(ch, class, state);
CASE class OF
| Conv.padding: (* nothing to do *)
| Conv.valid:
IF inExp THEN
IF IsSign(ch) THEN posExp:=ch="+"
ELSE (* must be digits *)
digit:=ORD(ch)-ORD("0");
IF posExp THEN exp:=exp*10+digit
ELSE exp:=exp*10-digit
END
END
ELSIF IsExponent(ch) THEN inExp:=TRUE
ELSIF IsSign(ch) THEN positive:=ch="+"
ELSIF ch="." THEN decExp:=TRUE
ELSE (* must be a digit *)
LInt.MultDigit(int, 10, ORD(ch)-ORD("0"));
IF decExp THEN DEC(nexp) END;
END
| Conv.invalid, Conv.terminator: EXIT
END;
prev:=class; INC(index)
END;
IF class IN {Conv.invalid, Conv.terminator} THEN
RETURN ZERO
ELSIF prev=Conv.padding THEN
RETURN ZERO
ELSE
rn:=Real(int, exp, nexp, outOfRange);
IF outOfRange THEN RETURN Low.large END
END;
IF ~positive THEN rn:=-rn END;
RETURN rn
END ValueReal;
PROCEDURE LengthFloatReal*(real: LONGREAL; sigFigs: INTEGER): INTEGER;
(*
Returns the number of characters in the floating-point string
representation of real with sigFigs significant figures.
This value corresponds to the capacity of an array `str' which
is of the minimum capacity needed to avoid truncation of the
result in the call LongStr.RealToFloat(real,sigFigs,str).
*)
VAR
len, exp: INTEGER;
BEGIN
IF Low.IsNaN(real) THEN RETURN 3
ELSIF Low.IsInfinity(real) THEN
IF real<ZERO THEN RETURN 9 ELSE RETURN 8 END
END;
IF sigFigs=0 THEN sigFigs:=SigFigs END; len:=sigFigs; (* default digits -- if none given *)
IF real<ZERO THEN INC(len); real:=-real END; (* account for the sign *)
exp:=Low.exponent10(real);
IF sigFigs>1 THEN INC(len) END; (* account for the decimal point *)
IF exp>10 THEN INC(len, 4) (* account for the exponent *)
ELSIF exp#0 THEN INC(len, 3)
END;
RETURN len
END LengthFloatReal;
PROCEDURE LengthEngReal*(real: LONGREAL; sigFigs: INTEGER): INTEGER;
(*
Returns the number of characters in the floating-point engineering
string representation of real with sigFigs significant figures.
This value corresponds to the capacity of an array `str' which is
of the minimum capacity needed to avoid truncation of the result in
the call LongStr.RealToEng(real,sigFigs,str).
*)
VAR
len, exp, off: INTEGER;
BEGIN
IF Low.IsNaN(real) THEN RETURN 3
ELSIF Low.IsInfinity(real) THEN
IF real<ZERO THEN RETURN 9 ELSE RETURN 8 END
END;
IF sigFigs=0 THEN sigFigs:=SigFigs END; len:=sigFigs; (* default digits -- if none given *)
IF real<ZERO THEN INC(len); real:=-real END; (* account for the sign *)
exp:=Low.exponent10(real); off:=exp MOD 3; (* account for the exponent *)
IF exp-off>10 THEN INC(len, 4)
ELSIF exp-off#0 THEN INC(len, 3)
END;
IF sigFigs>off+1 THEN INC(len) END; (* account for the decimal point *)
IF off+1-sigFigs>0 THEN INC(len, off+1-sigFigs) END; (* account for extra padding digits *)
RETURN len
END LengthEngReal;
PROCEDURE LengthFixedReal*(real: LONGREAL; place: INTEGER): INTEGER;
(* Returns the number of characters in the fixed-point string
representation of real rounded to the given place relative
to the decimal point.
This value corresponds to the capacity of an array `str' which
is of the minimum capacity needed to avoid truncation of the
result in the call LongStr.RealToFixed(real,sigFigs,str).
*)
VAR
len, exp: INTEGER; addDecPt: BOOLEAN;
BEGIN
IF Low.IsNaN(real) THEN RETURN 3
ELSIF Low.IsInfinity(real) THEN
IF real<ZERO THEN RETURN 9 ELSE RETURN 8 END
END;
exp:=Low.exponent10(real); addDecPt:=place>=0;
IF place<0 THEN INC(place, 2) ELSE INC(place) END;
IF exp<0 THEN (* account for digits *)
IF place<=0 THEN len:=1 ELSE len:=place END
ELSE len:=exp+place;
IF 1-place>0 THEN INC(len, 1-place) END
END;
IF real<ZERO THEN INC(len) END; (* account for the sign *)
IF addDecPt THEN INC(len) END; (* account for decimal point *)
RETURN len
END LengthFixedReal;
PROCEDURE IsRConvException*(): BOOLEAN;
(* Returns TRUE if the current coroutine is in the exceptional execution state because
of the raising of the RealConv exception; otherwise returns FALSE.
*)
BEGIN
RETURN FALSE
END IsRConvException;
PROCEDURE Test;
VAR res: INTEGER; f: LONGREAL;
BEGIN
f:=ValueReal("-1.8770465240919248E+246");
f:=ValueReal("5.1059259362558051E-111");
f:=ValueReal("2.4312432637500083E-88");
res:=LengthFixedReal(100, 0);
res:=LengthEngReal(100, 0);
res:=LengthFloatReal(100, 0);
res:=LengthFixedReal(-100.123, 0);
res:=LengthEngReal(-100.123, 0);
res:=LengthFloatReal(-100.123, 0);
res:=LengthFixedReal(-1.0D20, 0);
res:=LengthEngReal(-1.0D20, 0);
res:=LengthFloatReal(-1.0D20, 0)
END Test;
BEGIN
NEW(RS); NEW(P); NEW(F); NEW(E); NEW(SE); NEW(WE); NEW(SR);
RS.p:=RSState; P.p:=PState; F.p:=FState; E.p:=EState;
SE.p:=SEState; WE.p:=WEState; SR.p:=ScanReal;
IF DEBUG THEN Test END
END oocLRealConv.

561
src/library/ooc/oocLRealMath.Mod Normal file
View file

@ -0,0 +1,561 @@
MODULE oocLRealMath;
(*
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.
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
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;
CONST
pi* = 3.1415926535897932384626433832795028841972D0;
exp1* = 2.7182818284590452353602874713526624977572D0;
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 *)
sqrtHalf=0.70710678118654752440D0;
Limit=1.0536712D-8; (* 2**(-MantBits/2) *)
eps=5.5511151D-17; (* 2**(-MantBits-1) *)
piInv=0.31830988618379067154D0; (* 1/pi *)
piByTwo=1.57079632679489661923D0;
lnv=0.6931610107421875D0; (* should be exact *)
vbytwo=0.13830277879601902638D-4; (* used in sinh/cosh *)
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;
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 *)
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;
c2=-8.908910206761537356617D-6;
r1=-0.16666666666666665052D+0;
r2= 0.83333333333331650314D-2;
r3=-0.19841269841201840457D-3;
r4= 0.27557319210152756119D-5;
r5=-0.25052106798274584544D-7;
r6= 0.16058936490371589114D-9;
r7=-0.76429178068910467734D-12;
r8= 0.27204790957888846175D-14;
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) *)
RETURN sign*g
END SinCos;
PROCEDURE div (x, y : LONGINT) : LONGINT;
(* corrected MOD function *)
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
P0=0.41731; P1=0.59016;
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)
END sqrt;
PROCEDURE exp*(x: LONGREAL): LONGREAL;
(* Returns the exponential of x for x < Ln(MAX(REAL) *)
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;
VAR xn, g, p, q, z: LONGREAL; n: INTEGER;
BEGIN
(* Ensure we detect overflows and return 0 for underflows *)
IF x>LnInfinity THEN l.ErrorHandler(Overflow); RETURN huge
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
c1=355.0D0/512.0D0; c2=-2.121944400546905827679D-4;
P0=-0.64124943423745581147D+2; P1=0.16383943563021534222D+2; P2=-0.78956112887491257267D+0;
Q0=-0.76949932108494879777D+3; Q1=0.31203222091924532844D+3; Q2=-0.35667977739034646171D+2;
VAR f, zn, zd, r, z, w, p, q, xn: LONGREAL; n: INTEGER;
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)
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;
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)
ELSE RETURN SinCos(x, x, ONE)
END
END sin;
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;
BEGIN
sincos(x, Sin, Cos);
IF ABS(Cos)<miny THEN l.ErrorHandler(IllegalTrig); RETURN huge
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
IF ABS(x)>ONE THEN l.ErrorHandler(IllegalInvTrig); RETURN huge
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
IF ABS(x)>ONE THEN l.ErrorHandler(IllegalInvTrig); RETURN huge
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
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;
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;
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
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;
(* 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;
w1:=ENTIER(16*w)*OneOver16; w2:=w2+(w-w1); w:=ENTIER(16*w2)*OneOver16;
iw1:=ENTIER(16*(w+w1)); w2:=w2-w;
(* check for overflow/underflow *)
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;
RETURN l.scale(z, SHORT(mp))
END power;
PROCEDURE round*(x: LONGREAL): LONGINT;
(* Returns the value of x rounded to the nearest integer *)
BEGIN
IF x<ZERO THEN RETURN -ENTIER(HALF-x)
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.
*)
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.
*)
PROCEDURE log* (x, base: LONGREAL): LONGREAL;
(* 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) *)
IF base<=ZERO THEN l.ErrorHandler(IllegalLogBase); RETURN -huge
ELSE RETURN ln(x)/ln(base)
END
END log;
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;
PROCEDURE Adjust(xadj: LONGREAL): LONGREAL;
BEGIN
IF (x<ZERO)&ODD(base) THEN RETURN -xadj ELSE RETURN xadj END
END Adjust;
BEGIN
(* handle all possible error conditions *)
IF base=0 THEN RETURN ONE (* x**0 = 1 *)
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;
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
altered : p442, The Art Of Computer Programming, Vol 2 *)
y:=ONE; IF base<0 THEN neg:=TRUE; base := -base ELSE neg:= FALSE END;
LOOP
IF ODD(base) THEN y:=y*x END;
base:=base DIV 2; IF base=0 THEN EXIT END;
x:=x*x;
END;
IF neg THEN RETURN ONE/y ELSE RETURN y END
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;
PROCEDURE arctan2* (xn, xd: LONGREAL): LONGREAL;
(* 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
P0=0.216062307897242551884D+3; P1=0.3226620700132512059245D+3;
P2=0.13270239816397674701D+3; P3=0.1288838303415727934D+2;
Q0=0.2160623078972426128957D+3; Q1=0.3946828393122829592162D+3;
Q2=0.221050883028417680623D+3; Q3=0.3850148650835119501D+2;
PiOver2=pi/2; Sqrt3=1.7320508075688772935D0;
VAR atan, z, z2, p, q: LONGREAL; xnExp, xdExp: INTEGER; Quadrant: SHORTINT;
BEGIN
IF ABS(xd)<miny THEN
IF ABS(xn)<miny THEN l.ErrorHandler(IllegalInvTrig); atan:=ZERO
ELSE l.ErrorHandler(Overflow); atan:=PiOver2
END
ELSE xnExp:=l.exponent(xn); xdExp:=l.exponent(xd);
IF xnExp-xdExp>=l.expoMax-3 THEN l.ErrorHandler(Overflow); atan:=PiOver2
ELSIF xnExp-xdExp<l.expoMin+3 THEN atan:=ZERO
ELSE
(* ensure division of xn/xd always produces a number < 1 & resolve quadrant *)
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
1: atan:=atan+pi/6
| 2: atan:=atan+PiOver2
| 3: atan:=atan+pi/3
| 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
END arctan2;
PROCEDURE sinh* (x: LONGREAL): LONGREAL;
(* sinh(x) is the hyperbolic sine of x. The argument x must not be so large
that exp(|x|) overflows. *)
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;
Q2=-0.27773523119650701667D+3;
VAR y, f, p, q: 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 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
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. *)
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 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;
Q0= 0.48402357071988688686D+4; Q1= 0.22337720718962312926D+4; Q2= 0.11274474380534949335D+3;
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);
IF f>BIG THEN t:=ONE
ELSIF f>ln3over2 THEN t:=ONE-TWO/(exp(TWO*f)+ONE)
ELSIF f<Limit THEN t:=f
ELSE (* approximation from "Software Manual for the Elementary Functions" *)
t:=f*f; t:=t*(((P2*t+P1)*t+P0)/(((t+Q2)*t+Q1)*t+Q0)); t:=f+f*t
END;
IF x<ZERO THEN RETURN -t ELSE RETURN t END
END tanh;
PROCEDURE arcsinh* (x: LONGREAL): LONGREAL;
(* arcsinh(x) is the arc hyperbolic sine of x. All arguments are legal. *)
BEGIN
IF ABS(x)>SqrtInfinity*HALF THEN l.ErrorHandler(HypInvTrigClipped);
IF x>ZERO THEN RETURN ln(SqrtInfinity) ELSE RETURN -ln(SqrtInfinity) END;
ELSIF x<ZERO THEN RETURN -ln(-x+sqrt(x*x+ONE))
ELSE RETURN ln(x+sqrt(x*x+ONE))
END
END arcsinh;
PROCEDURE arccosh* (x: LONGREAL): LONGREAL;
(* 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
ELSIF x>SqrtInfinity*HALF THEN l.ErrorHandler(HypInvTrigClipped); RETURN ln(SqrtInfinity)
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
result is less accurate than half precision. *)
CONST TanhLimit=0.999984991D0; (* Tanh(5.9) *)
VAR t: LONGREAL;
BEGIN t:=ABS(x);
IF (t>=ONE) OR (t>(ONE-TWO*em)) THEN l.ErrorHandler(IllegalHypInvTrig);
IF x<ZERO THEN RETURN -TanhMax ELSE RETURN TanhMax END
ELSIF t>TanhLimit THEN l.ErrorHandler(LossOfAccuracy)
END;
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)
END ToLONGREAL;
BEGIN
(* determine some fundamental constants used by hyperbolic trig functions *)
em:=l.ulp(ONE);
LnInfinity:=ln(huge);
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;
(* 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);
(* reenable compiler warnings *)
(*<* POP *>*)
END oocLRealMath.

451
src/library/ooc/oocLRealStr.Mod Normal file
View file

@ -0,0 +1,451 @@
(* $Id: LRealStr.Mod,v 1.8 2001/07/15 14:59:29 ooc-devel Exp $ *)
MODULE oocLRealStr;
(*
LRealStr - LONGREAL/string conversions.
Copyright (C) 1996, 2001 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
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
Low := oocLowLReal, Conv := oocConvTypes, RC := oocLRealConv, Str := oocStrings,
LInt := oocLongInts;
CONST
ZERO=0.0D0; B=8000H;
TYPE
ConvResults*= Conv.ConvResults; (* strAllRight, strOutOfRange, strWrongFormat, strEmpty *)
CONST
strAllRight*=Conv.strAllRight; (* the string format is correct for the corresponding conversion *)
strOutOfRange*=Conv.strOutOfRange; (* the string is well-formed but the value cannot be represented *)
strWrongFormat*=Conv.strWrongFormat; (* the string is in the wrong format for the conversion *)
strEmpty*=Conv.strEmpty; (* the given string is empty *)
(* the string form of a signed fixed-point real number is
["+" | "-"], decimal digit, {decimal digit}, [".", {decimal digit}]
*)
(* the string form of a signed floating-point real number is
signed fixed-point real number, "E"|"e", ["+" | "-"], decimal digit, {decimal digit}
*)
PROCEDURE StrToReal*(str: ARRAY OF CHAR; VAR real: LONGREAL; VAR res: ConvResults);
(*
Ignores any leading spaces in str. If the subsequent characters in str
are in the format of a signed real number, and shall assign values to
`res' and `real' as follows:
strAllRight
if the remainder of `str' represents a complete signed real number
in the range of the type of `real' -- the value of this number shall
be assigned to `real';
strOutOfRange
if the remainder of `str' represents a complete signed real number
but its value is out of the range of the type of `real' -- the
maximum or minimum value of the type of `real' shall be assigned to
`real' according to the sign of the number;
strWrongFormat
if there are remaining characters in `str' but these are not in the
form of a complete signed real number -- the value of `real' is not
defined;
strEmpty
if there are no remaining characters in `str' -- the value of `real'
is not defined.
*)
BEGIN
res:=RC.FormatReal(str);
IF res IN {strAllRight, strOutOfRange} THEN real:=RC.ValueReal(str) END
END StrToReal;
PROCEDURE AppendChar(ch: CHAR; VAR str: ARRAY OF CHAR);
VAR ds: ARRAY 2 OF CHAR;
BEGIN
ds[0]:=ch; ds[1]:=0X; Str.Append(ds, str)
END AppendChar;
PROCEDURE AppendDigit(dig: LONGINT; VAR str: ARRAY OF CHAR);
BEGIN
AppendChar(CHR(dig+ORD("0")), str)
END AppendDigit;
PROCEDURE AppendExponent(exp: INTEGER; VAR str: ARRAY OF CHAR);
BEGIN
Str.Append("E", str);
IF exp<0 THEN exp:=-exp; Str.Append("-", str)
ELSE Str.Append("+", str)
END;
IF exp>=100 THEN AppendDigit(exp DIV 100, str) END;
IF exp>=10 THEN AppendDigit((exp DIV 10) MOD 10, str) END;
AppendDigit(exp MOD 10, str)
END AppendExponent;
PROCEDURE AppendFraction(VAR n: LInt.LongInt; sigFigs, place: INTEGER; VAR str: ARRAY OF CHAR);
VAR digs, end: INTEGER; d: LONGINT; lstr: ARRAY 64 OF CHAR;
BEGIN
(* write significant digits *)
lstr:="";
FOR digs:=1 TO sigFigs DO
LInt.DivDigit(n, 10, d); AppendDigit(d, lstr);
END;
(* reverse the real digits and append to str *)
end:=sigFigs-1;
FOR digs:=0 TO sigFigs-1 DO
IF digs=place THEN Str.Append(".", str) END;
AppendChar(lstr[end], str); DEC(end)
END;
(* pad out digits to the decimal position *)
FOR digs:=sigFigs TO place-1 DO Str.Append("0", str) END
END AppendFraction;
PROCEDURE RemoveLeadingZeros(VAR str: ARRAY OF CHAR);
VAR len: LONGINT;
BEGIN
len:=Str.Length(str);
WHILE (len>1)&(str[0]="0")&(str[1]#".") DO Str.Delete(str, 0, 1); DEC(len) END
END RemoveLeadingZeros;
PROCEDURE MaxDigit (VAR n: LInt.LongInt) : LONGINT;
VAR
i, max : LONGINT;
BEGIN
(* return the maximum digit in the specified LongInt number *)
FOR i:=0 TO LEN(n)-1 DO
IF n[i] # 0 THEN
max := n[i];
WHILE max>=10 DO max:=max DIV 10 END;
RETURN max;
END;
END;
RETURN 0;
END MaxDigit;
PROCEDURE Scale (x: LONGREAL; VAR n: LInt.LongInt; sigFigs: INTEGER; exp: INTEGER; VAR overflow : BOOLEAN);
CONST
MaxDigits=4; LOG2B=15;
VAR
i, m, ln, d: LONGINT; e1, e2: INTEGER;
max: LONGINT;
BEGIN
(* extract fraction & exponent *)
m:=0; overflow := FALSE;
WHILE Low.exponent(x)=Low.expoMin DO (* scale up subnormal numbers *)
x:=x*2.0D0; DEC(m)
END;
m:=m+Low.exponent(x); x:=Low.fraction(x);
x:=Low.scale(x, SHORT(m MOD LOG2B)); (* scale up the number *)
m:=m DIV LOG2B; (* base B exponent *)
(* convert to an extended integer MOD B *)
ln:=LEN(n)-1;
FOR i:=ln-MaxDigits TO ln DO
n[i]:=SHORT(ENTIER(x)); (* convert/store the number *)
x:=(x-n[i])*B
END;
FOR i:=0 TO ln-MaxDigits-1 DO n[i]:=0 END; (* zero the other digits *)
(* scale to get the number of significant digits *)
e1:=SHORT(m)-MaxDigits; e2:= sigFigs-exp-1;
IF e1>=0 THEN
LInt.BPower(n, e1+1); LInt.TenPower(n, e2);
max := MaxDigit(n); (* remember the original digit so we can check for round-up *)
LInt.AddDigit(n, B DIV 2); LInt.DivDigit(n, B, d) (* round *)
ELSIF e2>0 THEN
LInt.TenPower(n, e2);
IF e1>0 THEN LInt.BPower(n, e1-1) ELSE LInt.BPower(n, e1+1) END;
max := MaxDigit(n); (* remember the original digit so we can check for round-up *)
LInt.AddDigit(n, B DIV 2); LInt.DivDigit(n, B, d) (* round *)
ELSE (* e1<=0, e2<=0 *)
LInt.TenPower(n, e2); LInt.BPower(n, e1+1);
max := MaxDigit(n); (* remember the original digit so we can check for round-up *)
LInt.AddDigit(n, B DIV 2); LInt.DivDigit(n, B, d) (* round *)
END;
(* check if the upper digit was changed by rounding up *)
IF (max = 9) & (max # MaxDigit(n)) THEN
overflow := TRUE;
END
END Scale;
PROCEDURE RealToFloat*(real: LONGREAL; sigFigs: INTEGER; VAR str: ARRAY OF CHAR);
(*
The call RealToFloat(real,sigFigs,str) shall assign to `str' the
possibly truncated string corresponding to the value of `real' in
floating-point form. A sign shall be included only for negative
values. One significant digit shall be included in the whole number
part. The signed exponent part shall be included only if the exponent
value is not 0. If the value of `sigFigs' is greater than 0, that
number of significant digits shall be included, otherwise an
implementation-defined number of significant digits shall be
included. The decimal point shall not be included if there are no
significant digits in the fractional part.
For example:
value: 3923009 39.23009 0.0003923009
sigFigs
1 4E+6 4E+1 4E-4
2 3.9E+6 3.9E+1 3.9E-4
5 3.9230E+6 3.9230E+1 3.9230E-4
*)
VAR
exp: INTEGER; in: LInt.LongInt;
lstr: ARRAY 64 OF CHAR;
overflow: BOOLEAN;
d: LONGINT;
BEGIN
(* set significant digits, extract sign & exponent *)
lstr:="";
IF sigFigs<=0 THEN sigFigs:=RC.SigFigs END;
(* check for illegal numbers *)
IF Low.IsNaN(real) THEN COPY("NaN", str); RETURN END;
IF real<ZERO THEN Str.Append("-", lstr); real:=-real END;
IF Low.IsInfinity(real) THEN Str.Append("Infinity", lstr); COPY(lstr, str); RETURN END;
exp:=Low.exponent10(real);
(* round the number and extract exponent again *)
Scale(real, in, sigFigs, exp, overflow);
IF overflow THEN
IF exp>=0 THEN INC(exp) ELSE DEC(exp) END;
LInt.DivDigit(in, 10, d)
END;
(* output number like x[.{x}][E+n[n]] *)
AppendFraction(in, sigFigs, 1, lstr);
IF exp#0 THEN AppendExponent(exp, lstr) END;
(* possibly truncate the result *)
COPY(lstr, str)
END RealToFloat;
PROCEDURE RealToEng*(real: LONGREAL; sigFigs: INTEGER; VAR str: ARRAY OF CHAR);
(*
Converts the value of real to floating-point string form, with
sigFigs significant figures, and copies the possibly truncated
result to str. The number is scaled with one to three digits in
the whole number part and with an exponent that is a multiple of
three.
For example:
value: 3923009 39.23009 0.0003923009
sigFigs
1 4E+6 40 400E-6
2 3.9E+6 39 390E-6
5 3.9230E+6 39.230 392.30E-6
*)
VAR
in: LInt.LongInt; exp, offset: INTEGER;
lstr: ARRAY 64 OF CHAR;
d: LONGINT;
overflow: BOOLEAN;
BEGIN
(* set significant digits, extract sign & exponent *)
lstr:="";
IF sigFigs<=0 THEN sigFigs:=RC.SigFigs END;
(* check for illegal numbers *)
IF Low.IsNaN(real) THEN COPY("NaN", str); RETURN END;
IF real<ZERO THEN Str.Append("-", lstr); real:=-real END;
IF Low.IsInfinity(real) THEN Str.Append("Infinity", lstr); COPY(lstr, str); RETURN END;
exp:=Low.exponent10(real);
(* round the number and extract exponent again (ie. 9.9 => 10.0) *)
Scale(real, in, sigFigs, exp, overflow);
IF overflow THEN
IF exp>=0 THEN INC(exp) ELSE DEC(exp) END;
LInt.DivDigit(in, 10, d)
END;
(* find the offset to make the exponent a multiple of three *)
offset:=exp MOD 3;
(* output number like x[x][x][.{x}][E+n[n]] *)
AppendFraction(in, sigFigs, offset+1, lstr);
exp:=exp-offset;
IF exp#0 THEN AppendExponent(exp, lstr) END;
(* possibly truncate the result *)
COPY(lstr, str)
END RealToEng;
PROCEDURE RealToFixed*(real: LONGREAL; place: INTEGER; VAR str: ARRAY OF CHAR);
(*
The call RealToFixed(real,place,str) shall assign to `str' the
possibly truncated string corresponding to the value of `real' in
fixed-point form. A sign shall be included only for negative values.
At least one digit shall be included in the whole number part. The
value shall be rounded to the given value of `place' relative to the
decimal point. The decimal point shall be suppressed if `place' is
less than 0.
For example:
value: 3923009 3.923009 0.0003923009
sigFigs
-5 3920000 0 0
-2 3923010 0 0
-1 3923009 4 0
0 3923009. 4. 0.
1 3923009.0 3.9 0.0
4 3923009.0000 3.9230 0.0004
*)
VAR
in: LInt.LongInt; exp, digs: INTEGER;
overflow, addDecPt: BOOLEAN;
lstr: ARRAY 256 OF CHAR;
BEGIN
(* set significant digits, extract sign & exponent *)
lstr:=""; addDecPt:=place=0;
(* check for illegal numbers *)
IF Low.IsNaN(real) THEN COPY("NaN", str); RETURN END;
IF real<ZERO THEN Str.Append("-", lstr); real:=-real END;
IF Low.IsInfinity(real) THEN Str.Append("Infinity", lstr); COPY(lstr, str); RETURN END;
exp:=Low.exponent10(real);
IF place<0 THEN digs:=place+exp+2 ELSE digs:=place+exp+1 END;
(* round the number and extract exponent again (ie. 9.9 => 10.0) *)
Scale(real, in, digs, exp, overflow);
IF overflow THEN
INC(digs); INC(exp);
addDecPt := place=0;
END;
(* output number like x[{x}][.{x}] *)
IF exp<0 THEN
IF place<0 THEN AppendFraction(in, 1, 1, lstr)
ELSE AppendFraction(in, place+1, 1, lstr)
END
ELSE AppendFraction(in, digs, exp+1, lstr);
RemoveLeadingZeros(lstr)
END;
(* special formatting *)
IF addDecPt THEN Str.Append(".", lstr) END;
(* possibly truncate the result *)
COPY(lstr, str)
END RealToFixed;
PROCEDURE RealToStr*(real: LONGREAL; VAR str: ARRAY OF CHAR);
(*
If the sign and magnitude of `real' can be shown within the capacity
of `str', the call RealToStr(real,str) shall behave as the call
RealToFixed(real,place,str), with a value of `place' chosen to fill
exactly the remainder of `str'. Otherwise, the call shall behave as
the call RealToFloat(real,sigFigs,str), with a value of `sigFigs' of
at least one, but otherwise limited to the number of significant
digits that can be included together with the sign and exponent part
in `str'.
*)
VAR
cap, exp, fp, len, pos: INTEGER;
found: BOOLEAN;
BEGIN
cap:=SHORT(LEN(str))-1; (* determine the capacity of the string with space for trailing 0X *)
(* check for illegal numbers *)
IF Low.IsNaN(real) THEN COPY("NaN", str); RETURN END;
IF real<ZERO THEN COPY("-", str); fp:=-1 ELSE COPY("", str); fp:=0 END;
IF Low.IsInfinity(ABS(real)) THEN Str.Append("Infinity", str); RETURN END;
(* extract exponent *)
exp:=Low.exponent10(real);
(* format number *)
INC(fp, RC.SigFigs-exp-2);
len:=RC.LengthFixedReal(real, fp);
IF cap>=len THEN
RealToFixed(real, fp, str);
(* pad with remaining zeros *)
IF fp<0 THEN Str.Append(".", str); INC(len) END; (* add decimal point *)
WHILE len<cap DO Str.Append("0", str); INC(len) END
ELSE
fp:=RC.LengthFloatReal(real, RC.SigFigs); (* check actual length *)
IF fp<=cap THEN
RealToFloat(real, RC.SigFigs, str);
(* pad with remaining zeros *)
Str.FindNext("E", str, 2, found, pos);
WHILE fp<cap DO Str.Insert("0", pos, str); INC(fp) END
ELSE fp:=RC.SigFigs-fp+cap;
IF fp<1 THEN fp:=1 END;
RealToFloat(real, fp, str)
END
END
END RealToStr;
END oocLRealStr.

101
src/library/ooc/oocLongInts.Mod Normal file
View file

@ -0,0 +1,101 @@
(* $Id: LongInts.Mod,v 1.3 1999/09/02 13:14:52 acken Exp $ *)
MODULE oocLongInts;
(*
LongInts - Simple extended integer implementation.
Copyright (C) 1996 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
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
*)
CONST
B*=8000H;
TYPE
LongInt*=ARRAY 170 OF INTEGER;
PROCEDURE MinDigit * (VAR w: LongInt) : LONGINT;
VAR min, l: LONGINT;
BEGIN
min:=1; l:=LEN(w)-1;
WHILE (min<l) & (w[min]=0) DO INC(min) END;
RETURN min
END MinDigit;
PROCEDURE MultDigit * (VAR w: LongInt; digit, k: LONGINT);
VAR i, t, min: LONGINT;
BEGIN
i:=LEN(w)-1; min:=MinDigit(w)-2;
REPEAT
t:=w[i]*digit+k; (* multiply *)
w[i]:=SHORT(t MOD B); k:=t DIV B; (* generate result & carry *)
DEC(i)
UNTIL i=min
END MultDigit;
PROCEDURE AddDigit * (VAR w: LongInt; k: LONGINT);
VAR i, t, min: LONGINT;
BEGIN
i:=LEN(w)-1; min:=MinDigit(w)-2;
REPEAT
t:=w[i]+k; (* add *)
w[i]:=SHORT(t MOD B); k:=t DIV B; (* generate result & carry *)
DEC(i)
UNTIL i=min
END AddDigit;
PROCEDURE DivDigit * (VAR w: LongInt; digit: LONGINT; VAR r: LONGINT);
VAR j, t, m: LONGINT;
BEGIN
j:=MinDigit(w)-1; r:=0; m:=LEN(w)-1;
REPEAT
t:=r*B+w[j];
w[j]:=SHORT(t DIV digit); r:=t MOD digit; (* generate result & remainder *)
INC(j)
UNTIL j>m
END DivDigit;
PROCEDURE TenPower * (VAR x: LongInt; power: INTEGER);
VAR exp, i: INTEGER; d: LONGINT;
BEGIN
IF power>0 THEN
exp:=power DIV 4; power:=power MOD 4;
FOR i:=1 TO exp DO MultDigit(x, 10000, 0) END;
FOR i:=1 TO power DO MultDigit(x, 10, 0) END
ELSIF power<0 THEN
power:=-power;
exp:=power DIV 4; power:=power MOD 4;
FOR i:=1 TO exp DO DivDigit(x, 10000, d) END;
FOR i:=1 TO power DO DivDigit(x, 10, d) END
END
END TenPower;
PROCEDURE BPower * (VAR x: LongInt; power: INTEGER);
VAR i, lx: LONGINT;
BEGIN
lx:=LEN(x);
IF power>0 THEN
FOR i:=1 TO lx-1-power DO x[i]:=x[i+power] END;
FOR i:=lx-power TO lx-1 DO x[i]:=0 END
ELSIF power<0 THEN
power:=-power;
FOR i:=lx-1-power TO 1 BY -1 DO x[i+power]:=x[i] END;
FOR i:=1 TO power DO x[i]:=0 END
END
END BPower;
END oocLongInts.

484
src/library/ooc/oocLowLReal.Mod Normal file
View file

@ -0,0 +1,484 @@
(* $Id: LowLReal.Mod,v 1.6 1999/09/02 13:15:35 acken Exp $ *)
MODULE oocLowLReal;
(*
LowLReal - Gives access to the underlying properties of the type LONGREAL
for IEEE double-precision numbers.
Copyright (C) 1996 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
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 Low := oocLowReal, S := SYSTEM;
(*
Real number properties are defined as follows:
radix--The whole number value of the radix used to represent the
corresponding read number values.
places--The whole number value of the number of radix places used
to store values of the corresponding real number type.
expoMin--The whole number value of the exponent minimum.
expoMax--The whole number value of the exponent maximum.
large--The largest value of the corresponding real number type.
small--The smallest positive value of the corresponding real number
type, represented to maximal precision.
IEC559--A Boolean value that is TRUE if and only if the implementation
of the corresponding real number type conforms to IEC 559:1989
(IEEE 754:1987) in all regards.
NOTES
6 -- If `IEC559' is TRUE, the value of `radix' is 2.
7 -- If LowReal.IEC559 is TRUE, the 32-bit format of IEC 559:1989
is used for the type REAL.
7 -- If LowLong.IEC559 is TRUE, the 64-bit format of IEC 559:1989
is used for the type REAL.
LIA1--A Boolean value that is TRUE if and only if the implementation of
the corresponding real number type conforms to ISO/IEC 10967-1:199x
(LIA-1) in all regards: parameters, arithmetic, exceptions, and
notification.
rounds--A Boolean value that is TRUE if and only if each operation produces
a result that is one of the values of the corresponding real number
type nearest to the mathematical result.
gUnderflow--A Boolean value that is TRUE if and only if there are values of
the corresponding real number type between 0.0 and `small'.
exception--A Boolean value that is TRUE if and only if every operation that
attempts to produce a real value out of range raises an exception.
extend--A Boolean value that is TRUE if and only if expressions of the
corresponding real number type are computed to higher precision than
the stored values.
nModes--The whole number value giving the number of bit positions needed for
the status flags for mode control.
*)
CONST
radix*= 2;
places*= 53;
expoMax*= 1023;
expoMin*= 1-expoMax;
large*= MAX(LONGREAL); (*1.7976931348623157D+308;*) (* MAX(LONGREAL) *)
(*small*= 2.2250738585072014D-308;*)
small*= 2.2250738585072014/9.9999999999999981D307(*/10^308)*);
IEC559*= TRUE;
LIA1*= FALSE;
rounds*= FALSE;
gUnderflow*= TRUE; (* there are IEEE numbers smaller than `small' *)
exception*= FALSE; (* at least in the default implementation *)
extend*= FALSE;
nModes*= 0;
ONE=1.0D0; (* some commonly-used constants *)
ZERO=0.0D0;
TEN=1.0D1;
DEBUG = TRUE;
expOffset=expoMax;
hiBit=19;
expBit=hiBit+1;
nMask={0..hiBit,31}; (* number mask *)
expMask={expBit..30}; (* exponent mask *)
TYPE
Modes*= SET;
LongInt=ARRAY 2 OF LONGINT;
LongSet=ARRAY 2 OF SET;
VAR
(*sml* : LONGREAL; tmp: LONGREAL;*) (* this was a test to get small as a variable at runtime. obviously, compile time preferred; -- noch *)
isBigEndian-: BOOLEAN; (* set when target is big endian *)
(*
PROCEDURE power0(i, j : INTEGER) : LONGREAL; (* used to calculate sml at runtime; -- noch *)
VAR k : INTEGER;
p : LONGREAL;
BEGIN
k := 1;
p := i;
REPEAT
p := p * i;
INC(k);
UNTIL k=j;
RETURN p;
END power0;
*)
(* Errors are handled through the LowReal module *)
PROCEDURE err*(): INTEGER;
BEGIN
RETURN Low.err
END err;
PROCEDURE ClearError*;
BEGIN
Low.ClearError
END ClearError;
PROCEDURE ErrorHandler*(err: INTEGER);
BEGIN
Low.ErrorHandler(err)
END ErrorHandler;
(* type-casting utilities *)
PROCEDURE Move (VAR x: LONGREAL; VAR ra: ARRAY OF LONGINT);
(* typecast a LONGREAL to an array of LONGINTs *)
VAR t: LONGINT;
BEGIN
S.MOVE(S.ADR(x),S.ADR(ra),SIZE(LONGREAL));
IF ~isBigEndian THEN t:=ra[0]; ra[0]:=ra[1]; ra[1]:=t END
END Move;
PROCEDURE MoveSet (VAR x: LONGREAL; VAR ra: ARRAY OF SET);
(* typecast a LONGREAL to an array of LONGINTs *)
VAR t: SET;
BEGIN
S.MOVE(S.ADR(x),S.ADR(ra),SIZE(LONGREAL));
IF ~isBigEndian THEN t:=ra[0]; ra[0]:=ra[1]; ra[1]:=t END
END MoveSet;
(* Note: The below should be done with a type cast --
once the compiler supports such things. *)
(*<* PUSH; Warnings := FALSE *>*)
PROCEDURE Real * (ra: ARRAY OF LONGINT): LONGREAL;
(* typecast an array of big endian LONGINTs to a LONGREAL *)
VAR t: LONGINT; x: LONGREAL;
BEGIN
IF ~isBigEndian THEN t:=ra[0]; ra[0]:=ra[1]; ra[1]:=t END;
S.MOVE(S.ADR(ra),S.ADR(x),SIZE(LONGREAL));
RETURN x
END Real;
PROCEDURE ToReal (ra: ARRAY OF SET): LONGREAL;
(* typecast an array of LONGINTs to a LONGREAL *)
VAR t: SET; x: LONGREAL;
BEGIN
IF ~isBigEndian THEN t:=ra[0]; ra[0]:=ra[1]; ra[1]:=t END;
S.MOVE(S.ADR(ra),S.ADR(x),SIZE(LONGREAL));
RETURN x
END ToReal;
(*<* POP *> *)
PROCEDURE exponent*(x: LONGREAL): INTEGER;
(*
The value of the call exponent(x) shall be the exponent value of `x'
that lies between `expoMin' and `expoMax'. An exception shall occur
and may be raised if `x' is equal to 0.0.
*)
VAR ra: LongInt;
BEGIN
(* NOTE: x=0.0 should raise exception *)
IF x=ZERO THEN RETURN 0
ELSE Move(x, ra);
RETURN SHORT(S.LSH(ra[0],-expBit) MOD 2048)-expOffset
END
END exponent;
PROCEDURE exponent10*(x: LONGREAL): INTEGER;
(*
The value of the call exponent10(x) shall be the base 10 exponent
value of `x'. An exception shall occur and may be raised if `x' is
equal to 0.0.
*)
VAR exp: INTEGER;
BEGIN
IF x=ZERO THEN RETURN 0 END; (* exception could be raised here *)
exp:=0; x:=ABS(x);
WHILE x>=TEN DO x:=x/TEN; INC(exp) END;
WHILE x<1 DO x:=x*TEN; DEC(exp) END;
RETURN exp
END exponent10;
PROCEDURE fraction*(x: LONGREAL): LONGREAL;
(*
The value of the call fraction(x) shall be the significand (or
significant) part of `x'. Hence the following relationship shall
hold: x = scale(fraction(x), exponent(x)).
*)
CONST eZero={(hiBit+2)..29};
VAR ra: LongInt;
BEGIN
IF x=ZERO THEN RETURN ZERO
ELSE Move(x, ra);
ra[0]:=S.VAL(LONGINT, S.VAL(SET,ra[0])*nMask+eZero);
RETURN Real(ra)*2.0D0
END
END fraction;
PROCEDURE IsInfinity * (real: LONGREAL) : BOOLEAN;
CONST signMask={0..30};
VAR ra: LongSet;
BEGIN
MoveSet(real, ra);
RETURN (ra[0]*signMask=expMask) & (ra[1]={})
END IsInfinity;
PROCEDURE IsNaN * (real: LONGREAL) : BOOLEAN;
CONST fracMask={0..hiBit};
VAR ra: LongSet;
BEGIN
MoveSet(real, ra);
RETURN (ra[0]*expMask=expMask) & ((ra[1]#{}) OR (ra[0]*fracMask#{}))
END IsNaN;
PROCEDURE sign*(x: LONGREAL): LONGREAL;
(*
The value of the call sign(x) shall be 1.0 if `x' is greater than 0.0,
or shall be -1.0 if `x' is less than 0.0, or shall be either 1.0 or
-1.0 if `x' is equal to 0.0.
*)
BEGIN
IF x<ZERO THEN RETURN -ONE ELSE RETURN ONE END
END sign;
PROCEDURE scale*(x: LONGREAL; n: INTEGER): LONGREAL;
(*
The value of the call scale(x,n) shall be the value x*radix^n if such
a value exists; otherwise an exception shall occur and may be raised.
*)
VAR exp: LONGINT; lexp: SET; ra: LongInt;
BEGIN
IF x=ZERO THEN RETURN ZERO END; (* can't scale zero *)
exp:= exponent(x)+n; (* new exponent *)
IF exp>expoMax THEN RETURN large*sign(x) (* exception raised here *)
ELSIF exp<expoMin THEN RETURN small*sign(x) (* exception here as well *)
END;
lexp:=S.VAL(SET,S.LSH(exp+expOffset,expBit)); (* shifted exponent bits *)
Move(x, ra);
ra[0]:=S.VAL(LONGINT, S.VAL(SET,ra[0])*nMask+lexp); (* insert new exponent *)
RETURN Real(ra)
END scale;
PROCEDURE ulp*(x: LONGREAL): LONGREAL;
(*
The value of the call ulp(x) shall be the value of the corresponding
real number type equal to a unit in the last place of `x', if such a
value exists; otherwise an exception shall occur and may be raised.
*)
BEGIN
RETURN scale(ONE, exponent(x)-places+1)
END ulp;
PROCEDURE succ*(x: LONGREAL): LONGREAL;
(*
The value of the call succ(x) shall be the next value of the
corresponding real number type greater than `x', if such a type
exists; otherwise an exception shall occur and may be raised.
*)
BEGIN
RETURN x+ulp(x)*sign(x)
END succ;
PROCEDURE pred*(x: LONGREAL): LONGREAL;
(*
The value of the call pred(x) shall be the next value of the
corresponding real number type less than `x', if such a type exists;
otherwise an exception shall occur and may be raised.
*)
BEGIN
RETURN x-ulp(x)*sign(x)
END pred;
PROCEDURE MaskReal(x: LONGREAL; lo: INTEGER): LONGREAL;
VAR ra: LongSet;
BEGIN
MoveSet(x, ra); (* type-cast into sets for masking *)
IF lo<32 THEN ra[1]:=ra[1]*{lo..31} (* just need to mask lower word *)
ELSE ra[0]:=ra[0]*{lo-32..31}; ra[1]:={} (* mask upper word & clear lower word *)
END;
RETURN ToReal(ra)
END MaskReal;
PROCEDURE intpart*(x: LONGREAL): LONGREAL;
(*
The value of the call intpart(x) shall be the integral part of `x'.
For negative values, this shall be -intpart(abs(x)).
*)
VAR lo, hi: INTEGER;
BEGIN hi:=hiBit+32; (* account for low 32-bits as well *)
lo:=(hi+1)-exponent(x);
IF lo<=0 THEN RETURN x (* no fractional part *)
ELSIF lo<=hi+1 THEN RETURN MaskReal(x, lo) (* integer part is extracted *)
ELSE RETURN 0 (* no whole part *)
END
END intpart;
PROCEDURE fractpart*(x: LONGREAL): LONGREAL;
(*
The value of the call fractpart(x) shall be the fractional part of
`x'. This satifies the relationship fractpart(x)+intpart(x)=x.
*)
BEGIN
RETURN x-intpart(x)
END fractpart;
PROCEDURE trunc*(x: LONGREAL; n: INTEGER): LONGREAL;
(*
The value of the call trunc(x,n) shall be the value of the most
significant `n' places of `x'. An exception shall occur and may be
raised if `n' is less than or equal to zero.
*)
VAR loBit: INTEGER;
BEGIN loBit:=places-n;
IF n<=0 THEN RETURN ZERO (* exception should be raised *)
ELSIF loBit<=0 THEN RETURN x (* nothing was truncated *)
ELSE RETURN MaskReal(x, loBit) (* clear all lower bits *)
END
END trunc;
PROCEDURE In (bit: INTEGER; x: LONGREAL): BOOLEAN;
VAR ra: LongSet;
BEGIN
MoveSet(x, ra); (* type-cast into sets for masking *)
IF bit<32 THEN RETURN bit IN ra[1] (* check bit in lower word *)
ELSE RETURN bit-32 IN ra[0] (* check bit in upper word *)
END
END In;
PROCEDURE round*(x: LONGREAL; n: INTEGER): LONGREAL;
(*
The value of the call round(x,n) shall be the value of `x' rounded to
the most significant `n' places. An exception shall occur and may be
raised if such a value does not exist, or if `n' is less than or equal
to zero.
*)
VAR loBit: INTEGER; t, r: LONGREAL;
BEGIN loBit:=places-n;
IF n<=0 THEN RETURN ZERO (* exception should be raised *)
ELSIF loBit<=0 THEN RETURN x (* nothing was rounded *)
ELSE t:=MaskReal(x, loBit); (* truncated result *)
IF In(loBit-1, x) THEN (* check if result should be rounded *)
r:=scale(ONE,exponent(x)-n+1); (* rounding fraction *)
IF In(31+32, x) THEN RETURN t-r (* negative rounding toward -infinity *)
ELSE RETURN t+r (* positive rounding toward +infinity *)
END
ELSE RETURN t (* return truncated result *)
END
END
END round;
PROCEDURE synthesize*(expart: INTEGER; frapart: LONGREAL): LONGREAL;
(*
The value of the call synthesize(expart,frapart) shall be a value of
the corresponding real number type contructed from the value of
`expart' and `frapart'. This value shall satisfy the relationship
synthesize(exponent(x),fraction(x)) = x.
*)
BEGIN
RETURN scale(frapart, expart)
END synthesize;
PROCEDURE setMode*(m: Modes);
(*
The call setMode(m) shall set status flags from the value of `m',
appropriate to the underlying implementation of the corresponding real
number type.
NOTES
3 -- Many implementations of floating point provide options for
setting flags within the system which control details of the handling
of the type. Although two procedures are provided, one for each real
number type, the effect may be the same. Typical effects that can be
obtained by this means are:
a) Ensuring that overflow will raise an exception;
b) Allowing underflow to raise an exception;
c) Controlling the rounding;
d) Allowing special values to be produced (e.g. NaNs in
implementations conforming to IEC 559:1989 (IEEE 754:1987));
e) Ensuring that special valu access will raise an exception;
Since these effects are so varied, the values of type `Modes' that may
be used are not specified by this International Standard.
4 -- The effects of `setMode' on operation on values of the
corresponding real number type in coroutines other than the calling
coroutine is not defined. Implementations are not require to preserve
the status flags (if any) with the coroutine state.
*)
BEGIN
(* hardware dependent mode setting of coprocessor *)
END setMode;
PROCEDURE currentMode*(): Modes;
(*
The value of the call currentMode() shall be the current status flags
(in the form set by `setMode'), or the default status flags (if
`setMode' is not used).
NOTE 5 -- The value of the call currentMode() is not necessarily the
value of set by `setMode', since a call of `setMode' might attempt to
set flags that cannot be set by the program.
*)
BEGIN
RETURN {}
END currentMode;
PROCEDURE IsLowException*(): BOOLEAN;
(* Returns TRUE if the current coroutine is in the exceptional execution state
because of the raising of the LowReal exception; otherwise returns FALSE.
*)
BEGIN
RETURN FALSE
END IsLowException;
PROCEDURE InitEndian;
VAR endianTest: INTEGER; c: CHAR;
BEGIN
endianTest:=1;
S.GET(S.ADR(endianTest), c);
isBigEndian:=c#1X
END InitEndian;
PROCEDURE Test;
CONST n1=1.234D39; n2=-1.23343D-20; n3=123.456;
VAR n: LONGREAL; exp: INTEGER;
BEGIN
exp:=exponent(n1); exp:=exponent(n2);
n:=fraction(n1); n:=fraction(n2);
n:=scale(ONE, -8); n:=scale(ONE, 8);
n:=succ(10);
n:=intpart(n3);
n:=trunc(n3, 5); (* n=120 *)
n:=trunc(n3, 7); (* n=123 *)
n:=trunc(n3, 12); (* n=123.4375 *)
n:=round(n3, 5); (* n=124 *)
n:=round(n3, 7); (* n=123 *)
n:=round(n3, 12); (* n=123.46875 *)
END Test;
BEGIN
InitEndian; (* check whether target is big endian *)
(*
tmp := power0(10,308); (* this is test to calculate small as a variable at runtime; -- noch *)
sml := 2.2250738585072014/tmp;
sml := 2.2250738585072014/power0(10, 308);
*)
IF DEBUG THEN Test END
END oocLowLReal.

387
src/library/ooc/oocLowReal.Mod Normal file
View file

@ -0,0 +1,387 @@
(* $Id: LowReal.Mod,v 1.5 1999/09/02 13:17:38 acken Exp $ *)
MODULE oocLowReal;
(*
LowReal - Gives access to the underlying properties of the type REAL
for IEEE single-precision numbers.
Copyright (C) 1995 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
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 S := SYSTEM, Console;
(*
Real number properties are defined as follows:
radix--The whole number value of the radix used to represent the
corresponding read number values.
places--The whole number value of the number of radix places used
to store values of the corresponding real number type.
expoMin--The whole number value of the exponent minimum.
expoMax--The whole number value of the exponent maximum.
large--The largest value of the corresponding real number type.
small--The smallest positive value of the corresponding real number
type, represented to maximal precision.
IEC559--A Boolean value that is TRUE if and only if the implementation
of the corresponding real number type conforms to IEC 559:1989
(IEEE 754:1987) in all regards.
NOTES
6 -- If `IEC559' is TRUE, the value of `radix' is 2.
7 -- If LowReal.IEC559 is TRUE, the 32-bit format of IEC 559:1989
is used for the type REAL.
7 -- If LowLong.IEC559 is TRUE, the 64-bit format of IEC 559:1989
is used for the type REAL.
LIA1--A Boolean value that is TRUE if and only if the implementation of
the corresponding real number type conforms to ISO/IEC 10967-1:199x
(LIA-1) in all regards: parameters, arithmetic, exceptions, and
notification.
rounds--A Boolean value that is TRUE if and only if each operation produces
a result that is one of the values of the corresponding real number
type nearest to the mathematical result.
gUnderflow--A Boolean value that is TRUE if and only if there are values of
the corresponding real number type between 0.0 and `small'.
exception--A Boolean value that is TRUE if and only if every operation that
attempts to produce a real value out of range raises an exception.
extend--A Boolean value that is TRUE if and only if expressions of the
corresponding real number type are computed to higher precision than
the stored values.
nModes--The whole number value giving the number of bit positions needed for
the status flags for mode control.
*)
CONST
radix*= 2;
places*= 24;
expoMax*= 127;
expoMin*= 1-expoMax;
large*= MAX(REAL);(*3.40282347E+38;*) (* MAX(REAL) *)
(*small*= 1.17549435E-38; (* 2^(-126) *)*)
small* = 1/8.50705917E37; (* don't know better way; -- noch *)
IEC559*= TRUE;
LIA1*= FALSE;
rounds*= FALSE;
gUnderflow*= TRUE; (* there are IEEE numbers smaller than `small' *)
exception*= FALSE; (* at least in the default implementation *)
extend*= FALSE;
nModes*= 0;
TEN=10.0; (* some commonly-used constants *)
ONE=1.0;
ZERO=0.0;
expOffset=expoMax;
hiBit=22;
expBit=hiBit+1;
nMask={0..hiBit,31}; (* number mask *)
expMask={expBit..30}; (* exponent mask *)
TYPE
Modes*= SET;
VAR
(*small* : REAL; tmp: REAL;*) (* this was a test to get small as a variable at runtime. obviously, compile time preferred; -- noch *)
ErrorHandler*: PROCEDURE (errno : INTEGER);
err-: INTEGER;
(* Error handler default stub which can be replaced *)
(* PROCEDURE power0(i, j : INTEGER) : REAL; (* used to calculate sml at runtime; -- noch *)
VAR k : INTEGER;
p : REAL;
BEGIN
k := 1;
p := i;
REPEAT
p := p * i;
INC(k);
UNTIL k=j;
RETURN p;
END power0;*)
PROCEDURE DefaultHandler (errno : INTEGER);
BEGIN
err:=errno
END DefaultHandler;
PROCEDURE ClearError*;
BEGIN
err:=0
END ClearError;
PROCEDURE exponent*(x: REAL): INTEGER;
(*
The value of the call exponent(x) shall be the exponent value of `x'
that lies between `expoMin' and `expoMax'. An exception shall occur
and may be raised if `x' is equal to 0.0.
*)
BEGIN
(* NOTE: x=0.0 should raise exception *)
IF x=ZERO THEN RETURN 0
ELSE RETURN SHORT(S.LSH(S.VAL(LONGINT,x),-expBit) MOD 256)-expOffset
END
END exponent;
PROCEDURE exponent10*(x: REAL): INTEGER;
(*
The value of the call exponent10(x) shall be the base 10 exponent
value of `x'. An exception shall occur and may be raised if `x' is
equal to 0.0.
*)
VAR exp: INTEGER;
BEGIN
exp:=0; x:=ABS(x);
IF x=ZERO THEN RETURN exp END; (* exception could be raised here *)
WHILE x>=TEN DO x:=x/TEN; INC(exp) END;
WHILE (x>ZERO) & (x<1.0) DO x:=x*TEN; DEC(exp) END;
RETURN exp
END exponent10;
PROCEDURE fraction*(x: REAL): REAL;
(*
The value of the call fraction(x) shall be the significand (or
significant) part of `x'. Hence the following relationship shall
hold: x = scale(fraction(x), exponent(x)).
*)
CONST eZero={(hiBit+2)..29};
BEGIN
IF x=ZERO THEN RETURN ZERO
ELSE RETURN S.VAL(REAL,(S.VAL(SET,x)*nMask)+eZero)*2.0 (* set the mantissa's exponent to zero *)
END
END fraction;
PROCEDURE IsInfinity * (real: REAL) : BOOLEAN;
CONST signMask={0..30};
BEGIN
RETURN S.VAL(SET,real)*signMask=expMask
END IsInfinity;
PROCEDURE IsNaN * (real: REAL) : BOOLEAN;
CONST fracMask={0..hiBit};
VAR sreal: SET;
BEGIN
sreal:=S.VAL(SET, real);
RETURN (sreal*expMask=expMask) & (sreal*fracMask#{})
END IsNaN;
PROCEDURE sign*(x: REAL): REAL;
(*
The value of the call sign(x) shall be 1.0 if `x' is greater than 0.0,
or shall be -1.0 if `x' is less than 0.0, or shall be either 1.0 or
-1.0 if `x' is equal to 0.0.
*)
BEGIN
IF x<ZERO THEN RETURN -ONE ELSE RETURN ONE END
END sign;
PROCEDURE scale*(x: REAL; n: INTEGER): REAL;
(*
The value of the call scale(x,n) shall be the value x*radix^n if such
a value exists; otherwise an execption shall occur and may be raised.
*)
VAR exp: LONGINT; lexp: SET;
BEGIN
IF x=ZERO THEN RETURN ZERO END;
exp:= exponent(x)+n; (* new exponent *)
IF exp>expoMax THEN RETURN large*sign(x) (* exception raised here *)
ELSIF exp<expoMin THEN RETURN small*sign(x) (* exception here as well *)
END;
lexp:=S.VAL(SET,S.LSH(exp+expOffset,expBit)); (* shifted exponent bits *)
RETURN S.VAL(REAL,(S.VAL(SET,x)*nMask)+lexp) (* insert new exponent *)
END scale;
PROCEDURE ulp*(x: REAL): REAL;
(*
The value of the call ulp(x) shall be the value of the corresponding
real number type equal to a unit in the last place of `x', if such a
value exists; otherwise an exception shall occur and may be raised.
*)
BEGIN
RETURN scale(ONE, exponent(x)-places+1)
END ulp;
PROCEDURE succ*(x: REAL): REAL;
(*
The value of the call succ(x) shall be the next value of the
corresponding real number type greater than `x', if such a type
exists; otherwise an exception shall occur and may be raised.
*)
BEGIN
RETURN x+ulp(x)*sign(x)
END succ;
PROCEDURE pred*(x: REAL): REAL;
(*
The value of the call pred(x) shall be the next value of the
corresponding real number type less than `x', if such a type exists;
otherwise an exception shall occur and may be raised.
*)
BEGIN
RETURN x-ulp(x)*sign(x)
END pred;
PROCEDURE intpart*(x: REAL): REAL;
(*
The value of the call intpart(x) shall be the integral part of `x'.
For negative values, this shall be -intpart(abs(x)).
*)
VAR loBit: INTEGER;
BEGIN
loBit:=(hiBit+1)-exponent(x);
IF loBit<=0 THEN RETURN x (* no fractional part *)
ELSIF loBit<=hiBit+1 THEN
RETURN S.VAL(REAL,S.VAL(SET,x)*{loBit..31}) (* integer part is extracted *)
ELSE RETURN ZERO (* no whole part *)
END
END intpart;
PROCEDURE fractpart*(x: REAL): REAL;
(*
The value of the call fractpart(x) shall be the fractional part of
`x'. This satifies the relationship fractpart(x)+intpart(x)=x.
*)
BEGIN
RETURN x-intpart(x)
END fractpart;
PROCEDURE trunc*(x: REAL; n: INTEGER): REAL;
(*
The value of the call trunc(x,n) shall be the value of the most
significant `n' places of `x'. An exception shall occur and may be
raised if `n' is less than or equal to zero.
*)
VAR loBit: INTEGER; mask: SET;
BEGIN loBit:=places-n;
IF n<=0 THEN RETURN ZERO (* exception should be raised *)
ELSIF loBit<=0 THEN RETURN x (* nothing was truncated *)
ELSE mask:={loBit..31}; (* truncation bit mask *)
RETURN S.VAL(REAL,S.VAL(SET,x)*mask)
END
END trunc;
PROCEDURE round*(x: REAL; n: INTEGER): REAL;
(*
The value of the call round(x,n) shall be the value of `x' rounded to
the most significant `n' places. An exception shall occur and may be
raised if such a value does not exist, or if `n' is less than or equal
to zero.
*)
VAR loBit: INTEGER; num, mask: SET; r: REAL;
BEGIN loBit:=places-n;
IF n<=0 THEN RETURN ZERO (* exception should be raised *)
ELSIF loBit<=0 THEN RETURN x (* nothing was rounded *)
ELSE mask:={loBit..31}; num:=S.VAL(SET,x); (* truncation bit mask and number as SET *)
x:=S.VAL(REAL,num*mask); (* truncated result *)
IF loBit-1 IN num THEN (* check if result should be rounded *)
r:=scale(ONE,exponent(x)-n+1); (* rounding fraction *)
IF 31 IN num THEN RETURN x-r (* negative rounding toward -infinity *)
ELSE RETURN x+r (* positive rounding toward +infinity *)
END
ELSE RETURN x (* return truncated result *)
END
END
END round;
PROCEDURE synthesize*(expart: INTEGER; frapart: REAL): REAL;
(*
The value of the call synthesize(expart,frapart) shall be a value of
the corresponding real number type contructed from the value of
`expart' and `frapart'. This value shall satisfy the relationship
synthesize(exponent(x),fraction(x)) = x.
*)
BEGIN
RETURN scale(frapart, expart)
END synthesize;
PROCEDURE setMode*(m: Modes);
(*
The call setMode(m) shall set status flags from the value of `m',
appropriate to the underlying implementation of the corresponding real
number type.
NOTES
3 -- Many implementations of floating point provide options for
setting flags within the system which control details of the handling
of the type. Although two procedures are provided, one for each real
number type, the effect may be the same. Typical effects that can be
obtained by this means are:
a) Ensuring that overflow will raise an exception;
b) Allowing underflow to raise an exception;
c) Controlling the rounding;
d) Allowing special values to be produced (e.g. NaNs in
implementations conforming to IEC 559:1989 (IEEE 754:1987));
e) Ensuring that special valu access will raise an exception;
Since these effects are so varied, the values of type `Modes' that may
be used are not specified by this International Standard.
4 -- The effects of `setMode' on operation on values of the
corresponding real number type in coroutines other than the calling
coroutine is not defined. Implementations are not require to preserve
the status flags (if any) with the coroutine state.
*)
BEGIN
(* hardware dependent mode setting of coprocessor *)
END setMode;
PROCEDURE currentMode*(): Modes;
(*
The value of the call currentMode() shall be the current status flags
(in the form set by `setMode'), or the default status flags (if
`setMode' is not used).
NOTE 5 -- The value of the call currentMode() is not necessarily the
value of set by `setMode', since a call of `setMode' might attempt to
set flags that cannot be set by the program.
*)
BEGIN
RETURN {}
END currentMode;
PROCEDURE IsLowException*(): BOOLEAN;
(*
Returns TRUE if the current coroutine is in the exceptional execution state
because of the raising of the LowReal exception; otherwise returns FALSE.
*)
BEGIN
RETURN FALSE
END IsLowException;
BEGIN
(* install the default error handler -- just sets err variable *)
ErrorHandler:=DefaultHandler;
(* tmp := power0(2,126); (* this is test to calculate small as a variable at runtime; -- noch *)
small := sml;
small := 1/power0(2,126);
*)
END oocLowReal.

552
src/library/ooc/oocMsg.Mod Normal file
View file

@ -0,0 +1,552 @@
(* $Id: Msg.Mod,v 1.11 2000/10/09 14:38:06 ooc-devel Exp $ *)
MODULE oocMsg;
(* Framework for messages (creation, expansion, conversion to text).
Copyright (C) 1999, 2000 Michael van Acken
This module is free software; you can redistribute it and/or
modify 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 OOC. If not, write to the Free Software Foundation,
59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
(**
This module combines several concepts: messages, message attributes,
message contexts, and message lists. This four aspects make this
module a little bit involved, but at the core it is actually very
simple.
The topics attributes and contexts are primarily of interest for
modules that generate messages. They determine the content of the
message, and how it can be translated into readable text. A user will
mostly be in the position of message consumer, and will be handed
filled in message objects. For a user, the typical operation will be
to convert a message into descriptive text (see methods
@oproc{Msg.GetText} and @oproc{Msg.GetLText}).
Message lists are a convenience feature for modules like parsers,
which normally do not abort after a single error message. Usually,
they try to continue their work after an error, looking for more
problems and possibly emitting more error messages.
*)
IMPORT
CharClass := oocCharClass, Strings := oocStrings, IntStr := oocIntStr;
CONST
sizeAttrName* = 128-1;
(**Maximum length of the attribute name for @oproc{InitAttribute},
@oproc{NewIntAttrib}, @oproc{NewStringAttrib}, @oproc{NewLStringAttrib},
or @oproc{NewMsgAttrib}. *)
sizeAttrReplacement* = 16*1024-1;
(**Maximum length of an attribute's replacement text. *)
TYPE (* the basic string and character types used by this module: *)
Char* = CHAR;
String* = ARRAY OF Char;
StringPtr* = POINTER TO String;
LChar* = CHAR;
LString* = ARRAY OF LChar;
LStringPtr* = POINTER TO LString;
Code* = LONGINT;
(**Identifier for a message's content. Together with the message context,
this value uniquely identifies the type of the message. *)
TYPE
Attribute* = POINTER TO AttributeDesc;
AttributeDesc* = RECORD (*[ABSTRACT]*)
(**An attribute is a @samp{(name, value)} tuple, which can be associated
with a message. When a message is tranlated into its readable version
through the @oproc{Msg.GetText} function, the value part is first
converted to some textual representation, and then inserted into the
message's text. Within a message, an attribute is uniquely identified
by its name. *)
nextAttrib-: Attribute;
(**Points to the next attribute in the message's attribute list. *)
name-: StringPtr;
(**The attribute name. Note that it is restricted to @oconst{sizeAttrName}
characters. *)
END;
TYPE
Context* = POINTER TO ContextDesc;
ContextDesc* = RECORD
(**Describes the context under which messages are converted into their
textual representation. Together, a message's context and its code
identify the message type. As a debugging aid, an identification string
can be associated with a context object (see procedure
@oproc{InitContext}). *)
id-: StringPtr;
(**The textual id associated with the context instance. See procedure
@oproc{InitContext}. *)
END;
TYPE
Msg* = POINTER TO MsgDesc;
MsgDesc* = RECORD
(**A message is an object that can be converted to human readable text and
presented to a program's user. Within the OOC library, messages are
used to store errors in the I/O modules, and the XML library uses them
to create an error list when parsing an XML document.
A message's type is uniquely identified by its context and its code.
Using these two attributes, a message can be converted to text. The
text may contain placeholders, which are filled by the textual
representation of attribute values associated with the message. *)
nextMsg-, prevMsg-: Msg;
(**Used by @otype{MsgList}. Initialized to @code{NIL}. *)
code-: Code;
(**The message code. *)
context-: Context;
(**The context in which the message was created. Within a given context,
the message code @ofield{code} uniquely identifies the message type. *)
attribList-: Attribute;
(**The list of attributes associated with the message. They are sorted by
name. *)
END;
TYPE
MsgList* = POINTER TO MsgListDesc;
MsgListDesc* = RECORD
(**A message list is an often used contruct to collect several error messages
that all refer to the same resource. For example within a parser,
multiple messages are collected before aborting processing and presenting
all messages to the user. *)
msgCount-: LONGINT;
(**The number of messages in the list. An empty list has a
@ofield{msgCount} of zero. *)
msgList-, lastMsg: Msg;
(**The error messages in the list. The messages are linked using the
fields @ofield{Msg.nextMsg} and @ofield{Msg.prevMsg}. *)
END;
TYPE (* default implementations for some commonly used message attributes: *)
IntAttribute* = POINTER TO IntAttributeDesc;
IntAttributeDesc = RECORD
(AttributeDesc)
int-: LONGINT;
END;
StringAttribute* = POINTER TO StringAttributeDesc;
StringAttributeDesc = RECORD
(AttributeDesc)
string-: StringPtr;
END;
LStringAttribute* = POINTER TO LStringAttributeDesc;
LStringAttributeDesc = RECORD
(AttributeDesc)
string-: LStringPtr;
END;
MsgAttribute* = POINTER TO MsgAttributeDesc;
MsgAttributeDesc = RECORD
(AttributeDesc)
msg-: Msg;
END;
(* Context
------------------------------------------------------------------------ *)
PROCEDURE InitContext* (context: Context; id: String);
(**The string argument @oparam{id} should describe the message context to the
programmer. It should not appear in output generated for a program's user,
or at least it should not be necessary for a user to interpret ths string to
understand the message. It is a good idea to use the module name of the
context variable for the identifier. If this is not sufficient to identify
the variable, add the variable name to the string. *)
BEGIN
NEW (context. id, Strings.Length (id)+1);
COPY (id, context. id^)
END InitContext;
PROCEDURE (context: Context) GetTemplate* (msg: Msg; VAR templ: LString);
(**Returns a template string for the message @oparam{msg}. The string may
contain attribute references. Instead of the reference @samp{$@{foo@}}, the
procedure @oproc{Msg.GetText} will insert the textual representation of the
attribute with the name @samp{foo}. The special reference
@samp{$@{MSG_CONTEXT@}} is replaced by the value of @ofield{context.id}, and
@samp{$@{MSG_CODE@}} with @ofield{msg.code}.
The default implementation returns this string:
@example
MSG_CONTEXT: $@{MSG_CONTEXT@}
MSG_CODE: $@{MSG_CODE@}
attribute_name: $@{attribute_name@}
@end example
The last line is repeated for every attribute name. The lines are separated
by @oconst{CharClass.eol}.
@precond
@oparam{msg} is not @code{NIL}.
@end precond *)
VAR
attrib: Attribute;
buffer: ARRAY sizeAttrReplacement+1 OF CHAR;
eol : ARRAY 2 OF CHAR;
BEGIN
eol := "|";
(* default implementation: the template contains the context identifier,
the error number, and the full list of attributes *)
COPY ("MSG_CONTEXT: ${MSG_CONTEXT}", templ);
Strings.Append ((*CharClass.eol*)eol, templ);
Strings.Append ("MSG_CODE: ${MSG_CODE}", templ);
Strings.Append ((*CharClass.eol*)eol, templ);
attrib := msg. attribList;
WHILE (attrib # NIL) DO
COPY (attrib. name^, buffer); (* extend to LONGCHAR *)
Strings.Append (buffer, templ);
Strings.Append (": ${", templ);
Strings.Append (buffer, templ);
Strings.Append ("}", templ);
Strings.Append ((*CharClass.eol*)eol, templ); (* CharClass.eol replaced by other symbol because generated C code with end of line symbols inside strings may not be compiled by all C compilers, and causes problems in gcc 4 with default settings. *)
attrib := attrib. nextAttrib
END
END GetTemplate;
(* Attribute Functions
------------------------------------------------------------------------ *)
PROCEDURE InitAttribute* (attr: Attribute; name: String);
(**Initializes attribute object and sets its name. *)
BEGIN
attr. nextAttrib := NIL;
NEW (attr. name, Strings.Length (name)+1);
COPY (name, attr. name^)
END InitAttribute;
PROCEDURE (attr: Attribute) (*[ABSTRACT]*) ReplacementText* (VAR text: LString);
(**Converts attribute value into some textual representation. The length of
the resulting string must not exceed @oconst{sizeAttrReplacement}
characters: @oproc{Msg.GetLText} calls this procedure with a text buffer of
@samp{@oconst{sizeAttrReplacement}+1} bytes. *)
END ReplacementText;
(* Message Functions
------------------------------------------------------------------------ *)
PROCEDURE New* (context: Context; code: Code): Msg;
(**Creates a new message object for the given context, using the specified
message code. The message's attribute list is empty. *)
VAR
msg: Msg;
BEGIN
NEW (msg);
msg. prevMsg := NIL;
msg. nextMsg := NIL;
msg. code := code;
msg. context := context;
msg. attribList := NIL;
RETURN msg
END New;
PROCEDURE (msg: Msg) SetAttribute* (attr: Attribute);
(**Appends an attribute to the message's attribute list. If an attribute of
the same name exists already, it is replaced by the new one.
@precond
@samp{Length(attr.name^)<=sizeAttrName} and @oparam{attr} has not been
attached to any other message.
@end precond *)
PROCEDURE Insert (VAR aList: Attribute; attr: Attribute);
BEGIN
IF (aList = NIL) THEN (* append to list *)
aList := attr
ELSIF (aList. name^ = attr. name^) THEN (* replace element aList *)
attr. nextAttrib := aList. nextAttrib;
aList := attr
ELSIF (aList. name^ > attr.name^) THEN (* insert element before aList *)
attr. nextAttrib := aList;
aList := attr
ELSE (* continue with next element *)
Insert (aList. nextAttrib, attr)
END
END Insert;
BEGIN
Insert (msg. attribList, attr)
END SetAttribute;
PROCEDURE (msg: Msg) GetAttribute* (name: String): Attribute;
(**Returns the attribute @oparam{name} of the message object. If no such
attribute exists, the value @code{NIL} is returned. *)
VAR
a: Attribute;
BEGIN
a := msg. attribList;
WHILE (a # NIL) & (a. name^ # name) DO
a := a. nextAttrib
END;
RETURN a
END GetAttribute;
PROCEDURE (msg: Msg) GetLText* (VAR text: LString);
(**Converts a message into a string. The basic format of the string is
determined by calling @oproc{msg.context.GetTemplate}. Then the attributes
are inserted into the template string: the placeholder string
@samp{$@{foo@}} is replaced with the textual representation of attribute.
@precond
@samp{LEN(@oparam{text}) < 2^15}
@end precond
Note: Behaviour is undefined if replacement text of attribute contains an
attribute reference. *)
VAR
attr: Attribute;
attrName: ARRAY sizeAttrName+4 OF CHAR;
insert: ARRAY sizeAttrReplacement+1 OF CHAR;
found: BOOLEAN;
pos, len: INTEGER;
num: ARRAY 48 OF CHAR;
BEGIN
msg. context. GetTemplate (msg, text);
attr := msg. attribList;
WHILE (attr # NIL) DO
COPY (attr. name^, attrName);
Strings.Insert ("${", 0, attrName);
Strings.Append ("}", attrName);
Strings.FindNext (attrName, text, 0, found, pos);
WHILE found DO
len := Strings.Length (attrName);
Strings.Delete (text, pos, len);
attr. ReplacementText (insert);
Strings.Insert (insert, pos, text);
Strings.FindNext (attrName, text, pos+Strings.Length (insert),
found, pos)
END;
attr := attr. nextAttrib
END;
Strings.FindNext ("${MSG_CONTEXT}", text, 0, found, pos);
IF found THEN
Strings.Delete (text, pos, 14);
COPY (msg. context. id^, insert);
Strings.Insert (insert, pos, text)
END;
Strings.FindNext ("${MSG_CODE}", text, 0, found, pos);
IF found THEN
Strings.Delete (text, pos, 11);
IntStr.IntToStr (msg. code, num);
COPY (num, insert);
Strings.Insert (insert, pos, text)
END
END GetLText;
PROCEDURE (msg: Msg) GetText* (VAR text: String);
(**Like @oproc{Msg.GetLText}, but the message text is truncated to ISO-Latin1
characters. All characters that are not part of ISO-Latin1 are mapped to
question marks @samp{?}. *)
VAR
buffer: ARRAY ASH(2,15)-1 OF LChar;
i: INTEGER;
BEGIN
msg. GetLText (buffer);
i := -1;
REPEAT
INC (i);
IF (buffer[i] <= 0FFX) THEN
text[i] := (*SHORT*) (buffer[i]) (* no need to short *)
ELSE
text[i] := "?"
END
UNTIL (text[i] = 0X)
END GetText;
(* Message List
------------------------------------------------------------------------ *)
PROCEDURE InitMsgList* (l: MsgList);
BEGIN
l. msgCount := 0;
l. msgList := NIL;
l. lastMsg := NIL
END InitMsgList;
PROCEDURE NewMsgList* (): MsgList;
VAR
l: MsgList;
BEGIN
NEW (l);
InitMsgList (l);
RETURN l
END NewMsgList;
PROCEDURE (l: MsgList) Append* (msg: Msg);
(**Appends the message @oparam{msg} to the list @oparam{l}.
@precond
@oparam{msg} is not part of another message list.
@end precond *)
BEGIN
msg. nextMsg := NIL;
IF (l. msgList = NIL) THEN
msg. prevMsg := NIL;
l. msgList := msg
ELSE
msg. prevMsg := l. lastMsg;
l. lastMsg. nextMsg := msg
END;
l. lastMsg := msg;
INC (l. msgCount)
END Append;
PROCEDURE (l: MsgList) AppendList* (source: MsgList);
(**Appends the messages of list @oparam{source} to @oparam{l}. Afterwards,
@oparam{source} is an empty list, and the elements of @oparam{source} can be
found at the end of the list @oparam{l}. *)
BEGIN
IF (source. msgCount # 0) THEN
IF (l. msgCount = 0) THEN
l^ := source^
ELSE (* both `source' and `l' are not empty *)
INC (l. msgCount, source. msgCount);
l. lastMsg. nextMsg := source. msgList;
source. msgList. prevMsg := l. lastMsg;
l. lastMsg := source. lastMsg;
InitMsgList (source)
END
END
END AppendList;
(* Standard Attributes
------------------------------------------------------------------------ *)
PROCEDURE NewIntAttrib* (name: String; value: LONGINT): IntAttribute;
(* pre: Length(name)<=sizeAttrName *)
VAR
attr: IntAttribute;
BEGIN
NEW (attr);
InitAttribute (attr, name);
attr. int := value;
RETURN attr
END NewIntAttrib;
PROCEDURE (msg: Msg) SetIntAttrib* (name: String; value: LONGINT);
(* pre: Length(name)<=sizeAttrName *)
BEGIN
msg. SetAttribute (NewIntAttrib (name, value))
END SetIntAttrib;
PROCEDURE (attr: IntAttribute) ReplacementText* (VAR text: LString);
VAR
num: ARRAY 48 OF CHAR;
BEGIN
IntStr.IntToStr (attr. int, num);
COPY (num, text)
END ReplacementText;
PROCEDURE NewStringAttrib* (name: String; value: StringPtr): StringAttribute;
(* pre: Length(name)<=sizeAttrName *)
VAR
attr: StringAttribute;
BEGIN
NEW (attr);
InitAttribute (attr, name);
attr. string := value;
RETURN attr
END NewStringAttrib;
PROCEDURE (msg: Msg) SetStringAttrib* (name: String; value: StringPtr);
(* pre: Length(name)<=sizeAttrName *)
BEGIN
msg. SetAttribute (NewStringAttrib (name, value))
END SetStringAttrib;
PROCEDURE (attr: StringAttribute) ReplacementText* (VAR text: LString);
BEGIN
COPY (attr. string^, text)
END ReplacementText;
PROCEDURE NewLStringAttrib* (name: String; value: LStringPtr): LStringAttribute;
(* pre: Length(name)<=sizeAttrName *)
VAR
attr: LStringAttribute;
BEGIN
NEW (attr);
InitAttribute (attr, name);
attr. string := value;
RETURN attr
END NewLStringAttrib;
PROCEDURE (msg: Msg) SetLStringAttrib* (name: String; value: LStringPtr);
(* pre: Length(name)<=sizeAttrName *)
BEGIN
msg. SetAttribute (NewLStringAttrib (name, value))
END SetLStringAttrib;
PROCEDURE (attr: LStringAttribute) ReplacementText* (VAR text: LString);
BEGIN
COPY (attr. string^, text)
END ReplacementText;
PROCEDURE NewMsgAttrib* (name: String; value: Msg): MsgAttribute;
(* pre: Length(name)<=sizeAttrName *)
VAR
attr: MsgAttribute;
BEGIN
NEW (attr);
InitAttribute (attr, name);
attr. msg := value;
RETURN attr
END NewMsgAttrib;
PROCEDURE (msg: Msg) SetMsgAttrib* (name: String; value: Msg);
(* pre: Length(name)<=sizeAttrName *)
BEGIN
msg. SetAttribute (NewMsgAttrib (name, value))
END SetMsgAttrib;
PROCEDURE (attr: MsgAttribute) ReplacementText* (VAR text: LString);
BEGIN
attr. msg. GetLText (text)
END ReplacementText;
(* Auxiliary functions
------------------------------------------------------------------------ *)
PROCEDURE GetStringPtr* (str: String): StringPtr;
(**Creates a copy of @oparam{str} on the heap and returns a pointer to it. *)
VAR
s: StringPtr;
BEGIN
NEW (s, Strings.Length (str)+1);
COPY (str, s^);
RETURN s
END GetStringPtr;
PROCEDURE GetLStringPtr* (str: LString): LStringPtr;
(**Creates a copy of @oparam{str} on the heap and returns a pointer to it. *)
VAR
s: LStringPtr;
BEGIN
NEW (s, Strings.Length (str)+1);
COPY (str, s^);
RETURN s
END GetLStringPtr;
END oocMsg.

137
src/library/ooc/oocOakMath.Mod Normal file
View file

@ -0,0 +1,137 @@
(* $Id: OakMath.Mod,v 1.1 1997/02/07 07:45:32 oberon1 Exp $ *)
MODULE oocOakMath;
IMPORT RealMath := oocRealMath;
CONST
pi* = RealMath.pi;
e* = RealMath.exp1;
PROCEDURE sqrt* (x: REAL): REAL;
(* sqrt(x) returns the square root of x, where x must be positive. *)
BEGIN
RETURN RealMath.sqrt (x)
END sqrt;
PROCEDURE power* (x, base: REAL): REAL;
(* power(x, base) returns the x to the power base. *)
BEGIN
RETURN RealMath.power (x, base)
END power;
PROCEDURE exp* (x: REAL): REAL;
(* exp(x) is the exponential of x base e. x must not be so small that this
exponential underflows nor so large that it overflows. *)
BEGIN
RETURN RealMath.exp (x)
END exp;
PROCEDURE ln* (x: REAL): REAL;
(* ln(x) returns the natural logarithm (base e) of x. *)
BEGIN
RETURN RealMath.ln (x)
END ln;
PROCEDURE log* (x, base: REAL): REAL;
(* log(x,base) is the logarithm of x base b. All positive arguments are
allowed. The base b must be positive. *)
BEGIN
RETURN RealMath.log (x, base)
END log;
PROCEDURE round* (x: REAL): REAL;
(* round(x) if fraction part of x is in range 0.0 to 0.5 then the result is
the largest integer not greater than x, otherwise the result is x rounded
up to the next highest whole number. Note that integer values cannot always
be exactly represented in REAL or REAL format. *)
BEGIN
RETURN RealMath.round (x)
END round;
PROCEDURE sin* (x: REAL): REAL;
BEGIN
RETURN RealMath.sin (x)
END sin;
PROCEDURE cos* (x: REAL): REAL;
BEGIN
RETURN RealMath.cos (x)
END cos;
PROCEDURE tan* (x: REAL): REAL;
(* sin, cos, tan(x) returns the sine, cosine or tangent value of x, where x is
in radians. *)
BEGIN
RETURN RealMath.tan (x)
END tan;
PROCEDURE arcsin* (x: REAL): REAL;
BEGIN
RETURN RealMath.arcsin (x)
END arcsin;
PROCEDURE arccos* (x: REAL): REAL;
BEGIN
RETURN RealMath.arccos (x)
END arccos;
PROCEDURE arctan* (x: REAL): REAL;
(* arcsin, arcos, arctan(x) returns the arcsine, arcos, arctan value in radians
of x, where x is in the sine, cosine or tangent value. *)
BEGIN
RETURN RealMath.arctan (x)
END arctan;
PROCEDURE arctan2* (xn, xd: REAL): REAL;
(* 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. *)
BEGIN
RETURN RealMath.arctan2 (xn, xd)
END arctan2;
PROCEDURE sinh* (x: REAL): REAL;
(* sinh(x) is the hyperbolic sine of x. The argument x must not be so large
that exp(|x|) overflows. *)
BEGIN
RETURN RealMath.sinh (x)
END sinh;
PROCEDURE cosh* (x: REAL): REAL;
(* cosh(x) is the hyperbolic cosine of x. The argument x must not be so large
that exp(|x|) overflows. *)
BEGIN
RETURN RealMath.cosh (x)
END cosh;
PROCEDURE tanh* (x: REAL): REAL;
(* tanh(x) is the hyperbolic tangent of x. All arguments are legal. *)
BEGIN
RETURN RealMath.tanh (x)
END tanh;
PROCEDURE arcsinh* (x: REAL): REAL;
(* arcsinh(x) is the arc hyperbolic sine of x. All arguments are legal. *)
BEGIN
RETURN RealMath.arcsinh (x)
END arcsinh;
PROCEDURE arccosh* (x: REAL): REAL;
(* arccosh(x) is the arc hyperbolic cosine of x. All arguments greater than
or equal to 1 are legal. *)
BEGIN
RETURN RealMath.arccosh (x)
END arccosh;
PROCEDURE arctanh* (x: REAL): REAL;
(* 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. *)
BEGIN
RETURN RealMath.arctanh (x)
END arctanh;
END oocOakMath.

181
src/library/ooc/oocOakStrings.Mod Normal file
View file

@ -0,0 +1,181 @@
(* $Id: OakStrings.Mod,v 1.3 1999/10/03 11:44:53 ooc-devel Exp $ *)
MODULE oocOakStrings;
(* Oakwood compliant string manipulation facilities.
Copyright (C) 1998, 1999 Michael van Acken
This module is free software; you can redistribute it and/or
modify 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 OOC. If not, write to the Free Software Foundation,
59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
(* see also [Oakwood Guidelines, revision 1A]
Module Strings provides a set of operations on strings (i.e., on string
constants and character arrays, both of wich contain the character 0X as a
terminator). All positions in strings start at 0.
Remarks
String assignments and string comparisons are already supported by the language
Oberon-2.
*)
PROCEDURE Length* (s: ARRAY OF CHAR): INTEGER;
(* Returns the number of characters in s up to and excluding the first 0X. *)
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (s[i] # 0X) DO
INC (i)
END;
RETURN i
END Length;
PROCEDURE Insert* (src: ARRAY OF CHAR; pos: INTEGER; VAR dst: ARRAY OF CHAR);
(* Inserts the string src into the string dst at position pos (0<=pos<=
Length(dst)). If pos=Length(dst), src is appended to dst. If the size of
dst is not large enough to hold the result of the operation, the result is
truncated so that dst is always terminated with a 0X. *)
VAR
lenSrc, lenDst, maxDst, i: INTEGER;
BEGIN
lenDst := Length (dst);
lenSrc := Length (src);
maxDst := SHORT (LEN (dst))-1;
IF (pos+lenSrc < maxDst) THEN
IF (lenDst+lenSrc > maxDst) THEN
(* 'dst' too long, truncate it *)
lenDst := maxDst-lenSrc;
dst[lenDst] := 0X
END;
(* 'src' is inserted inside of 'dst', move tail section *)
FOR i := lenDst TO pos BY -1 DO
dst[i+lenSrc] := dst[i]
END
ELSE
dst[maxDst] := 0X;
lenSrc := maxDst-pos
END;
(* copy characters from 'src' to 'dst' *)
FOR i := 0 TO lenSrc-1 DO
dst[pos+i] := src[i]
END
END Insert;
PROCEDURE Append* (s: ARRAY OF CHAR; VAR dst: ARRAY OF CHAR);
(* Has the same effect as Insert(s, Length(dst), dst). *)
VAR
sp, dp, m: INTEGER;
BEGIN
m := SHORT (LEN(dst))-1; (* max length of dst *)
dp := Length (dst); (* append s at position dp *)
sp := 0;
WHILE (dp < m) & (s[sp] # 0X) DO (* copy chars from s to dst *)
dst[dp] := s[sp];
INC (dp);
INC (sp)
END;
dst[dp] := 0X (* terminate dst *)
END Append;
PROCEDURE Delete* (VAR s: ARRAY OF CHAR; pos, n: INTEGER);
(* Deletes n characters from s starting at position pos (0<=pos<=Length(s)).
If n>Length(s)-pos, the new length of s is pos. *)
VAR
lenStr, i: INTEGER;
BEGIN
lenStr := Length (s);
IF (pos+n < lenStr) THEN
FOR i := pos TO lenStr-n DO
s[i] := s[i+n]
END
ELSE
s[pos] := 0X
END
END Delete;
PROCEDURE Replace* (src: ARRAY OF CHAR; pos: INTEGER; VAR dst: ARRAY OF CHAR);
(* Has the same effect as Delete(dst, pos, Length(src)) followed by an
Insert(src, pos, dst). *)
VAR
sp, maxDst: INTEGER;
addNull: BOOLEAN;
BEGIN
maxDst := SHORT (LEN (dst))-1; (* max length of dst *)
addNull := FALSE;
sp := 0;
WHILE (src[sp] # 0X) & (pos < maxDst) DO (* copy chars from src to dst *)
(* set addNull=TRUE if we write over the end of dst *)
addNull := addNull OR (dst[pos] = 0X);
dst[pos] := src[sp];
INC (pos);
INC (sp)
END;
IF addNull THEN
dst[pos] := 0X (* terminate dst *)
END
END Replace;
PROCEDURE Extract* (src: ARRAY OF CHAR; pos, n: INTEGER; VAR dst: ARRAY OF CHAR);
(* Extracts a substring dst with n characters from position pos (0<=pos<=
Length(src)) in src. If n>Length(src)-pos, dst is only the part of src from
pos to the end of src, i.e. Length(src)-1. If the size of dst is not large
enough to hold the result of the operation, the result is truncated so that
dst is always terminated with a 0X. *)
VAR
i: INTEGER;
BEGIN
(* set n to Max(n, LEN(dst)-1) *)
IF (n > LEN(dst)) THEN
n := SHORT (LEN(dst))-1
END;
(* copy upto n characters into dst *)
i := 0;
WHILE (i < n) & (src[pos+i] # 0X) DO
dst[i] := src[pos+i];
INC (i)
END;
dst[i] := 0X
END Extract;
PROCEDURE Pos* (pat, s: ARRAY OF CHAR; pos: INTEGER): INTEGER;
(* Returns the position of the first occurrence of pat in s. Searching starts
at position pos. If pat is not found, -1 is returned. *)
VAR
posPat: INTEGER;
BEGIN
posPat := 0;
LOOP
IF (pat[posPat] = 0X) THEN (* reached end of pattern *)
RETURN pos-posPat
ELSIF (s[pos] = 0X) THEN (* end of string (but not of pattern) *)
RETURN -1
ELSIF (s[pos] = pat[posPat]) THEN (* characters identic, compare next one *)
INC (pos); INC (posPat)
ELSE (* difference found: reset indices and restart *)
pos := pos-posPat+1; posPat := 0
END
END
END Pos;
PROCEDURE Cap* (VAR s: ARRAY OF CHAR);
(* Replaces each lower case letter with s by its upper case equivalent. *)
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (s[i] # 0X) DO
s[i] := CAP (s[i]);
INC (i)
END
END Cap;
END oocOakStrings.

75
src/library/ooc/oocRandomNumbers.Mod Normal file
View file

@ -0,0 +1,75 @@
(* $Id: RandomNumbers.Mod,v 1.1 1997/02/07 07:45:32 oberon1 Exp $ *)
MODULE oocRandomNumbers;
(*
For details on this algorithm take a look at
Park S.K. and Miller K.W. (1988). Random number generators, good ones are
hard to find. Communications of the ACM, 31, 1192-1201.
*)
CONST
modulo* = 2147483647; (* =2^31-1 *)
VAR
z : LONGINT;
PROCEDURE GetSeed* (VAR seed : LONGINT);
(* Returns the currently used seed value. *)
BEGIN
seed := z
END GetSeed;
PROCEDURE PutSeed* (seed : LONGINT);
(* Set 'seed' as the new seed value. Any values for 'seed' are allowed, but
values beyond the intervall [1..2^31-2] will be mapped into this range. *)
BEGIN
seed := seed MOD modulo;
IF (seed = 0) THEN
z := 1
ELSE
z := seed
END
END PutSeed;
PROCEDURE NextRND;
CONST
a = 16807;
q = 127773; (* m div a *)
r = 2836; (* m mod a *)
VAR
lo, hi, test : LONGINT;
BEGIN
hi := z DIV q;
lo := z MOD q;
test := a * lo - r * hi;
IF (test > 0) THEN
z := test
ELSE
z := test + modulo
END
END NextRND;
PROCEDURE RND* (range : LONGINT) : LONGINT;
(* Calculates a new number. 'range' has to be in the intervall
[1..2^31-2]. Result is a number from 0,1,..,range-1. *)
BEGIN
NextRND;
RETURN z MOD range
END RND;
PROCEDURE Random*() : REAL;
(* Calculates a number x with 0.0 <= x < 1.0. *)
BEGIN
NextRND;
RETURN (z-1)*(1 / (modulo-1))
END Random;
(*
PROCEDURE Randomize*;
BEGIN
PutSeed (Unix.time (Unix.NULL))
END Randomize;
*)
BEGIN
z := 1
END oocRandomNumbers.

389
src/library/ooc/oocRealConv.Mod Normal file
View file

@ -0,0 +1,389 @@
(* $Id: RealConv.Mod,v 1.6 1999/09/02 13:18:59 acken Exp $ *)
MODULE oocRealConv;
(*
RealConv - Low-level REAL/string conversions.
Copyright (C) 1995 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
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
Char := oocCharClass, Low := oocLowReal, Str := oocStrings, Conv := oocConvTypes;
CONST
ZERO=0.0;
TEN=10.0;
ExpCh="E";
SigFigs*=7; (* accuracy of REALs *)
DEBUG = FALSE;
TYPE
ConvResults*= Conv.ConvResults; (* strAllRight, strOutOfRange, strWrongFormat, strEmpty *)
CONST
strAllRight*=Conv.strAllRight; (* the string format is correct for the corresponding conversion *)
strOutOfRange*=Conv.strOutOfRange; (* the string is well-formed but the value cannot be represented *)
strWrongFormat*=Conv.strWrongFormat; (* the string is in the wrong format for the conversion *)
strEmpty*=Conv.strEmpty; (* the given string is empty *)
VAR
RS, P, F, E, SE, WE, SR: Conv.ScanState;
PROCEDURE IsSign (ch: CHAR): BOOLEAN;
(* Return TRUE for '+' or '-' *)
BEGIN
RETURN (ch='+')OR(ch='-')
END IsSign;
(* internal state machine procedures *)
PROCEDURE RSState(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
BEGIN
IF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=P
ELSE chClass:=Conv.invalid; nextState:=RS
END
END RSState;
PROCEDURE PState(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
BEGIN
IF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=P
ELSIF inputCh="." THEN chClass:=Conv.valid; nextState:=F
ELSIF inputCh=ExpCh THEN chClass:=Conv.valid; nextState:=E
ELSE chClass:=Conv.terminator; nextState:=NIL
END
END PState;
PROCEDURE FState(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
BEGIN
IF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=F
ELSIF inputCh=ExpCh THEN chClass:=Conv.valid; nextState:=E
ELSE chClass:=Conv.terminator; nextState:=NIL
END
END FState;
PROCEDURE EState(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
BEGIN
IF IsSign(inputCh) THEN chClass:=Conv.valid; nextState:=SE
ELSIF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=WE
ELSE chClass:=Conv.invalid; nextState:=E
END
END EState;
PROCEDURE SEState(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
BEGIN
IF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=WE
ELSE chClass:=Conv.invalid; nextState:=SE
END
END SEState;
PROCEDURE WEState(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
BEGIN
IF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=WE
ELSE chClass:=Conv.terminator; nextState:=NIL
END
END WEState;
PROCEDURE ScanReal*(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
(*
Represents the start state of a finite state scanner for real numbers - assigns
class of inputCh to chClass and a procedure representing the next state to
nextState.
The call of ScanReal(inputCh,chClass,nextState) shall assign values to
`chClass' and `nextState' depending upon the value of `inputCh' as
shown in the following table.
Procedure inputCh chClass nextState (a procedure
with behaviour of)
--------- --------- -------- ---------
ScanReal space padding ScanReal
sign valid RSState
decimal digit valid PState
other invalid ScanReal
RSState decimal digit valid PState
other invalid RSState
PState decimal digit valid PState
"." valid FState
"E" valid EState
other terminator --
FState decimal digit valid FState
"E" valid EState
other terminator --
EState sign valid SEState
decimal digit valid WEState
other invalid EState
SEState decimal digit valid WEState
other invalid SEState
WEState decimal digit valid WEState
other terminator --
For examples of how to use ScanReal, refer to FormatReal and
ValueReal below.
*)
BEGIN
IF Char.IsWhiteSpace(inputCh) THEN chClass:=Conv.padding; nextState:=SR
ELSIF IsSign(inputCh) THEN chClass:=Conv.valid; nextState:=RS
ELSIF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=P
ELSE chClass:=Conv.invalid; nextState:=SR
END
END ScanReal;
PROCEDURE FormatReal*(str: ARRAY OF CHAR): ConvResults;
(* Returns the format of the string value for conversion to REAL. *)
VAR
ch: CHAR;
rn: LONGREAL;
len, index, digit, nexp, exp: INTEGER;
state: Conv.ScanState;
inExp, posExp, decExp: BOOLEAN;
prev, class: Conv.ScanClass;
BEGIN
len:=Str.Length(str); index:=0;
class:=Conv.padding; prev:=class;
state:=SR; rn:=0.0; exp:=0; nexp:= 0;
inExp:=FALSE; posExp:=TRUE; decExp:=FALSE;
LOOP
IF index=len THEN EXIT END;
ch:=str[index];
state.p(ch, class, state);
CASE class OF
| Conv.padding: (* nothing to do *)
| Conv.valid:
IF inExp THEN
IF IsSign(ch) THEN posExp:=ch="+"
ELSE (* must be digits *)
digit:=ORD(ch)-ORD("0");
IF posExp THEN exp:=exp*10+digit
ELSE exp:=exp*10-digit
END
END
ELSIF CAP(ch)=ExpCh THEN inExp:=TRUE
ELSIF ch="." THEN decExp:=TRUE
ELSE (* must be a digit *)
rn:=rn*TEN+(ORD(ch)-ORD("0"));
IF decExp THEN DEC(nexp) END;
END
| Conv.invalid, Conv.terminator: EXIT
END;
prev:=class; INC(index)
END;
IF class IN {Conv.invalid, Conv.terminator} THEN
RETURN strWrongFormat
ELSIF prev=Conv.padding THEN
RETURN strEmpty
ELSE
INC(exp, nexp);
IF rn#ZERO THEN
WHILE exp>0 DO
IF (-3.4028235677973366D+38 < rn) &
((rn>=3.4028235677973366D+38) OR
(SHORT(rn)>Low.large/TEN)) THEN RETURN strOutOfRange
ELSE rn:=rn*TEN
END;
DEC(exp)
END;
WHILE exp<0 DO
IF (rn < 3.4028235677973366D+38) &
((rn<=-3.4028235677973366D+38) OR
(SHORT(rn)<Low.small*TEN)) THEN RETURN strOutOfRange
ELSE rn:=rn/TEN
END;
INC(exp)
END
END;
RETURN strAllRight
END
END FormatReal;
PROCEDURE ValueReal*(str: ARRAY OF CHAR): REAL;
(*
Returns the value corresponding to the real number string value str
if str is well-formed; otherwise raises the RealConv exception.
*)
VAR
ch: CHAR;
x: REAL;
rn: LONGREAL;
len, index, digit, nexp, exp: INTEGER;
state: Conv.ScanState;
positive, inExp, posExp, decExp: BOOLEAN;
prev, class: Conv.ScanClass;
BEGIN
len:=Str.Length(str); index:=0;
class:=Conv.padding; prev:=class;
state:=SR; rn:=0.0; exp:=0; nexp:= 0;
positive:=TRUE; inExp:=FALSE; posExp:=TRUE; decExp:=FALSE;
LOOP
IF index=len THEN EXIT END;
ch:=str[index];
state.p(ch, class, state);
CASE class OF
| Conv.padding: (* nothing to do *)
| Conv.valid:
IF inExp THEN
IF IsSign(ch) THEN posExp:=ch="+"
ELSE (* must be digits *)
digit:=ORD(ch)-ORD("0");
IF posExp THEN exp:=exp*10+digit
ELSE exp:=exp*10-digit
END
END
ELSIF CAP(ch)=ExpCh THEN inExp:=TRUE
ELSIF IsSign(ch) THEN positive:=ch="+"
ELSIF ch="." THEN decExp:=TRUE
ELSE (* must be a digit *)
rn:=rn*TEN+(ORD(ch)-ORD("0"));
IF decExp THEN DEC(nexp) END;
END
| Conv.invalid, Conv.terminator: EXIT
END;
prev:=class; INC(index)
END;
IF class IN {Conv.invalid, Conv.terminator} THEN
RETURN ZERO
ELSIF prev=Conv.padding THEN
RETURN ZERO
ELSE
INC(exp, nexp);
IF rn#ZERO THEN
WHILE exp>0 DO rn:=rn*TEN; DEC(exp) END;
WHILE exp<0 DO rn:=rn/TEN; INC(exp) END
END;
x:=SHORT(rn)
END;
IF ~positive THEN x:=-x END;
RETURN x
END ValueReal;
PROCEDURE LengthFloatReal*(real: REAL; sigFigs: INTEGER): INTEGER;
(*
Returns the number of characters in the floating-point string
representation of real with sigFigs significant figures.
This value corresponds to the capacity of an array `str' which
is of the minimum capacity needed to avoid truncation of the
result in the call RealStr.RealToFloat(real,sigFigs,str).
*)
VAR
len, exp: INTEGER;
BEGIN
IF Low.IsNaN(real) THEN RETURN 3
ELSIF Low.IsInfinity(real) THEN
IF real<ZERO THEN RETURN 9 ELSE RETURN 8 END
END;
IF sigFigs=0 THEN sigFigs:=SigFigs END; len:=sigFigs; (* default digits -- if none given *)
IF real<ZERO THEN INC(len); real:=-real END; (* account for the sign *)
exp:=Low.exponent10(real);
IF sigFigs>1 THEN INC(len) END; (* account for the decimal point *)
IF exp>10 THEN INC(len, 4) (* account for the exponent *)
ELSIF exp#0 THEN INC(len, 3)
END;
RETURN len
END LengthFloatReal;
PROCEDURE LengthEngReal*(real: REAL; sigFigs: INTEGER): INTEGER;
(*
Returns the number of characters in the floating-point engineering
string representation of real with sigFigs significant figures.
This value corresponds to the capacity of an array `str' which is
of the minimum capacity needed to avoid truncation of the result in
the call RealStr.RealToEng(real,sigFigs,str).
*)
VAR
len, exp, off: INTEGER;
BEGIN
IF Low.IsNaN(real) THEN RETURN 3
ELSIF Low.IsInfinity(real) THEN
IF real<ZERO THEN RETURN 9 ELSE RETURN 8 END
END;
IF sigFigs=0 THEN sigFigs:=SigFigs END; len:=sigFigs; (* default digits -- if none given *)
IF real<ZERO THEN INC(len); real:=-real END; (* account for the sign *)
exp:=Low.exponent10(real); off:=exp MOD 3; (* account for the exponent *)
IF exp-off>10 THEN INC(len, 4)
ELSIF exp-off#0 THEN INC(len, 3)
END;
IF sigFigs>off+1 THEN INC(len) END; (* account for the decimal point *)
IF off+1-sigFigs>0 THEN INC(len, off+1-sigFigs) END; (* account for extra padding digits *)
RETURN len
END LengthEngReal;
PROCEDURE LengthFixedReal*(real: REAL; place: INTEGER): INTEGER;
(*
Returns the number of characters in the fixed-point string
representation of real rounded to the given place relative
to the decimal point.
This value corresponds to the capacity of an array `str' which
is of the minimum capacity needed to avoid truncation of the
result in the call RealStr.RealToFixed(real,sigFigs,str).
*)
VAR
len, exp: INTEGER; addDecPt: BOOLEAN;
BEGIN
IF Low.IsNaN(real) THEN RETURN 3
ELSIF Low.IsInfinity(real) THEN
IF real<0 THEN RETURN 9 ELSE RETURN 8 END
END;
exp:=Low.exponent10(real); addDecPt:=place>=0;
IF place<0 THEN INC(place, 2) ELSE INC(place) END;
IF exp<0 THEN (* account for digits *)
IF place<=0 THEN len:=1 ELSE len:=place END
ELSE len:=exp+place;
IF 1-place>0 THEN INC(len, 1-place) END
END;
IF real<ZERO THEN INC(len) END; (* account for the sign *)
IF addDecPt THEN INC(len) END; (* account for decimal point *)
RETURN len
END LengthFixedReal;
PROCEDURE IsRConvException*(): BOOLEAN;
(*
Returns TRUE if the current coroutine is in the exceptional
execution state because of the raising of the RealConv exception;
otherwise returns FALSE.
*)
BEGIN
RETURN FALSE
END IsRConvException;
PROCEDURE Test;
VAR f: REAL; res: INTEGER;
BEGIN
f:=MAX(REAL);
f:=ValueReal("3.40282347E+38");
res:=LengthFixedReal(100, 0);
res:=LengthEngReal(100, 0);
res:=LengthFloatReal(100, 0);
res:=LengthFixedReal(-100.123, 0);
res:=LengthEngReal(-100.123, 0);
res:=LengthFloatReal(-100.123, 0);
res:=LengthFixedReal(-1.0E20, 0);
res:=LengthEngReal(-1.0E20, 0);
res:=LengthFloatReal(-1.0E20, 0);
END Test;
BEGIN
NEW(RS); NEW(P); NEW(F); NEW(E); NEW(SE); NEW(WE); NEW(SR);
RS.p:=RSState; P.p:=PState; F.p:=FState; E.p:=EState;
SE.p:=SEState; WE.p:=WEState; SR.p:=ScanReal;
IF DEBUG THEN Test END
END oocRealConv.

609
src/library/ooc/oocRealMath.Mod Normal file
View file

@ -0,0 +1,609 @@
(* $Id: RealMath.Mod,v 1.6 1999/09/02 13:19:17 acken Exp $ *)
MODULE oocRealMath;
(*
RealMath - Target independent mathematical functions for REAL
(IEEE single-precision) numbers.
Numerical approximations are taken from "Software Manual for the
Elementary Functions" by Cody & Waite and "Computer Approximations"
by Hart et al.
Copyright (C) 1995 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
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 := oocLowReal, S := SYSTEM;
CONST
pi* = 3.1415926535897932384626433832795028841972;
exp1* = 2.7182818284590452353602874713526624977572;
ZERO=0.0; ONE=1.0; HALF=0.5; TWO=2.0; (* local constants *)
(* internally-used constants *)
huge=l.large; (* largest number this package accepts *)
miny=ONE/huge; (* smallest number this package accepts *)
sqrtHalf=0.70710678118654752440;
Limit=2.4414062E-4; (* 2**(-MantBits/2) *)
eps=2.9802322E-8; (* 2**(-MantBits-1) *)
piInv=0.31830988618379067154; (* 1/pi *)
piByTwo=1.57079632679489661923132;
piByFour=0.78539816339744830962;
lnv=0.6931610107421875; (* should be exact *)
vbytwo=0.13830277879601902638E-4; (* used in sinh/cosh *)
ln2Inv=1.44269504088896340735992468100189213;
(* error/exception codes *)
NoError*=0; IllegalRoot*=1; IllegalLog*=2; Overflow*=3; IllegalPower*=4; IllegalLogBase*=5;
IllegalTrig*=6; IllegalInvTrig*=7; HypInvTrigClipped*=8; IllegalHypInvTrig*=9;
LossOfAccuracy*=10; Underflow*=11;
VAR
a1: ARRAY 18 OF REAL; (* lookup table for power function *)
a2: ARRAY 9 OF REAL; (* lookup table for power function *)
em: REAL; (* largest number such that 1+epsilon > 1.0 *)
LnInfinity: REAL; (* natural log of infinity *)
LnSmall: REAL; (* natural log of very small number *)
SqrtInfinity: REAL; (* square root of infinity *)
TanhMax: REAL; (* maximum Tanh value *)
t: REAL; (* internal variables *)
(* internally used support routines *)
PROCEDURE SinCos (x, y, sign: REAL): REAL;
CONST
ymax=9099; (* ENTIER(pi*2**(MantBits/2)) *)
r1=-0.1666665668E+0;
r2= 0.8333025139E-2;
r3=-0.1980741872E-3;
r4= 0.2601903036E-5;
VAR
n: LONGINT; xn, f, g: REAL;
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 *)
f:=SHORT(ABS(LONG(x)) - LONG(xn)*pi);
(* Pre: |f| <= pi/2 *)
IF ABS(f)<Limit THEN RETURN sign*f END;
(* evaluate polynomial approximation of sin *)
g:=f*f; g:=(((r4*g+r3)*g+r2)*g+r1)*g;
g:=f+f*g; (* don't use less accurate f(1+g) *)
RETURN sign*g
END SinCos;
PROCEDURE div (x, y : LONGINT) : LONGINT;
(* corrected MOD function *)
BEGIN
IF x < 0 THEN RETURN -ABS(x) DIV y ELSE RETURN x DIV y END
END div;
(* forward declarations *)
PROCEDURE^ arctan2* (xn, xd: REAL): REAL;
PROCEDURE^ sincos* (x: REAL; VAR Sin, Cos: REAL);
PROCEDURE round*(x: REAL): LONGINT;
(* Returns the value of x rounded to the nearest integer *)
BEGIN
IF x<ZERO THEN RETURN -ENTIER(HALF-x)
ELSE RETURN ENTIER(x+HALF)
END
END round;
PROCEDURE sqrt*(x: REAL): REAL;
(* Returns the positive square root of x where x >= 0 *)
CONST
P0=0.41731; P1=0.59016;
VAR
xMant, yEst, z: REAL; 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 two newtonian iterations *)
z:=(yEst+xMant/yEst); yEst:=0.25*z+xMant/z;
(* 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)
END sqrt;
PROCEDURE exp*(x: REAL): REAL;
(* Returns the exponential of x for x < Ln(MAX(REAL)) *)
CONST
ln2=0.6931471805599453094172321D0;
P0=0.24999999950E+0; P1=0.41602886268E-2; Q1=0.49987178778E-1;
VAR xn, g, p, q, z: REAL; n: LONGINT;
BEGIN
(* Ensure we detect overflows and return 0 for underflows *)
IF x>=LnInfinity THEN l.ErrorHandler(Overflow); RETURN huge
ELSIF x<LnSmall THEN l.ErrorHandler(Underflow); RETURN ZERO
ELSIF ABS(x)<eps THEN RETURN ONE
END;
(* Decompose and scale the number *)
n:=round(ln2Inv*x);
xn:=n; g:=SHORT(LONG(x)-LONG(xn)*ln2);
(* Calculate exp(g)/2 from "Software Manual for the Elementary Functions" *)
z:=g*g; p:=(P1*z+P0)*g; q:=Q1*z+HALF;
RETURN l.scale(HALF+p/(q-p), SHORT(n+1))
END exp;
PROCEDURE ln*(x: REAL): REAL;
(* Returns the natural logarithm of x for x > 0 *)
CONST
c1=355.0/512.0; c2=-2.121944400546905827679E-4;
A0=-0.5527074855E+0; B0=-0.6632718214E+1;
VAR f, zn, zd, r, z, w, xn: REAL; n: INTEGER;
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)
END;
(* evaluate rational approximation from "Software Manual for the Elementary Functions" *)
z:=zn/zd; w:=z*z; r:=z+z*(w*A0/(w+B0));
(* scale the output *)
xn:=n;
RETURN (xn*c2+r)+xn*c1
END ln;
(* The angle in all trigonometric functions is measured in radians *)
PROCEDURE sin*(x: REAL): REAL;
(* Returns the sine of x for all x *)
BEGIN
IF x<ZERO THEN RETURN SinCos(x, -x, -ONE)
ELSE RETURN SinCos(x, x, ONE)
END
END sin;
PROCEDURE cos*(x: REAL): REAL;
(* Returns the cosine of x for all x *)
BEGIN
RETURN SinCos(x, ABS(x)+piByTwo, ONE)
END cos;
PROCEDURE tan*(x: REAL): REAL;
(* Returns the tangent of x where x cannot be an odd multiple of pi/2 *)
CONST
ymax = 6434; (* ENTIER(2**(MantBits/2)*pi/2) *)
twoByPi = 0.63661977236758134308;
P1=-0.958017723E-1; Q1=-0.429135777E+0; Q2=0.971685835E-2;
VAR
n: LONGINT;
y, xn, f, xnum, xden, g: REAL;
BEGIN
(* check for error limits *)
y:=ABS(x);
IF y>ymax THEN l.ErrorHandler(LossOfAccuracy); RETURN ZERO END;
(* determine n and the fraction f *)
n:=round(x*twoByPi); xn:=n;
f:=SHORT(LONG(x)-LONG(xn)*piByTwo);
(* check for underflow *)
IF ABS(f)<Limit THEN xnum:=f; xden:=ONE
ELSE g:=f*f; xnum:=P1*g*f+f; xden:=(Q2*g+Q1)*g+HALF+HALF
END;
(* find the final result *)
IF ODD(n) THEN RETURN xden/(-xnum)
ELSE RETURN xnum/xden
END
END tan;
PROCEDURE asincos (x: REAL; flag: LONGINT; VAR i: LONGINT; VAR res: REAL);
CONST
P1=0.933935835E+0; P2=-0.504400557E+0;
Q0=0.560363004E+1; Q1=-0.554846723E+1;
VAR
y, g, r: REAL;
BEGIN
y:=ABS(x);
IF y>HALF THEN
i:=1-flag;
IF y>ONE THEN l.ErrorHandler(IllegalInvTrig); res:=huge; RETURN END;
(* reduce the input argument *)
g:=(ONE-y)*HALF; r:=-sqrt(g); y:=r+r;
(* compute approximation *)
r:=((P2*g+P1)*g)/((g+Q1)*g+Q0);
res:=y+(y*r)
ELSE
i:=flag;
IF y<Limit THEN res:=y
ELSE
g:=y*y;
(* compute approximation *)
g:=((P2*g+P1)*g)/((g+Q1)*g+Q0);
res:=y+y*g
END
END
END asincos;
PROCEDURE arcsin*(x: REAL): REAL;
(* Returns the arcsine of x, in the range [-pi/2, pi/2] where -1 <= x <= 1 *)
VAR
res: REAL; i: LONGINT;
BEGIN
asincos(x, 0, i, res);
IF l.err#0 THEN RETURN res END;
(* adjust result for the correct quadrant *)
IF i=1 THEN res:=piByFour+(piByFour+res) END;
IF x<0 THEN res:=-res END;
RETURN res
END arcsin;
PROCEDURE arccos*(x: REAL): REAL;
(* Returns the arccosine of x, in the range [0, pi] where -1 <= x <= 1 *)
VAR
res: REAL; i: LONGINT;
BEGIN
asincos(x, 1, i, res);
IF l.err#0 THEN RETURN res END;
(* adjust result for the correct quadrant *)
IF x<0 THEN
IF i=0 THEN res:=piByTwo+(piByTwo+res)
ELSE res:=piByFour+(piByFour+res)
END
ELSE
IF i=1 THEN res:=piByFour+(piByFour-res)
ELSE res:=-res
END;
END;
RETURN res
END arccos;
PROCEDURE atan(f: REAL): REAL;
(* internal arctan algorithm *)
CONST
rt32=0.26794919243112270647;
rt3=1.73205080756887729353;
a=rt3-ONE;
P0=-0.4708325141E+0; P1=-0.5090958253E-1; Q0=0.1412500740E+1;
piByThree=1.04719755119659774615;
piBySix=0.52359877559829887308;
VAR
n: LONGINT; res, g: REAL;
BEGIN
IF f>ONE THEN f:=ONE/f; n:=2
ELSE n:=0
END;
(* check if f should be scaled *)
IF f>rt32 THEN f:=(((a*f-HALF)-HALF)+f)/(rt3+f); INC(n) END;
(* check for underflow *)
IF ABS(f)<Limit THEN res:=f
ELSE
g:=f*f; res:=(P1*g+P0)*g/(g+Q0); res:=f+f*res
END;
IF n>1 THEN res:=-res END;
CASE n OF
| 1: res:=res+piBySix
| 2: res:=res+piByTwo
| 3: res:=res+piByThree
| ELSE (* do nothing *)
END;
RETURN res
END atan;
PROCEDURE arctan*(x: REAL): REAL;
(* Returns the arctangent of x, in the range [-pi/2, pi/2] for all x *)
BEGIN
IF x<0 THEN RETURN -atan(-x)
ELSE RETURN atan(x)
END
END arctan;
PROCEDURE power*(base, exponent: REAL): REAL;
(* Returns the value of the number base raised to the power exponent
for base > 0 *)
CONST P1=0.83357541E-1; K=0.4426950409;
Q1=0.69314675; Q2=0.24018510; Q3=0.54360383E-1;
OneOver16=0.0625; XMAX=16*(l.expoMax+1)-1; (*XMIN=16*l.expoMin;*) XMIN=-2016; (* to make it easier for voc; -- noch *)
VAR z, g, R, v, u2, u1, w1, w2: REAL; w: LONGREAL;
m, p, i: INTEGER; mp, pp, iw1: LONGINT;
BEGIN
(* handle all possible error conditions *)
IF base<=ZERO THEN
IF base#ZERO THEN l.ErrorHandler(IllegalPower); base:=-base
ELSIF exponent>ZERO THEN RETURN ZERO
ELSE l.ErrorHandler(IllegalPower); 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:=P1*v*z; R:=R+K*R; u2:=(R+z*K)+z;
u1:=(m*16-p)*OneOver16; w:=LONG(exponent)*(LONG(u1)+LONG(u2)); (* need extra precision *)
(* calculations below were modified to work properly -- incorrect in cited reference? *)
iw1:=ENTIER(16*w); w1:=iw1*OneOver16; w2:=SHORT(w-w1);
(* check for overflow/underflow *)
IF iw1>XMAX THEN l.ErrorHandler(Overflow); RETURN huge
ELSIF iw1<XMIN THEN l.ErrorHandler(Underflow); RETURN ZERO
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:=((Q3*w2+Q2)*w2+Q1)*w2; z:=a1[pp+1]+a1[pp+1]*z;
RETURN l.scale(z, SHORT(mp))
END power;
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.
*)
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.
*)
PROCEDURE log* (x, base: REAL): REAL;
(* log(x,base) is the logarithm of x base 'base'. All positive arguments are
allowed but base > 0 and base # 1 *)
BEGIN
(* log(x, base) = ln(x) / ln(base) *)
IF base<=ZERO THEN l.ErrorHandler(IllegalLogBase); RETURN -huge
ELSE RETURN ln(x)/ln(base)
END
END log;
PROCEDURE ipower* (x: REAL; base: INTEGER): REAL;
(* ipower(x, base) returns the x to the integer power base where Log2(x) < expoMax *)
VAR Exp: INTEGER; y: REAL; neg: BOOLEAN;
PROCEDURE Adjust(xadj: REAL): REAL;
BEGIN
IF (x<ZERO)&ODD(base) THEN RETURN -xadj ELSE RETURN xadj END
END Adjust;
BEGIN
(* handle all possible error conditions *)
IF base=0 THEN RETURN ONE (* x**0 = 1 *)
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;
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
altered : p442, The Art Of Computer Programming, Vol 2 *)
y:=ONE; IF base<0 THEN neg:=TRUE; base := -base ELSE neg:= FALSE END;
LOOP
IF ODD(base) THEN y:=y*x END;
base:=base DIV 2; IF base=0 THEN EXIT END;
x:=x*x;
END;
IF neg THEN RETURN ONE/y ELSE RETURN y END
END ipower;
PROCEDURE sincos* (x: REAL; VAR Sin, Cos: REAL);
(* More efficient sin/cos implementation if both values are needed. *)
BEGIN
Sin:=sin(x); Cos:=sqrt(ONE-Sin*Sin)
END sincos;
PROCEDURE arctan2* (xn, xd: REAL): REAL;
(* 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. *)
VAR
res: REAL; xpdiff: LONGINT;
BEGIN
(* check for error conditions *)
IF xd=ZERO THEN
IF xn=ZERO THEN l.ErrorHandler(IllegalTrig); RETURN ZERO
ELSIF xn<0 THEN RETURN -piByTwo
ELSE RETURN piByTwo
END;
ELSE
xpdiff:=l.exponent(xn)-l.exponent(xd);
IF ABS(xpdiff)>=l.expoMax-3 THEN
(* overflow detected *)
IF xn<0 THEN RETURN -piByTwo
ELSE RETURN piByTwo
END
ELSE
res:=ABS(xn/xd);
IF res#ZERO THEN res:=atan(res) END;
IF xd<ZERO THEN res:=pi-res END;
IF xn<ZERO THEN RETURN -res
ELSE RETURN res
END
END
END
END arctan2;
PROCEDURE sinh* (x: REAL): REAL;
(* sinh(x) is the hyperbolic sine of x. The argument x must not be so large
that exp(|x|) overflows. *)
CONST P0=-7.13793159; P1=-0.190333399; Q0=-42.8277109;
VAR y, f: REAL;
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; y:=f*((f*P1+P0)/(f+Q0)); 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 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
END sinh;
PROCEDURE cosh* (x: REAL): REAL;
(* cosh(x) is the hyperbolic cosine of x. The argument x must not be so large
that exp(|x|) overflows. *)
VAR y, f: REAL;
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 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: REAL): REAL;
(* tanh(x) is the hyperbolic tangent of x. All arguments are legal. *)
CONST P0=-0.8237728127; P1=-0.3831010665E-2; Q0=2.471319654; ln3over2=0.5493061443;
BIG=9.010913347; (* (ln(2)+(t+1)*ln(B))/2 where t=mantissa bits, B=base *)
VAR f, t: REAL;
BEGIN f:=ABS(x);
IF f>BIG THEN t:=ONE
ELSIF f>ln3over2 THEN t:=ONE-TWO/(exp(TWO*f)+ONE)
ELSIF f<Limit THEN t:=f
ELSE (* approximation from "Software Manual for the Elementary Functions" *)
t:=f*f; t:=t*(P1*t+P0)/(t+Q0); t:=f+f*t
END;
IF x<ZERO THEN RETURN -t ELSE RETURN t END
END tanh;
PROCEDURE arcsinh* (x: REAL): REAL;
(* arcsinh(x) is the arc hyperbolic sine of x. All arguments are legal. *)
BEGIN
IF ABS(x)>SqrtInfinity*HALF THEN l.ErrorHandler(HypInvTrigClipped);
IF x>ZERO THEN RETURN ln(SqrtInfinity) ELSE RETURN -ln(SqrtInfinity) END;
ELSIF x<ZERO THEN RETURN -ln(-x+sqrt(x*x+ONE))
ELSE RETURN ln(x+sqrt(x*x+ONE))
END
END arcsinh;
PROCEDURE arccosh* (x: REAL): REAL;
(* 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
ELSIF x>SqrtInfinity*HALF THEN l.ErrorHandler(HypInvTrigClipped); RETURN ln(SqrtInfinity)
ELSE RETURN ln(x+sqrt(x*x-ONE))
END
END arccosh;
PROCEDURE arctanh* (x: REAL): REAL;
(* 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.999984991; (* Tanh(5.9) *)
VAR t: REAL;
BEGIN t:=ABS(x);
IF (t>=ONE) OR (t>(ONE-TWO*em)) THEN l.ErrorHandler(IllegalHypInvTrig);
IF x<ZERO THEN RETURN -TanhMax ELSE RETURN TanhMax END
ELSIF t>TanhLimit THEN l.ErrorHandler(LossOfAccuracy)
END;
RETURN arcsinh(x/sqrt(ONE-x*x))
END arctanh;
BEGIN
(* determine some fundamental constants used by hyperbolic trig functions *)
em:=l.ulp(ONE);
LnInfinity:=ln(huge);
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) *)
a1[1] :=ONE;
a1[2] :=S.VAL(REAL, 3F75257DH);
a1[3] :=S.VAL(REAL, 3F6AC0C7H);
a1[4] :=S.VAL(REAL, 3F60CCDFH);
a1[5] :=S.VAL(REAL, 3F5744FDH);
a1[6] :=S.VAL(REAL, 3F4E248CH);
a1[7] :=S.VAL(REAL, 3F45672AH);
a1[8] :=S.VAL(REAL, 3F3D08A4H);
a1[9] :=S.VAL(REAL, 3F3504F3H);
a1[10]:=S.VAL(REAL, 3F2D583FH);
a1[11]:=S.VAL(REAL, 3F25FED7H);
a1[12]:=S.VAL(REAL, 3F1EF532H);
a1[13]:=S.VAL(REAL, 3F1837F0H);
a1[14]:=S.VAL(REAL, 3F11C3D3H);
a1[15]:=S.VAL(REAL, 3F0B95C2H);
a1[16]:=S.VAL(REAL, 3F05AAC3H);
a1[17]:=HALF;
(* a2[i]=2**[(1-2i)/16] - a1[2i]; delta resolution *)
a2[1]:=S.VAL(REAL, 31A92436H);
a2[2]:=S.VAL(REAL, 336C2A95H);
a2[3]:=S.VAL(REAL, 31A8FC24H);
a2[4]:=S.VAL(REAL, 331F580CH);
a2[5]:=S.VAL(REAL, 336A42A1H);
a2[6]:=S.VAL(REAL, 32C12342H);
a2[7]:=S.VAL(REAL, 32E75624H);
a2[8]:=S.VAL(REAL, 32CF9890H)
END oocRealMath.

390
src/library/ooc/oocRealStr.Mod Normal file
View file

@ -0,0 +1,390 @@
(* $Id: RealStr.Mod,v 1.7 1999/09/02 13:25:39 acken Exp $ *)
MODULE oocRealStr;
(* RealStr - REAL/string conversions.
Copyright (C) 1996 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
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
Low := oocLowReal, Conv := oocConvTypes, RC := oocRealConv, Real := oocLRealMath,
Str := oocStrings;
CONST
ZERO=0.0; FIVE=5.0; TEN=10.0;
DEBUG = FALSE;
TYPE
ConvResults*= Conv.ConvResults;
(* possible values: strAllRight, strOutOfRange, strWrongFormat, strEmpty *)
CONST
strAllRight*=Conv.strAllRight;
(* the string format is correct for the corresponding conversion *)
strOutOfRange*=Conv.strOutOfRange;
(* the string is well-formed but the value cannot be represented *)
strWrongFormat*=Conv.strWrongFormat;
(* the string is in the wrong format for the conversion *)
strEmpty*=Conv.strEmpty;
(* the given string is empty *)
(* the string form of a signed fixed-point real number is
["+" | "-"] decimal_digit {decimal_digit} ["." {decimal_digit}]
*)
(* the string form of a signed floating-point real number is
signed_fixed-point_real_number ("E" | "e") ["+" | "-"]
decimal_digit {decimal_digit}
*)
PROCEDURE StrToReal*(str: ARRAY OF CHAR; VAR real: REAL; VAR res: ConvResults);
(* Ignores any leading spaces in `str'. If the subsequent characters in `str'
are in the format of a signed real number, and shall assign values to
`res' and `real' as follows:
strAllRight
if the remainder of `str' represents a complete signed real number
in the range of the type of `real' -- the value of this number shall
be assigned to `real';
strOutOfRange
if the remainder of `str' represents a complete signed real number
but its value is out of the range of the type of `real' -- the
maximum or minimum value of the type of `real' shall be assigned to
`real' according to the sign of the number;
strWrongFormat
if there are remaining characters in `str' but these are not in the
form of a complete signed real number -- the value of `real' is not
defined;
strEmpty
if there are no remaining characters in `str' -- the value of `real'
is not defined. *)
BEGIN
res:=RC.FormatReal(str);
IF res IN {strAllRight, strOutOfRange} THEN real:=RC.ValueReal(str) END
END StrToReal;
PROCEDURE AppendDigit(dig: LONGINT; VAR str: ARRAY OF CHAR);
VAR ds: ARRAY 2 OF CHAR;
BEGIN
ds[0]:=CHR(dig+ORD("0")); ds[1]:=0X; Str.Append(ds, str)
END AppendDigit;
PROCEDURE AppendExponent(exp: INTEGER; VAR str: ARRAY OF CHAR);
BEGIN
Str.Append("E", str);
IF exp<0 THEN exp:=-exp; Str.Append("-", str)
ELSE Str.Append("+", str)
END;
IF exp>=10 THEN AppendDigit(exp DIV 10, str) END;
AppendDigit(exp MOD 10, str)
END AppendExponent;
PROCEDURE NextFraction(VAR real: LONGREAL; dec: INTEGER; VAR str: ARRAY OF CHAR);
VAR dig: LONGINT;
BEGIN
dig:=ENTIER(real*Real.ipower(TEN, dec)); AppendDigit(dig, str); real:=real-Real.ipower(TEN, -dec)*dig
END NextFraction;
PROCEDURE AppendFraction(real: LONGREAL; sigFigs, exp, place: INTEGER; VAR str: ARRAY OF CHAR);
VAR digs: INTEGER;
BEGIN
(* write significant digits *)
FOR digs:=0 TO sigFigs-1 DO
IF digs=place THEN Str.Append(".", str) END;
NextFraction(real, digs-exp, str)
END;
(* pad out digits to the decimal position *)
FOR digs:=sigFigs TO place-1 DO Str.Append("0", str) END
END AppendFraction;
PROCEDURE RemoveLeadingZeros(VAR str: ARRAY OF CHAR);
VAR len: LONGINT;
BEGIN
len:=Str.Length(str);
WHILE (len>1)&(str[0]="0")&(str[1]#".") DO Str.Delete(str, 0, 1); DEC(len) END
END RemoveLeadingZeros;
PROCEDURE ExtractExpScale(VAR real: LONGREAL; VAR exp, expoff: INTEGER);
CONST
SCALE=1.0D10;
BEGIN
exp:=Low.exponent10(SHORT(real));
(* adjust number to avoid overflow/underflows *)
IF exp>20 THEN real:=real/SCALE; DEC(exp, 10); expoff:=10
ELSIF exp<-20 THEN real:=real*SCALE; INC(exp, 10); expoff:=-10
ELSE expoff:=0
END
END ExtractExpScale;
PROCEDURE RealToFloat*(real: REAL; sigFigs: INTEGER; VAR str: ARRAY OF CHAR);
(* The call `RealToFloat(real,sigFigs,str)' shall assign to `str' the possibly
truncated string corresponding to the value of `real' in floating-point
form. A sign shall be included only for negative values. One significant
digit shall be included in the whole number part. The signed exponent part
shall be included only if the exponent value is not 0. If the value of
`sigFigs' is greater than 0, that number of significant digits shall be
included, otherwise an implementation-defined number of significant digits
shall be included. The decimal point shall not be included if there are no
significant digits in the fractional part.
For example:
value: 3923009 39.23009 0.0003923009
sigFigs
1 4E+6 4E+1 4E-4
2 3.9E+6 3.9E+1 3.9E-4
5 3.9230E+6 3.9230E+1 3.9230E-4
*)
VAR
x: LONGREAL; expoff, exp: INTEGER; lstr: ARRAY 32 OF CHAR;
BEGIN
(* set significant digits, extract sign & exponent *)
lstr:=""; x:=real;
IF sigFigs<=0 THEN sigFigs:=RC.SigFigs END;
(* check for illegal numbers *)
IF Low.IsNaN(real) THEN COPY("NaN", str); RETURN END;
IF x<ZERO THEN Str.Append("-", lstr); x:=-x END;
IF Low.IsInfinity(real) THEN Str.Append("Infinity", lstr); COPY(lstr, str); RETURN END;
ExtractExpScale(x, exp, expoff);
(* round the number and extract exponent again (ie. 9.9 => 10.0) *)
IF real#ZERO THEN
x:=x+FIVE*Real.ipower(TEN, exp-sigFigs);
exp:=Low.exponent10(SHORT(x))
END;
(* output number like x[.{x}][E+n[n]] *)
AppendFraction(x, sigFigs, exp, 1, lstr);
IF exp#0 THEN AppendExponent(exp+expoff, lstr) END;
(* possibly truncate the result *)
COPY(lstr, str)
END RealToFloat;
PROCEDURE RealToEng*(real: REAL; sigFigs: INTEGER; VAR str: ARRAY OF CHAR);
(* Converts the value of `real' to floating-point string form, with `sigFigs'
significant figures, and copies the possibly truncated result to `str'. The
number is scaled with one to three digits in the whole number part and with
an exponent that is a multiple of three.
For example:
value: 3923009 39.23009 0.0003923009
sigFigs
1 4E+6 40 400E-6
2 3.9E+6 39 390E-6
5 3.9230E+6 39.230 392.30E-6
*)
VAR
x: LONGREAL; exp, expoff, offset: INTEGER; lstr: ARRAY 32 OF CHAR;
BEGIN
(* set significant digits, extract sign & exponent *)
lstr:=""; x:=real;
IF sigFigs<=0 THEN sigFigs:=RC.SigFigs END;
(* check for illegal numbers *)
IF Low.IsNaN(real) THEN COPY("NaN", str); RETURN END;
IF x<ZERO THEN Str.Append("-", lstr); x:=-x END;
IF Low.IsInfinity(real) THEN Str.Append("Infinity", lstr); COPY(lstr, str); RETURN END;
ExtractExpScale(x, exp, expoff);
(* round the number and extract exponent again (ie. 9.9 => 10.0) *)
IF real#ZERO THEN
x:=x+FIVE*Real.ipower(TEN, exp-sigFigs);
exp:=Low.exponent10(SHORT(x))
END;
(* find the offset to make the exponent a multiple of three *)
offset:=(exp+expoff) MOD 3;
(* output number like x[x][x][.{x}][E+n[n]] *)
AppendFraction(x, sigFigs, exp, offset+1, lstr);
exp:=exp-offset+expoff;
IF exp#0 THEN AppendExponent(exp, lstr) END;
(* possibly truncate the result *)
COPY(lstr, str)
END RealToEng;
PROCEDURE RealToFixed*(real: REAL; place: INTEGER; VAR str: ARRAY OF CHAR);
(* The call `RealToFixed(real,place,str)' shall assign to `str' the possibly
truncated string corresponding to the value of `real' in fixed-point form.
A sign shall be included only for negative values. At least one digit shall
be included in the whole number part. The value shall be rounded to the
given value of `place' relative to the decimal point. The decimal point
shall be suppressed if `place' is less than 0.
For example:
value: 3923009 3.923009 0.0003923009
sigFigs
-5 3920000 0 0
-2 3923010 0 0
-1 3923009 4 0
0 3923009. 4. 0.
1 3923009.0 3.9 0.0
4 3923009.0000 3.9230 0.0004
*)
VAR
x: LONGREAL; exp, expoff: INTEGER; addDecPt: BOOLEAN; lstr: ARRAY 256 OF CHAR;
BEGIN
(* set significant digits, extract sign & exponent *)
lstr:=""; addDecPt:=place=0; x:=real;
(* check for illegal numbers *)
IF Low.IsNaN(real) THEN COPY("NaN", str); RETURN END;
IF x<ZERO THEN Str.Append("-", lstr); x:=-x END;
IF Low.IsInfinity(real) THEN Str.Append("Infinity", lstr); COPY(lstr, str); RETURN END;
ExtractExpScale(x, exp, expoff);
(* round the number and extract exponent again (ie. 9.9 => 10.0) *)
IF place<0 THEN INC(place, 2) ELSE INC(place) END;
IF real#ZERO THEN
x:=x+FIVE*Real.ipower(TEN, -place);
exp:=Low.exponent10(SHORT(x))
END;
(* output number like x[{x}][.{x}] *)
INC(place, expoff);
IF exp+expoff<0 THEN
IF place<=0 THEN Str.Append("0", lstr)
ELSE AppendFraction(x, place, 0, 1, lstr)
END
ELSE AppendFraction(x, exp+place, exp, exp+expoff+1, lstr);
RemoveLeadingZeros(lstr)
END;
(* special formatting ?? *)
IF addDecPt THEN Str.Append(".", lstr) END;
(* possibly truncate the result *)
COPY(lstr, str)
END RealToFixed;
PROCEDURE RealToStr*(real: REAL; VAR str: ARRAY OF CHAR);
(* If the sign and magnitude of `real' can be shown within the capacity of
`str', the call RealToStr(real,str) shall behave as the call
`RealToFixed(real,place,str)', with a value of `place' chosen to fill
exactly the remainder of `str'. Otherwise, the call shall behave as
the call `RealToFloat(real,sigFigs,str)', with a value of `sigFigs' of
at least one, but otherwise limited to the number of significant
digits that can be included together with the sign and exponent part
in `str'. *)
VAR
cap, exp, fp, len, pos: INTEGER;
found: BOOLEAN;
BEGIN
cap:=SHORT(LEN(str))-1; (* determine the capacity of the string with space for trailing 0X *)
(* check for illegal numbers *)
IF Low.IsNaN(real) THEN COPY("NaN", str); RETURN END;
IF real<ZERO THEN COPY("-", str); fp:=-1 ELSE COPY("", str); fp:=0 END;
IF Low.IsInfinity(ABS(real)) THEN Str.Append("Infinity", str); RETURN END;
(* extract exponent *)
exp:=Low.exponent10(real);
(* format number *)
INC(fp, RC.SigFigs-exp-2);
len:=RC.LengthFixedReal(real, fp);
IF cap>=len THEN
RealToFixed(real, fp, str);
(* pad with remaining zeros *)
IF fp<0 THEN Str.Append(".", str); INC(len) END; (* add decimal point *)
WHILE len<cap DO Str.Append("0", str); INC(len) END
ELSE
fp:=RC.LengthFloatReal(real, RC.SigFigs); (* check actual length *)
IF fp<=cap THEN
RealToFloat(real, RC.SigFigs, str);
(* pad with remaining zeros *)
Str.FindNext("E", str, 2, found, pos);
WHILE fp<cap DO Str.Insert("0", pos, str); INC(fp) END
ELSE fp:=RC.SigFigs-fp+cap;
IF fp<1 THEN fp:=1 END;
RealToFloat(real, fp, str)
END
END
END RealToStr;
PROCEDURE Test;
CONST n1=3923009.0; n2=39.23009; n3=0.0003923009; n4=3.923009;
VAR str: ARRAY 80 OF CHAR; len: INTEGER;
BEGIN
RealToFloat(MAX(REAL), 9, str);
RealToEng(MAX(REAL), 9, str);
RealToFixed(MAX(REAL), 9, str);
RealToFloat(MIN(REAL), 9, str);
RealToFloat(1.0E10, 9, str);
RealToFloat(0.0, 0, str);
RealToFloat(n1, 0, str);
RealToFloat(n2, 0, str);
RealToFloat(n3, 0, str);
RealToFloat(n4, 0, str);
RealToFloat(n1, 1, str); len:=RC.LengthFloatReal(n1, 1);
RealToFloat(n1, 2, str); len:=RC.LengthFloatReal(n1, 2);
RealToFloat(n1, 5, str); len:=RC.LengthFloatReal(n1, 5);
RealToFloat(n2, 1, str); len:=RC.LengthFloatReal(n2, 1);
RealToFloat(n2, 2, str); len:=RC.LengthFloatReal(n2, 2);
RealToFloat(n2, 5, str); len:=RC.LengthFloatReal(n2, 5);
RealToFloat(n3, 1, str); len:=RC.LengthFloatReal(n3, 1);
RealToFloat(n3, 2, str); len:=RC.LengthFloatReal(n3, 2);
RealToFloat(n3, 5, str); len:=RC.LengthFloatReal(n3, 5);
RealToEng(n1, 1, str); len:=RC.LengthEngReal(n1, 1);
RealToEng(n1, 2, str); len:=RC.LengthEngReal(n1, 2);
RealToEng(n1, 5, str); len:=RC.LengthEngReal(n1, 5);
RealToEng(n2, 1, str); len:=RC.LengthEngReal(n2, 1);
RealToEng(n2, 2, str); len:=RC.LengthEngReal(n2, 2);
RealToEng(n2, 5, str); len:=RC.LengthEngReal(n2, 5);
RealToEng(n3, 1, str); len:=RC.LengthEngReal(n3, 1);
RealToEng(n3, 2, str); len:=RC.LengthEngReal(n3, 2);
RealToEng(n3, 5, str); len:=RC.LengthEngReal(n3, 5);
RealToFixed(n1, -5, str); len:=RC.LengthFixedReal(n1, -5);
RealToFixed(n1, -2, str); len:=RC.LengthFixedReal(n1, -2);
RealToFixed(n1, -1, str); len:=RC.LengthFixedReal(n1, -1);
RealToFixed(n1, 0, str); len:=RC.LengthFixedReal(n1, 0);
RealToFixed(n1, 1, str); len:=RC.LengthFixedReal(n1, 1);
RealToFixed(n1, 4, str); len:=RC.LengthFixedReal(n1, 4);
RealToFixed(n4, -5, str); len:=RC.LengthFixedReal(n4, -5);
RealToFixed(n4, -2, str); len:=RC.LengthFixedReal(n4, -2);
RealToFixed(n4, -1, str); len:=RC.LengthFixedReal(n4, -1);
RealToFixed(n4, 0, str); len:=RC.LengthFixedReal(n4, 0);
RealToFixed(n4, 1, str); len:=RC.LengthFixedReal(n4, 1);
RealToFixed(n4, 4, str); len:=RC.LengthFixedReal(n4, 4);
RealToFixed(n3, -5, str); len:=RC.LengthFixedReal(n3, -5);
RealToFixed(n3, -2, str); len:=RC.LengthFixedReal(n3, -2);
RealToFixed(n3, -1, str); len:=RC.LengthFixedReal(n3, -1);
RealToFixed(n3, 0, str); len:=RC.LengthFixedReal(n3, 0);
RealToFixed(n3, 1, str); len:=RC.LengthFixedReal(n3, 1);
RealToFixed(n3, 4, str); len:=RC.LengthFixedReal(n3, 4);
END Test;
BEGIN
IF DEBUG THEN Test END
END oocRealStr.

78
src/library/ooc/oocRts.Mod Normal file
View file

@ -0,0 +1,78 @@
MODULE oocRts; (* module is written from scratch by noch to wrap around Unix.Mod and Args.Mod and provide compatibility for some ooc libraries *)
IMPORT Args, Unix, Files, Strings := oocStrings(*, Console*);
CONST
pathSeperator* = "/";
VAR i : INTEGER;
b : BOOLEAN;
str0 : ARRAY 128 OF CHAR;
PROCEDURE System* (command : ARRAY OF CHAR) : INTEGER;
(* Executes `command' as a shell command. Result is the value returned by
the libc `system' function. *)
BEGIN
RETURN Unix.System(command)
END System;
PROCEDURE GetEnv* (VAR var: ARRAY OF CHAR; name: ARRAY OF CHAR): BOOLEAN;
(* If an environment variable `name' exists, copy its value into `var' and
return TRUE. Otherwise return FALSE. *)
BEGIN
RETURN Args.getEnv(name, var);
END GetEnv;
PROCEDURE GetUserHome* (VAR home: ARRAY OF CHAR; user: ARRAY OF CHAR);
(* Get the user's home directory path (stored in /etc/passwd)
or the current user's home directory if user="". *)
VAR
f : Files.File;
r : Files.Rider;
str, str1 : ARRAY 1024 OF CHAR;
found, found1 : BOOLEAN;
p, p1, p2 : INTEGER;
BEGIN
f := Files.Old("/etc/passwd");
Files.Set(r, f, 0);
REPEAT
Files.ReadLine(r, str);
(* Console.String(str); Console.Ln;*)
Strings.Extract(str, 0, SHORT(LEN(user)-1), str1);
(* Console.String(str1); Console.Ln;*)
IF Strings.Equal(user, str1) THEN found := TRUE END;
UNTIL found OR r.eof;
IF found THEN
found1 := FALSE;
Strings.FindNext(":", str, SHORT(LEN(user)), found1, p); p2 := p + 1;
Strings.FindNext(":", str, p2, found1, p); p2 := p + 1;
Strings.FindNext(":", str, p2, found1, p); p2 := p + 1;
Strings.FindNext(":", str, p2, found1, p); p2 := p + 1;
Strings.FindNext(":", str, p2, found1, p1);
Strings.Extract(str,p+1,p1-p-1, home);
(*Console.String(home); Console.Ln;*)
ELSE
(* current user's home *)
found1 := GetEnv(home, "HOME");
(*Console.String("not found"); Console.Ln; Console.String (home); Console.Ln;*)
END
END GetUserHome;
BEGIN
(* test *)
(*
i := System("ls");
b := GetEnv(str0, "HOME");
IF b THEN Console.String(str0); Console.Ln END;
GetUserHome(str0, "noch");
*)
END oocRts.

497
src/library/ooc/oocStrings.Mod Normal file
View file

@ -0,0 +1,497 @@
(* $Id: Strings.Mod,v 1.4 1999/10/03 11:45:07 ooc-devel Exp $ *)
MODULE oocStrings;
(* Facilities for manipulating strings.
Copyright (C) 1996, 1997 Michael van Acken
This module is free software; you can redistribute it and/or
modify 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 OOC. If not, write to the Free Software Foundation,
59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
(*
Notes:
Unlike Modula-2, the behaviour of a procedure is undefined, if one of its input
parameters is an unterminated character array. All of the following procedures
expect to get 0X terminated strings, and will return likewise terminated
strings.
All input parameters that represent an array index or a length are expected to
be non-negative. In the descriptions below these restrictions are stated as
pre-conditions of the procedures, but they aren't checked explicitly. If this
module is compiled with enable run-time index checks some illegal input values
may be caught. By default it is installed _without_ index checks.
Differences from the Strings module of the Oakwood Guidelines:
- `Delete' is defined for `startPos' greater than `Length(stringVar)'
- `Insert' is defined for `startPos' greater than `Length(destination)'
- `Replace' is defined for `startPos' greater than `Length(destination)'
- `Replace' will never return a string in `destination' that is longer
than the initial value of `destination' before the call.
- `Capitalize' replaces `Cap'
- `FindNext' replaces `Pos' with slightly changed call pattern
- the `CanSomethingAll' predicates are new
- also new: `Compare', `Equal', `FindPrev', and `FindDiff'
*)
TYPE
CompareResults* = SHORTINT;
CONST
(* values returned by `Compare' *)
less* = -1;
equal* = 0;
greater* = 1;
PROCEDURE Length* (stringVal: ARRAY OF CHAR): INTEGER;
(* Returns the length of `stringVal'. This is equal to the number of
characters in `stringVal' up to and excluding the first 0X. *)
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (stringVal[i] # 0X) DO
INC (i)
END;
RETURN i
END Length;
(*
The following seven procedures construct a string value, and attempt to assign
it to a variable parameter. They all have the property that if the length of
the constructed string value exceeds the capacity of the variable parameter, a
truncated value is assigned. The constructed string always ends with the
string terminator 0X.
*)
PROCEDURE Assign* (source: ARRAY OF CHAR; VAR destination: ARRAY OF CHAR);
(* Copies `source' to `destination'. Equivalent to the predefined procedure
COPY. Unlike COPY, this procedure can be assigned to a procedure
variable. *)
VAR
i: INTEGER;
BEGIN
i := -1;
REPEAT
INC (i);
destination[i] := source[i]
UNTIL (destination[i] = 0X) OR (i = LEN (destination)-1);
destination[i] := 0X
END Assign;
PROCEDURE Extract* (source: ARRAY OF CHAR; startPos, numberToExtract: INTEGER;
VAR destination: ARRAY OF CHAR);
(* Copies at most `numberToExtract' characters from `source' to `destination',
starting at position `startPos' in `source'. An empty string value will be
extracted if `startPos' is greater than or equal to `Length(source)'.
pre: `startPos' and `numberToExtract' are not negative. *)
VAR
sourceLength, i: INTEGER;
BEGIN
(* make sure that we get an empty string if `startPos' refers to an array
index beyond `Length (source)' *)
sourceLength := Length (source);
IF (startPos > sourceLength) THEN
startPos := sourceLength
END;
(* make sure that `numberToExtract' doesn't exceed the capacity
of `destination' *)
IF (numberToExtract >= LEN (destination)) THEN
numberToExtract := SHORT (LEN (destination))-1
END;
(* copy up to `numberToExtract' characters to `destination' *)
i := 0;
WHILE (i < numberToExtract) & (source[startPos+i] # 0X) DO
destination[i] := source[startPos+i];
INC (i)
END;
destination[i] := 0X
END Extract;
PROCEDURE Delete* (VAR stringVar: ARRAY OF CHAR;
startPos, numberToDelete: INTEGER);
(* Deletes at most `numberToDelete' characters from `stringVar', starting at
position `startPos'. The string value in `stringVar' is not altered if
`startPos' is greater than or equal to `Length(stringVar)'.
pre: `startPos' and `numberToDelete' are not negative. *)
VAR
stringLength, i: INTEGER;
BEGIN
stringLength := Length (stringVar);
IF (startPos+numberToDelete < stringLength) THEN
(* `stringVar' has remaining characters beyond the deleted section;
these have to be moved forward by `numberToDelete' characters *)
FOR i := startPos TO stringLength-numberToDelete DO
stringVar[i] := stringVar[i+numberToDelete]
END
ELSIF (startPos < stringLength) THEN
stringVar[startPos] := 0X
END
END Delete;
PROCEDURE Insert* (source: ARRAY OF CHAR; startPos: INTEGER;
VAR destination: ARRAY OF CHAR);
(* Inserts `source' into `destination' at position `startPos'. After the call
`destination' contains the string that is contructed by first splitting
`destination' at the position `startPos' and then concatenating the first
half, `source', and the second half. The string value in `destination' is
not altered if `startPos' is greater than `Length(source)'. If `startPos =
Length(source)', then `source' is appended to `destination'.
pre: `startPos' is not negative. *)
VAR
sourceLength, destLength, destMax, i: INTEGER;
BEGIN
destLength := Length (destination);
sourceLength := Length (source);
destMax := SHORT (LEN (destination))-1;
IF (startPos+sourceLength < destMax) THEN
(* `source' is inserted inside of `destination' *)
IF (destLength+sourceLength > destMax) THEN
(* `destination' too long, truncate it *)
destLength := destMax-sourceLength;
destination[destLength] := 0X
END;
(* move tail section of `destination' *)
FOR i := destLength TO startPos BY -1 DO
destination[i+sourceLength] := destination[i]
END
ELSIF (startPos <= destLength) THEN
(* `source' replaces `destination' from `startPos' on *)
destination[destMax] := 0X; (* set string terminator *)
sourceLength := destMax-startPos (* truncate `source' *)
ELSE (* startPos > destLength: no change in `destination' *)
sourceLength := 0
END;
(* copy characters from `source' to `destination' *)
FOR i := 0 TO sourceLength-1 DO
destination[startPos+i] := source[i]
END
END Insert;
PROCEDURE Replace* (source: ARRAY OF CHAR; startPos: INTEGER;
VAR destination: ARRAY OF CHAR);
(* Copies `source' into `destination', starting at position `startPos'. Copying
stops when all of `source' has been copied, or when the last character of
the string value in `destination' has been replaced. The string value in
`destination' is not altered if `startPos' is greater than or equal to
`Length(source)'.
pre: `startPos' is not negative. *)
VAR
destLength, i: INTEGER;
BEGIN
destLength := Length (destination);
IF (startPos < destLength) THEN
(* if `startPos' is inside `destination', then replace characters until
the end of `source' or `destination' is reached *)
i := 0;
WHILE (startPos # destLength) & (source[i] # 0X) DO
destination[startPos] := source[i];
INC (startPos);
INC (i)
END
END
END Replace;
PROCEDURE Append* (source: ARRAY OF CHAR; VAR destination: ARRAY OF CHAR);
(* Appends source to destination. *)
VAR
destLength, i: INTEGER;
BEGIN
destLength := Length (destination);
i := 0;
WHILE (destLength < LEN (destination)-1) & (source[i] # 0X) DO
destination[destLength] := source[i];
INC (destLength);
INC (i)
END;
destination[destLength] := 0X
END Append;
PROCEDURE Concat* (source1, source2: ARRAY OF CHAR;
VAR destination: ARRAY OF CHAR);
(* Concatenates `source2' onto `source1' and copies the result into
`destination'. *)
VAR
i, j: INTEGER;
BEGIN
(* copy `source1' into `destination' *)
i := 0;
WHILE (source1[i] # 0X) & (i < LEN(destination)-1) DO
destination[i] := source1[i];
INC (i)
END;
(* append `source2' to `destination' *)
j := 0;
WHILE (source2[j] # 0X) & (i < LEN (destination)-1) DO
destination[i] := source2[j];
INC (j); INC (i)
END;
destination[i] := 0X
END Concat;
(*
The following predicates provide for pre-testing of the operation-completion
conditions for the procedures above.
*)
PROCEDURE CanAssignAll* (sourceLength: INTEGER; VAR destination: ARRAY OF CHAR): BOOLEAN;
(* Returns TRUE if a number of characters, indicated by `sourceLength', will
fit into `destination'; otherwise returns FALSE.
pre: `sourceLength' is not negative. *)
BEGIN
RETURN (sourceLength < LEN (destination))
END CanAssignAll;
PROCEDURE CanExtractAll* (sourceLength, startPos, numberToExtract: INTEGER;
VAR destination: ARRAY OF CHAR): BOOLEAN;
(* Returns TRUE if there are `numberToExtract' characters starting at
`startPos' and within the `sourceLength' of some string, and if the capacity
of `destination' is sufficient to hold `numberToExtract' characters;
otherwise returns FALSE.
pre: `sourceLength', `startPos', and `numberToExtract' are not negative. *)
BEGIN
RETURN (startPos+numberToExtract <= sourceLength) &
(numberToExtract < LEN (destination))
END CanExtractAll;
PROCEDURE CanDeleteAll* (stringLength, startPos,
numberToDelete: INTEGER): BOOLEAN;
(* Returns TRUE if there are `numberToDelete' characters starting at `startPos'
and within the `stringLength' of some string; otherwise returns FALSE.
pre: `stringLength', `startPos' and `numberToDelete' are not negative. *)
BEGIN
RETURN (startPos+numberToDelete <= stringLength)
END CanDeleteAll;
PROCEDURE CanInsertAll* (sourceLength, startPos: INTEGER;
VAR destination: ARRAY OF CHAR): BOOLEAN;
(* Returns TRUE if there is room for the insertion of `sourceLength'
characters from some string into `destination' starting at `startPos';
otherwise returns FALSE.
pre: `sourceLength' and `startPos' are not negative. *)
VAR
lenDestination: INTEGER;
BEGIN
lenDestination := Length (destination);
RETURN (startPos <= lenDestination) &
(sourceLength+lenDestination < LEN (destination))
END CanInsertAll;
PROCEDURE CanReplaceAll* (sourceLength, startPos: INTEGER;
VAR destination: ARRAY OF CHAR): BOOLEAN;
(* Returns TRUE if there is room for the replacement of `sourceLength'
characters in `destination' starting at `startPos'; otherwise returns FALSE.
pre: `sourceLength' and `startPos' are not negative. *)
BEGIN
RETURN (sourceLength+startPos <= Length(destination))
END CanReplaceAll;
PROCEDURE CanAppendAll* (sourceLength: INTEGER;
VAR destination: ARRAY OF CHAR): BOOLEAN;
(* Returns TRUE if there is sufficient room in `destination' to append a string
of length `sourceLength' to the string in `destination'; otherwise returns
FALSE.
pre: `sourceLength' is not negative. *)
BEGIN
RETURN (Length (destination)+sourceLength < LEN (destination))
END CanAppendAll;
PROCEDURE CanConcatAll* (source1Length, source2Length: INTEGER;
VAR destination: ARRAY OF CHAR): BOOLEAN;
(* Returns TRUE if there is sufficient room in `destination' for a two strings
of lengths `source1Length' and `source2Length'; otherwise returns FALSE.
pre: `source1Length' and `source2Length' are not negative. *)
BEGIN
RETURN (source1Length+source2Length < LEN (destination))
END CanConcatAll;
(*
The following type and procedures provide for the comparison of string values,
and for the location of substrings within strings.
*)
PROCEDURE Compare* (stringVal1, stringVal2: ARRAY OF CHAR): CompareResults;
(* Returns `less', `equal', or `greater', according as `stringVal1' is
lexically less than, equal to, or greater than `stringVal2'.
Note that Oberon-2 already contains predefined comparison operators on
strings. *)
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (stringVal1[i] # 0X) & (stringVal1[i] = stringVal2[i]) DO
INC (i)
END;
IF (stringVal1[i] < stringVal2[i]) THEN
RETURN less
ELSIF (stringVal1[i] > stringVal2[i]) THEN
RETURN greater
ELSE
RETURN equal
END
END Compare;
PROCEDURE Equal* (stringVal1, stringVal2: ARRAY OF CHAR): BOOLEAN;
(* Returns `stringVal1 = stringVal2'. Unlike the predefined operator `=', this
procedure can be assigned to a procedure variable. *)
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (stringVal1[i] # 0X) & (stringVal1[i] = stringVal2[i]) DO
INC (i)
END;
RETURN (stringVal1[i] = 0X) & (stringVal2[i] = 0X)
END Equal;
PROCEDURE FindNext* (pattern, stringToSearch: ARRAY OF CHAR; startPos: INTEGER;
VAR patternFound: BOOLEAN; VAR posOfPattern: INTEGER);
(* Looks forward for next occurrence of `pattern' in `stringToSearch', starting
the search at position `startPos'. If `startPos < Length(stringToSearch)'
and `pattern' is found, `patternFound' is returned as TRUE, and
`posOfPattern' contains the start position in `stringToSearch' of `pattern',
a value in the range [startPos..Length(stringToSearch)-1]. Otherwise
`patternFound' is returned as FALSE, and `posOfPattern' is unchanged.
If `startPos > Length(stringToSearch)-Length(Pattern)' then `patternFound'
is returned as FALSE.
pre: `startPos' is not negative. *)
VAR
patternPos: INTEGER;
BEGIN
IF (startPos < Length (stringToSearch)) THEN
patternPos := 0;
LOOP
IF (pattern[patternPos] = 0X) THEN
(* reached end of pattern *)
patternFound := TRUE;
posOfPattern := startPos-patternPos;
EXIT
ELSIF (stringToSearch[startPos] = 0X) THEN
(* end of string (but not of pattern) *)
patternFound := FALSE;
EXIT
ELSIF (stringToSearch[startPos] = pattern[patternPos]) THEN
(* characters identic, compare next one *)
INC (startPos);
INC (patternPos)
ELSE
(* difference found: reset indices and restart *)
startPos := startPos-patternPos+1;
patternPos := 0
END
END
ELSE
patternFound := FALSE
END
END FindNext;
PROCEDURE FindPrev* (pattern, stringToSearch: ARRAY OF CHAR; startPos: INTEGER;
VAR patternFound: BOOLEAN; VAR posOfPattern: INTEGER);
(* Looks backward for the previous occurrence of `pattern' in `stringToSearch'
and returns the position of the first character of the `pattern' if found.
The search for the pattern begins at `startPos'. If `pattern' is found,
`patternFound' is returned as TRUE, and `posOfPattern' contains the start
position in `stringToSearch' of pattern in the range [0..startPos].
Otherwise `patternFound' is returned as FALSE, and `posOfPattern' is
unchanged.
The pattern might be found at the given value of `startPos'. The search
will fail if `startPos' is negative.
If `startPos > Length(stringToSearch)-Length(pattern)' the whole string
value is searched. *)
VAR
patternPos, stringLength, patternLength: INTEGER;
BEGIN
(* correct `startPos' if it is larger than the possible searching range *)
stringLength := Length (stringToSearch);
patternLength := Length (pattern);
IF (startPos > stringLength-patternLength) THEN
startPos := stringLength-patternLength
END;
IF (startPos >= 0) THEN
patternPos := 0;
LOOP
IF (pattern[patternPos] = 0X) THEN
(* reached end of pattern *)
patternFound := TRUE;
posOfPattern := startPos-patternPos;
EXIT
ELSIF (stringToSearch[startPos] # pattern[patternPos]) THEN
(* characters differ: reset indices and restart *)
IF (startPos > patternPos) THEN
startPos := startPos-patternPos-1;
patternPos := 0
ELSE
(* reached beginning of `stringToSearch' without finding a match *)
patternFound := FALSE;
EXIT
END
ELSE (* characters identic, compare next one *)
INC (startPos);
INC (patternPos)
END
END
ELSE
patternFound := FALSE
END
END FindPrev;
PROCEDURE FindDiff* (stringVal1, stringVal2: ARRAY OF CHAR;
VAR differenceFound: BOOLEAN;
VAR posOfDifference: INTEGER);
(* Compares the string values in `stringVal1' and `stringVal2' for differences.
If they are equal, `differenceFound' is returned as FALSE, and TRUE
otherwise. If `differenceFound' is TRUE, `posOfDifference' is set to the
position of the first difference; otherwise `posOfDifference' is unchanged.
*)
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (stringVal1[i] # 0X) & (stringVal1[i] = stringVal2[i]) DO
INC (i)
END;
differenceFound := (stringVal1[i] # 0X) OR (stringVal2[i] # 0X);
IF differenceFound THEN
posOfDifference := i
END
END FindDiff;
PROCEDURE Capitalize* (VAR stringVar: ARRAY OF CHAR);
(* Applies the function CAP to each character of the string value in
`stringVar'. *)
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (stringVar[i] # 0X) DO
stringVar[i] := CAP (stringVar[i]);
INC (i)
END
END Capitalize;
END oocStrings.

100
src/library/ooc/oocStrings2.Mod Normal file
View file

@ -0,0 +1,100 @@
(* This module is obsolete. Don't use it. *)
MODULE oocStrings2;
IMPORT
Strings := oocStrings;
PROCEDURE AppendChar* (ch: CHAR; VAR dst: ARRAY OF CHAR);
(* Appends 'ch' to string 'dst' (if Length(dst)<LEN(dst)-1). *)
VAR
len: INTEGER;
BEGIN
len := Strings.Length (dst);
IF (len < SHORT (LEN (dst))-1) THEN
dst[len] := ch;
dst[len+1] := 0X
END
END AppendChar;
PROCEDURE InsertChar* (ch: CHAR; pos: INTEGER; VAR dst: ARRAY OF CHAR);
(* Inserts the character ch into the string dst at position pos (0<=pos<=
Length(dst)). If pos=Length(dst), src is appended to dst. If the size of
dst is not large enough to hold the result of the operation, the result is
truncated so that dst is always terminated with a 0X. *)
VAR
src: ARRAY 2 OF CHAR;
BEGIN
src[0] := ch; src[1] := 0X;
Strings.Insert (src, pos, dst)
END InsertChar;
PROCEDURE PosChar* (ch: CHAR; str: ARRAY OF CHAR): INTEGER;
(* Returns the first position of character 'ch' in 'str' or
-1 if 'str' doesn't contain the character.
Ex.: PosChar ("abcd", "c") = 2
PosChar ("abcd", "D") = -1 *)
VAR
i: INTEGER;
BEGIN
i := 0;
LOOP
IF (str[i] = ch) THEN
RETURN i
ELSIF (str[i] = 0X) THEN
RETURN -1
ELSE
INC (i)
END
END
END PosChar;
PROCEDURE Match* (pat, s: ARRAY OF CHAR): BOOLEAN;
(* Returns TRUE if the string in s matches the string in pat.
The pattern may contain any number of the wild characters '*' and '?'
'?' matches any single character
'*' matches any sequence of characters (including a zero length sequence)
E.g. '*.?' will match any string with two or more characters if it's second
last character is '.'. *)
VAR
lenSource,
lenPattern: INTEGER;
PROCEDURE RecMatch(VAR src: ARRAY OF CHAR; posSrc: INTEGER;
VAR pat: ARRAY OF CHAR; posPat: INTEGER): BOOLEAN;
(* src = to be tested , posSrc = position in src *)
(* pat = pattern to match, posPat = position in pat *)
VAR
i: INTEGER;
BEGIN
LOOP
IF (posSrc = lenSource) & (posPat = lenPattern) THEN
RETURN TRUE
ELSIF (posPat = lenPattern) THEN
RETURN FALSE
ELSIF (pat[posPat] = "*") THEN
IF (posPat = lenPattern-1) THEN
RETURN TRUE
ELSE
FOR i := posSrc TO lenSource DO
IF RecMatch (src, i, pat, posPat+1) THEN
RETURN TRUE
END
END;
RETURN FALSE
END
ELSIF (pat[posPat] # "?") & (pat[posPat] # src[posSrc]) THEN
RETURN FALSE
ELSE
INC(posSrc); INC(posPat)
END
END
END RecMatch;
BEGIN
lenPattern := Strings.Length (pat);
lenSource := Strings.Length (s);
RETURN RecMatch (s, 0, pat, 0)
END Match;
END oocStrings2.

110
src/library/ooc/oocSysClock.Mod Normal file
View file

@ -0,0 +1,110 @@
MODULE oocSysClock;
IMPORT Unix;
CONST
maxSecondParts* = 999; (* Most systems have just millisecond accuracy *)
zoneMin* = -780; (* time zone minimum minutes *)
zoneMax* = 720; (* time zone maximum minutes *)
localTime* = MIN(INTEGER); (* time zone is inactive & time is local *)
unknownZone* = localTime+1; (* time zone is unknown *)
(* daylight savings mode values *)
unknown* = -1; (* current daylight savings status is unknown *)
inactive* = 0; (* daylight savings adjustments are not in effect *)
active* = 1; (* daylight savings adjustments are being used *)
TYPE
(* The DateTime type is a system-independent time format whose fields
are defined as follows:
year > 0
month = 1 .. 12
day = 1 .. 31
hour = 0 .. 23
minute = 0 .. 59
second = 0 .. 59
fractions = 0 .. maxSecondParts
zone = -780 .. 720
*)
DateTime* =
RECORD
year*: INTEGER;
month*: SHORTINT;
day*: SHORTINT;
hour*: SHORTINT;
minute*: SHORTINT;
second*: SHORTINT;
summerTimeFlag*: SHORTINT; (* daylight savings mode (see above) *)
fractions*: INTEGER; (* parts of a second in milliseconds *)
zone*: INTEGER; (* Time zone differential factor which
is the number of minutes to add to
local time to obtain UTC or is set
to localTime when time zones are
inactive. *)
END;
PROCEDURE CanGetClock*(): BOOLEAN;
(* Returns TRUE if a system clock can be read; FALSE otherwise. *)
VAR timeval: Unix.Timeval; timezone: Unix.Timezone;
l : LONGINT;
BEGIN
l := Unix.Gettimeofday(timeval, timezone);
IF l = 0 THEN RETURN TRUE ELSE RETURN FALSE END
END CanGetClock;
(*
PROCEDURE CanSetClock*(): BOOLEAN;
(* Returns TRUE if a system clock can be set; FALSE otherwise. *)
*)
(*
PROCEDURE IsValidDateTime* (d: DateTime): BOOLEAN;
(* Returns TRUE if the value of `d' represents a valid date and time;
FALSE otherwise. *)
*)
(*
PROCEDURE SetClock* (userData: DateTime);
(* If possible, sets the system clock to the values of `userData'. *)
*)
(*
PROCEDURE MakeLocalTime * (VAR c: DateTime);
(* Fill in the daylight savings mode and time zone for calendar date `c'.
The fields `zone' and `summerTimeFlag' given in `c' are ignored, assuming
that the rest of the record describes a local time.
Note 1: On most Unix systems the time zone information is only available for
dates falling within approx. 1 Jan 1902 to 31 Dec 2037. Outside this range
the field `zone' will be set to the unspecified `localTime' value (see
above), and `summerTimeFlag' will be set to `unknown'.
Note 2: The time zone information might not be fully accurate for past (and
future) years that apply different DST rules than the current year.
Usually the current set of rules is used for _all_ years between 1902 and
2037.
Note 3: With DST there is one hour in the year that happens twice: the
hour after which the clock is turned back for a full hour. It is undefined
which time zone will be selected for dates refering to this hour, i.e.
whether DST or normal time zone will be chosen. *)
*)
PROCEDURE GetTimeOfDay* (VAR sec, usec: LONGINT): LONGINT;
(* PRIVAT. Don't use this. Take Time.GetTime instead.
Equivalent to the C function `gettimeofday'. The return value is `0' on
success and `-1' on failure; in the latter case `sec' and `usec' are set to
zero. *)
VAR timeval: Unix.Timeval; timezone: Unix.Timezone;
l : LONGINT;
BEGIN
l := Unix.Gettimeofday (timeval, timezone);
IF l = 0 THEN
sec := timeval.sec;
usec := timeval.usec;
ELSE
sec := 0;
usec := 0;
END;
RETURN l;
END GetTimeOfDay;
END oocSysClock.

1620
src/library/ooc/oocTextRider.Mod Normal file
View file

File diff suppressed because it is too large Load diff

205
src/library/ooc/oocTime.Mod Normal file
View file

@ -0,0 +1,205 @@
(* $Id: Time.Mod,v 1.6 2000/08/05 18:39:09 ooc-devel Exp $ *)
MODULE oocTime;
(*
Time - time and time interval manipulation.
Copyright (C) 1996 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
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 SysClock := oocSysClock;
CONST
msecPerSec* = 1000;
msecPerMin* = msecPerSec*60;
msecPerHour* = msecPerMin*60;
msecPerDay * = msecPerHour*24;
TYPE
(* The TimeStamp is a compressed date/time format with the
advantage over the Unix time stamp of being able to
represent any date/time in the DateTime type. The
fields are defined as follows:
days = Modified Julian days since 17 Nov 1858.
This quantity can be negative to represent
dates occuring before day zero.
msecs = Milliseconds since 00:00.
NOTE: TimeStamp is in UTC or local time when time zones
are not supported by the local operating system.
*)
TimeStamp * =
RECORD
days-: LONGINT;
msecs-: LONGINT
END;
(* The Interval is a delta time measure which can be used
to increment a Time or find the time difference between
two Times. The fields are defined as follows:
dayInt = numbers of days in this interval
msecInt = the number of milliseconds in this interval
The maximum number of milliseconds in an interval will
be the value `msecPerDay' *)
Interval * =
RECORD
dayInt-: LONGINT;
msecInt-: LONGINT
END;
(* ------------------------------------------------------------- *)
(* TimeStamp functions *)
PROCEDURE InitTimeStamp* (VAR t: TimeStamp; days, msecs: LONGINT);
(* Initialize the TimeStamp `t' with `days' days and `msecs' mS.
Pre: msecs>=0 *)
BEGIN
t.msecs:=msecs MOD msecPerDay;
t.days:=days + msecs DIV msecPerDay
END InitTimeStamp;
PROCEDURE GetTime* (VAR t: TimeStamp);
(* Set `t' to the current time of day. In case of failure (i.e. if
SysClock.CanGetClock() is FALSE) the time 00:00 UTC on Jan 1 1970 is
returned. This procedure is typically much faster than doing
SysClock.GetClock followed by Calendar.SetTimeStamp. *)
VAR
res, sec, usec: LONGINT;
BEGIN
res := SysClock.GetTimeOfDay (sec, usec);
t. days := 40587+sec DIV 86400;
t. msecs := (sec MOD 86400)*msecPerSec + usec DIV 1000
END GetTime;
PROCEDURE (VAR a: TimeStamp) Add* (b: Interval);
(* Adds the interval `b' to the time stamp `a'. *)
BEGIN
INC(a.msecs, b.msecInt);
INC(a.days, b.dayInt);
IF a.msecs>=msecPerDay THEN
DEC(a.msecs, msecPerDay); INC(a.days)
END
END Add;
PROCEDURE (VAR a: TimeStamp) Sub* (b: Interval);
(* Subtracts the interval `b' from the time stamp `a'. *)
BEGIN
DEC(a.msecs, b.msecInt);
DEC(a.days, b.dayInt);
IF a.msecs<0 THEN INC(a.msecs, msecPerDay); DEC(a.days) END
END Sub;
PROCEDURE (VAR a: TimeStamp) Delta* (b: TimeStamp; VAR c: Interval);
(* Post: c = a - b *)
BEGIN
c.msecInt:=a.msecs-b.msecs;
c.dayInt:=a.days-b.days;
IF c.msecInt<0 THEN
INC(c.msecInt, msecPerDay); DEC(c.dayInt)
END
END Delta;
PROCEDURE (VAR a: TimeStamp) Cmp* (b: TimeStamp) : SHORTINT;
(* Compares 'a' to 'b'. Result: -1: a<b; 0: a=b; 1: a>b
This means the comparison
can be directly extrapolated to a comparison between the
two numbers e.g.,
Cmp(a,b)<0 then a<b
Cmp(a,b)=0 then a=b
Cmp(a,b)>0 then a>b
Cmp(a,b)>=0 then a>=b
*)
BEGIN
IF (a.days>b.days) OR (a.days=b.days) & (a.msecs>b.msecs) THEN RETURN 1
ELSIF (a.days=b.days) & (a.msecs=b.msecs) THEN RETURN 0
ELSE RETURN -1
END
END Cmp;
(* ------------------------------------------------------------- *)
(* Interval functions *)
PROCEDURE InitInterval* (VAR int: Interval; days, msecs: LONGINT);
(* Initialize the Interval `int' with `days' days and `msecs' mS.
Pre: msecs>=0 *)
BEGIN
int.dayInt:=days + msecs DIV msecPerDay;
int.msecInt:=msecs MOD msecPerDay
END InitInterval;
PROCEDURE (VAR a: Interval) Add* (b: Interval);
(* Post: a = a + b *)
BEGIN
INC(a.msecInt, b.msecInt);
INC(a.dayInt, b.dayInt);
IF a.msecInt>=msecPerDay THEN
DEC(a.msecInt, msecPerDay); INC(a.dayInt)
END
END Add;
PROCEDURE (VAR a: Interval) Sub* (b: Interval);
(* Post: a = a - b *)
BEGIN
DEC(a.msecInt, b.msecInt);
DEC(a.dayInt, b.dayInt);
IF a.msecInt<0 THEN
INC(a.msecInt, msecPerDay); DEC(a.dayInt)
END
END Sub;
PROCEDURE (VAR a: Interval) Cmp* (b: Interval) : SHORTINT;
(* Compares 'a' to 'b'. Result: -1: a<b; 0: a=b; 1: a>b
Above convention makes more sense since the comparison
can be directly extrapolated to a comparison between the
two numbers e.g.,
Cmp(a,b)<0 then a<b
Cmp(a,b)=0 then a=b
Cmp(a,b)>0 then a>b
Cmp(a,b)>=0 then a>=b
*)
BEGIN
IF (a.dayInt>b.dayInt) OR (a.dayInt=b.dayInt)&(a.msecInt>b.msecInt) THEN RETURN 1
ELSIF (a.dayInt=b.dayInt) & (a.msecInt=b.msecInt) THEN RETURN 0
ELSE RETURN -1
END
END Cmp;
PROCEDURE (VAR a: Interval) Scale* (b: LONGREAL);
(* Pre: b>=0; Post: a := a*b *)
VAR
si: LONGREAL;
BEGIN
si:=(a.dayInt+a.msecInt/msecPerDay)*b;
a.dayInt:=ENTIER(si);
a.msecInt:=ENTIER((si-a.dayInt)*msecPerDay+0.5D0)
END Scale;
PROCEDURE (VAR a: Interval) Fraction* (b: Interval) : LONGREAL;
(* Pre: b<>0; Post: RETURN a/b *)
BEGIN
RETURN (a.dayInt+a.msecInt/msecPerDay)/(b.dayInt+b.msecInt/msecPerDay)
END Fraction;
END oocTime.

37
src/library/ooc2/ooc2Ascii.Mod Normal file
View file

@ -0,0 +1,37 @@
(* $Id: Ascii.Mod,v 1.2 2003/01/04 10:19:19 mva Exp $ *)
MODULE ooc2Ascii;
(* Standard short character names for control chars.
Copyright (C) 2002 Michael van Acken
This module is free software; you can redistribute it and/or
modify 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 OOC. If not, write to the Free Software Foundation,
59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
CONST
nul* = 00X; soh* = 01X; stx* = 02X; etx* = 03X;
eot* = 04X; enq* = 05X; ack* = 06X; bel* = 07X;
bs * = 08X; ht * = 09X; lf * = 0AX; vt * = 0BX;
ff * = 0CX; cr * = 0DX; so * = 0EX; si * = 0FX;
dle* = 10X; dc1* = 11X; dc2* = 12X; dc3* = 13X;
dc4* = 14X; nak* = 15X; syn* = 16X; etb* = 17X;
can* = 18X; em * = 19X; sub* = 1AX; esc* = 1BX;
fs * = 1CX; gs * = 1DX; rs * = 1EX; us * = 1FX;
del* = 7FX;
CONST (* often used synonyms *)
sp * = " ";
xon* = dc1;
xoff* = dc3;
END ooc2Ascii.

89
src/library/ooc2/ooc2CharClass.Mod Normal file
View file

@ -0,0 +1,89 @@
(* $Id: CharClass.Mod,v 1.1 2002/04/15 22:42:48 mva Exp $ *)
MODULE ooc2CharClass;
(* Classification of values of the type CHAR.
Copyright (C) 1997-1998, 2002 Michael van Acken
This module is free software; you can redistribute it and/or
modify 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 OOC. If not, write to the Free Software Foundation,
59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
IMPORT
Ascii := ooc2Ascii;
CONST
eol* = Ascii.lf;
(**The implementation-defined character used to represent end of line
internally for OOC. *)
VAR
systemEol-: ARRAY 3 OF CHAR;
(**End of line marker used by the target system for text files. The string
defined here can contain more than one character. For one character eol
markers, @ovar{systemEol} must not necessarily equal @oconst{eol}. Note
that the string cannot contain the termination character @code{0X}. *)
PROCEDURE IsNumeric* (ch: CHAR): BOOLEAN;
(**Returns @code{TRUE} if and only if @oparam{ch} is classified as a numeric
character. *)
BEGIN
RETURN ("0" <= ch) & (ch <= "9")
END IsNumeric;
PROCEDURE IsLetter* (ch: CHAR): BOOLEAN;
(**Returns @code{TRUE} if and only if @oparam{ch} is classified as a letter. *)
BEGIN
RETURN ("a" <= ch) & (ch <= "z") OR ("A" <= ch) & (ch <= "Z")
END IsLetter;
PROCEDURE IsUpper* (ch: CHAR): BOOLEAN;
(**Returns @code{TRUE} if and only if @oparam{ch} is classified as an upper
case letter. *)
BEGIN
RETURN ("A" <= ch) & (ch <= "Z")
END IsUpper;
PROCEDURE IsLower* (ch: CHAR): BOOLEAN;
(**Returns @code{TRUE} if and only if @oparam{ch} is classified as a lower case
letter. *)
BEGIN
RETURN ("a" <= ch) & (ch <= "z")
END IsLower;
PROCEDURE IsControl* (ch: CHAR): BOOLEAN;
(**Returns @code{TRUE} if and only if @oparam{ch} represents a control
function. *)
BEGIN
RETURN (ch < Ascii.sp)
END IsControl;
PROCEDURE IsWhiteSpace* (ch: CHAR): BOOLEAN;
(**Returns @code{TRUE} if and only if @oparam{ch} represents a space character
or a format effector. *)
BEGIN
RETURN (ch = Ascii.sp) OR (ch = Ascii.ff) OR (ch = Ascii.lf) OR
(ch = Ascii.cr) OR (ch = Ascii.ht) OR (ch = Ascii.vt)
END IsWhiteSpace;
PROCEDURE IsEol* (ch: CHAR): BOOLEAN;
(**Returns @code{TRUE} if and only if @oparam{ch} is the implementation-defined
character used to represent end of line internally for OOC. *)
BEGIN
RETURN (ch = eol)
END IsEol;
BEGIN
systemEol[0] := Ascii.lf; systemEol[1] := 0X
END ooc2CharClass.

45
src/library/ooc2/ooc2ConvTypes.Mod Normal file
View file

@ -0,0 +1,45 @@
(* $Id: ConvTypes.Mod,v 1.1 2002/05/10 22:25:18 mva Exp $ *)
MODULE ooc2ConvTypes;
(**Common types used in the string conversion modules. *)
TYPE
ConvResults*= SHORTINT;
(**Values of this type are used to express the format of a string. *)
CONST
strAllRight*=0;
(**The string format is correct for the corresponding conversion. *)
strOutOfRange*=1;
(**The string is well-formed but the value cannot be represented. *)
strWrongFormat*=2;
(**The string is in the wrong format for the conversion. *)
strEmpty*=3;
(**The given string is empty. *)
TYPE
ScanClass*= SHORTINT;
(**Values of this type are used to classify input to finite state scanners. *)
CONST
padding*=0;
(**A leading or padding character at this point in the scan---ignore it. *)
valid*=1;
(**A valid character at this point in the scan---accept it. *)
invalid*=2;
(*An invalid character at this point in the scan---reject it *)
terminator*=3;
(**A terminating character at this point in the scan (not part of token). *)
TYPE
ScanState*=POINTER TO ScanDesc;
ScanDesc*=RECORD
(**The type of lexical scanning control procedures. *)
p*: PROCEDURE (ch: CHAR; VAR cl: ScanClass; VAR st: ScanState);
(**A procedure that produces the next state corresponding to the
character @var{ch}. The class of the character is returned
in @var{cl}, the next state in @var{st}. *)
END;
END ooc2ConvTypes.

249
src/library/ooc2/ooc2IntConv.Mod Normal file
View file

@ -0,0 +1,249 @@
(* $Id: IntConv.Mod,v 1.6 2002/05/26 12:15:17 mva Exp $ *)
MODULE ooc2IntConv;
(*
IntConv - Low-level integer/string conversions.
Copyright (C) 2000, 2002 Michael van Acken
Copyright (C) 1995 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
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
Char := ooc2CharClass, Conv := ooc2ConvTypes;
TYPE
ConvResults* = Conv.ConvResults;
(**One of @oconst{strAllRight}, @oconst{strOutOfRange},
@oconst{strWrongFormat}, or @oconst{strEmpty}. *)
CONST
strAllRight*=Conv.strAllRight;
(**The string format is correct for the corresponding conversion. *)
strOutOfRange*=Conv.strOutOfRange;
(**The string is well-formed but the value cannot be represented. *)
strWrongFormat*=Conv.strWrongFormat;
(**The string is in the wrong format for the conversion. *)
strEmpty*=Conv.strEmpty;
(**The given string is empty. *)
VAR
W, S, SI: Conv.ScanState;
minInt, maxInt: ARRAY 11 OF CHAR;
CONST
maxDigits = 10; (* length of minInt, maxInt *)
(* internal state machine procedures *)
PROCEDURE WState(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
BEGIN
IF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=W
ELSE chClass:=Conv.terminator; nextState:=NIL
END
END WState;
PROCEDURE SState(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
BEGIN
IF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=W
ELSE chClass:=Conv.invalid; nextState:=S
END
END SState;
PROCEDURE ScanInt*(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
(**Represents the start state of a finite state scanner for signed whole
numbers---assigns class of @oparam{inputCh} to @oparam{chClass} and a
procedure representing the next state to @oparam{nextState}.
The call of @samp{ScanInt(inputCh,chClass,nextState)} shall assign values
to @oparam{chClass} and @oparam{nextState} depending upon the value of
@oparam{inputCh} as shown in the following table.
@example
Procedure inputCh chClass nextState (a procedure
with behaviour of)
--------- --------- -------- ---------
ScanInt space padding ScanInt
sign valid SState
decimal digit valid WState
other invalid ScanInt
SState decimal digit valid WState
other invalid SState
WState decimal digit valid WState
other terminator --
@end example
NOTE 1 -- The procedure @oproc{ScanInt} corresponds to the start state of a
finite state machine to scan for a character sequence that forms a signed
whole number. It may be used to control the actions of a finite state
interpreter. As long as the value of @oparam{chClass} is other than
@oconst{Conv.terminator} or @oconst{Conv.invalid}, the
interpreter should call the procedure whose value is assigned to
@oparam{nextState} by the previous call, supplying the next character from
the sequence to be scanned. It may be appropriate for the interpreter to
ignore characters classified as @oconst{Conv.invalid}, and proceed
with the scan. This would be the case, for example, with interactive
input, if only valid characters are being echoed in order to give
interactive users an immediate indication of badly-formed data. If the
character sequence end before one is classified as a terminator, the
string-terminator character should be supplied as input to the finite state
scanner. If the preceeding character sequence formed a complete number,
the string-terminator will be classified as @oconst{Conv.terminator},
otherwise it will be classified as @oconst{Conv.invalid}. *)
BEGIN
IF Char.IsWhiteSpace(inputCh) THEN chClass:=Conv.padding; nextState:=SI
ELSIF (inputCh="+") OR (inputCh="-") THEN chClass:=Conv.valid; nextState:=S
ELSIF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=W
ELSE chClass:=Conv.invalid; nextState:=SI
END
END ScanInt;
PROCEDURE FormatInt*(str: ARRAY OF CHAR): ConvResults;
(**Returns the format of the string value for conversion to LONGINT. *)
VAR
ch: CHAR;
index, start: INTEGER;
state: Conv.ScanState;
positive: BOOLEAN;
prev, class: Conv.ScanClass;
PROCEDURE LessOrEqual (VAR high: ARRAY OF CHAR; start, end: INTEGER): BOOLEAN;
VAR
i: INTEGER;
BEGIN (* pre: index-start = maxDigits *)
i := 0;
WHILE (start # end) DO
IF (str[start] < high[i]) THEN
RETURN TRUE;
ELSIF (str[start] > high[i]) THEN
RETURN FALSE;
ELSE (* str[start] = high[i] *)
INC (start); INC (i);
END;
END;
RETURN TRUE; (* full match *)
END LessOrEqual;
BEGIN
index:=0; prev:=Conv.padding; state:=SI; positive:=TRUE; start := -1;
LOOP
ch:=str[index];
state.p(ch, class, state);
CASE class OF
| Conv.padding: (* nothing to do *)
| Conv.valid:
IF ch="-" THEN positive:=FALSE
ELSIF ch="+" THEN positive:=TRUE
ELSIF (start < 0) & (ch # "0") THEN
start := index;
END
| Conv.invalid:
IF (prev = Conv.padding) & (ch = 0X) THEN
RETURN strEmpty;
ELSE
RETURN strWrongFormat;
END;
| Conv.terminator:
IF (ch = 0X) THEN
IF (index-start < maxDigits) OR
(index-start = maxDigits) &
(positive & LessOrEqual (maxInt, start, index) OR
~positive & LessOrEqual (minInt, start, index)) THEN
RETURN strAllRight;
ELSE
RETURN strOutOfRange;
END;
ELSE
RETURN strWrongFormat;
END;
END;
prev:=class; INC(index)
END;
END FormatInt;
PROCEDURE ValueInt*(str: ARRAY OF CHAR): LONGINT;
(**Returns the value corresponding to the signed whole number string value
@oparam{str} if @oparam{str} is well-formed. Otherwise, result is
undefined. *)
VAR
i: INTEGER;
int: LONGINT;
positive: BOOLEAN;
BEGIN
IF FormatInt(str)=strAllRight THEN
(* here holds: `str' is a well formed string and its value is in range *)
i:=0; positive:=TRUE;
WHILE (str[i] < "0") OR (str[i] > "9") DO (* skip whitespace and sign *)
IF (str[i] = "-") THEN
positive := FALSE;
END;
INC (i);
END;
int := 0;
IF positive THEN
WHILE (str[i] # 0X) DO
int:=int*10 + (ORD(str[i]) - ORD("0"));
INC (i);
END;
ELSE
WHILE (str[i] # 0X) DO
int:=int*10 - (ORD(str[i]) - ORD("0"));
INC (i);
END;
END;
RETURN int;
ELSE (* result is undefined *)
RETURN 0;
END
END ValueInt;
PROCEDURE LengthInt*(int: LONGINT): INTEGER;
(**Returns the number of characters in the string representation of
@oparam{int}. This value corresponds to the capacity of an array @samp{str}
which is of the minimum capacity needed to avoid truncation of the result in
the call @samp{IntStr.IntToStr(int,str)}. *)
VAR
cnt: INTEGER;
BEGIN
IF int=MIN(LONGINT) THEN
RETURN maxDigits+1;
ELSE
IF int<=0 THEN int:=-int; cnt:=1
ELSE cnt:=0
END;
WHILE int>0 DO INC(cnt); int:=int DIV 10 END;
RETURN cnt;
END;
END LengthInt;
BEGIN
(* kludge necessary because of recursive procedure declaration *)
NEW(S); NEW(W); NEW(SI);
S.p:=SState; W.p:=WState; SI.p:=ScanInt;
minInt := "2147483648";
maxInt := "2147483647";
END ooc2IntConv.

103
src/library/ooc2/ooc2IntStr.Mod Normal file
View file

@ -0,0 +1,103 @@
(* $Id: IntStr.Mod,v 1.1 2002/05/12 21:58:14 mva Exp $ *)
MODULE ooc2IntStr;
(* IntStr - Integer-number/string conversions.
Copyright (C) 1995 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
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
Conv := ooc2ConvTypes, IntConv := ooc2IntConv;
TYPE
ConvResults*= Conv.ConvResults;
(**One of @oconst{strAllRight}, @oconst{strOutOfRange},
@oconst{strWrongFormat}, or @oconst{strEmpty}. *)
CONST
strAllRight*=Conv.strAllRight;
(**The string format is correct for the corresponding conversion. *)
strOutOfRange*=Conv.strOutOfRange;
(**The string is well-formed but the value cannot be represented. *)
strWrongFormat*=Conv.strWrongFormat;
(**The string is in the wrong format for the conversion. *)
strEmpty*=Conv.strEmpty;
(**The given string is empty. *)
(* the string form of a signed whole number is
["+" | "-"] decimal_digit {decimal_digit}
*)
PROCEDURE StrToInt*(str: ARRAY OF CHAR; VAR int: LONGINT; VAR res: ConvResults);
(**Converts string to integer value. Ignores any leading spaces in
@oparam{str}. If the subsequent characters in @oparam{str} are in the
format of a signed whole number, assigns a corresponding value to
@oparam{int}. Assigns a value indicating the format of @oparam{str} to
@oparam{res}. *)
BEGIN
res:=IntConv.FormatInt(str);
IF (res = strAllRight) THEN
int:=IntConv.ValueInt(str)
END
END StrToInt;
PROCEDURE Reverse (VAR str : ARRAY OF CHAR; start, end : INTEGER);
(* Reverses order of characters in the interval [start..end]. *)
VAR
h : CHAR;
BEGIN
WHILE start < end DO
h := str[start]; str[start] := str[end]; str[end] := h;
INC(start); DEC(end)
END
END Reverse;
PROCEDURE IntToStr*(int: LONGINT; VAR str: ARRAY OF CHAR);
(**Converts the value of @oparam{int} to string form and copies the possibly
truncated result to @oparam{str}. *)
CONST
maxLength = 11; (* maximum number of digits representing a LONGINT value *)
VAR
b : ARRAY maxLength+1 OF CHAR;
s, e: INTEGER;
BEGIN
(* build representation in string 'b' *)
IF int = MIN(LONGINT) THEN (* smallest LONGINT, -int is an overflow *)
b := "-2147483648";
e := 11
ELSE
IF int < 0 THEN (* negative sign *)
b[0] := "-"; int := -int; s := 1
ELSE (* no sign *)
s := 0
END;
e := s; (* 's' holds starting position of string *)
REPEAT
b[e] := CHR(int MOD 10+ORD("0"));
int := int DIV 10;
INC(e)
UNTIL int = 0;
b[e] := 0X;
Reverse(b, s, e-1)
END;
COPY(b, str) (* truncate output if necessary *)
END IntToStr;
END ooc2IntStr.

106
src/library/ooc2/ooc2LRealConv.Mod Normal file
View file

@ -0,0 +1,106 @@
(* $Id: LRealConv.Mod,v 1.13 2003/04/06 12:11:15 mva Exp $ *)
MODULE ooc2LRealConv;
(* String to LONGREAL conversion functions.
Copyright (C) 2002 Michael van Acken
This module is free software; you can redistribute it and/or
modify 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 OOC. If not, write to the Free Software Foundation,
59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
IMPORT
SYSTEM, libc := oocwrapperlibc, CharClass := ooc2CharClass, ConvTypes := ooc2ConvTypes, Real0 := ooc2Real0;
(**
The regular expression for a signed fixed-point real number is
@samp{[+-]?\d+(\.\d* )?}. For the optional exponent part, it is
@samp{E[+-]?\d+}.
*)
TYPE
ConvResults* = ConvTypes.ConvResults;
(**One of @oconst{strAllRight}, @oconst{strOutOfRange},
@oconst{strWrongFormat}, or @oconst{strEmpty}. *)
CONST
strAllRight*=ConvTypes.strAllRight;
(**The string format is correct for the corresponding conversion. *)
strOutOfRange*=ConvTypes.strOutOfRange;
(**The string is well-formed but the value cannot be represented. *)
strWrongFormat*=ConvTypes.strWrongFormat;
(**The string is in the wrong format for the conversion. *)
strEmpty*=ConvTypes.strEmpty;
(**The given string is empty. *)
CONST
maxValue = "17976931348623157";
(* signifcant digits of the maximum value 1.7976931348623157D+308 *)
maxExp = 308;
(* maxium positive exponent of a normalized number *)
PROCEDURE ScanReal*(inputCh: CHAR;
VAR chClass: ConvTypes.ScanClass;
VAR nextState: ConvTypes.ScanState);
BEGIN
Real0.ScanReal (inputCh, chClass, nextState);
END ScanReal;
PROCEDURE FormatReal* (str: ARRAY OF CHAR): ConvResults;
BEGIN
RETURN Real0.FormatReal (str, maxExp, maxValue);
END FormatReal;
PROCEDURE ValueReal*(str: ARRAY OF CHAR): LONGREAL;
(* result is undefined if FormatReal(str) # strAllRight *)
VAR
i: LONGINT;
value: LONGREAL;
BEGIN
i := 0;
WHILE CharClass.IsWhiteSpace(str[i]) DO
(* skip our definition of whitespace *)
INC (i);
END;
IF libc.sscanf(SYSTEM.ADR(str[i]), "%lf", SYSTEM.ADR(value)) = 1 THEN
(* <*PUSH; Warnings:=FALSE*> *)
RETURN value (* syntax is ok *)
(* <*POP*> *)
ELSE
RETURN 0; (* error *)
END;
END ValueReal;
PROCEDURE LengthFloatReal*(real: LONGREAL; sigFigs: INTEGER): INTEGER;
BEGIN
(*<*PUSH; Assertions:=TRUE*>*)
ASSERT (FALSE)
(*<*POP*>*)
END LengthFloatReal;
PROCEDURE LengthEngReal*(real: LONGREAL; sigFigs: INTEGER): INTEGER;
BEGIN
(*<*PUSH; Assertions:=TRUE*>*)
ASSERT (FALSE)
(*<*POP*>*)
END LengthEngReal;
PROCEDURE LengthFixedReal*(real: LONGREAL; place: INTEGER): INTEGER;
BEGIN
(*<*PUSH; Assertions:=TRUE*>*)
ASSERT (FALSE)
(*<*POP*>*)
END LengthFixedReal;
END ooc2LRealConv.

447
src/library/ooc2/ooc2Real0.Mod Normal file
View file

@ -0,0 +1,447 @@
(* $Id: Real0.Mod,v 1.3 2002/08/12 18:11:30 mva Exp $ *)
MODULE ooc2Real0;
(* Helper functions used by the real conversion modules.
Copyright (C) 2002 Michael van Acken
This module is free software; you can redistribute it and/or
modify 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 OOC. If not, write to the Free Software Foundation,
59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
IMPORT
CharClass := ooc2CharClass, ConvTypes := ooc2ConvTypes, Strings := ooc2Strings;
TYPE
ConvResults = ConvTypes.ConvResults;
CONST
strAllRight=ConvTypes.strAllRight;
strOutOfRange=ConvTypes.strOutOfRange;
strWrongFormat=ConvTypes.strWrongFormat;
strEmpty=ConvTypes.strEmpty;
CONST
padding=ConvTypes.padding;
valid=ConvTypes.valid;
invalid=ConvTypes.invalid;
terminator=ConvTypes.terminator;
TYPE
ScanClass = ConvTypes.ScanClass;
ScanState = ConvTypes.ScanState;
CONST
expChar* = "E";
VAR
RS-, P-, F-, E-, SE-, WE-, SR-: ScanState;
(* internal state machine procedures *)
PROCEDURE IsSign (ch: CHAR): BOOLEAN;
(* Return TRUE for '+' or '-' *)
BEGIN
RETURN (ch='+') OR (ch='-')
END IsSign;
PROCEDURE RSState(inputCh: CHAR;
VAR chClass: ScanClass; VAR nextState: ScanState);
BEGIN
IF CharClass.IsNumeric(inputCh) THEN
chClass:=valid; nextState:=P
ELSE
chClass:=invalid; nextState:=RS
END
END RSState;
PROCEDURE PState(inputCh: CHAR;
VAR chClass: ScanClass; VAR nextState: ScanState);
BEGIN
IF CharClass.IsNumeric(inputCh) THEN
chClass:=valid; nextState:=P
ELSIF inputCh="." THEN
chClass:=valid; nextState:=F
ELSIF inputCh=expChar THEN
chClass:=valid; nextState:=E
ELSE
chClass:=terminator; nextState:=NIL
END
END PState;
PROCEDURE FState(inputCh: CHAR;
VAR chClass: ScanClass; VAR nextState: ScanState);
BEGIN
IF CharClass.IsNumeric(inputCh) THEN
chClass:=valid; nextState:=F
ELSIF inputCh=expChar THEN
chClass:=valid; nextState:=E
ELSE
chClass:=terminator; nextState:=NIL
END
END FState;
PROCEDURE EState(inputCh: CHAR;
VAR chClass: ScanClass; VAR nextState: ScanState);
BEGIN
IF IsSign(inputCh) THEN
chClass:=valid; nextState:=SE
ELSIF CharClass.IsNumeric(inputCh) THEN
chClass:=valid; nextState:=WE
ELSE
chClass:=invalid; nextState:=E
END
END EState;
PROCEDURE SEState(inputCh: CHAR;
VAR chClass: ScanClass; VAR nextState: ScanState);
BEGIN
IF CharClass.IsNumeric(inputCh) THEN
chClass:=valid; nextState:=WE
ELSE
chClass:=invalid; nextState:=SE
END
END SEState;
PROCEDURE WEState(inputCh: CHAR;
VAR chClass: ScanClass; VAR nextState: ScanState);
BEGIN
IF CharClass.IsNumeric(inputCh) THEN
chClass:=valid; nextState:=WE
ELSE
chClass:=terminator; nextState:=NIL
END
END WEState;
PROCEDURE ScanReal*(inputCh: CHAR;
VAR chClass: ScanClass; VAR nextState: ScanState);
BEGIN
IF CharClass.IsWhiteSpace(inputCh) THEN
chClass:=padding; nextState:=SR
ELSIF IsSign(inputCh) THEN
chClass:=valid; nextState:=RS
ELSIF CharClass.IsNumeric(inputCh) THEN
chClass:=valid; nextState:=P
ELSE
chClass:=invalid; nextState:=SR
END
END ScanReal;
PROCEDURE FormatReal* (str: ARRAY OF CHAR; maxExp: LONGINT;
maxValue: ARRAY OF CHAR): ConvResults;
VAR
i: LONGINT;
ch: CHAR;
state: ConvTypes.ScanState;
class: ConvTypes.ScanClass;
wSigFigs, fLeadingZeros, exp, startOfExp: LONGINT;
expNegative, allZeroDigit: BOOLEAN;
CONST
expCutoff = 100000000;
(* assume overflow if the value of the exponent is larger than this *)
PROCEDURE NonZeroDigit (): LONGINT;
(* locate first non-zero digit in str *)
BEGIN
i := 0;
WHILE (i # startOfExp) & ((str[i] < "1") OR (str[i] > "9")) DO
INC (i);
END;
RETURN i;
END NonZeroDigit;
PROCEDURE LessOrEqual (upperBound: ARRAY OF CHAR): BOOLEAN;
VAR
i, j: LONGINT;
BEGIN
i := NonZeroDigit();
IF (i # startOfExp) THEN (* str[i] is non-zero digit *)
j := 0;
WHILE (i # startOfExp) & (upperBound[j] # 0X) DO
IF (str[i] < upperBound[j]) THEN
RETURN TRUE;
ELSIF (str[i] > upperBound[j]) THEN
RETURN FALSE;
ELSE
INC (j); INC (i);
IF (str[i] = ".") THEN (* skip decimal point *)
INC (i);
END;
END;
END;
IF (upperBound[j] = 0X) THEN
(* any trailing zeros don't change the outcome: skip them *)
WHILE (str[i] = "0") OR (str[i] = ".") DO
INC (i);
END;
END;
END;
RETURN (i = startOfExp);
END LessOrEqual;
BEGIN
(* normalize exponent character *)
i := 0;
WHILE (str[i] # 0X) & (str[i] # "e") DO
INC (i);
END;
IF (str[i] = "e") THEN
str[i] := expChar;
END;
(* move index `i' over padding characters *)
i := 0;
state := SR;
REPEAT
ch := str[i];
state.p(ch, class, state);
INC (i);
UNTIL (class # ConvTypes.padding);
IF (ch = 0X) THEN
RETURN strEmpty;
ELSE
(* scan part before decimal point or exponent *)
WHILE (class = ConvTypes.valid) & (state # F) & (state # E) &
((ch < "1") OR (ch > "9")) DO
ch := str[i];
state.p(ch, class, state);
INC (i);
END;
wSigFigs := 0;
WHILE (class = ConvTypes.valid) & (state # F) & (state # E) DO
INC (wSigFigs);
ch := str[i];
state.p(ch, class, state);
INC (i);
END;
(* here holds: wSigFigs is the number of significant digits in
the whole number part of the number; 0 means there are only
zeros before the decimal point *)
(* scan fractional part exponent *)
fLeadingZeros := 0; allZeroDigit := TRUE;
WHILE (class = ConvTypes.valid) & (state # E) DO
ch := str[i];
IF allZeroDigit THEN
IF (ch = "0") THEN
INC (fLeadingZeros);
ELSIF (ch # ".") THEN
allZeroDigit := FALSE;
END;
END;
state.p(ch, class, state);
INC (i);
END;
(* here holds: fLeadingZeros holds the number of zeros after
the decimal point *)
(* scan exponent *)
startOfExp := i-1; exp := 0; expNegative := FALSE;
WHILE (class = ConvTypes.valid) DO
ch := str[i];
IF (ch = "-") THEN
expNegative := TRUE;
ELSIF ("0" <= ch) & (ch <= "9") & (exp < expCutoff) THEN
exp := exp*10 + (ORD(ch)-ORD("0"));
END;
state.p(ch, class, state);
INC (i);
END;
IF expNegative THEN
exp := -exp;
END;
(* here holds: exp holds the value of the exponent; if it's absolute
value is larger than expCutoff, then there has been an overflow *)
IF (class = ConvTypes.invalid) OR (ch # 0X) THEN
RETURN strWrongFormat;
ELSE (* (class = ConvTypes.terminator) & (ch = 0X) *)
(* normalize the number: calculate the exponent if the number would
start with a non-zero digit, immediately followed by the
decimal point *)
IF (wSigFigs > 0) THEN
exp := exp+wSigFigs-1;
ELSE
exp := exp-fLeadingZeros-1;
END;
IF (exp > maxExp) & (NonZeroDigit() # startOfExp) OR
(exp = maxExp) & ~LessOrEqual (maxValue) THEN
RETURN strOutOfRange;
ELSE
RETURN strAllRight;
END;
END;
END;
END FormatReal;
PROCEDURE NormalizeFloat* (VAR s: ARRAY OF CHAR);
VAR
i, d: INTEGER;
BEGIN
(* massage the output of sprintf to match our requirements; note: this
code should also handle "Inf", "Infinity", "NaN", etc., gracefully
but this is untested *)
IF (s[0] = "+") THEN d := 1; ELSE d := 0; END; (* erase "+" sign *)
i := 1;
WHILE (s[i] # 0X) DO
IF (s[i] = ".") & (s[i+1] = expChar) THEN
INC (d); (* eliminate "." if no digits follow *)
ELSIF (s[i] = "0") & (i-d-1 >= 0) & IsSign (s[i-d-1]) THEN
INC (d); (* eliminate zeros after exponent sign *)
ELSE
s[i-d] := s[i];
END;
INC (i);
END;
IF (s[i-d-2] = "E") THEN
s[i-d-2] := 0X; (* remove "E+" or "E-" *)
ELSE
s[i-d] := 0X;
END;
END NormalizeFloat;
PROCEDURE FormatForEng* (VAR s: ARRAY OF CHAR);
VAR
i, d, fract, exp, posExp, offset: INTEGER;
BEGIN
(* find out how large the exponent is, and how many digits are in the
fractional part *)
fract := 0; exp := 0; posExp := 0;
IF CharClass.IsNumeric (s[1]) THEN (* skip for NaN, Inf *)
i := 0; d := 0;
WHILE (s[i] # "E") DO
fract := fract + d;
IF (s[i] = ".") THEN d := 1; END;
INC (i);
END;
INC (i);
IF (s[i] = "-") THEN d := -1; ELSE d := 1; END;
posExp := i;
INC (i);
WHILE (s[i] # 0X) DO
exp := exp*10 + d*(ORD (s[i]) - ORD ("0"));
INC (i);
END;
END;
offset := exp MOD 3;
IF (offset # 0) THEN
WHILE (fract < offset) DO (* need more zeros before "E" *)
Strings.Insert ("0", posExp-1, s); INC (fract); INC (posExp);
END;
i := 2;
WHILE (i < offset+2) DO (* move "." offset places to right *)
s[i] := s[i+1]; INC (i);
END;
s[i] := ".";
(* write new exponent *)
exp := exp-offset;
IF (exp < 0) THEN
exp := -exp; s[posExp] := "-";
ELSE
s[posExp] := "+";
END;
s[posExp+1] := CHR (exp DIV 100 + ORD("0"));
s[posExp+2] := CHR (exp DIV 10 MOD 10 + ORD("0"));
s[posExp+3] := CHR (exp MOD 10 + ORD("0"));
s[posExp+4] := 0X;
END;
NormalizeFloat (s);
END FormatForEng;
PROCEDURE FormatForFixed* (VAR s: ARRAY OF CHAR; place: INTEGER);
VAR
i, d, c, fract, point, suffix: INTEGER;
PROCEDURE NotZero (VAR s: ARRAY OF CHAR; pos: INTEGER): BOOLEAN;
BEGIN
WHILE (s[pos] # 0X) DO
IF (s[pos] # "0") & (s[pos] # ".") THEN
RETURN TRUE;
END;
INC (pos);
END;
RETURN FALSE;
END NotZero;
BEGIN
IF (place < 0) THEN
(* locate position of decimal point in string *)
point := 1;
WHILE (s[point] # ".") DO INC (point); END;
(* number of digits before point is `point-1'; position in string
of the first digit that will be converted to zero due to rounding:
`point+place+1'; rightmost digit that may be incremented because
of rounding: `point+place' *)
IF (point+place >= 0) THEN
suffix := point+place+1; IF (s[suffix] = ".") THEN INC (suffix); END;
IF (s[suffix] > "5") OR
(s[suffix] = "5") &
(NotZero (s, suffix+1) OR
(point+place # 0) & ODD (ORD (s[point+place]))) THEN
(* we are rounding up *)
i := point+place;
WHILE (s[i] = "9") DO s[i] := "0"; DEC (i); END;
IF (i = 0) THEN (* looking at sign *)
Strings.Insert ("1", 1, s); INC (point);
ELSE
s[i] := CHR (ORD (s[i])+1); (* increment non-"9" digit by one *)
END;
END;
(* zero everything after the digit at `place' *)
i := point+place+1;
IF (i = 1) THEN (* all zero *)
s[1] := "0"; s[2] := 0X;
ELSE
WHILE (s[i] # ".") DO s[i] := "0"; INC (i); END;
END;
ELSE (* round to zero *)
s[1] := "0"; s[2] := 0X;
END;
s[point] := 0X;
END;
(* correct sign, and add trailing zeros if necessary *)
IF (s[0] = "+") THEN d := 1; ELSE d := 0; END; (* erase "+" sign *)
i := 1; fract := 0; c := 0;
WHILE (s[i] # 0X) DO
s[i-d] := s[i];
fract := fract+c;
IF (s[i] = ".") THEN
c := 1;
END;
INC (i);
END;
WHILE (fract < place) DO
s[i-d] := "0"; INC (fract); INC (i);
END;
s[i-d] := 0X;
END FormatForFixed;
BEGIN
NEW(RS); RS.p:=RSState;
NEW(P); P.p:=PState;
NEW(F); F.p:=FState;
NEW(E); E.p:=EState;
NEW(SE); SE.p:=SEState;
NEW(WE); WE.p:=WEState;
NEW(SR); SR.p:=ScanReal;
END ooc2Real0.

524
src/library/ooc2/ooc2Strings.Mod Normal file
View file

@ -0,0 +1,524 @@
(* $Id: Strings.Mod,v 1.2 2002/03/11 21:33:22 mva Exp $ *)
MODULE ooc2Strings;
(* Facilities for manipulating strings in character arrays.
Copyright (C) 1996, 1997 Michael van Acken
This module is free software; you can redistribute it and/or
modify 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 OOC. If not, write to the Free Software Foundation,
59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
(**
Unlike Modula-2, the behaviour of a procedure is undefined, if one of its input
parameters is an unterminated character array. All of the following procedures
expect to get 0X terminated strings, and will return likewise terminated
strings.
All input parameters that represent an array index or a length are
expected to be non-negative. In the descriptions below these
restrictions are stated as pre-conditions of the procedures, but they
aren't checked explicitly. If this module is compiled with run-time
index enabled, checks some illegal input values may be caught. By
default it is installed @emph{without} index checks.
*)
TYPE
CompareResults* = SHORTINT;
(**Result type of @oproc{Compare}. *)
CONST
less* = -1;
(**Result of @oproc{Compare} if the first argument is lexically less
than the second one. *)
equal* = 0;
(**Result of @oproc{Compare} if the first argument is equal to the second
one. *)
greater* = 1;
(**Result of @oproc{Compare} if the first argument is lexically greater
than the second one. *)
PROCEDURE Length* (stringVal: ARRAY OF CHAR): INTEGER;
(**Returns the length of @oparam{stringVal}. This is equal to the number of
characters in @oparam{stringVal} up to and excluding the first @code{0X}. *)
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (stringVal[i] # 0X) DO
INC (i)
END;
RETURN i
END Length;
PROCEDURE Assign* (source: ARRAY OF CHAR; VAR destination: ARRAY OF CHAR);
(**Copies @oparam{source} to @oparam{destination}. Equivalent to the
predefined procedure @code{COPY}. Unlike @code{COPY}, this procedure can be
assigned to a procedure variable. *)
VAR
i: INTEGER;
BEGIN
i := -1;
REPEAT
INC (i);
destination[i] := source[i]
UNTIL (destination[i] = 0X) OR (i = LEN (destination)-1);
destination[i] := 0X
END Assign;
PROCEDURE Extract* (source: ARRAY OF CHAR; startPos, numberToExtract: INTEGER;
VAR destination: ARRAY OF CHAR);
(**Copies at most @oparam{numberToExtract} characters from @oparam{source} to
@oparam{destination}, starting at position @oparam{startPos} in
@oparam{source}. An empty string value will be extracted if
@oparam{startPos} is greater than or equal to @samp{Length(source)}.
@precond
@oparam{startPos} and @oparam{numberToExtract} are not negative.
@end precond *)
VAR
sourceLength, i: INTEGER;
BEGIN
(* make sure that we get an empty string if `startPos' refers to an array
index beyond `Length (source)' *)
sourceLength := Length (source);
IF (startPos > sourceLength) THEN
startPos := sourceLength
END;
(* make sure that `numberToExtract' doesn't exceed the capacity
of `destination' *)
IF (numberToExtract >= LEN (destination)) THEN
numberToExtract := SHORT (LEN (destination))-1
END;
(* copy up to `numberToExtract' characters to `destination' *)
i := 0;
WHILE (i < numberToExtract) & (source[startPos+i] # 0X) DO
destination[i] := source[startPos+i];
INC (i)
END;
destination[i] := 0X
END Extract;
PROCEDURE Delete* (VAR stringVar: ARRAY OF CHAR;
startPos, numberToDelete: INTEGER);
(**Deletes at most @oparam{numberToDelete} characters from @oparam{stringVar},
starting at position @oparam{startPos}. The string value in
@oparam{stringVar} is not altered if @oparam{startPos} is greater than or
equal to @samp{Length(stringVar)}.
@precond
@oparam{startPos} and @oparam{numberToDelete} are not negative.
@end precond *)
VAR
stringLength, i: INTEGER;
BEGIN
stringLength := Length (stringVar);
IF (startPos+numberToDelete < stringLength) THEN
(* `stringVar' has remaining characters beyond the deleted section;
these have to be moved forward by `numberToDelete' characters *)
FOR i := startPos TO stringLength-numberToDelete DO
stringVar[i] := stringVar[i+numberToDelete]
END
ELSIF (startPos < stringLength) THEN
stringVar[startPos] := 0X
END
END Delete;
PROCEDURE Insert* (source: ARRAY OF CHAR; startPos: INTEGER;
VAR destination: ARRAY OF CHAR);
(**Inserts @oparam{source} into @oparam{destination} at position
@oparam{startPos}. After the call @oparam{destination} contains the string
that is contructed by first splitting @oparam{destination} at the position
@oparam{startPos} and then concatenating the first half, @oparam{source},
and the second half. The string value in @oparam{destination} is not
altered if @oparam{startPos} is greater than @samp{Length(source)}. If
@samp{startPos = Length(source)}, then @oparam{source} is appended to
@oparam{destination}.
@precond
@oparam{startPos} is not negative.
@end precond *)
VAR
sourceLength, destLength, destMax, i: INTEGER;
BEGIN
destLength := Length (destination);
sourceLength := Length (source);
destMax := SHORT (LEN (destination))-1;
IF (startPos+sourceLength < destMax) THEN
(* `source' is inserted inside of `destination' *)
IF (destLength+sourceLength > destMax) THEN
(* `destination' too long, truncate it *)
destLength := destMax-sourceLength;
destination[destLength] := 0X
END;
(* move tail section of `destination' *)
FOR i := destLength TO startPos BY -1 DO
destination[i+sourceLength] := destination[i]
END
ELSIF (startPos <= destLength) THEN
(* `source' replaces `destination' from `startPos' on *)
destination[destMax] := 0X; (* set string terminator *)
sourceLength := destMax-startPos (* truncate `source' *)
ELSE (* startPos > destLength: no change in `destination' *)
sourceLength := 0
END;
(* copy characters from `source' to `destination' *)
FOR i := 0 TO sourceLength-1 DO
destination[startPos+i] := source[i]
END
END Insert;
PROCEDURE Replace* (source: ARRAY OF CHAR; startPos: INTEGER;
VAR destination: ARRAY OF CHAR);
(**Copies @oparam{source} into @oparam{destination}, starting at position
@oparam{startPos}. Copying stops when all of @oparam{source} has been
copied, or when the last character of the string value in
@oparam{destination} has been replaced. The string value in
@oparam{destination} is not altered if @oparam{startPos} is greater than or
equal to @samp{Length(source)}.
@precond
@oparam{startPos} is not negative.
@end precond *)
VAR
destLength, i: INTEGER;
BEGIN
destLength := Length (destination);
IF (startPos < destLength) THEN
(* if `startPos' is inside `destination', then replace characters until
the end of `source' or `destination' is reached *)
i := 0;
WHILE (startPos # destLength) & (source[i] # 0X) DO
destination[startPos] := source[i];
INC (startPos);
INC (i)
END
END
END Replace;
PROCEDURE Append* (source: ARRAY OF CHAR; VAR destination: ARRAY OF CHAR);
(**Appends @oparam{source} to @oparam{destination}. *)
VAR
destLength, i: INTEGER;
BEGIN
destLength := Length (destination);
i := 0;
WHILE (destLength < LEN (destination)-1) & (source[i] # 0X) DO
destination[destLength] := source[i];
INC (destLength);
INC (i)
END;
destination[destLength] := 0X
END Append;
PROCEDURE Concat* (source1, source2: ARRAY OF CHAR;
VAR destination: ARRAY OF CHAR);
(**Concatenates @oparam{source2} onto @oparam{source1} and copies the result
into @oparam{destination}. *)
VAR
i, j: INTEGER;
BEGIN
(* copy `source1' into `destination' *)
i := 0;
WHILE (source1[i] # 0X) & (i < LEN(destination)-1) DO
destination[i] := source1[i];
INC (i)
END;
(* append `source2' to `destination' *)
j := 0;
WHILE (source2[j] # 0X) & (i < LEN (destination)-1) DO
destination[i] := source2[j];
INC (j); INC (i)
END;
destination[i] := 0X
END Concat;
PROCEDURE CanAssignAll* (sourceLength: INTEGER; VAR destination: ARRAY OF CHAR): BOOLEAN;
(**Returns @code{TRUE} if a number of characters, indicated by
@oparam{sourceLength}, will fit into @oparam{destination}; otherwise returns
@code{FALSE}.
@precond
@oparam{sourceLength} is not negative.
@end precond *)
BEGIN
RETURN (sourceLength < LEN (destination))
END CanAssignAll;
PROCEDURE CanExtractAll* (sourceLength, startPos, numberToExtract: INTEGER;
VAR destination: ARRAY OF CHAR): BOOLEAN;
(**Returns @code{TRUE} if there are @oparam{numberToExtract} characters
starting at @oparam{startPos} and within the @oparam{sourceLength} of some
string, and if the capacity of @oparam{destination} is sufficient to hold
@oparam{numberToExtract} characters; otherwise returns @code{FALSE}.
@precond
@oparam{sourceLength}, @oparam{startPos}, and @oparam{numberToExtract} are
not negative.
@end precond *)
BEGIN
RETURN (startPos+numberToExtract <= sourceLength) &
(numberToExtract < LEN (destination))
END CanExtractAll;
PROCEDURE CanDeleteAll* (stringLength, startPos,
numberToDelete: INTEGER): BOOLEAN;
(**Returns @code{TRUE} if there are @oparam{numberToDelete} characters starting
at @oparam{startPos} and within the @oparam{stringLength} of some string;
otherwise returns @code{FALSE}.
@precond
@oparam{stringLength}, @oparam{startPos} and @oparam{numberToDelete} are not
negative.
@end precond *)
BEGIN
RETURN (startPos+numberToDelete <= stringLength)
END CanDeleteAll;
PROCEDURE CanInsertAll* (sourceLength, startPos: INTEGER;
VAR destination: ARRAY OF CHAR): BOOLEAN;
(**Returns @code{TRUE} if there is room for the insertion of
@oparam{sourceLength} characters from some string into @oparam{destination}
starting at @oparam{startPos}; otherwise returns @code{FALSE}.
@precond
@oparam{sourceLength} and @oparam{startPos} are not negative.
@end precond *)
VAR
lenDestination: INTEGER;
BEGIN
lenDestination := Length (destination);
RETURN (startPos <= lenDestination) &
(sourceLength+lenDestination < LEN (destination))
END CanInsertAll;
PROCEDURE CanReplaceAll* (sourceLength, startPos: INTEGER;
VAR destination: ARRAY OF CHAR): BOOLEAN;
(**Returns @code{TRUE} if there is room for the replacement of
@oparam{sourceLength} characters in @oparam{destination} starting at
@oparam{startPos}; otherwise returns @code{FALSE}.
@precond
@oparam{sourceLength} and @oparam{startPos} are not negative.
@end precond *)
BEGIN
RETURN (sourceLength+startPos <= Length(destination))
END CanReplaceAll;
PROCEDURE CanAppendAll* (sourceLength: INTEGER;
VAR destination: ARRAY OF CHAR): BOOLEAN;
(**Returns @code{TRUE} if there is sufficient room in @oparam{destination} to
append a string of length @oparam{sourceLength} to the string in
@oparam{destination}; otherwise returns @code{FALSE}.
@precond
@oparam{sourceLength} is not negative.
@end precond *)
BEGIN
RETURN (Length (destination)+sourceLength < LEN (destination))
END CanAppendAll;
PROCEDURE CanConcatAll* (source1Length, source2Length: INTEGER;
VAR destination: ARRAY OF CHAR): BOOLEAN;
(**Returns @code{TRUE} if there is sufficient room in @oparam{destination} for
a two strings of lengths @oparam{source1Length} and @oparam{source2Length};
otherwise returns @code{FALSE}.
@precond
@oparam{source1Length} and @oparam{source2Length} are not negative.
@end precond *)
BEGIN
RETURN (source1Length+source2Length < LEN (destination))
END CanConcatAll;
PROCEDURE Compare* (stringVal1, stringVal2: ARRAY OF CHAR): CompareResults;
(**Returns @oconst{less}, @oconst{equal}, or @oconst{greater}, according as
@oparam{stringVal1} is lexically less than, equal to, or greater than
@oparam{stringVal2}. Note that Oberon-2 already contains predefined
comparison operators on strings. *)
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (stringVal1[i] # 0X) & (stringVal1[i] = stringVal2[i]) DO
INC (i)
END;
IF (stringVal1[i] < stringVal2[i]) THEN
RETURN less
ELSIF (stringVal1[i] > stringVal2[i]) THEN
RETURN greater
ELSE
RETURN equal
END
END Compare;
PROCEDURE Equal* (stringVal1, stringVal2: ARRAY OF CHAR): BOOLEAN;
(**Returns @samp{stringVal1 = stringVal2}. Unlike the predefined operator
@samp{=}, this procedure can be assigned to a procedure variable. *)
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (stringVal1[i] # 0X) & (stringVal1[i] = stringVal2[i]) DO
INC (i)
END;
RETURN (stringVal1[i] = 0X) & (stringVal2[i] = 0X)
END Equal;
PROCEDURE FindNext* (pattern, stringToSearch: ARRAY OF CHAR; startPos: INTEGER;
VAR patternFound: BOOLEAN; VAR posOfPattern: INTEGER);
(**Looks forward for next occurrence of @oparam{pattern} in
@oparam{stringToSearch}, starting the search at position @oparam{startPos}.
If @samp{startPos < Length(stringToSearch)} and @oparam{pattern} is found,
@oparam{patternFound} is returned as @code{TRUE}, and @oparam{posOfPattern}
contains the start position in @oparam{stringToSearch} of @oparam{pattern}.
The position is a value in the range [startPos..Length(stringToSearch)-1].
Otherwise @oparam{patternFound} is returned as @code{FALSE}, and
@oparam{posOfPattern} is unchanged. If @samp{startPos >
Length(stringToSearch)-Length(Pattern)} then @oparam{patternFound} is
returned as @code{FALSE}.
@precond
@oparam{startPos} is not negative.
@end precond *)
VAR
patternPos: INTEGER;
BEGIN
IF (startPos < Length (stringToSearch)) THEN
patternPos := 0;
LOOP
IF (pattern[patternPos] = 0X) THEN
(* reached end of pattern *)
patternFound := TRUE;
posOfPattern := startPos-patternPos;
EXIT
ELSIF (stringToSearch[startPos] = 0X) THEN
(* end of string (but not of pattern) *)
patternFound := FALSE;
EXIT
ELSIF (stringToSearch[startPos] = pattern[patternPos]) THEN
(* characters identic, compare next one *)
INC (startPos);
INC (patternPos)
ELSE
(* difference found: reset indices and restart *)
startPos := startPos-patternPos+1;
patternPos := 0
END
END
ELSE
patternFound := FALSE
END
END FindNext;
PROCEDURE FindPrev* (pattern, stringToSearch: ARRAY OF CHAR; startPos: INTEGER;
VAR patternFound: BOOLEAN; VAR posOfPattern: INTEGER);
(**Looks backward for the previous occurrence of @oparam{pattern} in
@oparam{stringToSearch} and returns the position of the first character of
the @oparam{pattern} if found. The search for the pattern begins at
@oparam{startPos}. If @oparam{pattern} is found, @oparam{patternFound} is
returned as @code{TRUE}, and @oparam{posOfPattern} contains the start
position in @oparam{stringToSearch} of pattern in the range [0..startPos].
Otherwise @oparam{patternFound} is returned as @code{FALSE}, and
@oparam{posOfPattern} is unchanged. The pattern might be found at the given
value of @oparam{startPos}. The search will fail if @oparam{startPos} is
negative. If @samp{startPos > Length(stringToSearch)-Length(pattern)} the
whole string value is searched. *)
VAR
patternPos, stringLength, patternLength: INTEGER;
BEGIN
(* correct `startPos' if it is larger than the possible searching range *)
stringLength := Length (stringToSearch);
patternLength := Length (pattern);
IF (startPos > stringLength-patternLength) THEN
startPos := stringLength-patternLength
END;
IF (startPos >= 0) THEN
patternPos := 0;
LOOP
IF (pattern[patternPos] = 0X) THEN
(* reached end of pattern *)
patternFound := TRUE;
posOfPattern := startPos-patternPos;
EXIT
ELSIF (stringToSearch[startPos] # pattern[patternPos]) THEN
(* characters differ: reset indices and restart *)
IF (startPos > patternPos) THEN
startPos := startPos-patternPos-1;
patternPos := 0
ELSE
(* reached beginning of `stringToSearch' without finding a match *)
patternFound := FALSE;
EXIT
END
ELSE (* characters identic, compare next one *)
INC (startPos);
INC (patternPos)
END
END
ELSE
patternFound := FALSE
END
END FindPrev;
PROCEDURE FindDiff* (stringVal1, stringVal2: ARRAY OF CHAR;
VAR differenceFound: BOOLEAN;
VAR posOfDifference: INTEGER);
(**Compares the string values in @oparam{stringVal1} and @oparam{stringVal2}
for differences. If they are equal, @oparam{differenceFound} is returned as
@code{FALSE}, and @code{TRUE} otherwise. If @oparam{differenceFound} is
@code{TRUE}, @oparam{posOfDifference} is set to the position of the first
difference; otherwise @oparam{posOfDifference} is unchanged. *)
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (stringVal1[i] # 0X) & (stringVal1[i] = stringVal2[i]) DO
INC (i)
END;
differenceFound := (stringVal1[i] # 0X) OR (stringVal2[i] # 0X);
IF differenceFound THEN
posOfDifference := i
END
END FindDiff;
PROCEDURE Capitalize* (VAR stringVar: ARRAY OF CHAR);
(**Applies the function @code{CAP} to each character of the string value in
@oparam{stringVar}. *)
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (stringVar[i] # 0X) DO
stringVar[i] := CAP (stringVar[i]);
INC (i)
END
END Capitalize;
END ooc2Strings.

34
src/library/ooc2/oocwrapperlibc.Mod Normal file
View file

@ -0,0 +1,34 @@
MODULE oocwrapperlibc;
IMPORT SYSTEM;
PROCEDURE -includeStdio()
"#include <stdio.h>";
PROCEDURE -sys(str: ARRAY OF CHAR): INTEGER
"system(str)";
PROCEDURE system*(cmd : ARRAY OF CHAR);
VAR r : INTEGER;
BEGIN
r := sys(cmd);
END system;
(*
PROCEDURE strtod* (string: C.address;
VAR tailptr: C.charPtr1d): C.double;
PROCEDURE strtof* (string: C.address;
VAR tailptr: C.charPtr1d): C.float;
PROCEDURE sscanf* (s: C.address; template: ARRAY OF CHAR; ...) : C.int;
*)
PROCEDURE -sprntf(s, t0, t1, t2: ARRAY OF CHAR): INTEGER
"sprintf(s, t0, t1, t2)";
PROCEDURE sprintf* (VAR s: ARRAY OF CHAR; template0: ARRAY OF CHAR; template1: ARRAY OF CHAR; template2: ARRAY OF CHAR);
VAR r : INTEGER;
BEGIN
r := sprntf (s, template0, template1, template2);
END sprintf;
BEGIN
END oocwrapperlibc.

3790
src/library/oocX11/oocX11.Mod Normal file
View file

File diff suppressed because it is too large Load diff

225
src/library/oocX11/oocXYplane.Mod Normal file
View file

@ -0,0 +1,225 @@
MODULE oocXYplane;
(*
Module XYplane provides some basic facilities for graphics programming. Its
interface is kept as simple as possible and is therefore more suited for
programming exercises than for serious graphics applications.
XYplane provides a Cartesian plane of pixels that can be drawn and erased. The
plane is mapped to some location on the screen. The variables X and Y indicate
its lower left corner, W its width and H its height. All variables are
read-only.
*)
IMPORT
Out := Console, C := oocC, X11 := oocX11, Xu := oocXutil, SYSTEM;
CONST
erase* = 0;
draw* = 1;
(*sizeSet = MAX (SET)+1;*)
sizeSet = 32; (* in ooc SET is always 32 bit *)
TYPE string = ARRAY 32 OF CHAR;
VAR
X-, Y-, W-, H-: INTEGER;
display: X11.DisplayPtr;
window: X11.Window;
fg, bg: X11.GC;
initialized: BOOLEAN; (* first call to Open sets this to TRUE *)
image: X11.XImagePtr;
map: POINTER TO ARRAY OF ARRAY OF SET;
PROCEDURE Error (msg: ARRAY OF CHAR);
BEGIN
Out.String ("Error: ");
Out.String (msg);
Out.Ln;
HALT (1)
END Error;
PROCEDURE Clear*;
(* Erases all pixels in the drawing plane. *)
VAR
x, y: INTEGER;
BEGIN
X11.XFillRectangle (display, window, bg, 0, 0, W+1, H+1);
FOR y := 0 TO SHORT (LEN (map^, 0))-1 DO
FOR x := 0 TO SHORT (LEN (map^, 1))-1 DO
map[y, x] := {}
END
END;
X11.XFlush (display)
END Clear;
PROCEDURE Dot* (x, y, mode: INTEGER);
(* Dot(x, y, m) draws or erases the pixel at the coordinates (x, y) relative to
the lower left corner of the plane. If m=draw the pixel is drawn, if m=erase
the pixel is erased. *)
VAR
dummy: C.int;
BEGIN
IF (x >= X) & (x < X+W) & (y >= Y) & (y < Y+H) THEN
dummy := image. f. putpixel(image, x, H-1-y, mode);
CASE mode OF
| draw:
X11.XDrawPoint (display, window, fg, x, H-1-y)
| erase:
X11.XDrawPoint (display, window, bg, x, H-1-y)
END;
X11.XFlush (display);
END
END Dot;
PROCEDURE IsDot* (x, y: INTEGER): BOOLEAN;
(* IsDot(x, y) returns TRUE if the pixel at the coordinates (x, y) relative to
the lower left corner of the plane is drawn, otherwise it returns FALSE. *)
BEGIN
IF (x < X) OR (x >= X+W) OR (y < Y) OR (y >= Y+H) THEN
RETURN FALSE
ELSE
RETURN (image. f. getpixel (image, x, H-1-y) # erase)
END
END IsDot;
PROCEDURE Key* (): CHAR;
(* Reads the keyboard. If a key was pressed prior to invocation, its
character value is returned, otherwise the result is 0X. *)
CONST
sizeBuffer = 16;
VAR
event: X11.XEvent;
buffer: ARRAY sizeBuffer OF C.char;
keySym: X11.KeySym;
numChars: C.int;
nl : C.longint;
PROCEDURE Redraw (x0, y0, w0, h0: INTEGER);
BEGIN
(* clip width and height to size of initial window *)
IF (x0+w0 > W) THEN
w0 := W-x0
END;
IF (y0+h0 > H) THEN
h0 := H-y0
END;
IF (w0 > 0) & (h0 > 0) THEN
X11.XPutImage (display, window, fg, image, x0, y0, x0, y0, w0, h0)
END
END Redraw;
BEGIN
WHILE initialized &
(X11.XEventsQueued (display, X11.QueuedAfterReading) > 0) DO
X11.XNextEvent (display, event);
nl := 0;
IF (event. type = X11.KeyPress) THEN
numChars := Xu.XLookupString (
(*event. xkey, buffer, sizeBuffer, keySym, NIL);*)
event, buffer, sizeBuffer, keySym, nl);
IF (numChars > 0) THEN
RETURN SYSTEM.VAL (CHAR, buffer[0])
END
ELSIF (event. type = X11.Expose) THEN
Redraw (SHORT (event. xexpose. x), SHORT (event. xexpose. y),
SHORT (event. xexpose. width), SHORT (event. xexpose. height))
END
END;
RETURN 0X
END Key;
PROCEDURE Open*;
(* Initializes the drawing plane. *)
VAR
screen: C.int;
parent: X11.Window;
bgColor, fgColor: C.longint;
gcValue: X11.XGCValues;
event: X11.XEvent;
x, y: INTEGER;
tmpstr : string;
(*tmpint : INTEGER;*)
scrn : C.int;
vis : X11.VisualPtr;
BEGIN
IF ~initialized THEN
initialized := TRUE;
tmpstr[0] := 0X;
(*display := X11.XOpenDisplay (NIL);*)
display := X11.XOpenDisplay (tmpstr);
(*display := X11.OpenDisplay (NIL);*)
IF (display = NIL) THEN
Error ("Couldn't open display")
ELSE
screen := X11.XDefaultScreen (display);
X := 0; Y := 0;
W := SHORT (X11.XDisplayWidth (display, screen));
H := SHORT (X11.XDisplayHeight (display, screen));
(* adjust ratio W:H to 3:4 [for no paritcular reason] *)
IF (W > 3*H DIV 4) THEN
W := 3*H DIV 4
END;
parent := X11.XRootWindow (display, screen);
fgColor := X11.XBlackPixel (display, screen);
bgColor := X11.XWhitePixel (display, screen);
window := X11.XCreateSimpleWindow (display, parent, 0, 0,
W, H, 0, 0, bgColor);
X11.XStoreName (display, window, "XYplane");
X11.XSelectInput (display, window, X11.KeyPressMask+X11.ExposureMask);
X11.XMapWindow (display, window);
X11.XFlush (display);
(*tmpint := W + ((*sizeSet*)32-1);
tmpint := tmpint DIV 32(*sizeSet*);*)
NEW (map, H, (W+(sizeSet-1)) DIV sizeSet);
(*NEW (map, H, tmpint);*)
FOR y := 0 TO SHORT (LEN (map^, 0))-1 DO
FOR x := 0 TO SHORT (LEN (map^, 1))-1 DO
map[y, x] := {}
END
END;
scrn := X11.XDefaultScreen (display);
vis := X11.XDefaultVisual (display, scrn);
image := X11.XCreateImage (display,
(*X11.XDefaultVisual (display, X11.XDefaultScreen (display)),*)
vis,
(*1, X11.XYBitmap, 0, SYSTEM.ADR (map^), W, H, sizeSet, 0);*)
1, X11.ZPixmap, 0, SYSTEM.ADR (map^), W, H, (*sizeSet*)32, 0);
(* wait until the window manager gives its ok to draw things *)
X11.XMaskEvent (display, X11.ExposureMask, event);
(* create graphic context to draw resp. erase a point *)
gcValue. foreground := fgColor;
gcValue. background := bgColor;
fg := X11.XCreateGC (display, parent,
X11.GCForeground+X11.GCBackground, gcValue);
gcValue. foreground := bgColor;
gcValue. background := fgColor;
bg := X11.XCreateGC (display, parent,
X11.GCForeground+X11.GCBackground, gcValue)
END
END
END Open;
PROCEDURE Close*;
BEGIN
(* X11.XDestroyImage(image);
X11.XDestroyWindow(display, window);*)
X11.XCloseDisplay(display);
END Close;
BEGIN
initialized := FALSE;
X := 0; Y := 0; W := 0; H := 0;
image := NIL; map := NIL
END oocXYplane.

548
src/library/oocX11/oocXutil.Mod Normal file
View file

@ -0,0 +1,548 @@
MODULE oocXutil (*[INTERFACE "C"]*);
IMPORT
C := oocC, X := oocX11, SYSTEM;
(*
* Bitmask returned by XParseGeometry(). Each bit tells if the corresponding
* value (x, y, width, height) was found in the parsed string.
*)
CONST
NoValue* = 00000H;
XValue* = 00001H;
YValue* = 00002H;
WidthValue* = 00004H;
HeightValue* = 00008H;
AllValues* = 0000FH;
XNegative* = 00010H;
YNegative* = 00020H;
(*
* new version containing basewidth, baseheight, and wingravity fields;
* used with WMNORMALHINTS.
*)
TYPE
XSizeHintsPtr* = POINTER TO XSizeHints;
XSizeHints* = RECORD
flags*: X.ulongmask; (* marks which fields in this structure are defined *)
x*, y*: C.int; (* obsolete for new window mgrs, but clients *)
width*, height*: C.int; (* should set so old wm's don't mess up *)
minwidth*, minheight*: C.int;
maxwidth*, maxheight*: C.int;
widthinc*, heightinc*: C.int;
minaspect*, maxaspect*: RECORD
x*: C.int; (* numerator *)
y*: C.int; (* denominator *)
END;
basewidth*, baseheight*: C.int;(* added by ICCCM version 1 *)
wingravity*: C.int; (* added by ICCCM version 1 *)
END;
(*
* The next block of definitions are for window manager properties that
* clients and applications use for communication.
*)
CONST
(* flags argument in size hints *)
USPosition* = {0}; (* user specified x, y *)
USSize* = {1}; (* user specified width, height *)
PPosition* = {2}; (* program specified position *)
PSize* = {3}; (* program specified size *)
PMinSize* = {4}; (* program specified minimum size *)
PMaxSize* = {5}; (* program specified maximum size *)
PResizeInc* = {6}; (* program specified resize increments *)
PAspect* = {7}; (* program specified min and max aspect ratios *)
PBaseSize* = {8}; (* program specified base for incrementing *)
PWinGravity* = {9}; (* program specified window gravity *)
(* obsolete *)
PAllHints* = PPosition+PSize+PMinSize+PMaxSize+PResizeInc+PAspect;
TYPE
XWMHintsPtr* = POINTER TO XWMHints;
XWMHints* = RECORD
flags*: X.ulongmask;(* marks which fields in this structure are defined *)
input*: X.Bool; (* does this application rely on the window manager to
get keyboard input? *)
initialstate*: C.int; (* see below *)
iconpixmap*: X.Pixmap; (* pixmap to be used as icon *)
iconwindow*: X.Window; (* window to be used as icon *)
iconx*, icony*: C.int; (* initial position of icon *)
iconmask*: X.Pixmap; (* icon mask bitmap *)
windowgroup*: X.XID; (* id of related window group *)
END;
CONST
(* definition for flags of XWMHints *)
InputHint* = {0};
StateHint* = {1};
IconPixmapHint* = {2};
IconWindowHint* = {3};
IconPositionHint* = {4};
IconMaskHint* = {5};
WindowGroupHint* = {6};
AllHints* = InputHint+StateHint+IconPixmapHint+IconWindowHint+IconPositionHint+IconMaskHint+WindowGroupHint;
XUrgencyHint* = {8};
(* definitions for initial window state *)
WithdrawnState* = 0; (* for windows that are not mapped *)
NormalState* = 1; (* most applications want to start this way *)
IconicState* = 3; (* application wants to start as an icon *)
(*
* Obsolete states no longer defined by ICCCM
*)
CONST
DontCareState* = 0; (* don't know or care *)
ZoomState* = 2; (* application wants to start zoomed *)
InactiveState* = 4; (* application believes it is seldom used; *)
(* some wm's may put it on inactive menu *)
(*
* new structure for manipulating TEXT properties; used with WMNAME,
* WMICONNAME, WMCLIENTMACHINE, and WMCOMMAND.
*)
TYPE
XTextPropertyPtr* = POINTER TO XTextProperty;
XTextProperty* = RECORD
value*: C.charPtr1d; (* same as Property routines *)
encoding*: X.Atom; (* prop type *)
format*: C.int; (* prop data format: 8, 16, or 32 *)
nitems*: C.longint; (* number of data items in value *)
END;
CONST
XNoMemory* = 1;
XLocaleNotSupported* = 2;
XConverterNotFound* = 3;
CONST (* enum XICCEncodingStyle *)
XStringStyle* = 0;
XCompoundTextStyle* = 1;
XTextStyle* = 2;
XStdICCTextStyle* = 3;
TYPE
XICCEncodingStyle* = C.enum1;
XIconSizePtr* = POINTER TO XIconSize;
XIconSize* = RECORD
minwidth*, minheight*: C.int;
maxwidth*, maxheight*: C.int;
widthinc*, heightinc*: C.int;
END;
XClassHintPtr* = POINTER TO XClassHint;
XClassHint* = RECORD
resname*: C.charPtr1d;
resclass*: C.charPtr1d;
END;
(*
* These macros are used to give some sugar to the image routines so that
* naive people are more comfortable with them.
*)
(* can't define any macros here *)
(*
* Compose sequence status structure, used in calling XLookupString.
*)
TYPE
XComposeStatusPtr* = POINTER TO XComposeStatus;
XComposeStatus* = RECORD
composeptr*: X.XPointer; (* state table pointer *)
charsmatched*: C.int; (* match state *)
END;
(*
* Keysym macros, used on Keysyms to test for classes of symbols
*)
(* can't define any macros here *)
(*
* opaque reference to Region data type
*)
TYPE
XRegion* = RECORD END;
Region* = POINTER TO XRegion;
(* Return values from XRectInRegion() *)
CONST
RectangleOut* = 0;
RectangleIn* = 1;
RectanglePart* = 2;
(*
* Information used by the visual utility routines to find desired visual
* type from the many visuals a display may support.
*)
TYPE
XVisualInfoPtr* = POINTER TO XVisualInfo;
XVisualInfo* = RECORD
visual*: X.VisualPtr;
visualid*: X.VisualID;
screen*: C.int;
depth*: C.int;
class*: C.int;
redmask*: X.ulongmask;
greenmask*: X.ulongmask;
bluemask*: X.ulongmask;
colormapsize*: C.int;
bitsperrgb*: C.int;
END;
CONST
VisualNoMask* = 00H;
VisualIDMask* = 01H;
VisualScreenMask* = 02H;
VisualDepthMask* = 04H;
VisualClassMask* = 08H;
VisualRedMaskMask* = 010H;
VisualGreenMaskMask* = 020H;
VisualBlueMaskMask* = 040H;
VisualColormapSizeMask* = 080H;
VisualBitsPerRGBMask* = 0100H;
VisualAllMask* = 01FFH;
(*
* This defines a window manager property that clients may use to
* share standard color maps of type RGBCOLORMAP:
*)
TYPE
XStandardColormapPtr* = POINTER TO XStandardColormap;
XStandardColormap* = RECORD
colormap*: X.Colormap;
redmax*: C.longint;
redmult*: C.longint;
greenmax*: C.longint;
greenmult*: C.longint;
bluemax*: C.longint;
bluemult*: C.longint;
basepixel*: C.longint;
visualid*: X.VisualID; (* added by ICCCM version 1 *)
killid*: X.XID; (* added by ICCCM version 1 *)
END;
CONST
ReleaseByFreeingColormap* = 1;(* for killid field above *)
(*
* return codes for XReadBitmapFile and XWriteBitmapFile
*)
CONST
BitmapSuccess* = 0;
BitmapOpenFailed* = 1;
BitmapFileInvalid* = 2;
BitmapNoMemory* = 3;
(****************************************************************
*
* Context Management
*
****************************************************************)
(* Associative lookup table return codes *)
CONST
XCSUCCESS* = 0; (* No error. *)
XCNOMEM* = 1; (* Out of memory *)
XCNOENT* = 2; (* No entry in table *)
TYPE
XContext* = C.int;
(* The following declarations are alphabetized. *)
(*
PROCEDURE XAllocClassHint* (): XClassHintPtr;
PROCEDURE XAllocIconSize* (): XIconSizePtr;
PROCEDURE XAllocSizeHints* (): XSizeHintsPtr;
PROCEDURE XAllocStandardColormap* (): XStandardColormapPtr;
PROCEDURE XAllocWMHints* (): XWMHintsPtr;
PROCEDURE XClipBox* (
r: Region;
VAR rectreturn: X.XRectangle);
PROCEDURE XCreateRegion* (): Region;
PROCEDURE XDefaultString* (): C.charPtr1d;
PROCEDURE XDeleteContext* (
display: X.DisplayPtr;
rid: X.XID;
context: XContext): C.int;
PROCEDURE XDestroyRegion* (
r: Region);
PROCEDURE XEmptyRegion* (
r: Region);
PROCEDURE XEqualRegion* (
r1: Region;
r2: Region);
PROCEDURE XFindContext* (
display: X.DisplayPtr;
rid: X.XID;
context: XContext;
VAR datareturn: X.XPointer): C.int;
PROCEDURE XGetClassHint* (
display: X.DisplayPtr;
w: X.Window;
VAR classhintsreturn: XClassHint): X.Status;
PROCEDURE XGetIconSizes* (
display: X.DisplayPtr;
w: X.Window;
VAR sizelistreturn: XIconSize;
VAR countreturn: C.int): X.Status;
PROCEDURE XGetNormalHints* (
display: X.DisplayPtr;
w: X.Window;
VAR hintsreturn: XSizeHints): X.Status;
PROCEDURE XGetRGBColormaps* (
display: X.DisplayPtr;
w: X.Window;
VAR stdcmapreturn: XStandardColormap;
VAR countreturn: C.int;
property: X.Atom): X.Status;
PROCEDURE XGetSizeHints* (
display: X.DisplayPtr;
w: X.Window;
VAR hintsreturn: XSizeHints;
property: X.Atom): X.Status;
PROCEDURE XGetStandardColormap* (
display: X.DisplayPtr;
w: X.Window;
VAR colormapreturn: XStandardColormap;
property: X.Atom): X.Status;
PROCEDURE XGetTextProperty* (
display: X.DisplayPtr;
window: X.Window;
VAR textpropreturn: XTextProperty;
property: X.Atom): X.Status;
PROCEDURE XGetVisualInfo* (
display: X.DisplayPtr;
vinfomask: X.ulongmask;
vinfotemplate: XVisualInfoPtr;
VAR nitemsreturn: C.int): XVisualInfoPtr;
PROCEDURE XGetWMClientMachine* (
display: X.DisplayPtr;
w: X.Window;
VAR textpropreturn: XTextProperty): X.Status;
PROCEDURE XGetWMHints* (
display: X.DisplayPtr;
w: X.Window): XWMHintsPtr;
PROCEDURE XGetWMIconName* (
display: X.DisplayPtr;
w: X.Window;
VAR textpropreturn: XTextProperty): X.Status;
PROCEDURE XGetWMName* (
display: X.DisplayPtr;
w: X.Window;
VAR textpropreturn: XTextProperty): X.Status;
PROCEDURE XGetWMNormalHints* (
display: X.DisplayPtr;
w: X.Window;
VAR hintsreturn: XSizeHints;
VAR suppliedreturn: C.longint): X.Status;
PROCEDURE XGetWMSizeHints* (
display: X.DisplayPtr;
w: X.Window;
VAR hintsreturn: XSizeHints;
VAR suppliedreturn: C.longint;
property: X.Atom): X.Status;
PROCEDURE XGetZoomHints* (
display: X.DisplayPtr;
w: X.Window;
VAR zhintsreturn: XSizeHints): X.Status;
PROCEDURE XIntersectRegion* (
sra, srb, drreturn: Region); (* ??? *)
PROCEDURE XConvertCase* (
sym: X.KeySym;
VAR lower: X.KeySym;
VAR upper: X.KeySym);
*)
PROCEDURE -XLookupString* (
(*VAR eventStruct: X.XKeyEvent;*)
VAR eventStruct: X.XEvent;
VAR bufferReturn: ARRAY OF C.char;
bytesBuffer: C.int;
VAR keysymReturn: X.KeySym;
(*VAR statusInOut(*[NILCOMPAT]*): XComposeStatus): C.int*)
VAR statusInOut(*[NILCOMPAT]*): C.longint): C.int
"(int)XLookupString(eventStruct, bufferReturn, bytesBuffer, keysymReturn, statusInOut)";
(*
PROCEDURE XMatchVisualInfo* (
display: X.DisplayPtr;
screen: C.int;
depth: C.int;
class: C.int;
VAR vinforeturn: XVisualInfo): X.Status;
PROCEDURE XOffsetRegion* (
r: Region;
dx: C.int;
dy: C.int);
PROCEDURE XPointInRegion* (
r: Region;
x: C.int;
y: C.int): X.Bool;
PROCEDURE XPolygonRegion* (
points: ARRAY OF X.XPoint;
n: C.int;
fillrule: C.int): Region;
PROCEDURE XRectInRegion* (
r: Region;
x: C.int;
y: C.int;
width: C.int;
height: C.int): C.int;
PROCEDURE XSaveContext* (
display: X.DisplayPtr;
rid: X.XID;
context: XContext;
data: ARRAY OF C.char): C.int;
PROCEDURE XSetClassHint* (
display: X.DisplayPtr;
w: X.Window;
classhints: XClassHintPtr);
PROCEDURE XSetIconSizes* (
display: X.DisplayPtr;
w: X.Window;
sizelist: XIconSizePtr;
count: C.int);
PROCEDURE XSetNormalHints* (
display: X.DisplayPtr;
w: X.Window;
hints: XSizeHintsPtr);
PROCEDURE XSetRGBColormaps* (
display: X.DisplayPtr;
w: X.Window;
stdcmaps: XStandardColormapPtr;
count: C.int;
property: X.Atom);
PROCEDURE XSetSizeHints* (
display: X.DisplayPtr;
w: X.Window;
hints: XSizeHintsPtr;
property: X.Atom);
PROCEDURE XSetStandardProperties* (
display: X.DisplayPtr;
w: X.Window;
windowname: ARRAY OF C.char;
iconname: ARRAY OF C.char;
iconpixmap: X.Pixmap;
argv: C.charPtr2d;
argc: C.int;
hints: XSizeHintsPtr);
PROCEDURE XSetTextProperty* (
display: X.DisplayPtr;
w: X.Window;
textprop: XTextPropertyPtr;
property: X.Atom);
PROCEDURE XSetWMClientMachine* (
display: X.DisplayPtr;
w: X.Window;
textprop: XTextPropertyPtr);
PROCEDURE XSetWMHints* (
display: X.DisplayPtr;
w: X.Window;
wmhints: XWMHintsPtr);
PROCEDURE XSetWMIconName* (
display: X.DisplayPtr;
w: X.Window;
textprop: XTextPropertyPtr);
PROCEDURE XSetWMName* (
display: X.DisplayPtr;
w: X.Window;
textprop: XTextPropertyPtr);
PROCEDURE XSetWMNormalHints* (
display: X.DisplayPtr;
w: X.Window;
hints: XSizeHintsPtr);
PROCEDURE XSetWMProperties* (
display: X.DisplayPtr;
w: X.Window;
windowname: XTextPropertyPtr;
iconname: XTextPropertyPtr;
argv: C.charPtr2d;
argc: C.int;
normalhints: XSizeHintsPtr;
wmhints: XWMHintsPtr;
classhints: XClassHintPtr);
PROCEDURE XmbSetWMProperties* (
display: X.DisplayPtr;
w: X.Window;
windowname: ARRAY OF C.char;
iconname: ARRAY OF C.char;
argv: C.charPtr2d;
argc: C.int;
normalhints: XSizeHintsPtr;
wmhints: XWMHintsPtr;
classhints: XClassHintPtr);
PROCEDURE XSetWMSizeHints* (
display: X.DisplayPtr;
w: X.Window;
hints: XSizeHintsPtr;
property: X.Atom);
PROCEDURE XSetRegion* (
display: X.DisplayPtr;
gc: X.GC;
r: Region);
PROCEDURE XSetStandardColormap* (
display: X.DisplayPtr;
w: X.Window;
colormap: XStandardColormapPtr;
property: X.Atom);
PROCEDURE XSetZoomHints* (
display: X.DisplayPtr;
w: X.Window;
zhints: XSizeHintsPtr);
PROCEDURE XShrinkRegion* (
r: Region;
dx: C.int;
dy: C.int);
PROCEDURE XStringListToTextProperty* (
list: C.charPtr2d;
count: C.int;
VAR textpropreturn: XTextProperty): X.Status;
PROCEDURE XSubtractRegion* (
sra, srb, drreturn: Region); (* ??? *)
PROCEDURE XmbTextListToTextProperty* (
display: X.DisplayPtr;
list: C.charPtr2d;
count: C.int;
style: XICCEncodingStyle;
VAR textpropreturn: XTextProperty): C.int;
PROCEDURE XwcTextListToTextProperty* (
display: X.DisplayPtr;
list: ARRAY OF X.wchart;
count: C.int;
style: XICCEncodingStyle;
VAR textpropreturn: XTextProperty): C.int;
PROCEDURE XwcFreeStringList* (
list: X.wcharPtr2d);
PROCEDURE XTextPropertyToStringList* (
textprop: XTextPropertyPtr;
VAR listreturn: C.charPtr2d;
VAR countreturn: C.int): X.Status;
PROCEDURE XTextPropertyToTextList* (
display: X.DisplayPtr;
textprop: XTextPropertyPtr;
VAR listreturn: C.charPtr2d;
VAR countreturn: C.int): X.Status;
PROCEDURE XwcTextPropertyToTextList* (
display: X.DisplayPtr;
textprop: XTextPropertyPtr;
VAR listreturn: X.wcharPtr2d;
VAR countreturn: C.int): X.Status;
PROCEDURE XUnionRectWithRegion* (
rectangle: X.XRectanglePtr;
srcregion: Region;
destregionreturn: Region); (* ??? *)
PROCEDURE XUnionRegion* (
sra, srb, drreturn: Region); (* ??? *)
PROCEDURE XWMGeometry* (
display: X.DisplayPtr;
screennumber: C.int;
usergeometry: ARRAY OF C.char;
defaultgeometry: ARRAY OF C.char;
borderwidth: C.int;
hints: XSizeHintsPtr;
VAR xreturn: C.int;
VAR yreturn: C.int;
VAR widthreturn: C.int;
VAR heightreturn: C.int;
VAR gravityreturn: C.int): C.int;
PROCEDURE XXorRegion* (
sra, srb, drreturn: Region); (* ??? *)
*)
END oocXutil.

639
src/library/pow/powStrings.Mod Normal file
View file

@ -0,0 +1,639 @@
(*----------------------------------------------------------------------------*)
(* Copyright (c) 1997 by the POW! team *)
(* e-Mail: pow@fim.uni-linz.ac.at *)
(*----------------------------------------------------------------------------*)
(* 08-20-1997 rel. 32/1.0 LEI *)
(* 19-11-1998 rel. 32/1.1 LEI bug in RemoveTrailingSpaces fixed *)
(**---------------------------------------------------------------------------
This module provides functions for string processing. This includes combining
strings, copying parts of a string, the conversion of a string to a number or
vice-versa etc.
All functions of this module start to count the character positions with one
i.e. the first character of a string is at position one.
All procedures applying to characters instead of strings have a
trailing "Char" in their names.
All procedures should be save. If character arrays are being used which are
to short for a result, the result will be truncated accordingly.
All functions tolerate errors in character position. However, strings
must always be terminated by a character with the code zero in order
to be processed correctly, otherwise runtime errors may occur.
----------------------------------------------------------------------------*)
MODULE powStrings;
CONST
ISSHORTINT*=1;
ISINTEGER*=2;
ISLONGINT*=3;
ISOUTOFRANGE*=4;
STRINGEMPTY*=5;
STRINGILLEGAL*=6;
TYPE
StringT*=ARRAY OF CHAR;
String*=POINTER TO StringT;
PROCEDURE Length*(VAR t:StringT):LONGINT;
(** Returns the length of a zero terminated string in characters. *)
VAR
i,maxlen:LONGINT;
BEGIN
maxlen:=LEN(t);
i:=0;
WHILE (i<maxlen) & (t[i]#0X) DO INC(i) END;
RETURN i;
END Length;
PROCEDURE PosChar*(x:CHAR;
VAR t:StringT;
start:LONGINT (** Indicates the position starting from which
the search is to be carried out. If start is less
than one it is set to one. If start denotes a
position beyond the end of t the function returns zero. *)
):LONGINT;
(** This function returns the position of the character <x> in the string <t>.
If <x> does not occur in <t> zero is returned. If <x> occurs several times the
position of the first occurrence is returned. *)
VAR
maxl:LONGINT;
BEGIN
IF start<1 THEN start:=0 ELSE DEC(start) END;
maxl:=Length(t);
WHILE (start<maxl) & (t[start]#x) DO INC(start); END;
IF (start<maxl) & (t[start]=x) THEN RETURN start+1 ELSE RETURN 0; END;
END PosChar;
PROCEDURE Pos*(VAR pattern:StringT;
VAR t:StringT;
start:LONGINT (** Indicates the position starting from which the search shall be
carried out. If start is less than one it is set to one. If start
denotes a position beyond the end of t the function returns zero. *)
):LONGINT;
(** This function returns the position of the string pattern in the string <t>.
If pattern does not occur in <t> zero is returned. If the pattern occurs several
times the position of the first occurrence is returned. *)
VAR
i,j,maxl,patLen:LONGINT;
BEGIN
IF start<1 THEN start:=0 ELSE DEC(start) END;
maxl:=Length(t);
patLen:=Length(pattern);
i:=start;
j:=0;
WHILE (j<patLen) & (i+j<maxl) DO
IF t[i+j]=pattern[j] THEN INC(j) ELSE j:=0; INC(i) END;
END;
IF j=patLen THEN RETURN i+1 ELSE RETURN 0 END;
END Pos;
PROCEDURE Copy*(VAR source,dest:StringT;
pos, (** character position of the source fragment *)
n:LONGINT (** length of the source fragment *)
);
(** A section of the string <source> is copied to the string <dest>. The former contents
of <dest> are overwritten and therefore lost.
The copied section in <source> starts at the position <pos> and is <n> characters long.
If <dest> is not large enough to hold the copied string then only the
part that fits into <dest> is copied. *)
VAR
i,j,l1,l2:LONGINT;
BEGIN
IF pos<1 THEN
dest[0]:=0X;
RETURN;
END;
l1:=Length(source)-pos+1;
IF l1<1 THEN
dest[0]:=0X;
RETURN;
END;
l2:=LEN(dest)-1;
IF l2<l1 THEN l1:=l2 END;
IF n<l1 THEN l1:=n END;
i:=0;
j:=pos-1;
WHILE i<l1 DO
dest[i]:=source[j];
INC(i);
INC(j);
END;
dest[i]:=0X;
END Copy;
PROCEDURE Append*(VAR dest:StringT; VAR src:StringT);
(** The string <src> is appended to the string <dest>. *)
VAR
i,j,lSrc,lDest:LONGINT;
BEGIN
i:=Length(dest);
j:=0;
lDest:=LEN(dest)-1;
lSrc:=LEN(src);
WHILE (i<lDest) & (j<lSrc) & (src[j]#0X) DO
dest[i]:=src[j];
INC(i);
INC(j);
END;
dest[i]:=0X;
END Append;
PROCEDURE AppendChar*(VAR dest:StringT; ch:CHAR);
(** The character <ch> is appended to the string <dest>. *)
VAR
l:LONGINT;
BEGIN
l:=Length(dest);
IF LEN(dest)>=l+2 THEN
dest[l]:=ch;
dest[l+1]:=0X;
END;
END AppendChar;
PROCEDURE UpCaseChar*(x:CHAR):CHAR;
(** For all lower case letters the corresponding capital letter is returned. This also
applies to international characters such as ä, á, à, â... All other characters are
returned unchanged. The difference between this function and the Oberon-2 function
CAP(x:CHAR): CHAR is that the return value for characters other than lower case
letters of the latter function depends on the individual compiler implementation. *)
BEGIN
CASE x OF
"a".."z":x:=CHR(ORD(x)+ORD("A")-ORD("a"));
| "ö": x:="Ö";
| "ä": x:="Ä";
| "ü": x:="Ü";
| "á": x:="Á";
| "é": x:="É";
| "í": x:="Í";
| "ó": x:="Ó";
| "ú": x:="Ú";
| "à": x:="À";
| "è": x:="È";
| "ì": x:="Ì";
| "ò": x:="Ò";
| "ù": x:="Ù";
| "â": x:="Â";
| "ê": x:="Ê";
| "î": x:="Î";
| "ô": x:="Ô";
| "û": x:="Û";
ELSE
END;
RETURN x;
END UpCaseChar;
PROCEDURE UpCase*(VAR t:StringT);
(** All lower case letters in <t> are converted to upper case. This also
applies to international characters such as ä, á, à, â... All other characters are
returned unchanged. *)
VAR
i,l:LONGINT;
BEGIN
i:=0;
l:=LEN(t);
WHILE (i<l) & (t[i]#0X) DO
t[i]:=UpCaseChar(t[i]);
INC(i);
END;
END UpCase;
PROCEDURE Delete*(VAR t:StringT; pos,n:LONGINT);
(** Starting at the position <pos> <n> characters of the string <t> are deleted. *)
VAR
i,l:LONGINT;
BEGIN
l:=Length(t);
IF (n<1) OR (pos<1) OR (pos>l) THEN RETURN END;
IF n>l-pos+1 THEN n:=l-pos+1 END;
FOR i:=pos-1 TO l-n DO t[i]:=t[i+n]; END;
END Delete;
PROCEDURE ReverseStringT(VAR t:StringT; n:LONGINT);
VAR
a,b:LONGINT;
x:CHAR;
BEGIN
a:=0;
b:=n-1;
WHILE (a<b) DO
x:=t[a];
t[a]:=t[b];
t[b]:=x;
INC(a);
DEC(b);
END;
END ReverseStringT;
PROCEDURE RemoveTrailingSpaces*(VAR t:StringT);
(** All blanks at the end of <t> are removed. *)
VAR
i:LONGINT;
BEGIN
i:=Length(t)-1;
WHILE (i>=0) & (t[i]=" ") DO DEC(i) END;
t[i+1]:=0X;
END RemoveTrailingSpaces;
PROCEDURE RemoveLeadingSpaces*(VAR t:StringT);
(** All blanks at the beginning of <t> are removed. *)
VAR
i,ml:LONGINT;
BEGIN
i:=0;
ml:=LEN(t)-1;
WHILE (i<ml) & (t[i]=" ") DO INC(i); END;
IF i>0 THEN Delete(t,1,i) END;
END RemoveLeadingSpaces;
PROCEDURE Val*(t:StringT):LONGINT;
(** The string <t> is converted to a number and returned as result of the function.
If the character sequence in <t> does not represent a number and thus the
conversion to a number fails the smallest negative number (MIN(LONGINT)) is returned.
Blanks at the beginning and the end of <t> are ignored.
The number must not contain blanks. *)
CONST
threshDec=MAX(LONGINT) DIV 10;
threshHex=MAX(LONGINT) DIV 16;
VAR
inx,l,v,res:LONGINT;
hex,exit,neg:BOOLEAN;
ch:CHAR;
BEGIN
RemoveTrailingSpaces(t);
RemoveLeadingSpaces(t);
l:=Length(t);
IF l<1 THEN RETURN MIN(LONGINT) END;
hex:=CAP(t[l-1])="H";
IF hex THEN
DEC(l);
t[l]:=0X;
IF l<1 THEN RETURN MIN(LONGINT) END;
END;
inx:=0;
neg:=FALSE;
res:=0;
IF t[0]="+" THEN INC(inx)
ELSIF t[0]="-" THEN INC(inx); neg:=TRUE; END;
IF t[l-1]="+" THEN DEC(l)
ELSIF t[l-1]="-" THEN DEC(l); neg:=TRUE; END;
exit:=FALSE;
IF hex THEN
IF neg THEN
WHILE (inx<l) & ~exit DO
ch:=CAP(t[inx]);
IF (ch>="0") & (ch<="9") THEN
v:=ORD(ch)-48;
ELSIF (ch>="A") & (ch<="F") THEN
v:=ORD(ch)-65+10;
ELSE
v:=-1;
END;
IF (v<0) OR (v>15) OR (res<-threshHex) THEN
exit:=TRUE
ELSE
res:=res*16-v;
INC(inx);
END;
END;
ELSE
WHILE (inx<l) & ~exit DO
ch:=CAP(t[inx]);
IF (ch>="0") & (ch<="9") THEN
v:=ORD(ch)-48;
ELSIF (ch>="A") & (ch<="F") THEN
v:=ORD(ch)-65+10;
ELSE
v:=-1;
END;
IF (v<0) OR (v>15) OR (res>threshHex) THEN
exit:=TRUE
ELSE
res:=res*16+v;
INC(inx);
END;
END;
END;
ELSE
IF neg THEN
WHILE (inx<l) & ~exit DO
v:=ORD(t[inx])-48;
IF (v<0) OR (v>9) OR (res<-threshDec) OR ((res=-threshDec) & (v>8)) THEN
exit:=TRUE
ELSE
res:=res*10-v;
INC(inx);
END;
END;
ELSE
WHILE (inx<l) & ~exit DO
v:=ORD(t[inx])-48;
IF (v<0) OR (v>9) OR (res>threshDec) OR ((res=threshDec) & (v>7)) THEN
exit:=TRUE
ELSE
res:=res*10+v;
INC(inx);
END;
END;
END;
END;
IF exit THEN
RETURN MIN(LONGINT)
ELSE
RETURN res;
END;
END Val;
PROCEDURE ValResult*(t:StringT):INTEGER;
(** This function can be used to discover whether the string <t> can be converted
to a number, and which kind of integer is at least necessary for storing it.
The IS??? constants defined for the return value have a numerical order defined
relative to each other:
ISSHORTINT < ISINTEGER < ISLONGINT < ISOUTOFRANGE < (STRINGEMPTY, STRINGILLEGAL)
This definition makes it easier to find out if e.g. a number is small enough to
be stored in a INTEGER variable.
IF Strings.ValResult(txt)<=Strings.ISINTEGER THEN ...
END;
instead of
IF (Strings.ValResult(txt)=Strings.ISSHORTINT) OR
(Strings.ValResult(txt)=Strings.ISINTEGER) THEN ... *)
CONST
threshDec=MAX(LONGINT) DIV 10;
threshHex=MAX(LONGINT) DIV 16;
mThreshHex=MIN(LONGINT) DIV 16;
VAR
inx,l,v,res:LONGINT;
h:INTEGER;
hex,exit,neg:BOOLEAN;
ch:CHAR;
BEGIN
RemoveTrailingSpaces(t);
RemoveLeadingSpaces(t);
l:=Length(t);
IF l<1 THEN RETURN STRINGEMPTY END;
hex:=CAP(t[l-1])="H";
IF hex THEN
DEC(l);
t[l]:=0X;
IF l<1 THEN RETURN STRINGEMPTY END;
END;
inx:=0;
neg:=FALSE;
res:=0;
IF t[0]="+" THEN INC(inx)
ELSIF t[0]="-" THEN INC(inx); neg:=TRUE; END;
IF t[l-1]="+" THEN DEC(l)
ELSIF t[l-1]="-" THEN DEC(l); neg:=TRUE; END;
exit:=FALSE;
IF hex THEN
IF neg THEN
WHILE (inx<l) & ~exit DO
ch:=CAP(t[inx]);
IF (ch>="0") & (ch<="9") THEN
v:=ORD(ch)-48;
ELSIF (ch>="A") & (ch<="F") THEN
v:=ORD(ch)-65+10;
ELSE
v:=-1;
END;
IF (v<0) OR (v>15) OR (res<mThreshHex) OR ((res=mThreshHex) & (v>0)) THEN
exit:=TRUE
ELSE
res:=res*16-v;
INC(inx);
END;
END;
ELSE
WHILE (inx<l) & ~exit DO
ch:=CAP(t[inx]);
IF (ch>="0") & (ch<="9") THEN
v:=ORD(ch)-48;
ELSIF (ch>="A") & (ch<="F") THEN
v:=ORD(ch)-65+10;
ELSE
v:=-1;
END;
IF (v<0) OR (v>15) OR (res>threshHex) THEN
exit:=TRUE
ELSE
res:=res*16+v;
INC(inx);
END;
END;
END;
ELSE
IF neg THEN
WHILE (inx<l) & ~exit DO
v:=ORD(t[inx])-48;
IF (v<0) OR (v>9) OR (res<-threshDec) OR ((res=-threshDec) & (v>8)) THEN
exit:=TRUE
ELSE
res:=res*10-v;
INC(inx);
END;
END;
ELSE
WHILE (inx<l) & ~exit DO
v:=ORD(t[inx])-48;
IF (v<0) OR (v>9) OR (res>threshDec) OR ((res=threshDec) & (v>7)) THEN
exit:=TRUE
ELSE
res:=res*10+v;
INC(inx);
END;
END;
END;
END;
IF exit THEN
IF (v<0) OR (hex & (v>15)) OR (~hex & (v>9)) THEN RETURN STRINGILLEGAL ELSE RETURN ISOUTOFRANGE END;
ELSE
h:=ISLONGINT;
IF (res>=MIN(INTEGER)) & (res<=MAX(INTEGER)) THEN DEC(h) END;
IF (res>=MIN(SHORTINT)) & (res<=MAX(SHORTINT)) THEN DEC(h) END;
RETURN h;
END;
END ValResult;
PROCEDURE Str*(x:LONGINT; VAR t:StringT);
(** The number <x> is converted to a string and the result is stored in <t>.
If <t> is not large enough to hold all characters of the number,
<t> is filled with "$" characters. *)
VAR
i:LONGINT;
maxlen:LONGINT;
neg:BOOLEAN;
BEGIN
maxlen:=LEN(t)-1;
IF maxlen<1 THEN
t[0]:=0X;
RETURN;
END;
IF x=0 THEN
t[0]:="0";
t[1]:=0X;
ELSE
i:=0;
neg:=x<0;
IF neg THEN
IF x=MIN(LONGINT) THEN
COPY("-2147483648",t);
IF Length(t)#11 THEN
FOR i:=0 TO maxlen-1 DO t[i]:="$" END;
t[maxlen]:=0X;
END;
RETURN;
ELSE
x:=-x;
END;
END;
WHILE (x#0) & (i<maxlen) DO
t[i]:=CHR(48+x MOD 10);
x:=x DIV 10;
INC(i);
END;
IF (x#0) OR (neg & (i>=maxlen)) THEN
FOR i:=0 TO maxlen-1 DO t[i]:="$" END;
t[maxlen]:=0X;
ELSE
IF neg THEN
t[i]:="-";
INC(i);
END;
t[i]:=0X;
ReverseStringT(t,i);
END;
END;
END Str;
PROCEDURE HexStr*(x:LONGINT; VAR t:StringT);
(** The number <x> is converted to a string of hexadecimal format and the result is stored
in <t>. At the end of the string an "h" is appended to indicate the hexadecimal
representation of the number.
If <t> is not large enough to hold all characters of the number, <t> is filled with "$"
characters. Example: 0 becomes "0h", 15 becomes "Fh", 16 becomes "10h". *)
VAR
i:LONGINT;
digit:LONGINT;
maxlen:LONGINT;
neg:BOOLEAN;
BEGIN
maxlen:=LEN(t)-1;
IF maxlen<2 THEN
IF maxlen=1 THEN t[0]:="$"; t[1]:=0X ELSE t[0]:=0X END;
RETURN;
END;
IF x=0 THEN
t[0]:="0";
t[1]:="h";
t[2]:=0X;
ELSE
t[0]:="h";
i:=1;
neg:=x<0;
IF neg THEN
IF x=MIN(LONGINT) THEN
COPY("-80000000h",t);
IF Length(t)#10 THEN
FOR i:=0 TO maxlen-1 DO t[i]:="$" END;
t[maxlen]:=0X;
END;
RETURN;
ELSE
x:=-x;
END;
END;
WHILE (x#0) & (i<maxlen) DO
digit:=x MOD 16;
IF digit<10 THEN t[i]:=CHR(48+digit) ELSE t[i]:=CHR(55+digit) END;
x:=x DIV 16;
INC(i);
END;
IF (x#0) OR (neg & (i>=maxlen)) THEN
FOR i:=0 TO maxlen-1 DO t[i]:="$" END;
t[maxlen]:=0X;
ELSE
IF neg THEN
t[i]:="-";
INC(i);
END;
t[i]:=0X;
ReverseStringT(t,i);
END;
END;
END HexStr;
PROCEDURE InsertChar*(x:CHAR; VAR t:StringT; pos:LONGINT);
(** The character <x> is inserted into the string <t> at the position <pos> if
<t> provides space for it. *)
VAR
i,l:LONGINT;
BEGIN
l:=Length(t);
IF l+1<LEN(t) THEN
IF pos<1 THEN pos:=1 ELSIF pos>l+1 THEN pos:=l+1 END;
FOR i:=l TO pos-1 BY -1 DO t[i+1]:=t[i]; END;
t[pos-1]:=x;
END;
END InsertChar;
PROCEDURE Insert*(VAR source:StringT; VAR dest:StringT; pos:LONGINT);
(** The string <source> is inserted into the string <dest> at the position <pos>.
If the maximum length of <dest> is insufficient to store the result only
the part of <source> fitting in <dest> is inserted. *)
VAR
i,l,dif:LONGINT;
BEGIN
dif:=Length(source);
l:=Length(dest);
IF l+dif+1>LEN(dest) THEN dif:=LEN(dest)-l-1 END;
IF pos<1 THEN pos:=1 ELSIF pos>l+1 THEN pos:=l+1 END;
FOR i:=l TO pos-1 BY -1 DO dest[i+dif]:=dest[i]; END;
FOR i:=pos-1 TO pos-2+dif DO dest[i]:=source[i+1-pos] END;
END Insert;
PROCEDURE LeftAlign*(VAR t:StringT; n:LONGINT);
(** The length of <t> is increased to <n> characters by appending blanks. If <t> has
already the appropriate length or is longer <t> remains unchanged. *)
VAR
l,i:LONGINT;
maxlen:LONGINT;
BEGIN
maxlen:=LEN(t);
IF n+1>maxlen THEN n:=maxlen-1; END;
l:=Length(t);
IF l<=n-1 THEN
FOR i:=l TO n-1 DO t[i]:=" " END;
t[n]:=0X;
END;
END LeftAlign;
PROCEDURE RightAlign*(VAR t:StringT; n:LONGINT);
(** The length of <t> is increased to <n> characters by inserting blanks at the
beginning. If <t> has already the appropriate length or is longer <t> remains unchanged. *)
VAR
l,i:LONGINT;
maxlen:LONGINT;
BEGIN
maxlen:=LEN(t);
IF n+1>maxlen THEN n:=maxlen-1; END;
l:=Length(t);
IF l<n THEN
t[n]:=0X;
n:=n-l;
FOR i:=l-1 TO 0 BY -1 DO t[i+n]:=t[i] END;
FOR i:=0 TO n-1 DO t[i]:=" " END;
END;
END RightAlign;
END powStrings.

1134
src/library/s3/ethBTrees.Mod Normal file
View file

File diff suppressed because it is too large Load diff

214
src/library/s3/ethDates.Mod Normal file
View file

@ -0,0 +1,214 @@
(* ETH Oberon, Copyright 2001 ETH Zuerich Institut fuer Computersysteme, ETH Zentrum, CH-8092 Zuerich.
Refer to the "General ETH Oberon System Source License" contract available at: http://www.oberon.ethz.ch/ *)
MODULE ethDates; (** portable *) (* PS *)
IMPORT Texts;
CONST
minute* = 60; hour* = 60*minute; day* = 24*hour; week*= 7* day;
zeroY = 1900;
firstY* = 1901;
VAR
TimeDiff*: LONGINT; (** local difference to universal time in minutes *)
A : ARRAY 13 OF INTEGER;
T : ARRAY 365 OF SHORTINT;
(** Returns TRUE if year is a leap year *)
PROCEDURE IsLeapYear* (year: INTEGER): BOOLEAN;
BEGIN RETURN (year MOD 4 = 0) & (~(year MOD 100 = 0) OR (year MOD 400 = 0))
END IsLeapYear;
PROCEDURE LastDay (year, month: INTEGER): INTEGER;
BEGIN
IF (month < 8) & ODD(month) OR (month > 7) & ~ODD(month) THEN RETURN 31
ELSIF month = 2 THEN
IF IsLeapYear(year) THEN RETURN 29 ELSE RETURN 28 END
ELSE RETURN 30
END
END LastDay;
(** Returns the number of days since 1.1.[firstY] *)
PROCEDURE NumberOfDays* (date: LONGINT): LONGINT;
VAR num: LONGINT; y, m: INTEGER;
BEGIN
y := SHORT(date DIV 512) + zeroY - firstY;
m := SHORT(date DIV 32) MOD 16;
num := LONG(y) * 365 + y DIV 4 + A[(m - 1) MOD 12] + (date MOD 32) - 1;
IF IsLeapYear(firstY + y) & (m > 2) THEN INC(num) END;
RETURN num
END NumberOfDays;
(** Returns the date 1.1.[firstY] + days *)
PROCEDURE NumberOfDaysToDate* (days: LONGINT): LONGINT;
VAR M, m, y, d: LONGINT;
BEGIN
IF (days + 307) MOD 1461 = 0 THEN d := 2 ELSE d := 1 END;
days := days - (days + 307) DIV 1461; y := firstY + days DIV 365;
IF firstY > y THEN y := zeroY; m := 1; d := 1
ELSE M := days MOD 365; m := T[M]; d := M - A[m - 1] + d
END;
RETURN ASH(ASH(y-zeroY, 4) + m, 5) + d
END NumberOfDaysToDate;
(** Converts year, month and day into an Oberon date *)
PROCEDURE ToDate* (year, month, day: INTEGER): LONGINT;
VAR d: INTEGER;
BEGIN
month := 1 + (month - 1) MOD 12;
d := LastDay(year, month); day := 1 + (day - 1) MOD d;
RETURN ASH(ASH(year-zeroY, 4) + month, 5) + day
END ToDate;
(** Converts hour, min and sec into an Oberon time *)
PROCEDURE ToTime* (hour, min, sec: INTEGER): LONGINT;
BEGIN RETURN ((LONG(hour) MOD 24)*64 + (min MOD 60))*64 + (sec MOD 60)
END ToTime;
(** Extracts year, month and day of an Oberon date *)
PROCEDURE ToYMD* (date: LONGINT; VAR year, month, day: INTEGER);
BEGIN
year := SHORT(date DIV 512) + zeroY;
month := SHORT((date DIV 32) MOD 16); day := SHORT(date MOD 32)
END ToYMD;
(** Extracts hour, min and sec of an Oberon time *)
PROCEDURE ToHMS* (time: LONGINT; VAR hour, min, sec: INTEGER);
BEGIN
hour := SHORT(time DIV 4096); min := SHORT((time DIV 64) MOD 64); sec := SHORT(time MOD 64)
END ToHMS;
(** Returns weekday from date, where 0 is monday *)
PROCEDURE DayOfWeek* (date: LONGINT): INTEGER;
VAR num: LONGINT;
BEGIN
num := NumberOfDays(date);
RETURN SHORT((num+1) MOD 7)
END DayOfWeek;
(** Returns number of days in a month *)
PROCEDURE DaysOfMonth* (date: LONGINT): INTEGER; (* returns last day in month *)
VAR year, month: LONGINT;
BEGIN
month := (date DIV 32) MOD 16; year := (date DIV 512) + zeroY;
RETURN LastDay(SHORT(year), SHORT(month))
END DaysOfMonth;
(** Following three procedures are used to add/subtract a certain amount of days/month/years. *)
PROCEDURE AddYear* (date: LONGINT; years: INTEGER): LONGINT;
VAR y, m, d: INTEGER;
BEGIN
ToYMD(date, y, m, d);
IF firstY <= y + years THEN
IF IsLeapYear(y) & (m = 2) & (d = 29) & ~IsLeapYear(y + years) THEN d := 28 END;
date := ToDate(y + years, m, d)
END;
RETURN date
END AddYear;
PROCEDURE AddMonth* (date: LONGINT; months: INTEGER): LONGINT;
VAR y, m, d: INTEGER;
BEGIN
ToYMD(date, y, m, d); INC(m, months - 1);
y := y + m DIV 12;
IF firstY <= y THEN
m := m MOD 12 + 1;
IF m =2 THEN
IF (d > 29) & IsLeapYear(y) THEN d := 29
ELSIF (d > 28) & ~ IsLeapYear(y) THEN d := 28
END
ELSIF (d > 30) & ((m < 8) & ~ODD(m) OR (m > 7) & ODD(m)) THEN d := 30
END;
date := ToDate(y, m, d)
END;
RETURN date
END AddMonth;
PROCEDURE AddDay* (date: LONGINT; days: INTEGER): LONGINT;
VAR num: LONGINT;
BEGIN num := NumberOfDays(date); num := num + days; RETURN NumberOfDaysToDate(num)
END AddDay;
(** Following three procedures are used to add/subtract a certain amount of time. *)
PROCEDURE AddHour* (time: LONGINT; hour: INTEGER): LONGINT;
VAR s, m, h: INTEGER;
BEGIN ToHMS(time, h, m, s); RETURN ToTime((h + hour) MOD 24, m, s)
END AddHour;
PROCEDURE AddMinute* (time: LONGINT; min: INTEGER): LONGINT;
VAR s, m, h: INTEGER;
BEGIN
ToHMS(time, h, m, s); INC(m, min);
IF (m < 0) OR (m >= 60) THEN h := (h + m DIV 60) MOD 24; m := m MOD 60 END;
RETURN ToTime(h, m, s)
END AddMinute;
PROCEDURE AddSecond* (time: LONGINT; sec: INTEGER): LONGINT;
VAR s, m, h: INTEGER;
BEGIN
ToHMS(time, h, m, s); INC(s, sec);
IF (s < 0) OR (s >= 60) THEN
INC(m, s DIV 60); s := s MOD 60;
IF (m < 0) OR (m >= 60) THEN h := (h + m DIV 60) MOD 24; m := m MOD 60 END
END;
RETURN ToTime(h, m, s)
END AddSecond;
(** Following procedure adds/subtracts a certain amount seconds to time/date. *)
PROCEDURE AddTime* (VAR time, date: LONGINT; sec: LONGINT);
VAR h, m, s: LONGINT; ss, mm, hh: INTEGER;
BEGIN
ToHMS(time, hh, mm, ss); s := sec + ss; h := hh; m := mm;
IF (s < 0) OR (s >= 60) THEN
m := s DIV 60 + mm; s := s MOD 60;
IF (m < 0) OR (m >= 60) THEN
h := m DIV 60 + hh; m := m MOD 60;
IF (h < 0) OR (h >= 24) THEN
date := AddDay(date, SHORT(h DIV 24)); h := h MOD 24
END
END
END;
time := ToTime(SHORT(h), SHORT(m), SHORT(s))
END AddTime;
PROCEDURE Init();
VAR
diff: ARRAY 8 OF CHAR;
S: Texts.Scanner;
Txt : Texts.Text; (* noch *)
i, j: LONGINT;
BEGIN
A[0] := 0; A[1] := 31; A[2] := 59; A[3] := 90; A[4] := 120; A[5] := 151; A[6] := 181;
A[7] := 212; A[8] := 243; A[9] := 273; A[10] := 304; A[11] := 334; A[12] := 365;
i := 0; j := 0;
WHILE i < 12 DO WHILE j < A[i+1] DO T[j] := SHORT(SHORT(i + 1)); INC(j) END; INC(i) END;
(*Oberon.OpenScanner(S, "System.TimeDiff");*)
NEW(Txt);
Texts.Open(Txt, "System.TimeDiff");
Texts.OpenScanner(S, Txt, 0);
TimeDiff := 0;
IF S.class = Texts.String THEN
COPY(S.s, diff);
i := 0; j := 1;
IF diff[i] = "+" THEN
INC(i)
ELSIF diff[i] = "-" THEN
INC(i); j := -1
END;
WHILE (diff[i] >= "0") & (diff[i] <= "9") DO
TimeDiff := 10*TimeDiff+ORD(diff[i])-ORD("0");
INC(i)
END;
TimeDiff := (TimeDiff DIV 100)*60 + (TimeDiff MOD 100);
TimeDiff := j*TimeDiff
END
END Init;
BEGIN
Init()
END ethDates.

169
src/library/s3/ethGZReaders.Mod Normal file
View file

@ -0,0 +1,169 @@
(* ETH Oberon, Copyright 2001 ETH Zuerich Institut fuer Computersysteme, ETH Zentrum, CH-8092 Zuerich.
Refer to the "General ETH Oberon System Source License" contract available at: http://www.oberon.ethz.ch/ *)
MODULE ethGZReaders; (** Stefan Walthert **)
(**
Reading from .gz files
**)
IMPORT
Files, ZlibReaders := ethZlibReaders;
CONST
(** result codes **)
Ok* = ZlibReaders.Ok; StreamEnd* = ZlibReaders.StreamEnd;
StreamError* = ZlibReaders.StreamError; DataError* = ZlibReaders.DataError; BufError* = ZlibReaders.BufError; FileError* = ZlibReaders.FileError;
BufSize = 4000H;
DeflateMethod = 8;
TYPE
(** structure for reading from a .gz file **)
Reader* = RECORD
file-: Files.File; (** underlying Oberon file **)
res-: LONGINT; (** current stream state **)
transparent: BOOLEAN; (* set if not a .gz file *)
pos: LONGINT; (* logical position in decompressed output stream *)
zr: ZlibReaders.Reader;
END;
(* check .gz header; input buffer must be empty or just have been refilled (in case magic id is missing) *)
PROCEDURE CheckHeader (VAR r: Reader; VAR fr: Files.Rider);
CONST
headCRC = 2; extraField = 4; origName = 8; comment = 10H; reserved = 20H;
VAR
ch, method, flags: CHAR; len: INTEGER;
BEGIN
Files.Read(fr, ch);
IF fr.eof THEN
r.res := StreamEnd
ELSIF ch # 1FX THEN
r.transparent := TRUE; r.res := Ok
ELSE (* first byte of magic id ok *)
Files.Read(fr, ch);
IF fr.eof OR (ch # 8BX)THEN
r.transparent := TRUE; r.res := Ok
ELSE (* second byte of magic id ok *)
Files.Read(fr, method); Files.Read(fr, flags);
IF fr.eof OR (ORD(method) # DeflateMethod) OR (ORD(flags) >= reserved) THEN
r.res := DataError
ELSE
FOR len := 1 TO 6 DO Files.Read(fr, ch) END; (* skip time, xflags and OS code *)
IF ODD(ORD(flags) DIV extraField) THEN (* skip extra field *)
Files.Read(fr, ch); len := ORD(ch);
Files.Read(fr, ch); len := len + 100H*ORD(ch);
WHILE ~fr.eof & (len # 0) DO
Files.Read(fr, ch); DEC(len)
END
END;
IF ODD(ORD(flags) DIV origName) THEN (* skip original file name *)
REPEAT Files.Read(fr, ch) UNTIL fr.eof OR (ch = 0X)
END;
IF ODD(ORD(flags) DIV comment) THEN (* skip the .gz file comment *)
REPEAT Files.Read(fr, ch) UNTIL fr.eof OR (ch = 0X)
END;
IF ODD(ORD(flags) DIV headCRC) THEN (* skip header crc *)
Files.Read(fr, ch); Files.Read(fr, ch)
END;
IF fr.eof THEN r.res := DataError
ELSE r.res := Ok
END
END
END
END
END CheckHeader;
(** open reader on existing file for input **)
PROCEDURE Open* (VAR r: Reader; file: Files.File);
VAR
fr: Files.Rider;
BEGIN
r.transparent := FALSE;
IF file # NIL THEN
r.file := file; Files.Set(fr, file, 0);
CheckHeader(r, fr);
ZlibReaders.Open(r.zr, FALSE, fr);
r.pos := 0
ELSE
r.res := StreamError
END
END Open;
(** close reader **)
PROCEDURE Close* (VAR r: Reader);
VAR
fr: Files.Rider;
crc32: LONGINT;
BEGIN
IF r.transparent THEN
r.res := Ok
ELSE
ZlibReaders.Close(r.zr);
IF r.zr.res = ZlibReaders.Ok THEN
Files.Set(fr, r.file, Files.Length(r.file) - 8);
Files.ReadLInt(fr, crc32);
IF crc32 # r.zr.crc32 THEN
r.res := DataError
ELSE
r.res := Ok
END
ELSE
r.res := r.zr.res
END
END
END Close;
(** read specified number of bytes into buffer and return number of bytes actually read **)
PROCEDURE ReadBytes* (VAR r: Reader; VAR buf: ARRAY OF CHAR; offset, len: LONGINT; VAR read: LONGINT);
VAR i: LONGINT; fr: Files.Rider; bufp: POINTER TO ARRAY OF CHAR;
BEGIN
IF r.file = NIL THEN
r.res := StreamError; read := 0
ELSIF r.res < Ok THEN
read := 0
ELSIF r.res = StreamEnd THEN
read := 0
ELSIF r.transparent THEN (* uncompressed input *)
Files.Set(fr, r.file, r.pos);
IF offset = 0 THEN
Files.ReadBytes(fr, buf, len)
ELSE
NEW(bufp, len);
Files.ReadBytes(fr, bufp^, len);
FOR i := 0 TO len - 1 DO
buf[offset + i] := bufp[i]
END
END;
read := len - fr.res
ELSE
ZlibReaders.ReadBytes(r.zr, buf, offset, len, read)
END;
INC(r.pos, read)
END ReadBytes;
(** read decompressed byte **)
PROCEDURE Read* (VAR r: Reader; VAR ch: CHAR);
BEGIN
ZlibReaders.Read(r.zr, ch)
END Read;
(** get position of reader within uncompressed output stream **)
PROCEDURE Pos* (VAR r: Reader): LONGINT;
VAR pos: LONGINT;
BEGIN
IF r.file = NIL THEN
r.res := StreamError; pos := 0
ELSIF r.res < Ok THEN
pos := 0
ELSE
pos := r.pos
END;
RETURN pos
END Pos;
END ethGZReaders.

113
src/library/s3/ethGZWriters.Mod Normal file
View file

@ -0,0 +1,113 @@
(* ETH Oberon, Copyright 2001 ETH Zuerich Institut fuer Computersysteme, ETH Zentrum, CH-8092 Zuerich.
Refer to the "General ETH Oberon System Source License" contract available at: http://www.oberon.ethz.ch/ *)
MODULE ethGZWriters; (** Stefan Walthert **)
IMPORT
Files, ZlibWriters := ethZlibWriters;
CONST
(** result codes **)
Ok* = ZlibWriters.Ok; StreamEnd* = ZlibWriters.StreamEnd;
FileError* = -1; StreamError* = ZlibWriters.StreamError; DataError* = ZlibWriters.DataError; BufError* = ZlibWriters.BufError;
(** compression levels **)
DefaultCompression* = ZlibWriters.DefaultCompression; NoCompression* = ZlibWriters.NoCompression;
BestSpeed* = ZlibWriters.BestSpeed; BestCompression* = ZlibWriters.BestCompression;
(** compression strategies **)
DefaultStrategy* = ZlibWriters.DefaultStrategy; Filtered* = ZlibWriters.Filtered; HuffmanOnly* = ZlibWriters.HuffmanOnly;
DeflateMethod = 8;
TYPE
(** structure for writing to a .gz file **)
Writer* = RECORD
file-: Files.File; (** underlying Oberon file **)
res-: LONGINT; (** current stream state **)
start: LONGINT; (* start of compressed data in file (after header) *)
pos: LONGINT; (* logical position in uncompressed input stream *)
zw: ZlibWriters.Writer;
END;
PROCEDURE WriteHeader(VAR w: Writer; VAR r: Files.Rider);
VAR
i: INTEGER;
BEGIN
Files.Write(r, 1FX); INC(w.start); (* ID1 *)
Files.Write(r, 8BX); INC(w.start); (* ID2 *)
Files.Write(r, CHR(DeflateMethod)); (* CM (Compression Method) *)
FOR i := 0 TO 6 DO Files.Write(r, 0X); INC(w.start) END;
END WriteHeader;
(** change deflate parameters within the writer **)
PROCEDURE SetParams*(VAR w: Writer; level, strategy: SHORTINT);
BEGIN
ZlibWriters.SetParams(w.zw, level, strategy, ZlibWriters.NoFlush);
w.res := w.zw.res;
END SetParams;
(** open writer on .gz-file **)
PROCEDURE Open*(VAR w: Writer; level, strategy: SHORTINT; file: Files.File);
VAR
r: Files.Rider;
BEGIN
w.start := 0;
IF file# NIL THEN
w.file := file; Files.Set(r, w.file, 0);
WriteHeader(w, r);
ZlibWriters.Open(w.zw, level, strategy, ZlibWriters.NoFlush, FALSE, r);
w.res := w.zw.res
ELSE
w.res := FileError
END
END Open;
(** write specified number of bytes from buffer into .gz-file and return number of bytes actually written **)
PROCEDURE WriteBytes*(VAR w: Writer; VAR buf: ARRAY OF CHAR; offset, len: LONGINT; VAR written: LONGINT);
BEGIN
ZlibWriters.WriteBytes(w.zw, buf, offset, len, written);
INC(w.pos, written);
w.res := w.zw.res
END WriteBytes;
(** write byte **)
PROCEDURE Write*(VAR w: Writer; ch: CHAR);
BEGIN
ZlibWriters.Write(w.zw, ch);
w.res := w.zw.res
END Write;
(** close writer **)
PROCEDURE Close*(VAR w: Writer);
VAR
r: Files.Rider;
BEGIN
ZlibWriters.Close(w.zw);
w.res := w.zw.res;
IF w.res = ZlibWriters.Ok THEN
Files.Close(w.file);
Files.Set(r, w.file, Files.Length(w.file));
Files.WriteLInt(r, w.zw.crc32); (* CRC32 *)
Files.WriteLInt(r, w.pos); (* ISIZE: Input Size *)
Files.Close(w.file)
END
END Close;
(** get position of reader within uncompressed output stream **)
PROCEDURE Pos* (VAR w: Writer): LONGINT;
VAR pos: LONGINT;
BEGIN
IF (w.file = NIL) THEN
w.res := StreamError; pos := 0
ELSIF w.res < Ok THEN
pos := 0
ELSE
pos := w.pos
END;
RETURN pos
END Pos;
END ethGZWriters.

295
src/library/s3/ethMD5.Mod Normal file
View file

@ -0,0 +1,295 @@
(* ETH Oberon, Copyright 2001 ETH Zuerich Institut fuer Computersysteme, ETH Zentrum, CH-8092 Zuerich.
Refer to the "General ETH Oberon System Source License" contract available at: http://www.oberon.ethz.ch/ *)
MODULE ethMD5; (** portable *) (* ejz *)
IMPORT SYSTEM;
(** The MD5 Message-Digest Algorithm (RFC1321)
The algorithm takes as input a message of arbitrary length and produces
as output a 128-bit "fingerprint" or "message digest" of the input. It is
conjectured that it is computationally infeasible to produce two messages
having the same message digest, or to produce any message having a
given prespecified target message digest. The MD5 algorithm is intended
for digital signature applications, where a large file must be "compressed"
in a secure manner before being encrypted with a private (secret) key
under a public-key cryptosystem such as RSA. *)
TYPE
Context* = POINTER TO ContextDesc;
ContextDesc = RECORD
buf: ARRAY 4 OF LONGINT;
bits: LONGINT;
in: ARRAY 64 OF CHAR
END;
Digest* = ARRAY 16 OF CHAR;
(** Begin an MD5 operation, with a new context. *)
PROCEDURE New*(): Context;
VAR cont: Context;
BEGIN
NEW(cont);
cont.buf[0] := 067452301H;
cont.buf[1] := 0EFCDAB89H;
cont.buf[2] := 098BADCFEH;
cont.buf[3] := 010325476H;
cont.bits := 0;
RETURN cont
END New;
PROCEDURE ByteReverse(VAR in: ARRAY OF SYSTEM.BYTE; VAR out: ARRAY OF LONGINT; longs: LONGINT);
VAR
adr, t, i: LONGINT;
bytes: ARRAY 4 OF CHAR;
BEGIN
adr := SYSTEM.ADR(in[0]); i := 0;
WHILE i < longs DO
SYSTEM.MOVE(adr, SYSTEM.ADR(bytes[0]), 4);
t := ORD(bytes[3]);
t := 256*t + ORD(bytes[2]);
t := 256*t + ORD(bytes[1]);
t := 256*t + ORD(bytes[0]);
out[i] := t;
INC(adr, 4); INC(i)
END
END ByteReverse;
PROCEDURE F1(x, y, z: LONGINT): LONGINT;
BEGIN
RETURN SYSTEM.VAL(LONGINT, (SYSTEM.VAL(SET, x)*SYSTEM.VAL(SET, y)) + ((-SYSTEM.VAL(SET, x))*SYSTEM.VAL(SET, z)))
END F1;
PROCEDURE F2(x, y, z: LONGINT): LONGINT;
BEGIN
RETURN SYSTEM.VAL(LONGINT, (SYSTEM.VAL(SET, x)*SYSTEM.VAL(SET, z)) + (SYSTEM.VAL(SET, y)*(-SYSTEM.VAL(SET, z))))
END F2;
PROCEDURE F3(x, y, z: LONGINT): LONGINT;
BEGIN
RETURN SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, x) / SYSTEM.VAL(SET, y) / SYSTEM.VAL(SET, z))
END F3;
PROCEDURE F4(x, y, z: LONGINT): LONGINT;
BEGIN
RETURN SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, y) / (SYSTEM.VAL(SET, x)+(-SYSTEM.VAL(SET, z))))
END F4;
PROCEDURE STEP1(VAR w: LONGINT; x, y, z, data, s: LONGINT);
BEGIN
w := w+F1(x, y, z)+data;
w := SYSTEM.ROT(w, s);
INC(w, x)
END STEP1;
PROCEDURE STEP2(VAR w: LONGINT; x, y, z, data, s: LONGINT);
BEGIN
w := w+F2(x, y, z)+data;
w := SYSTEM.ROT(w, s);
INC(w, x)
END STEP2;
PROCEDURE STEP3(VAR w: LONGINT; x, y, z, data, s: LONGINT);
BEGIN
w := w+F3(x, y, z)+data;
w := SYSTEM.ROT(w, s);
INC(w, x)
END STEP3;
PROCEDURE STEP4(VAR w: LONGINT; x, y, z, data, s: LONGINT);
BEGIN
w := w+F4(x, y, z)+data;
w := SYSTEM.ROT(w, s);
INC(w, x)
END STEP4;
PROCEDURE Transform(VAR buf, in: ARRAY OF LONGINT);
VAR a, b, c, d: LONGINT;
BEGIN
a := buf[0]; b := buf[1]; c := buf[2]; d := buf[3];
STEP1(a, b, c, d, in[0]+0D76AA478H, 7);
STEP1(d, a, b, c, in[1]+0E8C7B756H, 12);
STEP1(c, d, a, b, in[2]+0242070DBH, 17);
STEP1(b, c, d, a, in[3]+0C1BDCEEEH, 22);
STEP1(a, b, c, d, in[4]+0F57C0FAFH, 7);
STEP1(d, a, b, c, in[5]+04787C62AH, 12);
STEP1(c, d, a, b, in[6]+0A8304613H, 17);
STEP1(b, c, d, a, in[7]+0FD469501H, 22);
STEP1(a, b, c, d, in[8]+0698098D8H, 7);
STEP1(d, a, b, c, in[9]+08B44F7AFH, 12);
STEP1(c, d, a, b, in[10]+0FFFF5BB1H, 17);
STEP1(b, c, d, a, in[11]+0895CD7BEH, 22);
STEP1(a, b, c, d, in[12]+06B901122H, 7);
STEP1(d, a, b, c, in[13]+0FD987193H, 12);
STEP1(c, d, a, b, in[14]+0A679438EH, 17);
STEP1(b, c, d, a, in[15]+049B40821H, 22);
STEP2(a, b, c, d, in[1]+0F61E2562H, 5);
STEP2(d, a, b, c, in[6]+0C040B340H, 9);
STEP2(c, d, a, b, in[11]+0265E5A51H, 14);
STEP2(b, c, d, a, in[0]+0E9B6C7AAH, 20);
STEP2(a, b, c, d, in[5]+0D62F105DH, 5);
STEP2(d, a, b, c, in[10]+02441453H, 9);
STEP2(c, d, a, b, in[15]+0D8A1E681H, 14);
STEP2(b, c, d, a, in[4]+0E7D3FBC8H, 20);
STEP2(a, b, c, d, in[9]+021E1CDE6H, 5);
STEP2(d, a, b, c, in[14]+0C33707D6H, 9);
STEP2(c, d, a, b, in[3]+0F4D50D87H, 14);
STEP2(b, c, d, a, in[8]+0455A14EDH, 20);
STEP2(a, b, c, d, in[13]+0A9E3E905H, 5);
STEP2(d, a, b, c, in[2]+0FCEFA3F8H, 9);
STEP2(c, d, a, b, in[7]+0676F02D9H, 14);
STEP2(b, c, d, a, in[12]+08D2A4C8AH, 20);
STEP3(a, b, c, d, in[5]+0FFFA3942H, 4);
STEP3(d, a, b, c, in[8]+08771F681H, 11);
STEP3(c, d, a, b, in[11]+06D9D6122H, 16);
STEP3(b, c, d, a, in[14]+0FDE5380CH, 23);
STEP3(a, b, c, d, in[1]+0A4BEEA44H, 4);
STEP3(d, a, b, c, in[4]+04BDECFA9H, 11);
STEP3(c, d, a, b, in[7]+0F6BB4B60H, 16);
STEP3(b, c, d, a, in[10]+0BEBFBC70H, 23);
STEP3(a, b, c, d, in[13]+0289B7EC6H, 4);
STEP3(d, a, b, c, in[0]+0EAA127FAH, 11);
STEP3(c, d, a, b, in[3]+0D4EF3085H, 16);
STEP3(b, c, d, a, in[6]+04881D05H, 23);
STEP3(a, b, c, d, in[9]+0D9D4D039H, 4);
STEP3(d, a, b, c, in[12]+0E6DB99E5H, 11);
STEP3(c, d, a, b, in[15]+01FA27CF8H, 16);
STEP3(b, c, d, a, in[2]+0C4AC5665H, 23);
STEP4(a, b, c, d, in[0]+0F4292244H, 6);
STEP4(d, a, b, c, in[7]+0432AFF97H, 10);
STEP4(c, d, a, b, in[14]+0AB9423A7H, 15);
STEP4(b, c, d, a, in[5]+0FC93A039H, 21);
STEP4(a, b, c, d, in[12]+0655B59C3H, 6);
STEP4(d, a, b, c, in[3]+08F0CCC92H, 10);
STEP4(c, d, a, b, in[10]+0FFEFF47DH, 15);
STEP4(b, c, d, a, in[1]+085845DD1H, 21);
STEP4(a, b, c, d, in[8]+06FA87E4FH, 6);
STEP4(d, a, b, c, in[15]+0FE2CE6E0H, 10);
STEP4(c, d, a, b, in[6]+0A3014314H, 15);
STEP4(b, c, d, a, in[13]+04E0811A1H, 21);
STEP4(a, b, c, d, in[4]+0F7537E82H, 6);
STEP4(d, a, b, c, in[11]+ 0BD3AF235H, 10);
STEP4(c, d, a, b, in[2]+02AD7D2BBH, 15);
STEP4(b, c, d, a, in[9]+0EB86D391H, 21);
INC(buf[0], a); INC(buf[1], b);
INC(buf[2], c); INC(buf[3], d)
END Transform;
(** Continues an MD5 message-digest operation, processing another
message block, and updating the context. *)
PROCEDURE Write*(context: Context; ch: CHAR);
VAR
in: ARRAY 16 OF LONGINT;
t, len: LONGINT;
BEGIN
t := context.bits; len := 1;
context.bits := t + 8;
t := (t DIV 8) MOD 64;
IF t > 0 THEN
t := 64-t;
IF 1 < t THEN
context.in[64-t] := ch;
RETURN
END;
ASSERT(len = 1);
context.in[64-t] := ch;
ByteReverse(context.in, in, 16);
Transform(context.buf, in);
DEC(len, t)
END;
IF len > 0 THEN
context.in[0] := ch
END
END Write;
(** Continues an MD5 message-digest operation, processing another
message block, and updating the context. *)
PROCEDURE WriteBytes*(context: Context; VAR buf: ARRAY OF CHAR; len: LONGINT);
VAR
in: ARRAY 16 OF LONGINT;
beg, t: LONGINT;
BEGIN
beg := 0; t := context.bits;
context.bits := t + len*8;
t := (t DIV 8) MOD 64;
IF t > 0 THEN
t := 64-t;
IF len < t THEN
SYSTEM.MOVE(SYSTEM.ADR(buf[beg]), SYSTEM.ADR(context.in[64-t]), len);
RETURN
END;
SYSTEM.MOVE(SYSTEM.ADR(buf[beg]), SYSTEM.ADR(context.in[64-t]), t);
ByteReverse(context.in, in, 16);
Transform(context.buf, in);
INC(beg, t); DEC(len, t)
END;
WHILE len >= 64 DO
SYSTEM.MOVE(SYSTEM.ADR(buf[beg]), SYSTEM.ADR(context.in[0]), 64);
ByteReverse(context.in, in, 16);
Transform(context.buf, in);
INC(beg, 64); DEC(len, 64)
END;
IF len > 0 THEN
SYSTEM.MOVE(SYSTEM.ADR(buf[beg]), SYSTEM.ADR(context.in[0]), len)
END
END WriteBytes;
(** Ends an MD5 message-digest operation, writing the message digest. *)
PROCEDURE Close*(context: Context; VAR digest: Digest);
VAR
in: ARRAY 16 OF LONGINT;
beg, i, count: LONGINT;
BEGIN
count := (context.bits DIV 8) MOD 64;
beg := count;
context.in[beg] := CHR(128); INC(beg);
count := 64-1-count;
IF count < 8 THEN
i := 0;
WHILE i < count DO
context.in[beg+i] := 0X; INC(i)
END;
ByteReverse(context.in, in, 16);
Transform(context.buf, in);
i := 0;
WHILE i < 56 DO
context.in[i] := 0X; INC(i)
END
ELSE
i := 0;
WHILE i < (count-8) DO
context.in[beg+i] := 0X; INC(i)
END
END;
ByteReverse(context.in, in, 14);
in[14] := context.bits; in[15] := 0;
Transform(context.buf, in);
ByteReverse(context.buf, in, 4);
SYSTEM.MOVE(SYSTEM.ADR(in[0]), SYSTEM.ADR(digest[0]), 16)
END Close;
PROCEDURE HexDigit(i: LONGINT): CHAR;
BEGIN
IF i < 10 THEN
RETURN CHR(ORD("0")+i)
ELSE
RETURN CHR(ORD("a")+i-10)
END
END HexDigit;
(** Convert the digest into an hexadecimal string. *)
PROCEDURE ToString*(digest: Digest; VAR str: ARRAY OF CHAR);
VAR i: LONGINT;
BEGIN
FOR i := 0 TO 15 DO
str[2*i] := HexDigit(ORD(digest[i]) DIV 16);
str[2*i+1] := HexDigit(ORD(digest[i]) MOD 16)
END;
str[32] := 0X
END ToString;
END ethMD5.

40
src/library/s3/ethRandomNumbers.Mod Normal file
View file

@ -0,0 +1,40 @@
(* ETH Oberon, Copyright 2001 ETH Zuerich Institut fuer Computersysteme, ETH Zentrum, CH-8092 Zuerich.
Refer to the "General ETH Oberon System Source License" contract available at: http://www.oberon.ethz.ch/ *)
MODULE ethRandomNumbers; (** portable *)
(* Random Number Generator, page 12 *)
IMPORT Math := oocOakMath, Oberon := Kernel, SYSTEM;
VAR Z, t, d: LONGINT;
(** Return a uniform random number r, with 0 < r < 1. *)
PROCEDURE Uniform*(): REAL;
CONST
a = 16807; m = 2147483647;
q = m DIV a; r = m MOD a;
VAR g: LONGINT;
BEGIN
g := a*(Z MOD q) - r*(Z DIV q);
IF g > 0 THEN Z := g ELSE Z := g + m END;
RETURN SHORT(Z*1.0D0/m) (* must compute this in double precision, e.g. (m-1)/m *)
END Uniform;
(** Return an exponentially distributed random number r. *)
PROCEDURE Exp*(mu: REAL): REAL;
BEGIN
RETURN -Math.ln(Uniform())/mu
END Exp;
(** Initialize the random number seed. *)
PROCEDURE InitSeed*(seed: LONGINT);
BEGIN
Z := seed
END InitSeed;
BEGIN
Oberon.GetClock(t, d);
Z := SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, t) / SYSTEM.VAL(SET, d))
END ethRandomNumbers. (* Copyright M. Reiser, 1992 *)

305
src/library/s3/ethReals.Mod Normal file
View file

@ -0,0 +1,305 @@
(* ETH Oberon, Copyright 2001 ETH Zuerich Institut fuer Computersysteme, ETH Zentrum, CH-8092 Zuerich.
Refer to the "General ETH Oberon System Source License" contract available at: http://www.oberon.ethz.ch/ *)
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,
Swiss Federal Institute of Technology Z…rich.
*)
IMPORT SYSTEM;
(* Bernd Moesli
Seminar for Applied Mathematics
Swiss Federal Institute of Technology Zurich
Copyright 1993
Support module for IEEE floating-point numbers
Please change constant definitions of H, L depending on byte ordering
Use bm.TestReals.Do for testing the implementation.
Expo, ExpoL return the shifted binary exponent (0 <= e < 256 (2048 resp.))
SetExpo, SetExpoL set the shifted binary exponent
Real, RealL convert hexadecimals to reals
Int, IntL convert reals to hexadecimals
Ten returns 10^e (e <= 308, 308 < e delivers NaN)
1993.4.22 IEEE format only, 32-bits LONGINTs only
30.8.1993 mh: changed RealX to avoid compiler warnings;
7.11.1995 jt: dynamic endianess test
22.01.97 pjm: NaN stuff (using quiet NaNs only to avoid traps)
05.01.98 prk: NaN with INF support
*)
VAR
DefaultFCR*: SET;
tene: ARRAY 23 OF LONGREAL; (* e = 0..22: exact values of 10^e *)
ten: ARRAY 27 OF LONGREAL;
eq, gr: ARRAY 20 OF SET;
H, L: INTEGER;
(** Returns the shifted binary exponent (0 <= e < 256). *)
PROCEDURE Expo* (x: REAL): LONGINT;
BEGIN
RETURN ASH(SYSTEM.VAL(LONGINT, x), -23) MOD 256
END Expo;
(** Returns the shifted binary exponent (0 <= e < 2048). *)
PROCEDURE ExpoL* (x: LONGREAL): LONGINT;
VAR i: LONGINT;
BEGIN
SYSTEM.GET(SYSTEM.ADR(x) + H, i); RETURN ASH(i, -20) MOD 2048
END ExpoL;
(** Sets the shifted binary exponent. *)
PROCEDURE SetExpo* (e: LONGINT; VAR x: REAL);
VAR i: LONGINT;
BEGIN
SYSTEM.GET(SYSTEM.ADR(x), i);
i:= ASH(ASH(ASH(i, -31), 8) + e MOD 256, 23) + i MOD ASH(1, 23);
SYSTEM.PUT(SYSTEM.ADR(x), i)
END SetExpo;
(** Sets the shifted binary exponent. *)
PROCEDURE SetExpoL* (e: LONGINT; VAR x: LONGREAL);
VAR i: LONGINT;
BEGIN
SYSTEM.GET(SYSTEM.ADR(x) + H, i);
i:= ASH(ASH(ASH(i, -31), 11) + e MOD 2048, 20) + i MOD ASH(1, 20);
SYSTEM.PUT(SYSTEM.ADR(x) + H, i)
END SetExpoL;
(** Convert hexadecimal to REAL. *)
PROCEDURE Real* (h: LONGINT): REAL;
VAR x: REAL;
BEGIN SYSTEM.PUT(SYSTEM.ADR(x), h); RETURN x
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 SYSTEM.PUT(SYSTEM.ADR(x) + H, h); SYSTEM.PUT(SYSTEM.ADR(x) + L, l); RETURN x
END RealL;
(** Convert REAL to hexadecimal. *)
PROCEDURE Int* (x: REAL): LONGINT;
VAR i: LONGINT;
BEGIN SYSTEM.PUT(SYSTEM.ADR(i), x); RETURN i
END Int;
(** Convert LONGREAL to hexadecimal. h and l are the high and low parts. *)
PROCEDURE IntL* (x: LONGREAL; VAR h, l: LONGINT);
BEGIN SYSTEM.GET(SYSTEM.ADR(x) + H, h); SYSTEM.GET(SYSTEM.ADR(x) + L, l)
END IntL;
(** Returns 10^e (e <= 308, 308 < e delivers IEEE-code +INF). *)
PROCEDURE Ten* (e: LONGINT): LONGREAL;
VAR E: LONGINT; r: LONGREAL;
BEGIN
IF e < -307 THEN RETURN 0 ELSIF 308 < e THEN RETURN RealL(2146435072, 0) END;
INC(e, 307); r:= ten[e DIV 23] * tene[e MOD 23];
IF e MOD 32 IN eq[e DIV 32] THEN RETURN r
ELSE
E:= ExpoL(r); SetExpoL(1023+52, r);
IF e MOD 32 IN gr[e DIV 32] THEN r:= r-1 ELSE r:= r+1 END;
SetExpoL(E, r); RETURN r
END
END Ten;
(** Returns the NaN code (0 <= c < 8399608) or -1 if not NaN/Infinite. *)
PROCEDURE NaNCode* (x: REAL): LONGINT;
BEGIN
IF ASH(SYSTEM.VAL(LONGINT, x), -23) MOD 256 = 255 THEN (* Infinite or NaN *)
RETURN SYSTEM.VAL(LONGINT, x) MOD 800000H (* lowest 23 bits *)
ELSE
RETURN -1
END
END NaNCode;
(** Returns the NaN code (0 <= h < 1048576, MIN(LONGINT) <= l <= MAX(LONGINT)) or (-1,-1) if not NaN/Infinite. *)
PROCEDURE NaNCodeL* (x: LONGREAL; VAR h, l: LONGINT);
BEGIN
SYSTEM.GET(SYSTEM.ADR(x) + H, h); SYSTEM.GET(SYSTEM.ADR(x) + L, l);
IF ASH(h, -20) MOD 2048 = 2047 THEN (* Infinite or NaN *)
h := h MOD 100000H (* lowest 20 bits *)
ELSE
h := -1; l := -1
END
END NaNCodeL;
(** Returns TRUE iff x is NaN/Infinite. *)
PROCEDURE IsNaN* (x: REAL): BOOLEAN;
BEGIN
RETURN ASH(SYSTEM.VAL(LONGINT, x), -23) MOD 256 = 255
END IsNaN;
(** Returns TRUE iff x is NaN/Infinite. *)
PROCEDURE IsNaNL* (x: LONGREAL): BOOLEAN;
VAR h: LONGINT;
BEGIN
SYSTEM.GET(SYSTEM.ADR(x) + H, h);
RETURN ASH(h, -20) MOD 2048 = 2047
END IsNaNL;
(** Returns NaN with specified code (0 <= l < 8399608). *)
PROCEDURE NaN* (l: LONGINT): REAL;
VAR x: REAL;
BEGIN
SYSTEM.PUT(SYSTEM.ADR(x), (l MOD 800000H) + 7F800000H);
RETURN x
END NaN;
(** Returns NaN with specified code (0 <= h < 1048576, MIN(LONGINT) <= l <= MAX(LONGINT)). *)
PROCEDURE NaNL* (h, l: LONGINT): LONGREAL;
VAR x: LONGREAL;
BEGIN
h := (h MOD 100000H) + 7FF00000H;
SYSTEM.PUT(SYSTEM.ADR(x) + H, h);
SYSTEM.PUT(SYSTEM.ADR(x) + L, l);
RETURN x
END NaNL;
(*
PROCEDURE fcr(): SET;
CODE {SYSTEM.i386, SYSTEM.FPU}
PUSH 0
FSTCW [ESP]
FWAIT
POP EAX
END fcr;
*) (* commented out -- noch *)
(** Return state of the floating-point control register. *)
(*PROCEDURE FCR*(): SET;
BEGIN
IF Kernel.copro THEN
RETURN fcr()
ELSE
RETURN DefaultFCR
END
END FCR;
*)
(*PROCEDURE setfcr(s: SET);
CODE {SYSTEM.i386, SYSTEM.FPU}
FLDCW s[EBP]
END setfcr;
*)
(** Set state of floating-point control register. Traps reset this to the default & ENTIER resets the rounding mode. *)
(*PROCEDURE SetFCR*(s: SET);
BEGIN
IF Kernel.copro THEN setfcr(s) END
END SetFCR;
*)
PROCEDURE RealX (h, l: LONGINT; adr: LONGINT);
BEGIN SYSTEM.PUT(adr + H, h); SYSTEM.PUT(adr + L, l);
END RealX;
PROCEDURE InitHL;
VAR (*i: LONGINT; dmy: INTEGER;*) littleEndian: BOOLEAN;
BEGIN
(*DefaultFCR := (FCR() - {0,2,3,10,11}) + {0..5,8,9};
SetFCR(DefaultFCR);
dmy := 1; i := SYSTEM.ADR(dmy);
SYSTEM.GET(i, littleEndian); (* indirection via i avoids warning on SUN cc -O *)*)
littleEndian := TRUE; (* endianness will be set for each architecture -- noch *)
IF littleEndian THEN H := 4; L := 0 ELSE H := 0; L := 4 END
END InitHL;
BEGIN InitHL;
RealX(03FF00000H, 0, SYSTEM.ADR(tene[0]));
RealX(040240000H, 0, SYSTEM.ADR(tene[1])); (* 1 *)
RealX(040590000H, 0, SYSTEM.ADR(tene[2])); (* 2 *)
RealX(0408F4000H, 0, SYSTEM.ADR(tene[3])); (* 3 *)
RealX(040C38800H, 0, SYSTEM.ADR(tene[4])); (* 4 *)
RealX(040F86A00H, 0, SYSTEM.ADR(tene[5])); (* 5 *)
RealX(0412E8480H, 0, SYSTEM.ADR(tene[6])); (* 6 *)
RealX(0416312D0H, 0, SYSTEM.ADR(tene[7])); (* 7 *)
RealX(04197D784H, 0, SYSTEM.ADR(tene[8])); (* 8 *)
RealX(041CDCD65H, 0, 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, 064DD592H, SYSTEM.ADR(tene[22])); (* 22 *)
RealX(031FA18H, 02C40C60DH, SYSTEM.ADR(ten[0])); (* -307 *)
RealX(04F7CAD2H, 03DE82D7BH, SYSTEM.ADR(ten[1])); (* -284 *)
RealX(09BF7D22H, 08322BAF5H, SYSTEM.ADR(ten[2])); (* -261 *)
RealX(0E84D669H, 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, 0EC190DCH, SYSTEM.ADR(ten[10])); (* -77 *)
RealX(034B8851AH, 0B548EA4H, 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, 055B2D9EH, 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 *)
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};
eq[2]:= {0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28};
eq[3]:= {0, 1, 2, 3, 5, 6, 7, 8, 9, 11, 14, 15, 16, 17, 18, 19, 20, 22, 27, 28, 29, 30, 31};
eq[4]:= {0, 6, 7, 10, 11, 12, 13, 14, 15, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31};
eq[5]:= {0, 1, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31};
eq[6]:= {0, 1, 4, 5, 7, 8, 10, 14, 15, 16, 18, 20, 21, 23, 24, 25, 26, 28, 29, 30, 31};
eq[7]:= {0, 1, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 16, 17, 18, 19, 23, 24, 26, 28, 29, 30, 31};
eq[8]:= {0, 1, 2, 3, 4, 5, 6, 8, 9, 10, 11, 14, 16, 17, 18, 19, 20, 21, 24, 25, 26, 29};
eq[9]:= {1, 2, 4, 6, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31};
eq[10]:= {0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30};
eq[11]:= {0, 1, 2, 3, 4, 5, 6, 7, 8, 10, 12, 13, 14, 15, 16, 19, 20, 21, 22, 23, 27, 28, 29, 30};
eq[12]:= {0, 1, 2, 3, 4, 5, 7, 8, 9, 10, 12, 14, 15, 16, 17, 18, 19, 20, 21, 23, 26, 27, 29, 30, 31};
eq[13]:= {0, 1, 2, 3, 4, 5, 6, 7, 9, 10, 11, 13, 14, 15, 16, 17, 18, 20, 21, 23, 24, 27, 28, 29, 30, 31};
eq[14]:= {0, 1, 2, 3, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31};
eq[15]:= {0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 11, 12, 13, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 28};
eq[16]:= {1, 2, 4, 11, 13, 16, 17, 18, 19, 22, 24, 25, 26, 27, 28, 29, 30, 31};
eq[17]:= {1, 2, 3, 4, 5, 6, 7, 8, 9, 11, 14, 15, 18, 19, 20, 21, 23, 25, 26, 27, 28, 29, 31};
eq[18]:= {0, 2, 4, 5, 6, 8, 9, 11, 12, 13, 14, 16, 17, 19, 20, 22, 23, 24, 26, 27, 28, 29};
eq[19]:= {2, 3, 4, 5, 6, 7};
gr[0]:= {24, 27, 29, 30};
gr[1]:= {0, 1, 3, 4, 7};
gr[2]:= {29, 30, 31};
gr[3]:= {4, 10, 12, 13, 21, 23, 24, 25, 26};
gr[4]:= {1, 2, 3, 4, 5, 8, 9, 16, 17};
gr[5]:= {2, 3, 4, 18};
gr[6]:= {2, 3, 6, 9, 11, 12, 13, 17, 19, 22, 27};
gr[7]:= {2};
gr[8]:= {7, 12, 13, 15, 22, 23, 27, 28, 30, 31};
gr[9]:= {0, 3, 5, 7, 8};
gr[10]:= {};
gr[11]:= {};
gr[12]:= {11, 13, 22, 24, 25, 28};
gr[13]:= {22, 25, 26};
gr[14]:= {4, 5};
gr[15]:= {10, 14, 27, 29, 30, 31};
gr[16]:= {0, 3, 5, 6, 7, 8, 9, 10, 12, 14, 15, 20, 21, 23};
gr[17]:= {0, 10, 12, 13, 16, 17, 22, 24, 30};
gr[18]:= {};
gr[19]:= {}
END ethReals.

141
src/library/s3/ethSets.Mod Normal file
View file

@ -0,0 +1,141 @@
(* ETH Oberon, Copyright 2001 ETH Zuerich Institut fuer Computersysteme, ETH Zentrum, CH-8092 Zuerich.
Refer to the "General ETH Oberon System Source License" contract available at: http://www.oberon.ethz.ch/ *)
MODULE ethSets; (** portable *)
IMPORT Texts;
CONST size* = SIZE(LONGINT)* 8(*32*);
PROCEDURE Clear*(VAR s: ARRAY OF SET);
VAR i: INTEGER;
BEGIN
i := 0; WHILE i < LEN(s) DO s[i] := {}; INC(i) END
END Clear;
PROCEDURE Fill*(VAR s: ARRAY OF SET);
VAR i: INTEGER;
BEGIN
i := 0; WHILE i < LEN(s) DO s[i] := {0 .. size-1}; INC(i) END
END Fill;
PROCEDURE Incl*(VAR s: ARRAY OF SET; x: INTEGER);
BEGIN INCL(s[x DIV size], x MOD size)
END Incl;
PROCEDURE Excl*(VAR s: ARRAY OF SET; x: INTEGER);
BEGIN EXCL(s[x DIV size], x MOD size)
END Excl;
PROCEDURE In*(VAR s: ARRAY OF SET; x: INTEGER): BOOLEAN;
BEGIN RETURN x MOD size IN s[x DIV size]
END In;
PROCEDURE Includes*(VAR s1, s2: ARRAY OF SET): BOOLEAN;
VAR i: INTEGER;
BEGIN
i := 0;
WHILE i < LEN(s1) DO
IF s1[i] + s2[i] # s1[i] THEN RETURN FALSE END ;
INC(i)
END ;
RETURN TRUE;
END Includes;
PROCEDURE Elements*(VAR s: ARRAY OF SET; VAR lastElem: INTEGER): INTEGER;
VAR i, n, max: INTEGER;
BEGIN
i := 0; n := 0; max := SHORT(LEN(s)) * size;
WHILE i < max DO
IF (i MOD size) IN s[i DIV size] THEN INC(n); lastElem := i END ;
INC(i)
END ;
RETURN n
END Elements;
PROCEDURE Empty*(VAR s: ARRAY OF SET): BOOLEAN;
VAR i: INTEGER;
BEGIN
i := 0;
WHILE i < LEN(s) DO
IF s[i] # {} THEN RETURN FALSE END ;
INC(i)
END ;
RETURN TRUE
END Empty;
PROCEDURE Equal*(VAR s1, s2: ARRAY OF SET): BOOLEAN;
VAR i: INTEGER;
BEGIN
i := 0;
WHILE i < LEN(s1) DO
IF s1[i] # s2[i] THEN RETURN FALSE END ;
INC(i)
END ;
RETURN TRUE
END Equal;
PROCEDURE Different*(VAR s1, s2: ARRAY OF SET): BOOLEAN;
VAR i: INTEGER;
BEGIN
i := 0;
WHILE i < LEN(s1) DO
IF s1[i] * s2[i] # {} THEN RETURN FALSE END ;
INC(i)
END ;
RETURN TRUE
END Different;
PROCEDURE Unite*(VAR s1, s2: ARRAY OF SET);
VAR i: INTEGER; s: SET;
BEGIN
i := 0; WHILE i < LEN(s1) DO s := s1[i] + s2[i]; s1[i] := s; INC(i) END
END Unite;
PROCEDURE Differ*(VAR s1, s2: ARRAY OF SET);
VAR i: INTEGER; s: SET;
BEGIN
i := 0; WHILE i < LEN(s1) DO s := s1[i] - s2[i]; s1[i] := s; INC(i) END
END Differ;
PROCEDURE Intersect*(VAR s1, s2, s3: ARRAY OF SET);
VAR i: INTEGER; s: SET;
BEGIN
i := 0; WHILE i < LEN(s1) DO s := s1[i] * s2[i]; s3[i] := s; INC(i) END
END Intersect;
PROCEDURE Print*(VAR f: Texts.Writer; s: ARRAY OF SET; w, indent: INTEGER);
VAR col, i, max: INTEGER;
BEGIN
i := 0; col := indent; max := SHORT(LEN(s)) * size;
Texts.Write(f, "{");
WHILE i < max DO
IF In(s, i) THEN
IF col + 4 > w THEN
Texts.WriteLn(f);
col := 0; WHILE col < indent DO Texts.Write(f, " "); INC(col) END
END ;
Texts.WriteInt(f, i, 3); Texts.Write(f, ",");
INC(col, 4)
END ;
INC(i)
END ;
Texts.Write(f, "}")
END Print;
END ethSets.

956
src/library/s3/ethStrings.Mod Normal file
View file

@ -0,0 +1,956 @@
(* ETH Oberon, Copyright 2001 ETH Zuerich Institut fuer Computersysteme, ETH Zentrum, CH-8092 Zuerich.
Refer to the "General ETH Oberon System Source License" contract available at: http://www.oberon.ethz.ch/ *)
MODULE ethStrings; (** portable *) (* ejz, *)
(** Strings is a utility module that provides procedures to manipulate strings.
Note: All strings MUST be 0X terminated. *)
IMPORT Oberon, Texts, Dates := ethDates, Reals := ethReals;
CONST
CR* = 0DX; (** the Oberon end of line character *)
Tab* = 09X; (** the horizontal tab character *)
LF* = 0AX; (** the UNIX end of line character *)
VAR
isAlpha*: ARRAY 256 OF BOOLEAN; (** all letters in the oberon charset *)
ISOToOberon*, OberonToISO*: ARRAY 256 OF CHAR; (** Translation tables for iso-8859-1 to oberon ascii code. *)
CRLF*: ARRAY 4 OF CHAR; (** end of line "string" used by MS-DOS and most TCP protocols *)
sDayName: ARRAY 7, 4 OF CHAR;
lDayName: ARRAY 7, 12 OF CHAR;
sMonthName: ARRAY 12, 4 OF CHAR;
lMonthName: ARRAY 12, 12 OF CHAR;
dateform, timeform: ARRAY 32 OF CHAR;
(** Length of str. *)
PROCEDURE Length*(VAR str(** in *): ARRAY OF CHAR): LONGINT;
VAR i, l: LONGINT;
BEGIN
l := LEN(str); i := 0;
WHILE (i < l) & (str[i] # 0X) DO
INC(i)
END;
RETURN i
END Length;
(** Append this to to. *)
PROCEDURE Append*(VAR to(** in/out *): ARRAY OF CHAR; this: ARRAY OF CHAR);
VAR i, j, l: LONGINT;
BEGIN
i := 0;
WHILE to[i] # 0X DO
INC(i)
END;
l := LEN(to)-1; j := 0;
WHILE (i < l) & (this[j] # 0X) DO
to[i] := this[j]; INC(i); INC(j)
END;
to[i] := 0X
END Append;
(** Append this to to. *)
PROCEDURE AppendCh*(VAR to(** in/out *): ARRAY OF CHAR; this: CHAR);
VAR i: LONGINT;
BEGIN
i := 0;
WHILE to[i] # 0X DO
INC(i)
END;
IF i < (LEN(to)-1) THEN
to[i] := this; to[i+1] := 0X
END
END AppendCh;
(** TRUE if ch is a hexadecimal digit. *)
PROCEDURE IsHexDigit*(ch: CHAR): BOOLEAN;
BEGIN
RETURN ((ch >= "0") & (ch <= "9")) OR ((CAP(ch) >= "A") & (CAP(ch) <= "F"))
END IsHexDigit;
(** TRUE if ch is a decimal digit. *)
PROCEDURE IsDigit*(ch: CHAR): BOOLEAN;
BEGIN
RETURN (ch >= "0") & (ch <= "9")
END IsDigit;
(** TRUE if ch is a letter. *)
PROCEDURE IsAlpha*(ch: CHAR): BOOLEAN;
BEGIN
RETURN isAlpha[ORD(ch)]
END IsAlpha;
(** If ch is an upper-case letter return the corresponding lower-case letter. *)
PROCEDURE LowerCh*(ch: CHAR): CHAR;
BEGIN
CASE ch OF
"A" .. "Z": ch := CHR(ORD(ch)-ORD("A")+ORD("a"))
|"€": ch := "ƒ"
|"<22>": ch := "„"
|"‚": ch := "…"
ELSE
END;
RETURN ch
END LowerCh;
(** If ch is an lower-case letter return the corresponding upper-case letter. *)
PROCEDURE UpperCh*(ch: CHAR): CHAR;
BEGIN
CASE ch OF
"a" .. "z": ch := CAP(ch)
|"ƒ": ch := "€"
|"„": ch := "<22>"
|"…": ch := "‚"
|"†": ch := "A"
|"‡": ch := "E"
|"ˆ": ch := "I"
|"‰": ch := "O"
|"Š": ch := "U"
|"‹": ch := "A"
|"Œ": ch := "E"
|"<22>": ch := "I"
|"Ž": ch := "O"
|"<22>": ch := "U"
|"<22>": ch := "E"
|"‘": ch := "E"
|"’": ch := "I"
|"“": ch := "C"
|"”": ch := "A"
|"•": ch := "N"
|"–": ch := "S"
ELSE
END;
RETURN ch
END UpperCh;
(** Convert str to all lower-case letters. *)
PROCEDURE Lower*(VAR str(** in *), lstr(** out *): ARRAY OF CHAR);
VAR i: LONGINT;
BEGIN
i := 0;
WHILE str[i] # 0X DO
lstr[i] := LowerCh(str[i]); INC(i)
END;
lstr[i] := 0X
END Lower;
(** Convert str to all upper-case letters. *)
PROCEDURE Upper*(VAR str(** in *), ustr(** out *): ARRAY OF CHAR);
VAR i: LONGINT;
BEGIN
i := 0;
WHILE str[i] # 0X DO
ustr[i] := UpperCh(str[i]); INC(i)
END;
ustr[i] := 0X
END Upper;
(** Is str prefixed by pre? *)
PROCEDURE Prefix*(pre: ARRAY OF CHAR; VAR str(** in *): ARRAY OF CHAR): BOOLEAN;
VAR i: LONGINT;
BEGIN
i := 0;
WHILE (pre[i] # 0X) & (pre[i] = str[i]) DO
INC(i)
END;
RETURN pre[i] = 0X
END Prefix;
(** Checks if str is prefixed by pre. The case is ignored. *)
PROCEDURE CAPPrefix*(pre: ARRAY OF CHAR; VAR str(** in *): ARRAY OF CHAR): BOOLEAN;
VAR i: LONGINT;
BEGIN
i := 0;
WHILE (pre[i] # 0X) & (CAP(pre[i]) = CAP(str[i])) DO
INC(i)
END;
RETURN pre[i] = 0X
END CAPPrefix;
(** Compare str1 to str2. The case is ignored. *)
PROCEDURE CAPCompare*(VAR str1(** in *), str2(** in *): ARRAY OF CHAR): BOOLEAN;
VAR i: LONGINT;
BEGIN
i := 0;
WHILE (str1[i] # 0X) & (str2[i] # 0X) & (CAP(str1[i]) = CAP(str2[i])) DO
INC(i)
END;
RETURN str1[i] = str2[i]
END CAPCompare;
(** Get the parameter-value on line. The parameter value is started behind the first colon character. *)
PROCEDURE GetPar*(VAR line(** in *), par(** out *): ARRAY OF CHAR);
VAR i, j, l: LONGINT;
BEGIN
i := 0;
WHILE (line[i] # 0X) & (line[i] # ":") DO
INC(i)
END;
IF line[i] = ":" THEN
INC(i)
END;
WHILE (line[i] # 0X) & (line[i] <= " ") DO
INC(i)
END;
l := LEN(par)-1; j := 0;
WHILE (j < l) & (line[i] # 0X) DO
par[j] := line[i]; INC(j); INC(i)
END;
par[j] := 0X
END GetPar;
(** Get the suffix of str. The suffix is started by the last dot in str. *)
PROCEDURE GetSuffix*(VAR str(** in *), suf(** out *): ARRAY OF CHAR);
VAR i, j, l, dot: LONGINT;
BEGIN
dot := -1; i := 0;
WHILE str[i] # 0X DO
IF str[i] = "." THEN
dot := i
ELSIF str[i] = "/" THEN
dot := -1
END;
INC(i)
END;
j := 0;
IF dot > 0 THEN
l := LEN(suf)-1; i := dot+1;
WHILE (j < l) & (str[i] # 0X) DO
suf[j] := str[i]; INC(j); INC(i)
END
END;
suf[j] := 0X
END GetSuffix;
(** Change the suffix of str to suf. *)
PROCEDURE ChangeSuffix*(VAR str(** in/out *): ARRAY OF CHAR; suf: ARRAY OF CHAR);
VAR i, j, l, dot: LONGINT;
BEGIN
dot := -1; i := 0;
WHILE str[i] # 0X DO
IF str[i] = "." THEN
dot := i
ELSIF str[i] = "/" THEN
dot := -1
END;
INC(i)
END;
IF dot > 0 THEN
l := LEN(str)-1; i := dot+1; j := 0;
WHILE (i < l) & (suf[j] # 0X) DO
str[i] := suf[j]; INC(i); INC(j)
END;
str[i] := 0X
END
END ChangeSuffix;
(** Search in src starting at pos for the next occurrence of pat. Returns pos=-1 if not found. *)
PROCEDURE Search*(pat: ARRAY OF CHAR; VAR src(** in *): ARRAY OF CHAR; VAR pos(** in/out *): LONGINT);
CONST MaxPat = 128;
VAR
buf: ARRAY MaxPat OF CHAR;
len, i, srclen: LONGINT;
PROCEDURE Find(beg: LONGINT);
VAR
i, j, b, e: LONGINT;
ch: CHAR;
ref: ARRAY MaxPat OF CHAR;
BEGIN
ch := src[pos]; INC(pos);
ref[0] := ch;
i := 0; j := 0; b := 0; e := 1;
WHILE (pos <= srclen) & (i < len) DO
IF buf[i] = ch THEN
INC(i); j := (j + 1) MOD MaxPat
ELSE
i := 0; b := (b + 1) MOD MaxPat; j := b
END;
IF j # e THEN
ch := ref[j]
ELSE
IF pos >= srclen THEN
ch := 0X
ELSE
ch := src[pos]
END;
INC(pos); ref[j] := ch; e := (e + 1) MOD MaxPat; INC(beg);
END
END;
IF i = len THEN
pos := beg-len
ELSE
pos := -1
END
END Find;
BEGIN
len := Length(pat);
IF MaxPat < len THEN
len := MaxPat
END;
IF len <= 0 THEN
pos := -1;
RETURN
END;
i := 0;
REPEAT
buf[i] := pat[i]; INC(i)
UNTIL i >= len;
srclen := Length(src);
IF pos < 0 THEN
pos := 0
ELSIF pos >= srclen THEN
pos := -1;
RETURN
END;
Find(pos)
END Search;
(** Search in src starting at pos for the next occurrence of pat. *)
PROCEDURE CAPSearch*(pat: ARRAY OF CHAR; VAR src(** in *): ARRAY OF CHAR; VAR pos(** in/out *): LONGINT);
CONST MaxPat = 128;
VAR
buf: ARRAY MaxPat OF CHAR;
len, i, srclen: LONGINT;
PROCEDURE Find(beg: LONGINT);
VAR
i, j, b, e: LONGINT;
ch: CHAR;
ref: ARRAY MaxPat OF CHAR;
BEGIN
ch := UpperCh(src[pos]); INC(pos);
ref[0] := ch;
i := 0; j := 0; b := 0; e := 1;
WHILE (pos <= srclen) & (i < len) DO
IF buf[i] = ch THEN
INC(i); j := (j + 1) MOD MaxPat
ELSE
i := 0; b := (b + 1) MOD MaxPat; j := b
END;
IF j # e THEN
ch := ref[j]
ELSE
IF pos >= srclen THEN
ch := 0X
ELSE
ch := UpperCh(src[pos])
END;
INC(pos); ref[j] := ch; e := (e + 1) MOD MaxPat; INC(beg);
END
END;
IF i = len THEN
pos := beg-len
ELSE
pos := -1
END
END Find;
BEGIN
len := Length(pat);
IF MaxPat < len THEN
len := MaxPat
END;
IF len <= 0 THEN
pos := -1;
RETURN
END;
i := 0;
REPEAT
buf[i] := UpperCh(pat[i]); INC(i)
UNTIL i >= len;
srclen := Length(src);
IF pos < 0 THEN
pos := 0
ELSIF pos >= srclen THEN
pos := -1;
RETURN
END;
Find(pos)
END CAPSearch;
(** Convert a string into an integer. Leading white space characters are ignored. *)
PROCEDURE StrToInt*(VAR str: ARRAY OF CHAR; VAR val: LONGINT);
VAR i, d: LONGINT; ch: CHAR; neg: BOOLEAN;
BEGIN
i := 0; ch := str[0];
WHILE (ch # 0X) & (ch <= " ") DO
INC(i); ch := str[i]
END;
neg := FALSE; IF ch = "+" THEN INC(i); ch := str[i] END;
IF ch = "-" THEN neg := TRUE; INC(i); ch := str[i] END;
WHILE (ch # 0X) & (ch <= " ") DO
INC(i); ch := str[i]
END;
val := 0;
WHILE (ch >= "0") & (ch <= "9") DO
d := ORD(ch)-ORD("0");
INC(i); ch := str[i];
IF val <= ((MAX(LONGINT)-d) DIV 10) THEN
val := 10*val+d
ELSIF neg & (val = 214748364) & (d = 8) & ((ch < "0") OR (ch > "9")) THEN
val := MIN(LONGINT); neg := FALSE
ELSE
HALT(99)
END
END;
IF neg THEN val := -val END
END StrToInt;
(** Convert the substring beginning at position i in str into an integer. Any leading whitespace characters are ignored.
After the conversion i pointes to the first character after the integer. *)
PROCEDURE StrToIntPos*(VAR str: ARRAY OF CHAR; VAR val: LONGINT; VAR i: INTEGER);
VAR noStr: ARRAY 16 OF CHAR;
BEGIN
WHILE (str[i] # 0X) & (str[i] <= " ") DO
INC(i)
END;
val := 0;
IF str[i] = "-" THEN
noStr[val] := str[i]; INC(val); INC(i);
WHILE (str[i] # 0X) & (str[i] <= " ") DO
INC(i)
END
END;
WHILE (str[i] >= "0") & (str[i] <= "9") DO
noStr[val] := str[i]; INC(val); INC(i)
END;
noStr[val] := 0X;
StrToInt(noStr, val)
END StrToIntPos;
(** Convert an integer into a string. *)
PROCEDURE IntToStr*(val: LONGINT; VAR str: ARRAY OF CHAR);
VAR
i, j: LONGINT;
digits: ARRAY 16 OF LONGINT;
BEGIN
IF val = MIN(LONGINT) THEN
COPY("-2147483648", str);
RETURN
END;
IF val < 0 THEN
val := -val; str[0] := "-"; j := 1
ELSE
j := 0
END;
i := 0;
REPEAT
digits[i] := val MOD 10; INC(i); val := val DIV 10
UNTIL val = 0;
DEC(i);
WHILE i >= 0 DO
str[j] := CHR(digits[i]+ORD("0")); INC(j); DEC(i)
END;
str[j] := 0X
END IntToStr;
(** Converts a real to a string. *)
PROCEDURE RealToStr*(x: LONGREAL; VAR s: ARRAY OF CHAR);
VAR e, h, l, n, len: LONGINT; i, j, pos: INTEGER; z: LONGREAL; d: ARRAY 16 OF CHAR;
PROCEDURE Wr(ch: CHAR);
BEGIN
IF ch = 0X THEN HALT(42) END;
IF pos < len THEN s[pos] := ch; INC(pos) END;
END Wr;
BEGIN
len := LEN(s)-1; pos := 0;
e:= Reals.ExpoL(x);
IF e = 2047 THEN
Wr("N"); Wr("a"); Wr("N")
ELSE
n := 14;
IF (x < 0) & (e # 0) THEN Wr("-"); x:= - x END;
IF e = 0 THEN h:= 0; l:= 0 (* no denormals *)
ELSE e:= (e - 1023) * 301029 DIV 1000000; (* ln(2)/ln(10) = 0.301029996 *)
z:= Reals.Ten(e+1);
IF x >= z THEN x:= x/z; INC(e) ELSE x:= x * Reals.Ten(-e) END;
IF x >= 10 THEN x:= x * Reals.Ten(-1) + 0.5D0 / Reals.Ten(n); INC(e)
ELSE x:= x + 0.5D0 / Reals.Ten(n);
IF x >= 10 THEN x:= x * Reals.Ten(-1); INC(e) END
END;
x:= x * Reals.Ten(7); h:= ENTIER(x); x:= (x-h) * Reals.Ten(8); l:= ENTIER(x)
END;
i := 15; WHILE i > 7 DO d[i]:= CHR(l MOD 10 + ORD("0")); l:= l DIV 10; DEC(i) END;
WHILE i >= 0 DO d[i]:= CHR(h MOD 10 + ORD("0")); h:= h DIV 10; DEC(i) END;
IF ABS(e) > 8 THEN (* scientific notation *)
j := 15; WHILE (j > 0) & (d[j] = "0") DO DEC(j) END;
Wr(d[0]); IF j # 0 THEN Wr(".") END; i := 1; WHILE i <= j DO Wr(d[i]); INC(i) END;
IF e < 0 THEN Wr("D"); Wr("-"); e:= - e ELSE Wr("D"); Wr("+") END;
Wr(CHR(e DIV 100 + ORD("0"))); e:= e MOD 100;
Wr(CHR(e DIV 10 + ORD("0"))); Wr(CHR(e MOD 10 + ORD("0")))
ELSE
IF e < 0 THEN (* leading zeros *)
j := (* !15*) 14; WHILE (j > 0) & (d[j] = "0") DO DEC(j) END;
Wr("0"); Wr("."); INC(e);
WHILE e < 0 DO Wr("0"); INC(e) END;
i := 0; WHILE i <= j DO Wr(d[i]); INC(i) END
ELSE
i := 0; WHILE (e >= 0) & (i < 16 ) DO Wr(d[i]); INC(i); DEC(e) END;
IF i < 16 THEN
Wr(".");
WHILE i < (*16*) 15 DO Wr(d[i]); INC(i); END;
WHILE s[pos - 1] = "0" DO DEC(pos) END;
IF s[pos - 1] = "." THEN DEC(pos) END;
END
END
END
END;
s[pos] := 0X
END RealToStr;
PROCEDURE RealToFixStr*(x: LONGREAL; VAR str: ARRAY OF CHAR; n, f, D: LONGINT);
VAR pos, len, e, i, h, l: LONGINT; r, z: LONGREAL; d: ARRAY 16 OF CHAR; s: CHAR;
PROCEDURE Wr(ch: CHAR);
BEGIN
IF ch = 0X THEN HALT(42) END;
IF pos < len THEN str[pos] := ch; INC(pos) END;
END Wr;
BEGIN
len := LEN(str)-1; pos := 0;
e := Reals.ExpoL(x);
IF (e = 2047) OR (ABS(D) > 308) THEN
Wr("N"); Wr("a"); Wr("N")
ELSE
IF D = 0 THEN DEC(n, 2) ELSE DEC(n, 7) END;
IF n < 2 THEN n := 2 END;
IF f < 0 THEN f := 0 END;
IF n < f + 2 THEN n := f + 2 END;
DEC(n, f);
IF (e # 0) & (x < 0) THEN s := "-"; x := - x ELSE s := " " END;
IF e = 0 THEN
h := 0; l := 0; DEC(e, D-1) (* no denormals *)
ELSE
e := (e - 1023) * 301029 DIV 1000000; (* ln(2)/ln(10) = 0.301029996 *)
z := Reals.Ten(e+1);
IF x >= z THEN x := x/z; INC(e) ELSE x:= x * Reals.Ten(-e) END;
DEC(e, D-1); i := -(e+f);
IF i <= 0 THEN r := 5 * Reals.Ten(i) ELSE r := 0 END;
IF x >= 10 THEN
x := x * Reals.Ten(-1) + r; INC(e)
ELSE
x := x + r;
IF x >= 10 THEN x := x * Reals.Ten(-1); INC(e) END
END;
x := x * Reals.Ten(7); h:= ENTIER(x); x := (x-h) * Reals.Ten(8); l := ENTIER(x)
END;
i := 15;
WHILE i > 7 DO d[i] := CHR(l MOD 10 + ORD("0")); l := l DIV 10; DEC(i) END;
WHILE i >= 0 DO d[i] := CHR(h MOD 10 + ORD("0")); h := h DIV 10; DEC(i) END;
IF n <= e THEN n := e + 1 END;
IF e > 0 THEN
WHILE n > e DO Wr(" "); DEC(n) END;
Wr(s); e:= 0;
WHILE n > 0 DO
DEC(n);
IF e < 16 THEN Wr(d[e]); INC(e) ELSE Wr("0") END
END;
Wr(".")
ELSE
WHILE n > 1 DO Wr(" "); DEC(n) END;
Wr(s); Wr("0"); Wr(".");
WHILE (0 < f) & (e < 0) DO Wr("0"); DEC(f); INC(e) END
END;
WHILE f > 0 DO
DEC(f);
IF e < 16 THEN Wr(d[e]); INC(e) ELSE Wr("0") END
END;
IF D # 0 THEN
IF D < 0 THEN Wr("D"); Wr("-"); D := - D
ELSE Wr("D"); Wr("+")
END;
Wr(CHR(D DIV 100 + ORD("0"))); D := D MOD 100;
Wr(CHR(D DIV 10 + ORD("0"))); Wr(CHR(D MOD 10 + ORD("0")))
END
END;
str[pos] := 0X
END RealToFixStr;
(** Convert a string into a real. Precondition: s has a well defined real syntax. Scientific notation with D and E to indicate exponents is allowed. *)
PROCEDURE StrToReal*(s: ARRAY OF CHAR; VAR r: LONGREAL);
VAR p, e: INTEGER; y, g: LONGREAL; neg, negE: BOOLEAN;
BEGIN
p := 0;
WHILE (s[p] = " ") OR (s[p] = "0") DO INC(p) END;
IF s[p] = "-" THEN neg := TRUE; INC(p) ELSE neg := FALSE END;
WHILE (s[p] = " ") OR (s[p] = "0") DO INC(p) END;
y := 0;
WHILE ("0" <= s[p]) & (s[p] <= "9") DO
y := y * 10 + (ORD(s[p]) - 30H);
INC(p);
END;
IF s[p] = "." THEN
INC(p); g := 1;
WHILE ("0" <= s[p]) & (s[p] <= "9") DO
g := g / 10; y := y + g * (ORD(s[p]) - 30H);
INC(p);
END;
END;
IF (s[p] = "D") OR (s[p] = "E") THEN
INC(p); e := 0;
IF s[p] = "-" THEN negE := TRUE; INC(p) ELSE negE := FALSE END;
WHILE (s[p] = "0") DO INC(p) END;
WHILE ("0" <= s[p]) & (s[p] <= "9") DO
e := e * 10 + (ORD(s[p]) - 30H);
INC(p);
END;
IF negE THEN y := y / Reals.Ten(e)
ELSE y := y * Reals.Ten(e) END;
END;
IF neg THEN y := -y END;
r := y;
END StrToReal;
(** Convert a string into a boolean. "Yes", "True" and "On" are TRUE all other strings are FALSE.
Leading white space characters are ignored. *)
PROCEDURE StrToBool*(VAR str: ARRAY OF CHAR; VAR b: BOOLEAN);
VAR i: LONGINT;
BEGIN
i := 0;
WHILE (str[i] # 0X) & (str[i] <= " ") DO
INC(i)
END;
CASE CAP(str[i]) OF
"Y", "T": b := TRUE
|"O": b := CAP(str[i+1]) = "N"
ELSE
b := FALSE
END
END StrToBool;
(** Convert a boolean into "Yes" or "No". *)
PROCEDURE BoolToStr*(b: BOOLEAN; VAR str: ARRAY OF CHAR);
BEGIN
IF b THEN
COPY("Yes", str)
ELSE
COPY("No", str)
END
END BoolToStr;
(** Convert a string to a set *)
PROCEDURE StrToSet* (str: ARRAY OF CHAR; VAR set: SET);
VAR i, d, d1: INTEGER; ch: CHAR; dot: BOOLEAN;
BEGIN
set := {}; dot := FALSE;
i := 0; ch := str[i];
WHILE (ch # 0X) & (ch # "}") DO
WHILE (ch # 0X) & ((ch < "0") OR (ch > "9")) DO INC(i); ch := str[i] END;
d := 0; WHILE (ch >= "0") & (ch <= "9") DO d := d*10 + ORD(ch) - 30H; INC(i); ch := str[i] END;
IF d <= MAX(SET) THEN INCL(set, d) END;
IF dot THEN
d1 := 0;
WHILE (d1 <= MAX(SET)) & (d1 < d) DO INCL(set, d1); INC(d1) END;
dot := FALSE
END;
WHILE ch = " " DO INC(i); ch := str[i] END;
IF ch = "." THEN d1 := d + 1; dot := TRUE END
END
END StrToSet;
(** Convert a set to a string *)
PROCEDURE SetToStr* (set: SET; VAR str: ARRAY OF CHAR);
VAR i, j, k: INTEGER; noFirst: BOOLEAN;
BEGIN
str[0] := "{"; i := 0; k := 1; noFirst := FALSE;
WHILE i <= MAX(SET) DO
IF i IN set THEN
IF noFirst THEN str[k] := ","; INC(k) ELSE noFirst := TRUE END;
IF i >= 10 THEN str[k] := CHR(i DIV 10 + 30H); INC(k) END;
str[k] := CHR(i MOD 10 + 30H); INC(k);
j := i; INC(i);
WHILE (i <= MAX(SET)) & (i IN set) DO INC(i) END;
IF i-2 > j THEN
str[k] := "."; str[k+1] := "."; INC(k, 2); j := i - 1;
IF j >= 10 THEN str[k] := CHR(j DIV 10 + 30H); INC(k) END;
str[k] := CHR(j MOD 10 + 30H); INC(k)
ELSE i := j
END
END;
INC(i)
END;
str[k] := "}"; str[k+1] := 0X
END SetToStr;
(** Convert date (Oberon.GetClock) into specified format. *)
PROCEDURE DateToStr*(date: LONGINT; VAR str: ARRAY OF CHAR);
VAR i, j, k, x: LONGINT; form, name: ARRAY 32 OF CHAR;
BEGIN
COPY(dateform, form);
IF form = "" THEN form := "DD.MM.YY" END;
i := 0; j := 0;
WHILE form[j] # 0X DO
IF CAP(form[j]) = "D" THEN (* Day *)
INC(j); x := date MOD 32;
IF CAP(form[j]) = "D" THEN
INC(j);
IF CAP(form[j]) = "D" THEN
INC(j); x := Dates.DayOfWeek(date);
IF CAP(form[j]) = "D" THEN INC(j); COPY(lDayName[x], name)
ELSE COPY(sDayName[x], name)
END;
k := 0; WHILE name[k] # 0X DO str[i] := name[k]; INC(i); INC(k) END
ELSE (* day with leading zero *)
str[i] := CHR(x DIV 10 + ORD("0"));
str[i + 1] := CHR(x MOD 10 + ORD("0"));
INC(i, 2)
END
ELSE (* no leading zero *)
IF x > 9 THEN str[i] := CHR(x DIV 10 + ORD("0")); INC(i) END;
str[i] := CHR(x MOD 10 + ORD("0")); INC(i)
END
ELSIF CAP(form[j]) = "M" THEN (* Month *)
INC(j); x := date DIV 32 MOD 16;
IF CAP(form[j]) = "M" THEN
INC(j);
IF CAP(form[j]) = "M" THEN
INC(j);
IF CAP(form[j]) = "M" THEN INC(j); COPY(lMonthName[x-1], name)
ELSE COPY(sMonthName[x-1], name)
END;
k := 0; WHILE name[k] # 0X DO str[i] := name[k]; INC(i); INC(k) END
ELSE
str[i] := CHR(x DIV 10 + ORD("0"));
str[i + 1] := CHR(x MOD 10 + ORD("0"));
INC(i, 2)
END
ELSE
IF x > 9 THEN str[i] := CHR(x DIV 10 + ORD("0")); INC(i) END;
str[i] := CHR(x MOD 10 + ORD("0")); INC(i)
END
ELSIF CAP(form[j]) = "Y" THEN (* Year *)
INC(j,2); x := date DIV 512;
IF CAP(form[j]) = "Y" THEN
INC(j, 2); INC(x, 1900);
str[i] := CHR(x DIV 1000 + ORD("0")); str[i + 1] := CHR(x DIV 100 MOD 10 + ORD("0"));
str[i + 2] := CHR(x DIV 10 MOD 10 + ORD("0")); str[i + 3] := CHR(x MOD 10 + ORD("0"));
INC(i, 4)
ELSE
str[i] := CHR(x DIV 10 MOD 10 + ORD("0")); str[i + 1] := CHR(x MOD 10 + ORD("0"));
INC(i, 2)
END
ELSE str[i] := form[j]; INC(i); INC(j)
END
END;
str[i] := 0X
END DateToStr;
(** Returns a month's name (set short to get the abbreviation) *)
PROCEDURE MonthToStr* (month: INTEGER; VAR str: ARRAY OF CHAR; short: BOOLEAN);
BEGIN
month := (month - 1) MOD 12;
IF short THEN COPY(sMonthName[month], str) ELSE COPY(lMonthName[month], str) END
END MonthToStr;
(** Returns a day's name (set short to get the abbreviation) *)
PROCEDURE DayToStr* (day: INTEGER; VAR str: ARRAY OF CHAR; short: BOOLEAN);
BEGIN
IF short THEN COPY(sDayName[day MOD 7], str) ELSE COPY(lDayName[day MOD 7], str) END
END DayToStr;
(** Convert time (Oberon.GetClock) into specified format. *)
PROCEDURE TimeToStr*(time: LONGINT; VAR str: ARRAY OF CHAR);
VAR i, j, x, h, hPos: LONGINT; form: ARRAY 32 OF CHAR; shortH, leadingH: BOOLEAN;
BEGIN
COPY(timeform, form);
IF form = "" THEN form := "HH:MM:SS" END;
i := 0; j := 0; h:= time DIV 4096 MOD 32; shortH := FALSE;
WHILE form[j] # 0X DO
IF ((CAP(form[j]) = "A") OR (CAP(form[j]) = "P")) & (CAP(form[j+1]) = "M") THEN
shortH := TRUE;
IF CAP(form[j]) = form[j] THEN x := 0 ELSE x := 32 END;
IF (h < 1) OR (h > 12) THEN str[i] := CHR(ORD("P") + x) ELSE str[i] := CHR(ORD("A") + x) END;
h := h MOD 12; IF h = 0 THEN h := 12 END;
str[i + 1] := CHR(ORD("M") + x);
INC(i, 2);
WHILE (CAP(form[j]) = "A") OR (CAP(form[j]) = "P") OR (CAP(form[j]) = "M") DO INC(j) END
ELSIF form[j] = "H" THEN
hPos := i; INC(i, 2); INC(j); leadingH := (form[j] = "H");
IF leadingH THEN INC(j) END
ELSIF form[j] = "M" THEN
INC(j); x := time DIV 64 MOD 64;
IF form[j] = "M" THEN str[i] := CHR(x DIV 10 + ORD("0")); INC(i); INC(j)
ELSIF x > 9 THEN str[i] := CHR(x DIV 10 + ORD("0")); INC(i)
END;
str[i] := CHR(x MOD 10 + ORD("0")); INC(i)
ELSIF form[j] = "S" THEN
INC(j); x := time MOD 64;
IF form[j] = "S" THEN str[i] := CHR(x DIV 10 + ORD("0")); INC(i); INC(j)
ELSIF x > 9 THEN str[i] := CHR(x DIV 10 + ORD("0")); INC(i)
END;
str[i] := CHR(x MOD 10 + ORD("0")); INC(i)
ELSE str[i] := form[j]; INC(i); INC(j)
END
END;
str[i] := 0X;
IF ~leadingH THEN
IF h > 9 THEN str[hPos] := CHR(h DIV 10 + ORD("0")); INC(hPos)
ELSE i := hPos + 1; WHILE str[i] # 0X DO str[i] := str[i + 1]; INC(i) END
END;
str[hPos] := CHR(h MOD 10 + ORD("0"))
ELSE
str[hPos] := CHR(h DIV 10 + ORD("0"));
str[hPos + 1] := CHR(h MOD 10 + ORD("0"))
END
END TimeToStr;
(** Convert a string into an time value. Leading white space characters are ignored. *)
PROCEDURE StrToTime*(str: ARRAY OF CHAR; VAR time: LONGINT);
VAR
h, m, s: LONGINT;
i: INTEGER;
BEGIN
i := 0;
WHILE (str[i] # 0X) & ((str[i] < "0") OR (str[i] > "9")) DO INC(i) END;
StrToIntPos(str, h, i);
WHILE (str[i] # 0X) & ((str[i] < "0") OR (str[i] > "9")) DO INC(i) END;
StrToIntPos(str, m, i);
WHILE (str[i] # 0X) & ((str[i] < "0") OR (str[i] > "9")) DO INC(i) END;
StrToIntPos(str, s, i);
time := (h*64 + m)*64 + s
END StrToTime;
(** Convert a string into an date value. Leading white space characters are ignored. *)
PROCEDURE StrToDate*(str: ARRAY OF CHAR; VAR date: LONGINT);
VAR
d, m, y: LONGINT;
i: INTEGER;
BEGIN
i := 0;
WHILE (str[i] # 0X) & ((str[i] < "0") OR (str[i] > "9")) DO INC(i) END;
StrToIntPos(str, d, i);
WHILE (str[i] # 0X) & ((str[i] < "0") OR (str[i] > "9")) DO INC(i) END;
StrToIntPos(str, m, i);
WHILE (str[i] # 0X) & ((str[i] < "0") OR (str[i] > "9")) DO INC(i) END;
StrToIntPos(str, y, i); y := y-1900;
date := (y*16 + m)*32 + d
END StrToDate;
PROCEDURE Init();
VAR i: LONGINT; s: Texts.Scanner; txt : Texts.Text; (* noch *)
BEGIN
NEW(txt);
Texts.Open(txt, "System.DateFormat"); (* got rid of Oberon.OpenScanner -- noch *)
Texts.OpenScanner(s, txt, 0);
IF s.class = Texts.String THEN COPY(s.s, dateform) ELSE dateform := "" END;
Texts.Open(txt, "System.TimeFormat");
Texts.OpenScanner(s, txt, 0);
IF s.class = Texts.String THEN COPY(s.s, timeform) ELSE timeform := "" END;
sDayName[0] := "Mon"; sDayName[1] := "Tue"; sDayName[2] := "Wed"; sDayName[3] := "Thu";
sDayName[4] := "Fri"; sDayName[5] := "Sat"; sDayName[6] := "Sun";
lDayName[0] := "Monday"; lDayName[1] := "Tuesday"; lDayName[2] := "Wednesday"; lDayName[3] := "Thursday";
lDayName[4] := "Friday"; lDayName[5] := "Saturday"; lDayName[6] := "Sunday";
sMonthName[0] := "Jan"; sMonthName[1] := "Feb"; sMonthName[2] := "Mar"; sMonthName[3] := "Apr";
sMonthName[4] := "May"; sMonthName[5] := "Jun"; sMonthName[6] := "Jul"; sMonthName[7] := "Aug";
sMonthName[8] := "Sep"; sMonthName[9] := "Oct"; sMonthName[10] := "Nov"; sMonthName[11] := "Dec";
lMonthName[0] := "January"; lMonthName[1] := "February"; lMonthName[2] := "March"; lMonthName[3] := "April";
lMonthName[4] := "May"; lMonthName[5] := "June"; lMonthName[6] := "July"; lMonthName[7] := "August";
lMonthName[8] := "September"; lMonthName[9] := "October"; lMonthName[10] := "November";
lMonthName[11] := "December";
FOR i := 0 TO 255 DO
isAlpha[i] := ((i >= ORD("A")) & (i <= ORD("Z"))) OR ((i >= ORD("a")) & (i <= ORD("z")))
END;
isAlpha[ORD("€")] := TRUE; isAlpha[ORD("<22>")] := TRUE; isAlpha[ORD("‚")] := TRUE;
isAlpha[ORD("ƒ")] := TRUE; isAlpha[ORD("„")] := TRUE; isAlpha[ORD("…")] := TRUE;
isAlpha[ORD("†")] := TRUE; isAlpha[ORD("‡")] := TRUE; isAlpha[ORD("ˆ")] := TRUE;
isAlpha[ORD("‰")] := TRUE; isAlpha[ORD("Š")] := TRUE; isAlpha[ORD("‹")] := TRUE;
isAlpha[ORD("Œ")] := TRUE; isAlpha[ORD("<22>")] := TRUE; isAlpha[ORD("Ž")] := TRUE;
isAlpha[ORD("<22>")] := TRUE; isAlpha[ORD("<22>")] := TRUE; isAlpha[ORD("‘")] := TRUE;
isAlpha[ORD("’")] := TRUE; isAlpha[ORD("“")] := TRUE; isAlpha[ORD("”")] := TRUE;
isAlpha[ORD("•")] := TRUE; isAlpha[ORD("–")] := TRUE;
FOR i := 0 TO 255 DO
ISOToOberon[i] := CHR(i); OberonToISO[i] := CHR(i)
END;
ISOToOberon[8] := CHR(127);
ISOToOberon[146] := CHR(39);
ISOToOberon[160] := CHR(32);
ISOToOberon[162] := CHR(99);
ISOToOberon[166] := CHR(124);
ISOToOberon[168] := CHR(34);
ISOToOberon[169] := CHR(99);
ISOToOberon[170] := CHR(97);
ISOToOberon[171] := CHR(60);
ISOToOberon[173] := CHR(45);
ISOToOberon[174] := CHR(114);
ISOToOberon[175] := CHR(45);
ISOToOberon[176] := CHR(111);
ISOToOberon[178] := CHR(50);
ISOToOberon[179] := CHR(51);
ISOToOberon[180] := CHR(39);
ISOToOberon[183] := CHR(46);
ISOToOberon[185] := CHR(49);
ISOToOberon[186] := CHR(48);
ISOToOberon[187] := CHR(62);
ISOToOberon[192] := CHR(65);
ISOToOberon[193] := CHR(65);
ISOToOberon[194] := CHR(65);
ISOToOberon[195] := CHR(65);
ISOToOberon[196] := CHR(128); OberonToISO[128] := CHR(196);
ISOToOberon[197] := CHR(65);
ISOToOberon[198] := CHR(65);
ISOToOberon[199] := CHR(67);
ISOToOberon[200] := CHR(69);
ISOToOberon[201] := CHR(69);
ISOToOberon[202] := CHR(69);
ISOToOberon[203] := CHR(69);
ISOToOberon[204] := CHR(73);
ISOToOberon[205] := CHR(73);
ISOToOberon[206] := CHR(73);
ISOToOberon[207] := CHR(73);
ISOToOberon[208] := CHR(68);
ISOToOberon[209] := CHR(78);
ISOToOberon[210] := CHR(79);
ISOToOberon[211] := CHR(79);
ISOToOberon[212] := CHR(79);
ISOToOberon[213] := CHR(79);
ISOToOberon[214] := CHR(129); OberonToISO[129] := CHR(214);
ISOToOberon[215] := CHR(42);
ISOToOberon[216] := CHR(79);
ISOToOberon[217] := CHR(85);
ISOToOberon[218] := CHR(85);
ISOToOberon[219] := CHR(85);
ISOToOberon[220] := CHR(130); OberonToISO[130] := CHR(220);
ISOToOberon[221] := CHR(89);
ISOToOberon[222] := CHR(80);
ISOToOberon[223] := CHR(150); OberonToISO[150] := CHR(223);
ISOToOberon[224] := CHR(139); OberonToISO[139] := CHR(224);
ISOToOberon[225] := CHR(148); OberonToISO[148] := CHR(225);
ISOToOberon[226] := CHR(134); OberonToISO[134] := CHR(226);
ISOToOberon[227] := CHR(97);
ISOToOberon[228] := CHR(131); OberonToISO[131] := CHR(228);
ISOToOberon[229] := CHR(97);
ISOToOberon[230] := CHR(97);
ISOToOberon[231] := CHR(147); OberonToISO[147] := CHR(231);
ISOToOberon[232] := CHR(140); OberonToISO[140] := CHR(232);
ISOToOberon[233] := CHR(144); OberonToISO[144] := CHR(233);
ISOToOberon[234] := CHR(135); OberonToISO[135] := CHR(234);
ISOToOberon[235] := CHR(145); OberonToISO[145] := CHR(235);
ISOToOberon[236] := CHR(141); OberonToISO[141] := CHR(236);
ISOToOberon[237] := CHR(105);
ISOToOberon[238] := CHR(136); OberonToISO[136] := CHR(238);
ISOToOberon[239] := CHR(146); OberonToISO[146] := CHR(239);
ISOToOberon[240] := CHR(100);
ISOToOberon[241] := CHR(149); OberonToISO[149] := CHR(241);
ISOToOberon[242] := CHR(142); OberonToISO[142] := CHR(242);
ISOToOberon[243] := CHR(111);
ISOToOberon[244] := CHR(137); OberonToISO[137] := CHR(244);
ISOToOberon[245] := CHR(111);
ISOToOberon[246] := CHR(132); OberonToISO[132] := CHR(246);
ISOToOberon[248] := CHR(111);
ISOToOberon[249] := CHR(143); OberonToISO[143] := CHR(249);
ISOToOberon[250] := CHR(117);
ISOToOberon[251] := CHR(138); OberonToISO[138] := CHR(251);
ISOToOberon[252] := CHR(133); OberonToISO[133] := CHR(252);
ISOToOberon[253] := CHR(121);
ISOToOberon[254] := CHR(112);
ISOToOberon[255] := CHR(121);
CRLF[0] := CR; CRLF[1] := LF; CRLF[2] := 0X; CRLF[3] := 0X
END Init;
BEGIN
Init()
END ethStrings.

216
src/library/s3/ethUnicode.Mod Normal file
View file

@ -0,0 +1,216 @@
(* ETH Oberon, Copyright 2000 ETH Zuerich Institut fuer Computersysteme, ETH Zentrum, CH-8092 Zuerich.
Refer to the "General ETH Oberon System Source License" contract available at: http://www.oberon.ethz.ch/ *)
MODULE ethUnicode; (* be *)
IMPORT SYSTEM;
PROCEDURE AND(a,b: LONGINT): LONGINT;
BEGIN RETURN SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, a) * SYSTEM.VAL(SET, b))
END AND;
(** UCStoUTF8 - converts a single unicode-character to one UTF-8 character. The UTF-8 character is written
into 'utf8' starting at position 'pos' that points immediatly behind the inserted character.
Returns TRUE if the conversion was successful *)
PROCEDURE UCStoUTF8*(ucs: LONGINT; VAR utf8: ARRAY OF CHAR; VAR pos: LONGINT): BOOLEAN;
VAR len: LONGINT;
byte, mask, max, i: INTEGER;
buf: ARRAY 6 OF CHAR;
BEGIN
len := LEN(utf8);
IF (ucs <= 7FH) THEN
IF (pos + 1 < len) THEN utf8[pos] := CHR(SHORT(ucs));
utf8[pos+1] := 0X;
pos := pos + 1
ELSE RETURN FALSE
END
ELSE
byte := 0; mask := 7F80H; max := 3FH;
WHILE (ucs > max) DO
buf[byte] := CHR(80H + SHORT(AND(ucs, 3FH))); INC(byte);
ucs := ucs DIV 64; (* SYSTEM.LSH(ucs, -6) *)
mask := mask DIV 2; (* 80H + SYSTEM.LSH(mask, -1) *)
max := max DIV 2; (* SYSTEM.LSH(max, -1) *)
END;
buf[byte] := CHR(mask + SHORT(ucs));
IF (pos + byte + 1 < len) THEN
FOR i := 0 TO byte DO utf8[pos + i] := buf[byte - i] END;
utf8[pos+byte+1] := 0X;
pos := pos + byte + 1
ELSE RETURN FALSE
END
END;
RETURN TRUE
END UCStoUTF8;
(** UCS2toUTF8 - converts an array of 16-bit unicode characters to a UTF-8 string *)
PROCEDURE UCS2toUTF8*(VAR ucs2: ARRAY OF INTEGER; VAR utf8: ARRAY OF CHAR);
VAR i, p: LONGINT;
b: BOOLEAN;
BEGIN
b := TRUE; i := 0; p := 0;
WHILE (i < LEN(ucs2)) & b DO
b := UCStoUTF8(ucs2[i], utf8, p);
INC(i)
END
END UCS2toUTF8;
(** UCS4toUTF8 - converts an array of 32-bit unicode characters to an UTF-8 string *)
PROCEDURE UCS4toUTF8*(VAR ucs4: ARRAY OF LONGINT; VAR utf8: ARRAY OF CHAR);
VAR i, p: LONGINT;
b: BOOLEAN;
BEGIN
b := TRUE; i := 0; p := 0;
WHILE (i < LEN(ucs4)) & b DO
b := UCStoUTF8(ucs4[i], utf8, p);
INC(i)
END
END UCS4toUTF8;
(** UTF8toUCS - converts the UTF-8 character in the string 'utf8' at position 'p' into an unicode character.
Returns TRUE if the conversion was successful *)
PROCEDURE UTF8toUCS*(VAR utf8: ARRAY OF CHAR; VAR p: LONGINT; VAR ucs: LONGINT): BOOLEAN;
VAR b: LONGINT;
bytes, mask, i: INTEGER;
s: SET;
res: BOOLEAN;
BEGIN
res := FALSE;
IF (p < LEN(utf8)) THEN
b := ORD(utf8[p]);
IF (b < 80H) THEN ucs := b; INC(p); res := TRUE
ELSE
bytes := 2; mask := 3FH; s := SYSTEM.VAL(SET, b);
WHILE ((7-bytes) IN s) DO INC(bytes); mask := mask DIV 2 END;
ucs := AND(b, mask);
IF (p + bytes - 1 < LEN(utf8))THEN
FOR i := 1 TO bytes-1 DO ucs := ucs * 64 + AND(ORD(utf8[p+i]), 3FH) END;
p := p + bytes;
res := TRUE
END
END
END;
RETURN res
END UTF8toUCS;
(** UTF8toUCS2 - converts an UTF-8 string into an array of 16-bit unicode characters. The first character is placed
at position 'idx'. Returns TRUE if the conversion was successful *)
PROCEDURE UTF8toUCS2*(VAR utf8: ARRAY OF CHAR; VAR ucs2: ARRAY OF INTEGER; VAR idx: LONGINT): BOOLEAN;
VAR p, ucs: LONGINT;
BEGIN
p := 0;
WHILE UTF8toUCS(utf8, p, ucs) & (ucs > 0) & (idx < LEN(ucs2)-1) DO
IF (ucs <= MAX(INTEGER)) THEN ucs2[idx] := SHORT(ucs)
ELSE ucs2[0] := 0; RETURN FALSE
END;
INC(idx)
END;
IF (idx < LEN(ucs2)) THEN ucs2[idx] := 0; INC(idx) END;
RETURN TRUE
END UTF8toUCS2;
(** UTF8toUCS4 - converts an UTF-8 string into an array of 32-bit unicode characters. The first character is placed
at position 'idx'. Returns TRUE if the conversion was successful *)
PROCEDURE UTF8toUCS4*(VAR utf8: ARRAY OF CHAR; VAR ucs4: ARRAY OF LONGINT; VAR idx: LONGINT);
VAR p: LONGINT;
BEGIN
p := 0;
WHILE (idx < LEN(ucs4)) & UTF8toUCS(utf8, p, ucs4[idx]) & (ucs4[idx] > 0) DO
INC(idx)
END;
IF (idx < LEN(ucs4)) THEN ucs4[idx] := 0; INC(idx) END
END UTF8toUCS4;
(** UTF8toASCII - converts an UTF8-string into an ASCII-string. 'lossy' is TRUE if some information was lost during the
conversion. Returns TRUE if the conversion was successful *)
PROCEDURE UTF8toASCII*(utf8: ARRAY OF CHAR; VAR ascii: ARRAY OF CHAR; VAR lossy: BOOLEAN): BOOLEAN;
VAR p, idx, ucs: LONGINT;
BEGIN
p := 0; idx := 0; ucs := -1;
WHILE (ucs # 0) & UTF8toUCS(utf8, p, ucs) & (idx < LEN(ascii)) DO
IF (ucs >= 0) & (ucs < 256) THEN ascii[idx] := CHR(ucs)
ELSE ascii[idx] := "_"
END;
INC(idx)
END;
IF (ascii[idx-1] # 0X) & (idx < LEN(ascii)) THEN ascii[idx] := 0X; INC(idx) END;
RETURN ascii[idx-1] = 0X
END UTF8toASCII;
(** ASCIItoUTF8 - converts an ASCII-string into an UTF8-string *)
PROCEDURE ASCIItoUTF8*(ascii: ARRAY OF CHAR; VAR utf8: ARRAY OF CHAR);
VAR l, i: LONGINT;
ucs: POINTER TO ARRAY OF INTEGER;
BEGIN
l := 0; WHILE (ascii[l] # 0X) DO INC(l) END;
NEW(ucs, l);
FOR i := 0 TO l-1 DO ucs[i] := ORD(ascii[i]) END;
UCS2toUTF8(ucs^, utf8)
END ASCIItoUTF8;
(** UpperCh - returns the upper case of a character. 'lossy' is TRUE if some information was lost during the conversion. *)
PROCEDURE UpperCh*(ch: CHAR; VAR lossy: BOOLEAN): CHAR;
BEGIN
lossy := TRUE;
CASE ch OF
"a" .. "z": ch := CAP(ch); lossy := FALSE |
"0".."9", "A".."Z", "€", "<22>", "‚", "$", ".", "%", "'", "-", "_", "@", "~", "`", "!", "(", ")", "{", "}", "^", "#", "&": lossy := FALSE |
"ƒ": ch := "€"; lossy := FALSE |
"„": ch := "<22>"; lossy := FALSE |
"…": ch := "‚"; lossy := FALSE |
"†": ch := "A" |
"‡": ch := "E" |
"ˆ": ch := "I" |
"‰": ch := "O" |
"Š": ch := "U" |
"‹": ch := "A" |
"Œ": ch := "E" |
"<22>": ch := "I" |
"Ž": ch := "O" |
"<22>": ch := "U" |
"<22>": ch := "E" |
"‘": ch := "E" |
"’": ch := "I" |
"“": ch := "C" |
"”": ch := "A" |
"•": ch := "N" |
"–": ch := "S"
ELSE
END;
RETURN ch
END UpperCh;
(** Length - returns the length of a string *)
PROCEDURE Length*(VAR s: ARRAY OF CHAR): LONGINT;
VAR p, l: LONGINT;
BEGIN
l := LEN(s); p := 0;
WHILE (p < l) & (s[p] # 0X) DO INC(p) END;
RETURN p
END Length;
(** Append - appends 'this' to 'to' *)
PROCEDURE Append*(VAR to: ARRAY OF CHAR; this: ARRAY OF CHAR);
VAR i, j, l: LONGINT;
BEGIN
i := 0; WHILE to[i] # 0X DO INC(i) END;
l := LEN(to)-1; j := 0;
WHILE (i < l) & (this[j] # 0X) DO to[i] := this[j]; INC(i); INC(j) END;
to[i] := 0X
END Append;
(** Prepend - appends 'to' to 'this' *)
PROCEDURE Prepend*(VAR to: ARRAY OF CHAR; this: ARRAY OF CHAR);
VAR tmp: POINTER TO ARRAY OF CHAR;
BEGIN
NEW(tmp, LEN(to));
COPY(this, tmp^);
Append(tmp^, to);
COPY(tmp^, to)
END Prepend;
END ethUnicode.
ÛBIER¸Éx:ZÿÿÿÿCOberon10.Scn.Fnt29.03.01 17:55:31TimeStamps.New€

745
src/library/s3/ethZip.Mod Normal file
View file

@ -0,0 +1,745 @@
(* ETH Oberon, Copyright 2001 ETH Zuerich Institut fuer Computersysteme, ETH Zentrum, CH-8092 Zuerich.
Refer to the "General ETH Oberon System Source License" contract available at: http://www.oberon.ethz.ch/ *)
MODULE ethZip; (** Stefan Walthert **)
IMPORT
Files, Zlib := ethZlib, ZlibReaders := ethZlibReaders, ZlibWriters := ethZlibWriters;
CONST
(** result codes **)
Ok* = 0; (** operation on zip-file was successful **)
FileError* = -1; (** file not found **)
NotZipArchiveError* = -2; (** file is not in zip format **)
EntryNotFound* = -3; (** specified file was not found in zip-file **)
EntryAlreadyExists* = -4; (** file is already stored in zip-file -> can not add specified file to zip-file **)
NotSupportedError* = -5; (** can not extract specified file (compression method not supported/file is encrypted) **)
DataError* = -6; (** file is corrupted **)
BadName* = -7; (** bad file name *)
ReaderError* = -8; (** e.g. Reader not opened before Read **)
(** compression levels **)
DefaultCompression* = ZlibWriters.DefaultCompression;
NoCompression* = ZlibWriters.NoCompression;
BestSpeed* = ZlibWriters.BestSpeed;
BestCompression* = ZlibWriters.BestCompression;
(** compression strategies **)
DefaultStrategy* = ZlibWriters.DefaultStrategy;
Filtered* = ZlibWriters.Filtered;
HuffmanOnly* = ZlibWriters.HuffmanOnly;
(* support *)
Supported = 0; (* can extract file *)
IncompatibleVersion = 1; (* version needed to extract < PKZIP 1.00 *)
Encrypted = 2; (* file is encrypted *)
UnsupCompMethod = 3; (* file not stored or deflated *)
Stored = 0; (* file is stored (no compression) *)
Deflated = 8; (* file is deflated *)
SupportedCompMethods = {Stored, Deflated};
CompatibleVersions = 1; (* versions >= CompatibleVersions are supported *)
(* headers *)
LocalFileHeaderSignature = 04034B50H;
CentralFileHeaderSignature = 02014B50H;
EndOfCentralDirSignature = 06054B50H;
TYPE
Entry* = POINTER TO EntryDesc; (** description of a file stored in the zip-archive **)
EntryDesc* = RECORD
name-: ARRAY 256 OF CHAR; (** name of file stored in the zip-archive **)
method: INTEGER; (* compression method *)
time-, date-: LONGINT; (** (Oberon) time and date when file was last modified **)
crc32: LONGINT; (* checksum of uncompressed file data *)
compSize-, uncompSize-: LONGINT; (** size of compressed / uncompressed file **)
intFileAttr: INTEGER; (* internal file attributes, not used in this implementation *)
extFileAttr: LONGINT; (* external file attributes, not used in this implementation *)
extraField (* for future expansions *), comment-: POINTER TO ARRAY OF CHAR; (** comment for this file **)
genPurpBitFlag: INTEGER;
support: SHORTINT;
dataDescriptor: BOOLEAN; (* if set, data descriptor after (compressed) file data *)
offsetLocal: LONGINT; (* offset of file header in central directory *)
offsetFileData: LONGINT; (* offset of (compressed) file data *)
offsetCentralDir: LONGINT; (* offset of local file header *)
next: Entry
END;
Archive* = POINTER TO ArchiveDesc; (** description of a zipfile **)
ArchiveDesc* = RECORD
nofEntries-: INTEGER; (** total number of files stored in the zipfile **)
comment-: POINTER TO ARRAY OF CHAR; (** comment for zipfile **)
file: Files.File; (* pointer to the according zip-file *)
offset: LONGINT; (* offset of end of central dir record *)
firstEntry, lastEntry: Entry (* first and last Entry of Archive *)
END;
Reader* = POINTER TO ReaderDesc;
ReaderDesc* = RECORD (** structure for reading from a zip-file into a buffer **)
res-: LONGINT; (** result of last operation **)
open: BOOLEAN;
ent: Entry
END;
UncompReader = POINTER TO UncompReaderDesc;
UncompReaderDesc = RECORD (ReaderDesc) (* structur for reading from a uncompressed entry *)
fr: Files.Rider;
crc32: LONGINT; (* crc32 of uncomressed data *)
END;
DefReader = POINTER TO DefReaderDesc;
DefReaderDesc = RECORD (ReaderDesc) (* structure for reading from a deflated entry *)
zr: ZlibReaders.Reader
END;
(* length of str *)
PROCEDURE StringLength(VAR str(* in *): ARRAY OF CHAR): LONGINT;
VAR i, l: LONGINT;
BEGIN
l := LEN(str); i := 0;
WHILE (i < l) & (str[i] # 0X) DO
INC(i)
END;
RETURN i
END StringLength;
(* Converts Oberon time into MS-DOS time *)
PROCEDURE OberonToDosTime(t: LONGINT): INTEGER;
BEGIN
RETURN SHORT(t DIV 1000H MOD 20H * 800H + t DIV 40H MOD 40H * 20H + t MOD 40H DIV 2)
END OberonToDosTime;
(* Converts Oberon date into MS-DOS time *)
PROCEDURE OberonToDosDate(d: LONGINT): INTEGER;
BEGIN
RETURN SHORT((d DIV 200H + 1900 - 1980) * 200H + d MOD 200H)
END OberonToDosDate;
(* Converts MS-DOS time into Oberon time *)
PROCEDURE DosToOberonTime(t: INTEGER): LONGINT;
BEGIN
RETURN LONG(t) DIV 800H MOD 20H * 1000H + t DIV 20H MOD 40H * 40H + t MOD 20H * 2
END DosToOberonTime;
(* Converts MS-DOS date into Oberon date *)
PROCEDURE DosToOberonDate(d: INTEGER): LONGINT;
BEGIN
RETURN (LONG(d) DIV 200H MOD 80H + 1980 - 1900) * 200H + d MOD 200H
END DosToOberonDate;
(* Copy len bytes from src to dst; if compCRC32 is set, then the crc 32-checksum is computed *)
PROCEDURE Copy(VAR src, dst: Files.Rider; len: LONGINT; compCRC32: BOOLEAN; VAR crc32: LONGINT);
CONST
BufSize = 4000H;
VAR
n: LONGINT;
buf: ARRAY BufSize OF CHAR;
BEGIN
IF compCRC32 THEN crc32 := Zlib.CRC32(0, buf, -1, -1) END;
REPEAT
IF len < BufSize THEN n := len
ELSE n := BufSize
END;
Files.ReadBytes(src, buf, n);
IF compCRC32 THEN crc32 := Zlib.CRC32(crc32, buf, 0, n - src.res) END;
Files.WriteBytes(dst, buf, n - src.res);
DEC(len, n)
UNTIL len = 0
END Copy;
(* Reads an Entry, r must be at the start of a file header; returns NIL if read was not successful *)
PROCEDURE ReadEntry(VAR r: Files.Rider): Entry;
VAR
ent: Entry;
intDummy, nameLen, extraLen, commentLen: INTEGER;
longDummy: LONGINT;
bufDummy: ARRAY 256 OF CHAR;
BEGIN
Files.ReadLInt(r, longDummy);
IF longDummy = CentralFileHeaderSignature THEN
NEW(ent);
ent.offsetCentralDir := Files.Pos(r) - 4;
ent.support := 0;
Files.ReadInt(r, intDummy); (* version made by *)
Files.ReadInt(r, intDummy); (* version needed to extract *)
IF (intDummy MOD 100H) / 10 < CompatibleVersions THEN
ent.support := IncompatibleVersion
END;
Files.ReadInt(r, ent.genPurpBitFlag); (* general purpose bit flag *)
IF ODD(intDummy) THEN
ent.support := Encrypted (* bit 0: if set, file encrypted *)
END;
ent.dataDescriptor := ODD(intDummy DIV 8); (* bit 3: data descriptor after (compressed) file data *)
Files.ReadInt(r, ent.method); (* compression method *)
IF (ent.support = Supported) & ~(ent.method IN SupportedCompMethods) THEN
ent.support := UnsupCompMethod
END;
Files.ReadInt(r, intDummy); ent.time := DosToOberonTime(intDummy); (* last mod file time *)
Files.ReadInt(r, intDummy); ent.date := DosToOberonDate(intDummy); (* last mod file date *)
Files.ReadLInt(r, ent.crc32); (* crc-32 *)
Files.ReadLInt(r, ent.compSize); (* compressed size *)
Files.ReadLInt(r, ent.uncompSize); (* uncompressed size *)
Files.ReadInt(r, nameLen); (* filename length *)
Files.ReadInt(r, extraLen); (* extra field length *)
Files.ReadInt(r, commentLen); (* file comment length *)
Files.ReadInt(r, intDummy); (* disk number start *)
Files.ReadInt(r, ent.intFileAttr); (* internal file attributes *)
Files.ReadLInt(r, ent.extFileAttr); (* external file attributes *)
Files.ReadLInt(r, ent.offsetLocal); (* relative offset of local header *)
Files.ReadBytes(r, ent.name, nameLen); (* filename *)
IF extraLen # 0 THEN
NEW(ent.extraField, extraLen);
Files.ReadBytes(r, ent.extraField^, extraLen) (* extra field *)
END;
IF commentLen > 0 THEN
NEW(ent.comment, commentLen);
Files.ReadBytes(r, ent.comment^, commentLen) (* file comment *)
END;
(* read extra field length in the local file header (can be different from extra field length stored in the file header...) *)
longDummy := Files.Pos(r); (* store actual position of file reader *)
Files.Set(r, Files.Base(r), ent.offsetLocal + 28); (* set r to position of extra field length in local file header *)
Files.ReadInt(r, extraLen); (* extra field length *)
ent.offsetFileData := ent.offsetLocal + 30 + nameLen + extraLen; (* compute offset of file data *)
Files.Set(r, Files.Base(r), longDummy); (* set position of file reader to previous position *)
IF r.eof THEN (* if file is a zip-archive, r is not at end of file *)
ent := NIL
END
END;
RETURN ent;
END ReadEntry;
(* Writes a local file header *)
PROCEDURE WriteLocalFileHeader(ent: Entry; VAR r: Files.Rider);
BEGIN
Files.WriteLInt(r, LocalFileHeaderSignature); (* local file header signature *)
Files.WriteInt(r, CompatibleVersions * 10); (* version needed to extract *)
Files.WriteInt(r, ent.genPurpBitFlag); (* general purpose bit flag *)
Files.WriteInt(r, ent.method); (* compression method *)
Files.WriteInt(r, OberonToDosTime(ent.time)); (* last mod file time *)
Files.WriteInt(r, OberonToDosDate(ent.date)); (* last mod file date *)
Files.WriteLInt(r, ent.crc32); (* crc-32 *)
Files.WriteLInt(r, ent.compSize); (* compressed size *)
Files.WriteLInt(r, ent.uncompSize); (* uncompressed size *)
Files.WriteInt(r, SHORT(StringLength(ent.name))); (* filename length *)
IF ent.extraField # NIL THEN
Files.WriteInt(r, SHORT(LEN(ent.extraField^))) (* extra field length *)
ELSE
Files.WriteInt(r, 0)
END;
Files.WriteBytes(r, ent.name, StringLength(ent.name)); (* filename *)
IF ent.extraField # NIL THEN
Files.WriteBytes(r, ent.extraField^, LEN(ent.extraField^)) (* extra field *)
END
END WriteLocalFileHeader;
(* Writes file header in central directory, updates ent.offsetCentralDir *)
PROCEDURE WriteFileHeader(ent: Entry; VAR r: Files.Rider);
BEGIN
ent.offsetCentralDir := Files.Pos(r);
Files.WriteLInt(r, CentralFileHeaderSignature); (* central file header signature *)
Files.WriteInt(r, CompatibleVersions * 10); (* version made by *)
Files.WriteInt(r, CompatibleVersions * 10); (* version needed to extract *)
Files.WriteInt(r, ent.genPurpBitFlag); (* general purpose bit flag *)
Files.WriteInt(r, ent.method); (* compression method *)
Files.WriteInt(r, OberonToDosTime(ent.time)); (* last mod file time *)
Files.WriteInt(r, OberonToDosDate(ent.date)); (* last mod file date *)
Files.WriteLInt(r, ent.crc32); (* crc-32 *)
Files.WriteLInt(r, ent.compSize); (* compressed size *)
Files.WriteLInt(r, ent.uncompSize); (* uncompressed size *)
Files.WriteInt(r, SHORT(StringLength(ent.name))); (* filename length *)
IF ent.extraField = NIL THEN
Files.WriteInt(r, 0)
ELSE
Files.WriteInt(r, SHORT(LEN(ent.extraField^))); (* extra field length *)
END;
IF ent.comment = NIL THEN
Files.WriteInt(r, 0)
ELSE
Files.WriteInt(r, SHORT(LEN(ent.comment^))); (* file comment length *)
END;
Files.WriteInt(r, 0); (* disk number start *)
Files.WriteInt(r, ent.intFileAttr); (* internal file attributes *)
Files.WriteLInt(r, ent.extFileAttr); (* external file attributes *)
Files.WriteLInt(r, ent.offsetLocal); (* relative offset of local header *)
Files.WriteBytes(r, ent.name, StringLength(ent.name)); (* filename *)
IF ent.extraField # NIL THEN
Files.WriteBytes(r, ent.extraField^, LEN(ent.extraField^)) (* extra field *)
END;
IF ent.comment # NIL THEN
Files.WriteBytes(r, ent.comment^, LEN(ent.comment^)) (* file comment *)
END
END WriteFileHeader;
(* Writes end of central directory record *)
PROCEDURE WriteEndOfCentDir(arc: Archive; VAR r: Files.Rider);
VAR
size: LONGINT;
BEGIN
Files.WriteLInt(r, EndOfCentralDirSignature); (* end of central dir signature *)
Files.WriteInt(r, 0); (* number of this disk *)
Files.WriteInt(r, 0); (* number of the disk with the start of the central directory *)
Files.WriteInt(r, arc.nofEntries); (* total number of entries in the central dir on this disk *)
Files.WriteInt(r, arc.nofEntries); (* total number of entries in the central dir *)
IF arc.firstEntry # NIL THEN
Files.WriteLInt(r, arc.offset - arc.firstEntry.offsetCentralDir) (* size of the central directory (without end of central dir record) *)
ELSE
Files.WriteLInt(r, 0)
END;
IF arc.firstEntry = NIL THEN
Files.WriteLInt(r, arc.offset) (* offset of start of central directory with respect to the starting disk number *)
ELSE
Files.WriteLInt(r, arc.firstEntry.offsetCentralDir) (* offset of start of central directory with respect to the starting disk number *)
END;
IF arc.comment = NIL THEN
Files.WriteInt(r, 0) (* zipfile comment length *)
ELSE
Files.WriteInt(r, SHORT(LEN(arc.comment^))); (* zipfile comment length *)
Files.WriteBytes(r, arc.comment^, LEN(arc.comment^)) (* zipfile comment *)
END
END WriteEndOfCentDir;
(* Writes central directory + end of central directory record, updates arc.offset and offsetCentralDir of entries *)
PROCEDURE WriteCentralDirectory(arc: Archive; VAR r: Files.Rider);
VAR
ent: Entry;
BEGIN
ent := arc.firstEntry;
WHILE ent # NIL DO
WriteFileHeader(ent, r);
ent := ent.next
END;
arc.offset := Files.Pos(r);
WriteEndOfCentDir(arc, r)
END WriteCentralDirectory;
(** Returns an Archive data structure corresponding to the specified zipfile;
possible results:
- Ok: operation was successful
- FileError: file with specified name does not exist
- NotZipArchiveError: file is not a correct zipfile **)
PROCEDURE OpenArchive*(name: ARRAY OF CHAR; VAR res: LONGINT): Archive;
VAR
arc: Archive;
ent: Entry;
f: Files.File;
r: Files.Rider;
longDummy: LONGINT;
intDummy: INTEGER;
BEGIN
res := Ok;
f := Files.Old(name);
IF f = NIL THEN
res := FileError
ELSIF Files.Length(f) < 22 THEN
res := NotZipArchiveError
ELSE
longDummy := 0;
Files.Set(r, f, Files.Length(f) - 17);
WHILE (longDummy # EndOfCentralDirSignature) & (Files.Pos(r) > 4) DO
Files.Set(r, f, Files.Pos(r) - 5);
Files.ReadLInt(r, longDummy)
END;
IF longDummy # EndOfCentralDirSignature THEN
res := NotZipArchiveError
ELSE
NEW(arc);
arc.file := f;
arc.offset := Files.Pos(r) - 4;
Files.ReadInt(r, intDummy); (* number of this disk *)
Files.ReadInt(r, intDummy); (* number of the disk with the start of the central directory *)
Files.ReadInt(r, intDummy); (* total number of entries in the central dir on this disk *)
Files.ReadInt(r, arc.nofEntries); (* total number of entries in the central dir *)
Files.ReadLInt(r, longDummy); (* size of the central directory *)
Files.ReadLInt(r, longDummy); (* offset of start of central directory with respect to the starting disk number *)
Files.ReadInt(r, intDummy); (* zipfile comment length *)
IF intDummy # 0 THEN
NEW(arc.comment, intDummy);
Files.ReadBytes(r, arc.comment^, intDummy) (* zipfile comment *)
END;
IF Files.Pos(r) # Files.Length(f) THEN
res := NotZipArchiveError;
arc := NIL
ELSE
Files.Set(r, f, longDummy); (* set r on position of first file header in central dir *)
arc.firstEntry := ReadEntry(r); arc.lastEntry := arc.firstEntry;
ent := arc.firstEntry; intDummy := 0;
WHILE ent # NIL DO
arc.lastEntry := ent; INC(intDummy); (* count number of entries *)
ent.next := ReadEntry(r);
ent := ent.next
END;
IF intDummy # arc.nofEntries THEN
res := NotZipArchiveError;
arc := NIL
END
END;
Files.Close(f)
END
END;
RETURN arc
END OpenArchive;
(** Returns an Archive that corresponds to a file with specified name;
if there is already a zip-file with the same name, this already existing archive is returned;
possible results: cf. OpenArchive **)
PROCEDURE CreateArchive*(VAR name: ARRAY OF CHAR; VAR res: LONGINT): Archive;
VAR
f: Files.File;
r: Files.Rider;
arc: Archive;
BEGIN
f := Files.Old(name);
IF f # NIL THEN
RETURN OpenArchive(name, res)
ELSE
f := Files.New(name);
NEW(arc);
arc.file := f;
arc.nofEntries := 0;
arc.offset := 0;
Files.Set(r, f, 0);
WriteEndOfCentDir(arc, r);
Files.Register(f);
res := Ok;
RETURN arc
END
END CreateArchive;
(** Returns the first entry of the Archive arc (NIL if there is no Entry) **)
PROCEDURE FirstEntry*(arc: Archive): Entry;
BEGIN
IF arc = NIL THEN
RETURN NIL
ELSE
RETURN arc.firstEntry
END
END FirstEntry;
(** Returns the next Entry after ent **)
PROCEDURE NextEntry*(ent: Entry): Entry;
BEGIN
RETURN ent.next
END NextEntry;
(** Returns the Entry that corresponds to the file with the specified name and that is stored in the Archive arc;
possible results:
- Ok: Operation was successful
- NotZipArchiveError: arc is not a valid Archive
- EntryNotFound: no Entry corresponding to name was found **)
PROCEDURE GetEntry*(arc: Archive; VAR name: ARRAY OF CHAR; VAR res: LONGINT): Entry;
VAR
ent: Entry;
BEGIN
IF arc = NIL THEN
res := NotZipArchiveError
ELSE
ent := arc.firstEntry;
WHILE (ent # NIL) & (ent.name # name) DO
ent := ent.next
END;
IF ent = NIL THEN
res := EntryNotFound
ELSE
res := Ok
END
END;
RETURN ent
END GetEntry;
(** Uncompresses and writes the data of Entry ent to Files.Rider dst;
possible results:
- Ok: Data extracted
- NotZipArchiveError: arc is not a valid zip-archive
- EntryNotFound: ent is not an Entry of arc
- NotSupportedError: data of ent are encrypted or compression method is not supported
- DataError: zipfile is corrupted
- BadName: entry has a bad file name **)
PROCEDURE ExtractEntry*(arc: Archive; ent: Entry; VAR dst: Files.Rider; VAR res: LONGINT);
VAR
src: Files.Rider; crc32: LONGINT;
BEGIN
IF arc = NIL THEN
res := NotZipArchiveError
ELSIF Files.Base(dst) = NIL THEN
res := BadName
ELSIF (ent = NIL) OR (ent # GetEntry(arc, ent.name, res)) THEN
res := EntryNotFound
ELSIF ~(ent.method IN SupportedCompMethods) OR (ent.support > Supported) THEN
res := NotSupportedError
ELSE
CASE ent.method OF
| Stored:
Files.Set(src, arc.file, ent.offsetFileData);
Copy(src, dst, ent.uncompSize, TRUE, crc32);
IF crc32 = ent.crc32 THEN
res := Ok
ELSE
res := DataError
END
| Deflated:
Files.Set(src, arc.file, ent.offsetFileData);
ZlibReaders.Uncompress(src, dst, crc32, res);
IF (res = ZlibReaders.Ok) & (crc32 = ent.crc32) THEN
res := Ok
ELSE
res := DataError
END
END;
IF res = Ok THEN
Files.Close(Files.Base(dst));
END
END
END ExtractEntry;
(** Reads and compresses len bytes from Files.Rider src with specified level and strategy
and writes them to a new Entry in the Archive arc;
possible results:
- Ok: file was added to arc
- NotZipArchiveError: arc is not a valid zip-archive
- EntryAlreadyExists: there is already an Entry in arc with the same name
- DataError: error during compression
- BadName: src is not based on a valid file **)
PROCEDURE AddEntry*(arc: Archive; VAR name: ARRAY OF CHAR; VAR src: Files.Rider; len: LONGINT; level, strategy: SHORTINT; VAR res: LONGINT);
VAR
dst: Files.Rider; ent: Entry; start: LONGINT;
BEGIN
IF arc = NIL THEN
res := NotZipArchiveError
ELSIF Files.Base(src) = NIL THEN
res := BadName
ELSIF (GetEntry(arc, name, res) # NIL) & (res = Ok) THEN
res := EntryAlreadyExists
ELSE
NEW(ent);
COPY(name, ent.name);
ent.genPurpBitFlag := 0;
IF level = NoCompression THEN
ent.method := Stored
ELSE
ent.method := Deflated
END;
Files.GetDate(Files.Base(src), ent.time, ent.date);
ent.uncompSize := len;
ent.intFileAttr := 0;
ent.extFileAttr := 0;
ent.comment := NIL;
ent.support := Supported;
ent.dataDescriptor := FALSE;
IF arc.firstEntry # NIL THEN
ent.offsetLocal := arc.firstEntry.offsetCentralDir
ELSE
ent.offsetLocal := 0
END;
Files.Set(dst, arc.file, ent.offsetLocal);
WriteLocalFileHeader(ent, dst);
ent.offsetFileData := Files.Pos(dst);
Files.Close(arc.file);
start := Files.Pos(src);
IF level = 0 THEN
Copy(src, dst, len, TRUE, ent.crc32);
ent.compSize := len;
res := Ok
ELSE
ZlibWriters.Compress(src, dst, len, ent.compSize, level, strategy, ent.crc32, res);
IF res # ZlibWriters.Ok THEN
res := DataError
ELSE
res := Ok
END
END;
IF res = Ok THEN
ent.uncompSize := Files.Pos(src) - start;
Files.Close(arc.file);
Files.Set(dst, arc.file, ent.offsetLocal + 14);
Files.WriteLInt(dst, ent.crc32);
Files.WriteLInt(dst, ent.compSize);
Files.Close(arc.file);
IF arc.lastEntry # NIL THEN
arc.lastEntry.next := ent
ELSE (* archive has no entries *)
arc.firstEntry := ent
END;
arc.lastEntry := ent;
INC(arc.nofEntries);
Files.Set(dst, arc.file, ent.offsetFileData + ent.compSize);
WriteCentralDirectory(arc, dst);
Files.Close(arc.file);
res := Ok
END;
END
END AddEntry;
(** Deletes Entry ent from Archive arc;
Possible results:
- Ok: ent was deleted, ent is set to NIL
- NotZipArchiveError: arc is not a valid zip-archive
- EntryNotFound: ent is not an Entry of Archive arc **)
PROCEDURE DeleteEntry*(arc: Archive; VAR ent: Entry; VAR res: LONGINT);
CONST
BufSize = 4000H;
VAR
f: Files.File; r1, r2: Files.Rider;
ent2: Entry;
arcname: ARRAY 256 OF CHAR;
buf: ARRAY BufSize OF CHAR;
offset, diff: LONGINT;
BEGIN
IF arc = NIL THEN
res := NotZipArchiveError
ELSIF arc.firstEntry = NIL THEN
res := EntryNotFound
ELSIF arc.firstEntry = ent THEN
offset := arc.firstEntry.offsetLocal; (* arc.firstEntry.offsetLocal = 0 *)
IF arc.lastEntry = arc.firstEntry THEN
arc.lastEntry := arc.firstEntry.next (* = NIL *)
END;
arc.firstEntry := arc.firstEntry.next;
ent2 := arc.firstEntry;
res := Ok
ELSE
ent2 := arc.firstEntry;
WHILE (ent2.next # NIL) & (ent2.next # ent) DO
ent2 := ent2.next
END;
IF ent2.next = NIL THEN
res := EntryNotFound
ELSE
IF arc.lastEntry = ent2.next THEN
arc.lastEntry := ent2
END;
offset := ent2.next.offsetLocal;
ent2.next := ent2.next.next;
ent2 := ent2.next;
res := Ok
END
END;
IF res = Ok THEN
Files.GetName(arc.file, arcname);
f := Files.New(arcname);
Files.Set(r2, f, 0);
Files.Set(r1, arc.file, 0);
Copy(r1, r2, offset, FALSE, diff); (* no crc 32-checksum is computed -> diff used as dummy *)
Files.Close(f);
ASSERT(ent2 = ent.next);
IF ent2 # NIL THEN
Files.Set(r1, arc.file, ent2.offsetLocal);
Copy(r1, r2, arc.firstEntry.offsetCentralDir - ent2.offsetLocal, FALSE, diff); (* arc.firstEntry can not be NIL because ent # NIL *)
Files.Close(f);
diff := ent2.offsetLocal - offset
ELSE
diff := arc.offset - offset
END;
WHILE (ent2 # NIL) DO (* update offsets of entries *)
DEC(ent2.offsetLocal, diff); DEC(ent2.offsetFileData, diff); DEC(ent2.offsetCentralDir, diff);
ent2 := ent2.next
END;
DEC(arc.offset, diff);
DEC(arc.nofEntries);
WriteCentralDirectory(arc, r2);
Files.Register(f); arc.file := f; ent := NIL
END
END DeleteEntry;
(** open a Reader to read uncompressed data from a zip entry directly to memory **)
PROCEDURE OpenReader*(arc: Archive; ent: Entry): Reader;
VAR
dummyBuf: ARRAY 1 OF CHAR;
fr: Files.Rider;
r: Reader;
ur: UncompReader;
dr: DefReader;
BEGIN
IF ent.support = Supported THEN
IF ent.method = Stored THEN
NEW(ur);
ur.crc32 := Zlib.CRC32(0, dummyBuf, -1, -1);
Files.Set(ur.fr, arc.file, ent.offsetFileData);
r := ur;
r.open := TRUE;
r.res := Ok
ELSIF ent.method = Deflated THEN
Files.Set(fr, arc.file, ent.offsetFileData);
NEW(dr);
ZlibReaders.Open(dr.zr, FALSE, fr);
dr.res := dr.zr.res;
r := dr;
r.open := TRUE
ELSE
NEW(r);
r.open := FALSE;
r.res := NotSupportedError
END;
ELSE
NEW(r);
r.open := FALSE;
r.res := NotSupportedError
END;
r.ent := ent;
RETURN r;
END OpenReader;
(** read len bytes of uncompressed data into buf[offset] and return number of bytes actually read; Reader must be opened **)
PROCEDURE ReadBytes*(r: Reader; VAR buf: ARRAY OF CHAR; offset, len: LONGINT; VAR read: LONGINT);
VAR
bufp: POINTER TO ARRAY OF CHAR; i: LONGINT;
BEGIN
IF r.open THEN
IF r IS UncompReader THEN
IF offset = 0 THEN
Files.ReadBytes(r(UncompReader).fr, buf, len);
ELSE
NEW(bufp, len);
Files.ReadBytes(r(UncompReader).fr, bufp^, len);
FOR i := 0 TO len - 1 DO
buf[offset + i] := bufp[i]
END
END;
read := len - r(UncompReader).fr.res;
r(UncompReader).crc32 := Zlib.CRC32(r(UncompReader).crc32, buf, offset, read)
ELSIF r IS DefReader THEN
ZlibReaders.ReadBytes(r(DefReader).zr, buf, offset, len, read);
r.res := r(DefReader).zr.res
END
ELSE
r.res := ReaderError
END
END ReadBytes;
(** read decompressed byte **)
PROCEDURE Read*(r: Reader; VAR ch: CHAR);
VAR
buf: ARRAY 1 OF CHAR; read: LONGINT;
BEGIN
ReadBytes(r, buf, 0, 1, read);
ch := buf[0];
END Read;
(** close Reader **)
PROCEDURE Close*(r: Reader);
BEGIN
IF r.open THEN
IF r IS UncompReader THEN
IF r(UncompReader).crc32 # r.ent.crc32 THEN
r.res := DataError
ELSE
r.res := Ok
END
ELSIF r IS DefReader THEN
ZlibReaders.Close(r(DefReader).zr);
IF r(DefReader).zr.crc32 # r.ent.crc32 THEN
r.res := DataError
ELSE
r.res := r(DefReader).zr.res
END
ELSE
r.res := ReaderError
END;
r.open := FALSE
ELSE
r.res := ReaderError
END
END Close;
END ethZip.

160
src/library/s3/ethZlib.Mod Normal file
View file

@ -0,0 +1,160 @@
(* ETH Oberon, Copyright 2001 ETH Zuerich Institut fuer Computersysteme, ETH Zentrum, CH-8092 Zuerich.
Refer to the "General ETH Oberon System Source License" contract available at: http://www.oberon.ethz.ch/ *)
MODULE ethZlib; (** Stefan Walthert **)
IMPORT
SYSTEM;
CONST
(** Result codes for compression/decompression functions **)
(** regular termination **)
Ok* = 0; (** some progress has been made (more input processed or more output produced **)
StreamEnd* = 1; (** all input has been consumed and all output has been produced (only when flush is set to Finish) **)
NeedDict* = 2;
(** errors **)
StreamError* = -2; (** stream state was inconsistent (for example stream.in.next or stream.out.next was 0) **)
DataError* = -3;
MemError* = -4;
BufError* = -5; (** no progress is possible (for example stream.in.avail or stream.out.avail was zero) **)
(** Flush values (Flushing may degrade compression for some compression algorithms and so it should be used only
when necessary) **)
NoFlush* = 0;
PartialFlush* = 1; (** will be removed, use SyncFlush instead **)
SyncFlush* = 2; (** pending output is flushed to the output buffer and the output is aligned on a byte boundary,
so that the compressor/decompressor can get all input data available so far. (In particular stream.in.avail
is zero after the call if enough output space has been provided before the call.) **)
FullFlush* = 3; (** all output is flushed as with SyncFlush, and the compression state is reset so that
decompression can restart from this point if previous compressed data has been damaged of if random access
is desired. Using FullFlush too often can seriously degrade the compression. **)
Finish* = 4; (** pending input is processed, pending output is flushed.
If Deflate/Inflate returns with StreamEnd, there was enough space.
If Deflate/Inflate returns with Ok, this function must be called again with Finish and more output space
(updated stream.out.avail) but no more input data, until it returns with StreamEnd or an error.
After Deflate has returned StreamEnd, the only possible operations on the stream are Reset or Close
Finish can be used immediately after Open if all the compression/decompression is to be done in a single step.
In case of compression, the out-Buffer (respectively stream.out.avail) must be at least 0.1% larger than the
in-Buffer (respectively stream.in.avail) plus 12 bytes. **)
(** compression levels **)
DefaultCompression* = -1;
NoCompression* = 0;
BestSpeed* = 1;
BestCompression* = 9;
(** compression strategies; the strategy only affects the compression ratio but not the correctness of the
compressed output even if it is not set appropriately **)
DefaultStrategy* = 0; (** for normal data **)
Filtered* = 1; (** for data produced by a filter (or predictor); filtered data consists mostly of small values with a
somewhat random distribution. In this case, the compression algorithm is tuned to compress them better.
The effect of Filtered is to force more Huffman coding and less string matching; it is somewhat intermediate
between DefaultStrategy and HuffmanOnly. **)
HuffmanOnly* = 2; (** to force Huffman encoding only (no string match) **)
(** data type **)
Binary* = 0;
Ascii* = 1;
Unknown* = 2;
DeflateMethod* = 8;
VAR
CRCTable: ARRAY 256 OF LONGINT;
PROCEDURE Adler32*(adler: LONGINT; VAR buf: ARRAY OF CHAR; offset, len: LONGINT): LONGINT;
CONST
base = 65521; (* largest prim smaller than 65536 *)
nmax = 5552; (* largest n such that 255n(n + 1) / 2 + (n + 1)(base - 1) <= 2^32 - 1 *)
VAR
s1, s2, k, offset0, len0: LONGINT;
BEGIN
offset0 := offset; len0 := len;
IF len < 0 THEN
RETURN 1
ELSE
s1 := adler MOD 10000H;
s2 := SYSTEM.LSH(adler, -16) MOD 10000H;
WHILE len > 0 DO
IF len < nmax THEN k := len ELSE k := nmax END;
DEC(len, k);
REPEAT
INC(s1, LONG(ORD(buf[offset])));
INC(s2, s1);
INC(offset);
DEC(k)
UNTIL k = 0;
s1 := s1 MOD base;
s2 := s2 MOD base
END;
RETURN SYSTEM.LSH(s2, 16) + s1
END
END Adler32;
(** Generate a table for a byte-wise 32-bit CRC calculation on the polynomial:
x^32+x^26+x^23+x^22+x^16+x^12+x^11+x^10+x^8+x^7+x^5+x^4+x^2+x+1.
Polynomials over GF(2) are represented in binary, one bit per coefficient,
with the lowest powers in the most significant bit. Then adding polynomials
is just exclusive-or, and multiplying a polynomial by x is a right shift by
one. If we call the above polynomial p, and represent a byte as the
polynomial q, also with the lowest power in the most significant bit (so the
byte 0xb1 is the polynomial x^7+x^3+x+1), then the CRC is (q*x^32) mod p,
where a mod b means the remainder after dividing a by b.
This calculation is done using the shift-register method of multiplying and
taking the remainder. The register is initialized to zero, and for each
incoming bit, x^32 is added mod p to the register if the bit is a one (where
x^32 mod p is p+x^32 = x^26+...+1), and the register is multiplied mod p by
x (which is shifting right by one and adding x^32 mod p if the bit shifted
out is a one). We start with the highest power (least significant bit) of
q and repeat for all eight bits of q.
The table is simply the CRC of all possible eight bit values. This is all
the information needed to generate CRC's on data a byte at a time for all
combinations of CRC register values and incoming bytes. **)
PROCEDURE InitCRCTable*();
CONST
poly = 0EDB88320H;
VAR
n, c, k: LONGINT;
BEGIN
FOR n := 0 TO 255 DO
c := n;
FOR k := 0 TO 7 DO
IF ODD(c) THEN c := SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, poly)/SYSTEM.VAL(SET, SYSTEM.LSH(c, -1)))
ELSE c := SYSTEM.LSH(c, -1)
END
END;
CRCTable[n] := c
END
END InitCRCTable;
PROCEDURE CRC32*(crc: LONGINT; VAR buf: ARRAY OF CHAR; offset, len: LONGINT): LONGINT;
VAR idx: LONGINT;
BEGIN
IF offset < 0 THEN
crc := 0
ELSE
crc := SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, crc)/{0..31});
WHILE len > 0 DO
idx := SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, crc)/SYSTEM.VAL(SET, LONG(ORD(buf[offset])))) MOD 100H;
crc := SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, CRCTable[idx])/SYSTEM.VAL(SET, SYSTEM.LSH(crc, -8)));
DEC(len); INC(offset)
END;
crc := SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, crc)/{0..31})
END;
RETURN crc
END CRC32;
BEGIN
InitCRCTable();
END ethZlib.

116
src/library/s3/ethZlibBuffers.Mod Normal file
View file

@ -0,0 +1,116 @@
(* ETH Oberon, Copyright 2001 ETH Zuerich Institut fuer Computersysteme, ETH Zentrum, CH-8092 Zuerich.
Refer to the "General ETH Oberon System Source License" contract available at: http://www.oberon.ethz.ch/ *)
MODULE ethZlibBuffers; (** Stefan Walthert **)
IMPORT
SYSTEM;
(*
should be portable even if SYSTEM is imported:
- PUT and GET only with byte sized operands
- no overlapping MOVEs (unless malignant client passes buffer memory to buffer operations)
*)
TYPE
(** input/output buffer **)
Address = LONGINT;
Buffer* = RECORD
avail-: LONGINT; (** number of bytes that can be produced/consumed **)
size-: LONGINT; (** total number of bytes in buffer memory **)
totalOut-, totalIn-: LONGINT; (** total number of bytes produced/consumed **)
next: Address; (* address of next byte to produce/consume **)
adr: Address; (* buffer memory *)
END;
(** set buf.totalIn and buf.totalOut to zero **)
PROCEDURE Reset*(VAR buf: Buffer);
BEGIN
buf.totalIn := 0; buf.totalOut := 0
END Reset;
(** initialize buffer on memory in client space **)
PROCEDURE Init* (VAR buf: Buffer; VAR mem: ARRAY OF CHAR; offset, size, avail: LONGINT);
BEGIN
ASSERT((0 <= offset) & (0 < size) & (offset + size <= LEN(mem)), 100);
ASSERT((0 <= avail) & (avail <= size),101);
buf.avail := avail; buf.size := size; buf.adr := SYSTEM.ADR(mem[offset]); buf.next := buf.adr;
END Init;
(** read byte from (input) buffer **)
PROCEDURE Read* (VAR buf: Buffer; VAR ch: CHAR);
BEGIN
ASSERT(buf.avail > 0, 100);
SYSTEM.GET(buf.next, ch);
INC(buf.next); DEC(buf.avail); INC(buf.totalIn)
END Read;
(** read len bytes from (input) buffer **)
PROCEDURE ReadBytes* (VAR buf: Buffer; VAR dst: ARRAY OF CHAR; offset, len: LONGINT);
BEGIN
ASSERT((0 <= offset) & (0 < len) & (offset + len <= LEN(dst)) & (len <= buf.avail), 100);
SYSTEM.MOVE(buf.next, SYSTEM.ADR(dst[offset]), len);
INC(buf.next, len); DEC(buf.avail, len); INC(buf.totalIn, len)
END ReadBytes;
(** write byte into (output) buffer **)
PROCEDURE Write* (VAR buf: Buffer; ch: CHAR);
BEGIN
ASSERT(buf.avail > 0, 100);
SYSTEM.PUT(buf.next, ch);
INC(buf.next); DEC(buf.avail); INC(buf.totalOut)
END Write;
(** write len bytes into (output) buffer **)
PROCEDURE WriteBytes* (VAR buf: Buffer; VAR src: ARRAY OF CHAR; offset, len: LONGINT);
BEGIN
ASSERT((0 <= offset) & (0 < len) & (offset + len <= LEN(src)) & (len <= buf.avail), 100);
SYSTEM.MOVE(SYSTEM.ADR(src[offset]), buf.next, len);
INC(buf.next, len); DEC(buf.avail, len); INC(buf.totalOut, len)
END WriteBytes;
(** rewind previously empty input buffer to first position after it has been filled with new input **)
PROCEDURE Rewind* (VAR buf: Buffer; avail: LONGINT);
BEGIN
ASSERT(buf.avail = 0, 100);
ASSERT((0 <= avail) & (avail <= buf.size), 101);
buf.next := buf.adr; buf.avail := avail
END Rewind;
(** move position of next read for -offset bytes **)
PROCEDURE Reread* (VAR buf: Buffer; offset: LONGINT);
BEGIN
ASSERT((0 <= offset) & (buf.avail + offset <= buf.size), 101);
DEC(buf.next, offset); INC(buf.avail, offset)
END Reread;
(** restart writing at starting position of output buffer after it has been emptied **)
PROCEDURE Rewrite* (VAR buf: Buffer);
BEGIN
buf.next := buf.adr; buf.avail := buf.size
END Rewrite;
(** fill input buffer with new bytes to consume **)
PROCEDURE Fill* (VAR buf: Buffer; VAR src: ARRAY OF CHAR; offset, size: LONGINT);
BEGIN
ASSERT((0 <= offset) & (0 < size) & (offset + size <= LEN(src)), 100);
ASSERT(buf.avail + size <= buf.size, 101);
IF buf.avail # 0 THEN
SYSTEM.MOVE(buf.next, buf.adr, buf.avail)
END;
buf.next := buf.adr + buf.avail;
SYSTEM.MOVE(SYSTEM.ADR(src[offset]), buf.next, size);
INC(buf.avail, size)
END Fill;
(** extract bytes from output buffer to make room for new bytes **)
PROCEDURE Drain* (VAR buf: Buffer; VAR dst: ARRAY OF CHAR; offset, size: LONGINT);
BEGIN
ASSERT((0 <= offset) & (0 < size) & (offset + size <= LEN(dst)), 100);
ASSERT(buf.avail + size <= buf.size, 101); (* can't consume more than is in buffer *)
SYSTEM.MOVE(buf.adr, SYSTEM.ADR(dst[offset]), size);
SYSTEM.MOVE(buf.adr + size, buf.adr, buf.size - buf.avail - size);
INC(buf.avail, size); DEC(buf.next, size);
END Drain;
END ethZlibBuffers.

1492
src/library/s3/ethZlibDeflate.Mod Normal file
View file

File diff suppressed because it is too large Load diff

1230
src/library/s3/ethZlibInflate.Mod Normal file
View file

File diff suppressed because it is too large Load diff

113
src/library/s3/ethZlibReaders.Mod Normal file
View file

@ -0,0 +1,113 @@
(* ETH Oberon, Copyright 2001 ETH Zuerich Institut fuer Computersysteme, ETH Zentrum, CH-8092 Zuerich.
Refer to the "General ETH Oberon System Source License" contract available at: http://www.oberon.ethz.ch/ *)
MODULE ethZlibReaders; (** Stefan Walthert **)
IMPORT
Files, Zlib := ethZlib, ZlibBuffers := ethZlibBuffers, ZlibInflate := ethZlibInflate;
CONST
(** result codes **)
Ok* = ZlibInflate.Ok; StreamEnd* = ZlibInflate.StreamEnd;
FileError* = -1; StreamError* = ZlibInflate.StreamError; DataError* = ZlibInflate.DataError; BufError* = ZlibInflate.BufError;
BufSize = 4000H;
TYPE
(** structure for reading from a file with deflated data **)
Reader* = RECORD
res-: LONGINT; (** current stream state **)
crc32-: LONGINT; (* crc32 of uncompressed data *)
wrapper-: BOOLEAN; (** if set, a zlib header and a checksum are present **)
eof: BOOLEAN; (* set if at end of input file and input buffer empty *)
r: Files.Rider;
in: POINTER TO ARRAY BufSize OF CHAR; (* input buffer space *)
s: ZlibInflate.Stream; (* decompression stream *)
END;
(** open reader on a Rider for input; is wrapper is not set, no zlib header and no checksum are present **)
PROCEDURE Open*(VAR r: Reader; wrapper: BOOLEAN; VAR fr: Files.Rider);
BEGIN
r.wrapper := wrapper;
r.eof := fr.eof;
ZlibInflate.Open(r.s, wrapper);
IF r.s.res.code = ZlibInflate.Ok THEN
NEW(r.in); ZlibBuffers.Init(r.s.in, r.in^, 0, BufSize, 0);
r.crc32 := Zlib.CRC32(0, r.in^, -1, -1);
r.r := fr;
r.res := Ok
ELSE
r.res := r.s.res.code
END
END Open;
(** read specified number of bytes into buffer and return number of bytes actually read **)
PROCEDURE ReadBytes*(VAR r: Reader; VAR buf: ARRAY OF CHAR; offset, len: LONGINT; VAR read: LONGINT);
BEGIN
ASSERT((0 <= offset) & (0 <= len) & (offset + len <= LEN(buf)), 100);
IF ~r.s.open THEN
r.res := StreamError; read := 0
ELSIF (r.res < Ok) OR (r.res = StreamEnd) OR (len <= 0) THEN
read := 0
ELSE
ZlibBuffers.Init(r.s.out, buf, offset, len, len);
WHILE (r.s.out.avail # 0) & (r.res = Ok) DO
IF r.s.in.avail = 0 THEN
Files.ReadBytes(r.r, r.in^, BufSize);
ZlibBuffers.Rewind(r.s.in, BufSize - r.r.res);
IF r.s.in.avail = 0 THEN
r.eof := TRUE;
IF r.r.res < 0 THEN
r.res := FileError
END
END
END;
IF r.res = Ok THEN
ZlibInflate.Inflate(r.s, ZlibInflate.NoFlush);
r.res := r.s.res.code
END
END;
r.crc32 := Zlib.CRC32(r.crc32, buf, offset, len - r.s.out.avail);
read := len - r.s.out.avail
END
END ReadBytes;
(** read decompressed byte **)
PROCEDURE Read*(VAR r: Reader; VAR ch: CHAR);
VAR
buf: ARRAY 1 OF CHAR; read: LONGINT;
BEGIN
ReadBytes(r, buf, 0, 1, read);
ch := buf[0]
END Read;
(** close reader **)
PROCEDURE Close*(VAR r: Reader);
BEGIN
ZlibInflate.Close(r.s);
r.in := NIL;
IF r.res = StreamEnd THEN
r.res := Ok
END
END Close;
(** uncompress deflated data from scr and write them to dst **)
PROCEDURE Uncompress*(VAR src, dst: Files.Rider; VAR crc32: LONGINT; VAR res: LONGINT);
VAR
r: Reader; buf: ARRAY BufSize OF CHAR; read: LONGINT;
BEGIN
Open(r, FALSE, src);
IF r.res = Ok THEN
REPEAT
ReadBytes(r, buf, 0, BufSize, read);
Files.WriteBytes(dst, buf, read)
UNTIL (r.res # Ok) OR (read = 0);
crc32 := r.crc32;
Close(r)
END;
res := r.res
END Uncompress;
END ethZlibReaders.

161
src/library/s3/ethZlibWriters.Mod Normal file
View file

@ -0,0 +1,161 @@
(* ETH Oberon, Copyright 2001 ETH Zuerich Institut fuer Computersysteme, ETH Zentrum, CH-8092 Zuerich.
Refer to the "General ETH Oberon System Source License" contract available at: http://www.oberon.ethz.ch/ *)
MODULE ethZlibWriters; (** Stefan Walthert **)
IMPORT
Files, Zlib := ethZlib, ZlibBuffers := ethZlibBuffers, ZlibDeflate := ethZlibDeflate;
CONST
(** result codes **)
Ok* = ZlibDeflate.Ok; StreamEnd* = ZlibDeflate.StreamEnd;
StreamError* = ZlibDeflate.StreamError; DataError* = ZlibDeflate.DataError; BufError* = ZlibDeflate.BufError;
(** flush values **)
NoFlush* = ZlibDeflate.NoFlush;
SyncFlush* = ZlibDeflate.SyncFlush;
FullFlush* = ZlibDeflate.FullFlush;
(** compression levels **)
DefaultCompression* = ZlibDeflate.DefaultCompression; NoCompression* = ZlibDeflate.NoCompression;
BestSpeed* = ZlibDeflate.BestSpeed; BestCompression* = ZlibDeflate.BestCompression;
(** compression strategies **)
DefaultStrategy* = ZlibDeflate.DefaultStrategy; Filtered* = ZlibDeflate.Filtered; HuffmanOnly* = ZlibDeflate.HuffmanOnly;
BufSize = 10000H;
TYPE
(** structure for writing deflated data in a file **)
Writer* = RECORD
res-: LONGINT; (** current stream state **)
flush-: SHORTINT; (** flush strategy **)
wrapper-: BOOLEAN; (** if set, zlib header and checksum are generated **)
r: Files.Rider; (* file rider *)
pos: LONGINT; (* logical position in uncompressed input stream *)
crc32-: LONGINT; (** crc32 of uncompressed data **)
out: POINTER TO ARRAY BufSize OF CHAR; (* output buffer space *)
s: ZlibDeflate.Stream (* compression stream *)
END;
(** change deflate parameters within the writer **)
PROCEDURE SetParams*(VAR w: Writer; level, strategy, flush: SHORTINT);
BEGIN
IF flush IN {NoFlush, SyncFlush, FullFlush} THEN
ZlibDeflate.SetParams(w.s, level, strategy);
w.flush := flush;
w.res := w.s.res
ELSE
w.res := StreamError
END
END SetParams;
(** open writer on a Files.Rider **)
PROCEDURE Open*(VAR w: Writer; level, strategy, flush: SHORTINT; wrapper: BOOLEAN; r: Files.Rider);
BEGIN
IF flush IN {NoFlush, SyncFlush, FullFlush} THEN
w.flush := flush;
w.wrapper := wrapper;
ZlibDeflate.Open(w.s, level, strategy, FALSE);
IF w.s.res = Ok THEN
NEW(w.out); ZlibBuffers.Init(w.s.out, w.out^, 0, BufSize, BufSize);
w.crc32 := Zlib.CRC32(0, w.out^, -1, -1);
w.r := r;
w.res := Ok
ELSE
w.res := w.s.res
END
ELSE
w.res := StreamError
END
END Open;
(** write specified number of bytes from buffer into and return number of bytes actually written **)
PROCEDURE WriteBytes*(VAR w: Writer; VAR buf: ARRAY OF CHAR; offset, len: LONGINT; VAR written: LONGINT);
BEGIN
ASSERT((0 <= offset) & (0 <= len) & (len <= LEN(buf)), 110);
IF ~w.s.open THEN
w.res := StreamError; written := 0
ELSIF (w.res < Ok) OR (len <= 0) THEN
written := 0
ELSE
ZlibBuffers.Init(w.s.in, buf, offset, len, len);
WHILE (w.res = Ok) & (w.s.in.avail # 0) DO
IF (w.s.out.avail = 0) THEN
Files.WriteBytes(w.r, w.out^, BufSize);
ZlibBuffers.Rewrite(w.s.out)
END;
IF w.res = Ok THEN
ZlibDeflate.Deflate(w.s, w.flush);
w.res := w.s.res
END
END;
w.crc32 := Zlib.CRC32(w.crc32, buf, offset, len - w.s.in.avail);
written := len - w.s.in.avail
END;
END WriteBytes;
(** write byte **)
PROCEDURE Write*(VAR w: Writer; ch: CHAR);
VAR
buf: ARRAY 1 OF CHAR;
written: LONGINT;
BEGIN
buf[0] := ch;
WriteBytes(w, buf, 0, 1, written)
END Write;
(** close writer **)
PROCEDURE Close*(VAR w: Writer);
VAR
done: BOOLEAN;
len: LONGINT;
BEGIN
ASSERT(w.s.in.avail = 0, 110);
done := FALSE;
LOOP
len := BufSize - w.s.out.avail;
IF len # 0 THEN
Files.WriteBytes(w.r, w.out^, len);
ZlibBuffers.Rewrite(w.s.out)
END;
IF done THEN EXIT END;
ZlibDeflate.Deflate(w.s, ZlibDeflate.Finish);
IF (len = 0) & (w.s.res = BufError) THEN
w.res := Ok
ELSE
w.res := w.s.res
END;
done := (w.s.out.avail # 0) OR (w.res = StreamEnd);
IF (w.res # Ok) & (w.res # StreamEnd) THEN EXIT END
END;
ZlibDeflate.Close(w.s);
w.res := w.s.res
END Close;
(** compress srclen bytes from src to dst with specified level and strategy. dstlen returns how many bytes have been written. **)
PROCEDURE Compress*(VAR src, dst: Files.Rider; srclen: LONGINT; VAR dstlen: LONGINT; level, strategy: SHORTINT; VAR crc32: LONGINT; VAR res: LONGINT);
VAR
w: Writer; buf: ARRAY BufSize OF CHAR; totWritten, written, read: LONGINT;
BEGIN
Open(w, level, strategy, NoFlush, FALSE, dst);
IF w.res = Ok THEN
totWritten := 0;
REPEAT
IF (srclen - totWritten) >= BufSize THEN read := BufSize
ELSE read := srclen - totWritten
END;
Files.ReadBytes(src, buf, read);
WriteBytes(w, buf, 0, read - src.res, written);
INC(totWritten, written)
UNTIL (w.res # Ok) OR (totWritten >= srclen);
Close(w);
crc32 := w.crc32;
dstlen := Files.Pos(w.r) - Files.Pos(dst);
END;
res := w.res
END Compress;
END ethZlibWriters.

60
src/library/ulm/ulmASCII.Mod Normal file
View file

@ -0,0 +1,60 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: ASCII.om,v 1.1 1994/02/22 20:01:03 borchert Exp $
----------------------------------------------------------------------------
$Log: ASCII.om,v $
Revision 1.1 1994/02/22 20:01:03 borchert
Initial revision
----------------------------------------------------------------------------
AFB 12/90
----------------------------------------------------------------------------
*)
MODULE ulmASCII;
CONST
(* control characters *)
nul* = 000X; soh* = 001X; stx* = 002X; etx* = 003X; eot* = 004X;
enq* = 005X; ack* = 006X; bel* = 007X; bs* = 008X; ht* = 009X;
nl* = 00AX; vt* = 00BX; np* = 00CX; cr* = 00DX; so* = 00EX;
si* = 00FX; dle* = 010X; dc1* = 011X; dc2* = 012X; dc3* = 013X;
dc4* = 014X; nak* = 015X; syn* = 016X; etb* = 017X; can* = 018X;
em* = 019X; sub* = 01AX; esc* = 01BX; fs* = 01CX; gs* = 01DX;
rs* = 01EX; us* = 01FX; sp* = 020X; del* = 07FX;
CtrlA* = 01X; CtrlB* = 02X; CtrlC* = 03X; CtrlD* = 04X; CtrlE* = 05X;
CtrlF* = 06X; CtrlG* = 07X; CtrlH* = 08X; CtrlI* = 09X; CtrlJ* = 0AX;
CtrlK* = 0BX; CtrlL* = 0CX; CtrlM* = 0DX; CtrlN* = 0EX; CtrlO* = 0FX;
CtrlP* = 10X; CtrlQ* = 11X; CtrlR* = 12X; CtrlS* = 13X; CtrlT* = 14X;
CtrlU* = 15X; CtrlV* = 16X; CtrlW* = 17X; CtrlX* = 18X; CtrlY* = 19X;
CtrlZ* = 1AX;
(* other usual names *)
EOL* = nl;
null* = nul;
bell* = bel;
tab* = ht;
lf* = nl;
ff* = np;
quote* = 22X;
END ulmASCII.

121
src/library/ulm/ulmAssertions.Mod Normal file
View file

@ -0,0 +1,121 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Assertions.om,v 1.2 1996/01/04 16:50:59 borchert Exp $
----------------------------------------------------------------------------
$Log: Assertions.om,v $
Revision 1.2 1996/01/04 16:50:59 borchert
some fixes because event types are now an extension of Services.Object
Revision 1.1 1994/02/22 20:06:01 borchert
Initial revision
----------------------------------------------------------------------------
AFB 11/91
----------------------------------------------------------------------------
*)
MODULE ulmAssertions;
(* general error handling of library routines *)
IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, IO := ulmIO, Priorities := ulmPriorities, RelatedEvents := ulmRelatedEvents, Services := ulmServices;
TYPE
Object = Disciplines.Object;
Identifier* = ARRAY 32 OF CHAR; (* should be sufficient *)
Event* = POINTER TO EventRec;
EventRec* =
RECORD
(Events.EventRec)
object*: Object; (* may be NIL *)
module*: Identifier;
proc*: Identifier;
END;
EventType = POINTER TO EventTypeRec;
EventTypeRec* =
RECORD
(Events.EventTypeRec)
(* private components *)
module: Identifier;
END;
VAR
failedAssertion*: Events.EventType;
eventTypeType: Services.Type;
PROCEDURE Define*(VAR type: Events.EventType; module: ARRAY OF CHAR);
(* create a new event type which will be of type Assertions.EventType *)
VAR
newtype: EventType;
BEGIN
NEW(newtype);
Services.Init(newtype, eventTypeType);
Events.Init(newtype);
Events.SetPriority(newtype, Priorities.assertions);
COPY(module, newtype.module);
type := newtype;
END Define;
PROCEDURE Raise*(object: RelatedEvents.Object;
type: Events.EventType;
proc: ARRAY OF CHAR;
text: ARRAY OF CHAR);
(* raise Assertions.failedAssertion;
create a event of the given type and pass it
to RelatedEvents.Raise (if object # NIL)
or Events.Raise (if object = NIL);
*)
VAR
event: Event;
PROCEDURE CreateEvent(VAR event: Event; etype: Events.EventType);
BEGIN
NEW(event);
event.type := etype;
COPY(text, event.message);
event.object := object;
IF type IS EventType THEN
COPY(type(EventType).module, event.module);
ELSE
event.module[0] := 0X;
END;
COPY(proc, event.proc);
END CreateEvent;
BEGIN
IO.WriteString("assertion failed: ");
IO.WriteString(text); IO.WriteString(" in procedure ");
IO.WriteString(proc); IO.WriteLn;
CreateEvent(event, failedAssertion); Events.Raise(event);
CreateEvent(event, type);
IF object = NIL THEN
Events.Raise(event);
ELSE
RelatedEvents.Raise(object, event);
END;
END Raise;
BEGIN
Events.Define(failedAssertion);
Events.SetPriority(failedAssertion, Priorities.assertions);
Events.Ignore(failedAssertion);
Services.CreateType(eventTypeType,
"Assertions.EventType", "Events.EventType");
END ulmAssertions.

174
src/library/ulm/ulmAsymmetricCiphers.Mod Normal file
View file

@ -0,0 +1,174 @@
(* 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.
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: AsymmetricC.om,v 1.1 1997/04/02 11:52:05 borchert Exp borchert $
----------------------------------------------------------------------------
$Log: AsymmetricC.om,v $
Revision 1.1 1997/04/02 11:52:05 borchert
Initial revision
----------------------------------------------------------------------------
*)
MODULE ulmAsymmetricCiphers; (* Michael Szczuka *)
(* abstraction for the use of public key ciphers *)
IMPORT BlockCiphers := ulmBlockCiphers, Ciphers := ulmCiphers, NetIO := ulmNetIO, PersistentObjects := ulmPersistentObjects, Services := ulmServices, Streams := ulmStreams;
CONST
composed* = 0; isPrivateKey* = 1;
TYPE
CapabilitySet* = SET;
TYPE
Cipher* = POINTER TO CipherRec;
SplitProc* = PROCEDURE (VAR public: Cipher; key: Cipher);
RandomStreamProc* = PROCEDURE (s: Streams.Stream);
Interface* = POINTER TO InterfaceRec;
InterfaceRec* = RECORD
(Ciphers.InterfaceRec)
(* public *)
compencrypt* : Ciphers.CryptProc;
split* : SplitProc;
randomStream* : RandomStreamProc;
END;
CipherRec* = RECORD
(BlockCiphers.CipherRec)
(* private *)
cap : CapabilitySet;
asymIf : Interface;
END;
VAR
asymmetricCipherType : Services.Type;
if : PersistentObjects.Interface;
(* need to have this in case anyone wants to decrypt something with
a public cipher ... *)
PROCEDURE Identity(in: Streams.Stream; key: Ciphers.Cipher;
length: INTEGER; out: Streams.Stream) : BOOLEAN;
BEGIN
RETURN Streams.Copy(in, out, length);
END Identity;
PROCEDURE Init* (key: Cipher; if: Interface;
cap: CapabilitySet; inLength, outLength: INTEGER);
BEGIN
IF if.decrypt = NIL THEN
(* decrypt is not defined, so we have only the public part of a cipher;
we can use the identity instead of a decrypting function
in this case
*)
if.decrypt := Identity;
END;
BlockCiphers.Init(key, if, inLength, outLength);
key.cap := cap;
key.asymIf := if;
IF (key.asymIf.compencrypt = NIL) OR ~(composed IN cap) THEN
(* so the cipher's composed function is not defined; therefor it must be
the identical function *)
key.asymIf.compencrypt := Identity;
END;
END Init;
PROCEDURE Capabilities* (key: Cipher) : CapabilitySet;
BEGIN
RETURN key.cap;
END Capabilities;
PROCEDURE IsPublicKey* (key: Cipher) : BOOLEAN;
BEGIN
RETURN ~(isPrivateKey IN key.cap);
END IsPublicKey;
PROCEDURE Split* (VAR public: Cipher; key: Cipher);
BEGIN
IF IsPublicKey(key) THEN
(* trying to extract a public part from a key that already IS a public
cipher? well, if you really want to ... *)
public := key;
RETURN;
END;
key.asymIf.split(public, key);
(* define the extracted part as public *)
public.cap := public.cap - {isPrivateKey};
END Split;
(* encrypts a given stream msg with the composed map of the key *)
PROCEDURE ComposedEncrypt* (in: Streams.Stream; key: Cipher;
out: Streams.Stream) : BOOLEAN;
BEGIN
RETURN key.asymIf.compencrypt(in, key, -1, out);
END ComposedEncrypt;
PROCEDURE ComposedEncryptPart* (in: Streams.Stream; key: Cipher;
length: INTEGER;
out: Streams.Stream) : BOOLEAN;
BEGIN
RETURN key.asymIf.compencrypt(in, key, length, out);
END ComposedEncryptPart;
PROCEDURE ComposedEncryptBlock* (in: Streams.Stream; key: Cipher;
out: Streams.Stream) : BOOLEAN;
VAR
length : INTEGER;
BEGIN
length := BlockCiphers.GetInLength(key);
RETURN key.asymIf.compencrypt(in, key, length, out);
END ComposedEncryptBlock;
PROCEDURE RandomStream*(s: Streams.Stream; key: Cipher);
BEGIN
key.asymIf.randomStream(s);
END RandomStream;
PROCEDURE Create (VAR obj: PersistentObjects.Object);
VAR
cipher : Cipher;
BEGIN
NEW(cipher);
PersistentObjects.Init(cipher, asymmetricCipherType);
obj := cipher;
END Create;
PROCEDURE Write (s: Streams.Stream; obj: PersistentObjects.Object) : BOOLEAN;
BEGIN
WITH obj:Cipher DO
RETURN NetIO.WriteSet(s, obj.cap);
END;
END Write;
PROCEDURE Read (s: Streams.Stream; obj: PersistentObjects.Object) : BOOLEAN;
BEGIN
WITH obj:Cipher DO
RETURN NetIO.ReadSet(s, obj.cap);
END;
END Read;
BEGIN
NEW(if);
if.create := Create; if.write := Write; if.read := Read;
if.createAndRead := NIL;
PersistentObjects.RegisterType(asymmetricCipherType,
"AsymmetricCiphers.Cipher", "BlockCiphers.Cipher", if);
END ulmAsymmetricCiphers.

123
src/library/ulm/ulmBlockCiphers.Mod Normal file
View file

@ -0,0 +1,123 @@
(* 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.
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: BlockCipher.om,v 1.1 1997/04/02 11:52:59 borchert Exp borchert $
----------------------------------------------------------------------------
$Log: BlockCipher.om,v $
Revision 1.1 1997/04/02 11:52:59 borchert
Initial revision
----------------------------------------------------------------------------
*)
MODULE ulmBlockCiphers; (* Michael Szczuka *)
(* abstraction for the use of block ciphers *)
IMPORT Ciphers := ulmCiphers, NetIO := ulmNetIO, PersistentObjects := ulmPersistentObjects, Services := ulmServices, Streams := ulmStreams;
TYPE
Cipher* = POINTER TO CipherRec;
CipherRec* = RECORD
(Ciphers.CipherRec)
(* private *)
inLength: INTEGER;
outLength: INTEGER;
END;
VAR
blockCipherType : Services.Type;
if : PersistentObjects.Interface;
PROCEDURE Init* (key: Cipher; if: Ciphers.Interface;
inLength, outLength: INTEGER);
(* init a block cipher with its special interface *)
BEGIN
Ciphers.Init(key, if);
ASSERT(inLength > 0);
ASSERT(outLength > 0);
key.inLength := inLength;
key.outLength := outLength;
END Init;
PROCEDURE GetInLength* (key: Cipher) : INTEGER;
(* returns the input block length of a block cipher *)
BEGIN
RETURN key.inLength;
END GetInLength;
PROCEDURE GetOutLength* (key: Cipher) : INTEGER;
(* returns the output block length of a block cipher *)
BEGIN
RETURN key.outLength;
END GetOutLength;
PROCEDURE EncryptBlock* (in: Streams.Stream; key: Cipher;
out: Streams.Stream) : BOOLEAN;
VAR
length : INTEGER;
BEGIN
length := GetInLength(key);
RETURN Ciphers.EncryptPart(in, key, length, out);
END EncryptBlock;
PROCEDURE DecryptBlock* (in: Streams.Stream; key: Cipher;
out: Streams.Stream) : BOOLEAN;
VAR
length : INTEGER;
BEGIN
length := GetOutLength(key);
RETURN Ciphers.DecryptPart(in, key, length, out);
END DecryptBlock;
PROCEDURE Create(VAR obj: PersistentObjects.Object);
VAR
key : Cipher;
BEGIN
NEW(key);
PersistentObjects.Init(key, blockCipherType);
obj := key;
END Create;
PROCEDURE Write(s: Streams.Stream; obj: PersistentObjects.Object) : BOOLEAN;
BEGIN
WITH obj:Cipher DO
RETURN NetIO.WriteInteger(s, obj.inLength) &
NetIO.WriteInteger(s, obj.outLength);
END;
END Write;
PROCEDURE Read(s: Streams.Stream; obj: PersistentObjects.Object) : BOOLEAN;
BEGIN
WITH obj:Cipher DO
RETURN NetIO.ReadInteger(s, obj.inLength) &
NetIO.ReadInteger(s, obj.outLength);
END;
END Read;
BEGIN
NEW(if);
if.create := Create;
if.write := Write;
if.read := Read;
if.createAndRead := NIL;
PersistentObjects.RegisterType(blockCipherType, "BlockCiphers.Cipher",
"Ciphers.Cipher", if);
END ulmBlockCiphers.

67
src/library/ulm/ulmCipherOps.Mod Normal file
View file

@ -0,0 +1,67 @@
(* 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.
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
----------------------------------------------------------------------------
*)
MODULE ulmCipherOps; (* Michael Szczuka *)
(* useful functions for stream ciphers *)
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 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
RETURN wholeStream
END;
DEC(length);
END;
RETURN TRUE
END XorStream;
END ulmCipherOps.

94
src/library/ulm/ulmCiphers.Mod Normal file
View file

@ -0,0 +1,94 @@
(* 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.
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: Ciphers.om,v 1.1 1997/04/02 11:51:15 borchert Exp $
----------------------------------------------------------------------------
$Log: Ciphers.om,v $
Revision 1.1 1997/04/02 11:51:15 borchert
Initial revision
----------------------------------------------------------------------------
*)
(* abstraction for the use of ciphers and cryptographic methods *)
MODULE ulmCiphers;
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
Interface* = POINTER TO InterfaceRec;
InterfaceRec* = RECORD
(Objects.ObjectRec)
(* public *)
encrypt*, decrypt* : CryptProc;
END;
TYPE
CipherRec* = RECORD
(PersistentDisciplines.ObjectRec)
(* private *)
if : Interface
END;
VAR
cipherType, interfaceType : Services.Type;
PROCEDURE Init*(key: Cipher; if: Interface);
BEGIN
ASSERT(if # NIL);
ASSERT(if.encrypt # NIL);
key.if := if;
END Init;
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;
BEGIN
RETURN key.if.decrypt(in, key, -1, out);
END Decrypt;
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;
BEGIN
RETURN key.if.decrypt(in, key, length, out);
END DecryptPart;
BEGIN
PersistentObjects.RegisterType(cipherType, "Ciphers.Cipher",
"PersistentDisciplines.Object", NIL);
END ulmCiphers.

277
src/library/ulm/ulmClocks.Mod Normal file
View file

@ -0,0 +1,277 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Clocks.om,v 1.3 2004/02/19 15:21:17 borchert Exp $
----------------------------------------------------------------------------
$Log: Clocks.om,v $
Revision 1.3 2004/02/19 15:21:17 borchert
Passed added including passed capability
Revision 1.2 1996/01/04 16:50:25 borchert
clocks are now an extension of Services.Object
Revision 1.1 1994/02/22 20:06:13 borchert
Initial revision
----------------------------------------------------------------------------
AFB 1/92
----------------------------------------------------------------------------
*)
MODULE ulmClocks;
IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Objects := ulmObjects, Op := ulmOperations, Priorities := ulmPriorities,
RelatedEvents := ulmRelatedEvents, Services := ulmServices, Times := ulmTimes;
TYPE
Clock* = POINTER TO ClockRec;
CONST
settime* = 0; timer* = 1; passed* = 2;
TYPE
CapabilitySet* = SET; (* OF [settime..passed] *)
TYPE
GetTimeProc* = PROCEDURE (clock: Clock; VAR time: Times.Time);
SetTimeProc* = PROCEDURE (clock: Clock; time: Times.Time);
PassedProc* = PROCEDURE (clock: Clock; time: Times.Time) : BOOLEAN;
TimerOnProc* = PROCEDURE (clock: Clock; time: Times.Time;
event: Events.Event);
TimerOffProc* = PROCEDURE (clock: Clock);
GetPriorityProc* = PROCEDURE (clock: Clock;
VAR priority: Priorities.Priority);
Interface* = POINTER TO InterfaceRec;
InterfaceRec* =
RECORD
(Objects.ObjectRec)
gettime*: GetTimeProc;
settime*: SetTimeProc;
passed*: PassedProc;
timeron*: TimerOnProc;
timeroff*: TimerOffProc;
getpriority*: GetPriorityProc;
END;
TYPE
ClockRec* =
RECORD
(Services.ObjectRec)
if: Interface;
caps: CapabilitySet;
END;
VAR
clockType: Services.Type;
TYPE
StaticClock = POINTER TO StaticClockRec;
StaticClockRec =
RECORD
(ClockRec)
time: Times.Time;
timerOn: BOOLEAN;
timer: Times.Time;
event: Events.Event;
END;
VAR
staticClockType: Services.Type;
VAR
system*: Clock; (* the clock of the operating system *)
CONST
cannotSetTime* = 0; (* SetTime not implemented *)
cannotSetTimer* = 1; (* timer not implemented *)
errorcodes* = 2;
TYPE
ErrorEvent* = POINTER TO ErrorEventRec;
ErrorEventRec* =
RECORD
(Events.EventRec)
errorcode*: SHORTINT;
END;
VAR
errormsg*: ARRAY errorcodes OF Events.Message;
error*: Events.EventType;
PROCEDURE Error(clock: Clock; code: SHORTINT);
VAR
event: ErrorEvent;
BEGIN
NEW(event);
event.type := error;
event.message := errormsg[code];
event.errorcode := code;
RelatedEvents.Raise(clock, event);
END Error;
PROCEDURE InitErrorHandling;
BEGIN
errormsg[cannotSetTime] := "SetTime not implemented for this clock";
errormsg[cannotSetTimer] := "timer not implemented for this clock";
Events.Define(error);
Events.SetPriority(error, Priorities.liberrors);
END InitErrorHandling;
PROCEDURE Init*(clock: Clock; if: Interface; caps: CapabilitySet);
VAR
type: Services.Type;
BEGIN
Services.GetType(clock, type);
ASSERT(type # NIL);
ASSERT(if.gettime # NIL);
ASSERT(~(passed IN caps) OR (if.passed # NIL));
ASSERT(~(settime IN caps) OR (if.settime # NIL));
IF timer IN caps THEN
ASSERT((if.timeron # NIL) & (if.timeroff # NIL) &
(if.getpriority # NIL));
END;
clock.if := if;
clock.caps := caps;
RelatedEvents.QueueEvents(clock);
END Init;
PROCEDURE Capabilities*(clock: Clock) : CapabilitySet;
BEGIN
RETURN clock.caps
END Capabilities;
PROCEDURE GetTime*(clock: Clock; VAR time: Times.Time);
BEGIN
clock.if.gettime(clock, time);
END GetTime;
PROCEDURE SetTime*(clock: Clock; time: Times.Time);
BEGIN
IF settime IN clock.caps THEN
clock.if.settime(clock, time);
ELSE
Error(clock, cannotSetTime);
END;
END SetTime;
PROCEDURE Passed*(clock: Clock; time: Times.Time) : BOOLEAN;
VAR
currentTime: Times.Time;
BEGIN
IF passed IN clock.caps THEN
RETURN clock.if.passed(clock, time)
ELSE
GetTime(clock, currentTime);
RETURN Op.Compare(currentTime, time) >= 0
END;
END Passed;
PROCEDURE TimerOn*(clock: Clock; time: Times.Time; event: Events.Event);
BEGIN
IF timer IN clock.caps THEN
clock.if.timeron(clock, time, event);
ELSE
Error(clock, cannotSetTimer);
END;
END TimerOn;
PROCEDURE TimerOff*(clock: Clock);
BEGIN
IF timer IN clock.caps THEN
clock.if.timeroff(clock);
ELSE
Error(clock, cannotSetTimer);
END;
END TimerOff;
PROCEDURE GetPriority*(clock: Clock; VAR priority: Priorities.Priority);
(* return Priorities.base in case of static clocks *)
BEGIN
IF timer IN clock.caps THEN
clock.if.getpriority(clock, priority);
ELSE
Error(clock, cannotSetTimer);
END;
END GetPriority;
(* ========= implementation of static clocks ========== *)
PROCEDURE StaticGetTime(clock: Clock; VAR time: Times.Time);
BEGIN
time := clock(StaticClock).time;
END StaticGetTime;
PROCEDURE StaticSetTime(clock: Clock; time: Times.Time);
BEGIN
WITH clock: StaticClock DO
clock.time := time;
IF clock.timerOn & (Op.Compare(clock.time, clock.timer) >= 0) THEN
clock.timerOn := FALSE;
Events.Raise(clock.event);
END;
END;
END StaticSetTime;
PROCEDURE StaticTimerOn(clock: Clock; time: Times.Time; event: Events.Event);
BEGIN
WITH clock: StaticClock DO
IF Op.Compare(time, clock.time) < 0 THEN
Events.Raise(event);
ELSE
clock.timerOn := TRUE;
clock.timer := time;
clock.event := event;
END;
END;
END StaticTimerOn;
PROCEDURE StaticTimerOff(clock: Clock);
BEGIN
WITH clock: StaticClock DO
clock.timerOn := FALSE;
END;
END StaticTimerOff;
PROCEDURE StaticGetPriority(clock: Clock; VAR priority: Priorities.Priority);
BEGIN
priority := Priorities.base;
END StaticGetPriority;
PROCEDURE CreateStaticClock*(VAR clock: Clock);
VAR
if: Interface;
staticClock: StaticClock;
BEGIN
NEW(staticClock);
Services.Init(staticClock, staticClockType);
Times.Create(staticClock.time, Times.absolute);
staticClock.timerOn := FALSE;
NEW(if);
if.gettime := StaticGetTime;
if.settime := StaticSetTime;
if.timeron := StaticTimerOn;
if.timeroff := StaticTimerOff;
if.getpriority := StaticGetPriority;
Init(staticClock, if, {settime, timer});
clock := staticClock;
END CreateStaticClock;
BEGIN
InitErrorHandling;
Services.CreateType(clockType, "Clocks.Clock", "");
Services.CreateType(staticClockType, "Clocks.StaticClock", "Clocks.Clock");
(* system is hopefully re-initialized by another module which interfaces
the real system clock
*)
CreateStaticClock(system);
END ulmClocks.

169
src/library/ulm/ulmConclusions.Mod Normal file
View file

@ -0,0 +1,169 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Conclusions.om,v 1.2 1994/07/05 12:50:01 borchert Exp $
----------------------------------------------------------------------------
$Log: Conclusions.om,v $
Revision 1.2 1994/07/05 12:50:01 borchert
formatting of error messages depends now on the indentation width
of StreamDisciplines
Revision 1.1 1994/02/23 07:46:17 borchert
Initial revision
----------------------------------------------------------------------------
AFB 11/91
----------------------------------------------------------------------------
*)
MODULE ulmConclusions;
(* convert errors and events into conclusions,
i.e. a final message and reaction
*)
IMPORT Errors := ulmErrors, Events := ulmEvents, Process := ulmProcess, RelatedEvents := ulmRelatedEvents, StreamDisciplines := ulmStreamDisciplines,
Streams := ulmStreams, Strings := ulmStrings, Write := ulmWrite;
VAR
handlerSet*: Errors.HandlerSet;
errors*: INTEGER; (* number of errors *)
fatalcode*: INTEGER; (* exit code on fatal events *)
(* private variables *)
cmdName: Process.Name; (* should be sufficient for a base name *)
cmdNameLen: INTEGER; (* Strings.Len(cmdName) *)
(* private procedures *)
PROCEDURE GeneralHandler(event: Events.Event; kind: Errors.Kind);
VAR
width: INTEGER;
BEGIN
IF event # NIL THEN
Write.IndentS(Streams.stderr);
Write.StringS(Streams.stderr, cmdName);
Write.StringS(Streams.stderr, ": ");
width := SHORT(Strings.Len(cmdName) + 2);
StreamDisciplines.IncrIndentationWidth(Streams.stderr, width);
IF kind # Errors.message THEN
Write.StringS(Streams.stderr, Errors.kindText[kind]);
Write.StringS(Streams.stderr, ": ");
END;
Errors.Write(Streams.stderr, event); Write.LnS(Streams.stderr);
StreamDisciplines.IncrIndentationWidth(Streams.stderr, -width);
END;
CASE kind OF
| Errors.error: INC(errors);
| Errors.fatal: Process.Exit(fatalcode);
| Errors.bug: Process.Abort;
ELSE
(* no further actions *)
END;
END GeneralHandler;
PROCEDURE AbortHandler(event: Events.Event);
BEGIN
GeneralHandler(event, Errors.bug);
END AbortHandler;
PROCEDURE Init;
VAR
messageKind: Errors.Kind;
BEGIN
fatalcode := 1;
errors := 0;
cmdName := Process.name;
cmdNameLen := SHORT(Strings.Len(cmdName));
messageKind := 0;
Errors.CreateHandlerSet(handlerSet);
WHILE messageKind < Errors.nkinds DO
Errors.InstallHandler(handlerSet, messageKind, GeneralHandler);
INC(messageKind);
END;
Events.AbortHandler(AbortHandler);
END Init;
(* public procedures *)
PROCEDURE CatchEvent*(type: Events.EventType; kind: Errors.Kind);
BEGIN
Errors.CatchEvent(handlerSet, kind, type);
END CatchEvent;
PROCEDURE ConcludeS*(s: Streams.Stream;
object: RelatedEvents.Object; kind: Errors.Kind;
text: ARRAY OF CHAR);
VAR
queue: RelatedEvents.Queue;
width: INTEGER;
PROCEDURE ReverseQueue(VAR queue: RelatedEvents.Queue);
VAR
ptr, prev, next: RelatedEvents.Queue;
BEGIN
ptr := queue; prev := NIL;
WHILE ptr # NIL DO
next := ptr.next;
ptr.next := prev;
prev := ptr;
ptr := next;
END;
queue := prev;
END ReverseQueue;
BEGIN
RelatedEvents.GetQueue(object, queue);
Write.IndentS(s);
Write.StringS(s, cmdName); Write.StringS(s, ": ");
IF kind # Errors.message THEN
Write.StringS(s, Errors.kindText[kind]); Write.StringS(s, ": ");
END;
IF text # "" THEN
Write.StringS(s, text); Write.StringS(s, ": ");
END;
IF queue = NIL THEN
Write.StringS(s, "*no error messages found*"); Write.LnS(s);
ELSE
width := cmdNameLen + (* ": " *) 2;
StreamDisciplines.IncrIndentationWidth(s, width);
(* convert FIFO into LIFO *)
ReverseQueue(queue);
LOOP
Errors.Write(s, queue.event); Write.LnS(s);
queue := queue.next;
(**)IF queue = NIL THEN EXIT END;
Write.IndentS(s);
END;
StreamDisciplines.IncrIndentationWidth(s, -width);
END;
GeneralHandler(NIL, kind);
END ConcludeS;
PROCEDURE Conclude*(object: RelatedEvents.Object; kind: Errors.Kind;
text: ARRAY OF CHAR);
BEGIN
ConcludeS(Streams.stderr, object, kind, text);
END Conclude;
BEGIN
Init;
END ulmConclusions.

967
src/library/ulm/ulmConditions.Mod Normal file
View file

@ -0,0 +1,967 @@
(* Ulm's Oberon Library
Copyright (C) 1989-2005 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Conditions.om,v 1.7 2005/02/09 09:53:25 borchert Exp $
----------------------------------------------------------------------------
$Log: Conditions.om,v $
Revision 1.7 2005/02/09 09:53:25 borchert
bug fix: we have to enter a busy loop even in case of interrupting
events as there is a window between setup and Process.Pause
Revision 1.6 2005/02/06 22:26:59 borchert
bug fix: assure that the priority of asynchronous events exceeds
those of interrupting events
Revision 1.5 2004/09/03 08:59:34 borchert
hash tab size for ConditionSet changed from 128 to 64
Revision 1.4 2004/09/01 13:32:18 borchert
performance improvement: condition sets are now based on hashes
Revision 1.3 2001/05/18 21:59:01 borchert
SetupAsyncEvents checks now all conditions to add as much conditions
as possible to setOfTrueConditions
Revision 1.2 1996/01/04 16:59:56 borchert
- conditions are now extensions of Disciplines.Object
- some renamings: timecond -> timelimit, hint -> timecond
- errors events have been replaced by assertions
- WaitForAndSelect has been renamed to WaitFor (the old version
of WaitFor vanished)
- conditions are now tagged to allow some optimizations of the
condition set operations
- optimized support of async capability
- redesign of blocking algorithm
Revision 1.1 1994/02/22 20:06:25 borchert
Initial revision
----------------------------------------------------------------------------
AFB 12/91
----------------------------------------------------------------------------
*)
MODULE ulmConditions;
IMPORT Clocks := ulmClocks, Disciplines := ulmDisciplines, Events := ulmEvents, Objects := ulmObjects, Op := ulmOperations,
Priorities := ulmPriorities, Process := ulmProcess, RelatedEvents := ulmRelatedEvents, Scales := ulmScales, Timers := ulmTimers, Times := ulmTimes, SYSTEM;
CONST
tags = 64;
TYPE
Tag = INTEGER; (* 0..tags-1 *)
(* tags are used for the hashs *)
VAR
nextTag: Tag; (* 0..tags-1, 0..tags-1, ... *)
TYPE
Domain* = POINTER TO DomainRec;
Condition* = POINTER TO ConditionRec;
ConditionRec* =
RECORD
(Disciplines.ObjectRec)
domain: Domain;
tag: Tag;
waitingForEvent: BOOLEAN;
gotEvent: BOOLEAN;
END;
(* disjunctive list of conditions *)
ConditionList = POINTER TO ConditionListRec;
ConditionListRec =
RECORD
cond: Condition;
next: ConditionList;
END;
BucketTable = ARRAY tags OF ConditionList;
ConditionSet* = POINTER TO ConditionSetRec;
ConditionSetRec* =
RECORD
(Objects.ObjectRec)
cardinality: INTEGER;
bucket: BucketTable;
(* for the iterator *)
next: ConditionList; i: INTEGER;
END;
CONST
select* = 0; timelimit* = 1; async* = 2; timecond* = 3; preconditions* = 4;
TYPE
CapabilitySet* = SET; (* OF [select..preconditions] *)
TYPE
SelectProc* = PROCEDURE (domain: Domain; conditionSet: ConditionSet;
time: Times.Time;
VAR setOfTrueConditions: ConditionSet;
errors: RelatedEvents.Object;
retry: BOOLEAN;
VAR interrupted: BOOLEAN) : BOOLEAN;
(* needs only to be provided if select is in caps;
if timelimit isn't in caps then time is guaranteed to
be equal to NIL
*)
TestProc* = PROCEDURE (domain: Domain; condition: Condition;
errors: RelatedEvents.Object) : BOOLEAN;
SendEventProc* = PROCEDURE (domain: Domain; condition: Condition;
event: Events.Event;
errors: RelatedEvents.Object) : BOOLEAN;
(* sendevent needs only to be provided if async is in caps *)
GetTimeProc* = PROCEDURE (domain: Domain; conditionSet: ConditionSet;
VAR nextTime: Times.Time;
VAR nextCond: Condition;
errors: RelatedEvents.Object);
(* needs only to be provided if timecond is in caps *)
PreConditionsProc* = PROCEDURE (domain: Domain; condition: Condition;
VAR preconds: ConditionSet;
errors: RelatedEvents.Object) : BOOLEAN;
(* needs only to be provided if preconditions is in caps *)
Interface* = POINTER TO InterfaceRec;
InterfaceRec* =
RECORD
(Objects.ObjectRec)
test*: TestProc;
select*: SelectProc;
sendevent*: SendEventProc;
gettime*: GetTimeProc;
preconditions*: PreConditionsProc;
END;
Description* = POINTER TO DescriptionRec;
DescriptionRec* =
RECORD
(Objects.ObjectRec)
caps*: CapabilitySet;
internal*: BOOLEAN; (* value does not change during Process.Pause? *)
END;
TYPE
DomainRec* =
RECORD
(Disciplines.ObjectRec)
if: Interface;
desc: Description;
END;
TYPE
GetTimeOfNextTryProc* = PROCEDURE (iteration: INTEGER;
VAR time: Times.Time);
(* return a relative time measure *)
VAR
getTimeOfNextTry: GetTimeOfNextTryProc;
TYPE
WakeupEvent = POINTER TO WakeupEventRec;
WakeupEventRec =
RECORD
(Events.EventRec)
condition: Condition;
END;
VAR
nodelay: Times.Time;
wakeupEventType: Events.EventType; (* used for busy loops only *)
PROCEDURE WakeupHandler(event: Events.Event);
BEGIN
WITH event: WakeupEvent DO
event.condition.gotEvent := TRUE;
END;
END WakeupHandler;
PROCEDURE SetGetTimeOfNextTryProc*(p: GetTimeOfNextTryProc);
BEGIN
getTimeOfNextTry := p;
END SetGetTimeOfNextTryProc;
PROCEDURE GetTimeOfNextTry(iteration: INTEGER; VAR time: Times.Time);
BEGIN
Times.CreateAndSet(time, Times.relative, 0, 1, 0);
iteration := iteration DIV 5;
IF iteration > 8 THEN
iteration := 8;
END;
WHILE iteration > 0 DO
Op.Add2(SYSTEM.VAL(Op.Operand, time), time);
DEC(iteration);
END;
END GetTimeOfNextTry;
PROCEDURE CreateSet*(VAR conditionSet: ConditionSet);
VAR
i: INTEGER;
cset: ConditionSet;
BEGIN
NEW(cset);
cset.cardinality := 0;
(*
commented out for reasons of efficiency
as NEW delivers 0-initialized areas anyway
i := 0;
WHILE i < tags DO
conditionSet.bucket[i] := NIL;
INC(i);
END;
*)
cset.next := NIL; cset.i := 0;
conditionSet := cset;
END CreateSet;
PROCEDURE Incl*(conditionSet: ConditionSet; condition: Condition);
VAR
listp: ConditionList;
new: ConditionList;
i: INTEGER;
BEGIN
(* check if condition is already present in conditionSet *)
i := condition.tag;
listp := conditionSet.bucket[i];
WHILE (listp # NIL) & (listp.cond # condition) DO
listp := listp.next;
END;
IF listp # NIL THEN (* already in set *) RETURN END;
NEW(new); new.cond := condition;
new.next := conditionSet.bucket[i];
conditionSet.bucket[i] := new;
INC(conditionSet.cardinality);
END Incl;
PROCEDURE Excl*(conditionSet: ConditionSet; condition: Condition);
VAR
prev, listp: ConditionList;
i: INTEGER;
BEGIN
i := condition.tag;
listp := conditionSet.bucket[i]; prev := NIL;
WHILE (listp # NIL) & (listp.cond # condition) DO
prev := listp; listp := listp.next;
END;
IF listp = NIL THEN (* condition not in set *) RETURN END;
IF prev = NIL THEN
conditionSet.bucket[i] := listp.next;
ELSE
prev.next := listp.next;
END;
DEC(conditionSet.cardinality);
(* make the iterator more robust *)
IF conditionSet.next = listp THEN
conditionSet.next := listp.next;
END;
END Excl;
PROCEDURE In*(conditionSet: ConditionSet; condition: Condition) : BOOLEAN;
VAR
listp: ConditionList;
BEGIN
listp := conditionSet.bucket[condition.tag];
WHILE (listp # NIL) & (listp.cond # condition) DO
listp := listp.next;
END;
RETURN listp # NIL
END In;
PROCEDURE Union*(result: ConditionSet; set: ConditionSet);
VAR
listp: ConditionList;
newelem, newelems: ConditionList;
count: INTEGER; (* # of added elements in newelems *)
i: INTEGER;
BEGIN
count := 0;
i := 0;
WHILE i < tags DO
listp := set.bucket[i];
newelems := result.bucket[i];
IF newelems = NIL THEN
WHILE listp # NIL DO
NEW(newelem); newelem.cond := listp.cond;
newelem.next := newelems;
newelems := newelem;
INC(count);
listp := listp.next;
END;
ELSE
WHILE listp # NIL DO
IF ~In(result, listp.cond) THEN
NEW(newelem); newelem.cond := listp.cond;
newelem.next := newelems;
newelems := newelem;
INC(count);
END;
listp := listp.next;
END;
END;
result.bucket[i] := newelems;
INC(i);
END;
INC(result.cardinality, count);
END Union;
PROCEDURE Union3*(VAR result: ConditionSet; set1, set2: ConditionSet);
BEGIN
CreateSet(result); Union(result, set1); Union(result, set2);
END Union3;
PROCEDURE Card*(conditionSet: ConditionSet) : INTEGER;
BEGIN
RETURN conditionSet.cardinality
END Card;
PROCEDURE ExamineConditions*(conditionSet: ConditionSet);
BEGIN
conditionSet.next := NIL;
conditionSet.i := 0;
END ExamineConditions;
PROCEDURE GetNextCondition*(conditionSet: ConditionSet;
VAR condition: Condition) : BOOLEAN;
VAR
i: INTEGER;
BEGIN
IF conditionSet.next = NIL THEN
i := conditionSet.i;
WHILE (i < tags) & (conditionSet.bucket[i] = NIL) DO
INC(i);
END;
conditionSet.i := i + 1;
IF i >= tags THEN
RETURN FALSE
END;
conditionSet.next := conditionSet.bucket[i];
END;
condition := conditionSet.next.cond;
conditionSet.next := conditionSet.next.next;
RETURN TRUE
END GetNextCondition;
PROCEDURE InitDomain*(domain: Domain; if: Interface; desc: Description);
BEGIN
domain.if := if;
domain.desc := desc;
END InitDomain;
PROCEDURE Init*(condition: Condition; domain: Domain);
BEGIN
condition.domain := domain;
condition.tag := nextTag;
nextTag := (nextTag + 1) MOD tags;
condition.waitingForEvent := FALSE;
condition.gotEvent := FALSE;
END Init;
PROCEDURE Test*(condition: Condition; errors: RelatedEvents.Object) : BOOLEAN;
BEGIN
IF condition.waitingForEvent & ~condition.gotEvent THEN
RETURN FALSE
ELSE
RETURN condition.domain.if.test(condition.domain, condition, errors)
END;
END Test;
PROCEDURE CommonDomain(cset: ConditionSet;
VAR domain: Domain) : BOOLEAN;
VAR
dom: Domain;
i: INTEGER;
listp: ConditionList;
BEGIN
dom := NIL;
i := 0;
WHILE i < tags DO
listp := cset.bucket[i];
WHILE listp # NIL DO
IF dom = NIL THEN
dom := listp.cond.domain;
ELSIF dom # listp.cond.domain THEN
RETURN FALSE
END;
listp := listp.next;
END;
INC(i);
END;
domain := dom;
RETURN dom # NIL
END CommonDomain;
PROCEDURE SimpleWaitForAndSelect(
conditionSet: ConditionSet;
VAR setOfTrueConditions: ConditionSet;
errors: RelatedEvents.Object);
(* simple means that we don't need to take care of preconditions *)
TYPE
List = POINTER TO ListRec;
Element = POINTER TO ElementRec;
ListRec =
RECORD
head: Element;
END;
Ring = POINTER TO RingRec;
RingRec =
RECORD
(ListRec)
tail: Element;
END;
ElementRec =
RECORD
next: Element;
domain: Domain;
cset: ConditionSet;
END;
VAR
domain: Domain;
interrupted: BOOLEAN;
ok: BOOLEAN;
PROCEDURE SortConditions(VAR asyncList, timeList, others: List;
VAR ring: Ring;
VAR otherAreInternal: BOOLEAN);
(* sort conditions into several lists:
ayncList: list of conditions for which we can setup an event;
after this setup we needn't to take care of them
timeList: list of time conditions (based on system clock)
ring: conditions which support select & timelimit
otherAreInternal:
is set to TRUE if all other conditions which
are not put into one of the lists above remain
unaffected while pausing
*)
VAR
listp: ConditionList;
i: INTEGER;
PROCEDURE CreateList(VAR list: List);
BEGIN
NEW(list); list.head := NIL;
END CreateList;
PROCEDURE CreateRing(VAR ring: Ring);
BEGIN
NEW(ring); ring.head := NIL; ring.tail := NIL;
END CreateRing;
PROCEDURE Add(condition: Condition);
VAR
domain: Domain;
PROCEDURE AddTo(list: List);
VAR
elp: Element;
BEGIN
elp := list.head;
WHILE (elp # NIL) & (elp.domain # domain) DO
elp := elp.next;
END;
IF elp = NIL THEN
NEW(elp);
elp.next := list.head;
elp.domain := condition.domain;
CreateSet(elp.cset);
list.head := elp;
IF list IS Ring THEN
WITH list: Ring DO
IF list.tail = NIL THEN
list.tail := elp;
END;
list.tail.next := list.head;
END;
END;
END;
Incl(elp.cset, condition);
END AddTo;
BEGIN (* Add *)
domain := condition.domain;
IF timecond IN domain.desc.caps THEN
IF timeList = NIL THEN
CreateList(timeList);
END;
AddTo(timeList);
ELSIF async IN domain.desc.caps THEN
IF asyncList = NIL THEN
CreateList(asyncList);
END;
AddTo(asyncList);
ELSIF (select IN domain.desc.caps) &
(timelimit IN domain.desc.caps) THEN
IF ring = NIL THEN
CreateRing(ring);
END;
AddTo(ring);
ELSE
IF others = NIL THEN
CreateList(others);
END;
AddTo(others);
IF ~domain.desc.internal THEN
otherAreInternal := FALSE;
END;
END;
END Add;
BEGIN (* SortConditions *)
asyncList := NIL; timeList := NIL; ring := NIL;
otherAreInternal := TRUE;
i := 0;
WHILE i < tags DO
listp := conditionSet.bucket[i];
WHILE listp # NIL DO
Add(listp.cond);
listp := listp.next;
END;
INC(i);
END;
END SortConditions;
PROCEDURE SetupEventHandling(condition: Condition;
VAR wakeupEvent: WakeupEvent);
VAR
wakeup: Events.EventType;
priority: Priorities.Priority;
BEGIN
Events.Define(wakeup);
priority := Events.GetPriority() + 1;
IF priority < Priorities.interrupts + 1 THEN
priority := Priorities.interrupts + 1;
END;
Events.SetPriority(wakeup, priority);
Events.Handler(wakeup, WakeupHandler);
NEW(wakeupEvent); wakeupEvent.type := wakeup;
wakeupEvent.condition := condition;
condition.waitingForEvent := TRUE;
condition.gotEvent := FALSE;
END SetupEventHandling;
PROCEDURE SetupAsyncEvents(list: List) : BOOLEAN;
VAR
elp: Element;
listp: ConditionList; i: INTEGER;
wakeupEvent: WakeupEvent;
sendevent: SendEventProc;
anythingTrue: BOOLEAN;
BEGIN
anythingTrue := FALSE;
elp := list.head;
WHILE elp # NIL DO
sendevent := elp.domain.if.sendevent;
i := 0;
WHILE i < tags DO
listp := elp.cset.bucket[i];
WHILE listp # NIL DO
IF ~listp.cond.waitingForEvent OR listp.cond.gotEvent THEN
SetupEventHandling(listp.cond, wakeupEvent);
IF ~sendevent(elp.domain, listp.cond,
wakeupEvent, errors) THEN
IF ~anythingTrue THEN
CreateSet(setOfTrueConditions);
END;
Incl(setOfTrueConditions, listp.cond);
listp.cond.waitingForEvent := FALSE;
anythingTrue := TRUE;
END;
END;
listp := listp.next;
END;
INC(i);
END;
elp := elp.next;
END;
RETURN ~anythingTrue
END SetupAsyncEvents;
PROCEDURE Block;
(* block until one of the conditions becomes TRUE *)
VAR
asyncList: List; (* list of domains which supports async events *)
timeList: List; (* list of domains which supports timecond *)
ring: Ring; (* ring of domains which support select+timelimit *)
largeRing: BOOLEAN; (* >=2 ring members *)
ringMember: Element; (* current ring member *)
others: List; (* those which are not member of the other lists *)
otherAreInternal: BOOLEAN;
waitErrors: RelatedEvents.Object;
queue: RelatedEvents.Queue; (* queue of waitErrors *)
busyLoop: BOOLEAN; (* TRUE if we have to resort to a busy loop *)
wakeupEvent: Events.Event; (* iteration event for busy loops *)
loopCnt: INTEGER; (* number of iterations *)
nextTime: Times.Time;
minTime: Times.Time;
minTimeCond: Condition;
interrupted: BOOLEAN; (* interrupted select? *)
highPriority: BOOLEAN; (* priority >= Priorities.interrupt? *)
PROCEDURE FixToRelTime(VAR time: Times.Time);
VAR
currentTime: Times.Time;
relTime: Times.Time;
BEGIN
Clocks.GetTime(Clocks.system, currentTime);
Op.Sub3(SYSTEM.VAL(Op.Operand, relTime), time, currentTime);
time := relTime;
END FixToRelTime;
PROCEDURE GetMinTime(VAR nextTime: Times.Time;
VAR minCond: Condition);
VAR
elp: Element;
time: Times.Time;
condition: Condition;
BEGIN (* GetMinTime *)
nextTime := NIL; minCond := NIL;
IF timeList # NIL THEN
elp := timeList.head;
WHILE elp # NIL DO
elp.domain.if.gettime(domain, elp.cset,
time, condition, waitErrors);
IF Scales.IsAbsolute(time) THEN
FixToRelTime(time);
END;
IF (nextTime = NIL) OR (Op.Compare(time, nextTime) < 0) THEN
nextTime := time; minCond := condition;
END;
elp := elp.next;
END;
END;
END GetMinTime;
PROCEDURE UpdateMinTime(VAR nextTime: Times.Time;
VAR minCond: Condition);
VAR
set: ConditionSet;
time: Times.Time;
cond: Condition;
BEGIN
IF minCond = NIL THEN
nextTime := NIL;
ELSE
CreateSet(set);
Incl(set, minCond);
minCond.domain.if.gettime(minCond.domain, set,
time, cond, waitErrors);
IF Scales.IsAbsolute(time) THEN
FixToRelTime(time);
END;
nextTime := time;
END;
END UpdateMinTime;
PROCEDURE TestNonRingMembers() : BOOLEAN;
PROCEDURE TestList(list: List) : BOOLEAN;
VAR
domain: Domain;
element: Element;
selected: ConditionSet;
interrupted: BOOLEAN;
PROCEDURE TestAndSelect(conditionSet: ConditionSet;
VAR setOfTrueConditions: ConditionSet;
errors: RelatedEvents.Object) : BOOLEAN;
VAR
listp: ConditionList; i: INTEGER;
condition: Condition;
anythingTrue: BOOLEAN;
BEGIN (* TestAndSelect *)
anythingTrue := FALSE;
CreateSet(setOfTrueConditions);
i := 0;
WHILE i < tags DO
listp := conditionSet.bucket[i];
WHILE listp # NIL DO
condition := listp.cond;
IF domain.if.test(domain, condition, errors) THEN
Incl(setOfTrueConditions, condition);
anythingTrue := TRUE;
END;
listp := listp.next;
END;
INC(i);
END;
RETURN anythingTrue
END TestAndSelect;
BEGIN (* TestList *)
IF list = NIL THEN RETURN FALSE END;
element := list.head;
WHILE element # NIL DO
domain := element.domain;
IF (select IN domain.desc.caps) &
(timelimit IN domain.desc.caps) THEN
IF domain.if.select(domain, element.cset, nodelay,
selected, waitErrors, FALSE, interrupted) THEN
ASSERT(Card(selected) > 0);
Union(setOfTrueConditions, selected);
RETURN TRUE
END;
ELSE
IF TestAndSelect(element.cset, selected, waitErrors) THEN
Union(setOfTrueConditions, selected);
RETURN TRUE
END;
END;
element := element.next;
END;
RETURN FALSE
END TestList;
PROCEDURE TestAsyncList(list: List) : BOOLEAN;
VAR
element: Element;
listp: ConditionList; i: INTEGER;
condition: Condition;
anythingFound: BOOLEAN;
BEGIN
IF list = NIL THEN RETURN FALSE END;
anythingFound := FALSE;
element := list.head;
WHILE element # NIL DO
i := 0;
WHILE i < tags DO
listp := element.cset.bucket[i];
WHILE listp # NIL DO
condition := listp.cond;
IF condition.gotEvent THEN
Incl(setOfTrueConditions, condition);
anythingFound := TRUE;
END;
listp := listp.next;
END;
INC(i);
END;
element := element.next;
END;
RETURN anythingFound
END TestAsyncList;
BEGIN (* TestNonRingMembers *)
CreateSet(setOfTrueConditions);
RETURN TestAsyncList(asyncList) OR TestList(others)
END TestNonRingMembers;
BEGIN (* Block *)
NEW(waitErrors); RelatedEvents.QueueEvents(waitErrors);
SortConditions(asyncList, timeList, others, ring, otherAreInternal);
IF asyncList # NIL THEN
(* set up asynchronous events for these conditions --
this should be done before the first call of
TestNonRingMembers() to avoid redundant test calls
*)
IF ~SetupAsyncEvents(asyncList) THEN
(* one of them happened to be TRUE now *)
RETURN
END;
END;
IF TestNonRingMembers() THEN
RETURN
END;
(* check for deadlock *)
ASSERT((asyncList # NIL) OR (timeList # NIL) OR (ring # NIL) OR
~otherAreInternal);
highPriority := Events.GetPriority() >= Priorities.interrupts;
IF ring # NIL THEN
ringMember := ring.head;
largeRing := ring.head # ring.head.next;
ELSE
ringMember := NIL; largeRing := FALSE;
END;
GetMinTime(minTime, minTimeCond);
busyLoop := largeRing OR ~otherAreInternal OR (asyncList # NIL);
loopCnt := 0;
LOOP (* until one of the conditions becomes TRUE *)
(* determine timelimit parameter for select *)
IF busyLoop THEN
getTimeOfNextTry(loopCnt + 1, nextTime);
ASSERT(Op.Compare(nextTime, nodelay) > 0);
IF timeList # NIL THEN
IF Op.Compare(minTime, nextTime) < 0 THEN
nextTime := minTime;
END;
END;
ELSIF timeList # NIL THEN
nextTime := minTime;
ELSE
nextTime := NIL; minTime := NIL; minTimeCond := NIL;
END;
IF (minTime # NIL) & (Op.Compare(minTime, nodelay) <= 0) THEN
CreateSet(setOfTrueConditions);
Incl(setOfTrueConditions, minTimeCond);
EXIT
END;
IF ringMember = NIL THEN
ASSERT(~highPriority);
IF nextTime # NIL THEN
NEW(wakeupEvent);
wakeupEvent.type := wakeupEventType;
Events.SetPriority(wakeupEventType, Events.GetPriority() + 1);
Timers.Schedule(Clocks.system, nextTime, wakeupEvent);
END;
Process.Pause;
ELSE
IF ringMember.domain.if.select
(ringMember.domain, ringMember.cset, nextTime,
setOfTrueConditions, waitErrors,
(* retry = *) FALSE, interrupted) THEN
ASSERT(Card(setOfTrueConditions) > 0);
EXIT
END;
(* timelimit exceeded or interrupted *)
ASSERT(interrupted OR (nextTime # NIL));
IF interrupted THEN
(* remove error event *)
RelatedEvents.GetQueue(waitErrors, queue);
ELSIF (minTimeCond # NIL) & ~busyLoop THEN
(* timelimit exceeded: minTimeCond is now TRUE *)
CreateSet(setOfTrueConditions);
Incl(setOfTrueConditions, minTimeCond);
EXIT
END;
END;
IF TestNonRingMembers() THEN
EXIT
END;
IF timeList # NIL THEN
UpdateMinTime(minTime, minTimeCond);
END;
INC(loopCnt);
END;
(* forward error events to error parameter of SimpleWaitForAndSelect *)
RelatedEvents.GetQueue(waitErrors, queue);
RelatedEvents.AppendQueue(errors, queue);
END Block;
BEGIN (* SimpleWaitForAndSelect *)
IF CommonDomain(conditionSet, domain) &
(select IN domain.desc.caps) THEN
ok := domain.if.select
(domain, conditionSet, NIL, setOfTrueConditions,
errors, (* retry = *) TRUE, interrupted);
(* a return value of FALSE is only to be expected
if a time limit is given or if retry = FALSE
*)
ASSERT(ok);
ELSE
Block;
END;
END SimpleWaitForAndSelect;
PROCEDURE WaitFor*(conditionSet: ConditionSet;
VAR setOfTrueConditions: ConditionSet;
errors: RelatedEvents.Object);
VAR
listp: ConditionList; i: INTEGER;
testSet: ConditionSet;
preconds: ConditionSet;
domain: Domain;
selected: ConditionSet;
anyPreconditions: BOOLEAN;
PROCEDURE PretestClosure(testSet, preconds: ConditionSet);
VAR
listp: ConditionList; i: INTEGER;
domain: Domain;
morePreconditions: ConditionSet;
evenMorePreconditions: ConditionSet;
BEGIN
REPEAT
CreateSet(morePreconditions);
i := 0;
WHILE i < tags DO
listp := preconds.bucket[i];
WHILE listp # NIL DO
domain := listp.cond.domain;
IF (preconditions IN domain.desc.caps) &
domain.if.preconditions(domain, listp.cond,
evenMorePreconditions, errors) &
(evenMorePreconditions # NIL) &
(Card(evenMorePreconditions) > 0) THEN
Union(morePreconditions, evenMorePreconditions);
ELSE
Incl(testSet, listp.cond);
END;
listp := listp.next;
END;
INC(i);
END;
preconds := morePreconditions;
UNTIL Card(preconds) = 0
END PretestClosure;
BEGIN (* WaitFor *)
ASSERT(conditionSet.cardinality > 0);
LOOP
CreateSet(testSet);
anyPreconditions := FALSE;
i := 0;
WHILE i < tags DO
listp := conditionSet.bucket[i];
WHILE listp # NIL DO
domain := listp.cond.domain;
IF (preconditions IN domain.desc.caps) &
domain.if.preconditions(domain,
listp.cond, preconds, errors) &
(preconds # NIL) & (Card(preconds) > 0) THEN
PretestClosure(testSet, preconds);
anyPreconditions := TRUE;
ELSE
Incl(testSet, listp.cond);
END;
listp := listp.next;
END;
INC(i);
END;
SimpleWaitForAndSelect(testSet, selected, errors);
IF ~anyPreconditions THEN
setOfTrueConditions := selected;
EXIT
END;
i := 0;
WHILE i < tags DO
listp := selected.bucket[i];
WHILE listp # NIL DO
IF ~In(conditionSet, listp.cond) THEN
Excl(selected, listp.cond);
END;
listp := listp.next;
END;
INC(i);
END;
IF Card(selected) > 0 THEN
setOfTrueConditions := selected;
EXIT
END;
END;
ASSERT(Card(setOfTrueConditions) > 0);
END WaitFor;
BEGIN
SetGetTimeOfNextTryProc(GetTimeOfNextTry);
Times.CreateAndSet(nodelay, Times.relative, 0, 0, 0);
nextTag := 0;
Events.Define(wakeupEventType);
Events.Handler(wakeupEventType, Events.NilHandler);
END ulmConditions.

575
src/library/ulm/ulmConstStrings.Mod Normal file
View file

@ -0,0 +1,575 @@
(* 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.
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: ConstString.om,v 1.5 2004/05/21 14:22:04 borchert Exp $
----------------------------------------------------------------------------
$Log: ConstString.om,v $
Revision 1.5 2004/05/21 14:22:04 borchert
various performance improvements:
- support of ReadBuf interface procedure of Streams
- CreateD is no longer based on CloseD
- Write takes advantage of Streams.WritePart
(partially based on code and suggestions by Christian Ehrhardt)
Revision 1.4 1997/04/02 07:34:53 borchert
ConstStrings are now an extension of Disciplines.Object
Revision 1.3 1996/01/04 17:03:26 borchert
- const strings are now an extension of Disciplines.Object
- domains added
Revision 1.2 1994/07/18 14:15:42 borchert
unused variables of Close (buf & offset) removed
Revision 1.1 1994/02/22 20:06:38 borchert
Initial revision
----------------------------------------------------------------------------
AFB 10/90
----------------------------------------------------------------------------
*)
MODULE ulmConstStrings;
(* WORM-device for strings *)
IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Objects := ulmObjects, Process := ulmProcess, Services := ulmServices, Streams := ulmStreams, Strings := ulmStrings,
Texts := ulmTexts, Types := ulmTypes;
CONST
tabsize = 1031; (* should be a prime number *)
bufsize = 512;
TYPE
Domain* = POINTER TO DomainRec;
TYPE
Byte = Types.Byte;
Buffer = POINTER TO BufferRec;
BufferRec =
RECORD
buf: ARRAY bufsize OF CHAR;
free: INTEGER; (* buf[free..bufsize-1] is unused *)
next: Buffer;
END;
String* = POINTER TO StringRec;
StringRec* =
RECORD
(Disciplines.ObjectRec)
(* read-only *)
len-: Streams.Count; (* length of string in bytes *)
hashval-: LONGINT; (* hash value *)
(* private part *)
domain: Domain;
length: Streams.Count; (* private copy of length *)
buf: Buffer; (* first buffer containing the string *)
offset: INTEGER; (* offset into buf *)
next: String; (* list of strings with same hash value *)
END;
TYPE
DomainRec* =
RECORD
(Disciplines.ObjectRec)
bucket: ARRAY tabsize OF String;
head, tail: Buffer;
END;
VAR
std*: Domain; (* default domain *)
TYPE
StreamList = POINTER TO StreamListRec;
StreamListRec =
RECORD
stream: Streams.Stream;
next: StreamList;
END;
ReadStream = POINTER TO ReadStreamRec;
ReadStreamRec =
RECORD
(Streams.StreamRec)
string: String;
buf: Buffer; (* current buffer *)
offset: INTEGER; (* index in current buffer *)
pos: Streams.Count; (* current position *)
END;
VAR
freelist: StreamList; (* list of unused streams *)
if: Streams.Interface;
caps: Streams.CapabilitySet;
type: Services.Type; (* ReadStream *)
(* === internal procedures =========================================== *)
PROCEDURE HashVal(s: Streams.Stream; len: Streams.Count;
VAR hashval, orighashval: LONGINT);
(* compute the hash value of the first `len' bytes of `s';
the hash value is returned in two variants:
hashval: hash value MOD tabsize
orighashval: unmodified hash value
*)
CONST
shift = 4;
VAR
ordval: INTEGER;
ch: CHAR;
index: Streams.Count;
BEGIN
Streams.SetPos(s, 0);
hashval := len;
index := 0;
WHILE (index < len) & Streams.ReadByte(s, ch) DO
IF ch >= " " THEN
ordval := ORD(ch) - ORD(" ");
ELSE
ordval := ORD(MAX(CHAR)) - ORD(" ") + ORD(ch);
END;
hashval := ASH(hashval, shift) + ordval;
INC(index);
END;
(* assert: index = len *)
orighashval := hashval;
hashval := hashval MOD tabsize;
END HashVal;
PROCEDURE Equal(s: Streams.Stream; len: Streams.Count;
string: String) : BOOLEAN;
(* consider `s' to be a stream providing `len' bytes;
return TRUE iff the byte sequence of `s' equals that of `string'
*)
VAR
ch: CHAR;
buf: Buffer; offset: INTEGER;
index: Streams.Count;
BEGIN
Streams.SetPos(s, 0);
IF len # string.length THEN
RETURN FALSE
END;
index := 0;
buf := string.buf; offset := string.offset;
WHILE (index < len) & Streams.ReadByte(s, ch) DO
IF ch # buf.buf[offset] THEN
RETURN FALSE
END;
INC(offset);
IF offset >= bufsize THEN
buf := buf.next; offset := 0;
END;
INC(index);
END;
(* assert: index = len *)
RETURN TRUE
END Equal;
PROCEDURE Allocate(domain: Domain; len: Streams.Count;
VAR buf: Buffer; VAR offset: INTEGER);
(* allocate space for `len' bytes;
`buf' and `offset' are returned, designating the
begin of the allocated area; note that
if the space within `buf' is not sufficient its
subsequent buffers are to be used
*)
PROCEDURE NewBuffer;
VAR
buf: Buffer;
BEGIN
NEW(buf);
buf.free := 0;
buf.next := NIL;
IF domain.head = NIL THEN
domain.head := buf;
ELSE
domain.tail.next := buf;
END;
domain.tail := buf;
END NewBuffer;
BEGIN (* Allocate *)
IF (domain.head = NIL) OR (domain.tail.free = bufsize) THEN
NewBuffer;
END;
buf := domain.tail;
offset := buf.free;
WHILE len > 0 DO
IF len <= bufsize - domain.tail.free THEN
INC(domain.tail.free, SHORT(len)); len := 0;
ELSE
DEC(len, bufsize - LONG(domain.tail.free));
domain.tail.free := bufsize;
NewBuffer;
END;
END;
END Allocate;
PROCEDURE CopyString(s: Streams.Stream; length: Streams.Count;
buf: Buffer; offset: INTEGER);
(* copy `length' bytes from `s' to `buf' at the given offset
and its subsequent buffers
*)
VAR
ok: BOOLEAN;
bytes: Streams.Count;
BEGIN
Streams.SetPos(s, 0);
WHILE length > 0 DO
bytes := bufsize - offset;
IF bytes > length THEN
bytes := length;
END;
IF bytes > bufsize - offset THEN
bytes := bufsize - offset;
END;
ok := Streams.ReadPart(s, buf.buf, offset, bytes); ASSERT(ok);
offset := 0;
buf := buf.next;
DEC(length, bytes);
END;
END CopyString;
PROCEDURE InternalCreateD(s: Streams.Stream;
length: Streams.Count;
domain: Domain;
VAR string: String);
(* common part of CloseD and CreateD *)
VAR
orighashval, hashval: LONGINT;
str: String;
BEGIN
HashVal(s, length, hashval, orighashval);
IF domain.bucket[hashval] # NIL THEN
str := domain.bucket[hashval];
WHILE str # NIL DO
IF Equal(s, length, str) THEN
string := str;
RETURN
END;
str := str.next;
END;
END;
NEW(str);
str.domain := domain;
str.len := length; str.length := length;
str.hashval := orighashval;
(* enter new string into the table *)
Allocate(domain, length, str.buf, str.offset);
CopyString(s, length, str.buf, str.offset);
str.next := domain.bucket[hashval];
domain.bucket[hashval] := str;
string := str;
END InternalCreateD;
(* === exported procedures =========================================== *)
PROCEDURE CreateDomain*(VAR domain: Domain);
BEGIN
NEW(domain); domain.head := NIL; domain.tail := NIL;
END CreateDomain;
PROCEDURE Init*(VAR s: Streams.Stream);
(* open s for writing *)
BEGIN
IF freelist # NIL THEN
s := freelist.stream;
freelist := freelist.next;
Streams.SetPos(s, 0);
ELSE
Texts.Open(s);
END;
END Init;
PROCEDURE CloseD*(s: Streams.Stream; domain: Domain; VAR string: String);
(* must be called instead of Streams.Close to get
the resulting string
*)
VAR
length: Streams.Count;
PROCEDURE FreeText;
VAR
free: StreamList;
BEGIN
NEW(free); free.stream := s;
free.next := freelist; freelist := free;
END FreeText;
BEGIN (* CloseD *)
Streams.GetPos(s, length);
InternalCreateD(s, length, domain, string);
FreeText;
END CloseD;
PROCEDURE Close*(s: Streams.Stream; VAR string: String);
BEGIN
CloseD(s, std, string);
END Close;
PROCEDURE CreateD*(VAR string: String; domain: Domain; s: ARRAY OF CHAR);
VAR
length: Streams.Count;
stream: Streams.Stream;
BEGIN
length := 0;
WHILE (length < LEN(s)) & (s[length] # 0X) DO
INC(length);
END;
Strings.Open(stream, s);
InternalCreateD(stream, length, domain, string);
END CreateD;
PROCEDURE Create*(VAR string: String; s: ARRAY OF CHAR);
BEGIN
CreateD(string, std, s);
END Create;
PROCEDURE Open*(VAR s: Streams.Stream; string: String);
(* open s for reading *)
VAR
rs: ReadStream;
BEGIN
NEW(rs);
Services.Init(rs, type);
Streams.Init(rs, if, caps, Streams.nobuf);
rs.string := string;
rs.buf := string.buf;
rs.offset := string.offset;
rs.pos := 0;
s := rs;
END Open;
PROCEDURE Compare*(string1, string2: String) : INTEGER;
(* returns < 0: if string1 < string2
= 0: if string1 = string2 (see note above)
> 0: if string1 > string2
*)
VAR
ch1, ch2: CHAR;
buf1, buf2: Buffer;
offset1, offset2: INTEGER;
len1, len2: Streams.Count;
PROCEDURE Next(VAR buf: Buffer; VAR offset: INTEGER; VAR ch: CHAR);
BEGIN
ch := buf.buf[offset];
INC(offset);
IF offset >= bufsize THEN
buf := buf.next;
offset := 0;
END;
END Next;
BEGIN (* Compare *)
IF string1 = string2 THEN
RETURN 0
END;
len1 := string1.length; len2 := string2.length;
buf1 := string1.buf; buf2 := string2.buf;
offset1 := string1.offset; offset2 := string2.offset;
WHILE (len1 > 0) & (len2 > 0) DO
Next(buf1, offset1, ch1);
Next(buf2, offset2, ch2);
IF ch1 # ch2 THEN
RETURN ORD(ch1) - ORD(ch2)
END;
DEC(len1); DEC(len2);
END;
(* RETURN len1 - len2 does not work because of the return type *)
IF len1 < len2 THEN
RETURN -1
ELSIF len1 > len2 THEN
RETURN 1
ELSE
RETURN 0
END;
END Compare;
PROCEDURE Write*(s: Streams.Stream; string: String);
(* copy contents of `string' to `s' *)
VAR
len: Streams.Count;
buf: Buffer;
offset: INTEGER;
count: Streams.Count;
bytes: Streams.Count;
BEGIN
len := string.length;
buf := string.buf;
offset := string.offset;
count := 0;
LOOP
IF len = 0 THEN EXIT END;
bytes := len;
IF bytes > bufsize - offset THEN
bytes := bufsize - offset;
END;
IF ~Streams.WritePart(s, buf.buf, offset, bytes) THEN
INC(count, s.count);
EXIT
END;
INC(count, bytes); DEC(len, bytes); INC(offset, SHORT(bytes));
IF offset >= bufsize THEN
buf := buf.next;
offset := 0;
END;
END;
s.count := count;
END Write;
PROCEDURE Extract*(VAR s: ARRAY OF CHAR; string: String);
(* copy contents of `string' to `s' *)
VAR
len: Streams.Count;
buf: Buffer;
offset: INTEGER;
index: Streams.Count;
BEGIN
len := string.length;
buf := string.buf;
offset := string.offset;
index := 0;
WHILE (index+1 < LEN(s)) & (len > 0) DO
s[index] := buf.buf[offset];
INC(index);
DEC(len);
INC(offset);
IF offset >= bufsize THEN
buf := buf.next;
offset := 0;
END;
END;
s[index] := 0X;
END Extract;
(* ========= interface procedures for ReadStream ===================== *)
PROCEDURE ReadByte(s: Streams.Stream; VAR byte: Byte) : BOOLEAN;
BEGIN
WITH s: ReadStream DO
IF s.pos >= s.string.length THEN
RETURN FALSE
END;
byte := s.buf.buf[s.offset];
INC(s.offset);
IF s.offset >= bufsize THEN
s.offset := 0;
s.buf := s.buf.next;
END;
INC(s.pos);
RETURN TRUE
END;
END ReadByte;
PROCEDURE ReadBuf(s: Streams.Stream; VAR buf: ARRAY OF Types.Byte(*BYTE*);
off, cnt: Streams.Count) : Streams.Count;
VAR
bytes, max: Streams.Count;
BEGIN
WITH s: ReadStream DO
IF s.pos >= s.string.length THEN
RETURN 0
END;
bytes := s.string.length - s.pos;
IF bytes > cnt THEN
bytes := cnt;
END;
IF bytes > bufsize - s.offset THEN
bytes := bufsize - s.offset;
END;
max := off + bytes;
WHILE off < max DO
buf[off] := s.buf.buf[s.offset];
INC(off); INC(s.offset);
END;
IF s.offset >= bufsize THEN
s.offset := 0;
s.buf := s.buf.next;
END;
INC(s.pos, bytes);
RETURN bytes
END;
END ReadBuf;
PROCEDURE Seek(s: Streams.Stream;
cnt: Streams.Count; whence: Streams.Whence) : BOOLEAN;
VAR
realpos: Streams.Count;
BEGIN
WITH s: ReadStream DO
CASE whence OF
| Streams.fromStart: realpos := cnt;
| Streams.fromPos: realpos := s.pos + cnt;
| Streams.fromEnd: realpos := s.string.length + cnt;
END;
IF (realpos < 0) OR (realpos > s.string.length) THEN
RETURN FALSE
END;
IF realpos # s.pos THEN
IF realpos < s.pos THEN
s.pos := 0; s.offset := s.string.offset; s.buf := s.string.buf;
END;
WHILE s.pos < realpos DO
IF realpos - s.pos < bufsize - s.offset THEN
INC(s.offset, SHORT(realpos - s.pos));
s.pos := realpos;
ELSE
INC(s.pos, LONG(bufsize - s.offset));
s.offset := 0;
s.buf := s.buf.next;
END;
END;
END;
RETURN TRUE
END;
END Seek;
PROCEDURE Tell(s: Streams.Stream; VAR cnt: Streams.Count) : BOOLEAN;
BEGIN
WITH s: ReadStream DO
cnt := s.pos;
RETURN TRUE
END;
END Tell;
(* =================================================================== *)
PROCEDURE FreeHandler(event: Events.Event);
(* set free list to NIL to return the associated storage
to the garbage collector
*)
BEGIN
freelist := NIL;
END FreeHandler;
BEGIN
freelist := NIL;
CreateDomain(std);
caps := {Streams.read, Streams.seek, Streams.tell, Streams.bufio};
NEW(if);
if.read := ReadByte;
if.bufread := ReadBuf;
if.seek := Seek;
if.tell := Tell;
Events.Handler(Process.startOfGarbageCollection, FreeHandler);
Services.CreateType(type, "ConstStrings.ReadStream", "Streams.Stream");
END ulmConstStrings.

140
src/library/ulm/ulmDisciplines.Mod Normal file
View file

@ -0,0 +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.
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
----------------------------------------------------------------------------
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)
*)
IMPORT Objects := ulmObjects;
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;
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;
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;
END ulmDisciplines.

158
src/library/ulm/ulmErrors.Mod Normal file
View file

@ -0,0 +1,158 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: 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
----------------------------------------------------------------------------
AFB 11/91
----------------------------------------------------------------------------
*)
MODULE ulmErrors;
(* translate events to errors *)
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;
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;
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);
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";
END ulmErrors.

567
src/library/ulm/ulmEvents.Mod Normal file
View file

@ -0,0 +1,567 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Events.om,v 1.4 2004/03/30 17:48:14 borchert Exp $
----------------------------------------------------------------------------
$Log: Events.om,v $
Revision 1.4 2004/03/30 17:48:14 borchert
support of external queue handling added
Revision 1.3 1996/01/04 17:07:20 borchert
event types are now an extension of Services.Object
Revision 1.2 1994/07/18 14:17:17 borchert
unused variables of Raise (oldevent + newevent) removed
Revision 1.1 1994/02/22 20:07:41 borchert
Initial revision
----------------------------------------------------------------------------
AFB 8/89
----------------------------------------------------------------------------
*)
MODULE ulmEvents;
IMPORT Objects := ulmObjects, Priorities := ulmPriorities, Services := ulmServices, SYS := ulmSYSTEM;
TYPE
EventType* = POINTER TO EventTypeRec;
CONST
(* possibilities on receipt of an event: *)
default* = 0; (* causes abortion *)
ignore* = 1; (* ignore event *)
funcs* = 2; (* call associated event handlers *)
TYPE
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;
EventHandler = PROCEDURE (event: Event);
(* event managers are needed if there is any action necessary
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
*)
HandlerList = POINTER TO HandlerRec;
HandlerRec* =
RECORD
(Objects.ObjectRec)
handler*: EventHandler;
next*: HandlerList;
END;
SaveList = POINTER TO SaveRec;
SaveRec =
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;
Queue = POINTER TO QueueRec;
QueueRec =
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) *)
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;
CONST
priorityViolation* = 0; (* priority violation (EnterPriority *)
unbalancedExitPriority* = 1; (* unbalanced call of ExitPriority *)
unbalancedRestoreReaction* = 2; (* unbalanced call of RestoreReaction *)
negPriority* = 3; (* negative priority given to SetPriority *)
errorcodes* = 4;
TYPE
ErrorEvent* = POINTER TO ErrorEventRec;
ErrorEventRec* =
RECORD
(EventRec)
errorcode*: SHORTINT;
END;
VAR
errormsg*: ARRAY errorcodes OF Message;
error*: EventType;
VAR
(* private part *)
abort, log, queueHandler: EventHandler;
nestlevel: INTEGER; (* of Raise calls *)
queue: Queue;
lock: BOOLEAN; (* lock critical operations *)
psys: PrioritySystem; (* current priority system *)
PROCEDURE ^ Define*(VAR type: EventType);
PROCEDURE ^ SetPriority*(type: EventType; priority: Priority);
PROCEDURE ^ Raise*(event: Event);
PROCEDURE InitErrorHandling;
BEGIN
Define(error); SetPriority(error, Priorities.liberrors);
errormsg[priorityViolation] :=
"priority violation (Events.EnterPriority)";
errormsg[unbalancedExitPriority] :=
"unbalanced call of Events.ExitPriority";
errormsg[unbalancedRestoreReaction] :=
"unbalanced call of Events.RestoreReaction";
errormsg[negPriority] :=
"negative priority given to Events.SetPriority";
END InitErrorHandling;
PROCEDURE Error(code: SHORTINT);
VAR event: ErrorEvent;
BEGIN
NEW(event); event.type := error;
event.message := errormsg[code];
event.errorcode := code;
Raise(event);
END Error;
PROCEDURE NilEventManager(type: EventType; reaction: Reaction);
END NilEventManager;
PROCEDURE Init*(type: EventType);
VAR
stype: Services.Type;
BEGIN
Services.GetType(type, stype); ASSERT(stype # NIL);
type.handlers := NIL;
type.priority := Priorities.default;
type.reaction := default;
type.manager := NilEventManager;
type.savelist := NIL;
END Init;
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'
*)
BEGIN
NEW(type);
Services.Init(type, eventTypeType);
Init(type);
END Define;
PROCEDURE GetReaction*(type: EventType) : Reaction;
(* returns either `default', `ignore', or `funcs' *)
BEGIN
RETURN type.reaction
END GetReaction;
PROCEDURE SetPriority*(type: EventType; priority: Priority);
(* (re-)defines the priority of an event *)
BEGIN
IF priority <= 0 THEN
Error(negPriority);
ELSE
type.priority := priority;
END;
END SetPriority;
PROCEDURE GetEventPriority*(type: EventType) : Priority;
(* return the priority of the given event *)
BEGIN
RETURN type.priority
END GetEventPriority;
PROCEDURE Manager*(type: EventType; manager: EventManager);
BEGIN
type.manager := manager;
END Manager;
PROCEDURE Handler*(type: EventType; handler: EventHandler);
(* add `handler' to the list of handlers for event `type' *)
VAR
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);
END;
END Handler;
PROCEDURE RemoveHandlers*(type: EventType);
(* remove list of handlers for event `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);
END;
END RemoveHandlers;
PROCEDURE Ignore*(type: EventType);
(* implies RemoveHandlers(type) and causes receipt
of `type' to be ignored
*)
BEGIN
type.handlers := NIL;
IF type.reaction # ignore THEN
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'
*)
BEGIN
handlers := type.handlers;
END GetHandlers;
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
*)
BEGIN
log := loghandler;
END Log;
PROCEDURE GetLog*(VAR loghandler: EventHandler);
(* returns the loghandler set by `Log' *)
BEGIN
loghandler := log;
END GetLog;
PROCEDURE NilHandler*(event: Event);
(* an empty event handler *)
END NilHandler;
(* now QueueHandler will translate partly like
BOOLEAN b;
handler_EventHandler tmphandler;
LONGINT i, j;
i = (LONGINT)handler;
tmphandler = handler_NilHandler;
j = (LONGINT)tmphandler;
b = i != j;
*)
(* changed because voc cannot compara handler and NilHandler -- noch *)
PROCEDURE QueueHandler*(handler: EventHandler);
(* setup an alternative handler of events
that cannot be processed now because
of their unsufficient priority
*)
VAR b : BOOLEAN; (* noch *)
tmphandler : EventHandler;
(*i,j : LONGINT;*)
BEGIN
(*i := SYSTEM.VAL(LONGINT, handler);*)
tmphandler := NilHandler;
(*b := tmphandler = handler;*)
(*j := SYSTEM.VAL(LONGINT, tmphandler);
b := i # j;*)
b := handler # tmphandler;
(*ASSERT (handler # NilHandler);*)
ASSERT(b);
queueHandler := handler;
END QueueHandler;
PROCEDURE AbortHandler*(handler: EventHandler);
(* defines the handler to be called on abortion *)
BEGIN
abort := handler;
END AbortHandler;
PROCEDURE GetAbortHandler*(VAR handler: EventHandler);
(* returns the handler set by `AbortHandler' *)
BEGIN
handler := abort;
END GetAbortHandler;
PROCEDURE ^ CallHandlers(event: Event);
PROCEDURE WorkupQueue;
VAR
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;
END;
END WorkupQueue;
PROCEDURE CallHandlers(event: Event);
VAR
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;
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)
*)
VAR
priority: Priority;
PROCEDURE AddToQueue(event: Event);
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;
END AddToQueue;
BEGIN (* Raise *)
INC(nestlevel);
IF nestlevel >= maxnestlevel THEN
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;
END;
DEC(nestlevel);
END Raise;
PROCEDURE CreatePrioritySystem*(VAR prioritySystem: PrioritySystem);
(* create and initialize a new priority system *)
BEGIN
NEW(prioritySystem);
prioritySystem.currentPriority := Priorities.base;
prioritySystem.priotop := 0;
END CreatePrioritySystem;
PROCEDURE CurrentPrioritySystem*() : PrioritySystem;
(* return the priority system currently active *)
BEGIN
RETURN psys
END CurrentPrioritySystem;
PROCEDURE SwitchPrioritySystem*(prioritySystem: PrioritySystem);
(* switch to another priority system; this is typically
done in case of task switches
*)
BEGIN
psys := prioritySystem;
END SwitchPrioritySystem;
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')
*)
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;
ELSE
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
*)
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;
ELSE
INC(psys.overflow);
END;
END AssertPriority;
PROCEDURE ExitPriority*;
(* causes the priority before the last effective call
of SetPriority or AssertPriority to be restored
*)
BEGIN
IF psys.overflow > 0 THEN
DEC(psys.overflow);
ELSIF psys.priotop = 0 THEN
Error(unbalancedExitPriority);
ELSE
DEC(psys.priotop); psys.currentPriority := psys.priotab[psys.priotop];
WorkupQueue;
END;
END ExitPriority;
PROCEDURE GetPriority*() : Priority;
(* returns the current priority *)
BEGIN
RETURN psys.currentPriority
END GetPriority;
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
*)
VAR
savelist: SaveList;
BEGIN
NEW(savelist);
savelist.reaction := type.reaction;
savelist.handlers := type.handlers;
savelist.next := type.savelist;
type.savelist := savelist;
type.handlers := NIL;
IF type.reaction # ignore THEN
type.reaction := ignore; type.manager(type, ignore);
END;
END SaveReaction;
PROCEDURE RestoreReaction*(type: EventType);
(* restores old reaction;
must be properly nested
*)
VAR
savelist: SaveList;
BEGIN
IF type.savelist = NIL THEN
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;
END;
END RestoreReaction;
BEGIN
CreatePrioritySystem(psys);
Services.CreateType(eventTypeType, "Events.EventType", "");
abort := NilHandler; log := NilHandler; queueHandler := NIL;
nestlevel := 0;
queue := NIL;
lock := FALSE;
InitErrorHandling;
END ulmEvents.

244
src/library/ulm/ulmForwarders.Mod Normal file
View file

@ -0,0 +1,244 @@
(* 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.
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
----------------------------------------------------------------------------
*)
MODULE ulmForwarders; (* AFB 3/95 *)
IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Resources := ulmResources, Services := ulmServices, SYSTEM;
(* SYSTEM is necessary to cast to Disciplines.Discipline; noch *)
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;
END;
IF p # NIL THEN
IF prev = NIL THEN
list := p.next;
ELSE
prev.next := p.next;
END;
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;
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);
END;
END GetObjectDiscipline;
(* === 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;
BEGIN (* Register *)
IF for = "" THEN
Insert(genlist, forward);
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);
END;
END Register;
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 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;
END;
END Update;
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 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
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, 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;
END;
CallForwarders(genlist);
END Forward;
BEGIN
genlist := NIL;
typeDiscID := Disciplines.Unique();
objectDiscID := Disciplines.Unique();
END ulmForwarders.

142
src/library/ulm/ulmIEEE.Mod Normal file
View file

@ -0,0 +1,142 @@
(* Ulm's Oberon Library
Copyright (C) 1989-2005 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: IEEE.om,v 1.1 1994/02/23 07:45:22 borchert Exp $
----------------------------------------------------------------------------
$Log: IEEE.om,v $
Revision 1.1 1994/02/23 07:45:22 borchert
Initial revision
----------------------------------------------------------------------------
AFB 7/89
----------------------------------------------------------------------------
*)
MODULE ulmIEEE;
(* this module is portable as far as a IEEE floating point processor
is present
implementation for the I386 architecture
assumptions:
{0} is the most significant bit
MAX(SET) = 31
double precision binary real format (REAL):
0 1..11 12 .. 63
+-+-----+---------------+
|S| exp | fraction |
+-+-----+---------------+
normalized numbers: min < exp < max
denormalized numbers: exp = 0 and nonzero mantissa
zero: exp = 0 and mantissa = 0
infinity: exp = max and mantissa = 0
not-a-number: exp = max and mantissa # 0
*)
IMPORT SYS := SYSTEM;
CONST
(*patternlen = SYS.SIZE(LONGREAL) DIV SYS.SIZE(SET);*)
patternlen = SIZE(LONGREAL) DIV SIZE(SET) + 23; (* in ulm Oberon system, size of longreal is 12, size of set is 4, so this will be 3
in voc 32 bit we have it as 8 DIV 4
in voc 64 bit we have it as 8 DIV 8
may be it worth just to add some number to the result of division -- noch
*)
VAR
plusInfinity*: REAL;
minusInfinity*: REAL;
nan*: REAL; (* Not-A-Number *)
snan*: REAL; (* Signaling Not-A-Number *)
(*PROCEDURE Convert(VAR from, to: ARRAY OF BYTE);*)
PROCEDURE Convert(VAR from, to: ARRAY OF SYS.BYTE);
VAR i: INTEGER;
BEGIN
i := 0;
WHILE i < LEN(to) DO
to[i] := from[i]; INC(i);
END;
END Convert;
PROCEDURE Normalized*(real: LONGREAL) : BOOLEAN;
VAR pattern: ARRAY patternlen OF SET;
BEGIN
Convert(real, pattern);
pattern[1] := pattern[1] * {20..30};
RETURN (pattern[1] # {}) & (pattern[1] # {20..30})
END Normalized;
PROCEDURE Valid*(real: LONGREAL) : BOOLEAN;
(* returns TRUE if real is normalized or denormalized
but FALSE for infinity and Not-A-Numbers
*)
VAR pattern: ARRAY patternlen OF SET;
BEGIN
Convert(real, pattern);
pattern[1] := pattern[1] * {20..30};
RETURN pattern[1] # {20..30}
END Valid;
PROCEDURE NotANumber*(real: LONGREAL) : BOOLEAN;
(* returns TRUE if real is a (signaling) Not-A-Number *)
VAR pattern: ARRAY patternlen OF SET;
BEGIN
Convert(real, pattern);
RETURN (pattern[1] * {20..30} = {20..30}) &
((pattern[0] * {0..MAX(SET)} # {}) OR
(pattern[1] * {0..19} # {}))
END NotANumber;
PROCEDURE SetReal(VAR real: REAL;
sign: BOOLEAN; expbits: BOOLEAN;
msb: BOOLEAN; otherbits: BOOLEAN);
VAR
pattern: ARRAY 2 OF SET;
BEGIN
pattern[0] := {}; pattern[1] := {};
IF sign THEN
INCL(pattern[1], 31);
END;
IF expbits THEN
pattern[1] := pattern[1] + {20..30};
END;
IF msb THEN
INCL(pattern[1], 19);
END;
IF otherbits THEN
pattern[1] := pattern[1] + {0..18};
pattern[0] := {0..MAX(SET)};
END;
Convert(pattern, real);
END SetReal;
BEGIN
(* sign exp msb mantissa *)
SetReal(plusInfinity, FALSE, TRUE, FALSE, FALSE);
SetReal(minusInfinity, TRUE, TRUE, FALSE, FALSE);
SetReal(nan, FALSE, TRUE, TRUE, TRUE);
SetReal(snan, FALSE, TRUE, FALSE, TRUE);
END ulmIEEE.

244
src/library/ulm/ulmIO.Mod Normal file
View file

@ -0,0 +1,244 @@
MODULE ulmIO;
IMPORT SYS := ulmSYSTEM, SYSTEM;
CONST nl = 0AX;
(* conversions *)
CONST
oct = 0;
dec = 1;
hex = 2;
TYPE
Basetype = SHORTINT; (* oct..hex *)
(* basic IO *)
VAR
Done*: BOOLEAN;
oldch: CHAR;
readAgain: BOOLEAN;
(* ==================== conversions ================================= *)
PROCEDURE ConvertNumber(num, len: LONGINT; btyp: Basetype; neg: BOOLEAN;
VAR str: ARRAY OF CHAR);
(* conversion of a number into a string of characters *)
(* num must get the absolute value of the number *)
(* len is the minimal length of the generated string *)
(* neg means: "the number is negative" for btyp = dec *)
(*CONST
NumberLen = 11;*)
(* we need it as variable to change the value depending on architecture; -- noch *)
VAR
(*digits : ARRAY NumberLen+1 OF CHAR;*)
digits : POINTER TO ARRAY OF CHAR;
base : INTEGER;
cnt, ix : INTEGER;
maxlen : LONGINT;
dig : LONGINT;
NumberLen : SHORTINT;
BEGIN
IF SIZE(LONGINT) = 4 THEN
NumberLen := 11
ELSIF SIZE(LONGINT) = 8 THEN
NumberLen := 21
ELSE
NumberLen := 11 (* default value, corresponds to 32 bit *)
END;
NEW(digits, NumberLen + 1 );
ASSERT(num >= 0);
ix := 1;
WHILE ix <= NumberLen DO
digits[ix] := "0";
INC(ix);
END; (* initialisation *)
IF btyp = oct THEN
base := 8;
ELSIF btyp = dec THEN
base := 10;
ELSIF btyp = hex THEN
base := 10H;
END;
cnt := 0;
REPEAT
INC(cnt);
dig := num MOD base;
num := num DIV base;
IF dig < 10 THEN
dig := dig + ORD("0");
ELSE
dig := dig - 10 + ORD("A");
END;
digits[cnt] := CHR(dig);
UNTIL num = 0;
(* (* i don't like this *)
IF btyp = oct THEN
cnt := 11;
ELSIF btyp = hex THEN
cnt := 8;
ELSIF neg THEN
*)
IF neg THEN
INC(cnt);
digits[cnt] := "-";
END;
maxlen := LEN(str); (* get maximal length *)
IF len > maxlen THEN
len := SHORT(maxlen);
END;
IF cnt > maxlen THEN
cnt := SHORT(maxlen);
END;
ix := 0;
WHILE len > cnt DO
str[ix] := " ";
INC(ix);
DEC(len);
END;
WHILE cnt > 0 DO
str[ix] := digits[cnt];
INC(ix);
DEC(cnt);
END;
IF ix < maxlen THEN
str[ix] := 0X;
END;
END ConvertNumber;
PROCEDURE ConvertInteger(num: LONGINT; len: INTEGER; VAR str: ARRAY OF
CHAR);
(* conversion of an integer decimal number to a string *)
BEGIN
ConvertNumber(ABS(num),len,dec,num < 0,str);
END ConvertInteger;
(* ========================= terminal ============================ *)
PROCEDURE ReadChar(VAR ch: CHAR) : BOOLEAN;
CONST read = 3;
(*VAR r0, r1: INTEGER;*)
VAR r0, r1: LONGINT; (* in ulm system INTEGER and LONGINT have the same 4 byte size; -- noch *)
BEGIN
RETURN SYS.UNIXCALL(read, r0, r1, 0, SYSTEM.ADR(ch), 1) & (r0 > 0)
END ReadChar;
PROCEDURE WriteChar(ch: CHAR) : BOOLEAN;
CONST write = 4;
(*VAR r0, r1: INTEGER;*)
VAR r0, r1: LONGINT; (* same here *)
BEGIN
RETURN SYS.UNIXCALL(write, r0, r1, 1, SYSTEM.ADR(ch), 1)
END WriteChar;
PROCEDURE Read*(VAR ch: CHAR);
BEGIN
Done := TRUE;
IF readAgain THEN
ch := oldch;
readAgain := FALSE;
ELSIF ~ReadChar(ch) THEN
Done := FALSE;
ch := 0X;
ELSE
oldch := ch;
END;
END Read;
PROCEDURE ReadAgain*;
BEGIN
IF readAgain THEN
Done := FALSE;
ELSE
Done := TRUE;
readAgain := TRUE;
END;
END ReadAgain;
PROCEDURE Write*(ch: CHAR);
BEGIN
Done := WriteChar(ch);
END Write;
PROCEDURE WriteLn*;
CONST nl = 0AX;
BEGIN
Write(nl);
END WriteLn;
PROCEDURE WriteString*(s: ARRAY OF CHAR);
VAR i: INTEGER;
BEGIN
i := 0;
WHILE (i < LEN(s)) & (s[i] # 0X) DO
Write(s[i]);
INC(i);
END;
END WriteString;
PROCEDURE InitIO;
BEGIN
readAgain := FALSE;
Done := TRUE;
END InitIO;
PROCEDURE WriteInt*(arg: LONGINT);
VAR field: ARRAY 23 OF CHAR;
BEGIN (* the field size should be big enough to hold the long number. it was 12 to hold just 32 bit numbers, now it can hold 64 bit numbers; need to be more for 128bit numbers; -- noch *)
ConvertInteger(arg, 1, field);
WriteString(field);
END WriteInt;
PROCEDURE ReadInt*(VAR arg: LONGINT);
VAR ch: CHAR;
minus: BOOLEAN;
BEGIN
minus := FALSE;
REPEAT
Read(ch);
IF ~Done THEN RETURN END;
IF ch = "-" THEN
minus := TRUE;
ELSIF (ch # " ") & (ch # nl) & ((ch < "0") OR (ch > "9")) THEN
WriteString("--- Integer expected on input"); WriteLn;
END;
UNTIL (ch >= "0") & (ch <= "9");
arg := ORD(ch) - ORD("0");
REPEAT
Read(ch);
IF ~Done THEN RETURN END;
IF (ch >= "0") & (ch <= "9") THEN
arg := arg*10 + (ORD(ch) - ORD("0"));
END;
UNTIL (ch < "0") OR (ch > "9");
ReadAgain;
IF minus THEN arg := -arg; END;
END ReadInt;
PROCEDURE ReadLine*(VAR string: ARRAY OF CHAR);
VAR
index: INTEGER;
ch: CHAR;
ok: BOOLEAN;
BEGIN
index := 0; ok := TRUE;
LOOP
IF ~ReadChar(ch) THEN ok := FALSE; EXIT END;
IF ch = nl THEN EXIT END;
IF index < LEN(string) THEN
string[index] := ch; INC(index);
END;
END;
IF index < LEN(string) THEN
string[index] := 0X;
END;
Done := ok OR (index > 0);
END ReadLine;
BEGIN
InitIO;
END ulmIO.

122
src/library/ulm/ulmIndirectDisciplines.Mod Normal file
View file

@ -0,0 +1,122 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: IndirectDis.om,v 1.2 1995/03/17 13:56:51 borchert Exp $
----------------------------------------------------------------------------
$Log: IndirectDis.om,v $
Revision 1.2 1995/03/17 13:56:51 borchert
support of Forwarders added
Revision 1.1 1994/06/27 09:50:43 borchert
Initial revision
----------------------------------------------------------------------------
*)
MODULE ulmIndirectDisciplines;
IMPORT Disciplines := ulmDisciplines, Forwarders := ulmForwarders, SYSTEM;
TYPE
Object* = Disciplines.Object;
ObjectRec* = Disciplines.ObjectRec;
Discipline* = Disciplines.Discipline;
DisciplineRec* = Disciplines.DisciplineRec;
Identifier* = Disciplines.Identifier;
TYPE
IndDiscipline = POINTER TO IndDisciplineRec;
IndDisciplineRec =
RECORD
(DisciplineRec)
forwardTo: Object;
END;
VAR
discID: Identifier;
PROCEDURE Forward*(from, to: Object);
VAR
disc: IndDiscipline;
BEGIN
IF to = NIL THEN
Disciplines.Remove(from, discID);
ELSE
NEW(disc); disc.id := discID;
disc.forwardTo := to;
Disciplines.Add(from, disc);
END;
END Forward;
PROCEDURE InternalForward(from, to: Forwarders.Object);
BEGIN
Forward(from, to);
END InternalForward;
PROCEDURE Add*(object: Object; discipline: Discipline);
VAR
disc: IndDiscipline;
BEGIN
WHILE Disciplines.Seek(object, discID, SYSTEM.VAL(Disciplines.Discipline, disc)) DO
object := disc.forwardTo;
END;
Disciplines.Add(object, discipline);
END Add;
PROCEDURE Remove*(object: Object; id: Identifier);
VAR
dummy: Discipline;
disc: IndDiscipline;
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;
END;
END Remove;
PROCEDURE Seek*(object: Object; id: Identifier;
VAR discipline: Discipline) : BOOLEAN;
VAR
disc: IndDiscipline;
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;
END;
END Seek;
PROCEDURE Unique*() : Identifier;
BEGIN
RETURN Disciplines.Unique()
END Unique;
BEGIN
discID := Disciplines.Unique();
Forwarders.Register("", InternalForward);
END ulmIndirectDisciplines.

353
src/library/ulm/ulmIntOperations.Mod Normal file
View file

@ -0,0 +1,353 @@
(* 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.
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: IntOperatio.om,v 1.1 1997/04/03 09:38:51 borchert Exp $
----------------------------------------------------------------------------
$Log: IntOperatio.om,v $
Revision 1.1 1997/04/03 09:38:51 borchert
Initial revision
----------------------------------------------------------------------------
*)
MODULE ulmIntOperations; (* Frank B.J. Fischer *)
IMPORT Operations := ulmOperations, PersistentObjects := ulmPersistentObjects, Services := ulmServices, Streams := ulmStreams, Types := ulmTypes, SYSTEM;
(* 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
mod* = 5; pow* = 6; inc* = 7; dec* = 8; mmul* = 9; mpow* = 10;
odd* = 11; shift* = 12;
TYPE
Operation* = Operations.Operation; (* Operations.add..mpow *)
Operand* = POINTER TO OperandRec;
TYPE
CapabilitySet* = Operations.CapabilitySet;
(* SET of [Operations.add..shift] *)
IsLargeEnoughForProc* = PROCEDURE (op: Operations.Operand;
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);
Interface* = POINTER TO InterfaceRec;
InterfaceRec* = RECORD
(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;
END;
VAR
operandType: Services.Type;
PROCEDURE Init*(op: Operand; if: Interface; caps: CapabilitySet);
BEGIN
Operations.Init(op, if, caps);
op.if := if;
op.caps := caps;
END Init;
PROCEDURE Capabilities*(op: Operand): CapabilitySet;
BEGIN
RETURN op.caps
END Capabilities;
PROCEDURE IsLargeEnoughFor*(op: Operations.Operand; n: LONGINT): BOOLEAN;
BEGIN
WITH op: Operand DO
RETURN op.if.isLargeEnoughFor(op, n)
END;
END IsLargeEnoughFor;
PROCEDURE Unsigned*(op: Operations.Operand): BOOLEAN;
BEGIN
WITH op: Operand DO
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
*)
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;*)
END IntToOp;
PROCEDURE OpToInt*(op: Operations.Operand; VAR int32: Types.Int32);
(* converts op into int32 *)
BEGIN
WITH op: Operand DO
op.if.opToInt(op, int32);
END;
END OpToInt;
PROCEDURE Log2*(op: Operations.Operand): LONGINT;
BEGIN
WITH op: Operand DO
RETURN op.if.log2(op)
END;
END Log2;
PROCEDURE Odd*(op: Operations.Operand): BOOLEAN;
BEGIN
WITH op: Operand DO
ASSERT(odd IN op.caps);
RETURN op.if.odd(op)
END;
END Odd;
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;
END;
END Op;
PROCEDURE Shift*(op1: Operations.Operand; n: INTEGER): Operations.Operand;
BEGIN
WITH op1: Operand DO
ASSERT(shift IN op1.caps);
RETURN op1.if.shift(op1,n);
END;
END Shift;
PROCEDURE Shift2*(VAR op1: Operations.Operand; n: INTEGER);
BEGIN
op1 := Shift(op1, n);
END Shift2;
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;
END;
END Shift3;
PROCEDURE Inc*(op1: Operations.Operand): Operations.Operand;
VAR
result: Operations.Operand;
BEGIN
result := NIL;
Op(inc,op1,NIL,NIL,result);
RETURN result
END Inc;
PROCEDURE Inc2*(VAR op1: Operations.Operand);
BEGIN
Op(inc,op1,NIL,NIL,op1);
END Inc2;
PROCEDURE Inc3*(VAR result: Operations.Operand; op1: Operations.Operand);
BEGIN
Op(inc,op1,NIL,NIL,result);
END Inc3;
PROCEDURE Dec*(op1: Operations.Operand): Operations.Operand;
VAR
result: Operations.Operand;
BEGIN
result := NIL;
Op(dec,op1,NIL,NIL,result);
RETURN result
END Dec;
PROCEDURE Dec2*(VAR op1: Operations.Operand);
BEGIN
Op(dec,op1,NIL,NIL,op1);
END Dec2;
PROCEDURE Dec3*(VAR result: Operations.Operand; op1: Operations.Operand);
BEGIN
Op(dec,op1,NIL,NIL,result);
END Dec3;
PROCEDURE Mod*(op1, op2: Operations.Operand): Operations.Operand;
VAR
result: Operations.Operand;
BEGIN
result := NIL;
Op(mod, op1, op2, NIL, result);
RETURN result
END Mod;
PROCEDURE Mod2*(VAR op1: Operations.Operand; op2: Operations.Operand);
BEGIN
Op(mod, op1, op2, NIL, op1);
END Mod2;
PROCEDURE Mod3*(VAR result: Operations.Operand; op1, op2: Operations.Operand);
BEGIN
Op(mod, op1, op2, NIL, result);
END Mod3;
PROCEDURE Pow*(op1, op2: Operations.Operand): Operations.Operand;
VAR
result : Operand;
BEGIN
result := NIL;
(*Op(pow, op1, op2, NIL, result);*)
Op(pow, op1, op2, NIL, SYSTEM.VAL(Operations.Operand, result)); (* -- noch *)
RETURN result
END Pow;
PROCEDURE Pow2*(VAR op1: Operations.Operand; op2: Operations.Operand);
BEGIN
Op(pow, op1, op2, NIL, op1);
END Pow2;
PROCEDURE Pow3*(VAR result: Operations.Operand; op1, op2: Operations.Operand);
BEGIN
Op(pow, op1, op2, NIL, result);
END Pow3;
PROCEDURE MMul*(op1, op2, op3: Operations.Operand): Operations.Operand;
VAR
result : Operand;
BEGIN
result := NIL;
(*Op(mmul, op1, op2, op3, result); *)
Op(mmul, op1, op2, op3, SYSTEM.VAL(Operations.Operand, result)); (* --noch*)
RETURN result
END MMul;
PROCEDURE MMul2*(VAR op1: Operations.Operand; op2, op3: Operations.Operand);
BEGIN
Op(mmul, op1, op2, op3, op1);
END MMul2;
PROCEDURE MMul3*(VAR result: Operations.Operand;
op1, op2, op3: Operations.Operand);
BEGIN
Op(mmul, op1, op2, op3, result);
END MMul3;
PROCEDURE MPow*(op1, op2, op3: Operations.Operand): Operations.Operand;
VAR
result : Operand;
BEGIN
result := NIL;
(*Op(mpow, op1, op2, op3, result); *)
Op(mpow, op1, op2, op3, SYSTEM.VAL(Operations.Operand, result)); (* -- noch*)
RETURN result
END MPow;
PROCEDURE MPow2*(VAR op1: Operations.Operand; op2, op3: Operations.Operand);
BEGIN
Op(mpow, op1, op2, op3, op1);
END MPow2;
PROCEDURE MPow3*(VAR result: Operations.Operand;
op1, op2, op3: Operations.Operand);
BEGIN
Op(mpow, op1, op2, op3, result);
END MPow3;
BEGIN
PersistentObjects.RegisterType(operandType,"IntOperations.Operand",
"Operations.Operand", NIL);
END ulmIntOperations.

216
src/library/ulm/ulmLoader.Mod Normal file
View file

@ -0,0 +1,216 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Loader.om,v 1.3 2004/09/03 09:46:50 borchert Exp $
----------------------------------------------------------------------------
$Log: Loader.om,v $
Revision 1.3 2004/09/03 09:46:50 borchert
error events are also raised as global events
(this allows to log all failed loading operations)
Revision 1.2 1996/01/04 16:48:33 borchert
support for dynamic loading of service providers added
Revision 1.1 1994/02/22 20:08:13 borchert
Initial revision
----------------------------------------------------------------------------
AFB 6/93
----------------------------------------------------------------------------
*)
MODULE ulmLoader;
(* load and initialize modules *)
IMPORT ASCII := ulmASCII , Events := ulmEvents, Priorities := ulmPriorities, RelatedEvents := ulmRelatedEvents, Services := ulmServices;
CONST
loadService* = 0;
TYPE
CapabilitySet* = SET; (* loadService..loadService *)
LoadProc* = PROCEDURE (module: ARRAY OF CHAR;
errors: RelatedEvents.Object) : BOOLEAN;
LoadServiceProc* = PROCEDURE (service, for: ARRAY OF CHAR;
errors: RelatedEvents.Object) : BOOLEAN;
Interface* = POINTER TO InterfaceRec;
InterfaceRec* =
RECORD
load*: LoadProc;
loadService*: LoadServiceProc;
END;
CONST
noInterface* = 0; (* SetInterface has not been called yet *)
moduleNotLoaded* = 1; (* interface procedure returned FALSE *)
servicesNotSupported* = 2; (* no dynamic loading of service providers *)
serviceNotLoaded* = 3; (* interface procedure returned FALSE *)
errorcodes* = 4;
TYPE
ErrorEvent* = POINTER TO ErrorEventRec;
ErrorEventRec* =
RECORD
(Events.EventRec)
errorcode*: SHORTINT;
module*: Events.Message; (* module or service name *)
for*: Events.Message; (* type name for serviceNotLoaded *)
END;
VAR
errormsg*: ARRAY errorcodes OF Events.Message;
error*: Events.EventType;
VAR
loadif: Interface; loadcaps: CapabilitySet;
(* commented out because Loader must not import Streams, Errors
and Strings to avoid reference cycles
PROCEDURE WriteErrorEvent(s: Streams.Stream; event: Events.Event);
PROCEDURE WriteString(string: ARRAY OF CHAR);
BEGIN
IF ~Streams.WritePart(s, string, 0, Strings.Len(string)) THEN END;
END WriteString;
PROCEDURE WriteChar(ch: CHAR);
BEGIN
IF ~Streams.WriteByte(s, ch) THEN END;
END WriteChar;
BEGIN
WITH event: ErrorEvent DO
WriteChar(ASCII.quote);
WriteString(event.module);
WriteChar(ASCII.quote);
IF event.for # "" THEN
WriteString(" for ");
WriteChar(ASCII.quote);
WriteString(event.for);
WriteChar(ASCII.quote);
END;
WriteString(": ");
WriteString(event.message);
END;
END WriteErrorEvent;
*)
PROCEDURE InitErrorHandling;
BEGIN
Events.Define(error);
Events.SetPriority(error, Priorities.liberrors);
Events.Ignore(error);
(* Errors.AssignWriteProcedure(error, WriteErrorEvent); *)
errormsg[noInterface] := "Loader.SetInterface has not been called yet";
errormsg[moduleNotLoaded] := "module cannot be loaded";
errormsg[servicesNotSupported] :=
"dynamic loading of service providers is not supported";
errormsg[serviceNotLoaded] :=
"serving module cannot be loaded";
END InitErrorHandling;
PROCEDURE SetInterface*(if: Interface; caps: CapabilitySet);
BEGIN
loadif := if; loadcaps := caps;
END SetInterface;
PROCEDURE Load*(module: ARRAY OF CHAR;
errors: RelatedEvents.Object) : BOOLEAN;
PROCEDURE Error(errorcode: SHORTINT);
VAR
event: ErrorEvent;
BEGIN
NEW(event);
event.type := error;
event.message := errormsg[errorcode];
event.errorcode := errorcode;
COPY(module, event.module);
event.for[0] := 0X;
RelatedEvents.Raise(errors, event);
Events.Raise(event);
END Error;
BEGIN
IF loadif = NIL THEN
Error(noInterface); RETURN FALSE
ELSE
IF ~loadif.load(module, errors) THEN
Error(moduleNotLoaded); RETURN FALSE
END;
RETURN TRUE
END;
END Load;
PROCEDURE LoadService*(service, for: ARRAY OF CHAR;
errors: RelatedEvents.Object) : BOOLEAN;
PROCEDURE Error(errorcode: SHORTINT);
VAR
event: ErrorEvent;
BEGIN
NEW(event);
event.type := error;
event.message := errormsg[errorcode];
event.errorcode := errorcode;
COPY(service, event.module);
COPY(for, event.for);
RelatedEvents.Raise(errors, event);
Events.Raise(event);
END Error;
BEGIN
IF loadif = NIL THEN
Error(noInterface); RETURN FALSE
ELSIF ~(loadService IN loadcaps) THEN
Error(servicesNotSupported); RETURN FALSE
ELSIF ~loadif.loadService(service, for, errors) THEN
Error(serviceNotLoaded); RETURN FALSE
ELSE
RETURN TRUE
END;
END LoadService;
(* === support of Services =========================================== *)
PROCEDURE LService(service, for: ARRAY OF CHAR) : BOOLEAN;
BEGIN
RETURN LoadService(service, for, RelatedEvents.null)
END LService;
PROCEDURE LModule(module: ARRAY OF CHAR) : BOOLEAN;
BEGIN
RETURN Load(module, RelatedEvents.null)
END LModule;
PROCEDURE InitServices;
VAR
if: Services.LoaderInterface;
BEGIN
NEW(if);
if.loadService := LService;
if.loadModule := LModule;
Services.InitLoader(if);
END InitServices;
BEGIN
loadif := NIL; loadcaps := {};
InitErrorHandling;
InitServices;
END ulmLoader.

183
src/library/ulm/ulmMC68881.Mod Normal file
View file

@ -0,0 +1,183 @@
(* Oberon Library - SunOS 4.1 - AFB 8/90 *)
(* (c) University of Ulm, Sektion Informatik, D-7900 Ulm *)
MODULE ulmMC68881;
(* library interface to MC68881 instructions *)
IMPORT SYS := SYSTEM;
CONST
available* = FALSE; (* TRUE if MC68881 present *)
(* rounding modes *)
toNearest* = 0;
towardZero* = 1;
towardMinusInfinity* = 2;
towardPlusInfinity* = 3;
(* rounding precision *)
extended* = 0;
single* = 1;
double* = 2;
(* exceptions *)
branchOnUnordered* = 0;
signalingNotANumber* = 1;
operandError* = 2;
overflow* = 3;
underflow* = 4;
divideByZero* = 5;
inexactOperation* = 6;
inexactDecimalInput* = 7;
CONST
floatlen* = 4; (* length of a single precision real number *)
(* monadic operations *)
PROCEDURE FACOS*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FACOS;
PROCEDURE FASIN*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FASIN;
PROCEDURE FATAN*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FATAN;
PROCEDURE FATANH*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FATANH;
PROCEDURE FCOS*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FCOS;
PROCEDURE FCOSH*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FCOSH;
PROCEDURE FETOX*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FETOX;
PROCEDURE FETOXM1*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FETOXM1;
PROCEDURE FGETEXP*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FGETEXP;
PROCEDURE FGETMAN*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FGETMAN;
PROCEDURE FLOG10*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FLOG10;
PROCEDURE FLOG2*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FLOG2;
PROCEDURE FLOGN*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FLOGN;
PROCEDURE FLOGNP1*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FLOGNP1;
PROCEDURE FSIN*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FSIN;
PROCEDURE FSINH*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FSINH;
PROCEDURE FSQRT*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FSQRT;
PROCEDURE FTAN*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FTAN;
PROCEDURE FTANH*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FTANH;
PROCEDURE FTENTOX*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FTENTOX;
PROCEDURE FTWOTOX*(x: LONGREAL) : LONGREAL;
BEGIN
RETURN ABS(x)
END FTWOTOX;
PROCEDURE GetExceptionEnable*(VAR exceptions: SET);
BEGIN
exceptions := {};
END GetExceptionEnable;
PROCEDURE SetExceptionEnable*(exceptions: SET);
BEGIN
exceptions := {};
END SetExceptionEnable;
PROCEDURE GetRoundingMode*(VAR precision, mode: INTEGER);
BEGIN
precision := 1;
mode := 2;
END GetRoundingMode;
PROCEDURE SetRoundingMode*(precision, mode: INTEGER);
BEGIN
precision := 1;
mode := 2;
END SetRoundingMode;
(* conversions to and from single precision (C's float);
float must consist of at least floatlen bytes
*)
PROCEDURE RealToFloat*(real: LONGREAL; VAR float: ARRAY OF SYS.BYTE);
BEGIN
(*SYS.WMOVE(SYS.ADR(real), SYS.ADR(float), floatlen DIV 4);*)
END RealToFloat;
PROCEDURE FloatToReal*(float: ARRAY OF SYS.BYTE; VAR real: LONGREAL);
BEGIN
(*SYS.WMOVE(SYS.ADR(float), SYS.ADR(real), floatlen DIV 4);*)
END FloatToReal;
END ulmMC68881.

546
src/library/ulm/ulmNetIO.Mod Normal file
View file

@ -0,0 +1,546 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: NetIO.om,v 1.4 2004/05/21 15:19:03 borchert Exp $
----------------------------------------------------------------------------
$Log: NetIO.om,v $
Revision 1.4 2004/05/21 15:19:03 borchert
performance improvements:
- ReadConstStringD prefers Streams.ReadPart and ConstStrings.CreateD,
if possible
(based on code by Christian Ehrhardt)
- WriteConstString uses Streams.Copy instead of a loop that uses
Streams.ReadByte and Streams.WriteByte
Revision 1.3 1995/03/17 16:28:20 borchert
- SizeOf stuff removed
- support of const strings added
- support of Forwarders added
Revision 1.2 1994/07/18 14:18:37 borchert
unused variables of WriteString (ch + index) removed
Revision 1.1 1994/02/22 20:08:43 borchert
Initial revision
----------------------------------------------------------------------------
AFB 6/93
----------------------------------------------------------------------------
*)
MODULE ulmNetIO;
(* abstraction for the exchange of Oberon base types which
are components of persistent data structures
*)
IMPORT ConstStrings := ulmConstStrings, Disciplines := ulmDisciplines, Forwarders := ulmForwarders, Streams := ulmStreams, Strings := ulmStrings,
SYS := SYSTEM, Types := ulmTypes;
TYPE
Byte* = Types.Byte;
TYPE
ReadByteProc* =
PROCEDURE (s: Streams.Stream; VAR byte: Byte) : BOOLEAN;
ReadCharProc* =
PROCEDURE (s: Streams.Stream; VAR char: CHAR) : BOOLEAN;
ReadBooleanProc* =
PROCEDURE (s: Streams.Stream; VAR boolean: BOOLEAN) : BOOLEAN;
ReadShortIntProc* =
PROCEDURE (s: Streams.Stream; VAR shortint: SHORTINT) : BOOLEAN;
ReadIntegerProc* =
PROCEDURE (s: Streams.Stream; VAR integer: INTEGER) : BOOLEAN;
ReadLongIntProc* =
PROCEDURE (s: Streams.Stream; VAR longint: LONGINT) : BOOLEAN;
ReadRealProc* =
PROCEDURE (s: Streams.Stream; VAR real: REAL) : BOOLEAN;
ReadLongRealProc* =
PROCEDURE (s: Streams.Stream; VAR longreal: LONGREAL) : BOOLEAN;
ReadSetProc* =
PROCEDURE (s: Streams.Stream; VAR set: SET) : BOOLEAN;
ReadStringProc* =
PROCEDURE (s: Streams.Stream; VAR string: ARRAY OF CHAR) : BOOLEAN;
ReadConstStringProc* =
PROCEDURE (s: Streams.Stream; domain: ConstStrings.Domain;
VAR string: ConstStrings.String) : BOOLEAN;
WriteByteProc* =
PROCEDURE (s: Streams.Stream; byte: Byte) : BOOLEAN;
WriteCharProc* =
PROCEDURE (s: Streams.Stream; char: CHAR) : BOOLEAN;
WriteBooleanProc* =
PROCEDURE (s: Streams.Stream; boolean: BOOLEAN) : BOOLEAN;
WriteShortIntProc* =
PROCEDURE (s: Streams.Stream; shortint: SHORTINT) : BOOLEAN;
WriteIntegerProc* =
PROCEDURE (s: Streams.Stream; integer: INTEGER) : BOOLEAN;
WriteLongIntProc* =
PROCEDURE (s: Streams.Stream; longint: LONGINT) : BOOLEAN;
WriteRealProc* =
PROCEDURE (s: Streams.Stream; real: REAL) : BOOLEAN;
WriteLongRealProc* =
PROCEDURE (s: Streams.Stream; longreal: LONGREAL) : BOOLEAN;
WriteSetProc* =
PROCEDURE (s: Streams.Stream; set: SET) : BOOLEAN;
WriteStringProc* =
PROCEDURE (s: Streams.Stream; string: ARRAY OF CHAR) : BOOLEAN;
WriteConstStringProc* =
PROCEDURE (s: Streams.Stream;
string: ConstStrings.String) : BOOLEAN;
Interface* = POINTER TO InterfaceRec;
InterfaceRec* =
RECORD
readByte*: ReadByteProc;
readChar*: ReadCharProc;
readBoolean*: ReadBooleanProc;
readShortInt*: ReadShortIntProc;
readInteger*: ReadIntegerProc;
readLongInt*: ReadLongIntProc;
readReal*: ReadRealProc;
readLongReal*: ReadLongRealProc;
readSet*: ReadSetProc;
readString*: ReadStringProc;
readConstString*: ReadConstStringProc;
writeByte*: WriteByteProc;
writeChar*: WriteCharProc;
writeBoolean*: WriteBooleanProc;
writeShortInt*: WriteShortIntProc;
writeInteger*: WriteIntegerProc;
writeLongInt*: WriteLongIntProc;
writeReal*: WriteRealProc;
writeLongReal*: WriteLongRealProc;
writeSet*: WriteSetProc;
writeString*: WriteStringProc;
writeConstString*: WriteConstStringProc;
END;
(* private data structures *)
TYPE
Discipline = POINTER TO DisciplineRec;
DisciplineRec =
RECORD
(Disciplines.DisciplineRec)
if: Interface;
END;
VAR
discID: Disciplines.Identifier;
PROCEDURE Swap (VAR a : ARRAY OF SYS.BYTE);
VAR
i,j : LONGINT;
tmp : SYS.BYTE;
BEGIN
i := 0; j := LEN (a) - 1;
WHILE i < j DO
tmp := a[i]; a[i] := a[j]; a[j] := tmp;
INC (i); DEC (j);
END;
END Swap;
PROCEDURE BitSwap (VAR a : ARRAY OF SYS.BYTE);
VAR
i,old, bit : LONGINT;
new : LONGINT;
BEGIN
i := 0;
WHILE i < LEN (a) DO
old := ORD (SYS.VAL (CHAR, a[i]));
new := 0; bit := 080H;
WHILE old # 0 DO
IF ODD (old) THEN
INC (new, bit);
END;
bit := ASH (bit, -1);;
old := ASH (old, -1);
END;
a[i] := SYS.VAL (SYS.BYTE, new);
INC (i);
END;
END BitSwap;
PROCEDURE ^ Forward(from, to: Forwarders.Object);
PROCEDURE AttachInterface*(s: Streams.Stream; if: Interface);
VAR
disc: Discipline;
BEGIN
IF if # NIL THEN
NEW(disc); disc.id := discID; disc.if := if;
Disciplines.Add(s, disc);
ELSE
Disciplines.Remove(s, discID);
END;
Forwarders.Update(s, Forward);
END AttachInterface;
PROCEDURE GetInterface(s: Streams.Stream; VAR if: Interface);
VAR
disc: Discipline;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
if := disc.if;
ELSE
if := NIL;
END;
END GetInterface;
PROCEDURE CopyInterface*(from, to: Streams.Stream);
VAR
if: Interface;
BEGIN
GetInterface(from, if);
AttachInterface(to, if);
END CopyInterface;
PROCEDURE Forward(from, to: Forwarders.Object);
BEGIN
(* this check is necessary because of Forwarders.Update *)
IF ~(from IS Streams.Stream) OR ~(to IS Streams.Stream) THEN
RETURN
END;
WITH from: Streams.Stream DO WITH to: Streams.Stream DO
(* be careful here, from & to must be reversed *)
CopyInterface(to, from);
END; END;
END Forward;
PROCEDURE ReadByte*(s: Streams.Stream; VAR byte: Byte) : BOOLEAN;
VAR
disc: Discipline;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.readByte(s, byte)
ELSE
RETURN Streams.ReadByte(s, byte)
END;
END ReadByte;
PROCEDURE ReadChar*(s: Streams.Stream; VAR char: CHAR) : BOOLEAN;
VAR
disc: Discipline;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.readChar(s, char)
ELSE
RETURN Streams.ReadByte(s, char)
END;
END ReadChar;
PROCEDURE ReadBoolean*(s: Streams.Stream; VAR boolean: BOOLEAN) : BOOLEAN;
VAR
disc: Discipline;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.readBoolean(s, boolean)
ELSE
RETURN Streams.Read(s, boolean)
END;
END ReadBoolean;
PROCEDURE ReadShortInt*(s: Streams.Stream; VAR shortint: SHORTINT) : BOOLEAN;
VAR
disc: Discipline;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.readShortInt(s, shortint)
ELSE
RETURN Streams.ReadByte(s, shortint)
END;
END ReadShortInt;
PROCEDURE ReadInteger*(s: Streams.Stream; VAR integer: INTEGER) : BOOLEAN;
VAR
disc: Discipline;
ret : BOOLEAN;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.readInteger(s, integer)
ELSE
ret := Streams.Read(s, integer);
IF Types.byteorder = Types.littleEndian THEN
Swap (integer);
END;
RETURN ret;
END;
END ReadInteger;
PROCEDURE ReadLongInt*(s: Streams.Stream; VAR longint: LONGINT) : BOOLEAN;
VAR
disc: Discipline;
ret : BOOLEAN;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.readLongInt(s, longint)
ELSE
ret := Streams.Read(s, longint);
IF Types.byteorder = Types.littleEndian THEN
Swap (longint);
END;
RETURN ret;
END;
END ReadLongInt;
PROCEDURE ReadReal*(s: Streams.Stream; VAR real: REAL) : BOOLEAN;
VAR
disc: Discipline;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.readReal(s, real)
ELSE
RETURN Streams.Read(s, real)
END;
END ReadReal;
PROCEDURE ReadLongReal*(s: Streams.Stream; VAR longreal: LONGREAL) : BOOLEAN;
VAR
disc: Discipline;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.readLongReal(s, longreal)
ELSE
RETURN Streams.Read(s, longreal)
END;
END ReadLongReal;
PROCEDURE ReadSet*(s: Streams.Stream; VAR set: SET) : BOOLEAN;
VAR
disc: Discipline;
ret : BOOLEAN;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.readSet(s, set)
ELSE
ret := Streams.Read(s, set);
IF Types.byteorder = Types.littleEndian THEN
BitSwap (set);
END;
RETURN ret;
END;
END ReadSet;
PROCEDURE ReadString*(s: Streams.Stream; VAR string: ARRAY OF CHAR) : BOOLEAN;
VAR
disc: Discipline;
ch: CHAR; index: LONGINT;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.readString(s, string)
ELSE
index := 0;
WHILE Streams.ReadByte(s, ch) & (ch # 0X) DO
IF index + 1 < LEN(string) THEN
string[index] := ch; INC(index);
END;
END;
string[index] := 0X;
RETURN ~s.error
END;
END ReadString;
PROCEDURE ReadConstStringD*(s: Streams.Stream;
domain: ConstStrings.Domain;
VAR string: ConstStrings.String) : BOOLEAN;
CONST
bufsize = 512;
VAR
length: LONGINT;
buf: Streams.Stream;
ch: CHAR;
disc: Discipline;
stringbuf: ARRAY bufsize OF CHAR;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.readConstString(s, domain, string)
ELSE
IF ReadLongInt(s, length) THEN
IF length >= bufsize THEN
ConstStrings.Init(buf);
IF ~Streams.Copy(s, buf, length) THEN
RETURN FALSE
END;
ConstStrings.CloseD(buf, domain, string);
RETURN length = s.count;
ELSE
IF ~Streams.ReadPart(s, stringbuf, 0, length) THEN
RETURN FALSE
END;
stringbuf[length] := 0X;
ConstStrings.CreateD(string, domain, stringbuf);
RETURN TRUE
END;
ELSE
RETURN FALSE
END;
END;
END ReadConstStringD;
PROCEDURE ReadConstString*(s: Streams.Stream;
VAR string: ConstStrings.String) : BOOLEAN;
BEGIN
RETURN ReadConstStringD(s, ConstStrings.std, string)
END ReadConstString;
PROCEDURE WriteByte*(s: Streams.Stream; byte: Byte) : BOOLEAN;
VAR
disc: Discipline;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.writeByte(s, byte)
ELSE
RETURN Streams.WriteByte(s, byte)
END;
END WriteByte;
PROCEDURE WriteChar*(s: Streams.Stream; char: CHAR) : BOOLEAN;
VAR
disc: Discipline;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.writeChar(s, char)
ELSE
RETURN Streams.WriteByte(s, char)
END;
END WriteChar;
PROCEDURE WriteBoolean*(s: Streams.Stream; boolean: BOOLEAN) : BOOLEAN;
VAR
disc: Discipline;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.writeBoolean(s, boolean)
ELSE
RETURN Streams.Write(s, boolean)
END;
END WriteBoolean;
PROCEDURE WriteShortInt*(s: Streams.Stream; shortint: SHORTINT) : BOOLEAN;
VAR
disc: Discipline;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.writeShortInt(s, shortint)
ELSE
RETURN Streams.WriteByte(s, shortint)
END;
END WriteShortInt;
PROCEDURE WriteInteger*(s: Streams.Stream; integer: INTEGER) : BOOLEAN;
VAR
disc: Discipline;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.writeInteger(s, integer)
ELSE
IF Types.byteorder = Types.littleEndian THEN
Swap (integer);
END;
RETURN Streams.Write(s, integer);
END;
END WriteInteger;
PROCEDURE WriteLongInt*(s: Streams.Stream; longint: LONGINT) : BOOLEAN;
VAR
disc: Discipline;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.writeLongInt(s, longint)
ELSE
IF Types.byteorder = Types.littleEndian THEN
Swap (longint);
END;
RETURN Streams.Write(s, longint);
END;
END WriteLongInt;
PROCEDURE WriteReal*(s: Streams.Stream; real: REAL) : BOOLEAN;
VAR
disc: Discipline;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.writeReal(s, real)
ELSE
RETURN Streams.Write(s, real)
END;
END WriteReal;
PROCEDURE WriteLongReal*(s: Streams.Stream; longreal: LONGREAL) : BOOLEAN;
VAR
disc: Discipline;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.writeLongReal(s, longreal)
ELSE
RETURN Streams.Write(s, longreal)
END;
END WriteLongReal;
PROCEDURE WriteSet*(s: Streams.Stream; set: SET) : BOOLEAN;
VAR
disc: Discipline;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.writeSet(s, set)
ELSE
IF Types.byteorder = Types.littleEndian THEN
BitSwap (set);
END;
RETURN Streams.Write(s, set)
END;
END WriteSet;
PROCEDURE WriteString*(s: Streams.Stream; string: ARRAY OF CHAR) : BOOLEAN;
VAR
disc: Discipline;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.writeString(s, string)
ELSE
RETURN Streams.WritePart(s, string, 0, Strings.Len(string)) &
Streams.WriteByte(s, 0X)
END;
END WriteString;
PROCEDURE WriteConstString*(s: Streams.Stream;
string: ConstStrings.String) : BOOLEAN;
VAR
ch: CHAR;
buf: Streams.Stream;
disc: Discipline;
BEGIN
IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN
RETURN disc.if.writeConstString(s, string)
ELSE
IF WriteLongInt(s, string.len) THEN
ConstStrings.Open(buf, string);
RETURN Streams.Copy(buf, s, string.len)
ELSE
RETURN FALSE
END;
END;
END WriteConstString;
BEGIN
discID := Disciplines.Unique();
Forwarders.Register("Streams.Stream", Forward);
END ulmNetIO.

39
src/library/ulm/ulmObjects.Mod Normal file
View file

@ -0,0 +1,39 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Objects.om,v 1.1 1994/02/22 20:08:53 borchert Exp $
----------------------------------------------------------------------------
$Log: Objects.om,v $
Revision 1.1 1994/02/22 20:08:53 borchert
Initial revision
----------------------------------------------------------------------------
AFB 6/89
----------------------------------------------------------------------------
*)
MODULE ulmObjects;
(* common base of all record definitions of the library *)
TYPE
Object* = POINTER TO ObjectRec;
ObjectRec* = RECORD END;
END ulmObjects.

234
src/library/ulm/ulmOperations.Mod Normal file
View file

@ -0,0 +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.
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
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.1 1994/02/22 20:09:03 borchert
Initial revision
----------------------------------------------------------------------------
AFB 12/91
----------------------------------------------------------------------------
*)
MODULE ulmOperations;
(* generic support of arithmetic operations *)
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;
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;
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
source.if.assign(target, source);
END Copy;
BEGIN
PersistentObjects.RegisterType(operandType,
"Operations.Operand", "PersistentDisciplines.Object", NIL);
END ulmOperations.

391
src/library/ulm/ulmPersistentDisciplines.Mod Normal file
View file

@ -0,0 +1,391 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: PersistentD.om,v 1.4 1998/02/22 10:25:22 borchert Exp $
----------------------------------------------------------------------------
$Log: PersistentD.om,v $
Revision 1.4 1998/02/22 10:25:22 borchert
bug fix in GetObject: Disciplines.Add was missing if the main object
is just an extension of Disciplines.Object and not of
PersistentDisciplines.Object
Revision 1.3 1996/07/24 07:41:28 borchert
bug fix: count component was not initialized (with the
exception of CreateObject) -- detected by Martin Hasch
Revision 1.2 1995/03/17 16:13:33 borchert
- persistent disciplines may now be attached to non-persistent objects
- some fixes due to changes of PersistentObjects
Revision 1.1 1994/02/22 20:09:12 borchert
Initial revision
----------------------------------------------------------------------------
*)
MODULE ulmPersistentDisciplines;
IMPORT Disciplines := ulmDisciplines, Forwarders := ulmForwarders, NetIO := ulmNetIO, Objects := ulmObjects, PersistentObjects := ulmPersistentObjects,
Services := ulmServices, Streams := ulmStreams, SYS := SYSTEM;
CONST
objectName = "PersistentDisciplines.Object";
disciplineName = "PersistentDisciplines.Discipline";
TYPE
Identifier* = LONGINT;
Discipline* = POINTER TO DisciplineRec;
DisciplineRec* =
RECORD
(PersistentObjects.ObjectRec)
id*: Identifier; (* should be unique for all types of disciplines *)
END;
DisciplineList = POINTER TO DisciplineListRec;
DisciplineListRec =
RECORD
discipline: Discipline;
id: Identifier; (* copied from discipline.id *)
next: DisciplineList;
END;
Interface = POINTER TO InterfaceRec;
Object = POINTER TO ObjectRec;
ObjectRec* =
RECORD
(PersistentObjects.ObjectRec)
(* private part *)
count: LONGINT; (* number of attached disciplines *)
list: DisciplineList; (* set of disciplines *)
if: Interface; (* overrides builtins if # NIL *)
forwardTo: Object;
usedBy: Object; (* used as target of UseInterfaceOf *)
(* very restrictive way of avoiding reference cycles:
forwardTo references must be built from inner to
outer objects and not vice versa
*)
END;
TYPE
VolatileDiscipline = POINTER TO VolatileDisciplineRec;
VolatileDisciplineRec =
RECORD
(Disciplines.DisciplineRec)
object: Object;
END;
VAR
volDiscID: Disciplines.Identifier;
TYPE
AddProc* = PROCEDURE (object: Disciplines.Object; discipline: Discipline);
RemoveProc* = PROCEDURE (object: Disciplines.Object; id: Identifier);
SeekProc* = PROCEDURE (object: Disciplines.Object; id: Identifier;
VAR discipline: Discipline) : BOOLEAN;
InterfaceRec* =
RECORD
(Objects.ObjectRec)
add*: AddProc;
remove*: RemoveProc;
seek*: SeekProc;
END;
VAR
unique: Identifier;
objIf: PersistentObjects.Interface;
objDatatype, discDatatype: Services.Type;
CONST
hashtabsize = 32;
TYPE
Sample = POINTER TO SampleRec;
SampleRec =
RECORD
id: Identifier;
sample: Discipline;
next: Sample;
END;
BucketTable = ARRAY hashtabsize OF Sample;
VAR
samples: BucketTable;
PROCEDURE CreateObject*(VAR object: Object);
(* creates a new object; this procedures should be called instead of
NEW for objects of type `Object'
*)
BEGIN
NEW(object);
object.count := 0; (* up to now, there are no attached disciplines *)
object.list := NIL;
object.if := NIL;
PersistentObjects.Init(object, objDatatype);
END CreateObject;
PROCEDURE GetObject(obj: Disciplines.Object; VAR object: Object);
VAR
disc: VolatileDiscipline;
BEGIN
IF obj IS Object THEN
object := obj(Object);
(* initialize private components now if not done already;
we assume here that pointers which have not been
initialized yet are defined to be NIL
(because of the garbage collection);
a similar assumption does not necessarily hold for
other types (e.g. integers)
*)
IF object.list = NIL THEN
object.count := 0;
END;
ELSIF Disciplines.Seek(obj, volDiscID, SYS.VAL(Disciplines.Discipline, disc)) THEN
object := disc.object;
ELSE
CreateObject(object);
NEW(disc); disc.id := volDiscID; disc.object := object;
Disciplines.Add(obj, disc);
END;
END GetObject;
(* === normal stuff for disciplines ===================================== *)
PROCEDURE Unique*(sample: Discipline) : Identifier;
(* returns a unique identifier;
this procedure should be called during initialization by
all modules defining a discipline type;
a sample of the associated discipline has to be provided
*)
VAR
hashval: Identifier;
entry: Sample;
BEGIN
INC(unique);
NEW(entry); entry.id := unique; entry.sample := sample;
hashval := unique MOD hashtabsize;
entry.next := samples[hashval]; samples[hashval] := entry;
RETURN unique
END Unique;
PROCEDURE GetSample*(id: Identifier) : Discipline;
(* return sample for the given identifier;
NIL will be returned if id has not yet been returned by Unique
*)
VAR
hashval: Identifier;
ptr: Sample;
BEGIN
hashval := id MOD hashtabsize;
ptr := samples[hashval];
WHILE (ptr # NIL) & (ptr.id # id) DO
ptr := ptr.next;
END;
IF ptr # NIL THEN
RETURN ptr.sample
ELSE
RETURN NIL
END;
END GetSample;
PROCEDURE AttachInterface*(object: Disciplines.Object; if: Interface);
(* override the builtin implementations of Add, Remove and
Seek for `object' with the implementations given by `if'
*)
VAR
po: Object;
BEGIN
GetObject(object, po);
IF (po.list = NIL) & (po.forwardTo = NIL) THEN
po.if := if;
END;
END AttachInterface;
PROCEDURE UseInterfaceOf*(object, host: Disciplines.Object);
(* forward Add, Remove and Seek operations from object to host *)
VAR
po, phost: Object;
BEGIN
GetObject(object, po); GetObject(host, phost);
IF (po.list = NIL) & (po.forwardTo = NIL) &
(po.usedBy = NIL) THEN
po.forwardTo := phost;
phost.usedBy := po; (* avoid reference cycles *)
END;
END UseInterfaceOf;
PROCEDURE Forward(from, to: Forwarders.Object);
BEGIN
UseInterfaceOf(from, to);
END Forward;
PROCEDURE Remove*(object: Disciplines.Object; id: Identifier);
(* remove the discipline with the given id from object, if it exists *)
VAR
po: Object;
prev, dl: DisciplineList;
BEGIN
GetObject(object, po);
WHILE po.forwardTo # NIL DO
po := po.forwardTo;
END;
IF po.if = NIL THEN
prev := NIL;
dl := po.list;
WHILE (dl # NIL) & (dl.id # id) DO
prev := dl; dl := dl.next;
END;
IF dl # NIL THEN
IF prev = NIL THEN
po.list := dl.next;
ELSE
prev.next := dl.next;
END;
DEC(po.count); (* discipline removed *)
END;
ELSE
po.if.remove(po, id);
END;
END Remove;
PROCEDURE Add*(object: Disciplines.Object; discipline: Discipline);
(* adds a new discipline to the given object;
if already a discipline with the same identifier exist
it is deleted first
*)
VAR
po: Object;
dl: DisciplineList;
BEGIN
GetObject(object, po);
WHILE po.forwardTo # NIL DO
po := po.forwardTo;
END;
IF po.if = NIL THEN
dl := po.list;
WHILE (dl # NIL) & (dl.id # discipline.id) DO
dl := dl.next;
END;
IF dl = NIL THEN
NEW(dl);
dl.id := discipline.id;
dl.next := po.list;
po.list := dl;
INC(po.count); (* discipline added *)
END;
dl.discipline := discipline;
ELSE
po.if.add(po, discipline);
END;
END Add;
PROCEDURE Seek*(object: Disciplines.Object; id: Identifier;
VAR discipline: Discipline) : BOOLEAN;
(* returns TRUE if a discipline with the given id is found *)
VAR
po: Object;
dl: DisciplineList;
BEGIN
GetObject(object, po);
WHILE po.forwardTo # NIL DO
po := po.forwardTo;
END;
IF po.if = NIL THEN
dl := po.list;
WHILE (dl # NIL) & (dl.id # id) DO
dl := dl.next;
END;
IF dl # NIL THEN
discipline := dl.discipline;
ELSE
discipline := NIL;
END;
RETURN discipline # NIL
ELSE
RETURN po.if.seek(po, id, discipline)
END;
END Seek;
(* === interface procedures for PersistentObjects for Object === *)
PROCEDURE ReadObjectData(stream: Streams.Stream;
object: PersistentObjects.Object) : BOOLEAN;
(* read data and attached disciplines of given object from stream *)
VAR
discipline: Discipline;
count: LONGINT;
BEGIN
(* get number of attached disciplines *)
IF ~NetIO.ReadLongInt(stream, count) THEN
RETURN FALSE;
END;
(* read all disciplines from `stream' and attach them to `object' *)
WHILE count > 0 DO
IF ~PersistentObjects.Read(stream, SYS.VAL(PersistentObjects.Object, discipline)) THEN
RETURN FALSE;
END;
Add(object(Object), discipline);
DEC(count);
END;
RETURN TRUE;
END ReadObjectData;
PROCEDURE WriteObjectData(stream: Streams.Stream;
object: PersistentObjects.Object) : BOOLEAN;
(* write data and attached disciplines of given object to stream *)
VAR
dl: DisciplineList;
BEGIN
WITH object: Object DO
(* write number of attached disciplines to `stream' *)
IF ~NetIO.WriteLongInt(stream, object.count) THEN
RETURN FALSE;
END;
(* write all attached disciplines to the stream *)
dl := object.list;
WHILE dl # NIL DO
IF ~PersistentObjects.Write(stream, dl.discipline) THEN
RETURN FALSE;
END;
dl := dl.next;
END;
END;
RETURN TRUE;
END WriteObjectData;
PROCEDURE InternalCreate(VAR obj: PersistentObjects.Object);
VAR
myObject: Object;
BEGIN
CreateObject(myObject);
obj := myObject;
END InternalCreate;
BEGIN
unique := 0;
NEW(objIf);
objIf.read := ReadObjectData;
objIf.write := WriteObjectData;
objIf.create := InternalCreate;
objIf.createAndRead := NIL;
PersistentObjects.RegisterType(objDatatype, objectName, "", objIf);
PersistentObjects.RegisterType(discDatatype, disciplineName, "", NIL);
volDiscID := Disciplines.Unique();
Forwarders.Register("", Forward);
END ulmPersistentDisciplines.

1078
src/library/ulm/ulmPersistentObjects.Mod Normal file
View file

File diff suppressed because it is too large Load diff

268
src/library/ulm/ulmPlotters.Mod Normal file
View file

@ -0,0 +1,268 @@
(* 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.
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: Plotters.om,v 1.1 2004/04/08 12:30:29 borchert Exp borchert $
----------------------------------------------------------------------------
$Log: Plotters.om,v $
Revision 1.1 2004/04/08 12:30:29 borchert
Initial revision
----------------------------------------------------------------------------
*)
MODULE ulmPlotters;
IMPORT Events := ulmEvents, Objects := ulmObjects, Resources := ulmResources, Services := ulmServices, SYS := ulmSYSTEM;
TYPE
Plotter* = POINTER TO PlotterRec;
CONST
solid* = 0;
dotted* = 1;
dotdashed* = 2;
shortdashed* = 3;
longdashed* = 4;
lineModes* = 5;
TYPE
LineMode* = SHORTINT; (* solid ... *)
CONST
setspace* = 0;
erase* = 1;
string* = 2;
linemodes* = 3;
linewidth* = 4;
TYPE
CapabilitySet* = SET; (* OF setspace, erase ... *)
TYPE
Description* = POINTER TO DescriptionRec;
DescriptionRec* =
RECORD
(Objects.ObjectRec)
xmin*, ymin, xmax, ymax: INTEGER; (* maximal supported range *)
END;
TYPE
GetSpaceProc* = PROCEDURE (
plotter: Plotter;
VAR xmin, ymin, xmax, ymax: INTEGER);
SetSpaceProc* = PROCEDURE (
plotter: Plotter;
xmin, ymin, xmax, ymax: INTEGER);
EraseProc* = PROCEDURE (plotter: Plotter);
MoveProc* = PROCEDURE (plotter: Plotter; xto, yto: INTEGER);
LineProc* = PROCEDURE (plotter: Plotter; xfrom, yfrom, xto, yto: INTEGER);
ArcProc* = PROCEDURE (
plotter: Plotter;
xcenter, ycenter, xstart, ystart, xend, yend: INTEGER);
CircleProc* = PROCEDURE (
plotter: Plotter; xcenter, ycenter, radius: INTEGER);
StringProc* = PROCEDURE (plotter: Plotter; str: ARRAY OF CHAR);
SetLineModeProc* = PROCEDURE (plotter: Plotter; mode: LineMode);
SetLineWidthProc* = PROCEDURE (plotter: Plotter; width: INTEGER);
CloseProc* = PROCEDURE (plotter: Plotter);
TYPE
Interface* = POINTER TO InterfaceRec;
InterfaceRec* =
RECORD
(Objects.ObjectRec)
setSpace*: SetSpaceProc;
erase*: EraseProc;
move*: MoveProc;
cont*: MoveProc;
point*: MoveProc;
line*: LineProc;
arc*: ArcProc;
circle*: CircleProc;
string*: StringProc;
setLineMode*: SetLineModeProc;
setLineWidth*: SetLineWidthProc;
close*: CloseProc;
END;
TYPE
PlotterRec* =
RECORD
(Services.ObjectRec)
if: Interface;
caps: CapabilitySet;
desc: Description;
xmin, ymin, xmax, ymax: INTEGER; (* current range *)
terminated: BOOLEAN;
END;
VAR
plotterType: Services.Type;
PROCEDURE InitModule;
BEGIN
Services.CreateType(plotterType, "Plotters.Plotter", "");
END InitModule;
PROCEDURE ^ Close*(plotter: Plotter);
PROCEDURE TerminationHandler(event: Events.Event);
VAR
plotter: Plotter;
BEGIN
WITH event: Resources.Event DO
IF event.change IN {Resources.terminated, Resources.unreferenced} THEN
Close(event.resource(Plotter));
END;
END;
END TerminationHandler;
PROCEDURE Init*(plotter: Plotter; if: Interface;
caps: CapabilitySet; desc: Description);
VAR
eventType: Events.EventType;
BEGIN
ASSERT((if # NIL) & (if.move # NIL) & (if.cont # NIL) &
(if.point # NIL) & (if.line # NIL) & (if.arc # NIL) &
(if.circle # NIL));
ASSERT(~(setspace IN caps) OR (if.setSpace # NIL));
ASSERT(~(erase IN caps) OR (if.erase # NIL));
ASSERT(~(string IN caps) OR (if.string # NIL));
ASSERT(~(linemodes IN caps) OR (if.setLineMode # NIL));
ASSERT(~(linewidth IN caps) OR (if.setLineWidth # NIL));
ASSERT((desc.xmin < desc.xmax) & (desc.ymin < desc.ymax));
plotter.if := if;
plotter.caps := caps;
plotter.desc := desc;
plotter.xmin := desc.xmin;
plotter.xmax := desc.xmax;
plotter.ymin := desc.ymin;
plotter.ymax := desc.ymax;
plotter.terminated := FALSE;
Resources.TakeInterest(plotter, eventType);
Events.Handler(eventType, TerminationHandler);
END Init;
PROCEDURE GetCapabilities*(plotter: Plotter) : CapabilitySet;
BEGIN
RETURN plotter.caps
END GetCapabilities;
PROCEDURE GetSpace*(plotter: Plotter;
VAR xmin, ymin,
xmax, ymax: INTEGER);
BEGIN
xmin := plotter.xmin;
xmax := plotter.xmax;
ymin := plotter.ymin;
ymax := plotter.ymax;
END GetSpace;
PROCEDURE GetMaxSpace*(plotter: Plotter;
VAR xmin, ymin,
xmax, ymax: INTEGER);
BEGIN
xmin := plotter.desc.xmin;
xmax := plotter.desc.xmax;
ymin := plotter.desc.ymin;
ymax := plotter.desc.ymax;
END GetMaxSpace;
PROCEDURE SetSpace*(plotter: Plotter;
xmin, ymin,
xmax, ymax: INTEGER);
BEGIN
ASSERT((xmin < xmax) & (ymin < ymax));
ASSERT((xmin >= plotter.desc.xmin) &
(xmax <= plotter.desc.xmax) &
(ymin >= plotter.desc.ymin) &
(ymax <= plotter.desc.ymax));
ASSERT(setspace IN plotter.caps);
plotter.if.setSpace(plotter, xmin, ymin, xmax, ymax);
plotter.xmin := xmin;
plotter.ymin := ymin;
plotter.xmax := xmax;
plotter.ymax := ymax;
END SetSpace;
PROCEDURE Erase*(plotter: Plotter);
BEGIN
ASSERT(erase IN plotter.caps);
plotter.if.erase(plotter);
END Erase;
PROCEDURE Move*(plotter: Plotter; xto, yto: INTEGER);
BEGIN
plotter.if.move(plotter, xto, yto);
END Move;
PROCEDURE Cont*(plotter: Plotter; xto, yto: INTEGER);
BEGIN
plotter.if.cont(plotter, xto, yto);
END Cont;
PROCEDURE Point*(plotter: Plotter; xpoint, ypoint: INTEGER);
BEGIN
plotter.if.point(plotter, xpoint, ypoint);
END Point;
PROCEDURE Line*(plotter: Plotter; xfrom, yfrom, xto, yto: INTEGER);
BEGIN
plotter.if.line(plotter, xfrom, yfrom, xto, yto);
END Line;
PROCEDURE Arc*(plotter: Plotter;
xcenter, ycenter, xstart, ystart, xend, yend: INTEGER);
BEGIN
plotter.if.arc(plotter, xcenter, ycenter, xstart, ystart, xend, yend);
END Arc;
PROCEDURE Circle*(plotter: Plotter; xcenter, ycenter, radius: INTEGER);
BEGIN
plotter.if.circle(plotter, xcenter, ycenter, radius);
END Circle;
PROCEDURE String*(plotter: Plotter; str: ARRAY OF CHAR);
BEGIN
ASSERT(string IN plotter.caps);
plotter.if.string(plotter, str);
END String;
PROCEDURE SetLineMode*(plotter: Plotter; mode: LineMode);
BEGIN
ASSERT((linemodes IN plotter.caps) & (mode >= 0) & (mode < lineModes));
plotter.if.setLineMode(plotter, mode);
END SetLineMode;
PROCEDURE SetLineWidth*(plotter: Plotter; width: INTEGER);
BEGIN
ASSERT((linewidth IN plotter.caps) & (width > 0));
plotter.if.setLineWidth(plotter, width);
END SetLineWidth;
PROCEDURE Close*(plotter: Plotter);
BEGIN
IF ~SYS.TAS(plotter.terminated) THEN
IF plotter.if.close # NIL THEN
plotter.if.close(plotter);
END;
Resources.Notify(plotter, Resources.terminated);
plotter.if := NIL; plotter.desc := NIL;
END;
END Close;
BEGIN
InitModule;
END ulmPlotters.

964
src/library/ulm/ulmPrint.Mod Normal file
View file

@ -0,0 +1,964 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Print.om,v 1.3 2004/05/21 12:08:43 borchert Exp $
----------------------------------------------------------------------------
$Log: Print.om,v $
Revision 1.3 2004/05/21 12:08:43 borchert
bug fix: NaNs and other invalid floating point numbers weren't
checked for
Revision 1.2 1996/09/18 07:47:41 borchert
support of SYSTEM.INT16 added
Revision 1.1 1994/02/23 07:46:28 borchert
Initial revision
----------------------------------------------------------------------------
AFB 6/89
----------------------------------------------------------------------------
*)
MODULE ulmPrint;
(* formatted printing;
Print.F[0-9] prints to Streams.stdout
formats are close to those of printf(3)
*)
IMPORT Events := ulmEvents, IEEE := ulmIEEE, Priorities := ulmPriorities, Reals := ulmReals, RelatedEvents := ulmRelatedEvents, StreamDisciplines := ulmStreamDisciplines,
Streams := ulmStreams, SYS := SYSTEM;
CONST
tooManyArgs* = 0; (* too many arguments given *)
tooFewArgs* = 1; (* too few arguments given *)
badFormat* = 2; (* syntax error in format string *)
badArgumentSize* = 3; (* bad size of argument *)
errors* = 4;
TYPE
FormatString* = ARRAY 128 OF CHAR;
ErrorCode* = SHORTINT;
ErrorEvent* = POINTER TO ErrorEventRec;
ErrorEventRec* =
RECORD
(Events.EventRec)
errorcode*: ErrorCode;
format*: FormatString;
errpos*: LONGINT;
nargs*: INTEGER;
END;
VAR
error*: Events.EventType;
errormsg*: ARRAY errors OF Events.Message;
(* === private part ============================================= *)
PROCEDURE InitErrorHandling;
BEGIN
Events.Define(error); Events.SetPriority(error, Priorities.liberrors);
errormsg[tooManyArgs] := "too many arguments given";
errormsg[tooFewArgs] := "too few arguments given";
errormsg[badFormat] := "syntax error in format string";
errormsg[badArgumentSize] :=
"size of argument doesn't conform to the corresponding format element";
END InitErrorHandling;
PROCEDURE Out(out: Streams.Stream; VAR fmt: ARRAY OF CHAR; nargs: INTEGER;
VAR p1,p2,p3,p4,p5,p6,p7,p8,p9: ARRAY OF SYS.BYTE;
errors: RelatedEvents.Object);
CONST
maxargs = 9; (* maximal number of arguments *)
maxargsize = SIZE(LONGREAL); (* maximal arg size (except strings) *)
fmtcmd = "%";
escape = "\";
VAR
arglen: ARRAY maxargs OF LONGINT;
nextarg: INTEGER;
fmtindex: LONGINT;
fmtchar: CHAR;
hexcharval: LONGINT;
PROCEDURE Error(errorcode: ErrorCode);
VAR
event: ErrorEvent;
BEGIN
NEW(event);
event.type := error;
event.message := errormsg[errorcode];
event.errorcode := errorcode;
COPY(fmt, event.format);
event.errpos := fmtindex;
event.nargs := nargs;
RelatedEvents.Raise(errors, event);
END Error;
PROCEDURE Next() : BOOLEAN;
BEGIN
IF fmtindex < LEN(fmt) THEN
fmtchar := fmt[fmtindex]; INC(fmtindex);
IF fmtchar = 0X THEN
fmtindex := LEN(fmt);
RETURN FALSE
ELSE
RETURN TRUE
END;
ELSE
RETURN FALSE
END;
END Next;
PROCEDURE Unget;
BEGIN
IF (fmtindex > 0) & (fmtindex < LEN(fmt)) THEN
DEC(fmtindex); fmtchar := fmt[fmtindex];
ELSE
fmtchar := 0X;
END;
END Unget;
PROCEDURE Write(byte: SYS.BYTE);
BEGIN
IF Streams.WriteByte(out, byte) THEN
INC(out.count);
END;
END Write;
PROCEDURE WriteLn;
VAR
lineterm: StreamDisciplines.LineTerminator;
i: INTEGER;
BEGIN
StreamDisciplines.GetLineTerm(out, lineterm);
Write(lineterm[0]);
i := 1;
WHILE (i < LEN(lineterm)) & (lineterm[i] # 0X) DO
Write(lineterm[i]); INC(i);
END;
END WriteLn;
PROCEDURE Int(VAR int: LONGINT; base: INTEGER) : BOOLEAN;
PROCEDURE ValidDigit(ch: CHAR) : BOOLEAN;
BEGIN
RETURN (ch >= "0") & (ch <= "9") OR
(base = 16) & (CAP(ch) >= "A") & (CAP(ch) <= "F")
END ValidDigit;
BEGIN
int := 0;
REPEAT
int := int * base;
IF (fmtchar >= "0") & (fmtchar <= "9") THEN
INC(int, LONG(ORD(fmtchar) - ORD("0")));
ELSIF (base = 16) &
(CAP(fmtchar) >= "A") & (CAP(fmtchar) <= "F") THEN
INC(int, LONG(10 + ORD(CAP(fmtchar)) - ORD("A")));
ELSE
RETURN FALSE
END;
UNTIL ~Next() OR ~ValidDigit(fmtchar);
RETURN TRUE
END Int;
PROCEDURE SetSize;
VAR
index: INTEGER;
BEGIN
index := 0;
WHILE index < nargs DO
CASE index OF
| 0: arglen[index] := LEN(p1);
| 1: arglen[index] := LEN(p2);
| 2: arglen[index] := LEN(p3);
| 3: arglen[index] := LEN(p4);
| 4: arglen[index] := LEN(p5);
| 5: arglen[index] := LEN(p6);
| 6: arglen[index] := LEN(p7);
| 7: arglen[index] := LEN(p8);
| 8: arglen[index] := LEN(p9);
END;
INC(index);
END;
END SetSize;
PROCEDURE Access(par: INTEGER; at: LONGINT) : SYS.BYTE;
BEGIN
CASE par OF
| 0: RETURN p1[at]
| 1: RETURN p2[at]
| 2: RETURN p3[at]
| 3: RETURN p4[at]
| 4: RETURN p5[at]
| 5: RETURN p6[at]
| 6: RETURN p7[at]
| 7: RETURN p8[at]
| 8: RETURN p9[at]
END;
END Access;
PROCEDURE Convert(from: INTEGER; VAR to: ARRAY OF SYS.BYTE);
VAR i: INTEGER;
BEGIN
i := 0;
WHILE i < arglen[from] DO
to[i] := Access(from, i); INC(i);
END;
END Convert;
PROCEDURE GetInt(index: INTEGER; VAR long: LONGINT) : BOOLEAN;
(* access index-th parameter (counted from 0);
fails if arglen[index] > SIZE(LONGINT)
*)
VAR
short: SHORTINT;
(*int16: SYS.INT16;*)
int: INTEGER;
BEGIN
IF arglen[index] = SIZE(SHORTINT) THEN
Convert(index, short); long := short;
(*ELSIF arglen[index] = SIZE(SYS.INT16) THEN
Convert(index, int16); long := int16;*)
ELSIF arglen[index] = SIZE(INTEGER) THEN
Convert(index, int); long := int;
ELSIF arglen[index] = SIZE(LONGINT) THEN
Convert(index, long);
ELSE
Error(badArgumentSize);
RETURN FALSE
END;
RETURN TRUE
END GetInt;
PROCEDURE Format() : BOOLEAN;
VAR
fillch: CHAR; (* filling character *)
insert: BOOLEAN; (* insert between sign and 1st digit *)
sign: BOOLEAN; (* sign even positive values *)
leftaligned: BOOLEAN; (* output left aligned *)
width, scale: LONGINT;
PROCEDURE NextArg(VAR index: INTEGER) : BOOLEAN;
BEGIN
IF nextarg < nargs THEN
index := nextarg; INC(nextarg); RETURN TRUE
ELSE
RETURN FALSE
END;
END NextArg;
PROCEDURE Flags() : BOOLEAN;
BEGIN
fillch := " "; insert := FALSE; sign := FALSE;
leftaligned := FALSE;
REPEAT
CASE fmtchar OF
| "+": sign := TRUE;
| "0": fillch := "0"; insert := TRUE;
| "-": leftaligned := TRUE;
| "^": insert := TRUE;
| "\": IF ~Next() THEN RETURN FALSE END; fillch := fmtchar;
ELSE
RETURN TRUE
END;
UNTIL ~Next();
Error(badFormat);
RETURN FALSE (* unexpected end *)
END Flags;
PROCEDURE FetchInt(VAR int: LONGINT) : BOOLEAN;
VAR
index: INTEGER;
BEGIN
RETURN (fmtchar = "*") & Next() &
NextArg(index) & GetInt(index, int) OR
Int(int, 10) & (int >= 0)
END FetchInt;
PROCEDURE Width() : BOOLEAN;
BEGIN
IF (fmtchar >= "0") & (fmtchar <= "9") OR (fmtchar = "*") THEN
IF FetchInt(width) THEN
RETURN TRUE
END;
Error(badFormat); RETURN FALSE
ELSE
width := 0;
RETURN TRUE
END;
END Width;
PROCEDURE Scale() : BOOLEAN;
BEGIN
IF fmtchar = "." THEN
IF Next() & FetchInt(scale) THEN
RETURN TRUE
ELSE
Error(badFormat); RETURN FALSE
END;
ELSE
scale := -1; RETURN TRUE
END;
END Scale;
PROCEDURE Conversion() : BOOLEAN;
PROCEDURE Fill(cnt: LONGINT);
(* cnt: space used by normal output *)
VAR i: LONGINT;
BEGIN
IF cnt < width THEN
i := width - cnt;
WHILE i > 0 DO
Write(fillch);
DEC(i);
END;
END;
END Fill;
PROCEDURE FillLeft(cnt: LONGINT);
BEGIN
IF ~leftaligned THEN
Fill(cnt);
END;
END FillLeft;
PROCEDURE FillRight(cnt: LONGINT);
BEGIN
IF leftaligned THEN
Fill(cnt);
END;
END FillRight;
PROCEDURE WriteBool(true, false: ARRAY OF CHAR) : BOOLEAN;
VAR index: INTEGER; val: LONGINT;
PROCEDURE WriteString(VAR s: ARRAY OF CHAR);
VAR i, len: INTEGER;
BEGIN
len := 0;
WHILE (len < LEN(s)) & (s[len] # 0X) DO
INC(len);
END;
FillLeft(len);
i := 0;
WHILE i < len DO
Write(s[i]); INC(i);
END;
FillRight(len);
END WriteString;
BEGIN
IF NextArg(index) & GetInt(index, val) THEN
IF val = 0 THEN
WriteString(false); RETURN TRUE
ELSIF val = 1 THEN
WriteString(true); RETURN TRUE
END;
END;
RETURN FALSE
END WriteBool;
PROCEDURE WriteChar() : BOOLEAN;
VAR
val: LONGINT;
index: INTEGER;
BEGIN
IF NextArg(index) & GetInt(index, val) &
(val >= 0) & (val <= ORD(MAX(CHAR))) THEN
FillLeft(1);
Write(CHR(val));
FillRight(1);
RETURN TRUE
END;
RETURN FALSE
END WriteChar;
PROCEDURE WriteInt(base: INTEGER) : BOOLEAN;
VAR
index: INTEGER;
val: LONGINT;
neg: BOOLEAN; (* set by Convert *)
buf: ARRAY 12 OF CHAR; (* filled by Convert *)
i: INTEGER;
len: INTEGER; (* space needed for val *)
signcnt: INTEGER; (* =1 if sign printed; else 0 *)
signch: CHAR;
PROCEDURE Convert;
VAR
index: INTEGER;
digit: LONGINT;
BEGIN
neg := val < 0;
index := 0;
REPEAT
digit := val MOD base;
val := val DIV base;
IF neg & (digit > 0) THEN
digit := base - digit;
INC(val);
END;
IF digit < 10 THEN
buf[index] := CHR(ORD("0") + digit);
ELSE
buf[index] := CHR(ORD("A") + digit - 10);
END;
INC(index);
UNTIL val = 0;
len := index;
END Convert;
BEGIN (* WriteInt *)
IF NextArg(index) & GetInt(index, val) THEN
Convert;
IF sign OR neg THEN
signcnt := 1;
IF neg THEN
signch := "-";
ELSE
signch := "+";
END;
ELSE
signcnt := 0;
END;
IF insert & (signcnt = 1) THEN
Write(signch);
END;
FillLeft(len+signcnt);
IF ~insert & (signcnt = 1) THEN
Write(signch);
END;
i := len;
WHILE i > 0 DO
DEC(i); Write(buf[i]);
END;
FillRight(len+signcnt);
RETURN TRUE
END;
RETURN FALSE
END WriteInt;
PROCEDURE WriteReal(format: CHAR) : BOOLEAN;
(* format either "f", "e", or "g" *)
CONST
defaultscale = 6;
VAR
index: INTEGER;
lr: LONGREAL;
r: REAL;
shortint: SHORTINT; int: INTEGER; longint: LONGINT;
(*int16: SYS.INT16;*)
long: BOOLEAN;
exponent: INTEGER;
mantissa: LONGREAL;
digits: ARRAY Reals.maxlongdignum OF CHAR;
neg: BOOLEAN;
ndigits: INTEGER;
decpt: INTEGER;
PROCEDURE Print(decpt: INTEGER; withexp: BOOLEAN; exp: INTEGER);
(* decpt: position of decimal point
= 0: just before the digits
> 0: after decpt digits
< 0: ABS(decpt) zeroes before digits needed
*)
VAR
needed: INTEGER; (* space needed *)
index: INTEGER;
count: LONGINT;
PROCEDURE WriteExp(exp: INTEGER);
CONST
base = 10;
VAR
power: INTEGER;
digit: INTEGER;
BEGIN
IF long THEN
Write("D");
ELSE
Write("E");
END;
IF exp < 0 THEN
Write("-"); exp := - exp;
ELSE
Write("+");
END;
IF long THEN
power := 1000;
ELSE
power := 100;
END;
WHILE power > 0 DO
digit := (exp DIV power) MOD base;
Write(CHR(digit+ORD("0")));
power := power DIV base;
END;
END WriteExp;
BEGIN (* Print *)
(* leading digits *)
IF decpt > 0 THEN
needed := decpt;
ELSE
needed := 1;
END;
IF neg OR sign THEN
INC(needed);
END;
IF withexp OR (scale # 0) THEN
INC(needed); (* decimal point *)
END;
IF withexp THEN
INC(needed, 2); (* E[+-] *)
IF long THEN
INC(needed, 4);
ELSE
INC(needed, 3);
END;
END;
INC(needed, SHORT(scale));
FillLeft(needed);
IF neg THEN
Write("-");
ELSIF sign THEN
Write("+");
END;
IF decpt <= 0 THEN
Write("0");
ELSE
index := 0;
WHILE index < decpt DO
IF index < ndigits THEN
Write(digits[index]);
ELSE
Write("0");
END;
INC(index);
END;
END;
IF withexp OR (scale > 0) THEN
Write(".");
END;
IF scale > 0 THEN
count := scale;
index := decpt;
WHILE (index < 0) & (count > 0) DO
Write("0"); INC(index); DEC(count);
END;
WHILE (index < ndigits) & (count > 0) DO
Write(digits[index]); INC(index); DEC(count);
END;
WHILE count > 0 DO
Write("0"); DEC(count);
END;
END;
IF withexp THEN
WriteExp(exp);
END;
FillRight(needed);
END Print;
BEGIN (* WriteReal *)
IF NextArg(index) THEN
IF arglen[index] = SIZE(LONGREAL) THEN
long := TRUE;
Convert(index, lr);
ELSIF arglen[index] = SIZE(REAL) THEN
long := FALSE;
Convert(index, r);
lr := r;
ELSIF arglen[index] = SIZE(LONGINT) THEN
long := FALSE;
Convert(index, longint);
lr := longint;
ELSIF arglen[index] = SIZE(INTEGER) THEN
long := FALSE;
Convert(index, int);
lr := int;
(*ELSIF arglen[index] = SIZE(SYS.INT16) THEN
long := FALSE;
Convert(index, int16);
lr := int16;*)
ELSIF arglen[index] = SIZE(SHORTINT) THEN
long := FALSE;
Convert(index, shortint);
lr := shortint;
ELSE
Error(badArgumentSize); RETURN FALSE
END;
IF scale = -1 THEN
scale := defaultscale;
END;
(* check for NaNs and other invalid numbers *)
IF ~IEEE.Valid(lr) THEN
IF IEEE.NotANumber(lr) THEN
Write("N"); Write("a"); Write("N");
RETURN TRUE
ELSE
IF lr < 0 THEN
Write("-");
ELSE
Write("+");
END;
Write("i"); Write("n"); Write("f");
END;
RETURN TRUE
END;
(* real value in `lr' *)
Reals.ExpAndMan(lr, long, 10, exponent, mantissa);
CASE format OF
| "e": ndigits := SHORT(scale)+1;
| "f": ndigits := SHORT(scale)+exponent+1;
IF ndigits <= 0 THEN
ndigits := 1;
END;
| "g": ndigits := SHORT(scale);
END;
Reals.Digits(mantissa, 10, digits, neg,
(* force = *) format # "g", ndigits);
decpt := 1;
CASE format OF
| "e": Print(decpt, (* withexp = *) TRUE, exponent);
| "f": INC(decpt, exponent);
Print(decpt, (* withexp = *) FALSE, 0);
| "g": IF (exponent < -4) OR (exponent > scale) THEN
scale := ndigits-1;
Print(decpt, (* withexp = *) TRUE, exponent);
ELSE
INC(decpt, exponent);
scale := ndigits-1;
DEC(scale, LONG(exponent));
IF scale < 0 THEN
scale := 0;
END;
Print(decpt, (* withexp = *) FALSE, 0);
END;
END;
RETURN TRUE
ELSE
RETURN FALSE
END;
END WriteReal;
PROCEDURE WriteString() : BOOLEAN;
VAR
index: INTEGER;
i: LONGINT;
byte: SYS.BYTE;
len: LONGINT;
BEGIN
IF NextArg(index) THEN
len := 0;
WHILE (len < arglen[index]) &
((scale = -1) OR (len < scale)) &
((*CHR*)SYS.VAL(CHAR, (Access(index, len))) # 0X) DO
INC(len);
END;
FillLeft(len);
i := 0;
WHILE i < len DO
byte := Access(index, i);
Write(byte);
INC(i);
END;
FillRight(len);
RETURN TRUE
END;
RETURN FALSE
END WriteString;
BEGIN (* Conversion *)
CASE fmtchar OF
| "b": RETURN WriteBool("TRUE", "FALSE")
| "c": RETURN WriteChar()
| "d": RETURN WriteInt(10)
| "e",
"f",
"g": RETURN WriteReal(fmtchar)
| "j": RETURN WriteBool("ja", "nein")
| "o": RETURN WriteInt(8)
| "s": RETURN WriteString()
| "x": RETURN WriteInt(16)
| "y": RETURN WriteBool("yes", "no")
ELSE
Error(badFormat); RETURN FALSE
END;
END Conversion;
BEGIN
IF ~Next() THEN RETURN FALSE END;
IF fmtchar = fmtcmd THEN Write(fmtcmd); RETURN TRUE END;
RETURN Flags() & Width() & Scale() & Conversion()
END Format;
BEGIN
out.count := 0; out.error := FALSE;
SetSize;
nextarg := 0;
fmtindex := 0;
WHILE Next() DO
IF fmtchar = fmtcmd THEN
IF ~Format() THEN
RETURN
END;
ELSIF (fmtchar = "\") & Next() THEN
CASE fmtchar OF
| "0".."9", "A".."F":
IF ~Int(hexcharval, 16) THEN
(* Error(s, BadFormat); *) RETURN
END;
Unget;
Write(CHR(hexcharval));
| "b": Write(08X); (* back space *)
| "e": Write(1BX); (* escape *)
| "f": Write(0CX); (* form feed *)
| "n": WriteLn;
| "q": Write("'");
| "Q": Write(22X); (* double quote: " *)
| "r": Write(0DX); (* carriage return *)
| "t": Write(09X); (* horizontal tab *)
| "&": Write(07X); (* bell *)
ELSE
Write(fmtchar);
END;
ELSE
Write(fmtchar);
END;
END;
IF nextarg < nargs THEN
Error(tooManyArgs);
ELSIF nextarg > nargs THEN
Error(tooFewArgs);
END;
END Out;
(* === public part ============================================== *)
PROCEDURE F*(fmt: ARRAY OF CHAR);
VAR x: INTEGER;
BEGIN
Out(Streams.stdout, fmt, 0, x,x,x,x,x,x,x,x,x, NIL);
END F;
PROCEDURE F1*(fmt: ARRAY OF CHAR; p1: ARRAY OF SYS.BYTE);
VAR x: INTEGER;
BEGIN
Out(Streams.stdout, fmt, 1, p1, x,x,x,x,x,x,x,x, NIL);
END F1;
PROCEDURE F2*(fmt: ARRAY OF CHAR; p1, p2: ARRAY OF SYS.BYTE);
VAR x: INTEGER;
BEGIN
Out(Streams.stdout, fmt, 2, p1,p2, x,x,x,x,x,x,x, NIL);
END F2;
PROCEDURE F3*(fmt: ARRAY OF CHAR; p1, p2, p3: ARRAY OF SYS.BYTE);
VAR x: INTEGER;
BEGIN
Out(Streams.stdout, fmt, 3, p1,p2,p3, x,x,x,x,x,x, NIL);
END F3;
PROCEDURE F4*(fmt: ARRAY OF CHAR; p1, p2, p3, p4: ARRAY OF SYS.BYTE);
VAR x: INTEGER;
BEGIN
Out(Streams.stdout, fmt, 4, p1,p2,p3,p4, x,x,x,x,x, NIL);
END F4;
PROCEDURE F5*(fmt: ARRAY OF CHAR; p1, p2, p3, p4, p5: ARRAY OF SYS.BYTE);
VAR x: INTEGER;
BEGIN
Out(Streams.stdout, fmt, 5, p1,p2,p3,p4,p5, x,x,x,x, NIL);
END F5;
PROCEDURE F6*(fmt: ARRAY OF CHAR; p1, p2, p3, p4, p5, p6: ARRAY OF SYS.BYTE);
VAR x: INTEGER;
BEGIN
Out(Streams.stdout, fmt, 6, p1,p2,p3,p4,p5,p6, x,x,x, NIL);
END F6;
PROCEDURE F7*(fmt: ARRAY OF CHAR; p1, p2, p3, p4, p5, p6, p7: ARRAY OF SYS.BYTE);
VAR x: INTEGER;
BEGIN
Out(Streams.stdout, fmt, 7, p1,p2,p3,p4,p5,p6,p7, x,x, NIL);
END F7;
PROCEDURE F8*(fmt: ARRAY OF CHAR;
p1, p2, p3, p4, p5, p6, p7, p8: ARRAY OF SYS.BYTE);
VAR x: INTEGER;
BEGIN
Out(Streams.stdout, fmt, 8, p1,p2,p3,p4,p5,p6,p7,p8, x, NIL);
END F8;
PROCEDURE F9*(fmt: ARRAY OF CHAR;
p1, p2, p3, p4, p5, p6, p7, p8, p9: ARRAY OF SYS.BYTE);
BEGIN
Out(Streams.stdout, fmt, 9, p1,p2,p3,p4,p5,p6,p7,p8,p9, NIL);
END F9;
PROCEDURE S*(out: Streams.Stream; fmt: ARRAY OF CHAR);
VAR x: INTEGER;
BEGIN
Out(out, fmt, 0, x,x,x,x,x,x,x,x,x, NIL);
END S;
PROCEDURE S1*(out: Streams.Stream; fmt: ARRAY OF CHAR; p1: ARRAY OF SYS.BYTE);
VAR x: INTEGER;
BEGIN
Out(out, fmt, 1, p1, x,x,x,x,x,x,x,x, NIL);
END S1;
PROCEDURE S2*(out: Streams.Stream; fmt: ARRAY OF CHAR; p1, p2: ARRAY OF SYS.BYTE);
VAR x: INTEGER;
BEGIN
Out(out, fmt, 2, p1,p2, x,x,x,x,x,x,x, NIL);
END S2;
PROCEDURE S3*(out: Streams.Stream; fmt: ARRAY OF CHAR; p1, p2, p3: ARRAY OF SYS.BYTE);
VAR x: INTEGER;
BEGIN
Out(out, fmt, 3, p1,p2,p3, x,x,x,x,x,x, NIL);
END S3;
PROCEDURE S4*(out: Streams.Stream; fmt: ARRAY OF CHAR;
p1, p2, p3, p4: ARRAY OF SYS.BYTE);
VAR x: INTEGER;
BEGIN
Out(out, fmt, 4, p1,p2,p3,p4, x,x,x,x,x, NIL);
END S4;
PROCEDURE S5*(out: Streams.Stream; fmt: ARRAY OF CHAR;
p1, p2, p3, p4, p5: ARRAY OF SYS.BYTE);
VAR x: INTEGER;
BEGIN
Out(out, fmt, 5, p1,p2,p3,p4,p5, x,x,x,x, NIL);
END S5;
PROCEDURE S6*(out: Streams.Stream; fmt: ARRAY OF CHAR;
p1, p2, p3, p4, p5, p6: ARRAY OF SYS.BYTE);
VAR x: INTEGER;
BEGIN
Out(out, fmt, 6, p1,p2,p3,p4,p5,p6, x,x,x, NIL);
END S6;
PROCEDURE S7*(out: Streams.Stream; fmt: ARRAY OF CHAR;
p1, p2, p3, p4, p5, p6, p7: ARRAY OF SYS.BYTE);
VAR x: INTEGER;
BEGIN
Out(out, fmt, 7, p1,p2,p3,p4,p5,p6,p7, x,x, NIL);
END S7;
PROCEDURE S8*(out: Streams.Stream; fmt: ARRAY OF CHAR;
p1, p2, p3, p4, p5, p6, p7, p8: ARRAY OF SYS.BYTE);
VAR x: INTEGER;
BEGIN
Out(out, fmt, 8, p1,p2,p3,p4,p5,p6,p7,p8, x, NIL);
END S8;
PROCEDURE S9*(out: Streams.Stream; fmt: ARRAY OF CHAR;
p1, p2, p3, p4, p5, p6, p7, p8, p9: ARRAY OF SYS.BYTE);
BEGIN
Out(out, fmt, 9, p1,p2,p3,p4,p5,p6,p7,p8,p9, NIL);
END S9;
PROCEDURE SE*(out: Streams.Stream; fmt: ARRAY OF CHAR;
errors: RelatedEvents.Object);
VAR x: INTEGER;
BEGIN
Out(out, fmt, 0, x,x,x,x,x,x,x,x,x, NIL);
END SE;
PROCEDURE SE1*(out: Streams.Stream; fmt: ARRAY OF CHAR; p1: ARRAY OF SYS.BYTE;
errors: RelatedEvents.Object);
VAR x: INTEGER;
BEGIN
Out(out, fmt, 1, p1, x,x,x,x,x,x,x,x, errors);
END SE1;
PROCEDURE SE2*(out: Streams.Stream; fmt: ARRAY OF CHAR; p1, p2: ARRAY OF SYS.BYTE;
errors: RelatedEvents.Object);
VAR x: INTEGER;
BEGIN
Out(out, fmt, 2, p1,p2, x,x,x,x,x,x,x, errors);
END SE2;
PROCEDURE SE3*(out: Streams.Stream; fmt: ARRAY OF CHAR;
p1, p2, p3: ARRAY OF SYS.BYTE;
errors: RelatedEvents.Object);
VAR x: INTEGER;
BEGIN
Out(out, fmt, 3, p1,p2,p3, x,x,x,x,x,x, errors);
END SE3;
PROCEDURE SE4*(out: Streams.Stream; fmt: ARRAY OF CHAR;
p1, p2, p3, p4: ARRAY OF SYS.BYTE;
errors: RelatedEvents.Object);
VAR x: INTEGER;
BEGIN
Out(out, fmt, 4, p1,p2,p3,p4, x,x,x,x,x, errors);
END SE4;
PROCEDURE SE5*(out: Streams.Stream; fmt: ARRAY OF CHAR;
p1, p2, p3, p4, p5: ARRAY OF SYS.BYTE;
errors: RelatedEvents.Object);
VAR x: INTEGER;
BEGIN
Out(out, fmt, 5, p1,p2,p3,p4,p5, x,x,x,x, errors);
END SE5;
PROCEDURE SE6*(out: Streams.Stream; fmt: ARRAY OF CHAR;
p1, p2, p3, p4, p5, p6: ARRAY OF SYS.BYTE;
errors: RelatedEvents.Object);
VAR x: INTEGER;
BEGIN
Out(out, fmt, 6, p1,p2,p3,p4,p5,p6, x,x,x, errors);
END SE6;
PROCEDURE SE7*(out: Streams.Stream; fmt: ARRAY OF CHAR;
p1, p2, p3, p4, p5, p6, p7: ARRAY OF SYS.BYTE;
errors: RelatedEvents.Object);
VAR x: INTEGER;
BEGIN
Out(out, fmt, 7, p1,p2,p3,p4,p5,p6,p7, x,x, errors);
END SE7;
PROCEDURE SE8*(out: Streams.Stream; fmt: ARRAY OF CHAR;
p1, p2, p3, p4, p5, p6, p7, p8: ARRAY OF SYS.BYTE;
errors: RelatedEvents.Object);
VAR x: INTEGER;
BEGIN
Out(out, fmt, 8, p1,p2,p3,p4,p5,p6,p7,p8, x, errors);
END SE8;
PROCEDURE SE9*(out: Streams.Stream; fmt: ARRAY OF CHAR;
p1, p2, p3, p4, p5, p6, p7, p8, p9: ARRAY OF SYS.BYTE;
errors: RelatedEvents.Object);
BEGIN
Out(out, fmt, 9, p1,p2,p3,p4,p5,p6,p7,p8,p9, errors);
END SE9;
BEGIN
InitErrorHandling;
END ulmPrint.

155
src/library/ulm/ulmPriorities.Mod Normal file
View file

@ -0,0 +1,155 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Priorities.om,v 1.1 1994/02/22 20:09:33 borchert Exp $
----------------------------------------------------------------------------
$Log: Priorities.om,v $
Revision 1.1 1994/02/22 20:09:33 borchert
Initial revision
----------------------------------------------------------------------------
AFB 9/89
----------------------------------------------------------------------------
*)
MODULE ulmPriorities;
(* defines priority system per initialized variables;
all priorities needed by the Oberon-library (base, sys, and std) are
defined in this module;
the original module of this definition can be copied
and modified to match the needs of a specific application;
the default priority should range in [null..error);
setting the default priority to null allows to take advantage
of default error handling routines in small applications;
the priority system must be open for extensions:
- each priority below defines a base value of a priority region;
the region size is defined by `region';
e.g. legal library error priorities range from
liberrors to liberrors+region-1
- gap defines the minimum distance between two priority regions
defined in this module
*)
CONST
region* = 10;
gap* = 10;
null* = 0; (* lowest priority possible;
this is not a legal priority for events
*)
TYPE
Priority* = INTEGER;
VAR
(* current priority at begin of execution (after init of Events);
this is the lowest priority possible during execution (>= null);
every event with priority less than `base' is ignored
automatically
*)
base*: Priority;
(* default priority of events (if not changed by Events.SetPriority)*)
default*: Priority;
(* priority of messages which do not indicate an error *)
message*: Priority;
(* priority of system call errors *)
syserrors*: Priority;
(* priority of library errors;
e.g. usage errors or failed system calls;
library errors should have higher priority than syserrors
*)
liberrors*: Priority;
(* priority of assertions of library modules *)
assertions*: Priority;
(* priority of (application) error messages or warnings *)
error*: Priority;
(* priority of asynchronous interrupts like
break key, alarm clock, etc.
*)
interrupts*: Priority;
(* priority of ``out of space'' events (SysStorage) *)
storage*: Priority;
(* priority of run time errors *)
rtserrors*: Priority;
(* priority of fatal errors (error message & exit) *)
fatal*: Priority;
(* priority of fatal signals;
e.g. segmentation violation, alignment faults, illegal instructions;
these signals must not be ignored, and
event handlers must not return on such events
(this would cause an infinite loop)
*)
fatalsignals*: Priority;
(* priority of bugs and (failed) assertions;
bugs are error messages followed by exit (with core dump if possible)
*)
bug*: Priority;
(* priority of task switches are at very high priority to
allow the necessary bookkeeping
*)
taskswitch*: Priority;
(* priority of exit and abort;
actions on this priority level should be minimized
and (if possible) error-free
*)
exit*: Priority;
next: Priority; (* next legal priority value *)
PROCEDURE Set(VAR base: Priority);
BEGIN
base := next; INC(next, region+gap);
END Set;
BEGIN
next := null;
Set(base);
Set(default);
Set(message);
Set(syserrors);
Set(liberrors);
Set(assertions);
Set(error);
Set(interrupts);
Set(storage);
Set(rtserrors);
Set(fatal);
Set(fatalsignals);
Set(bug);
Set(taskswitch);
Set(exit);
END ulmPriorities.

203
src/library/ulm/ulmProcess.Mod Normal file
View file

@ -0,0 +1,203 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Process.om,v 1.3 2004/09/10 16:42:31 borchert Exp $
----------------------------------------------------------------------------
$Log: Process.om,v $
Revision 1.3 2004/09/10 16:42:31 borchert
id and host added
Revision 1.2 2004/04/02 17:58:26 borchert
softTermination and TerminateSoftly added
Revision 1.1 1994/02/22 20:09:43 borchert
Initial revision
----------------------------------------------------------------------------
AFB 3/92
----------------------------------------------------------------------------
*)
MODULE ulmProcess;
IMPORT Events := ulmEvents, Priorities := ulmPriorities;
(* user readable name of our process *)
TYPE
Name* = ARRAY 128 OF CHAR;
VAR
name*: Name;
id*: Name; (* something that identifies our process on our host *)
host*: Name; (* something that identifies our host, may be "" *)
(* exit codes *)
TYPE
ExitCode* = INTEGER;
VAR
indicateSuccess*: ExitCode;
indicateFailure*: ExitCode;
(* process events *)
TYPE
ExitEvent* = POINTER TO ExitEventRec;
ExitEventRec* =
RECORD
(Events.EventRec)
exitcode*: ExitCode;
END;
VAR
softTermination*: Events.EventType;
termination*: Events.EventType;
abort*: Events.EventType;
startOfGarbageCollection*, endOfGarbageCollection: Events.EventType;
(* these events indicate beginning and end of a garbage collection *)
TYPE
ExitProc* = PROCEDURE (code: ExitCode);
AbortProc* = PROCEDURE;
PauseProc* = PROCEDURE;
Interface* = POINTER TO InterfaceRec;
InterfaceRec* =
RECORD
exit*: ExitProc;
abort*: AbortProc;
pause*: PauseProc;
END;
(* private declarations *)
VAR
handlers: Interface;
nestlevel: INTEGER;
PROCEDURE SetHandlers*(if: Interface);
BEGIN
handlers := if;
END SetHandlers;
PROCEDURE Exit*(code: ExitCode);
VAR
event: ExitEvent;
BEGIN
INC(nestlevel);
IF nestlevel = 1 THEN
NEW(event);
event.type := termination;
event.message := "exit";
event.exitcode := code;
Events.Raise(event);
END;
handlers.exit(code);
handlers.pause;
LOOP END;
END Exit;
PROCEDURE TerminateSoftly*;
VAR
event: Events.Event;
BEGIN
NEW(event);
event.type := softTermination;
event.message := "terminate, please!";
Events.Raise(event);
END TerminateSoftly;
PROCEDURE Terminate*;
BEGIN
Exit(indicateSuccess);
END Terminate;
PROCEDURE Abort*;
VAR
event: Events.Event;
BEGIN
INC(nestlevel);
IF nestlevel = 1 THEN
NEW(event);
event.type := abort;
event.message := "abort";
Events.Raise(event);
END;
handlers.abort;
handlers.exit(indicateFailure);
handlers.pause;
LOOP END;
END Abort;
PROCEDURE Pause*;
BEGIN
handlers.pause;
END Pause;
(* =============================================================== *)
PROCEDURE AbortHandler(event: Events.Event);
BEGIN
Abort;
END AbortHandler;
(* =============================================================== *)
PROCEDURE DummyExit(code: ExitCode);
BEGIN
LOOP END;
END DummyExit;
PROCEDURE DummyAbort;
BEGIN
LOOP END;
END DummyAbort;
PROCEDURE DummyPause;
BEGIN
LOOP END;
END DummyPause;
BEGIN
nestlevel := 0;
name := "Process.name";
indicateSuccess := 0; indicateFailure := 1;
NEW(handlers);
handlers.exit := DummyExit;
handlers.abort := DummyAbort;
handlers.pause := DummyPause;
Events.Define(termination);
Events.SetPriority(termination, Priorities.exit);
Events.Handler(termination, Events.NilHandler);
Events.Define(abort);
Events.SetPriority(abort, Priorities.exit);
Events.Handler(abort, Events.NilHandler);
Events.Define(softTermination);
Events.SetPriority(softTermination, Priorities.message);
Events.Handler(softTermination, Events.NilHandler);
Events.AbortHandler(AbortHandler);
Events.Define(startOfGarbageCollection);
Events.SetPriority(startOfGarbageCollection, Priorities.message);
Events.Ignore(startOfGarbageCollection);
Events.Define(endOfGarbageCollection);
Events.SetPriority(endOfGarbageCollection, Priorities.message);
Events.Ignore(endOfGarbageCollection);
END ulmProcess.

419
src/library/ulm/ulmRandomGenerators.Mod Normal file
View file

@ -0,0 +1,419 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: 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.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.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.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.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
----------------------------------------------------------------------------
*)
MODULE ulmRandomGenerators;
(* 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;
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);
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;
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
*)
(* ----- 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 *)
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;
VAR
service : Services.Service;
serviceDiscID: Disciplines.Identifier;
sequenceType,
defaultSequenceType: Services.Type;
(* ----- bug workaround ----- *)
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: 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;
BEGIN
serviceDiscID := Disciplines.Unique();
Services.Create(service, "RandomGenerators");
Services.CreateType(sequenceType, "RandomGenerators.Sequence", "");
Services.CreateType(defaultSequenceType, "RandomGenerators.DefaultSequence",
"RandomGenerators.Sequence");
CreateDefaultSequences;
END ulmRandomGenerators.

313
src/library/ulm/ulmReals.Mod Normal file
View file

@ -0,0 +1,313 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Reals.om,v 1.2 2004/03/09 21:38:50 borchert Exp $
----------------------------------------------------------------------------
$Log: Reals.om,v $
Revision 1.2 2004/03/09 21:38:50 borchert
maxlongexp, minlongexp, and maxlongdignum adapted to SPARC architecture
Revision 1.1 1994/02/23 07:45:40 borchert
Initial revision
----------------------------------------------------------------------------
AFB 6/89
----------------------------------------------------------------------------
*)
MODULE ulmReals;
IMPORT IEEE := ulmIEEE, MC68881 := ulmMC68881;
CONST
(* for REAL *)
maxexp* = 309;
minexp* = -323;
maxdignum* = 16;
(* for LONGREAL *)
(*
maxlongexp = 4932;
minlongexp = -4951;
maxlongdignum = 19;
*)
maxlongexp* = 309;
minlongexp* = -323;
maxlongdignum* = 16;
powers = 6;
maxbase = 16;
TYPE
PowerRec =
RECORD
p10: LONGREAL;
n: INTEGER;
END;
VAR
powtab: ARRAY powers OF PowerRec;
sigdigits: ARRAY maxbase+1 OF INTEGER; (* valid range: [2..maxbase] *)
PROCEDURE ExpAndMan*(r: LONGREAL; long: BOOLEAN; base: INTEGER;
VAR exponent: INTEGER; VAR mantissa: LONGREAL);
(* get exponent and mantissa from `r':
(1.0 >= ABS(mantissa)) & (ABS(mantissa) < base)
r = mantissa * base^exponent
long should be false if a REAL-value is passed to `r'
valid values of base: 2, 8, 10, and 16
*)
VAR
neg: BOOLEAN;
index: INTEGER;
roundoff: LONGREAL;
i: INTEGER;
ndigits: INTEGER;
BEGIN
IF r = 0.0 THEN
exponent := 0; mantissa := 0; RETURN
ELSIF r = IEEE.plusInfinity THEN
IF long THEN
exponent := 9999;
ELSE
exponent := 999;
END;
mantissa := 1;
RETURN
ELSIF r = IEEE.minusInfinity THEN
IF long THEN
exponent := 9999;
ELSE
exponent := 999;
END;
mantissa := -1;
RETURN
ELSIF IEEE.NotANumber(r) THEN
exponent := 0;
mantissa := 0;
RETURN
END;
neg := r < 0.0;
IF neg THEN
r := ABS(r);
END;
exponent := 0; mantissa := r;
IF base = 10 THEN
IF MC68881.available THEN
exponent := SHORT(ENTIER(MC68881.FLOG10(r)));
mantissa := r / MC68881.FTENTOX(exponent);
ELSE
(* use powtab *)
index := 0;
WHILE mantissa < 1.0 DO
WHILE mantissa * powtab[index].p10 < 10 DO
DEC(exponent, powtab[index].n);
mantissa := mantissa * powtab[index].p10;
END;
INC(index);
END;
WHILE mantissa >= 10 DO
WHILE mantissa >= powtab[index].p10 DO
INC(exponent, powtab[index].n);
mantissa := mantissa / powtab[index].p10;
END;
INC(index);
END;
END;
ELSE (* general case *)
WHILE mantissa < 1.0 DO
DEC(exponent); mantissa := mantissa * base;
END;
WHILE mantissa >= base DO
INC(exponent); mantissa := mantissa / base;
END;
END;
IF ~(base IN {2, 4, 16}) THEN
(* roundoff *)
roundoff := base/2;
IF ~long & (base = 10) THEN
ndigits := maxdignum;
ELSE
ndigits := sigdigits[base];
END;
i := 0;
WHILE i < ndigits DO
roundoff := roundoff/base; INC(i);
END;
mantissa := mantissa + roundoff;
IF mantissa >= base THEN
mantissa := mantissa / base;
INC(exponent);
ELSIF mantissa < 1 THEN
mantissa := mantissa * base;
DEC(exponent);
END;
END;
IF neg THEN
mantissa := -mantissa;
END;
END ExpAndMan;
PROCEDURE Power*(base: LONGREAL; exp: INTEGER) : LONGREAL;
(* efficient calculation of base^exp *)
VAR
r, res: LONGREAL;
neg: BOOLEAN; (* negative exponent? *)
BEGIN
IF MC68881.available & (base = 10) THEN
RETURN MC68881.FTENTOX(exp)
ELSIF MC68881.available & (base = 2) THEN
RETURN MC68881.FTWOTOX(exp)
ELSE
res := 1.0;
r := base;
neg := exp < 0;
exp := ABS(exp);
LOOP
IF ODD(exp) THEN
res := res * r;
END;
exp := exp DIV 2;
IF exp = 0 THEN
EXIT
END;
r := r * r;
END;
IF neg THEN
RETURN 1 / res
ELSE
RETURN res
END;
END;
END Power;
PROCEDURE Digits*(mantissa: LONGREAL; base: INTEGER;
VAR buf: ARRAY OF CHAR;
VAR neg: BOOLEAN;
force: BOOLEAN; VAR ndigits: INTEGER);
(* PRE:
mantissa holds the post-condition of ExpAndMan;
valid values for base are 2, 8, 10, and 16
ndigits > 0: maximal number of digits
POST:
the mantissa is converted into digits 0-9 and A-F (if base = 16);
buf consists of ndigits digits and
is guaranteed to be 0X-terminated;
neg is set to TRUE if mantissa < 0
force = FALSE:
there are no leading zeroes except on mantissa = 0;
force = TRUE
ndigits is unchanged
*)
VAR
index: INTEGER; (* of buf *)
i: INTEGER; roundoff: LONGREAL;
lastnz: INTEGER; (* last index with buf[index] # "0" *)
ch: CHAR;
digit: LONGINT;
maxdig: CHAR; (* base-1 converted *)
BEGIN
index := 0;
IF (ndigits <= 0) OR (ndigits+1 >= LEN(buf)) THEN
ndigits := SHORT(LEN(buf) - 1);
END;
IF ~force & (ndigits > sigdigits[base]) THEN
ndigits := sigdigits[base];
END;
neg := mantissa < 0;
mantissa := ABS(mantissa);
IF mantissa = 0 THEN
buf[index] := "0"; INC(index);
ELSE
(* roundoff *)
roundoff := base/2;
i := 0;
WHILE i < ndigits DO
roundoff := roundoff/base; INC(i);
END;
IF mantissa + roundoff < base THEN
mantissa := mantissa + roundoff;
END;
(* conversion *)
lastnz := 0;
WHILE (index < ndigits) & (mantissa # 0) DO
digit := ENTIER(mantissa);
(* digit in [0..base-1] *)
IF digit <= 9 THEN
ch := CHR(digit + ORD("0"));
ELSIF digit <= 16 THEN
ch := CHR(digit - 10 + ORD("A"));
ELSE
ch := "?";
END;
buf[index] := ch; INC(index);
mantissa := (mantissa - digit) * base;
IF ch # "0" THEN
lastnz := index;
END;
END;
index := lastnz;
END;
buf[index] := 0X; ndigits := index;
END Digits;
PROCEDURE Convert*(digits: ARRAY OF CHAR; base: INTEGER; neg: BOOLEAN;
VAR mantissa: LONGREAL);
(* convert normalized `digits' (decimal point after 1st digit)
into `mantissa'
*)
VAR
index: INTEGER;
factor: LONGREAL;
BEGIN
IF digits = "0" THEN
mantissa := 0;
ELSE
mantissa := ORD(digits[0]) - ORD("0");
factor := 1 / base;
index := 1;
WHILE (index < LEN(digits)) & (index < sigdigits[base]) &
(digits[index] # 0X) & (factor > 0) DO
mantissa := mantissa + (ORD(digits[index]) - ORD("0")) * factor;
factor := factor / base;
INC(index);
END;
IF neg THEN
mantissa := -mantissa;
END;
END;
END Convert;
BEGIN
powtab[0].p10 := 1.0D32; powtab[0].n := 32;
powtab[1].p10 := 1.0D16; powtab[1].n := 16;
powtab[2].p10 := 1.0D8; powtab[2].n := 8;
powtab[3].p10 := 1.0D4; powtab[3].n := 4;
powtab[4].p10 := 1.0D2; powtab[4].n := 2;
powtab[5].p10 := 1.0D1; powtab[5].n := 1;
(* for LONGREAL *)
sigdigits[2] := 64; sigdigits[3] := 40; sigdigits[4] := 32;
sigdigits[5] := 27; sigdigits[6] := 24; sigdigits[7] := 22;
sigdigits[8] := 21; sigdigits[9] := 20; sigdigits[10] := 19;
sigdigits[11] := 18; sigdigits[12] := 17; sigdigits[13] := 17;
sigdigits[14] := 16; sigdigits[15] := 16; sigdigits[16] := 16;
END ulmReals.

Some files were not shown because too many files have changed in this diff Show more