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

Beginning adding -OC (large model) runtime library

Browse source
This commit is contained in:
David Brown 2016-09-28 11:38:53 +01:00
parent 9ffafc59b4
commit 212bcd58b9
23 changed files with 6183 additions and 169 deletions
Download patch file Download diff file Expand all files Collapse all files

10
makefile
View file

@ -156,13 +156,14 @@ full: configuration
@printf "\n\n--- Compiler build successfull ---\n\n"
@make -f src/tools/make/oberon.mk -s browsercmd MODEL=2
@printf "\n\n--- Library build started ---\n\n"
@make -f src/tools/make/oberon.mk -s library MODEL=2
@make -f src/tools/make/oberon.mk -s O2library
@make -f src/tools/make/oberon.mk -s OakwoodLibrary MODEL=C
@printf "\n\n--- Library build successfull ---\n\n"
@make -f src/tools/make/oberon.mk -s sourcechanges
@make -f src/tools/make/oberon.mk -s install MODEL=2
@make -f src/tools/make/oberon.mk -s install
@printf "\n\n--- Confidence tests started ---\n\n"
@make -f src/tools/make/oberon.mk -s confidence MODEL=2
@make -f src/tools/make/oberon.mk -s showpath MODEL=2
@make -f src/tools/make/oberon.mk -s showpath
assemble:
@ -190,7 +191,8 @@ browsercmd: configuration
# library: build all directories under src/library
library: configuration
@make -f src/tools/make/oberon.mk -s library MODEL=2
@make -f src/tools/make/oberon.mk -s O2library
@make -f src/tools/make/oberon.mk -s OakwoodLibrary MODEL=C
# Individual library components
v4: configuration

9
src/compiler/Compiler.Mod
View file

@ -66,7 +66,14 @@ MODULE Compiler; (* J. Templ 3.2.95 *)
OPT.sintobj.typ := OPT.sinttyp;
OPT.intobj.typ := OPT.inttyp;
OPT.lintobj.typ := OPT.linttyp
OPT.lintobj.typ := OPT.linttyp;
(* Enable or disable (non-system) BYTE type *)
IF OPM.Model = "C" THEN
OPT.cpbytetyp.strobj.name[4] := 0X (* Enable Component Pascal non-system BYTE type *)
ELSE
OPT.cpbytetyp.strobj.name[4] := '@' (* Disable Component Pascal non-system BYTE type *)
END
END PropagateElementaryTypeSizes;

9
src/compiler/OPC.Mod
View file

@ -821,10 +821,11 @@ MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *)
GenHeaderMsg;
OPM.WriteLn;
(* Define adjustable type sizes *)
OPM.WriteString("#define INTEGER int"); OPM.WriteInt(OPT.inttyp.size*8); OPM.WriteLn;
OPM.WriteString("#define LONGINT int"); OPM.WriteInt(OPT.linttyp.size*8); OPM.WriteLn;
OPM.WriteString("#define SET uint"); OPM.WriteInt(OPT.settyp.size*8); OPM.WriteLn;
(* Define model dependent type sizes *)
OPM.WriteString("#define SHORTINT int"); OPM.WriteInt(OPT.sinttyp.size*8); OPM.WriteLn;
OPM.WriteString("#define INTEGER int"); OPM.WriteInt(OPT.inttyp.size*8); OPM.WriteLn;
OPM.WriteString("#define LONGINT int"); OPM.WriteInt(OPT.linttyp.size*8); OPM.WriteLn;
OPM.WriteString("#define SET uint"); OPM.WriteInt(OPT.settyp.size*8); OPM.WriteLn;
OPM.WriteLn;
Include(BasicIncludeFile);

34
src/compiler/OPT.Mod
View file

@ -151,13 +151,12 @@ CONST
VAR
topScope*: Object;
undftyp*,
bytetyp*, booltyp*, chartyp*,
sinttyp*, inttyp*, linttyp*, hinttyp*,
adrtyp*,
int8typ*, int16typ*, int32typ*, int64typ*,
realtyp*, lrltyp*, settyp*, stringtyp*,
niltyp*, notyp*, sysptrtyp*: Struct;
undftyp*, niltyp*, notyp*,
bytetyp*, cpbytetyp*, booltyp*, chartyp*,
sinttyp*, inttyp*, linttyp*, hinttyp*,
int8typ*, int16typ*, int32typ*, int64typ*,
realtyp*, lrltyp*, settyp*, stringtyp*,
adrtyp*, sysptrtyp*: Struct;
sintobj*, intobj*, lintobj*: Object;
@ -1295,13 +1294,13 @@ BEGIN topScope := NIL; OpenScope(0, NIL); OPM.errpos := 0;
InitStruct(niltyp, NilTyp);
(*initialization of module SYSTEM*)
EnterTyp("BYTE", Byte, 1, bytetyp);
EnterTyp("BYTE", Byte, 1, bytetyp);
EnterTyp("PTR", Pointer, -1, sysptrtyp); (* Size set in Compiler.PropagateElementaryTypeSize *)
EnterTyp("ADDRESS", Int, -1, adrtyp); (* Size set in Compiler.PropagateElementaryTypeSize *)
EnterTyp("INT8", Int, 1, int8typ);
EnterTyp("INT16", Int, 2, int16typ);
EnterTyp("INT32", Int, 4, int32typ);
EnterTyp("INT64", Int, 8, int64typ);
EnterTyp("INT8", Int, 1, int8typ);
EnterTyp("INT16", Int, 2, int16typ);
EnterTyp("INT32", Int, 4, int32typ);
EnterTyp("INT64", Int, 8, int64typ);
EnterProc("ADR", adrfn);
EnterProc("CC", ccfn);
@ -1320,12 +1319,13 @@ BEGIN topScope := NIL; OpenScope(0, NIL); OPM.errpos := 0;
universe := topScope; topScope^.right := NIL;
EnterTyp("BOOLEAN", Bool, 1, booltyp);
EnterTyp("CHAR", Char, 1, chartyp);
EnterTyp("BOOLEAN", Bool, 1, booltyp);
EnterTyp("CHAR", Char, 1, chartyp);
EnterTyp("SET", Set, -1, settyp); (* Size set in Compiler.PropagateElementaryTypeSize *)
EnterTyp("REAL", Real, 4, realtyp);
EnterTyp("LONGREAL", LReal, 8, lrltyp);
EnterTyp("HUGEINT", Int, 8, hinttyp);
EnterTyp("REAL", Real, 4, realtyp);
EnterTyp("LONGREAL", LReal, 8, lrltyp);
EnterTyp("HUGEINT", Int, 8, hinttyp);
EnterTyp("BYTE@", Int, 1, cpbytetyp); (* Component Pascal byte type, enabled in Compiler.PropagateElementaryTypeSize *)
EnterTypeAlias("SHORTINT", sintobj);
EnterTypeAlias("INTEGER", intobj);

1
src/compiler/OPV.Mod
View file

@ -137,6 +137,7 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96
(* mark basic types as predefined, OPC.Ident can avoid qualification*)
OPT.chartyp^.strobj^.linkadr := PredefinedType;
OPT.cpbytetyp^.strobj^.linkadr := PredefinedType;
OPT.settyp^.strobj^.linkadr := PredefinedType;
OPT.realtyp^.strobj^.linkadr := PredefinedType;
OPT.adrtyp^.strobj^.linkadr := PredefinedType;

1
src/compiler/extTools.Mod
View file

@ -76,4 +76,3 @@ PROCEDURE LinkMain*(VAR moduleName: ARRAY OF CHAR; statically: BOOLEAN; addition
END extTools.
,

764
src/runtime/Files.Mod Normal file
View file

@ -0,0 +1,764 @@
MODULE Files; (* J. Templ 1.12. 89/12.4.95 Oberon files mapped onto Unix files *)
IMPORT SYSTEM, Platform, Heap, Strings, Out;
(* standard data type I/O
little endian,
Sint:1, Int:2, Lint:4
ORD({0}) = 1,
false = 0, true =1
IEEE real format,
null terminated strings,
compact numbers according to M.Odersky *)
CONST
nofbufs = 4;
bufsize = 4096;
noDesc = -1;
notDone = -1;
(* file states *)
open = 0; (* OS File has been opened *)
create = 1; (* OS file needs to be created *)
close = 2; (* Register telling Create to use registerName directly:
i.e. since we're closing and all data is still in
buffers bypass writing to temp file and then renaming
and just write directly to fianl register name *)
TYPE
FileName = ARRAY 101 OF CHAR;
File* = POINTER TO FileDesc;
Buffer = POINTER TO BufDesc;
FileDesc = RECORD
workName: FileName;
registerName: FileName;
tempFile: BOOLEAN;
identity: Platform.FileIdentity;
fd-: Platform.FileHandle;
len, pos: LONGINT;
bufs: ARRAY nofbufs OF Buffer;
swapper: INTEGER;
state: INTEGER;
next: File;
END;
BufDesc = RECORD
f: File;
chg: BOOLEAN;
org: LONGINT;
size: LONGINT;
data: ARRAY bufsize OF SYSTEM.BYTE
END;
Rider* = RECORD
res*: LONGINT;
eof*: BOOLEAN;
buf: Buffer;
org: LONGINT;
offset: LONGINT
END;
VAR
files: File; (* List of files that have an OS file handle/descriptor assigned *)
tempno: INTEGER;
HOME: ARRAY 1024 OF CHAR;
SearchPath: POINTER TO ARRAY OF CHAR;
PROCEDURE -IdxTrap "__HALT(-1)";
PROCEDURE^ Finalize(o: SYSTEM.PTR);
PROCEDURE Err(s: ARRAY OF CHAR; f: File; errcode: Platform.ErrorCode);
BEGIN
Out.Ln; Out.String("-- "); Out.String(s); Out.String(": ");
IF f # NIL THEN
IF f.registerName # "" THEN Out.String(f.registerName) ELSE Out.String(f.workName) END;
IF f.fd # 0 THEN Out.String("f.fd = "); Out.Int(f.fd,1) END
END;
IF errcode # 0 THEN Out.String(" errcode = "); Out.Int(errcode, 1) END;
Out.Ln;
HALT(99)
END Err;
PROCEDURE MakeFileName(dir, name: ARRAY OF CHAR; VAR dest: ARRAY OF CHAR);
VAR i, j: INTEGER;
BEGIN i := 0; j := 0;
WHILE dir[i] # 0X DO dest[i] := dir[i]; INC(i) END;
IF dest[i-1] # "/" THEN dest[i] := "/"; INC(i) END;
WHILE name[j] # 0X DO dest[i] := name[j]; INC(i); INC(j) END;
dest[i] := 0X
END MakeFileName;
PROCEDURE GetTempName(finalName: ARRAY OF CHAR; VAR name: ARRAY OF CHAR);
VAR n, i, j: LONGINT;
BEGIN
INC(tempno); n := tempno; i := 0;
IF finalName[0] # "/" THEN (* relative pathname *)
WHILE Platform.CWD[i] # 0X DO name[i] := Platform.CWD[i]; INC(i) END;
IF Platform.CWD[i-1] # "/" THEN name[i] := "/"; INC(i) END
END;
j := 0;
WHILE finalName[j] # 0X DO name[i] := finalName[j]; INC(i); INC(j) END;
DEC(i);
WHILE name[i] # "/" DO DEC(i) END;
name[i+1] := "."; name[i+2] := "t"; name[i+3] := "m"; name[i+4] := "p"; name[i+5] := "."; INC(i, 6);
WHILE n > 0 DO name[i] := CHR(n MOD 10 + ORD("0")); n := n DIV 10; INC(i) END;
name[i] := "."; INC(i); n := Platform.PID;
WHILE n > 0 DO name[i] := CHR(n MOD 10 + ORD("0")); n := n DIV 10; INC(i) END;
name[i] := 0X
END GetTempName;
PROCEDURE Create(f: File);
VAR
identity: Platform.FileIdentity;
done: BOOLEAN;
error: Platform.ErrorCode;
err: ARRAY 32 OF CHAR;
BEGIN
(*
Out.String("Files.Create fd = "); Out.Int(f.fd,1);
Out.String(", registerName = "); Out.String(f.registerName);
Out.String(", workName = "); Out.String(f.workName);
Out.String(", state = "); Out.Int(f.state,1);
Out.Ln;
*)
IF f.fd = noDesc THEN
IF f.state = create THEN
GetTempName(f.registerName, f.workName); f.tempFile := TRUE
ELSIF f.state = close THEN
f.workName := f.registerName; f.registerName := ""; f.tempFile := FALSE
END;
error := Platform.Unlink(f.workName); (*unlink first to avoid stale NFS handles and to avoid reuse of inodes*)
error := Platform.New(f.workName, f.fd);
done := error = 0;
IF done THEN
f.next := files; files := f;
INC(Heap.FileCount);
Heap.RegisterFinalizer(f, Finalize);
f.state := open;
f.pos := 0;
error := Platform.Identify(f.fd, f.identity);
ELSE
IF Platform.NoSuchDirectory(error) THEN err := "no such directory"
ELSIF Platform.TooManyFiles(error) THEN err := "too many files open"
ELSE err := "file not created"
END;
Err(err, f, error)
END
END
END Create;
PROCEDURE Flush(buf: Buffer);
VAR
error: Platform.ErrorCode;
f: File;
(* identity: Platform.FileIdentity; *)
BEGIN
(*
Out.String("Files.Flush buf.f.registername = "); Out.String(buf.f.registerName);
Out.String(", buf.f.fd = "); Out.Int(buf.f.fd,1);
Out.String(", buffer at $"); Out.Hex(SYSTEM.ADR(buf.data));
Out.String(", size "); Out.Int(buf.size,1); Out.Ln;
*)
IF buf.chg THEN f := buf.f; Create(f);
IF buf.org # f.pos THEN
error := Platform.Seek(f.fd, buf.org, Platform.SeekSet);
(*
Out.String("Seeking to "); Out.Int(buf.org,1);
Out.String(", error code "); Out.Int(error,1); Out.Ln;
*)
END;
error := Platform.Write(f.fd, SYSTEM.ADR(buf.data), buf.size);
IF error # 0 THEN Err("error writing file", f, error) END;
f.pos := buf.org + buf.size;
buf.chg := FALSE;
error := Platform.Identify(f.fd, f.identity);
IF error # 0 THEN Err("error identifying file", f, error) END;
(*
error := Platform.Identify(f.fd, identity);
f.identity.mtime := identity.mtime;
*)
END
END Flush;
PROCEDURE CloseOSFile(f: File);
(* Close the OS file handle and remove f from 'files' *)
VAR prev: File; error: Platform.ErrorCode;
BEGIN
IF files = f THEN files := f.next
ELSE
prev := files;
WHILE (prev # NIL) & (prev.next # f) DO prev := prev.next END;
IF prev.next # NIL THEN prev.next := f.next END
END;
error := Platform.Close(f.fd);
f.fd := noDesc; f.state := create; DEC(Heap.FileCount);
END CloseOSFile;
PROCEDURE Close* (f: File);
VAR
i: LONGINT;
error: Platform.ErrorCode;
BEGIN
IF (f.state # create) OR (f.registerName # "") THEN
Create(f); i := 0;
WHILE (i < nofbufs) & (f.bufs[i] # NIL) DO Flush(f.bufs[i]); INC(i) END;
error := Platform.Sync(f.fd);
IF error # 0 THEN Err("error writing file", f, error) END;
CloseOSFile(f);
END
END Close;
PROCEDURE Length* (f: File): LONGINT;
BEGIN RETURN f.len END Length;
PROCEDURE New* (name: ARRAY OF CHAR): File;
VAR f: File;
BEGIN
NEW(f); f.workName := ""; COPY(name, f.registerName);
f.fd := noDesc; f.state := create; f.len := 0; f.pos := 0; f.swapper := -1; (*all f.buf[i] = NIL*)
RETURN f
END New;
PROCEDURE ScanPath(VAR pos: INTEGER; VAR dir: ARRAY OF CHAR);
(* Extract next individual directory from searchpath starting at pos,
updating pos and returning dir.
Supports ~, ~user and blanks inside path *)
VAR i: INTEGER; ch: CHAR;
BEGIN
i := 0;
IF SearchPath = NIL THEN
IF pos = 0 THEN
dir[0] := "."; i := 1; INC(pos) (* Default search path is just the current directory *)
END
ELSE
ch := SearchPath[pos];
WHILE (ch = " ") OR (ch = ";") DO INC(pos); ch := SearchPath[pos] END;
IF ch = "~" THEN
INC(pos); ch := SearchPath[pos];
WHILE HOME[i] # 0X DO dir[i] := HOME[i]; INC(i) END;
IF (ch # "/") & (ch # 0X) & (ch # ";") & (ch # " ") THEN
WHILE (i > 0) & (dir[i-1] # "/") DO DEC(i) END
END
END;
WHILE (ch # 0X) & (ch # ";") DO dir[i] := ch; INC(i); INC(pos); ch := SearchPath[pos] END;
WHILE (i > 0) & (dir[i-1] = " ") DO DEC(i) END
END;
dir[i] := 0X
END ScanPath;
PROCEDURE HasDir(VAR name: ARRAY OF CHAR): BOOLEAN;
VAR i: INTEGER; ch: CHAR;
BEGIN i := 0; ch := name[0];
WHILE (ch # 0X) & (ch # "/") DO INC(i); ch := name[i] END;
RETURN ch = "/"
END HasDir;
PROCEDURE CacheEntry(identity: Platform.FileIdentity): File;
VAR f: File; i: INTEGER; error: Platform.ErrorCode;
BEGIN f := files;
WHILE f # NIL DO
IF Platform.SameFile(identity, f.identity) THEN
IF ~Platform.SameFileTime(identity, f.identity) THEN i := 0;
WHILE i < nofbufs DO
IF f.bufs[i] # NIL THEN f.bufs[i].org := -1; f.bufs[i] := NIL END;
INC(i)
END;
f.swapper := -1; f.identity := identity;
error := Platform.Size(f.fd, f.len);
END;
RETURN f
END;
f := f.next
END;
RETURN NIL
END CacheEntry;
PROCEDURE Old*(name: ARRAY OF CHAR): File;
VAR
f: File;
fd: Platform.FileHandle;
pos: INTEGER;
done: BOOLEAN;
dir, path: ARRAY 256 OF CHAR;
error: Platform.ErrorCode;
identity: Platform.FileIdentity;
BEGIN
(* Out.String("Files.Old "); Out.String(name); Out.Ln; *)
IF name # "" THEN
IF HasDir(name) THEN dir := ""; COPY(name, path)
ELSE pos := 0; ScanPath(pos, dir); MakeFileName(dir, name, path); ScanPath(pos, dir)
END;
LOOP
error := Platform.OldRW(path, fd); done := error = 0;
IF ~done & Platform.TooManyFiles(error) THEN Err("too many files open", f, error) END;
IF ~done & Platform.Inaccessible(error) THEN
error := Platform.OldRO(path, fd); done := error = 0;
END;
IF ~done & ~Platform.Absent(error) THEN
Out.String("Warning: Files.Old "); Out.String(name);
Out.String(" error = "); Out.Int(error, 0); Out.Ln;
END;
IF done THEN
(* Out.String(" fd = "); Out.Int(fd,1); Out.Ln; *)
error := Platform.Identify(fd, identity);
f := CacheEntry(identity);
IF f # NIL THEN
(* error := Platform.Close(fd); DCWB: Either this should be removed or should call CloseOSFile. *)
RETURN f
ELSE NEW(f); Heap.RegisterFinalizer(f, Finalize);
f.fd := fd; f.state := open; f.pos := 0; f.swapper := -1; (*all f.buf[i] = NIL*)
error := Platform.Size(fd, f.len);
COPY(name, f.workName); f.registerName := ""; f.tempFile := FALSE;
f.identity := identity;
f.next := files; files := f; INC(Heap.FileCount);
RETURN f
END
ELSIF dir = "" THEN RETURN NIL
ELSE MakeFileName(dir, name, path); ScanPath(pos, dir)
END
END
ELSE RETURN NIL
END
END Old;
PROCEDURE Purge* (f: File);
VAR i: INTEGER; identity: Platform.FileIdentity; error: Platform.ErrorCode;
BEGIN i := 0;
WHILE i < nofbufs DO
IF f.bufs[i] # NIL THEN f.bufs[i].org := -1; f.bufs[i] := NIL END;
INC(i)
END;
IF f.fd # noDesc THEN
error := Platform.Truncate(f.fd, 0);
error := Platform.Seek(f.fd, 0, Platform.SeekSet)
END;
f.pos := 0; f.len := 0; f.swapper := -1;
error := Platform.Identify(f.fd, identity); Platform.SetMTime(f.identity, identity)
END Purge;
PROCEDURE GetDate* (f: File; VAR t, d: LONGINT);
VAR
identity: Platform.FileIdentity; error: Platform.ErrorCode;
BEGIN
Create(f); error := Platform.Identify(f.fd, identity);
Platform.MTimeAsClock(identity, t, d)
END GetDate;
PROCEDURE Pos* (VAR r: Rider): LONGINT;
BEGIN RETURN r.org + r.offset
END Pos;
PROCEDURE Set* (VAR r: Rider; f: File; pos: LONGINT);
VAR org, offset, i, n: LONGINT; buf: Buffer; error: Platform.ErrorCode;
BEGIN
IF f # NIL THEN
(*
Out.String("Files.Set rider on fd = "); Out.Int(f.fd,1);
Out.String(", registerName = "); Out.String(f.registerName);
Out.String(", workName = "); Out.String(f.workName);
Out.String(", state = "); Out.Int(f.state,1);
Out.Ln;
*)
IF pos > f.len THEN pos := f.len ELSIF pos < 0 THEN pos := 0 END;
offset := pos MOD bufsize; org := pos - offset; i := 0;
WHILE (i < nofbufs) & (f.bufs[i] # NIL) & (org # f.bufs[i].org) DO INC(i) END;
IF i < nofbufs THEN
IF f.bufs[i] = NIL THEN NEW(buf); buf.chg := FALSE; buf.org := -1; buf.f := f; f.bufs[i] := buf
ELSE buf := f.bufs[i]
END
ELSE
f.swapper := (f.swapper + 1) MOD nofbufs;
buf := f.bufs[f.swapper];
Flush(buf)
END;
IF buf.org # org THEN
IF org = f.len THEN buf.size := 0
ELSE Create(f);
IF f.pos # org THEN error := Platform.Seek(f.fd, org, Platform.SeekSet) END;
error := Platform.ReadBuf(f.fd, buf.data, n);
IF error # 0 THEN Err("read from file not done", f, error) END;
f.pos := org + n;
buf.size := n
END;
buf.org := org; buf.chg := FALSE
END
ELSE buf := NIL; org := 0; offset := 0
END;
r.buf := buf; r.org := org; r.offset := offset; r.eof := FALSE; r.res := 0
END Set;
PROCEDURE Read* (VAR r: Rider; VAR x: SYSTEM.BYTE);
VAR offset: LONGINT; buf: Buffer;
BEGIN
buf := r.buf; offset := r.offset;
IF r.org # buf.org THEN Set(r, buf.f, r.org + offset); buf := r.buf; offset := r.offset END;
IF (offset < buf.size) THEN
x := buf.data[offset]; r.offset := offset + 1
ELSIF r.org + offset < buf.f.len THEN
Set(r, r.buf.f, r.org + offset);
x := r.buf.data[0]; r.offset := 1
ELSE
x := 0X; r.eof := TRUE
END
END Read;
PROCEDURE ReadBytes* (VAR r: Rider; VAR x: ARRAY OF SYSTEM.BYTE; n: LONGINT);
VAR xpos, min, restInBuf, offset: LONGINT; buf: Buffer;
BEGIN
IF n > LEN(x) THEN IdxTrap END;
xpos := 0; buf := r.buf; offset := r.offset;
WHILE n > 0 DO
IF (r.org # buf.org) OR (offset >= bufsize) THEN
Set(r, buf.f, r.org + offset);
buf := r.buf; offset := r.offset
END;
restInBuf := buf.size - offset;
IF restInBuf = 0 THEN r.res := n; r.eof := TRUE; RETURN
ELSIF n > restInBuf THEN min := restInBuf ELSE min := n END;
SYSTEM.MOVE(SYSTEM.ADR(buf.data) + offset, SYSTEM.ADR(x) + xpos, min);
INC(offset, min); r.offset := offset; INC(xpos, min); DEC(n, min)
END;
r.res := 0; r.eof := FALSE
END ReadBytes;
PROCEDURE Base* (VAR r: Rider): File;
BEGIN RETURN r.buf.f
END Base;
PROCEDURE Write* (VAR r: Rider; x: SYSTEM.BYTE);
VAR buf: Buffer; offset: LONGINT;
BEGIN
buf := r.buf; offset := r.offset;
IF (r.org # buf.org) OR (offset >= bufsize) THEN
Set(r, buf.f, r.org + offset);
buf := r.buf; offset := r.offset
END;
buf.data[offset] := x;
buf.chg := TRUE;
IF offset = buf.size THEN
INC(buf.size); INC(buf.f.len)
END;
r.offset := offset + 1; r.res := 0
END Write;
PROCEDURE WriteBytes* (VAR r: Rider; VAR x: ARRAY OF SYSTEM.BYTE; n: LONGINT);
VAR xpos, min, restInBuf, offset: LONGINT; buf: Buffer;
BEGIN
IF n > LEN(x) THEN IdxTrap END;
xpos := 0; buf := r.buf; offset := r.offset;
WHILE n > 0 DO
IF (r.org # buf.org) OR (offset >= bufsize) THEN
Set(r, buf.f, r.org + offset);
buf := r.buf; offset := r.offset
END;
restInBuf := bufsize - offset;
IF n > restInBuf THEN min := restInBuf ELSE min := n END;
SYSTEM.MOVE(SYSTEM.ADR(x) + xpos, SYSTEM.ADR(buf.data) + offset, min);
INC(offset, min); r.offset := offset;
IF offset > buf.size THEN INC(buf.f.len, offset - buf.size); buf.size := offset END;
INC(xpos, min); DEC(n, min); buf.chg := TRUE
END;
r.res := 0
END WriteBytes;
(* another solution would be one that is similar to ReadBytes, WriteBytes.
No code duplication, more symmetric, only two ifs for
Read and Write in buffer, buf.size replaced by bufsize in Write ops, buf.size and len
must be made consistent with offset (if offset > buf.size) in a lazy way.
PROCEDURE Write* (VAR r: Rider; x: SYSTEM.BYTE);
VAR buf: Buffer; offset: LONGINT;
BEGIN
buf := r.buf; offset := r.offset;
IF (offset >= bufsize) OR (r.org # buf.org) THEN
Set(r, buf.f, r.org + offset); buf := r.buf; offset := r.offset;
END;
buf.data[offset] := x; r.offset := offset + 1; buf.chg := TRUE
END Write;
PROCEDURE WriteBytes ...
PROCEDURE Read* (VAR r: Rider; VAR x: SYSTEM.BYTE);
VAR offset: LONGINT; buf: Buffer;
BEGIN
buf := r.buf; offset := r.offset;
IF (offset >= buf.size) OR (r.org # buf.org) THEN
IF r.org + offset >= buf.f.len THEN x := 0X; r.eof := TRUE; RETURN
ELSE Set(r, buf.f, r.org + offset); buf := r.buf; offset := r.offset
END
END;
x := buf.data[offset]; r.offset := offset + 1
END Read;
but this would also affect Set, Length, and Flush.
Especially Length would become fairly complex.
*)
PROCEDURE Delete*(name: ARRAY OF CHAR; VAR res: INTEGER);
BEGIN res := Platform.Unlink(name) END Delete;
PROCEDURE Rename* (old, new: ARRAY OF CHAR; VAR res: INTEGER);
VAR
fdold, fdnew: Platform.FileHandle;
n: LONGINT;
error, ignore: Platform.ErrorCode;
oldidentity, newidentity: Platform.FileIdentity;
buf: ARRAY 4096 OF CHAR;
BEGIN
(*
Out.String("Files.Rename old = "); Out.String(old);
Out.String(", new = "); Out.String(new); Out.Ln;
*)
error := Platform.IdentifyByName(old, oldidentity);
IF error = 0 THEN
error := Platform.IdentifyByName(new, newidentity);
IF (error # 0) & ~Platform.SameFile(oldidentity, newidentity) THEN
Delete(new, error); (* work around stale nfs handles *)
END;
error := Platform.Rename(old, new);
(* Out.String("Platform.Rename error code "); Out.Int(error,1); Out.Ln; *)
IF ~Platform.DifferentFilesystems(error) THEN
res := error; RETURN
ELSE
(* cross device link, move the file *)
error := Platform.OldRO(old, fdold);
IF error # 0 THEN res := 2; RETURN END;
error := Platform.New(new, fdnew);
IF error # 0 THEN error := Platform.Close(fdold); res := 3; RETURN END;
error := Platform.Read(fdold, SYSTEM.ADR(buf), bufsize, n);
WHILE n > 0 DO
error := Platform.Write(fdnew, SYSTEM.ADR(buf), n);
IF error # 0 THEN
ignore := Platform.Close(fdold);
ignore := Platform.Close(fdnew);
Err("cannot move file", NIL, error)
END;
error := Platform.Read(fdold, SYSTEM.ADR(buf), bufsize, n);
END;
ignore := Platform.Close(fdold);
ignore := Platform.Close(fdnew);
IF n = 0 THEN
error := Platform.Unlink(old); res := 0
ELSE
Err("cannot move file", NIL, error)
END;
END
ELSE
res := 2 (* old file not found *)
END
END Rename;
PROCEDURE Register* (f: File);
VAR idx, errcode: INTEGER; f1: File; file: ARRAY 104 OF CHAR;
BEGIN
(*
Out.String("Files.Register f.registerName = "); Out.String(f.registerName);
Out.String(", fd = "); Out.Int(f.fd,1); Out.Ln;
*)
IF (f.state = create) & (f.registerName # "") THEN f.state := close (* shortcut renaming *) END;
Close(f);
IF f.registerName # "" THEN
Rename(f.workName, f.registerName, errcode);
(*
Out.String("Renamed (for register) f.fd = "); Out.Int(f.fd,1);
Out.String(" from workname "); Out.String(f.workName);
Out.String(" to registerName "); Out.String(f.registerName);
Out.String(" errorcode = "); Out.Int(errcode,1); Out.Ln;
*)
IF errcode # 0 THEN COPY(f.registerName, file); HALT(99) END;
f.workName := f.registerName; f.registerName := ""; f.tempFile := FALSE
END
END Register;
PROCEDURE ChangeDirectory*(path: ARRAY OF CHAR; VAR res: INTEGER);
BEGIN
res := Platform.Chdir(path);
END ChangeDirectory;
PROCEDURE FlipBytes(VAR src, dest: ARRAY OF SYSTEM.BYTE);
VAR i, j: LONGINT;
BEGIN
IF ~Platform.LittleEndian THEN i := LEN(src); j := 0;
WHILE i > 0 DO DEC(i); dest[j] := src[i]; INC(j) END
ELSE SYSTEM.MOVE(SYSTEM.ADR(src), SYSTEM.ADR(dest), LEN(src))
END
END FlipBytes;
PROCEDURE ReadBool* (VAR R: Rider; VAR x: BOOLEAN);
BEGIN Read(R, SYSTEM.VAL(CHAR, x))
END ReadBool;
PROCEDURE ReadInt* (VAR R: Rider; VAR x: INTEGER);
VAR b: ARRAY 2 OF CHAR;
BEGIN ReadBytes(R, b, 2);
x := ORD(b[0]) + ORD(b[1])*256
END ReadInt;
PROCEDURE ReadLInt* (VAR R: Rider; VAR x: LONGINT);
VAR b: ARRAY 4 OF CHAR;
BEGIN ReadBytes(R, b, 4);
x := ORD(b[0]) + ORD(b[1])*100H + ORD(b[2])*10000H + ORD(b[3])*1000000H
END ReadLInt;
PROCEDURE ReadSet* (VAR R: Rider; VAR x: SET);
(* Reads 32 bits as a SET value (even on 64 bit systems. See Oakwood appendix 1.2.5.4 *)
VAR b: ARRAY 4 OF CHAR; l: LONGINT;
BEGIN ReadBytes(R, b, 4);
(* Need to read via a LONGINT to provide correct behaviour for 64 bit sets. *)
l := ORD(b[0]) + ORD(b[1])*100H + ORD(b[2])*10000H + ORD(b[3])*1000000H;
x := SYSTEM.VAL(SET, l)
END ReadSet;
PROCEDURE ReadReal* (VAR R: Rider; VAR x: REAL);
VAR b: ARRAY 4 OF CHAR;
BEGIN ReadBytes(R, b, 4); FlipBytes(b, x)
END ReadReal;
PROCEDURE ReadLReal* (VAR R: Rider; VAR x: LONGREAL);
VAR b: ARRAY 8 OF CHAR;
BEGIN ReadBytes(R, b, 8); FlipBytes(b, x)
END ReadLReal;
PROCEDURE ReadString* (VAR R: Rider; VAR x: ARRAY OF CHAR);
VAR i: INTEGER; ch: CHAR;
BEGIN i := 0;
REPEAT Read(R, ch); x[i] := ch; INC(i) UNTIL ch = 0X
END ReadString;
PROCEDURE ReadLine* (VAR R: Rider; VAR x: ARRAY OF CHAR);
VAR i: INTEGER; ch: CHAR; b : BOOLEAN;
BEGIN
i := 0;
b := FALSE;
REPEAT
Read(R, ch);
IF ((ch = 0X) OR (ch = 0AX) OR (ch = 0DX)) THEN
b := TRUE
ELSE
x[i] := ch;
INC(i);
END;
UNTIL b
END ReadLine;
PROCEDURE ReadNum* (VAR R: Rider; VAR x: LONGINT);
VAR s: SHORTINT; ch: CHAR; n: LONGINT;
BEGIN s := 0; n := 0; Read(R, ch);
WHILE ORD(ch) >= 128 DO INC(n, ASH(ORD(ch) - 128, s) ); INC(s, 7); Read(R, ch) END;
INC(n, ASH(ORD(ch) MOD 64 - ORD(ch) DIV 64 * 64, s) );
x := n
END ReadNum;
PROCEDURE ReadNum64* (VAR R: Rider; VAR x: SYSTEM.INT64);
(* todo. use proper code when INC/ASH properly support INT64 on 32 bit platforms
VAR s: SHORTINT; ch: CHAR; n: SYSTEM.INT64;
BEGIN s := 0; n := 0; Read(R, ch);
WHILE ORD(ch) >= 128 DO INC(n, ASH(ORD(ch) - 128, s) ); INC(s, 7); Read(R, ch) END;
INC(n, ASH(ORD(ch) MOD 64 - ORD(ch) DIV 64 * 64, s) );
x := n
*)
VAR n: LONGINT;
BEGIN ReadNum(R, n); x := n
END ReadNum64;
PROCEDURE WriteBool* (VAR R: Rider; x: BOOLEAN);
BEGIN Write(R, SYSTEM.VAL(CHAR, x))
END WriteBool;
PROCEDURE WriteInt* (VAR R: Rider; x: INTEGER);
VAR b: ARRAY 2 OF CHAR;
BEGIN b[0] := CHR(x); b[1] := CHR(x DIV 256);
WriteBytes(R, b, 2);
END WriteInt;
PROCEDURE WriteLInt* (VAR R: Rider; x: LONGINT);
VAR b: ARRAY 4 OF CHAR;
BEGIN
b[0] := CHR(x); b[1] := CHR(x DIV 100H); b[2] := CHR(x DIV 10000H); b[3] := CHR(x DIV 1000000H);
WriteBytes(R, b, 4);
END WriteLInt;
PROCEDURE WriteSet* (VAR R: Rider; x: SET);
VAR b: ARRAY 4 OF CHAR; i: LONGINT;
BEGIN i := SYSTEM.VAL(LONGINT, x);
b[0] := CHR(i); b[1] := CHR(i DIV 100H); b[2] := CHR(i DIV 10000H); b[3] := CHR(i DIV 1000000H);
WriteBytes(R, b, 4);
END WriteSet;
PROCEDURE WriteReal* (VAR R: Rider; x: REAL);
VAR b: ARRAY 4 OF CHAR;
BEGIN FlipBytes(x, b); WriteBytes(R, b, 4)
END WriteReal;
PROCEDURE WriteLReal* (VAR R: Rider; x: LONGREAL);
VAR b: ARRAY 8 OF CHAR;
BEGIN FlipBytes(x, b); WriteBytes(R, b, 8)
END WriteLReal;
PROCEDURE WriteString* (VAR R: Rider; x: ARRAY [1] OF CHAR);
VAR i: INTEGER;
BEGIN i := 0;
WHILE x[i] # 0X DO INC(i) END;
WriteBytes(R, x, i+1)
END WriteString;
PROCEDURE WriteNum* (VAR R: Rider; x: LONGINT);
BEGIN
WHILE (x < - 64) OR (x > 63) DO Write(R, CHR(x MOD 128 + 128)); x := x DIV 128 END;
Write(R, CHR(x MOD 128))
END WriteNum;
PROCEDURE WriteNum64* (VAR R: Rider; x: SYSTEM.INT64);
BEGIN
WHILE (x < - 64) OR (x > 63) DO Write(R, CHR(x MOD 128 + 128)); x := x DIV 128 END;
Write(R, CHR(x MOD 128))
END WriteNum64;
PROCEDURE GetName*(f: File; VAR name: ARRAY OF CHAR);
BEGIN
COPY (f.workName, name);
END GetName;
PROCEDURE Finalize(o: SYSTEM.PTR);
VAR f: File; res: LONGINT;
BEGIN
f := SYSTEM.VAL(File, o);
(*
Out.String("Files.Finalize f.fd = "); Out.Int(f.fd,1);
Out.String(", f.registername = "); Out.String(f.registerName);
Out.String(", f.workName = "); Out.String(f.workName); Out.Ln;
*)
IF f.fd >= 0 THEN
CloseOSFile(f);
IF f.tempFile THEN res := Platform.Unlink(f.workName) END
END
END Finalize;
PROCEDURE SetSearchPath*(path: ARRAY OF CHAR);
BEGIN
IF Strings.Length(path) # 0 THEN
NEW(SearchPath, Strings.Length(path)+1);
COPY(path, SearchPath^)
ELSE
SearchPath := NIL
END
END SetSearchPath;
BEGIN
tempno := -1;
Heap.FileCount := 0;
HOME := ""; Platform.GetEnv("HOME", HOME);
END Files.

578
src/runtime/Heap.Mod Normal file
View file

@ -0,0 +1,578 @@
MODULE Heap;
IMPORT S := SYSTEM; (* Cannot import anything else as heap initialization must complete
before any other modules are initialized. *)
CONST
ModNameLen = 20;
CmdNameLen = 24;
SZA = SIZE(S.ADDRESS); (* Size of address *)
Unit = 4*SZA; (* smallest possible heap block *)
nofLists = 9; (* number of free_lists *)
heapSize0 = 8000*Unit; (* startup heap size *)
(* all blocks look the same:
free blocks describe themselves: size = Unit
tag = &tag++
->block size
sentinel = -SZA
next
*)
(* heap chunks *)
nextChnkOff = S.VAL(S.ADDRESS, 0); (* next heap chunk, sorted ascendingly! *)
endOff = S.VAL(S.ADDRESS, SZA); (* end of heap chunk *)
blkOff = S.VAL(S.ADDRESS, 3*SZA); (* first block in a chunk *)
(* heap blocks *)
tagOff = S.VAL(S.ADDRESS, 0); (* block starts with tag *)
sizeOff = S.VAL(S.ADDRESS, SZA); (* block size in free block relative to block start *)
sntlOff = S.VAL(S.ADDRESS, 2*SZA); (* pointer offset table sentinel in free block relative to block start *)
nextOff = S.VAL(S.ADDRESS, 3*SZA); (* next pointer in free block relative to block start *)
NoPtrSntl = S.VAL(S.ADDRESS, -SZA);
AddressZero = S.VAL(S.ADDRESS, 0);
TYPE
ModuleName = ARRAY ModNameLen OF CHAR;
CmdName = ARRAY CmdNameLen OF CHAR;
Module = POINTER TO ModuleDesc;
Cmd = POINTER TO CmdDesc;
EnumProc = PROCEDURE(P: PROCEDURE(p: S.PTR));
ModuleDesc = RECORD
next: Module;
name: ModuleName;
refcnt: LONGINT;
cmds: Cmd;
types: S.ADDRESS;
enumPtrs: EnumProc;
reserved1, reserved2: LONGINT
END ;
Command = PROCEDURE;
CmdDesc = RECORD
next: Cmd;
name: CmdName;
cmd: Command
END ;
Finalizer = PROCEDURE(obj: S.PTR);
FinNode = POINTER TO FinDesc;
FinDesc = RECORD
next: FinNode;
obj: S.ADDRESS; (* weak pointer *)
marked: BOOLEAN;
finalize: Finalizer;
END ;
VAR
(* the list of loaded (=initialization started) modules *)
modules*: S.PTR;
freeList: ARRAY nofLists + 1 OF S.ADDRESS; (* dummy, 16, 32, 48, 64, 80, 96, 112, 128, sentinel *)
bigBlocks: S.ADDRESS;
allocated*: S.ADDRESS;
firstTry: BOOLEAN;
(* extensible heap *)
heap: S.ADDRESS; (* the sorted list of heap chunks *)
heapend: S.ADDRESS; (* max possible pointer value (used for stack collection) *)
heapsize*: S.ADDRESS; (* the sum of all heap chunk sizes *)
(* finalization candidates *)
fin: FinNode;
(* garbage collector locking *)
lockdepth: INTEGER;
interrupted: BOOLEAN;
(* File system file count monitor *)
FileCount*: INTEGER;
PROCEDURE Lock*;
BEGIN
INC(lockdepth);
END Lock;
PROCEDURE -PlatformHalt(code: LONGINT) "Platform_Halt(code)";
PROCEDURE Unlock*;
BEGIN
DEC(lockdepth);
IF interrupted & (lockdepth = 0) THEN
PlatformHalt(-9);
END
END Unlock;
(*
PROCEDURE TAS*(VAR flag:BOOLEAN): BOOLEAN; (* added for compatibility with ulmSYSTEM module; noch *)
VAR oldflag : BOOLEAN;
BEGIN
oldflag := flag;
flag := TRUE;
RETURN oldflag;
END TAS;
*)
PROCEDURE REGMOD*(VAR name: ModuleName; enumPtrs: EnumProc): S.PTR;
VAR m: Module;
BEGIN
(* REGMOD is called at the start of module initialisation code before that modules
type descriptors have been set up. 'NEW' depends on the Heap modules type
descriptors being ready for use, therefore, just for the Heap module itself, we
must use S.NEW. *)
IF name = "Heap" THEN
S.NEW(m, SIZE(ModuleDesc))
ELSE
NEW(m)
END;
m.types := 0; m.cmds := NIL;
COPY(name, m.name); m.refcnt := 0; m.enumPtrs := enumPtrs; m.next := S.VAL(Module, modules);
modules := m;
RETURN m
END REGMOD;
PROCEDURE REGCMD*(m: Module; VAR name: CmdName; cmd: Command);
VAR c: Cmd;
BEGIN
(* REGCMD is called during module initialisation code before that modules
type descriptors have been set up. 'NEW' depends on the Heap modules type
descriptors being ready for use, therefore, just for the commands registered
by the Heap module itself, we must use S.NEW. *)
IF m.name = "Heap" THEN
S.NEW(c, SIZE(CmdDesc))
ELSE
NEW(c)
END;
COPY(name, c.name); c.cmd := cmd; c.next := m.cmds; m.cmds := c
END REGCMD;
PROCEDURE REGTYP*(m: Module; typ: S.ADDRESS);
BEGIN S.PUT(typ, m.types); m.types := typ
END REGTYP;
PROCEDURE INCREF*(m: Module);
BEGIN INC(m.refcnt)
END INCREF;
PROCEDURE -ExternPlatformOSAllocate "extern address Platform_OSAllocate(address size);";
PROCEDURE -OSAllocate(size: S.ADDRESS): S.ADDRESS "Platform_OSAllocate(size)";
PROCEDURE NewChunk(blksz: S.ADDRESS): S.ADDRESS;
VAR chnk: S.ADDRESS;
BEGIN
chnk := OSAllocate(blksz + blkOff);
IF chnk # 0 THEN
S.PUT(chnk + endOff, chnk + (blkOff + blksz));
S.PUT(chnk + blkOff, chnk + (blkOff + sizeOff));
S.PUT(chnk + (blkOff + sizeOff), blksz);
S.PUT(chnk + (blkOff + sntlOff), NoPtrSntl);
S.PUT(chnk + (blkOff + nextOff), bigBlocks);
bigBlocks := chnk + blkOff;
INC(heapsize, blksz)
END ;
RETURN chnk
END NewChunk;
PROCEDURE ExtendHeap(blksz: S.ADDRESS);
VAR size, chnk, j, next: S.ADDRESS;
BEGIN
IF blksz > 10000*Unit THEN size := blksz
ELSE size := 10000*Unit (* additional heuristics *)
END ;
chnk := NewChunk(size);
IF chnk # 0 THEN
(*sorted insertion*)
IF chnk < heap THEN
S.PUT(chnk, heap); heap := chnk
ELSE
j := heap; S.GET(j, next);
WHILE (next # 0) & (chnk > next) DO
j := next;
S.GET(j, next)
END;
S.PUT(chnk, next); S.PUT(j, chnk)
END ;
IF next = 0 THEN S.GET(chnk+endOff, heapend) END
END
END ExtendHeap;
PROCEDURE ^GC*(markStack: BOOLEAN);
PROCEDURE NEWREC*(tag: S.ADDRESS): S.PTR;
VAR
i, i0, di, blksz, restsize, t, adr, end, next, prev: S.ADDRESS;
new: S.PTR;
BEGIN
Lock();
S.GET(tag, blksz);
ASSERT((Unit = 16) OR (Unit = 32));
ASSERT(SIZE(S.PTR) = SIZE(S.ADDRESS));
ASSERT(blksz MOD Unit = 0);
i0 := blksz DIV Unit; i := i0;
IF i < nofLists THEN adr := freeList[i];
WHILE adr = 0 DO INC(i); adr := freeList[i] END
END ;
IF i < nofLists THEN (* unlink *)
S.GET(adr + nextOff, next);
freeList[i] := next;
IF i # i0 THEN (* split *)
di := i - i0; restsize := di * Unit; end := adr + restsize;
S.PUT(end + sizeOff, blksz);
S.PUT(end + sntlOff, NoPtrSntl);
S.PUT(end, end + sizeOff);
S.PUT(adr + sizeOff, restsize);
S.PUT(adr + nextOff, freeList[di]);
freeList[di] := adr;
INC(adr, restsize)
END
ELSE
adr := bigBlocks; prev := 0;
LOOP
IF adr = 0 THEN
IF firstTry THEN
GC(TRUE); INC(blksz, Unit);
IF (heapsize - allocated - blksz) * 4 < heapsize THEN
(* heap is still almost full; expand to avoid thrashing *)
ExtendHeap((allocated + blksz) DIV (3*Unit) * (4*Unit) - heapsize)
END ;
firstTry := FALSE; new := NEWREC(tag); firstTry := TRUE;
IF new = NIL THEN
(* depending on the fragmentation, the heap may not have been extended by
the anti-thrashing heuristics above *)
ExtendHeap((allocated + blksz) DIV (3*Unit) * (4*Unit) - heapsize);
new := NEWREC(tag); (* will find a free block if heap has been expanded properly *)
END ;
Unlock(); RETURN new
ELSE
Unlock(); RETURN NIL
END
END ;
S.GET(adr+sizeOff, t);
IF t >= blksz THEN EXIT END ;
prev := adr; S.GET(adr + nextOff, adr)
END ;
restsize := t - blksz; end := adr + restsize;
S.PUT(end + sizeOff, blksz);
S.PUT(end + sntlOff, NoPtrSntl);
S.PUT(end, end + sizeOff);
IF restsize > nofLists * Unit THEN (*resize*)
S.PUT(adr + sizeOff, restsize)
ELSE (*unlink*)
S.GET(adr + nextOff, next);
IF prev = 0 THEN bigBlocks := next
ELSE S.PUT(prev + nextOff, next);
END ;
IF restsize > 0 THEN (*move*)
di := restsize DIV Unit;
S.PUT(adr + sizeOff, restsize);
S.PUT(adr + nextOff, freeList[di]);
freeList[di] := adr
END
END ;
INC(adr, restsize)
END ;
i := adr + 4*SZA; end := adr + blksz;
WHILE i < end DO (*deliberately unrolled*)
S.PUT(i, AddressZero);
S.PUT(i + SZA, AddressZero);
S.PUT(i + 2*SZA, AddressZero);
S.PUT(i + 3*SZA, AddressZero);
INC(i, 4*SZA)
END ;
S.PUT(adr + nextOff, AddressZero);
S.PUT(adr, tag);
S.PUT(adr + sizeOff, AddressZero);
S.PUT(adr + sntlOff, AddressZero);
INC(allocated, blksz);
Unlock();
RETURN S.VAL(S.PTR, adr + SZA)
END NEWREC;
PROCEDURE NEWBLK*(size: S.ADDRESS): S.PTR;
VAR blksz, tag: S.ADDRESS; new: S.PTR;
BEGIN
Lock();
blksz := (size + (4*SZA + Unit - 1)) DIV Unit * Unit; (*size + tag + meta + blksz + sntnl + UnitAlignment*)
new := NEWREC(S.ADR(blksz));
tag := S.VAL(S.ADDRESS, new) + blksz - 3*SZA;
S.PUT(tag - SZA, AddressZero); (*reserved for meta info*)
S.PUT(tag, blksz);
S.PUT(tag + SZA, NoPtrSntl);
S.PUT(S.VAL(S.ADDRESS, new) - SZA, tag);
Unlock();
RETURN new
END NEWBLK;
PROCEDURE Mark(q: S.ADDRESS);
VAR p, tag, offset, fld, n, tagbits: S.ADDRESS;
BEGIN
IF q # 0 THEN
S.GET(q - SZA, tagbits); (* Load the tag for the record at q *)
IF ~ODD(tagbits) THEN (* If it has not already been marked *)
S.PUT(q - SZA, tagbits + 1); (* Mark it *)
p := 0;
tag := tagbits + SZA; (* Tag addresses first offset *)
LOOP
S.GET(tag, offset); (* Get next ptr field offset *)
IF offset < 0 THEN (* Sentinel reached: Value is -8*(#fields+1) *)
S.PUT(q - SZA, tag + offset + 1); (* Rotate base ptr into tag *)
IF p = 0 THEN EXIT END ;
n := q; q := p;
S.GET(q - SZA, tag); DEC(tag, 1);
S.GET(tag, offset); fld := q + offset;
S.GET(fld, p); S.PUT(fld, S.VAL(S.PTR, n))
ELSE (* offset references a ptr field *)
fld := q + offset; (* S.ADDRESS the pointer *)
S.GET(fld, n); (* Load the pointer *)
IF n # 0 THEN (* If pointer is not NIL *)
S.GET(n - SZA, tagbits); (* Consider record pointed to by this field *)
IF ~ODD(tagbits) THEN
S.PUT(n - SZA, tagbits + 1);
S.PUT(q - SZA, tag + 1);
S.PUT(fld, S.VAL(S.PTR, p));
p := q; q := n;
tag := tagbits
END
END
END ;
INC(tag, SZA)
END
END
END
END Mark;
PROCEDURE MarkP(p: S.PTR); (* for compatibility with EnumPtrs in ANSI mode *)
BEGIN
Mark(S.VAL(S.ADDRESS, p))
END MarkP;
PROCEDURE Scan;
VAR chnk, adr, end, start, tag, i, size, freesize: S.ADDRESS;
BEGIN bigBlocks := 0; i := 1;
WHILE i < nofLists DO freeList[i] := 0; INC(i) END ;
freesize := 0; allocated := 0; chnk := heap;
WHILE chnk # 0 DO
adr := chnk + blkOff;
S.GET(chnk + endOff, end);
WHILE adr < end DO
S.GET(adr, tag);
IF ODD(tag) THEN (*marked*)
IF freesize > 0 THEN
start := adr - freesize;
S.PUT(start, start+SZA);
S.PUT(start+sizeOff, freesize);
S.PUT(start+sntlOff, NoPtrSntl);
i := freesize DIV Unit; freesize := 0;
IF i < nofLists THEN S.PUT(start + nextOff, freeList[i]); freeList[i] := start
ELSE S.PUT(start + nextOff, bigBlocks); bigBlocks := start
END
END ;
DEC(tag, 1);
S.PUT(adr, tag);
S.GET(tag, size);
INC(allocated, size);
INC(adr, size)
ELSE (*unmarked*)
S.GET(tag, size);
INC(freesize, size);
INC(adr, size)
END
END ;
IF freesize > 0 THEN (*collect last block*)
start := adr - freesize;
S.PUT(start, start+SZA);
S.PUT(start+sizeOff, freesize);
S.PUT(start+sntlOff, NoPtrSntl);
i := freesize DIV Unit; freesize := 0;
IF i < nofLists THEN S.PUT(start + nextOff, freeList[i]); freeList[i] := start
ELSE S.PUT(start + nextOff, bigBlocks); bigBlocks := start
END
END ;
S.GET(chnk, chnk)
END
END Scan;
PROCEDURE Sift (l, r: S.ADDRESS; VAR a: ARRAY OF S.ADDRESS);
VAR i, j, x: S.ADDRESS;
BEGIN j := l; x := a[j];
LOOP i := j; j := 2*j + 1;
IF (j < r) & (a[j] < a[j+1]) THEN INC(j) END;
IF (j > r) OR (a[j] <= x) THEN EXIT END;
a[i] := a[j]
END;
a[i] := x
END Sift;
PROCEDURE HeapSort (n: S.ADDRESS; VAR a: ARRAY OF S.ADDRESS);
VAR l, r, x: S.ADDRESS;
BEGIN l := n DIV 2; r := n - 1;
WHILE l > 0 DO DEC(l); Sift(l, r, a) END;
WHILE r > 0 DO x := a[0]; a[0] := a[r]; a[r] := x; DEC(r); Sift(l, r, a) END
END HeapSort;
PROCEDURE MarkCandidates(n: S.ADDRESS; VAR cand: ARRAY OF S.ADDRESS);
VAR chnk, adr, tag, next, lim, lim1, i, ptr, size: S.ADDRESS;
BEGIN
chnk := heap; i := 0; lim := cand[n-1];
WHILE (chnk # 0 ) & (chnk < lim) DO
adr := chnk + blkOff;
S.GET(chnk + endOff, lim1);
IF lim < lim1 THEN lim1 := lim END ;
WHILE adr < lim1 DO
S.GET(adr, tag);
IF ODD(tag) THEN (*already marked*)
S.GET(tag-1, size); INC(adr, size)
ELSE
S.GET(tag, size);
ptr := adr + SZA;
WHILE cand[i] < ptr DO INC(i) END ;
IF i = n THEN RETURN END ;
next := adr + size;
IF cand[i] < next THEN Mark(ptr) END ;
adr := next
END
END ;
S.GET(chnk, chnk)
END
END MarkCandidates;
PROCEDURE CheckFin;
VAR n: FinNode; tag: S.ADDRESS;
BEGIN
n := fin;
WHILE n # NIL DO
S.GET(n.obj - SZA, tag);
IF ~ODD(tag) THEN n.marked := FALSE; Mark(n.obj)
ELSE n.marked := TRUE
END ;
n := n.next
END
END CheckFin;
PROCEDURE Finalize;
VAR n, prev: FinNode;
BEGIN n := fin; prev := NIL;
WHILE n # NIL DO
IF ~n.marked THEN
IF n = fin THEN fin := fin.next ELSE prev.next := n.next END ;
n.finalize(S.VAL(S.PTR, n.obj));
(* new nodes may have been pushed in n.finalize, therefore: *)
IF prev = NIL THEN n := fin ELSE n := n.next END
ELSE
prev := n; n := n.next
END
END
END Finalize;
PROCEDURE FINALL*;
VAR n: FinNode;
BEGIN
WHILE fin # NIL DO
n := fin; fin := fin.next;
n.finalize(S.VAL(S.PTR, n.obj))
END
END FINALL;
PROCEDURE -ExternMainStackFrame "extern address Platform_MainStackFrame;";
PROCEDURE -PlatformMainStackFrame(): S.ADDRESS "Platform_MainStackFrame";
PROCEDURE MarkStack(n: S.ADDRESS; VAR cand: ARRAY OF S.ADDRESS);
VAR
frame: S.PTR;
inc, nofcand: S.ADDRESS;
sp, p, stack0: S.ADDRESS;
align: RECORD ch: CHAR; p: S.PTR END ;
BEGIN
IF n > 0 THEN MarkStack(n-1, cand); (* flush register windows by means of recursive calls *)
IF n > 100 THEN RETURN END (* prevent tail recursion optimization *)
END ;
IF n = 0 THEN
nofcand := 0; sp := S.ADR(frame);
stack0 := PlatformMainStackFrame();
(* check for minimum alignment of pointers *)
inc := S.ADR(align.p) - S.ADR(align);
IF sp > stack0 THEN inc := -inc END ;
WHILE sp # stack0 DO
S.GET(sp, p);
IF (p > heap) & (p < heapend) THEN
IF nofcand = LEN(cand) THEN HeapSort(nofcand, cand); MarkCandidates(nofcand, cand); nofcand := 0 END ;
cand[nofcand] := p; INC(nofcand)
END ;
INC(sp, inc)
END ;
IF nofcand > 0 THEN HeapSort(nofcand, cand); MarkCandidates(nofcand, cand) END
END
END MarkStack;
PROCEDURE GC*(markStack: BOOLEAN);
VAR
m: Module;
i0, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, i21, i22, i23: S.ADDRESS;
cand: ARRAY 10000 OF S.ADDRESS;
BEGIN
IF (lockdepth = 0) OR (lockdepth = 1) & ~markStack THEN
Lock();
m := S.VAL(Module, modules);
WHILE m # NIL DO
IF m.enumPtrs # NIL THEN m.enumPtrs(MarkP) END ;
m := m^.next
END ;
IF markStack THEN
(* generate register pressure to force callee saved registers to memory;
may be simplified by inlining OS calls or processor specific instructions
*)
i0 := -100; i1 := -101; i2 := -102; i3 := -103; i4 := -104; i5 := -105; i6 := -106; i7 := -107;
i8 := 1; i9 := 2; i10 := 3; i11 := 4; i12 := 5; i13 := 6; i14 := 7; i15 := 8;
i16 := 9; i17 := 10; i18 := 11; i19 := 12; i20 := 13; i21 := 14; i22 := 15; i23 := 16;
LOOP INC(i0, 1); INC(i1, 2); INC(i2, 3); INC(i3, 4); INC(i4, 5); INC(i5, 6); INC(i6, 7); INC(i7, 8);
INC(i8, 9); INC(i9, 10); INC(i10, 11); INC(i11, 12); INC(i12, 13); INC(i13, 14); INC(i14, 15); INC(i15, 16);
INC(i16, 17); INC(i17, 18); INC(i18, 19); INC(i19, 20); INC(i20, 21); INC(i21, 22); INC(i22, 23); INC(i23, 24);
IF (i0 = -99) & (i15 = 24) THEN MarkStack(32, cand); EXIT END
END ;
IF i0 + i1 + i2 + i3 + i4 + i5 + i6 + i7 + i8 + i9 + i10 + i11 + i12 + i13 + i14 + i15
+ i16 + i17 + i18 + i19 + i20 + i21 + i22 + i23 > 10000 THEN RETURN (* use all variables *)
END ;
END;
CheckFin;
Scan;
Finalize;
Unlock()
END
END GC;
PROCEDURE RegisterFinalizer*(obj: S.PTR; finalize: Finalizer);
VAR f: FinNode;
BEGIN NEW(f);
f.obj := S.VAL(S.ADDRESS, obj); f.finalize := finalize; f.marked := TRUE;
f.next := fin; fin := f;
END RegisterFinalizer;
PROCEDURE -ExternHeapInit "extern void *Heap__init();";
PROCEDURE -HeapModuleInit 'Heap__init()';
PROCEDURE InitHeap*;
(* InitHeap is called by Platform.init before any module bodies have been
initialised, to enable NEW, S.NEW *)
BEGIN
heap := NewChunk(heapSize0);
S.GET(heap + endOff, heapend);
S.PUT(heap, AddressZero);
allocated := 0; firstTry := TRUE; freeList[nofLists] := 1; lockdepth := 0;
FileCount := 0; modules := NIL; heapsize := 0; bigBlocks := 0; fin := NIL;
interrupted := FALSE;
HeapModuleInit;
END InitHeap;
END Heap.

0
src/runtime/In.Mod Normal file
View file

486
src/runtime/LowLReal.Mod Normal file
View file

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

408
src/runtime/LowReal.Mod Normal file
View file

@ -0,0 +1,408 @@
(* $Id: LowReal.Mod,v 1.5 1999/09/02 13:17:38 acken Exp $ *)
MODULE LowReal;
(*
LowReal - Gives access to the underlying properties of the type REAL
for IEEE single-precision numbers.
Copyright (C) 1995 Michael Griebling
This module is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2 of the
License, or (at your option) any later version.
This module is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*)
IMPORT S := SYSTEM, Reals;
(*
Real number properties are defined as follows:
radix--The whole number value of the radix used to represent the
corresponding read number values.
places--The whole number value of the number of radix places used
to store values of the corresponding real number type.
expoMin--The whole number value of the exponent minimum.
expoMax--The whole number value of the exponent maximum.
large--The largest value of the corresponding real number type.
small--The smallest positive value of the corresponding real number
type, represented to maximal precision.
IEC559--A Boolean value that is TRUE if and only if the implementation
of the corresponding real number type conforms to IEC 559:1989
(IEEE 754:1987) in all regards.
NOTES
6 -- If `IEC559' is TRUE, the value of `radix' is 2.
7 -- If LowReal.IEC559 is TRUE, the 32-bit format of IEC 559:1989
is used for the type REAL.
7 -- If LowLong.IEC559 is TRUE, the 64-bit format of IEC 559:1989
is used for the type REAL.
LIA1--A Boolean value that is TRUE if and only if the implementation of
the corresponding real number type conforms to ISO/IEC 10967-1:199x
(LIA-1) in all regards: parameters, arithmetic, exceptions, and
notification.
rounds--A Boolean value that is TRUE if and only if each operation produces
a result that is one of the values of the corresponding real number
type nearest to the mathematical result.
gUnderflow--A Boolean value that is TRUE if and only if there are values of
the corresponding real number type between 0.0 and `small'.
exception--A Boolean value that is TRUE if and only if every operation that
attempts to produce a real value out of range raises an exception.
extend--A Boolean value that is TRUE if and only if expressions of the
corresponding real number type are computed to higher precision than
the stored values.
nModes--The whole number value giving the number of bit positions needed for
the status flags for mode control.
*)
CONST
radix* = 2;
places* = 24;
expoMax* = 127;
expoMin* = 1-expoMax;
large* = MAX(REAL); (*3.40282347E+38;*)
(*small* = 1.17549435E-38; (* 2^(-126) *)*)
small* = 1/8.50705917E37; (* don't know better way; -- noch *)
IEC559* = TRUE;
LIA1* = FALSE;
rounds* = FALSE;
gUnderflow* = TRUE; (* there are IEEE numbers smaller than `small' *)
exception* = FALSE; (* at least in the default implementation *)
extend* = FALSE;
nModes* = 0;
TEN = 10.0; (* some commonly-used constants *)
ONE = 1.0;
ZERO = 0.0;
expOffset = expoMax;
hiBit = 22;
expBit = hiBit+1;
nMask = {0..hiBit,31}; (* number mask *)
expMask = {expBit..30}; (* exponent mask *)
TYPE
Modes*= SET;
VAR
(*small* : REAL; tmp: REAL;*) (* this was a test to get small as a variable at runtime. obviously, compile time preferred; -- noch *)
ErrorHandler*: PROCEDURE (errno : INTEGER);
err-: INTEGER;
(* Error handler default stub which can be replaced *)
PROCEDURE DefaultHandler (errno : INTEGER);
BEGIN
err:=errno
END DefaultHandler;
PROCEDURE ClearError*;
BEGIN
err:=0
END ClearError;
PROCEDURE exponent*(x: REAL): INTEGER;
(*
The value of the call exponent(x) shall be the exponent value of `x'
that lies between `expoMin' and `expoMax'. An exception shall occur
and may be raised if `x' is equal to 0.0.
*)
BEGIN
(* NOTE: x=0.0 should raise exception *)
IF x = ZERO THEN RETURN 0
ELSE RETURN Reals.Expo(x) - expOffset
END
END exponent;
PROCEDURE SetExponent(VAR x: REAL; ex: INTEGER);
BEGIN Reals.SetExpo(x, ex + expOffset)
END SetExponent;
PROCEDURE exponent10*(x: REAL): INTEGER;
(*
The value of the call exponent10(x) shall be the base 10 exponent
value of `x'. An exception shall occur and may be raised if `x' is
equal to 0.0.
*)
VAR exp: INTEGER;
BEGIN
exp := 0; x := ABS(x);
IF x = ZERO THEN RETURN exp END; (* exception could be raised here *)
WHILE x >= TEN DO x := x/TEN; INC(exp) END;
WHILE (x > ZERO) & (x < 1.0) DO x := x*TEN; DEC(exp) END;
RETURN exp
END exponent10;
(* TYPE REAL: 1/sign, 8/exponent, 23/significand *)
PROCEDURE fraction*(x: REAL): REAL;
(*
The value of the call fraction(x) shall be the significand (or
significant) part of `x'. Hence the following relationship shall
hold: x = scale(fraction(x), exponent(x)).
*)
VAR c: CHAR;
BEGIN
IF x=ZERO THEN RETURN ZERO
ELSE
(* Set top 7 bits of exponent to 0111111 *)
S.GET(S.ADR(x)+3, c);
c := CHR(((ORD(c) DIV 128) * 128) + 63); (* Set X0111111 (X unchanged) *)
S.PUT(S.ADR(x)+3, c);
(* Set bottom bit of exponent to 0 *)
S.GET(S.ADR(x)+2, c);
c := CHR(ORD(c) MOD 128); (* Set 0XXXXXXX (X unchanged) *)
S.PUT(S.ADR(x)+2, c);
RETURN x * 2.0;
END
(*
CONST eZero={(hiBit+2)..29};
BEGIN
IF x=ZERO THEN RETURN ZERO
ELSE RETURN S.VAL(REAL,(S.VAL(SET,x)*nMask)+eZero)*2.0 (* set the mantissa's exponent to zero *)
END
*)
END fraction;
PROCEDURE IsInfinity * (real: REAL) : BOOLEAN;
VAR c0, c1, c2, c3: CHAR;
BEGIN
S.GET(S.ADR(real)+0, c3);
S.GET(S.ADR(real)+1, c2);
S.GET(S.ADR(real)+2, c1);
S.GET(S.ADR(real)+3, c0);
RETURN (ORD(c0) MOD 128 = 127) & (ORD(c1) = 128) & (ORD(c2) = 0) & (ORD(c3) = 0)
END IsInfinity;
PROCEDURE IsNaN * (real: REAL) : BOOLEAN;
VAR c0, c1, c2, c3: CHAR;
BEGIN
S.GET(S.ADR(real)+0, c3);
S.GET(S.ADR(real)+1, c2);
S.GET(S.ADR(real)+2, c1);
S.GET(S.ADR(real)+3, c0);
RETURN (ORD(c0) MOD 128 = 127)
& (ORD(c1) DIV 128 = 1)
& ((ORD(c1) MOD 128 # 0) OR (ORD(c2) # 0) OR (ORD(c3) # 0))
END IsNaN;
PROCEDURE sign*(x: REAL): REAL;
(*
The value of the call sign(x) shall be 1.0 if `x' is greater than 0.0,
or shall be -1.0 if `x' is less than 0.0, or shall be either 1.0 or
-1.0 if `x' is equal to 0.0.
*)
BEGIN
IF x<ZERO THEN RETURN -ONE ELSE RETURN ONE END
END sign;
PROCEDURE scale*(x: REAL; n: INTEGER): REAL;
(*
The value of the call scale(x,n) shall be the value x*radix^n if such
a value exists; otherwise an execption shall occur and may be raised.
*)
VAR exp: LONGINT; lexp: SET;
BEGIN
IF x = ZERO THEN RETURN ZERO END;
exp := exponent(x) + n; (* new exponent *)
IF exp > expoMax THEN RETURN large * sign(x) (* exception raised here *)
ELSIF exp < expoMin THEN RETURN small * sign(x) (* exception here as well *)
END;
SetExponent(x, SHORT(exp));
(* SetExponent replaces these 2 lines:
lexp := S.VAL(SET, S.LSH(exp + expOffset, expBit)); (* shifted exponent bits *)
RETURN S.VAL(REAL, (S.VAL(SET, x) * nMask) + lexp) (* insert new exponent *)
*)
END scale;
PROCEDURE ulp*(x: REAL): REAL;
(*
The value of the call ulp(x) shall be the value of the corresponding
real number type equal to a unit in the last place of `x', if such a
value exists; otherwise an exception shall occur and may be raised.
*)
BEGIN
RETURN scale(ONE, exponent(x)-places+1)
END ulp;
PROCEDURE succ*(x: REAL): REAL;
(*
The value of the call succ(x) shall be the next value of the
corresponding real number type greater than `x', if such a type
exists; otherwise an exception shall occur and may be raised.
*)
BEGIN
RETURN x+ulp(x)*sign(x)
END succ;
PROCEDURE pred*(x: REAL): REAL;
(*
The value of the call pred(x) shall be the next value of the
corresponding real number type less than `x', if such a type exists;
otherwise an exception shall occur and may be raised.
*)
BEGIN
RETURN x-ulp(x)*sign(x)
END pred;
PROCEDURE intpart*(x: REAL): REAL;
(*
The value of the call intpart(x) shall be the integral part of `x'.
For negative values, this shall be -intpart(abs(x)).
*)
VAR loBit: INTEGER;
BEGIN
loBit := (hiBit+1) - exponent(x);
IF loBit <= 0 THEN RETURN x (* no fractional part *)
ELSIF loBit <= hiBit+1 THEN
RETURN S.VAL(REAL,S.VAL(SET,x)*{loBit..31}) (* integer part is extracted *)
ELSE RETURN ZERO (* no whole part *)
END
END intpart;
PROCEDURE fractpart*(x: REAL): REAL;
(*
The value of the call fractpart(x) shall be the fractional part of
`x'. This satifies the relationship fractpart(x)+intpart(x)=x.
*)
BEGIN
RETURN x-intpart(x)
END fractpart;
PROCEDURE trunc*(x: REAL; n: INTEGER): REAL;
(*
The value of the call trunc(x,n) shall be the value of the most
significant `n' places of `x'. An exception shall occur and may be
raised if `n' is less than or equal to zero.
*)
VAR loBit: INTEGER; mask: SET;
BEGIN loBit:=places-n;
IF n<=0 THEN RETURN ZERO (* exception should be raised *)
ELSIF loBit<=0 THEN RETURN x (* nothing was truncated *)
ELSE mask:={loBit..31}; (* truncation bit mask *)
RETURN S.VAL(REAL,S.VAL(SET,x)*mask)
END
END trunc;
PROCEDURE round*(x: REAL; n: INTEGER): REAL;
(*
The value of the call round(x,n) shall be the value of `x' rounded to
the most significant `n' places. An exception shall occur and may be
raised if such a value does not exist, or if `n' is less than or equal
to zero.
*)
VAR loBit: INTEGER; num, mask: SET; r: REAL;
BEGIN loBit:=places-n;
IF n<=0 THEN RETURN ZERO (* exception should be raised *)
ELSIF loBit<=0 THEN RETURN x (* nothing was rounded *)
ELSE mask:={loBit..31}; num:=S.VAL(SET,x); (* truncation bit mask and number as SET *)
x:=S.VAL(REAL,num*mask); (* truncated result *)
IF loBit-1 IN num THEN (* check if result should be rounded *)
r:=scale(ONE,exponent(x)-n+1); (* rounding fraction *)
IF 31 IN num THEN RETURN x-r (* negative rounding toward -infinity *)
ELSE RETURN x+r (* positive rounding toward +infinity *)
END
ELSE RETURN x (* return truncated result *)
END
END
END round;
PROCEDURE synthesize*(expart: INTEGER; frapart: REAL): REAL;
(*
The value of the call synthesize(expart,frapart) shall be a value of
the corresponding real number type contructed from the value of
`expart' and `frapart'. This value shall satisfy the relationship
synthesize(exponent(x),fraction(x)) = x.
*)
BEGIN
RETURN scale(frapart, expart)
END synthesize;
PROCEDURE setMode*(m: Modes);
(*
The call setMode(m) shall set status flags from the value of `m',
appropriate to the underlying implementation of the corresponding real
number type.
NOTES
3 -- Many implementations of floating point provide options for
setting flags within the system which control details of the handling
of the type. Although two procedures are provided, one for each real
number type, the effect may be the same. Typical effects that can be
obtained by this means are:
a) Ensuring that overflow will raise an exception;
b) Allowing underflow to raise an exception;
c) Controlling the rounding;
d) Allowing special values to be produced (e.g. NaNs in
implementations conforming to IEC 559:1989 (IEEE 754:1987));
e) Ensuring that special valu access will raise an exception;
Since these effects are so varied, the values of type `Modes' that may
be used are not specified by this International Standard.
4 -- The effects of `setMode' on operation on values of the
corresponding real number type in coroutines other than the calling
coroutine is not defined. Implementations are not require to preserve
the status flags (if any) with the coroutine state.
*)
BEGIN
(* hardware dependent mode setting of coprocessor *)
END setMode;
PROCEDURE currentMode*(): Modes;
(*
The value of the call currentMode() shall be the current status flags
(in the form set by `setMode'), or the default status flags (if
`setMode' is not used).
NOTE 5 -- The value of the call currentMode() is not necessarily the
value of set by `setMode', since a call of `setMode' might attempt to
set flags that cannot be set by the program.
*)
BEGIN
RETURN {}
END currentMode;
PROCEDURE IsLowException*(): BOOLEAN;
(*
Returns TRUE if the current coroutine is in the exceptional execution state
because of the raising of the LowReal exception; otherwise returns FALSE.
*)
BEGIN
RETURN FALSE
END IsLowException;
BEGIN
(* install the default error handler -- just sets err variable *)
ErrorHandler:=DefaultHandler;
(* tmp := power0(2,126); (* this is test to calculate small as a variable at runtime; -- noch *)
small := sml;
small := 1/power0(2,126);
*)
END LowReal.

612
src/runtime/Math.Mod Normal file
View file

@ -0,0 +1,612 @@
(* $Id: RealMath.Mod,v 1.6 1999/09/02 13:19:17 acken Exp $ *)
MODULE oocRealMath;
(* MathL - Oakwood REAL Mathematics.
Adapted (with minimal changes) from OOC RealMath.Mod *)
(*
RealMath - Target independent mathematical functions for REAL
(IEEE single-precision) numbers.
Numerical approximations are taken from "Software Manual for the
Elementary Functions" by Cody & Waite and "Computer Approximations"
by Hart et al.
Copyright (C) 1995 Michael Griebling
This module is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2 of the
License, or (at your option) any later version.
This module is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*)
IMPORT l := LowReal, S := SYSTEM;
CONST
pi* = 3.1415926535897932384626433832795028841972;
e* = 2.7182818284590452353602874713526624977572;
ZERO=0.0; ONE=1.0; HALF=0.5; TWO=2.0; (* local constants *)
(* internally-used constants *)
huge = l.large; (* largest number this package accepts *)
miny = ONE/huge; (* smallest number this package accepts *)
sqrtHalf = 0.70710678118654752440;
Limit = 2.4414062E-4; (* 2**(-MantBits/2) *)
eps = 2.9802322E-8; (* 2**(-MantBits-1) *)
piInv = 0.31830988618379067154; (* 1/pi *)
piByTwo = 1.57079632679489661923132;
piByFour = 0.78539816339744830962;
lnv = 0.6931610107421875; (* should be exact *)
vbytwo = 0.13830277879601902638E-4; (* used in sinh/cosh *)
ln2Inv = 1.44269504088896340735992468100189213;
(* error/exception codes *)
NoError*=0; IllegalRoot*=1; IllegalLog*=2; Overflow*=3; IllegalPower*=4; IllegalLogBase*=5;
IllegalTrig*=6; IllegalInvTrig*=7; HypInvTrigClipped*=8; IllegalHypInvTrig*=9;
LossOfAccuracy*=10; Underflow*=11;
VAR
a1: ARRAY 18 OF REAL; (* lookup table for power function *)
a2: ARRAY 9 OF REAL; (* lookup table for power function *)
em: REAL; (* largest number such that 1+epsilon > 1.0 *)
LnInfinity: REAL; (* natural log of infinity *)
LnSmall: REAL; (* natural log of very small number *)
SqrtInfinity: REAL; (* square root of infinity *)
TanhMax: REAL; (* maximum Tanh value *)
t: REAL; (* internal variables *)
(* internally used support routines *)
PROCEDURE SinCos (x, y, sign: REAL): REAL;
CONST
ymax=9099; (* ENTIER(pi*2**(MantBits/2)) *)
r1=-0.1666665668E+0;
r2= 0.8333025139E-2;
r3=-0.1980741872E-3;
r4= 0.2601903036E-5;
VAR
n: LONGINT; xn, f, g: REAL;
BEGIN
IF y>=ymax THEN l.ErrorHandler(LossOfAccuracy); RETURN ZERO END;
(* determine the reduced number *)
n:=ENTIER(y*piInv+HALF); xn:=n;
IF ODD(n) THEN sign:=-sign END;
x:=ABS(x);
IF x#y THEN xn:=xn-HALF END;
(* fractional part of reduced number *)
f:=SHORT(ABS(LONG(x)) - LONG(xn)*pi);
(* Pre: |f| <= pi/2 *)
IF ABS(f)<Limit THEN RETURN sign*f END;
(* evaluate polynomial approximation of sin *)
g:=f*f; g:=(((r4*g+r3)*g+r2)*g+r1)*g;
g:=f+f*g; (* don't use less accurate f(1+g) *)
RETURN sign*g
END SinCos;
PROCEDURE div (x, y : LONGINT) : LONGINT;
(* corrected MOD function *)
BEGIN
IF x < 0 THEN RETURN -ABS(x) DIV y ELSE RETURN x DIV y END
END div;
(* forward declarations *)
PROCEDURE^ arctan2* (xn, xd: REAL): REAL;
PROCEDURE^ sincos* (x: REAL; VAR Sin, Cos: REAL);
PROCEDURE round*(x: REAL): LONGINT;
(* Returns the value of x rounded to the nearest integer *)
BEGIN
IF x<ZERO THEN RETURN -ENTIER(HALF-x)
ELSE RETURN ENTIER(x+HALF)
END
END round;
PROCEDURE sqrt*(x: REAL): REAL;
(* Returns the positive square root of x where x >= 0 *)
CONST
P0=0.41731; P1=0.59016;
VAR
xMant, yEst, z: REAL; xExp: INTEGER;
BEGIN
(* optimize zeros and check for illegal negative roots *)
IF x=ZERO THEN RETURN ZERO END;
IF x<ZERO THEN l.ErrorHandler(IllegalRoot); x:=-x END;
(* reduce the input number to the range 0.5 <= x <= 1.0 *)
xMant:=l.fraction(x)*HALF; xExp:=l.exponent(x)+1;
(* initial estimate of the square root *)
yEst:=P0+P1*xMant;
(* perform two newtonian iterations *)
z:=(yEst+xMant/yEst); yEst:=0.25*z+xMant/z;
(* adjust for odd exponents *)
IF ODD(xExp) THEN yEst:=yEst*sqrtHalf; INC(xExp) END;
(* single Newtonian iteration to produce real number accuracy *)
RETURN l.scale(yEst, xExp DIV 2)
END sqrt;
PROCEDURE exp*(x: REAL): REAL;
(* Returns the exponential of x for x < Ln(MAX(REAL)) *)
CONST
ln2=0.6931471805599453094172321D0;
P0=0.24999999950E+0; P1=0.41602886268E-2; Q1=0.49987178778E-1;
VAR xn, g, p, q, z: REAL; n: LONGINT;
BEGIN
(* Ensure we detect overflows and return 0 for underflows *)
IF x>=LnInfinity THEN l.ErrorHandler(Overflow); RETURN huge
ELSIF x<LnSmall THEN l.ErrorHandler(Underflow); RETURN ZERO
ELSIF ABS(x)<eps THEN RETURN ONE
END;
(* Decompose and scale the number *)
n:=round(ln2Inv*x);
xn:=n; g:=SHORT(LONG(x)-LONG(xn)*ln2);
(* Calculate exp(g)/2 from "Software Manual for the Elementary Functions" *)
z:=g*g; p:=(P1*z+P0)*g; q:=Q1*z+HALF;
RETURN l.scale(HALF+p/(q-p), SHORT(n+1))
END exp;
PROCEDURE ln*(x: REAL): REAL;
(* Returns the natural logarithm of x for x > 0 *)
CONST
c1=355.0/512.0; c2=-2.121944400546905827679E-4;
A0=-0.5527074855E+0; B0=-0.6632718214E+1;
VAR f, zn, zd, r, z, w, xn: REAL; n: INTEGER;
BEGIN
(* ensure illegal inputs are trapped and handled *)
IF x<=ZERO THEN l.ErrorHandler(IllegalLog); RETURN -huge END;
(* reduce the range of the input *)
f:=l.fraction(x)*HALF; n:=l.exponent(x)+1;
IF f>sqrtHalf THEN zn:=(f-HALF)-HALF; zd:=f*HALF+HALF
ELSE zn:=f-HALF; zd:=zn*HALF+HALF; DEC(n)
END;
(* evaluate rational approximation from "Software Manual for the Elementary Functions" *)
z:=zn/zd; w:=z*z; r:=z+z*(w*A0/(w+B0));
(* scale the output *)
xn:=n;
RETURN (xn*c2+r)+xn*c1
END ln;
(* The angle in all trigonometric functions is measured in radians *)
PROCEDURE sin*(x: REAL): REAL;
(* Returns the sine of x for all x *)
BEGIN
IF x<ZERO THEN RETURN SinCos(x, -x, -ONE)
ELSE RETURN SinCos(x, x, ONE)
END
END sin;
PROCEDURE cos*(x: REAL): REAL;
(* Returns the cosine of x for all x *)
BEGIN
RETURN SinCos(x, ABS(x)+piByTwo, ONE)
END cos;
PROCEDURE tan*(x: REAL): REAL;
(* Returns the tangent of x where x cannot be an odd multiple of pi/2 *)
CONST
ymax = 6434; (* ENTIER(2**(MantBits/2)*pi/2) *)
twoByPi = 0.63661977236758134308;
P1=-0.958017723E-1; Q1=-0.429135777E+0; Q2=0.971685835E-2;
VAR
n: LONGINT;
y, xn, f, xnum, xden, g: REAL;
BEGIN
(* check for error limits *)
y:=ABS(x);
IF y>ymax THEN l.ErrorHandler(LossOfAccuracy); RETURN ZERO END;
(* determine n and the fraction f *)
n:=round(x*twoByPi); xn:=n;
f:=SHORT(LONG(x)-LONG(xn)*piByTwo);
(* check for underflow *)
IF ABS(f)<Limit THEN xnum:=f; xden:=ONE
ELSE g:=f*f; xnum:=P1*g*f+f; xden:=(Q2*g+Q1)*g+HALF+HALF
END;
(* find the final result *)
IF ODD(n) THEN RETURN xden/(-xnum)
ELSE RETURN xnum/xden
END
END tan;
PROCEDURE asincos (x: REAL; flag: LONGINT; VAR i: LONGINT; VAR res: REAL);
CONST
P1=0.933935835E+0; P2=-0.504400557E+0;
Q0=0.560363004E+1; Q1=-0.554846723E+1;
VAR
y, g, r: REAL;
BEGIN
y:=ABS(x);
IF y>HALF THEN
i:=1-flag;
IF y>ONE THEN l.ErrorHandler(IllegalInvTrig); res:=huge; RETURN END;
(* reduce the input argument *)
g:=(ONE-y)*HALF; r:=-sqrt(g); y:=r+r;
(* compute approximation *)
r:=((P2*g+P1)*g)/((g+Q1)*g+Q0);
res:=y+(y*r)
ELSE
i:=flag;
IF y<Limit THEN res:=y
ELSE
g:=y*y;
(* compute approximation *)
g:=((P2*g+P1)*g)/((g+Q1)*g+Q0);
res:=y+y*g
END
END
END asincos;
PROCEDURE arcsin*(x: REAL): REAL;
(* Returns the arcsine of x, in the range [-pi/2, pi/2] where -1 <= x <= 1 *)
VAR
res: REAL; i: LONGINT;
BEGIN
asincos(x, 0, i, res);
IF l.err#0 THEN RETURN res END;
(* adjust result for the correct quadrant *)
IF i=1 THEN res:=piByFour+(piByFour+res) END;
IF x<0 THEN res:=-res END;
RETURN res
END arcsin;
PROCEDURE arccos*(x: REAL): REAL;
(* Returns the arccosine of x, in the range [0, pi] where -1 <= x <= 1 *)
VAR
res: REAL; i: LONGINT;
BEGIN
asincos(x, 1, i, res);
IF l.err#0 THEN RETURN res END;
(* adjust result for the correct quadrant *)
IF x<0 THEN
IF i=0 THEN res:=piByTwo+(piByTwo+res)
ELSE res:=piByFour+(piByFour+res)
END
ELSE
IF i=1 THEN res:=piByFour+(piByFour-res)
ELSE res:=-res
END;
END;
RETURN res
END arccos;
PROCEDURE atan(f: REAL): REAL;
(* internal arctan algorithm *)
CONST
rt32=0.26794919243112270647;
rt3=1.73205080756887729353;
a=rt3-ONE;
P0=-0.4708325141E+0; P1=-0.5090958253E-1; Q0=0.1412500740E+1;
piByThree=1.04719755119659774615;
piBySix=0.52359877559829887308;
VAR
n: LONGINT; res, g: REAL;
BEGIN
IF f>ONE THEN f:=ONE/f; n:=2
ELSE n:=0
END;
(* check if f should be scaled *)
IF f>rt32 THEN f:=(((a*f-HALF)-HALF)+f)/(rt3+f); INC(n) END;
(* check for underflow *)
IF ABS(f)<Limit THEN res:=f
ELSE
g:=f*f; res:=(P1*g+P0)*g/(g+Q0); res:=f+f*res
END;
IF n>1 THEN res:=-res END;
CASE n OF
| 1: res:=res+piBySix
| 2: res:=res+piByTwo
| 3: res:=res+piByThree
| ELSE (* do nothing *)
END;
RETURN res
END atan;
PROCEDURE arctan*(x: REAL): REAL;
(* Returns the arctangent of x, in the range [-pi/2, pi/2] for all x *)
BEGIN
IF x<0 THEN RETURN -atan(-x)
ELSE RETURN atan(x)
END
END arctan;
PROCEDURE power*(base, exponent: REAL): REAL;
(* Returns the value of the number base raised to the power exponent
for base > 0 *)
CONST P1=0.83357541E-1; K=0.4426950409;
Q1=0.69314675; Q2=0.24018510; Q3=0.54360383E-1;
OneOver16=0.0625; XMAX=16*(l.expoMax+1)-1; (*XMIN=16*l.expoMin;*) XMIN=-2016; (* to make it easier for voc; -- noch *)
VAR z, g, R, v, u2, u1, w1, w2: REAL; w: LONGREAL;
m, p, i: INTEGER; mp, pp, iw1: LONGINT;
BEGIN
(* handle all possible error conditions *)
IF base<=ZERO THEN
IF base#ZERO THEN l.ErrorHandler(IllegalPower); base:=-base
ELSIF exponent>ZERO THEN RETURN ZERO
ELSE l.ErrorHandler(IllegalPower); RETURN huge
END
END;
(* extract the exponent of base to m and clear exponent of base in g *)
g:=l.fraction(base)*HALF; m:=l.exponent(base)+1;
(* determine p table offset with an unrolled binary search *)
p:=1;
IF g<=a1[9] THEN p:=9 END;
IF g<=a1[p+4] THEN INC(p, 4) END;
IF g<=a1[p+2] THEN INC(p, 2) END;
(* compute scaled z so that |z| <= 0.044 *)
z:=((g-a1[p+1])-a2[(p+1) DIV 2])/(g+a1[p+1]); z:=z+z;
(* approximation for log2(z) from "Software Manual for the Elementary Functions" *)
v:=z*z; R:=P1*v*z; R:=R+K*R; u2:=(R+z*K)+z;
u1:=(m*16-p)*OneOver16; w:=LONG(exponent)*(LONG(u1)+LONG(u2)); (* need extra precision *)
(* calculations below were modified to work properly -- incorrect in cited reference? *)
iw1:=ENTIER(16*w); w1:=iw1*OneOver16; w2:=SHORT(w-w1);
(* check for overflow/underflow *)
IF iw1>XMAX THEN l.ErrorHandler(Overflow); RETURN huge
ELSIF iw1<XMIN THEN l.ErrorHandler(Underflow); RETURN ZERO
END;
(* final approximation 2**w2-1 where -0.0625 <= w2 <= 0 *)
IF w2>ZERO THEN INC(iw1); w2:=w2-OneOver16 END; IF iw1<0 THEN i:=0 ELSE i:=1 END;
mp:=div(iw1, 16)+i; pp:=16*mp-iw1; z:=((Q3*w2+Q2)*w2+Q1)*w2; z:=a1[pp+1]+a1[pp+1]*z;
RETURN l.scale(z, SHORT(mp))
END power;
PROCEDURE IsRMathException*(): BOOLEAN;
(* Returns TRUE if the current coroutine is in the exceptional execution state
because of the raising of the RealMath exception; otherwise returns FALSE.
*)
BEGIN
RETURN FALSE
END IsRMathException;
(*
Following routines are provided as extensions to the ISO standard.
They are either used as the basis of other functions or provide
useful functions which are not part of the ISO standard.
*)
PROCEDURE log* (x, base: REAL): REAL;
(* log(x,base) is the logarithm of x base 'base'. All positive arguments are
allowed but base > 0 and base # 1 *)
BEGIN
(* log(x, base) = ln(x) / ln(base) *)
IF base<=ZERO THEN l.ErrorHandler(IllegalLogBase); RETURN -huge
ELSE RETURN ln(x)/ln(base)
END
END log;
PROCEDURE ipower* (x: REAL; base: INTEGER): REAL;
(* ipower(x, base) returns the x to the integer power base where Log2(x) < expoMax *)
VAR Exp: INTEGER; y: REAL; neg: BOOLEAN;
PROCEDURE Adjust(xadj: REAL): REAL;
BEGIN
IF (x<ZERO)&ODD(base) THEN RETURN -xadj ELSE RETURN xadj END
END Adjust;
BEGIN
(* handle all possible error conditions *)
IF base=0 THEN RETURN ONE (* x**0 = 1 *)
ELSIF ABS(x)<miny THEN
IF base>0 THEN RETURN ZERO ELSE l.ErrorHandler(Overflow); RETURN Adjust(huge) END
END;
(* trap potential overflows and underflows *)
Exp:=(l.exponent(x)+1)*base; y:=LnInfinity*ln2Inv;
IF Exp>y THEN l.ErrorHandler(Overflow); RETURN Adjust(huge)
ELSIF Exp<-y THEN RETURN ZERO
END;
(* compute x**base using an optimised algorithm from Knuth, slightly
altered : p442, The Art Of Computer Programming, Vol 2 *)
y:=ONE; IF base<0 THEN neg:=TRUE; base := -base ELSE neg:= FALSE END;
LOOP
IF ODD(base) THEN y:=y*x END;
base:=base DIV 2; IF base=0 THEN EXIT END;
x:=x*x;
END;
IF neg THEN RETURN ONE/y ELSE RETURN y END
END ipower;
PROCEDURE sincos* (x: REAL; VAR Sin, Cos: REAL);
(* More efficient sin/cos implementation if both values are needed. *)
BEGIN
Sin:=sin(x); Cos:=sqrt(ONE-Sin*Sin)
END sincos;
PROCEDURE arctan2* (xn, xd: REAL): REAL;
(* arctan2(xn,xd) is the quadrant-correct arc tangent atan(xn/xd). If the
denominator xd is zero, then the numerator xn must not be zero. All
arguments are legal except xn = xd = 0. *)
VAR
res: REAL; xpdiff: LONGINT;
BEGIN
(* check for error conditions *)
IF xd=ZERO THEN
IF xn=ZERO THEN l.ErrorHandler(IllegalTrig); RETURN ZERO
ELSIF xn<0 THEN RETURN -piByTwo
ELSE RETURN piByTwo
END;
ELSE
xpdiff:=l.exponent(xn)-l.exponent(xd);
IF ABS(xpdiff)>=l.expoMax-3 THEN
(* overflow detected *)
IF xn<0 THEN RETURN -piByTwo
ELSE RETURN piByTwo
END
ELSE
res:=ABS(xn/xd);
IF res#ZERO THEN res:=atan(res) END;
IF xd<ZERO THEN res:=pi-res END;
IF xn<ZERO THEN RETURN -res
ELSE RETURN res
END
END
END
END arctan2;
PROCEDURE sinh* (x: REAL): REAL;
(* sinh(x) is the hyperbolic sine of x. The argument x must not be so large
that exp(|x|) overflows. *)
CONST P0=-7.13793159; P1=-0.190333399; Q0=-42.8277109;
VAR y, f: REAL;
BEGIN y:=ABS(x);
IF y<=ONE THEN (* handle small arguments *)
IF y<Limit THEN RETURN x END;
(* use approximation from "Software Manual for the Elementary Functions" *)
f:=y*y; y:=f*((f*P1+P0)/(f+Q0)); RETURN x+x*y
ELSIF y>LnInfinity THEN (* handle exp overflows *)
y:=y-lnv;
IF y>LnInfinity-lnv+0.69 THEN l.ErrorHandler(Overflow);
IF x>ZERO THEN RETURN huge ELSE RETURN -huge END
ELSE f:=exp(y); f:=f+f*vbytwo (* don't change to f(1+vbytwo) *)
END
ELSE f:=exp(y); f:=(f-ONE/f)*HALF
END;
(* reach here when 1 < ABS(x) < LnInfinity-lnv+0.69 *)
IF x>ZERO THEN RETURN f ELSE RETURN -f END
END sinh;
PROCEDURE cosh* (x: REAL): REAL;
(* cosh(x) is the hyperbolic cosine of x. The argument x must not be so large
that exp(|x|) overflows. *)
VAR y, f: REAL;
BEGIN y:=ABS(x);
IF y>LnInfinity THEN (* handle exp overflows *)
y:=y-lnv;
IF y>LnInfinity-lnv+0.69 THEN l.ErrorHandler(Overflow);
IF x>ZERO THEN RETURN huge ELSE RETURN -huge END
ELSE f:=exp(y); RETURN f+f*vbytwo (* don't change to f(1+vbytwo) *)
END
ELSE f:=exp(y); RETURN (f+ONE/f)*HALF
END
END cosh;
PROCEDURE tanh* (x: REAL): REAL;
(* tanh(x) is the hyperbolic tangent of x. All arguments are legal. *)
CONST P0=-0.8237728127; P1=-0.3831010665E-2; Q0=2.471319654; ln3over2=0.5493061443;
BIG=9.010913347; (* (ln(2)+(t+1)*ln(B))/2 where t=mantissa bits, B=base *)
VAR f, t: REAL;
BEGIN f:=ABS(x);
IF f>BIG THEN t:=ONE
ELSIF f>ln3over2 THEN t:=ONE-TWO/(exp(TWO*f)+ONE)
ELSIF f<Limit THEN t:=f
ELSE (* approximation from "Software Manual for the Elementary Functions" *)
t:=f*f; t:=t*(P1*t+P0)/(t+Q0); t:=f+f*t
END;
IF x<ZERO THEN RETURN -t ELSE RETURN t END
END tanh;
PROCEDURE arcsinh* (x: REAL): REAL;
(* arcsinh(x) is the arc hyperbolic sine of x. All arguments are legal. *)
BEGIN
IF ABS(x)>SqrtInfinity*HALF THEN l.ErrorHandler(HypInvTrigClipped);
IF x>ZERO THEN RETURN ln(SqrtInfinity) ELSE RETURN -ln(SqrtInfinity) END;
ELSIF x<ZERO THEN RETURN -ln(-x+sqrt(x*x+ONE))
ELSE RETURN ln(x+sqrt(x*x+ONE))
END
END arcsinh;
PROCEDURE arccosh* (x: REAL): REAL;
(* arccosh(x) is the arc hyperbolic cosine of x. All arguments greater than
or equal to 1 are legal. *)
BEGIN
IF x<ONE THEN l.ErrorHandler(IllegalHypInvTrig); RETURN ZERO
ELSIF x>SqrtInfinity*HALF THEN l.ErrorHandler(HypInvTrigClipped); RETURN ln(SqrtInfinity)
ELSE RETURN ln(x+sqrt(x*x-ONE))
END
END arccosh;
PROCEDURE arctanh* (x: REAL): REAL;
(* arctanh(x) is the arc hyperbolic tangent of x. |x| < 1 - sqrt(em), where
em is machine epsilon. Note that |x| must not be so close to 1 that the
result is less accurate than half precision. *)
CONST TanhLimit=0.999984991; (* Tanh(5.9) *)
VAR t: REAL;
BEGIN t:=ABS(x);
IF (t>=ONE) OR (t>(ONE-TWO*em)) THEN l.ErrorHandler(IllegalHypInvTrig);
IF x<ZERO THEN RETURN -TanhMax ELSE RETURN TanhMax END
ELSIF t>TanhLimit THEN l.ErrorHandler(LossOfAccuracy)
END;
RETURN arcsinh(x/sqrt(ONE-x*x))
END arctanh;
BEGIN
(* determine some fundamental constants used by hyperbolic trig functions *)
em:=l.ulp(ONE);
LnInfinity:=ln(huge);
LnSmall:=ln(miny);
SqrtInfinity:=sqrt(huge);
t:=l.pred(ONE)/sqrt(em); TanhMax:=ln(t+sqrt(t*t+ONE));
(* initialize some tables for the power() function a1[i]=2**((1-i)/16) *)
a1[1] :=ONE;
a1[2] :=S.VAL(REAL, 3F75257DH);
a1[3] :=S.VAL(REAL, 3F6AC0C7H);
a1[4] :=S.VAL(REAL, 3F60CCDFH);
a1[5] :=S.VAL(REAL, 3F5744FDH);
a1[6] :=S.VAL(REAL, 3F4E248CH);
a1[7] :=S.VAL(REAL, 3F45672AH);
a1[8] :=S.VAL(REAL, 3F3D08A4H);
a1[9] :=S.VAL(REAL, 3F3504F3H);
a1[10]:=S.VAL(REAL, 3F2D583FH);
a1[11]:=S.VAL(REAL, 3F25FED7H);
a1[12]:=S.VAL(REAL, 3F1EF532H);
a1[13]:=S.VAL(REAL, 3F1837F0H);
a1[14]:=S.VAL(REAL, 3F11C3D3H);
a1[15]:=S.VAL(REAL, 3F0B95C2H);
a1[16]:=S.VAL(REAL, 3F05AAC3H);
a1[17]:=HALF;
(* a2[i]=2**[(1-2i)/16] - a1[2i]; delta resolution *)
a2[1]:=S.VAL(REAL, 31A92436H);
a2[2]:=S.VAL(REAL, 336C2A95H);
a2[3]:=S.VAL(REAL, 31A8FC24H);
a2[4]:=S.VAL(REAL, 331F580CH);
a2[5]:=S.VAL(REAL, 336A42A1H);
a2[6]:=S.VAL(REAL, 32C12342H);
a2[7]:=S.VAL(REAL, 32E75624H);
a2[8]:=S.VAL(REAL, 32CF9890H)
END oocRealMath.

562
src/runtime/MathL.Mod Normal file
View file

@ -0,0 +1,562 @@
MODULE MathL;
(* MathL - Oakwood LONGREAL Mathematics.
Adapted (with minimal changes) from OOC LRealMath.Mod *)
(*
LRealMath - Target independent mathematical functions for LONGREAL
(IEEE double-precision) numbers.
Numerical approximations are taken from "Software Manual for the
Elementary Functions" by Cody & Waite and "Computer Approximations"
by Hart et al.
Copyright (C) 1996-1998 Michael Griebling
This module is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2 of the
License, or (at your option) any later version.
This module is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*)
IMPORT l := LowLReal, m := Math, SYSTEM;
CONST
pi* = 3.1415926535897932384626433832795028841972D0;
e* = 2.7182818284590452353602874713526624977572D0;
ZERO=0.0D0; ONE=1.0D0; HALF=0.5D0; TWO=2.0D0; (* local constants *)
(* internally-used constants *)
huge = l.large; (* largest number this package accepts *)
miny = l.small; (* smallest number this package accepts *)
sqrtHalf = 0.70710678118654752440D0;
Limit = 1.0536712D-8; (* 2**(-MantBits/2) *)
eps = 5.5511151D-17; (* 2**(-MantBits-1) *)
piInv = 0.31830988618379067154D0; (* 1/pi *)
piByTwo = 1.57079632679489661923D0;
lnv = 0.6931610107421875D0; (* should be exact *)
vbytwo = 0.13830277879601902638D-4; (* used in sinh/cosh *)
ln2Inv = 1.44269504088896340735992468100189213D0;
(* error/exception codes *)
NoError*=m.NoError; IllegalRoot*=m.IllegalRoot; IllegalLog*=m.IllegalLog; Overflow*=m.Overflow;
IllegalPower*=m.IllegalPower; IllegalLogBase*=m.IllegalLogBase; IllegalTrig*=m.IllegalTrig;
IllegalInvTrig*=m.IllegalInvTrig; HypInvTrigClipped*=m.HypInvTrigClipped;
IllegalHypInvTrig*=m.IllegalHypInvTrig; LossOfAccuracy*=m.LossOfAccuracy;
VAR
a1: ARRAY 18 OF LONGREAL; (* lookup table for power function *)
a2: ARRAY 9 OF LONGREAL; (* lookup table for power function *)
em: LONGREAL; (* largest number such that 1+epsilon > 1.0 *)
LnInfinity: LONGREAL; (* natural log of infinity *)
LnSmall: LONGREAL; (* natural log of very small number *)
SqrtInfinity: LONGREAL; (* square root of infinity *)
TanhMax: LONGREAL; (* maximum Tanh value *)
t: LONGREAL; (* internal variables *)
(* internally used support routines *)
PROCEDURE SinCos (x, y, sign: LONGREAL): LONGREAL;
CONST
ymax=210828714; (* ENTIER(pi*2**(MantBits/2)) *)
c1=3.1416015625D0;
c2=-8.908910206761537356617D-6;
r1=-0.16666666666666665052D+0;
r2= 0.83333333333331650314D-2;
r3=-0.19841269841201840457D-3;
r4= 0.27557319210152756119D-5;
r5=-0.25052106798274584544D-7;
r6= 0.16058936490371589114D-9;
r7=-0.76429178068910467734D-12;
r8= 0.27204790957888846175D-14;
VAR
n: LONGINT; xn, f, x1, g: LONGREAL;
BEGIN
IF y>=ymax THEN l.ErrorHandler(LossOfAccuracy); RETURN ZERO END;
(* determine the reduced number *)
n:=ENTIER(y*piInv+HALF); xn:=n;
IF ODD(n) THEN sign:=-sign END;
x:=ABS(x);
IF x#y THEN xn:=xn-HALF END;
(* fractional part of reduced number *)
x1:=ENTIER(x);
f:=((x1-xn*c1)+(x-x1))-xn*c2;
(* Pre: |f| <= pi/2 *)
IF ABS(f)<Limit THEN RETURN sign*f END;
(* evaluate polynomial approximation of sin *)
g:=f*f; g:=(((((((r8*g+r7)*g+r6)*g+r5)*g+r4)*g+r3)*g+r2)*g+r1)*g;
g:=f+f*g; (* don't use less accurate f(1+g) *)
RETURN sign*g
END SinCos;
PROCEDURE div (x, y : LONGINT) : LONGINT;
(* corrected MOD function *)
BEGIN
IF x < 0 THEN RETURN -ABS(x) DIV y ELSE RETURN x DIV y END
END div;
(* forward declarations *)
PROCEDURE^ arctan2* (xn, xd: LONGREAL): LONGREAL;
PROCEDURE^ sincos* (x: LONGREAL; VAR Sin, Cos: LONGREAL);
PROCEDURE sqrt*(x: LONGREAL): LONGREAL;
(* Returns the positive square root of x where x >= 0 *)
CONST
P0=0.41731; P1=0.59016;
VAR
xMant, yEst, z: LONGREAL; xExp: INTEGER;
BEGIN
(* optimize zeros and check for illegal negative roots *)
IF x=ZERO THEN RETURN ZERO END;
IF x<ZERO THEN l.ErrorHandler(IllegalRoot); x:=-x END;
(* reduce the input number to the range 0.5 <= x <= 1.0 *)
xMant:=l.fraction(x)*HALF; xExp:=l.exponent(x)+1;
(* initial estimate of the square root *)
yEst:=P0+P1*xMant;
(* perform three newtonian iterations *)
z:=(yEst+xMant/yEst); yEst:=0.25*z+xMant/z;
yEst:=HALF*(yEst+xMant/yEst);
(* adjust for odd exponents *)
IF ODD(xExp) THEN yEst:=yEst*sqrtHalf; INC(xExp) END;
(* single Newtonian iteration to produce real number accuracy *)
RETURN l.scale(yEst, xExp DIV 2)
END sqrt;
PROCEDURE exp*(x: LONGREAL): LONGREAL;
(* Returns the exponential of x for x < Ln(MAX(REAL) *)
CONST
c1=0.693359375D0; c2=-2.1219444005469058277D-4;
P0=0.249999999999999993D+0; P1=0.694360001511792852D-2; P2=0.165203300268279130D-4;
Q1=0.555538666969001188D-1; Q2=0.495862884905441294D-3;
VAR xn, g, p, q, z: LONGREAL; n: INTEGER;
BEGIN
(* Ensure we detect overflows and return 0 for underflows *)
IF x>LnInfinity THEN l.ErrorHandler(Overflow); RETURN huge
ELSIF x<LnSmall THEN RETURN ZERO
ELSIF ABS(x)<eps THEN RETURN ONE
END;
(* Decompose and scale the number *)
IF x>=ZERO THEN n:=SHORT(ENTIER(ln2Inv*x+HALF))
ELSE n:=SHORT(ENTIER(ln2Inv*x-HALF))
END;
xn:=n; g:=(x-xn*c1)-xn*c2;
(* Calculate exp(g)/2 from "Software Manual for the Elementary Functions" *)
z:=g*g; p:=((P2*z+P1)*z+P0)*g; q:=(Q2*z+Q1)*z+HALF;
RETURN l.scale(HALF+p/(q-p), n+1)
END exp;
PROCEDURE ln*(x: LONGREAL): LONGREAL;
(* Returns the natural logarithm of x for x > 0 *)
CONST
c1=355.0D0/512.0D0; c2=-2.121944400546905827679D-4;
P0=-0.64124943423745581147D+2; P1=0.16383943563021534222D+2; P2=-0.78956112887491257267D+0;
Q0=-0.76949932108494879777D+3; Q1=0.31203222091924532844D+3; Q2=-0.35667977739034646171D+2;
VAR f, zn, zd, r, z, w, p, q, xn: LONGREAL; n: INTEGER;
BEGIN
(* ensure illegal inputs are trapped and handled *)
IF x<=ZERO THEN l.ErrorHandler(IllegalLog); RETURN -huge END;
(* reduce the range of the input *)
f:=l.fraction(x)*HALF; n:=l.exponent(x)+1;
IF f>sqrtHalf THEN zn:=(f-HALF)-HALF; zd:=f*HALF+HALF
ELSE zn:=f-HALF; zd:=zn*HALF+HALF; DEC(n)
END;
(* evaluate rational approximation from "Software Manual for the Elementary Functions" *)
z:=zn/zd; w:=z*z; q:=((w+Q2)*w+Q1)*w+Q0; p:=w*((P2*w+P1)*w+P0); r:=z+z*(p/q);
(* scale the output *)
xn:=n;
RETURN (xn*c2+r)+xn*c1
END ln;
(* The angle in all trigonometric functions is measured in radians *)
PROCEDURE sin* (x: LONGREAL): LONGREAL;
BEGIN
IF x<ZERO THEN RETURN SinCos(x, -x, -ONE)
ELSE RETURN SinCos(x, x, ONE)
END
END sin;
PROCEDURE cos* (x: LONGREAL): LONGREAL;
BEGIN
RETURN SinCos(x, ABS(x)+piByTwo, ONE)
END cos;
PROCEDURE tan*(x: LONGREAL): LONGREAL;
(* Returns the tangent of x where x cannot be an odd multiple of pi/2 *)
VAR Sin, Cos: LONGREAL;
BEGIN
sincos(x, Sin, Cos);
IF ABS(Cos)<miny THEN l.ErrorHandler(IllegalTrig); RETURN huge
ELSE RETURN Sin/Cos
END
END tan;
PROCEDURE arcsin*(x: LONGREAL): LONGREAL;
(* Returns the arcsine of x, in the range [-pi/2, pi/2] where -1 <= x <= 1 *)
BEGIN
IF ABS(x)>ONE THEN l.ErrorHandler(IllegalInvTrig); RETURN huge
ELSE RETURN arctan2(x, sqrt(ONE-x*x))
END
END arcsin;
PROCEDURE arccos*(x: LONGREAL): LONGREAL;
(* Returns the arccosine of x, in the range [0, pi] where -1 <= x <= 1 *)
BEGIN
IF ABS(x)>ONE THEN l.ErrorHandler(IllegalInvTrig); RETURN huge
ELSE RETURN arctan2(sqrt(ONE-x*x), x)
END
END arccos;
PROCEDURE arctan*(x: LONGREAL): LONGREAL;
(* Returns the arctangent of x, in the range [-pi/2, pi/2] for all x *)
BEGIN
RETURN arctan2(x, ONE)
END arctan;
PROCEDURE power*(base, exponent: LONGREAL): LONGREAL;
(* Returns the value of the number base raised to the power exponent
for base > 0 *)
CONST
P1=0.83333333333333211405D-1; P2=0.12500000000503799174D-1;
P3=0.22321421285924258967D-2; P4=0.43445775672163119635D-3;
K=0.44269504088896340736D0;
Q1=0.69314718055994529629D+0; Q2=0.24022650695909537056D+0;
Q3=0.55504108664085595326D-1; Q4=0.96181290595172416964D-2;
Q5=0.13333541313585784703D-2; Q6=0.15400290440989764601D-3;
Q7=0.14928852680595608186D-4;
OneOver16=0.0625D0; XMAX=16*l.expoMax-1; (*XMIN=16*l.expoMin+1;*) XMIN=-16351; (* noch *)
VAR z, g, R, v, u2, u1, w1, w2, y1, y2, w: LONGREAL; m, p, i: INTEGER; mp, pp, iw1: LONGINT;
BEGIN
(* handle all possible error conditions *)
IF ABS(exponent)<miny THEN RETURN ONE (* base**0 = 1 *)
ELSIF base<ZERO THEN l.ErrorHandler(IllegalPower); RETURN -huge
ELSIF ABS(base)<miny THEN
IF exponent>ZERO THEN RETURN ZERO ELSE l.ErrorHandler(Overflow); RETURN -huge END
END;
(* extract the exponent of base to m and clear exponent of base in g *)
g:=l.fraction(base)*HALF; m:=l.exponent(base)+1;
(* determine p table offset with an unrolled binary search *)
p:=1;
IF g<=a1[9] THEN p:=9 END;
IF g<=a1[p+4] THEN INC(p, 4) END;
IF g<=a1[p+2] THEN INC(p, 2) END;
(* compute scaled z so that |z| <= 0.044 *)
z:=((g-a1[p+1])-a2[(p+1) DIV 2])/(g+a1[p+1]); z:=z+z;
(* approximation for log2(z) from "Software Manual for the Elementary Functions" *)
v:=z*z; R:=(((P4*v+P3)*v+P2)*v+P1)*v*z; R:=R+K*R; u2:=(R+z*K)+z; u1:=(m*16-p)*OneOver16;
(* generate w with extra precision calculations *)
y1:=ENTIER(16*exponent)*OneOver16; y2:=exponent-y1; w:=u2*exponent+u1*y2;
w1:=ENTIER(16*w)*OneOver16; w2:=w-w1; w:=w1+u1*y1;
w1:=ENTIER(16*w)*OneOver16; w2:=w2+(w-w1); w:=ENTIER(16*w2)*OneOver16;
iw1:=ENTIER(16*(w+w1)); w2:=w2-w;
(* check for overflow/underflow *)
IF iw1>XMAX THEN l.ErrorHandler(Overflow); RETURN huge
ELSIF iw1<XMIN THEN RETURN ZERO (* underflow *)
END;
(* final approximation 2**w2-1 where -0.0625 <= w2 <= 0 *)
IF w2>ZERO THEN INC(iw1); w2:=w2-OneOver16 END; IF iw1<0 THEN i:=0 ELSE i:=1 END;
mp:=div(iw1, 16)+i; pp:=16*mp-iw1;
z:=((((((Q7*w2+Q6)*w2+Q5)*w2+Q4)*w2+Q3)*w2+Q2)*w2+Q1)*w2; z:=a1[pp+1]+a1[pp+1]*z;
RETURN l.scale(z, SHORT(mp))
END power;
PROCEDURE round*(x: LONGREAL): LONGINT;
(* Returns the value of x rounded to the nearest integer *)
BEGIN
IF x<ZERO THEN RETURN -ENTIER(HALF-x)
ELSE RETURN ENTIER(x+HALF)
END
END round;
PROCEDURE IsRMathException*(): BOOLEAN;
(* Returns TRUE if the current coroutine is in the exceptional execution state
because of the raising of the RealMath exception; otherwise returns FALSE.
*)
BEGIN
RETURN FALSE
END IsRMathException;
(*
Following routines are provided as extensions to the ISO standard.
They are either used as the basis of other functions or provide
useful functions which are not part of the ISO standard.
*)
PROCEDURE log* (x, base: LONGREAL): LONGREAL;
(* log(x,base) is the logarithm of x base b. All positive arguments are
allowed but base > 0 and base # 1. *)
BEGIN
(* log(x, base) = log2(x) / log2(base) *)
IF base<=ZERO THEN l.ErrorHandler(IllegalLogBase); RETURN -huge
ELSE RETURN ln(x)/ln(base)
END
END log;
PROCEDURE ipower* (x: LONGREAL; base: INTEGER): LONGREAL;
(* ipower(x, base) returns the x to the integer power base where base*Log2(x) < Log2(Max) *)
VAR y: LONGREAL; neg: BOOLEAN; Exp: LONGINT;
PROCEDURE Adjust(xadj: LONGREAL): LONGREAL;
BEGIN
IF (x<ZERO)&ODD(base) THEN RETURN -xadj ELSE RETURN xadj END
END Adjust;
BEGIN
(* handle all possible error conditions *)
IF base=0 THEN RETURN ONE (* x**0 = 1 *)
ELSIF ABS(x)<miny THEN
IF base>0 THEN RETURN ZERO ELSE l.ErrorHandler(Overflow); RETURN Adjust(huge) END
END;
(* trap potential overflows and underflows *)
Exp:=(l.exponent(x)+1)*base; y:=LnInfinity*ln2Inv;
IF Exp>y THEN l.ErrorHandler(Overflow); RETURN Adjust(huge)
ELSIF Exp<-y THEN RETURN ZERO
END;
(* compute x**base using an optimised algorithm from Knuth, slightly
altered : p442, The Art Of Computer Programming, Vol 2 *)
y:=ONE; IF base<0 THEN neg:=TRUE; base := -base ELSE neg:= FALSE END;
LOOP
IF ODD(base) THEN y:=y*x END;
base:=base DIV 2; IF base=0 THEN EXIT END;
x:=x*x;
END;
IF neg THEN RETURN ONE/y ELSE RETURN y END
END ipower;
PROCEDURE sincos* (x: LONGREAL; VAR Sin, Cos: LONGREAL);
(* More efficient sin/cos implementation if both values are needed. *)
BEGIN
Sin:=sin(x); Cos:=sqrt(ONE-Sin*Sin)
END sincos;
PROCEDURE arctan2* (xn, xd: LONGREAL): LONGREAL;
(* arctan2(xn,xd) is the quadrant-correct arc tangent atan(xn/xd). If the
denominator xd is zero, then the numerator xn must not be zero. All
arguments are legal except xn = xd = 0. *)
CONST
P0=0.216062307897242551884D+3; P1=0.3226620700132512059245D+3;
P2=0.13270239816397674701D+3; P3=0.1288838303415727934D+2;
Q0=0.2160623078972426128957D+3; Q1=0.3946828393122829592162D+3;
Q2=0.221050883028417680623D+3; Q3=0.3850148650835119501D+2;
PiOver2=pi/2; Sqrt3=1.7320508075688772935D0;
VAR atan, z, z2, p, q: LONGREAL; xnExp, xdExp: INTEGER; Quadrant: SHORTINT;
BEGIN
IF ABS(xd)<miny THEN
IF ABS(xn)<miny THEN l.ErrorHandler(IllegalInvTrig); atan:=ZERO
ELSE l.ErrorHandler(Overflow); atan:=PiOver2
END
ELSE xnExp:=l.exponent(xn); xdExp:=l.exponent(xd);
IF xnExp-xdExp>=l.expoMax-3 THEN l.ErrorHandler(Overflow); atan:=PiOver2
ELSIF xnExp-xdExp<l.expoMin+3 THEN atan:=ZERO
ELSE
(* ensure division of xn/xd always produces a number < 1 & resolve quadrant *)
IF ABS(xn)>ABS(xd) THEN z:=ABS(xd/xn); Quadrant:=2
ELSE z:=ABS(xn/xd); Quadrant:=0
END;
(* further reduce range to within 0 to 2-sqrt(3) *)
IF z>TWO-Sqrt3 THEN z:=(z*Sqrt3-ONE)/(Sqrt3+z); INC(Quadrant) END;
(* approximation from "Computer Approximations" table ARCTN 5075 *)
IF ABS(z)<Limit THEN atan:=z (* for small values of z2, return this value *)
ELSE z2:=z*z; p:=(((P3*z2+P2)*z2+P1)*z2+P0)*z; q:=(((z2+Q3)*z2+Q2)*z2+Q1)*z2+Q0; atan:=p/q;
END;
(* adjust for z's quadrant *)
IF Quadrant>1 THEN atan:=-atan END;
CASE Quadrant OF
1: atan:=atan+pi/6
| 2: atan:=atan+PiOver2
| 3: atan:=atan+pi/3
| ELSE (* angle is correct *)
END
END;
(* map negative xds into the correct quadrant *)
IF xd<ZERO THEN atan:=pi-atan END
END;
(* map negative xns into the correct quadrant *)
IF xn<ZERO THEN atan:=-atan END;
RETURN atan
END arctan2;
PROCEDURE sinh* (x: LONGREAL): LONGREAL;
(* sinh(x) is the hyperbolic sine of x. The argument x must not be so large
that exp(|x|) overflows. *)
CONST
P0=-0.35181283430177117881D+6; P1=-0.11563521196851768270D+5;
P2=-0.16375798202630751372D+3; P3=-0.78966127417357099479D+0;
Q0=-0.21108770058106271242D+7; Q1= 0.36162723109421836460D+5;
Q2=-0.27773523119650701667D+3;
VAR y, f, p, q: LONGREAL;
BEGIN y:=ABS(x);
IF y<=ONE THEN (* handle small arguments *)
IF y<Limit THEN RETURN x END;
(* use approximation from "Software Manual for the Elementary Functions" *)
f:=y*y; p:=((P3*f+P2)*f+P1)*f+P0; q:=((f+Q2)*f+Q1)*f+Q0; y:=f*(p/q); RETURN x+x*y
ELSIF y>LnInfinity THEN (* handle exp overflows *)
y:=y-lnv;
IF y>LnInfinity-lnv+0.69 THEN l.ErrorHandler(Overflow);
IF x>ZERO THEN RETURN huge ELSE RETURN -huge END
ELSE f:=exp(y); f:=f+f*vbytwo (* don't change to f(1+vbytwo) *)
END
ELSE f:=exp(y); f:=(f-ONE/f)*HALF
END;
(* reach here when 1 < ABS(x) < LnInfinity-lnv+0.69 *)
IF x>ZERO THEN RETURN f ELSE RETURN -f END
END sinh;
PROCEDURE cosh* (x: LONGREAL): LONGREAL;
(* cosh(x) is the hyperbolic cosine of x. The argument x must not be so large
that exp(|x|) overflows. *)
VAR y, f: LONGREAL;
BEGIN y:=ABS(x);
IF y>LnInfinity THEN (* handle exp overflows *)
y:=y-lnv;
IF y>LnInfinity-lnv+0.69 THEN l.ErrorHandler(Overflow);
IF x>ZERO THEN RETURN huge ELSE RETURN -huge END
ELSE f:=exp(y); RETURN f+f*vbytwo (* don't change to f(1+vbytwo) *)
END
ELSE f:=exp(y); RETURN (f+ONE/f)*HALF
END
END cosh;
PROCEDURE tanh* (x: LONGREAL): LONGREAL;
(* tanh(x) is the hyperbolic tangent of x. All arguments are legal. *)
CONST
P0=-0.16134119023996228053D+4; P1=-0.99225929672236083313D+2; P2=-0.96437492777225469787D+0;
Q0= 0.48402357071988688686D+4; Q1= 0.22337720718962312926D+4; Q2= 0.11274474380534949335D+3;
ln3over2=0.54930614433405484570D0;
BIG=19.06154747D0; (* (ln(2)+(t+1)*ln(B))/2 where t=mantissa bits, B=base *)
VAR f, t: LONGREAL;
BEGIN f:=ABS(x);
IF f>BIG THEN t:=ONE
ELSIF f>ln3over2 THEN t:=ONE-TWO/(exp(TWO*f)+ONE)
ELSIF f<Limit THEN t:=f
ELSE (* approximation from "Software Manual for the Elementary Functions" *)
t:=f*f; t:=t*(((P2*t+P1)*t+P0)/(((t+Q2)*t+Q1)*t+Q0)); t:=f+f*t
END;
IF x<ZERO THEN RETURN -t ELSE RETURN t END
END tanh;
PROCEDURE arcsinh* (x: LONGREAL): LONGREAL;
(* arcsinh(x) is the arc hyperbolic sine of x. All arguments are legal. *)
BEGIN
IF ABS(x)>SqrtInfinity*HALF THEN l.ErrorHandler(HypInvTrigClipped);
IF x>ZERO THEN RETURN ln(SqrtInfinity) ELSE RETURN -ln(SqrtInfinity) END;
ELSIF x<ZERO THEN RETURN -ln(-x+sqrt(x*x+ONE))
ELSE RETURN ln(x+sqrt(x*x+ONE))
END
END arcsinh;
PROCEDURE arccosh* (x: LONGREAL): LONGREAL;
(* arccosh(x) is the arc hyperbolic cosine of x. All arguments greater than
or equal to 1 are legal. *)
BEGIN
IF x<ONE THEN l.ErrorHandler(IllegalHypInvTrig); RETURN ZERO
ELSIF x>SqrtInfinity*HALF THEN l.ErrorHandler(HypInvTrigClipped); RETURN ln(SqrtInfinity)
ELSE RETURN ln(x+sqrt(x*x-ONE))
END
END arccosh;
PROCEDURE arctanh* (x: LONGREAL): LONGREAL;
(* arctanh(x) is the arc hyperbolic tangent of x. |x| < 1 - sqrt(em), where
em is machine epsilon. Note that |x| must not be so close to 1 that the
result is less accurate than half precision. *)
CONST TanhLimit=0.999984991D0; (* Tanh(5.9) *)
VAR t: LONGREAL;
BEGIN t:=ABS(x);
IF (t>=ONE) OR (t>(ONE-TWO*em)) THEN l.ErrorHandler(IllegalHypInvTrig);
IF x<ZERO THEN RETURN -TanhMax ELSE RETURN TanhMax END
ELSIF t>TanhLimit THEN l.ErrorHandler(LossOfAccuracy)
END;
RETURN arcsinh(x/sqrt(ONE-x*x))
END arctanh;
PROCEDURE ToLONGREAL(h: HUGEINT): LONGREAL;
BEGIN RETURN SYSTEM.VAL(LONGREAL, h)
END ToLONGREAL;
BEGIN
(* determine some fundamental constants used by hyperbolic trig functions *)
em:=l.ulp(ONE);
LnInfinity:=ln(huge);
LnSmall:=ln(miny);
SqrtInfinity:=sqrt(huge);
t:=l.pred(ONE)/sqrt(em); TanhMax:=ln(t+sqrt(t*t+ONE));
(* initialize some tables for the power() function a1[i]=2**((1-i)/16) *)
(* disable compiler warnings about 32-bit negative integers *)
(*<* PUSH; Warnings := FALSE *>*)
a1[ 1] := ONE;
a1[ 2] := ToLONGREAL(3FEEA4AFA2A490DAH);
a1[ 3] := ToLONGREAL(3FED5818DCFBA487H);
a1[ 4] := ToLONGREAL(3FEC199BDD85529CH);
a1[ 5] := ToLONGREAL(3FEAE89F995AD3ADH);
a1[ 6] := ToLONGREAL(3FE9C49182A3F090H);
a1[ 7] := ToLONGREAL(3FE8ACE5422AA0DBH);
a1[ 8] := ToLONGREAL(3FE7A11473EB0186H);
a1[ 9] := ToLONGREAL(3FE6A09E667F3BCCH);
a1[10] := ToLONGREAL(3FE5AB07DD485429H);
a1[11] := ToLONGREAL(3FE4BFDAD5362A27H);
a1[12] := ToLONGREAL(3FE3DEA64C123422H);
a1[13] := ToLONGREAL(3FE306FE0A31B715H);
a1[14] := ToLONGREAL(3FE2387A6E756238H);
a1[15] := ToLONGREAL(3FE172B83C7D517AH);
a1[16] := ToLONGREAL(3FE0B5586CF9890FH);
a1[17] := HALF;
(* a2[i]=2**[(1-2i)/16] - a1[2i]; delta resolution *)
a2[1] := ToLONGREAL(3C90B1EE74320000H);
a2[2] := ToLONGREAL(3C71106589500000H);
a2[3] := ToLONGREAL(3C6C7C46B0700000H);
a2[4] := ToLONGREAL(3C9AFAA2047F0000H);
a2[5] := ToLONGREAL(3C86324C05460000H);
a2[6] := ToLONGREAL(3C7ADA0911F00000H);
a2[7] := ToLONGREAL(3C89B07EB6C80000H);
a2[8] := ToLONGREAL(3C88A62E4ADC0000H);
(* reenable compiler warnings *)
(*<* POP *>*)
END MathL.

96
src/runtime/Modules.Mod Normal file
View file

@ -0,0 +1,96 @@
MODULE Modules; (* jt 6.1.96 *)
(* access to list of modules and commands, based on ETH Oberon *)
IMPORT SYSTEM, Heap;
CONST
ModNameLen* = 20;
TYPE
ModuleName* = ARRAY ModNameLen OF CHAR;
Module* = POINTER TO ModuleDesc;
Cmd* = POINTER TO CmdDesc;
ModuleDesc* = RECORD (* cf. SYSTEM.Mod *)
next-: Module;
name-: ModuleName;
refcnt-: LONGINT;
cmds-: Cmd;
types-: LONGINT;
enumPtrs-: PROCEDURE (P: PROCEDURE(p: LONGINT));
reserved1, reserved2: LONGINT;
END ;
Command* = PROCEDURE;
CmdDesc* = RECORD
next-: Cmd;
name-: ARRAY 24 OF CHAR;
cmd-: Command
END ;
VAR
res*: INTEGER;
resMsg*: ARRAY 256 OF CHAR;
imported*, importing*: ModuleName;
PROCEDURE -modules*(): Module
"(Modules_Module)Heap_modules";
PROCEDURE -setmodules*(m: Module)
"Heap_modules = m";
PROCEDURE Append(VAR a: ARRAY OF CHAR; b: ARRAY OF CHAR);
VAR i, j: INTEGER;
BEGIN
i := 0; WHILE a[i] # 0X DO INC(i) END;
j := 0; WHILE b[j] # 0X DO a[i] := b[j]; INC(i); INC(j) END;
a[i] := 0X
END Append;
PROCEDURE ThisMod* (name: ARRAY OF CHAR): Module;
VAR m: Module; bodyname: ARRAY 64 OF CHAR; body: Command;
BEGIN m := modules();
WHILE (m # NIL) & (m.name # name) DO m := m.next END ;
IF m # NIL THEN res := 0; resMsg := ""
ELSE res := 1; COPY(name, importing);
resMsg := ' module "'; Append(resMsg, name); Append(resMsg, '" not found');
END ;
RETURN m
END ThisMod;
PROCEDURE ThisCommand* (mod: Module; name: ARRAY OF CHAR): Command;
VAR c: Cmd;
BEGIN c := mod.cmds;
WHILE (c # NIL) & (c.name # name) DO c := c.next END ;
IF c # NIL THEN res := 0; resMsg := ""; RETURN c.cmd
ELSE res := 2; resMsg := ' command "'; COPY(name, importing);
Append(resMsg, mod.name); Append(resMsg, "."); Append(resMsg, name); Append(resMsg, '" not found');
RETURN NIL
END
END ThisCommand;
PROCEDURE Free*(name: ARRAY OF CHAR; all: BOOLEAN);
VAR m, p: Module;
BEGIN m := modules();
IF all THEN
res := 1; resMsg := 'unloading "all" not yet supported'
ELSE
WHILE (m # NIL) & (m.name # name) DO p := m; m := m.next END ;
IF (m # NIL) & (m.refcnt = 0) THEN
IF m = modules() THEN setmodules(m.next)
ELSE p.next := m.next
END ;
res := 0
ELSE res := 1;
IF m = NIL THEN resMsg := "module not found"
ELSE resMsg := "clients of this module exist"
END
END
END
END Free;
END Modules.

74
src/runtime/Oberon.Mod Normal file
View file

@ -0,0 +1,74 @@
MODULE Oberon;
(* this version should not have dependency on graphics -- noch *)
IMPORT Platform, Texts, Out;
TYPE
ParList* = POINTER TO ParRec;
ParRec* = RECORD
(*
vwr*: Viewers.Viewer;
frame*: Display.Frame;
*)
text*: Texts.Text;
pos*: LONGINT
END;
VAR
Log*: Texts.Text;
Par*: ParList; (*actual parameters*)
OptionChar*: CHAR;
R: Texts.Reader;
W: Texts.Writer;
(*clocks*)
PROCEDURE GetClock* (VAR t, d: LONGINT);
BEGIN Platform.GetClock(t, d)
END GetClock;
PROCEDURE Time* (): LONGINT;
BEGIN RETURN Platform.Time()
END Time;
PROCEDURE PopulateParams;
VAR W: Texts.Writer; i: INTEGER; str: ARRAY 256 OF CHAR;
BEGIN
Texts.OpenWriter(W);
i := 1; (* skip program name *)
WHILE i < Platform.ArgCount DO
Platform.GetArg(i, str); Texts.WriteString(W, str); Texts.Write(W, " ");
INC(i)
END;
Texts.Append (Par^.text, W.buf);
END PopulateParams;
PROCEDURE GetSelection*(VAR text: Texts.Text; VAR beg, end, time: LONGINT);
BEGIN text := NIL; beg := 0; end := 0; time := 0
END GetSelection;
(* --- Notifier for echoing to the comsole all text appended to the log. --- *)
PROCEDURE LogNotifier(Log: Texts.Text; op: INTEGER; beg, end: LONGINT);
VAR ch: CHAR;
BEGIN
Texts.OpenReader(R, Log, beg);
WHILE ~R.eot & (beg < end) DO
Texts.Read(R, ch);
IF ch = 0DX THEN Out.Ln ELSE Out.Char(ch) END;
INC(beg)
END
END LogNotifier;
BEGIN
NEW(Par);
NEW(Par.text);
Par.pos := 0;
OptionChar := '-';
Texts.Open(Par.text, "");
PopulateParams;
NEW(Log);
Texts.Open(Log, "");
Log.notify := LogNotifier;
END Oberon.

55
src/runtime/Out.Mod Normal file
View file

@ -0,0 +1,55 @@
MODULE Out; (* D C W Brown. 2016-09-27 *)
IMPORT SYSTEM, Platform;
PROCEDURE Open*;
BEGIN
END Open;
PROCEDURE Char*(ch: CHAR);
VAR error: Platform.ErrorCode;
BEGIN
error := Platform.Write(Platform.StdOut, SYSTEM.ADR(ch), 1)
END Char;
PROCEDURE String*(str: ARRAY OF CHAR);
VAR l: LONGINT; error: Platform.ErrorCode;
BEGIN
l := 0; WHILE (l < LEN(str)) & (str[l] # 0X) DO INC(l) END;
error := Platform.Write(Platform.StdOut, SYSTEM.ADR(str), l)
END String;
PROCEDURE Int*(x: HUGEINT; n: LONGINT);
CONST zero = ORD('0');
VAR s: ARRAY 22 OF CHAR; i: INTEGER; negative: BOOLEAN;
BEGIN
negative := x < 0;
IF x = MIN(HUGEINT) THEN
s := "8085774586302733229"; i := 19
ELSE
IF x < 0 THEN x := - x END;
s[0] := CHR(zero + (x MOD 10)); x := x DIV 10;
i := 1; WHILE x # 0 DO
s[i] := CHR(zero + (x MOD 10));
x := x DIV 10;
INC(i)
END
END;
IF negative THEN s[i] := '-'; INC(i) END;
WHILE n > i DO Char(' '); DEC(n) END;
WHILE i > 0 DO DEC(i); Char(s[i]) END
END Int;
PROCEDURE Real*(x: REAL; n: INTEGER);
BEGIN
END Real;
PROCEDURE LongReal*(x: LONGREAL; n: INTEGER);
BEGIN
END LongReal;
PROCEDURE Ln*;
BEGIN String(Platform.NL)
END Ln;
END Out.

552
src/runtime/Platformunix.Mod Normal file
View file

@ -0,0 +1,552 @@
MODULE Platform;
IMPORT SYSTEM;
CONST
StdIn- = 0;
StdOut- = 1;
StdErr- = 2;
TYPE
HaltProcedure = PROCEDURE(n: LONGINT);
SignalHandler = PROCEDURE(signal: INTEGER);
ErrorCode* = INTEGER;
FileHandle* = LONGINT;
FileIdentity* = RECORD
volume: LONGINT; (* dev on Unix filesystems, volume serial number on NTFS *)
index: LONGINT; (* inode on Unix filesystems, file id on NTFS *)
mtime: LONGINT; (* File modification time, value is system dependent *)
END;
EnvPtr = POINTER TO ARRAY 1024 OF CHAR;
ArgPtr = POINTER TO ARRAY 1024 OF CHAR;
ArgVec = POINTER TO ARRAY 1024 OF ArgPtr;
ArgVecPtr = POINTER TO ARRAY 1 OF SYSTEM.ADDRESS;
VAR
LittleEndian-: BOOLEAN;
MainStackFrame-: SYSTEM.ADDRESS;
HaltCode-: LONGINT;
PID-: INTEGER; (* Note: Must be updated by Fork implementation *)
CWD-: ARRAY 256 OF CHAR;
ArgCount-: INTEGER;
ArgVector-: SYSTEM.ADDRESS;
HaltHandler: HaltProcedure;
TimeStart: LONGINT;
SeekSet-: INTEGER;
SeekCur-: INTEGER;
SeekEnd-: INTEGER;
NL-: ARRAY 3 OF CHAR; (* Platform specific newline representation *)
(* Unix headers to be included *)
PROCEDURE -Aincludesystime '#include <sys/time.h>'; (* for gettimeofday *)
PROCEDURE -Aincludetime '#include <time.h>'; (* for localtime *)
PROCEDURE -Aincludesystypes '#include <sys/types.h>';
PROCEDURE -Aincludeunistd '#include <unistd.h>';
PROCEDURE -Aincludesysstat '#include <sys/stat.h>';
PROCEDURE -Aincludefcntl '#include <fcntl.h>';
PROCEDURE -Aincludeerrno '#include <errno.h>';
PROCEDURE -Astdlib '#include <stdlib.h>';
PROCEDURE -Astdio '#include <stdio.h>';
PROCEDURE -Aerrno '#include <errno.h>';
(* Error code tests *)
PROCEDURE -EMFILE(): ErrorCode 'EMFILE';
PROCEDURE -ENFILE(): ErrorCode 'ENFILE';
PROCEDURE -ENOENT(): ErrorCode 'ENOENT';
PROCEDURE -EXDEV(): ErrorCode 'EXDEV';
PROCEDURE -EACCES(): ErrorCode 'EACCES';
PROCEDURE -EROFS(): ErrorCode 'EROFS';
PROCEDURE -EAGAIN(): ErrorCode 'EAGAIN';
PROCEDURE -ETIMEDOUT(): ErrorCode 'ETIMEDOUT';
PROCEDURE -ECONNREFUSED(): ErrorCode 'ECONNREFUSED';
PROCEDURE -ECONNABORTED(): ErrorCode 'ECONNABORTED';
PROCEDURE -ENETUNREACH(): ErrorCode 'ENETUNREACH';
PROCEDURE -EHOSTUNREACH(): ErrorCode 'EHOSTUNREACH';
PROCEDURE -EINTR(): ErrorCode 'EINTR';
PROCEDURE TooManyFiles*(e: ErrorCode): BOOLEAN;
BEGIN RETURN (e = EMFILE()) OR (e = ENFILE()) END TooManyFiles;
PROCEDURE NoSuchDirectory*(e: ErrorCode): BOOLEAN;
BEGIN RETURN e = ENOENT() END NoSuchDirectory;
PROCEDURE DifferentFilesystems*(e: ErrorCode): BOOLEAN;
BEGIN RETURN e = EXDEV() END DifferentFilesystems;
PROCEDURE Inaccessible*(e: ErrorCode): BOOLEAN;
BEGIN RETURN (e = EACCES()) OR (e = EROFS()) OR (e = EAGAIN()) END Inaccessible;
PROCEDURE Absent*(e: ErrorCode): BOOLEAN;
BEGIN RETURN e = ENOENT() END Absent;
PROCEDURE TimedOut*(e: ErrorCode): BOOLEAN;
BEGIN RETURN e = ETIMEDOUT() END TimedOut;
PROCEDURE ConnectionFailed*(e: ErrorCode): BOOLEAN;
BEGIN RETURN (e = ECONNREFUSED()) OR (e = ECONNABORTED())
OR (e = ENETUNREACH()) OR (e = EHOSTUNREACH()) END ConnectionFailed;
PROCEDURE Interrupted*(e: ErrorCode): BOOLEAN;
BEGIN RETURN e = EINTR() END Interrupted;
(* OS memory allocaton *)
PROCEDURE -allocate (size: SYSTEM.ADDRESS): SYSTEM.ADDRESS "(address)((void*)malloc((size_t)size))";
PROCEDURE OSAllocate*(size: SYSTEM.ADDRESS): SYSTEM.ADDRESS; BEGIN RETURN allocate(size) END OSAllocate;
PROCEDURE -free(address: SYSTEM.ADDRESS) "free((void*)address)";
PROCEDURE OSFree*(address: SYSTEM.ADDRESS); BEGIN free(address) END OSFree;
(* Program startup *)
PROCEDURE -ExternInitHeap "extern void Heap_InitHeap();";
PROCEDURE -HeapInitHeap() "Heap_InitHeap()";
PROCEDURE Init*(argc: INTEGER; argvadr: SYSTEM.ADDRESS);
VAR av: ArgVecPtr;
BEGIN
MainStackFrame := argvadr;
ArgCount := argc;
av := SYSTEM.VAL(ArgVecPtr, argvadr);
ArgVector := av[0];
HaltCode := -128;
(* This function (Platform.Init) is called at program startup BEFORE any
modules have been initalised. In turn we must initialise the heap
before module startup (xxx__init) code is run. *)
HeapInitHeap();
END Init;
(* Program arguments and environment access *)
PROCEDURE -getenv(var: ARRAY OF CHAR): EnvPtr "(Platform_EnvPtr)getenv((char*)var)";
PROCEDURE getEnv*(var: ARRAY OF CHAR; VAR val: ARRAY OF CHAR): BOOLEAN;
VAR p: EnvPtr;
BEGIN
p := getenv(var);
IF p # NIL THEN COPY(p^, val) END;
RETURN p # NIL;
END getEnv;
PROCEDURE GetEnv*(var: ARRAY OF CHAR; VAR val: ARRAY OF CHAR);
BEGIN
IF ~ getEnv(var, val) THEN val[0] := 0X END;
END GetEnv;
PROCEDURE GetArg*(n: INTEGER; VAR val: ARRAY OF CHAR);
VAR av: ArgVec;
BEGIN
IF n < ArgCount THEN
av := SYSTEM.VAL(ArgVec,ArgVector);
COPY(av[n]^, val)
END
END GetArg;
PROCEDURE GetIntArg*(n: INTEGER; VAR val: LONGINT);
VAR s: ARRAY 64 OF CHAR; k, d, i: LONGINT;
BEGIN
s := ""; GetArg(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 k := -k; DEC(i) END ;
IF i > 0 THEN val := k END
END GetIntArg;
PROCEDURE ArgPos*(s: ARRAY OF CHAR): INTEGER;
VAR i: INTEGER; arg: ARRAY 256 OF CHAR;
BEGIN
i := 0; GetArg(i, arg);
WHILE (i < ArgCount) & (s # arg) DO INC(i); GetArg(i, arg) END ;
RETURN i
END ArgPos;
(* Signals and traps *)
PROCEDURE -sethandler(s: INTEGER; h: SignalHandler) "SystemSetHandler(s, (address)h)";
PROCEDURE SetInterruptHandler*(handler: SignalHandler);
BEGIN sethandler(2, handler); END SetInterruptHandler;
PROCEDURE SetQuitHandler*(handler: SignalHandler);
BEGIN sethandler(3, handler); END SetQuitHandler;
PROCEDURE SetBadInstructionHandler*(handler: SignalHandler);
BEGIN sethandler(4, handler); END SetBadInstructionHandler;
(* Time of day *)
PROCEDURE -gettimeval "struct timeval tv; gettimeofday(&tv,0)";
PROCEDURE -tvsec(): LONGINT "tv.tv_sec";
PROCEDURE -tvusec(): LONGINT "tv.tv_usec";
PROCEDURE -sectotm(s: LONGINT) "struct tm *time = localtime((time_t*)&s)";
PROCEDURE -tmsec(): LONGINT "(LONGINT)time->tm_sec";
PROCEDURE -tmmin(): LONGINT "(LONGINT)time->tm_min";
PROCEDURE -tmhour(): LONGINT "(LONGINT)time->tm_hour";
PROCEDURE -tmmday(): LONGINT "(LONGINT)time->tm_mday";
PROCEDURE -tmmon(): LONGINT "(LONGINT)time->tm_mon";
PROCEDURE -tmyear(): LONGINT "(LONGINT)time->tm_year";
PROCEDURE YMDHMStoClock(ye,mo,da,ho,mi,se: LONGINT; VAR t, d: LONGINT);
BEGIN
d := ASH(ye MOD 100, 9) + ASH(mo+1, 5) + da;
t := ASH(ho, 12) + ASH(mi, 6) + se;
END YMDHMStoClock;
PROCEDURE GetClock*(VAR t, d: LONGINT);
BEGIN
gettimeval; sectotm(tvsec());
YMDHMStoClock(tmyear(), tmmon(), tmmday(), tmhour(), tmmin(), tmsec(), t, d);
END GetClock;
PROCEDURE GetTimeOfDay*(VAR sec, usec: LONGINT);
BEGIN
gettimeval; sec := tvsec(); usec := tvusec();
END GetTimeOfDay;
PROCEDURE Time*(): LONGINT;
VAR ms: LONGINT;
BEGIN
gettimeval;
ms := (tvusec() DIV 1000) + (tvsec() * 1000);
RETURN (ms - TimeStart) MOD 7FFFFFFFH;
END Time;
PROCEDURE -nanosleep(s: LONGINT; ns: LONGINT) "struct timespec req, rem; req.tv_sec = s; req.tv_nsec = ns; nanosleep(&req, &rem)";
PROCEDURE Delay*(ms: LONGINT);
VAR s, ns: LONGINT;
BEGIN
s := ms DIV 1000;
ns := (ms MOD 1000) * 1000000;
nanosleep(s, ns);
END Delay;
(* System call *)
PROCEDURE -system(str: ARRAY OF CHAR): INTEGER "system((char*)str)";
PROCEDURE -err(): INTEGER "errno";
PROCEDURE System*(cmd : ARRAY OF CHAR): INTEGER;
BEGIN RETURN system(cmd); END System;
PROCEDURE Error*(): ErrorCode; BEGIN RETURN err() END Error;
(* File system *)
(* Note: Consider also using flags O_SYNC and O_DIRECT as we do buffering *)
PROCEDURE -openrw (n: ARRAY OF CHAR): INTEGER "open((char*)n, O_RDWR)";
PROCEDURE -openro (n: ARRAY OF CHAR): INTEGER "open((char*)n, O_RDONLY)";
PROCEDURE -opennew(n: ARRAY OF CHAR): INTEGER "open((char*)n, O_CREAT | O_TRUNC | O_RDWR, 0664)";
(* File APIs *)
PROCEDURE OldRO*(VAR n: ARRAY OF CHAR; VAR h: FileHandle): ErrorCode;
VAR fd: INTEGER;
BEGIN
fd := openro(n);
IF (fd < 0) THEN RETURN err() ELSE h := fd; RETURN 0 END;
END OldRO;
PROCEDURE OldRW*(VAR n: ARRAY OF CHAR; VAR h: FileHandle): ErrorCode;
VAR fd: INTEGER;
BEGIN
fd := openrw(n);
IF (fd < 0) THEN RETURN err() ELSE h := fd; RETURN 0 END;
END OldRW;
PROCEDURE New*(VAR n: ARRAY OF CHAR; VAR h: FileHandle): ErrorCode;
VAR fd: INTEGER;
BEGIN
fd := opennew(n);
IF (fd < 0) THEN RETURN err() ELSE h := fd; RETURN 0 END;
END New;
PROCEDURE -closefile (fd: LONGINT): INTEGER "close(fd)";
PROCEDURE Close*(h: FileHandle): ErrorCode;
BEGIN
IF closefile(h) < 0 THEN RETURN err() ELSE RETURN 0 END
END Close;
PROCEDURE -fstat(fd: LONGINT): INTEGER "fstat(fd, &s)";
PROCEDURE -stat(n: ARRAY OF CHAR): INTEGER "stat((char*)n, &s)";
PROCEDURE -structstats "struct stat s";
PROCEDURE -statdev(): LONGINT "(LONGINT)s.st_dev";
PROCEDURE -statino(): LONGINT "(LONGINT)s.st_ino";
PROCEDURE -statmtime(): LONGINT "(LONGINT)s.st_mtime";
PROCEDURE -statsize(): LONGINT "(address)s.st_size";
PROCEDURE Identify*(h: FileHandle; VAR identity: FileIdentity): ErrorCode;
BEGIN
structstats;
IF fstat(h) < 0 THEN RETURN err() END;
identity.volume := statdev();
identity.index := statino();
identity.mtime := statmtime();
RETURN 0
END Identify;
PROCEDURE IdentifyByName*(n: ARRAY OF CHAR; VAR identity: FileIdentity): ErrorCode;
BEGIN
structstats;
IF stat(n) < 0 THEN RETURN err() END;
identity.volume := statdev();
identity.index := statino();
identity.mtime := statmtime();
RETURN 0
END IdentifyByName;
PROCEDURE SameFile*(i1, i2: FileIdentity): BOOLEAN;
BEGIN RETURN (i1.index = i2.index) & (i1.volume = i2.volume)
END SameFile;
PROCEDURE SameFileTime*(i1, i2: FileIdentity): BOOLEAN;
BEGIN RETURN i1.mtime = i2.mtime
END SameFileTime;
PROCEDURE SetMTime*(VAR target: FileIdentity; source: FileIdentity);
BEGIN target.mtime := source.mtime;
END SetMTime;
PROCEDURE MTimeAsClock*(i: FileIdentity; VAR t, d: LONGINT);
BEGIN
sectotm(i.mtime);
YMDHMStoClock(tmyear(), tmmon(), tmmday(), tmhour(), tmmin(), tmsec(), t, d);
END MTimeAsClock;
PROCEDURE Size*(h: FileHandle; VAR l: LONGINT): ErrorCode;
BEGIN
structstats;
IF fstat(h) < 0 THEN RETURN err() END;
l := statsize();
RETURN 0;
END Size;
PROCEDURE -readfile (fd: LONGINT; p: SYSTEM.ADDRESS; l: LONGINT): LONGINT
"(LONGINT)read(fd, (void*)(address)(p), l)";
PROCEDURE Read*(h: FileHandle; p: SYSTEM.ADDRESS; l: LONGINT; VAR n: LONGINT): ErrorCode;
BEGIN
n := readfile(h, p, l);
IF n < 0 THEN n := 0; RETURN err() ELSE RETURN 0 END
END Read;
PROCEDURE ReadBuf*(h: FileHandle; VAR b: ARRAY OF SYSTEM.BYTE; VAR n: LONGINT): ErrorCode;
BEGIN
n := readfile(h, SYSTEM.ADR(b), LEN(b));
IF n < 0 THEN n := 0; RETURN err() ELSE RETURN 0 END
END ReadBuf;
PROCEDURE -writefile(fd: LONGINT; p: SYSTEM.ADDRESS; l: SYSTEM.ADDRESS): SYSTEM.ADDRESS
"write(fd, (void*)(address)(p), l)";
PROCEDURE Write*(h: FileHandle; p: SYSTEM.ADDRESS; l: LONGINT): ErrorCode;
VAR written: SYSTEM.ADDRESS;
BEGIN
written := writefile(h, p, l);
IF written < 0 THEN RETURN err() ELSE RETURN 0 END
END Write;
PROCEDURE -fsync(fd: LONGINT): INTEGER "fsync(fd)";
PROCEDURE Sync*(h: FileHandle): ErrorCode;
BEGIN
IF fsync(h) < 0 THEN RETURN err() ELSE RETURN 0 END
END Sync;
PROCEDURE -lseek(fd: LONGINT; o: LONGINT; w: INTEGER): INTEGER "lseek(fd, o, w)";
PROCEDURE -seekset(): INTEGER "SEEK_SET";
PROCEDURE -seekcur(): INTEGER "SEEK_CUR";
PROCEDURE -seekend(): INTEGER "SEEK_END";
PROCEDURE Seek*(h: FileHandle; offset: LONGINT; whence: INTEGER): ErrorCode;
BEGIN
IF lseek(h, offset, whence) < 0 THEN RETURN err() ELSE RETURN 0 END
END Seek;
PROCEDURE -ftruncate(fd: LONGINT; l: LONGINT): INTEGER "ftruncate(fd, l)";
PROCEDURE Truncate*(h: FileHandle; l: LONGINT): ErrorCode;
BEGIN
IF (ftruncate(h, l) < 0) THEN RETURN err() ELSE RETURN 0 END;
END Truncate;
PROCEDURE -unlink(n: ARRAY OF CHAR): INTEGER "unlink((char*)n)";
PROCEDURE Unlink*(VAR n: ARRAY OF CHAR): ErrorCode;
BEGIN
IF unlink(n) < 0 THEN RETURN err() ELSE RETURN 0 END
END Unlink;
PROCEDURE -chdir(n: ARRAY OF CHAR): INTEGER "chdir((char*)n)";
PROCEDURE -getcwd(VAR cwd: ARRAY OF CHAR): SYSTEM.PTR "getcwd((char*)cwd, cwd__len)";
PROCEDURE Chdir*(VAR n: ARRAY OF CHAR): ErrorCode;
VAR r: INTEGER;
BEGIN
IF (chdir(n) >= 0) & (getcwd(CWD) # NIL) THEN RETURN 0
ELSE RETURN err() END
END Chdir;
PROCEDURE -rename(o,n: ARRAY OF CHAR): INTEGER "rename((char*)o, (char*)n)";
PROCEDURE Rename*(VAR o,n: ARRAY OF CHAR): ErrorCode;
BEGIN
IF rename(o,n) < 0 THEN RETURN err() ELSE RETURN 0 END
END Rename;
(* Process termination *)
PROCEDURE -exit(code: INTEGER) "exit(code)";
PROCEDURE Exit*(code: INTEGER);
BEGIN exit(code) END Exit;
PROCEDURE -errstring(s: ARRAY OF CHAR) 'write(1, s, s__len-1)';
PROCEDURE -errc (c: CHAR) 'write(1, &c, 1)';
PROCEDURE errch(c: CHAR); BEGIN errc(c) END errch;
PROCEDURE errln; BEGIN errch(0AX) END errln;
PROCEDURE errposint(l: LONGINT);
BEGIN IF l>10 THEN errposint(l DIV 10) END; errch(CHR(ORD('0') + (l MOD 10))) END errposint;
PROCEDURE errint(l: LONGINT);
BEGIN IF l<0 THEN errch('-'); l := -l END; errposint(l) END errint;
PROCEDURE DisplayHaltCode(code: LONGINT);
BEGIN
CASE code OF
| -1: errstring("Assertion failure.")
| -2: errstring("Index out of range.")
| -3: errstring("Reached end of function without reaching RETURN.")
| -4: errstring("CASE statement: no matching label and no ELSE.")
| -5: errstring("Type guard failed.")
| -6: errstring("Implicit type guard in record assignment failed.")
| -7: errstring("Invalid case in WITH statement.")
| -8: errstring("Value out of range.")
| -9: errstring("Heap interrupted while locked, but lockdepth = 0 at unlock.")
|-10: errstring("NIL access.");
|-11: errstring("Alignment error.");
|-12: errstring("Divide by zero.");
|-13: errstring("Arithmetic overflow/underflow.");
|-14: errstring("Invalid function argument.");
|-15: errstring("Internal error, e.g. Type descriptor size mismatch.")
|-20: errstring("Too many, or negative number of, elements in dynamic array.")
ELSE
END
END DisplayHaltCode;
PROCEDURE Halt*(code: LONGINT);
BEGIN
HaltCode := code;
IF HaltHandler # NIL THEN HaltHandler(code) END;
errstring("Terminated by Halt("); errint(code); errstring("). ");
IF code < 0 THEN DisplayHaltCode(code) END;
errln;
exit(SYSTEM.VAL(INTEGER,code));
END Halt;
PROCEDURE AssertFail*(code: LONGINT);
BEGIN
errstring("Assertion failure.");
IF code # 0 THEN errstring(" ASSERT code "); errint(code); errstring("."); END;
errln;
exit(SYSTEM.VAL(INTEGER,code));
END AssertFail;
PROCEDURE SetHalt*(p: HaltProcedure);
BEGIN HaltHandler := p; END SetHalt;
PROCEDURE TestLittleEndian;
VAR i: INTEGER;
BEGIN i := 1; SYSTEM.GET(SYSTEM.ADR(i), LittleEndian); END TestLittleEndian;
PROCEDURE -getpid(): INTEGER "(INTEGER)getpid()";
BEGIN
TestLittleEndian;
HaltCode := -128;
HaltHandler := NIL;
TimeStart := 0; TimeStart := Time();
PID := getpid();
IF getcwd(CWD) = NIL THEN CWD := "" END;
SeekSet := seekset();
SeekCur := seekcur();
SeekEnd := seekend();
NL[0] := 0AX; (* LF *)
NL[1] := 0X;
END Platform.

622
src/runtime/Platformwindows.Mod Normal file
View file

@ -0,0 +1,622 @@
MODULE Platform;
IMPORT SYSTEM;
(* TODO:
Use Unicode APIs with manual UTF8 conversion and prepend '\\?\' to
file paths in order to get 32768 character path length limit (as
opposed to 256 bytes. *)
TYPE
HaltProcedure = PROCEDURE(n: LONGINT);
SignalHandler = PROCEDURE(signal: INTEGER);
ErrorCode* = INTEGER;
FileHandle* = LONGINT;
FileIdentity* = RECORD
volume: LONGINT; (* dev on Unix filesystems, volume serial number on NTFS *)
indexhigh: LONGINT; (* inode on Unix filesystems, file id on NTFS *)
indexlow: LONGINT;
mtimehigh: LONGINT; (* File modification time, value is system dependent *)
mtimelow: LONGINT; (* File modification time, value is system dependent *)
END;
EnvPtr = POINTER TO ARRAY 1024 OF CHAR;
ArgPtr = POINTER TO ARRAY 1024 OF CHAR;
ArgVec = POINTER TO ARRAY 1024 OF ArgPtr;
ArgVecPtr = POINTER TO ARRAY 1 OF SYSTEM.ADDRESS;
VAR
LittleEndian-: BOOLEAN;
MainStackFrame-: SYSTEM.ADDRESS;
HaltCode-: LONGINT;
PID-: INTEGER; (* Note: Must be updated by Fork implementation *)
CWD-: ARRAY 4096 OF CHAR;
ArgCount-: INTEGER;
ArgVector-: SYSTEM.ADDRESS;
HaltHandler: HaltProcedure;
TimeStart: LONGINT;
SeekSet-: INTEGER;
SeekCur-: INTEGER;
SeekEnd-: INTEGER;
StdIn-: FileHandle;
StdOut-: FileHandle;
StdErr-: FileHandle;
InterruptHandler: SignalHandler;
nl-: ARRAY 3 OF CHAR; (* Platform specific newline representation *)
PROCEDURE -AincludeWindowsWrapper '#include "WindowsWrapper.h"';
(* Error code tests *)
PROCEDURE -ERRORTOOMANYOPENFILES(): ErrorCode 'ERROR_TOO_MANY_OPEN_FILES';
PROCEDURE -ERRORPATHNOTFOUND(): ErrorCode 'ERROR_PATH_NOT_FOUND';
PROCEDURE -ERRORFILENOTFOUND(): ErrorCode 'ERROR_FILE_NOT_FOUND';
PROCEDURE -ERRORNOTSAMEDEVICE(): ErrorCode 'ERROR_NOT_SAME_DEVICE';
PROCEDURE -ERRORACCESSDENIED(): ErrorCode 'ERROR_ACCESS_DENIED';
PROCEDURE -ERRORWRITEPROTECT(): ErrorCode 'ERROR_WRITE_PROTECT';
PROCEDURE -ERRORSHARINGVIOLATION(): ErrorCode 'ERROR_SHARING_VIOLATION';
PROCEDURE -ERRORNOTREADY(): ErrorCode 'ERROR_NOT_READY';
PROCEDURE -ETIMEDOUT(): ErrorCode 'WSAETIMEDOUT';
PROCEDURE -ECONNREFUSED(): ErrorCode 'WSAECONNREFUSED';
PROCEDURE -ECONNABORTED(): ErrorCode 'WSAECONNABORTED';
PROCEDURE -ENETUNREACH(): ErrorCode 'WSAENETUNREACH';
PROCEDURE -EHOSTUNREACH(): ErrorCode 'WSAEHOSTUNREACH';
PROCEDURE -EINTR(): ErrorCode 'WSAEINTR';
PROCEDURE TooManyFiles*(e: ErrorCode): BOOLEAN;
BEGIN RETURN e = ERRORTOOMANYOPENFILES() END TooManyFiles;
PROCEDURE NoSuchDirectory*(e: ErrorCode): BOOLEAN;
BEGIN RETURN e = ERRORPATHNOTFOUND() END NoSuchDirectory;
PROCEDURE DifferentFilesystems*(e: ErrorCode): BOOLEAN;
BEGIN RETURN e = ERRORNOTSAMEDEVICE() END DifferentFilesystems;
PROCEDURE Inaccessible*(e: ErrorCode): BOOLEAN;
BEGIN
RETURN (e = ERRORACCESSDENIED()) OR (e = ERRORWRITEPROTECT())
OR (e = ERRORNOTREADY()) OR (e = ERRORSHARINGVIOLATION());
END Inaccessible;
PROCEDURE Absent*(e: ErrorCode): BOOLEAN;
BEGIN RETURN (e = ERRORFILENOTFOUND()) OR (e = ERRORPATHNOTFOUND()) END Absent;
PROCEDURE TimedOut*(e: ErrorCode): BOOLEAN;
BEGIN RETURN (e = ETIMEDOUT()) END TimedOut;
PROCEDURE ConnectionFailed*(e: ErrorCode): BOOLEAN;
BEGIN RETURN (e = ECONNREFUSED()) OR (e = ECONNABORTED())
OR (e = ENETUNREACH()) OR (e = EHOSTUNREACH()) END ConnectionFailed;
PROCEDURE Interrupted*(e: ErrorCode): BOOLEAN;
BEGIN RETURN e = EINTR() END Interrupted;
(* OS memory allocaton *)
PROCEDURE -allocate(size: SYSTEM.ADDRESS): SYSTEM.ADDRESS "(address)((void*)HeapAlloc(GetProcessHeap(), 0, (size_t)size))";
PROCEDURE OSAllocate*(size: SYSTEM.ADDRESS): SYSTEM.ADDRESS; BEGIN RETURN allocate(size) END OSAllocate;
PROCEDURE -free(address: SYSTEM.ADDRESS) "HeapFree(GetProcessHeap(), 0, (void*)address)";
PROCEDURE OSFree*(address: SYSTEM.ADDRESS); BEGIN free(address) END OSFree;
(* Program startup *)
PROCEDURE -ExternInitHeap "extern void Heap_InitHeap();";
PROCEDURE -HeapInitHeap() "Heap_InitHeap()";
PROCEDURE Init*(argc: INTEGER; argvadr: SYSTEM.ADDRESS);
VAR av: ArgVecPtr;
BEGIN
MainStackFrame := argvadr;
ArgCount := argc;
av := SYSTEM.VAL(ArgVecPtr, argvadr);
ArgVector := av[0];
HaltCode := -128;
(* This function (Platform.Init) is called at program startup BEFORE any
modules have been initalised. In turn we must initialise the heap
before module startup (xxx__init) code is run. *)
HeapInitHeap();
END Init;
(* Program arguments and environmet access *)
PROCEDURE -getenv(name: ARRAY OF CHAR; VAR buf: ARRAY OF CHAR): INTEGER
"(INTEGER)GetEnvironmentVariable((char*)name, (char*)buf, buf__len)";
PROCEDURE getEnv*(var: ARRAY OF CHAR; VAR val: ARRAY OF CHAR): BOOLEAN;
VAR
buf: ARRAY 4096 OF CHAR;
res: INTEGER;
BEGIN
res := getenv(var, buf);
IF (res > 0) & (res < LEN(buf)) THEN
COPY(buf, val);
RETURN TRUE;
ELSE
RETURN FALSE;
END;
END getEnv;
PROCEDURE GetEnv*(var: ARRAY OF CHAR; VAR val: ARRAY OF CHAR);
BEGIN
IF ~getEnv(var, val) THEN val[0] := 0X END;
END GetEnv;
PROCEDURE GetArg*(n: INTEGER; VAR val: ARRAY OF CHAR);
VAR av: ArgVec;
BEGIN
IF n < ArgCount THEN
av := SYSTEM.VAL(ArgVec,ArgVector);
COPY(av[n]^, val)
END
END GetArg;
PROCEDURE GetIntArg*(n: INTEGER; VAR val: LONGINT);
VAR s: ARRAY 64 OF CHAR; k, d, i: LONGINT;
BEGIN
s := ""; GetArg(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 k := -k; DEC(i) END ;
IF i > 0 THEN val := k END
END GetIntArg;
PROCEDURE ArgPos*(s: ARRAY OF CHAR): INTEGER;
VAR i: INTEGER; arg: ARRAY 256 OF CHAR;
BEGIN
i := 0; GetArg(i, arg);
WHILE (i < ArgCount) & (s # arg) DO INC(i); GetArg(i, arg) END ;
RETURN i
END ArgPos;
(* Signals and traps *)
(* PROCEDURE -signal(sig: LONGINT; func: SignalHandler) "signal(sig, func)"; *)
(* TODO *)
(* Ctrl/c handling *)
PROCEDURE -SetInterruptHandler*(h: SignalHandler) "SystemSetInterruptHandler((address)h)";
PROCEDURE -SetQuitHandler* (h: SignalHandler) "SystemSetQuitHandler((address)h)";
PROCEDURE SetBadInstructionHandler*(handler: SignalHandler);
BEGIN (* TODO *) END SetBadInstructionHandler;
(* Time of day *)
PROCEDURE -getLocalTime "SYSTEMTIME st; GetLocalTime(&st)";
PROCEDURE -stmsec(): INTEGER "(INTEGER)st.wMilliseconds";
PROCEDURE -stsec(): INTEGER "(INTEGER)st.wSecond";
PROCEDURE -stmin(): INTEGER "(INTEGER)st.wMinute";
PROCEDURE -sthour(): INTEGER "(INTEGER)st.wHour";
PROCEDURE -stmday(): INTEGER "(INTEGER)st.wDay";
PROCEDURE -stmon(): INTEGER "(INTEGER)st.wMonth";
PROCEDURE -styear(): INTEGER "(INTEGER)st.wYear";
PROCEDURE YMDHMStoClock(ye,mo,da,ho,mi,se: INTEGER; VAR t, d: LONGINT);
BEGIN
d := ASH(ye MOD 100, 9) + ASH(mo+1, 5) + da;
t := ASH(ho, 12) + ASH(mi, 6) + se;
END YMDHMStoClock;
PROCEDURE GetClock*(VAR t, d: LONGINT);
BEGIN
getLocalTime;
YMDHMStoClock(styear(), stmon(), stmday(), sthour(), stmin(), stsec(), t, d);
END GetClock;
PROCEDURE -GetTickCount(): LONGINT "(LONGINT)(uint32)GetTickCount()";
PROCEDURE Time*(): LONGINT;
VAR ms: LONGINT;
BEGIN
ms := GetTickCount();
RETURN (ms - TimeStart) MOD 7FFFFFFFH;
END Time;
PROCEDURE -sleep(ms: LONGINT) "Sleep((DWORD)ms)";
PROCEDURE Delay*(ms: LONGINT);
BEGIN
WHILE ms > 30000 DO sleep(30000); ms := ms-30000 END;
IF ms > 0 THEN sleep(ms) END;
END Delay;
PROCEDURE -stToFt "FILETIME ft; SystemTimeToFileTime(&st, &ft)";
PROCEDURE -ftToUli "ULARGE_INTEGER ul; ul.LowPart=ft.dwLowDateTime; ul.HighPart=ft.dwHighDateTime";
PROCEDURE -tous1970 "ul.QuadPart = (ul.QuadPart - 116444736000000000ULL)/10LL";
PROCEDURE -ulSec(): LONGINT "(LONGINT)(ul.QuadPart / 1000000LL)";
PROCEDURE -uluSec(): LONGINT "(LONGINT)(ul.QuadPart % 1000000LL)";
PROCEDURE GetTimeOfDay*(VAR sec, usec: LONGINT);
BEGIN
getLocalTime; stToFt; ftToUli; tous1970;
sec := ulSec(); usec := uluSec();
END GetTimeOfDay;
(* System call *)
PROCEDURE -startupInfo "STARTUPINFO si = {0}; si.cb = sizeof(si);";
PROCEDURE -processInfo "PROCESS_INFORMATION pi = {0};";
PROCEDURE -createProcess(str: ARRAY OF CHAR): INTEGER "(INTEGER)CreateProcess(0, (char*)str, 0,0,0,0,0,0,&si,&pi)";
PROCEDURE -waitForProcess(): INTEGER "(INTEGER)WaitForSingleObject(pi.hProcess, INFINITE)";
PROCEDURE -getExitCodeProcess(VAR exitcode: INTEGER) "GetExitCodeProcess(pi.hProcess, (DWORD*)exitcode);";
PROCEDURE -cleanupProcess "CloseHandle(pi.hProcess); CloseHandle(pi.hThread);";
PROCEDURE -err(): INTEGER "(INTEGER)GetLastError()";
PROCEDURE System*(cmd : ARRAY OF CHAR): INTEGER;
VAR
result: INTEGER;
BEGIN
result := 127;
startupInfo; processInfo;
IF createProcess(cmd) # 0 THEN
IF waitForProcess() = 0 THEN getExitCodeProcess(result) END;
cleanupProcess;
END;
RETURN result * 256;
END System;
PROCEDURE Error*(): ErrorCode; BEGIN RETURN err() END Error;
(* File system *)
PROCEDURE -invalidHandleValue(): LONGINT "((LONGINT)(address)INVALID_HANDLE_VALUE)";
PROCEDURE -openrw (n: ARRAY OF CHAR): LONGINT
"(LONGINT)(address)CreateFile((char*)n, GENERIC_READ|GENERIC_WRITE, FILE_SHARE_READ|FILE_SHARE_WRITE, 0, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)";
PROCEDURE -openro (n: ARRAY OF CHAR): LONGINT
"(LONGINT)(address)CreateFile((char*)n, GENERIC_READ , FILE_SHARE_READ|FILE_SHARE_WRITE, 0, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)";
PROCEDURE -opennew(n: ARRAY OF CHAR): LONGINT
"(LONGINT)(address)CreateFile((char*)n, GENERIC_READ|GENERIC_WRITE, FILE_SHARE_READ|FILE_SHARE_WRITE, 0, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)";
(* File APIs *)
PROCEDURE OldRO*(VAR n: ARRAY OF CHAR; VAR h: FileHandle): ErrorCode;
VAR fd: LONGINT;
BEGIN
fd := openro(n);
IF (fd = invalidHandleValue()) THEN RETURN err() ELSE h := fd; RETURN 0 END;
END OldRO;
PROCEDURE OldRW*(VAR n: ARRAY OF CHAR; VAR h: FileHandle): ErrorCode;
VAR fd: LONGINT;
BEGIN
fd := openrw(n);
IF (fd = invalidHandleValue()) THEN RETURN err() ELSE h := fd; RETURN 0 END;
END OldRW;
PROCEDURE New*(VAR n: ARRAY OF CHAR; VAR h: FileHandle): ErrorCode;
VAR fd: LONGINT;
BEGIN
fd := opennew(n);
IF (fd = invalidHandleValue()) THEN RETURN err() ELSE h := fd; RETURN 0 END;
END New;
PROCEDURE -closeHandle(h: FileHandle): INTEGER "(INTEGER)CloseHandle((HANDLE)(address)h)";
PROCEDURE Close*(h: FileHandle): ErrorCode;
BEGIN
IF closeHandle(h) = 0 THEN RETURN err() ELSE RETURN 0 END
END Close;
PROCEDURE -byHandleFileInformation "BY_HANDLE_FILE_INFORMATION bhfi";
PROCEDURE -getFileInformationByHandle(h: FileHandle): INTEGER "(INTEGER)GetFileInformationByHandle((HANDLE)(address)h, &bhfi)";
PROCEDURE -bhfiMtimeHigh(): LONGINT "(LONGINT)bhfi.ftLastWriteTime.dwHighDateTime";
PROCEDURE -bhfiMtimeLow(): LONGINT "(LONGINT)bhfi.ftLastWriteTime.dwLowDateTime";
PROCEDURE -bhfiVsn(): LONGINT "(LONGINT)bhfi.dwVolumeSerialNumber";
PROCEDURE -bhfiIndexHigh(): LONGINT "(LONGINT)bhfi.nFileIndexHigh";
PROCEDURE -bhfiIndexLow(): LONGINT "(LONGINT)bhfi.nFileIndexLow";
PROCEDURE Identify*(h: FileHandle; VAR identity: FileIdentity): ErrorCode;
BEGIN
byHandleFileInformation;
IF getFileInformationByHandle(h) = 0 THEN RETURN err() END;
identity.volume := bhfiVsn();
identity.indexhigh := bhfiIndexHigh();
identity.indexlow := bhfiIndexLow();
identity.mtimehigh := bhfiMtimeHigh();
identity.mtimelow := bhfiMtimeLow();
RETURN 0
END Identify;
PROCEDURE IdentifyByName*(n: ARRAY OF CHAR; VAR identity: FileIdentity): ErrorCode;
VAR
h: FileHandle;
e,i: ErrorCode;
BEGIN
e := OldRO(n, h);
IF e # 0 THEN RETURN e END;
e := Identify(h, identity);
i := Close(h);
RETURN e;
END IdentifyByName;
PROCEDURE SameFile*(i1, i2: FileIdentity): BOOLEAN;
BEGIN RETURN (i1.indexhigh = i2.indexhigh) & (i1.indexlow = i2.indexlow) & (i1.volume = i2.volume)
END SameFile;
PROCEDURE SameFileTime*(i1, i2: FileIdentity): BOOLEAN;
BEGIN RETURN (i1.mtimehigh = i2.mtimehigh) & (i1.mtimelow = i2.mtimelow)
END SameFileTime;
PROCEDURE SetMTime*(VAR target: FileIdentity; source: FileIdentity);
BEGIN target.mtimehigh := source.mtimehigh; target.mtimelow := source.mtimelow;
END SetMTime;
PROCEDURE -identityToFileTime(i: FileIdentity)
"FILETIME ft; ft.dwHighDateTime = i.mtimehigh; ft.dwLowDateTime = i.mtimelow";
PROCEDURE -fileTimeToSysTime
"SYSTEMTIME st; FileTimeToSystemTime(&ft, &st)";
PROCEDURE MTimeAsClock*(i: FileIdentity; VAR t, d: LONGINT);
BEGIN
identityToFileTime(i); fileTimeToSysTime;
YMDHMStoClock(styear(), stmon(), stmday(), sthour(), stmin(), stsec(), t, d);
END MTimeAsClock;
PROCEDURE -largeInteger "LARGE_INTEGER li";
PROCEDURE -liLongint(): LONGINT "(LONGINT)li.QuadPart";
PROCEDURE -getFileSize(h: FileHandle): INTEGER "(INTEGER)GetFileSizeEx((HANDLE)(address)h, &li)";
PROCEDURE Size*(h: FileHandle; VAR l: LONGINT): ErrorCode;
BEGIN
largeInteger;
IF getFileSize(h) = 0 THEN RETURN err() END;
l := liLongint();
RETURN 0;
END Size;
PROCEDURE -readfile (fd: LONGINT; p: SYSTEM.ADDRESS; l: LONGINT; VAR n: SYSTEM.INT32): INTEGER
"(INTEGER)ReadFile((HANDLE)fd, (void*)p, (DWORD)l, (DWORD*)n, 0)";
PROCEDURE Read*(h: FileHandle; p: SYSTEM.ADDRESS; l: LONGINT; VAR n: LONGINT): ErrorCode;
VAR result: INTEGER; lengthread: SYSTEM.INT32;
BEGIN
result := readfile(h, p, l, lengthread);
IF result = 0 THEN n := 0; RETURN err() ELSE n := lengthread; RETURN 0 END
END Read;
PROCEDURE ReadBuf*(h: FileHandle; VAR b: ARRAY OF SYSTEM.BYTE; VAR n: LONGINT): ErrorCode;
VAR result: INTEGER; lengthread: SYSTEM.INT32;
BEGIN
result := readfile(h, SYSTEM.ADR(b), LEN(b), lengthread);
IF result = 0 THEN n := 0; RETURN err() ELSE n := lengthread; RETURN 0 END
END ReadBuf;
PROCEDURE -writefile(fd: LONGINT; p: SYSTEM.ADDRESS; l: LONGINT): INTEGER
"(INTEGER)WriteFile((HANDLE)fd, (void*)(p), (DWORD)l, 0,0)";
PROCEDURE Write*(h: FileHandle; p: SYSTEM.ADDRESS; l: LONGINT): ErrorCode;
BEGIN
IF writefile(h, p, l) = 0 THEN RETURN err() ELSE RETURN 0 END
END Write;
PROCEDURE -flushFileBuffers(h: FileHandle): INTEGER "(INTEGER)FlushFileBuffers((HANDLE)h)";
PROCEDURE Sync*(h: FileHandle): ErrorCode;
BEGIN
IF flushFileBuffers(h) = 0 THEN RETURN err() ELSE RETURN 0 END
END Sync;
PROCEDURE -setFilePointerEx(h: FileHandle; o: LONGINT; r: INTEGER; VAR rc: INTEGER)
"li.QuadPart=o; *rc = (INTEGER)SetFilePointerEx((HANDLE)(address)h, li, 0, (DWORD)r)";
PROCEDURE -seekset(): INTEGER "FILE_BEGIN";
PROCEDURE -seekcur(): INTEGER "FILE_CURRENT";
PROCEDURE -seekend(): INTEGER "FILE_END";
PROCEDURE Seek*(h: FileHandle; o: LONGINT; r: INTEGER): ErrorCode;
VAR rc: INTEGER;
BEGIN
largeInteger;
setFilePointerEx(h, o, r, rc);
IF rc = 0 THEN RETURN err() ELSE RETURN 0 END
END Seek;
PROCEDURE -setEndOfFile(h: FileHandle): INTEGER "(INTEGER)SetEndOfFile((HANDLE)(address)h)";
PROCEDURE -getFilePos(h: FileHandle; VAR r: LONGINT; VAR rc: INTEGER)
"LARGE_INTEGER liz = {0}; *rc = (INTEGER)SetFilePointerEx((HANDLE)(address)h, liz, &li, FILE_CURRENT); *r = (LONGINT)li.QuadPart";
PROCEDURE Truncate*(h: FileHandle; limit: LONGINT): ErrorCode;
VAR rc: INTEGER; oldpos: LONGINT;
BEGIN
largeInteger;
getFilePos(h, oldpos, rc);
IF rc = 0 THEN RETURN err() END;
setFilePointerEx(h, limit, seekset(), rc);
IF rc = 0 THEN RETURN err() END;
IF setEndOfFile(h) = 0 THEN RETURN err() END;
setFilePointerEx(h, oldpos, seekset(), rc); (* Restore original file position *)
IF rc = 0 THEN RETURN err() END;
RETURN 0;
END Truncate;
PROCEDURE -deleteFile(n: ARRAY OF CHAR): INTEGER "(INTEGER)DeleteFile((char*)n)";
PROCEDURE Unlink*(VAR n: ARRAY OF CHAR): ErrorCode;
BEGIN
IF deleteFile(n) = 0 THEN RETURN err() ELSE RETURN 0 END
END Unlink;
PROCEDURE -setCurrentDirectory(n: ARRAY OF CHAR): INTEGER "(INTEGER)SetCurrentDirectory((char*)n)";
PROCEDURE -getCurrentDirectory(VAR n: ARRAY OF CHAR) "GetCurrentDirectory(n__len, (char*)n)";
PROCEDURE Chdir*(VAR n: ARRAY OF CHAR): ErrorCode;
VAR r: INTEGER;
BEGIN
r := setCurrentDirectory(n);
IF r = 0 THEN RETURN err() END;
getCurrentDirectory(CWD);
RETURN 0;
END Chdir;
PROCEDURE -moveFile(o,n: ARRAY OF CHAR): INTEGER
"(INTEGER)MoveFileEx((char*)o, (char*)n, MOVEFILE_REPLACE_EXISTING)";
PROCEDURE Rename*(VAR o,n: ARRAY OF CHAR): ErrorCode;
BEGIN
IF moveFile(o,n) = 0 THEN RETURN err() ELSE RETURN 0 END
END Rename;
(* Process termination *)
PROCEDURE -exit(code: INTEGER) "ExitProcess((UINT)code)";
PROCEDURE Exit*(code: INTEGER);
BEGIN exit(code) END Exit;
PROCEDURE -errstring(s: ARRAY OF CHAR) 'WriteFile((HANDLE)(address)Platform_StdOut, s, s__len-1, 0,0)';
PROCEDURE -errc (c: CHAR) 'WriteFile((HANDLE)(address)Platform_StdOut, &c, 1, 0,0)';
PROCEDURE errch(c: CHAR); BEGIN errc(c) END errch;
PROCEDURE errln; BEGIN errch(0DX); errch(0AX) END errln;
PROCEDURE errposint(l: LONGINT);
BEGIN IF l>10 THEN errposint(l DIV 10) END; errch(CHR(ORD('0') + (l MOD 10))) END errposint;
PROCEDURE errint(l: LONGINT);
BEGIN IF l<0 THEN errch('-'); l := -l END; errposint(l) END errint;
PROCEDURE DisplayHaltCode(code: LONGINT);
BEGIN
CASE code OF
| -1: errstring("Rider ReadBuf/WriteBuf transfer size longer than buffer.")
| -2: errstring("Index out of range.")
| -3: errstring("Reached end of function without reaching RETURN.")
| -4: errstring("CASE statement: no matching label and no ELSE.")
| -5: errstring("Type guard failed.")
| -6: errstring("Type equality failed.")
| -7: errstring("WITH statement type guard failed.")
| -8: errstring("SHORT: Value too large for shorter type.")
| -9: errstring("Heap interrupted while locked, but lockdepth = 0 at unlock.")
|-10: errstring("NIL access.");
|-11: errstring("Alignment error.");
|-12: errstring("Divide by zero.");
|-13: errstring("Arithmetic overflow/underflow.");
|-14: errstring("Invalid function argument.");
|-15: errstring("Internal error, e.g. Type descriptor size mismatch.")
|-20: errstring("Too many, or negative number of, elements in dynamic array.")
ELSE
END
END DisplayHaltCode;
PROCEDURE Halt*(code: LONGINT);
BEGIN
HaltCode := code;
IF HaltHandler # NIL THEN HaltHandler(code) END;
errstring("Terminated by Halt("); errint(code); errstring("). ");
IF code < 0 THEN DisplayHaltCode(code) END;
errln;
exit(SYSTEM.VAL(INTEGER,code));
END Halt;
PROCEDURE AssertFail*(code: LONGINT);
BEGIN
errstring("Assertion failure.");
IF code # 0 THEN errstring(" ASSERT code "); errint(code); errstring("."); END;
errln;
exit(SYSTEM.VAL(INTEGER,code));
END AssertFail;
PROCEDURE SetHalt*(p: HaltProcedure);
BEGIN HaltHandler := p; END SetHalt;
PROCEDURE TestLittleEndian;
VAR i: INTEGER;
BEGIN i := 1; SYSTEM.GET(SYSTEM.ADR(i), LittleEndian); END TestLittleEndian;
PROCEDURE -getstdinhandle(): FileHandle "(address)GetStdHandle(STD_INPUT_HANDLE)";
PROCEDURE -getstdouthandle(): FileHandle "(address)GetStdHandle(STD_OUTPUT_HANDLE)";
PROCEDURE -getstderrhandle(): FileHandle "(address)GetStdHandle(STD_ERROR_HANDLE)";
PROCEDURE -getpid(): INTEGER "(INTEGER)GetCurrentProcessId()";
BEGIN
TestLittleEndian;
HaltCode := -128;
HaltHandler := NIL;
TimeStart := 0; TimeStart := Time();
CWD := ""; getCurrentDirectory(CWD);
PID := getpid();
SeekSet := seekset();
SeekCur := seekcur();
SeekEnd := seekend();
StdIn := getstdinhandle();
StdOut := getstdouthandle();
StdErr := getstderrhandle();
nl[0] := 0DX; (* CR *)
nl[1] := 0AX; (* LF *)
nl[2] := 0X;
END Platform.

136
src/runtime/Reals.Mod Normal file
View file

@ -0,0 +1,136 @@
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*)
(* DCWB 20160817 Made independent of INTEGER size *)
IMPORT SYSTEM;
PROCEDURE Ten*(e: INTEGER): REAL;
VAR r, power: LONGREAL;
BEGIN r := 1.0;
power := 10.0;
WHILE e > 0 DO
IF ODD(e) THEN r := r * power END ;
power := power * power; e := e DIV 2
END ;
RETURN SHORT(r)
END Ten;
PROCEDURE TenL*(e: INTEGER): LONGREAL;
VAR r, power: LONGREAL;
BEGIN r := 1.0;
power := 10.0;
LOOP
IF ODD(e) THEN r := r * power END ;
e := e DIV 2;
IF e <= 0 THEN RETURN r END ;
power := power * power
END
END TenL;
(* Real number format (IEEE 754)
TYPE REAL - Single precision / binary32:
1/sign, 8/exponent, 23/significand
TYPE LONGREAL - Double precision / binary64:
1/sign, 11/exponent, 52/significand
exponent:
stored as exponent value + 127.
significand (fraction):
excludes leading (most significant) bit which is assumed to be 1.
*)
PROCEDURE Expo*(x: REAL): INTEGER;
VAR i: INTEGER;
BEGIN
SYSTEM.GET(SYSTEM.ADR(x)+2, i);
RETURN (i DIV 128) MOD 256
END Expo;
PROCEDURE SetExpo*(VAR x: REAL; ex: INTEGER);
VAR c: CHAR;
BEGIN
(* Replace exponent bits within top byte of REAL *)
SYSTEM.GET(SYSTEM.ADR(x)+3, c);
SYSTEM.PUT(SYSTEM.ADR(x)+3, CHR(((ORD(c) DIV 128) * 128) + ((ex DIV 2) MOD 128)));
(* Replace exponent bits within 2nd byte of REAL *)
SYSTEM.GET(SYSTEM.ADR(x)+2, c);
SYSTEM.PUT(SYSTEM.ADR(x)+2, CHR((ORD(c) MOD 128) + ((ex MOD 2) * 128)))
END SetExpo;
PROCEDURE ExpoL*(x: LONGREAL): INTEGER;
VAR i: INTEGER;
BEGIN
SYSTEM.GET(SYSTEM.ADR(x)+6, i);
RETURN (i DIV 16) MOD 2048
END ExpoL;
(* 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;
PROCEDURE ToHex(i: INTEGER): CHAR;
BEGIN
IF i < 10 THEN RETURN CHR(i+48)
ELSE RETURN CHR(i+55) END
END ToHex;
PROCEDURE BytesToHex(VAR b, d: ARRAY OF SYSTEM.BYTE);
VAR i: INTEGER; l: LONGINT; by: CHAR;
BEGIN
i := 0; l := LEN(b);
WHILE i < l DO
by := SYSTEM.VAL(CHAR, b[i]);
d[i*2] := ToHex(ORD(by) DIV 16);
d[i*2+1] := ToHex(ORD(by) MOD 16);
INC(i)
END
END BytesToHex;
(* Convert Hex *)
PROCEDURE ConvertH*(y: REAL; VAR d: ARRAY OF CHAR);
BEGIN BytesToHex(y, d)
END ConvertH;
(* Convert Hex Long *)
PROCEDURE ConvertHL*(x: LONGREAL; VAR d: ARRAY OF CHAR);
BEGIN BytesToHex(x, d)
END ConvertHL;
END Reals.

156
src/runtime/Strings.Mod Normal file
View file

@ -0,0 +1,156 @@
(*-------------------------------------------------------------
Strings provides a set of operations on strings (i.e., on string constants and character
arrays, both of which contain the character 0X as a terminator). All positions in
strings start at 0.
Strings.Length(s)
returns the number of characters in s up to and excluding the first 0X.
Strings.Insert(src, pos, dst)
inserts the string src into the string dst at position pos (0 <= pos <= Length(dst)).
If pos = Length(dst), src is appended to dst. If the size of dst is not large enough
to hold the result of the operation, the result is truncated so that dst is always
terminated with a 0X.
Strings.Append(s, dst)
has the same effect as Insert(s, Length(s), dst).
Strings.Delete(s, pos, n)
deletes n characters from s starting at position pos (0 <= pos < Length(s)).
If n > Length(s) - pos, the new length of s is pos.
Strings.Replace(src, pos, dst)
has the same effect as Delete(dst, pos, Length(src)) followed by an Insert(src, pos, dst).
Strings.Extract(src, pos, n, dst)
extracts a substring dst with n characters from position pos (0 <= pos < Length(src)) in src.
If n > Length(src) - pos, dst is only the part of src from pos to Length(src) - 1. If the size of
dst is not large enough to hold the result of the operation, the result is truncated so that
dst is always terminated with a 0X.
Strings.Pos(pat, s, pos)
returns the position of the first occurrence of pat in s after position pos (inclusive).
If pat is not found, -1 is returned.
Strings.Cap(s)
replaces each lower case letter in s by its upper case equivalent.
-------------------------------------------------------------*)
(* added from trianus v4 *)
MODULE Strings; (*HM 94-06-22 / *)
PROCEDURE Length* (s: ARRAY OF CHAR): INTEGER;
VAR i: INTEGER;
BEGIN
i := 0; WHILE (i < LEN(s)) & (s[i] # 0X) DO INC(i) END ;
RETURN i
END Length;
PROCEDURE Append* (extra: ARRAY OF CHAR; VAR dest: ARRAY OF CHAR);
VAR n1, n2, i: INTEGER;
BEGIN
n1 := Length(dest); n2 := Length(extra); i := 0;
WHILE (i < n2) & (i + n1 < LEN(dest)) DO dest[i + n1] := extra[i]; INC(i) END ;
IF i + n1 < LEN(dest) THEN dest[i + n1] := 0X END
END Append;
PROCEDURE Insert* (source: ARRAY OF CHAR; pos: INTEGER; VAR dest: ARRAY OF CHAR);
VAR n1, n2, i: INTEGER;
BEGIN
n1 := Length(dest); n2 := Length(source);
IF pos < 0 THEN pos := 0 END ;
IF pos > n1 THEN Append(dest, source); RETURN END ;
IF pos + n2 < LEN(dest) THEN (*make room for source*)
i := n1; (*move also 0X if it is there*)
WHILE i >= pos DO
IF i + n2 < LEN(dest) THEN dest[i + n2] := dest[i] END ;
DEC(i)
END
END ;
i := 0; WHILE i < n2 DO dest[pos + i] := source[i]; INC(i) END
END Insert;
PROCEDURE Delete* (VAR s: ARRAY OF CHAR; pos, n: INTEGER);
VAR len, i: INTEGER;
BEGIN
len:=Length(s);
IF pos < 0 THEN pos:=0 ELSIF pos >= len THEN RETURN END ;
IF pos + n < len THEN
i:=pos + n; WHILE i < len DO s[i - n]:=s[i]; INC(i) END ;
IF i - n < LEN(s) THEN s[i - n]:=0X END
ELSE s[pos]:=0X
END
END Delete;
PROCEDURE Replace* (source: ARRAY OF CHAR; pos: INTEGER; VAR dest: ARRAY OF CHAR);
BEGIN
Delete(dest, pos, pos + Length(source));
Insert(source, pos, dest)
END Replace;
PROCEDURE Extract* (source: ARRAY OF CHAR; pos, n: INTEGER; VAR dest: ARRAY OF CHAR);
VAR len, destLen, i: INTEGER;
BEGIN
len := Length(source); destLen := SHORT(LEN(dest)) - 1;
IF pos < 0 THEN pos := 0 END ;
IF pos >= len THEN dest[0] := 0X; RETURN END ;
i := 0;
WHILE (pos + i <= LEN(source)) & (source[pos + i] # 0X) & (i < n) DO
IF i < destLen THEN dest[i] := source[pos + i] END ;
INC(i)
END ;
dest[i] := 0X
END Extract;
PROCEDURE Pos* (pattern, s: ARRAY OF CHAR; pos: INTEGER): INTEGER;
VAR n1, n2, i, j: INTEGER;
BEGIN
n1 := Length(s); n2 := Length(pattern);
IF n2 = 0 THEN RETURN 0 END ;
i := pos;
WHILE i <= n1 - n2 DO
IF s[i] = pattern[0] THEN
j := 1; WHILE (j < n2) & (s[i + j] = pattern[j]) DO INC(j) END ;
IF j = n2 THEN RETURN i END
END ;
INC(i)
END ;
RETURN -1
END Pos;
PROCEDURE Cap* (VAR s: ARRAY OF CHAR);
VAR i: INTEGER;
BEGIN
i := 0;
WHILE s[i] # 0X DO
IF ("a" <= s[i]) & (s[i] <= "z") THEN s[i] := CAP(s[i]) END ;
INC(i)
END
END Cap;
PROCEDURE Match* (string, pattern: ARRAY OF CHAR): BOOLEAN;
PROCEDURE M (VAR name, mask: ARRAY OF CHAR; n, m: INTEGER): BOOLEAN;
BEGIN
WHILE (n >= 0) & (m >= 0) & (mask[m] # "*") DO
IF name[n] # mask[m] THEN RETURN FALSE END ;
DEC(n); DEC(m)
END ;
(* ----- name empty | mask empty | mask ends with "*" *)
IF m < 0 THEN RETURN n < 0 END ;
(* ----- name empty | mask ends with "*" *)
WHILE (m >= 0) & (mask[m] = "*") DO DEC(m) END ;
IF m < 0 THEN RETURN TRUE END ;
(* ----- name empty | mask still to be matched *)
WHILE n >= 0 DO
IF M(name, mask, n, m) THEN RETURN TRUE END ;
DEC(n)
END ;
RETURN FALSE
END M;
BEGIN
RETURN M(string, pattern, Length(string)-1, Length(pattern)-1)
END Match;
END Strings.

881
src/runtime/Texts.Mod Normal file
View file

@ -0,0 +1,881 @@
MODULE Texts; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91**) (* << RC, MB, JT *)
IMPORT
Files, Modules, Reals, SYSTEM;
(*--- insert field e: Elem into Texts.Scanner and change Texts.Scan to set it in case of class=6 *)
CONST
Displaywhite = 15;
ElemChar* = 1CX;
TAB = 9X; CR = 0DX; maxD = 9;
(**FileMsg.id**)
load* = 0; store* = 1;
(**Notifier op**)
replace* = 0; insert* = 1; delete* = 2; unmark* = 3;
(**Scanner.class**)
Inval* = 0; Name* = 1; String* = 2; Int* = 3; Real* = 4; LongReal* = 5; Char* = 6;
textTag = 0F0X; DocBlockId = 0F7X; version = 01X;
TYPE
FontsFont = POINTER TO FontDesc;
FontDesc = RECORD
name: ARRAY 32 OF CHAR;
END ;
Run = POINTER TO RunDesc;
RunDesc = RECORD
prev, next: Run;
len: LONGINT;
fnt: FontsFont;
col, voff: SYSTEM.INT8;
ascii: BOOLEAN (* << *)
END;
Piece = POINTER TO PieceDesc;
PieceDesc = RECORD (RunDesc)
file: Files.File;
org: LONGINT
END;
Elem* = POINTER TO ElemDesc;
Buffer* = POINTER TO BufDesc;
Text* = POINTER TO TextDesc;
ElemMsg* = RECORD END;
Handler* = PROCEDURE (e: Elem; VAR msg: ElemMsg);
ElemDesc* = RECORD (RunDesc)
W*, H*: LONGINT;
handle*: Handler;
base: Text
END;
FileMsg* = RECORD (ElemMsg)
id*: INTEGER;
pos*: LONGINT;
r*: Files.Rider
END;
CopyMsg* = RECORD (ElemMsg)
e*: Elem
END;
IdentifyMsg* = RECORD (ElemMsg)
mod*, proc*: ARRAY 32 OF CHAR
END;
BufDesc* = RECORD
len*: LONGINT;
head: Run
END;
Notifier* = PROCEDURE (T: Text; op: INTEGER; beg, end: LONGINT);
TextDesc* = RECORD
len*: LONGINT;
notify*: Notifier;
head, cache: Run;
corg: LONGINT
END;
Reader* = RECORD
eot*: BOOLEAN;
fnt*: FontsFont;
col*, voff*: SYSTEM.INT8;
elem*: Elem;
rider: Files.Rider;
run: Run;
org, off: LONGINT
END;
Scanner* = RECORD (Reader)
nextCh*: CHAR;
line*, class*: INTEGER;
i*: LONGINT;
x*: REAL;
y*: LONGREAL;
c*: CHAR;
len*: SHORTINT;
s*: ARRAY 64 OF CHAR (* << *)
END;
Writer* = RECORD
buf*: Buffer;
fnt*: FontsFont;
col*, voff*: SYSTEM.INT8;
rider: Files.Rider;
file: Files.File
END;
Alien = POINTER TO RECORD (ElemDesc)
file: Files.File;
org, span: LONGINT;
mod, proc: ARRAY 32 OF CHAR
END;
VAR
new*: Elem;
del: Buffer;
FontsDefault: FontsFont;
PROCEDURE FontsThis(VAR name: ARRAY OF CHAR): FontsFont;
VAR F: FontsFont;
BEGIN
NEW(F); COPY(name, F.name); RETURN F
END FontsThis;
(* run primitives *)
PROCEDURE Find (T: Text; VAR pos: LONGINT; VAR u: Run; VAR org, off: LONGINT);
VAR v: Run; m: LONGINT;
BEGIN
IF pos >= T.len THEN pos := T.len; u := T.head; org := T.len; off := 0; T.cache := T.head; T.corg := 0
ELSE v := T.cache.next; m := pos - T.corg;
IF pos >= T.corg THEN
WHILE m >= v.len DO DEC(m, v.len); v := v.next END
ELSE
WHILE m < 0 DO v := v.prev; INC(m, v.len) END;
END;
u := v; org := pos - m; off := m; T.cache := v.prev; T.corg := org
END
END Find;
PROCEDURE Split (off: LONGINT; VAR u, un: Run);
VAR p, U: Piece;
BEGIN
IF off = 0 THEN un := u; u := un.prev
ELSIF off >= u.len THEN un := u.next
ELSE NEW(p); un := p; U := u(Piece);
p^ := U^; INC(p.org, off); DEC(p.len, off); DEC(U.len, p.len);
p.ascii := u.ascii; p.prev := U; p.next := U.next; p.next.prev := p; U.next := p (* << *)
END
END Split;
PROCEDURE Merge (T: Text; u: Run; VAR v: Run);
VAR p, q: Piece;
BEGIN
IF (u IS Piece) & (v IS Piece) & (u.fnt.name = v.fnt.name) & (u.col = v.col) & (u.voff = v.voff)
& (u(Piece).ascii = v(Piece).ascii) THEN (* << *)
p := u(Piece); q := v(Piece);
IF (p.file = q.file) & (p.org + p.len = q.org) THEN
IF T.cache = u THEN INC(T.corg, q.len)
ELSIF T.cache = v THEN T.cache := T.head; T.corg := 0
END;
INC(p.len, q.len); v := v.next
END
END
END Merge;
PROCEDURE Splice (un, v, w: Run; base: Text); (* (u, un) -> (u, v, w, un) *)
VAR u: Run;
BEGIN
IF v # w.next THEN u := un.prev;
u.next := v; v.prev := u; un.prev := w; w.next := un;
REPEAT
IF v IS Elem THEN v(Elem).base := base END;
v := v.next
UNTIL v = un
END
END Splice;
PROCEDURE ClonePiece (p: Piece): Piece;
VAR q: Piece;
BEGIN NEW(q); q^ := p^; RETURN q
END ClonePiece;
PROCEDURE CloneElem (e: Elem): Elem;
VAR msg: CopyMsg;
BEGIN msg.e := NIL; e.handle(e, msg); RETURN msg.e
END CloneElem;
(** Elements **)
PROCEDURE CopyElem* (SE, DE: Elem);
BEGIN DE.len := SE.len; DE.fnt := SE.fnt; DE.col := SE.col; DE.voff := SE.voff;
DE.W := SE.W; DE.H := SE.H; DE.handle := SE.handle
END CopyElem;
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;
WHILE u # E DO pos := pos + u.len; u := u.next END;
RETURN pos
END ElemPos;
PROCEDURE HandleAlien (E: Elem; VAR msg: ElemMsg);
VAR e: Alien; r: Files.Rider; i: LONGINT; ch: CHAR;
BEGIN
WITH E: Alien DO
IF msg IS CopyMsg THEN
WITH msg: CopyMsg DO NEW(e); CopyElem(E, e);
e.file := E.file; e.org := E.org; e.span := E.span; e.mod := E.mod; e.proc := E.proc;
msg.e := e
END
ELSIF msg IS IdentifyMsg THEN
WITH msg: IdentifyMsg DO
COPY(E.mod, msg.mod); COPY(E.proc, msg.proc); msg.mod[31] := 1X (*alien*)
END
ELSIF msg IS FileMsg THEN
WITH msg: FileMsg DO
IF msg.id = store THEN Files.Set(r, E.file, E.org); i := E.span;
WHILE i > 0 DO Files.Read(r, ch); Files.Write(msg.r, ch); DEC(i) END
END
END
END
END
END HandleAlien;
(** Buffers **)
PROCEDURE OpenBuf* (B: Buffer);
VAR u: Run;
BEGIN NEW(u); u.next := u; u.prev := u; B.head := u; B.len := 0
END OpenBuf;
PROCEDURE Copy* (SB, DB: Buffer);
VAR u, v, vn: Run;
BEGIN u := SB.head.next; v := DB.head.prev;
WHILE u # SB.head DO
IF u IS Piece THEN vn := ClonePiece(u(Piece)) ELSE vn := CloneElem(u(Elem)) END;
v.next := vn; vn.prev := v; v := vn; u := u.next
END;
v.next := DB.head; DB.head.prev := v;
INC(DB.len, SB.len)
END Copy;
PROCEDURE Recall* (VAR B: Buffer);
BEGIN B := del; del := NIL
END Recall;
(** Texts **)
PROCEDURE Save* (T: Text; beg, end: LONGINT; B: Buffer);
VAR u, v, w, wn: Run; uo, ud, vo, vd: LONGINT;
BEGIN Find(T, beg, u, uo, ud); Find(T, end, v, vo, vd);
w := B.head.prev;
WHILE u # v DO
IF u IS Piece THEN wn := ClonePiece(u(Piece)); DEC(wn.len, ud); INC(wn(Piece).org, ud)
ELSE wn := CloneElem(u(Elem))
END;
w.next := wn; wn.prev := w; w := wn; u := u.next; ud := 0
END;
IF vd > 0 THEN (*v IS Piece*) wn := ClonePiece(v(Piece)); wn.len := vd - ud; INC(wn(Piece).org, ud);
w.next := wn; wn.prev := w; w := wn
END;
w.next := B.head; B.head.prev := w;
INC(B.len, end - beg)
END Save;
PROCEDURE Insert* (T: Text; pos: LONGINT; B: Buffer);
VAR u, un, v: Run; p, q: Piece; uo, ud, len: LONGINT;
BEGIN Find(T, pos, u, uo, ud); Split(ud, u, un);
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);
VAR v: Run; pos, len: LONGINT;
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);
VAR c, u, un, v, vn: Run; co, uo, ud, vo, vd: LONGINT;
BEGIN
Find(T, beg, u, uo, ud); Split(ud, u, un); c := T.cache; co := T.corg;
Find(T, end, v, vo, vd); Split(vd, v, vn); T.cache := c; T.corg := co;
NEW(del); OpenBuf(del); del.len := end - beg;
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: SYSTEM.INT8);
VAR c, u, un, v, vn: Run; co, uo, ud, vo, vd: LONGINT;
BEGIN Find(T, beg, u, uo, ud); Split(ud, u, un); c := T.cache; co := T.corg;
Find(T, end, v, vo, vd); Split(vd, v, vn); T.cache := c; T.corg := co;
WHILE un # vn DO
IF (0 IN sel) & (fnt # NIL) THEN un.fnt := fnt END;
IF 1 IN sel THEN un.col := col END;
IF 2 IN sel THEN un.voff := voff END;
Merge(T, u, un);
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;
(** Readers **)
PROCEDURE OpenReader* (VAR R: Reader; T: Text; pos: LONGINT);
VAR u: Run;
BEGIN
IF pos >= T.len THEN pos := T.len END;
Find(T, pos, u, R.org, R.off); R.run := u; R.eot := FALSE;
IF u IS Piece THEN
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; pos: LONGINT; nextch: CHAR;
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 (* << 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
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 ReadElem* (VAR R: Reader);
VAR u, un: Run;
BEGIN u := R.run;
WHILE u IS Piece DO INC(R.org, u.len); u := u.next END;
IF u IS Elem THEN un := u.next; R.run := un; INC(R.org); R.off := 0;
R.fnt := u.fnt; R.col := u.col; R.voff := u.voff; R.elem := u(Elem);
IF un IS Piece THEN
WITH un: Piece DO Files.Set(R.rider, un.file, un.org) END
END
ELSE R.eot := TRUE; R.elem := NIL
END
END ReadElem;
PROCEDURE ReadPrevElem* (VAR R: Reader);
VAR u: Run;
BEGIN u := R.run.prev;
WHILE u IS Piece DO DEC(R.org, u.len); u := u.prev END;
IF u IS Elem THEN R.run := u; DEC(R.org); R.off := 0;
R.fnt := u.fnt; R.col := u.col; R.voff := u.voff; R.elem := u(Elem)
ELSE R.eot := TRUE; R.elem := NIL
END
END ReadPrevElem;
PROCEDURE Pos* (VAR R: Reader): LONGINT;
BEGIN RETURN R.org + R.off
END Pos;
(** Scanners --------------- NW --------------- **)
PROCEDURE OpenScanner* (VAR S: Scanner; T: Text; pos: LONGINT);
BEGIN OpenReader(S, T, pos); S.line := 0; S.nextCh := " "
END OpenScanner;
(*IEEE floating point formats:
x = 2^(e-127) * 1.m bit 0: sign, bits 1- 8: e, bits 9-31: m
x = 2^(e-1023) * 1.m bit 0: sign, bits 1-11: e, bits 12-63: m *)
PROCEDURE Scan* (VAR S: Scanner);
CONST maxD = 32;
VAR ch, term: CHAR;
neg, negE, hex: BOOLEAN;
i, j, h: SHORTINT;
e: INTEGER; k: LONGINT;
x, f: REAL; y, g: LONGREAL;
d: ARRAY maxD OF CHAR;
PROCEDURE ReadScaleFactor;
BEGIN Read(S, ch);
IF ch = "-" THEN negE := TRUE; Read(S, ch)
ELSE negE := FALSE;
IF ch = "+" THEN Read(S, ch) END
END;
WHILE ("0" <= ch) & (ch <= "9") DO
e := e*10 + ORD(ch) - 30H; Read(S, ch)
END
END ReadScaleFactor;
BEGIN ch := S.nextCh; i := 0;
LOOP
IF ch = CR THEN INC(S.line)
ELSIF (ch # " ") & (ch # TAB) THEN EXIT
END ;
Read(S, ch)
END;
IF ("A" <= CAP(ch)) & (CAP(ch) <= "Z") OR (ch = "/") OR (ch = ".") THEN (*name*) (* << *)
REPEAT S.s[i] := ch; INC(i); Read(S, ch)
UNTIL (CAP(ch) > "Z") & (ch # "_") (* << *)
OR ("A" > CAP(ch)) & (ch > "9")
OR ("0" > ch) & (ch # ".") & (ch # "/") (* << *)
OR (i = 63); (* << *)
S.s[i] := 0X; S.len := i; S.class := 1
ELSIF ch = 22X THEN (*literal string*)
Read(S, ch);
WHILE (ch # 22X) & (ch >= " ") & (i # 63) DO (* << *)
S.s[i] := ch; INC(i); Read(S, ch)
END;
S.s[i] := 0X; S.len := i+1; Read(S, ch); S.class := 2
ELSE
IF ch = "-" THEN neg := TRUE; Read(S, ch) ELSE neg := FALSE END ;
IF ("0" <= ch) & (ch <= "9") THEN (*number*)
hex := FALSE; j := 0;
LOOP d[i] := ch; INC(i); Read(S, ch);
IF ch < "0" THEN EXIT END;
IF "9" < ch THEN
IF ("A" <= ch) & (ch <= "F") THEN hex := TRUE; ch := CHR(ORD(ch)-7)
ELSIF ("a" <= ch) & (ch <= "f") THEN hex := TRUE; ch := CHR(ORD(ch)-27H)
ELSE EXIT
END
END
END;
IF ch = "H" THEN (*hex number*)
Read(S, ch); S.class := 3;
IF i-j > 8 THEN j := i-8 END ;
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
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 ;
IF ch = "D" THEN
e := 0; y := 0; g := 1;
REPEAT y := y*10 + (ORD(d[j]) - 30H); INC(j) UNTIL j = h;
WHILE j < i DO g := g/10; y := (ORD(d[j]) - 30H)*g + y; INC(j) END ;
ReadScaleFactor;
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
END ;
IF neg THEN y := -y END ;
S.class := 5; S.y := y
ELSE e := 0; x := 0; f := 1;
REPEAT x := x*10 + (ORD(d[j]) - 30H); INC(j) UNTIL j = h;
WHILE j < i DO f := f/10; x := (ORD(d[j])-30H)*f + x; INC(j) END;
IF ch = "E" THEN ReadScaleFactor END ;
IF negE THEN
IF e <= 38 THEN x := x / Reals.Ten(e) ELSE x := 0 END
ELSIF e > 0 THEN
IF e <= 38 THEN x := Reals.Ten(e) * x ELSE HALT(40) END
END ;
IF neg THEN x := -x END ;
S.class := 4; S.x := x
END ;
IF hex THEN S.class := 0 END
ELSE (*decimal integer*)
S.class := 3; k := 0;
REPEAT k := k*10 + (ORD(d[j]) - 30H); INC(j) UNTIL j = i;
IF neg THEN S.i := -k ELSE S.i := k END;
IF hex THEN S.class := 0 ELSE S.class := 3 END
END
ELSE S.class := 6;
IF neg THEN S.c := "-" ELSE S.c := ch; Read(S, ch) END
END
END;
S.nextCh := ch
END Scan;
(** Writers **)
PROCEDURE OpenWriter* (VAR W: Writer);
BEGIN NEW(W.buf); OpenBuf(W.buf);
W.fnt := FontsDefault; W.col := Displaywhite; W.voff := 0;
W.file := Files.New(""); Files.Set(W.rider, W.file, 0)
END OpenWriter;
PROCEDURE SetFont* (VAR W: Writer; fnt: FontsFont);
BEGIN W.fnt := fnt
END SetFont;
PROCEDURE SetColor* (VAR W: Writer; col: SYSTEM.INT8);
BEGIN W.col := col
END SetColor;
PROCEDURE SetOffset* (VAR W: Writer; voff: SYSTEM.INT8);
BEGIN W.voff := voff
END SetOffset;
PROCEDURE Write* (VAR W: Writer; ch: CHAR);
VAR u, un: Run; p: Piece;
BEGIN Files.Write(W.rider, ch); INC(W.buf.len); un := W.buf.head; u := un.prev;
IF (u IS Piece) & (u(Piece).file = W.file) & (u.fnt.name = W.fnt.name) & (u.col = W.col) & (u.voff = W.voff)
& ~u(Piece).ascii THEN (* << *)
INC(u.len)
ELSE NEW(p); u.next := p; p.prev := u; p.next := un; un.prev := p;
p.len := 1; p.fnt := W.fnt; p.col := W.col; p.voff := W.voff;
p.file := W.file; p.org := Files.Length(W.file) - 1; p.ascii := FALSE (* << *)
END
END Write;
PROCEDURE WriteElem* (VAR W: Writer; e: Elem);
VAR u, un: Run;
BEGIN
IF e.base # NIL THEN HALT(99) END;
INC(W.buf.len); e.len := 1; e.fnt := W.fnt; e.col := W.col; e.voff := W.voff;
un := W.buf.head; u := un.prev; u.next := e; e.prev := u; e.next := un; un.prev := e
END WriteElem;
PROCEDURE WriteLn* (VAR W: Writer);
BEGIN Write(W, CR)
END WriteLn;
PROCEDURE WriteString* (VAR W: Writer; s: ARRAY OF CHAR);
VAR i: INTEGER;
BEGIN i := 0;
WHILE s[i] >= " " DO Write(W, s[i]); INC(i) END
END WriteString;
PROCEDURE WriteInt* (VAR W: Writer; x, n: SYSTEM.INT64);
VAR
i: INTEGER; x0: SYSTEM.INT64;
a: ARRAY 24 OF CHAR;
BEGIN i := 0;
IF x < 0 THEN
IF x = MIN(SYSTEM.INT64) THEN WriteString(W, " -9223372036854775808"); RETURN
ELSE DEC(n); x0 := -x
END
ELSE x0 := x
END;
REPEAT
a[i] := CHR(x0 MOD 10 + 30H); x0 := x0 DIV 10; INC(i)
UNTIL x0 = 0;
WHILE n > i DO Write(W, " "); DEC(n) END;
IF x < 0 THEN Write(W, "-") END;
REPEAT DEC(i); Write(W, a[i]) UNTIL i = 0
END WriteInt;
PROCEDURE WriteHex* (VAR W: Writer; x: LONGINT);
VAR i: INTEGER; y: LONGINT;
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;
x := x DIV 10H; INC(i)
UNTIL i = 8;
REPEAT DEC(i); Write(W, a[i]) UNTIL i = 0
END WriteHex;
PROCEDURE WriteReal* (VAR W: Writer; x: REAL; n: INTEGER);
VAR e: INTEGER; x0: REAL;
d: ARRAY maxD OF CHAR;
BEGIN e := Reals.Expo(x);
IF e = 0 THEN
WriteString(W, " 0");
REPEAT Write(W, " "); DEC(n) UNTIL n <= 3
ELSIF e = 255 THEN
WriteString(W, " NaN");
WHILE n > 4 DO Write(W, " "); DEC(n) END
ELSE
IF n <= 9 THEN n := 3 ELSE DEC(n, 6) END;
REPEAT Write(W, " "); DEC(n) UNTIL n <= 8;
(*there are 2 < n <= 8 digits to be written*)
IF x < 0.0 THEN Write(W, "-"); x := -x ELSE Write(W, " ") END;
e := (e - 127) * 77 DIV 256;
IF e >= 0 THEN x := x / Reals.Ten(e) ELSE x := Reals.Ten(-e) * x END;
IF x >= 10.0 THEN x := 0.1*x; INC(e) END;
x0 := Reals.Ten(n-1); x := x0*x + 0.5;
IF x >= 10.0*x0 THEN x := x*0.1; INC(e) END;
Reals.Convert(x, n, d);
DEC(n); Write(W, d[n]); Write(W, ".");
REPEAT DEC(n); Write(W, d[n]) UNTIL n = 0;
Write(W, "E");
IF e < 0 THEN Write(W, "-"); e := -e ELSE Write(W, "+") END;
Write(W, CHR(e DIV 10 + 30H)); Write(W, CHR(e MOD 10 + 30H))
END
END WriteReal;
PROCEDURE WriteRealFix* (VAR W: Writer; x: REAL; n, k: INTEGER);
VAR e, i: INTEGER; sign: CHAR; x0: REAL;
d: ARRAY maxD OF CHAR;
PROCEDURE seq(ch: CHAR; n: INTEGER);
BEGIN WHILE n > 0 DO Write(W, ch); DEC(n) END
END seq;
PROCEDURE dig(n: INTEGER);
BEGIN
WHILE n > 0 DO
DEC(i); Write(W, d[i]); DEC(n)
END
END dig;
BEGIN e := Reals.Expo(x);
IF k < 0 THEN k := 0 END;
IF e = 0 THEN seq(" ", n-k-2); Write(W, "0"); seq(" ", k+1)
ELSIF e = 255 THEN WriteString(W, " NaN"); seq(" ", n-4)
ELSE e := (e - 127) * 77 DIV 256;
IF x < 0 THEN sign := "-"; x := -x ELSE sign := " " END;
IF e >= 0 THEN (*x >= 1.0, 77/256 = log 2*) x := x/Reals.Ten(e)
ELSE (*x < 1.0*) x := Reals.Ten(-e) * x
END;
IF x >= 10.0 THEN x := 0.1*x; INC(e) END;
(* 1 <= x < 10 *)
IF k+e >= maxD-1 THEN k := maxD-1-e
ELSIF k+e < 0 THEN k := -e; x := 0.0
END;
x0 := Reals.Ten(k+e); x := x0*x + 0.5;
IF x >= 10.0*x0 THEN INC(e) END;
(*e = no. of digits before decimal point*)
INC(e); i := k+e; Reals.Convert(x, i, d);
IF e > 0 THEN
seq(" ", n-e-k-2); Write(W, sign); dig(e);
Write(W, "."); dig(k)
ELSE seq(" ", n-k-3);
Write(W, sign); Write(W, "0"); Write(W, ".");
seq("0", -e); dig(k+e)
END
END
END WriteRealFix;
PROCEDURE WriteRealHex* (VAR W: Writer; x: REAL);
VAR i: INTEGER;
d: ARRAY 8 OF CHAR;
BEGIN Reals.ConvertH(x, d); i := 0;
REPEAT Write(W, d[i]); INC(i) UNTIL i = 8
END WriteRealHex;
PROCEDURE WriteLongReal* (VAR W: Writer; x: LONGREAL; n: INTEGER);
CONST maxD = 16;
VAR e: INTEGER; x0: LONGREAL;
d: ARRAY maxD OF CHAR;
BEGIN e := Reals.ExpoL(x);
IF e = 0 THEN
WriteString(W, " 0");
REPEAT Write(W, " "); DEC(n) UNTIL n <= 3
ELSIF e = 2047 THEN
WriteString(W, " NaN");
WHILE n > 4 DO Write(W, " "); DEC(n) END
ELSE
IF n <= 10 THEN n := 3 ELSE DEC(n, 7) END;
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;
(* 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;
Write(W, CHR(e DIV 10 + 30H));
Write(W, CHR(e MOD 10 + 30H))
END
END WriteLongReal;
PROCEDURE WriteLongRealHex* (VAR W: Writer; x: LONGREAL);
VAR i: INTEGER;
d: ARRAY 16 OF CHAR;
BEGIN Reals.ConvertHL(x, d); i := 0;
REPEAT Write(W, d[i]); INC(i) UNTIL i = 16
END WriteLongRealHex;
PROCEDURE WriteDate* (VAR W: Writer; t, d: LONGINT);
PROCEDURE WritePair(ch: CHAR; x: LONGINT);
BEGIN Write(W, ch);
Write(W, CHR(x DIV 10 + 30H)); Write(W, CHR(x MOD 10 + 30H))
END WritePair;
BEGIN
WritePair(" ", d MOD 32); WritePair(".", d DIV 32 MOD 16); WritePair(".", d DIV 512 MOD 128);
WritePair(" ", t DIV 4096 MOD 32); WritePair(":", t DIV 64 MOD 64); WritePair(":", t MOD 64)
END WriteDate;
(** Text Filing **)
PROCEDURE Load0 (VAR r: Files.Rider; T: Text);
VAR u, un: Run; p: Piece; e: Elem;
org, pos, hlen, plen: LONGINT; ecnt, fcnt: SHORTINT;
fno, col, voff: SYSTEM.INT8;
f: Files.File;
msg: FileMsg;
mods, procs: ARRAY 64, 32 OF CHAR;
name: ARRAY 32 OF CHAR;
fnts: ARRAY 32 OF FontsFont;
PROCEDURE LoadElem (VAR r: Files.Rider; pos, span: LONGINT; VAR e: Elem);
VAR M: Modules.Module; Cmd: Modules.Command; a: Alien;
org, ew, eh: LONGINT; eno: SYSTEM.INT8;
BEGIN new := NIL;
Files.ReadLInt(r, ew); Files.ReadLInt(r, eh); Files.Read(r, eno);
IF eno > ecnt THEN ecnt := eno; Files.ReadString(r, mods[eno]); Files.ReadString(r, procs[eno]) END;
org := Files.Pos(r); M := Modules.ThisMod(mods[eno]);
IF M # NIL THEN Cmd := Modules.ThisCommand(M, procs[eno]);
IF Cmd # NIL THEN Cmd END
END;
e := new;
IF e # NIL THEN e.W := ew; e.H := eh; e.base := T;
msg.pos := pos; e.handle(e, msg);
IF Files.Pos(r) # org + span THEN e := NIL END
END;
IF e = NIL THEN Files.Set(r, f, org + span);
NEW(a); a.W := ew; a.H := eh; a.handle := HandleAlien; a.base := T;
a.file := f; a.org := org; a.span := span;
COPY(mods[eno], a.mod); COPY(procs[eno], a.proc);
e := a
END
END LoadElem;
BEGIN pos := Files.Pos(r); f := Files.Base(r);
NEW(u); u.len := MAX(LONGINT); (*u.fnt := FontsDefault;*)u.fnt := NIL; u.col := Displaywhite;
T.head := u; ecnt := 0; fcnt := 0;
msg.id := load; msg.r := r;
Files.ReadLInt(msg.r, hlen); (*!!!org := pos + hlen;*) org := pos -2 + hlen; pos := org; Files.Read(msg.r, fno);
WHILE fno # 0 DO
IF fno > fcnt THEN fcnt := fno; Files.ReadString(msg.r, name); fnts[fno] := FontsThis(name) END;
Files.Read(msg.r, col); Files.Read(msg.r, voff); Files.ReadLInt(msg.r, plen);
IF plen > 0 THEN NEW(p); p.file := f; p.org := pos; p.ascii := FALSE; un := p; un.len := plen
ELSE LoadElem(msg.r, pos - org, -plen, e); un := e; un.len := 1
END;
(*un.fnt := fnts[fno];*) un.col := col; un.voff := voff;
INC(pos, un.len); u.next := un; un.prev := u; u := un; Files.Read(msg.r, fno)
END;
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;
BEGIN
(* for compatibility inner text tags are checked and skipped; remove this in a later version *)
Files.ReadInt(r, tag); IF tag # oldTag THEN Files.Set(r, Files.Base(r), Files.Pos(r)-2) END;
Load0(r, T)
END Load;
PROCEDURE Open* (T: Text; name: ARRAY OF CHAR);
VAR f: Files.File; r: Files.Rider; u: Run; p: Piece; tag, version: CHAR; hlen: LONGINT;
BEGIN f := Files.Old(name);
IF f = NIL THEN f := Files.New("") END;
Files.Set(r, f, 0); Files.Read(r, tag); Files.Read(r, version);
IF (tag = textTag) OR (tag = 01X) & (version = textTag) THEN Load0(r, T)
ELSE (*ascii*)
NEW(u); u.len := MAX(LONGINT); u.fnt := NIL; u.col := Displaywhite;
NEW(p);
IF (tag = DocBlockId) & (version = 07X) THEN (* extract ascii text from System 3 text document *)
Files.Set(r, f, 28); Files.ReadLInt(r, hlen);
Files.Set(r, f, 22 + hlen); Files.ReadLInt(r, T.len); p.org := 26 + hlen
ELSE
T.len := Files.Length(f); p.org := 0
END ;
IF T.len > 0 THEN p.len := T.len; p.fnt := FontsDefault;
p.col := Displaywhite; p.voff := 0; p.file := f; p.ascii := TRUE;
u.next := p; u.prev := p; p.next := u; p.prev := u
ELSE u.next := u; u.prev := u
END;
T.head := u; T.cache := T.head; T.corg := 0
END
END Open;
PROCEDURE Store* (VAR r: Files.Rider; T: Text);
VAR r1: Files.Rider; u, un: Run; e: Elem; org, pos, delta, hlen, rlen: LONGINT; ecnt, fcnt: SHORTINT; ch: CHAR; (* << *)
fno: SYSTEM.INT8;
msg: FileMsg; iden: IdentifyMsg;
mods, procs: ARRAY 64, 32 OF CHAR;
fnts: ARRAY 32 OF FontsFont;
block: ARRAY 1024 OF CHAR;
PROCEDURE StoreElem (VAR r: Files.Rider; pos: LONGINT; e: Elem);
VAR r1: Files.Rider; org, span: LONGINT; eno: SYSTEM.INT8;
BEGIN COPY(iden.mod, mods[ecnt]); COPY(iden.proc, procs[ecnt]); eno := 1;
WHILE (mods[eno] # iden.mod) OR (procs[eno] # iden.proc) DO INC(eno) END;
Files.Set(r1, Files.Base(r), Files.Pos(r));
Files.WriteLInt(r, 0); Files.WriteLInt(r, 0); Files.WriteLInt(r, 0); (*fixup slot*)
Files.Write(r, eno);
IF eno = ecnt THEN INC(ecnt); Files.WriteString(r, iden.mod); Files.WriteString(r, iden.proc) END;
msg.pos := pos; org := Files.Pos(r); e.handle(e, msg); span := Files.Pos(r) - org;
Files.WriteLInt(r1, -span); Files.WriteLInt(r1, e.W); Files.WriteLInt(r1, e.H) (*fixup*)
END StoreElem;
BEGIN
org := Files.Pos(r); msg.id := store; msg.r := r; Files.WriteLInt(msg.r, 0); (*fixup slot*)
u := T.head.next; pos := 0; delta := 0; fcnt := 1; ecnt := 1;
WHILE u # T.head DO
IF u IS Elem THEN iden.mod[0] := 0X; u(Elem).handle(u(Elem), iden) ELSE iden.mod[0] := 1X END;
IF iden.mod[0] # 0X THEN
fnts[fcnt] := u.fnt; fno := 1;
WHILE fnts[fno].name # u.fnt.name DO INC(fno) END;
Files.Write(msg.r, fno);
IF fno = fcnt THEN INC(fcnt); Files.WriteString(msg.r, u.fnt.name) END;
Files.Write(msg.r, u.col); Files.Write(msg.r, u.voff)
END;
IF u IS Piece THEN rlen := u.len; un := u.next;
WHILE (un IS Piece) & (un.fnt = u.fnt) & (un.col = u.col) & (un.voff = u.voff) DO
INC(rlen, un.len); un := un.next
END;
Files.WriteLInt(msg.r, rlen); INC(pos, rlen); u := un
ELSIF iden.mod[0] # 0X THEN StoreElem(msg.r, pos, u(Elem)); INC(pos); u := u.next
ELSE INC(delta); u := u.next
END
END;
Files.Write(msg.r, 0); Files.WriteLInt(msg.r, T.len - delta);
(*!!!hlen := Files.Pos(msg.r) - org;*) hlen := Files.Pos(msg.r) - org + 2;
Files.Set(r1, Files.Base(msg.r), org); Files.WriteLInt(r1, hlen); (*fixup*)
u := T.head.next;
WHILE u # T.head DO
IF u IS Piece THEN
WITH u: Piece DO
IF u.ascii THEN Files.Set(r1, u.file, u.org); delta := u.len; (* << LF to CR *)
WHILE delta > 0 DO Files.Read(r1, ch); DEC(delta);
IF ch = 0AX THEN Files.Write(msg.r, CR) ELSE Files.Write(msg.r, ch) END
END
ELSE Files.Set(r1, u.file, u.org); delta := u.len;
WHILE delta > LEN(block) DO Files.ReadBytes(r1, block, LEN(block));
Files.WriteBytes(msg.r, block, LEN(block)); DEC(delta, LEN(block))
END;
Files.ReadBytes(r1, block, delta); Files.WriteBytes(msg.r, block, delta)
END
END
ELSE iden.mod[0] := 0X; u(Elem).handle(u(Elem), iden);
IF iden.mod[0] # 0X THEN Files.Write(msg.r, ElemChar) END
END;
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
f := Files.New(name); Files.Set(r, f, 0); Files.Write(r, textTag); Files.Write(r, version); Store(r, T);
i := 0; WHILE name[i] # 0X DO INC(i) END;
COPY(name, bak); bak[i] := "."; bak[i+1] := "B"; bak[i+2] := "a"; bak[i+3] := "k"; bak[i+4] := 0X;
Files.Rename(name, bak, res); Files.Register(f)
END Close;
BEGIN del := NIL; NEW(FontsDefault); FontsDefault.name := "Syntax10.Scn.Fnt"
END Texts.

6
src/system/Platformunix.Mod
View file

@ -41,7 +41,7 @@ VAR
SeekCur-: INTEGER;
SeekEnd-: INTEGER;
nl-: ARRAY 3 OF CHAR; (* Platform specific newline representation *)
NL-: ARRAY 3 OF CHAR; (* Platform specific newline representation *)
@ -547,6 +547,6 @@ BEGIN
SeekCur := seekcur();
SeekEnd := seekend();
nl[0] := 0AX; (* LF *)
nl[1] := 0X;
NL[0] := 0AX; (* LF *)
NL[1] := 0X;
END Platform.

300
src/tools/make/oberon.mk
View file

@ -155,16 +155,20 @@ installable:
# May require root access.
install:
@printf "\nInstalling into \"$(INSTALLDIR)\"\n"
@rm -rf "$(INSTALLDIR)/bin" "$(INSTALLDIR)/$(MODEL)"
@rm -rf "$(INSTALLDIR)/bin" "$(INSTALLDIR)/2 "$(INSTALLDIR)/C
@mkdir -p "$(INSTALLDIR)/bin"
@cp $(OBECOMP) "$(INSTALLDIR)/bin/$(OBECOMP)"
@-cp $(BUILDDIR)/showdef$(BINEXT) "$(INSTALLDIR)/bin"
@mkdir -p "$(INSTALLDIR)/2/include" && cp $(BUILDDIR)/*.h "$(INSTALLDIR)/2/include/"
@mkdir -p "$(INSTALLDIR)/2/sym" && cp $(BUILDDIR)/*.sym "$(INSTALLDIR)/2/sym/"
@mkdir -p "$(INSTALLDIR)/C/include" && cp $(BUILDDIR)/C/*.h "$(INSTALLDIR)/C/include/"
@mkdir -p "$(INSTALLDIR)/C/sym" && cp $(BUILDDIR)/C/*.sym "$(INSTALLDIR)/C/sym/"
@mkdir -p "$(INSTALLDIR)/lib"
@mkdir -p "$(INSTALLDIR)/$(MODEL)/include"
@mkdir -p "$(INSTALLDIR)/$(MODEL)/sym"
@cp $(BUILDDIR)/*.h "$(INSTALLDIR)/$(MODEL)/include/"
@cp $(BUILDDIR)/*.sym "$(INSTALLDIR)/$(MODEL)/sym/"
@cp $(OBECOMP) "$(INSTALLDIR)/bin/$(OBECOMP)"
@-cp $(BUILDDIR)/showdef$(BINEXT) "$(INSTALLDIR)/bin"
@cp $(BUILDDIR)/lib$(ONAME)* "$(INSTALLDIR)/lib/"
@cp $(BUILDDIR)/lib$(ONAME)* "$(INSTALLDIR)/lib/"
@cp $(BUILDDIR)/C/lib$(ONAME)* "$(INSTALLDIR)/lib/"
@if which ldconfig >/dev/null 2>&1; then $(LDCONFIG); fi
@ -184,176 +188,194 @@ uninstall:
if which ldconfig >/dev/null 2>&1; then ldconfig; fi
runtime:
@printf "\nMaking v4 library for -O$(MODEL)\n"
cd $(BUILDDIR)/$(MODEL) && $(COMPILE) -c SYSTEM.c
cd $(BUILDDIR)/$(MODEL); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../../src/runtime/Platform$(PLATFORM).Mod
cd $(BUILDDIR)/$(MODEL); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../../src/runtime/Heap.Mod
cd $(BUILDDIR)/$(MODEL); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../../src/runtime/Out.Mod
cd $(BUILDDIR)/$(MODEL); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../../src/runtime/Modules.Mod
cd $(BUILDDIR)/$(MODEL); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../../src/runtime/Strings.Mod
cd $(BUILDDIR)/$(MODEL); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../../src/runtime/Files.Mod
cd $(BUILDDIR)/$(MODEL); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../../src/runtime/Reals.Mod
# cd $(BUILDDIR)/$(MODEL); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../../src/runtime/LowReal.Mod
# cd $(BUILDDIR)/$(MODEL); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../../src/runtime/Math.Mod
# cd $(BUILDDIR)/$(MODEL); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../../src/runtime/LowLReal.Mod
# cd $(BUILDDIR)/$(MODEL); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../../src/runtime/MathL.Mod
cd $(BUILDDIR)/$(MODEL); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../../src/runtime/Texts.Mod
cd $(BUILDDIR)/$(MODEL); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../../src/runtime/Oberon.Mod
v4:
@printf "\nMaking v4 library\n"
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/v4/Args.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/v4/Printer.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/v4/Sets.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/v4/Args.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/v4/Printer.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/v4/Sets.Mod
ooc2:
@printf "\nMaking ooc2 library\n"
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc2/ooc2Strings.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc2/ooc2Ascii.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc2/ooc2CharClass.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc2/ooc2ConvTypes.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc2/ooc2IntConv.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc2/ooc2IntStr.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc2/ooc2Real0.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc2/ooc2Strings.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc2/ooc2Ascii.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc2/ooc2CharClass.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc2/ooc2ConvTypes.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc2/ooc2IntConv.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc2/ooc2IntStr.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc2/ooc2Real0.Mod
TODO: Comment disabled lines contain use of VAL that reads beyond source variable
ooc:
@printf "\nMaking ooc library\n"
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocLowReal.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocLowLReal.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocRealMath.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocOakMath.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocLRealMath.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocLongInts.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocComplexMath.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocLComplexMath.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocAscii.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocCharClass.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocStrings.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocConvTypes.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocLRealConv.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocLRealStr.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocRealConv.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocRealStr.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocIntConv.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocIntStr.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocMsg.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocSysClock.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocTime.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocChannel.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocStrings2.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocRts.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocFilenames.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocTextRider.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocBinaryRider.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocJulianDay.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocFilenames.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocwrapperlibc.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocC$(DATAMODEL).Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc/oocLowReal.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc/oocLowLReal.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc/oocRealMath.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc/oocOakMath.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc/oocLRealMath.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc/oocLongInts.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc/oocComplexMath.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc/oocLComplexMath.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc/oocAscii.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc/oocCharClass.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc/oocStrings.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc/oocConvTypes.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc/oocLRealConv.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc/oocLRealStr.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc/oocRealConv.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc/oocRealStr.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc/oocIntConv.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc/oocIntStr.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc/oocMsg.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc/oocSysClock.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc/oocTime.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc/oocChannel.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc/oocStrings2.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc/oocRts.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc/oocFilenames.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc/oocTextRider.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc/oocBinaryRider.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc/oocJulianDay.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc/oocFilenames.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc/oocwrapperlibc.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ooc/oocC$(DATAMODEL).Mod
oocX11:
@printf "\nMaking oocX11 library\n"
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/oocX11/oocX11.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/oocX11/oocXutil.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/oocX11/oocXYplane.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/oocX11/oocX11.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/oocX11/oocXutil.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/oocX11/oocXYplane.Mod
ulm:
@printf "\nMaking ulm library\n"
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmObjects.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmPriorities.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmDisciplines.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmServices.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmSys.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmSYSTEM.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmEvents.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmProcess.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmResources.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmForwarders.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmRelatedEvents.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmTypes.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmStreams.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmStrings.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmSysTypes.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmTexts.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmSysConversions.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmErrors.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmSysErrors.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmSysStat.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmASCII.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmSets.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmIO.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmAssertions.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmIndirectDisciplines.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmStreamDisciplines.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmIEEE.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmMC68881.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmReals.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmPrint.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmWrite.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmConstStrings.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmPlotters.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmSysIO.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmLoader.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmNetIO.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmPersistentObjects.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmPersistentDisciplines.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmOperations.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmScales.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmTimes.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmClocks.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmTimers.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmConditions.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmStreamConditions.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmTimeConditions.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmCiphers.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmCipherOps.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmBlockCiphers.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmAsymmetricCiphers.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmConclusions.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmRandomGenerators.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmTCrypt.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmIntOperations.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmObjects.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmPriorities.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmDisciplines.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmServices.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmSys.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmSYSTEM.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmEvents.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmProcess.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmResources.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmForwarders.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmRelatedEvents.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmTypes.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmStreams.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmStrings.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmSysTypes.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmTexts.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmSysConversions.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmErrors.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmSysErrors.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmSysStat.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmASCII.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmSets.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmIO.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmAssertions.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmIndirectDisciplines.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmStreamDisciplines.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmIEEE.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmMC68881.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmReals.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmPrint.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmWrite.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmConstStrings.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmPlotters.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmSysIO.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmLoader.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmNetIO.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmPersistentObjects.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmPersistentDisciplines.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmOperations.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmScales.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmTimes.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmClocks.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmTimers.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmConditions.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmStreamConditions.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmTimeConditions.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmCiphers.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmCipherOps.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmBlockCiphers.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmAsymmetricCiphers.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmConclusions.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmRandomGenerators.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmTCrypt.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/ulm/ulmIntOperations.Mod
pow32:
@printf "\nMaking pow library\n"
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/pow/powStrings.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/pow/powStrings.Mod
misc:
@printf "\nMaking misc library\n"
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/system/Oberon.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/misc/crt.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/misc/Listen.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/misc/MersenneTwister.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/misc/MultiArrays.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/misc/MultiArrayRiders.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/system/Oberon.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/misc/crt.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/misc/Listen.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/misc/MersenneTwister.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/misc/MultiArrays.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/misc/MultiArrayRiders.Mod
s3:
@printf "\nMaking s3 library\n"
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/s3/ethBTrees.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/s3/ethMD5.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/s3/ethSets.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/s3/ethZlib.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/s3/ethZlibBuffers.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/s3/ethZlibInflate.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/s3/ethZlibDeflate.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/s3/ethZlibReaders.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/s3/ethZlibWriters.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/s3/ethZip.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/s3/ethRandomNumbers.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/s3/ethGZReaders.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/s3/ethGZWriters.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/s3/ethUnicode.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/s3/ethDates.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/s3/ethReals.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/s3/ethStrings.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/s3/ethBTrees.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/s3/ethMD5.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/s3/ethSets.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/s3/ethZlib.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/s3/ethZlibBuffers.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/s3/ethZlibInflate.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/s3/ethZlibDeflate.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/s3/ethZlibReaders.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/s3/ethZlibWriters.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/s3/ethZip.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/s3/ethRandomNumbers.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/s3/ethGZReaders.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/s3/ethGZWriters.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/s3/ethUnicode.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/s3/ethDates.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/s3/ethReals.Mod
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/s3/ethStrings.Mod
librarybinary:
@printf "\nMaking lib$(ONAME)\n"
# Remove objects that should not be part of the library
O2library: v4 ooc2 ooc ulm pow32 misc s3
@printf "\nMaking lib$(ONAME)2\n"
rm -f $(BUILDDIR)/Compiler.o
# Note: remining compiler files are retained in the library allowing the building
# of utilities like BrowserCmd.Mod (aka showdef).
# Make static library
ar rcs "$(BUILDDIR)/lib$(ONAME)$(MODEL).a" $(BUILDDIR)/*.o
ar rcs "$(BUILDDIR)/lib$(ONAME)2.a" $(BUILDDIR)/*.o
# Make shared library
@cd $(BUILDDIR) && $(COMPILE) -shared -o lib$(ONAME)$(MODEL).so *.o
@cd $(BUILDDIR) && $(COMPILE) -shared -o lib$(ONAME)2.so *.o
library: v4 ooc2 ooc ulm pow32 misc s3 librarybinary
OakwoodLibrary:
@printf "\nMaking lib$(ONAME)$(MODEL)\n"
mkdir -p $(BUILDDIR)/$(MODEL)
cp src/system/*.[ch] $(BUILDDIR)/$(MODEL)
@make -f src/tools/make/oberon.mk -s runtime MODEL=$(MODEL)
ar rcs "$(BUILDDIR)/$(MODEL)/lib$(ONAME)$(MODEL).a" $(BUILDDIR)/$(MODEL)/*.o
@cd $(BUILDDIR)/$(MODEL) && $(COMPILE) -shared -o lib$(ONAME)$(MODEL).so *.o