From 4245c6e8b314a2e4880061f76c8e47d361fc84e5 Mon Sep 17 00:00:00 2001 From: David Brown Date: Thu, 16 Jun 2016 14:14:39 +0100 Subject: [PATCH] Update system source to V2. --- src/system/Console.Mod | 20 +- src/system/Files.Mod | 600 +++++++++++++--------- src/system/Heap.Mod | 337 +++++++----- src/system/Kernel0.Mod | 200 -------- src/system/Oberon.Mod | 76 +-- src/system/Platformunix.Mod | 914 +++++++++++++++++---------------- src/system/Platformwindows.Mod | 611 ++++++++++++++++++++++ src/system/SYSTEM.c | 392 +++++++------- src/system/SYSTEM.h | 473 +++++++++-------- src/system/WindowsWrapper.h | 9 + 10 files changed, 2150 insertions(+), 1482 deletions(-) delete mode 100644 src/system/Kernel0.Mod create mode 100755 src/system/Platformwindows.Mod create mode 100755 src/system/WindowsWrapper.h diff --git a/src/system/Console.Mod b/src/system/Console.Mod index e523ef7b..8e2be161 100644 --- a/src/system/Console.Mod +++ b/src/system/Console.Mod @@ -2,20 +2,16 @@ MODULE Console; (* J. Templ, 29-June-96 *) (* output to Unix standard output device based Write system call *) - IMPORT SYSTEM; + IMPORT SYSTEM, Platform; VAR line: ARRAY 128 OF CHAR; pos: INTEGER; - PROCEDURE -Write(adr, n: LONGINT) - "write(1/*stdout*/, adr, n)"; - - PROCEDURE -read(VAR ch: CHAR): LONGINT - "read(0/*stdin*/, ch, 1)"; - - PROCEDURE Flush*(); + PROCEDURE Flush*; + VAR error: Platform.ErrorCode; BEGIN - Write(SYSTEM.ADR(line), pos); pos := 0; + error := Platform.Write(Platform.StdOut, SYSTEM.ADR(line), pos); + pos := 0; END Flush; PROCEDURE Char*(ch: CHAR); @@ -68,16 +64,16 @@ MODULE Console; (* J. Templ, 29-June-96 *) END Hex; PROCEDURE Read*(VAR ch: CHAR); - VAR n: LONGINT; + VAR n: LONGINT; error: Platform.ErrorCode; BEGIN Flush(); - n := read(ch); + error := Platform.ReadBuf(Platform.StdIn, ch, n); IF n # 1 THEN ch := 0X END END Read; PROCEDURE ReadLine*(VAR line: ARRAY OF CHAR); VAR i: LONGINT; ch: CHAR; BEGIN Flush(); - i := 0; Read(ch); + i := 0; Read(ch); WHILE (i < LEN(line) - 1) & (ch # 0AX) & (ch # 0X) DO line[i] := ch; INC(i); Read(ch) END ; line[i] := 0X END ReadLine; diff --git a/src/system/Files.Mod b/src/system/Files.Mod index 1d9cd953..73a78028 100644 --- a/src/system/Files.Mod +++ b/src/system/Files.Mod @@ -1,11 +1,8 @@ -MODULE Files0; (* J. Templ 1.12. 89/12.4.95 Oberon files mapped onto Unix files *) +MODULE Files; (* J. Templ 1.12. 89/12.4.95 Oberon files mapped onto Unix files *) -(* this module is not for use by developers and inteded to bootstrap voc *) -(* for general use import Files module *) + IMPORT SYSTEM, Platform, Heap, Strings, Configuration, Console; - IMPORT SYSTEM, Unix, Kernel := Kernel0, Args, Console; - - (* standard data type I/O + (* standard data type I/O little endian, Sint:1, Int:2, Lint:4 @@ -19,74 +16,71 @@ MODULE Files0; (* J. Templ 1.12. 89/12.4.95 Oberon files mapped onto Unix files CONST nofbufs = 4; bufsize = 4096; - fileTabSize = 64; + fileTabSize = 256; (* 256 needed for Windows *) noDesc = -1; notDone = -1; (* file states *) - open = 0; create = 1; close = 2; + 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 Handle; - Buffer = POINTER TO BufDesc; + File* = POINTER TO Handle; + Buffer = POINTER TO BufDesc; Handle = RECORD workName, registerName: FileName; tempFile: BOOLEAN; - dev, ino, mtime: LONGINT; - fd-: INTEGER; + identity: Platform.FileIdentity; + fd-: Platform.FileHandle; len, pos: LONGINT; bufs: ARRAY nofbufs OF Buffer; swapper, state: INTEGER - END ; + END; BufDesc = RECORD - f: File; - chg: BOOLEAN; - org, size: LONGINT; + f: File; + chg: BOOLEAN; + org: LONGINT; + size: LONGINT; data: ARRAY bufsize OF SYSTEM.BYTE - END ; + END; - Rider* = RECORD + Rider* = RECORD res*: LONGINT; eof*: BOOLEAN; buf: Buffer; org, offset: LONGINT - END ; + END; - Time = POINTER TO TimeDesc; - TimeDesc = RECORD - sec*, min*, hour*, mday*, mon*, year*, wday*, isdst*, zone*, gmtoff*: LONGINT; -(* sec*, min*, hour*, mday*, mon*, year*, wday*, isdst*, zone*, gmtoff*: INTEGER;*) - END ; VAR - fileTab: ARRAY fileTabSize OF LONGINT (*=File*); - tempno: INTEGER; + fileTab: ARRAY fileTabSize OF LONGINT (*=File*); + tempno: INTEGER; + HOME: ARRAY 1024 OF CHAR; + SearchPath: POINTER TO ARRAY OF CHAR; -(* for localtime *) - PROCEDURE -includetime() - '#include "time.h"'; - PROCEDURE -localtime(VAR clock: LONGINT): Time - "(Files0_Time) localtime(clock)"; - PROCEDURE -getcwd(VAR cwd: Unix.Name) - "getcwd(cwd, cwd__len)"; PROCEDURE -IdxTrap "__HALT(-1)"; PROCEDURE^ Finalize(o: SYSTEM.PTR); - PROCEDURE Err(s: ARRAY OF CHAR; f: File; errno: LONGINT); + PROCEDURE Err(s: ARRAY OF CHAR; f: File; errcode: Platform.ErrorCode); BEGIN - Console.Ln; Console.String("-- "); Console.String(s); Console.String(": "); + Console.Ln; Console.String("-- "); Console.String(s); Console.String(": "); IF f # NIL THEN - IF f.registerName # "" THEN Console.String(f.registerName) ELSE Console.String(f.workName) END - END ; - IF errno # 0 THEN Console.String(" errno = "); Console.Int(errno, 1) END ; + IF f.registerName # "" THEN Console.String(f.registerName) ELSE Console.String(f.workName) END; + IF f.fd # 0 THEN Console.String("f.fd = "); Console.Int(f.fd,1) END + END; + IF errcode # 0 THEN Console.String(" errcode = "); Console.Int(errcode, 1) END; Console.Ln; HALT(99) END Err; @@ -94,9 +88,9 @@ MODULE Files0; (* J. Templ 1.12. 89/12.4.95 Oberon files mapped onto Unix files 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 ; + 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; @@ -105,8 +99,8 @@ MODULE Files0; (* J. Templ 1.12. 89/12.4.95 Oberon files mapped onto Unix files BEGIN INC(tempno); n := tempno; i := 0; IF finalName[0] # "/" THEN (* relative pathname *) - WHILE Kernel.CWD[i] # 0X DO name[i] := Kernel.CWD[i]; INC(i) END; - IF Kernel.CWD[i-1] # "/" THEN name[i] := "/"; INC(i) END + 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; @@ -114,73 +108,128 @@ MODULE Files0; (* J. Templ 1.12. 89/12.4.95 Oberon files mapped onto Unix files 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 := SHORT(Unix.Getpid()); + 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 stat: Unix.Status; done: BOOLEAN; - errno: LONGINT; err: ARRAY 32 OF CHAR; + VAR + identity: Platform.FileIdentity; + done: BOOLEAN; + error: Platform.ErrorCode; + err: ARRAY 32 OF CHAR; BEGIN + (* + Console.String("Files.Create fd = "); Console.Int(f.fd,1); + Console.String(", registerName = "); Console.String(f.registerName); + Console.String(", workName = "); Console.String(f.workName); + Console.String(", state = "); Console.Int(f.state,1); + Console.Ln; + *) IF f.fd = noDesc THEN - IF f.state = create THEN GetTempName(f.registerName, f.workName); f.tempFile := TRUE + 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 ; - errno := Unix.Unlink(f.workName); (*unlink first to avoid stale NFS handles and to avoid reuse of inodes*) -f.fd := Unix.Open(f.workName, SHORT(SYSTEM.VAL(LONGINT, (Unix.rdwr + Unix.creat + Unix.trunc))), SHORT(SYSTEM.VAL(LONGINT, ({2, 4,5, 7,8})))); - done := f.fd >= 0; errno := Unix.errno(); - IF (~done & ((errno = Unix.ENFILE) OR (errno = Unix.EMFILE))) OR (done & (f.fd >= fileTabSize)) THEN - IF done & (f.fd >= fileTabSize) THEN errno := Unix.Close(f.fd) END ; - Kernel.GC(TRUE); - f.fd := Unix.Open(f.workName, SHORT(SYSTEM.VAL(LONGINT, (Unix.rdwr + Unix.creat + Unix.trunc))), SHORT(SYSTEM.VAL(LONGINT, {2, 4,5, 7,8}))); - done := f.fd >= 0 - END ; + 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; + (* In case of too many files, try just once more. *) + IF (~done & Platform.TooManyFiles(error)) OR (done & (f.fd >= fileTabSize)) THEN + IF done & (f.fd >= fileTabSize) THEN error := Platform.Close(f.fd) END; + Heap.GC(TRUE); + error := Platform.New(f.workName, f.fd); + done := f.fd = 0 + END; IF done THEN - IF f.fd >= fileTabSize THEN errno := Unix.Close(f.fd); Err("too many files open", f, 0) - ELSE fileTab[f.fd] := SYSTEM.VAL(LONGINT, f); INC(Kernel.nofiles); Kernel.RegisterObject(f, Finalize); - f.state := open; f.pos := 0; errno := Unix.Fstat(f.fd, stat); - f.dev := stat.dev; f.ino := stat.ino; f.mtime := stat.mtime + IF f.fd >= fileTabSize THEN + (* Console.String("f.fd = "); Console.Int(f.fd,1); Console.Ln; *) + error := Platform.Close(f.fd); Err("too many files open", f, 0) + ELSE + fileTab[f.fd] := SYSTEM.VAL(LONGINT, f); + INC(Heap.FileCount); + Heap.RegisterFinalizer(f, Finalize); + f.state := open; + f.pos := 0; + error := Platform.Identify(f.fd, f.identity); END - ELSE errno := Unix.errno(); - IF errno = Unix.ENOENT THEN err := "no such directory" - ELSIF (errno = Unix.ENFILE) OR (errno = Unix.EMFILE) THEN err := "too many files open" - ELSE err := "file not created" - END ; - Err(err, f, errno) + ELSE + IF Platform.NoSuchDirectory(error) THEN err := "no such directory" + ELSIF Platform.TooManyFiles(error) THEN + (* Console.String("f.fd = "); Console.Int(f.fd,1); Console.Ln; *) + err := "too many files open" + ELSE err := "file not created" + END; + Err(err, f, error) END END END Create; PROCEDURE Flush(buf: Buffer); - VAR res: LONGINT; f: File; stat: Unix.Status; + VAR + error: Platform.ErrorCode; + f: File; + (* identity: Platform.FileIdentity; *) BEGIN + (* + Console.String("Files.Flush buf.f.registername = "); Console.String(buf.f.registerName); + Console.String(", buf.f.fd = "); Console.Int(buf.f.fd,1); + Console.String(", buffer at $"); Console.Hex(SYSTEM.ADR(buf.data)); + Console.String(", size "); Console.Int(buf.size,1); Console.Ln; + *) IF buf.chg THEN f := buf.f; Create(f); - IF buf.org # f.pos THEN res := Unix.Lseek(f.fd, buf.org, 0) END ; - res := Unix.Write(f.fd, SYSTEM.ADR(buf.data), buf.size); - IF res < 0 THEN Err("error in writing file", f, Unix.errno()) END ; + IF buf.org # f.pos THEN + error := Platform.Seek(f.fd, buf.org, Platform.SeekSet); + (* + Console.String("Seeking to "); Console.Int(buf.org,1); + Console.String(", error code "); Console.Int(error,1); Console.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; - res := Unix.Fstat(f.fd, stat); - f.mtime := stat.mtime + 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 Close* (f: File); - VAR i, res: LONGINT; + VAR + i: LONGINT; + error: Platform.ErrorCode; BEGIN + (* + Console.String("Files.Close f.fd = "); Console.Int(f.fd,1); + Console.String(" f.registername = "); Console.String(f.registerName); + Console.String(", f.workName = "); Console.String(f.workName); Console.Ln; + *) 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 ; - res := Unix.Fsync(f.fd); - IF res < 0 THEN Err("error in writing file", f, Unix.errno()) END + WHILE (i < nofbufs) & (f.bufs[i] # NIL) DO Flush(f.bufs[i]); INC(i) END; + error := Platform.Sync(f.fd); + (* + Console.String("Syncing closed file. fd = "); Console.Int(f.fd, 1); + Console.String(" error = "); Console.Int(error,1); Console.Ln; + *) + IF error # 0 THEN Err("error writing file", f, error) END; + (* Windows needs us to actually cose the file so that subsequent rename + will not encounter a sharing error. *) + fileTab[f.fd] := 0; + error := Platform.Close(f.fd); + f.fd := noDesc; f.state := create; DEC(Heap.FileCount); END END Close; PROCEDURE Length* (f: File): LONGINT; - BEGIN RETURN f.len - END Length; + BEGIN RETURN f.len END Length; PROCEDURE New* (name: ARRAY OF CHAR): File; VAR f: File; @@ -190,87 +239,108 @@ f.fd := Unix.Open(f.workName, SHORT(SYSTEM.VAL(LONGINT, (Unix.rdwr + Unix.creat RETURN f END New; - PROCEDURE ScanPath(VAR pos: INTEGER; VAR dir: ARRAY OF CHAR); (* supports ~, ~user and blanks inside path *) - VAR i: INTEGER; ch: CHAR; home: ARRAY 256 OF CHAR; + 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; ch := Kernel.OBERON[pos]; - WHILE (ch = " ") OR (ch = ":") DO INC(pos); ch := Kernel.OBERON[pos] END ; - IF ch = "~" THEN - INC(pos); ch := Kernel.OBERON[pos]; - home := ""; Args.GetEnv("HOME", home); - 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 + 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 - END ; - WHILE (ch # 0X) & (ch # ":") DO dir[i] := ch; INC(i); INC(pos); ch := Kernel.OBERON[pos] END ; - WHILE (i > 0) & (dir[i-1] = " ") DO DEC(i) 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 ; + WHILE (ch # 0X) & (ch # "/") DO INC(i); ch := name[i] END; RETURN ch = "/" END HasDir; - PROCEDURE CacheEntry(dev, ino: LONGINT; mtime: LONGINT): File; - VAR f: File; i: INTEGER; stat: Unix.Status; res: LONGINT; + PROCEDURE CacheEntry(identity: Platform.FileIdentity): File; + VAR f: File; i: INTEGER; error: Platform.ErrorCode; BEGIN i := 0; WHILE i < fileTabSize DO f := SYSTEM.VAL(File, fileTab[i]); - IF (f # NIL) & (ino = f.ino) & (dev = f.dev) THEN - IF mtime # f.mtime THEN i := 0; + IF (f # NIL) & 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 ; + IF f.bufs[i] # NIL THEN f.bufs[i].org := -1; f.bufs[i] := NIL END; INC(i) - END ; - f.swapper := -1; f.mtime := mtime; - res := Unix.Fstat(f.fd, stat); f.len := stat.size - END ; + END; + f.swapper := -1; f.identity := identity; + error := Platform.Size(f.fd, f.len); + END; RETURN f - END ; + END; INC(i) - END ; + END; RETURN NIL END CacheEntry; - PROCEDURE Old* (name: ARRAY OF CHAR): File; - VAR f: File; fd: INTEGER; res, errno: LONGINT; pos: INTEGER; done: BOOLEAN; + PROCEDURE Old*(name: ARRAY OF CHAR): File; + VAR + f: File; + fd: Platform.FileHandle; + pos: INTEGER; + done: BOOLEAN; dir, path: ARRAY 256 OF CHAR; - stat: Unix.Status; + error: Platform.ErrorCode; + identity: Platform.FileIdentity; BEGIN + (* Console.String("Files.Old "); Console.String(name); Console.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 ; + END; LOOP - fd := Unix.Open(path, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr)), SHORT(SYSTEM.VAL(LONGINT, {}))); done := fd >= 0; errno := Unix.errno(); - IF (~done & ((errno = Unix.ENFILE) OR (errno = Unix.EMFILE))) OR (done & (fd >= fileTabSize)) THEN - IF done & (fd >= fileTabSize) THEN res := Unix.Close(fd) END ; - Kernel.GC(TRUE); - fd := Unix.Open(path, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr)), SHORT(SYSTEM.VAL(LONGINT, {}))); - done := fd >= 0; errno := Unix.errno(); - IF ~done & ((errno = Unix.ENFILE) OR (errno = Unix.EMFILE)) THEN Err("too many files open", f, errno) END - END ; - IF ~done & ((errno = Unix.EACCES) OR (errno = Unix.EROFS) OR (errno = Unix.EAGAIN)) THEN - (* errno EAGAIN observed on Solaris 2.4 *) - fd := Unix.Open(path, SHORT(SYSTEM.VAL(LONGINT, Unix.rdonly)), SHORT(SYSTEM.VAL(LONGINT, {}))); done := fd >= 0; errno := Unix.errno() - END ; -IF (~done) & (errno # Unix.ENOENT) THEN - Console.String("warning Files0.Old "); Console.String(name); - Console.String(" errno = "); Console.Int(errno, 0); Console.Ln; -END ; + error := Platform.OldRW(path, fd); done := error = 0; + IF (~done & Platform.TooManyFiles(error)) OR (done & (fd >= fileTabSize)) THEN + IF done & (fd >= fileTabSize) THEN error := Platform.Close(fd) END; + Heap.GC(TRUE); + error := Platform.OldRW(path, fd); done := error = 0; + IF ~done & Platform.TooManyFiles(error) THEN + (* Console.String("fd = "); Console.Int(fd,1); Console.Ln; *) + Err("too many files open", f, error) + END + END; + IF ~done & Platform.Inaccessible(error) THEN + error := Platform.OldRO(path, fd); done := error = 0; + END; + IF (~done) & (~Platform.Absent(error)) THEN + Console.String("Warning: Files.Old "); Console.String(name); + Console.String(" error = "); Console.Int(error, 0); Console.Ln; + END; IF done THEN - res := Unix.Fstat(fd, stat); - f := CacheEntry(stat.dev, stat.ino, stat.mtime); - IF f # NIL THEN res := Unix.Close(fd); RETURN f - ELSIF fd >= fileTabSize THEN res := Unix.Close(fd); Err("too many files open", f, 0) - ELSE NEW(f); fileTab[fd] := SYSTEM.VAL(LONGINT, f); INC(Kernel.nofiles); Kernel.RegisterObject(f, Finalize); - f.fd := fd; f.state := open; f.len := stat.size; f.pos := 0; f.swapper := -1; (*all f.buf[i] = NIL*) + (* Console.String(" fd = "); Console.Int(fd,1); Console.Ln; *) + error := Platform.Identify(fd, identity); + f := CacheEntry(identity); + IF f # NIL THEN error := Platform.Close(fd); RETURN f + ELSIF fd >= fileTabSize THEN + (* Console.String("fd = "); Console.Int(fd,1); Console.Ln; *) + error := Platform.Close(fd); + Err("too many files open", f, 0) + ELSE NEW(f); fileTab[fd] := SYSTEM.VAL(LONGINT, f); INC(Heap.FileCount); 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.dev := stat.dev; f.ino := stat.ino; f.mtime := stat.mtime; + f.identity := identity; RETURN f END ELSIF dir = "" THEN RETURN NIL @@ -282,24 +352,26 @@ END ; END Old; PROCEDURE Purge* (f: File); - VAR i: INTEGER; stat: Unix.Status; res: LONGINT; + 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 ; + IF f.bufs[i] # NIL THEN f.bufs[i].org := -1; f.bufs[i] := NIL END; INC(i) - END ; - IF f.fd # noDesc THEN res := Unix.Ftruncate(f.fd, 0); res := Unix.Lseek(f.fd, 0, 0) END ; + 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; - res := Unix.Fstat(f.fd, stat); f.mtime := stat.mtime + error := Platform.Identify(f.fd, identity); Platform.SetMTime(f.identity, identity) END Purge; PROCEDURE GetDate* (f: File; VAR t, d: LONGINT); - VAR stat: Unix.Status; clock, res: LONGINT; time: Time; + VAR + identity: Platform.FileIdentity; error: Platform.ErrorCode; BEGIN - Create(f); res := Unix.Fstat(f.fd, stat); - time := localtime(stat.mtime); - t := time.sec + ASH(time.min, 6) + ASH(time.hour, 12); - d := time.mday + ASH(time.mon+1, 5) + ASH(time.year MOD 100, 9) + Create(f); error := Platform.Identify(f.fd, identity); + Platform.MTimeAsClock(identity, t, d) END GetDate; PROCEDURE Pos* (VAR r: Rider): LONGINT; @@ -307,12 +379,19 @@ END ; END Pos; PROCEDURE Set* (VAR r: Rider; f: File; pos: LONGINT); - VAR org, offset, i, n, res: LONGINT; buf: Buffer; + VAR org, offset, i, n: LONGINT; buf: Buffer; error: Platform.ErrorCode; BEGIN IF f # NIL THEN - IF pos > f.len THEN pos := f.len ELSIF pos < 0 THEN pos := 0 END ; + (* + Console.String("Files.Set rider on fd = "); Console.Int(f.fd,1); + Console.String(", registerName = "); Console.String(f.registerName); + Console.String(", workName = "); Console.String(f.workName); + Console.String(", state = "); Console.Int(f.state,1); + Console.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 ; + 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] @@ -321,20 +400,20 @@ END ; f.swapper := (f.swapper + 1) MOD nofbufs; buf := f.bufs[f.swapper]; Flush(buf) - END ; + END; IF buf.org # org THEN IF org = f.len THEN buf.size := 0 ELSE Create(f); - IF f.pos # org THEN res := Unix.Lseek(f.fd, org, 0) END ; - n := Unix.ReadBlk(f.fd, buf.data); - IF n < 0 THEN Err("read from file not done", f, Unix.errno()) END ; + 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 ; + END; buf.org := org; buf.chg := FALSE END ELSE buf := NIL; org := 0; offset := 0 - END ; + END; r.buf := buf; r.org := org; r.offset := offset; r.eof := FALSE; r.res := 0 END Set; @@ -342,33 +421,33 @@ END ; 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 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 + 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 ; + 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; + 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 ; + 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 ; + END; r.res := 0; r.eof := FALSE END ReadBytes; @@ -388,32 +467,32 @@ END ; IF (r.org # buf.org) OR (offset >= bufsize) THEN Set(r, buf.f, r.org + offset); buf := r.buf; offset := r.offset - END ; + END; buf.data[offset] := x; buf.chg := TRUE; IF offset = buf.size THEN INC(buf.size); INC(buf.f.len) - END ; + 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 ; + 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 ; + END; restInBuf := bufsize - offset; - IF n > restInBuf THEN min := restInBuf ELSE min := n END ; + 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 ; + 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 ; + END; r.res := 0 END WriteBytes; @@ -426,9 +505,9 @@ 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 + IF (offset >= bufsize) OR (r.org # buf.org) THEN Set(r, buf.f, r.org + offset); buf := r.buf; offset := r.offset; - END ; + END; buf.data[offset] := x; r.offset := offset + 1; buf.chg := TRUE END Write; @@ -442,7 +521,7 @@ BEGIN 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 ; + END; x := buf.data[offset]; r.offset := offset + 1 END Read; @@ -450,73 +529,91 @@ 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 := SHORT(Unix.Unlink(name)); - res := SHORT(Unix.errno()) - END Delete; + 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: INTEGER; n, errno, r: LONGINT; - ostat, nstat: Unix.Status; + VAR + fdold, fdnew: Platform.FileHandle; + n: LONGINT; + error, ignore: Platform.ErrorCode; + oldidentity, newidentity: Platform.FileIdentity; buf: ARRAY 4096 OF CHAR; BEGIN - r := Unix.Stat(old, ostat); - IF r >= 0 THEN - r := Unix.Stat(new, nstat); - IF (r >= 0) & ((ostat.dev # nstat.dev) OR (ostat.ino # nstat.ino)) THEN - Delete(new, res); (* work around stale nfs handles *) - END ; - r := Unix.Rename(old, new); - IF r < 0 THEN res := SHORT(Unix.errno()); - IF res = Unix.EXDEV THEN (* cross device link, move the file *) - fdold := Unix.Open(old, SHORT(SYSTEM.VAL(LONGINT, Unix.rdonly)), SHORT(SYSTEM.VAL(LONGINT, {}))); - IF fdold < 0 THEN res := 2; RETURN END ; - fdnew := Unix.Open(new, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr + Unix.creat + Unix.trunc)), SHORT(SYSTEM.VAL(LONGINT, {2, 4,5, 7,8}))); - IF fdnew < 0 THEN r := Unix.Close(fdold); res := 3; RETURN END ; - n := Unix.Read(fdold, SYSTEM.ADR(buf), bufsize); - WHILE n > 0 DO - r := Unix.Write(fdnew, SYSTEM.ADR(buf), n); - IF r < 0 THEN errno := Unix.errno(); r := Unix.Close(fdold); r := Unix.Close(fdnew); - Err("cannot move file", NIL, errno) - END ; - n := Unix.Read(fdold, SYSTEM.ADR(buf), bufsize) - END ; - errno := Unix.errno(); - r := Unix.Close(fdold); r := Unix.Close(fdnew); - IF n = 0 THEN r := Unix.Unlink(old); res := 0 - ELSE Err("cannot move file", NIL, errno) - END ; - ELSE RETURN (* res is Unix.Rename return code *) - END - END ; - res := 0 - ELSE res := 2 (* old file not found *) + (* + Console.String("Files.Rename old = "); Console.String(old); + Console.String(", new = "); Console.String(new); Console.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); + (* Console.String("Platform.Rename error code "); Console.Int(error,1); Console.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, errno: INTEGER; f1: File; file: ARRAY 104 OF CHAR; + VAR idx, errcode: INTEGER; f1: File; file: ARRAY 104 OF CHAR; BEGIN - IF (f.state = create) & (f.registerName # "") THEN f.state := close (* shortcut renaming *) END ; + (* + Console.String("Files.Register f.registerName = "); Console.String(f.registerName); + Console.String(", fd = "); Console.Int(f.fd,1); Console.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, errno); - IF errno # 0 THEN COPY(f.registerName, file); HALT(99) END ; + Rename(f.workName, f.registerName, errcode); + (* + Console.String("Renamed (for register) f.fd = "); Console.Int(f.fd,1); + Console.String(" from workname "); Console.String(f.workName); + Console.String(" to registerName "); Console.String(f.registerName); + Console.String(" errorcode = "); Console.Int(errcode,1); Console.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 := SHORT(Unix.Chdir(path)); - getcwd(Kernel.CWD) + res := Platform.Chdir(path); END ChangeDirectory; PROCEDURE FlipBytes(VAR src, dest: ARRAY OF SYSTEM.BYTE); VAR i, j: LONGINT; BEGIN - IF ~Kernel.littleEndian THEN i := LEN(src); j := 0; + 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 @@ -531,35 +628,51 @@ Especially Length would become fairly complex. 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); VAR b: ARRAY 4 OF CHAR; BEGIN ReadBytes(R, b, 4); x := SYSTEM.VAL(SET, ORD(b[0]) + ORD(b[1])*100H + ORD(b[2])*10000H + ORD(b[3])*1000000H) 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); @@ -567,70 +680,93 @@ Especially Length would become fairly complex. INC(n, ASH(ORD(ch) MOD 64 - ORD(ch) DIV 64 * 64, s) ); x := n END ReadNum; - + 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 ; + 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 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); + (* + Console.String("Files.Finalize f.fd = "); Console.Int(f.fd,1); + Console.String(", f.registername = "); Console.String(f.registerName); + Console.String(", f.workName = "); Console.String(f.workName); Console.Ln; + *) IF f.fd >= 0 THEN - fileTab[f.fd] := 0; res := Unix.Close(f.fd); f.fd := -1; DEC(Kernel.nofiles); - IF f.tempFile THEN res := Unix.Unlink(f.workName) END + fileTab[f.fd] := 0; res := Platform.Close(f.fd); f.fd := -1; DEC(Heap.FileCount); + 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; + PROCEDURE Init; VAR i: LONGINT; BEGIN - i := 0; WHILE i < fileTabSize DO fileTab[i] := 0; INC(i) END ; - tempno := -1; Kernel.nofiles := 0 + i := 0; WHILE i < fileTabSize DO fileTab[i] := 0; INC(i) END; + tempno := -1; + Heap.FileCount := 0; + SearchPath := NIL; + HOME := ""; Platform.GetEnv("HOME", HOME); END Init; BEGIN Init -END Files0. +END Files. diff --git a/src/system/Heap.Mod b/src/system/Heap.Mod index 6fc08dcf..a323c785 100644 --- a/src/system/Heap.Mod +++ b/src/system/Heap.Mod @@ -1,60 +1,52 @@ -(* -* voc (jet backend) runtime system, Version 1.1 -* -* Copyright (c) Software Templ, 1994, 1995, 1996 -* -* Module SYSTEM is subject to change any time without prior notification. -* Software Templ disclaims all warranties with regard to module SYSTEM, -* in particular shall Software Templ not be liable for any damage resulting -* from inappropriate use or modification of module SYSTEM. -*) +MODULE Heap; -MODULE SYSTEM; (* J. Templ, 31.5.95 *) + IMPORT SYSTEM; (* Cannot import anything else as heap initialization must complete + before any other modules are initialized. *) - IMPORT SYSTEM; (*must not import other modules*) - - CONST + CONST ModNameLen = 20; CmdNameLen = 24; - SZL = SIZE(LONGINT); - Unit = 4*SZL; (* smallest possible heap block *) - nofLists = 9; (* number of free_lists *) - heapSize0 = 8000*Unit; (* startup heap size *) + SZL = SIZE(LONGINT); + Unit = 4*SZL; (* 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++ - ->blksize + ->block size sentinel = -SZL next *) (* heap chunks *) - nextChnkOff = 0; (* next heap chunk, sorted ascendingly! *) - endOff = SZL; (* end of heap chunk *) - blkOff = 3*SZL; (* first block in a chunk *) + nextChnkOff = LONG(LONG(0)); (* next heap chunk, sorted ascendingly! *) + endOff = LONG(LONG(SZL)); (* end of heap chunk *) + blkOff = LONG(LONG(3*SZL)); (* first block in a chunk *) (* heap blocks *) - tagOff = 0; (* block starts with tag *) - sizeOff = SZL; (* block size in free block relative to block start *) - sntlOff = 2*SZL; (* pointer offset table sentinel in free block relative to block start *) - nextOff = 3*SZL; (* next pointer in free block relative to block start *) + tagOff = LONG(LONG(0)); (* block starts with tag *) + sizeOff = LONG(LONG(SZL)); (* block size in free block relative to block start *) + sntlOff = LONG(LONG(2*SZL)); (* pointer offset table sentinel in free block relative to block start *) + nextOff = LONG(LONG(3*SZL)); (* next pointer in free block relative to block start *) NoPtrSntl = LONG(LONG(-SZL)); - + LongZero = LONG(LONG(0)); TYPE ModuleName = ARRAY ModNameLen OF CHAR; - CmdName = ARRAY CmdNameLen OF CHAR; + CmdName = ARRAY CmdNameLen OF CHAR; Module = POINTER TO ModuleDesc; - Cmd = POINTER TO CmdDesc; - EnumProc = PROCEDURE(P: PROCEDURE(p: SYSTEM.PTR)); + Cmd = POINTER TO CmdDesc; + + EnumProc = PROCEDURE(P: PROCEDURE(p: SYSTEM.PTR)); + ModuleDesc = RECORD - next: Module; - name: ModuleName; - refcnt: LONGINT; - cmds: Cmd; - types: LONGINT; + next: Module; + name: ModuleName; + refcnt: LONGINT; + cmds: Cmd; + types: LONGINT; enumPtrs: EnumProc; reserved1, reserved2: LONGINT END ; @@ -64,16 +56,16 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *) CmdDesc = RECORD next: Cmd; name: CmdName; - cmd: Command + cmd: Command END ; Finalizer = PROCEDURE(obj: SYSTEM.PTR); - FinNode = POINTER TO FinDesc; - FinDesc = RECORD - next: FinNode; - obj: LONGINT; (* weak pointer *) - marked: BOOLEAN; + FinNode = POINTER TO FinDesc; + FinDesc = RECORD + next: FinNode; + obj: LONGINT; (* weak pointer *) + marked: BOOLEAN; finalize: Finalizer; END ; @@ -81,42 +73,66 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *) (* the list of loaded (=initialization started) modules *) modules*: SYSTEM.PTR; - freeList: ARRAY nofLists + 1 OF LONGINT; (* dummy, 16, 32, 48, 64, 80, 96, 112, 128, sentinel *) - bigBlocks, allocated*: LONGINT; - firstTry: BOOLEAN; + freeList: ARRAY nofLists + 1 OF LONGINT; (* dummy, 16, 32, 48, 64, 80, 96, 112, 128, sentinel *) + bigBlocks: LONGINT; + allocated*: LONGINT; + firstTry: BOOLEAN; (* extensible heap *) - heap, (* the sorted list of heap chunks *) - heapend, (* max possible pointer value (used for stack collection) *) + heap: LONGINT; (* the sorted list of heap chunks *) + heapend: LONGINT; (* max possible pointer value (used for stack collection) *) heapsize*: LONGINT; (* the sum of all heap chunk sizes *) (* finalization candidates *) fin: FinNode; (* garbage collector locking *) - gclock*: SHORTINT; + lockdepth: INTEGER; + interrupted: BOOLEAN; + + (* File system file count monitor *) + FileCount*: INTEGER; - PROCEDURE -malloc(size: LONGINT): LONGINT "(LONGINT)malloc(size)"; - PROCEDURE -Lock() "Lock"; - PROCEDURE -Unlock() "Unlock"; - PROCEDURE -Mainfrm(): LONGINT "SYSTEM_mainfrm"; -(* - PROCEDURE TAS*(VAR flag:BOOLEAN): BOOLEAN; (* added for compatibility with ulmSYSTEM module; noch *) - VAR oldflag : BOOLEAN; + PROCEDURE Lock*; BEGIN - oldflag := flag; - flag := TRUE; - RETURN oldflag; - END TAS; -*) + 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): SYSTEM.PTR; VAR m: Module; BEGIN - IF name = "SYSTEM" THEN (* cannot use NEW *) - SYSTEM.NEW(m, SIZE(ModuleDesc)); m.cmds := NIL - ELSE NEW(m) - END ; + (* 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 SYSTEM.NEW. *) + IF name = "Heap" THEN + SYSTEM.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 := SYSTEM.VAL(Module, modules); modules := m; RETURN m @@ -124,7 +140,16 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *) PROCEDURE REGCMD*(m: Module; VAR name: CmdName; cmd: Command); VAR c: Cmd; - BEGIN NEW(c); + 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 SYSTEM.NEW. *) + IF m.name = "Heap" THEN + SYSTEM.NEW(c, SIZE(CmdDesc)) + ELSE + NEW(c) + END; COPY(name, c.name); c.cmd := cmd; c.next := m.cmds; m.cmds := c END REGCMD; @@ -136,13 +161,17 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *) BEGIN INC(m.refcnt) END INCREF; + + PROCEDURE -ExternPlatformOSAllocate "extern LONGINT Platform_OSAllocate(LONGINT size);"; + PROCEDURE -OSAllocate(size: LONGINT): LONGINT "Platform_OSAllocate(size)"; + PROCEDURE NewChunk(blksz: LONGINT): LONGINT; VAR chnk: LONGINT; BEGIN - chnk := malloc(blksz + blkOff); + chnk := OSAllocate(blksz + blkOff); IF chnk # 0 THEN - SYSTEM.PUT(chnk + endOff, chnk + (blkOff + blksz)); - SYSTEM.PUT(chnk + blkOff, chnk + (blkOff + sizeOff)); + SYSTEM.PUT(chnk + endOff, chnk + (blkOff + blksz)); + SYSTEM.PUT(chnk + blkOff, chnk + (blkOff + sizeOff)); SYSTEM.PUT(chnk + (blkOff + sizeOff), blksz); SYSTEM.PUT(chnk + (blkOff + sntlOff), NoPtrSntl); SYSTEM.PUT(chnk + (blkOff + nextOff), bigBlocks); @@ -152,6 +181,13 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *) RETURN chnk END NewChunk; + + (* FetchAddress fetches a pointer from memory and returns it as a LONGINT. It works + correctly regardless of the size of an address. Specifically on 32 bit address + architectures with 64 bit LONGINT, it loads 32 bits and extends it to LONGINT + rather than loading 64 bits. *) + PROCEDURE -FetchAddress(pointer: LONGINT): LONGINT "(LONGINT)(uintptr_t)(*((void**)((uintptr_t)pointer)))"; + PROCEDURE ExtendHeap(blksz: LONGINT); VAR size, chnk, j, next: LONGINT; BEGIN @@ -159,39 +195,48 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *) ELSE size := 10000*Unit (* additional heuristics *) END ; chnk := NewChunk(size); - IF chnk # 0 THEN + IF chnk # 0 THEN (*sorted insertion*) IF chnk < heap THEN SYSTEM.PUT(chnk, heap); heap := chnk ELSE - j := heap; SYSTEM.GET(j, next); - WHILE (next # 0) & (chnk > next) DO j := next; SYSTEM.GET(j, next) END ; + j := heap; next := FetchAddress(j); + WHILE (next # 0) & (chnk > next) DO + j := next; + next := FetchAddress(j) + END; SYSTEM.PUT(chnk, next); SYSTEM.PUT(j, chnk) END ; - IF next = 0 THEN SYSTEM.GET(chnk + endOff, heapend) END + IF next = 0 THEN heapend := FetchAddress(chnk+endOff) END END END ExtendHeap; PROCEDURE ^GC*(markStack: BOOLEAN); PROCEDURE NEWREC*(tag: LONGINT): SYSTEM.PTR; - VAR i, i0, di, blksz, restsize, t, adr, end, next, prev: LONGINT; new: SYSTEM.PTR; + VAR + i, i0, di, blksz, restsize, t, adr, end, next, prev: LONGINT; + new: SYSTEM.PTR; BEGIN Lock(); - SYSTEM.GET(tag, blksz); + blksz := FetchAddress(tag); + + ASSERT((Unit = 16) OR (Unit = 32)); + ASSERT(SIZE(SYSTEM.PTR) <= SIZE(LONGINT)); 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 *) - SYSTEM.GET(adr + nextOff, next); + next := FetchAddress(adr + nextOff); freeList[i] := next; IF i # i0 THEN (* split *) di := i - i0; restsize := di * Unit; end := adr + restsize; SYSTEM.PUT(end + sizeOff, blksz); SYSTEM.PUT(end + sntlOff, NoPtrSntl); - SYSTEM.PUT(end, end + sizeOff); + SYSTEM.PUT(end, end + sizeOff); SYSTEM.PUT(adr + sizeOff, restsize); SYSTEM.PUT(adr + nextOff, freeList[di]); freeList[di] := adr; @@ -219,18 +264,18 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *) Unlock(); RETURN NIL END END ; - SYSTEM.GET(adr+sizeOff, t); + t := FetchAddress(adr+sizeOff); IF t >= blksz THEN EXIT END ; - prev := adr; SYSTEM.GET(adr + nextOff, adr) + prev := adr; adr := FetchAddress(adr + nextOff) END ; restsize := t - blksz; end := adr + restsize; SYSTEM.PUT(end + sizeOff, blksz); SYSTEM.PUT(end + sntlOff, NoPtrSntl); - SYSTEM.PUT(end, end + sizeOff); + SYSTEM.PUT(end, end + sizeOff); IF restsize > nofLists * Unit THEN (*resize*) SYSTEM.PUT(adr + sizeOff, restsize) ELSE (*unlink*) - SYSTEM.GET(adr + nextOff, next); + next := FetchAddress(adr + nextOff); IF prev = 0 THEN bigBlocks := next ELSE SYSTEM.PUT(prev + nextOff, next); END ; @@ -245,16 +290,16 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *) END ; i := adr + 4*SZL; end := adr + blksz; WHILE i < end DO (*deliberately unrolled*) - SYSTEM.PUT(i, LONG(LONG(0))); - SYSTEM.PUT(i + SZL, LONG(LONG(0))); - SYSTEM.PUT(i + 2*SZL, LONG(LONG(0))); - SYSTEM.PUT(i + 3*SZL, LONG(LONG(0))); + SYSTEM.PUT(i, LongZero); + SYSTEM.PUT(i + SZL, LongZero); + SYSTEM.PUT(i + 2*SZL, LongZero); + SYSTEM.PUT(i + 3*SZL, LongZero); INC(i, 4*SZL) END ; - SYSTEM.PUT(adr + nextOff, LONG(LONG(0))); - SYSTEM.PUT(adr, tag); - SYSTEM.PUT(adr + sizeOff, LONG(LONG(0))); - SYSTEM.PUT(adr + sntlOff, LONG(LONG(0))); + SYSTEM.PUT(adr + nextOff, LongZero); + SYSTEM.PUT(adr, tag); + SYSTEM.PUT(adr + sizeOff, LongZero); + SYSTEM.PUT(adr + sntlOff, LongZero); INC(allocated, blksz); Unlock(); RETURN SYSTEM.VAL(SYSTEM.PTR, adr + SZL) @@ -267,9 +312,9 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *) blksz := (size + (4*SZL + Unit - 1)) DIV Unit * Unit; (*size + tag + meta + blksz + sntnl + UnitAlignment*) new := NEWREC(SYSTEM.ADR(blksz)); tag := SYSTEM.VAL(LONGINT, new) + blksz - 3*SZL; - SYSTEM.PUT(tag - SZL, LONG(LONG(0))); (*reserved for meta info*) - SYSTEM.PUT(tag, blksz); - SYSTEM.PUT(tag + SZL, NoPtrSntl); + SYSTEM.PUT(tag - SZL, LongZero); (*reserved for meta info*) + SYSTEM.PUT(tag, blksz); + SYSTEM.PUT(tag + SZL, NoPtrSntl); SYSTEM.PUT(SYSTEM.VAL(LONGINT, new) - SZL, tag); Unlock(); RETURN new @@ -278,28 +323,31 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *) PROCEDURE Mark(q: LONGINT); VAR p, tag, fld, n, offset, tagbits: LONGINT; BEGIN - IF q # 0 THEN SYSTEM.GET(q - SZL, tagbits); - IF ~ODD(tagbits) THEN - SYSTEM.PUT(q - SZL, tagbits + 1); - p := 0; tag := tagbits + SZL; + IF q # 0 THEN + tagbits := FetchAddress(q - SZL); (* Load the tag for the record at q *) + IF ~ODD(tagbits) THEN (* If it has not already been marked *) + SYSTEM.PUT(q - SZL, tagbits + 1); (* Mark it *) + p := 0; + tag := tagbits + SZL; (* Tag addresses first offset *) LOOP - SYSTEM.GET(tag, offset); - IF offset < 0 THEN - SYSTEM.PUT(q - SZL, tag + offset + 1); + SYSTEM.GET(tag, offset); (* Get next ptr field offset *) + IF offset < 0 THEN (* If sentinel. (Value is -8*(#fields+1) *) + SYSTEM.PUT(q - SZL, tag + offset + 1); (* Rotate base ptr into tag *) IF p = 0 THEN EXIT END ; n := q; q := p; - SYSTEM.GET(q - SZL, tag); DEC(tag, 1); + tag := FetchAddress(q - SZL); DEC(tag, 1); SYSTEM.GET(tag, offset); fld := q + offset; - SYSTEM.GET(fld, p); SYSTEM.PUT(fld, n) - ELSE - fld := q + offset; - SYSTEM.GET(fld, n); - IF n # 0 THEN - SYSTEM.GET(n - SZL, tagbits); + p := FetchAddress(fld); SYSTEM.PUT(fld, SYSTEM.VAL(SYSTEM.PTR, n)) + ELSE (* offset references a ptr field *) + fld := q + offset; (* Address the pointer *) + n := FetchAddress(fld); (* Load the pointer *) + IF n # 0 THEN (* If pointer is not NIL *) + tagbits := FetchAddress(n - SZL); (* Consider record pointed to by this field *) IF ~ODD(tagbits) THEN SYSTEM.PUT(n - SZL, tagbits + 1); SYSTEM.PUT(q - SZL, tag + 1); - SYSTEM.PUT(fld, p); p := q; q := n; + SYSTEM.PUT(fld, SYSTEM.VAL(SYSTEM.PTR, p)); + p := q; q := n; tag := tagbits END END @@ -321,42 +369,43 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *) WHILE i < nofLists DO freeList[i] := 0; INC(i) END ; freesize := 0; allocated := 0; chnk := heap; WHILE chnk # 0 DO - adr := chnk + blkOff; SYSTEM.GET(chnk + endOff, end); + adr := chnk + blkOff; + end := FetchAddress(chnk + endOff); WHILE adr < end DO - SYSTEM.GET(adr, tag); + tag := FetchAddress(adr); IF ODD(tag) THEN (*marked*) IF freesize > 0 THEN start := adr - freesize; - SYSTEM.PUT(start, start+SZL); + SYSTEM.PUT(start, start+SZL); SYSTEM.PUT(start+sizeOff, freesize); SYSTEM.PUT(start+sntlOff, NoPtrSntl); i := freesize DIV Unit; freesize := 0; IF i < nofLists THEN SYSTEM.PUT(start + nextOff, freeList[i]); freeList[i] := start - ELSE SYSTEM.PUT(start + nextOff, bigBlocks); bigBlocks := start + ELSE SYSTEM.PUT(start + nextOff, bigBlocks); bigBlocks := start END END ; DEC(tag, 1); SYSTEM.PUT(adr, tag); - SYSTEM.GET(tag, size); + size := FetchAddress(tag); INC(allocated, size); INC(adr, size) ELSE (*unmarked*) - SYSTEM.GET(tag, size); + size := FetchAddress(tag); INC(freesize, size); INC(adr, size) END END ; IF freesize > 0 THEN (*collect last block*) start := adr - freesize; - SYSTEM.PUT(start, start+SZL); + SYSTEM.PUT(start, start+SZL); SYSTEM.PUT(start+sizeOff, freesize); SYSTEM.PUT(start+sntlOff, NoPtrSntl); i := freesize DIV Unit; freesize := 0; IF i < nofLists THEN SYSTEM.PUT(start + nextOff, freeList[i]); freeList[i] := start - ELSE SYSTEM.PUT(start + nextOff, bigBlocks); bigBlocks := start + ELSE SYSTEM.PUT(start + nextOff, bigBlocks); bigBlocks := start END END ; - SYSTEM.GET(chnk, chnk) + chnk := FetchAddress(chnk) END END Scan; @@ -384,14 +433,14 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *) chnk := heap; i := 0; lim := cand[n-1]; WHILE (chnk # 0 ) & (chnk < lim) DO adr := chnk + blkOff; - SYSTEM.GET(chnk + endOff, lim1); + lim1 := FetchAddress(chnk + endOff); IF lim < lim1 THEN lim1 := lim END ; WHILE adr < lim1 DO - SYSTEM.GET(adr, tag); + tag := FetchAddress(adr); IF ODD(tag) THEN (*already marked*) - SYSTEM.GET(tag-1, size); INC(adr, size) + size := FetchAddress(tag-1); INC(adr, size) ELSE - SYSTEM.GET(tag, size); + size := FetchAddress(tag); ptr := adr + SZL; WHILE cand[i] < ptr DO INC(i) END ; IF i = n THEN RETURN END ; @@ -400,15 +449,16 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *) adr := next END END ; - SYSTEM.GET(chnk, chnk) + chnk := FetchAddress(chnk) END END MarkCandidates; PROCEDURE CheckFin; VAR n: FinNode; tag: LONGINT; - BEGIN n := fin; + BEGIN + n := fin; WHILE n # NIL DO - SYSTEM.GET(n.obj - SZL, tag); + tag := FetchAddress(n.obj - SZL); IF ~ODD(tag) THEN n.marked := FALSE; Mark(n.obj) ELSE n.marked := TRUE END ; @@ -425,7 +475,8 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *) n.finalize(SYSTEM.VAL(SYSTEM.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 + ELSE + prev := n; n := n.next END END END Finalize; @@ -439,6 +490,9 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *) END END FINALL; + PROCEDURE -ExternMainStackFrame "extern LONGINT Platform_MainStackFrame;"; + PROCEDURE -PlatformMainStackFrame(): LONGINT "Platform_MainStackFrame"; + PROCEDURE MarkStack(n: LONGINT; VAR cand: ARRAY OF LONGINT); VAR frame: SYSTEM.PTR; @@ -449,9 +503,9 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *) 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 + IF n = 0 THEN nofcand := 0; sp := SYSTEM.ADR(frame); - stack0 := Mainfrm(); + stack0 := PlatformMainStackFrame(); (* check for minimum alignment of pointers *) inc := SYSTEM.ADR(align.p) - SYSTEM.ADR(align); IF sp > stack0 THEN inc := -inc END ; @@ -473,10 +527,10 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *) i0, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, i21, i22, i23: LONGINT; cand: ARRAY 10000 OF LONGINT; BEGIN - IF (gclock = 0) OR (gclock = 1) & ~markStack THEN + IF (lockdepth = 0) OR (lockdepth = 1) & ~markStack THEN Lock(); m := SYSTEM.VAL(Module, modules); - WHILE m # NIL DO + WHILE m # NIL DO IF m.enumPtrs # NIL THEN m.enumPtrs(MarkP) END ; m := m^.next END ; @@ -484,7 +538,7 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *) (* 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; + 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); @@ -503,18 +557,29 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *) END END GC; - PROCEDURE REGFIN*(obj: SYSTEM.PTR; finalize: Finalizer); + PROCEDURE RegisterFinalizer*(obj: SYSTEM.PTR; finalize: Finalizer); VAR f: FinNode; BEGIN NEW(f); - f.obj := SYSTEM.VAL(LONGINT, obj); f.finalize := finalize; f.marked := TRUE; f.next := fin; fin := f - END REGFIN; + f.obj := SYSTEM.VAL(LONGINT, obj); f.finalize := finalize; f.marked := TRUE; + f.next := fin; fin := f; + END RegisterFinalizer; - PROCEDURE InitHeap; (* initialized before body to enable NEW, SYSTEM.NEW *) + +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, SYSTEM.NEW *) BEGIN - heap := NewChunk(heapSize0); - SYSTEM.GET(heap + endOff, heapend); - SYSTEM.PUT(heap, LONG(LONG(0))); - allocated := 0; firstTry := TRUE; freeList[nofLists] := 1; gclock := 0 + heap := NewChunk(heapSize0); + heapend := FetchAddress(heap + endOff); + SYSTEM.PUT(heap, LongZero); + 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 SYSTEM. +END Heap. diff --git a/src/system/Kernel0.Mod b/src/system/Kernel0.Mod deleted file mode 100644 index 6a58650f..00000000 --- a/src/system/Kernel0.Mod +++ /dev/null @@ -1,200 +0,0 @@ -MODULE Kernel0; -(* - J. Templ, 16.4.95 - communication with C-runtime and storage management -*) -(* version for bootstrapping voc *) - - IMPORT SYSTEM, Unix, Args, Strings, version; - - TYPE - RealTime = POINTER TO TimeDesc; - TimeDesc = RECORD - sec, min, hour, mday, mon, year, wday, isdst, zone, gmtoff: LONGINT -(* sec, min, hour, mday, mon, year, wday, isdst, zone, gmtoff: INTEGER*) - END ; - - KeyCmd* = PROCEDURE; - - ObjFinalizer* = PROCEDURE(obj: SYSTEM.PTR); - - - VAR - (* trap handling *) - trapEnv*: Unix.JmpBuf; (* saved stack environment for trap handling *) - - (* oberon heap management *) - nofiles*: LONGINT; - - (* input event handling *) - readSet*, readySet*: Unix.FdSet; - - FKey*: ARRAY 16 OF KeyCmd; - - littleEndian*: BOOLEAN; - - TimeUnit*: LONGINT; (* 1 sec *) - - LIB*, CWD*: ARRAY 256 OF CHAR; - OBERON*: ARRAY 1024 OF CHAR; - MODULES-: ARRAY 1024 OF CHAR; - - prefix*, fullprefix* : ARRAY 256 OF CHAR; - timeStart: LONGINT; (* milliseconds *) - - - PROCEDURE -includesetjmp() - '#include "setjmp.h"'; -(* for localtime *) - PROCEDURE -includetime() - '#include "time.h"'; - - PROCEDURE -Lock*() - "SYSTEM_lock++"; - - PROCEDURE -Unlock*() - "SYSTEM_lock--; if (SYSTEM_interrupted && SYSTEM_lock == 0) __HALT(-9)"; - - PROCEDURE -Exit*(n: LONGINT) - "exit(n)"; - - PROCEDURE -sigsetjmp*(VAR env: Unix.JmpBuf; savemask: LONGINT): LONGINT - "__sigsetjmp(env, savemask)"; - - PROCEDURE -siglongjmp*(VAR env:Unix.JmpBuf; val: LONGINT) - "siglongjmp(env, val)"; - - PROCEDURE -heapsize*(): LONGINT - "SYSTEM_heapsize"; - - PROCEDURE -allocated*(): LONGINT - "SYSTEM_allocated"; - - PROCEDURE -localtime(VAR clock: LONGINT): RealTime - "(Kernel0_RealTime)localtime(clock)"; - - PROCEDURE -malloc*(size: LONGINT): LONGINT - "(LONGINT)malloc(size)"; - - PROCEDURE -free*(adr: LONGINT) - "(void)free(adr)"; - - PROCEDURE -getcwd(VAR cwd: Unix.Name) - "getcwd(cwd, cwd__len)"; - - - PROCEDURE GetClock* (VAR t, d: LONGINT); - VAR tv: Unix.Timeval; tz: Unix.Timezone; time: RealTime; - l : LONGINT; - BEGIN - l := Unix.Gettimeofday(tv, tz); - time := localtime(tv.sec); - t := time.sec + ASH(time.min, 6) + ASH(time.hour, 12); - d := time.mday + ASH(time.mon+1, 5) + ASH(time.year MOD 100, 9); - END GetClock; - - PROCEDURE SetClock* (t, d: LONGINT); - VAR err: ARRAY 25 OF CHAR; - BEGIN err := "not yet implemented"; HALT(99) - END SetClock; - - PROCEDURE Time*(): LONGINT; - VAR timeval: Unix.Timeval; timezone: Unix.Timezone; - l : LONGINT; - BEGIN - l := Unix.Gettimeofday(timeval, timezone); - RETURN (timeval.usec DIV 1000 + timeval.sec * 1000 - timeStart) MOD 7FFFFFFFH - END Time; - -(* - PROCEDURE UserTime*(): LONGINT; - VAR rusage: Unix.Rusage; - BEGIN - Unix.Getrusage(0, S.ADR(rusage)); - RETURN rusage.utime.sec*1000 + rusage.utime.usec DIV 1000 - (* + rusage.stime.sec*1000 + rusage.stime.usec DIV 1000*) - END UserTime; -*) - - PROCEDURE Select*(delay: LONGINT); - VAR rs, ws, xs: Unix.FdSet; n: LONGINT; tv: Unix.Timeval; - BEGIN - rs := readSet; - FOR n := 0 TO 7 DO ws[n] := {}; xs[n] := {}; readySet[n] := {} END; - IF delay < 0 THEN delay := 0 END ; - tv.sec := delay DIV 1000; tv.usec := delay MOD 1000 * 1000; - n := Unix.Select(256, rs, ws, xs, tv); - IF n >= 0 THEN readySet := rs END - END Select; - - PROCEDURE -GC*(markStack: BOOLEAN) - "SYSTEM_GC(markStack)"; - - PROCEDURE -RegisterObject*(obj: SYSTEM.PTR; finalize: ObjFinalizer) - "SYSTEM_REGFIN(obj, finalize)"; - - PROCEDURE -SetHalt*(p: PROCEDURE(n: LONGINT)) - "SYSTEM_Halt = p"; - - PROCEDURE InstallTermHandler*(p: PROCEDURE); - (* not yet supported; no Modules.Free *) - END InstallTermHandler; - - PROCEDURE LargestAvailable*(): LONGINT; - BEGIN - (* dummy proc for System 3 compatibility - no meaningful value except may be the remaining swap space can be returned - in the context of an extensible heap *) - RETURN MAX(LONGINT) - END LargestAvailable; - - PROCEDURE Halt(n: LONGINT); - VAR res: LONGINT; - BEGIN res := Unix.Kill(Unix.Getpid(), 4); - END Halt; - - PROCEDURE EndianTest; - VAR i: LONGINT; dmy: INTEGER; - BEGIN - dmy := 1; i := SYSTEM.ADR(dmy); - SYSTEM.GET(i, littleEndian); (* indirection via i avoids warning on SUN cc -O *) - END EndianTest; - - PROCEDURE -SizeofUnixJmpBuf(): INTEGER - "sizeof(Unix_JmpBuf)"; - - PROCEDURE -SizeofSigJmpBuf(): INTEGER - "sizeof(sigjmp_buf)"; - - PROCEDURE -Error(msg: ARRAY OF CHAR; len: INTEGER) - "write(1/*stdout*/, msg, len); char ch = 0xa; write(1, &ch, 1)"; - - PROCEDURE JmpBufCheck; (* check for inconsistent usage of sigjmp_buf *) - VAR x, y: LONGINT; - BEGIN - x := SizeofUnixJmpBuf(); - y := SizeofSigJmpBuf(); - IF x < y THEN - Error("Kernel.JmpBufCheck: inconsistent usage of sigjmp_buf", 52); - Exit(1); - END - END JmpBufCheck; - -BEGIN - EndianTest(); - SetHalt(Halt); - CWD := ""; OBERON := "."; LIB := ""; - MODULES := ""; (* additional modules path which can be specified on commandline and will be added to the OBERON variable; noch *) - getcwd(CWD); - Args.GetEnv ("MODULES", MODULES); - Args.GetEnv("OBERON", OBERON); - (* always have current directory in module search path, noch *) - Strings.Append(":.:", OBERON); - Strings.Append(MODULES, OBERON); - Strings.Append(":", OBERON); - Strings.Append(version.prefix, OBERON); - Strings.Append("/lib/voc/sym:", OBERON); - Args.GetEnv("OBERON_LIB", LIB); - TimeUnit := 1000; timeStart := 0; timeStart := Time(); - JmpBufCheck() -END Kernel0. diff --git a/src/system/Oberon.Mod b/src/system/Oberon.Mod index 1a0c8c69..d0125cdc 100644 --- a/src/system/Oberon.Mod +++ b/src/system/Oberon.Mod @@ -2,9 +2,9 @@ MODULE Oberon; (* this version should not have dependency on graphics -- noch *) - IMPORT Kernel, Texts, Args, Out := Console; - TYPE + IMPORT Platform, Texts, Args, Console; + TYPE ParList* = POINTER TO ParRec; ParRec* = RECORD @@ -18,23 +18,26 @@ MODULE Oberon; Log*: Texts.Text; Par*: ParList; (*actual parameters*) - W : Texts.Writer; - OptionChar*: CHAR; + R: Texts.Reader; + W: Texts.Writer; + OptionChar*: CHAR; + (*clocks*) PROCEDURE GetClock* (VAR t, d: LONGINT); - BEGIN Kernel.GetClock(t, d) + BEGIN Platform.GetClock(t, d) END GetClock; PROCEDURE Time* (): LONGINT; - BEGIN - RETURN Kernel.Time() + BEGIN + RETURN Platform.Time() END Time; PROCEDURE PopulateParams; - VAR W : Texts.Writer; - i : INTEGER; - str : ARRAY 32 OF CHAR; + VAR + W: Texts.Writer; + i: INTEGER; + str: ARRAY 32 OF CHAR; BEGIN i := 1; (* skip program name *) @@ -52,47 +55,23 @@ MODULE Oberon; Texts.Append (Par^.text, W.buf); END PopulateParams; -(* - PROCEDURE DumpLog*; - VAR R : Texts.Reader; - ch : CHAR; - BEGIN - Texts.OpenReader(R, Log, 0); - REPEAT - Texts.Read(R, ch); - Out.Char(ch); - UNTIL R.eot; - END DumpLog; -*) + PROCEDURE GetSelection*(VAR text: Texts.Text; VAR beg, end, time: LONGINT); + BEGIN text := NIL; beg := 0; end := 0; time := 0; + END GetSelection; -PROCEDURE TextToString(VAR T : Texts.Text; VAR string : ARRAY OF CHAR); - VAR R : Texts.Reader; - ch : CHAR; - i : LONGINT; +(* --- Notifier for echoing all text appended to the log onto the console. --- *) + +PROCEDURE LogNotifier(Log: Texts.Text; op: INTEGER; beg, end: LONGINT); + VAR ch: CHAR; BEGIN - COPY("", string); - Texts.OpenReader(R, T, 0); - i := 0; - WHILE Texts.Pos(R) < T.len DO - Texts.Read(R, ch); - string[i] := ch; - INC(i); - END; - (*string[i] := 0X;*) -END TextToString; - -PROCEDURE DumpLog*; -VAR s : POINTER TO ARRAY OF CHAR; -BEGIN - NEW(s, Log.len + 1); - COPY("", s^); - TextToString(Log, s^); - Out.String(s^); Out.Ln; - - NEW(Log); - Texts.Open(Log, ""); -END DumpLog; + Texts.OpenReader(R, Log, beg); + WHILE ~R.eot & (beg < end) DO + Texts.Read(R, ch); + IF ch = 0DX THEN Console.Ln ELSE Console.Char(ch) END; + INC(beg) + END +END LogNotifier; BEGIN NEW(Par); @@ -103,4 +82,5 @@ BEGIN PopulateParams; NEW(Log); Texts.Open(Log, ""); + Log.notify := LogNotifier; END Oberon. diff --git a/src/system/Platformunix.Mod b/src/system/Platformunix.Mod index dbaae75f..fbb015e8 100644 --- a/src/system/Platformunix.Mod +++ b/src/system/Platformunix.Mod @@ -1,519 +1,551 @@ -MODULE Unix; (* Josef Templ, 5.3.90 Linux system calls *) -(* ported to gnu x86_64 and added system(), sleep() functions, noch *) -(* Module Unix provides a system call interface to Linux. - Naming conventions: - Procedure and Type-names always start with a capital letter. - error numbers as defined in Unix - other constants start with lower case letters *) - +MODULE Platform; IMPORT SYSTEM; CONST - -(* various important constants *) - - stdin* = 0; stdout* =1; stderr* = 2; - - LOCKEX* = 2; LOCKUN* = 8; (* /usr/include/file.h *) - AFINET* = 2; (* /usr/include/sys/socket.h *) - PFINET* = AFINET; (* /usr/include/linux/socket.h *) - SOCKSTREAM* = 1; (* /usr/include/linux/socket.h *) - FIONREAD* = 541BH; (* in /usr/include/asm/termios.h *) - SETFL* = 4; (* set file descriptor flags; in asm/fcntl.h *) - TCP* = 0; - -(* flag sets, cf. /usr/include/asm/fcntl.h *) - rdonly* = {}; wronly* = {0}; rdwr* = {1}; creat* = {6}; excl* = {7}; trunc* = {9}; append* = {10}; ndelay = {11}; - -(* error numbers *) - - EPERM* = 1; (* Not owner *) - ENOENT* = 2; (* No such file or directory *) - ESRCH* = 3; (* No such process *) - EINTR* = 4; (* Interrupted system call *) - EIO* = 5; (* I/O error *) - ENXIO* = 6; (* No such device or address *) - E2BIG* = 7; (* Arg list too long *) - ENOEXEC* = 8; (* Exec format error *) - EBADF* = 9; (* Bad file number *) - ECHILD* = 10; (* No children *) - EAGAIN* = 11; (* No more processes *) - ENOMEM* = 12; (* Not enough core *) - EACCES* = 13; (* Permission denied *) - EFAULT* = 14; (* Bad address *) - ENOTBLK* = 15; (* Block device required *) - EBUSY* = 16; (* Mount device busy *) - EEXIST* = 17; (* File exists *) - EXDEV* = 18; (* Cross-device link *) - ENODEV* = 19; (* No such device *) - ENOTDIR* = 20; (* Not a directory*) - EISDIR* = 21; (* Is a directory *) - EINVAL* = 22; (* Invalid argument *) - ENFILE* = 23; (* File table overflow *) - EMFILE* = 24; (* Too many open files *) - ENOTTY* = 25; (* Not a typewriter *) - ETXTBSY* = 26; (* Text file busy *) - EFBIG* = 27; (* File too large *) - ENOSPC* = 28; (* No space left on device *) - ESPIPE* = 29; (* Illegal seek *) - EROFS* = 30; (* Read-only file system *) - EMLINK* = 31; (* Too many links *) - EPIPE* = 32; (* Broken pipe *) - EDOM* = 33; (* Argument too large *) - ERANGE* = 34; (* Result too large *) - EDEADLK* = 35; (* Resource deadlock would occur *) - ENAMETOOLONG* = 36; (* File name too long *) - ENOLCK* = 37; (* No record locks available *) - ENOSYS* = 38; (* Function not implemented *) - ENOTEMPTY* = 39; (* Directory not empty *) - ELOOP* = 40; (* Too many symbolic links encountered *) - EWOULDBLOCK* = EAGAIN; (* Operation would block *) - ENOMSG* = 42; (* No message of desired type *) - EIDRM* = 43; (* Identifier removed *) - ECHRNG* = 44; (* Channel number out of range *) - EL2NSYNC* = 45; (* Level 2 not synchronized *) - EL3HLT* = 46; (* Level 3 halted *) - EL3RST* = 47; (* Level 3 reset *) - ELNRNG* = 48; (* Link number out of range *) - EUNATCH* = 49; (* Protocol driver not attached *) - ENOCSI* = 50; (* No CSI structure available *) - EL2HLT* = 51; (* Level 2 halted *) - EBADE* = 52; (* Invalid exchange *) - EBADR* = 53; (* Invalid request descriptor *) - EXFULL* = 54; (* Exchange full *) - ENOANO* = 55; (* No anode *) - EBADRQC* = 56; (* Invalid request code *) - EBADSLT* = 57; (* Invalid slot *) - EDEADLOCK* = 58; (* File locking deadlock error *) - EBFONT* = 59; (* Bad font file format *) - ENOSTR* = 60; (* Device not a stream *) - ENODATA* = 61; (* No data available *) - ETIME* = 62; (* Timer expired *) - ENOSR* = 63; (* Out of streams resources *) - ENONET* = 64; (* Machine is not on the network *) - ENOPKG* = 65; (* Package not installed *) - EREMOTE* = 66; (* Object is remote *) - ENOLINK* = 67; (* Link has been severed *) - EADV* = 68; (* Advertise error *) - ESRMNT* = 69; (* Srmount error *) - ECOMM* = 70; (* Communication error on send *) - EPROTO* = 71; (* Protocol error *) - EMULTIHOP* = 72; (* Multihop attempted *) - EDOTDOT* = 73; (* RFS specific error *) - EBADMSG* = 74; (* Not a data message *) - EOVERFLOW* = 75; (* Value too large for defined data type *) - ENOTUNIQ* = 76; (* Name not unique on network *) - EBADFD* = 77; (* File descriptor in bad state *) - EREMCHG* = 78; (* Remote address changed *) - ELIBACC* = 79; (* Can not access a needed shared library *) - ELIBBAD* = 80; (* Accessing a corrupted shared library *) - ELIBSCN* = 81; (* .lib section in a.out corrupted *) - ELIBMAX* = 82; (* Attempting to link in too many shared libraries *) - ELIBEXEC* = 83; (* Cannot exec a shared library directly *) - EILSEQ* = 84; (* Illegal byte sequence *) - ERESTART* = 85; (* Interrupted system call should be restarted *) - ESTRPIPE* = 86; (* Streams pipe error *) - EUSERS* = 87; (* Too many users *) - ENOTSOCK* = 88; (* Socket operation on non-socket *) - EDESTADDRREQ* = 89; (* Destination address required *) - EMSGSIZE* = 90; (* Message too long *) - EPROTOTYPE* = 91; (* Protocol wrong type for socket *) - ENOPROTOOPT* = 92; (* Protocol not available *) - EPROTONOSUPPORT* = 93; (* Protocol not supported *) - ESOCKTNOSUPPORT* = 94; (* Socket type not supported *) - EOPNOTSUPP* = 95; (* Operation not supported on transport endpoint *) - EPFNOSUPPORT* = 96; (* Protocol family not supported *) - EAFNOSUPPORT* = 97; (* Address family not supported by protocol *) - EADDRINUSE* = 98; (* Address already in use *) - EADDRNOTAVAIL* = 99; (* Cannot assign requested address *) - ENETDOWN* = 100; (* Network is down *) - ENETUNREACH* = 101; (* Network is unreachable *) - ENETRESET* = 102; (* Network dropped connection because of reset *) - ECONNABORTED* = 103; (* Software caused connection abort *) - ECONNRESET* = 104; (* Connection reset by peer *) - ENOBUFS* = 105; (* No buffer space available *) - EISCONN* = 106; (* Transport endpoint is already connected *) - ENOTCONN* = 107; (* Transport endpoint is not connected *) - ESHUTDOWN* = 108; (* Cannot send after transport endpoint shutdown *) - ETOOMANYREFS* = 109; (* Too many references: cannot splice *) - ETIMEDOUT* = 110; (* Connection timed out *) - ECONNREFUSED* = 111; (* Connection refused *) - EHOSTDOWN* = 112; (* Host is down *) - EHOSTUNREACH* = 113; (* No route to host *) - EALREADY* = 114; (* Operation already in progress *) - EINPROGRESS* = 115; (* Operation now in progress *) - ESTALE* = 116; (* Stale NFS file handle *) - EUCLEAN* = 117; (* Structure needs cleaning *) - ENOTNAM* = 118; (* Not a XENIX named type file *) - ENAVAIL* = 119; (* No XENIX semaphores available *) - EISNAM* = 120; (* Is a named type file *) - EREMOTEIO* = 121; (* Remote I/O error *) - EDQUOT* = 122; (* Quota exceeded *) - -CONST sigsetarrlength = 1024 / 8 * SIZE(LONGINT); - + StdIn- = 0; + StdOut- = 1; + StdErr- = 2; TYPE - (* cpp /usr/include/setjmp.h - struct __jmp_buf_tag - { - __jmp_buf __jmpbuf; - int __mask_was_saved; - __sigset_t __saved_mask; - }; + HaltProcedure = PROCEDURE(n: LONGINT); + SignalHandler = PROCEDURE(signal: INTEGER); - typedef struct __jmp_buf_tag jmp_buf[1]; + ErrorCode* = INTEGER; + FileHandle* = LONGINT; - __sigset_t is 128 byte long in glibc on arm, x86, x86_64 - __jmp_buf is 24 bytes long in glibc on x86 - 256 bytes long in glibc on armv6 - 64 bytes long in glibc on x86_64 - - *) - JmpBuf* = RECORD - jmpbuf: ARRAY 8 OF LONGINT; (* 8 * 8 = 64 *) - maskWasSaved*: INTEGER; - savedMask*: ARRAY 16 OF LONGINT; (* 16 * 8 = 128 *) - END ; - - Status* = RECORD (* struct stat *) - dev* : LONGINT; (* dev_t 8 *) - ino* : LONGINT; (* ino 8 *) - nlink* : LONGINT; - mode* : INTEGER; - uid*, gid*: INTEGER; - pad0* : INTEGER; - rdev* : LONGINT; - size* : LONGINT; - blksize* : LONGINT; - blocks* : LONGINT; - atime* : LONGINT; - atimences* : LONGINT; - mtime* : LONGINT; - mtimensec* : LONGINT; - ctime* : LONGINT; - ctimensec* : LONGINT; - unused0*, unused1*, unused2*: LONGINT; - END ; - -(* from /usr/include/bits/time.h - -struct timeval - { - __time_t tv_sec; /* Seconds. */ //__time_t 8 - __suseconds_t tv_usec; /* Microseconds. */ __suseconds_t 8 - }; - - -*) - - Timeval* = RECORD - sec*, usec*: LONGINT - END ; - - -(* -from man gettimeofday - - struct timezone { - int tz_minuteswest; /* minutes west of Greenwich */ int 4 - int tz_dsttime; /* type of DST correction */ int 4 - }; -*) - - - Timezone* = RECORD - (*minuteswest*, dsttime*: LONGINT*) - minuteswest*, dsttime*: INTEGER - END ; - - Itimerval* = RECORD - interval*, value*: Timeval - END ; - - FdSet* = ARRAY 8 OF SET; - - SigCtxPtr* = POINTER TO SigContext; - SigContext* = RECORD - END ; - - SignalHandler* = PROCEDURE (sig, code: LONGINT; scp: SigCtxPtr); - - Dirent* = RECORD - ino, off: LONGINT; - reclen: INTEGER; - name: ARRAY 256 OF CHAR; - END ; - - Rusage* = RECORD - utime*, stime*: Timeval; - maxrss*, ixrss*, idrss*, isrss*, - minflt*, majflt*, nswap*, inblock*, - oublock*, msgsnd*, msgrcv*, nsignals*, - nvcsw*, nivcsw*: LONGINT - END ; - - Iovec* = RECORD - base*, len*: LONGINT - END ; - - SocketPair* = ARRAY 2 OF LONGINT; - - Pollfd* = RECORD - fd*: LONGINT; - events*, revents*: INTEGER - END ; - - Sockaddr* = RECORD - family0*, family1*: SHORTINT; - pad0, pad1: SHORTINT; - pad2 : INTEGER; - (*port*: INTEGER; - internetAddr*: LONGINT;*) - pad*: ARRAY 14 OF CHAR; - END ; - - HostEntry* = POINTER [1] TO Hostent; - Hostent* = RECORD - name*, aliases*: LONGINT; - addrtype*, length*: INTEGER; - addrlist*: LONGINT; (*POINTER TO POINTER TO LONGINT, network byte order*) + 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; - Name* = ARRAY OF CHAR; + 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 LONGINT; - PROCEDURE -includeStat() - "#include "; - PROCEDURE -includeErrno() - "#include "; +VAR + LittleEndian-: BOOLEAN; + MainStackFrame-: LONGINT; + HaltCode-: LONGINT; + PID-: INTEGER; (* Note: Must be updated by Fork implementation *) + CWD-: ARRAY 256 OF CHAR; + ArgCount-: INTEGER; - (* for read(), write() and sleep() *) - PROCEDURE -includeUnistd() - "#include "; + ArgVector-: LONGINT; + HaltHandler: HaltProcedure; + TimeStart: LONGINT; - (* for system() *) - PROCEDURE -includeStdlib() - "#include "; + SeekSet-: INTEGER; + SeekCur-: INTEGER; + SeekEnd-: INTEGER; - (* for nanosleep() *) - PROCEDURE -includeTime() - "#include "; + nl-: ARRAY 3 OF CHAR; (* Platform specific newline representation *) - (* for select() *) - PROCEDURE -includeSelect() - "#include "; - PROCEDURE -err(): INTEGER - "errno"; - PROCEDURE errno*(): INTEGER; - BEGIN - RETURN err() - END errno; +(* Unix headers to be included *) - PROCEDURE -Exit*(n: INTEGER) - "exit(n)"; +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 '; - PROCEDURE -Fork*(): INTEGER - "fork()"; - PROCEDURE -Wait*(VAR status: INTEGER): INTEGER - "wait(status)"; - PROCEDURE -Select*(width: INTEGER; VAR readfds, writefds, exceptfds: FdSet; VAR timeout: Timeval): INTEGER - "select(width, readfds, writefds, exceptfds, timeout)"; - PROCEDURE -Gettimeofday* (VAR tv: Timeval; VAR tz: Timezone) : INTEGER - "gettimeofday(tv, tz)"; +(* Error code tests *) - PROCEDURE -Read* (fd: INTEGER; buf, nbyte: LONGINT): LONGINT - "read(fd, buf, nbyte)"; +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 -ReadBlk* (fd: INTEGER; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT - "read(fd, buf, buf__len)"; - PROCEDURE -Write* (fd: INTEGER; buf, nbyte: LONGINT): LONGINT - "write(fd, buf, nbyte)"; - PROCEDURE -WriteBlk* (fd: INTEGER; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT - "write(fd, buf, buf__len)"; - PROCEDURE -Dup*(fd: INTEGER): INTEGER - "dup(fd)"; +PROCEDURE TooManyFiles*(e: ErrorCode): BOOLEAN; +BEGIN RETURN (e = EMFILE()) OR (e = ENFILE()) END TooManyFiles; - PROCEDURE -Dup2*(fd1, fd2: INTEGER): INTEGER - "dup(fd1, fd2)"; +PROCEDURE NoSuchDirectory*(e: ErrorCode): BOOLEAN; +BEGIN RETURN e = ENOENT() END NoSuchDirectory; - PROCEDURE -Pipe*(fds : LONGINT): INTEGER - "pipe(fds)"; +PROCEDURE DifferentFilesystems*(e: ErrorCode): BOOLEAN; +BEGIN RETURN e = EXDEV() END DifferentFilesystems; - PROCEDURE -Getpid*(): INTEGER - "getpid()"; +PROCEDURE Inaccessible*(e: ErrorCode): BOOLEAN; +BEGIN RETURN (e = EACCES()) OR (e = EROFS()) OR (e = EAGAIN()) END Inaccessible; - PROCEDURE -Getuid*(): INTEGER - "getuid()"; +PROCEDURE Absent*(e: ErrorCode): BOOLEAN; +BEGIN RETURN (e = ENOENT()) END Absent; - PROCEDURE -Geteuid*(): INTEGER - "geteuid()"; +PROCEDURE TimedOut*(e: ErrorCode): BOOLEAN; +BEGIN RETURN (e = ETIMEDOUT()) END TimedOut; - PROCEDURE -Getgid*(): INTEGER - "getgid()"; +PROCEDURE ConnectionFailed*(e: ErrorCode): BOOLEAN; +BEGIN RETURN (e = ECONNREFUSED()) OR (e = ECONNABORTED()) + OR (e = ENETUNREACH()) OR (e = EHOSTUNREACH()) END ConnectionFailed; - PROCEDURE -Getegid*(): INTEGER - "getegid()"; - PROCEDURE -Unlink*(name: Name): INTEGER - "unlink(name)"; - PROCEDURE -Open*(name: Name; flag: INTEGER; mode: LONGINT): INTEGER - "open(name, flag, mode)"; - PROCEDURE -Close*(fd: INTEGER): INTEGER - "close(fd)"; +(* OS memory allocaton *) - PROCEDURE -stat(name: Name; VAR statbuf: Status): INTEGER - "stat((const char*)name, (struct stat*)statbuf)"; +PROCEDURE -allocate(size: LONGINT): LONGINT "(LONGINT)(uintptr_t)((void*)malloc((size_t)size))"; +PROCEDURE OSAllocate*(size: LONGINT): LONGINT; BEGIN RETURN allocate(size) END OSAllocate; - PROCEDURE Stat*(name: Name; VAR statbuf: Status): INTEGER; - VAR res: INTEGER; - BEGIN - res := stat(name, statbuf); - (* make the first 4 bytes as unique as possible (used in module Files for caching!) *) - (* don't understand this - INC(statbuf.dev, statbuf.devX); - INC(statbuf.rdev, statbuf.rdevX); *) - RETURN res; - END Stat; +PROCEDURE -free(address: LONGINT) "free((void*)(uintptr_t)address)"; +PROCEDURE OSFree*(address: LONGINT); BEGIN free(address) END OSFree; - PROCEDURE -fstat(fd: INTEGER; VAR statbuf: Status): INTEGER - "fstat(fd, (struct stat*)statbuf)"; - PROCEDURE Fstat*(fd: INTEGER; VAR statbuf: Status): INTEGER; - VAR res: INTEGER; - BEGIN - res := fstat(fd, statbuf); - (* make the first 4 bytes as unique as possible (used in module Files for caching!) *) - (*INC(statbuf.dev, statbuf.devX); - INC(statbuf.rdev, statbuf.rdevX); *) - RETURN res; - END Fstat; - PROCEDURE -Fchmod*(fd, mode: INTEGER): INTEGER - "fchmod(fd, mode)"; - PROCEDURE -Chmod*(path: Name; mode: INTEGER): INTEGER - "chmod(path, mode)"; +(* Program startup *) - PROCEDURE -Lseek*(fd: INTEGER; offset: LONGINT; origin: INTEGER): LONGINT - "lseek(fd, offset, origin)"; +PROCEDURE -ExternInitHeap "extern void Heap_InitHeap();"; +PROCEDURE -HeapInitHeap() "Heap_InitHeap()"; - PROCEDURE -Fsync*(fd: INTEGER): INTEGER - "fsync(fd)"; +PROCEDURE Init*(argc: INTEGER; argvadr: LONGINT); +VAR av: ArgVecPtr; +BEGIN + MainStackFrame := argvadr; + ArgCount := argc; + av := SYSTEM.VAL(ArgVecPtr, argvadr); + ArgVector := av[0]; + HaltCode := -128; - PROCEDURE -Fcntl*(fd: INTEGER; cmd: INTEGER; arg: LONGINT ): INTEGER - "fcntl(fd, cmd, arg)"; + (* 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; - PROCEDURE -Flock*(fd, operation: INTEGER): INTEGER - "flock(fd, operation)"; - PROCEDURE -Ftruncate*(fd: INTEGER; length: LONGINT): INTEGER - "ftruncate(fd, length)"; - PROCEDURE -Readblk*(fd: INTEGER; VAR buf: ARRAY OF SYSTEM.BYTE; len: LONGINT): LONGINT - "read(fd, buf, len)"; - PROCEDURE -Rename*(old, new: Name): INTEGER - "rename(old, new)"; +(* Program arguments and environment access *) - PROCEDURE -Chdir*(path: Name): INTEGER - "chdir(path)"; +PROCEDURE -getenv(var: ARRAY OF CHAR): EnvPtr "(Platform_EnvPtr)getenv((char*)var)"; - PROCEDURE -Ioctl*(fd: INTEGER; request, arg: LONGINT): INTEGER - "ioctl(fd, request, arg)"; +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 -Kill*(pid, sig: INTEGER): INTEGER - "kill(pid, sig)"; +PROCEDURE GetEnv*(var: ARRAY OF CHAR; VAR val: ARRAY OF CHAR); +BEGIN + IF ~ getEnv(var, val) THEN val[0] := 0X END; +END GetEnv; - PROCEDURE -Sigsetmask*(mask: INTEGER): INTEGER - "sigsetmask(mask)"; +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 -Sleep*(ms : INTEGER): INTEGER - "(INTEGER)sleep(ms)"; +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 -Nanosleep*(VAR req : Timeval; VAR rem : Timeval): INTEGER - "(INTEGER)nanosleep(req, rem)"; +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; - (* TCP/IP networking *) - PROCEDURE -Gethostbyname*(name: Name): HostEntry - "(Unix_HostEntry)gethostbyname(name)"; - PROCEDURE -Gethostname*(VAR name: Name): INTEGER - "gethostname(name, name__len)"; - PROCEDURE -Socket*(af, type, protocol: INTEGER): INTEGER - "socket(af, type, protocol)"; - PROCEDURE -Connect*(socket: INTEGER; name: Sockaddr; namelen: INTEGER): INTEGER - "connect(socket, &(name), namelen)"; +(* Signals and traps *) - PROCEDURE -Getsockname*(socket: INTEGER; VAR name: Sockaddr; VAR namelen: INTEGER): INTEGER - "getsockname(socket, name, namelen)"; +PROCEDURE -sethandler(s: INTEGER; h: SignalHandler) "SystemSetHandler(s, (uintptr_t)h)"; - PROCEDURE -Bind*(socket: INTEGER; name: Sockaddr; namelen: INTEGER): INTEGER - "bind(socket, &(name), namelen)"; +PROCEDURE SetInterruptHandler*(handler: SignalHandler); +BEGIN sethandler(2, handler); END SetInterruptHandler; - PROCEDURE -Listen*(socket, backlog: INTEGER): INTEGER - "listen(socket, backlog)"; +PROCEDURE SetQuitHandler*(handler: SignalHandler); +BEGIN sethandler(3, handler); END SetQuitHandler; - PROCEDURE -Accept*(socket: INTEGER; VAR addr: Sockaddr; VAR addrlen: INTEGER): LONGINT - "accept(socket, addr, addrlen)"; +PROCEDURE SetBadInstructionHandler*(handler: SignalHandler); +BEGIN sethandler(4, handler); END SetBadInstructionHandler; - PROCEDURE -Recv*(socket: INTEGER; bufadr, buflen: LONGINT; flags: INTEGER): LONGINT - "recv(socket, bufadr, buflen, flags)"; - PROCEDURE -Send*(socket: INTEGER; bufadr, buflen: LONGINT; flags: INTEGER): LONGINT - "send(socket, bufadr, buflen, flags)"; - PROCEDURE -sys(str: ARRAY OF CHAR): INTEGER (* need this to call external tools like gcc or gas; noch *) - "system(str)"; - PROCEDURE system*(cmd : ARRAY OF CHAR); - VAR r : INTEGER; - BEGIN - r := sys(cmd); - END system; +(* Time of day *) - PROCEDURE System*(cmd : ARRAY OF CHAR): INTEGER; - VAR r : INTEGER; - BEGIN - r := sys(cmd); - RETURN r - END System; +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 -SizeofUnixStat(): INTEGER - "sizeof(Unix_Status)"; +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 -SizeofStat(): INTEGER - "sizeof(struct stat)"; +PROCEDURE GetClock*(VAR t, d: LONGINT); +BEGIN + gettimeval; sectotm(tvsec()); + YMDHMStoClock(tmyear(), tmmon(), tmmday(), tmhour(), tmmin(), tmsec(), t, d); +END GetClock; - PROCEDURE -Error(msg: ARRAY OF CHAR; len: INTEGER) - "write(1/*stdout*/, msg, len); char ch = 0xa; write(1, &ch, 1)"; +PROCEDURE GetTimeOfDay*(VAR sec, usec: LONGINT); +BEGIN + gettimeval; sec := tvsec(); usec := tvusec(); +END GetTimeOfDay; - PROCEDURE StatCheck; - VAR x, y: LONGINT; - BEGIN - x := SizeofUnixStat(); - y := SizeofStat(); - IF x # y THEN - Error("Unix.StatCheck: inconsistent usage of struct stat", 49); - Exit(1); - END - END StatCheck; +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 "(LONGINT)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: LONGINT; l: LONGINT): LONGINT +"read(fd, (void*)(uintptr_t)(p), l)"; + +PROCEDURE Read*(h: FileHandle; p: LONGINT; 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: LONGINT; l: LONGINT): LONGINT +"write(fd, (void*)(uintptr_t)(p), l)"; + +PROCEDURE Write*(h: FileHandle; p: LONGINT; l: LONGINT): ErrorCode; + VAR written: LONGINT; +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) "getcwd((char*)cwd, cwd__len)"; + +PROCEDURE Chdir*(VAR n: ARRAY OF CHAR): ErrorCode; + VAR r: INTEGER; +BEGIN + r := chdir(n); getcwd(CWD); + IF r < 0 THEN RETURN err() ELSE RETURN 0 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(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("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); +VAR e: ErrorCode; +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); +VAR e: ErrorCode; +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; - StatCheck(); + HaltCode := -128; + HaltHandler := NIL; + TimeStart := Time(); + CWD := ""; getcwd(CWD); + PID := getpid(); + + SeekSet := seekset(); + SeekCur := seekcur(); + SeekEnd := seekend(); + + nl[0] := 0AX; (* LF *) + nl[1] := 0X; +END Platform. -END Unix. diff --git a/src/system/Platformwindows.Mod b/src/system/Platformwindows.Mod new file mode 100755 index 00000000..c9b67b7c --- /dev/null +++ b/src/system/Platformwindows.Mod @@ -0,0 +1,611 @@ +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 LONGINT; + + +VAR + LittleEndian-: BOOLEAN; + MainStackFrame-: LONGINT; + HaltCode-: LONGINT; + PID-: INTEGER; (* Note: Must be updated by Fork implementation *) + CWD-: ARRAY 4096 OF CHAR; + ArgCount-: INTEGER; + + ArgVector-: LONGINT; + 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 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; + + + +(* OS memory allocaton *) + +PROCEDURE -allocate(size: LONGINT): LONGINT "(LONGINT)(uintptr_t)((void*)HeapAlloc(GetProcessHeap(), 0, (size_t)size))"; +PROCEDURE OSAllocate*(size: LONGINT): LONGINT; BEGIN RETURN allocate(size) END OSAllocate; + +PROCEDURE -free(address: LONGINT) "HeapFree(GetProcessHeap(), 0, (void*)(uintptr_t)address)"; +PROCEDURE OSFree*(address: LONGINT); BEGIN free(address) END OSFree; + + + + +(* Program startup *) + +PROCEDURE -ExternInitHeap "extern void Heap_InitHeap();"; +PROCEDURE -HeapInitHeap() "Heap_InitHeap()"; + +PROCEDURE Init*(argc: INTEGER; argvadr: LONGINT); +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((uintptr_t)h)"; +PROCEDURE -SetQuitHandler* (h: SignalHandler) "SystemSetQuitHandler((uintptr_t)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 GetTimeOfDay*(VAR sec, usec: LONGINT); +BEGIN + getLocalTime; sec := stsec(); usec := LONG(stmsec()) * 1000; +END GetTimeOfDay; + +PROCEDURE -GetTickCount(): LONGINT "(LONGINT)(uint32_t)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; + + + + +(* 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)(uintptr_t)INVALID_HANDLE_VALUE)"; + +PROCEDURE -openrw (n: ARRAY OF CHAR): LONGINT +"(LONGINT)(uintptr_t)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)(uintptr_t)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)(uintptr_t)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)(uintptr_t)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)(uintptr_t)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)(uintptr_t)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: LONGINT; l: LONGINT; VAR n: LONGINT): INTEGER +"(INTEGER)ReadFile ((HANDLE)(uintptr_t)fd, (void*)(uintptr_t)(p), (DWORD)l, (DWORD*)n, 0)"; + +PROCEDURE Read*(h: FileHandle; p: LONGINT; l: LONGINT; VAR n: LONGINT): ErrorCode; +VAR result: INTEGER; +BEGIN + n := 0; (* Clear n because readfile takes a LONGINT but only updates the bottom 32 bits *) + result := readfile(h, p, l, n); + IF result = 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; +VAR result: INTEGER; +BEGIN + n := 0; (* Clear n because readfile takes a LONGINT but only updates the bottom 32 bits *) + result := readfile(h, SYSTEM.ADR(b), LEN(b), n); + IF result = 0 THEN n := 0; RETURN err() ELSE RETURN 0 END +END ReadBuf; + + + +PROCEDURE -writefile(fd: LONGINT; p: LONGINT; l: LONGINT): INTEGER +"(INTEGER)WriteFile((HANDLE)(uintptr_t)fd, (void*)(uintptr_t)(p), (DWORD)l, 0,0)"; + +PROCEDURE Write*(h: FileHandle; p: LONGINT; 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)(uintptr_t)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)(uintptr_t)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)(uintptr_t)h)"; +PROCEDURE -getFilePos(h: FileHandle; VAR r: LONGINT; VAR rc: INTEGER) +"LARGE_INTEGER liz = {0}; *rc = (INTEGER)SetFilePointerEx((HANDLE)(uintptr_t)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)(uintptr_t)Platform_StdOut, s, s__len-1, 0,0)'; +PROCEDURE -errc (c: CHAR) 'WriteFile((HANDLE)(uintptr_t)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.") + |-15: errstring("Type descriptor size mismatch.") + |-20: errstring("Too many, or negative number of, elements in dynamic array.") + ELSE + END +END DisplayHaltCode; + +PROCEDURE Halt*(code: LONGINT); +VAR e: ErrorCode; +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); +VAR e: ErrorCode; +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 "(uintptr_t)GetStdHandle(STD_INPUT_HANDLE)"; +PROCEDURE -getstdouthandle(): FileHandle "(uintptr_t)GetStdHandle(STD_OUTPUT_HANDLE)"; +PROCEDURE -getstderrhandle(): FileHandle "(uintptr_t)GetStdHandle(STD_ERROR_HANDLE)"; +PROCEDURE -getpid(): INTEGER "(INTEGER)GetCurrentProcessId()"; + +BEGIN + TestLittleEndian; + + HaltCode := -128; + HaltHandler := NIL; + 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/system/SYSTEM.c b/src/system/SYSTEM.c index 3d875068..0fcc5ee2 100644 --- a/src/system/SYSTEM.c +++ b/src/system/SYSTEM.c @@ -1,205 +1,207 @@ -/* -* The body prefix file of the voc(jet backend) runtime system, Version 1.0 +/* +* The body prefix file of the voc(jet backend) runtime system, Version 1.0 * -* Copyright (c) Software Templ, 1994, 1995 +* Copyright (c) Software Templ, 1994, 1995 * -* Module SYSTEM is subject to change any time without prior notification. -* Software Templ disclaims all warranties with regard to module SYSTEM, -* in particular shall Software Templ not be liable for any damage resulting -* from inappropriate use or modification of module SYSTEM. +* Module SYSTEM is subject to change any time without prior notification. +* Software Templ disclaims all warranties with regard to module SYSTEM, +* in particular shall Software Templ not be liable for any damage resulting +* from inappropriate use or modification of module SYSTEM. * -* Version 1.1 jt, 24.11.95 fixes for correct pointer arithmetic on Cray computers -* jt 31.1.2007 ANSI prototypes for malloc and exit in order to avoid cc warnings +* Version 1.1 jt, 24.11.95 fixes for correct pointer arithmetic on Cray computers +* jt 31.1.2007 ANSI prototypes for malloc and exit in order to avoid cc warnings * */ #include "SYSTEM.h" -#ifdef __STDC__ #include "stdarg.h" +#include + + +LONGINT SYSTEM_XCHK(LONGINT i, LONGINT ub) {return __X(i, ub);} +LONGINT SYSTEM_RCHK(LONGINT i, LONGINT ub) {return __R(i, ub);} +LONGINT SYSTEM_ASH (LONGINT i, LONGINT n) {return __ASH(i, n);} +LONGINT SYSTEM_ABS (LONGINT i) {return __ABS(i);} +double SYSTEM_ABSD(double i) {return __ABS(i);} + +void SYSTEM_INHERIT(LONGINT *t, LONGINT *t0) +{ + t -= __TPROC0OFF; + t0 -= __TPROC0OFF; + while (*t0 != __EOM) {*t = *t0; t--; t0--;} +} + + +void SYSTEM_ENUMP(void *adr, LONGINT n, void (*P)()) +{ + while (n > 0) { + P((LONGINT)(uintptr_t)(*((void**)(adr)))); + adr = ((void**)adr) + 1; + n--; + } +} + +void SYSTEM_ENUMR(void *adr, LONGINT *typ, LONGINT size, LONGINT n, void (*P)()) +{ + LONGINT *t, off; + typ++; + while (n > 0) { + t = typ; + off = *t; + while (off >= 0) {P(*(LONGINT*)((char*)adr+off)); t++; off = *t;} + adr = ((char*)adr) + size; + n--; + } +} + +LONGINT SYSTEM_DIV(unsigned LONGINT x, unsigned LONGINT y) +{ if ((LONGINT) x >= 0) return (x / y); + else return -((y - 1 - x) / y); +} + +LONGINT SYSTEM_MOD(unsigned LONGINT x, unsigned LONGINT y) +{ unsigned LONGINT m; + if ((LONGINT) x >= 0) return (x % y); + else { m = (-x) % y; + if (m != 0) return (y - m); else return 0; + } +} + +LONGINT SYSTEM_ENTIER(double x) +{ + LONGINT y; + if (x >= 0) + return (LONGINT)x; + else { + y = (LONGINT)x; + if (y <= x) return y; else return y - 1; + } +} + +extern void Heap_Lock(); +extern void Heap_Unlock(); + +SYSTEM_PTR SYSTEM_NEWARR(LONGINT *typ, LONGINT elemsz, int elemalgn, int nofdim, int nofdyn, ...) +{ + LONGINT nofelems, size, dataoff, n, nptr, *x, *p, nofptrs, i, *ptab, off; + va_list ap; + va_start(ap, nofdyn); + nofelems = 1; + while (nofdim > 0) { + nofelems = nofelems * va_arg(ap, LONGINT); nofdim--; + if (nofelems <= 0) __HALT(-20); + } + va_end(ap); + dataoff = nofdyn * sizeof(LONGINT); + if (elemalgn > sizeof(LONGINT)) { + n = dataoff % elemalgn; + if (n != 0) dataoff += elemalgn - n; + } + size = dataoff + nofelems * elemsz; + Heap_Lock(); + if (typ == NIL) { + /* element typ does not contain pointers */ + x = Heap_NEWBLK(size); + } + else if (typ == (LONGINT*)POINTER__typ) { + /* element type is a pointer */ + x = Heap_NEWBLK(size + nofelems * sizeof(LONGINT)); + p = (LONGINT*)(uintptr_t)x[-1]; + p[-nofelems] = *p; /* build new type desc in situ: 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */ + p -= nofelems - 1; n = 1; /* n =1 for skipping the size field */ + while (n <= nofelems) {*p = n*sizeof(LONGINT); p++; n++;} + *p = - (nofelems + 1) * sizeof(LONGINT); /* sentinel */ + x[-1] -= nofelems * sizeof(LONGINT); + } + else { + /* element type is a record that contains pointers */ + ptab = typ + 1; nofptrs = 0; + while (ptab[nofptrs] >= 0) {nofptrs++;} /* number of pointers per element */ + nptr = nofelems * nofptrs; /* total number of pointers */ + x = Heap_NEWBLK(size + nptr * sizeof(LONGINT)); + p = (LONGINT*)(uintptr_t)x[- 1]; + p[-nptr] = *p; /* build new type desc in situ; 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */ + p -= nptr - 1; n = 0; off = dataoff; + while (n < nofelems) {i = 0; + while (i < nofptrs) {*p = off + ptab[i]; p++; i++;} + off += elemsz; n++; + } + *p = - (nptr + 1) * sizeof(LONGINT); /* sentinel */ + x[-1] -= nptr * sizeof(LONGINT); + } + if (nofdyn != 0) { + /* setup len vector for index checks */ + va_start(ap, nofdyn); + p = x; + while (nofdyn > 0) {*p = va_arg(ap, LONGINT); p++, nofdyn--;} + va_end(ap); + } + Heap_Unlock(); + return x; +} + + + + +typedef void (*SystemSignalHandler)(INTEGER); // = Platform_SignalHandler + +#ifndef _WIN32 + + SystemSignalHandler handler[3] = {0}; + + // Provide signal handling for Unix based systems + void signalHandler(int s) { + if (s >= 2 && s <= 4) handler[s-2](s); + // (Ignore other signals) + } + + void SystemSetHandler(int s, uintptr_t h) { + if (s >= 2 && s <= 4) { + int needtosetsystemhandler = handler[s-2] == 0; + handler[s-2] = (SystemSignalHandler)h; + if (needtosetsystemhandler) {signal(s, signalHandler);} + } + } + #else -#include "varargs.h" + + // Provides Windows callback handlers for signal-like scenarios + #include "WindowsWrapper.h" + + SystemSignalHandler SystemInterruptHandler = 0; + SystemSignalHandler SystemQuitHandler = 0; + BOOL ConsoleCtrlHandlerSet = FALSE; + + BOOL WINAPI SystemConsoleCtrlHandler(DWORD ctrlType) { + if ((ctrlType == CTRL_C_EVENT) || (ctrlType == CTRL_BREAK_EVENT)) { + if (SystemInterruptHandler) { + SystemInterruptHandler(2); // SIGINT + return TRUE; + } + } else { // Close, logoff or shutdown + if (SystemQuitHandler) { + SystemQuitHandler(3); // SIGQUIT + return TRUE; + } + } + return FALSE; + } + + void EnsureConsoleCtrlHandler() { + if (!ConsoleCtrlHandlerSet) { + SetConsoleCtrlHandler(SystemConsoleCtrlHandler, TRUE); + ConsoleCtrlHandlerSet = TRUE; + } + } + + void SystemSetInterruptHandler(uintptr_t h) { + EnsureConsoleCtrlHandler(); + SystemInterruptHandler = (SystemSignalHandler)h; + } + + void SystemSetQuitHandler(uintptr_t h) { + EnsureConsoleCtrlHandler(); + SystemQuitHandler = (SystemSignalHandler)h; + } + #endif - -extern void *malloc(unsigned long size); -extern void exit(int status); - -void (*SYSTEM_Halt)(); -LONGINT SYSTEM_halt; /* x in HALT(x) */ -LONGINT SYSTEM_assert; /* x in ASSERT(cond, x) */ -LONGINT SYSTEM_argc; -LONGINT SYSTEM_argv; -LONGINT SYSTEM_lock; -BOOLEAN SYSTEM_interrupted; -static LONGINT SYSTEM_mainfrm; /* adr of main proc stack frame, used for stack collection */ - -#define Lock SYSTEM_lock++ -#define Unlock SYSTEM_lock--; if (SYSTEM_interrupted && (SYSTEM_lock == 0)) __HALT(-9) - - -static void SYSTEM_InitHeap(); -void *SYSTEM__init(); - -void SYSTEM_INIT(argc, argvadr) - int argc; long argvadr; -{ - SYSTEM_mainfrm = argvadr; - SYSTEM_argc = argc; - SYSTEM_argv = *(long*)argvadr; - SYSTEM_InitHeap(); - SYSTEM_halt = -128; - SYSTEM__init(); -} - -void SYSTEM_FINI() -{ - SYSTEM_FINALL(); -} - -long SYSTEM_XCHK(i, ub) long i, ub; {return __X(i, ub);} -long SYSTEM_RCHK(i, ub) long i, ub; {return __R(i, ub);} -long SYSTEM_ASH(i, n) long i, n; {return __ASH(i, n);} -long SYSTEM_ABS(i) long i; {return __ABS(i);} -double SYSTEM_ABSD(i) double i; {return __ABS(i);} - -void SYSTEM_INHERIT(t, t0) - long *t, *t0; -{ - t -= __TPROC0OFF; - t0 -= __TPROC0OFF; - while (*t0 != __EOM) {*t = *t0; t--; t0--;} -} - -void SYSTEM_ENUMP(adr, n, P) - long *adr; - long n; - void (*P)(); -{ - while (n > 0) {P(*adr); adr++; n--;} -} - -void SYSTEM_ENUMR(adr, typ, size, n, P) - char *adr; - long *typ, size, n; - void (*P)(); -{ - long *t, off; - typ++; - while (n > 0) { - t = typ; - off = *t; - while (off >= 0) {P(*(long*)(adr+off)); t++; off = *t;} - adr += size; n--; - } -} - -long SYSTEM_DIV(x, y) - unsigned long x, y; -{ if ((long) x >= 0) return (x / y); - else return -((y - 1 - x) / y); -} - -long SYSTEM_MOD(x, y) - unsigned long x, y; -{ unsigned long m; - if ((long) x >= 0) return (x % y); - else { m = (-x) % y; - if (m != 0) return (y - m); else return 0; - } -} - -long SYSTEM_ENTIER(x) - double x; -{ - long y; - if (x >= 0) - return (long)x; - else { - y = (long)x; - if (y <= x) return y; else return y - 1; - } -} - -void SYSTEM_HALT(n) - int n; -{ - SYSTEM_halt = n; - if (SYSTEM_Halt!=0) SYSTEM_Halt(n); - exit(n); -} - -#ifdef __STDC__ -SYSTEM_PTR SYSTEM_NEWARR(long *typ, long elemsz, int elemalgn, int nofdim, int nofdyn, ...) -#else -SYSTEM_PTR SYSTEM_NEWARR(typ, elemsz, elemalgn, nofdim, nofdyn, va_alist) - long *typ, elemsz; - int elemalgn, nofdim, nofdyn; - va_dcl -#endif -{ - long nofelems, size, dataoff, n, nptr, *x, *p, nofptrs, i, *ptab, off; - va_list ap; -#ifdef __STDC__ - va_start(ap, nofdyn); -#else - va_start(ap); -#endif - nofelems = 1; - while (nofdim > 0) { - nofelems = nofelems * va_arg(ap, long); nofdim--; - if (nofelems <= 0) __HALT(-20); - } - va_end(ap); - dataoff = nofdyn * sizeof(long); - if (elemalgn > sizeof(long)) { - n = dataoff % elemalgn; - if (n != 0) dataoff += elemalgn - n; - } - size = dataoff + nofelems * elemsz; - Lock; - if (typ == NIL) { - /* element typ does not contain pointers */ - x = SYSTEM_NEWBLK(size); - } - else if (typ == POINTER__typ) { - /* element type is a pointer */ - x = SYSTEM_NEWBLK(size + nofelems * sizeof(long)); - p = (long*)x[-1]; - p[-nofelems] = *p; /* build new type desc in situ: 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */ - p -= nofelems - 1; n = 1; /* n =1 for skipping the size field */ - while (n <= nofelems) {*p = n*sizeof(long); p++; n++;} - *p = - (nofelems + 1) * sizeof(long); /* sentinel */ - x[-1] -= nofelems * sizeof(long); - } - else { - /* element type is a record that contains pointers */ - ptab = typ + 1; nofptrs = 0; - while (ptab[nofptrs] >= 0) {nofptrs++;} /* number of pointers per element */ - nptr = nofelems * nofptrs; /* total number of pointers */ - x = SYSTEM_NEWBLK(size + nptr * sizeof(long)); - p = (long*)x[- 1]; - p[-nptr] = *p; /* build new type desc in situ; 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */ - p -= nptr - 1; n = 0; off = dataoff; - while (n < nofelems) {i = 0; - while (i < nofptrs) {*p = off + ptab[i]; p++; i++;} - off += elemsz; n++; - } - *p = - (nptr + 1) * sizeof(long); /* sentinel */ - x[-1] -= nptr * sizeof(long); - } - if (nofdyn != 0) { - /* setup len vector for index checks */ -#ifdef __STDC__ - va_start(ap, nofdyn); -#else - va_start(ap); -#endif - p = x; - while (nofdyn > 0) {*p = va_arg(ap, long); p++, nofdyn--;} - va_end(ap); - } - Unlock; - return x; -} - -/* ----------- end of SYSTEM.co ------------- */ - diff --git a/src/system/SYSTEM.h b/src/system/SYSTEM.h index 2c8e71d0..f9e2f930 100644 --- a/src/system/SYSTEM.h +++ b/src/system/SYSTEM.h @@ -1,238 +1,275 @@ #ifndef SYSTEM__h #define SYSTEM__h -/* +#ifndef _WIN32 -voc (jet backend) runtime system interface and macros library -copyright (c) Josef Templ, 1995, 1996 + // Building for a Unix/Linux based system + #include // For memcpy ... + #include // For uintptr_t ... -gcc for Linux version (same as SPARC/Solaris2) -uses double # as concatenation operator - -*/ - -#include -#include /* for type sizes -- noch */ - -extern void *memcpy(void *dest, const void *src, unsigned long n); -extern void *malloc(unsigned long size); -extern void exit(int status); - -#define export -#define import extern - -/* constants */ -#define __MAXEXT 16 -#define NIL 0L -#define POINTER__typ (long*)1L /* not NIL and not a valid type */ - -/* basic types */ -//typedef char BOOLEAN; -#define BOOLEAN char -//typedef unsigned char CHAR; -#define CHAR unsigned char -//exactly two bytes -#define LONGCHAR unsigned short int -//typedef signed char SHORTINT; -#define SHORTINT signed char -//for x86 GNU/Linux -//typedef short int INTEGER; -//for x86_64 GNU/Linux -//typedef int INTEGER; -#define INTEGER int -//typedef long LONGINT; -#define LONGINT long -//typedef float REAL; -#define REAL float -//typedef double LONGREAL; -#define LONGREAL double -//typedef unsigned long SET; -#define SET unsigned long -typedef void *SYSTEM_PTR; -//#define *SYSTEM_PTR void -//typedef unsigned char SYSTEM_BYTE; -#define SYSTEM_BYTE unsigned char -typedef int8_t SYSTEM_INT8; -typedef int16_t SYSTEM_INT16; -typedef int32_t SYSTEM_INT32; -typedef int64_t SYSTEM_INT64; - -/* runtime system routines */ -extern long SYSTEM_DIV(); -extern long SYSTEM_MOD(); -extern long SYSTEM_ENTIER(); -extern long SYSTEM_ASH(); -extern long SYSTEM_ABS(); -extern long SYSTEM_XCHK(); -extern long SYSTEM_RCHK(); -extern double SYSTEM_ABSD(); -extern SYSTEM_PTR SYSTEM_NEWREC(); -extern SYSTEM_PTR SYSTEM_NEWBLK(); -#ifdef __STDC__ -extern SYSTEM_PTR SYSTEM_NEWARR(long*, long, int, int, int, ...); #else -extern SYSTEM_PTR SYSTEM_NEWARR(); -#endif -extern SYSTEM_PTR SYSTEM_REGMOD(); -extern void SYSTEM_INCREF(); -extern void SYSTEM_REGCMD(); -extern void SYSTEM_REGTYP(); -extern void SYSTEM_REGFIN(); -extern void SYSTEM_FINALL(); -extern void SYSTEM_INIT(); -extern void SYSTEM_FINI(); -extern void SYSTEM_HALT(); -extern void SYSTEM_INHERIT(); -extern void SYSTEM_ENUMP(); -extern void SYSTEM_ENUMR(); -/* module registry */ -#define __DEFMOD static void *m; if(m!=0)return m -#define __REGMOD(name, enum) if(m==0)m=SYSTEM_REGMOD((CHAR*)name,enum); else return m -#define __ENDMOD return m -#define __INIT(argc, argv) static void *m; SYSTEM_INIT(argc, (long)&argv); -#define __REGMAIN(name, enum) m=SYSTEM_REGMOD(name,enum) -#define __FINI SYSTEM_FINI(); return 0 -#define __IMPORT(name) SYSTEM_INCREF(name##__init()) -#define __REGCMD(name, cmd) SYSTEM_REGCMD(m, name, cmd) + // Building for Windows platform with either mingw under cygwin, or the MS C compiler + #ifdef _WIN64 + typedef unsigned long long size_t; + typedef unsigned long long uintptr_t; + #else + typedef unsigned int size_t; + typedef unsigned int uintptr_t; + #endif /* _WIN64 */ + + typedef unsigned int uint32_t; + void * __cdecl memcpy(void * dest, const void * source, size_t size); + +#endif + + +// The compiler uses 'import' and 'export' which translate to 'extern' and +// nothing respectively. + +#define import extern +#define export + + + +// Known constants + +#define NIL ((void*)0) +#define __MAXEXT 16 +#define POINTER__typ ((LONGINT*)(1)) // not NIL and not a valid type + + +// Oberon types + +#define BOOLEAN char +#define SYSTEM_BYTE unsigned char +#define CHAR unsigned char +#define SHORTINT signed char +#define REAL float +#define LONGREAL double +#define SYSTEM_PTR void* + +// For 32 bit builds, the size of LONGINT depends on a make option: + +#if (__SIZEOF_POINTER__ == 8) || defined(LARGE) || defined(_WIN64) + #define INTEGER int // INTEGER is 32 bit. + #define LONGINT long long // LONGINT is 64 bit. (long long is always 64 bits, while long can be 32 bits e.g. under MSC/MingW) +#else + #define INTEGER short int // INTEGER is 16 bit. + #define LONGINT long // LONGINT is 32 bit. +#endif + +#define SET unsigned LONGINT + + +// OS Memory allocation interfaces are in PlatformXXX.Mod + +extern LONGINT Platform_OSAllocate (LONGINT size); +extern void Platform_OSFree (LONGINT addr); + + +// Run time system routines in SYSTEM.c + +extern LONGINT SYSTEM_XCHK (LONGINT i, LONGINT ub); +extern LONGINT SYSTEM_RCHK (LONGINT i, LONGINT ub); +extern LONGINT SYSTEM_ASH (LONGINT i, LONGINT n); +extern LONGINT SYSTEM_ABS (LONGINT i); +extern double SYSTEM_ABSD (double i); +extern void SYSTEM_INHERIT(LONGINT *t, LONGINT *t0); +extern void SYSTEM_ENUMP (void *adr, LONGINT n, void (*P)()); +extern void SYSTEM_ENUMR (void *adr, LONGINT *typ, LONGINT size, LONGINT n, void (*P)()); +extern LONGINT SYSTEM_DIV (unsigned LONGINT x, unsigned LONGINT y); +extern LONGINT SYSTEM_MOD (unsigned LONGINT x, unsigned LONGINT y); +extern LONGINT SYSTEM_ENTIER (double x); + + +// Signal handling in SYSTEM.c + +#ifndef _WIN32 + extern void SystemSetHandler(int s, uintptr_t h); +#else + extern void SystemSetInterruptHandler(uintptr_t h); + extern void SystemSetQuitHandler (uintptr_t h); +#endif + + + +// String comparison + +static int __str_cmp(CHAR *x, CHAR *y){ + LONGINT i = 0; + CHAR ch1, ch2; + do {ch1 = x[i]; ch2 = y[i]; i++; + if (!ch1) return -(int)ch2; + } while (ch1==ch2); + return (int)ch1 - (int)ch2; +} +#define __STRCMP(a,b) __str_cmp((CHAR*)(a), (CHAR*)(b)) + + + +// Inline string, record and array copy + +#define __COPY(s, d, n) {char*_a=(void*)s,*_b=(void*)d; LONGINT _i=0,_t=n-1; \ + while(_i<_t&&((_b[_i]=_a[_i])!=0)){_i++;};_b[_i]=0;} +#define __DUP(x, l, t) x=(void*)memcpy((void*)(uintptr_t)Platform_OSAllocate(l*sizeof(t)),x,l*sizeof(t)) +#define __DUPARR(v, t) v=(void*)memcpy(v##__copy,v,sizeof(t)) +#define __DEL(x) Platform_OSFree((LONGINT)(uintptr_t)x) + + + /* SYSTEM ops */ -#define __SYSNEW(p, len) p=SYSTEM_NEWBLK((long)(len)) -#define __VAL(t, x) (*(t*)&(x)) -#define __GET(a, x, t) x= *(t*)(a) -#define __PUT(a, x, t) *(t*)(a)=x -#define __LSHL(x, n, t) ((t)((unsigned t)(x)<<(n))) -#define __LSHR(x, n, t) ((t)((unsigned t)(x)>>(n))) -#define __LSH(x, n, t) ((n)>=0? __LSHL(x, n, t): __LSHR(x, -(n), t)) -#define __ROTL(x, n, t) ((t)((unsigned t)(x)<<(n)|(unsigned t)(x)>>(8*sizeof(t)-(n)))) -#define __ROTR(x, n, t) ((t)((unsigned t)(x)>>(n)|(unsigned t)(x)<<(8*sizeof(t)-(n)))) -#define __LSHR(x, n, t) ((t)((unsigned t)(x)>>(n))) -#define __LSH(x, n, t) ((n)>=0? __LSHL(x, n, t): __LSHR(x, -(n), t)) -#define __ROTL(x, n, t) ((t)((unsigned t)(x)<<(n)|(unsigned t)(x)>>(8*sizeof(t)-(n)))) -#define __ROTR(x, n, t) ((t)((unsigned t)(x)>>(n)|(unsigned t)(x)<<(8*sizeof(t)-(n)))) -#define __ROT(x, n, t) ((n)>=0? __ROTL(x, n, t): __ROTR(x, -(n), t)) -#define __BIT(x, n) (*(unsigned long*)(x)>>(n)&1) -#define __MOVE(s, d, n) memcpy((char*)(d),(char*)(s),n) -/* std procs and operator mappings */ -#define __SHORT(x, y) ((int)((unsigned long)(x)+(y)<(y)+(y)?(x):(__HALT(-8),0))) -#define __SHORTF(x, y) ((int)(__RF((x)+(y),(y)+(y))-(y))) -#define __CHR(x) ((CHAR)__R(x, 256)) -#define __CHRF(x) ((CHAR)__RF(x, 256)) -#define __DIV(x, y) ((x)>=0?(x)/(y):-(((y)-1-(x))/(y))) -#define __DIVF(x, y) SYSTEM_DIV((long)(x),(long)(y)) -#define __MOD(x, y) ((x)>=0?(x)%(y):__MODF(x,y)) -#define __MODF(x, y) SYSTEM_MOD((long)(x),(long)(y)) -#define __NEW(p, t) p=SYSTEM_NEWREC((long)t##__typ) -#define __NEWARR SYSTEM_NEWARR -#define __HALT(x) SYSTEM_HALT(x) -#define __ASSERT(cond, x) if (!(cond)) {SYSTEM_assert = x; SYSTEM_HALT(-1);} -#define __ENTIER(x) SYSTEM_ENTIER(x) -#define __ABS(x) (((x)<0)?-(x):(x)) -#define __ABSF(x) SYSTEM_ABS((long)(x)) -#define __ABSFD(x) SYSTEM_ABSD((double)(x)) -#define __CAP(ch) ((CHAR)((ch)&0x5f)) -#define __ODD(x) ((x)&1) -#define __IN(x, s) (((s)>>(x))&1) -#define __SETOF(x) ((SET)1<<(x)) -#define __SETRNG(l, h) ((~(SET)0<<(l))&~(SET)0>>(8*sizeof(SET)-1-(h))) -#define __MASK(x, m) ((x)&~(m)) -#define __COPY(s, d, n) {char*_a=(void*)s,*_b=(void*)d;long _i=0,_t=n-1;while(_i<_t&&((_b[_i]=_a[_i])!=0)){_i++;};_b[_i]=0;} -static int __STRCMP(x, y) - CHAR *x, *y; -{long i = 0; CHAR ch1, ch2; - do {ch1 = x[i]; ch2 = y[i]; i++; - if (!ch1) return -(int)ch2; - } while (ch1==ch2); - return (int)ch1 - (int)ch2; -} -#define __ASH(x, n) ((n)>=0?__ASHL(x,n):__ASHR(x,-(n))) -#define __ASHL(x, n) ((long)(x)<<(n)) -#define __ASHR(x, n) ((long)(x)>>(n)) -#define __ASHF(x, n) SYSTEM_ASH((long)(x), (long)(n)) -#define __DUP(x, l, t) x=(void*)memcpy(alloca(l*sizeof(t)),x,l*sizeof(t)) -#define __DUPARR(v, t) v=(void*)memcpy(v##__copy,v,sizeof(t)) -#define __DEL(x) /* DUP with alloca frees storage automatically */ -#define __IS(tag, typ, level) (*(tag-(__BASEOFF-level))==(long)typ##__typ) -#define __TYPEOF(p) (*(((long**)(p))-1)) -#define __ISP(p, typ, level) __IS(__TYPEOF(p),typ,level) +#define __VAL(t, x) ((t)(x)) +#define __VALP(t, x) ((t)(uintptr_t)(x)) -/* runtime checks */ -#define __X(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-2),0)) -#define __XF(i, ub) SYSTEM_XCHK((long)(i), (long)(ub)) -#define __RETCHK __retchk: __HALT(-3) -#define __CASECHK __HALT(-4) -#define __GUARDP(p, typ, level) ((typ*)(__ISP(p,typ,level)?p:(__HALT(-5),p))) -#define __GUARDR(r, typ, level) (*((typ*)(__IS(r##__typ,typ,level)?r:(__HALT(-5),r)))) -#define __GUARDA(p, typ, level) ((struct typ*)(__IS(__TYPEOF(p),typ,level)?p:(__HALT(-5),p))) -#define __GUARDEQR(p, dyntyp, typ) if(dyntyp!=typ##__typ) __HALT(-6);*(p) -#define __GUARDEQP(p, typ) if(__TYPEOF(p)!=typ##__typ)__HALT(-6);*(p) -#define __WITHCHK __HALT(-7) -#define __R(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-8),0)) -#define __RF(i, ub) SYSTEM_RCHK((long)(i),(long)(ub)) +#define __GET(a, x, t) x= *(t*)(uintptr_t)(a) +#define __PUT(a, x, t) *(t*)(uintptr_t)(a)=x +#define __LSHL(x, n, t) ((t)((unsigned t)(x)<<(n))) +#define __LSHR(x, n, t) ((t)((unsigned t)(x)>>(n))) +#define __LSH(x, n, t) ((n)>=0? __LSHL(x, n, t): __LSHR(x, -(n), t)) +#define __ROTL(x, n, t) ((t)((unsigned t)(x)<<(n)|(unsigned t)(x)>>(8*sizeof(t)-(n)))) +#define __ROTR(x, n, t) ((t)((unsigned t)(x)>>(n)|(unsigned t)(x)<<(8*sizeof(t)-(n)))) +#define __LSHR(x, n, t) ((t)((unsigned t)(x)>>(n))) +#define __LSH(x, n, t) ((n)>=0? __LSHL(x, n, t): __LSHR(x, -(n), t)) +#define __ROTL(x, n, t) ((t)((unsigned t)(x)<<(n)|(unsigned t)(x)>>(8*sizeof(t)-(n)))) +#define __ROTR(x, n, t) ((t)((unsigned t)(x)>>(n)|(unsigned t)(x)<<(8*sizeof(t)-(n)))) +#define __ROT(x, n, t) ((n)>=0? __ROTL(x, n, t): __ROTR(x, -(n), t)) +#define __BIT(x, n) (*(unsigned LONGINT*)(x)>>(n)&1) +#define __MOVE(s, d, n) memcpy((char*)(uintptr_t)(d),(char*)(uintptr_t)(s),n) +#define __ASHL(x, n) ((LONGINT)(x)<<(n)) +#define __ASHR(x, n) ((LONGINT)(x)>>(n)) +#define __ASH(x, n) ((n)>=0?__ASHL(x,n):__ASHR(x,-(n))) +#define __ASHF(x, n) SYSTEM_ASH((LONGINT)(x), (LONGINT)(n)) +#define __SHORT(x, y) ((int)((unsigned LONGINT)(x)+(y)<(y)+(y)?(x):(__HALT(-8),0))) +#define __SHORTF(x, y) ((int)(__RF((x)+(y),(y)+(y))-(y))) +#define __CHR(x) ((CHAR)__R(x, 256)) +#define __CHRF(x) ((CHAR)__RF(x, 256)) +#define __DIV(x, y) ((x)>=0?(x)/(y):-(((y)-1-(x))/(y))) +#define __DIVF(x, y) SYSTEM_DIV((LONGINT)(x),(LONGINT)(y)) +#define __MOD(x, y) ((x)>=0?(x)%(y):__MODF(x,y)) +#define __MODF(x, y) SYSTEM_MOD((LONGINT)(x),(LONGINT)(y)) +#define __ENTIER(x) SYSTEM_ENTIER(x) +#define __ABS(x) (((x)<0)?-(x):(x)) +#define __ABSF(x) SYSTEM_ABS((LONGINT)(x)) +#define __ABSFD(x) SYSTEM_ABSD((double)(x)) +#define __CAP(ch) ((CHAR)((ch)&0x5f)) +#define __ODD(x) ((x)&1) +#define __IN(x, s) (((s)>>(x))&1) +#define __SETOF(x) ((SET)1<<(x)) +#define __SETRNG(l, h) ((~(SET)0<<(l))&~(SET)0>>(8*sizeof(SET)-1-(h))) +#define __MASK(x, m) ((x)&~(m)) -/* record type descriptors */ -#define __TDESC(t, m, n) \ - static struct t##__desc {\ - long tproc[m]; \ - long tag, next, level, module; \ - char name[24]; \ - long *base[__MAXEXT]; \ - char *rsrvd; \ - long blksz, ptr[n+1]; \ - } t##__desc -#define __BASEOFF (__MAXEXT+1) -#define __TPROC0OFF (__BASEOFF+24/sizeof(long)+5) -#define __EOM 1 -#define __TDFLDS(name, size) {__EOM}, 1, 0, 0, 0, name, {0}, 0, size -#define __ENUMP(adr, n, P) SYSTEM_ENUMP(adr, (long)(n), P) -#define __ENUMR(adr, typ, size, n, P) SYSTEM_ENUMR(adr, typ, (long)(size), (long)(n), P) + +// Runtime checks + +#define __X(i, ub) (((unsigned LONGINT)(i)<(unsigned LONGINT)(ub))?i:(__HALT(-2),0)) +#define __XF(i, ub) SYSTEM_XCHK((LONGINT)(i), (LONGINT)(ub)) +#define __R(i, ub) (((unsigned LONGINT)(i)<(unsigned LONGINT)(ub))?i:(__HALT(-8),0)) +#define __RF(i, ub) SYSTEM_RCHK((LONGINT)(i),(LONGINT)(ub)) +#define __RETCHK __retchk: __HALT(-3); return 0; +#define __CASECHK __HALT(-4) +#define __WITHCHK __HALT(-7) + +#define __GUARDP(p, typ, level) ((typ*)(__ISP(p,typ,level)?p:(__HALT(-5),p))) +#define __GUARDR(r, typ, level) (*((typ*)(__IS(r##__typ,typ,level)?r:(__HALT(-5),r)))) +#define __GUARDA(p, typ, level) ((struct typ*)(__IS(__TYPEOF(p),typ,level)?p:(__HALT(-5),p))) +#define __GUARDEQR(p, dyntyp, typ) if(dyntyp!=typ##__typ) __HALT(-6);*(p) +#define __GUARDEQP(p, typ) if(__TYPEOF(p)!=typ##__typ)__HALT(-6);*(p) + + + +// Module entry/registration/exit + +extern void Heap_REGCMD(); +extern SYSTEM_PTR Heap_REGMOD(); +extern void Heap_REGTYP(); +extern void Heap_INCREF(); + +#define __DEFMOD static void *m; if (m!=0) {return m;} +#define __REGCMD(name, cmd) Heap_REGCMD(m, (CHAR*)name, cmd) +#define __REGMOD(name, enum) if (m==0) {m = Heap_REGMOD((CHAR*)name,enum);} +#define __ENDMOD return m +#define __MODULE_IMPORT(name) Heap_INCREF(name##__init()) + + + +// Main module initialisation, registration and finalisation + +extern void Platform_Init(INTEGER argc, LONGINT argv); +extern void *Platform_MainModule; +extern void Heap_FINALL(); + +#define __INIT(argc, argv) static void *m; Platform_Init((INTEGER)argc, (LONGINT)(uintptr_t)&argv); +#define __REGMAIN(name, enum) m = Heap_REGMOD((CHAR*)name,enum) +#define __FINI Heap_FINALL(); return 0 + + +// Assertions and Halts + +extern void Platform_Halt(LONGINT x); +extern void Platform_AssertFail(LONGINT x); + +#define __HALT(x) Platform_Halt(x) +#define __ASSERT(cond, x) if (!(cond)) Platform_AssertFail((LONGINT)(x)) + + +// Memory allocation + +extern SYSTEM_PTR Heap_NEWBLK (LONGINT size); +extern SYSTEM_PTR Heap_NEWREC (LONGINT tag); +extern SYSTEM_PTR SYSTEM_NEWARR(LONGINT*, LONGINT, int, int, int, ...); + +#define __SYSNEW(p, len) p = Heap_NEWBLK((LONGINT)(len)) +#define __NEW(p, t) p = Heap_NEWREC((LONGINT)(uintptr_t)t##__typ) +#define __NEWARR SYSTEM_NEWARR + + + +/* Type handling */ + +#define __TDESC(t, m, n) \ + static struct t##__desc { \ + LONGINT tproc[m]; /* Proc for each ptr field */ \ + LONGINT tag; \ + LONGINT next; /* Module table type list points here */ \ + LONGINT level; \ + LONGINT module; \ + char name[24]; \ + LONGINT basep[__MAXEXT]; /* List of bases this extends */ \ + LONGINT reserved; \ + LONGINT blksz; /* xxx_typ points here */ \ + LONGINT ptr[n+1]; /* Offsets of ptrs up to -ve sentinel */ \ + } t##__desc + +#define __BASEOFF (__MAXEXT+1) // blksz as index to base. +#define __TPROC0OFF (__BASEOFF+24/sizeof(LONGINT)+5) // blksz as index to tproc IFF m=1. +#define __EOM 1 +#define __TDFLDS(name, size) {__EOM}, 1, 0, 0, 0, name, {0}, 0, size +#define __ENUMP(adr, n, P) SYSTEM_ENUMP(adr, (LONGINT)(n), P) +#define __ENUMR(adr, typ, size, n, P) SYSTEM_ENUMR(adr, typ, (LONGINT)(size), (LONGINT)(n), P) #define __INITYP(t, t0, level) \ - t##__typ= &t##__desc.blksz; \ - memcpy(t##__desc.base, t0##__typ - __BASEOFF, level*sizeof(long)); \ - t##__desc.base[level]=t##__typ; \ - t##__desc.module=(long)m; \ - if(t##__desc.blksz!=sizeof(struct t)) __HALT(-15); \ - t##__desc.blksz=(t##__desc.blksz+5*sizeof(long)-1)/(4*sizeof(long))*(4*sizeof(long)); \ - SYSTEM_REGTYP(m, (long)&t##__desc.next); \ - SYSTEM_INHERIT(t##__typ, t0##__typ) + t##__typ = (LONGINT*)&t##__desc.blksz; \ + memcpy(t##__desc.basep, t0##__typ - __BASEOFF, level*sizeof(LONGINT)); \ + t##__desc.basep[level] = (LONGINT)(uintptr_t)t##__typ; \ + t##__desc.module = (LONGINT)(uintptr_t)m; \ + if(t##__desc.blksz!=sizeof(struct t)) __HALT(-15); \ + t##__desc.blksz = (t##__desc.blksz+5*sizeof(LONGINT)-1)/(4*sizeof(LONGINT))*(4*sizeof(LONGINT)); \ + Heap_REGTYP(m, (LONGINT)(uintptr_t)&t##__desc.next); \ + SYSTEM_INHERIT(t##__typ, t0##__typ) + +#define __IS(tag, typ, level) (*(tag-(__BASEOFF-level))==(LONGINT)(uintptr_t)typ##__typ) +#define __TYPEOF(p) ((LONGINT*)(uintptr_t)(*(((LONGINT*)(p))-1))) +#define __ISP(p, typ, level) __IS(__TYPEOF(p),typ,level) + +// Oberon-2 type bound procedures support +#define __INITBP(t, proc, num) *(t##__typ-(__TPROC0OFF+num))=(LONGINT)(uintptr_t)proc +#define __SEND(typ, num, funtyp, parlist) ((funtyp)((uintptr_t)*(typ-(__TPROC0OFF+num))))parlist -/* Oberon-2 type bound procedures support */ -#define __INITBP(t, proc, num) *(t##__typ-(__TPROC0OFF+num))=(long)proc -#define __SEND(typ, num, funtyp, parlist) ((funtyp)(*(typ-(__TPROC0OFF+num))))parlist -/* runtime system variables */ -extern LONGINT SYSTEM_argc; -extern LONGINT SYSTEM_argv; -extern void (*SYSTEM_Halt)(); -extern LONGINT SYSTEM_halt; -extern LONGINT SYSTEM_assert; -extern SYSTEM_PTR SYSTEM_modules; -extern LONGINT SYSTEM_heapsize; -extern LONGINT SYSTEM_allocated; -extern LONGINT SYSTEM_lock; -extern SHORTINT SYSTEM_gclock; -extern BOOLEAN SYSTEM_interrupted; -/* ANSI prototypes; not used so far -static int __STRCMP(CHAR *x, CHAR *y); -void SYSTEM_INIT(int argc, long argvadr); -void SYSTEM_FINI(void); -long SYSTEM_XCHK(long i, long ub); -long SYSTEM_RCHK(long i, long ub); -long SYSTEM_ASH(long i, long n); -long SYSTEM_ABS(long i); -double SYSTEM_ABSD(double i); -void SYSTEM_INHERIT(long *t, long *t0); -void SYSTEM_ENUMP(long *adr, long n, void (*P)(void*)); -void SYSTEM_ENUMR(char *adr, long *typ, long size, long n, void (*P)(void*)); -long SYSTEM_DIV(unsigned long x, unsigned long y); -long SYSTEM_MOD(unsigned long x, unsigned long y); -long SYSTEM_ENTIER(double x); -void SYSTEM_HALT(int n); -*/ #endif - diff --git a/src/system/WindowsWrapper.h b/src/system/WindowsWrapper.h new file mode 100755 index 00000000..cdb8714c --- /dev/null +++ b/src/system/WindowsWrapper.h @@ -0,0 +1,9 @@ +// WindowsWrapper.h +// +// Includes Windows.h while avoiding conflicts with Oberon types. + +#undef BOOLEAN +#undef CHAR +#include +#define BOOLEAN char +#define CHAR unsigned char