From 7bdc53145e4a65704e6cc39c76d23b14752993a2 Mon Sep 17 00:00:00 2001 From: David Brown Date: Thu, 16 Jun 2016 14:56:42 +0100 Subject: [PATCH] Update library source to V2. --- src/library/misc/MultiArrayRiders.Mod | 2 +- src/library/misc/MultiArrays.Mod | 2 +- src/library/misc/crt.Mod | 19 +- src/library/ooc/oocCILP32.Mod | 48 +- src/library/ooc/oocCLLP64.Mod | 47 +- src/library/ooc/oocCLP64.Mod | 47 +- src/library/ooc/oocIntConv.Mod | 1 + src/library/ooc/oocLRealConv.Mod | 2 + src/library/ooc/oocRealConv.Mod | 2 + src/library/ooc/oocRts.Mod | 95 +- src/library/ooc/oocSysClock.Mod | 101 +- src/library/ooc/oocwrapperlibc.Mod | 23 + src/library/ooc2/ooc2IntConv.Mod | 3 +- src/library/oocX11/oocX11.Mod | 249 ++-- src/library/oocX11/oocXYplane.Mod | 60 +- src/library/oocX11/oocXutil.Mod | 2 +- src/library/pow/powStrings.Mod | 1278 ++++++++-------- src/library/s3/ethBTrees.Mod | 1 + src/library/s3/ethRandomNumbers.Mod | 2 +- src/library/s3/ethReals.Mod | 223 +-- src/library/s3/ethStrings.Mod | 2 +- src/library/s3/ethZip.Mod | 1 + src/library/s3/ethZlibDeflate.Mod | 1 + src/library/s3/ethZlibInflate.Mod | 3 + src/library/ulm/ulmConstStrings.Mod | 1 + src/library/ulm/ulmEvents.Mod | 1 + src/library/ulm/ulmPersistentObjects.Mod | 1 + src/library/ulm/ulmPrint.Mod | 1224 ++++++++-------- src/library/ulm/ulmResources.Mod | 225 +-- src/library/ulm/ulmSYSTEM.Mod | 52 +- src/library/ulm/ulmScales.Mod | 1 + src/library/ulm/ulmStreamConditions.Mod | 1 + src/library/ulm/ulmStreams.Mod | 1 + src/library/ulm/ulmSysConversions.Mod | 22 +- src/library/ulm/ulmSysIO.Mod | 306 ++-- src/library/ulm/ulmSysStat.Mod | 256 ++-- src/library/ulm/ulmTCrypt.Mod | 1692 +++++++++++----------- src/library/ulm/ulmTexts.Mod | 1 + src/library/ulm/ulmTimes.Mod | 38 +- src/library/ulm/ulmTypes.Mod | 52 +- src/library/v4/Args.Mod | 64 +- src/library/v4/Modules.Mod | 6 +- src/library/v4/Printer.Mod | 7 +- src/library/v4/Reals.Mod | 216 +-- src/library/v4/Sets.Mod | 30 +- src/library/v4/Texts.Mod | 79 +- 46 files changed, 3141 insertions(+), 3349 deletions(-) create mode 100755 src/library/ooc/oocwrapperlibc.Mod diff --git a/src/library/misc/MultiArrayRiders.Mod b/src/library/misc/MultiArrayRiders.Mod index 852dcde0..1d67850b 100644 --- a/src/library/misc/MultiArrayRiders.Mod +++ b/src/library/misc/MultiArrayRiders.Mod @@ -20,7 +20,7 @@ email Patrick.Hunziker@unibas.ch 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; +IMPORT MultiArrays, Out := Console, Input := Platform; 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 *) diff --git a/src/library/misc/MultiArrays.Mod b/src/library/misc/MultiArrays.Mod index 7bf04447..a2e61b2c 100644 --- a/src/library/misc/MultiArrays.Mod +++ b/src/library/misc/MultiArrays.Mod @@ -40,7 +40,7 @@ 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 *) +IMPORT Out := Console, Input := Platform; (* Import only needed for Demo purposes *) TYPE SIntPtr* = POINTER TO ARRAY OF SHORTINT; diff --git a/src/library/misc/crt.Mod b/src/library/misc/crt.Mod index 3fd63b47..ab6e36b9 100644 --- a/src/library/misc/crt.Mod +++ b/src/library/misc/crt.Mod @@ -1,6 +1,6 @@ MODULE crt; -IMPORT vt100, Unix, Console, +IMPORT vt100, Platform, Console, Strings; (* strings to remove later ? *) CONST @@ -28,11 +28,6 @@ CONST (* Add-in for blinking *) Blink* = 128; -TYPE - PFdSet = POINTER TO Unix.FdSet; - -VAR tmpstr : ARRAY 23 OF CHAR; - PROCEDURE EraseDisplay*; BEGIN vt100.ED(2); @@ -58,16 +53,8 @@ VAR tmpstr : ARRAY 23 OF CHAR; 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 Delay*(ms: INTEGER); + BEGIN Platform.Delay(ms) END Delay; PROCEDURE GotoXY* (x, y: INTEGER); BEGIN diff --git a/src/library/ooc/oocCILP32.Mod b/src/library/ooc/oocCILP32.Mod index 2e7751ff..e868b9f6 100644 --- a/src/library/ooc/oocCILP32.Mod +++ b/src/library/ooc/oocCILP32.Mod @@ -1,5 +1,8 @@ (* $Id: C.Mod,v 1.9 1999/10/03 11:46:01 ooc-devel Exp $ *) MODULE oocC; + +(* ILP32 model *) + (* Basic data types for interfacing to C code. Copyright (C) 1997-1998 Michael van Acken @@ -18,8 +21,7 @@ MODULE oocC; 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -IMPORT - SYSTEM; +IMPORT SYSTEM; (* These types are intended to be equivalent to their C counterparts. @@ -28,39 +30,33 @@ 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; + char* = CHAR; (* 8 bits *) + signedchar* = SHORTINT; (* 8 bits *) + shortint* = RECORD a,b: SYSTEM.BYTE END; (* 16 bits *) + int* = LONGINT; (* 32 bits *) + set* = LONGINT; (* 32 bits *) + longint* = LONGINT; (* 32 bits on ILP32 (64 bits is 'long long') *) +(*longset* = SET; n/a *) (* 64 bit SET *) + address* = LONGINT; (* 32 bits *) + float* = REAL; (* 32 bits *) + double* = LONGREAL; (* 64 bits *) 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; + (* + enum2* = int; + enum4* = int; *) - FILE* = address; (* this is acually a replacement for `FILE*', i.e., for a pointer type *) - sizet* = longint; - uidt* = int; - gidt* = int; + FILE* = address; (* this is acually a replacement for `FILE*', i.e., for a pointer type *) + sizet* = longint; (* 32 bits in i686 *) + 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; + intPtr1d* = POINTER TO ARRAY OF int; TYPE (* C string type, assignment compatible with character arrays and string constants *) diff --git a/src/library/ooc/oocCLLP64.Mod b/src/library/ooc/oocCLLP64.Mod index 14638e75..a7eadc0b 100644 --- a/src/library/ooc/oocCLLP64.Mod +++ b/src/library/ooc/oocCLLP64.Mod @@ -1,5 +1,8 @@ (* $Id: C.Mod,v 1.9 1999/10/03 11:46:01 ooc-devel Exp $ *) MODULE oocC; + +(* LP64 model *) + (* Basic data types for interfacing to C code. Copyright (C) 1997-1998 Michael van Acken @@ -18,8 +21,7 @@ MODULE oocC; 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -IMPORT - SYSTEM; +IMPORT SYSTEM; (* These types are intended to be equivalent to their C counterparts. @@ -28,42 +30,37 @@ 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; + char* = CHAR; (* 8 bits *) + signedchar* = SHORTINT; (* 8 bits *) + shortint* = RECORD a,b: SYSTEM.BYTE END; (* 16 bits *) + int* = INTEGER; (* 32 bits *) + set* = INTEGER; (* 32 bits *) + longint* = INTEGER; (* 32 bits *) + longset* = SET; (* 64 bits *) + address* = LONGINT; (* 64 bits *) + float* = REAL; (* 32 bits *) + double* = LONGREAL; (* 64 bits *) 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; + (* + enum2* = int; + enum4* = int; *) - FILE* = address; (* this is acually a replacement for `FILE*', i.e., for a pointer type *) + FILE* = address; (* this is acually a replacement for `FILE*', i.e., for a pointer type *) sizet* = longint; - uidt* = int; - gidt* = int; + 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; + 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; + string* = POINTER TO ARRAY OF char; TYPE Proc* = PROCEDURE; diff --git a/src/library/ooc/oocCLP64.Mod b/src/library/ooc/oocCLP64.Mod index 14638e75..dcc76584 100644 --- a/src/library/ooc/oocCLP64.Mod +++ b/src/library/ooc/oocCLP64.Mod @@ -1,5 +1,8 @@ (* $Id: C.Mod,v 1.9 1999/10/03 11:46:01 ooc-devel Exp $ *) MODULE oocC; + +(* LP64 model *) + (* Basic data types for interfacing to C code. Copyright (C) 1997-1998 Michael van Acken @@ -18,8 +21,7 @@ MODULE oocC; 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -IMPORT - SYSTEM; +IMPORT SYSTEM; (* These types are intended to be equivalent to their C counterparts. @@ -28,42 +30,37 @@ 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; + char* = CHAR; (* 8 bits *) + signedchar* = SHORTINT; (* 8 bits *) + shortint* = RECORD a,b: SYSTEM.BYTE END; (* 16 bits *) + int* = INTEGER; (* 32 bits *) + set* = INTEGER; (* 32 bits *) + longint* = LONGINT; (* 64 bits *) + longset* = SET; (* 64 bits *) + address* = LONGINT; (* 64 bits *) + float* = REAL; (* 32 bits *) + double* = LONGREAL; (* 64 bits *) 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; + (* + enum2* = int; + enum4* = int; *) - FILE* = address; (* this is acually a replacement for `FILE*', i.e., for a pointer type *) + FILE* = address; (* this is acually a replacement for `FILE*', i.e., for a pointer type *) sizet* = longint; - uidt* = int; - gidt* = int; + 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; + 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; + string* = POINTER TO ARRAY OF char; TYPE Proc* = PROCEDURE; diff --git a/src/library/ooc/oocIntConv.Mod b/src/library/ooc/oocIntConv.Mod index 1f6532ab..73185830 100644 --- a/src/library/ooc/oocIntConv.Mod +++ b/src/library/ooc/oocIntConv.Mod @@ -162,6 +162,7 @@ BEGIN ELSE RETURN strWrongFormat; END; + ELSE (* Ignore unrecognised class *) END; prev:=class; INC(index) END; diff --git a/src/library/ooc/oocLRealConv.Mod b/src/library/ooc/oocLRealConv.Mod index a596e6de..7aa13f23 100644 --- a/src/library/ooc/oocLRealConv.Mod +++ b/src/library/ooc/oocLRealConv.Mod @@ -231,6 +231,7 @@ BEGIN IF decExp THEN DEC(nexp) END; END | Conv.invalid, Conv.terminator: EXIT + ELSE (* Ignore unrecognised class *) END; prev:=class; INC(index) END; @@ -285,6 +286,7 @@ BEGIN IF decExp THEN DEC(nexp) END; END | Conv.invalid, Conv.terminator: EXIT + ELSE (* Ignore unrecognised class *) END; prev:=class; INC(index) END; diff --git a/src/library/ooc/oocRealConv.Mod b/src/library/ooc/oocRealConv.Mod index 9eaca9ed..b8742bf2 100644 --- a/src/library/ooc/oocRealConv.Mod +++ b/src/library/ooc/oocRealConv.Mod @@ -182,6 +182,7 @@ BEGIN IF decExp THEN DEC(nexp) END; END | Conv.invalid, Conv.terminator: EXIT + ELSE (* Ignore unrecognised class *) END; prev:=class; INC(index) END; @@ -254,6 +255,7 @@ BEGIN IF decExp THEN DEC(nexp) END; END | Conv.invalid, Conv.terminator: EXIT + ELSE (* Ignore unrecognised class *) END; prev:=class; INC(index) END; diff --git a/src/library/ooc/oocRts.Mod b/src/library/ooc/oocRts.Mod index 87461561..86274ce9 100644 --- a/src/library/ooc/oocRts.Mod +++ b/src/library/ooc/oocRts.Mod @@ -1,78 +1,67 @@ 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*); +IMPORT Args, Platform, Files, Strings := oocStrings(*, Console*); CONST pathSeperator* = "/"; -VAR i : INTEGER; -b : BOOLEAN; -str0 : ARRAY 128 OF CHAR; +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; +BEGIN RETURN Platform.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; +BEGIN RETURN Platform.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; + 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 + 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;*) + found := Strings.Equal(user, str1) + 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"); -*) + (* test *) + (* + i := System("ls"); + b := GetEnv(str0, "HOME"); + IF b THEN Console.String(str0); Console.Ln END; + GetUserHome(str0, "noch"); + *) END oocRts. diff --git a/src/library/ooc/oocSysClock.Mod b/src/library/ooc/oocSysClock.Mod index da43fea4..ee9b7157 100644 --- a/src/library/ooc/oocSysClock.Mod +++ b/src/library/ooc/oocSysClock.Mod @@ -1,110 +1,15 @@ MODULE oocSysClock; -IMPORT Unix; +IMPORT SYSTEM, Platform; -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 CanGetClock*(): BOOLEAN; BEGIN RETURN TRUE END CanGetClock; 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; + Platform.GetTimeOfDay(sec, usec); RETURN 0; END GetTimeOfDay; END oocSysClock. diff --git a/src/library/ooc/oocwrapperlibc.Mod b/src/library/ooc/oocwrapperlibc.Mod new file mode 100755 index 00000000..c5a0377e --- /dev/null +++ b/src/library/ooc/oocwrapperlibc.Mod @@ -0,0 +1,23 @@ +MODULE oocwrapperlibc; +IMPORT SYSTEM, Platform; + + +PROCEDURE -includeStdio() "#include "; + +PROCEDURE system*(cmd : ARRAY OF CHAR); +VAR r: INTEGER; +BEGIN + r := Platform.System(cmd) +END system; + + +PROCEDURE -sprntf(s, t0, t1, t2: ARRAY OF CHAR): INTEGER + "sprintf((char*)s, (char*)t0, (char*)t1, (char*)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; + +END oocwrapperlibc. diff --git a/src/library/ooc2/ooc2IntConv.Mod b/src/library/ooc2/ooc2IntConv.Mod index 3b9c0d1b..298835d6 100644 --- a/src/library/ooc2/ooc2IntConv.Mod +++ b/src/library/ooc2/ooc2IntConv.Mod @@ -124,7 +124,7 @@ VAR positive: BOOLEAN; prev, class: Conv.ScanClass; -PROCEDURE LessOrEqual (VAR high: ARRAY OF CHAR; start, end: INTEGER): BOOLEAN; + PROCEDURE LessOrEqual (VAR high: ARRAY OF CHAR; start, end: INTEGER): BOOLEAN; VAR i: INTEGER; BEGIN (* pre: index-start = maxDigits *) @@ -176,6 +176,7 @@ BEGIN ELSE RETURN strWrongFormat; END; + ELSE (* Ignore unrecognised class *) END; prev:=class; INC(index) END; diff --git a/src/library/oocX11/oocX11.Mod b/src/library/oocX11/oocX11.Mod index fa4e860b..b0e793ac 100644 --- a/src/library/oocX11/oocX11.Mod +++ b/src/library/oocX11/oocX11.Mod @@ -1,5 +1,5 @@ MODULE oocX11;(* [INTERFACE "C"; - LINK LIB "X11" ADDOPTION LibX11Prefix, LibX11Suffix END];*) + LINK LIB "X11" ADDOPTION LibX11Prefix, LibX11Suffix END];*) IMPORT C := oocC, SYSTEM; @@ -8,6 +8,7 @@ CONST XPROTOCOL* = 11; (* current protocol version *) XPROTOCOLREVISION* = 0; (* current minor version *) + TYPE ulongmask* = C.longset; (*uintmask* = C.set;*) @@ -46,11 +47,11 @@ TYPE CONST None* = 0; (* universal null resource or null atom *) ParentRelative* = 1; (* background pixmap in CreateWindow - and ChangeWindowAttributes *) + and ChangeWindowAttributes *) CopyFromParent* = 0; (* border pixmap in CreateWindow - and ChangeWindowAttributes - special VisualID and special window - class passed to CreateWindow *) + and ChangeWindowAttributes + special VisualID and special window + class passed to CreateWindow *) PointerWindow* = 0; (* destination window in SendEvent *) InputFocus* = 1; (* destination window in SendEvent *) PointerRoot* = 1; (* focus window in SetInputFocus *) @@ -67,96 +68,96 @@ CONST (* Input Event Masks. Used as event-mask window attribute and as arguments to Grab requests. Not to be confused with event names. *) CONST - NoEventMask* = {}; - KeyPressMask* = {0}; - KeyReleaseMask* = {1}; - ButtonPressMask* = {2}; - ButtonReleaseMask* = {3}; - EnterWindowMask* = {4}; - LeaveWindowMask* = {5}; - PointerMotionMask* = {6}; - PointerMotionHintMask* = {7}; - Button1MotionMask* = {8}; - Button2MotionMask* = {9}; - Button3MotionMask* = {10}; - Button4MotionMask* = {11}; - Button5MotionMask* = {12}; - ButtonMotionMask* = {13}; - KeymapStateMask* = {14}; - ExposureMask* = {15}; - VisibilityChangeMask* = {16}; - StructureNotifyMask* = {17}; - ResizeRedirectMask* = {18}; - SubstructureNotifyMask* = {19}; + NoEventMask* = {}; + KeyPressMask* = {0}; + KeyReleaseMask* = {1}; + ButtonPressMask* = {2}; + ButtonReleaseMask* = {3}; + EnterWindowMask* = {4}; + LeaveWindowMask* = {5}; + PointerMotionMask* = {6}; + PointerMotionHintMask* = {7}; + Button1MotionMask* = {8}; + Button2MotionMask* = {9}; + Button3MotionMask* = {10}; + Button4MotionMask* = {11}; + Button5MotionMask* = {12}; + ButtonMotionMask* = {13}; + KeymapStateMask* = {14}; + ExposureMask* = {15}; + VisibilityChangeMask* = {16}; + StructureNotifyMask* = {17}; + ResizeRedirectMask* = {18}; + SubstructureNotifyMask* = {19}; SubstructureRedirectMask* = {20}; - FocusChangeMask* = {21}; - PropertyChangeMask* = {22}; - ColormapChangeMask* = {23}; - OwnerGrabButtonMask* = {24}; + FocusChangeMask* = {21}; + PropertyChangeMask* = {22}; + ColormapChangeMask* = {23}; + OwnerGrabButtonMask* = {24}; (* Event names. Used in "type" field in XEvent structures. Not to be confused with event masks above. They start from 2 because 0 and 1 are reserved in the protocol for errors and replies. *) CONST - KeyPress* = 2; - KeyRelease* = 3; - ButtonPress* = 4; - ButtonRelease* = 5; - MotionNotify* = 6; - EnterNotify* = 7; - LeaveNotify* = 8; - FocusIn* = 9; - FocusOut* = 10; - KeymapNotify* = 11; - Expose* = 12; - GraphicsExpose* = 13; - NoExpose* = 14; + KeyPress* = 2; + KeyRelease* = 3; + ButtonPress* = 4; + ButtonRelease* = 5; + MotionNotify* = 6; + EnterNotify* = 7; + LeaveNotify* = 8; + FocusIn* = 9; + FocusOut* = 10; + KeymapNotify* = 11; + Expose* = 12; + GraphicsExpose* = 13; + NoExpose* = 14; VisibilityNotify* = 15; - CreateNotify* = 16; - DestroyNotify* = 17; - UnmapNotify* = 18; - MapNotify* = 19; - MapRequest* = 20; - ReparentNotify* = 21; - ConfigureNotify* = 22; + CreateNotify* = 16; + DestroyNotify* = 17; + UnmapNotify* = 18; + MapNotify* = 19; + MapRequest* = 20; + ReparentNotify* = 21; + ConfigureNotify* = 22; ConfigureRequest* = 23; - GravityNotify* = 24; - ResizeRequest* = 25; - CirculateNotify* = 26; + GravityNotify* = 24; + ResizeRequest* = 25; + CirculateNotify* = 26; CirculateRequest* = 27; - PropertyNotify* = 28; - SelectionClear* = 29; + PropertyNotify* = 28; + SelectionClear* = 29; SelectionRequest* = 30; - SelectionNotify* = 31; - ColormapNotify* = 32; - ClientMessage* = 33; - MappingNotify* = 34; - LASTEvent* = 35; (* must be bigger than any event # *) + SelectionNotify* = 31; + ColormapNotify* = 32; + ClientMessage* = 33; + MappingNotify* = 34; + LASTEvent* = 35; (* must be bigger than any event # *) (* Key masks. Used as modifiers to GrabButton and GrabKey, results of QueryPointer, state in various key-, mouse-, and button-related events. *) CONST - ShiftMask* = {0}; - LockMask* = {1}; + ShiftMask* = {0}; + LockMask* = {1}; ControlMask* = {2}; - Mod1Mask* = {3}; - Mod2Mask* = {4}; - Mod3Mask* = {5}; - Mod4Mask* = {6}; - Mod5Mask* = {7}; + Mod1Mask* = {3}; + Mod2Mask* = {4}; + Mod3Mask* = {5}; + Mod4Mask* = {6}; + Mod5Mask* = {7}; (* modifier names. Used to build a SetModifierMapping request or to read a GetModifierMapping request. These correspond to the masks defined above. *) CONST - ShiftMapIndex* = 0; - LockMapIndex* = 1; + ShiftMapIndex* = 0; + LockMapIndex* = 1; ControlMapIndex* = 2; - Mod1MapIndex* = 3; - Mod2MapIndex* = 4; - Mod3MapIndex* = 5; - Mod4MapIndex* = 6; - Mod5MapIndex* = 7; + Mod1MapIndex* = 3; + Mod2MapIndex* = 4; + Mod3MapIndex* = 5; + Mod4MapIndex* = 6; + Mod5MapIndex* = 7; (* button masks. Used in same manner as Key masks above. Not to be confused with button names below. *) @@ -270,14 +271,14 @@ CONST BadMatch* = 8; (* parameter mismatch *) BadDrawable* = 9; (* parameter not a Pixmap or Window *) BadAccess* = 10; (* depending on context: - - key/button already grabbed - - attempt to free an illegal - cmap entry - - attempt to store into a read-only - color map entry. - - attempt to modify the access control - list from other than the local host. - *) + - key/button already grabbed + - attempt to free an illegal + cmap entry + - attempt to store into a read-only + color map entry. + - attempt to modify the access control + list from other than the local host. + *) BadAlloc* = 11; (* insufficient resources *) BadColor* = 12; (* no such colormap *) BadGC* = 13; (* parameter not a GC *) @@ -630,9 +631,9 @@ CONST $XFree86: xc/lib/X11/Xlib.h,v 3.2 1994/09/17 13:44:15 dawes Exp $ *) (* - * Xlib.h - Header definition and support file for the C subroutine - * interface library (Xlib) to the X Window System Protocol (V11). - * Structures and symbols starting with "" are private to the library. + * Xlib.h - Header definition and support file for the C subroutine + * interface library (Xlib) to the X Window System Protocol (V11). + * Structures and symbols starting with "" are private to the library. *) CONST @@ -706,10 +707,10 @@ TYPE linewidth*: C.int; (* line width *) linestyle*: C.int; (* LineSolid, LineOnOffDash, LineDoubleDash *) capstyle*: C.int; (* CapNotLast, CapButt, - CapRound, CapProjecting *) + CapRound, CapProjecting *) joinstyle*: C.int; (* JoinMiter, JoinRound, JoinBevel *) fillstyle*: C.int; (* FillSolid, FillTiled, - FillStippled, FillOpaeueStippled *) + FillStippled, FillOpaeueStippled *) fillrule*: C.int; (* EvenOddRule, WindingRule *) arcmode*: C.int; (* ArcChord, ArcPieSlice *) tile*: Pixmap; (* tile pixmap for tiling operations *) @@ -1118,9 +1119,9 @@ TYPE xroot*, yroot*: C.int; (* coordinates relative to root *) mode*: C.int; (* NotifyNormal, NotifyGrab, NotifyUngrab *) detail*: C.int; (* - * NotifyAncestor, NotifyVirtual, NotifyInferior, - * NotifyNonlinear,NotifyNonlinearVirtual - *) + * NotifyAncestor, NotifyVirtual, NotifyInferior, + * NotifyNonlinear,NotifyNonlinearVirtual + *) samescreen*: Bool; (* same screen flag *) focus*: Bool; (* boolean focus *) state*: uintmask; (* key or button mask *) @@ -1137,10 +1138,10 @@ TYPE window*: Window; (* window of event *) mode*: C.int; (* NotifyNormal, NotifyGrab, NotifyUngrab *) detail*: C.int; (* - * NotifyAncestor, NotifyVirtual, NotifyInferior, - * NotifyNonlinear,NotifyNonlinearVirtual, NotifyPointer, - * NotifyPointerRoot, NotifyDetailNone - *) + * NotifyAncestor, NotifyVirtual, NotifyInferior, + * NotifyNonlinear,NotifyNonlinearVirtual, NotifyPointer, + * NotifyPointerRoot, NotifyDetailNone + *) END; XFocusInEvent* = XFocusChangeEvent; XFocusOutEvent* = XFocusChangeEvent; @@ -1431,7 +1432,7 @@ TYPE display*: DisplayPtr; (* Display the event was read from *) window*: Window; (* unused *) request*: C.int; (* one of MappingModifier, MappingKeyboard, - MappingPointer *) + MappingPointer *) firstkeycode*: C.int; (* first keycode *) count*: C.int; (* defines range of change w. firstkeycode*) END; @@ -1950,6 +1951,13 @@ TYPE XErrorHandler* = PROCEDURE (display: DisplayPtr; errorevent: XErrorEventPtr): C.int; XIOErrorHandler* = PROCEDURE (display: DisplayPtr); XConnectionWatchProc* = PROCEDURE (dpy: DisplayPtr; clientdate: XPointer; fd: C.int; opening: Bool; watchdata: XPointerPtr1d); + + +PROCEDURE -aincludexlib "#include "; +PROCEDURE -aincludexutil "#include "; +PROCEDURE -aincludexresource "#include "; + + (* PROCEDURE XLoadQueryFont* ( display: DisplayPtr; @@ -1987,7 +1995,7 @@ PROCEDURE -XCreateImage* ( height: C.int; bitmapPad: C.int; bytesPerLine: C.int): XImagePtr - "(long)XCreateImage(display, visual, depth, format, offset, data, width, height, bitmapPad, bytesPerLine)"; + "(oocX11_XImagePtr)XCreateImage((struct _XDisplay*)display, (Visual*)visual, depth, format, offset, (char*)data, width, height, bitmapPad, bytesPerLine)"; (* PROCEDURE XInitImage* ( image: XImagePtr): Status; @@ -2017,8 +2025,7 @@ PROCEDURE XGetSubImage* ( * X function declarations. *) *) -PROCEDURE -XOpenDisplay* (name: ARRAY OF C.char): DisplayPtr - "(long)XOpenDisplay(name)"; +PROCEDURE -XOpenDisplay* (name: ARRAY OF C.char): DisplayPtr "(oocX11_DisplayPtr)XOpenDisplay((char*)name)"; PROCEDURE OpenDisplay* (name: ARRAY OF C.char): DisplayPtr; BEGIN @@ -2101,7 +2108,7 @@ PROCEDURE -XCreateGC* ( d: Drawable; valueMask: ulongmask; VAR values: XGCValues): GC - "(long)XCreateGC(display, d, valueMask, values)"; + "(oocX11_GC)XCreateGC((struct _XDisplay*)display, d, valueMask, (XGCValues *)values)"; (* PROCEDURE XGContextFromGC* ( gc: GC): GContext; @@ -2140,7 +2147,7 @@ PROCEDURE -XCreateSimpleWindow* ( borderWidth: C.int; border: C.longint; background: C.longint): Window - "(long)XCreateSimpleWindow(display, parent, x, y, width, height, borderWidth, border, background)"; + "(long)XCreateSimpleWindow((struct _XDisplay*)display, parent, x, y, width, height, borderWidth, border, background)"; (* PROCEDURE XGetSelectionOwner* ( display: DisplayPtr; @@ -2240,7 +2247,7 @@ PROCEDURE XEHeadOfExtensionList* ( PROCEDURE -XRootWindow* ( display: DisplayPtr; screen: C.int): Window - "(long)XRootWindow(display, screen)"; + "(long)XRootWindow((struct _XDisplay*)display, screen)"; (* PROCEDURE XDefaultRootWindow* ( display: DisplayPtr): Window; @@ -2250,7 +2257,7 @@ PROCEDURE XRootWindowOfScreen* ( PROCEDURE -XDefaultVisual* ( display: DisplayPtr; screen: C.int): VisualPtr - "(long)XDefaultVisual(display, screen)"; + "(oocX11_VisualPtr)XDefaultVisual((struct _XDisplay*)display, screen)"; (* PROCEDURE XDefaultVisualOfScreen* ( screen: ScreenPtr): VisualPtr; @@ -2263,12 +2270,12 @@ PROCEDURE XDefaultGCOfScreen* ( PROCEDURE -XBlackPixel* ( display: DisplayPtr; screen: C.int): C.longint - "(long)XBlackPixel(display, screen)"; + "(long)XBlackPixel((struct _XDisplay*)display, screen)"; PROCEDURE -XWhitePixel* ( display: DisplayPtr; screen: C.int): C.longint - "(long)XWhitePixel(display, screen)"; + "(long)XWhitePixel((struct _XDisplay*)display, screen)"; (* PROCEDURE XAllPlanes* (): C.longint; PROCEDURE XBlackPixelOfScreen* ( @@ -2296,7 +2303,7 @@ PROCEDURE XScreenOfDisplay* ( *) PROCEDURE -XDefaultScreenOfDisplay* ( display: DisplayPtr): ScreenPtr - "(long)XDefaultScreen(display)"; + "(long)XDefaultScreen((struct _XDisplay*)display)"; (* PROCEDURE XEventMaskOfScreen* ( screen: ScreenPtr): C.longint; @@ -2523,7 +2530,7 @@ PROCEDURE XClearWindow* ( PROCEDURE -XCloseDisplay* ( display: DisplayPtr) - "XCloseDisplay(display)"; + "XCloseDisplay((struct _XDisplay*)display)"; (* @@ -2577,7 +2584,7 @@ PROCEDURE XDefaultDepthOfScreen* ( *) PROCEDURE -XDefaultScreen* ( display: DisplayPtr): C.int - "(int)XDefaultScreen(display)"; + "(int)XDefaultScreen((struct _XDisplay*)display)"; (* PROCEDURE XDefineCursor* ( display: DisplayPtr; @@ -2591,11 +2598,11 @@ PROCEDURE XDeleteProperty* ( PROCEDURE -XDestroyWindow* ( display: DisplayPtr; w: Window) - "XDestroyWindow(display, w)"; + "XDestroyWindow((struct _XDisplay*)display, w)"; PROCEDURE -XDestroyImage* (image : XImagePtr) - "XDestroyImage(image)"; + "XDestroyImage((struct _XDisplay*)image)"; (* PROCEDURE XDestroySubwindows* ( @@ -2614,7 +2621,7 @@ PROCEDURE XDisplayCells* ( PROCEDURE -XDisplayHeight* ( display: DisplayPtr; screen: C.int): C.int - "(int)XDisplayHeight(display, screen)"; + "(int)XDisplayHeight((struct _XDisplay*)display, screen)"; (* PROCEDURE XDisplayHeightMM* ( display: DisplayPtr; @@ -2630,7 +2637,7 @@ PROCEDURE XDisplayPlanes* ( PROCEDURE -XDisplayWidth* ( display: DisplayPtr; screennumber: C.int): C.int - "(int)XDisplayWidth(display, screen)"; + "(int)XDisplayWidth((struct _XDisplay*)display, screen)"; (* PROCEDURE XDisplayWidthMM* ( display: DisplayPtr; @@ -2690,7 +2697,7 @@ PROCEDURE -XDrawPoint* ( gc: GC; x: C.int; y: C.int) - "XDrawPoint(display, d, gc, x, y)"; + "XDrawPoint((struct _XDisplay*)display, d, (struct _XGC*)gc, x, y)"; (* PROCEDURE XDrawPoints* ( display: DisplayPtr; @@ -2758,7 +2765,7 @@ PROCEDURE XEnableAccessControl* ( PROCEDURE -XEventsQueued* ( display: DisplayPtr; mode: C.int): C.int - "(int)XEventsQueued(display, mode)"; + "(int)XEventsQueued((struct _XDisplay*)display, mode)"; (* PROCEDURE XFetchName* ( display: DisplayPtr; @@ -2797,7 +2804,7 @@ PROCEDURE -XFillRectangle* ( y: C.int; width: C.int; height: C.int) - "XFillRectangle(display, d, gc, x, y, width, height)"; + "XFillRectangle((struct _XDisplay*)display, d, (struct _XGC*)gc, x, y, width, height)"; (* PROCEDURE XFillRectangles* ( display: DisplayPtr; @@ -2808,7 +2815,7 @@ PROCEDURE XFillRectangles* ( *) PROCEDURE -XFlush* ( display: DisplayPtr) - "XFlush(display)"; + "XFlush((struct _XDisplay*)display)"; (* PROCEDURE XForceScreenSaver* ( display: DisplayPtr; @@ -3016,13 +3023,13 @@ PROCEDURE XMapSubwindows* ( PROCEDURE -XMapWindow* ( display: DisplayPtr; w: Window) - "XMapWindow(display, w)"; + "XMapWindow((struct _XDisplay*)display, w)"; PROCEDURE -XMaskEvent* ( display: DisplayPtr; mask: ulongmask; VAR event: XEvent) - "XMaskEvent(display, mask, event)"; + "XMaskEvent((struct _XDisplay*)display, mask, (union _XEvent*)event)"; (* PROCEDURE XMaxCmapsOfScreen* ( @@ -3045,7 +3052,7 @@ PROCEDURE XMoveWindow* ( PROCEDURE -XNextEvent* ( display: DisplayPtr; VAR event: XEvent) - "XNextEvent(display, event)"; + "XNextEvent((struct _XDisplay*)display, (union _XEvent*)event)"; (* PROCEDURE XNoOp* ( display: DisplayPtr); @@ -3091,7 +3098,7 @@ PROCEDURE -XPutImage* ( dstY: C.int; width: C.int; height: C.int) - "XPutImage(display, d, gc, image, srcX, srcY, dstX, dstY, width, height)"; + "XPutImage((struct _XDisplay*)display, d, (struct _XGC*)gc, (struct _XImage*)image, srcX, srcY, dstX, dstY, width, height)"; (* PROCEDURE XQLength* ( display: DisplayPtr): C.int; @@ -3254,7 +3261,7 @@ PROCEDURE -XSelectInput* ( display: DisplayPtr; window: Window; eventMask: ulongmask) - "XSelectInput(display, window, eventMask)"; + "XSelectInput((struct _XDisplay*)display, window, (long)eventMask)"; (* PROCEDURE XSendEvent* ( display: DisplayPtr; @@ -3441,7 +3448,7 @@ PROCEDURE -XStoreName* ( display: DisplayPtr; window: Window; name: ARRAY OF C.char) - "XStoreName(display, window, name)"; + "XStoreName((struct _XDisplay*)display, window, (char*)name)"; (* PROCEDURE XStoreNamedColor* ( display: DisplayPtr; diff --git a/src/library/oocX11/oocXYplane.Mod b/src/library/oocX11/oocXYplane.Mod index d0a68210..4da2383f 100644 --- a/src/library/oocX11/oocXYplane.Mod +++ b/src/library/oocX11/oocXYplane.Mod @@ -32,8 +32,14 @@ VAR initialized: BOOLEAN; (* first call to Open sets this to TRUE *) image: X11.XImagePtr; map: POINTER TO ARRAY OF ARRAY OF SET; + +PROCEDURE -aincludexlib "#include "; +PROCEDURE -aincludexutil "#include "; +PROCEDURE -aincludexresource "#include "; + + PROCEDURE Error (msg: ARRAY OF CHAR); BEGIN Out.String ("Error: "); @@ -70,6 +76,7 @@ PROCEDURE Dot* (x, y, mode: INTEGER); X11.XDrawPoint (display, window, fg, x, H-1-y) | erase: X11.XDrawPoint (display, window, bg, x, H-1-y) + ELSE END; X11.XFlush (display); END @@ -135,44 +142,43 @@ PROCEDURE Key* (): CHAR; PROCEDURE Open*; (* Initializes the drawing plane. *) VAR - screen: C.int; - parent: X11.Window; - bgColor, fgColor: C.longint; + screen: C.int; + parent: X11.Window; + bgColor: C.longint; + fgColor: C.longint; gcValue: X11.XGCValues; - event: X11.XEvent; - x, y: INTEGER; - tmpstr : string; - (*tmpint : INTEGER;*) - scrn : C.int; - vis : X11.VisualPtr; + event: X11.XEvent; + x, y: INTEGER; + tmpstr: string; + 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.XOpenDisplay(tmpstr); (*display := X11.OpenDisplay (NIL);*) IF (display = NIL) THEN - Error ("Couldn't open display") + Error("Couldn't open display") ELSE - screen := X11.XDefaultScreen (display); + screen := X11.XDefaultScreen(display); X := 0; Y := 0; W := SHORT (X11.XDisplayWidth (display, screen)); - H := SHORT (X11.XDisplayHeight (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, + 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.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*);*) @@ -184,16 +190,16 @@ PROCEDURE Open*; END END; - scrn := X11.XDefaultScreen (display); - vis := X11.XDefaultVisual (display, scrn); - image := X11.XCreateImage (display, + 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); + 1, X11.ZPixmap, 0, SYSTEM.VAL(C.address,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); + X11.XMaskEvent(display, X11.ExposureMask, event); (* create graphic context to draw resp. erase a point *) gcValue. foreground := fgColor; @@ -208,7 +214,7 @@ PROCEDURE Open*; END END Open; - PROCEDURE Close*; +PROCEDURE Close*; BEGIN (* X11.XDestroyImage(image); diff --git a/src/library/oocX11/oocXutil.Mod b/src/library/oocX11/oocXutil.Mod index cee7a253..b047cffc 100644 --- a/src/library/oocX11/oocXutil.Mod +++ b/src/library/oocX11/oocXutil.Mod @@ -359,7 +359,7 @@ PROCEDURE -XLookupString* ( VAR keysymReturn: X.KeySym; (*VAR statusInOut(*[NILCOMPAT]*): XComposeStatus): C.int*) VAR statusInOut(*[NILCOMPAT]*): C.longint): C.int - "(int)XLookupString(eventStruct, bufferReturn, bytesBuffer, keysymReturn, statusInOut)"; + "(int)XLookupString((XKeyEvent*)eventStruct, bufferReturn, bytesBuffer, (KeySym*)keysymReturn, (XComposeStatus*)statusInOut)"; (* PROCEDURE XMatchVisualInfo* ( display: X.DisplayPtr; diff --git a/src/library/pow/powStrings.Mod b/src/library/pow/powStrings.Mod index 5d93fbf3..d3d6d4f8 100644 --- a/src/library/pow/powStrings.Mod +++ b/src/library/pow/powStrings.Mod @@ -1,639 +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 in the string . - If does not occur in zero is returned. If 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. - If pattern does not occur in 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 is copied to the string . The former contents - of are overwritten and therefore lost. - - The copied section in starts at the position and is characters long. - - If is not large enough to hold the copied string then only the - part that fits into 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 is appended to the string . *) -VAR - i,j,lSrc,lDest:LONGINT; -BEGIN - i:=Length(dest); - j:=0; - lDest:=LEN(dest)-1; - lSrc:=LEN(src); - WHILE (i is appended to the string . *) -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 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 characters of the string 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 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 are removed. *) -VAR - i,ml:LONGINT; -BEGIN - i:=0; - ml:=LEN(t)-1; - WHILE (i0 THEN Delete(t,1,i) END; -END RemoveLeadingSpaces; - -PROCEDURE Val*(t:StringT):LONGINT; -(** The string is converted to a number and returned as result of the function. - - If the character sequence in 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 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="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="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 (inx9) OR (res<-threshDec) OR ((res=-threshDec) & (v>8)) THEN - exit:=TRUE - ELSE - res:=res*10-v; - INC(inx); - END; - END; - ELSE - WHILE (inx9) 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 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="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 (res0)) THEN - exit:=TRUE - ELSE - res:=res*16-v; - INC(inx); - END; - END; - ELSE - WHILE (inx="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 (inx9) OR (res<-threshDec) OR ((res=-threshDec) & (v>8)) THEN - exit:=TRUE - ELSE - res:=res*10-v; - INC(inx); - END; - END; - ELSE - WHILE (inx9) 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 is converted to a string and the result is stored in . - If is not large enough to hold all characters of the number, - 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)) 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 is converted to a string of hexadecimal format and the result is stored - in . At the end of the string an "h" is appended to indicate the hexadecimal - representation of the number. - - If is not large enough to hold all characters of the number, 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)) 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 is inserted into the string at the position if - provides space for it. *) -VAR - i,l:LONGINT; -BEGIN - l:=Length(t); - IF l+1l+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 is inserted into the string at the position . - If the maximum length of is insufficient to store the result only - the part of fitting in 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 is increased to characters by appending blanks. If has - already the appropriate length or is longer 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 is increased to characters by inserting blanks at the - beginning. If has already the appropriate length or is longer 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 in the string . + If does not occur in zero is returned. If 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. + If pattern does not occur in 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 is copied to the string . The former contents + of are overwritten and therefore lost. + + The copied section in starts at the position and is characters long. + + If is not large enough to hold the copied string then only the + part that fits into 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 is appended to the string . *) +VAR + i,j,lSrc,lDest:LONGINT; +BEGIN + i:=Length(dest); + j:=0; + lDest:=LEN(dest)-1; + lSrc:=LEN(src); + WHILE (i is appended to the string . *) +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 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 characters of the string 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 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 are removed. *) +VAR + i,ml:LONGINT; +BEGIN + i:=0; + ml:=LEN(t)-1; + WHILE (i0 THEN Delete(t,1,i) END; +END RemoveLeadingSpaces; + +PROCEDURE Val*(t:StringT):LONGINT; +(** The string is converted to a number and returned as result of the function. + + If the character sequence in 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 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="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="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 (inx9) OR (res<-threshDec) OR ((res=-threshDec) & (v>8)) THEN + exit:=TRUE + ELSE + res:=res*10-v; + INC(inx); + END; + END; + ELSE + WHILE (inx9) 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 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="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 (res0)) THEN + exit:=TRUE + ELSE + res:=res*16-v; + INC(inx); + END; + END; + ELSE + WHILE (inx="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 (inx9) OR (res<-threshDec) OR ((res=-threshDec) & (v>8)) THEN + exit:=TRUE + ELSE + res:=res*10-v; + INC(inx); + END; + END; + ELSE + WHILE (inx9) 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 is converted to a string and the result is stored in . + If is not large enough to hold all characters of the number, + 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)) 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 is converted to a string of hexadecimal format and the result is stored + in . At the end of the string an "h" is appended to indicate the hexadecimal + representation of the number. + + If is not large enough to hold all characters of the number, 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)) 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 is inserted into the string at the position if + provides space for it. *) +VAR + i,l:LONGINT; +BEGIN + l:=Length(t); + IF l+1l+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 is inserted into the string at the position . + If the maximum length of is insufficient to store the result only + the part of fitting in 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 is increased to characters by appending blanks. If has + already the appropriate length or is longer 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 is increased to characters by inserting blanks at the + beginning. If has already the appropriate length or is longer 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 s.block.nlit + s.block.ndist THEN SetMsg(s.res, "invalid bit length repeat"); @@ -1125,6 +1127,7 @@ MODULE ethZlibInflate; (** eos **) | InfBad: (* error in stream *) stream.res.code := DataError; EXIT + ELSE END END END diff --git a/src/library/ulm/ulmConstStrings.Mod b/src/library/ulm/ulmConstStrings.Mod index 3b4de5ba..ae62e3b7 100644 --- a/src/library/ulm/ulmConstStrings.Mod +++ b/src/library/ulm/ulmConstStrings.Mod @@ -520,6 +520,7 @@ MODULE ulmConstStrings; | Streams.fromStart: realpos := cnt; | Streams.fromPos: realpos := s.pos + cnt; | Streams.fromEnd: realpos := s.string.length + cnt; + ELSE END; IF (realpos < 0) OR (realpos > s.string.length) THEN RETURN FALSE diff --git a/src/library/ulm/ulmEvents.Mod b/src/library/ulm/ulmEvents.Mod index 605dced8..6016f8b0 100644 --- a/src/library/ulm/ulmEvents.Mod +++ b/src/library/ulm/ulmEvents.Mod @@ -375,6 +375,7 @@ MODULE ulmEvents; ptr := ptr.next; END; psys.currentPriority := oldPriority; + ELSE (* Explicitly ignore unhandled even type reactions *) END; END CallHandlers; diff --git a/src/library/ulm/ulmPersistentObjects.Mod b/src/library/ulm/ulmPersistentObjects.Mod index 5e23487a..3f82e089 100644 --- a/src/library/ulm/ulmPersistentObjects.Mod +++ b/src/library/ulm/ulmPersistentObjects.Mod @@ -647,6 +647,7 @@ MODULE ulmPersistentObjects; ELSE form := incrF; END; + ELSE END; IF mode DIV 4 MOD 2 > 0 THEN INC(form, sizeF); diff --git a/src/library/ulm/ulmPrint.Mod b/src/library/ulm/ulmPrint.Mod index 35f46457..756a3813 100644 --- a/src/library/ulm/ulmPrint.Mod +++ b/src/library/ulm/ulmPrint.Mod @@ -57,13 +57,13 @@ MODULE ulmPrint; ErrorCode* = SHORTINT; ErrorEvent* = POINTER TO ErrorEventRec; ErrorEventRec* = - RECORD - (Events.EventRec) - errorcode*: ErrorCode; - format*: FormatString; - errpos*: LONGINT; - nargs*: INTEGER; - END; + RECORD + (Events.EventRec) + errorcode*: ErrorCode; + format*: FormatString; + errpos*: LONGINT; + nargs*: INTEGER; + END; VAR error*: Events.EventType; errormsg*: ARRAY errors OF Events.Message; @@ -77,679 +77,683 @@ MODULE ulmPrint; 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"; + "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); + 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 = "\"; + 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; + arglen: ARRAY maxargs OF LONGINT; + nextarg: INTEGER; + fmtindex: LONGINT; + fmtchar: CHAR; + hexcharval: LONGINT; PROCEDURE Error(errorcode: ErrorCode); - VAR - event: ErrorEvent; + 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); + 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; + 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; + 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; + IF Streams.WriteByte(out, byte) THEN + INC(out.count); + END; END Write; PROCEDURE WriteLn; - VAR - lineterm: StreamDisciplines.LineTerminator; - i: INTEGER; + 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; + 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; + 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 + 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; + 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; + 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); + ELSE + 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; + 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] + ELSE + END; END Access; PROCEDURE Convert(from: INTEGER; VAR to: ARRAY OF SYS.BYTE); - VAR i: INTEGER; + VAR i: INTEGER; BEGIN - i := 0; - WHILE i < arglen[from] DO - to[i] := Access(from, i); INC(i); - END; + 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; - + (* 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 + 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; + 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 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 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 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 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 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 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 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 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 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 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; + 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; + 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 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 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; + 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; + 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 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 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; + 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)); + 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; + 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; + 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); + ELSE + 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; + ELSE + 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; + 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 (* 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() + 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; + 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); + Error(tooManyArgs); ELSIF nextarg > nargs THEN - Error(tooFewArgs); + Error(tooFewArgs); END; END Out; @@ -804,14 +808,14 @@ MODULE ulmPrint; END F7; PROCEDURE F8*(fmt: ARRAY OF CHAR; - p1, p2, p3, p4, p5, p6, p7, p8: ARRAY OF SYS.BYTE); + 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); + 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; @@ -842,49 +846,49 @@ MODULE ulmPrint; END S3; PROCEDURE S4*(out: Streams.Stream; fmt: ARRAY OF CHAR; - p1, p2, p3, p4: ARRAY OF SYS.BYTE); + 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); + 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); + 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); + 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); + 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); + 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); + errors: RelatedEvents.Object); VAR x: INTEGER; BEGIN Out(out, fmt, 0, x,x,x,x,x,x,x,x,x, NIL); @@ -905,7 +909,7 @@ MODULE ulmPrint; END SE2; PROCEDURE SE3*(out: Streams.Stream; fmt: ARRAY OF CHAR; - p1, p2, p3: ARRAY OF SYS.BYTE; + p1, p2, p3: ARRAY OF SYS.BYTE; errors: RelatedEvents.Object); VAR x: INTEGER; BEGIN @@ -913,7 +917,7 @@ MODULE ulmPrint; END SE3; PROCEDURE SE4*(out: Streams.Stream; fmt: ARRAY OF CHAR; - p1, p2, p3, p4: ARRAY OF SYS.BYTE; + p1, p2, p3, p4: ARRAY OF SYS.BYTE; errors: RelatedEvents.Object); VAR x: INTEGER; BEGIN @@ -921,7 +925,7 @@ MODULE ulmPrint; END SE4; PROCEDURE SE5*(out: Streams.Stream; fmt: ARRAY OF CHAR; - p1, p2, p3, p4, p5: ARRAY OF SYS.BYTE; + p1, p2, p3, p4, p5: ARRAY OF SYS.BYTE; errors: RelatedEvents.Object); VAR x: INTEGER; BEGIN @@ -929,7 +933,7 @@ MODULE ulmPrint; END SE5; PROCEDURE SE6*(out: Streams.Stream; fmt: ARRAY OF CHAR; - p1, p2, p3, p4, p5, p6: ARRAY OF SYS.BYTE; + p1, p2, p3, p4, p5, p6: ARRAY OF SYS.BYTE; errors: RelatedEvents.Object); VAR x: INTEGER; BEGIN @@ -937,7 +941,7 @@ MODULE ulmPrint; END SE6; PROCEDURE SE7*(out: Streams.Stream; fmt: ARRAY OF CHAR; - p1, p2, p3, p4, p5, p6, p7: ARRAY OF SYS.BYTE; + p1, p2, p3, p4, p5, p6, p7: ARRAY OF SYS.BYTE; errors: RelatedEvents.Object); VAR x: INTEGER; BEGIN @@ -945,7 +949,7 @@ MODULE ulmPrint; END SE7; PROCEDURE SE8*(out: Streams.Stream; fmt: ARRAY OF CHAR; - p1, p2, p3, p4, p5, p6, p7, p8: ARRAY OF SYS.BYTE; + p1, p2, p3, p4, p5, p6, p7, p8: ARRAY OF SYS.BYTE; errors: RelatedEvents.Object); VAR x: INTEGER; BEGIN @@ -953,7 +957,7 @@ MODULE ulmPrint; END SE8; PROCEDURE SE9*(out: Streams.Stream; fmt: ARRAY OF CHAR; - p1, p2, p3, p4, p5, p6, p7, p8, p9: ARRAY OF SYS.BYTE; + 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); diff --git a/src/library/ulm/ulmResources.Mod b/src/library/ulm/ulmResources.Mod index 08b9ae20..9ff929bd 100644 --- a/src/library/ulm/ulmResources.Mod +++ b/src/library/ulm/ulmResources.Mod @@ -64,43 +64,43 @@ MODULE ulmResources; TYPE StateChange* = SHORTINT; (* terminated..communicationResumed *) State = SHORTINT; (* alive, unreferenced, or alive *) - (* whether objects are stopped or not is maintained separately *) + (* whether objects are stopped or not is maintained separately *) Event* = POINTER TO EventRec; (* notification of state changes *) EventRec* = - RECORD - (Events.EventRec) - change*: StateChange; (* new state *) - resource*: Resource; - END; + RECORD + (Events.EventRec) + change*: StateChange; (* new state *) + resource*: Resource; + END; TYPE Key* = POINTER TO KeyRec; KeyRec* = - RECORD - (Objects.ObjectRec) - valid: BOOLEAN; - resource: Resource; - END; + RECORD + (Objects.ObjectRec) + valid: BOOLEAN; + resource: Resource; + END; TYPE List = POINTER TO ListRec; ListRec = - RECORD - resource: Resource; - next: List; - END; + RECORD + resource: Resource; + next: List; + END; Discipline = POINTER TO DisciplineRec; DisciplineRec = - RECORD - (Disciplines.DisciplineRec) - state: State; (* alive, unreferenced, or terminated *) - stopped: BOOLEAN; (* may be TRUE, if alive or unreferenced *) - refcnt: LONGINT; (* # of Attach - # of Detach *) - eventType: Events.EventType; (* may be NIL *) - dependants: List; (* list of resources which depends on us *) - dependsOn: Resource; (* we depend on this resource *) - key: Key; (* attach key for dependsOn *) - END; + RECORD + (Disciplines.DisciplineRec) + state: State; (* alive, unreferenced, or terminated *) + stopped: BOOLEAN; (* may be TRUE, if alive or unreferenced *) + refcnt: LONGINT; (* # of Attach - # of Detach *) + eventType: Events.EventType; (* may be NIL *) + dependants: List; (* list of resources which depends on us *) + dependsOn: Resource; (* we depend on this resource *) + key: Key; (* attach key for dependsOn *) + END; VAR discID: Disciplines.Identifier; @@ -120,27 +120,27 @@ MODULE ulmResources; noch *) IF ~Disciplines.Seek(resource, discID, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *) - NEW(disc); disc.id := discID; - disc.state := alive; disc.refcnt := 0; - disc.eventType := NIL; - disc.dependants := NIL; disc.dependsOn := NIL; - Disciplines.Add(resource, disc); + NEW(disc); disc.id := discID; + disc.state := alive; disc.refcnt := 0; + disc.eventType := NIL; + disc.dependants := NIL; disc.dependsOn := NIL; + Disciplines.Add(resource, disc); END; END GetDisc; PROCEDURE GenEvent(resource: Resource; change: StateChange); VAR - disc: Discipline; - event: Event; + disc: Discipline; + event: Event; BEGIN GetDisc(resource, disc); IF disc.eventType # NIL THEN - NEW(event); - event.type := disc.eventType; - event.message := "Resources: state change notification"; - event.change := change; - event.resource := resource; - Events.Raise(event); + NEW(event); + event.type := disc.eventType; + event.message := "Resources: state change notification"; + event.change := change; + event.resource := resource; + Events.Raise(event); END; END GenEvent; @@ -149,24 +149,24 @@ MODULE ulmResources; PROCEDURE Unlink(dependant, resource: Resource); (* undo DependsOn operation *) VAR - dependantDisc, resourceDisc: Discipline; - prev, member: List; + dependantDisc, resourceDisc: Discipline; + prev, member: List; BEGIN GetDisc(resource, resourceDisc); IF resourceDisc.state = terminated THEN - (* no necessity for clean up *) - RETURN + (* no necessity for clean up *) + RETURN END; GetDisc(dependant, dependantDisc); prev := NIL; member := resourceDisc.dependants; WHILE member.resource # dependant DO - prev := member; member := member.next; + prev := member; member := member.next; END; IF prev = NIL THEN - resourceDisc.dependants := member.next; + resourceDisc.dependants := member.next; ELSE - prev.next := member.next; + prev.next := member.next; END; (* Detach reference from dependant to resource *) @@ -176,28 +176,29 @@ MODULE ulmResources; PROCEDURE InternalNotify(resource: Resource; change: StateChange); VAR - disc: Discipline; - event: Event; - dependant: List; + disc: Discipline; + event: Event; + dependant: List; BEGIN GetDisc(resource, disc); CASE change OF | communicationResumed: disc.stopped := FALSE; | communicationStopped: disc.stopped := TRUE; | terminated: disc.stopped := FALSE; disc.state := terminated; + ELSE (* Explicitly ignore unhandled values of change *) END; GenEvent(resource, change); (* notify all dependants *) dependant := disc.dependants; WHILE dependant # NIL DO - InternalNotify(dependant.resource, change); - dependant := dependant.next; + InternalNotify(dependant.resource, change); + dependant := dependant.next; END; (* remove dependency relation in case of termination, if present *) IF (change = terminated) & (disc.dependsOn # NIL) THEN - Unlink(resource, disc.dependsOn); + Unlink(resource, disc.dependsOn); END; END InternalNotify; @@ -205,16 +206,16 @@ MODULE ulmResources; PROCEDURE TakeInterest*(resource: Resource; VAR eventType: Events.EventType); (* return resource specific event type for state notifications; - eventType is guaranteed to be # NIL even if - the given resource is already terminated + eventType is guaranteed to be # NIL even if + the given resource is already terminated *) VAR - disc: Discipline; + disc: Discipline; BEGIN GetDisc(resource, disc); IF disc.eventType = NIL THEN - Events.Define(disc.eventType); - Events.Ignore(disc.eventType); + Events.Define(disc.eventType); + Events.Ignore(disc.eventType); END; eventType := disc.eventType; END TakeInterest; @@ -222,93 +223,93 @@ MODULE ulmResources; PROCEDURE Attach*(resource: Resource; VAR key: Key); (* mark the resource as being used until Detach gets called *) VAR - disc: Discipline; + disc: Discipline; BEGIN GetDisc(resource, disc); IF disc.state IN {terminated, unreferenced} THEN - key := NIL; + key := NIL; ELSE - INC(disc.refcnt); NEW(key); key.valid := TRUE; - key.resource := resource; + INC(disc.refcnt); NEW(key); key.valid := TRUE; + key.resource := resource; END; END Attach; PROCEDURE Detach*(resource: Resource; key: Key); (* mark the resource as unused; the returned key of Attach must - be given -- this allows to check for proper balances - of Attach/Detach calls; - the last Detach operation causes a state change to unreferenced + be given -- this allows to check for proper balances + of Attach/Detach calls; + the last Detach operation causes a state change to unreferenced *) VAR - disc: Discipline; + disc: Discipline; BEGIN IF (key # NIL) & key.valid & (key.resource = resource) THEN - GetDisc(resource, disc); - IF disc.state # terminated THEN - key.valid := FALSE; DEC(disc.refcnt); - IF disc.refcnt = 0 THEN - GenEvent(resource, unreferenced); - disc.state := unreferenced; - IF disc.dependsOn # NIL THEN - Unlink(resource, disc.dependsOn); - END; - END; - END; + GetDisc(resource, disc); + IF disc.state # terminated THEN + key.valid := FALSE; DEC(disc.refcnt); + IF disc.refcnt = 0 THEN + GenEvent(resource, unreferenced); + disc.state := unreferenced; + IF disc.dependsOn # NIL THEN + Unlink(resource, disc.dependsOn); + END; + END; + END; END; END Detach; PROCEDURE Notify*(resource: Resource; change: StateChange); (* notify all interested parties about the new state; - only valid state changes are accepted: - - Notify doesn't accept any changes after termination - - unreferenced is generated conditionally by Detach only - - communicationResumed is valid after communicationStopped only - valid notifications are propagated to all dependants (see below); + only valid state changes are accepted: + - Notify doesn't accept any changes after termination + - unreferenced is generated conditionally by Detach only + - communicationResumed is valid after communicationStopped only + valid notifications are propagated to all dependants (see below); *) VAR - disc: Discipline; - event: Event; - dependant: List; + disc: Discipline; + event: Event; + dependant: List; BEGIN IF change # unreferenced THEN - GetDisc(resource, disc); - IF (disc.state # terminated) & (disc.state # change) & - ((change # communicationResumed) OR disc.stopped) THEN - InternalNotify(resource, change); - END; + GetDisc(resource, disc); + IF (disc.state # terminated) & (disc.state # change) & + ((change # communicationResumed) OR disc.stopped) THEN + InternalNotify(resource, change); + END; END; END Notify; PROCEDURE DependsOn*(dependant, resource: Resource); (* states that `dependant' depends entirely on `resource' -- - this is usually the case if operations on `dependant' - are delegated to `resource'; - only one call of DependsOn may be given per `dependant' while - several DependsOn for one resource are valid; - DependsOn calls implicitly Attach for resource and - detaches if the dependant becomes unreferenced; - all other state changes propagate from `resource' to - `dependant' + this is usually the case if operations on `dependant' + are delegated to `resource'; + only one call of DependsOn may be given per `dependant' while + several DependsOn for one resource are valid; + DependsOn calls implicitly Attach for resource and + detaches if the dependant becomes unreferenced; + all other state changes propagate from `resource' to + `dependant' *) VAR - dependantDisc, resourceDisc: Discipline; - member: List; + dependantDisc, resourceDisc: Discipline; + member: List; BEGIN GetDisc(resource, resourceDisc); IF resourceDisc.state <= unreferenced THEN - (* do not create a relationship to dead or unreferenced objects - but propagate a termination immediately to dependant - *) - IF resourceDisc.state = terminated THEN - Notify(dependant, resourceDisc.state); - END; - RETURN + (* do not create a relationship to dead or unreferenced objects + but propagate a termination immediately to dependant + *) + IF resourceDisc.state = terminated THEN + Notify(dependant, resourceDisc.state); + END; + RETURN END; GetDisc(dependant, dependantDisc); IF dependantDisc.dependsOn # NIL THEN - (* don't accept changes *) - RETURN + (* don't accept changes *) + RETURN END; dependantDisc.dependsOn := resource; @@ -320,10 +321,10 @@ MODULE ulmResources; PROCEDURE Alive*(resource: Resource) : BOOLEAN; (* returns TRUE if the resource is not yet terminated - and ready for communication (i.e. not communicationStopped) + and ready for communication (i.e. not communicationStopped) *) VAR - disc: Discipline; + disc: Discipline; BEGIN GetDisc(resource, disc); RETURN ~disc.stopped & (disc.state IN {alive, unreferenced}) @@ -331,10 +332,10 @@ MODULE ulmResources; PROCEDURE Stopped*(resource: Resource) : BOOLEAN; (* returns TRUE if the object is currently not responsive - and not yet terminated + and not yet terminated *) VAR - disc: Discipline; + disc: Discipline; BEGIN GetDisc(resource, disc); RETURN disc.stopped @@ -343,7 +344,7 @@ MODULE ulmResources; PROCEDURE Terminated*(resource: Resource) : BOOLEAN; (* returns TRUE if the resource is terminated *) VAR - disc: Discipline; + disc: Discipline; BEGIN GetDisc(resource, disc); RETURN disc.state = terminated diff --git a/src/library/ulm/ulmSYSTEM.Mod b/src/library/ulm/ulmSYSTEM.Mod index fa6c66a6..838548f0 100644 --- a/src/library/ulm/ulmSYSTEM.Mod +++ b/src/library/ulm/ulmSYSTEM.Mod @@ -1,9 +1,9 @@ MODULE ulmSYSTEM; -IMPORT SYSTEM, Unix, Sys := ulmSys; +IMPORT SYSTEM, Platform, Sys := ulmSys; TYPE pchar = POINTER TO ARRAY 1 OF CHAR; pstring = POINTER TO ARRAY 1024 OF CHAR; - pstatus = POINTER TO Unix.Status; + (* pstatus = POINTER TO Platform.Status; *) TYPE bytearray* = ARRAY SIZE(LONGINT) OF SYSTEM.BYTE; (* need this because voc does not convert implicitly LONGINT to ARRAY OF BYTE; -- noch *) pbytearray* = POINTER TO bytearray; @@ -52,16 +52,16 @@ TYPE pchar = POINTER TO ARRAY 1 OF CHAR; PROCEDURE UNIXCALL*(syscall: LONGINT; VAR d0, d1: LONGINT; (* in ulm version both LONGINT and INTEGER are 4 byte size *) arg1, arg2, arg3: LONGINT) : BOOLEAN; VAR - n : LONGINT; - ch : CHAR; - pch : pchar; - pstr : pstring; - pst : pstatus; + n: LONGINT; + ch: CHAR; + pch: pchar; + pstr: pstring; + h: Platform.FileHandle; + (* pst : pstatus; *) BEGIN IF syscall = Sys.read THEN - d0 := Unix.Read(SHORT(arg1), arg2, arg3); - IF d0 >= 0 THEN RETURN TRUE ELSE RETURN FALSE END + RETURN Platform.Read(arg1, arg2, arg3, n) = 0; (*NEW(pch); pch := SYSTEM.VAL(pchar, arg2); ch := pch^[0]; @@ -75,44 +75,48 @@ TYPE pchar = POINTER TO ARRAY 1 OF CHAR; END; *) ELSIF syscall = Sys.write THEN - d0 := Unix.Write(SHORT(arg1), arg2, arg3); - IF d0 >= 0 THEN RETURN TRUE ELSE RETURN FALSE END + RETURN Platform.Write(arg1, arg2, arg3) = 0; (*NEW(pch); pch := SYSTEM.VAL(pchar, arg2); n := Write(SYSTEM.VAL(LONGINT, pch), 1); IF n # 1 THEN RETURN FALSE ELSE RETURN TRUE END *) ELSIF syscall = Sys.open THEN - pstr := SYSTEM.VAL(pstring, arg1); - d0 := Unix.Open(pstr^, SHORT(arg3), arg2); - IF d0 >= 0 THEN RETURN TRUE ELSE RETURN FALSE END + pstr := SYSTEM.VAL(pstring, arg1); + IF SYSTEM.VAL(SET, arg3) * {0,1} # {} THEN + RETURN Platform.OldRW(pstr^, d0) = 0 + ELSE + RETURN Platform.OldRO(pstr^, d0) = 0 + END ELSIF syscall = Sys.close THEN - d0 := Unix.Close(SHORT(arg1)); - IF d0 = 0 THEN RETURN TRUE ELSE RETURN FALSE END + RETURN Platform.Close(arg1) = 0 ELSIF syscall = Sys.lseek THEN - d0 := Unix.Lseek(SHORT(arg1), arg2, SHORT(arg3)); - IF d0 >= 0 THEN RETURN TRUE ELSE RETURN FALSE END + RETURN Platform.Seek(arg1, arg2, SYSTEM.VAL(INTEGER, arg3)) = 0 + (* ELSIF syscall = Sys.ioctl THEN - d0 := Unix.Ioctl(SHORT(arg1), SHORT(arg2), arg3); + d0 := Platform.Ioctl(arg1, arg2, arg3); RETURN d0 >= 0; ELSIF syscall = Sys.fcntl THEN - d0 := Unix.Fcntl (SHORT(arg1), SHORT(arg2), arg3); + d0 := Platform.Fcntl (arg1, arg2, arg3); RETURN d0 >= 0; ELSIF syscall = Sys.dup THEN - d0 := Unix.Dup(SHORT(arg1)); + d0 := Platform.Dup(arg1); RETURN d0 > 0; ELSIF syscall = Sys.pipe THEN - d0 := Unix.Pipe(arg1); + d0 := Platform.Pipe(arg1); RETURN d0 >= 0; ELSIF syscall = Sys.newstat THEN pst := SYSTEM.VAL(pstatus, arg2); pstr := SYSTEM.VAL(pstring, arg1); - d0 := Unix.Stat(pstr^, pst^); + d0 := Platform.Stat(pstr^, pst^); RETURN d0 >= 0 ELSIF syscall = Sys.newfstat THEN pst := SYSTEM.VAL(pstatus, arg2); - d0 := Unix.Fstat(SHORT(arg1), pst^); + d0 := Platform.Fstat(arg1, pst^); RETURN d0 >= 0; + *) + ELSE + HALT(99); END END UNIXCALL; diff --git a/src/library/ulm/ulmScales.Mod b/src/library/ulm/ulmScales.Mod index 8b60d48a..5de1188b 100644 --- a/src/library/ulm/ulmScales.Mod +++ b/src/library/ulm/ulmScales.Mod @@ -403,6 +403,7 @@ MODULE ulmScales; (* abs - abs or rel - rel *) restype := relative; END; + ELSE END; ASSERT(ok); (* invalid operation *) END; END; diff --git a/src/library/ulm/ulmStreamConditions.Mod b/src/library/ulm/ulmStreamConditions.Mod index 794b3cb1..9e7f5712 100644 --- a/src/library/ulm/ulmStreamConditions.Mod +++ b/src/library/ulm/ulmStreamConditions.Mod @@ -115,6 +115,7 @@ MODULE ulmStreamConditions; | write: IF Streams.OutputWillBeBuffered(condition.stream) THEN RETURN TRUE END; + ELSE END; msg.operation := condition.operation; msg.errors := errors; diff --git a/src/library/ulm/ulmStreams.Mod b/src/library/ulm/ulmStreams.Mod index 8e54ed95..149b1220 100644 --- a/src/library/ulm/ulmStreams.Mod +++ b/src/library/ulm/ulmStreams.Mod @@ -632,6 +632,7 @@ MODULE ulmStreams; | linebuf: nbuf := 1; | onebuf: nbuf := 1; | bufpool: nbuf := s.bufpool.maxbuf; + ELSE (* Explicitly ignore unhandled values of s.bufmode *) END; END GetBufferPoolSize; diff --git a/src/library/ulm/ulmSysConversions.Mod b/src/library/ulm/ulmSysConversions.Mod index e1047a58..4da16095 100644 --- a/src/library/ulm/ulmSysConversions.Mod +++ b/src/library/ulm/ulmSysConversions.Mod @@ -336,17 +336,17 @@ MODULE ulmSysConversions; (* C type *) CASE type2 OF - | "a": size2 := 8; INCL(flags, unsigned); (* char* *) - | "c": size2 := 1; (* /* signed */ char *) - | "C": size2 := 1; INCL(flags, unsigned); (* unsigned char *) - | "s": size2 := 2; (* short int *) - | "S": size2 := 2; INCL(flags, unsigned); (* unsigned short int *) - | "i": size2 := 4; (* int *) - | "I": size2 := 4; INCL(flags, unsigned); (* unsigned int *) - | "u": size2 := 4; INCL(flags, unsigned); (* unsigned int *) - | "l": size2 := 8; (* long int *) - | "L": size2 := 8; INCL(flags, unsigned); (* long int *) - | "-": size2 := 0; + | "a": size2 := SIZE(Address); INCL(flags, unsigned); (* char* *) + | "c": size2 := 1; (* /* signed */ char *) + | "C": size2 := 1; INCL(flags, unsigned); (* unsigned char *) + | "s": size2 := 2; (* short int *) + | "S": size2 := 2; INCL(flags, unsigned); (* unsigned short int *) + | "i": size2 := 4; (* int *) + | "I": size2 := 4; INCL(flags, unsigned); (* unsigned int *) + | "u": size2 := 4; INCL(flags, unsigned); (* unsigned int *) + | "l": size2 := 8; (* long int *) + | "L": size2 := 8; INCL(flags, unsigned); (* long int *) + | "-": size2 := 0; ELSE Error(cv, "bad C type specifier"); RETURN FALSE END; IF size2 > 1 THEN diff --git a/src/library/ulm/ulmSysIO.Mod b/src/library/ulm/ulmSysIO.Mod index 33959006..a961f64d 100644 --- a/src/library/ulm/ulmSysIO.Mod +++ b/src/library/ulm/ulmSysIO.Mod @@ -59,14 +59,14 @@ MODULE ulmSysIO; closeonexec* = { 0 }; (* Fcntl requests *) - dupfd* = 0; (* duplicate file descriptor *) - getfd* = 1; (* get file desc flags (close-on-exec) *) - setfd* = 2; (* set file desc flags (close-on-exec) *) - getfl* = 3; (* get file flags *) - setfl* = 4; (* set file flags (ndelay, append) *) - getlk* = 5; (* get file lock *) - setlk* = 6; (* set file lock *) - setlkw* = 7; (* set file lock and wait *) + dupfd* = 0; (* duplicate file descriptor *) + getfd* = 1; (* get file desc flags (close-on-exec) *) + setfd* = 2; (* set file desc flags (close-on-exec) *) + getfl* = 3; (* get file flags *) + setfl* = 4; (* set file flags (ndelay, append) *) + getlk* = 5; (* get file lock *) + setlk* = 6; (* set file lock *) + setlkw* = 7; (* set file lock and wait *) setown* = 8; (* set owner (async IO) *) getown* = 9; (* get owner (async IO) *) setsig* = 10; (* set SIGIO replacement *) @@ -80,263 +80,267 @@ MODULE ulmSysIO; Whence* = LONGINT; PROCEDURE OpenCreat*(VAR fd: File; - filename: ARRAY OF CHAR; options: SET; - protection: Protection; - errors: RelatedEvents.Object; - retry: BOOLEAN; VAR interrupted: BOOLEAN) : BOOLEAN; + filename: ARRAY OF CHAR; options: SET; + protection: Protection; + errors: RelatedEvents.Object; + retry: BOOLEAN; VAR interrupted: BOOLEAN) : BOOLEAN; (* the filename must be 0X-terminated *) VAR - d0, d1: (*INTEGER*)LONGINT; + d0, d1: (*INTEGER*)LONGINT; BEGIN interrupted := FALSE; LOOP - IF ulmSYSTEM.UNIXCALL(Sys.open, d0, d1, - SYS.ADR(filename), SYS.VAL(LONGINT, options), protection) THEN - fd := d0; - RETURN TRUE - ELSE - IF d0 = SysErrors.intr THEN - interrupted := TRUE; - END; - IF (d0 # SysErrors.intr) OR ~retry THEN - SysErrors.Raise(errors, d0, Sys.open, filename); - RETURN FALSE - END; - END; + IF ulmSYSTEM.UNIXCALL(Sys.open, d0, d1, + SYS.ADR(filename), SYS.VAL(LONGINT, options), protection) THEN + fd := d0; + RETURN TRUE + ELSE + IF d0 = SysErrors.intr THEN + interrupted := TRUE; + END; + IF (d0 # SysErrors.intr) OR ~retry THEN + SysErrors.Raise(errors, d0, Sys.open, filename); + RETURN FALSE + END; + END; END; END OpenCreat; PROCEDURE Open*(VAR fd: File; - filename: ARRAY OF CHAR; options: SET; - errors: RelatedEvents.Object; - retry: BOOLEAN; VAR interrupted: BOOLEAN) : BOOLEAN; + filename: ARRAY OF CHAR; options: SET; + errors: RelatedEvents.Object; + retry: BOOLEAN; VAR interrupted: BOOLEAN) : BOOLEAN; (* the filename must be 0X-terminated *) BEGIN RETURN OpenCreat(fd, filename, options, 0, errors, retry, interrupted) END Open; PROCEDURE Close*(fd: File; - errors: RelatedEvents.Object; - retry: BOOLEAN; VAR interrupted: BOOLEAN) : BOOLEAN; + errors: RelatedEvents.Object; + retry: BOOLEAN; VAR interrupted: BOOLEAN) : BOOLEAN; VAR - d0, d1: LONGINT; - a0, a1 : LONGINT; (* just to match UNIXCALL interface *) + d0, d1: LONGINT; + a0, a1 : LONGINT; (* just to match UNIXCALL interface *) BEGIN interrupted := FALSE; + a0 := 0; a1 := 0; (* Initialised to disable compiler warning. *) LOOP - IF ulmSYSTEM.UNIXCALL(Sys.close, d0, d1, fd, a0, a1) THEN - (*IF ulmSYSTEM.UNIXCALL(Sys.close, d0, d1, fd) THEN*) - RETURN TRUE - ELSE - IF d0 = SysErrors.intr THEN - interrupted := TRUE; - END; - IF (d0 # SysErrors.intr) OR ~retry THEN - SysErrors.Raise(errors, d0, Sys.close, ""); - RETURN FALSE - END; - END; + IF ulmSYSTEM.UNIXCALL(Sys.close, d0, d1, fd, a0, a1) THEN + (*IF ulmSYSTEM.UNIXCALL(Sys.close, d0, d1, fd) THEN*) + RETURN TRUE + ELSE + IF d0 = SysErrors.intr THEN + interrupted := TRUE; + END; + IF (d0 # SysErrors.intr) OR ~retry THEN + SysErrors.Raise(errors, d0, Sys.close, ""); + RETURN FALSE + END; + END; END; END Close; PROCEDURE Read*(fd: File; buf: Address; cnt: Count; - errors: RelatedEvents.Object; - retry: BOOLEAN; VAR interrupted: BOOLEAN) : Count; + errors: RelatedEvents.Object; + retry: BOOLEAN; VAR interrupted: BOOLEAN) : Count; (* return value of 0: EOF - -1: I/O error - >0: number of bytes read + -1: I/O error + >0: number of bytes read *) VAR - d0, d1: LONGINT; + d0, d1: LONGINT; BEGIN interrupted := FALSE; LOOP - IF ulmSYSTEM.UNIXCALL(Sys.read, d0, d1, fd, buf, cnt) THEN - RETURN d0 - ELSE - IF d0 = SysErrors.intr THEN - interrupted := TRUE; - END; - IF (d0 # SysErrors.intr) OR ~retry THEN - SysErrors.Raise(errors, d0, Sys.read, ""); - RETURN -1 - END; - END; + IF ulmSYSTEM.UNIXCALL(Sys.read, d0, d1, fd, buf, cnt) THEN + RETURN d0 + ELSE + IF d0 = SysErrors.intr THEN + interrupted := TRUE; + END; + IF (d0 # SysErrors.intr) OR ~retry THEN + SysErrors.Raise(errors, d0, Sys.read, ""); + RETURN -1 + END; + END; END; END Read; PROCEDURE Write*(fd: File; buf: Address; cnt: Count; - errors: RelatedEvents.Object; - retry: BOOLEAN; VAR interrupted: BOOLEAN) : Count; + errors: RelatedEvents.Object; + retry: BOOLEAN; VAR interrupted: BOOLEAN) : Count; (* return value of -1: I/O error - >=0: number of bytes written + >=0: number of bytes written *) VAR - d0, d1: LONGINT; + d0, d1: LONGINT; BEGIN interrupted := FALSE; LOOP - IF ulmSYSTEM.UNIXCALL(Sys.write, d0, d1, fd, buf, cnt) THEN - RETURN d0 - ELSE - IF d0 = SysErrors.intr THEN - interrupted := TRUE; - END; - IF (d0 # SysErrors.intr) OR ~retry THEN - SysErrors.Raise(errors, d0, Sys.write, ""); - RETURN -1 - END; - END; + IF ulmSYSTEM.UNIXCALL(Sys.write, d0, d1, fd, buf, cnt) THEN + RETURN d0 + ELSE + IF d0 = SysErrors.intr THEN + interrupted := TRUE; + END; + IF (d0 # SysErrors.intr) OR ~retry THEN + SysErrors.Raise(errors, d0, Sys.write, ""); + RETURN -1 + END; + END; END; END Write; PROCEDURE Seek*(fd: File; offset: Count; whence: Whence; - errors: RelatedEvents.Object) : BOOLEAN; + errors: RelatedEvents.Object) : BOOLEAN; VAR - d0, d1: LONGINT; + d0, d1: LONGINT; BEGIN IF ulmSYSTEM.UNIXCALL(Sys.lseek, d0, d1, fd, offset, whence) THEN - RETURN TRUE + RETURN TRUE ELSE - SysErrors.Raise(errors, d0, Sys.lseek, ""); - RETURN FALSE + SysErrors.Raise(errors, d0, Sys.lseek, ""); + RETURN FALSE END; END Seek; PROCEDURE Tell*(fd: File; VAR offset: Count; - errors: RelatedEvents.Object) : BOOLEAN; + errors: RelatedEvents.Object) : BOOLEAN; VAR - d0, d1: LONGINT; + d0, d1: LONGINT; BEGIN IF ulmSYSTEM.UNIXCALL(Sys.lseek, d0, d1, fd, 0, fromPos) THEN - offset := d0; - RETURN TRUE + offset := d0; + RETURN TRUE ELSE - SysErrors.Raise(errors, d0, Sys.lseek, ""); - RETURN FALSE + SysErrors.Raise(errors, d0, Sys.lseek, ""); + RETURN FALSE END; END Tell; PROCEDURE Isatty*(fd: File) : BOOLEAN; CONST - sizeofStructTermIO = 18; - tcgeta = 00005405H; + sizeofStructTermIO = 18; + tcgeta = 00005405H; VAR - d0, d1: LONGINT; - buf: ARRAY 32 OF SYS.BYTE; (* Should be more than sufficient *) + d0, d1: LONGINT; + buf: ARRAY 32 OF SYS.BYTE; (* Should be more than sufficient *) BEGIN (* following system call fails for non-tty's *) RETURN ulmSYSTEM.UNIXCALL(Sys.ioctl, d0, d1, fd, tcgeta, SYS.ADR(buf)) END Isatty; PROCEDURE Fcntl*(fd: File; request: INTEGER; VAR arg: LONGINT; - errors: RelatedEvents.Object; - retry: BOOLEAN; VAR interrupted: BOOLEAN) : BOOLEAN; + errors: RelatedEvents.Object; + retry: BOOLEAN; VAR interrupted: BOOLEAN) : BOOLEAN; VAR - d0, d1: LONGINT; + d0, d1: LONGINT; BEGIN interrupted := FALSE; LOOP - IF ulmSYSTEM.UNIXCALL(Sys.fcntl, d0, d1, fd, request, arg) THEN - arg := d0; - RETURN TRUE - ELSE - IF d0 = SysErrors.intr THEN - interrupted := TRUE; - END; - IF (d0 # SysErrors.intr) OR ~retry THEN - SysErrors.Raise(errors, d0, Sys.fcntl, ""); - RETURN FALSE - END; - END; + IF ulmSYSTEM.UNIXCALL(Sys.fcntl, d0, d1, fd, request, arg) THEN + arg := d0; + RETURN TRUE + ELSE + IF d0 = SysErrors.intr THEN + interrupted := TRUE; + END; + IF (d0 # SysErrors.intr) OR ~retry THEN + SysErrors.Raise(errors, d0, Sys.fcntl, ""); + RETURN FALSE + END; + END; END; END Fcntl; PROCEDURE FcntlSet*(fd: File; request: INTEGER; flags: SET; - errors: RelatedEvents.Object; - retry: BOOLEAN; VAR interrupted: BOOLEAN) : BOOLEAN; + errors: RelatedEvents.Object; + retry: BOOLEAN; VAR interrupted: BOOLEAN) : BOOLEAN; VAR - d0, d1: LONGINT; + d0, d1: LONGINT; BEGIN interrupted := FALSE; LOOP - IF ulmSYSTEM.UNIXCALL(Sys.fcntl, d0, d1, fd, request, SYS.VAL(LONGINT, flags)) THEN - RETURN TRUE - ELSE - IF d0 = SysErrors.intr THEN - interrupted := TRUE; - END; - IF (d0 # SysErrors.intr) OR ~retry THEN - SysErrors.Raise(errors, d0, Sys.fcntl, ""); - RETURN FALSE - END; - END; + IF ulmSYSTEM.UNIXCALL(Sys.fcntl, d0, d1, fd, request, SYS.VAL(LONGINT, flags)) THEN + RETURN TRUE + ELSE + IF d0 = SysErrors.intr THEN + interrupted := TRUE; + END; + IF (d0 # SysErrors.intr) OR ~retry THEN + SysErrors.Raise(errors, d0, Sys.fcntl, ""); + RETURN FALSE + END; + END; END; END FcntlSet; PROCEDURE FcntlGet*(fd: File; request: INTEGER; VAR flags: SET; - errors: RelatedEvents.Object) : BOOLEAN; + errors: RelatedEvents.Object) : BOOLEAN; VAR - d0, d1: LONGINT; + d0, d1: LONGINT; BEGIN IF ulmSYSTEM.UNIXCALL(Sys.fcntl, d0, d1, fd, request, 0) THEN - ulmSYSTEM.WMOVE(SYS.ADR(d0), SYS.ADR(flags), 1); - RETURN TRUE + ulmSYSTEM.WMOVE(SYS.ADR(d0), SYS.ADR(flags), 1); + RETURN TRUE ELSE - SysErrors.Raise(errors, d0, Sys.fcntl, ""); - RETURN FALSE + SysErrors.Raise(errors, d0, Sys.fcntl, ""); + RETURN FALSE END; END FcntlGet; PROCEDURE Dup*(fd: File; VAR newfd: File; - errors: RelatedEvents.Object) : BOOLEAN; + errors: RelatedEvents.Object) : BOOLEAN; VAR - d0, d1: LONGINT; - a0, a1: LONGINT; + d0, d1: LONGINT; + a0, a1: LONGINT; BEGIN + a0 := 0; a1 := 0; (* Initialised to disable compiler warning. *) IF ulmSYSTEM.UNIXCALL(Sys.dup, d0, d1, fd, a0, a1) THEN - newfd := d0; - RETURN TRUE + newfd := d0; + RETURN TRUE ELSE - SysErrors.Raise(errors, d0, Sys.dup, ""); - RETURN FALSE + SysErrors.Raise(errors, d0, Sys.dup, ""); + RETURN FALSE END; END Dup; PROCEDURE Dup2*(fd, newfd: File; errors: RelatedEvents.Object) : BOOLEAN; VAR - d0, d1: LONGINT; - a0, a1: LONGINT; - fd2: File; - interrupted: BOOLEAN; + d0, d1: LONGINT; + a0, a1: LONGINT; + fd2: File; + interrupted: BOOLEAN; BEGIN + a0 := 0; a1 := 0; (* Initialised to disable compiler warning. *) fd2 := newfd; (* handmade close to avoid unnecessary events *) IF ~ulmSYSTEM.UNIXCALL(Sys.close, d0, d1, newfd, a0, a1) THEN END; IF Fcntl(fd, dupfd, fd2, errors, TRUE, interrupted) THEN - IF fd2 = newfd THEN - RETURN TRUE - ELSE - RETURN Close(fd2, errors, TRUE, interrupted) & FALSE - END; + IF fd2 = newfd THEN + RETURN TRUE + ELSE + RETURN Close(fd2, errors, TRUE, interrupted) & FALSE + END; ELSE - RETURN FALSE + RETURN FALSE END; END Dup2; PROCEDURE Pipe*(VAR readfd, writefd: File; - errors: RelatedEvents.Object) : BOOLEAN; + errors: RelatedEvents.Object) : BOOLEAN; VAR - d0, d1: LONGINT; - a0, a1: LONGINT; - fds : ARRAY 2 OF (*File*)INTEGER; (* it needs int pipefd[2], and int is 4 bytes long on x86_64 -- noch *) + d0, d1: LONGINT; + a0, a1: LONGINT; + fds : ARRAY 2 OF (*File*)INTEGER; (* it needs int pipefd[2], and int is 4 bytes long on x86_64 -- noch *) BEGIN + a0 := 0; a1 := 0; (* Initialised to disable compiler warning. *) IF ulmSYSTEM.UNIXCALL(Sys.pipe, d0, d1, SYS.ADR (fds), a0, a1) THEN - readfd := fds[0]; writefd := fds[1]; - RETURN TRUE + readfd := fds[0]; writefd := fds[1]; + RETURN TRUE ELSE - SysErrors.Raise(errors, d0, Sys.pipe, ""); - RETURN FALSE + SysErrors.Raise(errors, d0, Sys.pipe, ""); + RETURN FALSE END; END Pipe; diff --git a/src/library/ulm/ulmSysStat.Mod b/src/library/ulm/ulmSysStat.Mod index 54d1fc41..f9aaa507 100644 --- a/src/library/ulm/ulmSysStat.Mod +++ b/src/library/ulm/ulmSysStat.Mod @@ -45,42 +45,42 @@ MODULE ulmSysStat; CONST (* file mode: bit 0 = 1<<0 bit 31 = 1<<31 - + user group other 3 1 1111 11 1 ... 6 5432 109 876 543 210 - +--------+------+-----+-----+-----+-----+ - | unused | type | sst | rwx | rwx | rwx | - +--------+------+-----+-----+-----+-----+ + +--------+------+-----+-----+-----+-----+ + | unused | type | sst | rwx | rwx | rwx | + +--------+------+-----+-----+-----+-----+ *) type* = {12..15}; prot* = {0..8}; (* file types; example: (stat.mode * type = dir) *) - reg* = {15}; (* regular *) - dir* = {14}; (* directory *) - chr* = {13}; (* character special *) - fifo* = {12}; (* fifo *) - blk* = {13..14}; (* block special *) - symlink* = {13, 15}; (* symbolic link *) - socket* = {14, 15}; (* socket *) + reg* = {15}; (* regular *) + dir* = {14}; (* directory *) + chr* = {13}; (* character special *) + fifo* = {12}; (* fifo *) + blk* = {13..14}; (* block special *) + symlink* = {13, 15}; (* symbolic link *) + socket* = {14, 15}; (* socket *) (* special *) - setuid* = 11; (* set user id on execution *) - setgid* = 10; (* set group id on execution *) - savetext* = 9; (* save swapped text even after use *) + setuid* = 11; (* set user id on execution *) + setgid* = 10; (* set group id on execution *) + savetext* = 9; (* save swapped text even after use *) (* protection *) - uread* = 8; (* read permission owner *) - uwrite* = 7; (* write permission owner *) - uexec* = 6; (* execute/search permission owner *) - gread* = 5; (* read permission group *) - gwrite* = 4; (* write permission group *) - gexec* = 3; (* execute/search permission group *) - oread* = 2; (* read permission other *) - owrite* = 1; (* write permission other *) - oexec* = 0; (* execute/search permission other *) + uread* = 8; (* read permission owner *) + uwrite* = 7; (* write permission owner *) + uexec* = 6; (* execute/search permission owner *) + gread* = 5; (* read permission group *) + gwrite* = 4; (* write permission group *) + gexec* = 3; (* execute/search permission group *) + oread* = 2; (* read permission other *) + owrite* = 1; (* write permission other *) + oexec* = 0; (* execute/search permission other *) (* example for "r-xr-x---": (read + exec) * (owner + group) *) owner* = {uread, uwrite, uexec}; @@ -92,136 +92,98 @@ MODULE ulmSysStat; rwx* = prot; TYPE - StatRec* = (* result of stat(2) and fstat(2) *) - RECORD - device*: SysTypes.Device; (* ID of device containing - a directory entry for this file *) - inode*: SysTypes.Inode; (* inode number *) - nlinks*: LONGINT(*INTEGER*); (* number of links *) - mode*: SET; (* file mode; see mknod(2) *) - uid*: INTEGER; (* user id of the file's owner *) - gid*: INTEGER; (* group id of the file's group *) - rdev*: SysTypes.Device; (* ID of device - this entry is defined only for - character special or block - special files - *) - size*: SysTypes.Offset; (* file size in bytes *) - blksize*: LONGINT; (* preferred blocksize *) - blocks*: LONGINT; (* # of blocks allocated *) - atime*: SysTypes.Time; (* time of last access *) - mtime*: SysTypes.Time; (* time of last data modification *) - ctime*: SysTypes.Time; (* time of last file status change *) - END; + StatRec* = RECORD (* result of stat(2) and fstat(2) *) + device*: SysTypes.Device; (* ID of device containing a directory entry + for this file *) + inode*: SysTypes.Inode; (* inode number *) + mode*: SET; (* file mode; see mknod(2) *) + nlinks*: LONGINT; (* number of links *) + uid*: LONGINT; (* user id of the file's owner *) + gid*: LONGINT; (* group id of the file's group *) + rdev*: SysTypes.Device; (* ID of device. this entry is defined only for + character special or block special files *) + size*: SysTypes.Offset; (* file size in bytes *) + + (* Blocks and blksize are not available on all platforms. + blksize*: LONGINT; (* preferred blocksize *) + blocks*: LONGINT; (* # of blocks allocated *) + *) + + atime*: SysTypes.Time; (* time of last access *) + mtime*: SysTypes.Time; (* time of last data modification *) + ctime*: SysTypes.Time; (* time of last file status change *) + END; -(* StatRec* = (* result of stat(2) and fstat(2) *) - RECORD - device*: SysTypes.Device; (* ID of device containing - a directory entry for this file *) - inode*: SysTypes.Inode; (* inode number *) - nlinks*: LONGINT; (* number of links *) - mode*: INTEGER(*SET*); (* file mode; see mknod(2) *) - uid*: INTEGER; (* user id of the file's owner *) - gid*: INTEGER; (* group id of the file's group *) - pad0: INTEGER; - rdev*: SysTypes.Device; (* ID of device - this entry is defined only for - character special or block - special files - *) - size*: SysTypes.Offset; (* file size in bytes *) - blksize*: LONGINT; (* preferred blocksize *) - blocks*: LONGINT; (* # of blocks allocated *) - atime*: SysTypes.Time; (* time of last access *) - atimences* : LONGINT; - mtime*: SysTypes.Time; (* time of last data modification *) - mtimensec* : LONGINT; - ctime*: SysTypes.Time; (* time of last file status change *) - ctimensec* : LONGINT; - unused0*, unused1*, unused2*: LONGINT; - END; -*) -(* Linux kernel struct stat (2.2.17) - struct stat { - unsigned short st_dev; - unsigned short __pad1; - unsigned long st_ino; - unsigned short st_mode; - unsigned short st_nlink; - unsigned short st_uid; - unsigned short st_gid; - unsigned short st_rdev; - unsigned short __pad2; - unsigned long st_size; - unsigned long st_blksize; - unsigned long st_blocks; - unsigned long st_atime; - unsigned long __unused1; - unsigned long st_mtime; - unsigned long __unused2; - unsigned long st_ctime; - unsigned long __unused3; - unsigned long __unused4; - unsigned long __unused5; - }; -*) - CONST - statbufsize = 144(*64*); (* see *) (* sizeof struct stat gives us 144 on x86_64 and 88 or x86; -- noch *) - TYPE - UnixStatRec = ARRAY statbufsize OF SYS.BYTE; - CONST - statbufconv = - (*"is=dev/-s=pad1/ll=ino/Ss=mode/4*is=nlink+uid+gid+rdev/-s=pad2/ll=size/2*ll=blksize,blocks/il=atime/-l/il=mtime/-l/il=ctime/3*-l";*) - "lL=dev/lL=ino/lL=nlink/Su=mode/2*iu=uid+gid/-i=pad0/lL=rdev/ll=size/2*ll=blksize,blocks/lL=atime/-l/lL=mtime/-l/lL=ctime/3*-l"; (* noch *) - VAR - statbuffmt: SysConversions.Format; + PROCEDURE -Aincludesysstat '#include '; + PROCEDURE -Aerrno '#include '; - PROCEDURE Stat*(path: ARRAY OF CHAR; VAR buf: StatRec; - errors: RelatedEvents.Object) : BOOLEAN; - VAR - d0, d1, d2: LONGINT; - origbuf: UnixStatRec; + PROCEDURE -structstats "struct stat s"; + PROCEDURE -statdev(): LONGINT "(LONGINT)s.st_dev"; + PROCEDURE -statino(): LONGINT "(LONGINT)s.st_ino"; + PROCEDURE -statmode(): LONGINT "(LONGINT)s.st_mode"; + PROCEDURE -statnlink(): LONGINT "(LONGINT)s.st_nlink"; + PROCEDURE -statuid(): LONGINT "(LONGINT)s.st_uid"; + PROCEDURE -statgid(): LONGINT "(LONGINT)s.st_gid"; + PROCEDURE -statrdev(): LONGINT "(LONGINT)s.st_rdev"; + PROCEDURE -statsize(): LONGINT "(LONGINT)s.st_size"; + PROCEDURE -statatime(): LONGINT "(LONGINT)s.st_atime"; + PROCEDURE -statmtime(): LONGINT "(LONGINT)s.st_mtime"; + PROCEDURE -statctime(): LONGINT "(LONGINT)s.st_ctime"; + + (* Blocks and blksize are not available on all platforms. + PROCEDURE -statblksize(): LONGINT "(LONGINT)s.st_blksize"; + PROCEDURE -statblocks(): LONGINT "(LONGINT)s.st_blocks"; + *) + + PROCEDURE -fstat(fd: LONGINT): INTEGER "fstat(fd, &s)"; + PROCEDURE -stat (n: ARRAY OF CHAR): INTEGER "stat((char*)n, &s)"; + + PROCEDURE -err(): INTEGER "errno"; + + PROCEDURE Stat*(path: ARRAY OF CHAR; VAR buf: StatRec; errors: RelatedEvents.Object): BOOLEAN; BEGIN - IF uSYS.UNIXCALL(Sys.newstat, d0, d1, SYS.ADR(path), SYS.ADR(origbuf), d2) THEN - SysConversions.ByFmtFromC(origbuf, buf, statbuffmt); - RETURN TRUE - ELSE - SysErrors.Raise(errors, d0, Sys.newstat, path); - RETURN FALSE - END; + structstats; + IF stat(path) < 0 THEN SysErrors.Raise(errors, err(), Sys.newstat, path); RETURN FALSE END; + buf.device := SYS.VAL(SysTypes.Device, statdev()); + buf.inode := SYS.VAL(SysTypes.Inode, statino()); + buf.mode := SYS.VAL(SET, statmode()); + buf.nlinks := statnlink(); + buf.uid := statuid(); + buf.gid := statgid(); + buf.rdev := SYS.VAL(SysTypes.Device, statrdev()); + buf.size := SYS.VAL(SysTypes.Offset, statsize()); + (* Blocks and blksize are not available on all platforms. + buf.blksize := statblksize(); + buf.blocks := statblocks(); + *) + buf.atime := SYS.VAL(SysTypes.Time, statatime()); + buf.mtime := SYS.VAL(SysTypes.Time, statmtime()); + buf.ctime := SYS.VAL(SysTypes.Time, statctime()); + RETURN TRUE; END Stat; -(* commented temporarily, it is used only in FTPUnixDirLister module *) (* - PROCEDURE Lstat*(path: ARRAY OF CHAR; VAR buf: StatRec; - errors: RelatedEvents.Object) : BOOLEAN; - VAR - d0, d1: INTEGER; - origbuf: UnixStatRec; + + PROCEDURE Fstat*(fd: SysTypes.File; VAR buf: StatRec; errors: RelatedEvents.Object): BOOLEAN; BEGIN - IF SYS.UNIXCALL(Sys.newlstat, d0, d1, SYS.ADR(path), SYS.ADR(origbuf)) THEN - SysConversions.ByFmtFromC(origbuf, buf, statbuffmt); - RETURN TRUE - ELSE - SysErrors.Raise(errors, d0, Sys.newlstat, path); - RETURN FALSE - END; - END Lstat; -*) - PROCEDURE Fstat*(fd: SysTypes.File; VAR buf: StatRec; - errors: RelatedEvents.Object) : BOOLEAN; - VAR - d0, d1, d2: LONGINT; - origbuf: UnixStatRec; - BEGIN - IF uSYS.UNIXCALL(Sys.newfstat, d0, d1, fd, SYS.ADR(origbuf), d2) THEN - SysConversions.ByFmtFromC(origbuf, buf, statbuffmt); - RETURN TRUE - ELSE - SysErrors.Raise(errors, d0, Sys.newfstat, ""); - RETURN FALSE - END; + structstats; + IF fstat(SYS.VAL(LONGINT, fd)) < 0 THEN SysErrors.Raise(errors, err(), Sys.newfstat, ""); RETURN FALSE END; + buf.device := SYS.VAL(SysTypes.Device, statdev()); + buf.inode := SYS.VAL(SysTypes.Inode, statino()); + buf.mode := SYS.VAL(SET, statmode()); + buf.nlinks := statnlink(); + buf.uid := statuid(); + buf.gid := statgid(); + buf.rdev := SYS.VAL(SysTypes.Device, statrdev()); + buf.size := SYS.VAL(SysTypes.Offset, statsize()); + (* Blocks and blksize are not available on all platforms. + buf.blksize := statblksize(); + buf.blocks := statblocks(); + *) + buf.atime := SYS.VAL(SysTypes.Time, statatime()); + buf.mtime := SYS.VAL(SysTypes.Time, statmtime()); + buf.ctime := SYS.VAL(SysTypes.Time, statctime()); + RETURN TRUE; END Fstat; -BEGIN - SysConversions.Compile(statbuffmt, statbufconv); + END ulmSysStat. diff --git a/src/library/ulm/ulmTCrypt.Mod b/src/library/ulm/ulmTCrypt.Mod index e1909085..4003eaf0 100644 --- a/src/library/ulm/ulmTCrypt.Mod +++ b/src/library/ulm/ulmTCrypt.Mod @@ -38,11 +38,11 @@ MODULE ulmTCrypt; (* Michael Szczuka *) M = 16; (* size of an element of CC(M) [ring of Circular Convolution] *) MaxVar = 8; (* number of variables of a polynomial *) MaxNrExp = 4; (* maxiumum number of different exponts used during - initialisaton *) + initialisaton *) Dim = 2; (* dimension of the linear recursion *) Rounds = 16; (* length of the linear recursion in rounds *) LastRounds = 4; (* use the last LastRounds polynomial vectors as - the composed function eta *) + the composed function eta *) reg = 1; sing = 2; random = 3; LIST = TRUE; NOLIST = FALSE; MaxTerms = 1000; @@ -62,9 +62,9 @@ MODULE ulmTCrypt; (* Michael Szczuka *) (* a polynomial with coefficients out of CC(M) *) Polynom = POINTER TO PolynomRec; PolynomRec = RECORD - koeff : CCMElement; - exp : Exponent; - next : Polynom; + koeff : CCMElement; + exp : Exponent; + next : Polynom; END; TYPE @@ -77,51 +77,51 @@ MODULE ulmTCrypt; (* Michael Szczuka *) ChainCCM = ARRAY Rounds OF VektorCCM; ChainPolynom = ARRAY Rounds OF VektorPolynom; (* to increase the performance of the algorithm there shouldn't be too - many different exponents to start with *) + many different exponents to start with *) ListExp = ARRAY MaxNrExp OF Exponent; TYPE (* this type is the input of the TCrypt method *) TCryptInput = POINTER TO TCryptInputRec; TCryptInputRec = RECORD - arg : ARRAY MaxVar OF CCMElement; + arg : ARRAY MaxVar OF CCMElement; END; TYPE (* result type after encryption with the public key *) TCryptTmp = POINTER TO TCryptTmpRec; TCryptTmpRec = RECORD - numerator : ChainCCM; - denominator : ListCCM; + numerator : ChainCCM; + denominator : ListCCM; END; TYPE (* result type of the algorithm *) TCryptRes = POINTER TO TCryptResRec; TCryptResRec = RECORD - arg : ARRAY LastRounds OF VektorCCM; + arg : ARRAY LastRounds OF VektorCCM; END; TYPE (* this type represents the public function f resp. phi *) Phi = POINTER TO PhiRec; PhiRec = RECORD - num : ChainPolynom; - denom : ListPolynom; + num : ChainPolynom; + denom : ListPolynom; END; TYPE (* the private/secret function g resp. psi consisting of an inital matrix - and a permutation *) + and a permutation *) Psi = POINTER TO PsiRec; PsiRec = RECORD - (* although the inital matrix consists only of elements out of CC(M) - this generalization is useful since all other matrces consist of - polynomials *) - initialmatrix : MatCCM; - (* correcting factors *) - korrNum : ChainCCM; - korrDenom : ListCCM; + (* although the inital matrix consists only of elements out of CC(M) + this generalization is useful since all other matrces consist of + polynomials *) + initialmatrix : MatCCM; + (* correcting factors *) + korrNum : ChainCCM; + korrDenom : ListCCM; END; (* the public function h resp. eta being the composition of f/phi @@ -129,49 +129,49 @@ MODULE ulmTCrypt; (* Michael Szczuka *) TYPE Eta = POINTER TO EtaRec; EtaRec = RECORD - p : ARRAY LastRounds OF VektorPolynom; + p : ARRAY LastRounds OF VektorPolynom; END; TYPE (* the declaration of a basic type which PublicCipher and PrivateCipher - are descendents from seems a good idea ... at least to me :) *) + are descendents from seems a good idea ... at least to me :) *) Cipher* = POINTER TO CipherRec; CipherRec* = RECORD (AsymmetricCiphers.CipherRec) END; (* the specific format of a public key for Trautner's technique *) PublicCipher = POINTER TO PublicCipherRec; PublicCipherRec = RECORD - (CipherRec) - phi : Phi; - eta : Eta; + (CipherRec) + phi : Phi; + eta : Eta; END; (* the specific format of a key for Trautner's technique *) PrivateCipher = POINTER TO PrivateCipherRec; PrivateCipherRec = RECORD - (CipherRec) - phi : Phi; - psi : Psi; - eta : Eta; + (CipherRec) + phi : Phi; + psi : Psi; + eta : Eta; END; TYPE ErrorEvent = POINTER TO ErrorEventRec; ErrorEventRec = RECORD - (Events.EventRec) - errorcode : SHORTINT; + (Events.EventRec) + errorcode : SHORTINT; END; VAR pubType, privType, cipherType : Services.Type; pubIf, privIf, cipherIf : PersistentObjects.Interface; NullCCM, EinsCCM : CCMElement; (* the zero and unit of CC(M) *) - NullExp : Exponent; (* consists of zero exponents *) + NullExp : Exponent; (* consists of zero exponents *) NullExpList : ListExp; (* a pseudo list for CreatePolynom *) GlobalExpList : ListExp; (* contains the exponents which should be used - when calling CreatePolynom *) + when calling CreatePolynom *) NullPolynom : Polynom; (* the zero polynomial *) PolFeld : ARRAY MaxTerms OF Polynom; (* used for sorting purposes *) PreEvalArg : ARRAY M OF TCryptInput; (* precomputed values to speed - up evaluation of a polynomial *) + up evaluation of a polynomial *) k : SHORTINT; (* simple counter during initialisation *) error : Events.EventType; errormsg : ARRAY errorcodes OF Events.Message; @@ -189,7 +189,7 @@ MODULE ulmTCrypt; (* Michael Szczuka *) PROCEDURE Error(s: Streams.Stream; errorcode: SHORTINT); VAR - event: ErrorEvent; + event: ErrorEvent; BEGIN NEW(event); event.message := errormsg[errorcode]; @@ -202,33 +202,33 @@ MODULE ulmTCrypt; (* Michael Szczuka *) PROCEDURE RegulaerCCM (x: CCMElement) : BOOLEAN; (* tests x for regularity [a regular CCMElement contains an odd number of - set bits]; returns TRUE when x is regular, FALSE otherwise *) + set bits]; returns TRUE when x is regular, FALSE otherwise *) VAR - res, i : SHORTINT; + res, i : SHORTINT; BEGIN i := 0; res := 0; - REPEAT (* counting the set bits *) - IF i IN x THEN - INC(res); - END; - INC(i); + REPEAT (* counting the set bits *) + IF i IN x THEN + INC(res); + END; + INC(i); UNTIL i>=M; RETURN ((res MOD 2) = 1); END RegulaerCCM; PROCEDURE EqualCCM (x, y: CCMElement) : BOOLEAN; (* compares x and y for equality; if x and y are equal TRUE is returned, - FALSE otherwise *) + FALSE otherwise *) VAR - i : SHORTINT; + i : SHORTINT; BEGIN i := 0; WHILE i < M DO - IF ((i IN x) & (~(i IN y))) OR ((~(i IN x)) & (i IN y)) THEN - RETURN FALSE; - END; - INC(i); + IF ((i IN x) & (~(i IN y))) OR ((~(i IN x)) & (i IN y)) THEN + RETURN FALSE; + END; + INC(i); END; RETURN TRUE; END EqualCCM; @@ -236,121 +236,122 @@ MODULE ulmTCrypt; (* Michael Szczuka *) PROCEDURE AddCCM (x, y: CCMElement; VAR z: CCMElement); (* add x and y in CC(M) *) VAR - i : SHORTINT; + i : SHORTINT; BEGIN z := NullCCM; i := 0; REPEAT - IF ((i IN x) & (~(i IN y))) OR ((~(i IN x)) & (i IN y)) THEN - z := z + {i}; - END; - INC(i); + IF ((i IN x) & (~(i IN y))) OR ((~(i IN x)) & (i IN y)) THEN + z := z + {i}; + END; + INC(i); UNTIL i>=M; END AddCCM; PROCEDURE MulCCM (x, y: CCMElement; VAR z: CCMElement); (* multiply x and y in CC(M) *) VAR - i, j, diff : SHORTINT; - tmp : INTEGER; + i, j, diff : SHORTINT; + tmp : INTEGER; BEGIN z := NullCCM; i := 0; REPEAT - j := 0; - tmp := 0; - REPEAT - diff := i-j; - IF diff >= 0 THEN - IF (j IN x) & (diff IN y) THEN - INC(tmp); - END; - ELSE - IF (j IN x) & ((M+diff) IN y) THEN - INC(tmp); - END; - END; - INC(j); - UNTIL j>=M; - IF (tmp MOD 2) = 1 THEN - z := z + {i}; - END; - INC(i); + j := 0; + tmp := 0; + REPEAT + diff := i-j; + IF diff >= 0 THEN + IF (j IN x) & (diff IN y) THEN + INC(tmp); + END; + ELSE + IF (j IN x) & ((M+diff) IN y) THEN + INC(tmp); + END; + END; + INC(j); + UNTIL j>=M; + IF (tmp MOD 2) = 1 THEN + z := z + {i}; + END; + INC(i); UNTIL i>=M; END MulCCM; PROCEDURE PowerCCM (x: CCMElement; exp: INTEGER; VAR z: CCMElement); (* raises x to the power exp in CC(M) *) VAR - tmp : CCMElement; + tmp : CCMElement; BEGIN (* some special cases first *) IF exp >= M THEN - IF ~RegulaerCCM(x) THEN - (* x is singular -> result is zero *) - z := NullCCM; - RETURN; - END; - (* x is regular -> compute the modulus of exp mod M and use this - instead of exp *) - exp := exp MOD M; + IF ~RegulaerCCM(x) THEN + (* x is singular -> result is zero *) + z := NullCCM; + RETURN; + END; + (* x is regular -> compute the modulus of exp mod M and use this + instead of exp *) + exp := exp MOD M; END; IF exp = 0 THEN - z := EinsCCM; - RETURN; + z := EinsCCM; + RETURN; END; IF exp = 1 THEN - z := x; - RETURN; + z := x; + RETURN; END; (* default case; use a "square and multiply" technique *) tmp := x; z := EinsCCM; REPEAT - IF exp MOD 2 = 1 THEN - MulCCM(z, tmp, z); - END; - exp := exp DIV 2; - MulCCM(tmp, tmp, tmp); + IF exp MOD 2 = 1 THEN + MulCCM(z, tmp, z); + END; + exp := exp DIV 2; + MulCCM(tmp, tmp, tmp); UNTIL exp < 1; END PowerCCM; PROCEDURE CreateCCM (VAR x: CCMElement; mode: SHORTINT); (* creates a random element out of CC(M) depending on mode which - can be reg, sing or random; - the result is in any case different from the zero *) + can be reg, sing or random; + the result is in any case different from the zero *) VAR - i, SetBits: SHORTINT; + i, SetBits: SHORTINT; BEGIN x := NullCCM; REPEAT - i := 0; - SetBits := 0; - REPEAT - IF Random.Flip() THEN - (* set bit *) - x := x + {i}; - INC(SetBits); - END; - INC(i); - UNTIL i >= (M-1); + i := 0; + SetBits := 0; + REPEAT + IF Random.Flip() THEN + (* set bit *) + x := x + {i}; + INC(SetBits); + END; + INC(i); + UNTIL i >= (M-1); UNTIL SetBits > 0; (* at least one bit must be set so that the result - differs from zero *) + differs from zero *) CASE mode OF - random: - IF Random.Flip() THEN - x := x + {M-1}; - END; - | sing: (* singular element - even # of bits *) - IF (SetBits MOD 2) = 1 THEN - x := x + {M-1}; - END; - | reg: (* regular element - odd # of bits *) - IF ((SetBits + 1) MOD 2) = 1 THEN - x := x + {M-1}; - END; + random: + IF Random.Flip() THEN + x := x + {M-1}; + END; + | sing: (* singular element - even # of bits *) + IF (SetBits MOD 2) = 1 THEN + x := x + {M-1}; + END; + | reg: (* regular element - odd # of bits *) + IF ((SetBits + 1) MOD 2) = 1 THEN + x := x + {M-1}; + END; + ELSE END; END CreateCCM; @@ -359,64 +360,64 @@ MODULE ulmTCrypt; (* Michael Szczuka *) PROCEDURE LengthPolynom(p: Polynom) : INTEGER; (* returns the number of terms which make up the polynomial p *) VAR - i : INTEGER; + i : INTEGER; BEGIN i := 0; WHILE p # NIL DO - INC(i); - p := p.next; + INC(i); + p := p.next; END; RETURN i; END LengthPolynom; PROCEDURE RegulaerPolynom (p: Polynom) : BOOLEAN; (* tests the regularity of a polynomial [a polynomial is regular - iff the # of regular coefficients is odd] *) + iff the # of regular coefficients is odd] *) VAR - regkoeffs : SHORTINT; + regkoeffs : SHORTINT; BEGIN regkoeffs := 0; WHILE p # NIL DO - IF RegulaerCCM(p.koeff) THEN - (* count # of reg. coefficients *) - INC(regkoeffs); - END; - p := p.next; + IF RegulaerCCM(p.koeff) THEN + (* count # of reg. coefficients *) + INC(regkoeffs); + END; + p := p.next; END; RETURN (regkoeffs MOD 2) = 1; END RegulaerPolynom; PROCEDURE CmpExp (exp1, exp2: Exponent) : SHORTINT; (* compares two exponent vectors and returns 0 on equality, a - positive value if exp1>exp2 and a negative value if exp1exp2 and a negative value if exp1 e2 THEN - cmp := 1; diff := TRUE; - END; - END; - INC(i); + e1 := exp1[i]; e2 := exp2[i]; + INC(sum1, e1); INC(sum2, e2); + IF ~diff THEN + IF e1 < e2 THEN + cmp := -1; diff := TRUE; + ELSIF e1 > e2 THEN + cmp := 1; diff := TRUE; + END; + END; + INC(i); UNTIL i >= MaxVar; IF sum1 < sum2 THEN - RETURN -2; + RETURN -2; END; IF sum1 > sum2 THEN - RETURN 2; + RETURN 2; END; RETURN cmp @@ -425,69 +426,69 @@ MODULE ulmTCrypt; (* Michael Szczuka *) PROCEDURE ArrangePolynom (VAR p: Polynom); (* arrange a polynomial according to the order given by CmpExp *) VAR - r : Polynom; - cnt : INTEGER; + r : Polynom; + cnt : INTEGER; PROCEDURE SortPolynom(left, right: INTEGER); - (* sort the global field PolFeld with the quicksort algorithm *) - VAR - mid : INTEGER; + (* sort the global field PolFeld with the quicksort algorithm *) + VAR + mid : INTEGER; - PROCEDURE Partition(l, r: INTEGER) : INTEGER; - VAR - koeff : CCMElement; - exp : Exponent; - cmp : Exponent; - i, j : INTEGER; - BEGIN - cmp := PolFeld[(l+r) DIV 2].exp; - i := l-1; - j := r+1; - LOOP - REPEAT - DEC(j); - UNTIL CmpExp(PolFeld[j].exp, cmp) >= 0; - REPEAT - INC(i); - UNTIL CmpExp(PolFeld[i].exp, cmp) <= 0; - IF i < j THEN - koeff := PolFeld[i].koeff; - exp := PolFeld[i].exp; - PolFeld[i].koeff := PolFeld[j].koeff; - PolFeld[i].exp := PolFeld[j].exp; - PolFeld[j].koeff := koeff; - PolFeld[j].exp := exp; - ELSE - RETURN j; - END; - END; - END Partition; + PROCEDURE Partition(l, r: INTEGER) : INTEGER; + VAR + koeff : CCMElement; + exp : Exponent; + cmp : Exponent; + i, j : INTEGER; + BEGIN + cmp := PolFeld[(l+r) DIV 2].exp; + i := l-1; + j := r+1; + LOOP + REPEAT + DEC(j); + UNTIL CmpExp(PolFeld[j].exp, cmp) >= 0; + REPEAT + INC(i); + UNTIL CmpExp(PolFeld[i].exp, cmp) <= 0; + IF i < j THEN + koeff := PolFeld[i].koeff; + exp := PolFeld[i].exp; + PolFeld[i].koeff := PolFeld[j].koeff; + PolFeld[i].exp := PolFeld[j].exp; + PolFeld[j].koeff := koeff; + PolFeld[j].exp := exp; + ELSE + RETURN j; + END; + END; + END Partition; BEGIN - IF left < right THEN - mid := Partition(left, right); - SortPolynom(left, mid); - SortPolynom(mid+1, right); - END; + IF left < right THEN + mid := Partition(left, right); + SortPolynom(left, mid); + SortPolynom(mid+1, right); + END; END SortPolynom; BEGIN (* ArrangePolynom *) IF p = NIL THEN - RETURN; + RETURN; END; r := p; cnt := 0; WHILE (p # NIL) & (cnt < MaxTerms) DO - PolFeld[cnt] := p; - INC(cnt); - p := p.next; + PolFeld[cnt] := p; + INC(cnt); + p := p.next; END; (* polynomial contains too many terms; this shouldn't happen if all - parameters are set to reasonable values and MaxTerms is high - enough *) + parameters are set to reasonable values and MaxTerms is high + enough *) ASSERT(cnt 1 THEN - SortPolynom(0, cnt-1); + SortPolynom(0, cnt-1); END; p := r; END ArrangePolynom; @@ -495,97 +496,97 @@ MODULE ulmTCrypt; (* Michael Szczuka *) PROCEDURE CopyPolynom (s: Polynom; VAR t: Polynom); (* copy the source polynomial s to a new target t *) VAR - troot : Polynom; + troot : Polynom; BEGIN IF s = NIL THEN - t := NIL; - RETURN; + t := NIL; + RETURN; END; NEW(t); - troot := t; (* save the root of t *) + troot := t; (* save the root of t *) WHILE s # NIL DO - troot.koeff := s.koeff; - troot.exp := s.exp; - s := s.next; - IF s # NIL THEN - NEW(troot.next); - troot := troot.next; - ELSE - troot.next := NIL; - END; + troot.koeff := s.koeff; + troot.exp := s.exp; + s := s.next; + IF s # NIL THEN + NEW(troot.next); + troot := troot.next; + ELSE + troot.next := NIL; + END; END; END CopyPolynom; PROCEDURE AddPolynom (p, q: Polynom; VAR r: Polynom); (* add two polynomial; the polynomials must be sorted by the exponents as - is the result *) + is the result *) VAR - term1, term2 : Polynom; - last : Polynom; (* the last term of the result *) - tmp : Polynom; - cmpres : SHORTINT; + term1, term2 : Polynom; + last : Polynom; (* the last term of the result *) + tmp : Polynom; + cmpres : SHORTINT; BEGIN IF (p = NIL) & (q = NIL) THEN - r := NIL; - RETURN; + r := NIL; + RETURN; END; NEW(r); - term1 := p; (* term1 runs through all terms of p *) - term2 := q; (* same with term2 for q *) - tmp := r; (* save the root of r *) + term1 := p; (* term1 runs through all terms of p *) + term2 := q; (* same with term2 for q *) + tmp := r; (* save the root of r *) last := tmp; REPEAT - IF (term1 = NIL) OR (term2 = NIL) THEN - IF term2 = NIL THEN - (* no further terms in q *) - WHILE term1 # NIL DO - (* copy the remaining terms of p *) - tmp.koeff := term1.koeff; - tmp.exp := term1.exp; - term1 := term1.next; - IF ~EqualCCM(tmp.koeff, NullCCM) THEN - last := tmp; - NEW(tmp.next); - tmp := tmp.next; - END; - END; - ELSE (* no further terms in p *) - WHILE term2 # NIL DO - tmp.koeff := term2.koeff; - tmp.exp := term2.exp; - term2 := term2.next; - IF ~EqualCCM(tmp.koeff, NullCCM) THEN - last := tmp; - NEW(tmp.next); - tmp := tmp.next; - END; - END; - END; - ELSE (* both p and q still have a term *) - cmpres := CmpExp(term1.exp, term2.exp); - IF cmpres = 0 THEN (* add when exponents are equal *) - AddCCM(term1.koeff, term2.koeff, tmp.koeff); - tmp.exp := term1.exp; - term1 := term1.next; - term2 := term2.next; - ELSE - IF cmpres < 0 THEN (* exp2 > exp1 *) - tmp.koeff := term2.koeff; - tmp.exp := term2.exp; - term2 := term2.next; - ELSE (* exp1 > exp2 *) - tmp.koeff := term1.koeff; - tmp.exp := term1.exp; - term1 := term1.next; - END; - END; - (* zero coefficients = zero terms shouldn't occur in the result *) - IF ~EqualCCM(tmp.koeff, NullCCM) THEN - NEW(tmp.next); - last := tmp; - tmp := tmp.next; - END; - END; + IF (term1 = NIL) OR (term2 = NIL) THEN + IF term2 = NIL THEN + (* no further terms in q *) + WHILE term1 # NIL DO + (* copy the remaining terms of p *) + tmp.koeff := term1.koeff; + tmp.exp := term1.exp; + term1 := term1.next; + IF ~EqualCCM(tmp.koeff, NullCCM) THEN + last := tmp; + NEW(tmp.next); + tmp := tmp.next; + END; + END; + ELSE (* no further terms in p *) + WHILE term2 # NIL DO + tmp.koeff := term2.koeff; + tmp.exp := term2.exp; + term2 := term2.next; + IF ~EqualCCM(tmp.koeff, NullCCM) THEN + last := tmp; + NEW(tmp.next); + tmp := tmp.next; + END; + END; + END; + ELSE (* both p and q still have a term *) + cmpres := CmpExp(term1.exp, term2.exp); + IF cmpres = 0 THEN (* add when exponents are equal *) + AddCCM(term1.koeff, term2.koeff, tmp.koeff); + tmp.exp := term1.exp; + term1 := term1.next; + term2 := term2.next; + ELSE + IF cmpres < 0 THEN (* exp2 > exp1 *) + tmp.koeff := term2.koeff; + tmp.exp := term2.exp; + term2 := term2.next; + ELSE (* exp1 > exp2 *) + tmp.koeff := term1.koeff; + tmp.exp := term1.exp; + term1 := term1.next; + END; + END; + (* zero coefficients = zero terms shouldn't occur in the result *) + IF ~EqualCCM(tmp.koeff, NullCCM) THEN + NEW(tmp.next); + last := tmp; + tmp := tmp.next; + END; + END; UNTIL (term1 = NIL) & (term2 = NIL); (* forget last created term *) @@ -595,41 +596,41 @@ MODULE ulmTCrypt; (* Michael Szczuka *) PROCEDURE MulTerm (p, term: Polynom; VAR r: Polynom); (* multiply a polynomial with a single term; is used by MulPolynom *) VAR - tmp : Polynom; - last : Polynom; + tmp : Polynom; + last : Polynom; (* add two exponent vetors; addition is modulo M *) PROCEDURE AddExp (exp1, exp2 : Exponent; VAR res: Exponent); - VAR - i : SHORTINT; + VAR + i : SHORTINT; BEGIN - i := 0; - WHILE i 0 DO - IF (exp MOD 2) = 1 THEN - MulPolynom(res, tmp, res); - END; - MulPolynom(tmp, tmp, tmp); - exp := exp DIV 2; + IF (exp MOD 2) = 1 THEN + MulPolynom(res, tmp, res); + END; + MulPolynom(tmp, tmp, tmp); + exp := exp DIV 2; END; END InvertPolynom; PROCEDURE EvalPolynom (p: Polynom; VAR res: CCMElement); (* evaluate p; a precomputed list of all the powers of the argument can - be found in the global variable PreEvalArg *) + be found in the global variable PreEvalArg *) VAR - i : SHORTINT; - pow, prod : CCMElement; + i : SHORTINT; + pow, prod : CCMElement; BEGIN res := NullCCM; IF p = NIL THEN - RETURN; + RETURN; END; WHILE p # NIL DO - prod := PreEvalArg[p.exp[0]].arg[0]; - i := 1; - REPEAT - pow := PreEvalArg[p.exp[i]].arg[i]; - MulCCM(prod, pow, prod); - INC(i); - UNTIL i >= MaxVar; - MulCCM(prod, p.koeff, prod); - AddCCM(res, prod, res); - p := p.next; + prod := PreEvalArg[p.exp[0]].arg[0]; + i := 1; + REPEAT + pow := PreEvalArg[p.exp[i]].arg[i]; + MulCCM(prod, pow, prod); + INC(i); + UNTIL i >= MaxVar; + MulCCM(prod, p.koeff, prod); + AddCCM(res, prod, res); + p := p.next; END; END EvalPolynom; PROCEDURE CreateExp (VAR exp: Exponent); (* creates a random vector of exponents *) VAR - i : SHORTINT; + i : SHORTINT; BEGIN i := 0; WHILE i 0 DO - IF (kk MOD 2) = 1 THEN - MulCCM(tmp, PreEvalArg[ii].arg[i], tmp); - END; - INC(ii,ii); - kk := kk DIV 2; - END; - PreEvalArg[k].arg[i] := tmp; - INC(k); - END; - INC(i); + k := 2; + tmp := arg.arg[i]; + WHILE k < M DO + MulCCM(tmp, tmp, tmp); + PreEvalArg[k].arg[i] := tmp; + INC(k,k); + END; + k := 3; + WHILE k < M DO + kk := k; + ii := 1; + tmp := EinsCCM; + WHILE kk > 0 DO + IF (kk MOD 2) = 1 THEN + MulCCM(tmp, PreEvalArg[ii].arg[i], tmp); + END; + INC(ii,ii); + kk := kk DIV 2; + END; + PreEvalArg[k].arg[i] := tmp; + INC(k); + END; + INC(i); END; END PreComputeArgs; PROCEDURE EvaluatePhi (arg: TCryptInput; data: Phi) : TCryptTmp; (* evaluate the public function phi (represented by data) with - argument arg *) + argument arg *) VAR - res : TCryptTmp; - r, d : SHORTINT; + res : TCryptTmp; + r, d : SHORTINT; BEGIN NEW(res); PreComputeArgs(arg); r := 0; WHILE r < Rounds DO - d := 0; - WHILE d < Dim DO - EvalPolynom(data.num[r][d], res.numerator[r][d]); - INC(d); - END; - EvalPolynom(data.denom[r], res.denominator[r]); - INC(r); + d := 0; + WHILE d < Dim DO + EvalPolynom(data.num[r][d], res.numerator[r][d]); + INC(d); + END; + EvalPolynom(data.denom[r], res.denominator[r]); + INC(r); END; RETURN res; END EvaluatePhi; @@ -1125,12 +1127,12 @@ MODULE ulmTCrypt; (* Michael Szczuka *) PROCEDURE EvaluatePsi (arg: TCryptTmp; data: Psi) : TCryptRes; (* evalute the private function psi *) VAR - res : TCryptRes; - mat, prev : MatCCM; - num, denom, inv : CCMElement; - vek : VektorCCM; - A : ChainCCM; - r, d : SHORTINT; + res : TCryptRes; + mat, prev : MatCCM; + num, denom, inv : CCMElement; + vek : VektorCCM; + A : ChainCCM; + r, d : SHORTINT; BEGIN (* first correct the input with the correlating inverts *) MulCCM(arg.denominator[0], data.korrDenom[0], denom); @@ -1143,28 +1145,28 @@ MODULE ulmTCrypt; (* Michael Szczuka *) prev := data.initialmatrix; r := 1; WHILE r < Rounds DO - (* the matrix for the current round of the recursion must be computed - each round *) - BuildMatrix(mat, prev, A[r-1]); - prev := mat; - MulCCM(arg.denominator[r], data.korrDenom[r], denom); - PowerCCM(denom, M-1, inv); - MulCCM(arg.numerator[r][0], data.korrNum[r][0], num); - MulCCM(num, inv, vek[0]); - MulCCM(arg.numerator[r][1], data.korrNum[r][1], num); - MulCCM(num, inv, vek[1]); - MulMatrix(mat, vek, A[r]); - INC(r); + (* the matrix for the current round of the recursion must be computed + each round *) + BuildMatrix(mat, prev, A[r-1]); + prev := mat; + MulCCM(arg.denominator[r], data.korrDenom[r], denom); + PowerCCM(denom, M-1, inv); + MulCCM(arg.numerator[r][0], data.korrNum[r][0], num); + MulCCM(num, inv, vek[0]); + MulCCM(arg.numerator[r][1], data.korrNum[r][1], num); + MulCCM(num, inv, vek[1]); + MulMatrix(mat, vek, A[r]); + INC(r); END; NEW(res); r := 0; WHILE r < LastRounds DO - d := 0; - WHILE d < Dim DO - res.arg[r][d] := A[Rounds-LastRounds+r][d]; - INC(d); - END; - INC(r); + d := 0; + WHILE d < Dim DO + res.arg[r][d] := A[Rounds-LastRounds+r][d]; + INC(d); + END; + INC(r); END; RETURN res; END EvaluatePsi; @@ -1172,19 +1174,19 @@ MODULE ulmTCrypt; (* Michael Szczuka *) PROCEDURE EvaluateEta (arg: TCryptInput; data: Eta) : TCryptRes; (* evaluate the public function eta (composition of phi and psi) *) VAR - l, d : SHORTINT; - res : TCryptRes; + l, d : SHORTINT; + res : TCryptRes; BEGIN NEW(res); PreComputeArgs(arg); l := 0; WHILE l < LastRounds DO - d := 0; - WHILE d < Dim DO - EvalPolynom(data.p[l][d], res.arg[l][d]); - INC(d); - END; - INC(l); + d := 0; + WHILE d < Dim DO + EvalPolynom(data.p[l][d], res.arg[l][d]); + INC(d); + END; + INC(l); END; RETURN res; END EvaluateEta; @@ -1192,191 +1194,191 @@ MODULE ulmTCrypt; (* Michael Szczuka *) PROCEDURE Eof (s: Streams.Stream) : BOOLEAN; (* returns TRUE if no bytes are left to read from stream s *) VAR - b : SYS.BYTE; + b : SYS.BYTE; BEGIN RETURN ~Streams.ReadByte(s, b) OR ~Streams.Back(s); END Eof; PROCEDURE Encrypt (msg: Streams.Stream; key: Ciphers.Cipher; - length: INTEGER; s: Streams.Stream) : BOOLEAN; + length: INTEGER; s: Streams.Stream) : BOOLEAN; (* interface procedure for Ciphers.Encrypt *) VAR - i, j : SHORTINT; - ccmarg : TCryptInput; - ccmres : TCryptTmp; - wholeStream : BOOLEAN; + i, j : SHORTINT; + ccmarg : TCryptInput; + ccmres : TCryptTmp; + wholeStream : BOOLEAN; BEGIN (* check if the whole stream msg shall be encrypted or only a certain - amount of bytes *) + amount of bytes *) IF length <= 0 THEN - wholeStream := TRUE; + wholeStream := TRUE; ELSE - wholeStream := FALSE + wholeStream := FALSE END; NEW(ccmarg); WHILE ~Eof(msg) & (wholeStream OR (length > 0)) DO - i := 0; - WHILE i < MaxVar DO - IF ~NetIO.ReadSet(msg, ccmarg.arg[i]) THEN - Error(msg, readSetFailed); - RETURN FALSE; - END; - IF ~RegulaerCCM(ccmarg.arg[i]) THEN - Error(msg, notRegular); - RETURN FALSE; - END; - INC(i); - END; - IF key IS PublicCipher THEN - ccmres := EvaluatePhi(ccmarg, key(PublicCipher).phi); - ELSE - ccmres := EvaluatePhi(ccmarg, key(PrivateCipher).phi); - END; - i := 0; - WHILE i < Rounds DO - j := 0; - WHILE j < Dim DO - IF ~NetIO.WriteSet(s, ccmres.numerator[i][j]) THEN - Error(s, writeSetFailed); - RETURN FALSE; - END; - INC(j); - END; - IF ~NetIO.WriteSet(s, ccmres.denominator[i]) THEN - Error(s, writeSetFailed); - RETURN FALSE; - END; - INC(i); - END; - DEC(length, MaxVar*(M DIV 8)); + i := 0; + WHILE i < MaxVar DO + IF ~NetIO.ReadSet(msg, ccmarg.arg[i]) THEN + Error(msg, readSetFailed); + RETURN FALSE; + END; + IF ~RegulaerCCM(ccmarg.arg[i]) THEN + Error(msg, notRegular); + RETURN FALSE; + END; + INC(i); + END; + IF key IS PublicCipher THEN + ccmres := EvaluatePhi(ccmarg, key(PublicCipher).phi); + ELSE + ccmres := EvaluatePhi(ccmarg, key(PrivateCipher).phi); + END; + i := 0; + WHILE i < Rounds DO + j := 0; + WHILE j < Dim DO + IF ~NetIO.WriteSet(s, ccmres.numerator[i][j]) THEN + Error(s, writeSetFailed); + RETURN FALSE; + END; + INC(j); + END; + IF ~NetIO.WriteSet(s, ccmres.denominator[i]) THEN + Error(s, writeSetFailed); + RETURN FALSE; + END; + INC(i); + END; + DEC(length, MaxVar*(M DIV 8)); END; RETURN TRUE; END Encrypt; PROCEDURE Decrypt (msg: Streams.Stream; key: Ciphers.Cipher; - length: INTEGER; s: Streams.Stream) : BOOLEAN; + length: INTEGER; s: Streams.Stream) : BOOLEAN; (* interface procedure for Ciphers.Decrypt *) VAR - i, j : SHORTINT; - inNum, inDenom, out : ARRAY (M DIV 8) OF SYS.BYTE; - ccmarg : TCryptTmp; - ccmres : TCryptRes; - wholeStream : BOOLEAN; + i, j : SHORTINT; + inNum, inDenom, out : ARRAY (M DIV 8) OF SYS.BYTE; + ccmarg : TCryptTmp; + ccmres : TCryptRes; + wholeStream : BOOLEAN; BEGIN IF length < 0 THEN - wholeStream := TRUE; + wholeStream := TRUE; ELSE - wholeStream := FALSE; + wholeStream := FALSE; END; WITH key:PrivateCipher DO - NEW(ccmarg); - WHILE ~Eof(msg) & (wholeStream OR (length > 0)) DO - i := 0; - WHILE i < Rounds DO - j := 0; - WHILE j < Dim DO - IF ~NetIO.ReadSet(msg, ccmarg.numerator[i][j]) THEN - Error(msg, readSetFailed); - RETURN FALSE; - END; - INC(j); - END; - IF ~NetIO.ReadSet(msg, ccmarg.denominator[i]) THEN - Error(msg, readSetFailed); - RETURN FALSE; - END; - INC(i); - END; - ccmres := EvaluatePsi(ccmarg, key.psi); - i := 0; - WHILE i < LastRounds DO - j := 0; - WHILE j < Dim DO - IF ~NetIO.WriteSet(s, ccmres.arg[i][j]) THEN - Error(s, writeSetFailed); - RETURN FALSE; - END; - INC(j); - END; - INC(i); - END; - DEC (length, Rounds*Dim*(M DIV 8)); - END; + NEW(ccmarg); + WHILE ~Eof(msg) & (wholeStream OR (length > 0)) DO + i := 0; + WHILE i < Rounds DO + j := 0; + WHILE j < Dim DO + IF ~NetIO.ReadSet(msg, ccmarg.numerator[i][j]) THEN + Error(msg, readSetFailed); + RETURN FALSE; + END; + INC(j); + END; + IF ~NetIO.ReadSet(msg, ccmarg.denominator[i]) THEN + Error(msg, readSetFailed); + RETURN FALSE; + END; + INC(i); + END; + ccmres := EvaluatePsi(ccmarg, key.psi); + i := 0; + WHILE i < LastRounds DO + j := 0; + WHILE j < Dim DO + IF ~NetIO.WriteSet(s, ccmres.arg[i][j]) THEN + Error(s, writeSetFailed); + RETURN FALSE; + END; + INC(j); + END; + INC(i); + END; + DEC (length, Rounds*Dim*(M DIV 8)); + END; END; RETURN TRUE; END Decrypt; PROCEDURE ComposedEncrypt (msg: Streams.Stream; key: Ciphers.Cipher; - length: INTEGER; s: Streams.Stream) : BOOLEAN; + length: INTEGER; s: Streams.Stream) : BOOLEAN; (* interface procedure for AsymmetricCiphers.ComposedEncrypt *) VAR - i, j : SHORTINT; - ccmarg : TCryptInput; - ccmres : TCryptRes; - in, out : ARRAY (M DIV 8) OF SYS.BYTE; - wholeStream : BOOLEAN; + i, j : SHORTINT; + ccmarg : TCryptInput; + ccmres : TCryptRes; + in, out : ARRAY (M DIV 8) OF SYS.BYTE; + wholeStream : BOOLEAN; BEGIN IF length < 0 THEN - wholeStream := TRUE; + wholeStream := TRUE; ELSE - wholeStream := FALSE; + wholeStream := FALSE; END; NEW(ccmarg); WHILE ~Eof(msg) & (wholeStream OR (length > 0)) DO - i := 0; - WHILE i < MaxVar DO - IF ~NetIO.ReadSet(msg, ccmarg.arg[i]) THEN - Error(msg, readSetFailed); - RETURN FALSE; - END; - INC(i); - END; - IF key IS PublicCipher THEN - ccmres := EvaluateEta(ccmarg, key(PublicCipher).eta); - ELSE - ccmres := EvaluateEta(ccmarg, key(PrivateCipher).eta); - END; - i := 0; - WHILE i < LastRounds DO - j := 0; - WHILE j < Dim DO - IF ~NetIO.WriteSet(s, ccmres.arg[i][j]) THEN - Error(s, writeSetFailed); - RETURN FALSE; - END; - INC(j); - END; - INC(i); - END; - DEC (length, MaxVar*(M DIV 8)); + i := 0; + WHILE i < MaxVar DO + IF ~NetIO.ReadSet(msg, ccmarg.arg[i]) THEN + Error(msg, readSetFailed); + RETURN FALSE; + END; + INC(i); + END; + IF key IS PublicCipher THEN + ccmres := EvaluateEta(ccmarg, key(PublicCipher).eta); + ELSE + ccmres := EvaluateEta(ccmarg, key(PrivateCipher).eta); + END; + i := 0; + WHILE i < LastRounds DO + j := 0; + WHILE j < Dim DO + IF ~NetIO.WriteSet(s, ccmres.arg[i][j]) THEN + Error(s, writeSetFailed); + RETURN FALSE; + END; + INC(j); + END; + INC(i); + END; + DEC (length, MaxVar*(M DIV 8)); END; RETURN TRUE; END ComposedEncrypt; PROCEDURE RandomStream (s: Streams.Stream); (* writes some random elements of CC(M) to the stream s which can then - be used as an input for Trautner's TCRYPT *) + be used as an input for Trautner's TCRYPT *) VAR - ccm : CCMElement; - bytes : ARRAY M DIV 8 OF SYS.BYTE; - i : INTEGER; + ccm : CCMElement; + bytes : ARRAY M DIV 8 OF SYS.BYTE; + i : INTEGER; BEGIN i := 0; WHILE i < MaxVar DO - CreateCCM(ccm, reg); - IF ~NetIO.WriteSet(s, ccm) THEN - Error(s, writeSetFailed); - END; - INC(i); + CreateCCM(ccm, reg); + IF ~NetIO.WriteSet(s, ccm) THEN + Error(s, writeSetFailed); + END; + INC(i); END; END RandomStream; PROCEDURE PublicCipherCreate (VAR obj: PersistentObjects.Object); (* constructor for a public cipher *) VAR - pub : PublicCipher; - if : AsymmetricCiphers.Interface; - caps : AsymmetricCiphers.CapabilitySet; + pub : PublicCipher; + if : AsymmetricCiphers.Interface; + caps : AsymmetricCiphers.CapabilitySet; BEGIN NEW(pub); NEW(pub.phi); NEW(pub.eta); PersistentObjects.Init(pub, pubType); @@ -1389,25 +1391,25 @@ MODULE ulmTCrypt; (* Michael Szczuka *) END PublicCipherCreate; PROCEDURE Split (VAR public: AsymmetricCiphers.Cipher; - key: AsymmetricCiphers.Cipher); + key: AsymmetricCiphers.Cipher); (* interface procedure for asymmetric interface *) VAR - pub: PublicCipher; + pub: PublicCipher; BEGIN WITH key:PrivateCipher DO - PublicCipherCreate(SYS.VAL(PersistentObjects.Object, pub)); - pub.phi := key.phi; - pub.eta := key.eta; - public := pub; + PublicCipherCreate(SYS.VAL(PersistentObjects.Object, pub)); + pub.phi := key.phi; + pub.eta := key.eta; + public := pub; END; END Split; PROCEDURE CipherCreate (VAR obj: PersistentObjects.Object); (* constructor for a private cipher *) VAR - key : PrivateCipher; - if : AsymmetricCiphers.Interface; - caps : AsymmetricCiphers.CapabilitySet; + key : PrivateCipher; + if : AsymmetricCiphers.Interface; + caps : AsymmetricCiphers.CapabilitySet; BEGIN NEW(key); NEW(key.phi); NEW(key.psi); NEW(key.eta); PersistentObjects.Init(key, privType); @@ -1422,10 +1424,10 @@ MODULE ulmTCrypt; (* Michael Szczuka *) PROCEDURE Create* (VAR key: Ciphers.Cipher); (* creates a cipher for the use with Trautner's TCRYPT algorithm *) VAR - tmpKey : PrivateCipher; - phi : Phi; - psi : Psi; - eta : Eta; + tmpKey : PrivateCipher; + phi : Phi; + psi : Psi; + eta : Eta; BEGIN CipherCreate(SYS.VAL(PersistentObjects.Object, tmpKey)); CreateMaps(tmpKey.phi, tmpKey.psi, tmpKey.eta); @@ -1435,28 +1437,28 @@ MODULE ulmTCrypt; (* Michael Szczuka *) PROCEDURE WritePolynom (s: Streams.Stream; p: Polynom) : BOOLEAN; (* writes the polynomial p onto the stream s *) CONST - index = M DIV 8; + index = M DIV 8; VAR - nrOfTerms, i : INTEGER; - bytes : ARRAY index OF SYS.BYTE; + nrOfTerms, i : INTEGER; + bytes : ARRAY index OF SYS.BYTE; BEGIN nrOfTerms := LengthPolynom(p); IF ~NetIO.WriteInteger(s, nrOfTerms) THEN - RETURN FALSE; + RETURN FALSE; END; WHILE nrOfTerms > 0 DO - IF ~NetIO.WriteSet(s, p.koeff) THEN - RETURN FALSE; - END; - i := 0; - WHILE i < MaxVar DO - IF ~NetIO.WriteShortInt(s, p.exp[i]) THEN - RETURN FALSE; - END; - INC(i); - END; - p := p.next; - DEC(nrOfTerms); + IF ~NetIO.WriteSet(s, p.koeff) THEN + RETURN FALSE; + END; + i := 0; + WHILE i < MaxVar DO + IF ~NetIO.WriteShortInt(s, p.exp[i]) THEN + RETURN FALSE; + END; + INC(i); + END; + p := p.next; + DEC(nrOfTerms); END; RETURN TRUE; END WritePolynom; @@ -1464,33 +1466,33 @@ MODULE ulmTCrypt; (* Michael Szczuka *) PROCEDURE ReadPolynom (s: Streams.Stream; VAR p: Polynom) : BOOLEAN; (* reads a polynomial from stream s *) CONST - index = M DIV 8; + index = M DIV 8; VAR - nrOfTerms, i : INTEGER; - pol : Polynom; - bytes : ARRAY index OF SYS.BYTE; + nrOfTerms, i : INTEGER; + pol : Polynom; + bytes : ARRAY index OF SYS.BYTE; BEGIN IF ~NetIO.ReadInteger(s, nrOfTerms) THEN - RETURN FALSE; + RETURN FALSE; END; NEW(p); pol := p; WHILE nrOfTerms > 0 DO - IF ~NetIO.ReadSet(s, pol.koeff) THEN - RETURN FALSE; - END; - i := 0; - WHILE i < MaxVar DO - IF ~NetIO.ReadShortInt(s, pol.exp[i]) THEN - RETURN FALSE; - END; - INC(i); - END; - DEC(nrOfTerms); - IF nrOfTerms > 0 THEN - NEW(pol.next); - pol := pol.next; - END + IF ~NetIO.ReadSet(s, pol.koeff) THEN + RETURN FALSE; + END; + i := 0; + WHILE i < MaxVar DO + IF ~NetIO.ReadShortInt(s, pol.exp[i]) THEN + RETURN FALSE; + END; + INC(i); + END; + DEC(nrOfTerms); + IF nrOfTerms > 0 THEN + NEW(pol.next); + pol := pol.next; + END END; RETURN TRUE; END ReadPolynom; @@ -1498,21 +1500,21 @@ MODULE ulmTCrypt; (* Michael Szczuka *) PROCEDURE PhiWrite (s: Streams.Stream; data: Phi) : BOOLEAN; (* writes the data structure for the public function phi onto a stream *) VAR - r, d, k : INTEGER; + r, d, k : INTEGER; BEGIN r := 0; WHILE r < Rounds DO - d := 0; - WHILE d < Dim DO - IF ~WritePolynom(s, data.num[r][d]) THEN - RETURN FALSE; - END; - INC(d); - END; - IF ~WritePolynom(s, data.denom[r]) THEN - RETURN FALSE; - END; - INC(r); + d := 0; + WHILE d < Dim DO + IF ~WritePolynom(s, data.num[r][d]) THEN + RETURN FALSE; + END; + INC(d); + END; + IF ~WritePolynom(s, data.denom[r]) THEN + RETURN FALSE; + END; + INC(r); END; RETURN TRUE; END PhiWrite; @@ -1520,22 +1522,22 @@ MODULE ulmTCrypt; (* Michael Szczuka *) PROCEDURE PhiRead (s: Streams.Stream; VAR data: Phi) : BOOLEAN; (* reads the data structure for the public function phi from a stream *) VAR - r, d, k : INTEGER; + r, d, k : INTEGER; BEGIN NEW(data); r := 0; WHILE r < Rounds DO - d := 0; - WHILE d < Dim DO - IF ~ReadPolynom(s, data.num[r][d]) THEN - RETURN FALSE; - END; - INC(d); - END; - IF ~ReadPolynom(s, data.denom[r]) THEN - RETURN FALSE; - END; - INC(r); + d := 0; + WHILE d < Dim DO + IF ~ReadPolynom(s, data.num[r][d]) THEN + RETURN FALSE; + END; + INC(d); + END; + IF ~ReadPolynom(s, data.denom[r]) THEN + RETURN FALSE; + END; + INC(r); END; RETURN TRUE; END PhiRead; @@ -1543,35 +1545,35 @@ MODULE ulmTCrypt; (* Michael Szczuka *) PROCEDURE PsiWrite (s: Streams.Stream; data: Psi) : BOOLEAN; (* writes the data structure for the private function psi onto a stream *) CONST - index = M DIV 8; + index = M DIV 8; VAR - dx, dy, r, d : INTEGER; - bytes : ARRAY index OF SYS.BYTE; + dx, dy, r, d : INTEGER; + bytes : ARRAY index OF SYS.BYTE; BEGIN dy := 0; WHILE dy < Dim DO - dx := 0; - WHILE dx < Dim DO - IF ~NetIO.WriteSet(s, data.initialmatrix[dy][dx]) THEN - RETURN FALSE; - END; - INC(dx); - END; - INC(dy); + dx := 0; + WHILE dx < Dim DO + IF ~NetIO.WriteSet(s, data.initialmatrix[dy][dx]) THEN + RETURN FALSE; + END; + INC(dx); + END; + INC(dy); END; r := 0; WHILE r < Rounds DO - d := 0; - WHILE d < Dim DO - IF ~NetIO.WriteSet(s, data.korrNum[r][d]) THEN - RETURN FALSE; - END; - INC(d); - END; - IF ~NetIO.WriteSet(s, data.korrDenom[r]) THEN - RETURN FALSE; - END; - INC(r); + d := 0; + WHILE d < Dim DO + IF ~NetIO.WriteSet(s, data.korrNum[r][d]) THEN + RETURN FALSE; + END; + INC(d); + END; + IF ~NetIO.WriteSet(s, data.korrDenom[r]) THEN + RETURN FALSE; + END; + INC(r); END; RETURN TRUE; END PsiWrite; @@ -1579,35 +1581,35 @@ MODULE ulmTCrypt; (* Michael Szczuka *) PROCEDURE PsiRead (s: Streams.Stream; VAR data: Psi) : BOOLEAN; (* reads the data structure for the private function psi from a stream *) CONST - index = M DIV 8; + index = M DIV 8; VAR - dy, dx, r, d : INTEGER; - bytes : ARRAY index OF SYS.BYTE; + dy, dx, r, d : INTEGER; + bytes : ARRAY index OF SYS.BYTE; BEGIN dy := 0; WHILE dy < Dim DO - dx := 0; - WHILE dx < Dim DO - IF ~NetIO.ReadSet(s, data.initialmatrix[dy][dx]) THEN - RETURN FALSE; - END; - INC(dx); - END; - INC(dy); + dx := 0; + WHILE dx < Dim DO + IF ~NetIO.ReadSet(s, data.initialmatrix[dy][dx]) THEN + RETURN FALSE; + END; + INC(dx); + END; + INC(dy); END; r := 0; WHILE r < Rounds DO - d := 0; - WHILE d < Dim DO - IF ~NetIO.ReadSet(s, data.korrNum[r][d]) THEN - RETURN FALSE; - END; - INC(d); - END; - IF ~NetIO.ReadSet(s, data.korrDenom[r]) THEN - RETURN FALSE; - END; - INC(r); + d := 0; + WHILE d < Dim DO + IF ~NetIO.ReadSet(s, data.korrNum[r][d]) THEN + RETURN FALSE; + END; + INC(d); + END; + IF ~NetIO.ReadSet(s, data.korrDenom[r]) THEN + RETURN FALSE; + END; + INC(r); END; RETURN TRUE; END PsiRead; @@ -1615,18 +1617,18 @@ MODULE ulmTCrypt; (* Michael Szczuka *) PROCEDURE EtaWrite (s: Streams.Stream; data: Eta) : BOOLEAN; (* writes the data structure for the public function eta onto a stream *) VAR - l, d : INTEGER; + l, d : INTEGER; BEGIN l := 0; WHILE l < LastRounds DO - d := 0; - WHILE d < Dim DO - IF ~WritePolynom(s, data.p[l][d]) THEN - RETURN FALSE; - END; - INC(d); - END; - INC(l); + d := 0; + WHILE d < Dim DO + IF ~WritePolynom(s, data.p[l][d]) THEN + RETURN FALSE; + END; + INC(d); + END; + INC(l); END; RETURN TRUE; END EtaWrite; @@ -1634,19 +1636,19 @@ MODULE ulmTCrypt; (* Michael Szczuka *) PROCEDURE EtaRead (s: Streams.Stream; VAR data: Eta) : BOOLEAN; (* reads the data structure for the public function eta from a stream *) VAR - l, d : INTEGER; + l, d : INTEGER; BEGIN NEW(data); l := 0; WHILE l < LastRounds DO - d := 0; - WHILE d < Dim DO - IF ~ReadPolynom(s, data.p[l][d]) THEN - RETURN FALSE; - END; - INC(d); - END; - INC(l); + d := 0; + WHILE d < Dim DO + IF ~ReadPolynom(s, data.p[l][d]) THEN + RETURN FALSE; + END; + INC(d); + END; + INC(l); END; RETURN TRUE; END EtaRead; @@ -1656,7 +1658,7 @@ MODULE ulmTCrypt; (* Michael Szczuka *) (* interface procedure for PersistentObjects *) BEGIN WITH obj:PublicCipher DO - RETURN PhiWrite(s, obj.phi) & EtaWrite(s, obj.eta); + RETURN PhiWrite(s, obj.phi) & EtaWrite(s, obj.eta); END; END PubWrite; @@ -1665,9 +1667,9 @@ MODULE ulmTCrypt; (* Michael Szczuka *) (* interface procedure for PersistentObjects *) BEGIN WITH obj:PrivateCipher DO - RETURN PhiWrite(s, obj.phi) & - PsiWrite(s, obj.psi) & - EtaWrite(s, obj.eta); + RETURN PhiWrite(s, obj.phi) & + PsiWrite(s, obj.psi) & + EtaWrite(s, obj.eta); END; END CipherWrite; @@ -1676,23 +1678,23 @@ MODULE ulmTCrypt; (* Michael Szczuka *) (* interface procedure for PersistentObjects *) BEGIN WITH obj:PublicCipher DO - IF ~PhiRead(s, obj.phi) OR ~EtaRead(s, obj.eta) THEN - RETURN FALSE; - END; + IF ~PhiRead(s, obj.phi) OR ~EtaRead(s, obj.eta) THEN + RETURN FALSE; + END; END; RETURN TRUE; END PubRead; PROCEDURE CipherRead (s: Streams.Stream; - obj: PersistentObjects.Object) : BOOLEAN; + obj: PersistentObjects.Object) : BOOLEAN; (* interface procedure for PersistentObjects *) BEGIN WITH obj:PrivateCipher DO - IF ~PhiRead(s, obj.phi) OR - ~PsiRead(s, obj.psi) OR - ~EtaRead(s, obj.eta) THEN - RETURN FALSE; - END; + IF ~PhiRead(s, obj.phi) OR + ~PsiRead(s, obj.psi) OR + ~EtaRead(s, obj.eta) THEN + RETURN FALSE; + END; END; RETURN TRUE; END CipherRead; @@ -1724,15 +1726,15 @@ BEGIN (* init of the zero polynomial *) NEW(NullPolynom); - NullPolynom.koeff := NullCCM; (* Koeffizient = Null *) - NullPolynom.exp := NullExp; (* alle Exponenten = Null *) - NullPolynom.next := NIL; (* nur ein Term *) + NullPolynom.koeff := NullCCM; (* Koeffizient = Null *) + NullPolynom.exp := NullExp; (* alle Exponenten = Null *) + NullPolynom.next := NIL; (* nur ein Term *) k := 0; WHILE k < M DO NEW(PreEvalArg[k]); IF k < MaxVar THEN - PreEvalArg[0].arg[k] := EinsCCM; + PreEvalArg[0].arg[k] := EinsCCM; END; INC(k); END; @@ -1740,7 +1742,7 @@ BEGIN (* no interface needed for cipherType since it serves only as a common type for public and private ciphers *) PersistentObjects.RegisterType(cipherType, "TCrypt.Cipher", - "AsymmetricCiphers.Cipher", NIL); + "AsymmetricCiphers.Cipher", NIL); NEW(pubIf); pubIf.create := PublicCipherCreate; @@ -1748,7 +1750,7 @@ BEGIN pubIf.read := PubRead; pubIf.createAndRead := NIL; PersistentObjects.RegisterType(pubType, "TCrypt.PublicCipher", - "TCrypt.Cipher", pubIf); + "TCrypt.Cipher", pubIf); NEW(privIf); privIf.create := CipherCreate; @@ -1756,7 +1758,7 @@ BEGIN privIf.read := CipherRead; privIf.createAndRead := NIL; PersistentObjects.RegisterType(privType, "TCrypt.PrivateCipher", - "TCrypt.Cipher", privIf); + "TCrypt.Cipher", privIf); InitErrorHandling; END ulmTCrypt. diff --git a/src/library/ulm/ulmTexts.Mod b/src/library/ulm/ulmTexts.Mod index a4214fcd..76590258 100644 --- a/src/library/ulm/ulmTexts.Mod +++ b/src/library/ulm/ulmTexts.Mod @@ -229,6 +229,7 @@ MODULE ulmTexts; | Streams.fromStart: pos := count; | Streams.fromPos: pos := count + s.pos; | Streams.fromEnd: pos := count + s.len; + ELSE END; IF (pos >= 0) & (pos <= s.len) THEN s.pos := pos; diff --git a/src/library/ulm/ulmTimes.Mod b/src/library/ulm/ulmTimes.Mod index 00f0cd0c..e7dc122f 100644 --- a/src/library/ulm/ulmTimes.Mod +++ b/src/library/ulm/ulmTimes.Mod @@ -200,6 +200,7 @@ MODULE ulmTimes; | epochUnit: value := measure.timeval.epoch; | secondUnit: value := measure.timeval.second; | usecUnit: value := measure.timeval.usec; + ELSE END; END; END; END InternalGetValue; @@ -212,6 +213,7 @@ MODULE ulmTimes; | epochUnit: measure.timeval.epoch := value; | secondUnit: measure.timeval.second := value; | usecUnit: measure.timeval.usec := value; + ELSE END; Normalize(measure.timeval); END; END; @@ -274,6 +276,7 @@ MODULE ulmTimes; CASE op OF | Scales.add: Add(op1.timeval, op2.timeval, result.timeval); | Scales.sub: Sub(op1.timeval, op2.timeval, result.timeval); + ELSE END; END; END; END; @@ -283,25 +286,28 @@ MODULE ulmTimes; PROCEDURE ReturnVal(val1, val2: Scales.Value) : INTEGER; BEGIN - IF val1 < val2 THEN - RETURN -1 - ELSIF val1 > val2 THEN - RETURN 1 - ELSE - RETURN 0 - END; + IF val1 < val2 THEN + RETURN -1 + ELSIF val1 > val2 THEN + RETURN 1 + ELSE + RETURN 0 + END; END ReturnVal; BEGIN - WITH op1: ReferenceTime DO WITH op2: ReferenceTime DO - IF op1.timeval.epoch # op2.timeval.epoch THEN - RETURN ReturnVal(op1.timeval.epoch, op2.timeval.epoch) - ELSIF op1.timeval.second # op2.timeval.second THEN - RETURN ReturnVal(op1.timeval.second, op2.timeval.second) - ELSE - RETURN ReturnVal(op1.timeval.usec, op2.timeval.usec) - END; - END; END; + WITH op1: ReferenceTime DO + WITH op2: ReferenceTime DO + IF op1.timeval.epoch # op2.timeval.epoch THEN + RETURN ReturnVal(op1.timeval.epoch, op2.timeval.epoch) + ELSIF op1.timeval.second # op2.timeval.second THEN + RETURN ReturnVal(op1.timeval.second, op2.timeval.second) + ELSE + RETURN ReturnVal(op1.timeval.usec, op2.timeval.usec) + END; + END; + END; + RETURN 0; END Compare; (* ========= initialization procedures ========================== *) diff --git a/src/library/ulm/ulmTypes.Mod b/src/library/ulm/ulmTypes.Mod index d46a2c63..c9d6f4fe 100644 --- a/src/library/ulm/ulmTypes.Mod +++ b/src/library/ulm/ulmTypes.Mod @@ -50,34 +50,32 @@ MODULE ulmTypes; IMPORT SYS := SYSTEM; TYPE - Address* = (*SYS.PTR*) LONGINT (*SYS.ADDRESS*); + Address* = LONGINT (*SYS.ADDRESS*); (* ulm compiler can accept VAR p : SYSTEM.ADDRESS; // SYSTEM.PTR in ETH and V4 versions - ... - p := SYSTEM.ADR(something); - and this is how it is used in ulm oberon system library, - while SYSTEM.ADR returns LONGINT in ETH and V4 versions. - Thus I leave it as LONGINT for now, before coming up with better solution -- noch *) - UntracedAddress* = POINTER[1] TO UntracedAddressDesc; (*SYS.UNTRACEDADDRESS;*) + ... + p := SYSTEM.ADR(something); + and this is how it is used in ulm oberon system library, + while SYSTEM.ADR returns LONGINT in ETH and V4 versions. + Thus I leave it as LONGINT for now, before coming up with better solution -- noch *) + + UntracedAddress* = POINTER[1] TO UntracedAddressDesc; (*SYS.UNTRACEDADDRESS;*) UntracedAddressDesc* = RECORD[1] END; - - intarr64 = ARRAY 8 OF SYS.BYTE; (* to emulate int16 on x86_64; -- noch *) - intarr16 = ARRAY 2 OF SYS.BYTE; - - Count* = LONGINT; - Size* = Count; - Byte* = SYS.BYTE; + + Count* = LONGINT; + Size* = Count; + Byte* = SYS.BYTE; IntAddress* = LONGINT; - Int8* = SHORTINT; - Int16* = intarr16(*INTEGER*); (* we don't have 16 bit integer in x86_64 version of voc *) - Int32* = INTEGER; - Real32* = REAL; - Real64* = LONGREAL; + Int8* = SHORTINT; + Int16* = INTEGER; (* No real 16 bit integer type *) + Int32* = INTEGER; + Real32* = REAL; + Real64* = LONGREAL; CONST - bigEndian* = 0; (* SPARC, M68K etc *) + bigEndian* = 0; (* SPARC, M68K etc *) littleEndian* = 1; (* Intel 80x86, VAX etc *) - byteorder* = littleEndian; (* machine-dependent constant *) + byteorder* = littleEndian; (* machine-dependent constant *) TYPE ByteOrder* = SHORTINT; (* bigEndian or littleEndian *) @@ -93,21 +91,17 @@ MODULE ulmTypes; PROCEDURE ToInt8*(int: LONGINT) : Int8; BEGIN - RETURN SHORT(SHORT(int)) + RETURN SYS.VAL(SHORTINT, int) END ToInt8; - PROCEDURE ToInt16*(int: LONGINT; VAR int16: Int16)(* : Int16*); - VAR longintarr : intarr64; + PROCEDURE ToInt16*(int: LONGINT) : Int16; BEGIN - (*RETURN SYS.VAL(Int16, int)*) - longintarr := SYS.VAL(intarr64, int); - int16[0] := longintarr[0]; - int16[1] := longintarr[1]; (* this will work for little endian -- noch *) + RETURN SYS.VAL(Int16, int) END ToInt16; PROCEDURE ToInt32*(int: LONGINT) : Int32; BEGIN - RETURN SHORT(int) + RETURN SYS.VAL(INTEGER, int) END ToInt32; PROCEDURE ToReal32*(real: LONGREAL) : Real32; diff --git a/src/library/v4/Args.Mod b/src/library/v4/Args.Mod index 2c0d25b5..0d4ff925 100644 --- a/src/library/v4/Args.Mod +++ b/src/library/v4/Args.Mod @@ -3,63 +3,29 @@ MODULE Args; (* jt, 8.12.94 *) (* command line argument handling for voc (jet backend) *) - IMPORT SYSTEM; - + IMPORT Platform; + TYPE ArgPtr = POINTER TO ARRAY 1024 OF CHAR; ArgVec = POINTER TO ARRAY 1024 OF ArgPtr; - VAR argc-: INTEGER; argv-: LONGINT; - (*PROCEDURE -includestdlib() "#include ";*) - PROCEDURE -externgetenv() "extern char *getenv(const char *name);"; (* took this from stdlib.h*) - PROCEDURE -Argc(): INTEGER "SYSTEM_argc"; - PROCEDURE -Argv(): LONGINT "(long)SYSTEM_argv"; - PROCEDURE -getenv(var: ARRAY OF CHAR): ArgPtr - "(Args_ArgPtr)getenv(var)"; + VAR + argc-: LONGINT; + argv-: LONGINT; - PROCEDURE Get*(n: INTEGER; VAR val: ARRAY OF CHAR); - VAR av: ArgVec; - BEGIN - IF n < argc THEN av := SYSTEM.VAL(ArgVec, argv); COPY(av[n]^, val) END - END Get; - PROCEDURE GetInt*(n: INTEGER; VAR val: LONGINT); - VAR s: ARRAY 64 OF CHAR; k, d, i: LONGINT; - BEGIN - s := ""; Get(n, s); i := 0; - IF s[0] = "-" THEN i := 1 END ; - k := 0; d := ORD(s[i]) - ORD("0"); - WHILE (d >= 0 ) & (d <= 9) DO k := k*10 + d; INC(i); d := ORD(s[i]) - ORD("0") END ; - IF s[0] = "-" THEN d := -d; DEC(i) END ; - IF i > 0 THEN val := k END - END GetInt; +PROCEDURE Get* (n: INTEGER; VAR val: ARRAY OF CHAR); BEGIN Platform.GetArg(n, val) END Get; +PROCEDURE GetInt*(n: INTEGER; VAR val: LONGINT); BEGIN Platform.GetIntArg(n, val) END GetInt; +PROCEDURE Pos* (s: ARRAY OF CHAR): INTEGER; BEGIN RETURN Platform.ArgPos(s) END Pos; - PROCEDURE Pos*(s: ARRAY OF CHAR): INTEGER; - VAR i: INTEGER; arg: ARRAY 256 OF CHAR; - BEGIN - i := 0; Get(i, arg); - WHILE (i < argc) & (s # arg) DO INC(i); Get(i, arg) END ; - RETURN i - END Pos; +PROCEDURE GetEnv*(var: ARRAY OF CHAR; VAR val: ARRAY OF CHAR); +BEGIN Platform.GetEnv(var, val) END GetEnv; - PROCEDURE GetEnv*(var: ARRAY OF CHAR; VAR val: ARRAY OF CHAR); - VAR p: ArgPtr; - BEGIN - p := getenv(var); - IF p # NIL THEN COPY(p^, val) END - END GetEnv; +PROCEDURE getEnv*(var: ARRAY OF CHAR; VAR val: ARRAY OF CHAR): BOOLEAN; +BEGIN RETURN Platform.getEnv(var, val) END getEnv; - PROCEDURE getEnv*(var: ARRAY OF CHAR; VAR val: ARRAY OF CHAR): BOOLEAN; - VAR p: ArgPtr; - BEGIN - p := getenv(var); - IF p # NIL THEN - COPY(p^, val); - RETURN TRUE - ELSE - RETURN FALSE - END - END getEnv; -BEGIN argc := Argc(); argv := Argv() +BEGIN + argc := Platform.ArgCount; + argv := Platform.ArgVector; END Args. diff --git a/src/library/v4/Modules.Mod b/src/library/v4/Modules.Mod index e73fefac..46c933f5 100644 --- a/src/library/v4/Modules.Mod +++ b/src/library/v4/Modules.Mod @@ -3,7 +3,7 @@ MODULE Modules; (* jt 6.1.96 *) (* access to list of modules and commands, based on ETH Oberon *) - IMPORT SYSTEM, Console; + IMPORT SYSTEM, Console, Heap; CONST ModNameLen* = 20; @@ -37,10 +37,10 @@ MODULE Modules; (* jt 6.1.96 *) PROCEDURE -modules*(): Module - "(Modules_Module)SYSTEM_modules"; + "(Modules_Module)Heap_modules"; PROCEDURE -setmodules*(m: Module) - "SYSTEM_modules = m"; + "Heap_modules = m"; PROCEDURE Append(VAR a: ARRAY OF CHAR; b: ARRAY OF CHAR); diff --git a/src/library/v4/Printer.Mod b/src/library/v4/Printer.Mod index 551db4bc..39b06c0c 100644 --- a/src/library/v4/Printer.Mod +++ b/src/library/v4/Printer.Mod @@ -1,6 +1,6 @@ MODULE Printer; (*UNIX version: JT 11.5.90, RC 2.7.93, JS 29.4.94, JT 14.4.95 *) - IMPORT SYSTEM, Files, Unix, Kernel; + IMPORT SYSTEM, Files, Platform; CONST N = 20; @@ -608,9 +608,6 @@ END; REPEAT ch := s2[j]; s1[i] := ch; INC(i); INC(j) UNTIL ch = 0X END Append; - PROCEDURE -system(cmd: ARRAY OF CHAR) - "system(cmd)"; - PROCEDURE Close*; CONST bufSize = 4*1024; VAR @@ -645,7 +642,7 @@ END; cmd := "lp -c -s "; IF PrinterName # "Pluto" THEN Append(cmd, "-d "); Append(cmd, PrinterName) END ; Append(cmd, " "); Append(cmd, printFileName); - system(cmd); + i := Platform.System(cmd); Files.Delete(printFileName, res); END; Files.Set(bodyR, NIL, 0); diff --git a/src/library/v4/Reals.Mod b/src/library/v4/Reals.Mod index e47d14ae..1c5bfb37 100644 --- a/src/library/v4/Reals.Mod +++ b/src/library/v4/Reals.Mod @@ -2,12 +2,9 @@ MODULE Reals; (* JT, 5.2.90 / RC 9.12.91 conversion between reals and strings for HP-700, MB 9.12.91, JT for Ofront, 16.3. 95*) IMPORT S := SYSTEM; -(* getting rid of ecvt -- noch - PROCEDURE -ecvt (x: LONGREAL; ndigit, decpt, sign: LONGINT): LONGINT - "(LONGINT)ecvt (x, ndigit, decpt, sign)"; -*) + PROCEDURE Ten*(e: INTEGER): REAL; - VAR r, power: LONGREAL; + VAR r, power: LONGREAL; BEGIN r := 1.0; power := 10.0; WHILE e > 0 DO @@ -17,6 +14,7 @@ MODULE Reals; RETURN SHORT(r) END Ten; + PROCEDURE TenL*(e: INTEGER): LONGREAL; VAR r, power: LONGREAL; BEGIN r := 1.0; @@ -29,166 +27,90 @@ MODULE Reals; END END TenL; + PROCEDURE Expo*(x: REAL): INTEGER; BEGIN - RETURN SHORT(ASH(S.VAL(LONGINT, x), -23) MOD 256) + RETURN SHORT(ASH(S.VAL(INTEGER, x), -23) MOD 256) END Expo; + PROCEDURE ExpoL*(x: LONGREAL): INTEGER; - VAR h: LONGINT; + VAR i: INTEGER; l: LONGINT; BEGIN - S.GET(S.ADR(x)+4, h); - RETURN SHORT(ASH(h, -20) MOD 2048) + IF SIZE(INTEGER) = 4 THEN + S.GET(S.ADR(x)+4, i); (* Fetch top 32 bits *) + RETURN SHORT(ASH(i, -20) MOD 2048) + ELSIF SIZE(LONGINT) = 4 THEN + S.GET(S.ADR(x)+4, l); (* Fetch top 32 bits *) + RETURN SHORT(ASH(l, -20) MOD 2048) + ELSE HALT(98) + END END ExpoL; - PROCEDURE SetExpo*(e: INTEGER; VAR x: REAL); - CONST expo = {1..8}; - BEGIN - x := S.VAL(REAL, S.VAL(SET, x) - expo + S.VAL(SET, ASH(LONG(e), 23))) - END SetExpo; - - PROCEDURE SetExpoL*(e: INTEGER; VAR x: LONGREAL); - CONST expo = {1..11}; - VAR h: SET; - BEGIN - S.GET(S.ADR(x)+4, h); - h := h - expo + S.VAL(SET, ASH(LONG(e), 20)); - S.PUT(S.ADR(x)+4, h) - END SetExpoL; - - 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; - (* these functions ⇅ necessary to get rid of ecvt -- noch *) - 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 Convert*(x: REAL; n: INTEGER; VAR d: ARRAY OF CHAR); - VAR i, k: LONGINT; - BEGIN IF x < 0 THEN x := -x END; - i := ENTIER(x); k := 0; + (* Convert LONGREAL: Write positive integer value of x into array d. + The value is stored backwards, i.e. least significant digit + first. n digits are written, with trailing zeros fill. + On entry x has been scaled to the number of digits required. *) + PROCEDURE ConvertL*(x: LONGREAL; n: INTEGER; VAR d: ARRAY OF CHAR); + VAR i, j, k: LONGINT; + BEGIN + IF x < 0 THEN x := -x END; + k := 0; + + IF (SIZE(LONGINT) < 8) & (n > 9) THEN + (* There are more decimal digits than can be held in a single LONGINT *) + i := ENTIER(x / 1000000000.0D0); (* The 10th and higher digits *) + j := ENTIER(x - (i * 1000000000.0D0)); (* The low 9 digits *) + (* First generate the low 9 digits. *) + IF j < 0 THEN j := 0 END; + WHILE k < 9 DO + d[k] := CHR(j MOD 10 + 48); j := j DIV 10; INC(k) + END; + (* Fall through to generate the upper digits *) + ELSE + (* We can generate all the digits in one go. *) + i := ENTIER(x); + END; + WHILE k < n DO d[k] := CHR(i MOD 10 + 48); i := i DIV 10; INC(k) END + END ConvertL; + + + PROCEDURE Convert*(x: REAL; n: INTEGER; VAR d: ARRAY OF CHAR); + BEGIN ConvertL(x, n, d) END Convert; -(* experimental, -- noch - PROCEDURE Convert0*(x: REAL; n: INTEGER; VAR d: ARRAY OF CHAR); - VAR i, j, k: LONGINT; - str : ARRAY 32 OF CHAR; - BEGIN - (* IF x = MIN(LONGREAL) THEN x := MAX(LONGREAL) END;*) - IF x < 0 THEN x := -x END; - i := ENTIER(x); - IF i < 0 THEN i := -i END; - IntToStr(i, str); - IF n >= LEN(d) THEN n := SHORT(LEN(d)) - 1 END; - d[n] := 0X; - j := n - 1 ; - IF j < 0 THEN j := 0 END; - k := 0; - REPEAT - d[j] := str[k]; - DEC(j); - INC(k); - UNTIL (str[k] = 0X) OR (j < 0); - WHILE j >= 0 DO d[j] := "0"; DEC(j) END ; - END Convert0; -*) - (* this seem to work -- noch *) - PROCEDURE ConvertL*(x: LONGREAL; n: INTEGER; VAR d: ARRAY OF CHAR); - VAR i, j, k: LONGINT; - str : ARRAY 32 OF CHAR; + PROCEDURE ToHex(i: INTEGER): CHAR; BEGIN - (* IF x = MIN(LONGREAL) THEN x := MAX(LONGREAL) END;*) - IF x < 0 THEN x := -x END; - i := ENTIER(x); - IF i < 0 THEN i := -i END; - IntToStr(i, str); - IF n >= LEN(d) THEN n := SHORT(LEN(d)) - 1 END; - d[n] := 0X; - j := n - 1 ; - IF j < 0 THEN j := 0 END; - k := 0; - REPEAT - d[j] := str[k]; - DEC(j); - INC(k); - UNTIL (str[k] = 0X) OR (j < 0); + IF i < 10 THEN RETURN CHR(i+48) + ELSE RETURN CHR(i+55) END + END ToHex; - WHILE j >= 0 DO d[j] := "0"; DEC(j) END ; - END ConvertL; -(* getting rid of ecvt -- noch - PROCEDURE ConvertL*(x: LONGREAL; n: INTEGER; VAR d: ARRAY OF CHAR); - VAR decpt, sign: INTEGER; i: LONGINT; buf: LONGINT; - BEGIN - (*x := x - 0.5; already rounded in ecvt*) - buf := ecvt(x, n+2, S.ADR(decpt), S.ADR(sign)); - i := 0; - WHILE i < decpt DO S.GET(buf + i, d[n - i -1]); INC(i) END ; (* showdef was crashing here on oocLowLReal.sym because of ecvt *) - i := n - i - 1; - WHILE i >= 0 DO d[i] := "0"; DEC(i) END ; - END ConvertL; -*) - PROCEDURE Unpack(VAR b, d: ARRAY OF S.BYTE); - VAR i, k: SHORTINT; len: LONGINT; - BEGIN i := 0; len := LEN(b); - WHILE i < len DO - k := SHORT(ORD(S.VAL(CHAR, b[i])) DIV 16); - IF k > 9 THEN d[i*2] := k + 55 ELSE d[i*2] := k + 48 END ; - k := SHORT(ORD(S.VAL(CHAR, b[i])) MOD 16); - IF k > 9 THEN d[i*2+1] := k + 55 ELSE d[i*2+1] := k + 48 END ; - INC(i) + (* Convert Hex *) + PROCEDURE ConvertH*(y: REAL; VAR d: ARRAY OF CHAR); + TYPE pc4 = POINTER TO ARRAY 4 OF CHAR; + VAR p: pc4; i: INTEGER; + BEGIN + p := S.VAL(pc4, S.ADR(y)); i := 0; + WHILE i<4 DO + d[i*2] := ToHex(ORD(p[i]) DIV 16); + d[i*2+1] := ToHex(ORD(p[i]) MOD 16) END - END Unpack; - - PROCEDURE ConvertH* (y: REAL; VAR d: ARRAY OF CHAR); - BEGIN Unpack(y, d) END ConvertH; - PROCEDURE ConvertHL* (x: LONGREAL; VAR d: ARRAY OF CHAR); - BEGIN Unpack(x, d) + (* Convert Hex Long *) + PROCEDURE ConvertHL*(y: LONGREAL; VAR d: ARRAY OF CHAR); + TYPE pc8 = POINTER TO ARRAY 8 OF CHAR; + VAR p: pc8; i: INTEGER; + BEGIN + p := S.VAL(pc8, S.ADR(y)); i := 0; + WHILE i<8 DO + d[i*2] := ToHex(ORD(p[i]) DIV 16); + d[i*2+1] := ToHex(ORD(p[i]) MOD 16) + END END ConvertHL; - + END Reals. diff --git a/src/library/v4/Sets.Mod b/src/library/v4/Sets.Mod index f5251990..3b46f090 100644 --- a/src/library/v4/Sets.Mod +++ b/src/library/v4/Sets.Mod @@ -1,6 +1,6 @@ -MODULE Sets0; +MODULE Sets; -IMPORT Out := Console; +IMPORT Texts; CONST (*size* = 32;*) size* = MAX(SET) + 1; @@ -114,7 +114,7 @@ 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 @@ -133,27 +133,5 @@ BEGIN END ; Texts.Write(f, "}") END Print; -*) -PROCEDURE Write*(s: ARRAY OF SET; w, indent: INTEGER); - VAR col, i, max: INTEGER; -BEGIN - i := 0; col := indent; max := SHORT(LEN(s)) * size; - Out.Char("{"); - WHILE i < max DO - IF In(s, i) THEN - IF col + 4 > w THEN - Out.Ln; - col := 0; WHILE col < indent DO Out.Char(" "); INC(col) END - END ; - Out.Int(i, 3); Out.Char(","); - INC(col, 4) - END ; - INC(i) - END ; - Out.Char("}") -END Write; - - - -END Sets0. +END Sets. diff --git a/src/library/v4/Texts.Mod b/src/library/v4/Texts.Mod index 4d8a3cb3..26b13c81 100644 --- a/src/library/v4/Texts.Mod +++ b/src/library/v4/Texts.Mod @@ -1,9 +1,9 @@ -MODULE Texts0; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91**) (* << RC, MB, JT *) +MODULE Texts; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91**) (* << RC, MB, JT *) IMPORT - Files := Files0, Modules, Reals; + Files, Modules, Reals; (*--- insert field e: Elem into Texts.Scanner and change Texts.Scan to set it in case of class=6 *) - (* this module is for bootstrapping voc, use Texts instead *) + CONST Displaywhite = 15; @@ -12,7 +12,7 @@ MODULE Texts0; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91* (**FileMsg.id**) load* = 0; store* = 1; (**Notifier op**) - replace* = 0; insert* = 1; delete* = 2; + replace* = 0; insert* = 1; delete* = 2; unmark* = 3; (**Scanner.class**) Inval* = 0; Name* = 1; String* = 2; Int* = 3; Real* = 4; LongReal* = 5; Char* = 6; @@ -20,7 +20,7 @@ MODULE Texts0; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91* TYPE FontsFont = POINTER TO FontDesc; - FontDesc = RECORD + FontDesc = RECORD name: ARRAY 32 OF CHAR; END ; @@ -72,8 +72,10 @@ MODULE Texts0; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91* head: Run END; + Notifier* = PROCEDURE (T: Text; op: INTEGER; beg, end: LONGINT); TextDesc* = RECORD len*: LONGINT; + notify*: Notifier; head, cache: Run; corg: LONGINT END; @@ -112,7 +114,7 @@ MODULE Texts0; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91* org, span: LONGINT; mod, proc: ARRAY 32 OF CHAR END; - + VAR new*: Elem; del: Buffer; @@ -200,7 +202,7 @@ MODULE Texts0; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91* PROCEDURE ElemBase* (E: Elem): Text; BEGIN RETURN E.base END ElemBase; - + PROCEDURE ElemPos* (E: Elem): LONGINT; VAR u: Run; pos: LONGINT; BEGIN u := E.base.head.next; pos := 0; @@ -281,6 +283,7 @@ MODULE Texts0; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91* len := B.len; v := B.head.next; Merge(T, u, v); Splice(un, v, B.head.prev, T); INC(T.len, len); B.head.next := B.head; B.head.prev := B.head; B.len := 0; + IF T.notify # NIL THEN T.notify(T, insert, pos, pos+len) END END Insert; PROCEDURE Append* (T: Text; B: Buffer); @@ -288,6 +291,7 @@ MODULE Texts0; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91* BEGIN pos := T.len; len := B.len; v := B.head.next; Merge(T, T.head.prev, v); Splice(T.head, v, B.head.prev, T); INC(T.len, len); B.head.next := B.head; B.head.prev := B.head; B.len := 0; + IF T.notify # NIL THEN T.notify(T, insert, pos, pos+len) END END Append; PROCEDURE Delete* (T: Text; beg, end: LONGINT); @@ -299,6 +303,7 @@ MODULE Texts0; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91* Splice(del.head, un, v, NIL); Merge(T, u, vn); u.next := vn; vn.prev := u; DEC(T.len, end - beg); + IF T.notify # NIL THEN T.notify(T, delete, beg, end) END END Delete; PROCEDURE ChangeLooks* (T: Text; beg, end: LONGINT; sel: SET; fnt: FontsFont; col, voff: SHORTINT); @@ -313,6 +318,7 @@ MODULE Texts0; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91* IF u.next = un THEN u := un; un := un.next ELSE u.next := un; un.prev := u END END; Merge(T, u, un); u.next := un; un.prev := u; + IF T.notify # NIL THEN T.notify(T, replace, beg, end) END END ChangeLooks; @@ -327,23 +333,7 @@ MODULE Texts0; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91* Files.Set(R.rider, u(Piece).file, u(Piece).org + R.off) END END OpenReader; -(* - PROCEDURE Read* (VAR R: Reader; VAR ch: CHAR); - VAR u: Run; - BEGIN u := R.run; R.fnt := u.fnt; R.col := u.col; R.voff := u.voff; INC(R.off); - IF u IS Piece THEN Files.Read(R.rider, ch); R.elem := NIL; - IF (ch = 0AX) & u(Piece).ascii THEN ch := CR END (* << LF to CR *) - ELSIF u IS Elem THEN ch := ElemChar; R.elem := u(Elem) - ELSE ch := 0X; R.elem := NIL; R.eot := TRUE - END; - IF R.off = u.len THEN INC(R.org, u.len); u := u.next; - IF u IS Piece THEN - WITH u: Piece DO Files.Set(R.rider, u.file, u.org) END - END; - R.run := u; R.off := 0 - END - END Read; -*) + PROCEDURE Read* (VAR R: Reader; VAR ch: CHAR); VAR u: Run; pos: LONGINT; nextch: CHAR; BEGIN u := R.run; R.fnt := u.fnt; R.col := u.col; R.voff := u.voff; INC(R.off); @@ -351,8 +341,8 @@ MODULE Texts0; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91* IF (ch = 0AX) & u(Piece).ascii THEN ch := CR (* << LF to CR *) ELSIF (ch = CR) & u(Piece).ascii THEN (* << CR LF to CR *) pos := Files.Pos(R.rider); Files.Read(R.rider, nextch); - IF nextch = 0AX THEN INC(R.off) ELSE Files.Set(R.rider, u(Piece).file, pos) END - END + IF nextch = 0AX THEN INC(R.off) ELSE Files.Set(R.rider, u(Piece).file, pos) END + END ELSIF u IS Elem THEN ch := ElemChar; R.elem := u(Elem) ELSE ch := 0X; R.elem := NIL; R.eot := TRUE END; @@ -364,7 +354,6 @@ MODULE Texts0; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91* END END Read; - PROCEDURE ReadElem* (VAR R: Reader); VAR u, un: Run; BEGIN u := R.run; @@ -462,7 +451,7 @@ MODULE Texts0; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91* k := ORD(d[j]) - 30H; INC(j); IF (i-j = 7) & (k >= 8) THEN DEC(k, 16) END ; WHILE j < i DO k := k*10H + (ORD(d[j]) - 30H); INC(j) END ; - IF neg THEN S.i := -k ELSE S.i := k END + IF neg THEN S.i := -k ELSE S.i := k END ELSIF ch = "." THEN (*read real*) Read(S, ch); h := i; WHILE ("0" <= ch) & (ch <= "9") DO d[i] := ch; INC(i); Read(S, ch) END ; @@ -474,7 +463,7 @@ MODULE Texts0; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91* IF negE THEN IF e <= 308 THEN y := y / Reals.TenL(e) ELSE y := 0 END ELSIF e > 0 THEN - IF e <= 308 THEN y := Reals.TenL(e) * y ELSE HALT(40) END + IF e <= 308 THEN y := Reals.TenL(e) * y ELSE HALT(40) END END ; IF neg THEN y := -y END ; S.class := 5; S.y := y @@ -557,11 +546,18 @@ MODULE Texts0; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91* END WriteString; PROCEDURE WriteInt* (VAR W: Writer; x, n: LONGINT); - VAR i: INTEGER; x0: LONGINT; - a: ARRAY 11 OF CHAR; + VAR + i: INTEGER; x0: LONGINT; + a: ARRAY 22 OF CHAR; BEGIN i := 0; IF x < 0 THEN - IF x = MIN(LONGINT) THEN WriteString(W, " -2147483648"); RETURN + IF x = MIN(LONGINT) THEN + IF SIZE(LONGINT) = 4 THEN + WriteString(W, " -2147483648") + ELSE + WriteString(W, " -9223372036854775808") + END; + RETURN ELSE DEC(n); x0 := -x END ELSE x0 := x @@ -576,7 +572,7 @@ MODULE Texts0; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91* PROCEDURE WriteHex* (VAR W: Writer; x: LONGINT); VAR i: INTEGER; y: LONGINT; - a: ARRAY 10 OF CHAR; + a: ARRAY 20 OF CHAR; BEGIN i := 0; Write(W, " "); REPEAT y := x MOD 10H; IF y < 10 THEN a[i] := CHR(y + 30H) ELSE a[i] := CHR(y + 37H) END; @@ -680,14 +676,22 @@ MODULE Texts0; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91* REPEAT Write(W, " "); DEC(n) UNTIL n <= maxD; (*there are 2 <= n <= maxD digits to be written*) IF x < 0 THEN Write(W, "-"); x := -x ELSE Write(W, " ") END; + + (* Scale e to be an exponent of 10 rather than 2 *) e := SHORT(LONG(e - 1023) * 77 DIV 256); IF e >= 0 THEN x := x / Reals.TenL(e) ELSE x := Reals.TenL(-e) * x END ; - IF x >= 10.0D0 THEN x := 0.1D0 * x; INC(e) END ; + IF x >= 10.0D0 THEN x := 0.1D0 * x; INC(e) END; + + (* Scale x to the number of digits requested *) x0 := Reals.TenL(n-1); x := x0*x + 0.5D0; IF x >= 10.0D0*x0 THEN x := 0.1D0 * x; INC(e) END ; + + (* Generate the mantissa digits of x *) Reals.ConvertL(x, n, d); + DEC(n); Write(W, d[n]); Write(W, "."); REPEAT DEC(n); Write(W, d[n]) UNTIL n = 0; + Write(W, "D"); IF e < 0 THEN Write(W, "-"); e := -e ELSE Write(W, "+") END; Write(W, CHR(e DIV 100 + 30H)); e := e MOD 100; @@ -767,7 +771,7 @@ MODULE Texts0; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91* u.next := T.head; T.head.prev := u; T.cache := T.head; T.corg := 0; Files.ReadLInt(msg.r, T.len); Files.Set(r, f, Files.Pos(msg.r) + T.len) END Load0; - + PROCEDURE Load* (VAR r: Files.Rider; T: Text); CONST oldTag = -4095; VAR tag: INTEGER; @@ -865,8 +869,9 @@ MODULE Texts0; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91* u := u.next END; r := msg.r; + IF T.notify # NIL THEN T.notify(T, unmark, 0, 0) END END Store; - + PROCEDURE Close* (T: Text; name: ARRAY OF CHAR); VAR f: Files.File; r: Files.Rider; i, res: INTEGER; bak: ARRAY 64 OF CHAR; BEGIN @@ -877,4 +882,4 @@ MODULE Texts0; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91* END Close; BEGIN del := NIL; NEW(FontsDefault); FontsDefault.name := "Syntax10.Scn.Fnt" -END Texts0. +END Texts.