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

Update system source to V2.

Browse source
This commit is contained in:
David Brown 2016-06-16 14:14:39 +01:00
parent efb7b6b030
commit 4245c6e8b3
10 changed files with 2150 additions and 1482 deletions
Download patch file Download diff file Expand all files Collapse all files

20
src/system/Console.Mod
View file

@ -2,20 +2,16 @@ MODULE Console; (* J. Templ, 29-June-96 *)
(* output to Unix standard output device based Write system call *) (* output to Unix standard output device based Write system call *)
IMPORT SYSTEM; IMPORT SYSTEM, Platform;
VAR line: ARRAY 128 OF CHAR; VAR line: ARRAY 128 OF CHAR;
pos: INTEGER; pos: INTEGER;
PROCEDURE -Write(adr, n: LONGINT) PROCEDURE Flush*;
"write(1/*stdout*/, adr, n)"; VAR error: Platform.ErrorCode;
PROCEDURE -read(VAR ch: CHAR): LONGINT
"read(0/*stdin*/, ch, 1)";
PROCEDURE Flush*();
BEGIN BEGIN
Write(SYSTEM.ADR(line), pos); pos := 0; error := Platform.Write(Platform.StdOut, SYSTEM.ADR(line), pos);
pos := 0;
END Flush; END Flush;
PROCEDURE Char*(ch: CHAR); PROCEDURE Char*(ch: CHAR);
@ -68,16 +64,16 @@ MODULE Console; (* J. Templ, 29-June-96 *)
END Hex; END Hex;
PROCEDURE Read*(VAR ch: CHAR); PROCEDURE Read*(VAR ch: CHAR);
VAR n: LONGINT; VAR n: LONGINT; error: Platform.ErrorCode;
BEGIN Flush(); BEGIN Flush();
n := read(ch); error := Platform.ReadBuf(Platform.StdIn, ch, n);
IF n # 1 THEN ch := 0X END IF n # 1 THEN ch := 0X END
END Read; END Read;
PROCEDURE ReadLine*(VAR line: ARRAY OF CHAR); PROCEDURE ReadLine*(VAR line: ARRAY OF CHAR);
VAR i: LONGINT; ch: CHAR; VAR i: LONGINT; ch: CHAR;
BEGIN Flush(); 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 ; WHILE (i < LEN(line) - 1) & (ch # 0AX) & (ch # 0X) DO line[i] := ch; INC(i); Read(ch) END ;
line[i] := 0X line[i] := 0X
END ReadLine; END ReadLine;

600
src/system/Files.Mod
View file

@ -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 *) IMPORT SYSTEM, Platform, Heap, Strings, Configuration, Console;
(* for general use import Files module *)
IMPORT SYSTEM, Unix, Kernel := Kernel0, Args, Console; (* standard data type I/O
(* standard data type I/O
little endian, little endian,
Sint:1, Int:2, Lint:4 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 CONST
nofbufs = 4; nofbufs = 4;
bufsize = 4096; bufsize = 4096;
fileTabSize = 64; fileTabSize = 256; (* 256 needed for Windows *)
noDesc = -1; noDesc = -1;
notDone = -1; notDone = -1;
(* file states *) (* 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 TYPE
FileName = ARRAY 101 OF CHAR; FileName = ARRAY 101 OF CHAR;
File* = POINTER TO Handle; File* = POINTER TO Handle;
Buffer = POINTER TO BufDesc; Buffer = POINTER TO BufDesc;
Handle = RECORD Handle = RECORD
workName, registerName: FileName; workName, registerName: FileName;
tempFile: BOOLEAN; tempFile: BOOLEAN;
dev, ino, mtime: LONGINT; identity: Platform.FileIdentity;
fd-: INTEGER; fd-: Platform.FileHandle;
len, pos: LONGINT; len, pos: LONGINT;
bufs: ARRAY nofbufs OF Buffer; bufs: ARRAY nofbufs OF Buffer;
swapper, state: INTEGER swapper, state: INTEGER
END ; END;
BufDesc = RECORD BufDesc = RECORD
f: File; f: File;
chg: BOOLEAN; chg: BOOLEAN;
org, size: LONGINT; org: LONGINT;
size: LONGINT;
data: ARRAY bufsize OF SYSTEM.BYTE data: ARRAY bufsize OF SYSTEM.BYTE
END ; END;
Rider* = RECORD Rider* = RECORD
res*: LONGINT; res*: LONGINT;
eof*: BOOLEAN; eof*: BOOLEAN;
buf: Buffer; buf: Buffer;
org, offset: LONGINT 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 VAR
fileTab: ARRAY fileTabSize OF LONGINT (*=File*); fileTab: ARRAY fileTabSize OF LONGINT (*=File*);
tempno: INTEGER; 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 -IdxTrap "__HALT(-1)";
PROCEDURE^ Finalize(o: SYSTEM.PTR); 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 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 # NIL THEN
IF f.registerName # "" THEN Console.String(f.registerName) ELSE Console.String(f.workName) END IF f.registerName # "" THEN Console.String(f.registerName) ELSE Console.String(f.workName) END;
END ; IF f.fd # 0 THEN Console.String("f.fd = "); Console.Int(f.fd,1) END
IF errno # 0 THEN Console.String(" errno = "); Console.Int(errno, 1) END ; END;
IF errcode # 0 THEN Console.String(" errcode = "); Console.Int(errcode, 1) END;
Console.Ln; Console.Ln;
HALT(99) HALT(99)
END Err; 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); PROCEDURE MakeFileName(dir, name: ARRAY OF CHAR; VAR dest: ARRAY OF CHAR);
VAR i, j: INTEGER; VAR i, j: INTEGER;
BEGIN i := 0; j := 0; BEGIN i := 0; j := 0;
WHILE dir[i] # 0X DO dest[i] := dir[i]; INC(i) END ; WHILE dir[i] # 0X DO dest[i] := dir[i]; INC(i) END;
IF dest[i-1] # "/" THEN dest[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 name[j] # 0X DO dest[i] := name[j]; INC(i); INC(j) END;
dest[i] := 0X dest[i] := 0X
END MakeFileName; END MakeFileName;
@ -105,8 +99,8 @@ MODULE Files0; (* J. Templ 1.12. 89/12.4.95 Oberon files mapped onto Unix files
BEGIN BEGIN
INC(tempno); n := tempno; i := 0; INC(tempno); n := tempno; i := 0;
IF finalName[0] # "/" THEN (* relative pathname *) IF finalName[0] # "/" THEN (* relative pathname *)
WHILE Kernel.CWD[i] # 0X DO name[i] := Kernel.CWD[i]; INC(i) END; WHILE Platform.CWD[i] # 0X DO name[i] := Platform.CWD[i]; INC(i) END;
IF Kernel.CWD[i-1] # "/" THEN name[i] := "/"; INC(i) END IF Platform.CWD[i-1] # "/" THEN name[i] := "/"; INC(i) END
END; END;
j := 0; j := 0;
WHILE finalName[j] # 0X DO name[i] := finalName[j]; INC(i); INC(j) END; 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; 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); 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; 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; WHILE n > 0 DO name[i] := CHR(n MOD 10 + ORD("0")); n := n DIV 10; INC(i) END;
name[i] := 0X name[i] := 0X
END GetTempName; END GetTempName;
PROCEDURE Create(f: File); PROCEDURE Create(f: File);
VAR stat: Unix.Status; done: BOOLEAN; VAR
errno: LONGINT; err: ARRAY 32 OF CHAR; identity: Platform.FileIdentity;
done: BOOLEAN;
error: Platform.ErrorCode;
err: ARRAY 32 OF CHAR;
BEGIN 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.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 ELSIF f.state = close THEN
f.workName := f.registerName; f.registerName := ""; f.tempFile := FALSE f.workName := f.registerName; f.registerName := ""; f.tempFile := FALSE
END ; END;
errno := Unix.Unlink(f.workName); (*unlink first to avoid stale NFS handles and to avoid reuse of inodes*) error := Platform.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(); error := Platform.New(f.workName, f.fd);
IF (~done & ((errno = Unix.ENFILE) OR (errno = Unix.EMFILE))) OR (done & (f.fd >= fileTabSize)) THEN done := error = 0;
IF done & (f.fd >= fileTabSize) THEN errno := Unix.Close(f.fd) END ; (* In case of too many files, try just once more. *)
Kernel.GC(TRUE); IF (~done & Platform.TooManyFiles(error)) OR (done & (f.fd >= fileTabSize)) THEN
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}))); IF done & (f.fd >= fileTabSize) THEN error := Platform.Close(f.fd) END;
done := f.fd >= 0 Heap.GC(TRUE);
END ; error := Platform.New(f.workName, f.fd);
done := f.fd = 0
END;
IF done THEN IF done THEN
IF f.fd >= fileTabSize THEN errno := Unix.Close(f.fd); Err("too many files open", f, 0) IF f.fd >= fileTabSize THEN
ELSE fileTab[f.fd] := SYSTEM.VAL(LONGINT, f); INC(Kernel.nofiles); Kernel.RegisterObject(f, Finalize); (* Console.String("f.fd = "); Console.Int(f.fd,1); Console.Ln; *)
f.state := open; f.pos := 0; errno := Unix.Fstat(f.fd, stat); error := Platform.Close(f.fd); Err("too many files open", f, 0)
f.dev := stat.dev; f.ino := stat.ino; f.mtime := stat.mtime 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 END
ELSE errno := Unix.errno(); ELSE
IF errno = Unix.ENOENT THEN err := "no such directory" IF Platform.NoSuchDirectory(error) THEN err := "no such directory"
ELSIF (errno = Unix.ENFILE) OR (errno = Unix.EMFILE) THEN err := "too many files open" ELSIF Platform.TooManyFiles(error) THEN
ELSE err := "file not created" (* Console.String("f.fd = "); Console.Int(f.fd,1); Console.Ln; *)
END ; err := "too many files open"
Err(err, f, errno) ELSE err := "file not created"
END;
Err(err, f, error)
END END
END END
END Create; END Create;
PROCEDURE Flush(buf: Buffer); PROCEDURE Flush(buf: Buffer);
VAR res: LONGINT; f: File; stat: Unix.Status; VAR
error: Platform.ErrorCode;
f: File;
(* identity: Platform.FileIdentity; *)
BEGIN 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.chg THEN f := buf.f; Create(f);
IF buf.org # f.pos THEN res := Unix.Lseek(f.fd, buf.org, 0) END ; IF buf.org # f.pos THEN
res := Unix.Write(f.fd, SYSTEM.ADR(buf.data), buf.size); error := Platform.Seek(f.fd, buf.org, Platform.SeekSet);
IF res < 0 THEN Err("error in writing file", f, Unix.errno()) END ; (*
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; f.pos := buf.org + buf.size;
buf.chg := FALSE; buf.chg := FALSE;
res := Unix.Fstat(f.fd, stat); error := Platform.Identify(f.fd, f.identity);
f.mtime := stat.mtime IF error # 0 THEN Err("error identifying file", f, error) END;
(*
error := Platform.Identify(f.fd, identity);
f.identity.mtime := identity.mtime;
*)
END END
END Flush; END Flush;
PROCEDURE Close* (f: File); PROCEDURE Close* (f: File);
VAR i, res: LONGINT; VAR
i: LONGINT;
error: Platform.ErrorCode;
BEGIN 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 IF (f.state # create) OR (f.registerName # "") THEN
Create(f); i := 0; Create(f); i := 0;
WHILE (i < nofbufs) & (f.bufs[i] # NIL) DO Flush(f.bufs[i]); INC(i) END ; WHILE (i < nofbufs) & (f.bufs[i] # NIL) DO Flush(f.bufs[i]); INC(i) END;
res := Unix.Fsync(f.fd); error := Platform.Sync(f.fd);
IF res < 0 THEN Err("error in writing file", f, Unix.errno()) END (*
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
END Close; END Close;
PROCEDURE Length* (f: File): LONGINT; PROCEDURE Length* (f: File): LONGINT;
BEGIN RETURN f.len BEGIN RETURN f.len END Length;
END Length;
PROCEDURE New* (name: ARRAY OF CHAR): File; PROCEDURE New* (name: ARRAY OF CHAR): File;
VAR f: File; VAR f: File;
@ -190,87 +239,108 @@ f.fd := Unix.Open(f.workName, SHORT(SYSTEM.VAL(LONGINT, (Unix.rdwr + Unix.creat
RETURN f RETURN f
END New; END New;
PROCEDURE ScanPath(VAR pos: INTEGER; VAR dir: ARRAY OF CHAR); (* supports ~, ~user and blanks inside path *) PROCEDURE ScanPath(VAR pos: INTEGER; VAR dir: ARRAY OF CHAR);
VAR i: INTEGER; ch: CHAR; home: ARRAY 256 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 BEGIN
i := 0; ch := Kernel.OBERON[pos]; i := 0;
WHILE (ch = " ") OR (ch = ":") DO INC(pos); ch := Kernel.OBERON[pos] END ; IF SearchPath = NIL THEN
IF ch = "~" THEN IF pos = 0 THEN
INC(pos); ch := Kernel.OBERON[pos]; dir[0] := "."; i := 1; INC(pos) (* Default search path is just the current directory *)
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
END END
END ; ELSE
WHILE (ch # 0X) & (ch # ":") DO dir[i] := ch; INC(i); INC(pos); ch := Kernel.OBERON[pos] END ; ch := SearchPath[pos];
WHILE (i > 0) & (dir[i-1] = " ") DO DEC(i) END ; 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 dir[i] := 0X
END ScanPath; END ScanPath;
PROCEDURE HasDir(VAR name: ARRAY OF CHAR): BOOLEAN; PROCEDURE HasDir(VAR name: ARRAY OF CHAR): BOOLEAN;
VAR i: INTEGER; ch: CHAR; VAR i: INTEGER; ch: CHAR;
BEGIN i := 0; ch := name[0]; 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 = "/" RETURN ch = "/"
END HasDir; END HasDir;
PROCEDURE CacheEntry(dev, ino: LONGINT; mtime: LONGINT): File; PROCEDURE CacheEntry(identity: Platform.FileIdentity): File;
VAR f: File; i: INTEGER; stat: Unix.Status; res: LONGINT; VAR f: File; i: INTEGER; error: Platform.ErrorCode;
BEGIN i := 0; BEGIN i := 0;
WHILE i < fileTabSize DO WHILE i < fileTabSize DO
f := SYSTEM.VAL(File, fileTab[i]); f := SYSTEM.VAL(File, fileTab[i]);
IF (f # NIL) & (ino = f.ino) & (dev = f.dev) THEN IF (f # NIL) & Platform.SameFile(identity, f.identity) THEN
IF mtime # f.mtime THEN i := 0; IF ~Platform.SameFileTime(identity, f.identity) THEN i := 0;
WHILE i < nofbufs DO 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) INC(i)
END ; END;
f.swapper := -1; f.mtime := mtime; f.swapper := -1; f.identity := identity;
res := Unix.Fstat(f.fd, stat); f.len := stat.size error := Platform.Size(f.fd, f.len);
END ; END;
RETURN f RETURN f
END ; END;
INC(i) INC(i)
END ; END;
RETURN NIL RETURN NIL
END CacheEntry; END CacheEntry;
PROCEDURE Old* (name: ARRAY OF CHAR): File; PROCEDURE Old*(name: ARRAY OF CHAR): File;
VAR f: File; fd: INTEGER; res, errno: LONGINT; pos: INTEGER; done: BOOLEAN; VAR
f: File;
fd: Platform.FileHandle;
pos: INTEGER;
done: BOOLEAN;
dir, path: ARRAY 256 OF CHAR; dir, path: ARRAY 256 OF CHAR;
stat: Unix.Status; error: Platform.ErrorCode;
identity: Platform.FileIdentity;
BEGIN BEGIN
(* Console.String("Files.Old "); Console.String(name); Console.Ln; *)
IF name # "" THEN IF name # "" THEN
IF HasDir(name) THEN dir := ""; COPY(name, path) IF HasDir(name) THEN dir := ""; COPY(name, path)
ELSE pos := 0; ScanPath(pos, dir); MakeFileName(dir, name, path); ScanPath(pos, dir) ELSE pos := 0; ScanPath(pos, dir); MakeFileName(dir, name, path); ScanPath(pos, dir)
END ; END;
LOOP LOOP
fd := Unix.Open(path, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr)), SHORT(SYSTEM.VAL(LONGINT, {}))); done := fd >= 0; errno := Unix.errno(); error := Platform.OldRW(path, fd); done := error = 0;
IF (~done & ((errno = Unix.ENFILE) OR (errno = Unix.EMFILE))) OR (done & (fd >= fileTabSize)) THEN IF (~done & Platform.TooManyFiles(error)) OR (done & (fd >= fileTabSize)) THEN
IF done & (fd >= fileTabSize) THEN res := Unix.Close(fd) END ; IF done & (fd >= fileTabSize) THEN error := Platform.Close(fd) END;
Kernel.GC(TRUE); Heap.GC(TRUE);
fd := Unix.Open(path, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr)), SHORT(SYSTEM.VAL(LONGINT, {}))); error := Platform.OldRW(path, fd); done := error = 0;
done := fd >= 0; errno := Unix.errno(); IF ~done & Platform.TooManyFiles(error) THEN
IF ~done & ((errno = Unix.ENFILE) OR (errno = Unix.EMFILE)) THEN Err("too many files open", f, errno) END (* Console.String("fd = "); Console.Int(fd,1); Console.Ln; *)
END ; Err("too many files open", f, error)
IF ~done & ((errno = Unix.EACCES) OR (errno = Unix.EROFS) OR (errno = Unix.EAGAIN)) THEN END
(* errno EAGAIN observed on Solaris 2.4 *) END;
fd := Unix.Open(path, SHORT(SYSTEM.VAL(LONGINT, Unix.rdonly)), SHORT(SYSTEM.VAL(LONGINT, {}))); done := fd >= 0; errno := Unix.errno() IF ~done & Platform.Inaccessible(error) THEN
END ; error := Platform.OldRO(path, fd); done := error = 0;
IF (~done) & (errno # Unix.ENOENT) THEN END;
Console.String("warning Files0.Old "); Console.String(name); IF (~done) & (~Platform.Absent(error)) THEN
Console.String(" errno = "); Console.Int(errno, 0); Console.Ln; Console.String("Warning: Files.Old "); Console.String(name);
END ; Console.String(" error = "); Console.Int(error, 0); Console.Ln;
END;
IF done THEN IF done THEN
res := Unix.Fstat(fd, stat); (* Console.String(" fd = "); Console.Int(fd,1); Console.Ln; *)
f := CacheEntry(stat.dev, stat.ino, stat.mtime); error := Platform.Identify(fd, identity);
IF f # NIL THEN res := Unix.Close(fd); RETURN f f := CacheEntry(identity);
ELSIF fd >= fileTabSize THEN res := Unix.Close(fd); Err("too many files open", f, 0) IF f # NIL THEN error := Platform.Close(fd); RETURN f
ELSE NEW(f); fileTab[fd] := SYSTEM.VAL(LONGINT, f); INC(Kernel.nofiles); Kernel.RegisterObject(f, Finalize); ELSIF fd >= fileTabSize THEN
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.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; 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 RETURN f
END END
ELSIF dir = "" THEN RETURN NIL ELSIF dir = "" THEN RETURN NIL
@ -282,24 +352,26 @@ END ;
END Old; END Old;
PROCEDURE Purge* (f: File); PROCEDURE Purge* (f: File);
VAR i: INTEGER; stat: Unix.Status; res: LONGINT; VAR i: INTEGER; identity: Platform.FileIdentity; error: Platform.ErrorCode;
BEGIN i := 0; BEGIN i := 0;
WHILE i < nofbufs DO 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) INC(i)
END ; END;
IF f.fd # noDesc THEN res := Unix.Ftruncate(f.fd, 0); res := Unix.Lseek(f.fd, 0, 0) 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; 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; END Purge;
PROCEDURE GetDate* (f: File; VAR t, d: LONGINT); 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 BEGIN
Create(f); res := Unix.Fstat(f.fd, stat); Create(f); error := Platform.Identify(f.fd, identity);
time := localtime(stat.mtime); Platform.MTimeAsClock(identity, t, d)
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 GetDate; END GetDate;
PROCEDURE Pos* (VAR r: Rider): LONGINT; PROCEDURE Pos* (VAR r: Rider): LONGINT;
@ -307,12 +379,19 @@ END ;
END Pos; END Pos;
PROCEDURE Set* (VAR r: Rider; f: File; pos: LONGINT); 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 BEGIN
IF f # NIL THEN 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; 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 i < nofbufs THEN
IF f.bufs[i] = NIL THEN NEW(buf); buf.chg := FALSE; buf.org := -1; buf.f := f; f.bufs[i] := buf 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] ELSE buf := f.bufs[i]
@ -321,20 +400,20 @@ END ;
f.swapper := (f.swapper + 1) MOD nofbufs; f.swapper := (f.swapper + 1) MOD nofbufs;
buf := f.bufs[f.swapper]; buf := f.bufs[f.swapper];
Flush(buf) Flush(buf)
END ; END;
IF buf.org # org THEN IF buf.org # org THEN
IF org = f.len THEN buf.size := 0 IF org = f.len THEN buf.size := 0
ELSE Create(f); ELSE Create(f);
IF f.pos # org THEN res := Unix.Lseek(f.fd, org, 0) END ; IF f.pos # org THEN error := Platform.Seek(f.fd, org, Platform.SeekSet) END;
n := Unix.ReadBlk(f.fd, buf.data); error := Platform.ReadBuf(f.fd, buf.data, n);
IF n < 0 THEN Err("read from file not done", f, Unix.errno()) END ; IF error # 0 THEN Err("read from file not done", f, error) END;
f.pos := org + n; f.pos := org + n;
buf.size := n buf.size := n
END ; END;
buf.org := org; buf.chg := FALSE buf.org := org; buf.chg := FALSE
END END
ELSE buf := NIL; org := 0; offset := 0 ELSE buf := NIL; org := 0; offset := 0
END ; END;
r.buf := buf; r.org := org; r.offset := offset; r.eof := FALSE; r.res := 0 r.buf := buf; r.org := org; r.offset := offset; r.eof := FALSE; r.res := 0
END Set; END Set;
@ -342,33 +421,33 @@ END ;
VAR offset: LONGINT; buf: Buffer; VAR offset: LONGINT; buf: Buffer;
BEGIN BEGIN
buf := r.buf; offset := r.offset; 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 IF (offset < buf.size) THEN
x := buf.data[offset]; r.offset := offset + 1 x := buf.data[offset]; r.offset := offset + 1
ELSIF r.org + offset < buf.f.len THEN ELSIF r.org + offset < buf.f.len THEN
Set(r, r.buf.f, r.org + offset); Set(r, r.buf.f, r.org + offset);
x := r.buf.data[0]; r.offset := 1 x := r.buf.data[0]; r.offset := 1
ELSE ELSE
x := 0X; r.eof := TRUE x := 0X; r.eof := TRUE
END END
END Read; END Read;
PROCEDURE ReadBytes* (VAR r: Rider; VAR x: ARRAY OF SYSTEM.BYTE; n: LONGINT); PROCEDURE ReadBytes* (VAR r: Rider; VAR x: ARRAY OF SYSTEM.BYTE; n: LONGINT);
VAR xpos, min, restInBuf, offset: LONGINT; buf: Buffer; VAR xpos, min, restInBuf, offset: LONGINT; buf: Buffer;
BEGIN BEGIN
IF n > LEN(x) THEN IdxTrap END ; IF n > LEN(x) THEN IdxTrap END;
xpos := 0; buf := r.buf; offset := r.offset; xpos := 0; buf := r.buf; offset := r.offset;
WHILE n > 0 DO WHILE n > 0 DO
IF (r.org # buf.org) OR (offset >= bufsize) THEN IF (r.org # buf.org) OR (offset >= bufsize) THEN
Set(r, buf.f, r.org + offset); Set(r, buf.f, r.org + offset);
buf := r.buf; offset := r.offset buf := r.buf; offset := r.offset
END ; END;
restInBuf := buf.size - offset; restInBuf := buf.size - offset;
IF restInBuf = 0 THEN r.res := n; r.eof := TRUE; RETURN 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); SYSTEM.MOVE(SYSTEM.ADR(buf.data) + offset, SYSTEM.ADR(x) + xpos, min);
INC(offset, min); r.offset := offset; INC(xpos, min); DEC(n, min) INC(offset, min); r.offset := offset; INC(xpos, min); DEC(n, min)
END ; END;
r.res := 0; r.eof := FALSE r.res := 0; r.eof := FALSE
END ReadBytes; END ReadBytes;
@ -388,32 +467,32 @@ END ;
IF (r.org # buf.org) OR (offset >= bufsize) THEN IF (r.org # buf.org) OR (offset >= bufsize) THEN
Set(r, buf.f, r.org + offset); Set(r, buf.f, r.org + offset);
buf := r.buf; offset := r.offset buf := r.buf; offset := r.offset
END ; END;
buf.data[offset] := x; buf.data[offset] := x;
buf.chg := TRUE; buf.chg := TRUE;
IF offset = buf.size THEN IF offset = buf.size THEN
INC(buf.size); INC(buf.f.len) INC(buf.size); INC(buf.f.len)
END ; END;
r.offset := offset + 1; r.res := 0 r.offset := offset + 1; r.res := 0
END Write; END Write;
PROCEDURE WriteBytes* (VAR r: Rider; VAR x: ARRAY OF SYSTEM.BYTE; n: LONGINT); PROCEDURE WriteBytes* (VAR r: Rider; VAR x: ARRAY OF SYSTEM.BYTE; n: LONGINT);
VAR xpos, min, restInBuf, offset: LONGINT; buf: Buffer; VAR xpos, min, restInBuf, offset: LONGINT; buf: Buffer;
BEGIN BEGIN
IF n > LEN(x) THEN IdxTrap END ; IF n > LEN(x) THEN IdxTrap END;
xpos := 0; buf := r.buf; offset := r.offset; xpos := 0; buf := r.buf; offset := r.offset;
WHILE n > 0 DO WHILE n > 0 DO
IF (r.org # buf.org) OR (offset >= bufsize) THEN IF (r.org # buf.org) OR (offset >= bufsize) THEN
Set(r, buf.f, r.org + offset); Set(r, buf.f, r.org + offset);
buf := r.buf; offset := r.offset buf := r.buf; offset := r.offset
END ; END;
restInBuf := bufsize - offset; 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); SYSTEM.MOVE(SYSTEM.ADR(x) + xpos, SYSTEM.ADR(buf.data) + offset, min);
INC(offset, min); r.offset := offset; 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 INC(xpos, min); DEC(n, min); buf.chg := TRUE
END ; END;
r.res := 0 r.res := 0
END WriteBytes; END WriteBytes;
@ -426,9 +505,9 @@ PROCEDURE Write* (VAR r: Rider; x: SYSTEM.BYTE);
VAR buf: Buffer; offset: LONGINT; VAR buf: Buffer; offset: LONGINT;
BEGIN BEGIN
buf := r.buf; offset := r.offset; 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; 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 buf.data[offset] := x; r.offset := offset + 1; buf.chg := TRUE
END Write; END Write;
@ -442,7 +521,7 @@ BEGIN
IF r.org + offset >= buf.f.len THEN x := 0X; r.eof := TRUE; RETURN 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 ELSE Set(r, buf.f, r.org + offset); buf := r.buf; offset := r.offset
END END
END ; END;
x := buf.data[offset]; r.offset := offset + 1 x := buf.data[offset]; r.offset := offset + 1
END Read; END Read;
@ -450,73 +529,91 @@ but this would also affect Set, Length, and Flush.
Especially Length would become fairly complex. Especially Length would become fairly complex.
*) *)
PROCEDURE Delete* (name: ARRAY OF CHAR; VAR res: INTEGER); PROCEDURE Delete*(name: ARRAY OF CHAR; VAR res: INTEGER);
BEGIN BEGIN res := Platform.Unlink(name) END Delete;
res := SHORT(Unix.Unlink(name));
res := SHORT(Unix.errno())
END Delete;
PROCEDURE Rename* (old, new: ARRAY OF CHAR; VAR res: INTEGER); PROCEDURE Rename* (old, new: ARRAY OF CHAR; VAR res: INTEGER);
VAR fdold, fdnew: INTEGER; n, errno, r: LONGINT; VAR
ostat, nstat: Unix.Status; fdold, fdnew: Platform.FileHandle;
n: LONGINT;
error, ignore: Platform.ErrorCode;
oldidentity, newidentity: Platform.FileIdentity;
buf: ARRAY 4096 OF CHAR; buf: ARRAY 4096 OF CHAR;
BEGIN BEGIN
r := Unix.Stat(old, ostat); (*
IF r >= 0 THEN Console.String("Files.Rename old = "); Console.String(old);
r := Unix.Stat(new, nstat); Console.String(", new = "); Console.String(new); Console.Ln;
IF (r >= 0) & ((ostat.dev # nstat.dev) OR (ostat.ino # nstat.ino)) THEN *)
Delete(new, res); (* work around stale nfs handles *) error := Platform.IdentifyByName(old, oldidentity);
END ; IF error = 0 THEN
r := Unix.Rename(old, new); error := Platform.IdentifyByName(new, newidentity);
IF r < 0 THEN res := SHORT(Unix.errno()); IF (error # 0) & ~Platform.SameFile(oldidentity, newidentity) THEN
IF res = Unix.EXDEV THEN (* cross device link, move the file *) Delete(new, error); (* work around stale nfs handles *)
fdold := Unix.Open(old, SHORT(SYSTEM.VAL(LONGINT, Unix.rdonly)), SHORT(SYSTEM.VAL(LONGINT, {}))); END;
IF fdold < 0 THEN res := 2; RETURN END ; error := Platform.Rename(old, new);
fdnew := Unix.Open(new, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr + Unix.creat + Unix.trunc)), SHORT(SYSTEM.VAL(LONGINT, {2, 4,5, 7,8}))); (* Console.String("Platform.Rename error code "); Console.Int(error,1); Console.Ln; *)
IF fdnew < 0 THEN r := Unix.Close(fdold); res := 3; RETURN END ; IF ~Platform.DifferentFilesystems(error) THEN
n := Unix.Read(fdold, SYSTEM.ADR(buf), bufsize); res := error; RETURN
WHILE n > 0 DO ELSE
r := Unix.Write(fdnew, SYSTEM.ADR(buf), n); (* cross device link, move the file *)
IF r < 0 THEN errno := Unix.errno(); r := Unix.Close(fdold); r := Unix.Close(fdnew); error := Platform.OldRO(old, fdold);
Err("cannot move file", NIL, errno) IF error # 0 THEN res := 2; RETURN END;
END ; error := Platform.New(new, fdnew);
n := Unix.Read(fdold, SYSTEM.ADR(buf), bufsize) IF error # 0 THEN error := Platform.Close(fdold); res := 3; RETURN END;
END ; error := Platform.Read(fdold, SYSTEM.ADR(buf), bufsize, n);
errno := Unix.errno(); WHILE n > 0 DO
r := Unix.Close(fdold); r := Unix.Close(fdnew); error := Platform.Write(fdnew, SYSTEM.ADR(buf), n);
IF n = 0 THEN r := Unix.Unlink(old); res := 0 IF error # 0 THEN
ELSE Err("cannot move file", NIL, errno) ignore := Platform.Close(fdold);
END ; ignore := Platform.Close(fdnew);
ELSE RETURN (* res is Unix.Rename return code *) Err("cannot move file", NIL, error)
END END;
END ; error := Platform.Read(fdold, SYSTEM.ADR(buf), bufsize, n);
res := 0 END;
ELSE res := 2 (* old file not found *) 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
END Rename; END Rename;
PROCEDURE Register* (f: File); 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 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); Close(f);
IF f.registerName # "" THEN IF f.registerName # "" THEN
Rename(f.workName, f.registerName, errno); Rename(f.workName, f.registerName, errcode);
IF errno # 0 THEN COPY(f.registerName, file); HALT(99) END ; (*
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 f.workName := f.registerName; f.registerName := ""; f.tempFile := FALSE
END END
END Register; END Register;
PROCEDURE ChangeDirectory*(path: ARRAY OF CHAR; VAR res: INTEGER); PROCEDURE ChangeDirectory*(path: ARRAY OF CHAR; VAR res: INTEGER);
BEGIN BEGIN
res := SHORT(Unix.Chdir(path)); res := Platform.Chdir(path);
getcwd(Kernel.CWD)
END ChangeDirectory; END ChangeDirectory;
PROCEDURE FlipBytes(VAR src, dest: ARRAY OF SYSTEM.BYTE); PROCEDURE FlipBytes(VAR src, dest: ARRAY OF SYSTEM.BYTE);
VAR i, j: LONGINT; VAR i, j: LONGINT;
BEGIN 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 WHILE i > 0 DO DEC(i); dest[j] := src[i]; INC(j) END
ELSE SYSTEM.MOVE(SYSTEM.ADR(src), SYSTEM.ADR(dest), LEN(src)) ELSE SYSTEM.MOVE(SYSTEM.ADR(src), SYSTEM.ADR(dest), LEN(src))
END END
@ -531,35 +628,51 @@ Especially Length would become fairly complex.
BEGIN ReadBytes(R, b, 2); BEGIN ReadBytes(R, b, 2);
x := ORD(b[0]) + ORD(b[1])*256 x := ORD(b[0]) + ORD(b[1])*256
END ReadInt; END ReadInt;
PROCEDURE ReadLInt* (VAR R: Rider; VAR x: LONGINT); PROCEDURE ReadLInt* (VAR R: Rider; VAR x: LONGINT);
VAR b: ARRAY 4 OF CHAR; VAR b: ARRAY 4 OF CHAR;
BEGIN ReadBytes(R, b, 4); BEGIN ReadBytes(R, b, 4);
x := ORD(b[0]) + ORD(b[1])*100H + ORD(b[2])*10000H + ORD(b[3])*1000000H x := ORD(b[0]) + ORD(b[1])*100H + ORD(b[2])*10000H + ORD(b[3])*1000000H
END ReadLInt; END ReadLInt;
PROCEDURE ReadSet* (VAR R: Rider; VAR x: SET); PROCEDURE ReadSet* (VAR R: Rider; VAR x: SET);
VAR b: ARRAY 4 OF CHAR; VAR b: ARRAY 4 OF CHAR;
BEGIN ReadBytes(R, b, 4); BEGIN ReadBytes(R, b, 4);
x := SYSTEM.VAL(SET, ORD(b[0]) + ORD(b[1])*100H + ORD(b[2])*10000H + ORD(b[3])*1000000H) x := SYSTEM.VAL(SET, ORD(b[0]) + ORD(b[1])*100H + ORD(b[2])*10000H + ORD(b[3])*1000000H)
END ReadSet; END ReadSet;
PROCEDURE ReadReal* (VAR R: Rider; VAR x: REAL); PROCEDURE ReadReal* (VAR R: Rider; VAR x: REAL);
VAR b: ARRAY 4 OF CHAR; VAR b: ARRAY 4 OF CHAR;
BEGIN ReadBytes(R, b, 4); FlipBytes(b, x) BEGIN ReadBytes(R, b, 4); FlipBytes(b, x)
END ReadReal; END ReadReal;
PROCEDURE ReadLReal* (VAR R: Rider; VAR x: LONGREAL); PROCEDURE ReadLReal* (VAR R: Rider; VAR x: LONGREAL);
VAR b: ARRAY 8 OF CHAR; VAR b: ARRAY 8 OF CHAR;
BEGIN ReadBytes(R, b, 8); FlipBytes(b, x) BEGIN ReadBytes(R, b, 8); FlipBytes(b, x)
END ReadLReal; END ReadLReal;
PROCEDURE ReadString* (VAR R: Rider; VAR x: ARRAY OF CHAR); PROCEDURE ReadString* (VAR R: Rider; VAR x: ARRAY OF CHAR);
VAR i: INTEGER; ch: CHAR; VAR i: INTEGER; ch: CHAR;
BEGIN i := 0; BEGIN i := 0;
REPEAT Read(R, ch); x[i] := ch; INC(i) UNTIL ch = 0X REPEAT Read(R, ch); x[i] := ch; INC(i) UNTIL ch = 0X
END ReadString; 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); PROCEDURE ReadNum* (VAR R: Rider; VAR x: LONGINT);
VAR s: SHORTINT; ch: CHAR; n: LONGINT; VAR s: SHORTINT; ch: CHAR; n: LONGINT;
BEGIN s := 0; n := 0; Read(R, ch); 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) ); INC(n, ASH(ORD(ch) MOD 64 - ORD(ch) DIV 64 * 64, s) );
x := n x := n
END ReadNum; END ReadNum;
PROCEDURE WriteBool* (VAR R: Rider; x: BOOLEAN); PROCEDURE WriteBool* (VAR R: Rider; x: BOOLEAN);
BEGIN Write(R, SYSTEM.VAL(CHAR, x)) BEGIN Write(R, SYSTEM.VAL(CHAR, x))
END WriteBool; END WriteBool;
PROCEDURE WriteInt* (VAR R: Rider; x: INTEGER); PROCEDURE WriteInt* (VAR R: Rider; x: INTEGER);
VAR b: ARRAY 2 OF CHAR; VAR b: ARRAY 2 OF CHAR;
BEGIN b[0] := CHR(x); b[1] := CHR(x DIV 256); BEGIN b[0] := CHR(x); b[1] := CHR(x DIV 256);
WriteBytes(R, b, 2); WriteBytes(R, b, 2);
END WriteInt; END WriteInt;
PROCEDURE WriteLInt* (VAR R: Rider; x: LONGINT); PROCEDURE WriteLInt* (VAR R: Rider; x: LONGINT);
VAR b: ARRAY 4 OF CHAR; VAR b: ARRAY 4 OF CHAR;
BEGIN BEGIN
b[0] := CHR(x); b[1] := CHR(x DIV 100H); b[2] := CHR(x DIV 10000H); b[3] := CHR(x DIV 1000000H); 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); WriteBytes(R, b, 4);
END WriteLInt; END WriteLInt;
PROCEDURE WriteSet* (VAR R: Rider; x: SET); PROCEDURE WriteSet* (VAR R: Rider; x: SET);
VAR b: ARRAY 4 OF CHAR; i: LONGINT; VAR b: ARRAY 4 OF CHAR; i: LONGINT;
BEGIN i := SYSTEM.VAL(LONGINT, x); 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); 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); WriteBytes(R, b, 4);
END WriteSet; END WriteSet;
PROCEDURE WriteReal* (VAR R: Rider; x: REAL); PROCEDURE WriteReal* (VAR R: Rider; x: REAL);
VAR b: ARRAY 4 OF CHAR; VAR b: ARRAY 4 OF CHAR;
BEGIN FlipBytes(x, b); WriteBytes(R, b, 4) BEGIN FlipBytes(x, b); WriteBytes(R, b, 4)
END WriteReal; END WriteReal;
PROCEDURE WriteLReal* (VAR R: Rider; x: LONGREAL); PROCEDURE WriteLReal* (VAR R: Rider; x: LONGREAL);
VAR b: ARRAY 8 OF CHAR; VAR b: ARRAY 8 OF CHAR;
BEGIN FlipBytes(x, b); WriteBytes(R, b, 8) BEGIN FlipBytes(x, b); WriteBytes(R, b, 8)
END WriteLReal; END WriteLReal;
PROCEDURE WriteString* (VAR R: Rider; x: ARRAY [1] OF CHAR); PROCEDURE WriteString* (VAR R: Rider; x: ARRAY [1] OF CHAR);
VAR i: INTEGER; VAR i: INTEGER;
BEGIN i := 0; BEGIN i := 0;
WHILE x[i] # 0X DO INC(i) END ; WHILE x[i] # 0X DO INC(i) END;
WriteBytes(R, x, i+1) WriteBytes(R, x, i+1)
END WriteString; END WriteString;
PROCEDURE WriteNum* (VAR R: Rider; x: LONGINT); PROCEDURE WriteNum* (VAR R: Rider; x: LONGINT);
BEGIN BEGIN
WHILE (x < - 64) OR (x > 63) DO Write(R, CHR(x MOD 128 + 128)); x := x DIV 128 END; 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)) Write(R, CHR(x MOD 128))
END WriteNum; END WriteNum;
PROCEDURE GetName*(f: File; VAR name: ARRAY OF CHAR);
BEGIN
COPY (f.workName, name);
END GetName;
PROCEDURE Finalize(o: SYSTEM.PTR); PROCEDURE Finalize(o: SYSTEM.PTR);
VAR f: File; res: LONGINT; VAR f: File; res: LONGINT;
BEGIN BEGIN
f := SYSTEM.VAL(File, o); 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 IF f.fd >= 0 THEN
fileTab[f.fd] := 0; res := Unix.Close(f.fd); f.fd := -1; DEC(Kernel.nofiles); fileTab[f.fd] := 0; res := Platform.Close(f.fd); f.fd := -1; DEC(Heap.FileCount);
IF f.tempFile THEN res := Unix.Unlink(f.workName) END IF f.tempFile THEN res := Platform.Unlink(f.workName) END
END END
END Finalize; 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; PROCEDURE Init;
VAR i: LONGINT; VAR i: LONGINT;
BEGIN BEGIN
i := 0; WHILE i < fileTabSize DO fileTab[i] := 0; INC(i) END ; i := 0; WHILE i < fileTabSize DO fileTab[i] := 0; INC(i) END;
tempno := -1; Kernel.nofiles := 0 tempno := -1;
Heap.FileCount := 0;
SearchPath := NIL;
HOME := ""; Platform.GetEnv("HOME", HOME);
END Init; END Init;
BEGIN Init BEGIN Init
END Files0. END Files.

337
src/system/Heap.Mod
View file

@ -1,60 +1,52 @@
(* MODULE Heap;
* 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 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; ModNameLen = 20;
CmdNameLen = 24; CmdNameLen = 24;
SZL = SIZE(LONGINT); SZL = SIZE(LONGINT);
Unit = 4*SZL; (* smallest possible heap block *) Unit = 4*SZL; (* smallest possible heap block *)
nofLists = 9; (* number of free_lists *) nofLists = 9; (* number of free_lists *)
heapSize0 = 8000*Unit; (* startup heap size *) heapSize0 = 8000*Unit; (* startup heap size *)
(* all blocks look the same: (* all blocks look the same:
free blocks describe themselves: size = Unit free blocks describe themselves: size = Unit
tag = &tag++ tag = &tag++
->blksize ->block size
sentinel = -SZL sentinel = -SZL
next next
*) *)
(* heap chunks *) (* heap chunks *)
nextChnkOff = 0; (* next heap chunk, sorted ascendingly! *) nextChnkOff = LONG(LONG(0)); (* next heap chunk, sorted ascendingly! *)
endOff = SZL; (* end of heap chunk *) endOff = LONG(LONG(SZL)); (* end of heap chunk *)
blkOff = 3*SZL; (* first block in a chunk *) blkOff = LONG(LONG(3*SZL)); (* first block in a chunk *)
(* heap blocks *) (* heap blocks *)
tagOff = 0; (* block starts with tag *) tagOff = LONG(LONG(0)); (* block starts with tag *)
sizeOff = SZL; (* block size in free block relative to block start *) sizeOff = LONG(LONG(SZL)); (* block size in free block relative to block start *)
sntlOff = 2*SZL; (* pointer offset table sentinel in free block relative to block start *) sntlOff = LONG(LONG(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 *) nextOff = LONG(LONG(3*SZL)); (* next pointer in free block relative to block start *)
NoPtrSntl = LONG(LONG(-SZL)); NoPtrSntl = LONG(LONG(-SZL));
LongZero = LONG(LONG(0));
TYPE TYPE
ModuleName = ARRAY ModNameLen OF CHAR; ModuleName = ARRAY ModNameLen OF CHAR;
CmdName = ARRAY CmdNameLen OF CHAR; CmdName = ARRAY CmdNameLen OF CHAR;
Module = POINTER TO ModuleDesc; Module = POINTER TO ModuleDesc;
Cmd = POINTER TO CmdDesc; Cmd = POINTER TO CmdDesc;
EnumProc = PROCEDURE(P: PROCEDURE(p: SYSTEM.PTR));
EnumProc = PROCEDURE(P: PROCEDURE(p: SYSTEM.PTR));
ModuleDesc = RECORD ModuleDesc = RECORD
next: Module; next: Module;
name: ModuleName; name: ModuleName;
refcnt: LONGINT; refcnt: LONGINT;
cmds: Cmd; cmds: Cmd;
types: LONGINT; types: LONGINT;
enumPtrs: EnumProc; enumPtrs: EnumProc;
reserved1, reserved2: LONGINT reserved1, reserved2: LONGINT
END ; END ;
@ -64,16 +56,16 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
CmdDesc = RECORD CmdDesc = RECORD
next: Cmd; next: Cmd;
name: CmdName; name: CmdName;
cmd: Command cmd: Command
END ; END ;
Finalizer = PROCEDURE(obj: SYSTEM.PTR); Finalizer = PROCEDURE(obj: SYSTEM.PTR);
FinNode = POINTER TO FinDesc; FinNode = POINTER TO FinDesc;
FinDesc = RECORD FinDesc = RECORD
next: FinNode; next: FinNode;
obj: LONGINT; (* weak pointer *) obj: LONGINT; (* weak pointer *)
marked: BOOLEAN; marked: BOOLEAN;
finalize: Finalizer; finalize: Finalizer;
END ; END ;
@ -81,42 +73,66 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
(* the list of loaded (=initialization started) modules *) (* the list of loaded (=initialization started) modules *)
modules*: SYSTEM.PTR; modules*: SYSTEM.PTR;
freeList: ARRAY nofLists + 1 OF LONGINT; (* dummy, 16, 32, 48, 64, 80, 96, 112, 128, sentinel *) freeList: ARRAY nofLists + 1 OF LONGINT; (* dummy, 16, 32, 48, 64, 80, 96, 112, 128, sentinel *)
bigBlocks, allocated*: LONGINT; bigBlocks: LONGINT;
firstTry: BOOLEAN; allocated*: LONGINT;
firstTry: BOOLEAN;
(* extensible heap *) (* extensible heap *)
heap, (* the sorted list of heap chunks *) heap: LONGINT; (* the sorted list of heap chunks *)
heapend, (* max possible pointer value (used for stack collection) *) heapend: LONGINT; (* max possible pointer value (used for stack collection) *)
heapsize*: LONGINT; (* the sum of all heap chunk sizes *) heapsize*: LONGINT; (* the sum of all heap chunk sizes *)
(* finalization candidates *) (* finalization candidates *)
fin: FinNode; fin: FinNode;
(* garbage collector locking *) (* 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*;
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;
BEGIN BEGIN
oldflag := flag; INC(lockdepth);
flag := TRUE; END Lock;
RETURN oldflag;
END TAS; 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; PROCEDURE REGMOD*(VAR name: ModuleName; enumPtrs: EnumProc): SYSTEM.PTR;
VAR m: Module; VAR m: Module;
BEGIN BEGIN
IF name = "SYSTEM" THEN (* cannot use NEW *) (* REGMOD is called at the start of module initialisation code before that modules
SYSTEM.NEW(m, SIZE(ModuleDesc)); m.cmds := NIL type descriptors have been set up. 'NEW' depends on the Heap modules type
ELSE NEW(m) descriptors being ready for use, therefore, just for the Heap module itself, we
END ; 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); COPY(name, m.name); m.refcnt := 0; m.enumPtrs := enumPtrs; m.next := SYSTEM.VAL(Module, modules);
modules := m; modules := m;
RETURN m RETURN m
@ -124,7 +140,16 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
PROCEDURE REGCMD*(m: Module; VAR name: CmdName; cmd: Command); PROCEDURE REGCMD*(m: Module; VAR name: CmdName; cmd: Command);
VAR c: Cmd; 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 COPY(name, c.name); c.cmd := cmd; c.next := m.cmds; m.cmds := c
END REGCMD; END REGCMD;
@ -136,13 +161,17 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
BEGIN INC(m.refcnt) BEGIN INC(m.refcnt)
END INCREF; END INCREF;
PROCEDURE -ExternPlatformOSAllocate "extern LONGINT Platform_OSAllocate(LONGINT size);";
PROCEDURE -OSAllocate(size: LONGINT): LONGINT "Platform_OSAllocate(size)";
PROCEDURE NewChunk(blksz: LONGINT): LONGINT; PROCEDURE NewChunk(blksz: LONGINT): LONGINT;
VAR chnk: LONGINT; VAR chnk: LONGINT;
BEGIN BEGIN
chnk := malloc(blksz + blkOff); chnk := OSAllocate(blksz + blkOff);
IF chnk # 0 THEN IF chnk # 0 THEN
SYSTEM.PUT(chnk + endOff, chnk + (blkOff + blksz)); SYSTEM.PUT(chnk + endOff, chnk + (blkOff + blksz));
SYSTEM.PUT(chnk + blkOff, chnk + (blkOff + sizeOff)); SYSTEM.PUT(chnk + blkOff, chnk + (blkOff + sizeOff));
SYSTEM.PUT(chnk + (blkOff + sizeOff), blksz); SYSTEM.PUT(chnk + (blkOff + sizeOff), blksz);
SYSTEM.PUT(chnk + (blkOff + sntlOff), NoPtrSntl); SYSTEM.PUT(chnk + (blkOff + sntlOff), NoPtrSntl);
SYSTEM.PUT(chnk + (blkOff + nextOff), bigBlocks); SYSTEM.PUT(chnk + (blkOff + nextOff), bigBlocks);
@ -152,6 +181,13 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
RETURN chnk RETURN chnk
END NewChunk; 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); PROCEDURE ExtendHeap(blksz: LONGINT);
VAR size, chnk, j, next: LONGINT; VAR size, chnk, j, next: LONGINT;
BEGIN BEGIN
@ -159,39 +195,48 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
ELSE size := 10000*Unit (* additional heuristics *) ELSE size := 10000*Unit (* additional heuristics *)
END ; END ;
chnk := NewChunk(size); chnk := NewChunk(size);
IF chnk # 0 THEN IF chnk # 0 THEN
(*sorted insertion*) (*sorted insertion*)
IF chnk < heap THEN IF chnk < heap THEN
SYSTEM.PUT(chnk, heap); heap := chnk SYSTEM.PUT(chnk, heap); heap := chnk
ELSE ELSE
j := heap; SYSTEM.GET(j, next); j := heap; next := FetchAddress(j);
WHILE (next # 0) & (chnk > next) DO j := next; SYSTEM.GET(j, next) END ; WHILE (next # 0) & (chnk > next) DO
j := next;
next := FetchAddress(j)
END;
SYSTEM.PUT(chnk, next); SYSTEM.PUT(j, chnk) SYSTEM.PUT(chnk, next); SYSTEM.PUT(j, chnk)
END ; END ;
IF next = 0 THEN SYSTEM.GET(chnk + endOff, heapend) END IF next = 0 THEN heapend := FetchAddress(chnk+endOff) END
END END
END ExtendHeap; END ExtendHeap;
PROCEDURE ^GC*(markStack: BOOLEAN); PROCEDURE ^GC*(markStack: BOOLEAN);
PROCEDURE NEWREC*(tag: LONGINT): SYSTEM.PTR; 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 BEGIN
Lock(); 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); ASSERT(blksz MOD Unit = 0);
i0 := blksz DIV Unit; i := i0; i0 := blksz DIV Unit; i := i0;
IF i < nofLists THEN adr := freeList[i]; IF i < nofLists THEN adr := freeList[i];
WHILE adr = 0 DO INC(i); adr := freeList[i] END WHILE adr = 0 DO INC(i); adr := freeList[i] END
END ; END ;
IF i < nofLists THEN (* unlink *) IF i < nofLists THEN (* unlink *)
SYSTEM.GET(adr + nextOff, next); next := FetchAddress(adr + nextOff);
freeList[i] := next; freeList[i] := next;
IF i # i0 THEN (* split *) IF i # i0 THEN (* split *)
di := i - i0; restsize := di * Unit; end := adr + restsize; di := i - i0; restsize := di * Unit; end := adr + restsize;
SYSTEM.PUT(end + sizeOff, blksz); SYSTEM.PUT(end + sizeOff, blksz);
SYSTEM.PUT(end + sntlOff, NoPtrSntl); SYSTEM.PUT(end + sntlOff, NoPtrSntl);
SYSTEM.PUT(end, end + sizeOff); SYSTEM.PUT(end, end + sizeOff);
SYSTEM.PUT(adr + sizeOff, restsize); SYSTEM.PUT(adr + sizeOff, restsize);
SYSTEM.PUT(adr + nextOff, freeList[di]); SYSTEM.PUT(adr + nextOff, freeList[di]);
freeList[di] := adr; freeList[di] := adr;
@ -219,18 +264,18 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
Unlock(); RETURN NIL Unlock(); RETURN NIL
END END
END ; END ;
SYSTEM.GET(adr+sizeOff, t); t := FetchAddress(adr+sizeOff);
IF t >= blksz THEN EXIT END ; IF t >= blksz THEN EXIT END ;
prev := adr; SYSTEM.GET(adr + nextOff, adr) prev := adr; adr := FetchAddress(adr + nextOff)
END ; END ;
restsize := t - blksz; end := adr + restsize; restsize := t - blksz; end := adr + restsize;
SYSTEM.PUT(end + sizeOff, blksz); SYSTEM.PUT(end + sizeOff, blksz);
SYSTEM.PUT(end + sntlOff, NoPtrSntl); SYSTEM.PUT(end + sntlOff, NoPtrSntl);
SYSTEM.PUT(end, end + sizeOff); SYSTEM.PUT(end, end + sizeOff);
IF restsize > nofLists * Unit THEN (*resize*) IF restsize > nofLists * Unit THEN (*resize*)
SYSTEM.PUT(adr + sizeOff, restsize) SYSTEM.PUT(adr + sizeOff, restsize)
ELSE (*unlink*) ELSE (*unlink*)
SYSTEM.GET(adr + nextOff, next); next := FetchAddress(adr + nextOff);
IF prev = 0 THEN bigBlocks := next IF prev = 0 THEN bigBlocks := next
ELSE SYSTEM.PUT(prev + nextOff, next); ELSE SYSTEM.PUT(prev + nextOff, next);
END ; END ;
@ -245,16 +290,16 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
END ; END ;
i := adr + 4*SZL; end := adr + blksz; i := adr + 4*SZL; end := adr + blksz;
WHILE i < end DO (*deliberately unrolled*) WHILE i < end DO (*deliberately unrolled*)
SYSTEM.PUT(i, LONG(LONG(0))); SYSTEM.PUT(i, LongZero);
SYSTEM.PUT(i + SZL, LONG(LONG(0))); SYSTEM.PUT(i + SZL, LongZero);
SYSTEM.PUT(i + 2*SZL, LONG(LONG(0))); SYSTEM.PUT(i + 2*SZL, LongZero);
SYSTEM.PUT(i + 3*SZL, LONG(LONG(0))); SYSTEM.PUT(i + 3*SZL, LongZero);
INC(i, 4*SZL) INC(i, 4*SZL)
END ; END ;
SYSTEM.PUT(adr + nextOff, LONG(LONG(0))); SYSTEM.PUT(adr + nextOff, LongZero);
SYSTEM.PUT(adr, tag); SYSTEM.PUT(adr, tag);
SYSTEM.PUT(adr + sizeOff, LONG(LONG(0))); SYSTEM.PUT(adr + sizeOff, LongZero);
SYSTEM.PUT(adr + sntlOff, LONG(LONG(0))); SYSTEM.PUT(adr + sntlOff, LongZero);
INC(allocated, blksz); INC(allocated, blksz);
Unlock(); Unlock();
RETURN SYSTEM.VAL(SYSTEM.PTR, adr + SZL) 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*) blksz := (size + (4*SZL + Unit - 1)) DIV Unit * Unit; (*size + tag + meta + blksz + sntnl + UnitAlignment*)
new := NEWREC(SYSTEM.ADR(blksz)); new := NEWREC(SYSTEM.ADR(blksz));
tag := SYSTEM.VAL(LONGINT, new) + blksz - 3*SZL; tag := SYSTEM.VAL(LONGINT, new) + blksz - 3*SZL;
SYSTEM.PUT(tag - SZL, LONG(LONG(0))); (*reserved for meta info*) SYSTEM.PUT(tag - SZL, LongZero); (*reserved for meta info*)
SYSTEM.PUT(tag, blksz); SYSTEM.PUT(tag, blksz);
SYSTEM.PUT(tag + SZL, NoPtrSntl); SYSTEM.PUT(tag + SZL, NoPtrSntl);
SYSTEM.PUT(SYSTEM.VAL(LONGINT, new) - SZL, tag); SYSTEM.PUT(SYSTEM.VAL(LONGINT, new) - SZL, tag);
Unlock(); Unlock();
RETURN new RETURN new
@ -278,28 +323,31 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
PROCEDURE Mark(q: LONGINT); PROCEDURE Mark(q: LONGINT);
VAR p, tag, fld, n, offset, tagbits: LONGINT; VAR p, tag, fld, n, offset, tagbits: LONGINT;
BEGIN BEGIN
IF q # 0 THEN SYSTEM.GET(q - SZL, tagbits); IF q # 0 THEN
IF ~ODD(tagbits) THEN tagbits := FetchAddress(q - SZL); (* Load the tag for the record at q *)
SYSTEM.PUT(q - SZL, tagbits + 1); IF ~ODD(tagbits) THEN (* If it has not already been marked *)
p := 0; tag := tagbits + SZL; SYSTEM.PUT(q - SZL, tagbits + 1); (* Mark it *)
p := 0;
tag := tagbits + SZL; (* Tag addresses first offset *)
LOOP LOOP
SYSTEM.GET(tag, offset); SYSTEM.GET(tag, offset); (* Get next ptr field offset *)
IF offset < 0 THEN IF offset < 0 THEN (* If sentinel. (Value is -8*(#fields+1) *)
SYSTEM.PUT(q - SZL, tag + offset + 1); SYSTEM.PUT(q - SZL, tag + offset + 1); (* Rotate base ptr into tag *)
IF p = 0 THEN EXIT END ; IF p = 0 THEN EXIT END ;
n := q; q := p; 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(tag, offset); fld := q + offset;
SYSTEM.GET(fld, p); SYSTEM.PUT(fld, n) p := FetchAddress(fld); SYSTEM.PUT(fld, SYSTEM.VAL(SYSTEM.PTR, n))
ELSE ELSE (* offset references a ptr field *)
fld := q + offset; fld := q + offset; (* Address the pointer *)
SYSTEM.GET(fld, n); n := FetchAddress(fld); (* Load the pointer *)
IF n # 0 THEN IF n # 0 THEN (* If pointer is not NIL *)
SYSTEM.GET(n - SZL, tagbits); tagbits := FetchAddress(n - SZL); (* Consider record pointed to by this field *)
IF ~ODD(tagbits) THEN IF ~ODD(tagbits) THEN
SYSTEM.PUT(n - SZL, tagbits + 1); SYSTEM.PUT(n - SZL, tagbits + 1);
SYSTEM.PUT(q - SZL, tag + 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 tag := tagbits
END END
END END
@ -321,42 +369,43 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
WHILE i < nofLists DO freeList[i] := 0; INC(i) END ; WHILE i < nofLists DO freeList[i] := 0; INC(i) END ;
freesize := 0; allocated := 0; chnk := heap; freesize := 0; allocated := 0; chnk := heap;
WHILE chnk # 0 DO WHILE chnk # 0 DO
adr := chnk + blkOff; SYSTEM.GET(chnk + endOff, end); adr := chnk + blkOff;
end := FetchAddress(chnk + endOff);
WHILE adr < end DO WHILE adr < end DO
SYSTEM.GET(adr, tag); tag := FetchAddress(adr);
IF ODD(tag) THEN (*marked*) IF ODD(tag) THEN (*marked*)
IF freesize > 0 THEN IF freesize > 0 THEN
start := adr - freesize; start := adr - freesize;
SYSTEM.PUT(start, start+SZL); SYSTEM.PUT(start, start+SZL);
SYSTEM.PUT(start+sizeOff, freesize); SYSTEM.PUT(start+sizeOff, freesize);
SYSTEM.PUT(start+sntlOff, NoPtrSntl); SYSTEM.PUT(start+sntlOff, NoPtrSntl);
i := freesize DIV Unit; freesize := 0; i := freesize DIV Unit; freesize := 0;
IF i < nofLists THEN SYSTEM.PUT(start + nextOff, freeList[i]); freeList[i] := start 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
END ; END ;
DEC(tag, 1); DEC(tag, 1);
SYSTEM.PUT(adr, tag); SYSTEM.PUT(adr, tag);
SYSTEM.GET(tag, size); size := FetchAddress(tag);
INC(allocated, size); INC(allocated, size);
INC(adr, size) INC(adr, size)
ELSE (*unmarked*) ELSE (*unmarked*)
SYSTEM.GET(tag, size); size := FetchAddress(tag);
INC(freesize, size); INC(freesize, size);
INC(adr, size) INC(adr, size)
END END
END ; END ;
IF freesize > 0 THEN (*collect last block*) IF freesize > 0 THEN (*collect last block*)
start := adr - freesize; start := adr - freesize;
SYSTEM.PUT(start, start+SZL); SYSTEM.PUT(start, start+SZL);
SYSTEM.PUT(start+sizeOff, freesize); SYSTEM.PUT(start+sizeOff, freesize);
SYSTEM.PUT(start+sntlOff, NoPtrSntl); SYSTEM.PUT(start+sntlOff, NoPtrSntl);
i := freesize DIV Unit; freesize := 0; i := freesize DIV Unit; freesize := 0;
IF i < nofLists THEN SYSTEM.PUT(start + nextOff, freeList[i]); freeList[i] := start 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
END ; END ;
SYSTEM.GET(chnk, chnk) chnk := FetchAddress(chnk)
END END
END Scan; END Scan;
@ -384,14 +433,14 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
chnk := heap; i := 0; lim := cand[n-1]; chnk := heap; i := 0; lim := cand[n-1];
WHILE (chnk # 0 ) & (chnk < lim) DO WHILE (chnk # 0 ) & (chnk < lim) DO
adr := chnk + blkOff; adr := chnk + blkOff;
SYSTEM.GET(chnk + endOff, lim1); lim1 := FetchAddress(chnk + endOff);
IF lim < lim1 THEN lim1 := lim END ; IF lim < lim1 THEN lim1 := lim END ;
WHILE adr < lim1 DO WHILE adr < lim1 DO
SYSTEM.GET(adr, tag); tag := FetchAddress(adr);
IF ODD(tag) THEN (*already marked*) IF ODD(tag) THEN (*already marked*)
SYSTEM.GET(tag-1, size); INC(adr, size) size := FetchAddress(tag-1); INC(adr, size)
ELSE ELSE
SYSTEM.GET(tag, size); size := FetchAddress(tag);
ptr := adr + SZL; ptr := adr + SZL;
WHILE cand[i] < ptr DO INC(i) END ; WHILE cand[i] < ptr DO INC(i) END ;
IF i = n THEN RETURN END ; IF i = n THEN RETURN END ;
@ -400,15 +449,16 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
adr := next adr := next
END END
END ; END ;
SYSTEM.GET(chnk, chnk) chnk := FetchAddress(chnk)
END END
END MarkCandidates; END MarkCandidates;
PROCEDURE CheckFin; PROCEDURE CheckFin;
VAR n: FinNode; tag: LONGINT; VAR n: FinNode; tag: LONGINT;
BEGIN n := fin; BEGIN
n := fin;
WHILE n # NIL DO 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) IF ~ODD(tag) THEN n.marked := FALSE; Mark(n.obj)
ELSE n.marked := TRUE ELSE n.marked := TRUE
END ; END ;
@ -425,7 +475,8 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
n.finalize(SYSTEM.VAL(SYSTEM.PTR, n.obj)); n.finalize(SYSTEM.VAL(SYSTEM.PTR, n.obj));
(* new nodes may have been pushed in n.finalize, therefore: *) (* new nodes may have been pushed in n.finalize, therefore: *)
IF prev = NIL THEN n := fin ELSE n := n.next END 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 END
END Finalize; END Finalize;
@ -439,6 +490,9 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
END END
END FINALL; END FINALL;
PROCEDURE -ExternMainStackFrame "extern LONGINT Platform_MainStackFrame;";
PROCEDURE -PlatformMainStackFrame(): LONGINT "Platform_MainStackFrame";
PROCEDURE MarkStack(n: LONGINT; VAR cand: ARRAY OF LONGINT); PROCEDURE MarkStack(n: LONGINT; VAR cand: ARRAY OF LONGINT);
VAR VAR
frame: SYSTEM.PTR; 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 > 0 THEN MarkStack(n-1, cand); (* flush register windows by means of recursive calls *)
IF n > 100 THEN RETURN END (* prevent tail recursion optimization *) IF n > 100 THEN RETURN END (* prevent tail recursion optimization *)
END ; END ;
IF n = 0 THEN IF n = 0 THEN
nofcand := 0; sp := SYSTEM.ADR(frame); nofcand := 0; sp := SYSTEM.ADR(frame);
stack0 := Mainfrm(); stack0 := PlatformMainStackFrame();
(* check for minimum alignment of pointers *) (* check for minimum alignment of pointers *)
inc := SYSTEM.ADR(align.p) - SYSTEM.ADR(align); inc := SYSTEM.ADR(align.p) - SYSTEM.ADR(align);
IF sp > stack0 THEN inc := -inc END ; 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; 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; cand: ARRAY 10000 OF LONGINT;
BEGIN BEGIN
IF (gclock = 0) OR (gclock = 1) & ~markStack THEN IF (lockdepth = 0) OR (lockdepth = 1) & ~markStack THEN
Lock(); Lock();
m := SYSTEM.VAL(Module, modules); m := SYSTEM.VAL(Module, modules);
WHILE m # NIL DO WHILE m # NIL DO
IF m.enumPtrs # NIL THEN m.enumPtrs(MarkP) END ; IF m.enumPtrs # NIL THEN m.enumPtrs(MarkP) END ;
m := m^.next m := m^.next
END ; END ;
@ -484,7 +538,7 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
(* generate register pressure to force callee saved registers to memory; (* generate register pressure to force callee saved registers to memory;
may be simplified by inlining OS calls or processor specific instructions 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; 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; 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); 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
END GC; END GC;
PROCEDURE REGFIN*(obj: SYSTEM.PTR; finalize: Finalizer); PROCEDURE RegisterFinalizer*(obj: SYSTEM.PTR; finalize: Finalizer);
VAR f: FinNode; VAR f: FinNode;
BEGIN NEW(f); BEGIN NEW(f);
f.obj := SYSTEM.VAL(LONGINT, obj); f.finalize := finalize; f.marked := TRUE; f.next := fin; fin := f f.obj := SYSTEM.VAL(LONGINT, obj); f.finalize := finalize; f.marked := TRUE;
END REGFIN; 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 BEGIN
heap := NewChunk(heapSize0); heap := NewChunk(heapSize0);
SYSTEM.GET(heap + endOff, heapend); heapend := FetchAddress(heap + endOff);
SYSTEM.PUT(heap, LONG(LONG(0))); SYSTEM.PUT(heap, LongZero);
allocated := 0; firstTry := TRUE; freeList[nofLists] := 1; gclock := 0 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 InitHeap;
END SYSTEM. END Heap.

200
src/system/Kernel0.Mod
View file

@ -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.

76
src/system/Oberon.Mod
View file

@ -2,9 +2,9 @@ MODULE Oberon;
(* this version should not have dependency on graphics -- noch *) (* this version should not have dependency on graphics -- noch *)
IMPORT Kernel, Texts, Args, Out := Console; IMPORT Platform, Texts, Args, Console;
TYPE
TYPE
ParList* = POINTER TO ParRec; ParList* = POINTER TO ParRec;
ParRec* = RECORD ParRec* = RECORD
@ -18,23 +18,26 @@ MODULE Oberon;
Log*: Texts.Text; Log*: Texts.Text;
Par*: ParList; (*actual parameters*) Par*: ParList; (*actual parameters*)
W : Texts.Writer; R: Texts.Reader;
OptionChar*: CHAR; W: Texts.Writer;
OptionChar*: CHAR;
(*clocks*) (*clocks*)
PROCEDURE GetClock* (VAR t, d: LONGINT); PROCEDURE GetClock* (VAR t, d: LONGINT);
BEGIN Kernel.GetClock(t, d) BEGIN Platform.GetClock(t, d)
END GetClock; END GetClock;
PROCEDURE Time* (): LONGINT; PROCEDURE Time* (): LONGINT;
BEGIN BEGIN
RETURN Kernel.Time() RETURN Platform.Time()
END Time; END Time;
PROCEDURE PopulateParams; PROCEDURE PopulateParams;
VAR W : Texts.Writer; VAR
i : INTEGER; W: Texts.Writer;
str : ARRAY 32 OF CHAR; i: INTEGER;
str: ARRAY 32 OF CHAR;
BEGIN BEGIN
i := 1; (* skip program name *) i := 1; (* skip program name *)
@ -52,47 +55,23 @@ MODULE Oberon;
Texts.Append (Par^.text, W.buf); Texts.Append (Par^.text, W.buf);
END PopulateParams; END PopulateParams;
(*
PROCEDURE DumpLog*;
VAR R : Texts.Reader;
ch : CHAR;
BEGIN
Texts.OpenReader(R, Log, 0);
REPEAT PROCEDURE GetSelection*(VAR text: Texts.Text; VAR beg, end, time: LONGINT);
Texts.Read(R, ch); BEGIN text := NIL; beg := 0; end := 0; time := 0;
Out.Char(ch); END GetSelection;
UNTIL R.eot;
END DumpLog;
*)
PROCEDURE TextToString(VAR T : Texts.Text; VAR string : ARRAY OF CHAR); (* --- Notifier for echoing all text appended to the log onto the console. --- *)
VAR R : Texts.Reader;
ch : CHAR; PROCEDURE LogNotifier(Log: Texts.Text; op: INTEGER; beg, end: LONGINT);
i : LONGINT; VAR ch: CHAR;
BEGIN BEGIN
COPY("", string); Texts.OpenReader(R, Log, beg);
Texts.OpenReader(R, T, 0); WHILE ~R.eot & (beg < end) DO
i := 0; Texts.Read(R, ch);
WHILE Texts.Pos(R) < T.len DO IF ch = 0DX THEN Console.Ln ELSE Console.Char(ch) END;
Texts.Read(R, ch); INC(beg)
string[i] := ch; END
INC(i); END LogNotifier;
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;
BEGIN BEGIN
NEW(Par); NEW(Par);
@ -103,4 +82,5 @@ BEGIN
PopulateParams; PopulateParams;
NEW(Log); NEW(Log);
Texts.Open(Log, ""); Texts.Open(Log, "");
Log.notify := LogNotifier;
END Oberon. END Oberon.

914
src/system/Platformunix.Mod
View file

@ -1,519 +1,551 @@
MODULE Unix; (* Josef Templ, 5.3.90 Linux system calls *) MODULE Platform;
(* 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 *)
IMPORT SYSTEM; IMPORT SYSTEM;
CONST CONST
StdIn- = 0;
(* various important constants *) StdOut- = 1;
StdErr- = 2;
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);
TYPE TYPE
(* cpp /usr/include/setjmp.h HaltProcedure = PROCEDURE(n: LONGINT);
struct __jmp_buf_tag SignalHandler = PROCEDURE(signal: INTEGER);
{
__jmp_buf __jmpbuf;
int __mask_was_saved;
__sigset_t __saved_mask;
};
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 FileIdentity* = RECORD
__jmp_buf is 24 bytes long in glibc on x86 volume*: LONGINT; (* dev on Unix filesystems, volume serial number on NTFS *)
256 bytes long in glibc on armv6 index*: LONGINT; (* inode on Unix filesystems, file id on NTFS *)
64 bytes long in glibc on x86_64 mtime*: LONGINT; (* File modification time, value is system dependent *)
*)
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*)
END; 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 <sys/stat.h>";
PROCEDURE -includeErrno() VAR
"#include <errno.h>"; 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() *) ArgVector-: LONGINT;
PROCEDURE -includeUnistd() HaltHandler: HaltProcedure;
"#include <unistd.h>"; TimeStart: LONGINT;
(* for system() *) SeekSet-: INTEGER;
PROCEDURE -includeStdlib() SeekCur-: INTEGER;
"#include <stdlib.h>"; SeekEnd-: INTEGER;
(* for nanosleep() *) nl-: ARRAY 3 OF CHAR; (* Platform specific newline representation *)
PROCEDURE -includeTime()
"#include <time.h>";
(* for select() *)
PROCEDURE -includeSelect()
"#include <sys/select.h>";
PROCEDURE -err(): INTEGER
"errno";
PROCEDURE errno*(): INTEGER; (* Unix headers to be included *)
BEGIN
RETURN err()
END errno;
PROCEDURE -Exit*(n: INTEGER) PROCEDURE -Aincludesystime '#include <sys/time.h>'; (* for gettimeofday *)
"exit(n)"; PROCEDURE -Aincludetime '#include <time.h>'; (* for localtime *)
PROCEDURE -Aincludesystypes '#include <sys/types.h>';
PROCEDURE -Aincludeunistd '#include <unistd.h>';
PROCEDURE -Aincludesysstat '#include <sys/stat.h>';
PROCEDURE -Aincludefcntl '#include <fcntl.h>';
PROCEDURE -Aincludeerrno '#include <errno.h>';
PROCEDURE -Astdlib '#include <stdlib.h>';
PROCEDURE -Astdio '#include <stdio.h>';
PROCEDURE -Aerrno '#include <errno.h>';
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 (* Error code tests *)
"gettimeofday(tv, tz)";
PROCEDURE -Read* (fd: INTEGER; buf, nbyte: LONGINT): LONGINT PROCEDURE -EMFILE(): ErrorCode 'EMFILE';
"read(fd, buf, nbyte)"; 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 PROCEDURE TooManyFiles*(e: ErrorCode): BOOLEAN;
"dup(fd)"; BEGIN RETURN (e = EMFILE()) OR (e = ENFILE()) END TooManyFiles;
PROCEDURE -Dup2*(fd1, fd2: INTEGER): INTEGER PROCEDURE NoSuchDirectory*(e: ErrorCode): BOOLEAN;
"dup(fd1, fd2)"; BEGIN RETURN e = ENOENT() END NoSuchDirectory;
PROCEDURE -Pipe*(fds : LONGINT): INTEGER PROCEDURE DifferentFilesystems*(e: ErrorCode): BOOLEAN;
"pipe(fds)"; BEGIN RETURN e = EXDEV() END DifferentFilesystems;
PROCEDURE -Getpid*(): INTEGER PROCEDURE Inaccessible*(e: ErrorCode): BOOLEAN;
"getpid()"; BEGIN RETURN (e = EACCES()) OR (e = EROFS()) OR (e = EAGAIN()) END Inaccessible;
PROCEDURE -Getuid*(): INTEGER PROCEDURE Absent*(e: ErrorCode): BOOLEAN;
"getuid()"; BEGIN RETURN (e = ENOENT()) END Absent;
PROCEDURE -Geteuid*(): INTEGER PROCEDURE TimedOut*(e: ErrorCode): BOOLEAN;
"geteuid()"; BEGIN RETURN (e = ETIMEDOUT()) END TimedOut;
PROCEDURE -Getgid*(): INTEGER PROCEDURE ConnectionFailed*(e: ErrorCode): BOOLEAN;
"getgid()"; 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 (* OS memory allocaton *)
"close(fd)";
PROCEDURE -stat(name: Name; VAR statbuf: Status): INTEGER PROCEDURE -allocate(size: LONGINT): LONGINT "(LONGINT)(uintptr_t)((void*)malloc((size_t)size))";
"stat((const char*)name, (struct stat*)statbuf)"; PROCEDURE OSAllocate*(size: LONGINT): LONGINT; BEGIN RETURN allocate(size) END OSAllocate;
PROCEDURE Stat*(name: Name; VAR statbuf: Status): INTEGER; PROCEDURE -free(address: LONGINT) "free((void*)(uintptr_t)address)";
VAR res: INTEGER; PROCEDURE OSFree*(address: LONGINT); BEGIN free(address) END OSFree;
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 -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 (* Program startup *)
"chmod(path, mode)";
PROCEDURE -Lseek*(fd: INTEGER; offset: LONGINT; origin: INTEGER): LONGINT PROCEDURE -ExternInitHeap "extern void Heap_InitHeap();";
"lseek(fd, offset, origin)"; PROCEDURE -HeapInitHeap() "Heap_InitHeap()";
PROCEDURE -Fsync*(fd: INTEGER): INTEGER PROCEDURE Init*(argc: INTEGER; argvadr: LONGINT);
"fsync(fd)"; 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 (* This function (Platform.Init) is called at program startup BEFORE any
"fcntl(fd, cmd, arg)"; 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 (* Program arguments and environment access *)
"rename(old, new)";
PROCEDURE -Chdir*(path: Name): INTEGER PROCEDURE -getenv(var: ARRAY OF CHAR): EnvPtr "(Platform_EnvPtr)getenv((char*)var)";
"chdir(path)";
PROCEDURE -Ioctl*(fd: INTEGER; request, arg: LONGINT): INTEGER PROCEDURE getEnv*(var: ARRAY OF CHAR; VAR val: ARRAY OF CHAR): BOOLEAN;
"ioctl(fd, request, arg)"; 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 PROCEDURE GetEnv*(var: ARRAY OF CHAR; VAR val: ARRAY OF CHAR);
"kill(pid, sig)"; BEGIN
IF ~ getEnv(var, val) THEN val[0] := 0X END;
END GetEnv;
PROCEDURE -Sigsetmask*(mask: INTEGER): INTEGER PROCEDURE GetArg*(n: INTEGER; VAR val: ARRAY OF CHAR);
"sigsetmask(mask)"; 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 PROCEDURE GetIntArg*(n: INTEGER; VAR val: LONGINT);
"(INTEGER)sleep(ms)"; 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 PROCEDURE ArgPos*(s: ARRAY OF CHAR): INTEGER;
"(INTEGER)nanosleep(req, rem)"; 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 (* Signals and traps *)
"connect(socket, &(name), namelen)";
PROCEDURE -Getsockname*(socket: INTEGER; VAR name: Sockaddr; VAR namelen: INTEGER): INTEGER PROCEDURE -sethandler(s: INTEGER; h: SignalHandler) "SystemSetHandler(s, (uintptr_t)h)";
"getsockname(socket, name, namelen)";
PROCEDURE -Bind*(socket: INTEGER; name: Sockaddr; namelen: INTEGER): INTEGER PROCEDURE SetInterruptHandler*(handler: SignalHandler);
"bind(socket, &(name), namelen)"; BEGIN sethandler(2, handler); END SetInterruptHandler;
PROCEDURE -Listen*(socket, backlog: INTEGER): INTEGER PROCEDURE SetQuitHandler*(handler: SignalHandler);
"listen(socket, backlog)"; BEGIN sethandler(3, handler); END SetQuitHandler;
PROCEDURE -Accept*(socket: INTEGER; VAR addr: Sockaddr; VAR addrlen: INTEGER): LONGINT PROCEDURE SetBadInstructionHandler*(handler: SignalHandler);
"accept(socket, addr, addrlen)"; 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); (* Time of day *)
VAR r : INTEGER;
BEGIN
r := sys(cmd);
END system;
PROCEDURE System*(cmd : ARRAY OF CHAR): INTEGER; PROCEDURE -gettimeval "struct timeval tv; gettimeofday(&tv,0)";
VAR r : INTEGER; PROCEDURE -tvsec(): LONGINT "tv.tv_sec";
BEGIN PROCEDURE -tvusec(): LONGINT "tv.tv_usec";
r := sys(cmd); PROCEDURE -sectotm(s: LONGINT) "struct tm *time = localtime((time_t*)&s)";
RETURN r PROCEDURE -tmsec(): LONGINT "(LONGINT)time->tm_sec";
END System; 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 PROCEDURE YMDHMStoClock(ye,mo,da,ho,mi,se: LONGINT; VAR t, d: LONGINT);
"sizeof(Unix_Status)"; 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 PROCEDURE GetClock*(VAR t, d: LONGINT);
"sizeof(struct stat)"; BEGIN
gettimeval; sectotm(tvsec());
YMDHMStoClock(tmyear(), tmmon(), tmmday(), tmhour(), tmmin(), tmsec(), t, d);
END GetClock;
PROCEDURE -Error(msg: ARRAY OF CHAR; len: INTEGER) PROCEDURE GetTimeOfDay*(VAR sec, usec: LONGINT);
"write(1/*stdout*/, msg, len); char ch = 0xa; write(1, &ch, 1)"; BEGIN
gettimeval; sec := tvsec(); usec := tvusec();
END GetTimeOfDay;
PROCEDURE StatCheck; PROCEDURE Time*(): LONGINT;
VAR x, y: LONGINT; VAR ms: LONGINT;
BEGIN BEGIN
x := SizeofUnixStat(); gettimeval;
y := SizeofStat(); ms := (tvusec() DIV 1000) + (tvsec() * 1000);
IF x # y THEN RETURN (ms - TimeStart) MOD 7FFFFFFFH;
Error("Unix.StatCheck: inconsistent usage of struct stat", 49); END Time;
Exit(1);
END
END StatCheck; 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 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.

611
src/system/Platformwindows.Mod Executable file
View file

@ -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.

392
src/system/SYSTEM.c
View file

@ -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. * Module SYSTEM is subject to change any time without prior notification.
* Software Templ disclaims all warranties with regard to module SYSTEM, * Software Templ disclaims all warranties with regard to module SYSTEM,
* in particular shall Software Templ not be liable for any damage resulting * in particular shall Software Templ not be liable for any damage resulting
* from inappropriate use or modification of module SYSTEM. * from inappropriate use or modification of module SYSTEM.
* *
* Version 1.1 jt, 24.11.95 fixes for correct pointer arithmetic on Cray computers * 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 * jt 31.1.2007 ANSI prototypes for malloc and exit in order to avoid cc warnings
* *
*/ */
#include "SYSTEM.h" #include "SYSTEM.h"
#ifdef __STDC__
#include "stdarg.h" #include "stdarg.h"
#include <signal.h>
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 #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 #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 ------------- */

473
src/system/SYSTEM.h
View file

@ -1,238 +1,275 @@
#ifndef SYSTEM__h #ifndef SYSTEM__h
#define SYSTEM__h #define SYSTEM__h
/* #ifndef _WIN32
voc (jet backend) runtime system interface and macros library // Building for a Unix/Linux based system
copyright (c) Josef Templ, 1995, 1996 #include <string.h> // For memcpy ...
#include <stdint.h> // For uintptr_t ...
gcc for Linux version (same as SPARC/Solaris2)
uses double # as concatenation operator
*/
#include <alloca.h>
#include <stdint.h> /* 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 #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 */ // Building for Windows platform with either mingw under cygwin, or the MS C compiler
#define __DEFMOD static void *m; if(m!=0)return m #ifdef _WIN64
#define __REGMOD(name, enum) if(m==0)m=SYSTEM_REGMOD((CHAR*)name,enum); else return m typedef unsigned long long size_t;
#define __ENDMOD return m typedef unsigned long long uintptr_t;
#define __INIT(argc, argv) static void *m; SYSTEM_INIT(argc, (long)&argv); #else
#define __REGMAIN(name, enum) m=SYSTEM_REGMOD(name,enum) typedef unsigned int size_t;
#define __FINI SYSTEM_FINI(); return 0 typedef unsigned int uintptr_t;
#define __IMPORT(name) SYSTEM_INCREF(name##__init()) #endif /* _WIN64 */
#define __REGCMD(name, cmd) SYSTEM_REGCMD(m, name, cmd)
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 */ /* 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 __VAL(t, x) ((t)(x))
#define __SHORT(x, y) ((int)((unsigned long)(x)+(y)<(y)+(y)?(x):(__HALT(-8),0))) #define __VALP(t, x) ((t)(uintptr_t)(x))
#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)
/* runtime checks */ #define __GET(a, x, t) x= *(t*)(uintptr_t)(a)
#define __X(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-2),0)) #define __PUT(a, x, t) *(t*)(uintptr_t)(a)=x
#define __XF(i, ub) SYSTEM_XCHK((long)(i), (long)(ub)) #define __LSHL(x, n, t) ((t)((unsigned t)(x)<<(n)))
#define __RETCHK __retchk: __HALT(-3) #define __LSHR(x, n, t) ((t)((unsigned t)(x)>>(n)))
#define __CASECHK __HALT(-4) #define __LSH(x, n, t) ((n)>=0? __LSHL(x, n, t): __LSHR(x, -(n), t))
#define __GUARDP(p, typ, level) ((typ*)(__ISP(p,typ,level)?p:(__HALT(-5),p))) #define __ROTL(x, n, t) ((t)((unsigned t)(x)<<(n)|(unsigned t)(x)>>(8*sizeof(t)-(n))))
#define __GUARDR(r, typ, level) (*((typ*)(__IS(r##__typ,typ,level)?r:(__HALT(-5),r)))) #define __ROTR(x, n, t) ((t)((unsigned t)(x)>>(n)|(unsigned t)(x)<<(8*sizeof(t)-(n))))
#define __GUARDA(p, typ, level) ((struct typ*)(__IS(__TYPEOF(p),typ,level)?p:(__HALT(-5),p))) #define __LSHR(x, n, t) ((t)((unsigned t)(x)>>(n)))
#define __GUARDEQR(p, dyntyp, typ) if(dyntyp!=typ##__typ) __HALT(-6);*(p) #define __LSH(x, n, t) ((n)>=0? __LSHL(x, n, t): __LSHR(x, -(n), t))
#define __GUARDEQP(p, typ) if(__TYPEOF(p)!=typ##__typ)__HALT(-6);*(p) #define __ROTL(x, n, t) ((t)((unsigned t)(x)<<(n)|(unsigned t)(x)>>(8*sizeof(t)-(n))))
#define __WITHCHK __HALT(-7) #define __ROTR(x, n, t) ((t)((unsigned t)(x)>>(n)|(unsigned t)(x)<<(8*sizeof(t)-(n))))
#define __R(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-8),0)) #define __ROT(x, n, t) ((n)>=0? __ROTL(x, n, t): __ROTR(x, -(n), t))
#define __RF(i, ub) SYSTEM_RCHK((long)(i),(long)(ub)) #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) // Runtime checks
#define __EOM 1
#define __TDFLDS(name, size) {__EOM}, 1, 0, 0, 0, name, {0}, 0, size #define __X(i, ub) (((unsigned LONGINT)(i)<(unsigned LONGINT)(ub))?i:(__HALT(-2),0))
#define __ENUMP(adr, n, P) SYSTEM_ENUMP(adr, (long)(n), P) #define __XF(i, ub) SYSTEM_XCHK((LONGINT)(i), (LONGINT)(ub))
#define __ENUMR(adr, typ, size, n, P) SYSTEM_ENUMR(adr, typ, (long)(size), (long)(n), P) #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) \ #define __INITYP(t, t0, level) \
t##__typ= &t##__desc.blksz; \ t##__typ = (LONGINT*)&t##__desc.blksz; \
memcpy(t##__desc.base, t0##__typ - __BASEOFF, level*sizeof(long)); \ memcpy(t##__desc.basep, t0##__typ - __BASEOFF, level*sizeof(LONGINT)); \
t##__desc.base[level]=t##__typ; \ t##__desc.basep[level] = (LONGINT)(uintptr_t)t##__typ; \
t##__desc.module=(long)m; \ t##__desc.module = (LONGINT)(uintptr_t)m; \
if(t##__desc.blksz!=sizeof(struct t)) __HALT(-15); \ 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)); \ t##__desc.blksz = (t##__desc.blksz+5*sizeof(LONGINT)-1)/(4*sizeof(LONGINT))*(4*sizeof(LONGINT)); \
SYSTEM_REGTYP(m, (long)&t##__desc.next); \ Heap_REGTYP(m, (LONGINT)(uintptr_t)&t##__desc.next); \
SYSTEM_INHERIT(t##__typ, t0##__typ) 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 #endif

9
src/system/WindowsWrapper.h Executable file
View file

@ -0,0 +1,9 @@
// WindowsWrapper.h
//
// Includes Windows.h while avoiding conflicts with Oberon types.
#undef BOOLEAN
#undef CHAR
#include <windows.h>
#define BOOLEAN char
#define CHAR unsigned char