mirror of
https://github.com/vishapoberon/compiler.git
synced 2026-04-06 07:32:24 +00:00
Reorganise system and runtime library modules for both O2 and OC builds.
This commit is contained in:
David Brown
parent
c924a33a05
commit
c2567a2600
223 changed files with 1521 additions and 4039 deletions
|
|
@ -4,7 +4,7 @@ MODULE OPM; (* RC 6.3.89 / 28.6.89, J.Templ 10.7.89 / 22.7.96 *)
|
|||
31.1.2007 jt synchronized with BlackBox version, in particular PromoteIntConstToLInt added
|
||||
*)
|
||||
|
||||
IMPORT SYSTEM, Texts, Files, Platform, Console, errors, Configuration, vt100, Strings;
|
||||
IMPORT SYSTEM, Texts, Files, Platform, Out, errors, Configuration, vt100, Strings;
|
||||
|
||||
CONST
|
||||
OptionChar* = "-";
|
||||
|
|
@ -124,10 +124,10 @@ MODULE OPM; (* RC 6.3.89 / 28.6.89, J.Templ 10.7.89 / 22.7.96 *)
|
|||
|
||||
(* ------------------------- Log Output ------------------------- *)
|
||||
|
||||
PROCEDURE LogW*(ch: CHAR); BEGIN Console.Char(ch) END LogW;
|
||||
PROCEDURE LogWStr*(s: ARRAY OF CHAR); BEGIN Console.String(s) END LogWStr;
|
||||
PROCEDURE LogWNum*(i, len: SYSTEM.INT64); BEGIN Console.Int(i, len) END LogWNum;
|
||||
PROCEDURE LogWLn*; BEGIN Console.Ln END LogWLn;
|
||||
PROCEDURE LogW*(ch: CHAR); BEGIN Out.Char(ch) END LogW;
|
||||
PROCEDURE LogWStr*(s: ARRAY OF CHAR); BEGIN Out.String(s) END LogWStr;
|
||||
PROCEDURE LogWNum*(i, len: SYSTEM.INT64); BEGIN Out.Int(i, len) END LogWNum;
|
||||
PROCEDURE LogWLn*; BEGIN Out.Ln END LogWLn;
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
MODULE extTools;
|
||||
|
||||
IMPORT Strings, Console, Configuration, Platform, OPM;
|
||||
IMPORT Strings, Out, Configuration, Platform, OPM;
|
||||
|
||||
VAR CFLAGS: ARRAY 1023 OF CHAR;
|
||||
|
||||
|
|
@ -9,7 +9,7 @@ PROCEDURE execute(title: ARRAY OF CHAR; cmd: ARRAY OF CHAR);
|
|||
VAR r, status, exitcode: INTEGER;
|
||||
BEGIN
|
||||
IF OPM.verbose IN OPM.Options THEN
|
||||
Console.String(title); Console.String(cmd); Console.Ln
|
||||
Out.String(title); Out.String(cmd); Out.Ln
|
||||
END;
|
||||
r := Platform.System(cmd);
|
||||
status := r MOD 128;
|
||||
|
|
@ -17,12 +17,12 @@ BEGIN
|
|||
IF exitcode > 127 THEN exitcode := exitcode - 256 END; (* Handle signed exit code *)
|
||||
|
||||
IF r # 0 THEN
|
||||
Console.String(title); Console.String(cmd); Console.Ln;
|
||||
Console.String("-- failed: status "); Console.Int(status,1);
|
||||
Console.String(", exitcode "); Console.Int(exitcode,1);
|
||||
Console.String("."); Console.Ln;
|
||||
Out.String(title); Out.String(cmd); Out.Ln;
|
||||
Out.String("-- failed: status "); Out.Int(status,1);
|
||||
Out.String(", exitcode "); Out.Int(exitcode,1);
|
||||
Out.String("."); Out.Ln;
|
||||
IF (status = 0) & (exitcode = 127) THEN
|
||||
Console.String("Is the C compiler in the current command path?"); Console.Ln
|
||||
Out.String("Is the C compiler in the current command path?"); Out.Ln
|
||||
END;
|
||||
IF status # 0 THEN Platform.Halt(status) ELSE Platform.Halt(exitcode) END
|
||||
END;
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ BEGIN
|
|||
error := Platform.Write(Platform.StdOut, SYSTEM.ADR(str), l)
|
||||
END String;
|
||||
|
||||
PROCEDURE Int*(x: HUGEINT; n: LONGINT);
|
||||
PROCEDURE Int*(x, n: HUGEINT);
|
||||
CONST zero = ORD('0');
|
||||
VAR s: ARRAY 22 OF CHAR; i: INTEGER; negative: BOOLEAN;
|
||||
BEGIN
|
||||
|
|
|
|||
|
|
@ -389,7 +389,7 @@ END ReadBuf;
|
|||
|
||||
|
||||
|
||||
PROCEDURE -writefile(fd: LONGINT; p: SYSTEM.ADDRESS; l: LONGINT): SYSTEM.ADDRESS
|
||||
PROCEDURE -writefile(fd: LONGINT; p: SYSTEM.ADDRESS; l: SYSTEM.ADDRESS): SYSTEM.ADDRESS
|
||||
"write(fd, (void*)(address)(p), l)";
|
||||
|
||||
PROCEDURE Write*(h: FileHandle; p: SYSTEM.ADDRESS; l: LONGINT): ErrorCode;
|
||||
|
|
|
|||
342
src/runtime/vt100.Mod
Normal file
342
src/runtime/vt100.Mod
Normal file
|
|
@ -0,0 +1,342 @@
|
|||
MODULE vt100;
|
||||
|
||||
IMPORT Out, Strings;
|
||||
(* reference http://en.wikipedia.org/wiki/ANSI_escape_code
|
||||
& http://misc.flogisoft.com/bash/tip_colors_and_formatting
|
||||
*)
|
||||
CONST
|
||||
|
||||
Escape* = 1BX;
|
||||
SynchronousIdle* = 16X;
|
||||
LeftCrotchet* = '[';
|
||||
|
||||
(* formatting *)
|
||||
Bold* = "1m";
|
||||
Dim* = "2m";
|
||||
Underlined* = "4m";
|
||||
Blink* = "5m"; (* does not work with most emulators, works in tty and xterm *)
|
||||
Reverse* = "7m"; (* invert the foreground and background colors *)
|
||||
Hidden* = "8m"; (* useful for passwords *)
|
||||
|
||||
(* reset *)
|
||||
ResetAll* = "0m";
|
||||
ResetBold* = "21m";
|
||||
ResetDim* = "22m";
|
||||
ResetUnderlined* = "24m";
|
||||
ResetBlink* = "25m";
|
||||
ResetReverse* = "27m";
|
||||
ResetHidden* = "28m";
|
||||
|
||||
(* foreground colors *)
|
||||
Black* = "30m";
|
||||
Red* = "31m";
|
||||
Green* = "32m";
|
||||
Yellow* = "33m";
|
||||
Blue* = "34m";
|
||||
Magenta* = "35m";
|
||||
Cyan* = "36m";
|
||||
LightGray* = "37m";
|
||||
Default* = "39m";
|
||||
DarkGray* = "90m";
|
||||
LightRed* = "91m";
|
||||
LightGreen* = "92m";
|
||||
LightYellow* = "93m";
|
||||
LightBlue* = "94m";
|
||||
LightMagenta* = "95m";
|
||||
LightCyan* = "96m";
|
||||
White* = "97m";
|
||||
|
||||
(* background colors *)
|
||||
BBlack* = "40m";
|
||||
BRed* = "41m";
|
||||
BGreen* = "42m";
|
||||
BYellow* = "43m";
|
||||
BBlue* = "44m";
|
||||
BMagenta* = "45m";
|
||||
BCyan* = "46m";
|
||||
BLightGray* = "47m";
|
||||
BDefault* = "49m";
|
||||
BDarkGray* = "100m";
|
||||
BLightRed* = "101m";
|
||||
BLightGreen* = "102m";
|
||||
BLightYellow* = "103m";
|
||||
BLightBlue* = "104m";
|
||||
BLightMagenta*= "105m";
|
||||
BLightCyan* = "106m";
|
||||
BWhite* = "107m";
|
||||
|
||||
VAR
|
||||
CSI* : ARRAY 5 OF CHAR;
|
||||
tmpstr : ARRAY 32 OF CHAR;
|
||||
|
||||
(* IntToStr routine taken from
|
||||
https://github.com/romiras/Oberon-F-components/blob/master/Ott/Mod/IntStr.cp
|
||||
and modified to work on 64bit system,
|
||||
in order to avoid using oocIntStr, which has many dependencies *)
|
||||
PROCEDURE Reverse0 (VAR str : ARRAY OF CHAR; start, end : INTEGER);
|
||||
(* Reverses order of characters in the interval [start..end]. *)
|
||||
VAR
|
||||
h : CHAR;
|
||||
BEGIN
|
||||
WHILE start < end DO
|
||||
h := str[start]; str[start] := str[end]; str[end] := h;
|
||||
INC(start); DEC(end)
|
||||
END
|
||||
END Reverse0;
|
||||
|
||||
PROCEDURE IntToStr*(int: LONGINT; VAR str: ARRAY OF CHAR);
|
||||
(* Converts the value of `int' to string form and copies the possibly truncated
|
||||
result to `str'. *)
|
||||
VAR
|
||||
b : ARRAY 21 OF CHAR;
|
||||
s, e: INTEGER;
|
||||
maxLength : SHORTINT; (* maximum number of digits representing a LONGINT value *)
|
||||
BEGIN
|
||||
IF SIZE(LONGINT) = 4 THEN maxLength := 11 END;
|
||||
IF SIZE(LONGINT) = 8 THEN maxLength := 20 END;
|
||||
(* build representation in string 'b' *)
|
||||
IF int = MIN(LONGINT) THEN (* smallest LONGINT, -int is an overflow *)
|
||||
IF SIZE(LONGINT) = 4 THEN
|
||||
b := "-2147483648";
|
||||
e := 11
|
||||
ELSE (* SIZE(LONGINT) = 8 *)
|
||||
b := "-9223372036854775808";
|
||||
e := 20
|
||||
END
|
||||
ELSE
|
||||
IF int < 0 THEN (* negative sign *)
|
||||
b[0] := "-"; int := -int; s := 1
|
||||
ELSE (* no sign *)
|
||||
s := 0
|
||||
END;
|
||||
e := s; (* 's' holds starting position of string *)
|
||||
REPEAT
|
||||
b[e] := CHR(int MOD 10+ORD("0"));
|
||||
int := int DIV 10;
|
||||
INC(e)
|
||||
UNTIL int = 0;
|
||||
b[e] := 0X;
|
||||
Reverse0(b, s, e-1);
|
||||
END;
|
||||
COPY(b, str) (* truncate output if necessary *)
|
||||
END IntToStr;
|
||||
|
||||
PROCEDURE EscSeq0 (letter : ARRAY OF CHAR);
|
||||
VAR
|
||||
cmd : ARRAY 9 OF CHAR;
|
||||
BEGIN
|
||||
COPY(CSI, cmd);
|
||||
Strings.Append (letter, cmd);
|
||||
Out.String (cmd);
|
||||
END EscSeq0;
|
||||
|
||||
PROCEDURE EscSeq (n : INTEGER; letter : ARRAY OF CHAR);
|
||||
VAR nstr : ARRAY 2 OF CHAR;
|
||||
cmd : ARRAY 7 OF CHAR;
|
||||
BEGIN
|
||||
IntToStr (n, nstr);
|
||||
COPY(CSI, cmd);
|
||||
Strings.Append (nstr, cmd);
|
||||
Strings.Append (letter, cmd);
|
||||
Out.String (cmd);
|
||||
END EscSeq;
|
||||
|
||||
PROCEDURE EscSeqSwapped (n : INTEGER; letter : ARRAY OF CHAR);
|
||||
VAR nstr : ARRAY 2 OF CHAR;
|
||||
cmd : ARRAY 7 OF CHAR;
|
||||
BEGIN
|
||||
IntToStr (n, nstr);
|
||||
COPY(CSI, cmd);
|
||||
Strings.Append (letter, cmd);
|
||||
Strings.Append (nstr, cmd);
|
||||
Out.String (cmd);
|
||||
END EscSeqSwapped;
|
||||
|
||||
PROCEDURE EscSeq2(n, m : INTEGER; letter : ARRAY OF CHAR);
|
||||
VAR nstr, mstr : ARRAY 5 OF CHAR;
|
||||
cmd : ARRAY 12 OF CHAR;
|
||||
BEGIN
|
||||
IntToStr(n, nstr);
|
||||
IntToStr(m, mstr);
|
||||
|
||||
COPY (CSI, cmd);
|
||||
Strings.Append (nstr, cmd);
|
||||
Strings.Append (';', cmd);
|
||||
Strings.Append (mstr, cmd);
|
||||
Strings.Append (letter, cmd);
|
||||
Out.String (cmd);
|
||||
|
||||
END EscSeq2;
|
||||
|
||||
|
||||
|
||||
(* Cursor up
|
||||
moves cursor n cells in the given direction. if the cursor is already at the edge of the screen, this has no effect *)
|
||||
|
||||
PROCEDURE CUU*(n : INTEGER);
|
||||
BEGIN
|
||||
EscSeq (n, 'A');
|
||||
END CUU;
|
||||
|
||||
(* Cursor down
|
||||
moves cursor n cells in the given direction. if the cursor is already at the edge of the screen, this has no effect *)
|
||||
|
||||
PROCEDURE CUD*(n : INTEGER);
|
||||
BEGIN
|
||||
EscSeq (n, 'B');
|
||||
END CUD;
|
||||
|
||||
|
||||
(* Cursor forward
|
||||
moves cursor n cells in the given direction. if the cursor is already at the edge of the screen, this has no effect *)
|
||||
|
||||
PROCEDURE CUF*(n : INTEGER);
|
||||
BEGIN
|
||||
EscSeq (n, 'C');
|
||||
END CUF;
|
||||
|
||||
(* Cursor back
|
||||
moves cursor n cells in the given direction. if the cursor is already at the edge of the screen, this has no effect *)
|
||||
|
||||
PROCEDURE CUB*(n : INTEGER);
|
||||
BEGIN
|
||||
EscSeq (n, 'D');
|
||||
END CUB;
|
||||
|
||||
(* Curnser Next Line
|
||||
moves cursor to beginning of the line n lines down *)
|
||||
|
||||
PROCEDURE CNL*( n: INTEGER);
|
||||
BEGIN
|
||||
EscSeq (n, 'E');
|
||||
END CNL;
|
||||
|
||||
|
||||
(* Cursor Previous Line
|
||||
Moves cursor to beginning of the line n lines down *)
|
||||
|
||||
PROCEDURE CPL*( n : INTEGER);
|
||||
BEGIN
|
||||
EscSeq (n, 'F');
|
||||
END CPL;
|
||||
|
||||
(* Cursor Horizontal Absolute
|
||||
Moves the cursor to column n *)
|
||||
|
||||
PROCEDURE CHA*( n : INTEGER);
|
||||
BEGIN
|
||||
EscSeq (n, 'G');
|
||||
END CHA;
|
||||
|
||||
(* Cursor position, moves cursor to row n, column m *)
|
||||
PROCEDURE CUP*(n, m : INTEGER);
|
||||
BEGIN
|
||||
EscSeq2 (n, m, 'H');
|
||||
END CUP;
|
||||
|
||||
(* Erase Display
|
||||
if n = 0 then clears from cursor to end of the screen
|
||||
if n = 1 then clears from cursor to beginning of the screen
|
||||
if n = 2 then clears entire screen *)
|
||||
|
||||
PROCEDURE ED* (n : INTEGER);
|
||||
BEGIN
|
||||
EscSeq(n, 'J');
|
||||
END ED;
|
||||
|
||||
(* Erase in Line
|
||||
Erases part of the line. If n is zero, clear from cursor to the end of the line. If n is one, clear from cursor to beginning of the line. If n is two, clear entire line. Cursor position does not change *)
|
||||
PROCEDURE EL*( n : INTEGER);
|
||||
BEGIN
|
||||
EscSeq(n, 'K');
|
||||
END EL;
|
||||
|
||||
(* Scroll Up
|
||||
Scroll whole page up by n lines. New lines are added at the bottom *)
|
||||
PROCEDURE SU*( n : INTEGER);
|
||||
BEGIN
|
||||
EscSeq(n, 'S')
|
||||
END SU;
|
||||
|
||||
(* Scroll Down
|
||||
Scroll whole page down by n (default 1) lines. New lines are added at the top *)
|
||||
PROCEDURE SD*( n : INTEGER);
|
||||
BEGIN
|
||||
EscSeq(n, 'T');
|
||||
END SD;
|
||||
|
||||
(* Horizontal and Vertical Position,
|
||||
Moves the cursor to row n, column m. Both default to 1 if omitted. Same as CUP *)
|
||||
PROCEDURE HVP*(n, m : INTEGER);
|
||||
BEGIN
|
||||
EscSeq2 (n, m, 'f');
|
||||
END HVP;
|
||||
|
||||
(* Select Graphic Rendition
|
||||
Sets SGR parameters, including text color. After CSI can be zero or more parameters separated with ;. With no parameters, CSI m is treated as CSI 0 m (reset / normal), which is typical of most of the ANSI escape sequences *)
|
||||
|
||||
PROCEDURE SGR*( n : INTEGER);
|
||||
BEGIN
|
||||
EscSeq(n, 'm');
|
||||
END SGR;
|
||||
|
||||
PROCEDURE SGR2*( n, m : INTEGER);
|
||||
BEGIN
|
||||
EscSeq2(n, m, 'm');
|
||||
END SGR2;
|
||||
|
||||
(* Device Status Report
|
||||
Reports the cursor position (CPR) to the application as (as though typed at the keyboard) ESC[n;mR, where n is the row and m is the column.) *)
|
||||
|
||||
PROCEDURE DSR*(n : INTEGER);
|
||||
BEGIN
|
||||
EscSeq(6, 'n');
|
||||
END DSR;
|
||||
|
||||
(* Save Cursor Position *)
|
||||
|
||||
PROCEDURE SCP*;
|
||||
BEGIN
|
||||
EscSeq0('s');
|
||||
END SCP;
|
||||
|
||||
(* Restore Cursor Position *)
|
||||
|
||||
PROCEDURE RCP*;
|
||||
BEGIN
|
||||
EscSeq0('u');
|
||||
END RCP;
|
||||
|
||||
(* Hide the cursor *)
|
||||
PROCEDURE DECTCEMl*;
|
||||
BEGIN
|
||||
EscSeq0("?25l")
|
||||
END DECTCEMl;
|
||||
|
||||
(* shows the cursor *)
|
||||
PROCEDURE DECTCEMh*;
|
||||
BEGIN
|
||||
EscSeq0("?25h")
|
||||
END DECTCEMh;
|
||||
|
||||
PROCEDURE SetAttr*(attr : ARRAY OF CHAR);
|
||||
VAR tmpstr : ARRAY 16 OF CHAR;
|
||||
BEGIN
|
||||
COPY(CSI, tmpstr);
|
||||
Strings.Append(attr, tmpstr);
|
||||
Out.String(tmpstr);
|
||||
END SetAttr;
|
||||
|
||||
BEGIN
|
||||
(* init CSI sequence *)
|
||||
COPY(Escape, CSI);
|
||||
Strings.Append(LeftCrotchet, CSI);
|
||||
(*
|
||||
EraseDisplay;
|
||||
GotoXY (0, 0);
|
||||
COPY(CSI, tmpstr);
|
||||
Strings.Append(Green, tmpstr);
|
||||
Strings.Append("hello", tmpstr);
|
||||
Out.String(tmpstr); Out.Ln;
|
||||
*)
|
||||
END vt100.
|
||||
|
|
@ -1,749 +0,0 @@
|
|||
MODULE Files; (* J. Templ 1.12. 89/12.4.95 Oberon files mapped onto Unix files *)
|
||||
|
||||
IMPORT SYSTEM, Platform, Heap, Strings, Out := Console;
|
||||
|
||||
(* standard data type I/O
|
||||
|
||||
little endian,
|
||||
Sint:1, Int:2, Lint:4
|
||||
ORD({0}) = 1,
|
||||
false = 0, true =1
|
||||
IEEE real format,
|
||||
null terminated strings,
|
||||
compact numbers according to M.Odersky *)
|
||||
|
||||
|
||||
CONST
|
||||
nofbufs = 4;
|
||||
bufsize = 4096;
|
||||
noDesc = -1;
|
||||
notDone = -1;
|
||||
|
||||
(* file states *)
|
||||
open = 0; (* OS File has been opened *)
|
||||
create = 1; (* OS file needs to be created *)
|
||||
close = 2; (* Register telling Create to use registerName directly:
|
||||
i.e. since we're closing and all data is still in
|
||||
buffers bypass writing to temp file and then renaming
|
||||
and just write directly to fianl register name *)
|
||||
|
||||
|
||||
TYPE
|
||||
FileName = ARRAY 101 OF CHAR;
|
||||
File* = POINTER TO FileDesc;
|
||||
Buffer = POINTER TO BufDesc;
|
||||
|
||||
FileDesc = RECORD
|
||||
workName: FileName;
|
||||
registerName: FileName;
|
||||
tempFile: BOOLEAN;
|
||||
identity: Platform.FileIdentity;
|
||||
fd-: Platform.FileHandle;
|
||||
len, pos: LONGINT;
|
||||
bufs: ARRAY nofbufs OF Buffer;
|
||||
swapper: INTEGER;
|
||||
state: INTEGER;
|
||||
next: File;
|
||||
END;
|
||||
|
||||
BufDesc = RECORD
|
||||
f: File;
|
||||
chg: BOOLEAN;
|
||||
org: LONGINT;
|
||||
size: LONGINT;
|
||||
data: ARRAY bufsize OF SYSTEM.BYTE
|
||||
END;
|
||||
|
||||
Rider* = RECORD
|
||||
res*: LONGINT;
|
||||
eof*: BOOLEAN;
|
||||
buf: Buffer;
|
||||
org: LONGINT; (* File offset of block containing current position *)
|
||||
offset: LONGINT (* Current position offset within block at org. *)
|
||||
END;
|
||||
|
||||
|
||||
VAR
|
||||
files: File; (* List of files that have an OS file handle/descriptor assigned *)
|
||||
tempno: INTEGER;
|
||||
HOME: ARRAY 1024 OF CHAR;
|
||||
SearchPath: POINTER TO ARRAY OF CHAR;
|
||||
|
||||
|
||||
|
||||
|
||||
PROCEDURE -IdxTrap "__HALT(-1)";
|
||||
PROCEDURE -ToAdr(x: SYSTEM.INT64): SYSTEM.ADDRESS "(address)x";
|
||||
|
||||
PROCEDURE^ Finalize(o: SYSTEM.PTR);
|
||||
|
||||
PROCEDURE Err(s: ARRAY OF CHAR; f: File; errcode: Platform.ErrorCode);
|
||||
BEGIN
|
||||
Out.Ln; Out.String("-- "); Out.String(s); Out.String(": ");
|
||||
IF f # NIL THEN
|
||||
IF f.registerName # "" THEN Out.String(f.registerName) ELSE Out.String(f.workName) END;
|
||||
IF f.fd # 0 THEN Out.String("f.fd = "); Out.Int(f.fd,1) END
|
||||
END;
|
||||
IF errcode # 0 THEN Out.String(" errcode = "); Out.Int(errcode, 1) END;
|
||||
Out.Ln;
|
||||
HALT(99)
|
||||
END Err;
|
||||
|
||||
PROCEDURE MakeFileName(dir, name: ARRAY OF CHAR; VAR dest: ARRAY OF CHAR);
|
||||
VAR i, j: INTEGER;
|
||||
BEGIN i := 0; j := 0;
|
||||
WHILE dir[i] # 0X DO dest[i] := dir[i]; INC(i) END;
|
||||
IF dest[i-1] # "/" THEN dest[i] := "/"; INC(i) END;
|
||||
WHILE name[j] # 0X DO dest[i] := name[j]; INC(i); INC(j) END;
|
||||
dest[i] := 0X
|
||||
END MakeFileName;
|
||||
|
||||
PROCEDURE GetTempName(finalName: ARRAY OF CHAR; VAR name: ARRAY OF CHAR);
|
||||
VAR n, i, j: LONGINT;
|
||||
BEGIN
|
||||
INC(tempno); n := tempno; i := 0;
|
||||
IF finalName[0] # "/" THEN (* relative pathname *)
|
||||
WHILE Platform.CWD[i] # 0X DO name[i] := Platform.CWD[i]; INC(i) END;
|
||||
IF Platform.CWD[i-1] # "/" THEN name[i] := "/"; INC(i) END
|
||||
END;
|
||||
j := 0;
|
||||
WHILE finalName[j] # 0X DO name[i] := finalName[j]; INC(i); INC(j) END;
|
||||
DEC(i);
|
||||
WHILE name[i] # "/" DO DEC(i) END;
|
||||
name[i+1] := "."; name[i+2] := "t"; name[i+3] := "m"; name[i+4] := "p"; name[i+5] := "."; INC(i, 6);
|
||||
WHILE n > 0 DO name[i] := CHR(n MOD 10 + ORD("0")); n := n DIV 10; INC(i) END;
|
||||
name[i] := "."; INC(i); n := Platform.PID;
|
||||
WHILE n > 0 DO name[i] := CHR(n MOD 10 + ORD("0")); n := n DIV 10; INC(i) END;
|
||||
name[i] := 0X
|
||||
END GetTempName;
|
||||
|
||||
PROCEDURE Create(f: File);
|
||||
VAR
|
||||
identity: Platform.FileIdentity;
|
||||
done: BOOLEAN;
|
||||
error: Platform.ErrorCode;
|
||||
err: ARRAY 32 OF CHAR;
|
||||
BEGIN
|
||||
(*
|
||||
Out.String("Files.Create fd = "); Out.Int(f.fd,1);
|
||||
Out.String(", registerName = "); Out.String(f.registerName);
|
||||
Out.String(", workName = "); Out.String(f.workName);
|
||||
Out.String(", state = "); Out.Int(f.state,1);
|
||||
Out.Ln;
|
||||
*)
|
||||
IF f.fd = noDesc THEN
|
||||
IF f.state = create THEN
|
||||
GetTempName(f.registerName, f.workName); f.tempFile := TRUE
|
||||
ELSIF f.state = close THEN
|
||||
f.workName := f.registerName; f.registerName := ""; f.tempFile := FALSE
|
||||
END;
|
||||
error := Platform.Unlink(f.workName); (*unlink first to avoid stale NFS handles and to avoid reuse of inodes*)
|
||||
|
||||
error := Platform.New(f.workName, f.fd);
|
||||
done := error = 0;
|
||||
IF done THEN
|
||||
f.next := files; files := f;
|
||||
INC(Heap.FileCount);
|
||||
Heap.RegisterFinalizer(f, Finalize);
|
||||
f.state := open;
|
||||
f.pos := 0;
|
||||
error := Platform.Identify(f.fd, f.identity);
|
||||
ELSE
|
||||
IF Platform.NoSuchDirectory(error) THEN err := "no such directory"
|
||||
ELSIF Platform.TooManyFiles(error) THEN err := "too many files open"
|
||||
ELSE err := "file not created"
|
||||
END;
|
||||
Err(err, f, error)
|
||||
END
|
||||
END
|
||||
END Create;
|
||||
|
||||
PROCEDURE Flush(buf: Buffer);
|
||||
VAR
|
||||
error: Platform.ErrorCode;
|
||||
f: File;
|
||||
(* identity: Platform.FileIdentity; *)
|
||||
BEGIN
|
||||
(*
|
||||
Out.String("Files.Flush buf.f.registername = "); Out.String(buf.f.registerName);
|
||||
Out.String(", buf.f.fd = "); Out.Int(buf.f.fd,1);
|
||||
Out.String(", buffer at $"); Out.Hex(SYSTEM.ADR(buf.data));
|
||||
Out.String(", size "); Out.Int(buf.size,1); Out.Ln;
|
||||
*)
|
||||
IF buf.chg THEN f := buf.f; Create(f);
|
||||
IF buf.org # f.pos THEN
|
||||
error := Platform.Seek(f.fd, buf.org, Platform.SeekSet);
|
||||
(*
|
||||
Out.String("Seeking to "); Out.Int(buf.org,1);
|
||||
Out.String(", error code "); Out.Int(error,1); Out.Ln;
|
||||
*)
|
||||
END;
|
||||
error := Platform.Write(f.fd, SYSTEM.ADR(buf.data), buf.size);
|
||||
IF error # 0 THEN Err("error writing file", f, error) END;
|
||||
f.pos := buf.org + buf.size;
|
||||
buf.chg := FALSE;
|
||||
error := Platform.Identify(f.fd, f.identity);
|
||||
IF error # 0 THEN Err("error identifying file", f, error) END;
|
||||
(*
|
||||
error := Platform.Identify(f.fd, identity);
|
||||
f.identity.mtime := identity.mtime;
|
||||
*)
|
||||
END
|
||||
END Flush;
|
||||
|
||||
|
||||
PROCEDURE CloseOSFile(f: File);
|
||||
(* Close the OS file handle and remove f from 'files' *)
|
||||
VAR prev: File; error: Platform.ErrorCode;
|
||||
BEGIN
|
||||
IF files = f THEN files := f.next
|
||||
ELSE
|
||||
prev := files;
|
||||
WHILE (prev # NIL) & (prev.next # f) DO prev := prev.next END;
|
||||
IF prev.next # NIL THEN prev.next := f.next END
|
||||
END;
|
||||
error := Platform.Close(f.fd);
|
||||
f.fd := noDesc; f.state := create; DEC(Heap.FileCount);
|
||||
END CloseOSFile;
|
||||
|
||||
|
||||
PROCEDURE Close* (f: File);
|
||||
VAR
|
||||
i: LONGINT;
|
||||
error: Platform.ErrorCode;
|
||||
BEGIN
|
||||
IF (f.state # create) OR (f.registerName # "") THEN
|
||||
Create(f); i := 0;
|
||||
WHILE (i < nofbufs) & (f.bufs[i] # NIL) DO Flush(f.bufs[i]); INC(i) END;
|
||||
error := Platform.Sync(f.fd);
|
||||
IF error # 0 THEN Err("error writing file", f, error) END;
|
||||
CloseOSFile(f);
|
||||
END
|
||||
END Close;
|
||||
|
||||
PROCEDURE Length* (f: File): LONGINT;
|
||||
BEGIN RETURN f.len END Length;
|
||||
|
||||
PROCEDURE New* (name: ARRAY OF CHAR): File;
|
||||
VAR f: File;
|
||||
BEGIN
|
||||
NEW(f); f.workName := ""; COPY(name, f.registerName);
|
||||
f.fd := noDesc; f.state := create; f.len := 0; f.pos := 0; f.swapper := -1; (*all f.buf[i] = NIL*)
|
||||
RETURN f
|
||||
END New;
|
||||
|
||||
PROCEDURE ScanPath(VAR pos: INTEGER; VAR dir: ARRAY OF CHAR);
|
||||
(* Extract next individual directory from searchpath starting at pos,
|
||||
updating pos and returning dir.
|
||||
Supports ~, ~user and blanks inside path *)
|
||||
VAR i: INTEGER; ch: CHAR;
|
||||
BEGIN
|
||||
i := 0;
|
||||
IF SearchPath = NIL THEN
|
||||
IF pos = 0 THEN
|
||||
dir[0] := "."; i := 1; INC(pos) (* Default search path is just the current directory *)
|
||||
END
|
||||
ELSE
|
||||
ch := SearchPath[pos];
|
||||
WHILE (ch = " ") OR (ch = ";") DO INC(pos); ch := SearchPath[pos] END;
|
||||
IF ch = "~" THEN
|
||||
INC(pos); ch := SearchPath[pos];
|
||||
WHILE HOME[i] # 0X DO dir[i] := HOME[i]; INC(i) END;
|
||||
IF (ch # "/") & (ch # 0X) & (ch # ";") & (ch # " ") THEN
|
||||
WHILE (i > 0) & (dir[i-1] # "/") DO DEC(i) END
|
||||
END
|
||||
END;
|
||||
WHILE (ch # 0X) & (ch # ";") DO dir[i] := ch; INC(i); INC(pos); ch := SearchPath[pos] END;
|
||||
WHILE (i > 0) & (dir[i-1] = " ") DO DEC(i) END
|
||||
END;
|
||||
dir[i] := 0X
|
||||
END ScanPath;
|
||||
|
||||
PROCEDURE HasDir(VAR name: ARRAY OF CHAR): BOOLEAN;
|
||||
VAR i: INTEGER; ch: CHAR;
|
||||
BEGIN i := 0; ch := name[0];
|
||||
WHILE (ch # 0X) & (ch # "/") DO INC(i); ch := name[i] END;
|
||||
RETURN ch = "/"
|
||||
END HasDir;
|
||||
|
||||
PROCEDURE CacheEntry(identity: Platform.FileIdentity): File;
|
||||
VAR f: File; i: INTEGER; error: Platform.ErrorCode;
|
||||
BEGIN f := files;
|
||||
WHILE f # NIL DO
|
||||
IF Platform.SameFile(identity, f.identity) THEN
|
||||
IF ~Platform.SameFileTime(identity, f.identity) THEN i := 0;
|
||||
WHILE i < nofbufs DO
|
||||
IF f.bufs[i] # NIL THEN f.bufs[i].org := -1; f.bufs[i] := NIL END;
|
||||
INC(i)
|
||||
END;
|
||||
f.swapper := -1; f.identity := identity;
|
||||
error := Platform.Size(f.fd, f.len);
|
||||
END;
|
||||
RETURN f
|
||||
END;
|
||||
f := f.next
|
||||
END;
|
||||
RETURN NIL
|
||||
END CacheEntry;
|
||||
|
||||
PROCEDURE Old*(name: ARRAY OF CHAR): File;
|
||||
VAR
|
||||
f: File;
|
||||
fd: Platform.FileHandle;
|
||||
pos: INTEGER;
|
||||
done: BOOLEAN;
|
||||
dir, path: ARRAY 256 OF CHAR;
|
||||
error: Platform.ErrorCode;
|
||||
identity: Platform.FileIdentity;
|
||||
BEGIN
|
||||
(* Out.String("Files.Old "); Out.String(name); Out.Ln; *)
|
||||
IF name # "" THEN
|
||||
IF HasDir(name) THEN dir := ""; COPY(name, path)
|
||||
ELSE pos := 0; ScanPath(pos, dir); MakeFileName(dir, name, path); ScanPath(pos, dir)
|
||||
END;
|
||||
LOOP
|
||||
error := Platform.OldRW(path, fd); done := error = 0;
|
||||
IF ~done & Platform.TooManyFiles(error) THEN Err("too many files open", f, error) END;
|
||||
IF ~done & Platform.Inaccessible(error) THEN
|
||||
error := Platform.OldRO(path, fd); done := error = 0;
|
||||
END;
|
||||
IF ~done & ~Platform.Absent(error) THEN
|
||||
Out.String("Warning: Files.Old "); Out.String(name);
|
||||
Out.String(" error = "); Out.Int(error, 0); Out.Ln;
|
||||
END;
|
||||
IF done THEN
|
||||
(* Out.String(" fd = "); Out.Int(fd,1); Out.Ln; *)
|
||||
error := Platform.Identify(fd, identity);
|
||||
f := CacheEntry(identity);
|
||||
IF f # NIL THEN
|
||||
(* error := Platform.Close(fd); DCWB: Either this should be removed or should call CloseOSFile. *)
|
||||
RETURN f
|
||||
ELSE NEW(f); Heap.RegisterFinalizer(f, Finalize);
|
||||
f.fd := fd; f.state := open; f.pos := 0; f.swapper := -1; (*all f.buf[i] = NIL*)
|
||||
error := Platform.Size(fd, f.len);
|
||||
COPY(name, f.workName); f.registerName := ""; f.tempFile := FALSE;
|
||||
f.identity := identity;
|
||||
f.next := files; files := f; INC(Heap.FileCount);
|
||||
RETURN f
|
||||
END
|
||||
ELSIF dir = "" THEN RETURN NIL
|
||||
ELSE MakeFileName(dir, name, path); ScanPath(pos, dir)
|
||||
END
|
||||
END
|
||||
ELSE RETURN NIL
|
||||
END
|
||||
END Old;
|
||||
|
||||
PROCEDURE Purge* (f: File);
|
||||
VAR i: INTEGER; identity: Platform.FileIdentity; error: Platform.ErrorCode;
|
||||
BEGIN i := 0;
|
||||
WHILE i < nofbufs DO
|
||||
IF f.bufs[i] # NIL THEN f.bufs[i].org := -1; f.bufs[i] := NIL END;
|
||||
INC(i)
|
||||
END;
|
||||
IF f.fd # noDesc THEN
|
||||
error := Platform.Truncate(f.fd, 0);
|
||||
error := Platform.Seek(f.fd, 0, Platform.SeekSet)
|
||||
END;
|
||||
f.pos := 0; f.len := 0; f.swapper := -1;
|
||||
error := Platform.Identify(f.fd, identity); Platform.SetMTime(f.identity, identity)
|
||||
END Purge;
|
||||
|
||||
PROCEDURE GetDate* (f: File; VAR t, d: LONGINT);
|
||||
VAR
|
||||
identity: Platform.FileIdentity; error: Platform.ErrorCode;
|
||||
BEGIN
|
||||
Create(f); error := Platform.Identify(f.fd, identity);
|
||||
Platform.MTimeAsClock(identity, t, d)
|
||||
END GetDate;
|
||||
|
||||
PROCEDURE Pos* (VAR r: Rider): LONGINT;
|
||||
BEGIN RETURN r.org + r.offset
|
||||
END Pos;
|
||||
|
||||
PROCEDURE Set* (VAR r: Rider; f: File; pos: LONGINT);
|
||||
VAR org, offset, i, n: LONGINT; buf: Buffer; error: Platform.ErrorCode;
|
||||
BEGIN
|
||||
IF f # NIL THEN
|
||||
(*
|
||||
Out.String("Files.Set rider on fd = "); Out.Int(f.fd,1);
|
||||
Out.String(", registerName = "); Out.String(f.registerName);
|
||||
Out.String(", workName = "); Out.String(f.workName);
|
||||
Out.String(", state = "); Out.Int(f.state,1);
|
||||
Out.Ln;
|
||||
*)
|
||||
IF pos > f.len THEN pos := f.len ELSIF pos < 0 THEN pos := 0 END;
|
||||
offset := pos MOD bufsize; org := pos - offset; i := 0;
|
||||
WHILE (i < nofbufs) & (f.bufs[i] # NIL) & (org # f.bufs[i].org) DO INC(i) END;
|
||||
IF i < nofbufs THEN
|
||||
IF f.bufs[i] = NIL THEN NEW(buf); buf.chg := FALSE; buf.org := -1; buf.f := f; f.bufs[i] := buf
|
||||
ELSE buf := f.bufs[i]
|
||||
END
|
||||
ELSE
|
||||
f.swapper := (f.swapper + 1) MOD nofbufs;
|
||||
buf := f.bufs[f.swapper];
|
||||
Flush(buf)
|
||||
END;
|
||||
IF buf.org # org THEN
|
||||
IF org = f.len THEN buf.size := 0
|
||||
ELSE Create(f);
|
||||
IF f.pos # org THEN error := Platform.Seek(f.fd, org, Platform.SeekSet) END;
|
||||
error := Platform.ReadBuf(f.fd, buf.data, n);
|
||||
IF error # 0 THEN Err("read from file not done", f, error) END;
|
||||
f.pos := org + n;
|
||||
buf.size := n
|
||||
END;
|
||||
buf.org := org; buf.chg := FALSE
|
||||
END
|
||||
ELSE buf := NIL; org := 0; offset := 0
|
||||
END;
|
||||
r.buf := buf; r.org := org; r.offset := offset; r.eof := FALSE; r.res := 0
|
||||
END Set;
|
||||
|
||||
PROCEDURE Read* (VAR r: Rider; VAR x: SYSTEM.BYTE);
|
||||
VAR offset: LONGINT; buf: Buffer;
|
||||
BEGIN
|
||||
buf := r.buf; offset := r.offset;
|
||||
IF r.org # buf.org THEN Set(r, buf.f, r.org + offset); buf := r.buf; offset := r.offset END;
|
||||
IF (offset < buf.size) THEN
|
||||
x := buf.data[offset]; r.offset := offset + 1
|
||||
ELSIF r.org + offset < buf.f.len THEN
|
||||
Set(r, r.buf.f, r.org + offset);
|
||||
x := r.buf.data[0]; r.offset := 1
|
||||
ELSE
|
||||
x := 0X; r.eof := TRUE
|
||||
END
|
||||
END Read;
|
||||
|
||||
PROCEDURE ReadBytes* (VAR r: Rider; VAR x: ARRAY OF SYSTEM.BYTE; n: LONGINT);
|
||||
VAR xpos, min, restInBuf, offset: LONGINT; buf: Buffer;
|
||||
BEGIN
|
||||
IF n > LEN(x) THEN IdxTrap END;
|
||||
xpos := 0; buf := r.buf; offset := r.offset;
|
||||
WHILE n > 0 DO
|
||||
IF (r.org # buf.org) OR (offset >= bufsize) THEN
|
||||
Set(r, buf.f, r.org + offset);
|
||||
buf := r.buf; offset := r.offset
|
||||
END;
|
||||
restInBuf := buf.size - offset;
|
||||
IF restInBuf = 0 THEN r.res := n; r.eof := TRUE; RETURN
|
||||
ELSIF n > restInBuf THEN min := restInBuf ELSE min := n END;
|
||||
SYSTEM.MOVE(SYSTEM.ADR(buf.data) + ToAdr(offset), SYSTEM.ADR(x) + ToAdr(xpos), min);
|
||||
INC(offset, min); r.offset := offset; INC(xpos, min); DEC(n, min)
|
||||
END;
|
||||
r.res := 0; r.eof := FALSE
|
||||
END ReadBytes;
|
||||
|
||||
PROCEDURE Base* (VAR r: Rider): File;
|
||||
BEGIN RETURN r.buf.f
|
||||
END Base;
|
||||
|
||||
PROCEDURE Write* (VAR r: Rider; x: SYSTEM.BYTE);
|
||||
VAR buf: Buffer; offset: LONGINT;
|
||||
BEGIN
|
||||
buf := r.buf; offset := r.offset;
|
||||
IF (r.org # buf.org) OR (offset >= bufsize) THEN
|
||||
Set(r, buf.f, r.org + offset);
|
||||
buf := r.buf; offset := r.offset
|
||||
END;
|
||||
buf.data[offset] := x;
|
||||
buf.chg := TRUE;
|
||||
IF offset = buf.size THEN
|
||||
INC(buf.size); INC(buf.f.len)
|
||||
END;
|
||||
r.offset := offset + 1; r.res := 0
|
||||
END Write;
|
||||
|
||||
PROCEDURE WriteBytes* (VAR r: Rider; VAR x: ARRAY OF SYSTEM.BYTE; n: LONGINT);
|
||||
VAR xpos, min, restInBuf, offset: LONGINT; buf: Buffer;
|
||||
BEGIN
|
||||
IF n > LEN(x) THEN IdxTrap END;
|
||||
xpos := 0; buf := r.buf; offset := r.offset;
|
||||
WHILE n > 0 DO
|
||||
IF (r.org # buf.org) OR (offset >= bufsize) THEN
|
||||
Set(r, buf.f, r.org + offset);
|
||||
buf := r.buf; offset := r.offset
|
||||
END;
|
||||
restInBuf := bufsize - offset;
|
||||
IF n > restInBuf THEN min := restInBuf ELSE min := n END;
|
||||
SYSTEM.MOVE(SYSTEM.ADR(x) + ToAdr(xpos), SYSTEM.ADR(buf.data) + ToAdr(offset), min);
|
||||
INC(offset, min); r.offset := offset;
|
||||
IF offset > buf.size THEN INC(buf.f.len, offset - buf.size); buf.size := offset END;
|
||||
INC(xpos, min); DEC(n, min); buf.chg := TRUE
|
||||
END;
|
||||
r.res := 0
|
||||
END WriteBytes;
|
||||
|
||||
(* another solution would be one that is similar to ReadBytes, WriteBytes.
|
||||
No code duplication, more symmetric, only two ifs for
|
||||
Read and Write in buffer, buf.size replaced by bufsize in Write ops, buf.size and len
|
||||
must be made consistent with offset (if offset > buf.size) in a lazy way.
|
||||
|
||||
PROCEDURE Write* (VAR r: Rider; x: SYSTEM.BYTE);
|
||||
VAR buf: Buffer; offset: LONGINT;
|
||||
BEGIN
|
||||
buf := r.buf; offset := r.offset;
|
||||
IF (offset >= bufsize) OR (r.org # buf.org) THEN
|
||||
Set(r, buf.f, r.org + offset); buf := r.buf; offset := r.offset;
|
||||
END;
|
||||
buf.data[offset] := x; r.offset := offset + 1; buf.chg := TRUE
|
||||
END Write;
|
||||
|
||||
PROCEDURE WriteBytes ...
|
||||
|
||||
PROCEDURE Read* (VAR r: Rider; VAR x: SYSTEM.BYTE);
|
||||
VAR offset: LONGINT; buf: Buffer;
|
||||
BEGIN
|
||||
buf := r.buf; offset := r.offset;
|
||||
IF (offset >= buf.size) OR (r.org # buf.org) THEN
|
||||
IF r.org + offset >= buf.f.len THEN x := 0X; r.eof := TRUE; RETURN
|
||||
ELSE Set(r, buf.f, r.org + offset); buf := r.buf; offset := r.offset
|
||||
END
|
||||
END;
|
||||
x := buf.data[offset]; r.offset := offset + 1
|
||||
END Read;
|
||||
|
||||
but this would also affect Set, Length, and Flush.
|
||||
Especially Length would become fairly complex.
|
||||
*)
|
||||
|
||||
PROCEDURE Delete*(name: ARRAY OF CHAR; VAR res: INTEGER);
|
||||
BEGIN res := Platform.Unlink(name) END Delete;
|
||||
|
||||
PROCEDURE Rename* (old, new: ARRAY OF CHAR; VAR res: INTEGER);
|
||||
VAR
|
||||
fdold, fdnew: Platform.FileHandle;
|
||||
n: LONGINT;
|
||||
error, ignore: Platform.ErrorCode;
|
||||
oldidentity, newidentity: Platform.FileIdentity;
|
||||
buf: ARRAY 4096 OF CHAR;
|
||||
BEGIN
|
||||
(*
|
||||
Out.String("Files.Rename old = "); Out.String(old);
|
||||
Out.String(", new = "); Out.String(new); Out.Ln;
|
||||
*)
|
||||
error := Platform.IdentifyByName(old, oldidentity);
|
||||
IF error = 0 THEN
|
||||
error := Platform.IdentifyByName(new, newidentity);
|
||||
IF (error # 0) & ~Platform.SameFile(oldidentity, newidentity) THEN
|
||||
Delete(new, error); (* work around stale nfs handles *)
|
||||
END;
|
||||
error := Platform.Rename(old, new);
|
||||
(* Out.String("Platform.Rename error code "); Out.Int(error,1); Out.Ln; *)
|
||||
IF ~Platform.DifferentFilesystems(error) THEN
|
||||
res := error; RETURN
|
||||
ELSE
|
||||
(* cross device link, move the file *)
|
||||
error := Platform.OldRO(old, fdold);
|
||||
IF error # 0 THEN res := 2; RETURN END;
|
||||
error := Platform.New(new, fdnew);
|
||||
IF error # 0 THEN error := Platform.Close(fdold); res := 3; RETURN END;
|
||||
error := Platform.Read(fdold, SYSTEM.ADR(buf), bufsize, n);
|
||||
WHILE n > 0 DO
|
||||
error := Platform.Write(fdnew, SYSTEM.ADR(buf), n);
|
||||
IF error # 0 THEN
|
||||
ignore := Platform.Close(fdold);
|
||||
ignore := Platform.Close(fdnew);
|
||||
Err("cannot move file", NIL, error)
|
||||
END;
|
||||
error := Platform.Read(fdold, SYSTEM.ADR(buf), bufsize, n);
|
||||
END;
|
||||
ignore := Platform.Close(fdold);
|
||||
ignore := Platform.Close(fdnew);
|
||||
IF n = 0 THEN
|
||||
error := Platform.Unlink(old); res := 0
|
||||
ELSE
|
||||
Err("cannot move file", NIL, error)
|
||||
END;
|
||||
END
|
||||
ELSE
|
||||
res := 2 (* old file not found *)
|
||||
END
|
||||
END Rename;
|
||||
|
||||
PROCEDURE Register* (f: File);
|
||||
VAR idx, errcode: INTEGER; f1: File; file: ARRAY 104 OF CHAR;
|
||||
BEGIN
|
||||
(*
|
||||
Out.String("Files.Register f.registerName = "); Out.String(f.registerName);
|
||||
Out.String(", fd = "); Out.Int(f.fd,1); Out.Ln;
|
||||
*)
|
||||
IF (f.state = create) & (f.registerName # "") THEN f.state := close (* shortcut renaming *) END;
|
||||
Close(f);
|
||||
IF f.registerName # "" THEN
|
||||
Rename(f.workName, f.registerName, errcode);
|
||||
(*
|
||||
Out.String("Renamed (for register) f.fd = "); Out.Int(f.fd,1);
|
||||
Out.String(" from workname "); Out.String(f.workName);
|
||||
Out.String(" to registerName "); Out.String(f.registerName);
|
||||
Out.String(" errorcode = "); Out.Int(errcode,1); Out.Ln;
|
||||
*)
|
||||
IF errcode # 0 THEN COPY(f.registerName, file); HALT(99) END;
|
||||
f.workName := f.registerName; f.registerName := ""; f.tempFile := FALSE
|
||||
END
|
||||
END Register;
|
||||
|
||||
PROCEDURE ChangeDirectory*(path: ARRAY OF CHAR; VAR res: INTEGER);
|
||||
BEGIN
|
||||
res := Platform.Chdir(path);
|
||||
END ChangeDirectory;
|
||||
|
||||
PROCEDURE FlipBytes(VAR src, dest: ARRAY OF SYSTEM.BYTE);
|
||||
VAR i, j: LONGINT;
|
||||
BEGIN
|
||||
IF ~Platform.LittleEndian THEN i := LEN(src); j := 0;
|
||||
WHILE i > 0 DO DEC(i); dest[j] := src[i]; INC(j) END
|
||||
ELSE SYSTEM.MOVE(SYSTEM.ADR(src), SYSTEM.ADR(dest), LEN(src))
|
||||
END
|
||||
END FlipBytes;
|
||||
|
||||
PROCEDURE ReadBool* (VAR R: Rider; VAR x: BOOLEAN);
|
||||
BEGIN Read(R, SYSTEM.VAL(CHAR, x))
|
||||
END ReadBool;
|
||||
|
||||
PROCEDURE ReadInt* (VAR R: Rider; VAR x: INTEGER);
|
||||
VAR b: ARRAY 2 OF CHAR;
|
||||
BEGIN ReadBytes(R, b, 2);
|
||||
x := ORD(b[0]) + ORD(b[1])*256
|
||||
END ReadInt;
|
||||
|
||||
PROCEDURE ReadLInt* (VAR R: Rider; VAR x: LONGINT);
|
||||
VAR b: ARRAY 4 OF CHAR;
|
||||
BEGIN ReadBytes(R, b, 4);
|
||||
x := ORD(b[0]) + ORD(b[1])*100H + ORD(b[2])*10000H + ORD(b[3])*1000000H
|
||||
END ReadLInt;
|
||||
|
||||
PROCEDURE ReadSet* (VAR R: Rider; VAR x: SET);
|
||||
(* Reads 32 bits as a SET value (even on 64 bit systems. See Oakwood appendix 1.2.5.4 *)
|
||||
VAR b: ARRAY 4 OF CHAR; l: LONGINT;
|
||||
BEGIN ReadBytes(R, b, 4);
|
||||
(* Need to read via a LONGINT to provide correct behaviour for 64 bit sets. *)
|
||||
l := ORD(b[0]) + ORD(b[1])*100H + ORD(b[2])*10000H + ORD(b[3])*1000000H;
|
||||
x := SYSTEM.VAL(SET, l)
|
||||
END ReadSet;
|
||||
|
||||
PROCEDURE ReadReal* (VAR R: Rider; VAR x: REAL);
|
||||
VAR b: ARRAY 4 OF CHAR;
|
||||
BEGIN ReadBytes(R, b, 4); FlipBytes(b, x)
|
||||
END ReadReal;
|
||||
|
||||
PROCEDURE ReadLReal* (VAR R: Rider; VAR x: LONGREAL);
|
||||
VAR b: ARRAY 8 OF CHAR;
|
||||
BEGIN ReadBytes(R, b, 8); FlipBytes(b, x)
|
||||
END ReadLReal;
|
||||
|
||||
PROCEDURE ReadString* (VAR R: Rider; VAR x: ARRAY OF CHAR);
|
||||
VAR i: INTEGER; ch: CHAR;
|
||||
BEGIN i := 0;
|
||||
REPEAT Read(R, ch); x[i] := ch; INC(i) UNTIL ch = 0X
|
||||
END ReadString;
|
||||
|
||||
PROCEDURE ReadLine* (VAR R: Rider; VAR x: ARRAY OF CHAR);
|
||||
VAR i: INTEGER; ch: CHAR; b : BOOLEAN;
|
||||
BEGIN
|
||||
i := 0;
|
||||
b := FALSE;
|
||||
REPEAT
|
||||
Read(R, ch);
|
||||
IF ((ch = 0X) OR (ch = 0AX) OR (ch = 0DX)) THEN
|
||||
b := TRUE
|
||||
ELSE
|
||||
x[i] := ch;
|
||||
INC(i);
|
||||
END;
|
||||
UNTIL b
|
||||
END ReadLine;
|
||||
|
||||
PROCEDURE ReadNum*(VAR R: Rider; VAR x: ARRAY OF SYSTEM.BYTE);
|
||||
VAR s, b: SYSTEM.INT8; q: SYSTEM.INT64;
|
||||
BEGIN
|
||||
s := 0; q := 0; Read(R, b);
|
||||
WHILE b < 0 DO INC(q, ASH(b+128, s)); INC(s, 7); Read(R, b) END;
|
||||
INC(q, ASH(b MOD 64 - b DIV 64 * 64, s));
|
||||
ASSERT(LEN(x) <= 8);
|
||||
SYSTEM.MOVE(SYSTEM.ADR(q), SYSTEM.ADR(x), LEN(x)) (* Assumes little endian representation of q and x. *)
|
||||
END ReadNum;
|
||||
|
||||
PROCEDURE WriteBool* (VAR R: Rider; x: BOOLEAN);
|
||||
BEGIN Write(R, SYSTEM.VAL(CHAR, x))
|
||||
END WriteBool;
|
||||
|
||||
PROCEDURE WriteInt* (VAR R: Rider; x: INTEGER);
|
||||
VAR b: ARRAY 2 OF CHAR;
|
||||
BEGIN b[0] := CHR(x); b[1] := CHR(x DIV 256);
|
||||
WriteBytes(R, b, 2);
|
||||
END WriteInt;
|
||||
|
||||
PROCEDURE WriteLInt* (VAR R: Rider; x: LONGINT);
|
||||
VAR b: ARRAY 4 OF CHAR;
|
||||
BEGIN
|
||||
b[0] := CHR(x); b[1] := CHR(x DIV 100H); b[2] := CHR(x DIV 10000H); b[3] := CHR(x DIV 1000000H);
|
||||
WriteBytes(R, b, 4);
|
||||
END WriteLInt;
|
||||
|
||||
PROCEDURE WriteSet* (VAR R: Rider; x: SET);
|
||||
VAR b: ARRAY 4 OF CHAR; i: LONGINT;
|
||||
BEGIN i := SYSTEM.VAL(LONGINT, x);
|
||||
b[0] := CHR(i); b[1] := CHR(i DIV 100H); b[2] := CHR(i DIV 10000H); b[3] := CHR(i DIV 1000000H);
|
||||
WriteBytes(R, b, 4);
|
||||
END WriteSet;
|
||||
|
||||
PROCEDURE WriteReal* (VAR R: Rider; x: REAL);
|
||||
VAR b: ARRAY 4 OF CHAR;
|
||||
BEGIN FlipBytes(x, b); WriteBytes(R, b, 4)
|
||||
END WriteReal;
|
||||
|
||||
PROCEDURE WriteLReal* (VAR R: Rider; x: LONGREAL);
|
||||
VAR b: ARRAY 8 OF CHAR;
|
||||
BEGIN FlipBytes(x, b); WriteBytes(R, b, 8)
|
||||
END WriteLReal;
|
||||
|
||||
PROCEDURE WriteString* (VAR R: Rider; x: ARRAY [1] OF CHAR);
|
||||
VAR i: INTEGER;
|
||||
BEGIN i := 0;
|
||||
WHILE x[i] # 0X DO INC(i) END;
|
||||
WriteBytes(R, x, i+1)
|
||||
END WriteString;
|
||||
|
||||
PROCEDURE WriteNum* (VAR R: Rider; x: SYSTEM.INT64);
|
||||
BEGIN
|
||||
WHILE (x < - 64) OR (x > 63) DO Write(R, CHR(x MOD 128 + 128)); x := x DIV 128 END;
|
||||
Write(R, CHR(x MOD 128))
|
||||
END 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);
|
||||
(*
|
||||
Out.String("Files.Finalize f.fd = "); Out.Int(f.fd,1);
|
||||
Out.String(", f.registername = "); Out.String(f.registerName);
|
||||
Out.String(", f.workName = "); Out.String(f.workName); Out.Ln;
|
||||
*)
|
||||
IF f.fd >= 0 THEN
|
||||
CloseOSFile(f);
|
||||
IF f.tempFile THEN res := Platform.Unlink(f.workName) END
|
||||
END
|
||||
END Finalize;
|
||||
|
||||
PROCEDURE SetSearchPath*(path: ARRAY OF CHAR);
|
||||
BEGIN
|
||||
IF Strings.Length(path) # 0 THEN
|
||||
NEW(SearchPath, Strings.Length(path)+1);
|
||||
COPY(path, SearchPath^)
|
||||
ELSE
|
||||
SearchPath := NIL
|
||||
END
|
||||
END SetSearchPath;
|
||||
|
||||
|
||||
BEGIN
|
||||
tempno := -1;
|
||||
Heap.FileCount := 0;
|
||||
HOME := ""; Platform.GetEnv("HOME", HOME);
|
||||
END Files.
|
||||
|
|
@ -1,578 +0,0 @@
|
|||
MODULE Heap;
|
||||
|
||||
IMPORT S := SYSTEM; (* Cannot import anything else as heap initialization must complete
|
||||
before any other modules are initialized. *)
|
||||
|
||||
CONST
|
||||
ModNameLen = 20;
|
||||
CmdNameLen = 24;
|
||||
SZA = SIZE(S.ADDRESS); (* Size of address *)
|
||||
Unit = 4*SZA; (* smallest possible heap block *)
|
||||
nofLists = 9; (* number of free_lists *)
|
||||
heapSize0 = 8000*Unit; (* startup heap size *)
|
||||
|
||||
(* all blocks look the same:
|
||||
free blocks describe themselves: size = Unit
|
||||
tag = &tag++
|
||||
->block size
|
||||
sentinel = -SZA
|
||||
next
|
||||
*)
|
||||
|
||||
(* heap chunks *)
|
||||
nextChnkOff = S.VAL(S.ADDRESS, 0); (* next heap chunk, sorted ascendingly! *)
|
||||
endOff = S.VAL(S.ADDRESS, SZA); (* end of heap chunk *)
|
||||
blkOff = S.VAL(S.ADDRESS, 3*SZA); (* first block in a chunk *)
|
||||
|
||||
(* heap blocks *)
|
||||
tagOff = S.VAL(S.ADDRESS, 0); (* block starts with tag *)
|
||||
sizeOff = S.VAL(S.ADDRESS, SZA); (* block size in free block relative to block start *)
|
||||
sntlOff = S.VAL(S.ADDRESS, 2*SZA); (* pointer offset table sentinel in free block relative to block start *)
|
||||
nextOff = S.VAL(S.ADDRESS, 3*SZA); (* next pointer in free block relative to block start *)
|
||||
NoPtrSntl = S.VAL(S.ADDRESS, -SZA);
|
||||
AddressZero = S.VAL(S.ADDRESS, 0);
|
||||
|
||||
TYPE
|
||||
ModuleName = ARRAY ModNameLen OF CHAR;
|
||||
CmdName = ARRAY CmdNameLen OF CHAR;
|
||||
|
||||
Module = POINTER TO ModuleDesc;
|
||||
Cmd = POINTER TO CmdDesc;
|
||||
|
||||
EnumProc = PROCEDURE(P: PROCEDURE(p: S.PTR));
|
||||
|
||||
ModuleDesc = RECORD
|
||||
next: Module;
|
||||
name: ModuleName;
|
||||
refcnt: LONGINT;
|
||||
cmds: Cmd;
|
||||
types: S.ADDRESS;
|
||||
enumPtrs: EnumProc;
|
||||
reserved1, reserved2: LONGINT
|
||||
END ;
|
||||
|
||||
Command = PROCEDURE;
|
||||
|
||||
CmdDesc = RECORD
|
||||
next: Cmd;
|
||||
name: CmdName;
|
||||
cmd: Command
|
||||
END ;
|
||||
|
||||
Finalizer = PROCEDURE(obj: S.PTR);
|
||||
|
||||
FinNode = POINTER TO FinDesc;
|
||||
FinDesc = RECORD
|
||||
next: FinNode;
|
||||
obj: S.ADDRESS; (* weak pointer *)
|
||||
marked: BOOLEAN;
|
||||
finalize: Finalizer;
|
||||
END ;
|
||||
|
||||
VAR
|
||||
(* the list of loaded (=initialization started) modules *)
|
||||
modules*: S.PTR;
|
||||
|
||||
freeList: ARRAY nofLists + 1 OF S.ADDRESS; (* dummy, 16, 32, 48, 64, 80, 96, 112, 128, sentinel *)
|
||||
bigBlocks: S.ADDRESS;
|
||||
allocated*: S.ADDRESS;
|
||||
firstTry: BOOLEAN;
|
||||
|
||||
(* extensible heap *)
|
||||
heap: S.ADDRESS; (* the sorted list of heap chunks *)
|
||||
heapend: S.ADDRESS; (* max possible pointer value (used for stack collection) *)
|
||||
heapsize*: S.ADDRESS; (* the sum of all heap chunk sizes *)
|
||||
|
||||
(* finalization candidates *)
|
||||
fin: FinNode;
|
||||
|
||||
(* garbage collector locking *)
|
||||
lockdepth: INTEGER;
|
||||
interrupted: BOOLEAN;
|
||||
|
||||
(* File system file count monitor *)
|
||||
FileCount*: INTEGER;
|
||||
|
||||
|
||||
PROCEDURE Lock*;
|
||||
BEGIN
|
||||
INC(lockdepth);
|
||||
END Lock;
|
||||
|
||||
PROCEDURE -PlatformHalt(code: LONGINT) "Platform_Halt(code)";
|
||||
|
||||
PROCEDURE Unlock*;
|
||||
BEGIN
|
||||
DEC(lockdepth);
|
||||
IF interrupted & (lockdepth = 0) THEN
|
||||
PlatformHalt(-9);
|
||||
END
|
||||
END Unlock;
|
||||
|
||||
|
||||
(*
|
||||
PROCEDURE TAS*(VAR flag:BOOLEAN): BOOLEAN; (* added for compatibility with ulmSYSTEM module; noch *)
|
||||
VAR oldflag : BOOLEAN;
|
||||
BEGIN
|
||||
oldflag := flag;
|
||||
flag := TRUE;
|
||||
RETURN oldflag;
|
||||
END TAS;
|
||||
*)
|
||||
|
||||
PROCEDURE REGMOD*(VAR name: ModuleName; enumPtrs: EnumProc): S.PTR;
|
||||
VAR m: Module;
|
||||
BEGIN
|
||||
(* REGMOD is called at the start of module initialisation code before that modules
|
||||
type descriptors have been set up. 'NEW' depends on the Heap modules type
|
||||
descriptors being ready for use, therefore, just for the Heap module itself, we
|
||||
must use S.NEW. *)
|
||||
IF name = "Heap" THEN
|
||||
S.NEW(m, SIZE(ModuleDesc))
|
||||
ELSE
|
||||
NEW(m)
|
||||
END;
|
||||
m.types := 0; m.cmds := NIL;
|
||||
COPY(name, m.name); m.refcnt := 0; m.enumPtrs := enumPtrs; m.next := S.VAL(Module, modules);
|
||||
modules := m;
|
||||
RETURN m
|
||||
END REGMOD;
|
||||
|
||||
PROCEDURE REGCMD*(m: Module; VAR name: CmdName; cmd: Command);
|
||||
VAR c: Cmd;
|
||||
BEGIN
|
||||
(* REGCMD is called during module initialisation code before that modules
|
||||
type descriptors have been set up. 'NEW' depends on the Heap modules type
|
||||
descriptors being ready for use, therefore, just for the commands registered
|
||||
by the Heap module itself, we must use S.NEW. *)
|
||||
IF m.name = "Heap" THEN
|
||||
S.NEW(c, SIZE(CmdDesc))
|
||||
ELSE
|
||||
NEW(c)
|
||||
END;
|
||||
COPY(name, c.name); c.cmd := cmd; c.next := m.cmds; m.cmds := c
|
||||
END REGCMD;
|
||||
|
||||
PROCEDURE REGTYP*(m: Module; typ: S.ADDRESS);
|
||||
BEGIN S.PUT(typ, m.types); m.types := typ
|
||||
END REGTYP;
|
||||
|
||||
PROCEDURE INCREF*(m: Module);
|
||||
BEGIN INC(m.refcnt)
|
||||
END INCREF;
|
||||
|
||||
|
||||
PROCEDURE -ExternPlatformOSAllocate "extern address Platform_OSAllocate(address size);";
|
||||
PROCEDURE -OSAllocate(size: S.ADDRESS): S.ADDRESS "Platform_OSAllocate(size)";
|
||||
|
||||
PROCEDURE NewChunk(blksz: S.ADDRESS): S.ADDRESS;
|
||||
VAR chnk: S.ADDRESS;
|
||||
BEGIN
|
||||
chnk := OSAllocate(blksz + blkOff);
|
||||
IF chnk # 0 THEN
|
||||
S.PUT(chnk + endOff, chnk + (blkOff + blksz));
|
||||
S.PUT(chnk + blkOff, chnk + (blkOff + sizeOff));
|
||||
S.PUT(chnk + (blkOff + sizeOff), blksz);
|
||||
S.PUT(chnk + (blkOff + sntlOff), NoPtrSntl);
|
||||
S.PUT(chnk + (blkOff + nextOff), bigBlocks);
|
||||
bigBlocks := chnk + blkOff;
|
||||
INC(heapsize, blksz)
|
||||
END ;
|
||||
RETURN chnk
|
||||
END NewChunk;
|
||||
|
||||
PROCEDURE ExtendHeap(blksz: S.ADDRESS);
|
||||
VAR size, chnk, j, next: S.ADDRESS;
|
||||
BEGIN
|
||||
IF blksz > 10000*Unit THEN size := blksz
|
||||
ELSE size := 10000*Unit (* additional heuristics *)
|
||||
END ;
|
||||
chnk := NewChunk(size);
|
||||
IF chnk # 0 THEN
|
||||
(*sorted insertion*)
|
||||
IF chnk < heap THEN
|
||||
S.PUT(chnk, heap); heap := chnk
|
||||
ELSE
|
||||
j := heap; S.GET(j, next);
|
||||
WHILE (next # 0) & (chnk > next) DO
|
||||
j := next;
|
||||
S.GET(j, next)
|
||||
END;
|
||||
S.PUT(chnk, next); S.PUT(j, chnk)
|
||||
END ;
|
||||
IF next = 0 THEN S.GET(chnk+endOff, heapend) END
|
||||
END
|
||||
END ExtendHeap;
|
||||
|
||||
PROCEDURE ^GC*(markStack: BOOLEAN);
|
||||
|
||||
PROCEDURE NEWREC*(tag: S.ADDRESS): S.PTR;
|
||||
VAR
|
||||
i, i0, di, blksz, restsize, t, adr, end, next, prev: S.ADDRESS;
|
||||
new: S.PTR;
|
||||
BEGIN
|
||||
Lock();
|
||||
S.GET(tag, blksz);
|
||||
|
||||
ASSERT((Unit = 16) OR (Unit = 32));
|
||||
ASSERT(SIZE(S.PTR) = SIZE(S.ADDRESS));
|
||||
ASSERT(blksz MOD Unit = 0);
|
||||
|
||||
i0 := blksz DIV Unit; i := i0;
|
||||
IF i < nofLists THEN adr := freeList[i];
|
||||
WHILE adr = 0 DO INC(i); adr := freeList[i] END
|
||||
END ;
|
||||
IF i < nofLists THEN (* unlink *)
|
||||
S.GET(adr + nextOff, next);
|
||||
freeList[i] := next;
|
||||
IF i # i0 THEN (* split *)
|
||||
di := i - i0; restsize := di * Unit; end := adr + restsize;
|
||||
S.PUT(end + sizeOff, blksz);
|
||||
S.PUT(end + sntlOff, NoPtrSntl);
|
||||
S.PUT(end, end + sizeOff);
|
||||
S.PUT(adr + sizeOff, restsize);
|
||||
S.PUT(adr + nextOff, freeList[di]);
|
||||
freeList[di] := adr;
|
||||
INC(adr, restsize)
|
||||
END
|
||||
ELSE
|
||||
adr := bigBlocks; prev := 0;
|
||||
LOOP
|
||||
IF adr = 0 THEN
|
||||
IF firstTry THEN
|
||||
GC(TRUE); INC(blksz, Unit);
|
||||
IF (heapsize - allocated - blksz) * 4 < heapsize THEN
|
||||
(* heap is still almost full; expand to avoid thrashing *)
|
||||
ExtendHeap((allocated + blksz) DIV (3*Unit) * (4*Unit) - heapsize)
|
||||
END ;
|
||||
firstTry := FALSE; new := NEWREC(tag); firstTry := TRUE;
|
||||
IF new = NIL THEN
|
||||
(* depending on the fragmentation, the heap may not have been extended by
|
||||
the anti-thrashing heuristics above *)
|
||||
ExtendHeap((allocated + blksz) DIV (3*Unit) * (4*Unit) - heapsize);
|
||||
new := NEWREC(tag); (* will find a free block if heap has been expanded properly *)
|
||||
END ;
|
||||
Unlock(); RETURN new
|
||||
ELSE
|
||||
Unlock(); RETURN NIL
|
||||
END
|
||||
END ;
|
||||
S.GET(adr+sizeOff, t);
|
||||
IF t >= blksz THEN EXIT END ;
|
||||
prev := adr; S.GET(adr + nextOff, adr)
|
||||
END ;
|
||||
restsize := t - blksz; end := adr + restsize;
|
||||
S.PUT(end + sizeOff, blksz);
|
||||
S.PUT(end + sntlOff, NoPtrSntl);
|
||||
S.PUT(end, end + sizeOff);
|
||||
IF restsize > nofLists * Unit THEN (*resize*)
|
||||
S.PUT(adr + sizeOff, restsize)
|
||||
ELSE (*unlink*)
|
||||
S.GET(adr + nextOff, next);
|
||||
IF prev = 0 THEN bigBlocks := next
|
||||
ELSE S.PUT(prev + nextOff, next);
|
||||
END ;
|
||||
IF restsize > 0 THEN (*move*)
|
||||
di := restsize DIV Unit;
|
||||
S.PUT(adr + sizeOff, restsize);
|
||||
S.PUT(adr + nextOff, freeList[di]);
|
||||
freeList[di] := adr
|
||||
END
|
||||
END ;
|
||||
INC(adr, restsize)
|
||||
END ;
|
||||
i := adr + 4*SZA; end := adr + blksz;
|
||||
WHILE i < end DO (*deliberately unrolled*)
|
||||
S.PUT(i, AddressZero);
|
||||
S.PUT(i + SZA, AddressZero);
|
||||
S.PUT(i + 2*SZA, AddressZero);
|
||||
S.PUT(i + 3*SZA, AddressZero);
|
||||
INC(i, 4*SZA)
|
||||
END ;
|
||||
S.PUT(adr + nextOff, AddressZero);
|
||||
S.PUT(adr, tag);
|
||||
S.PUT(adr + sizeOff, AddressZero);
|
||||
S.PUT(adr + sntlOff, AddressZero);
|
||||
INC(allocated, blksz);
|
||||
Unlock();
|
||||
RETURN S.VAL(S.PTR, adr + SZA)
|
||||
END NEWREC;
|
||||
|
||||
PROCEDURE NEWBLK*(size: S.ADDRESS): S.PTR;
|
||||
VAR blksz, tag: S.ADDRESS; new: S.PTR;
|
||||
BEGIN
|
||||
Lock();
|
||||
blksz := (size + (4*SZA + Unit - 1)) DIV Unit * Unit; (*size + tag + meta + blksz + sntnl + UnitAlignment*)
|
||||
new := NEWREC(S.ADR(blksz));
|
||||
tag := S.VAL(S.ADDRESS, new) + blksz - 3*SZA;
|
||||
S.PUT(tag - SZA, AddressZero); (*reserved for meta info*)
|
||||
S.PUT(tag, blksz);
|
||||
S.PUT(tag + SZA, NoPtrSntl);
|
||||
S.PUT(S.VAL(S.ADDRESS, new) - SZA, tag);
|
||||
Unlock();
|
||||
RETURN new
|
||||
END NEWBLK;
|
||||
|
||||
PROCEDURE Mark(q: S.ADDRESS);
|
||||
VAR p, tag, offset, fld, n, tagbits: S.ADDRESS;
|
||||
BEGIN
|
||||
IF q # 0 THEN
|
||||
S.GET(q - SZA, tagbits); (* Load the tag for the record at q *)
|
||||
IF ~ODD(tagbits) THEN (* If it has not already been marked *)
|
||||
S.PUT(q - SZA, tagbits + 1); (* Mark it *)
|
||||
p := 0;
|
||||
tag := tagbits + SZA; (* Tag addresses first offset *)
|
||||
LOOP
|
||||
S.GET(tag, offset); (* Get next ptr field offset *)
|
||||
IF offset < 0 THEN (* Sentinel reached: Value is -8*(#fields+1) *)
|
||||
S.PUT(q - SZA, tag + offset + 1); (* Rotate base ptr into tag *)
|
||||
IF p = 0 THEN EXIT END ;
|
||||
n := q; q := p;
|
||||
S.GET(q - SZA, tag); DEC(tag, 1);
|
||||
S.GET(tag, offset); fld := q + offset;
|
||||
S.GET(fld, p); S.PUT(fld, S.VAL(S.PTR, n))
|
||||
ELSE (* offset references a ptr field *)
|
||||
fld := q + offset; (* S.ADDRESS the pointer *)
|
||||
S.GET(fld, n); (* Load the pointer *)
|
||||
IF n # 0 THEN (* If pointer is not NIL *)
|
||||
S.GET(n - SZA, tagbits); (* Consider record pointed to by this field *)
|
||||
IF ~ODD(tagbits) THEN
|
||||
S.PUT(n - SZA, tagbits + 1);
|
||||
S.PUT(q - SZA, tag + 1);
|
||||
S.PUT(fld, S.VAL(S.PTR, p));
|
||||
p := q; q := n;
|
||||
tag := tagbits
|
||||
END
|
||||
END
|
||||
END ;
|
||||
INC(tag, SZA)
|
||||
END
|
||||
END
|
||||
END
|
||||
END Mark;
|
||||
|
||||
PROCEDURE MarkP(p: S.PTR); (* for compatibility with EnumPtrs in ANSI mode *)
|
||||
BEGIN
|
||||
Mark(S.VAL(S.ADDRESS, p))
|
||||
END MarkP;
|
||||
|
||||
PROCEDURE Scan;
|
||||
VAR chnk, adr, end, start, tag, i, size, freesize: S.ADDRESS;
|
||||
BEGIN bigBlocks := 0; i := 1;
|
||||
WHILE i < nofLists DO freeList[i] := 0; INC(i) END ;
|
||||
freesize := 0; allocated := 0; chnk := heap;
|
||||
WHILE chnk # 0 DO
|
||||
adr := chnk + blkOff;
|
||||
S.GET(chnk + endOff, end);
|
||||
WHILE adr < end DO
|
||||
S.GET(adr, tag);
|
||||
IF ODD(tag) THEN (*marked*)
|
||||
IF freesize > 0 THEN
|
||||
start := adr - freesize;
|
||||
S.PUT(start, start+SZA);
|
||||
S.PUT(start+sizeOff, freesize);
|
||||
S.PUT(start+sntlOff, NoPtrSntl);
|
||||
i := freesize DIV Unit; freesize := 0;
|
||||
IF i < nofLists THEN S.PUT(start + nextOff, freeList[i]); freeList[i] := start
|
||||
ELSE S.PUT(start + nextOff, bigBlocks); bigBlocks := start
|
||||
END
|
||||
END ;
|
||||
DEC(tag, 1);
|
||||
S.PUT(adr, tag);
|
||||
S.GET(tag, size);
|
||||
INC(allocated, size);
|
||||
INC(adr, size)
|
||||
ELSE (*unmarked*)
|
||||
S.GET(tag, size);
|
||||
INC(freesize, size);
|
||||
INC(adr, size)
|
||||
END
|
||||
END ;
|
||||
IF freesize > 0 THEN (*collect last block*)
|
||||
start := adr - freesize;
|
||||
S.PUT(start, start+SZA);
|
||||
S.PUT(start+sizeOff, freesize);
|
||||
S.PUT(start+sntlOff, NoPtrSntl);
|
||||
i := freesize DIV Unit; freesize := 0;
|
||||
IF i < nofLists THEN S.PUT(start + nextOff, freeList[i]); freeList[i] := start
|
||||
ELSE S.PUT(start + nextOff, bigBlocks); bigBlocks := start
|
||||
END
|
||||
END ;
|
||||
S.GET(chnk, chnk)
|
||||
END
|
||||
END Scan;
|
||||
|
||||
PROCEDURE Sift (l, r: S.ADDRESS; VAR a: ARRAY OF S.ADDRESS);
|
||||
VAR i, j, x: S.ADDRESS;
|
||||
BEGIN j := l; x := a[j];
|
||||
LOOP i := j; j := 2*j + 1;
|
||||
IF (j < r) & (a[j] < a[j+1]) THEN INC(j) END;
|
||||
IF (j > r) OR (a[j] <= x) THEN EXIT END;
|
||||
a[i] := a[j]
|
||||
END;
|
||||
a[i] := x
|
||||
END Sift;
|
||||
|
||||
PROCEDURE HeapSort (n: S.ADDRESS; VAR a: ARRAY OF S.ADDRESS);
|
||||
VAR l, r, x: S.ADDRESS;
|
||||
BEGIN l := n DIV 2; r := n - 1;
|
||||
WHILE l > 0 DO DEC(l); Sift(l, r, a) END;
|
||||
WHILE r > 0 DO x := a[0]; a[0] := a[r]; a[r] := x; DEC(r); Sift(l, r, a) END
|
||||
END HeapSort;
|
||||
|
||||
PROCEDURE MarkCandidates(n: S.ADDRESS; VAR cand: ARRAY OF S.ADDRESS);
|
||||
VAR chnk, adr, tag, next, lim, lim1, i, ptr, size: S.ADDRESS;
|
||||
BEGIN
|
||||
chnk := heap; i := 0; lim := cand[n-1];
|
||||
WHILE (chnk # 0 ) & (chnk < lim) DO
|
||||
adr := chnk + blkOff;
|
||||
S.GET(chnk + endOff, lim1);
|
||||
IF lim < lim1 THEN lim1 := lim END ;
|
||||
WHILE adr < lim1 DO
|
||||
S.GET(adr, tag);
|
||||
IF ODD(tag) THEN (*already marked*)
|
||||
S.GET(tag-1, size); INC(adr, size)
|
||||
ELSE
|
||||
S.GET(tag, size);
|
||||
ptr := adr + SZA;
|
||||
WHILE cand[i] < ptr DO INC(i) END ;
|
||||
IF i = n THEN RETURN END ;
|
||||
next := adr + size;
|
||||
IF cand[i] < next THEN Mark(ptr) END ;
|
||||
adr := next
|
||||
END
|
||||
END ;
|
||||
S.GET(chnk, chnk)
|
||||
END
|
||||
END MarkCandidates;
|
||||
|
||||
PROCEDURE CheckFin;
|
||||
VAR n: FinNode; tag: S.ADDRESS;
|
||||
BEGIN
|
||||
n := fin;
|
||||
WHILE n # NIL DO
|
||||
S.GET(n.obj - SZA, tag);
|
||||
IF ~ODD(tag) THEN n.marked := FALSE; Mark(n.obj)
|
||||
ELSE n.marked := TRUE
|
||||
END ;
|
||||
n := n.next
|
||||
END
|
||||
END CheckFin;
|
||||
|
||||
PROCEDURE Finalize;
|
||||
VAR n, prev: FinNode;
|
||||
BEGIN n := fin; prev := NIL;
|
||||
WHILE n # NIL DO
|
||||
IF ~n.marked THEN
|
||||
IF n = fin THEN fin := fin.next ELSE prev.next := n.next END ;
|
||||
n.finalize(S.VAL(S.PTR, n.obj));
|
||||
(* new nodes may have been pushed in n.finalize, therefore: *)
|
||||
IF prev = NIL THEN n := fin ELSE n := n.next END
|
||||
ELSE
|
||||
prev := n; n := n.next
|
||||
END
|
||||
END
|
||||
END Finalize;
|
||||
|
||||
PROCEDURE FINALL*;
|
||||
VAR n: FinNode;
|
||||
BEGIN
|
||||
WHILE fin # NIL DO
|
||||
n := fin; fin := fin.next;
|
||||
n.finalize(S.VAL(S.PTR, n.obj))
|
||||
END
|
||||
END FINALL;
|
||||
|
||||
PROCEDURE -ExternMainStackFrame "extern address Platform_MainStackFrame;";
|
||||
PROCEDURE -PlatformMainStackFrame(): S.ADDRESS "Platform_MainStackFrame";
|
||||
|
||||
PROCEDURE MarkStack(n: S.ADDRESS; VAR cand: ARRAY OF S.ADDRESS);
|
||||
VAR
|
||||
frame: S.PTR;
|
||||
inc, nofcand: S.ADDRESS;
|
||||
sp, p, stack0: S.ADDRESS;
|
||||
align: RECORD ch: CHAR; p: S.PTR END ;
|
||||
BEGIN
|
||||
IF n > 0 THEN MarkStack(n-1, cand); (* flush register windows by means of recursive calls *)
|
||||
IF n > 100 THEN RETURN END (* prevent tail recursion optimization *)
|
||||
END ;
|
||||
IF n = 0 THEN
|
||||
nofcand := 0; sp := S.ADR(frame);
|
||||
stack0 := PlatformMainStackFrame();
|
||||
(* check for minimum alignment of pointers *)
|
||||
inc := S.ADR(align.p) - S.ADR(align);
|
||||
IF sp > stack0 THEN inc := -inc END ;
|
||||
WHILE sp # stack0 DO
|
||||
S.GET(sp, p);
|
||||
IF (p > heap) & (p < heapend) THEN
|
||||
IF nofcand = LEN(cand) THEN HeapSort(nofcand, cand); MarkCandidates(nofcand, cand); nofcand := 0 END ;
|
||||
cand[nofcand] := p; INC(nofcand)
|
||||
END ;
|
||||
INC(sp, inc)
|
||||
END ;
|
||||
IF nofcand > 0 THEN HeapSort(nofcand, cand); MarkCandidates(nofcand, cand) END
|
||||
END
|
||||
END MarkStack;
|
||||
|
||||
PROCEDURE GC*(markStack: BOOLEAN);
|
||||
VAR
|
||||
m: Module;
|
||||
i0, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, i21, i22, i23: S.ADDRESS;
|
||||
cand: ARRAY 10000 OF S.ADDRESS;
|
||||
BEGIN
|
||||
IF (lockdepth = 0) OR (lockdepth = 1) & ~markStack THEN
|
||||
Lock();
|
||||
m := S.VAL(Module, modules);
|
||||
WHILE m # NIL DO
|
||||
IF m.enumPtrs # NIL THEN m.enumPtrs(MarkP) END ;
|
||||
m := m^.next
|
||||
END ;
|
||||
IF markStack THEN
|
||||
(* generate register pressure to force callee saved registers to memory;
|
||||
may be simplified by inlining OS calls or processor specific instructions
|
||||
*)
|
||||
i0 := -100; i1 := -101; i2 := -102; i3 := -103; i4 := -104; i5 := -105; i6 := -106; i7 := -107;
|
||||
i8 := 1; i9 := 2; i10 := 3; i11 := 4; i12 := 5; i13 := 6; i14 := 7; i15 := 8;
|
||||
i16 := 9; i17 := 10; i18 := 11; i19 := 12; i20 := 13; i21 := 14; i22 := 15; i23 := 16;
|
||||
LOOP INC(i0, 1); INC(i1, 2); INC(i2, 3); INC(i3, 4); INC(i4, 5); INC(i5, 6); INC(i6, 7); INC(i7, 8);
|
||||
INC(i8, 9); INC(i9, 10); INC(i10, 11); INC(i11, 12); INC(i12, 13); INC(i13, 14); INC(i14, 15); INC(i15, 16);
|
||||
INC(i16, 17); INC(i17, 18); INC(i18, 19); INC(i19, 20); INC(i20, 21); INC(i21, 22); INC(i22, 23); INC(i23, 24);
|
||||
IF (i0 = -99) & (i15 = 24) THEN MarkStack(32, cand); EXIT END
|
||||
END ;
|
||||
IF i0 + i1 + i2 + i3 + i4 + i5 + i6 + i7 + i8 + i9 + i10 + i11 + i12 + i13 + i14 + i15
|
||||
+ i16 + i17 + i18 + i19 + i20 + i21 + i22 + i23 > 10000 THEN RETURN (* use all variables *)
|
||||
END ;
|
||||
END;
|
||||
CheckFin;
|
||||
Scan;
|
||||
Finalize;
|
||||
Unlock()
|
||||
END
|
||||
END GC;
|
||||
|
||||
PROCEDURE RegisterFinalizer*(obj: S.PTR; finalize: Finalizer);
|
||||
VAR f: FinNode;
|
||||
BEGIN NEW(f);
|
||||
f.obj := S.VAL(S.ADDRESS, obj); f.finalize := finalize; f.marked := TRUE;
|
||||
f.next := fin; fin := f;
|
||||
END RegisterFinalizer;
|
||||
|
||||
|
||||
PROCEDURE -ExternHeapInit "extern void *Heap__init();";
|
||||
PROCEDURE -HeapModuleInit 'Heap__init()';
|
||||
|
||||
PROCEDURE InitHeap*;
|
||||
(* InitHeap is called by Platform.init before any module bodies have been
|
||||
initialised, to enable NEW, S.NEW *)
|
||||
BEGIN
|
||||
heap := NewChunk(heapSize0);
|
||||
S.GET(heap + endOff, heapend);
|
||||
S.PUT(heap, AddressZero);
|
||||
allocated := 0; firstTry := TRUE; freeList[nofLists] := 1; lockdepth := 0;
|
||||
FileCount := 0; modules := NIL; heapsize := 0; bigBlocks := 0; fin := NIL;
|
||||
interrupted := FALSE;
|
||||
|
||||
HeapModuleInit;
|
||||
END InitHeap;
|
||||
|
||||
END Heap.
|
||||
|
|
@ -1,86 +0,0 @@
|
|||
MODULE Oberon;
|
||||
|
||||
(* this version should not have dependency on graphics -- noch *)
|
||||
|
||||
IMPORT Platform, Texts, Args, Console;
|
||||
|
||||
TYPE
|
||||
ParList* = POINTER TO ParRec;
|
||||
|
||||
ParRec* = RECORD
|
||||
(* vwr*: Viewers.Viewer;
|
||||
frame*: Display.Frame;*)
|
||||
text*: Texts.Text;
|
||||
pos*: LONGINT
|
||||
END;
|
||||
|
||||
VAR
|
||||
|
||||
Log*: Texts.Text;
|
||||
Par*: ParList; (*actual parameters*)
|
||||
R: Texts.Reader;
|
||||
W: Texts.Writer;
|
||||
OptionChar*: CHAR;
|
||||
|
||||
(*clocks*)
|
||||
|
||||
PROCEDURE GetClock* (VAR t, d: LONGINT);
|
||||
BEGIN Platform.GetClock(t, d)
|
||||
END GetClock;
|
||||
|
||||
PROCEDURE Time* (): LONGINT;
|
||||
BEGIN
|
||||
RETURN Platform.Time()
|
||||
END Time;
|
||||
|
||||
PROCEDURE PopulateParams;
|
||||
VAR
|
||||
W: Texts.Writer;
|
||||
i: INTEGER;
|
||||
str: ARRAY 32 OF CHAR;
|
||||
BEGIN
|
||||
|
||||
i := 1; (* skip program name *)
|
||||
Texts.OpenWriter(W);
|
||||
|
||||
REPEAT
|
||||
IF i < Args.argc THEN
|
||||
Args.Get(i, str);
|
||||
Texts.WriteString(W, str);
|
||||
Texts.WriteString(W, " ");
|
||||
END;
|
||||
INC(i)
|
||||
UNTIL i >= Args.argc;
|
||||
|
||||
Texts.Append (Par^.text, W.buf);
|
||||
|
||||
END PopulateParams;
|
||||
|
||||
PROCEDURE GetSelection*(VAR text: Texts.Text; VAR beg, end, time: LONGINT);
|
||||
BEGIN text := NIL; beg := 0; end := 0; time := 0;
|
||||
END GetSelection;
|
||||
|
||||
(* --- Notifier for echoing 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);
|
||||
IF ch = 0DX THEN Console.Ln ELSE Console.Char(ch) END;
|
||||
INC(beg)
|
||||
END
|
||||
END LogNotifier;
|
||||
|
||||
BEGIN
|
||||
NEW(Par);
|
||||
NEW(Par.text);
|
||||
Par.pos := 0;
|
||||
OptionChar := '-';
|
||||
Texts.Open(Par.text, "");
|
||||
PopulateParams;
|
||||
NEW(Log);
|
||||
Texts.Open(Log, "");
|
||||
Log.notify := LogNotifier;
|
||||
END Oberon.
|
||||
|
|
@ -1,552 +0,0 @@
|
|||
MODULE Platform;
|
||||
IMPORT SYSTEM;
|
||||
|
||||
CONST
|
||||
StdIn- = 0;
|
||||
StdOut- = 1;
|
||||
StdErr- = 2;
|
||||
|
||||
TYPE
|
||||
HaltProcedure = PROCEDURE(n: LONGINT);
|
||||
SignalHandler = PROCEDURE(signal: INTEGER);
|
||||
|
||||
ErrorCode* = INTEGER;
|
||||
FileHandle* = LONGINT;
|
||||
|
||||
FileIdentity* = RECORD
|
||||
volume: LONGINT; (* dev on Unix filesystems, volume serial number on NTFS *)
|
||||
index: LONGINT; (* inode on Unix filesystems, file id on NTFS *)
|
||||
mtime: LONGINT; (* File modification time, value is system dependent *)
|
||||
END;
|
||||
|
||||
EnvPtr = POINTER TO ARRAY 1024 OF CHAR;
|
||||
ArgPtr = POINTER TO ARRAY 1024 OF CHAR;
|
||||
ArgVec = POINTER TO ARRAY 1024 OF ArgPtr;
|
||||
ArgVecPtr = POINTER TO ARRAY 1 OF SYSTEM.ADDRESS;
|
||||
|
||||
|
||||
VAR
|
||||
LittleEndian-: BOOLEAN;
|
||||
MainStackFrame-: SYSTEM.ADDRESS;
|
||||
HaltCode-: LONGINT;
|
||||
PID-: INTEGER; (* Note: Must be updated by Fork implementation *)
|
||||
CWD-: ARRAY 256 OF CHAR;
|
||||
ArgCount-: INTEGER;
|
||||
|
||||
ArgVector-: SYSTEM.ADDRESS;
|
||||
HaltHandler: HaltProcedure;
|
||||
TimeStart: LONGINT;
|
||||
|
||||
SeekSet-: INTEGER;
|
||||
SeekCur-: INTEGER;
|
||||
SeekEnd-: INTEGER;
|
||||
|
||||
NL-: ARRAY 3 OF CHAR; (* Platform specific newline representation *)
|
||||
|
||||
|
||||
|
||||
(* Unix headers to be included *)
|
||||
|
||||
PROCEDURE -Aincludesystime '#include <sys/time.h>'; (* for gettimeofday *)
|
||||
PROCEDURE -Aincludetime '#include <time.h>'; (* for localtime *)
|
||||
PROCEDURE -Aincludesystypes '#include <sys/types.h>';
|
||||
PROCEDURE -Aincludeunistd '#include <unistd.h>';
|
||||
PROCEDURE -Aincludesysstat '#include <sys/stat.h>';
|
||||
PROCEDURE -Aincludefcntl '#include <fcntl.h>';
|
||||
PROCEDURE -Aincludeerrno '#include <errno.h>';
|
||||
PROCEDURE -Astdlib '#include <stdlib.h>';
|
||||
PROCEDURE -Astdio '#include <stdio.h>';
|
||||
PROCEDURE -Aerrno '#include <errno.h>';
|
||||
|
||||
|
||||
|
||||
|
||||
(* Error code tests *)
|
||||
|
||||
PROCEDURE -EMFILE(): ErrorCode 'EMFILE';
|
||||
PROCEDURE -ENFILE(): ErrorCode 'ENFILE';
|
||||
PROCEDURE -ENOENT(): ErrorCode 'ENOENT';
|
||||
PROCEDURE -EXDEV(): ErrorCode 'EXDEV';
|
||||
PROCEDURE -EACCES(): ErrorCode 'EACCES';
|
||||
PROCEDURE -EROFS(): ErrorCode 'EROFS';
|
||||
PROCEDURE -EAGAIN(): ErrorCode 'EAGAIN';
|
||||
PROCEDURE -ETIMEDOUT(): ErrorCode 'ETIMEDOUT';
|
||||
PROCEDURE -ECONNREFUSED(): ErrorCode 'ECONNREFUSED';
|
||||
PROCEDURE -ECONNABORTED(): ErrorCode 'ECONNABORTED';
|
||||
PROCEDURE -ENETUNREACH(): ErrorCode 'ENETUNREACH';
|
||||
PROCEDURE -EHOSTUNREACH(): ErrorCode 'EHOSTUNREACH';
|
||||
PROCEDURE -EINTR(): ErrorCode 'EINTR';
|
||||
|
||||
|
||||
|
||||
|
||||
PROCEDURE TooManyFiles*(e: ErrorCode): BOOLEAN;
|
||||
BEGIN RETURN (e = EMFILE()) OR (e = ENFILE()) END TooManyFiles;
|
||||
|
||||
PROCEDURE NoSuchDirectory*(e: ErrorCode): BOOLEAN;
|
||||
BEGIN RETURN e = ENOENT() END NoSuchDirectory;
|
||||
|
||||
PROCEDURE DifferentFilesystems*(e: ErrorCode): BOOLEAN;
|
||||
BEGIN RETURN e = EXDEV() END DifferentFilesystems;
|
||||
|
||||
PROCEDURE Inaccessible*(e: ErrorCode): BOOLEAN;
|
||||
BEGIN RETURN (e = EACCES()) OR (e = EROFS()) OR (e = EAGAIN()) END Inaccessible;
|
||||
|
||||
PROCEDURE Absent*(e: ErrorCode): BOOLEAN;
|
||||
BEGIN RETURN e = ENOENT() END Absent;
|
||||
|
||||
PROCEDURE TimedOut*(e: ErrorCode): BOOLEAN;
|
||||
BEGIN RETURN e = ETIMEDOUT() END TimedOut;
|
||||
|
||||
PROCEDURE ConnectionFailed*(e: ErrorCode): BOOLEAN;
|
||||
BEGIN RETURN (e = ECONNREFUSED()) OR (e = ECONNABORTED())
|
||||
OR (e = ENETUNREACH()) OR (e = EHOSTUNREACH()) END ConnectionFailed;
|
||||
|
||||
PROCEDURE Interrupted*(e: ErrorCode): BOOLEAN;
|
||||
BEGIN RETURN e = EINTR() END Interrupted;
|
||||
|
||||
|
||||
|
||||
|
||||
(* OS memory allocaton *)
|
||||
|
||||
PROCEDURE -allocate (size: SYSTEM.ADDRESS): SYSTEM.ADDRESS "(address)((void*)malloc((size_t)size))";
|
||||
PROCEDURE OSAllocate*(size: SYSTEM.ADDRESS): SYSTEM.ADDRESS; BEGIN RETURN allocate(size) END OSAllocate;
|
||||
|
||||
PROCEDURE -free(address: SYSTEM.ADDRESS) "free((void*)address)";
|
||||
PROCEDURE OSFree*(address: SYSTEM.ADDRESS); BEGIN free(address) END OSFree;
|
||||
|
||||
|
||||
|
||||
|
||||
(* Program startup *)
|
||||
|
||||
PROCEDURE -ExternInitHeap "extern void Heap_InitHeap();";
|
||||
PROCEDURE -HeapInitHeap() "Heap_InitHeap()";
|
||||
|
||||
PROCEDURE Init*(argc: INTEGER; argvadr: SYSTEM.ADDRESS);
|
||||
VAR av: ArgVecPtr;
|
||||
BEGIN
|
||||
MainStackFrame := argvadr;
|
||||
ArgCount := argc;
|
||||
av := SYSTEM.VAL(ArgVecPtr, argvadr);
|
||||
ArgVector := av[0];
|
||||
HaltCode := -128;
|
||||
|
||||
(* This function (Platform.Init) is called at program startup BEFORE any
|
||||
modules have been initalised. In turn we must initialise the heap
|
||||
before module startup (xxx__init) code is run. *)
|
||||
HeapInitHeap();
|
||||
END Init;
|
||||
|
||||
|
||||
|
||||
|
||||
(* Program arguments and environment access *)
|
||||
|
||||
PROCEDURE -getenv(var: ARRAY OF CHAR): EnvPtr "(Platform_EnvPtr)getenv((char*)var)";
|
||||
|
||||
PROCEDURE getEnv*(var: ARRAY OF CHAR; VAR val: ARRAY OF CHAR): BOOLEAN;
|
||||
VAR p: EnvPtr;
|
||||
BEGIN
|
||||
p := getenv(var);
|
||||
IF p # NIL THEN COPY(p^, val) END;
|
||||
RETURN p # NIL;
|
||||
END getEnv;
|
||||
|
||||
PROCEDURE GetEnv*(var: ARRAY OF CHAR; VAR val: ARRAY OF CHAR);
|
||||
BEGIN
|
||||
IF ~ getEnv(var, val) THEN val[0] := 0X END;
|
||||
END GetEnv;
|
||||
|
||||
PROCEDURE GetArg*(n: INTEGER; VAR val: ARRAY OF CHAR);
|
||||
VAR av: ArgVec;
|
||||
BEGIN
|
||||
IF n < ArgCount THEN
|
||||
av := SYSTEM.VAL(ArgVec,ArgVector);
|
||||
COPY(av[n]^, val)
|
||||
END
|
||||
END GetArg;
|
||||
|
||||
PROCEDURE GetIntArg*(n: INTEGER; VAR val: LONGINT);
|
||||
VAR s: ARRAY 64 OF CHAR; k, d, i: LONGINT;
|
||||
BEGIN
|
||||
s := ""; GetArg(n, s); i := 0;
|
||||
IF s[0] = "-" THEN i := 1 END ;
|
||||
k := 0; d := ORD(s[i]) - ORD("0");
|
||||
WHILE (d >= 0 ) & (d <= 9) DO k := k*10 + d; INC(i); d := ORD(s[i]) - ORD("0") END ;
|
||||
IF s[0] = "-" THEN k := -k; DEC(i) END ;
|
||||
IF i > 0 THEN val := k END
|
||||
END GetIntArg;
|
||||
|
||||
PROCEDURE ArgPos*(s: ARRAY OF CHAR): INTEGER;
|
||||
VAR i: INTEGER; arg: ARRAY 256 OF CHAR;
|
||||
BEGIN
|
||||
i := 0; GetArg(i, arg);
|
||||
WHILE (i < ArgCount) & (s # arg) DO INC(i); GetArg(i, arg) END ;
|
||||
RETURN i
|
||||
END ArgPos;
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(* Signals and traps *)
|
||||
|
||||
PROCEDURE -sethandler(s: INTEGER; h: SignalHandler) "SystemSetHandler(s, (address)h)";
|
||||
|
||||
PROCEDURE SetInterruptHandler*(handler: SignalHandler);
|
||||
BEGIN sethandler(2, handler); END SetInterruptHandler;
|
||||
|
||||
PROCEDURE SetQuitHandler*(handler: SignalHandler);
|
||||
BEGIN sethandler(3, handler); END SetQuitHandler;
|
||||
|
||||
PROCEDURE SetBadInstructionHandler*(handler: SignalHandler);
|
||||
BEGIN sethandler(4, handler); END SetBadInstructionHandler;
|
||||
|
||||
|
||||
|
||||
|
||||
(* Time of day *)
|
||||
|
||||
PROCEDURE -gettimeval "struct timeval tv; gettimeofday(&tv,0)";
|
||||
PROCEDURE -tvsec(): LONGINT "tv.tv_sec";
|
||||
PROCEDURE -tvusec(): LONGINT "tv.tv_usec";
|
||||
PROCEDURE -sectotm(s: LONGINT) "struct tm *time = localtime((time_t*)&s)";
|
||||
PROCEDURE -tmsec(): LONGINT "(LONGINT)time->tm_sec";
|
||||
PROCEDURE -tmmin(): LONGINT "(LONGINT)time->tm_min";
|
||||
PROCEDURE -tmhour(): LONGINT "(LONGINT)time->tm_hour";
|
||||
PROCEDURE -tmmday(): LONGINT "(LONGINT)time->tm_mday";
|
||||
PROCEDURE -tmmon(): LONGINT "(LONGINT)time->tm_mon";
|
||||
PROCEDURE -tmyear(): LONGINT "(LONGINT)time->tm_year";
|
||||
|
||||
PROCEDURE YMDHMStoClock(ye,mo,da,ho,mi,se: LONGINT; VAR t, d: LONGINT);
|
||||
BEGIN
|
||||
d := ASH(ye MOD 100, 9) + ASH(mo+1, 5) + da;
|
||||
t := ASH(ho, 12) + ASH(mi, 6) + se;
|
||||
END YMDHMStoClock;
|
||||
|
||||
PROCEDURE GetClock*(VAR t, d: LONGINT);
|
||||
BEGIN
|
||||
gettimeval; sectotm(tvsec());
|
||||
YMDHMStoClock(tmyear(), tmmon(), tmmday(), tmhour(), tmmin(), tmsec(), t, d);
|
||||
END GetClock;
|
||||
|
||||
PROCEDURE GetTimeOfDay*(VAR sec, usec: LONGINT);
|
||||
BEGIN
|
||||
gettimeval; sec := tvsec(); usec := tvusec();
|
||||
END GetTimeOfDay;
|
||||
|
||||
PROCEDURE Time*(): LONGINT;
|
||||
VAR ms: LONGINT;
|
||||
BEGIN
|
||||
gettimeval;
|
||||
ms := (tvusec() DIV 1000) + (tvsec() * 1000);
|
||||
RETURN (ms - TimeStart) MOD 7FFFFFFFH;
|
||||
END Time;
|
||||
|
||||
|
||||
PROCEDURE -nanosleep(s: LONGINT; ns: LONGINT) "struct timespec req, rem; req.tv_sec = s; req.tv_nsec = ns; nanosleep(&req, &rem)";
|
||||
|
||||
PROCEDURE Delay*(ms: LONGINT);
|
||||
VAR s, ns: LONGINT;
|
||||
BEGIN
|
||||
s := ms DIV 1000;
|
||||
ns := (ms MOD 1000) * 1000000;
|
||||
nanosleep(s, ns);
|
||||
END Delay;
|
||||
|
||||
|
||||
|
||||
|
||||
(* System call *)
|
||||
|
||||
PROCEDURE -system(str: ARRAY OF CHAR): INTEGER "system((char*)str)";
|
||||
PROCEDURE -err(): INTEGER "errno";
|
||||
|
||||
|
||||
PROCEDURE System*(cmd : ARRAY OF CHAR): INTEGER;
|
||||
BEGIN RETURN system(cmd); END System;
|
||||
|
||||
PROCEDURE Error*(): ErrorCode; BEGIN RETURN err() END Error;
|
||||
|
||||
|
||||
|
||||
|
||||
(* File system *)
|
||||
|
||||
(* Note: Consider also using flags O_SYNC and O_DIRECT as we do buffering *)
|
||||
PROCEDURE -openrw (n: ARRAY OF CHAR): INTEGER "open((char*)n, O_RDWR)";
|
||||
PROCEDURE -openro (n: ARRAY OF CHAR): INTEGER "open((char*)n, O_RDONLY)";
|
||||
PROCEDURE -opennew(n: ARRAY OF CHAR): INTEGER "open((char*)n, O_CREAT | O_TRUNC | O_RDWR, 0664)";
|
||||
|
||||
(* File APIs *)
|
||||
|
||||
PROCEDURE OldRO*(VAR n: ARRAY OF CHAR; VAR h: FileHandle): ErrorCode;
|
||||
VAR fd: INTEGER;
|
||||
BEGIN
|
||||
fd := openro(n);
|
||||
IF (fd < 0) THEN RETURN err() ELSE h := fd; RETURN 0 END;
|
||||
END OldRO;
|
||||
|
||||
PROCEDURE OldRW*(VAR n: ARRAY OF CHAR; VAR h: FileHandle): ErrorCode;
|
||||
VAR fd: INTEGER;
|
||||
BEGIN
|
||||
fd := openrw(n);
|
||||
IF (fd < 0) THEN RETURN err() ELSE h := fd; RETURN 0 END;
|
||||
END OldRW;
|
||||
|
||||
PROCEDURE New*(VAR n: ARRAY OF CHAR; VAR h: FileHandle): ErrorCode;
|
||||
VAR fd: INTEGER;
|
||||
BEGIN
|
||||
fd := opennew(n);
|
||||
IF (fd < 0) THEN RETURN err() ELSE h := fd; RETURN 0 END;
|
||||
END New;
|
||||
|
||||
|
||||
|
||||
PROCEDURE -closefile (fd: LONGINT): INTEGER "close(fd)";
|
||||
|
||||
PROCEDURE Close*(h: FileHandle): ErrorCode;
|
||||
BEGIN
|
||||
IF closefile(h) < 0 THEN RETURN err() ELSE RETURN 0 END
|
||||
END Close;
|
||||
|
||||
|
||||
|
||||
PROCEDURE -fstat(fd: LONGINT): INTEGER "fstat(fd, &s)";
|
||||
PROCEDURE -stat(n: ARRAY OF CHAR): INTEGER "stat((char*)n, &s)";
|
||||
PROCEDURE -structstats "struct stat s";
|
||||
PROCEDURE -statdev(): LONGINT "(LONGINT)s.st_dev";
|
||||
PROCEDURE -statino(): LONGINT "(LONGINT)s.st_ino";
|
||||
PROCEDURE -statmtime(): LONGINT "(LONGINT)s.st_mtime";
|
||||
PROCEDURE -statsize(): LONGINT "(address)s.st_size";
|
||||
|
||||
PROCEDURE Identify*(h: FileHandle; VAR identity: FileIdentity): ErrorCode;
|
||||
BEGIN
|
||||
structstats;
|
||||
IF fstat(h) < 0 THEN RETURN err() END;
|
||||
identity.volume := statdev();
|
||||
identity.index := statino();
|
||||
identity.mtime := statmtime();
|
||||
RETURN 0
|
||||
END Identify;
|
||||
|
||||
PROCEDURE IdentifyByName*(n: ARRAY OF CHAR; VAR identity: FileIdentity): ErrorCode;
|
||||
BEGIN
|
||||
structstats;
|
||||
IF stat(n) < 0 THEN RETURN err() END;
|
||||
identity.volume := statdev();
|
||||
identity.index := statino();
|
||||
identity.mtime := statmtime();
|
||||
RETURN 0
|
||||
END IdentifyByName;
|
||||
|
||||
|
||||
PROCEDURE SameFile*(i1, i2: FileIdentity): BOOLEAN;
|
||||
BEGIN RETURN (i1.index = i2.index) & (i1.volume = i2.volume)
|
||||
END SameFile;
|
||||
|
||||
PROCEDURE SameFileTime*(i1, i2: FileIdentity): BOOLEAN;
|
||||
BEGIN RETURN i1.mtime = i2.mtime
|
||||
END SameFileTime;
|
||||
|
||||
PROCEDURE SetMTime*(VAR target: FileIdentity; source: FileIdentity);
|
||||
BEGIN target.mtime := source.mtime;
|
||||
END SetMTime;
|
||||
|
||||
PROCEDURE MTimeAsClock*(i: FileIdentity; VAR t, d: LONGINT);
|
||||
BEGIN
|
||||
sectotm(i.mtime);
|
||||
YMDHMStoClock(tmyear(), tmmon(), tmmday(), tmhour(), tmmin(), tmsec(), t, d);
|
||||
END MTimeAsClock;
|
||||
|
||||
|
||||
PROCEDURE Size*(h: FileHandle; VAR l: LONGINT): ErrorCode;
|
||||
BEGIN
|
||||
structstats;
|
||||
IF fstat(h) < 0 THEN RETURN err() END;
|
||||
l := statsize();
|
||||
RETURN 0;
|
||||
END Size;
|
||||
|
||||
|
||||
|
||||
PROCEDURE -readfile (fd: LONGINT; p: SYSTEM.ADDRESS; l: LONGINT): LONGINT
|
||||
"(LONGINT)read(fd, (void*)(address)(p), l)";
|
||||
|
||||
PROCEDURE Read*(h: FileHandle; p: SYSTEM.ADDRESS; l: LONGINT; VAR n: LONGINT): ErrorCode;
|
||||
BEGIN
|
||||
n := readfile(h, p, l);
|
||||
IF n < 0 THEN n := 0; RETURN err() ELSE RETURN 0 END
|
||||
END Read;
|
||||
|
||||
PROCEDURE ReadBuf*(h: FileHandle; VAR b: ARRAY OF SYSTEM.BYTE; VAR n: LONGINT): ErrorCode;
|
||||
BEGIN
|
||||
n := readfile(h, SYSTEM.ADR(b), LEN(b));
|
||||
IF n < 0 THEN n := 0; RETURN err() ELSE RETURN 0 END
|
||||
END ReadBuf;
|
||||
|
||||
|
||||
|
||||
PROCEDURE -writefile(fd: LONGINT; p: SYSTEM.ADDRESS; l: SYSTEM.ADDRESS): SYSTEM.ADDRESS
|
||||
"write(fd, (void*)(address)(p), l)";
|
||||
|
||||
PROCEDURE Write*(h: FileHandle; p: SYSTEM.ADDRESS; l: LONGINT): ErrorCode;
|
||||
VAR written: SYSTEM.ADDRESS;
|
||||
BEGIN
|
||||
written := writefile(h, p, l);
|
||||
IF written < 0 THEN RETURN err() ELSE RETURN 0 END
|
||||
END Write;
|
||||
|
||||
|
||||
|
||||
PROCEDURE -fsync(fd: LONGINT): INTEGER "fsync(fd)";
|
||||
|
||||
PROCEDURE Sync*(h: FileHandle): ErrorCode;
|
||||
BEGIN
|
||||
IF fsync(h) < 0 THEN RETURN err() ELSE RETURN 0 END
|
||||
END Sync;
|
||||
|
||||
|
||||
|
||||
PROCEDURE -lseek(fd: LONGINT; o: LONGINT; w: INTEGER): INTEGER "lseek(fd, o, w)";
|
||||
PROCEDURE -seekset(): INTEGER "SEEK_SET";
|
||||
PROCEDURE -seekcur(): INTEGER "SEEK_CUR";
|
||||
PROCEDURE -seekend(): INTEGER "SEEK_END";
|
||||
|
||||
PROCEDURE Seek*(h: FileHandle; offset: LONGINT; whence: INTEGER): ErrorCode;
|
||||
BEGIN
|
||||
IF lseek(h, offset, whence) < 0 THEN RETURN err() ELSE RETURN 0 END
|
||||
END Seek;
|
||||
|
||||
|
||||
|
||||
PROCEDURE -ftruncate(fd: LONGINT; l: LONGINT): INTEGER "ftruncate(fd, l)";
|
||||
|
||||
PROCEDURE Truncate*(h: FileHandle; l: LONGINT): ErrorCode;
|
||||
BEGIN
|
||||
IF (ftruncate(h, l) < 0) THEN RETURN err() ELSE RETURN 0 END;
|
||||
END Truncate;
|
||||
|
||||
|
||||
|
||||
PROCEDURE -unlink(n: ARRAY OF CHAR): INTEGER "unlink((char*)n)";
|
||||
|
||||
PROCEDURE Unlink*(VAR n: ARRAY OF CHAR): ErrorCode;
|
||||
BEGIN
|
||||
IF unlink(n) < 0 THEN RETURN err() ELSE RETURN 0 END
|
||||
END Unlink;
|
||||
|
||||
|
||||
|
||||
PROCEDURE -chdir(n: ARRAY OF CHAR): INTEGER "chdir((char*)n)";
|
||||
PROCEDURE -getcwd(VAR cwd: ARRAY OF CHAR): SYSTEM.PTR "getcwd((char*)cwd, cwd__len)";
|
||||
|
||||
PROCEDURE Chdir*(VAR n: ARRAY OF CHAR): ErrorCode;
|
||||
VAR r: INTEGER;
|
||||
BEGIN
|
||||
IF (chdir(n) >= 0) & (getcwd(CWD) # NIL) THEN RETURN 0
|
||||
ELSE RETURN err() END
|
||||
END Chdir;
|
||||
|
||||
|
||||
|
||||
PROCEDURE -rename(o,n: ARRAY OF CHAR): INTEGER "rename((char*)o, (char*)n)";
|
||||
|
||||
PROCEDURE Rename*(VAR o,n: ARRAY OF CHAR): ErrorCode;
|
||||
BEGIN
|
||||
IF rename(o,n) < 0 THEN RETURN err() ELSE RETURN 0 END
|
||||
END Rename;
|
||||
|
||||
|
||||
|
||||
|
||||
(* Process termination *)
|
||||
|
||||
PROCEDURE -exit(code: INTEGER) "exit(code)";
|
||||
PROCEDURE Exit*(code: INTEGER);
|
||||
BEGIN exit(code) END Exit;
|
||||
|
||||
PROCEDURE -errstring(s: ARRAY OF CHAR) 'write(1, s, s__len-1)';
|
||||
PROCEDURE -errc (c: CHAR) 'write(1, &c, 1)';
|
||||
PROCEDURE errch(c: CHAR); BEGIN errc(c) END errch;
|
||||
PROCEDURE errln; BEGIN errch(0AX) END errln;
|
||||
|
||||
PROCEDURE errposint(l: LONGINT);
|
||||
BEGIN IF l>10 THEN errposint(l DIV 10) END; errch(CHR(ORD('0') + (l MOD 10))) END errposint;
|
||||
|
||||
PROCEDURE errint(l: LONGINT);
|
||||
BEGIN IF l<0 THEN errch('-'); l := -l END; errposint(l) END errint;
|
||||
|
||||
PROCEDURE DisplayHaltCode(code: LONGINT);
|
||||
BEGIN
|
||||
CASE code OF
|
||||
| -1: errstring("Assertion failure.")
|
||||
| -2: errstring("Index out of range.")
|
||||
| -3: errstring("Reached end of function without reaching RETURN.")
|
||||
| -4: errstring("CASE statement: no matching label and no ELSE.")
|
||||
| -5: errstring("Type guard failed.")
|
||||
| -6: errstring("Implicit type guard in record assignment failed.")
|
||||
| -7: errstring("Invalid case in WITH statement.")
|
||||
| -8: errstring("Value out of range.")
|
||||
| -9: errstring("Heap interrupted while locked, but lockdepth = 0 at unlock.")
|
||||
|-10: errstring("NIL access.");
|
||||
|-11: errstring("Alignment error.");
|
||||
|-12: errstring("Divide by zero.");
|
||||
|-13: errstring("Arithmetic overflow/underflow.");
|
||||
|-14: errstring("Invalid function argument.");
|
||||
|-15: errstring("Internal error, e.g. Type descriptor size mismatch.")
|
||||
|-20: errstring("Too many, or negative number of, elements in dynamic array.")
|
||||
ELSE
|
||||
END
|
||||
END DisplayHaltCode;
|
||||
|
||||
PROCEDURE Halt*(code: LONGINT);
|
||||
BEGIN
|
||||
HaltCode := code;
|
||||
IF HaltHandler # NIL THEN HaltHandler(code) END;
|
||||
errstring("Terminated by Halt("); errint(code); errstring("). ");
|
||||
IF code < 0 THEN DisplayHaltCode(code) END;
|
||||
errln;
|
||||
exit(SYSTEM.VAL(INTEGER,code));
|
||||
END Halt;
|
||||
|
||||
PROCEDURE AssertFail*(code: LONGINT);
|
||||
BEGIN
|
||||
errstring("Assertion failure.");
|
||||
IF code # 0 THEN errstring(" ASSERT code "); errint(code); errstring("."); END;
|
||||
errln;
|
||||
exit(SYSTEM.VAL(INTEGER,code));
|
||||
END AssertFail;
|
||||
|
||||
PROCEDURE SetHalt*(p: HaltProcedure);
|
||||
BEGIN HaltHandler := p; END SetHalt;
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
PROCEDURE TestLittleEndian;
|
||||
VAR i: INTEGER;
|
||||
BEGIN i := 1; SYSTEM.GET(SYSTEM.ADR(i), LittleEndian); END TestLittleEndian;
|
||||
|
||||
|
||||
PROCEDURE -getpid(): INTEGER "(INTEGER)getpid()";
|
||||
|
||||
BEGIN
|
||||
TestLittleEndian;
|
||||
|
||||
HaltCode := -128;
|
||||
HaltHandler := NIL;
|
||||
TimeStart := 0; TimeStart := Time();
|
||||
PID := getpid();
|
||||
IF getcwd(CWD) = NIL THEN CWD := "" END;
|
||||
|
||||
SeekSet := seekset();
|
||||
SeekCur := seekcur();
|
||||
SeekEnd := seekend();
|
||||
|
||||
NL[0] := 0AX; (* LF *)
|
||||
NL[1] := 0X;
|
||||
END Platform.
|
||||
|
|
@ -1,622 +0,0 @@
|
|||
MODULE Platform;
|
||||
IMPORT SYSTEM;
|
||||
|
||||
(* TODO:
|
||||
Use Unicode APIs with manual UTF8 conversion and prepend '\\?\' to
|
||||
file paths in order to get 32768 character path length limit (as
|
||||
opposed to 256 bytes. *)
|
||||
|
||||
|
||||
TYPE
|
||||
HaltProcedure = PROCEDURE(n: LONGINT);
|
||||
SignalHandler = PROCEDURE(signal: INTEGER);
|
||||
|
||||
ErrorCode* = INTEGER;
|
||||
FileHandle* = LONGINT;
|
||||
|
||||
FileIdentity* = RECORD
|
||||
volume: LONGINT; (* dev on Unix filesystems, volume serial number on NTFS *)
|
||||
indexhigh: LONGINT; (* inode on Unix filesystems, file id on NTFS *)
|
||||
indexlow: LONGINT;
|
||||
mtimehigh: LONGINT; (* File modification time, value is system dependent *)
|
||||
mtimelow: LONGINT; (* File modification time, value is system dependent *)
|
||||
END;
|
||||
|
||||
EnvPtr = POINTER TO ARRAY 1024 OF CHAR;
|
||||
ArgPtr = POINTER TO ARRAY 1024 OF CHAR;
|
||||
ArgVec = POINTER TO ARRAY 1024 OF ArgPtr;
|
||||
ArgVecPtr = POINTER TO ARRAY 1 OF SYSTEM.ADDRESS;
|
||||
|
||||
|
||||
VAR
|
||||
LittleEndian-: BOOLEAN;
|
||||
MainStackFrame-: SYSTEM.ADDRESS;
|
||||
HaltCode-: LONGINT;
|
||||
PID-: INTEGER; (* Note: Must be updated by Fork implementation *)
|
||||
CWD-: ARRAY 4096 OF CHAR;
|
||||
ArgCount-: INTEGER;
|
||||
|
||||
ArgVector-: SYSTEM.ADDRESS;
|
||||
HaltHandler: HaltProcedure;
|
||||
TimeStart: LONGINT;
|
||||
|
||||
SeekSet-: INTEGER;
|
||||
SeekCur-: INTEGER;
|
||||
SeekEnd-: INTEGER;
|
||||
|
||||
StdIn-: FileHandle;
|
||||
StdOut-: FileHandle;
|
||||
StdErr-: FileHandle;
|
||||
|
||||
InterruptHandler: SignalHandler;
|
||||
|
||||
nl-: ARRAY 3 OF CHAR; (* Platform specific newline representation *)
|
||||
|
||||
|
||||
|
||||
PROCEDURE -AincludeWindowsWrapper '#include "WindowsWrapper.h"';
|
||||
|
||||
|
||||
(* Error code tests *)
|
||||
|
||||
PROCEDURE -ERRORTOOMANYOPENFILES(): ErrorCode 'ERROR_TOO_MANY_OPEN_FILES';
|
||||
PROCEDURE -ERRORPATHNOTFOUND(): ErrorCode 'ERROR_PATH_NOT_FOUND';
|
||||
PROCEDURE -ERRORFILENOTFOUND(): ErrorCode 'ERROR_FILE_NOT_FOUND';
|
||||
PROCEDURE -ERRORNOTSAMEDEVICE(): ErrorCode 'ERROR_NOT_SAME_DEVICE';
|
||||
PROCEDURE -ERRORACCESSDENIED(): ErrorCode 'ERROR_ACCESS_DENIED';
|
||||
PROCEDURE -ERRORWRITEPROTECT(): ErrorCode 'ERROR_WRITE_PROTECT';
|
||||
PROCEDURE -ERRORSHARINGVIOLATION(): ErrorCode 'ERROR_SHARING_VIOLATION';
|
||||
PROCEDURE -ERRORNOTREADY(): ErrorCode 'ERROR_NOT_READY';
|
||||
PROCEDURE -ETIMEDOUT(): ErrorCode 'WSAETIMEDOUT';
|
||||
PROCEDURE -ECONNREFUSED(): ErrorCode 'WSAECONNREFUSED';
|
||||
PROCEDURE -ECONNABORTED(): ErrorCode 'WSAECONNABORTED';
|
||||
PROCEDURE -ENETUNREACH(): ErrorCode 'WSAENETUNREACH';
|
||||
PROCEDURE -EHOSTUNREACH(): ErrorCode 'WSAEHOSTUNREACH';
|
||||
PROCEDURE -EINTR(): ErrorCode 'WSAEINTR';
|
||||
|
||||
|
||||
|
||||
PROCEDURE TooManyFiles*(e: ErrorCode): BOOLEAN;
|
||||
BEGIN RETURN e = ERRORTOOMANYOPENFILES() END TooManyFiles;
|
||||
|
||||
PROCEDURE NoSuchDirectory*(e: ErrorCode): BOOLEAN;
|
||||
BEGIN RETURN e = ERRORPATHNOTFOUND() END NoSuchDirectory;
|
||||
|
||||
PROCEDURE DifferentFilesystems*(e: ErrorCode): BOOLEAN;
|
||||
BEGIN RETURN e = ERRORNOTSAMEDEVICE() END DifferentFilesystems;
|
||||
|
||||
PROCEDURE Inaccessible*(e: ErrorCode): BOOLEAN;
|
||||
BEGIN
|
||||
RETURN (e = ERRORACCESSDENIED()) OR (e = ERRORWRITEPROTECT())
|
||||
OR (e = ERRORNOTREADY()) OR (e = ERRORSHARINGVIOLATION());
|
||||
END Inaccessible;
|
||||
|
||||
PROCEDURE Absent*(e: ErrorCode): BOOLEAN;
|
||||
BEGIN RETURN (e = ERRORFILENOTFOUND()) OR (e = ERRORPATHNOTFOUND()) END Absent;
|
||||
|
||||
PROCEDURE TimedOut*(e: ErrorCode): BOOLEAN;
|
||||
BEGIN RETURN (e = ETIMEDOUT()) END TimedOut;
|
||||
|
||||
PROCEDURE ConnectionFailed*(e: ErrorCode): BOOLEAN;
|
||||
BEGIN RETURN (e = ECONNREFUSED()) OR (e = ECONNABORTED())
|
||||
OR (e = ENETUNREACH()) OR (e = EHOSTUNREACH()) END ConnectionFailed;
|
||||
|
||||
PROCEDURE Interrupted*(e: ErrorCode): BOOLEAN;
|
||||
BEGIN RETURN e = EINTR() END Interrupted;
|
||||
|
||||
|
||||
|
||||
(* OS memory allocaton *)
|
||||
|
||||
PROCEDURE -allocate(size: SYSTEM.ADDRESS): SYSTEM.ADDRESS "(address)((void*)HeapAlloc(GetProcessHeap(), 0, (size_t)size))";
|
||||
PROCEDURE OSAllocate*(size: SYSTEM.ADDRESS): SYSTEM.ADDRESS; BEGIN RETURN allocate(size) END OSAllocate;
|
||||
|
||||
PROCEDURE -free(address: SYSTEM.ADDRESS) "HeapFree(GetProcessHeap(), 0, (void*)address)";
|
||||
PROCEDURE OSFree*(address: SYSTEM.ADDRESS); BEGIN free(address) END OSFree;
|
||||
|
||||
|
||||
|
||||
|
||||
(* Program startup *)
|
||||
|
||||
PROCEDURE -ExternInitHeap "extern void Heap_InitHeap();";
|
||||
PROCEDURE -HeapInitHeap() "Heap_InitHeap()";
|
||||
|
||||
PROCEDURE Init*(argc: INTEGER; argvadr: SYSTEM.ADDRESS);
|
||||
VAR av: ArgVecPtr;
|
||||
BEGIN
|
||||
MainStackFrame := argvadr;
|
||||
ArgCount := argc;
|
||||
av := SYSTEM.VAL(ArgVecPtr, argvadr);
|
||||
ArgVector := av[0];
|
||||
HaltCode := -128;
|
||||
|
||||
(* This function (Platform.Init) is called at program startup BEFORE any
|
||||
modules have been initalised. In turn we must initialise the heap
|
||||
before module startup (xxx__init) code is run. *)
|
||||
HeapInitHeap();
|
||||
END Init;
|
||||
|
||||
|
||||
|
||||
|
||||
(* Program arguments and environmet access *)
|
||||
|
||||
PROCEDURE -getenv(name: ARRAY OF CHAR; VAR buf: ARRAY OF CHAR): INTEGER
|
||||
"(INTEGER)GetEnvironmentVariable((char*)name, (char*)buf, buf__len)";
|
||||
|
||||
PROCEDURE getEnv*(var: ARRAY OF CHAR; VAR val: ARRAY OF CHAR): BOOLEAN;
|
||||
VAR
|
||||
buf: ARRAY 4096 OF CHAR;
|
||||
res: INTEGER;
|
||||
BEGIN
|
||||
res := getenv(var, buf);
|
||||
IF (res > 0) & (res < LEN(buf)) THEN
|
||||
COPY(buf, val);
|
||||
RETURN TRUE;
|
||||
ELSE
|
||||
RETURN FALSE;
|
||||
END;
|
||||
END getEnv;
|
||||
|
||||
PROCEDURE GetEnv*(var: ARRAY OF CHAR; VAR val: ARRAY OF CHAR);
|
||||
BEGIN
|
||||
IF ~getEnv(var, val) THEN val[0] := 0X END;
|
||||
END GetEnv;
|
||||
|
||||
PROCEDURE GetArg*(n: INTEGER; VAR val: ARRAY OF CHAR);
|
||||
VAR av: ArgVec;
|
||||
BEGIN
|
||||
IF n < ArgCount THEN
|
||||
av := SYSTEM.VAL(ArgVec,ArgVector);
|
||||
COPY(av[n]^, val)
|
||||
END
|
||||
END GetArg;
|
||||
|
||||
PROCEDURE GetIntArg*(n: INTEGER; VAR val: LONGINT);
|
||||
VAR s: ARRAY 64 OF CHAR; k, d, i: LONGINT;
|
||||
BEGIN
|
||||
s := ""; GetArg(n, s); i := 0;
|
||||
IF s[0] = "-" THEN i := 1 END ;
|
||||
k := 0; d := ORD(s[i]) - ORD("0");
|
||||
WHILE (d >= 0 ) & (d <= 9) DO k := k*10 + d; INC(i); d := ORD(s[i]) - ORD("0") END ;
|
||||
IF s[0] = "-" THEN k := -k; DEC(i) END ;
|
||||
IF i > 0 THEN val := k END
|
||||
END GetIntArg;
|
||||
|
||||
PROCEDURE ArgPos*(s: ARRAY OF CHAR): INTEGER;
|
||||
VAR i: INTEGER; arg: ARRAY 256 OF CHAR;
|
||||
BEGIN
|
||||
i := 0; GetArg(i, arg);
|
||||
WHILE (i < ArgCount) & (s # arg) DO INC(i); GetArg(i, arg) END ;
|
||||
RETURN i
|
||||
END ArgPos;
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(* Signals and traps *)
|
||||
|
||||
(* PROCEDURE -signal(sig: LONGINT; func: SignalHandler) "signal(sig, func)"; *)
|
||||
|
||||
(* TODO *)
|
||||
|
||||
(* Ctrl/c handling *)
|
||||
|
||||
PROCEDURE -SetInterruptHandler*(h: SignalHandler) "SystemSetInterruptHandler((address)h)";
|
||||
PROCEDURE -SetQuitHandler* (h: SignalHandler) "SystemSetQuitHandler((address)h)";
|
||||
|
||||
PROCEDURE SetBadInstructionHandler*(handler: SignalHandler);
|
||||
BEGIN (* TODO *) END SetBadInstructionHandler;
|
||||
|
||||
|
||||
|
||||
|
||||
(* Time of day *)
|
||||
|
||||
PROCEDURE -getLocalTime "SYSTEMTIME st; GetLocalTime(&st)";
|
||||
PROCEDURE -stmsec(): INTEGER "(INTEGER)st.wMilliseconds";
|
||||
PROCEDURE -stsec(): INTEGER "(INTEGER)st.wSecond";
|
||||
PROCEDURE -stmin(): INTEGER "(INTEGER)st.wMinute";
|
||||
PROCEDURE -sthour(): INTEGER "(INTEGER)st.wHour";
|
||||
PROCEDURE -stmday(): INTEGER "(INTEGER)st.wDay";
|
||||
PROCEDURE -stmon(): INTEGER "(INTEGER)st.wMonth";
|
||||
PROCEDURE -styear(): INTEGER "(INTEGER)st.wYear";
|
||||
|
||||
PROCEDURE YMDHMStoClock(ye,mo,da,ho,mi,se: INTEGER; VAR t, d: LONGINT);
|
||||
BEGIN
|
||||
d := ASH(ye MOD 100, 9) + ASH(mo+1, 5) + da;
|
||||
t := ASH(ho, 12) + ASH(mi, 6) + se;
|
||||
END YMDHMStoClock;
|
||||
|
||||
PROCEDURE GetClock*(VAR t, d: LONGINT);
|
||||
BEGIN
|
||||
getLocalTime;
|
||||
YMDHMStoClock(styear(), stmon(), stmday(), sthour(), stmin(), stsec(), t, d);
|
||||
END GetClock;
|
||||
|
||||
PROCEDURE -GetTickCount(): LONGINT "(LONGINT)(uint32)GetTickCount()";
|
||||
|
||||
PROCEDURE Time*(): LONGINT;
|
||||
VAR ms: LONGINT;
|
||||
BEGIN
|
||||
ms := GetTickCount();
|
||||
RETURN (ms - TimeStart) MOD 7FFFFFFFH;
|
||||
END Time;
|
||||
|
||||
|
||||
PROCEDURE -sleep(ms: LONGINT) "Sleep((DWORD)ms)";
|
||||
|
||||
PROCEDURE Delay*(ms: LONGINT);
|
||||
BEGIN
|
||||
WHILE ms > 30000 DO sleep(30000); ms := ms-30000 END;
|
||||
IF ms > 0 THEN sleep(ms) END;
|
||||
END Delay;
|
||||
|
||||
|
||||
PROCEDURE -stToFt "FILETIME ft; SystemTimeToFileTime(&st, &ft)";
|
||||
PROCEDURE -ftToUli "ULARGE_INTEGER ul; ul.LowPart=ft.dwLowDateTime; ul.HighPart=ft.dwHighDateTime";
|
||||
PROCEDURE -tous1970 "ul.QuadPart = (ul.QuadPart - 116444736000000000ULL)/10LL";
|
||||
PROCEDURE -ulSec(): LONGINT "(LONGINT)(ul.QuadPart / 1000000LL)";
|
||||
PROCEDURE -uluSec(): LONGINT "(LONGINT)(ul.QuadPart % 1000000LL)";
|
||||
|
||||
PROCEDURE GetTimeOfDay*(VAR sec, usec: LONGINT);
|
||||
BEGIN
|
||||
getLocalTime; stToFt; ftToUli; tous1970;
|
||||
sec := ulSec(); usec := uluSec();
|
||||
END GetTimeOfDay;
|
||||
|
||||
|
||||
|
||||
(* System call *)
|
||||
|
||||
PROCEDURE -startupInfo "STARTUPINFO si = {0}; si.cb = sizeof(si);";
|
||||
PROCEDURE -processInfo "PROCESS_INFORMATION pi = {0};";
|
||||
PROCEDURE -createProcess(str: ARRAY OF CHAR): INTEGER "(INTEGER)CreateProcess(0, (char*)str, 0,0,0,0,0,0,&si,&pi)";
|
||||
PROCEDURE -waitForProcess(): INTEGER "(INTEGER)WaitForSingleObject(pi.hProcess, INFINITE)";
|
||||
PROCEDURE -getExitCodeProcess(VAR exitcode: INTEGER) "GetExitCodeProcess(pi.hProcess, (DWORD*)exitcode);";
|
||||
PROCEDURE -cleanupProcess "CloseHandle(pi.hProcess); CloseHandle(pi.hThread);";
|
||||
PROCEDURE -err(): INTEGER "(INTEGER)GetLastError()";
|
||||
|
||||
PROCEDURE System*(cmd : ARRAY OF CHAR): INTEGER;
|
||||
VAR
|
||||
result: INTEGER;
|
||||
BEGIN
|
||||
result := 127;
|
||||
startupInfo; processInfo;
|
||||
IF createProcess(cmd) # 0 THEN
|
||||
IF waitForProcess() = 0 THEN getExitCodeProcess(result) END;
|
||||
cleanupProcess;
|
||||
END;
|
||||
RETURN result * 256;
|
||||
END System;
|
||||
|
||||
PROCEDURE Error*(): ErrorCode; BEGIN RETURN err() END Error;
|
||||
|
||||
|
||||
(* File system *)
|
||||
|
||||
PROCEDURE -invalidHandleValue(): LONGINT "((LONGINT)(address)INVALID_HANDLE_VALUE)";
|
||||
|
||||
PROCEDURE -openrw (n: ARRAY OF CHAR): LONGINT
|
||||
"(LONGINT)(address)CreateFile((char*)n, GENERIC_READ|GENERIC_WRITE, FILE_SHARE_READ|FILE_SHARE_WRITE, 0, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)";
|
||||
|
||||
PROCEDURE -openro (n: ARRAY OF CHAR): LONGINT
|
||||
"(LONGINT)(address)CreateFile((char*)n, GENERIC_READ , FILE_SHARE_READ|FILE_SHARE_WRITE, 0, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)";
|
||||
|
||||
PROCEDURE -opennew(n: ARRAY OF CHAR): LONGINT
|
||||
"(LONGINT)(address)CreateFile((char*)n, GENERIC_READ|GENERIC_WRITE, FILE_SHARE_READ|FILE_SHARE_WRITE, 0, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)";
|
||||
|
||||
|
||||
|
||||
|
||||
(* File APIs *)
|
||||
|
||||
PROCEDURE OldRO*(VAR n: ARRAY OF CHAR; VAR h: FileHandle): ErrorCode;
|
||||
VAR fd: LONGINT;
|
||||
BEGIN
|
||||
fd := openro(n);
|
||||
IF (fd = invalidHandleValue()) THEN RETURN err() ELSE h := fd; RETURN 0 END;
|
||||
END OldRO;
|
||||
|
||||
PROCEDURE OldRW*(VAR n: ARRAY OF CHAR; VAR h: FileHandle): ErrorCode;
|
||||
VAR fd: LONGINT;
|
||||
BEGIN
|
||||
fd := openrw(n);
|
||||
IF (fd = invalidHandleValue()) THEN RETURN err() ELSE h := fd; RETURN 0 END;
|
||||
END OldRW;
|
||||
|
||||
PROCEDURE New*(VAR n: ARRAY OF CHAR; VAR h: FileHandle): ErrorCode;
|
||||
VAR fd: LONGINT;
|
||||
BEGIN
|
||||
fd := opennew(n);
|
||||
IF (fd = invalidHandleValue()) THEN RETURN err() ELSE h := fd; RETURN 0 END;
|
||||
END New;
|
||||
|
||||
|
||||
|
||||
PROCEDURE -closeHandle(h: FileHandle): INTEGER "(INTEGER)CloseHandle((HANDLE)(address)h)";
|
||||
|
||||
PROCEDURE Close*(h: FileHandle): ErrorCode;
|
||||
BEGIN
|
||||
IF closeHandle(h) = 0 THEN RETURN err() ELSE RETURN 0 END
|
||||
END Close;
|
||||
|
||||
|
||||
|
||||
PROCEDURE -byHandleFileInformation "BY_HANDLE_FILE_INFORMATION bhfi";
|
||||
PROCEDURE -getFileInformationByHandle(h: FileHandle): INTEGER "(INTEGER)GetFileInformationByHandle((HANDLE)(address)h, &bhfi)";
|
||||
PROCEDURE -bhfiMtimeHigh(): LONGINT "(LONGINT)bhfi.ftLastWriteTime.dwHighDateTime";
|
||||
PROCEDURE -bhfiMtimeLow(): LONGINT "(LONGINT)bhfi.ftLastWriteTime.dwLowDateTime";
|
||||
PROCEDURE -bhfiVsn(): LONGINT "(LONGINT)bhfi.dwVolumeSerialNumber";
|
||||
PROCEDURE -bhfiIndexHigh(): LONGINT "(LONGINT)bhfi.nFileIndexHigh";
|
||||
PROCEDURE -bhfiIndexLow(): LONGINT "(LONGINT)bhfi.nFileIndexLow";
|
||||
|
||||
|
||||
PROCEDURE Identify*(h: FileHandle; VAR identity: FileIdentity): ErrorCode;
|
||||
BEGIN
|
||||
byHandleFileInformation;
|
||||
IF getFileInformationByHandle(h) = 0 THEN RETURN err() END;
|
||||
identity.volume := bhfiVsn();
|
||||
identity.indexhigh := bhfiIndexHigh();
|
||||
identity.indexlow := bhfiIndexLow();
|
||||
identity.mtimehigh := bhfiMtimeHigh();
|
||||
identity.mtimelow := bhfiMtimeLow();
|
||||
RETURN 0
|
||||
END Identify;
|
||||
|
||||
PROCEDURE IdentifyByName*(n: ARRAY OF CHAR; VAR identity: FileIdentity): ErrorCode;
|
||||
VAR
|
||||
h: FileHandle;
|
||||
e,i: ErrorCode;
|
||||
BEGIN
|
||||
e := OldRO(n, h);
|
||||
IF e # 0 THEN RETURN e END;
|
||||
e := Identify(h, identity);
|
||||
i := Close(h);
|
||||
RETURN e;
|
||||
END IdentifyByName;
|
||||
|
||||
|
||||
PROCEDURE SameFile*(i1, i2: FileIdentity): BOOLEAN;
|
||||
BEGIN RETURN (i1.indexhigh = i2.indexhigh) & (i1.indexlow = i2.indexlow) & (i1.volume = i2.volume)
|
||||
END SameFile;
|
||||
|
||||
PROCEDURE SameFileTime*(i1, i2: FileIdentity): BOOLEAN;
|
||||
BEGIN RETURN (i1.mtimehigh = i2.mtimehigh) & (i1.mtimelow = i2.mtimelow)
|
||||
END SameFileTime;
|
||||
|
||||
PROCEDURE SetMTime*(VAR target: FileIdentity; source: FileIdentity);
|
||||
BEGIN target.mtimehigh := source.mtimehigh; target.mtimelow := source.mtimelow;
|
||||
END SetMTime;
|
||||
|
||||
PROCEDURE -identityToFileTime(i: FileIdentity)
|
||||
"FILETIME ft; ft.dwHighDateTime = i.mtimehigh; ft.dwLowDateTime = i.mtimelow";
|
||||
|
||||
PROCEDURE -fileTimeToSysTime
|
||||
"SYSTEMTIME st; FileTimeToSystemTime(&ft, &st)";
|
||||
|
||||
PROCEDURE MTimeAsClock*(i: FileIdentity; VAR t, d: LONGINT);
|
||||
BEGIN
|
||||
identityToFileTime(i); fileTimeToSysTime;
|
||||
YMDHMStoClock(styear(), stmon(), stmday(), sthour(), stmin(), stsec(), t, d);
|
||||
END MTimeAsClock;
|
||||
|
||||
PROCEDURE -largeInteger "LARGE_INTEGER li";
|
||||
PROCEDURE -liLongint(): LONGINT "(LONGINT)li.QuadPart";
|
||||
PROCEDURE -getFileSize(h: FileHandle): INTEGER "(INTEGER)GetFileSizeEx((HANDLE)(address)h, &li)";
|
||||
|
||||
PROCEDURE Size*(h: FileHandle; VAR l: LONGINT): ErrorCode;
|
||||
BEGIN
|
||||
largeInteger;
|
||||
IF getFileSize(h) = 0 THEN RETURN err() END;
|
||||
l := liLongint();
|
||||
RETURN 0;
|
||||
END Size;
|
||||
|
||||
|
||||
PROCEDURE -readfile (fd: LONGINT; p: SYSTEM.ADDRESS; l: LONGINT; VAR n: SYSTEM.INT32): INTEGER
|
||||
"(INTEGER)ReadFile((HANDLE)fd, (void*)p, (DWORD)l, (DWORD*)n, 0)";
|
||||
|
||||
PROCEDURE Read*(h: FileHandle; p: SYSTEM.ADDRESS; l: LONGINT; VAR n: LONGINT): ErrorCode;
|
||||
VAR result: INTEGER; lengthread: SYSTEM.INT32;
|
||||
BEGIN
|
||||
result := readfile(h, p, l, lengthread);
|
||||
IF result = 0 THEN n := 0; RETURN err() ELSE n := lengthread; RETURN 0 END
|
||||
END Read;
|
||||
|
||||
PROCEDURE ReadBuf*(h: FileHandle; VAR b: ARRAY OF SYSTEM.BYTE; VAR n: LONGINT): ErrorCode;
|
||||
VAR result: INTEGER; lengthread: SYSTEM.INT32;
|
||||
BEGIN
|
||||
result := readfile(h, SYSTEM.ADR(b), LEN(b), lengthread);
|
||||
IF result = 0 THEN n := 0; RETURN err() ELSE n := lengthread; RETURN 0 END
|
||||
END ReadBuf;
|
||||
|
||||
|
||||
|
||||
PROCEDURE -writefile(fd: LONGINT; p: SYSTEM.ADDRESS; l: LONGINT): INTEGER
|
||||
"(INTEGER)WriteFile((HANDLE)fd, (void*)(p), (DWORD)l, 0,0)";
|
||||
|
||||
PROCEDURE Write*(h: FileHandle; p: SYSTEM.ADDRESS; l: LONGINT): ErrorCode;
|
||||
BEGIN
|
||||
IF writefile(h, p, l) = 0 THEN RETURN err() ELSE RETURN 0 END
|
||||
END Write;
|
||||
|
||||
|
||||
|
||||
PROCEDURE -flushFileBuffers(h: FileHandle): INTEGER "(INTEGER)FlushFileBuffers((HANDLE)h)";
|
||||
|
||||
PROCEDURE Sync*(h: FileHandle): ErrorCode;
|
||||
BEGIN
|
||||
IF flushFileBuffers(h) = 0 THEN RETURN err() ELSE RETURN 0 END
|
||||
END Sync;
|
||||
|
||||
|
||||
|
||||
PROCEDURE -setFilePointerEx(h: FileHandle; o: LONGINT; r: INTEGER; VAR rc: INTEGER)
|
||||
"li.QuadPart=o; *rc = (INTEGER)SetFilePointerEx((HANDLE)(address)h, li, 0, (DWORD)r)";
|
||||
|
||||
PROCEDURE -seekset(): INTEGER "FILE_BEGIN";
|
||||
PROCEDURE -seekcur(): INTEGER "FILE_CURRENT";
|
||||
PROCEDURE -seekend(): INTEGER "FILE_END";
|
||||
|
||||
PROCEDURE Seek*(h: FileHandle; o: LONGINT; r: INTEGER): ErrorCode;
|
||||
VAR rc: INTEGER;
|
||||
BEGIN
|
||||
largeInteger;
|
||||
setFilePointerEx(h, o, r, rc);
|
||||
IF rc = 0 THEN RETURN err() ELSE RETURN 0 END
|
||||
END Seek;
|
||||
|
||||
|
||||
|
||||
PROCEDURE -setEndOfFile(h: FileHandle): INTEGER "(INTEGER)SetEndOfFile((HANDLE)(address)h)";
|
||||
PROCEDURE -getFilePos(h: FileHandle; VAR r: LONGINT; VAR rc: INTEGER)
|
||||
"LARGE_INTEGER liz = {0}; *rc = (INTEGER)SetFilePointerEx((HANDLE)(address)h, liz, &li, FILE_CURRENT); *r = (LONGINT)li.QuadPart";
|
||||
|
||||
PROCEDURE Truncate*(h: FileHandle; limit: LONGINT): ErrorCode;
|
||||
VAR rc: INTEGER; oldpos: LONGINT;
|
||||
BEGIN
|
||||
largeInteger;
|
||||
getFilePos(h, oldpos, rc);
|
||||
IF rc = 0 THEN RETURN err() END;
|
||||
setFilePointerEx(h, limit, seekset(), rc);
|
||||
IF rc = 0 THEN RETURN err() END;
|
||||
IF setEndOfFile(h) = 0 THEN RETURN err() END;
|
||||
setFilePointerEx(h, oldpos, seekset(), rc); (* Restore original file position *)
|
||||
IF rc = 0 THEN RETURN err() END;
|
||||
RETURN 0;
|
||||
END Truncate;
|
||||
|
||||
|
||||
|
||||
PROCEDURE -deleteFile(n: ARRAY OF CHAR): INTEGER "(INTEGER)DeleteFile((char*)n)";
|
||||
|
||||
PROCEDURE Unlink*(VAR n: ARRAY OF CHAR): ErrorCode;
|
||||
BEGIN
|
||||
IF deleteFile(n) = 0 THEN RETURN err() ELSE RETURN 0 END
|
||||
END Unlink;
|
||||
|
||||
|
||||
PROCEDURE -setCurrentDirectory(n: ARRAY OF CHAR): INTEGER "(INTEGER)SetCurrentDirectory((char*)n)";
|
||||
PROCEDURE -getCurrentDirectory(VAR n: ARRAY OF CHAR) "GetCurrentDirectory(n__len, (char*)n)";
|
||||
|
||||
PROCEDURE Chdir*(VAR n: ARRAY OF CHAR): ErrorCode;
|
||||
VAR r: INTEGER;
|
||||
BEGIN
|
||||
r := setCurrentDirectory(n);
|
||||
IF r = 0 THEN RETURN err() END;
|
||||
getCurrentDirectory(CWD);
|
||||
RETURN 0;
|
||||
END Chdir;
|
||||
|
||||
|
||||
|
||||
PROCEDURE -moveFile(o,n: ARRAY OF CHAR): INTEGER
|
||||
"(INTEGER)MoveFileEx((char*)o, (char*)n, MOVEFILE_REPLACE_EXISTING)";
|
||||
|
||||
PROCEDURE Rename*(VAR o,n: ARRAY OF CHAR): ErrorCode;
|
||||
BEGIN
|
||||
IF moveFile(o,n) = 0 THEN RETURN err() ELSE RETURN 0 END
|
||||
END Rename;
|
||||
|
||||
|
||||
|
||||
|
||||
(* Process termination *)
|
||||
|
||||
PROCEDURE -exit(code: INTEGER) "ExitProcess((UINT)code)";
|
||||
PROCEDURE Exit*(code: INTEGER);
|
||||
BEGIN exit(code) END Exit;
|
||||
|
||||
|
||||
PROCEDURE -errstring(s: ARRAY OF CHAR) 'WriteFile((HANDLE)(address)Platform_StdOut, s, s__len-1, 0,0)';
|
||||
PROCEDURE -errc (c: CHAR) 'WriteFile((HANDLE)(address)Platform_StdOut, &c, 1, 0,0)';
|
||||
PROCEDURE errch(c: CHAR); BEGIN errc(c) END errch;
|
||||
PROCEDURE errln; BEGIN errch(0DX); errch(0AX) END errln;
|
||||
|
||||
PROCEDURE errposint(l: LONGINT);
|
||||
BEGIN IF l>10 THEN errposint(l DIV 10) END; errch(CHR(ORD('0') + (l MOD 10))) END errposint;
|
||||
|
||||
PROCEDURE errint(l: LONGINT);
|
||||
BEGIN IF l<0 THEN errch('-'); l := -l END; errposint(l) END errint;
|
||||
|
||||
PROCEDURE DisplayHaltCode(code: LONGINT);
|
||||
BEGIN
|
||||
CASE code OF
|
||||
| -1: errstring("Rider ReadBuf/WriteBuf transfer size longer than buffer.")
|
||||
| -2: errstring("Index out of range.")
|
||||
| -3: errstring("Reached end of function without reaching RETURN.")
|
||||
| -4: errstring("CASE statement: no matching label and no ELSE.")
|
||||
| -5: errstring("Type guard failed.")
|
||||
| -6: errstring("Type equality failed.")
|
||||
| -7: errstring("WITH statement type guard failed.")
|
||||
| -8: errstring("SHORT: Value too large for shorter type.")
|
||||
| -9: errstring("Heap interrupted while locked, but lockdepth = 0 at unlock.")
|
||||
|-10: errstring("NIL access.");
|
||||
|-11: errstring("Alignment error.");
|
||||
|-12: errstring("Divide by zero.");
|
||||
|-13: errstring("Arithmetic overflow/underflow.");
|
||||
|-14: errstring("Invalid function argument.");
|
||||
|-15: errstring("Internal error, e.g. Type descriptor size mismatch.")
|
||||
|-20: errstring("Too many, or negative number of, elements in dynamic array.")
|
||||
ELSE
|
||||
END
|
||||
END DisplayHaltCode;
|
||||
|
||||
PROCEDURE Halt*(code: LONGINT);
|
||||
BEGIN
|
||||
HaltCode := code;
|
||||
IF HaltHandler # NIL THEN HaltHandler(code) END;
|
||||
errstring("Terminated by Halt("); errint(code); errstring("). ");
|
||||
IF code < 0 THEN DisplayHaltCode(code) END;
|
||||
errln;
|
||||
exit(SYSTEM.VAL(INTEGER,code));
|
||||
END Halt;
|
||||
|
||||
PROCEDURE AssertFail*(code: LONGINT);
|
||||
BEGIN
|
||||
errstring("Assertion failure.");
|
||||
IF code # 0 THEN errstring(" ASSERT code "); errint(code); errstring("."); END;
|
||||
errln;
|
||||
exit(SYSTEM.VAL(INTEGER,code));
|
||||
END AssertFail;
|
||||
|
||||
PROCEDURE SetHalt*(p: HaltProcedure);
|
||||
BEGIN HaltHandler := p; END SetHalt;
|
||||
|
||||
|
||||
|
||||
|
||||
PROCEDURE TestLittleEndian;
|
||||
VAR i: INTEGER;
|
||||
BEGIN i := 1; SYSTEM.GET(SYSTEM.ADR(i), LittleEndian); END TestLittleEndian;
|
||||
|
||||
|
||||
PROCEDURE -getstdinhandle(): FileHandle "(address)GetStdHandle(STD_INPUT_HANDLE)";
|
||||
PROCEDURE -getstdouthandle(): FileHandle "(address)GetStdHandle(STD_OUTPUT_HANDLE)";
|
||||
PROCEDURE -getstderrhandle(): FileHandle "(address)GetStdHandle(STD_ERROR_HANDLE)";
|
||||
PROCEDURE -getpid(): INTEGER "(INTEGER)GetCurrentProcessId()";
|
||||
|
||||
BEGIN
|
||||
TestLittleEndian;
|
||||
|
||||
HaltCode := -128;
|
||||
HaltHandler := NIL;
|
||||
TimeStart := 0; TimeStart := Time();
|
||||
CWD := ""; getCurrentDirectory(CWD);
|
||||
PID := getpid();
|
||||
|
||||
SeekSet := seekset();
|
||||
SeekCur := seekcur();
|
||||
SeekEnd := seekend();
|
||||
|
||||
StdIn := getstdinhandle();
|
||||
StdOut := getstdouthandle();
|
||||
StdErr := getstderrhandle();
|
||||
|
||||
nl[0] := 0DX; (* CR *)
|
||||
nl[1] := 0AX; (* LF *)
|
||||
nl[2] := 0X;
|
||||
END Platform.
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
MODULE BrowserCmd; (* RC 29.10.93 *) (* object model 4.12.93, command line version jt 4.4.95 *)
|
||||
|
||||
IMPORT
|
||||
OPM, OPS, OPT, OPV, Texts, Console, Platform, SYSTEM;
|
||||
OPM, OPS, OPT, OPV, Texts, Out, Platform, SYSTEM;
|
||||
|
||||
|
||||
CONST
|
||||
|
|
@ -257,12 +257,12 @@ MODULE BrowserCmd; (* RC 29.10.93 *) (* object model 4.12.93, command line ver
|
|||
OPT.Init(name, {}); OPT.SelfName := "AvoidErr154"; WModule(name, T); OPT.Close;
|
||||
Texts.OpenReader(R, T, 0); Texts.Read(R, ch); i := 0;
|
||||
WHILE ~R.eot DO
|
||||
IF ch = 0DX THEN s[i] := 0X; i := 0; Console.String(s); Console.Ln
|
||||
IF ch = 0DX THEN s[i] := 0X; i := 0; Out.String(s); Out.Ln
|
||||
ELSE s[i] := ch; INC(i)
|
||||
END ;
|
||||
Texts.Read(R, ch)
|
||||
END ;
|
||||
s[i] := 0X; Console.String(s)
|
||||
s[i] := 0X; Out.String(s)
|
||||
END
|
||||
END ShowDef;
|
||||
|
||||
|
|
|
|||
|
|
@ -60,17 +60,17 @@ assemble:
|
|||
@printf " DATAMODEL: %s\n" "$(DATAMODEL)"
|
||||
|
||||
cd $(BUILDDIR) && $(COMPILE) -c SYSTEM.c Configuration.c Platform.c Heap.c
|
||||
cd $(BUILDDIR) && $(COMPILE) -c Console.c Strings.c Modules.c Files.c
|
||||
cd $(BUILDDIR) && $(COMPILE) -c Out.c Strings.c Modules.c Files.c
|
||||
cd $(BUILDDIR) && $(COMPILE) -c Reals.c Texts.c vt100.c errors.c
|
||||
cd $(BUILDDIR) && $(COMPILE) -c OPM.c extTools.c OPS.c OPT.c
|
||||
cd $(BUILDDIR) && $(COMPILE) -c OPC.c OPV.c OPB.c OPP.c
|
||||
|
||||
cd $(BUILDDIR) && $(COMPILE) $(STATICLINK) Compiler.c -o $(ROOTDIR)/$(OBECOMP) \
|
||||
SYSTEM.o Configuration.o Platform.o Heap.o Console.o Strings.o Modules.o Files.o \
|
||||
SYSTEM.o Configuration.o Platform.o Heap.o Out.o Strings.o Modules.o Files.o \
|
||||
Reals.o Texts.o vt100.o errors.o OPM.o extTools.o OPS.o OPT.o \
|
||||
OPC.o OPV.o OPB.o OPP.o
|
||||
|
||||
cp src/system/*.[ch] $(BUILDDIR)
|
||||
cp src/runtime/*.[ch] $(BUILDDIR)
|
||||
@printf "$(OBECOMP) created.\n"
|
||||
|
||||
|
||||
|
|
@ -102,15 +102,15 @@ translate:
|
|||
@rm -f $(BUILDDIR)/*.sym
|
||||
|
||||
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -SsfF -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../Configuration.Mod
|
||||
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -SsfF -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/system/Platform$(PLATFORM).Mod
|
||||
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -SsfFapx -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/system/Heap.Mod
|
||||
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -SsfF -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/system/Console.Mod
|
||||
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -SsfF -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/library/v4/Strings.Mod
|
||||
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -SsfF -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/library/v4/Modules.Mod
|
||||
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -SsfFx -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/system/Files.Mod
|
||||
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -SsfF -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/library/v4/Reals.Mod
|
||||
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -SsfF -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/library/v4/Texts.Mod
|
||||
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -SsfF -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/library/misc/vt100.Mod
|
||||
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -SsfF -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/runtime/Platform$(PLATFORM).Mod
|
||||
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -SsfFapx -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/runtime/Heap.Mod
|
||||
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -SsfFapx -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/runtime/Out.Mod
|
||||
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -SsfF -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/runtime/Strings.Mod
|
||||
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -SsfF -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/runtime/Modules.Mod
|
||||
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -SsfFx -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/runtime/Files.Mod
|
||||
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -SsfF -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/runtime/Reals.Mod
|
||||
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -SsfF -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/runtime/Texts.Mod
|
||||
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -SsfF -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/runtime/vt100.Mod
|
||||
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -SsfF -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/compiler/errors.Mod
|
||||
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -SsfF -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/compiler/OPM.Mod
|
||||
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -SsfF -A$(ADRSIZE)$(ALIGNMENT) -O$(MODEL) ../../src/compiler/extTools.Mod
|
||||
|
|
@ -131,7 +131,7 @@ browsercmd:
|
|||
@printf "\nMaking symbol browser\n"
|
||||
@cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -fSm -O$(MODEL) ../../src/tools/browser/BrowserCmd.Mod
|
||||
@cd $(BUILDDIR); $(COMPILE) BrowserCmd.c -o showdef \
|
||||
Platform.o Texts.o OPT.o Heap.o Console.o SYSTEM.o OPM.o OPS.o OPV.o \
|
||||
Platform.o Texts.o OPT.o Heap.o Out.o SYSTEM.o OPM.o OPS.o OPV.o \
|
||||
Files.o Reals.o Modules.o vt100.o errors.o Configuration.o Strings.o \
|
||||
OPC.o
|
||||
|
||||
|
|
@ -191,7 +191,7 @@ uninstall:
|
|||
runtime:
|
||||
@printf "\nMaking run time library for -O$(MODEL)\n"
|
||||
mkdir -p $(BUILDDIR)/$(MODEL)
|
||||
cp src/system/*.[ch] $(BUILDDIR)/$(MODEL)
|
||||
cp src/runtime/*.[ch] $(BUILDDIR)/$(MODEL)
|
||||
cd $(BUILDDIR)/$(MODEL) && $(COMPILE) -c SYSTEM.c
|
||||
cd $(BUILDDIR)/$(MODEL); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../../src/runtime/Platform$(PLATFORM).Mod
|
||||
cd $(BUILDDIR)/$(MODEL); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../../src/runtime/Heap.Mod
|
||||
|
|
@ -215,6 +215,7 @@ runtime:
|
|||
v4:
|
||||
@printf "\nMaking v4 library\n"
|
||||
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/v4/Args.Mod
|
||||
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/v4/Console.Mod
|
||||
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/v4/Printer.Mod
|
||||
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/v4/Sets.Mod
|
||||
|
||||
|
|
@ -334,7 +335,7 @@ pow32:
|
|||
|
||||
misc:
|
||||
@printf "\nMaking misc library\n"
|
||||
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/system/Oberon.Mod
|
||||
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/runtime/Oberon.Mod
|
||||
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/misc/crt.Mod
|
||||
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/misc/Listen.Mod
|
||||
cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O2 ../../src/library/misc/MersenneTwister.Mod
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue