vishapoberon/compiler
1
0
Fork 0
mirror of https://github.com/vishapoberon/compiler.git synced 2026-04-06 21:32:26 +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

18
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,9 +64,9 @@ 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;

434
src/system/Files.Mod
View file

@ -1,9 +1,6 @@
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
@ -19,12 +16,17 @@ 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
@ -35,8 +37,8 @@ MODULE Files0; (* J. Templ 1.12. 89/12.4.95 Oberon files mapped onto Unix files
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
@ -45,7 +47,8 @@ MODULE Files0; (* J. Templ 1.12. 89/12.4.95 Oberon files mapped onto Unix files
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;
@ -56,37 +59,28 @@ MODULE Files0; (* J. Templ 1.12. 89/12.4.95 Oberon files mapped onto Unix files
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;
IF f.fd # 0 THEN Console.String("f.fd = "); Console.Int(f.fd,1) END
END; END;
IF errno # 0 THEN Console.String(" errno = "); Console.Int(errno, 1) 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;
@ -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);
error := Platform.New(f.workName, f.fd);
done := f.fd = 0
END; 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
(* Console.String("f.fd = "); Console.Int(f.fd,1); Console.Ln; *)
err := "too many files open"
ELSE err := "file not created" ELSE err := "file not created"
END; END;
Err(err, f, errno) 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,21 +239,30 @@ 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 pos = 0 THEN
dir[0] := "."; i := 1; INC(pos) (* Default search path is just the current directory *)
END
ELSE
ch := SearchPath[pos];
WHILE (ch = " ") OR (ch = ";") DO INC(pos); ch := SearchPath[pos] END;
IF ch = "~" THEN IF ch = "~" THEN
INC(pos); ch := Kernel.OBERON[pos]; INC(pos); ch := SearchPath[pos];
home := ""; Args.GetEnv("HOME", home); WHILE HOME[i] # 0X DO dir[i] := HOME[i]; INC(i) END;
WHILE home[i] # 0X DO dir[i] := home[i]; INC(i) END ; IF (ch # "/") & (ch # 0X) & (ch # ";") & (ch # " ") THEN
IF (ch # "/") & (ch # 0X) & (ch # ":") & (ch # " ") THEN
WHILE (i > 0) & (dir[i-1] # "/") DO DEC(i) END WHILE (i > 0) & (dir[i-1] # "/") DO DEC(i) END
END END
END; END;
WHILE (ch # 0X) & (ch # ":") DO dir[i] := ch; INC(i); INC(pos); ch := Kernel.OBERON[pos] 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 ; WHILE (i > 0) & (dir[i-1] = " ") DO DEC(i) END
END;
dir[i] := 0X dir[i] := 0X
END ScanPath; END ScanPath;
@ -215,19 +273,19 @@ f.fd := Unix.Open(f.workName, SHORT(SYSTEM.VAL(LONGINT, (Unix.rdwr + Unix.creat
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;
@ -237,40 +295,52 @@ f.fd := Unix.Open(f.workName, SHORT(SYSTEM.VAL(LONGINT, (Unix.rdwr + Unix.creat
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; *)
Err("too many files open", f, error)
END
END; END;
IF ~done & ((errno = Unix.EACCES) OR (errno = Unix.EROFS) OR (errno = Unix.EAGAIN)) THEN IF ~done & Platform.Inaccessible(error) THEN
(* errno EAGAIN observed on Solaris 2.4 *) error := Platform.OldRO(path, fd); done := error = 0;
fd := Unix.Open(path, SHORT(SYSTEM.VAL(LONGINT, Unix.rdonly)), SHORT(SYSTEM.VAL(LONGINT, {}))); done := fd >= 0; errno := Unix.errno()
END; END;
IF (~done) & (errno # Unix.ENOENT) THEN IF (~done) & (~Platform.Absent(error)) THEN
Console.String("warning Files0.Old "); Console.String(name); Console.String("Warning: Files.Old "); Console.String(name);
Console.String(" errno = "); Console.Int(errno, 0); Console.Ln; Console.String(" error = "); Console.Int(error, 0); Console.Ln;
END; 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,9 +379,16 @@ 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
(*
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; 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;
@ -325,9 +404,9 @@ 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;
@ -451,72 +530,90 @@ 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);
IF error = 0 THEN
error := Platform.IdentifyByName(new, newidentity);
IF (error # 0) & ~Platform.SameFile(oldidentity, newidentity) THEN
Delete(new, error); (* work around stale nfs handles *)
END; END;
r := Unix.Rename(old, new); error := Platform.Rename(old, new);
IF r < 0 THEN res := SHORT(Unix.errno()); (* Console.String("Platform.Rename error code "); Console.Int(error,1); Console.Ln; *)
IF res = Unix.EXDEV THEN (* cross device link, move the file *) IF ~Platform.DifferentFilesystems(error) THEN
fdold := Unix.Open(old, SHORT(SYSTEM.VAL(LONGINT, Unix.rdonly)), SHORT(SYSTEM.VAL(LONGINT, {}))); res := error; RETURN
IF fdold < 0 THEN res := 2; RETURN END ; ELSE
fdnew := Unix.Open(new, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr + Unix.creat + Unix.trunc)), SHORT(SYSTEM.VAL(LONGINT, {2, 4,5, 7,8}))); (* cross device link, move the file *)
IF fdnew < 0 THEN r := Unix.Close(fdold); res := 3; RETURN END ; error := Platform.OldRO(old, fdold);
n := Unix.Read(fdold, SYSTEM.ADR(buf), bufsize); IF error # 0 THEN res := 2; RETURN END;
error := Platform.New(new, fdnew);
IF error # 0 THEN error := Platform.Close(fdold); res := 3; RETURN END;
error := Platform.Read(fdold, SYSTEM.ADR(buf), bufsize, n);
WHILE n > 0 DO WHILE n > 0 DO
r := Unix.Write(fdnew, SYSTEM.ADR(buf), n); error := Platform.Write(fdnew, SYSTEM.ADR(buf), n);
IF r < 0 THEN errno := Unix.errno(); r := Unix.Close(fdold); r := Unix.Close(fdnew); IF error # 0 THEN
Err("cannot move file", NIL, errno) ignore := Platform.Close(fdold);
ignore := Platform.Close(fdnew);
Err("cannot move file", NIL, error)
END; END;
n := Unix.Read(fdold, SYSTEM.ADR(buf), bufsize) error := Platform.Read(fdold, SYSTEM.ADR(buf), bufsize, n);
END; END;
errno := Unix.errno(); ignore := Platform.Close(fdold);
r := Unix.Close(fdold); r := Unix.Close(fdnew); ignore := Platform.Close(fdnew);
IF n = 0 THEN r := Unix.Unlink(old); res := 0 IF n = 0 THEN
ELSE Err("cannot move file", NIL, errno) error := Platform.Unlink(old); res := 0
ELSE
Err("cannot move file", NIL, error)
END; END;
ELSE RETURN (* res is Unix.Rename return code *)
END END
END ; ELSE
res := 0 res := 2 (* old file not found *)
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
(*
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; 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
@ -560,6 +657,22 @@ Especially Length would become fairly complex.
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);
@ -615,22 +728,45 @@ Especially Length would become fairly complex.
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.

245
src/system/Heap.Mod
View file

@ -1,17 +1,7 @@
(* 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;
@ -24,23 +14,23 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
(* 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;
@ -48,7 +38,9 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
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;
@ -82,25 +74,42 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
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;
allocated*: LONGINT;
firstTry: BOOLEAN; 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 Lock*;
BEGIN
INC(lockdepth);
END Lock;
PROCEDURE -PlatformHalt(code: LONGINT) "Platform_Halt(code)";
PROCEDURE Unlock*;
BEGIN
DEC(lockdepth);
IF interrupted & (lockdepth = 0) THEN
PlatformHalt(-9);
END
END Unlock;
PROCEDURE -malloc(size: LONGINT): LONGINT "(LONGINT)malloc(size)";
PROCEDURE -Lock() "Lock";
PROCEDURE -Unlock() "Unlock";
PROCEDURE -Mainfrm(): LONGINT "SYSTEM_mainfrm";
(* (*
PROCEDURE TAS*(VAR flag:BOOLEAN): BOOLEAN; (* added for compatibility with ulmSYSTEM module; noch *) PROCEDURE TAS*(VAR flag:BOOLEAN): BOOLEAN; (* added for compatibility with ulmSYSTEM module; noch *)
VAR oldflag : BOOLEAN; VAR oldflag : BOOLEAN;
@ -110,13 +119,20 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
RETURN oldflag; RETURN oldflag;
END TAS; 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
must use SYSTEM.NEW. *)
IF name = "Heap" THEN
SYSTEM.NEW(m, SIZE(ModuleDesc))
ELSE
NEW(m)
END; 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,10 +161,14 @@ 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));
@ -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
@ -164,28 +200,37 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
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;
@ -219,9 +264,9 @@ 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);
@ -230,7 +275,7 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
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,7 +312,7 @@ 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);
@ -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,9 +369,10 @@ 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;
@ -337,11 +386,11 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
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
@ -356,7 +405,7 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
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;
@ -451,7 +505,7 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
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,7 +527,7 @@ 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
@ -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.

68
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,21 +18,24 @@ MODULE Oberon;
Log*: Texts.Text; Log*: Texts.Text;
Par*: ParList; (*actual parameters*) Par*: ParList; (*actual parameters*)
R: Texts.Reader;
W: Texts.Writer; W: Texts.Writer;
OptionChar*: CHAR; 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
W: Texts.Writer;
i: INTEGER; i: INTEGER;
str: ARRAY 32 OF CHAR; str: ARRAY 32 OF CHAR;
BEGIN BEGIN
@ -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);
BEGIN text := NIL; beg := 0; end := 0; time := 0;
END GetSelection;
(* --- Notifier for echoing all text appended to the log onto the console. --- *)
PROCEDURE LogNotifier(Log: Texts.Text; op: INTEGER; beg, end: LONGINT);
VAR ch: CHAR;
BEGIN
Texts.OpenReader(R, Log, beg);
WHILE ~R.eot & (beg < end) DO
Texts.Read(R, ch); Texts.Read(R, ch);
Out.Char(ch); IF ch = 0DX THEN Console.Ln ELSE Console.Char(ch) END;
UNTIL R.eot; INC(beg)
END DumpLog; END
*) END LogNotifier;
PROCEDURE TextToString(VAR T : Texts.Text; VAR string : ARRAY OF CHAR);
VAR R : Texts.Reader;
ch : CHAR;
i : LONGINT;
BEGIN
COPY("", string);
Texts.OpenReader(R, T, 0);
i := 0;
WHILE Texts.Pos(R) < T.len DO
Texts.Read(R, ch);
string[i] := ch;
INC(i);
END;
(*string[i] := 0X;*)
END TextToString;
PROCEDURE DumpLog*;
VAR s : POINTER TO ARRAY OF CHAR;
BEGIN
NEW(s, Log.len + 1);
COPY("", s^);
TextToString(Log, s^);
Out.String(s^); Out.Ln;
NEW(Log);
Texts.Open(Log, "");
END DumpLog;
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.

942
src/system/Platformunix.Mod
View file

File diff suppressed because it is too large Load diff

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.

224
src/system/SYSTEM.c
View file

@ -14,192 +14,194 @@
*/ */
#include "SYSTEM.h" #include "SYSTEM.h"
#ifdef __STDC__
#include "stdarg.h" #include "stdarg.h"
#else #include <signal.h>
#include "varargs.h"
#endif
extern void *malloc(unsigned long size);
extern void exit(int status);
void (*SYSTEM_Halt)();
LONGINT SYSTEM_halt; /* x in HALT(x) */
LONGINT SYSTEM_assert; /* x in ASSERT(cond, x) */
LONGINT SYSTEM_argc;
LONGINT SYSTEM_argv;
LONGINT SYSTEM_lock;
BOOLEAN SYSTEM_interrupted;
static LONGINT SYSTEM_mainfrm; /* adr of main proc stack frame, used for stack collection */
#define Lock SYSTEM_lock++
#define Unlock SYSTEM_lock--; if (SYSTEM_interrupted && (SYSTEM_lock == 0)) __HALT(-9)
static void SYSTEM_InitHeap(); LONGINT SYSTEM_XCHK(LONGINT i, LONGINT ub) {return __X(i, ub);}
void *SYSTEM__init(); 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_INIT(argc, argvadr) void SYSTEM_INHERIT(LONGINT *t, LONGINT *t0)
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; t -= __TPROC0OFF;
t0 -= __TPROC0OFF; t0 -= __TPROC0OFF;
while (*t0 != __EOM) {*t = *t0; t--; t0--;} while (*t0 != __EOM) {*t = *t0; t--; t0--;}
} }
void SYSTEM_ENUMP(adr, n, P)
long *adr; void SYSTEM_ENUMP(void *adr, LONGINT n, void (*P)())
long n;
void (*P)();
{ {
while (n > 0) {P(*adr); adr++; n--;} while (n > 0) {
P((LONGINT)(uintptr_t)(*((void**)(adr))));
adr = ((void**)adr) + 1;
n--;
}
} }
void SYSTEM_ENUMR(adr, typ, size, n, P) void SYSTEM_ENUMR(void *adr, LONGINT *typ, LONGINT size, LONGINT n, void (*P)())
char *adr;
long *typ, size, n;
void (*P)();
{ {
long *t, off; LONGINT *t, off;
typ++; typ++;
while (n > 0) { while (n > 0) {
t = typ; t = typ;
off = *t; off = *t;
while (off >= 0) {P(*(long*)(adr+off)); t++; off = *t;} while (off >= 0) {P(*(LONGINT*)((char*)adr+off)); t++; off = *t;}
adr += size; n--; adr = ((char*)adr) + size;
n--;
} }
} }
long SYSTEM_DIV(x, y) LONGINT SYSTEM_DIV(unsigned LONGINT x, unsigned LONGINT y)
unsigned long x, y; { if ((LONGINT) x >= 0) return (x / y);
{ if ((long) x >= 0) return (x / y);
else return -((y - 1 - x) / y); else return -((y - 1 - x) / y);
} }
long SYSTEM_MOD(x, y) LONGINT SYSTEM_MOD(unsigned LONGINT x, unsigned LONGINT y)
unsigned long x, y; { unsigned LONGINT m;
{ unsigned long m; if ((LONGINT) x >= 0) return (x % y);
if ((long) x >= 0) return (x % y);
else { m = (-x) % y; else { m = (-x) % y;
if (m != 0) return (y - m); else return 0; if (m != 0) return (y - m); else return 0;
} }
} }
long SYSTEM_ENTIER(x) LONGINT SYSTEM_ENTIER(double x)
double x;
{ {
long y; LONGINT y;
if (x >= 0) if (x >= 0)
return (long)x; return (LONGINT)x;
else { else {
y = (long)x; y = (LONGINT)x;
if (y <= x) return y; else return y - 1; if (y <= x) return y; else return y - 1;
} }
} }
void SYSTEM_HALT(n) extern void Heap_Lock();
int n; extern void Heap_Unlock();
{
SYSTEM_halt = n;
if (SYSTEM_Halt!=0) SYSTEM_Halt(n);
exit(n);
}
#ifdef __STDC__ SYSTEM_PTR SYSTEM_NEWARR(LONGINT *typ, LONGINT elemsz, int elemalgn, int nofdim, int nofdyn, ...)
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; LONGINT nofelems, size, dataoff, n, nptr, *x, *p, nofptrs, i, *ptab, off;
va_list ap; va_list ap;
#ifdef __STDC__
va_start(ap, nofdyn); va_start(ap, nofdyn);
#else
va_start(ap);
#endif
nofelems = 1; nofelems = 1;
while (nofdim > 0) { while (nofdim > 0) {
nofelems = nofelems * va_arg(ap, long); nofdim--; nofelems = nofelems * va_arg(ap, LONGINT); nofdim--;
if (nofelems <= 0) __HALT(-20); if (nofelems <= 0) __HALT(-20);
} }
va_end(ap); va_end(ap);
dataoff = nofdyn * sizeof(long); dataoff = nofdyn * sizeof(LONGINT);
if (elemalgn > sizeof(long)) { if (elemalgn > sizeof(LONGINT)) {
n = dataoff % elemalgn; n = dataoff % elemalgn;
if (n != 0) dataoff += elemalgn - n; if (n != 0) dataoff += elemalgn - n;
} }
size = dataoff + nofelems * elemsz; size = dataoff + nofelems * elemsz;
Lock; Heap_Lock();
if (typ == NIL) { if (typ == NIL) {
/* element typ does not contain pointers */ /* element typ does not contain pointers */
x = SYSTEM_NEWBLK(size); x = Heap_NEWBLK(size);
} }
else if (typ == POINTER__typ) { else if (typ == (LONGINT*)POINTER__typ) {
/* element type is a pointer */ /* element type is a pointer */
x = SYSTEM_NEWBLK(size + nofelems * sizeof(long)); x = Heap_NEWBLK(size + nofelems * sizeof(LONGINT));
p = (long*)x[-1]; 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] = *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 */ p -= nofelems - 1; n = 1; /* n =1 for skipping the size field */
while (n <= nofelems) {*p = n*sizeof(long); p++; n++;} while (n <= nofelems) {*p = n*sizeof(LONGINT); p++; n++;}
*p = - (nofelems + 1) * sizeof(long); /* sentinel */ *p = - (nofelems + 1) * sizeof(LONGINT); /* sentinel */
x[-1] -= nofelems * sizeof(long); x[-1] -= nofelems * sizeof(LONGINT);
} }
else { else {
/* element type is a record that contains pointers */ /* element type is a record that contains pointers */
ptab = typ + 1; nofptrs = 0; ptab = typ + 1; nofptrs = 0;
while (ptab[nofptrs] >= 0) {nofptrs++;} /* number of pointers per element */ while (ptab[nofptrs] >= 0) {nofptrs++;} /* number of pointers per element */
nptr = nofelems * nofptrs; /* total number of pointers */ nptr = nofelems * nofptrs; /* total number of pointers */
x = SYSTEM_NEWBLK(size + nptr * sizeof(long)); x = Heap_NEWBLK(size + nptr * sizeof(LONGINT));
p = (long*)x[- 1]; 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] = *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; p -= nptr - 1; n = 0; off = dataoff;
while (n < nofelems) {i = 0; while (n < nofelems) {i = 0;
while (i < nofptrs) {*p = off + ptab[i]; p++; i++;} while (i < nofptrs) {*p = off + ptab[i]; p++; i++;}
off += elemsz; n++; off += elemsz; n++;
} }
*p = - (nptr + 1) * sizeof(long); /* sentinel */ *p = - (nptr + 1) * sizeof(LONGINT); /* sentinel */
x[-1] -= nptr * sizeof(long); x[-1] -= nptr * sizeof(LONGINT);
} }
if (nofdyn != 0) { if (nofdyn != 0) {
/* setup len vector for index checks */ /* setup len vector for index checks */
#ifdef __STDC__
va_start(ap, nofdyn); va_start(ap, nofdyn);
#else
va_start(ap);
#endif
p = x; p = x;
while (nofdyn > 0) {*p = va_arg(ap, long); p++, nofdyn--;} while (nofdyn > 0) {*p = va_arg(ap, LONGINT); p++, nofdyn--;}
va_end(ap); va_end(ap);
} }
Unlock; Heap_Unlock();
return x; return x;
} }
/* ----------- end of SYSTEM.co ------------- */
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
// 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

399
src/system/SYSTEM.h
View file

@ -1,106 +1,131 @@
#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 __VAL(t, x) ((t)(x))
#define __GET(a, x, t) x= *(t*)(a) #define __VALP(t, x) ((t)(uintptr_t)(x))
#define __PUT(a, x, t) *(t*)(a)=x
#define __GET(a, x, t) x= *(t*)(uintptr_t)(a)
#define __PUT(a, x, t) *(t*)(uintptr_t)(a)=x
#define __LSHL(x, n, t) ((t)((unsigned t)(x)<<(n))) #define __LSHL(x, n, t) ((t)((unsigned t)(x)<<(n)))
#define __LSHR(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 __LSH(x, n, t) ((n)>=0? __LSHL(x, n, t): __LSHR(x, -(n), t))
@ -111,25 +136,23 @@ extern void SYSTEM_ENUMR();
#define __ROTL(x, n, t) ((t)((unsigned t)(x)<<(n)|(unsigned t)(x)>>(8*sizeof(t)-(n)))) #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 __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 __ROT(x, n, t) ((n)>=0? __ROTL(x, n, t): __ROTR(x, -(n), t))
#define __BIT(x, n) (*(unsigned long*)(x)>>(n)&1) #define __BIT(x, n) (*(unsigned LONGINT*)(x)>>(n)&1)
#define __MOVE(s, d, n) memcpy((char*)(d),(char*)(s),n) #define __MOVE(s, d, n) memcpy((char*)(uintptr_t)(d),(char*)(uintptr_t)(s),n)
#define __ASHL(x, n) ((LONGINT)(x)<<(n))
/* std procs and operator mappings */ #define __ASHR(x, n) ((LONGINT)(x)>>(n))
#define __SHORT(x, y) ((int)((unsigned long)(x)+(y)<(y)+(y)?(x):(__HALT(-8),0))) #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 __SHORTF(x, y) ((int)(__RF((x)+(y),(y)+(y))-(y)))
#define __CHR(x) ((CHAR)__R(x, 256)) #define __CHR(x) ((CHAR)__R(x, 256))
#define __CHRF(x) ((CHAR)__RF(x, 256)) #define __CHRF(x) ((CHAR)__RF(x, 256))
#define __DIV(x, y) ((x)>=0?(x)/(y):-(((y)-1-(x))/(y))) #define __DIV(x, y) ((x)>=0?(x)/(y):-(((y)-1-(x))/(y)))
#define __DIVF(x, y) SYSTEM_DIV((long)(x),(long)(y)) #define __DIVF(x, y) SYSTEM_DIV((LONGINT)(x),(LONGINT)(y))
#define __MOD(x, y) ((x)>=0?(x)%(y):__MODF(x,y)) #define __MOD(x, y) ((x)>=0?(x)%(y):__MODF(x,y))
#define __MODF(x, y) SYSTEM_MOD((long)(x),(long)(y)) #define __MODF(x, y) SYSTEM_MOD((LONGINT)(x),(LONGINT)(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 __ENTIER(x) SYSTEM_ENTIER(x)
#define __ABS(x) (((x)<0)?-(x):(x)) #define __ABS(x) (((x)<0)?-(x):(x))
#define __ABSF(x) SYSTEM_ABS((long)(x)) #define __ABSF(x) SYSTEM_ABS((LONGINT)(x))
#define __ABSFD(x) SYSTEM_ABSD((double)(x)) #define __ABSFD(x) SYSTEM_ABSD((double)(x))
#define __CAP(ch) ((CHAR)((ch)&0x5f)) #define __CAP(ch) ((CHAR)((ch)&0x5f))
#define __ODD(x) ((x)&1) #define __ODD(x) ((x)&1)
@ -137,102 +160,116 @@ extern void SYSTEM_ENUMR();
#define __SETOF(x) ((SET)1<<(x)) #define __SETOF(x) ((SET)1<<(x))
#define __SETRNG(l, h) ((~(SET)0<<(l))&~(SET)0>>(8*sizeof(SET)-1-(h))) #define __SETRNG(l, h) ((~(SET)0<<(l))&~(SET)0>>(8*sizeof(SET)-1-(h)))
#define __MASK(x, m) ((x)&~(m)) #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 __X(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-2),0))
#define __XF(i, ub) SYSTEM_XCHK((long)(i), (long)(ub)) // Runtime checks
#define __RETCHK __retchk: __HALT(-3)
#define __X(i, ub) (((unsigned LONGINT)(i)<(unsigned LONGINT)(ub))?i:(__HALT(-2),0))
#define __XF(i, ub) SYSTEM_XCHK((LONGINT)(i), (LONGINT)(ub))
#define __R(i, ub) (((unsigned LONGINT)(i)<(unsigned LONGINT)(ub))?i:(__HALT(-8),0))
#define __RF(i, ub) SYSTEM_RCHK((LONGINT)(i),(LONGINT)(ub))
#define __RETCHK __retchk: __HALT(-3); return 0;
#define __CASECHK __HALT(-4) #define __CASECHK __HALT(-4)
#define __WITHCHK __HALT(-7)
#define __GUARDP(p, typ, level) ((typ*)(__ISP(p,typ,level)?p:(__HALT(-5),p))) #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 __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 __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 __GUARDEQR(p, dyntyp, typ) if(dyntyp!=typ##__typ) __HALT(-6);*(p)
#define __GUARDEQP(p, typ) if(__TYPEOF(p)!=typ##__typ)__HALT(-6);*(p) #define __GUARDEQP(p, typ) if(__TYPEOF(p)!=typ##__typ)__HALT(-6);*(p)
#define __WITHCHK __HALT(-7)
#define __R(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-8),0))
#define __RF(i, ub) SYSTEM_RCHK((long)(i),(long)(ub))
/* record type descriptors */
// 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) \ #define __TDESC(t, m, n) \
static struct t##__desc { \ static struct t##__desc { \
long tproc[m]; \ LONGINT tproc[m]; /* Proc for each ptr field */ \
long tag, next, level, module; \ LONGINT tag; \
LONGINT next; /* Module table type list points here */ \
LONGINT level; \
LONGINT module; \
char name[24]; \ char name[24]; \
long *base[__MAXEXT]; \ LONGINT basep[__MAXEXT]; /* List of bases this extends */ \
char *rsrvd; \ LONGINT reserved; \
long blksz, ptr[n+1]; \ LONGINT blksz; /* xxx_typ points here */ \
LONGINT ptr[n+1]; /* Offsets of ptrs up to -ve sentinel */ \
} t##__desc } t##__desc
#define __BASEOFF (__MAXEXT+1) #define __BASEOFF (__MAXEXT+1) // blksz as index to base.
#define __TPROC0OFF (__BASEOFF+24/sizeof(long)+5) #define __TPROC0OFF (__BASEOFF+24/sizeof(LONGINT)+5) // blksz as index to tproc IFF m=1.
#define __EOM 1 #define __EOM 1
#define __TDFLDS(name, size) {__EOM}, 1, 0, 0, 0, name, {0}, 0, size #define __TDFLDS(name, size) {__EOM}, 1, 0, 0, 0, name, {0}, 0, size
#define __ENUMP(adr, n, P) SYSTEM_ENUMP(adr, (long)(n), P) #define __ENUMP(adr, n, P) SYSTEM_ENUMP(adr, (LONGINT)(n), P)
#define __ENUMR(adr, typ, size, n, P) SYSTEM_ENUMR(adr, typ, (long)(size), (long)(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)
/* Oberon-2 type bound procedures support */ #define __IS(tag, typ, level) (*(tag-(__BASEOFF-level))==(LONGINT)(uintptr_t)typ##__typ)
#define __INITBP(t, proc, num) *(t##__typ-(__TPROC0OFF+num))=(long)proc #define __TYPEOF(p) ((LONGINT*)(uintptr_t)(*(((LONGINT*)(p))-1)))
#define __SEND(typ, num, funtyp, parlist) ((funtyp)(*(typ-(__TPROC0OFF+num))))parlist #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
/* 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