vishapoberon/compiler
1
0
Fork 0
mirror of https://github.com/vishapoberon/compiler.git synced 2026-04-06 02:52:24 +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 *)
IMPORT SYSTEM;
IMPORT SYSTEM, Platform;
VAR line: ARRAY 128 OF CHAR;
pos: INTEGER;
PROCEDURE -Write(adr, n: LONGINT)
"write(1/*stdout*/, adr, n)";
PROCEDURE -read(VAR ch: CHAR): LONGINT
"read(0/*stdin*/, ch, 1)";
PROCEDURE Flush*();
PROCEDURE Flush*;
VAR error: Platform.ErrorCode;
BEGIN
Write(SYSTEM.ADR(line), pos); pos := 0;
error := Platform.Write(Platform.StdOut, SYSTEM.ADR(line), pos);
pos := 0;
END Flush;
PROCEDURE Char*(ch: CHAR);
@ -68,9 +64,9 @@ MODULE Console; (* J. Templ, 29-June-96 *)
END Hex;
PROCEDURE Read*(VAR ch: CHAR);
VAR n: LONGINT;
VAR n: LONGINT; error: Platform.ErrorCode;
BEGIN Flush();
n := read(ch);
error := Platform.ReadBuf(Platform.StdIn, ch, n);
IF n # 1 THEN ch := 0X END
END Read;

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 *)
(* for general use import Files module *)
IMPORT SYSTEM, Unix, Kernel := Kernel0, Args, Console;
IMPORT SYSTEM, Platform, Heap, Strings, Configuration, Console;
(* 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
nofbufs = 4;
bufsize = 4096;
fileTabSize = 64;
fileTabSize = 256; (* 256 needed for Windows *)
noDesc = -1;
notDone = -1;
(* file states *)
open = 0; create = 1; close = 2;
open = 0; (* OS File has been opened *)
create = 1; (* OS file needs to be created *)
close = 2; (* Register telling Create to use registerName directly:
i.e. since we're closing and all data is still in
buffers bypass writing to temp file and then renaming
and just write directly to fianl register name *)
TYPE
@ -35,8 +37,8 @@ MODULE Files0; (* J. Templ 1.12. 89/12.4.95 Oberon files mapped onto Unix files
Handle = RECORD
workName, registerName: FileName;
tempFile: BOOLEAN;
dev, ino, mtime: LONGINT;
fd-: INTEGER;
identity: Platform.FileIdentity;
fd-: Platform.FileHandle;
len, pos: LONGINT;
bufs: ARRAY nofbufs OF Buffer;
swapper, state: INTEGER
@ -45,7 +47,8 @@ MODULE Files0; (* J. Templ 1.12. 89/12.4.95 Oberon files mapped onto Unix files
BufDesc = RECORD
f: File;
chg: BOOLEAN;
org, size: LONGINT;
org: LONGINT;
size: LONGINT;
data: ARRAY bufsize OF SYSTEM.BYTE
END;
@ -56,37 +59,28 @@ MODULE Files0; (* J. Templ 1.12. 89/12.4.95 Oberon files mapped onto Unix files
org, offset: LONGINT
END;
Time = POINTER TO TimeDesc;
TimeDesc = RECORD
sec*, min*, hour*, mday*, mon*, year*, wday*, isdst*, zone*, gmtoff*: LONGINT;
(* sec*, min*, hour*, mday*, mon*, year*, wday*, isdst*, zone*, gmtoff*: INTEGER;*)
END ;
VAR
fileTab: ARRAY fileTabSize OF LONGINT (*=File*);
tempno: INTEGER;
HOME: ARRAY 1024 OF CHAR;
SearchPath: POINTER TO ARRAY OF CHAR;
(* for localtime *)
PROCEDURE -includetime()
'#include "time.h"';
PROCEDURE -localtime(VAR clock: LONGINT): Time
"(Files0_Time) localtime(clock)";
PROCEDURE -getcwd(VAR cwd: Unix.Name)
"getcwd(cwd, cwd__len)";
PROCEDURE -IdxTrap "__HALT(-1)";
PROCEDURE^ Finalize(o: SYSTEM.PTR);
PROCEDURE Err(s: ARRAY OF CHAR; f: File; errno: LONGINT);
PROCEDURE Err(s: ARRAY OF CHAR; f: File; errcode: Platform.ErrorCode);
BEGIN
Console.Ln; Console.String("-- "); Console.String(s); Console.String(": ");
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;
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;
HALT(99)
END Err;
@ -105,8 +99,8 @@ MODULE Files0; (* J. Templ 1.12. 89/12.4.95 Oberon files mapped onto Unix files
BEGIN
INC(tempno); n := tempno; i := 0;
IF finalName[0] # "/" THEN (* relative pathname *)
WHILE Kernel.CWD[i] # 0X DO name[i] := Kernel.CWD[i]; INC(i) END;
IF Kernel.CWD[i-1] # "/" THEN name[i] := "/"; INC(i) END
WHILE Platform.CWD[i] # 0X DO name[i] := Platform.CWD[i]; INC(i) END;
IF Platform.CWD[i-1] # "/" THEN name[i] := "/"; INC(i) END
END;
j := 0;
WHILE finalName[j] # 0X DO name[i] := finalName[j]; INC(i); INC(j) END;
@ -114,73 +108,128 @@ MODULE Files0; (* J. Templ 1.12. 89/12.4.95 Oberon files mapped onto Unix files
WHILE name[i] # "/" DO DEC(i) END;
name[i+1] := "."; name[i+2] := "t"; name[i+3] := "m"; name[i+4] := "p"; name[i+5] := "."; INC(i, 6);
WHILE n > 0 DO name[i] := CHR(n MOD 10 + ORD("0")); n := n DIV 10; INC(i) END;
name[i] := "."; INC(i); n := SHORT(Unix.Getpid());
name[i] := "."; INC(i); n := Platform.PID;
WHILE n > 0 DO name[i] := CHR(n MOD 10 + ORD("0")); n := n DIV 10; INC(i) END;
name[i] := 0X
END GetTempName;
PROCEDURE Create(f: File);
VAR stat: Unix.Status; done: BOOLEAN;
errno: LONGINT; err: ARRAY 32 OF CHAR;
VAR
identity: Platform.FileIdentity;
done: BOOLEAN;
error: Platform.ErrorCode;
err: ARRAY 32 OF CHAR;
BEGIN
(*
Console.String("Files.Create fd = "); Console.Int(f.fd,1);
Console.String(", registerName = "); Console.String(f.registerName);
Console.String(", workName = "); Console.String(f.workName);
Console.String(", state = "); Console.Int(f.state,1);
Console.Ln;
*)
IF f.fd = noDesc THEN
IF f.state = create THEN GetTempName(f.registerName, f.workName); f.tempFile := TRUE
IF f.state = create THEN
GetTempName(f.registerName, f.workName); f.tempFile := TRUE
ELSIF f.state = close THEN
f.workName := f.registerName; f.registerName := ""; f.tempFile := FALSE
END;
errno := Unix.Unlink(f.workName); (*unlink first to avoid stale NFS handles and to avoid reuse of inodes*)
f.fd := Unix.Open(f.workName, SHORT(SYSTEM.VAL(LONGINT, (Unix.rdwr + Unix.creat + Unix.trunc))), SHORT(SYSTEM.VAL(LONGINT, ({2, 4,5, 7,8}))));
done := f.fd >= 0; errno := Unix.errno();
IF (~done & ((errno = Unix.ENFILE) OR (errno = Unix.EMFILE))) OR (done & (f.fd >= fileTabSize)) THEN
IF done & (f.fd >= fileTabSize) THEN errno := Unix.Close(f.fd) END ;
Kernel.GC(TRUE);
f.fd := Unix.Open(f.workName, SHORT(SYSTEM.VAL(LONGINT, (Unix.rdwr + Unix.creat + Unix.trunc))), SHORT(SYSTEM.VAL(LONGINT, {2, 4,5, 7,8})));
done := f.fd >= 0
error := Platform.Unlink(f.workName); (*unlink first to avoid stale NFS handles and to avoid reuse of inodes*)
error := Platform.New(f.workName, f.fd);
done := error = 0;
(* In case of too many files, try just once more. *)
IF (~done & Platform.TooManyFiles(error)) OR (done & (f.fd >= fileTabSize)) THEN
IF done & (f.fd >= fileTabSize) THEN error := Platform.Close(f.fd) END;
Heap.GC(TRUE);
error := Platform.New(f.workName, f.fd);
done := f.fd = 0
END;
IF done THEN
IF f.fd >= fileTabSize THEN errno := Unix.Close(f.fd); Err("too many files open", f, 0)
ELSE fileTab[f.fd] := SYSTEM.VAL(LONGINT, f); INC(Kernel.nofiles); Kernel.RegisterObject(f, Finalize);
f.state := open; f.pos := 0; errno := Unix.Fstat(f.fd, stat);
f.dev := stat.dev; f.ino := stat.ino; f.mtime := stat.mtime
IF f.fd >= fileTabSize THEN
(* Console.String("f.fd = "); Console.Int(f.fd,1); Console.Ln; *)
error := Platform.Close(f.fd); Err("too many files open", f, 0)
ELSE
fileTab[f.fd] := SYSTEM.VAL(LONGINT, f);
INC(Heap.FileCount);
Heap.RegisterFinalizer(f, Finalize);
f.state := open;
f.pos := 0;
error := Platform.Identify(f.fd, f.identity);
END
ELSE errno := Unix.errno();
IF errno = Unix.ENOENT THEN err := "no such directory"
ELSIF (errno = Unix.ENFILE) OR (errno = Unix.EMFILE) THEN err := "too many files open"
ELSE
IF Platform.NoSuchDirectory(error) THEN err := "no such directory"
ELSIF Platform.TooManyFiles(error) THEN
(* Console.String("f.fd = "); Console.Int(f.fd,1); Console.Ln; *)
err := "too many files open"
ELSE err := "file not created"
END;
Err(err, f, errno)
Err(err, f, error)
END
END
END Create;
PROCEDURE Flush(buf: Buffer);
VAR res: LONGINT; f: File; stat: Unix.Status;
VAR
error: Platform.ErrorCode;
f: File;
(* identity: Platform.FileIdentity; *)
BEGIN
(*
Console.String("Files.Flush buf.f.registername = "); Console.String(buf.f.registerName);
Console.String(", buf.f.fd = "); Console.Int(buf.f.fd,1);
Console.String(", buffer at $"); Console.Hex(SYSTEM.ADR(buf.data));
Console.String(", size "); Console.Int(buf.size,1); Console.Ln;
*)
IF buf.chg THEN f := buf.f; Create(f);
IF buf.org # f.pos THEN res := Unix.Lseek(f.fd, buf.org, 0) END ;
res := Unix.Write(f.fd, SYSTEM.ADR(buf.data), buf.size);
IF res < 0 THEN Err("error in writing file", f, Unix.errno()) END ;
IF buf.org # f.pos THEN
error := Platform.Seek(f.fd, buf.org, Platform.SeekSet);
(*
Console.String("Seeking to "); Console.Int(buf.org,1);
Console.String(", error code "); Console.Int(error,1); Console.Ln;
*)
END;
error := Platform.Write(f.fd, SYSTEM.ADR(buf.data), buf.size);
IF error # 0 THEN Err("error writing file", f, error) END;
f.pos := buf.org + buf.size;
buf.chg := FALSE;
res := Unix.Fstat(f.fd, stat);
f.mtime := stat.mtime
error := Platform.Identify(f.fd, f.identity);
IF error # 0 THEN Err("error identifying file", f, error) END;
(*
error := Platform.Identify(f.fd, identity);
f.identity.mtime := identity.mtime;
*)
END
END Flush;
PROCEDURE Close* (f: File);
VAR i, res: LONGINT;
VAR
i: LONGINT;
error: Platform.ErrorCode;
BEGIN
(*
Console.String("Files.Close f.fd = "); Console.Int(f.fd,1);
Console.String(" f.registername = "); Console.String(f.registerName);
Console.String(", f.workName = "); Console.String(f.workName); Console.Ln;
*)
IF (f.state # create) OR (f.registerName # "") THEN
Create(f); i := 0;
WHILE (i < nofbufs) & (f.bufs[i] # NIL) DO Flush(f.bufs[i]); INC(i) END;
res := Unix.Fsync(f.fd);
IF res < 0 THEN Err("error in writing file", f, Unix.errno()) END
error := Platform.Sync(f.fd);
(*
Console.String("Syncing closed file. fd = "); Console.Int(f.fd, 1);
Console.String(" error = "); Console.Int(error,1); Console.Ln;
*)
IF error # 0 THEN Err("error writing file", f, error) END;
(* Windows needs us to actually cose the file so that subsequent rename
will not encounter a sharing error. *)
fileTab[f.fd] := 0;
error := Platform.Close(f.fd);
f.fd := noDesc; f.state := create; DEC(Heap.FileCount);
END
END Close;
PROCEDURE Length* (f: File): LONGINT;
BEGIN RETURN f.len
END Length;
BEGIN RETURN f.len END Length;
PROCEDURE New* (name: ARRAY OF CHAR): File;
VAR f: File;
@ -190,21 +239,30 @@ f.fd := Unix.Open(f.workName, SHORT(SYSTEM.VAL(LONGINT, (Unix.rdwr + Unix.creat
RETURN f
END New;
PROCEDURE ScanPath(VAR pos: INTEGER; VAR dir: ARRAY OF CHAR); (* supports ~, ~user and blanks inside path *)
VAR i: INTEGER; ch: CHAR; home: ARRAY 256 OF CHAR;
PROCEDURE ScanPath(VAR pos: INTEGER; VAR dir: ARRAY OF CHAR);
(* Extract next individual directory from searchpath starting at pos,
updating pos and returning dir.
Supports ~, ~user and blanks inside path *)
VAR i: INTEGER; ch: CHAR;
BEGIN
i := 0; ch := Kernel.OBERON[pos];
WHILE (ch = " ") OR (ch = ":") DO INC(pos); ch := Kernel.OBERON[pos] END ;
i := 0;
IF SearchPath = NIL THEN
IF pos = 0 THEN
dir[0] := "."; i := 1; INC(pos) (* Default search path is just the current directory *)
END
ELSE
ch := SearchPath[pos];
WHILE (ch = " ") OR (ch = ";") DO INC(pos); ch := SearchPath[pos] END;
IF ch = "~" THEN
INC(pos); ch := Kernel.OBERON[pos];
home := ""; Args.GetEnv("HOME", home);
WHILE home[i] # 0X DO dir[i] := home[i]; INC(i) END ;
IF (ch # "/") & (ch # 0X) & (ch # ":") & (ch # " ") THEN
INC(pos); ch := SearchPath[pos];
WHILE HOME[i] # 0X DO dir[i] := HOME[i]; INC(i) END;
IF (ch # "/") & (ch # 0X) & (ch # ";") & (ch # " ") THEN
WHILE (i > 0) & (dir[i-1] # "/") DO DEC(i) END
END
END;
WHILE (ch # 0X) & (ch # ":") DO dir[i] := ch; INC(i); INC(pos); ch := Kernel.OBERON[pos] END ;
WHILE (i > 0) & (dir[i-1] = " ") DO DEC(i) END ;
WHILE (ch # 0X) & (ch # ";") DO dir[i] := ch; INC(i); INC(pos); ch := SearchPath[pos] END;
WHILE (i > 0) & (dir[i-1] = " ") DO DEC(i) END
END;
dir[i] := 0X
END ScanPath;
@ -215,19 +273,19 @@ f.fd := Unix.Open(f.workName, SHORT(SYSTEM.VAL(LONGINT, (Unix.rdwr + Unix.creat
RETURN ch = "/"
END HasDir;
PROCEDURE CacheEntry(dev, ino: LONGINT; mtime: LONGINT): File;
VAR f: File; i: INTEGER; stat: Unix.Status; res: LONGINT;
PROCEDURE CacheEntry(identity: Platform.FileIdentity): File;
VAR f: File; i: INTEGER; error: Platform.ErrorCode;
BEGIN i := 0;
WHILE i < fileTabSize DO
f := SYSTEM.VAL(File, fileTab[i]);
IF (f # NIL) & (ino = f.ino) & (dev = f.dev) THEN
IF mtime # f.mtime THEN i := 0;
IF (f # NIL) & Platform.SameFile(identity, f.identity) THEN
IF ~Platform.SameFileTime(identity, f.identity) THEN i := 0;
WHILE i < nofbufs DO
IF f.bufs[i] # NIL THEN f.bufs[i].org := -1; f.bufs[i] := NIL END;
INC(i)
END;
f.swapper := -1; f.mtime := mtime;
res := Unix.Fstat(f.fd, stat); f.len := stat.size
f.swapper := -1; f.identity := identity;
error := Platform.Size(f.fd, f.len);
END;
RETURN f
END;
@ -237,40 +295,52 @@ f.fd := Unix.Open(f.workName, SHORT(SYSTEM.VAL(LONGINT, (Unix.rdwr + Unix.creat
END CacheEntry;
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;
stat: Unix.Status;
error: Platform.ErrorCode;
identity: Platform.FileIdentity;
BEGIN
(* Console.String("Files.Old "); Console.String(name); Console.Ln; *)
IF name # "" THEN
IF HasDir(name) THEN dir := ""; COPY(name, path)
ELSE pos := 0; ScanPath(pos, dir); MakeFileName(dir, name, path); ScanPath(pos, dir)
END;
LOOP
fd := Unix.Open(path, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr)), SHORT(SYSTEM.VAL(LONGINT, {}))); done := fd >= 0; errno := Unix.errno();
IF (~done & ((errno = Unix.ENFILE) OR (errno = Unix.EMFILE))) OR (done & (fd >= fileTabSize)) THEN
IF done & (fd >= fileTabSize) THEN res := Unix.Close(fd) END ;
Kernel.GC(TRUE);
fd := Unix.Open(path, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr)), SHORT(SYSTEM.VAL(LONGINT, {})));
done := fd >= 0; errno := Unix.errno();
IF ~done & ((errno = Unix.ENFILE) OR (errno = Unix.EMFILE)) THEN Err("too many files open", f, errno) END
error := Platform.OldRW(path, fd); done := error = 0;
IF (~done & Platform.TooManyFiles(error)) OR (done & (fd >= fileTabSize)) THEN
IF done & (fd >= fileTabSize) THEN error := Platform.Close(fd) END;
Heap.GC(TRUE);
error := Platform.OldRW(path, fd); done := error = 0;
IF ~done & Platform.TooManyFiles(error) THEN
(* Console.String("fd = "); Console.Int(fd,1); Console.Ln; *)
Err("too many files open", f, error)
END
END;
IF ~done & ((errno = Unix.EACCES) OR (errno = Unix.EROFS) OR (errno = Unix.EAGAIN)) THEN
(* errno EAGAIN observed on Solaris 2.4 *)
fd := Unix.Open(path, SHORT(SYSTEM.VAL(LONGINT, Unix.rdonly)), SHORT(SYSTEM.VAL(LONGINT, {}))); done := fd >= 0; errno := Unix.errno()
IF ~done & Platform.Inaccessible(error) THEN
error := Platform.OldRO(path, fd); done := error = 0;
END;
IF (~done) & (errno # Unix.ENOENT) THEN
Console.String("warning Files0.Old "); Console.String(name);
Console.String(" errno = "); Console.Int(errno, 0); Console.Ln;
IF (~done) & (~Platform.Absent(error)) THEN
Console.String("Warning: Files.Old "); Console.String(name);
Console.String(" error = "); Console.Int(error, 0); Console.Ln;
END;
IF done THEN
res := Unix.Fstat(fd, stat);
f := CacheEntry(stat.dev, stat.ino, stat.mtime);
IF f # NIL THEN res := Unix.Close(fd); RETURN f
ELSIF fd >= fileTabSize THEN res := Unix.Close(fd); Err("too many files open", f, 0)
ELSE NEW(f); fileTab[fd] := SYSTEM.VAL(LONGINT, f); INC(Kernel.nofiles); Kernel.RegisterObject(f, Finalize);
f.fd := fd; f.state := open; f.len := stat.size; f.pos := 0; f.swapper := -1; (*all f.buf[i] = NIL*)
(* Console.String(" fd = "); Console.Int(fd,1); Console.Ln; *)
error := Platform.Identify(fd, identity);
f := CacheEntry(identity);
IF f # NIL THEN error := Platform.Close(fd); RETURN f
ELSIF fd >= fileTabSize THEN
(* Console.String("fd = "); Console.Int(fd,1); Console.Ln; *)
error := Platform.Close(fd);
Err("too many files open", f, 0)
ELSE NEW(f); fileTab[fd] := SYSTEM.VAL(LONGINT, f); INC(Heap.FileCount); Heap.RegisterFinalizer(f, Finalize);
f.fd := fd; f.state := open; f.pos := 0; f.swapper := -1; (*all f.buf[i] = NIL*)
error := Platform.Size(fd, f.len);
COPY(name, f.workName); f.registerName := ""; f.tempFile := FALSE;
f.dev := stat.dev; f.ino := stat.ino; f.mtime := stat.mtime;
f.identity := identity;
RETURN f
END
ELSIF dir = "" THEN RETURN NIL
@ -282,24 +352,26 @@ END ;
END Old;
PROCEDURE Purge* (f: File);
VAR i: INTEGER; stat: Unix.Status; res: LONGINT;
VAR i: INTEGER; identity: Platform.FileIdentity; error: Platform.ErrorCode;
BEGIN i := 0;
WHILE i < nofbufs DO
IF f.bufs[i] # NIL THEN f.bufs[i].org := -1; f.bufs[i] := NIL END;
INC(i)
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;
res := Unix.Fstat(f.fd, stat); f.mtime := stat.mtime
error := Platform.Identify(f.fd, identity); Platform.SetMTime(f.identity, identity)
END Purge;
PROCEDURE GetDate* (f: File; VAR t, d: LONGINT);
VAR stat: Unix.Status; clock, res: LONGINT; time: Time;
VAR
identity: Platform.FileIdentity; error: Platform.ErrorCode;
BEGIN
Create(f); res := Unix.Fstat(f.fd, stat);
time := localtime(stat.mtime);
t := time.sec + ASH(time.min, 6) + ASH(time.hour, 12);
d := time.mday + ASH(time.mon+1, 5) + ASH(time.year MOD 100, 9)
Create(f); error := Platform.Identify(f.fd, identity);
Platform.MTimeAsClock(identity, t, d)
END GetDate;
PROCEDURE Pos* (VAR r: Rider): LONGINT;
@ -307,9 +379,16 @@ END ;
END Pos;
PROCEDURE Set* (VAR r: Rider; f: File; pos: LONGINT);
VAR org, offset, i, n, res: LONGINT; buf: Buffer;
VAR org, offset, i, n: LONGINT; buf: Buffer; error: Platform.ErrorCode;
BEGIN
IF f # NIL THEN
(*
Console.String("Files.Set rider on fd = "); Console.Int(f.fd,1);
Console.String(", registerName = "); Console.String(f.registerName);
Console.String(", workName = "); Console.String(f.workName);
Console.String(", state = "); Console.Int(f.state,1);
Console.Ln;
*)
IF pos > f.len THEN pos := f.len ELSIF pos < 0 THEN pos := 0 END;
offset := pos MOD bufsize; org := pos - offset; i := 0;
WHILE (i < nofbufs) & (f.bufs[i] # NIL) & (org # f.bufs[i].org) DO INC(i) END;
@ -325,9 +404,9 @@ END ;
IF buf.org # org THEN
IF org = f.len THEN buf.size := 0
ELSE Create(f);
IF f.pos # org THEN res := Unix.Lseek(f.fd, org, 0) END ;
n := Unix.ReadBlk(f.fd, buf.data);
IF n < 0 THEN Err("read from file not done", f, Unix.errno()) END ;
IF f.pos # org THEN error := Platform.Seek(f.fd, org, Platform.SeekSet) END;
error := Platform.ReadBuf(f.fd, buf.data, n);
IF error # 0 THEN Err("read from file not done", f, error) END;
f.pos := org + n;
buf.size := n
END;
@ -451,72 +530,90 @@ Especially Length would become fairly complex.
*)
PROCEDURE Delete*(name: ARRAY OF CHAR; VAR res: INTEGER);
BEGIN
res := SHORT(Unix.Unlink(name));
res := SHORT(Unix.errno())
END Delete;
BEGIN res := Platform.Unlink(name) END Delete;
PROCEDURE Rename* (old, new: ARRAY OF CHAR; VAR res: INTEGER);
VAR fdold, fdnew: INTEGER; n, errno, r: LONGINT;
ostat, nstat: Unix.Status;
VAR
fdold, fdnew: Platform.FileHandle;
n: LONGINT;
error, ignore: Platform.ErrorCode;
oldidentity, newidentity: Platform.FileIdentity;
buf: ARRAY 4096 OF CHAR;
BEGIN
r := Unix.Stat(old, ostat);
IF r >= 0 THEN
r := Unix.Stat(new, nstat);
IF (r >= 0) & ((ostat.dev # nstat.dev) OR (ostat.ino # nstat.ino)) THEN
Delete(new, res); (* work around stale nfs handles *)
(*
Console.String("Files.Rename old = "); Console.String(old);
Console.String(", new = "); Console.String(new); Console.Ln;
*)
error := Platform.IdentifyByName(old, oldidentity);
IF error = 0 THEN
error := Platform.IdentifyByName(new, newidentity);
IF (error # 0) & ~Platform.SameFile(oldidentity, newidentity) THEN
Delete(new, error); (* work around stale nfs handles *)
END;
r := Unix.Rename(old, new);
IF r < 0 THEN res := SHORT(Unix.errno());
IF res = Unix.EXDEV THEN (* cross device link, move the file *)
fdold := Unix.Open(old, SHORT(SYSTEM.VAL(LONGINT, Unix.rdonly)), SHORT(SYSTEM.VAL(LONGINT, {})));
IF fdold < 0 THEN res := 2; RETURN END ;
fdnew := Unix.Open(new, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr + Unix.creat + Unix.trunc)), SHORT(SYSTEM.VAL(LONGINT, {2, 4,5, 7,8})));
IF fdnew < 0 THEN r := Unix.Close(fdold); res := 3; RETURN END ;
n := Unix.Read(fdold, SYSTEM.ADR(buf), bufsize);
error := Platform.Rename(old, new);
(* Console.String("Platform.Rename error code "); Console.Int(error,1); Console.Ln; *)
IF ~Platform.DifferentFilesystems(error) THEN
res := error; RETURN
ELSE
(* cross device link, move the file *)
error := Platform.OldRO(old, fdold);
IF error # 0 THEN res := 2; RETURN END;
error := Platform.New(new, fdnew);
IF error # 0 THEN error := Platform.Close(fdold); res := 3; RETURN END;
error := Platform.Read(fdold, SYSTEM.ADR(buf), bufsize, n);
WHILE n > 0 DO
r := Unix.Write(fdnew, SYSTEM.ADR(buf), n);
IF r < 0 THEN errno := Unix.errno(); r := Unix.Close(fdold); r := Unix.Close(fdnew);
Err("cannot move file", NIL, errno)
error := Platform.Write(fdnew, SYSTEM.ADR(buf), n);
IF error # 0 THEN
ignore := Platform.Close(fdold);
ignore := Platform.Close(fdnew);
Err("cannot move file", NIL, error)
END;
n := Unix.Read(fdold, SYSTEM.ADR(buf), bufsize)
error := Platform.Read(fdold, SYSTEM.ADR(buf), bufsize, n);
END;
errno := Unix.errno();
r := Unix.Close(fdold); r := Unix.Close(fdnew);
IF n = 0 THEN r := Unix.Unlink(old); res := 0
ELSE Err("cannot move file", NIL, errno)
ignore := Platform.Close(fdold);
ignore := Platform.Close(fdnew);
IF n = 0 THEN
error := Platform.Unlink(old); res := 0
ELSE
Err("cannot move file", NIL, error)
END;
ELSE RETURN (* res is Unix.Rename return code *)
END
END ;
res := 0
ELSE res := 2 (* old file not found *)
ELSE
res := 2 (* old file not found *)
END
END Rename;
PROCEDURE Register* (f: File);
VAR idx, errno: INTEGER; f1: File; file: ARRAY 104 OF CHAR;
VAR idx, errcode: INTEGER; f1: File; file: ARRAY 104 OF CHAR;
BEGIN
(*
Console.String("Files.Register f.registerName = "); Console.String(f.registerName);
Console.String(", fd = "); Console.Int(f.fd,1); Console.Ln;
*)
IF (f.state = create) & (f.registerName # "") THEN f.state := close (* shortcut renaming *) END;
Close(f);
IF f.registerName # "" THEN
Rename(f.workName, f.registerName, errno);
IF errno # 0 THEN COPY(f.registerName, file); HALT(99) END ;
Rename(f.workName, f.registerName, errcode);
(*
Console.String("Renamed (for register) f.fd = "); Console.Int(f.fd,1);
Console.String(" from workname "); Console.String(f.workName);
Console.String(" to registerName "); Console.String(f.registerName);
Console.String(" errorcode = "); Console.Int(errcode,1); Console.Ln;
*)
IF errcode # 0 THEN COPY(f.registerName, file); HALT(99) END;
f.workName := f.registerName; f.registerName := ""; f.tempFile := FALSE
END
END Register;
PROCEDURE ChangeDirectory*(path: ARRAY OF CHAR; VAR res: INTEGER);
BEGIN
res := SHORT(Unix.Chdir(path));
getcwd(Kernel.CWD)
res := Platform.Chdir(path);
END ChangeDirectory;
PROCEDURE FlipBytes(VAR src, dest: ARRAY OF SYSTEM.BYTE);
VAR i, j: LONGINT;
BEGIN
IF ~Kernel.littleEndian THEN i := LEN(src); j := 0;
IF ~Platform.LittleEndian THEN i := LEN(src); j := 0;
WHILE i > 0 DO DEC(i); dest[j] := src[i]; INC(j) END
ELSE SYSTEM.MOVE(SYSTEM.ADR(src), SYSTEM.ADR(dest), LEN(src))
END
@ -560,6 +657,22 @@ Especially Length would become fairly complex.
REPEAT Read(R, ch); x[i] := ch; INC(i) UNTIL ch = 0X
END ReadString;
PROCEDURE ReadLine* (VAR R: Rider; VAR x: ARRAY OF CHAR);
VAR i: INTEGER; ch: CHAR; b : BOOLEAN;
BEGIN
i := 0;
b := FALSE;
REPEAT
Read(R, ch);
IF ((ch = 0X) OR (ch = 0AX) OR (ch = 0DX)) THEN
b := TRUE
ELSE
x[i] := ch;
INC(i);
END;
UNTIL b
END ReadLine;
PROCEDURE ReadNum* (VAR R: Rider; VAR x: LONGINT);
VAR s: SHORTINT; ch: CHAR; n: LONGINT;
BEGIN s := 0; n := 0; Read(R, ch);
@ -615,22 +728,45 @@ Especially Length would become fairly complex.
Write(R, CHR(x MOD 128))
END WriteNum;
PROCEDURE GetName*(f: File; VAR name: ARRAY OF CHAR);
BEGIN
COPY (f.workName, name);
END GetName;
PROCEDURE Finalize(o: SYSTEM.PTR);
VAR f: File; res: LONGINT;
BEGIN
f := SYSTEM.VAL(File, o);
(*
Console.String("Files.Finalize f.fd = "); Console.Int(f.fd,1);
Console.String(", f.registername = "); Console.String(f.registerName);
Console.String(", f.workName = "); Console.String(f.workName); Console.Ln;
*)
IF f.fd >= 0 THEN
fileTab[f.fd] := 0; res := Unix.Close(f.fd); f.fd := -1; DEC(Kernel.nofiles);
IF f.tempFile THEN res := Unix.Unlink(f.workName) END
fileTab[f.fd] := 0; res := Platform.Close(f.fd); f.fd := -1; DEC(Heap.FileCount);
IF f.tempFile THEN res := Platform.Unlink(f.workName) END
END
END Finalize;
PROCEDURE SetSearchPath*(path: ARRAY OF CHAR);
BEGIN
IF Strings.Length(path) # 0 THEN
NEW(SearchPath, Strings.Length(path)+1);
COPY(path, SearchPath^)
ELSE
SearchPath := NIL
END
END SetSearchPath;
PROCEDURE Init;
VAR i: LONGINT;
BEGIN
i := 0; WHILE i < fileTabSize DO fileTab[i] := 0; INC(i) END;
tempno := -1; Kernel.nofiles := 0
tempno := -1;
Heap.FileCount := 0;
SearchPath := NIL;
HOME := ""; Platform.GetEnv("HOME", HOME);
END Init;
BEGIN Init
END Files0.
END Files.

245
src/system/Heap.Mod
View file

@ -1,17 +1,7 @@
(*
* voc (jet backend) runtime system, Version 1.1
*
* Copyright (c) Software Templ, 1994, 1995, 1996
*
* Module SYSTEM is subject to change any time without prior notification.
* Software Templ disclaims all warranties with regard to module SYSTEM,
* in particular shall Software Templ not be liable for any damage resulting
* from inappropriate use or modification of module SYSTEM.
*)
MODULE Heap;
MODULE SYSTEM; (* J. Templ, 31.5.95 *)
IMPORT SYSTEM; (*must not import other modules*)
IMPORT SYSTEM; (* Cannot import anything else as heap initialization must complete
before any other modules are initialized. *)
CONST
ModNameLen = 20;
@ -24,23 +14,23 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
(* all blocks look the same:
free blocks describe themselves: size = Unit
tag = &tag++
->blksize
->block size
sentinel = -SZL
next
*)
(* heap chunks *)
nextChnkOff = 0; (* next heap chunk, sorted ascendingly! *)
endOff = SZL; (* end of heap chunk *)
blkOff = 3*SZL; (* first block in a chunk *)
nextChnkOff = LONG(LONG(0)); (* next heap chunk, sorted ascendingly! *)
endOff = LONG(LONG(SZL)); (* end of heap chunk *)
blkOff = LONG(LONG(3*SZL)); (* first block in a chunk *)
(* heap blocks *)
tagOff = 0; (* block starts with tag *)
sizeOff = SZL; (* block size in free block relative to block start *)
sntlOff = 2*SZL; (* pointer offset table sentinel in free block relative to block start *)
nextOff = 3*SZL; (* next pointer in free block relative to block start *)
tagOff = LONG(LONG(0)); (* block starts with tag *)
sizeOff = LONG(LONG(SZL)); (* block size in free block relative to block start *)
sntlOff = LONG(LONG(2*SZL)); (* pointer offset table sentinel in free block relative to block start *)
nextOff = LONG(LONG(3*SZL)); (* next pointer in free block relative to block start *)
NoPtrSntl = LONG(LONG(-SZL));
LongZero = LONG(LONG(0));
TYPE
ModuleName = ARRAY ModNameLen OF CHAR;
@ -48,7 +38,9 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
Module = POINTER TO ModuleDesc;
Cmd = POINTER TO CmdDesc;
EnumProc = PROCEDURE(P: PROCEDURE(p: SYSTEM.PTR));
ModuleDesc = RECORD
next: Module;
name: ModuleName;
@ -82,25 +74,42 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
modules*: SYSTEM.PTR;
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;
(* extensible heap *)
heap, (* the sorted list of heap chunks *)
heapend, (* max possible pointer value (used for stack collection) *)
heap: LONGINT; (* the sorted list of heap chunks *)
heapend: LONGINT; (* max possible pointer value (used for stack collection) *)
heapsize*: LONGINT; (* the sum of all heap chunk sizes *)
(* finalization candidates *)
fin: FinNode;
(* garbage collector locking *)
gclock*: SHORTINT;
lockdepth: INTEGER;
interrupted: BOOLEAN;
(* File system file count monitor *)
FileCount*: INTEGER;
PROCEDURE 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 *)
VAR oldflag : BOOLEAN;
@ -110,13 +119,20 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
RETURN oldflag;
END TAS;
*)
PROCEDURE REGMOD*(VAR name: ModuleName; enumPtrs: EnumProc): SYSTEM.PTR;
VAR m: Module;
BEGIN
IF name = "SYSTEM" THEN (* cannot use NEW *)
SYSTEM.NEW(m, SIZE(ModuleDesc)); m.cmds := NIL
ELSE NEW(m)
(* REGMOD is called at the start of module initialisation code before that modules
type descriptors have been set up. 'NEW' depends on the Heap modules type
descriptors being ready for use, therefore, just for the Heap module itself, we
must use SYSTEM.NEW. *)
IF name = "Heap" THEN
SYSTEM.NEW(m, SIZE(ModuleDesc))
ELSE
NEW(m)
END;
m.types := 0; m.cmds := NIL;
COPY(name, m.name); m.refcnt := 0; m.enumPtrs := enumPtrs; m.next := SYSTEM.VAL(Module, modules);
modules := m;
RETURN m
@ -124,7 +140,16 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
PROCEDURE REGCMD*(m: Module; VAR name: CmdName; cmd: Command);
VAR c: Cmd;
BEGIN NEW(c);
BEGIN
(* REGCMD is called during module initialisation code before that modules
type descriptors have been set up. 'NEW' depends on the Heap modules type
descriptors being ready for use, therefore, just for the commands registered
by the Heap module itself, we must use SYSTEM.NEW. *)
IF m.name = "Heap" THEN
SYSTEM.NEW(c, SIZE(CmdDesc))
ELSE
NEW(c)
END;
COPY(name, c.name); c.cmd := cmd; c.next := m.cmds; m.cmds := c
END REGCMD;
@ -136,10 +161,14 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
BEGIN INC(m.refcnt)
END INCREF;
PROCEDURE -ExternPlatformOSAllocate "extern LONGINT Platform_OSAllocate(LONGINT size);";
PROCEDURE -OSAllocate(size: LONGINT): LONGINT "Platform_OSAllocate(size)";
PROCEDURE NewChunk(blksz: LONGINT): LONGINT;
VAR chnk: LONGINT;
BEGIN
chnk := malloc(blksz + blkOff);
chnk := OSAllocate(blksz + blkOff);
IF chnk # 0 THEN
SYSTEM.PUT(chnk + endOff, chnk + (blkOff + blksz));
SYSTEM.PUT(chnk + blkOff, chnk + (blkOff + sizeOff));
@ -152,6 +181,13 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
RETURN chnk
END NewChunk;
(* FetchAddress fetches a pointer from memory and returns it as a LONGINT. It works
correctly regardless of the size of an address. Specifically on 32 bit address
architectures with 64 bit LONGINT, it loads 32 bits and extends it to LONGINT
rather than loading 64 bits. *)
PROCEDURE -FetchAddress(pointer: LONGINT): LONGINT "(LONGINT)(uintptr_t)(*((void**)((uintptr_t)pointer)))";
PROCEDURE ExtendHeap(blksz: LONGINT);
VAR size, chnk, j, next: LONGINT;
BEGIN
@ -164,28 +200,37 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
IF chnk < heap THEN
SYSTEM.PUT(chnk, heap); heap := chnk
ELSE
j := heap; SYSTEM.GET(j, next);
WHILE (next # 0) & (chnk > next) DO j := next; SYSTEM.GET(j, next) END ;
j := heap; next := FetchAddress(j);
WHILE (next # 0) & (chnk > next) DO
j := next;
next := FetchAddress(j)
END;
SYSTEM.PUT(chnk, next); SYSTEM.PUT(j, chnk)
END ;
IF next = 0 THEN SYSTEM.GET(chnk + endOff, heapend) END
IF next = 0 THEN heapend := FetchAddress(chnk+endOff) END
END
END ExtendHeap;
PROCEDURE ^GC*(markStack: BOOLEAN);
PROCEDURE NEWREC*(tag: LONGINT): SYSTEM.PTR;
VAR i, i0, di, blksz, restsize, t, adr, end, next, prev: LONGINT; new: SYSTEM.PTR;
VAR
i, i0, di, blksz, restsize, t, adr, end, next, prev: LONGINT;
new: SYSTEM.PTR;
BEGIN
Lock();
SYSTEM.GET(tag, blksz);
blksz := FetchAddress(tag);
ASSERT((Unit = 16) OR (Unit = 32));
ASSERT(SIZE(SYSTEM.PTR) <= SIZE(LONGINT));
ASSERT(blksz MOD Unit = 0);
i0 := blksz DIV Unit; i := i0;
IF i < nofLists THEN adr := freeList[i];
WHILE adr = 0 DO INC(i); adr := freeList[i] END
END ;
IF i < nofLists THEN (* unlink *)
SYSTEM.GET(adr + nextOff, next);
next := FetchAddress(adr + nextOff);
freeList[i] := next;
IF i # i0 THEN (* split *)
di := i - i0; restsize := di * Unit; end := adr + restsize;
@ -219,9 +264,9 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
Unlock(); RETURN NIL
END
END ;
SYSTEM.GET(adr+sizeOff, t);
t := FetchAddress(adr+sizeOff);
IF t >= blksz THEN EXIT END ;
prev := adr; SYSTEM.GET(adr + nextOff, adr)
prev := adr; adr := FetchAddress(adr + nextOff)
END ;
restsize := t - blksz; end := adr + restsize;
SYSTEM.PUT(end + sizeOff, blksz);
@ -230,7 +275,7 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
IF restsize > nofLists * Unit THEN (*resize*)
SYSTEM.PUT(adr + sizeOff, restsize)
ELSE (*unlink*)
SYSTEM.GET(adr + nextOff, next);
next := FetchAddress(adr + nextOff);
IF prev = 0 THEN bigBlocks := next
ELSE SYSTEM.PUT(prev + nextOff, next);
END ;
@ -245,16 +290,16 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
END ;
i := adr + 4*SZL; end := adr + blksz;
WHILE i < end DO (*deliberately unrolled*)
SYSTEM.PUT(i, LONG(LONG(0)));
SYSTEM.PUT(i + SZL, LONG(LONG(0)));
SYSTEM.PUT(i + 2*SZL, LONG(LONG(0)));
SYSTEM.PUT(i + 3*SZL, LONG(LONG(0)));
SYSTEM.PUT(i, LongZero);
SYSTEM.PUT(i + SZL, LongZero);
SYSTEM.PUT(i + 2*SZL, LongZero);
SYSTEM.PUT(i + 3*SZL, LongZero);
INC(i, 4*SZL)
END ;
SYSTEM.PUT(adr + nextOff, LONG(LONG(0)));
SYSTEM.PUT(adr + nextOff, LongZero);
SYSTEM.PUT(adr, tag);
SYSTEM.PUT(adr + sizeOff, LONG(LONG(0)));
SYSTEM.PUT(adr + sntlOff, LONG(LONG(0)));
SYSTEM.PUT(adr + sizeOff, LongZero);
SYSTEM.PUT(adr + sntlOff, LongZero);
INC(allocated, blksz);
Unlock();
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*)
new := NEWREC(SYSTEM.ADR(blksz));
tag := SYSTEM.VAL(LONGINT, new) + blksz - 3*SZL;
SYSTEM.PUT(tag - SZL, LONG(LONG(0))); (*reserved for meta info*)
SYSTEM.PUT(tag - SZL, LongZero); (*reserved for meta info*)
SYSTEM.PUT(tag, blksz);
SYSTEM.PUT(tag + SZL, NoPtrSntl);
SYSTEM.PUT(SYSTEM.VAL(LONGINT, new) - SZL, tag);
@ -278,28 +323,31 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
PROCEDURE Mark(q: LONGINT);
VAR p, tag, fld, n, offset, tagbits: LONGINT;
BEGIN
IF q # 0 THEN SYSTEM.GET(q - SZL, tagbits);
IF ~ODD(tagbits) THEN
SYSTEM.PUT(q - SZL, tagbits + 1);
p := 0; tag := tagbits + SZL;
IF q # 0 THEN
tagbits := FetchAddress(q - SZL); (* Load the tag for the record at q *)
IF ~ODD(tagbits) THEN (* If it has not already been marked *)
SYSTEM.PUT(q - SZL, tagbits + 1); (* Mark it *)
p := 0;
tag := tagbits + SZL; (* Tag addresses first offset *)
LOOP
SYSTEM.GET(tag, offset);
IF offset < 0 THEN
SYSTEM.PUT(q - SZL, tag + offset + 1);
SYSTEM.GET(tag, offset); (* Get next ptr field offset *)
IF offset < 0 THEN (* If sentinel. (Value is -8*(#fields+1) *)
SYSTEM.PUT(q - SZL, tag + offset + 1); (* Rotate base ptr into tag *)
IF p = 0 THEN EXIT END ;
n := q; q := p;
SYSTEM.GET(q - SZL, tag); DEC(tag, 1);
tag := FetchAddress(q - SZL); DEC(tag, 1);
SYSTEM.GET(tag, offset); fld := q + offset;
SYSTEM.GET(fld, p); SYSTEM.PUT(fld, n)
ELSE
fld := q + offset;
SYSTEM.GET(fld, n);
IF n # 0 THEN
SYSTEM.GET(n - SZL, tagbits);
p := FetchAddress(fld); SYSTEM.PUT(fld, SYSTEM.VAL(SYSTEM.PTR, n))
ELSE (* offset references a ptr field *)
fld := q + offset; (* Address the pointer *)
n := FetchAddress(fld); (* Load the pointer *)
IF n # 0 THEN (* If pointer is not NIL *)
tagbits := FetchAddress(n - SZL); (* Consider record pointed to by this field *)
IF ~ODD(tagbits) THEN
SYSTEM.PUT(n - SZL, tagbits + 1);
SYSTEM.PUT(q - SZL, tag + 1);
SYSTEM.PUT(fld, p); p := q; q := n;
SYSTEM.PUT(fld, SYSTEM.VAL(SYSTEM.PTR, p));
p := q; q := n;
tag := tagbits
END
END
@ -321,9 +369,10 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
WHILE i < nofLists DO freeList[i] := 0; INC(i) END ;
freesize := 0; allocated := 0; chnk := heap;
WHILE chnk # 0 DO
adr := chnk + blkOff; SYSTEM.GET(chnk + endOff, end);
adr := chnk + blkOff;
end := FetchAddress(chnk + endOff);
WHILE adr < end DO
SYSTEM.GET(adr, tag);
tag := FetchAddress(adr);
IF ODD(tag) THEN (*marked*)
IF freesize > 0 THEN
start := adr - freesize;
@ -337,11 +386,11 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
END ;
DEC(tag, 1);
SYSTEM.PUT(adr, tag);
SYSTEM.GET(tag, size);
size := FetchAddress(tag);
INC(allocated, size);
INC(adr, size)
ELSE (*unmarked*)
SYSTEM.GET(tag, size);
size := FetchAddress(tag);
INC(freesize, size);
INC(adr, size)
END
@ -356,7 +405,7 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
ELSE SYSTEM.PUT(start + nextOff, bigBlocks); bigBlocks := start
END
END ;
SYSTEM.GET(chnk, chnk)
chnk := FetchAddress(chnk)
END
END Scan;
@ -384,14 +433,14 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
chnk := heap; i := 0; lim := cand[n-1];
WHILE (chnk # 0 ) & (chnk < lim) DO
adr := chnk + blkOff;
SYSTEM.GET(chnk + endOff, lim1);
lim1 := FetchAddress(chnk + endOff);
IF lim < lim1 THEN lim1 := lim END ;
WHILE adr < lim1 DO
SYSTEM.GET(adr, tag);
tag := FetchAddress(adr);
IF ODD(tag) THEN (*already marked*)
SYSTEM.GET(tag-1, size); INC(adr, size)
size := FetchAddress(tag-1); INC(adr, size)
ELSE
SYSTEM.GET(tag, size);
size := FetchAddress(tag);
ptr := adr + SZL;
WHILE cand[i] < ptr DO INC(i) END ;
IF i = n THEN RETURN END ;
@ -400,15 +449,16 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
adr := next
END
END ;
SYSTEM.GET(chnk, chnk)
chnk := FetchAddress(chnk)
END
END MarkCandidates;
PROCEDURE CheckFin;
VAR n: FinNode; tag: LONGINT;
BEGIN n := fin;
BEGIN
n := fin;
WHILE n # NIL DO
SYSTEM.GET(n.obj - SZL, tag);
tag := FetchAddress(n.obj - SZL);
IF ~ODD(tag) THEN n.marked := FALSE; Mark(n.obj)
ELSE n.marked := TRUE
END ;
@ -425,7 +475,8 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
n.finalize(SYSTEM.VAL(SYSTEM.PTR, n.obj));
(* new nodes may have been pushed in n.finalize, therefore: *)
IF prev = NIL THEN n := fin ELSE n := n.next END
ELSE prev := n; n := n.next
ELSE
prev := n; n := n.next
END
END
END Finalize;
@ -439,6 +490,9 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
END
END FINALL;
PROCEDURE -ExternMainStackFrame "extern LONGINT Platform_MainStackFrame;";
PROCEDURE -PlatformMainStackFrame(): LONGINT "Platform_MainStackFrame";
PROCEDURE MarkStack(n: LONGINT; VAR cand: ARRAY OF LONGINT);
VAR
frame: SYSTEM.PTR;
@ -451,7 +505,7 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
END ;
IF n = 0 THEN
nofcand := 0; sp := SYSTEM.ADR(frame);
stack0 := Mainfrm();
stack0 := PlatformMainStackFrame();
(* check for minimum alignment of pointers *)
inc := SYSTEM.ADR(align.p) - SYSTEM.ADR(align);
IF sp > stack0 THEN inc := -inc END ;
@ -473,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;
cand: ARRAY 10000 OF LONGINT;
BEGIN
IF (gclock = 0) OR (gclock = 1) & ~markStack THEN
IF (lockdepth = 0) OR (lockdepth = 1) & ~markStack THEN
Lock();
m := SYSTEM.VAL(Module, modules);
WHILE m # NIL DO
@ -503,18 +557,29 @@ MODULE SYSTEM; (* J. Templ, 31.5.95 *)
END
END GC;
PROCEDURE REGFIN*(obj: SYSTEM.PTR; finalize: Finalizer);
PROCEDURE RegisterFinalizer*(obj: SYSTEM.PTR; finalize: Finalizer);
VAR f: FinNode;
BEGIN NEW(f);
f.obj := SYSTEM.VAL(LONGINT, obj); f.finalize := finalize; f.marked := TRUE; f.next := fin; fin := f
END REGFIN;
f.obj := SYSTEM.VAL(LONGINT, obj); f.finalize := finalize; f.marked := TRUE;
f.next := fin; fin := f;
END RegisterFinalizer;
PROCEDURE InitHeap; (* initialized before body to enable NEW, SYSTEM.NEW *)
PROCEDURE -ExternHeapInit "extern void *Heap__init();";
PROCEDURE -HeapModuleInit 'Heap__init()';
PROCEDURE InitHeap*;
(* InitHeap is called by Platform.init before any module bodies have been
initialised, to enable NEW, SYSTEM.NEW *)
BEGIN
heap := NewChunk(heapSize0);
SYSTEM.GET(heap + endOff, heapend);
SYSTEM.PUT(heap, LONG(LONG(0)));
allocated := 0; firstTry := TRUE; freeList[nofLists] := 1; gclock := 0
heapend := FetchAddress(heap + endOff);
SYSTEM.PUT(heap, LongZero);
allocated := 0; firstTry := TRUE; freeList[nofLists] := 1; lockdepth := 0;
FileCount := 0; modules := NIL; heapsize := 0; bigBlocks := 0; fin := NIL;
interrupted := FALSE;
HeapModuleInit;
END InitHeap;
END SYSTEM.
END Heap.

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 *)
IMPORT Kernel, Texts, Args, Out := Console;
TYPE
IMPORT Platform, Texts, Args, Console;
TYPE
ParList* = POINTER TO ParRec;
ParRec* = RECORD
@ -18,21 +18,24 @@ MODULE Oberon;
Log*: Texts.Text;
Par*: ParList; (*actual parameters*)
R: Texts.Reader;
W: Texts.Writer;
OptionChar*: CHAR;
(*clocks*)
PROCEDURE GetClock* (VAR t, d: LONGINT);
BEGIN Kernel.GetClock(t, d)
BEGIN Platform.GetClock(t, d)
END GetClock;
PROCEDURE Time* (): LONGINT;
BEGIN
RETURN Kernel.Time()
RETURN Platform.Time()
END Time;
PROCEDURE PopulateParams;
VAR W : Texts.Writer;
VAR
W: Texts.Writer;
i: INTEGER;
str: ARRAY 32 OF CHAR;
BEGIN
@ -52,47 +55,23 @@ MODULE Oberon;
Texts.Append (Par^.text, W.buf);
END PopulateParams;
(*
PROCEDURE DumpLog*;
VAR R : Texts.Reader;
ch : CHAR;
BEGIN
Texts.OpenReader(R, Log, 0);
REPEAT
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);
Out.Char(ch);
UNTIL R.eot;
END DumpLog;
*)
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;
IF ch = 0DX THEN Console.Ln ELSE Console.Char(ch) END;
INC(beg)
END
END LogNotifier;
BEGIN
NEW(Par);
@ -103,4 +82,5 @@ BEGIN
PopulateParams;
NEW(Log);
Texts.Open(Log, "");
Log.notify := LogNotifier;
END Oberon.

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"
#ifdef __STDC__
#include "stdarg.h"
#else
#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)
#include <signal.h>
static void SYSTEM_InitHeap();
void *SYSTEM__init();
LONGINT SYSTEM_XCHK(LONGINT i, LONGINT ub) {return __X(i, ub);}
LONGINT SYSTEM_RCHK(LONGINT i, LONGINT ub) {return __R(i, ub);}
LONGINT SYSTEM_ASH (LONGINT i, LONGINT n) {return __ASH(i, n);}
LONGINT SYSTEM_ABS (LONGINT i) {return __ABS(i);}
double SYSTEM_ABSD(double i) {return __ABS(i);}
void SYSTEM_INIT(argc, argvadr)
int argc; long argvadr;
{
SYSTEM_mainfrm = argvadr;
SYSTEM_argc = argc;
SYSTEM_argv = *(long*)argvadr;
SYSTEM_InitHeap();
SYSTEM_halt = -128;
SYSTEM__init();
}
void SYSTEM_FINI()
{
SYSTEM_FINALL();
}
long SYSTEM_XCHK(i, ub) long i, ub; {return __X(i, ub);}
long SYSTEM_RCHK(i, ub) long i, ub; {return __R(i, ub);}
long SYSTEM_ASH(i, n) long i, n; {return __ASH(i, n);}
long SYSTEM_ABS(i) long i; {return __ABS(i);}
double SYSTEM_ABSD(i) double i; {return __ABS(i);}
void SYSTEM_INHERIT(t, t0)
long *t, *t0;
void SYSTEM_INHERIT(LONGINT *t, LONGINT *t0)
{
t -= __TPROC0OFF;
t0 -= __TPROC0OFF;
while (*t0 != __EOM) {*t = *t0; t--; t0--;}
}
void SYSTEM_ENUMP(adr, n, P)
long *adr;
long n;
void (*P)();
void SYSTEM_ENUMP(void *adr, LONGINT 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)
char *adr;
long *typ, size, n;
void (*P)();
void SYSTEM_ENUMR(void *adr, LONGINT *typ, LONGINT size, LONGINT n, void (*P)())
{
long *t, off;
LONGINT *t, off;
typ++;
while (n > 0) {
t = typ;
off = *t;
while (off >= 0) {P(*(long*)(adr+off)); t++; off = *t;}
adr += size; n--;
while (off >= 0) {P(*(LONGINT*)((char*)adr+off)); t++; off = *t;}
adr = ((char*)adr) + size;
n--;
}
}
long SYSTEM_DIV(x, y)
unsigned long x, y;
{ if ((long) x >= 0) return (x / y);
LONGINT SYSTEM_DIV(unsigned LONGINT x, unsigned LONGINT y)
{ if ((LONGINT) x >= 0) return (x / y);
else return -((y - 1 - x) / y);
}
long SYSTEM_MOD(x, y)
unsigned long x, y;
{ unsigned long m;
if ((long) x >= 0) return (x % y);
LONGINT SYSTEM_MOD(unsigned LONGINT x, unsigned LONGINT y)
{ unsigned LONGINT m;
if ((LONGINT) x >= 0) return (x % y);
else { m = (-x) % y;
if (m != 0) return (y - m); else return 0;
}
}
long SYSTEM_ENTIER(x)
double x;
LONGINT SYSTEM_ENTIER(double x)
{
long y;
LONGINT y;
if (x >= 0)
return (long)x;
return (LONGINT)x;
else {
y = (long)x;
y = (LONGINT)x;
if (y <= x) return y; else return y - 1;
}
}
void SYSTEM_HALT(n)
int n;
{
SYSTEM_halt = n;
if (SYSTEM_Halt!=0) SYSTEM_Halt(n);
exit(n);
}
extern void Heap_Lock();
extern void Heap_Unlock();
#ifdef __STDC__
SYSTEM_PTR SYSTEM_NEWARR(long *typ, long elemsz, int elemalgn, int nofdim, int nofdyn, ...)
#else
SYSTEM_PTR SYSTEM_NEWARR(typ, elemsz, elemalgn, nofdim, nofdyn, va_alist)
long *typ, elemsz;
int elemalgn, nofdim, nofdyn;
va_dcl
#endif
SYSTEM_PTR SYSTEM_NEWARR(LONGINT *typ, LONGINT elemsz, int elemalgn, int nofdim, int nofdyn, ...)
{
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;
#ifdef __STDC__
va_start(ap, nofdyn);
#else
va_start(ap);
#endif
nofelems = 1;
while (nofdim > 0) {
nofelems = nofelems * va_arg(ap, long); nofdim--;
nofelems = nofelems * va_arg(ap, LONGINT); nofdim--;
if (nofelems <= 0) __HALT(-20);
}
va_end(ap);
dataoff = nofdyn * sizeof(long);
if (elemalgn > sizeof(long)) {
dataoff = nofdyn * sizeof(LONGINT);
if (elemalgn > sizeof(LONGINT)) {
n = dataoff % elemalgn;
if (n != 0) dataoff += elemalgn - n;
}
size = dataoff + nofelems * elemsz;
Lock;
Heap_Lock();
if (typ == NIL) {
/* 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 */
x = SYSTEM_NEWBLK(size + nofelems * sizeof(long));
p = (long*)x[-1];
x = Heap_NEWBLK(size + nofelems * sizeof(LONGINT));
p = (LONGINT*)(uintptr_t)x[-1];
p[-nofelems] = *p; /* build new type desc in situ: 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */
p -= nofelems - 1; n = 1; /* n =1 for skipping the size field */
while (n <= nofelems) {*p = n*sizeof(long); p++; n++;}
*p = - (nofelems + 1) * sizeof(long); /* sentinel */
x[-1] -= nofelems * sizeof(long);
while (n <= nofelems) {*p = n*sizeof(LONGINT); p++; n++;}
*p = - (nofelems + 1) * sizeof(LONGINT); /* sentinel */
x[-1] -= nofelems * sizeof(LONGINT);
}
else {
/* element type is a record that contains pointers */
ptab = typ + 1; nofptrs = 0;
while (ptab[nofptrs] >= 0) {nofptrs++;} /* number of pointers per element */
nptr = nofelems * nofptrs; /* total number of pointers */
x = SYSTEM_NEWBLK(size + nptr * sizeof(long));
p = (long*)x[- 1];
x = Heap_NEWBLK(size + nptr * sizeof(LONGINT));
p = (LONGINT*)(uintptr_t)x[- 1];
p[-nptr] = *p; /* build new type desc in situ; 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */
p -= nptr - 1; n = 0; off = dataoff;
while (n < nofelems) {i = 0;
while (i < nofptrs) {*p = off + ptab[i]; p++; i++;}
off += elemsz; n++;
}
*p = - (nptr + 1) * sizeof(long); /* sentinel */
x[-1] -= nptr * sizeof(long);
*p = - (nptr + 1) * sizeof(LONGINT); /* sentinel */
x[-1] -= nptr * sizeof(LONGINT);
}
if (nofdyn != 0) {
/* setup len vector for index checks */
#ifdef __STDC__
va_start(ap, nofdyn);
#else
va_start(ap);
#endif
p = x;
while (nofdyn > 0) {*p = va_arg(ap, long); p++, nofdyn--;}
while (nofdyn > 0) {*p = va_arg(ap, LONGINT); p++, nofdyn--;}
va_end(ap);
}
Unlock;
Heap_Unlock();
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
#define SYSTEM__h
/*
#ifndef _WIN32
voc (jet backend) runtime system interface and macros library
copyright (c) Josef Templ, 1995, 1996
// Building for a Unix/Linux based system
#include <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
extern SYSTEM_PTR SYSTEM_NEWARR();
#endif
extern SYSTEM_PTR SYSTEM_REGMOD();
extern void SYSTEM_INCREF();
extern void SYSTEM_REGCMD();
extern void SYSTEM_REGTYP();
extern void SYSTEM_REGFIN();
extern void SYSTEM_FINALL();
extern void SYSTEM_INIT();
extern void SYSTEM_FINI();
extern void SYSTEM_HALT();
extern void SYSTEM_INHERIT();
extern void SYSTEM_ENUMP();
extern void SYSTEM_ENUMR();
/* module registry */
#define __DEFMOD static void *m; if(m!=0)return m
#define __REGMOD(name, enum) if(m==0)m=SYSTEM_REGMOD((CHAR*)name,enum); else return m
#define __ENDMOD return m
#define __INIT(argc, argv) static void *m; SYSTEM_INIT(argc, (long)&argv);
#define __REGMAIN(name, enum) m=SYSTEM_REGMOD(name,enum)
#define __FINI SYSTEM_FINI(); return 0
#define __IMPORT(name) SYSTEM_INCREF(name##__init())
#define __REGCMD(name, cmd) SYSTEM_REGCMD(m, name, cmd)
// Building for Windows platform with either mingw under cygwin, or the MS C compiler
#ifdef _WIN64
typedef unsigned long long size_t;
typedef unsigned long long uintptr_t;
#else
typedef unsigned int size_t;
typedef unsigned int uintptr_t;
#endif /* _WIN64 */
typedef unsigned int uint32_t;
void * __cdecl memcpy(void * dest, const void * source, size_t size);
#endif
// The compiler uses 'import' and 'export' which translate to 'extern' and
// nothing respectively.
#define import extern
#define export
// Known constants
#define NIL ((void*)0)
#define __MAXEXT 16
#define POINTER__typ ((LONGINT*)(1)) // not NIL and not a valid type
// Oberon types
#define BOOLEAN char
#define SYSTEM_BYTE unsigned char
#define CHAR unsigned char
#define SHORTINT signed char
#define REAL float
#define LONGREAL double
#define SYSTEM_PTR void*
// For 32 bit builds, the size of LONGINT depends on a make option:
#if (__SIZEOF_POINTER__ == 8) || defined(LARGE) || defined(_WIN64)
#define INTEGER int // INTEGER is 32 bit.
#define LONGINT long long // LONGINT is 64 bit. (long long is always 64 bits, while long can be 32 bits e.g. under MSC/MingW)
#else
#define INTEGER short int // INTEGER is 16 bit.
#define LONGINT long // LONGINT is 32 bit.
#endif
#define SET unsigned LONGINT
// OS Memory allocation interfaces are in PlatformXXX.Mod
extern LONGINT Platform_OSAllocate (LONGINT size);
extern void Platform_OSFree (LONGINT addr);
// Run time system routines in SYSTEM.c
extern LONGINT SYSTEM_XCHK (LONGINT i, LONGINT ub);
extern LONGINT SYSTEM_RCHK (LONGINT i, LONGINT ub);
extern LONGINT SYSTEM_ASH (LONGINT i, LONGINT n);
extern LONGINT SYSTEM_ABS (LONGINT i);
extern double SYSTEM_ABSD (double i);
extern void SYSTEM_INHERIT(LONGINT *t, LONGINT *t0);
extern void SYSTEM_ENUMP (void *adr, LONGINT n, void (*P)());
extern void SYSTEM_ENUMR (void *adr, LONGINT *typ, LONGINT size, LONGINT n, void (*P)());
extern LONGINT SYSTEM_DIV (unsigned LONGINT x, unsigned LONGINT y);
extern LONGINT SYSTEM_MOD (unsigned LONGINT x, unsigned LONGINT y);
extern LONGINT SYSTEM_ENTIER (double x);
// Signal handling in SYSTEM.c
#ifndef _WIN32
extern void SystemSetHandler(int s, uintptr_t h);
#else
extern void SystemSetInterruptHandler(uintptr_t h);
extern void SystemSetQuitHandler (uintptr_t h);
#endif
// String comparison
static int __str_cmp(CHAR *x, CHAR *y){
LONGINT i = 0;
CHAR ch1, ch2;
do {ch1 = x[i]; ch2 = y[i]; i++;
if (!ch1) return -(int)ch2;
} while (ch1==ch2);
return (int)ch1 - (int)ch2;
}
#define __STRCMP(a,b) __str_cmp((CHAR*)(a), (CHAR*)(b))
// Inline string, record and array copy
#define __COPY(s, d, n) {char*_a=(void*)s,*_b=(void*)d; LONGINT _i=0,_t=n-1; \
while(_i<_t&&((_b[_i]=_a[_i])!=0)){_i++;};_b[_i]=0;}
#define __DUP(x, l, t) x=(void*)memcpy((void*)(uintptr_t)Platform_OSAllocate(l*sizeof(t)),x,l*sizeof(t))
#define __DUPARR(v, t) v=(void*)memcpy(v##__copy,v,sizeof(t))
#define __DEL(x) Platform_OSFree((LONGINT)(uintptr_t)x)
/* SYSTEM ops */
#define __SYSNEW(p, len) p=SYSTEM_NEWBLK((long)(len))
#define __VAL(t, x) (*(t*)&(x))
#define __GET(a, x, t) x= *(t*)(a)
#define __PUT(a, x, t) *(t*)(a)=x
#define __VAL(t, x) ((t)(x))
#define __VALP(t, x) ((t)(uintptr_t)(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 __LSHR(x, n, t) ((t)((unsigned t)(x)>>(n)))
#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 __ROTR(x, n, t) ((t)((unsigned t)(x)>>(n)|(unsigned t)(x)<<(8*sizeof(t)-(n))))
#define __ROT(x, n, t) ((n)>=0? __ROTL(x, n, t): __ROTR(x, -(n), t))
#define __BIT(x, n) (*(unsigned long*)(x)>>(n)&1)
#define __MOVE(s, d, n) memcpy((char*)(d),(char*)(s),n)
/* std procs and operator mappings */
#define __SHORT(x, y) ((int)((unsigned long)(x)+(y)<(y)+(y)?(x):(__HALT(-8),0)))
#define __BIT(x, n) (*(unsigned LONGINT*)(x)>>(n)&1)
#define __MOVE(s, d, n) memcpy((char*)(uintptr_t)(d),(char*)(uintptr_t)(s),n)
#define __ASHL(x, n) ((LONGINT)(x)<<(n))
#define __ASHR(x, n) ((LONGINT)(x)>>(n))
#define __ASH(x, n) ((n)>=0?__ASHL(x,n):__ASHR(x,-(n)))
#define __ASHF(x, n) SYSTEM_ASH((LONGINT)(x), (LONGINT)(n))
#define __SHORT(x, y) ((int)((unsigned LONGINT)(x)+(y)<(y)+(y)?(x):(__HALT(-8),0)))
#define __SHORTF(x, y) ((int)(__RF((x)+(y),(y)+(y))-(y)))
#define __CHR(x) ((CHAR)__R(x, 256))
#define __CHRF(x) ((CHAR)__RF(x, 256))
#define __DIV(x, y) ((x)>=0?(x)/(y):-(((y)-1-(x))/(y)))
#define __DIVF(x, y) SYSTEM_DIV((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 __MODF(x, y) SYSTEM_MOD((long)(x),(long)(y))
#define __NEW(p, t) p=SYSTEM_NEWREC((long)t##__typ)
#define __NEWARR SYSTEM_NEWARR
#define __HALT(x) SYSTEM_HALT(x)
#define __ASSERT(cond, x) if (!(cond)) {SYSTEM_assert = x; SYSTEM_HALT(-1);}
#define __MODF(x, y) SYSTEM_MOD((LONGINT)(x),(LONGINT)(y))
#define __ENTIER(x) SYSTEM_ENTIER(x)
#define __ABS(x) (((x)<0)?-(x):(x))
#define __ABSF(x) SYSTEM_ABS((long)(x))
#define __ABSF(x) SYSTEM_ABS((LONGINT)(x))
#define __ABSFD(x) SYSTEM_ABSD((double)(x))
#define __CAP(ch) ((CHAR)((ch)&0x5f))
#define __ODD(x) ((x)&1)
@ -137,102 +160,116 @@ extern void SYSTEM_ENUMR();
#define __SETOF(x) ((SET)1<<(x))
#define __SETRNG(l, h) ((~(SET)0<<(l))&~(SET)0>>(8*sizeof(SET)-1-(h)))
#define __MASK(x, m) ((x)&~(m))
#define __COPY(s, d, n) {char*_a=(void*)s,*_b=(void*)d;long _i=0,_t=n-1;while(_i<_t&&((_b[_i]=_a[_i])!=0)){_i++;};_b[_i]=0;}
static int __STRCMP(x, y)
CHAR *x, *y;
{long i = 0; CHAR ch1, ch2;
do {ch1 = x[i]; ch2 = y[i]; i++;
if (!ch1) return -(int)ch2;
} while (ch1==ch2);
return (int)ch1 - (int)ch2;
}
#define __ASH(x, n) ((n)>=0?__ASHL(x,n):__ASHR(x,-(n)))
#define __ASHL(x, n) ((long)(x)<<(n))
#define __ASHR(x, n) ((long)(x)>>(n))
#define __ASHF(x, n) SYSTEM_ASH((long)(x), (long)(n))
#define __DUP(x, l, t) x=(void*)memcpy(alloca(l*sizeof(t)),x,l*sizeof(t))
#define __DUPARR(v, t) v=(void*)memcpy(v##__copy,v,sizeof(t))
#define __DEL(x) /* DUP with alloca frees storage automatically */
#define __IS(tag, typ, level) (*(tag-(__BASEOFF-level))==(long)typ##__typ)
#define __TYPEOF(p) (*(((long**)(p))-1))
#define __ISP(p, typ, level) __IS(__TYPEOF(p),typ,level)
/* runtime checks */
#define __X(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-2),0))
#define __XF(i, ub) SYSTEM_XCHK((long)(i), (long)(ub))
#define __RETCHK __retchk: __HALT(-3)
// Runtime checks
#define __X(i, ub) (((unsigned LONGINT)(i)<(unsigned LONGINT)(ub))?i:(__HALT(-2),0))
#define __XF(i, ub) SYSTEM_XCHK((LONGINT)(i), (LONGINT)(ub))
#define __R(i, ub) (((unsigned LONGINT)(i)<(unsigned LONGINT)(ub))?i:(__HALT(-8),0))
#define __RF(i, ub) SYSTEM_RCHK((LONGINT)(i),(LONGINT)(ub))
#define __RETCHK __retchk: __HALT(-3); return 0;
#define __CASECHK __HALT(-4)
#define __WITHCHK __HALT(-7)
#define __GUARDP(p, typ, level) ((typ*)(__ISP(p,typ,level)?p:(__HALT(-5),p)))
#define __GUARDR(r, typ, level) (*((typ*)(__IS(r##__typ,typ,level)?r:(__HALT(-5),r))))
#define __GUARDA(p, typ, level) ((struct typ*)(__IS(__TYPEOF(p),typ,level)?p:(__HALT(-5),p)))
#define __GUARDEQR(p, dyntyp, typ) if(dyntyp!=typ##__typ) __HALT(-6);*(p)
#define __GUARDEQP(p, typ) if(__TYPEOF(p)!=typ##__typ)__HALT(-6);*(p)
#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) \
static struct t##__desc { \
long tproc[m]; \
long tag, next, level, module; \
LONGINT tproc[m]; /* Proc for each ptr field */ \
LONGINT tag; \
LONGINT next; /* Module table type list points here */ \
LONGINT level; \
LONGINT module; \
char name[24]; \
long *base[__MAXEXT]; \
char *rsrvd; \
long blksz, ptr[n+1]; \
LONGINT basep[__MAXEXT]; /* List of bases this extends */ \
LONGINT reserved; \
LONGINT blksz; /* xxx_typ points here */ \
LONGINT ptr[n+1]; /* Offsets of ptrs up to -ve sentinel */ \
} t##__desc
#define __BASEOFF (__MAXEXT+1)
#define __TPROC0OFF (__BASEOFF+24/sizeof(long)+5)
#define __BASEOFF (__MAXEXT+1) // blksz as index to base.
#define __TPROC0OFF (__BASEOFF+24/sizeof(LONGINT)+5) // blksz as index to tproc IFF m=1.
#define __EOM 1
#define __TDFLDS(name, size) {__EOM}, 1, 0, 0, 0, name, {0}, 0, size
#define __ENUMP(adr, n, P) SYSTEM_ENUMP(adr, (long)(n), P)
#define __ENUMR(adr, typ, size, n, P) SYSTEM_ENUMR(adr, typ, (long)(size), (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, (LONGINT)(size), (LONGINT)(n), P)
#define __INITYP(t, t0, level) \
t##__typ= &t##__desc.blksz; \
memcpy(t##__desc.base, t0##__typ - __BASEOFF, level*sizeof(long)); \
t##__desc.base[level]=t##__typ; \
t##__desc.module=(long)m; \
t##__typ = (LONGINT*)&t##__desc.blksz; \
memcpy(t##__desc.basep, t0##__typ - __BASEOFF, level*sizeof(LONGINT)); \
t##__desc.basep[level] = (LONGINT)(uintptr_t)t##__typ; \
t##__desc.module = (LONGINT)(uintptr_t)m; \
if(t##__desc.blksz!=sizeof(struct t)) __HALT(-15); \
t##__desc.blksz=(t##__desc.blksz+5*sizeof(long)-1)/(4*sizeof(long))*(4*sizeof(long)); \
SYSTEM_REGTYP(m, (long)&t##__desc.next); \
t##__desc.blksz = (t##__desc.blksz+5*sizeof(LONGINT)-1)/(4*sizeof(LONGINT))*(4*sizeof(LONGINT)); \
Heap_REGTYP(m, (LONGINT)(uintptr_t)&t##__desc.next); \
SYSTEM_INHERIT(t##__typ, t0##__typ)
/* Oberon-2 type bound procedures support */
#define __INITBP(t, proc, num) *(t##__typ-(__TPROC0OFF+num))=(long)proc
#define __SEND(typ, num, funtyp, parlist) ((funtyp)(*(typ-(__TPROC0OFF+num))))parlist
#define __IS(tag, typ, level) (*(tag-(__BASEOFF-level))==(LONGINT)(uintptr_t)typ##__typ)
#define __TYPEOF(p) ((LONGINT*)(uintptr_t)(*(((LONGINT*)(p))-1)))
#define __ISP(p, typ, level) __IS(__TYPEOF(p),typ,level)
// Oberon-2 type bound procedures support
#define __INITBP(t, proc, num) *(t##__typ-(__TPROC0OFF+num))=(LONGINT)(uintptr_t)proc
#define __SEND(typ, num, funtyp, parlist) ((funtyp)((uintptr_t)*(typ-(__TPROC0OFF+num))))parlist
/* 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

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