diff --git a/makefile b/makefile index df72a78b..5202abb7 100644 --- a/makefile +++ b/makefile @@ -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 diff --git a/src/compiler/Compiler.Mod b/src/compiler/Compiler.Mod index f27fd578..e5acdac7 100644 --- a/src/compiler/Compiler.Mod +++ b/src/compiler/Compiler.Mod @@ -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; diff --git a/src/compiler/OPC.Mod b/src/compiler/OPC.Mod index 4f4839c5..e0313bbe 100644 --- a/src/compiler/OPC.Mod +++ b/src/compiler/OPC.Mod @@ -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); diff --git a/src/compiler/OPT.Mod b/src/compiler/OPT.Mod index ad3afe73..3732b2cb 100644 --- a/src/compiler/OPT.Mod +++ b/src/compiler/OPT.Mod @@ -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); diff --git a/src/compiler/OPV.Mod b/src/compiler/OPV.Mod index 34d1ef34..39bfeded 100644 --- a/src/compiler/OPV.Mod +++ b/src/compiler/OPV.Mod @@ -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; diff --git a/src/compiler/extTools.Mod b/src/compiler/extTools.Mod index f158fd60..077fb5a5 100644 --- a/src/compiler/extTools.Mod +++ b/src/compiler/extTools.Mod @@ -76,4 +76,3 @@ PROCEDURE LinkMain*(VAR moduleName: ARRAY OF CHAR; statically: BOOLEAN; addition END extTools. -, \ No newline at end of file diff --git a/src/runtime/Files.Mod b/src/runtime/Files.Mod new file mode 100644 index 00000000..7e497627 --- /dev/null +++ b/src/runtime/Files.Mod @@ -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. diff --git a/src/runtime/Heap.Mod b/src/runtime/Heap.Mod new file mode 100644 index 00000000..b05b218b --- /dev/null +++ b/src/runtime/Heap.Mod @@ -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. diff --git a/src/runtime/In.Mod b/src/runtime/In.Mod new file mode 100644 index 00000000..e69de29b diff --git a/src/runtime/LowLReal.Mod b/src/runtime/LowLReal.Mod new file mode 100644 index 00000000..b90958b2 --- /dev/null +++ b/src/runtime/LowLReal.Mod @@ -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 xexpoMax THEN RETURN large*sign(x) (* exception raised here *) + ELSIF exp= 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 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. + + diff --git a/src/runtime/Math.Mod b/src/runtime/Math.Mod new file mode 100644 index 00000000..c2a648c9 --- /dev/null +++ b/src/runtime/Math.Mod @@ -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)= 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=LnInfinity THEN l.ErrorHandler(Overflow); RETURN huge + ELSIF 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 xymax 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)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 yONE 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)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 iw1ZERO 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 (x0 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 xdLnInfinity 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 fSqrtInfinity*HALF THEN l.ErrorHandler(HypInvTrigClipped); + IF x>ZERO THEN RETURN ln(SqrtInfinity) ELSE RETURN -ln(SqrtInfinity) END; + ELSIF xSqrtInfinity*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 xTanhLimit 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. diff --git a/src/runtime/MathL.Mod b/src/runtime/MathL.Mod new file mode 100644 index 00000000..8732fee9 --- /dev/null +++ b/src/runtime/MathL.Mod @@ -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)= 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 xLnInfinity THEN l.ErrorHandler(Overflow); RETURN huge + ELSIF 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 xONE 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)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 iw1ZERO 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 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 (x0 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)=l.expoMax-3 THEN l.ErrorHandler(Overflow); atan:=PiOver2 + ELSIF xnExp-xdExpABS(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)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 xdLnInfinity 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 fSqrtInfinity*HALF THEN l.ErrorHandler(HypInvTrigClipped); + IF x>ZERO THEN RETURN ln(SqrtInfinity) ELSE RETURN -ln(SqrtInfinity) END; + ELSIF xSqrtInfinity*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 xTanhLimit 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. + diff --git a/src/runtime/Modules.Mod b/src/runtime/Modules.Mod new file mode 100644 index 00000000..26268749 --- /dev/null +++ b/src/runtime/Modules.Mod @@ -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. diff --git a/src/runtime/Oberon.Mod b/src/runtime/Oberon.Mod new file mode 100644 index 00000000..fbc3abd4 --- /dev/null +++ b/src/runtime/Oberon.Mod @@ -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. diff --git a/src/runtime/Out.Mod b/src/runtime/Out.Mod new file mode 100644 index 00000000..245c67a8 --- /dev/null +++ b/src/runtime/Out.Mod @@ -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. diff --git a/src/runtime/Platformunix.Mod b/src/runtime/Platformunix.Mod new file mode 100644 index 00000000..034906bd --- /dev/null +++ b/src/runtime/Platformunix.Mod @@ -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 '; (* for gettimeofday *) +PROCEDURE -Aincludetime '#include '; (* for localtime *) +PROCEDURE -Aincludesystypes '#include '; +PROCEDURE -Aincludeunistd '#include '; +PROCEDURE -Aincludesysstat '#include '; +PROCEDURE -Aincludefcntl '#include '; +PROCEDURE -Aincludeerrno '#include '; +PROCEDURE -Astdlib '#include '; +PROCEDURE -Astdio '#include '; +PROCEDURE -Aerrno '#include '; + + + + +(* 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. diff --git a/src/runtime/Platformwindows.Mod b/src/runtime/Platformwindows.Mod new file mode 100644 index 00000000..a538fdc5 --- /dev/null +++ b/src/runtime/Platformwindows.Mod @@ -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. diff --git a/src/runtime/Reals.Mod b/src/runtime/Reals.Mod new file mode 100644 index 00000000..f9e6617b --- /dev/null +++ b/src/runtime/Reals.Mod @@ -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. diff --git a/src/runtime/Strings.Mod b/src/runtime/Strings.Mod new file mode 100644 index 00000000..e6fe12ac --- /dev/null +++ b/src/runtime/Strings.Mod @@ -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. diff --git a/src/runtime/Texts.Mod b/src/runtime/Texts.Mod new file mode 100644 index 00000000..305b225d --- /dev/null +++ b/src/runtime/Texts.Mod @@ -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. diff --git a/src/system/Platformunix.Mod b/src/system/Platformunix.Mod index 288fc04b..034906bd 100644 --- a/src/system/Platformunix.Mod +++ b/src/system/Platformunix.Mod @@ -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. diff --git a/src/tools/make/oberon.mk b/src/tools/make/oberon.mk index 16311bd0..862ee483 100644 --- a/src/tools/make/oberon.mk +++ b/src/tools/make/oberon.mk @@ -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