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

Merge branch 'master' of https://github.com/vishaps/voc

Browse source
This commit is contained in:
David Brown 2016-11-29 15:44:23 +00:00
commit f72b4280b7
19 changed files with 0 additions and 5404 deletions
Download patch file Download diff file Expand all files Collapse all files

585
src/voc07R/CompatTexts.Mod
View file

@ -1,585 +0,0 @@
MODULE CompatTexts; (*JG 21.11.90 / NW 11.7.90 / 24.12.95 / 22.11.10 / 26.3.2014*)
IMPORT Files := CompatFiles, Fonts;
TYPE INTEGER = LONGINT; (* voc adaptation by noch *)
BYTE = CHAR;
CONST (*scanner symbol classes*)
Inval* = 0; (*invalid symbol*)
Name* = 1; (*name s (length len)*)
String* = 2; (*literal string s (length len)*)
Int* = 3; (*integer i (decimal or hexadecimal)*)
Real* = 4; (*real number x*)
Char* = 6; (*special character c*)
(* TextBlock = TextTag "1" offset run {run} "0" len {AsciiCode}.
run = fnt [name] col voff len. *)
TAB = 9X; CR = 0DX; maxD = 9;
TextTag = 0F1X;
replace* = 0; insert* = 1; delete* = 2; unmark* = 3; (*op-codes*)
TYPE Piece = POINTER TO PieceDesc;
PieceDesc = RECORD
f: Files.File;
off, len: LONGINT;
fnt: Fonts.Font;
col, voff: INTEGER;
prev, next: Piece
END;
Text* = POINTER TO TextDesc;
Notifier* = PROCEDURE (T: Text; op: INTEGER; beg, end: LONGINT);
TextDesc* = RECORD
len*: LONGINT;
changed*: BOOLEAN;
notify*: Notifier;
trailer: Piece;
pce: Piece; (*cache*)
org: LONGINT; (*cache*)
END;
Reader* = RECORD
eot*: BOOLEAN;
fnt*: Fonts.Font;
col*, voff*: INTEGER;
ref: Piece;
org: LONGINT;
off: LONGINT;
rider: Files.Rider
END;
Scanner* = RECORD (Reader)
nextCh*: CHAR;
line*, class*: INTEGER;
i*: LONGINT;
x*: REAL;
y*: LONGREAL;
c*: CHAR;
len*: INTEGER;
s*: ARRAY 32 OF CHAR
END;
Buffer* = POINTER TO BufDesc;
BufDesc* = RECORD
len*: LONGINT;
header, last: Piece
END;
Writer* = RECORD
buf*: Buffer;
fnt*: Fonts.Font;
col*, voff*: INTEGER;
rider: Files.Rider
END;
VAR TrailerFile: Files.File;
(* voc adaptation by noch *)
PROCEDURE FLOOR(x : REAL): INTEGER;
BEGIN
RETURN ENTIER(x)
END FLOOR;
PROCEDURE LSL (x, n : INTEGER): INTEGER;
BEGIN
RETURN ASH(x, n);
END LSL;
PROCEDURE ASR (x, n : INTEGER): INTEGER;
BEGIN
RETURN ASH(x, n);
END ASR;
(* -------------------- Filing ------------------------*)
PROCEDURE Trailer(): Piece;
VAR Q: Piece;
BEGIN NEW(Q);
Q.f := TrailerFile; Q.off := -1; Q.len := 1; Q.fnt := NIL; Q.col := 0; Q.voff := 0; RETURN Q
END Trailer;
PROCEDURE Load* (VAR R: Files.Rider; T: Text);
VAR Q, q, p: Piece;
off: LONGINT;
N, fno: INTEGER; bt: BYTE;
f: Files.File;
FName: ARRAY 32 OF CHAR;
Dict: ARRAY 32 OF Fonts.Font;
BEGIN f := Files.Base(R); N := 1; Q := Trailer(); p := Q;
Files.ReadInt(R, off); Files.ReadByte(R, bt);
(*fno := bt;*)
fno := ORD(bt); (* voc adaptation by noch *)
WHILE fno # 0 DO
IF fno = N THEN
Files.ReadString(R, FName);
Dict[N] := Fonts.This(FName); INC(N)
END;
NEW(q); q.fnt := Dict[fno];
Files.ReadByte(R, bt);
(*q.col := bt;*)
q.col := ORD(bt); (* voc adaptation by noch *)
Files.ReadByte(R, bt);
(*q.voff := ASR(LSL(bt, -24), 24);*)
q.voff := ASR(LSL(ORD(bt), -24), 24); (* voc adaptation by noch *)
Files.ReadInt(R, q.len);
Files.ReadByte(R, bt);
(*fno := bt;*)
fno := ORD(bt); (* voc adaptation by noch *)
q.f := f; q.off := off; off := off + q.len;
p.next := q; q.prev := p; p := q
END;
p.next := Q; Q.prev := p;
T.trailer := Q; Files.ReadInt(R, T.len); (*Files.Set(R, f, Files.Pos(R) + T.len)*)
END Load;
PROCEDURE Open* (T: Text; name: ARRAY OF CHAR);
VAR f: Files.File; R: Files.Rider; Q, q: Piece;
tag: CHAR; len: LONGINT;
BEGIN f := Files.Old(name);
IF f # NIL THEN
Files.Set(R, f, 0); Files.Read(R, tag);
IF tag = TextTag THEN Load(R, T)
ELSE (*Ascii file*)
len := Files.Length(f); Q := Trailer();
NEW(q); q.fnt := Fonts.Default; q.col := 1; q.voff := 0; q.f := f; q.off := 0; q.len := len;
Q.next := q; q.prev := Q; q.next := Q; Q.prev := q; T.trailer := Q; T.len := len
END
ELSE (*create new text*)
Q := Trailer(); Q.next := Q; Q.prev := Q; T.trailer := Q; T.len := 0
END ;
T.changed := FALSE; T.org := -1; T.pce := T.trailer (*init cache*)
END Open;
PROCEDURE Store* (VAR W: Files.Rider; T: Text);
VAR p, q: Piece;
R: Files.Rider;
off, rlen, pos: LONGINT;
N, n: INTEGER;
ch: CHAR;
Dict: ARRAY 32, 32 OF CHAR;
BEGIN pos := Files.Pos(W); Files.WriteInt(W, 0); (*place holder*)
N := 1; p := T.trailer.next;
WHILE p # T.trailer DO
rlen := p.len; q := p.next;
WHILE (q # T.trailer) & (q.fnt = p.fnt) & (q.col = p.col) & (q.voff = p.voff) DO
rlen := rlen + q.len; q := q.next
END;
(*Dict[N] := p.fnt.name;*)
IF p.fnt # NIL THEN COPY(p.fnt.name, Dict[N]) END; (* voc adaptation by noch *)
n := 1;
IF p.fnt # NIL THEN (* voc adaptation by noch *)
WHILE Dict[n] # p.fnt.name DO INC(n) END;
END;
(*Files.WriteByte(W, n);*)
Files.WriteByte(W, SHORT(SHORT(n))); (* voc adaptation by noch *)
IF p.fnt # NIL THEN (* voc adaptation by noch *)
IF n = N THEN Files.WriteString(W, p.fnt.name); INC(N) END;
END;
(*Files.WriteByte(W, p.col);*)
Files.WriteByte(W, SHORT(SHORT(p.col))); (* voc adaptation by noch *)
(*Files.WriteByte(W, p.voff);*)
Files.WriteByte(W, SHORT(SHORT(p.voff))); (* voc adaptation by noch *)
Files.WriteInt(W, rlen);
p := q
END;
Files.WriteByte(W, 0); Files.WriteInt(W, T.len);
off := Files.Pos(W); p := T.trailer.next;
WHILE p # T.trailer DO
rlen := p.len; Files.Set(R, p.f, p.off);
WHILE rlen > 0 DO Files.Read(R, ch); Files.Write(W, ch); DEC(rlen) END ;
p := p.next
END ;
Files.Set(W, Files.Base(W), pos); Files.WriteInt(W, off); (*fixup*)
T.changed := FALSE;
IF T.notify # NIL THEN T.notify(T, unmark, 0, 0) END
END Store;
PROCEDURE Close*(T: Text; name: ARRAY OF CHAR);
VAR f: Files.File; w: Files.Rider;
BEGIN f := Files.New(name); Files.Set(w, f, 0);
Files.Write(w, TextTag); Store(w, T); Files.Register(f)
END Close;
(* -------------------- Editing ----------------------- *)
PROCEDURE OpenBuf* (B: Buffer);
BEGIN NEW(B.header); (*null piece*)
B.last := B.header; B.len := 0
END OpenBuf;
PROCEDURE FindPiece (T: Text; pos: LONGINT; VAR org: LONGINT; VAR pce: Piece);
VAR p: Piece; porg: LONGINT;
BEGIN p := T.pce; porg := T.org;
IF pos >= porg THEN
WHILE pos >= porg + p.len DO INC(porg, p.len); p := p.next END
ELSE p := p.prev; DEC(porg, p.len);
WHILE pos < porg DO p := p.prev; DEC(porg, p.len) END
END ;
T.pce := p; T.org := porg; (*update cache*)
pce := p; org := porg
END FindPiece;
PROCEDURE SplitPiece (p: Piece; off: LONGINT; VAR pr: Piece);
VAR q: Piece;
BEGIN
IF off > 0 THEN NEW(q);
q.fnt := p.fnt; q.col := p.col; q.voff := p.voff;
q.len := p.len - off;
q.f := p.f; q.off := p.off + off;
p.len := off;
q.next := p.next; p.next := q;
q.prev := p; q.next.prev := q;
pr := q
ELSE pr := p
END
END SplitPiece;
PROCEDURE Save* (T: Text; beg, end: LONGINT; B: Buffer);
VAR p, q, qb, qe: Piece; org: LONGINT;
BEGIN
IF end > T.len THEN end := T.len END;
FindPiece(T, beg, org, p);
NEW(qb); qb^ := p^;
qb.len := qb.len - (beg - org);
qb.off := qb.off + (beg - org);
qe := qb;
WHILE end > org + p.len DO
org := org + p.len; p := p.next;
NEW(q); q^ := p^; qe.next := q; q.prev := qe; qe := q
END;
qe.next := NIL; qe.len := qe.len - (org + p.len - end);
B.last.next := qb; qb.prev := B.last; B.last := qe;
B.len := B.len + (end - beg)
END Save;
PROCEDURE Copy* (SB, DB: Buffer);
VAR Q, q, p: Piece;
BEGIN p := SB.header; Q := DB.last;
WHILE p # SB.last DO p := p.next;
NEW(q); q^ := p^; Q.next := q; q.prev := Q; Q := q
END;
DB.last := Q; DB.len := DB.len + SB.len
END Copy;
PROCEDURE Insert* (T: Text; pos: LONGINT; B: Buffer);
VAR pl, pr, p, qb, qe: Piece; org, end: LONGINT;
BEGIN
FindPiece(T, pos, org, p); SplitPiece(p, pos - org, pr);
IF T.org >= org THEN T.org := org - p.prev.len; T.pce := p.prev END ;
pl := pr.prev; qb := B.header.next;
IF (qb # NIL) & (qb.f = pl.f) & (qb.off = pl.off + pl.len)
& (qb.fnt = pl.fnt) & (qb.col = pl.col) & (qb.voff = pl.voff) THEN
pl.len := pl.len + qb.len; qb := qb.next
END;
IF qb # NIL THEN qe := B.last;
qb.prev := pl; pl.next := qb; qe.next := pr; pr.prev := qe
END;
T.len := T.len + B.len; end := pos + B.len;
B.last := B.header; B.last.next := NIL; B.len := 0;
T.changed := TRUE;
(*T.notify(T, insert, pos, end)*)
IF T.notify # NIL THEN
T.notify(T, insert, pos, end)
END(* voc adaptation by noch *)
END Insert;
PROCEDURE Append* (T: Text; B: Buffer);
BEGIN Insert(T, T.len, B)
END Append;
PROCEDURE Delete* (T: Text; beg, end: LONGINT; B: Buffer);
VAR pb, pe, pbr, per: Piece; orgb, orge: LONGINT;
BEGIN
IF end > T.len THEN end := T.len END;
FindPiece(T, beg, orgb, pb); SplitPiece(pb, beg - orgb, pbr);
FindPiece(T, end, orge, pe);
SplitPiece(pe, end - orge, per);
IF T.org >= orgb THEN (*adjust cache*)
T.org := orgb - pb.prev.len; T.pce := pb.prev
END;
B.header.next := pbr; B.last := per.prev;
B.last.next := NIL; B.len := end - beg;
per.prev := pbr.prev; pbr.prev.next := per;
T.len := T.len - B.len;
T.changed := TRUE;
IF T.notify # NIL THEN (* noch *)
T.notify(T, delete, beg, end)
END
END Delete;
PROCEDURE ChangeLooks* (T: Text; beg, end: LONGINT; sel: SET; fnt: Fonts.Font; col, voff: INTEGER);
VAR pb, pe, p: Piece; org: LONGINT;
BEGIN
IF end > T.len THEN end := T.len END;
FindPiece(T, beg, org, p); SplitPiece(p, beg - org, pb);
FindPiece(T, end, org, p); SplitPiece(p, end - org, pe);
p := pb;
REPEAT
IF 0 IN sel THEN p.fnt := fnt END;
IF 1 IN sel THEN p.col := col END;
IF 2 IN sel THEN p.voff := voff END;
p := p.next
UNTIL p = pe;
T.changed := TRUE;
IF T.notify # NIL THEN (* noch *)
T.notify(T, replace, beg, end)
END
END ChangeLooks;
PROCEDURE Attributes*(T: Text; pos: LONGINT; VAR fnt: Fonts.Font; VAR col, voff: INTEGER);
VAR p: Piece; org: LONGINT;
BEGIN FindPiece(T, pos, org, p); fnt := p.fnt; col := p.col; voff := p.voff
END Attributes;
(* ------------------ Access: Readers ------------------------- *)
PROCEDURE OpenReader* (VAR R: Reader; T: Text; pos: LONGINT);
VAR p: Piece; org: LONGINT;
BEGIN FindPiece(T, pos, org, p);
R.ref := p; R.org := org; R.off := pos - org;
Files.Set(R.rider, p.f, p.off + R.off); R.eot := FALSE
END OpenReader;
PROCEDURE Read* (VAR R: Reader; VAR ch: CHAR);
BEGIN Files.Read(R.rider, ch);
R.fnt := R.ref.fnt; R.col := R.ref.col; R.voff := R.ref.voff;
INC(R.off);
IF R.off = R.ref.len THEN
IF R.ref.f = TrailerFile THEN R.eot := TRUE END;
R.org := R.org + R.off; R.off := 0;
R.ref := R.ref.next; R.org := R.org + R.off; R.off := 0;
Files.Set(R.rider, R.ref.f, R.ref.off)
END
END Read;
PROCEDURE Pos* (VAR R: Reader): LONGINT;
BEGIN RETURN R.org + R.off
END Pos;
(* ------------------ Access: Scanners (NW) ------------------------- *)
PROCEDURE OpenScanner* (VAR S: Scanner; T: Text; pos: LONGINT);
BEGIN OpenReader(S, T, pos); S.line := 0; S.nextCh := " "
END OpenScanner;
(*floating point formats:
x = 1.m * 2^(e-127) bit 0: sign, bits 1- 8: e, bits 9-31: m
x = 1.m * 2^(e-1023) bit 0: sign, bits 1-11: e, bits 12-63: m *)
PROCEDURE Ten(n: INTEGER): REAL;
VAR t, p: REAL;
BEGIN t := 1.0; p := 10.0; (*compute 10^n *)
WHILE n > 0 DO
IF ODD(n) THEN t := p * t END ;
p := p*p; n := n DIV 2
END ;
RETURN t
END Ten;
PROCEDURE Scan* (VAR S: Scanner);
CONST maxExp = 38; maxM = 16777216; (*2^24*)
VAR ch, term: CHAR;
neg, negE, hex: BOOLEAN;
i, j, h, d, e, n, s: INTEGER;
k: LONGINT;
x: REAL;
BEGIN ch := S.nextCh; i := 0;
WHILE (ch = " ") OR (ch = TAB) OR (ch = CR) DO
IF ch = CR THEN INC(S.line) END ;
Read(S, ch)
END ;
IF ("A" <= ch) & (ch <= "Z") OR ("a" <= ch) & (ch <= "z") THEN (*name*)
REPEAT S.s[i] := ch; INC(i); Read(S, ch)
UNTIL ((ch < "0") & (ch # ".") OR ("9" < ch) & (ch < "A") OR ("Z" < ch) & (ch < "a") OR ("z" < ch)) OR (i = 31);
S.s[i] := 0X; S.len := i; S.class := Name
ELSIF ch = 22X THEN (*string*)
Read(S, ch);
WHILE (ch # 22X) & (ch >= " ") & (i # 31) DO S.s[i] := ch; INC(i); Read(S, ch) END;
S.s[i] := 0X; S.len := i+1; Read(S, ch); S.class := String
ELSE hex := FALSE;
IF ch = "-" THEN neg := TRUE; Read(S, ch) ELSE neg := FALSE END ;
IF ("0" <= ch) & (ch <= "9") THEN (*number*)
n := ORD(ch) - 30H; h := n; Read(S, ch);
WHILE ("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F") DO
IF ch <= "9" THEN d := ORD(ch) - 30H ELSE d := ORD(ch) - 37H; hex := TRUE END ;
n := 10*n + d; h := 10H*h + d; Read(S, ch)
END ;
IF ch = "H" THEN (*hex integer*) Read(S, ch); S.i := h; S.class := Int (*neg?*)
ELSIF ch = "." THEN (*real number*)
Read(S, ch); x := 0.0; e := 0; j := 0;
WHILE ("0" <= ch) & (ch <= "9") DO (*fraction*)
h := 10*n + (ORD(ch) - 30H);
IF h < maxM THEN n := h; INC(j) END ;
Read(S, ch)
END ;
IF ch = "E" THEN (*scale factor*)
s := 0; Read(S, ch);
IF ch = "-" THEN negE := TRUE; Read(S, ch)
ELSE negE := FALSE;
IF ch = "+" THEN Read(S, ch) END
END ;
WHILE ("0" <= ch) & (ch <= "9") DO
s := s*10 + ORD(ch) - 30H; Read(S, ch)
END ;
IF negE THEN DEC(e, s) ELSE INC(e, s) END ;
END ;
(*x := FLT(n);*)
x := n; (* voc adaptation by noch *)
DEC(e, j);
IF e < 0 THEN
IF e >= -maxExp THEN x := x / Ten(-e) ELSE x := 0.0 END
ELSIF e > 0 THEN
IF e <= maxExp THEN x := Ten(e) * x ELSE x := 0.0 END
END ;
IF neg THEN S.x := -x ELSE S.x := x END ;
IF hex THEN S.class := 0 ELSE S.class := Real END
ELSE (*decimal integer*)
IF neg THEN S.i := -n ELSE S.i := n END;
IF hex THEN S.class := Inval ELSE S.class := Int END
END
ELSE (*spectal character*) S.class := Char;
IF neg THEN S.c := "-" ELSE S.c := ch; Read(S, ch) END
END
END ;
S.nextCh := ch
END Scan;
(* --------------- Access: Writers (NW) ------------------ *)
PROCEDURE OpenWriter* (VAR W: Writer);
BEGIN NEW(W.buf);
OpenBuf(W.buf); W.fnt := Fonts.Default; W.col := 15; W.voff := 0;
Files.Set(W.rider, Files.New(""), 0)
END OpenWriter;
PROCEDURE SetFont* (VAR W: Writer; fnt: Fonts.Font);
BEGIN W.fnt := fnt
END SetFont;
PROCEDURE SetColor* (VAR W: Writer; col: INTEGER);
BEGIN W.col := col
END SetColor;
PROCEDURE SetOffset* (VAR W: Writer; voff: INTEGER);
BEGIN W.voff := voff
END SetOffset;
PROCEDURE Write* (VAR W: Writer; ch: CHAR);
VAR p: Piece;
BEGIN
IF (W.buf.last.fnt # W.fnt) OR (W.buf.last.col # W.col) OR (W.buf.last.voff # W.voff) THEN
NEW(p); p.f := Files.Base(W.rider); p.off := Files.Pos(W.rider); p.len := 0;
p.fnt := W.fnt; p.col := W.col; p.voff:= W.voff;
p.next := NIL; W.buf.last.next := p;
p.prev := W.buf.last; W.buf.last := p
END;
Files.Write(W.rider, ch);
INC(W.buf.last.len); INC(W.buf.len)
END Write;
PROCEDURE WriteLn* (VAR W: Writer);
BEGIN Write(W, CR)
END WriteLn;
PROCEDURE WriteString* (VAR W: Writer; s: ARRAY OF CHAR);
VAR i: INTEGER;
BEGIN i := 0;
WHILE s[i] >= " " DO Write(W, s[i]); INC(i) END
END WriteString;
PROCEDURE WriteInt* (VAR W: Writer; x, n: LONGINT);
VAR i: INTEGER; x0: LONGINT;
a: ARRAY 10 OF CHAR;
BEGIN
(*IF ROR(x, 31) = 1 THEN WriteString(W, " -2147483648")
ELSE*) i := 0; (* voc adaptation by noch *)
IF x < 0 THEN DEC(n); x0 := -x ELSE x0 := x END;
REPEAT
a[i] := CHR(x0 MOD 10 + 30H); x0 := x0 DIV 10; INC(i)
UNTIL x0 = 0;
WHILE n > i DO Write(W, " "); DEC(n) END;
IF x < 0 THEN Write(W, "-") END;
REPEAT DEC(i); Write(W, a[i]) UNTIL i = 0
(*END*)
END WriteInt;
PROCEDURE WriteHex* (VAR W: Writer; x: LONGINT);
VAR i: INTEGER; y: LONGINT;
a: ARRAY 10 OF CHAR;
BEGIN i := 0; Write(W, " ");
REPEAT y := x MOD 10H;
IF y < 10 THEN a[i] := CHR(y + 30H) ELSE a[i] := CHR(y + 37H) END;
x := x DIV 10H; INC(i)
UNTIL i = 8;
REPEAT DEC(i); Write(W, a[i]) UNTIL i = 0
END WriteHex;
(* commented out because it's not necessary to compile OR compiler; -- noch
PROCEDURE WriteReal* (VAR W: Writer; x: REAL; n: INTEGER);
VAR e, i, m: INTEGER; x0: REAL; neg: BOOLEAN;
d: ARRAY 16 OF CHAR;
BEGIN
IF x = 0.0 THEN
WriteString(W, " 0.0"); i := 5;
WHILE i < n DO Write(W, " "); INC(i) END
ELSE
IF x < 0.0 THEN x := -x; neg := TRUE ELSE neg := FALSE END ;
x0 := x; UNPK(x0, e);
IF e = 255 THEN WriteString(W, " NaN")
ELSE
REPEAT Write(W, " "); DEC(n) UNTIL n <= 14;
IF neg THEN Write(W, "-") ELSE Write(W, " ") END ;
e := e * 77 DIV 256 - 6;
IF e >= 0 THEN x := x / Ten(e) ELSE x := x * Ten(-e) END ;
IF x >= 10.0E6 THEN x := 0.1*x; INC(e) END ;
m := FLOOR(x + 0.5); i := 0;
IF x >= 10.0E6 THEN x := 0.1*x; INC(e) END ;
REPEAT d[i] := CHR(m MOD 10 + 30H); m := m DIV 10; INC(i) UNTIL m = 0;
DEC(i); Write(W, d[i]); Write(W, ".");
IF i < n-6 THEN n := 0 ELSE n := 13-n END ;
WHILE i > n DO DEC(i); Write(W, d[i]) END ;
Write(W, "E"); INC(e, 6);
IF e < 0 THEN Write(W, "-"); e := -e ELSE Write(W, "+") END ;
Write(W, CHR(e DIV 10 + 30H)); Write(W, CHR(e MOD 10 + 30H))
END
END
END WriteReal;
*)
PROCEDURE WriteRealFix* (VAR W: Writer; x: REAL; n, k: INTEGER);
VAR i, m: INTEGER; neg: BOOLEAN;
d: ARRAY 12 OF CHAR;
BEGIN
IF x = 0.0 THEN WriteString(W, " 0")
ELSE
IF x < 0.0 THEN x := -x; neg := TRUE ELSE neg := FALSE END ;
IF k > 7 THEN k := 7 END ;
x := Ten(k) * x; m := FLOOR(x + 0.5);
i := 0;
REPEAT d[i] := CHR(m MOD 10 + 30H); m := m DIV 10; INC(i) UNTIL m = 0;
REPEAT Write(W, " "); DEC(n) UNTIL n <= i+3;
IF neg THEN Write(W, "-"); DEC(n) ELSE Write(W, " ") END ;
WHILE i > k DO DEC(i); Write(W, d[i]) END ;
Write(W, ".");
WHILE k > i DO DEC(k); Write(W, "0") END ;
WHILE i > 0 DO DEC(i); Write(W, d[i]) END
END
END WriteRealFix;
PROCEDURE WritePair(VAR W: Writer; ch: CHAR; x: LONGINT);
BEGIN Write(W, ch);
Write(W, CHR(x DIV 10 + 30H)); Write(W, CHR(x MOD 10 + 30H))
END WritePair;
PROCEDURE WriteClock* (VAR W: Writer; d: LONGINT);
BEGIN
WritePair(W, " ", d DIV 20000H MOD 20H); (*day*)
WritePair(W, ".", d DIV 400000H MOD 10H); (*month*)
WritePair(W, ".", d DIV 4000000H MOD 40H); (*year*)
WritePair(W, " ", d DIV 1000H MOD 20H); (*hour*)
WritePair(W, ":", d DIV 40H MOD 40H); (*min*)
WritePair(W, ":", d MOD 40H) (*sec*)
END WriteClock;
BEGIN TrailerFile := Files.New("")
END CompatTexts.

146
src/voc07R/Fonts.Mod
View file

@ -1,146 +0,0 @@
MODULE Fonts; (*JG 18.11.90; PDR 8.6.12; NW 25.3.2013*)
IMPORT SYSTEM, Files := CompatFiles;
TYPE INTEGER = LONGINT; (* voc adaptation by noch *)
BYTE = CHAR;
CONST FontFileId = 0DBH;
TYPE Font* = POINTER TO FontDesc;
FontDesc* = RECORD
name*: ARRAY 32 OF CHAR;
height*, minX*, maxX*, minY*, maxY*: INTEGER;
next*: Font;
T: ARRAY 128 OF INTEGER;
raster: ARRAY 2360 OF BYTE
END ;
LargeFontDesc = RECORD (FontDesc) ext: ARRAY 2560 OF BYTE END ;
LargeFont = POINTER TO LargeFontDesc;
(* raster sizes: Syntax8 1367, Syntax10 1628, Syntax12 1688, Syntax14 1843, Syntax14b 1983,
Syntax16 2271, Syntax20 3034, Syntac24 4274, Syntax24b 4302 *)
VAR Default*, root*: Font;
PROCEDURE GetPat*(fnt: Font; ch: CHAR; VAR dx, x, y, w, h, patadr: INTEGER);
VAR pa: INTEGER; dxb, xb, yb, wb, hb: BYTE;
BEGIN pa := fnt.T[ORD(ch) MOD 80H]; patadr := pa;
SYSTEM.GET(pa-3, dxb); SYSTEM.GET(pa-2, xb); SYSTEM.GET(pa-1, yb); SYSTEM.GET(pa, wb); SYSTEM.GET(pa+1, hb);
(*dx := dxb;*)
dx := ORD(dxb); (* voc adaptation by noch *)
(*x := xb;*)
x := ORD(xb); (* voc adaptation by noch *)
(*y := yb;*)
y := ORD(yb); (* voc adaptation by noch *)
(*w := wb;*)
w := ORD(wb); (* voc adaptation by noch *)
(*h := hb;*)
h := ORD(hb); (* voc adaptation by noch *)
(*IF yb < 128 THEN y := yb ELSE y := yb - 256 END*)
IF ORD(yb) < 128 THEN y := ORD(yb) ELSE y := ORD(yb) - 256 END (* voc adaptation by noch *)
END GetPat;
PROCEDURE This*(name: ARRAY OF CHAR): Font;
TYPE RunRec = RECORD beg, end: BYTE END ;
BoxRec = RECORD dx, x, y, w, h: BYTE END ;
VAR F: Font; LF: LargeFont;
f: Files.File; R: Files.Rider;
NofRuns, NofBoxes: BYTE;
NofBytes: INTEGER;
height, minX, maxX, minY, maxY: BYTE;
i, j, k, m, n: INTEGER;
a, a0: INTEGER;
b, beg, end: BYTE;
run: ARRAY 16 OF RunRec;
box: ARRAY 512 OF BoxRec;
PROCEDURE RdInt16(VAR R: Files.Rider; VAR b0: BYTE);
VAR b1: BYTE;
BEGIN Files.ReadByte(R, b0); Files.ReadByte(R, b1)
END RdInt16;
BEGIN F := root;
WHILE (F # NIL) & (name # F.name) DO F := F.next END;
IF F = NIL THEN
f := Files.Old(name);
IF f # NIL THEN
Files.Set(R, f, 0); Files.ReadByte(R, b);
(*IF b = FontFileId THEN*)
IF ORD(b) = FontFileId THEN (* voc adaptation by noch *)
Files.ReadByte(R, b); (*abstraction*)
Files.ReadByte(R, b); (*family*)
Files.ReadByte(R, b); (*variant*)
NEW(F);
(*F.name := name;*)
COPY(name, F.name); (* voc adaptation by noch *)
RdInt16(R, height); RdInt16(R, minX); RdInt16(R, maxX); RdInt16(R, minY); RdInt16(R, maxY); RdInt16(R, NofRuns);
(*NofBoxes := 0;*) (* voc adaptation by noch *)
NofBoxes := 0X;
k := 0;
(*WHILE k # NofRuns DO*)
WHILE k # ORD(NofRuns) DO (* voc adaptation by noch *)
RdInt16(R, beg);
run[k].beg := beg; RdInt16(R, end);
run[k].end := end;
(*NofBoxes := NofBoxes + end - beg;*)
NofBoxes := CHR(ORD(NofBoxes) + ORD(end) - ORD(beg)); (* voc adaptation by noch *)
INC(k)
END;
NofBytes := 5; j := 0;
(*WHILE j # NofBoxes DO*)
WHILE j # ORD(NofBoxes) DO (* voc adaptation by noch *)
RdInt16(R, box[j].dx); RdInt16(R, box[j].x); RdInt16(R, box[j].y);
RdInt16(R, box[j].w); RdInt16(R, box[j].h);
(*NofBytes := NofBytes + 5 + (box[j].w + 7) DIV 8 * box[j].h;*)
NofBytes := (NofBytes + 5 + (ORD(box[j].w) + 7) DIV 8 * ORD(box[j].h)); (* voc adaptation by noch *)
INC(j)
END;
IF NofBytes < 2300 THEN NEW(F) ELSE NEW(LF); F := LF END ;
(*F.name := name;*)
COPY(name, F.name); (* voc adaptation by noch *)
(*F.height := height; F.minX := minX; F.maxX := maxX; F.maxY := maxY;*)
F.height := ORD(height); F.minX := ORD(minX); F.maxX := ORD(maxX); F.maxY := ORD(maxY); (* voc adaptation by noch *)
(*IF minY >= 80H THEN F.minY := minY - 100H ELSE F.minY := minY END ;*)
IF ORD(minY) >= 80H THEN F.minY := ORD(minY) - 100H ELSE F.minY := ORD(minY) END ; (* voc adaptation by noch *)
a0 := SYSTEM.ADR(F.raster);
SYSTEM.PUT(a0, 0X); SYSTEM.PUT(a0+1, 0X); SYSTEM.PUT(a0+2, 0X); SYSTEM.PUT(a0+3, 0X); SYSTEM.PUT(a0+4, 0X);
(*null pattern for characters not in a run*)
INC(a0, 2); a := a0+3; j := 0; k := 0; m := 0;
(*WHILE k < NofRuns DO*)
WHILE k < ORD(NofRuns) DO
(*WHILE (m < run[k].beg) & (m < 128) DO F.T[m] := a0; INC(m) END;*)
WHILE (m < ORD(run[k].beg)) & (m < 128) DO F.T[m] := a0; INC(m) END; (* voc adaptation by noch *)
(*WHILE (m < run[k].end) & (m < 128) DO*) (* voc adaptation by noch *)
WHILE (m < ORD(run[k].end)) & (m < 128) DO
F.T[m] := a+3;
SYSTEM.PUT(a, box[j].dx); SYSTEM.PUT(a+1, box[j].x); SYSTEM.PUT(a+2, box[j].y);
SYSTEM.PUT(a+3, box[j].w); SYSTEM.PUT(a+4, box[j].h); INC(a, 5);
(*n := (box[j].w + 7) DIV 8 * box[j].h;*)
n := (ORD(box[j].w) + 7) DIV 8 * ORD(box[j].h); (* voc adaptation by noch *)
WHILE n # 0 DO DEC(n); Files.ReadByte(R, b); SYSTEM.PUT(a, b); INC(a) END ;
INC(j); INC(m)
END;
INC(k)
END;
WHILE m < 128 DO F.T[m] := a0; INC(m) END ;
F.next := root; root := F
ELSE (*bad file id*) F := Default
END
ELSE (*font file not available*) F := Default
END
END;
RETURN F
END This;
PROCEDURE Free*; (*remove all but first two from font list*)
VAR f: Font;
BEGIN f := root.next;
IF f # NIL THEN f := f.next END ;
f.next := NIL
END Free;
BEGIN root := NIL; Default := This("Oberon10.Scn.Fnt")
END Fonts.

447
src/voc07R/ORB.Mod
View file

@ -1,447 +0,0 @@
MODULE ORB; (*NW 25.6.2014 in Oberon-07*)
IMPORT Files := CompatFiles (* voc adaptation by noch *)
, ORS;
(*Definition of data types Object and Type, which together form the data structure
called "symbol table". Contains procedures for creation of Objects, and for search:
NewObj, this, thisimport, thisfield (and OpenScope, CloseScope).
Handling of import and export, i.e. reading and writing of "symbol files" is done by procedures
Import and Export. This module contains the list of standard identifiers, with which
the symbol table (universe), and that of the pseudo-module SYSTEM are initialized. *)
TYPE INTEGER = LONGINT; (* voc adaptation by noch *)
BYTE = CHAR;
CONST versionkey* = 1; maxTypTab = 64;
(* class values*) Head* = 0;
Const* = 1; Var* = 2; Par* = 3; Fld* = 4; Typ* = 5;
SProc* = 6; SFunc* = 7; Mod* = 8;
(* form values*)
Byte* = 1; Bool* = 2; Char* = 3; Int* = 4; Real* = 5; Set* = 6;
Pointer* = 7; NilTyp* = 8; NoTyp* = 9; Proc* = 10;
String* = 11; Array* = 12; Record* = 13;
TYPE Object* = POINTER TO ObjDesc;
Module* = POINTER TO ModDesc;
Type* = POINTER TO TypeDesc;
ObjDesc*= RECORD
class*, lev*, exno*: INTEGER;
expo*, rdo*: BOOLEAN; (*exported / read-only*)
next*, dsc*: Object;
type*: Type;
name*: ORS.Ident;
val*: LONGINT
END ;
ModDesc* = RECORD (ObjDesc) orgname*: ORS.Ident END ;
TypeDesc* = RECORD
form*, ref*, mno*: INTEGER; (*ref is only used for import/export*)
nofpar*: INTEGER; (*for procedures, extension level for records*)
len*: LONGINT; (*for arrays, len < 0 => open array; for records: adr of descriptor*)
dsc*, typobj*: Object;
base*: Type; (*for arrays, records, pointers*)
size*: LONGINT; (*in bytes; always multiple of 4, except for Byte, Bool and Char*)
END ;
(* Object classes and the meaning of "val":
class val
----------
Var address
Par address
Const value
Fld offset
Typ type descriptor (TD) address
SProc inline code number
SFunc inline code number
Mod key
Type forms and the meaning of "dsc" and "base":
form dsc base
------------------------
Pointer - type of dereferenced object
Proc params result type
Array - type of elements
Record fields extension *)
VAR topScope*, universe, system*: Object;
byteType*, boolType*, charType*: Type;
intType*, realType*, setType*, nilType*, noType*, strType*: Type;
nofmod, Ref: INTEGER;
typtab: ARRAY maxTypTab OF Type;
PROCEDURE NewObj*(VAR obj: Object; id: ORS.Ident; class: INTEGER); (*insert new Object with name id*)
VAR new, x: Object;
BEGIN x := topScope;
WHILE (x.next # NIL) & (x.next.name # id) DO x := x.next END ;
IF x.next = NIL THEN
NEW(new); new.name := id; new.class := class; new.next := NIL; new.rdo := FALSE; new.dsc := NIL;
x.next := new; obj := new
ELSE obj := x.next; ORS.Mark("mult def")
END
END NewObj;
PROCEDURE thisObj*(): Object;
VAR s, x: Object;
BEGIN s := topScope;
REPEAT x := s.next;
WHILE (x # NIL) & (x.name # ORS.id) DO x := x.next END ;
s := s.dsc
UNTIL (x # NIL) OR (s = NIL);
RETURN x
END thisObj;
PROCEDURE thisimport*(mod: Object): Object;
VAR obj: Object;
BEGIN
IF mod.rdo THEN
IF mod.name[0] # 0X THEN
obj := mod.dsc;
WHILE (obj # NIL) & (obj.name # ORS.id) DO obj := obj.next END
ELSE obj := NIL
END
ELSE obj := NIL
END ;
RETURN obj
END thisimport;
PROCEDURE thisfield*(rec: Type): Object;
VAR fld: Object;
BEGIN fld := rec.dsc;
WHILE (fld # NIL) & (fld.name # ORS.id) DO fld := fld.next END ;
RETURN fld
END thisfield;
PROCEDURE OpenScope*;
VAR s: Object;
BEGIN NEW(s); s.class := Head; s.dsc := topScope; s.next := NIL; topScope := s
END OpenScope;
PROCEDURE CloseScope*;
BEGIN topScope := topScope.dsc
END CloseScope;
(*------------------------------- Import ---------------------------------*)
PROCEDURE MakeFileName*(VAR FName: ORS.Ident; name, ext: ARRAY OF CHAR);
VAR i, j: INTEGER;
BEGIN i := 0; j := 0; (*assume name suffix less than 4 characters*)
WHILE (i < ORS.IdLen-5) & (name[i] > 0X) DO FName[i] := name[i]; INC(i) END ;
REPEAT FName[i]:= ext[j]; INC(i); INC(j) UNTIL ext[j] = 0X;
FName[i] := 0X
END MakeFileName;
PROCEDURE ThisModule(name, orgname: ORS.Ident; non: BOOLEAN; key: LONGINT): Object;
VAR mod: Module; obj, obj1: Object;
BEGIN obj1 := topScope; obj := obj1.next; (*search for module*)
WHILE (obj # NIL) & (obj.name # name) DO obj1 := obj; obj := obj1.next END ;
IF obj = NIL THEN (*insert new module*)
NEW(mod); mod.class := Mod; mod.rdo := FALSE;
mod.name := name; mod.orgname := orgname; mod.val := key;
mod.lev := nofmod; INC(nofmod); mod.type := noType; mod.dsc := NIL; mod.next := NIL;
obj1.next := mod; obj := mod
ELSE (*module already present*)
IF non THEN ORS.Mark("invalid import order") END
END ;
RETURN obj
END ThisModule;
PROCEDURE Read(VAR R: Files.Rider; VAR x: INTEGER);
VAR b: BYTE;
BEGIN Files.ReadByte(R, b);
(*IF b < 80H THEN x := b ELSE x := b - 100H END*)
IF b < 80X THEN x := ORD(b) ELSE x := ORD(b) - 100H END (* voc adaptation by noch *)
END Read;
PROCEDURE InType(VAR R: Files.Rider; thismod: Object; VAR T: Type);
VAR key: LONGINT;
ref, class, mno, form, np, readonly: INTEGER;
new, fld, par, obj, mod, impmod: Object;
t: Type;
name, modname: ORS.Ident;
BEGIN Read(R, ref);
IF ref < 0 THEN T := typtab[-ref] (*already read*)
ELSE NEW(t); T := t; typtab[ref] := t; t.mno := thismod.lev;
Read(R, form); t.form := form;
IF form = Pointer THEN InType(R, thismod, t.base); t.size := 4
ELSIF form = Array THEN
InType(R, thismod, t.base); Files.ReadNum(R, t.len); Files.ReadNum(R, t.size)
ELSIF form = Record THEN
InType(R, thismod, t.base);
IF t.base.form = NoTyp THEN t.base := NIL; obj := NIL ELSE obj := t.base.dsc END ;
Files.ReadNum(R, t.len); (*TD adr/exno*)
Files.ReadNum(R, t.nofpar); (*ext level*)
Files.ReadNum(R, t.size);
Read(R, class);
WHILE class # 0 DO (*fields*)
NEW(fld); fld.class := class; Files.ReadString(R, fld.name);
IF fld.name[0] # 0X THEN fld.expo := TRUE; InType(R, thismod, fld.type) ELSE fld.expo := FALSE; fld.type := nilType END ;
Files.ReadNum(R, fld.val); fld.next := obj; obj := fld; Read(R, class)
END ;
t.dsc := obj
ELSIF form = Proc THEN
InType(R, thismod, t.base);
obj := NIL; np := 0; Read(R, class);
WHILE class # 0 DO (*parameters*)
NEW(par); par.class := class; Read(R, readonly); par.rdo := readonly = 1;
InType(R, thismod, par.type); par.next := obj; obj := par; INC(np); Read(R, class)
END ;
t.dsc := obj; t.nofpar := np; t.size := 4
END ;
Files.ReadString(R, modname);
IF modname[0] # 0X THEN (*re-import*)
Files.ReadInt(R, key); Files.ReadString(R, name);
mod := ThisModule(modname, modname, FALSE, key);
obj := mod.dsc; (*search type*)
WHILE (obj # NIL) & (obj.name # name) DO obj := obj.next END ;
IF obj # NIL THEN T := obj.type (*type object found in object list of mod*)
ELSE (*insert new type object in object list of mod*)
NEW(obj); obj.name := name; obj.class := Typ; obj.next := mod.dsc; mod.dsc := obj; obj.type := t;
t.mno := mod.lev; t.typobj := obj; T := t
END ;
typtab[ref] := T
END
END
END InType;
PROCEDURE Import*(VAR modid, modid1: ORS.Ident);
VAR key: LONGINT; class, k: INTEGER;
obj: Object; t: Type;
thismod: Object;
modname, fname: ORS.Ident;
F: Files.File; R: Files.Rider;
BEGIN
IF modid1 = "SYSTEM" THEN
thismod := ThisModule(modid, modid1, TRUE, key); DEC(nofmod);
thismod.lev := 0; thismod.dsc := system; thismod.rdo := TRUE
ELSE MakeFileName(fname, modid1, ".smb"); F := Files.Old(fname);
IF F # NIL THEN
Files.Set(R, F, 0); Files.ReadInt(R, key); Files.ReadInt(R, key); Files.ReadString(R, modname);
thismod := ThisModule(modid, modid1, TRUE, key); thismod.rdo := TRUE;
Read(R, class); (*version key*)
IF class # versionkey THEN ORS.Mark("wrong version") END ;
Read(R, class);
WHILE class # 0 DO
NEW(obj); obj.class := class; Files.ReadString(R, obj.name);
InType(R, thismod, obj.type); obj.lev := -thismod.lev;
IF class = Typ THEN
t := obj.type; t.typobj := obj; Read(R, k); (*fixup bases of previously declared pointer types*)
WHILE k # 0 DO typtab[k].base := t; Read(R, k) END
ELSE
IF class = Const THEN
IF obj.type.form = Real THEN Files.ReadInt(R, obj.val) ELSE Files.ReadNum(R, obj.val) END
ELSIF class = Var THEN Files.ReadNum(R, obj.val); obj.rdo := TRUE
END
END ;
obj.next := thismod.dsc; thismod.dsc := obj; Read(R, class)
END ;
ELSE ORS.Mark("import not available")
END
END
END Import;
(*-------------------------------- Export ---------------------------------*)
PROCEDURE Write(VAR R: Files.Rider; x: INTEGER);
BEGIN
(*Files.WriteByte(R, x)*)
Files.WriteByte(R, SHORT(SHORT(x))) (* voc adaptation by noch *)
END Write;
PROCEDURE OutType(VAR R: Files.Rider; t: Type);
VAR obj, mod, fld: Object;
PROCEDURE OutPar(VAR R: Files.Rider; par: Object; n: INTEGER);
VAR cl: INTEGER;
BEGIN
IF n > 0 THEN
OutPar(R, par.next, n-1); cl := par.class;
Write(R, cl);
IF par.rdo THEN Write(R, 1) ELSE Write(R, 0) END ;
OutType(R, par.type)
END
END OutPar;
PROCEDURE FindHiddenPointers(VAR R: Files.Rider; typ: Type; offset: LONGINT);
VAR fld: Object; i, n: LONGINT;
BEGIN
IF (typ.form = Pointer) OR (typ.form = NilTyp) THEN Write(R, Fld); Write(R, 0); Files.WriteNum(R, offset)
ELSIF typ.form = Record THEN fld := typ.dsc;
WHILE fld # NIL DO FindHiddenPointers(R, fld.type, fld.val + offset); fld := fld.next END
ELSIF typ.form = Array THEN i := 0; n := typ.len;
WHILE i < n DO FindHiddenPointers(R, typ.base, typ.base.size * i + offset); INC(i) END
END
END FindHiddenPointers;
BEGIN
IF t.ref > 0 THEN (*type was already output*) Write(R, -t.ref)
ELSE obj := t.typobj;
IF obj # NIL THEN Write(R, Ref); t.ref := Ref; INC(Ref) ELSE (*anonymous*) Write(R, 0) END ;
Write(R, t.form);
IF t.form = Pointer THEN OutType(R, t.base)
ELSIF t.form = Array THEN OutType(R, t.base); Files.WriteNum(R, t.len); Files.WriteNum(R, t.size)
ELSIF t.form = Record THEN
IF t.base # NIL THEN OutType(R, t.base) ELSE OutType(R, noType) END ;
IF obj # NIL THEN Files.WriteNum(R, obj.exno) ELSE Write(R, 0) END ;
Files.WriteNum(R, t.nofpar); Files.WriteNum(R, t.size);
fld := t.dsc;
WHILE fld # NIL DO (*fields*)
IF fld.expo THEN
Write(R, Fld); Files.WriteString(R, fld.name); OutType(R, fld.type); Files.WriteNum(R, fld.val)
ELSE FindHiddenPointers(R, fld.type, fld.val) (*offset*)
END ;
fld := fld.next
END ;
Write(R, 0)
ELSIF t.form = Proc THEN OutType(R, t.base); OutPar(R, t.dsc, t.nofpar); Write(R, 0)
END ;
IF (t.mno > 0) & (obj # NIL) THEN (*re-export, output name*)
mod := topScope.next;
WHILE (mod # NIL) & (mod.lev # t.mno) DO mod := mod.next END ;
IF mod # NIL THEN Files.WriteString(R, mod.name); Files.WriteInt(R, mod.val); Files.WriteString(R, obj.name)
ELSE ORS.Mark("re-export not found"); Write(R, 0)
END
ELSE Write(R, 0)
END
END
END OutType;
PROCEDURE Export*(VAR modid: ORS.Ident; VAR newSF: BOOLEAN; VAR key: LONGINT);
VAR x, sum, oldkey: LONGINT;
obj, obj0: Object;
filename: ORS.Ident;
F, F1: Files.File; R, R1: Files.Rider;
BEGIN Ref := Record + 1; MakeFileName(filename, modid, ".smb");
F := Files.New(filename); Files.Set(R, F, 0);
Files.WriteInt(R, 0); (*placeholder*)
Files.WriteInt(R, 0); (*placeholder for key to be inserted at the end*)
Files.WriteString(R, modid); Write(R, versionkey);
obj := topScope.next;
WHILE obj # NIL DO
IF obj.expo THEN
Write(R, obj.class); Files.WriteString(R, obj.name);
OutType(R, obj.type);
IF obj.class = Typ THEN
IF obj.type.form = Record THEN
obj0 := topScope.next; (*check whether this is base of previously declared pointer types*)
WHILE obj0 # obj DO
IF (obj0.type.form = Pointer) & (obj0.type.base = obj.type) & (obj0.type.ref > 0) THEN Write(R, obj0.type.ref) END ;
obj0 := obj0.next
END
END ;
Write(R, 0)
ELSIF obj.class = Const THEN
IF obj.type.form = Proc THEN Files.WriteNum(R, obj.exno)
ELSIF obj.type.form = Real THEN Files.WriteInt(R, obj.val)
ELSE Files.WriteNum(R, obj.val)
END
ELSIF obj.class = Var THEN
Files.WriteNum(R, obj.exno);
IF obj.type.form = String THEN
Files.WriteNum(R, obj.val DIV 10000H); obj.val := obj.val MOD 10000H
END
END
END ;
obj := obj.next
END ;
REPEAT Write(R, 0) UNTIL Files.Length(F) MOD 4 = 0;
FOR Ref := Record+1 TO maxTypTab-1 DO typtab[Ref] := NIL END ;
Files.Set(R, F, 0); sum := 0; Files.ReadInt(R, x); (* compute key (checksum) *)
WHILE ~R.eof DO sum := sum + x; Files.ReadInt(R, x) END ;
F1 := Files.Old(filename); (*sum is new key*)
IF F1 # NIL THEN Files.Set(R1, F1, 4); Files.ReadInt(R1, oldkey) ELSE oldkey := sum+1 END ;
IF sum # oldkey THEN
IF newSF OR (F1 = NIL) THEN
key := sum; newSF := TRUE; Files.Set(R, F, 4); Files.WriteInt(R, sum); Files.Register(F) (*insert checksum*)
ELSE ORS.Mark("new symbol file inhibited")
END
ELSE newSF := FALSE; key := sum
END
END Export;
PROCEDURE Init*;
BEGIN topScope := universe; nofmod := 1
END Init;
PROCEDURE type(ref, form: INTEGER; size: LONGINT): Type;
VAR tp: Type;
BEGIN NEW(tp); tp.form := form; tp.size := size; tp.ref := ref; tp.base := NIL;
typtab[ref] := tp; RETURN tp
END type;
PROCEDURE enter(name: ARRAY OF CHAR; cl: INTEGER; type: Type; n: LONGINT);
VAR obj: Object;
BEGIN
NEW(obj);
(*obj.name := name; *)
COPY(name, obj.name); (* voc adaptation by noch *)
obj.class := cl;
obj.type := type;
obj.val := n;
obj.dsc := NIL;
IF cl = Typ THEN type.typobj := obj END ;
obj.next := system; system := obj
END enter;
BEGIN
byteType := type(Byte, Int, 1);
boolType := type(Bool, Bool, 1);
charType := type(Char, Char,1);
intType := type(Int, Int, 4);
realType := type(Real, Real, 4);
setType := type(Set, Set,4);
nilType := type(NilTyp, NilTyp, 4);
noType := type(NoTyp, NoTyp, 4);
strType := type(String, String, 8);
(*initialize universe with data types and in-line procedures;
LONGINT is synonym to INTEGER, LONGREAL to REAL.
LED, ADC, SBC; LDPSR, LDREG, REG, COND are not in language definition*)
system := NIL; (*n = procno*10 + nofpar*)
enter("UML", SFunc, intType, 132); (*functions*)
enter("SBC", SFunc, intType, 122);
enter("ADC", SFunc, intType, 112);
enter("ROR", SFunc, intType, 92);
enter("ASR", SFunc, intType, 82);
enter("LSL", SFunc, intType, 72);
enter("LEN", SFunc, intType, 61);
enter("CHR", SFunc, charType, 51);
enter("ORD", SFunc, intType, 41);
enter("FLT", SFunc, realType, 31);
enter("FLOOR", SFunc, intType, 21);
enter("ODD", SFunc, boolType, 11);
enter("ABS", SFunc, intType, 1);
enter("LED", SProc, noType, 81); (*procedures*)
enter("UNPK", SProc, noType, 72);
enter("PACK", SProc, noType, 62);
enter("NEW", SProc, noType, 51);
enter("ASSERT", SProc, noType, 41);
enter("EXCL", SProc, noType, 32);
enter("INCL", SProc, noType, 22);
enter("DEC", SProc, noType, 11);
enter("INC", SProc, noType, 1);
enter("SET", Typ, setType, 0); (*types*)
enter("BOOLEAN", Typ, boolType, 0);
enter("BYTE", Typ, byteType, 0);
enter("CHAR", Typ, charType, 0);
enter("LONGREAL", Typ, realType, 0);
enter("REAL", Typ, realType, 0);
enter("LONGINT", Typ, intType, 0);
enter("INTEGER", Typ, intType, 0);
topScope := NIL; OpenScope; topScope.next := system; universe := topScope;
system := NIL; (* initialize "unsafe" pseudo-module SYSTEM*)
enter("H", SFunc, intType, 201); (*functions*)
enter("COND", SFunc, boolType, 191);
enter("SIZE", SFunc, intType, 181);
enter("ADR", SFunc, intType, 171);
enter("VAL", SFunc, intType, 162);
enter("REG", SFunc, intType, 151);
enter("BIT", SFunc, boolType, 142);
enter("LDREG", SProc, noType, 142); (*procedures*)
enter("LDPSR", SProc, noType, 131);
enter("COPY", SProc, noType, 123);
enter("PUT", SProc, noType, 112);
enter("GET", SProc, noType, 102);
END ORB.

1134
src/voc07R/ORG.Mod
View file

File diff suppressed because it is too large Load diff

997
src/voc07R/ORP.Mod
View file

@ -1,997 +0,0 @@
MODULE ORP; (*N. Wirth 1.7.97 / 7.6.2014 Oberon compiler for RISC in Oberon-07*)
IMPORT Texts := CompatTexts, Oberon, ORS, ORB, ORG;
(*Author: Niklaus Wirth, 2014.
Parser of Oberon-RISC compiler. Uses Scanner ORS to obtain symbols (tokens),
ORB for definition of data structures and for handling import and export, and
ORG to produce binary code. ORP performs type checking and data allocation.
Parser is target-independent, except for part of the handling of allocations.*)
TYPE INTEGER = LONGINT; (* voc adaptation by noch *)
TYPE PtrBase = POINTER TO PtrBaseDesc;
PtrBaseDesc = RECORD (*list of names of pointer base types*)
name: ORS.Ident; type: ORB.Type; next: PtrBase
END ;
VAR sym: INTEGER; (*last symbol read*)
dc: LONGINT; (*data counter*)
level, exno, version: INTEGER;
newSF: BOOLEAN; (*option flag*)
expression: PROCEDURE (VAR x: ORG.Item); (*to avoid forward reference*)
Type: PROCEDURE (VAR type: ORB.Type);
FormalType: PROCEDURE (VAR typ: ORB.Type; dim: INTEGER);
modid: ORS.Ident;
pbsList: PtrBase; (*list of names of pointer base types*)
dummy: ORB.Object;
W: Texts.Writer;
PROCEDURE Check(s: INTEGER; msg: ARRAY OF CHAR);
BEGIN
IF sym = s THEN ORS.Get(sym) ELSE ORS.Mark(msg) END
END Check;
PROCEDURE qualident(VAR obj: ORB.Object);
BEGIN obj := ORB.thisObj(); ORS.Get(sym);
IF obj = NIL THEN ORS.Mark("undef"); obj := dummy END ;
IF (sym = ORS.period) & (obj.class = ORB.Mod) THEN
ORS.Get(sym);
IF sym = ORS.ident THEN obj := ORB.thisimport(obj); ORS.Get(sym);
IF obj = NIL THEN ORS.Mark("undef"); obj := dummy END
ELSE ORS.Mark("identifier expected"); obj := dummy
END
END
END qualident;
PROCEDURE CheckBool(VAR x: ORG.Item);
BEGIN
IF x.type.form # ORB.Bool THEN ORS.Mark("not Boolean"); x.type := ORB.boolType END
END CheckBool;
PROCEDURE CheckInt(VAR x: ORG.Item);
BEGIN
IF x.type.form # ORB.Int THEN ORS.Mark("not Integer"); x.type := ORB.intType END
END CheckInt;
PROCEDURE CheckReal(VAR x: ORG.Item);
BEGIN
IF x.type.form # ORB.Real THEN ORS.Mark("not Real"); x.type := ORB.realType END
END CheckReal;
PROCEDURE CheckSet(VAR x: ORG.Item);
BEGIN
IF x.type.form # ORB.Set THEN ORS.Mark("not Set"); x.type := ORB.setType END
END CheckSet;
PROCEDURE CheckSetVal(VAR x: ORG.Item);
BEGIN
IF x.type.form # ORB.Int THEN ORS.Mark("not Int"); x.type := ORB.setType
ELSIF x.mode = ORB.Const THEN
IF (x.a < 0) OR (x.a >= 32) THEN ORS.Mark("invalid set") END
END
END CheckSetVal;
PROCEDURE CheckConst(VAR x: ORG.Item);
BEGIN
IF x.mode # ORB.Const THEN ORS.Mark("not a constant"); x.mode := ORB.Const END
END CheckConst;
PROCEDURE CheckReadOnly(VAR x: ORG.Item);
BEGIN
IF x.rdo THEN ORS.Mark("read-only") END
END CheckReadOnly;
PROCEDURE CheckExport(VAR expo: BOOLEAN);
BEGIN
IF sym = ORS.times THEN
expo := TRUE; ORS.Get(sym);
IF level # 0 THEN ORS.Mark("remove asterisk") END
ELSE expo := FALSE
END
END CheckExport;
PROCEDURE IsExtension(t0, t1: ORB.Type): BOOLEAN;
BEGIN (*t1 is an extension of t0*)
RETURN (t0 = t1) OR (t1 # NIL) & IsExtension(t0, t1.base)
END IsExtension;
(* expressions *)
PROCEDURE TypeTest(VAR x: ORG.Item; T: ORB.Type; guard: BOOLEAN);
VAR xt: ORB.Type;
BEGIN xt := x.type;
WHILE (xt # T) & (xt # NIL) DO xt := xt.base END ;
IF xt # T THEN xt := x.type;
IF (xt.form = ORB.Pointer) & (T.form = ORB.Pointer) THEN
IF IsExtension(xt.base, T.base) THEN ORG.TypeTest(x, T.base, FALSE, guard); x.type := T
ELSE ORS.Mark("not an extension")
END
ELSIF (xt.form = ORB.Record) & (T.form = ORB.Record) & (x.mode = ORB.Par) THEN
IF IsExtension(xt, T) THEN ORG.TypeTest(x, T, TRUE, guard); x.type := T
ELSE ORS.Mark("not an extension")
END
ELSE ORS.Mark("incompatible types")
END
ELSIF ~guard THEN ORG.MakeConstItem(x, ORB.boolType, 1)
END ;
IF ~guard THEN x.type := ORB.boolType END
END TypeTest;
PROCEDURE selector(VAR x: ORG.Item);
VAR y: ORG.Item; obj: ORB.Object;
BEGIN
WHILE (sym = ORS.lbrak) OR (sym = ORS.period) OR (sym = ORS.arrow)
OR (sym = ORS.lparen) & (x.type.form IN {ORB.Record, ORB.Pointer}) DO
IF sym = ORS.lbrak THEN
REPEAT ORS.Get(sym); expression(y);
IF x.type.form = ORB.Array THEN
CheckInt(y); ORG.Index(x, y); x.type := x.type.base
ELSE ORS.Mark("not an array")
END
UNTIL sym # ORS.comma;
Check(ORS.rbrak, "no ]")
ELSIF sym = ORS.period THEN ORS.Get(sym);
IF sym = ORS.ident THEN
IF x.type.form = ORB.Pointer THEN ORG.DeRef(x); x.type := x.type.base END ;
IF x.type.form = ORB.Record THEN
obj := ORB.thisfield(x.type); ORS.Get(sym);
IF obj # NIL THEN ORG.Field(x, obj); x.type := obj.type
ELSE ORS.Mark("undef")
END
ELSE ORS.Mark("not a record")
END
ELSE ORS.Mark("ident?")
END
ELSIF sym = ORS.arrow THEN
ORS.Get(sym);
IF x.type.form = ORB.Pointer THEN ORG.DeRef(x); x.type := x.type.base
ELSE ORS.Mark("not a pointer")
END
ELSIF (sym = ORS.lparen) & (x.type.form IN {ORB.Record, ORB.Pointer}) THEN (*type guard*)
ORS.Get(sym);
IF sym = ORS.ident THEN
qualident(obj);
IF obj.class = ORB.Typ THEN TypeTest(x, obj.type, TRUE)
ELSE ORS.Mark("guard type expected")
END
ELSE ORS.Mark("not an identifier")
END ;
Check(ORS.rparen, " ) missing")
END
END
END selector;
PROCEDURE CompTypes(t0, t1: ORB.Type; varpar: BOOLEAN): BOOLEAN;
PROCEDURE EqualSignatures(t0, t1: ORB.Type): BOOLEAN;
VAR p0, p1: ORB.Object; com: BOOLEAN;
BEGIN com := TRUE;
IF (t0.base = t1.base) & (t0.nofpar = t1.nofpar) THEN
p0 := t0.dsc; p1 := t1.dsc;
WHILE p0 # NIL DO
IF (p0.class = p1.class) & CompTypes(p0.type, p1.type, TRUE) &
(*(ORD(p0.rdo) = ORD(p1.rdo))*)
(p0.rdo = p1.rdo) (* voc adaptation by noch *)
THEN
IF p0.type.form >= ORB.Array THEN com := CompTypes(p0.type, p1.type, (p0.class = ORB.Par)) END ;
p0 := p0.next; p1 := p1.next
ELSE p0 := NIL; com := FALSE
END
END
ELSE com := FALSE
END ;
RETURN com
END EqualSignatures;
BEGIN (*Compatible Types*)
RETURN (t0 = t1)
OR (t0.form = ORB.Array) & (t1.form = ORB.Array) & CompTypes(t0.base, t1.base, varpar)
OR (t0.form = ORB.Pointer) & (t1.form = ORB.Pointer) & IsExtension(t0.base, t1.base)
OR (t0.form = ORB.Record) & (t1.form = ORB.Record) & IsExtension(t0, t1)
OR (t0.form = ORB.Proc) & (t1.form = ORB.Proc) & EqualSignatures(t0, t1)
OR (t0.form IN {ORB.Pointer, ORB.Proc}) & (t1.form = ORB.NilTyp)
OR (t0.form = ORB.NilTyp) & (t1.form IN {ORB.Pointer, ORB.Proc})
OR ~varpar & (t0.form = ORB.Int) & (t1.form = ORB.Int)
END CompTypes;
PROCEDURE Parameter(par: ORB.Object);
VAR x: ORG.Item; varpar: BOOLEAN;
BEGIN expression(x);
IF par # NIL THEN
varpar := par.class = ORB.Par;
IF CompTypes(par.type, x.type, varpar) THEN
IF ~varpar THEN ORG.ValueParam(x)
ELSE (*par.class = Par*)
IF ~par.rdo THEN CheckReadOnly(x) END ;
ORG.VarParam(x, par.type)
END
ELSIF ~varpar & (par.type.form = ORB.Int) & (x.type.form = ORB.Int) THEN
ORG.ValueParam(x)
ELSIF (x.type.form = ORB.String) & (x.b = 2) & (par.class = ORB.Var) & (par.type.form = ORB.Char) THEN
ORG.StrToChar(x); ORG.ValueParam(x)
ELSIF (x.type.form = ORB.Array) & (par.type.form = ORB.Array) &
(x.type.base.form = par.type.base.form) & (par.type.len < 0) THEN
ORG.OpenArrayParam(x);
ELSIF (x.type.form = ORB.String) & varpar & par.rdo & (par.type.form = ORB.Array) &
(par.type.base.form = ORB.Char) & (par.type.len < 0) THEN ORG.StringParam(x)
ELSIF (par.type.form = ORB.Array) & (par.type.base.form = ORB.Int) & (par.type.size = x.type.size) THEN
ORG.VarParam(x, par.type)
ELSE ORS.Mark("incompatible parameters")
END
END
END Parameter;
PROCEDURE ParamList(VAR x: ORG.Item);
VAR n: INTEGER; par: ORB.Object;
BEGIN par := x.type.dsc; n := 0;
IF sym # ORS.rparen THEN
Parameter(par); n := 1;
WHILE sym <= ORS.comma DO
Check(sym, "comma?");
IF par # NIL THEN par := par.next END ;
INC(n); Parameter(par)
END ;
Check(ORS.rparen, ") missing")
ELSE ORS.Get(sym);
END ;
IF n < x.type.nofpar THEN ORS.Mark("too few params")
ELSIF n > x.type.nofpar THEN ORS.Mark("too many params")
END
END ParamList;
PROCEDURE StandFunc(VAR x: ORG.Item; fct: LONGINT; restyp: ORB.Type);
VAR y: ORG.Item; n, npar: LONGINT;
BEGIN Check(ORS.lparen, "no (");
npar := fct MOD 10; fct := fct DIV 10; expression(x); n := 1;
WHILE sym = ORS.comma DO ORS.Get(sym); expression(y); INC(n) END ;
Check(ORS.rparen, "no )");
IF n = npar THEN
IF fct = 0 THEN (*ABS*)
IF x.type.form IN {ORB.Int, ORB.Real} THEN ORG.Abs(x); restyp := x.type ELSE ORS.Mark("bad type") END
ELSIF fct = 1 THEN (*ODD*) CheckInt(x); ORG.Odd(x)
ELSIF fct = 2 THEN (*FLOOR*) CheckReal(x); ORG.Floor(x)
ELSIF fct = 3 THEN (*FLT*) CheckInt(x); ORG.Float(x)
ELSIF fct = 4 THEN (*ORD*)
IF x.type.form <= ORB.Proc THEN ORG.Ord(x)
ELSIF (x.type.form = ORB.String) & (x.b = 2) THEN ORG.StrToChar(x)
ELSE ORS.Mark("bad type")
END
ELSIF fct = 5 THEN (*CHR*) CheckInt(x); ORG.Ord(x)
ELSIF fct = 6 THEN (*LEN*)
IF x.type.form = ORB.Array THEN ORG.Len(x) ELSE ORS.Mark("not an array") END
ELSIF fct IN {7, 8, 9} THEN (*LSL, ASR, ROR*) CheckInt(y);
IF x.type.form IN {ORB.Int, ORB.Set} THEN ORG.Shift(fct-7, x, y); restyp := x.type ELSE ORS.Mark("bad type") END
ELSIF fct = 11 THEN (*ADC*) ORG.ADC(x, y)
ELSIF fct = 12 THEN (*SBC*) ORG.SBC(x, y)
ELSIF fct = 13 THEN (*UML*) ORG.UML(x, y)
ELSIF fct = 14 THEN (*BIT*) CheckInt(x); CheckInt(y); ORG.Bit(x, y)
ELSIF fct = 15 THEN (*REG*) CheckConst(x); CheckInt(x); ORG.Register(x)
ELSIF fct = 16 THEN (*VAL*)
IF (x.mode= ORB.Typ) & (x.type.size <= y.type.size) THEN restyp := x.type; x := y
ELSE ORS.Mark("casting not allowed")
END
ELSIF fct = 17 THEN (*ADR*) ORG.Adr(x)
ELSIF fct = 18 THEN (*SIZE*)
IF x.mode = ORB.Typ THEN ORG.MakeConstItem(x, ORB.intType, x.type.size)
ELSE ORS.Mark("must be a type")
END
ELSIF fct = 19 THEN (*COND*) CheckConst(x); CheckInt(x); ORG.Condition(x)
ELSIF fct = 20 THEN (*H*) CheckConst(x); CheckInt(x); ORG.H(x)
END ;
x.type := restyp
ELSE ORS.Mark("wrong nof params")
END
END StandFunc;
PROCEDURE element(VAR x: ORG.Item);
VAR y: ORG.Item;
BEGIN expression(x); CheckSetVal(x);
IF sym = ORS.upto THEN ORS.Get(sym); expression(y); CheckSetVal(y); ORG.Set(x, y)
ELSE ORG.Singleton(x)
END ;
x.type := ORB.setType
END element;
PROCEDURE set(VAR x: ORG.Item);
VAR y: ORG.Item;
BEGIN
IF sym >= ORS.if THEN
IF sym # ORS.rbrace THEN ORS.Mark(" } missing") END ;
ORG.MakeConstItem(x, ORB.setType, 0) (*empty set*)
ELSE element(x);
WHILE (sym < ORS.rparen) OR (sym > ORS.rbrace) DO
IF sym = ORS.comma THEN ORS.Get(sym)
ELSIF sym # ORS.rbrace THEN ORS.Mark("missing comma")
END ;
element(y); ORG.SetOp(ORS.plus, x, y)
END
END
END set;
PROCEDURE factor(VAR x: ORG.Item);
VAR obj: ORB.Object; rx: LONGINT;
BEGIN (*sync*)
IF (sym < ORS.char) OR (sym > ORS.ident) THEN ORS.Mark("expression expected");
REPEAT ORS.Get(sym) UNTIL (sym >= ORS.char) & (sym <= ORS.ident)
END ;
IF sym = ORS.ident THEN
qualident(obj);
IF obj.class = ORB.SFunc THEN StandFunc(x, obj.val, obj.type)
ELSE ORG.MakeItem(x, obj, level); selector(x);
IF sym = ORS.lparen THEN
ORS.Get(sym);
IF (x.type.form = ORB.Proc) & (x.type.base.form # ORB.NoTyp) THEN
ORG.PrepCall(x, rx); ParamList(x); ORG.Call(x, rx); x.type := x.type.base
ELSE ORS.Mark("not a function"); ParamList(x)
END
END
END
ELSIF sym = ORS.int THEN ORG.MakeConstItem(x, ORB.intType, ORS.ival); ORS.Get(sym)
ELSIF sym = ORS.real THEN ORG.MakeRealItem(x, ORS.rval); ORS.Get(sym)
ELSIF sym = ORS.char THEN ORG.MakeConstItem(x, ORB.charType, ORS.ival); ORS.Get(sym)
ELSIF sym = ORS.nil THEN ORS.Get(sym); ORG.MakeConstItem(x, ORB.nilType, 0)
ELSIF sym = ORS.string THEN ORG.MakeStringItem(x, ORS.slen); ORS.Get(sym)
ELSIF sym = ORS.lparen THEN ORS.Get(sym); expression(x); Check(ORS.rparen, "no )")
ELSIF sym = ORS.lbrace THEN ORS.Get(sym); set(x); Check(ORS.rbrace, "no }")
ELSIF sym = ORS.not THEN ORS.Get(sym); factor(x); CheckBool(x); ORG.Not(x)
ELSIF sym = ORS.false THEN ORS.Get(sym); ORG.MakeConstItem(x, ORB.boolType, 0)
ELSIF sym = ORS.true THEN ORS.Get(sym); ORG.MakeConstItem(x, ORB.boolType, 1)
ELSE ORS.Mark("not a factor"); ORG.MakeItem(x, NIL, level)
END
END factor;
PROCEDURE term(VAR x: ORG.Item);
VAR y: ORG.Item; op, f: INTEGER;
BEGIN factor(x); f := x.type.form;
WHILE (sym >= ORS.times) & (sym <= ORS.and) DO
op := sym; ORS.Get(sym);
IF op = ORS.times THEN
IF f = ORB.Int THEN factor(y); CheckInt(y); ORG.MulOp(x, y)
ELSIF f = ORB.Real THEN factor(y); CheckReal(y); ORG.RealOp(op, x, y)
ELSIF f = ORB.Set THEN factor(y); CheckSet(y); ORG.SetOp(op, x, y)
ELSE ORS.Mark("bad type")
END
ELSIF (op = ORS.div) OR (op = ORS.mod) THEN
CheckInt(x); factor(y); CheckInt(y); ORG.DivOp(op, x, y)
ELSIF op = ORS.rdiv THEN
IF f = ORB.Real THEN factor(y); CheckReal(y); ORG.RealOp(op, x, y)
ELSIF f = ORB.Set THEN factor(y); CheckSet(y); ORG.SetOp(op, x, y)
ELSE ORS.Mark("bad type")
END
ELSE (*op = and*) CheckBool(x); ORG.And1(x); factor(y); CheckBool(y); ORG.And2(x, y)
END
END
END term;
PROCEDURE SimpleExpression(VAR x: ORG.Item);
VAR y: ORG.Item; op: INTEGER;
BEGIN
IF sym = ORS.minus THEN ORS.Get(sym); term(x);
IF x.type.form IN {ORB.Int, ORB.Real, ORB.Set} THEN ORG.Neg(x) ELSE CheckInt(x) END
ELSIF sym = ORS.plus THEN ORS.Get(sym); term(x);
ELSE term(x)
END ;
WHILE (sym >= ORS.plus) & (sym <= ORS.or) DO
op := sym; ORS.Get(sym);
IF op = ORS.or THEN ORG.Or1(x); CheckBool(x); term(y); CheckBool(y); ORG.Or2(x, y)
ELSIF x.type.form = ORB.Int THEN term(y); CheckInt(y); ORG.AddOp(op, x, y)
ELSIF x.type.form = ORB.Real THEN term(y); CheckReal(y); ORG.RealOp(op, x, y)
ELSE CheckSet(x); term(y); CheckSet(y); ORG.SetOp(op, x, y)
END
END
END SimpleExpression;
PROCEDURE expression0(VAR x: ORG.Item);
VAR y: ORG.Item; obj: ORB.Object; rel, xf, yf: INTEGER;
BEGIN SimpleExpression(x);
IF (sym >= ORS.eql) & (sym <= ORS.geq) THEN
rel := sym; ORS.Get(sym); SimpleExpression(y); xf := x.type.form; yf := y.type.form;
IF CompTypes(x.type, y.type, FALSE) OR
(xf = ORB.Pointer) & (yf = ORB.Pointer) & IsExtension(y.type.base, x.type.base) THEN
IF (xf IN {ORB.Char, ORB.Int}) THEN ORG.IntRelation(rel, x, y)
ELSIF xf = ORB.Real THEN ORG.RealRelation(rel, x, y)
ELSIF xf = ORB.Set THEN ORG.SetRelation(rel, x, y)
ELSIF (xf IN {ORB.Pointer, ORB.Proc, ORB.NilTyp}) THEN
IF rel <= ORS.neq THEN ORG.IntRelation(rel, x, y) ELSE ORS.Mark("only = or #") END
ELSIF (xf = ORB.Array) & (x.type.base.form = ORB.Char) OR (xf = ORB.String) THEN
ORG.StringRelation(rel, x, y)
ELSE ORS.Mark("illegal comparison")
END
ELSIF (xf = ORB.Array) & (x.type.base.form = ORB.Char) &
((yf = ORB.String) OR (yf = ORB.Array) & (y.type.base.form = ORB.Char))
OR (yf = ORB.Array) & (y.type.base.form = ORB.Char) & (xf = ORB.String) THEN
ORG.StringRelation(rel, x, y)
ELSIF (xf = ORB.Char) & (yf = ORB.String) & (y.b = 2) THEN
ORG.StrToChar(y); ORG.IntRelation(rel, x, y)
ELSIF (yf = ORB.Char) & (xf = ORB.String) & (x.b = 2) THEN
ORG.StrToChar(x); ORG.IntRelation(rel, x, y)
ELSE ORS.Mark("illegal comparison")
END ;
x.type := ORB.boolType
ELSIF sym = ORS.in THEN
ORS.Get(sym); SimpleExpression(y);
IF (x.type.form = ORB.Int) & (y.type.form = ORB.Set) THEN ORG.In(x, y)
ELSE ORS.Mark("illegal operands of IN")
END ;
x.type := ORB.boolType
ELSIF sym = ORS.is THEN
ORS.Get(sym); qualident(obj); TypeTest(x, obj.type, FALSE) ;
x.type := ORB.boolType
END
END expression0;
(* statements *)
PROCEDURE StandProc(pno: LONGINT);
VAR nap, npar: LONGINT; (*nof actual/formal parameters*)
x, y, z: ORG.Item;
BEGIN Check(ORS.lparen, "no (");
npar := pno MOD 10; pno := pno DIV 10; expression(x); nap := 1;
IF sym = ORS.comma THEN
ORS.Get(sym); expression(y); nap := 2; z.type := ORB.noType;
WHILE sym = ORS.comma DO ORS.Get(sym); expression(z); INC(nap) END
ELSE y.type := ORB.noType
END ;
Check(ORS.rparen, "no )");
IF (npar = nap) OR (pno IN {0, 1}) THEN
IF pno IN {0, 1} THEN (*INC, DEC*)
CheckInt(x); CheckReadOnly(x);
IF y.type # ORB.noType THEN CheckInt(y) END ;
ORG.Increment(pno, x, y)
ELSIF pno IN {2, 3} THEN (*INCL, EXCL*)
CheckSet(x); CheckReadOnly(x); CheckInt(y); ORG.Include(pno-2, x, y)
ELSIF pno = 4 THEN CheckBool(x); ORG.Assert(x)
ELSIF pno = 5 THEN(*NEW*) CheckReadOnly(x);
IF (x.type.form = ORB.Pointer) & (x.type.base.form = ORB.Record) THEN ORG.New(x)
ELSE ORS.Mark("not a pointer to record")
END
ELSIF pno = 6 THEN CheckReal(x); CheckInt(y); CheckReadOnly(x); ORG.Pack(x, y)
ELSIF pno = 7 THEN CheckReal(x); CheckInt(y); CheckReadOnly(x); ORG.Unpk(x, y)
ELSIF pno = 8 THEN
IF x.type.form <= ORB.Set THEN ORG.Led(x) ELSE ORS.Mark("bad type") END
ELSIF pno = 10 THEN CheckInt(x); ORG.Get(x, y)
ELSIF pno = 11 THEN CheckInt(x); ORG.Put(x, y)
ELSIF pno = 12 THEN CheckInt(x); CheckInt(y); CheckInt(z); ORG.Copy(x, y, z)
ELSIF pno = 13 THEN CheckConst(x); CheckInt(x); ORG.LDPSR(x)
ELSIF pno = 14 THEN CheckInt(x); ORG.LDREG(x, y)
END
ELSE ORS.Mark("wrong nof parameters")
END
END StandProc;
PROCEDURE StatSequence;
VAR obj: ORB.Object;
orgtype: ORB.Type; (*original type of case var*)
x, y, z, w: ORG.Item;
L0, L1, rx: LONGINT;
PROCEDURE TypeCase(obj: ORB.Object; VAR x: ORG.Item);
VAR typobj: ORB.Object;
BEGIN
IF sym = ORS.ident THEN
qualident(typobj); ORG.MakeItem(x, obj, level);
IF typobj.class # ORB.Typ THEN ORS.Mark("not a type") END ;
TypeTest(x, typobj.type, FALSE); obj.type := typobj.type;
ORG.CFJump(x); Check(ORS.colon, ": expected"); StatSequence
ELSE ORG.CFJump(x); ORS.Mark("type id expected")
END
END TypeCase;
PROCEDURE SkipCase;
BEGIN
WHILE sym # ORS.colon DO ORS.Get(sym) END ;
ORS.Get(sym); StatSequence
END SkipCase;
BEGIN (* StatSequence *)
REPEAT (*sync*) obj := NIL;
IF ~((sym = ORS.ident) OR (sym >= ORS.if) & (sym <= ORS.for) OR (sym >= ORS.semicolon)) THEN
ORS.Mark("statement expected");
REPEAT ORS.Get(sym) UNTIL (sym = ORS.ident) OR (sym >= ORS.if)
END ;
IF sym = ORS.ident THEN
qualident(obj); ORG.MakeItem(x, obj, level);
IF x.mode = ORB.SProc THEN StandProc(obj.val)
ELSE selector(x);
IF sym = ORS.becomes THEN (*assignment*)
ORS.Get(sym); CheckReadOnly(x); expression(y);
IF CompTypes(x.type, y.type, FALSE) OR (x.type.form = ORB.Int) & (y.type.form = ORB.Int) THEN
IF (x.type.form <= ORB.Pointer) OR (x.type.form = ORB.Proc) THEN ORG.Store(x, y)
ELSIF y.type.size # 0 THEN ORG.StoreStruct(x, y)
END
ELSIF (x.type.form = ORB.Char) & (y.type.form = ORB.String) & (y.b = 2) THEN
ORG.StrToChar(y); ORG.Store(x, y)
ELSIF (x.type.form = ORB.Array) & (x.type.base.form = ORB.Char) &
(y.type.form = ORB.String) THEN ORG.CopyString(y, x)
ELSE ORS.Mark("illegal assignment")
END
ELSIF sym = ORS.eql THEN ORS.Mark("should be :="); ORS.Get(sym); expression(y)
ELSIF sym = ORS.lparen THEN (*procedure call*)
ORS.Get(sym);
IF (x.type.form = ORB.Proc) & (x.type.base.form = ORB.NoTyp) THEN
ORG.PrepCall(x, rx); ParamList(x); ORG.Call(x, rx)
ELSE ORS.Mark("not a procedure"); ParamList(x)
END
ELSIF x.type.form = ORB.Proc THEN (*procedure call without parameters*)
IF x.type.nofpar > 0 THEN ORS.Mark("missing parameters") END ;
IF x.type.base.form = ORB.NoTyp THEN ORG.PrepCall(x, rx); ORG.Call(x, rx) ELSE ORS.Mark("not a procedure") END
ELSIF x.mode = ORB.Typ THEN ORS.Mark("illegal assignment")
ELSE ORS.Mark("not a procedure")
END
END
ELSIF sym = ORS.if THEN
ORS.Get(sym); expression(x); CheckBool(x); ORG.CFJump(x);
Check(ORS.then, "no THEN");
StatSequence; L0 := 0;
WHILE sym = ORS.elsif DO
ORS.Get(sym); ORG.FJump(L0); ORG.Fixup(x); expression(x); CheckBool(x);
ORG.CFJump(x); Check(ORS.then, "no THEN"); StatSequence
END ;
IF sym = ORS.else THEN ORS.Get(sym); ORG.FJump(L0); ORG.Fixup(x); StatSequence
ELSE ORG.Fixup(x)
END ;
ORG.FixLink(L0); Check(ORS.end, "no END")
ELSIF sym = ORS.while THEN
ORS.Get(sym); L0 := ORG.Here(); expression(x); CheckBool(x); ORG.CFJump(x);
Check(ORS.do, "no DO"); StatSequence; ORG.BJump(L0);
WHILE sym = ORS.elsif DO
ORS.Get(sym); ORG.Fixup(x); expression(x); CheckBool(x); ORG.CFJump(x);
Check(ORS.do, "no DO"); StatSequence; ORG.BJump(L0)
END ;
ORG.Fixup(x); Check(ORS.end, "no END")
ELSIF sym = ORS.repeat THEN
ORS.Get(sym); L0 := ORG.Here(); StatSequence;
IF sym = ORS.until THEN
ORS.Get(sym); expression(x); CheckBool(x); ORG.CBJump(x, L0)
ELSE ORS.Mark("missing UNTIL")
END
ELSIF sym = ORS.for THEN
ORS.Get(sym);
IF sym = ORS.ident THEN
qualident(obj); ORG.MakeItem(x, obj, level); CheckInt(x); CheckReadOnly(x);
IF sym = ORS.becomes THEN
ORS.Get(sym); expression(y); CheckInt(y); ORG.For0(x, y); L0 := ORG.Here();
Check(ORS.to, "no TO"); expression(z); CheckInt(z); obj.rdo := TRUE;
IF sym = ORS.by THEN ORS.Get(sym); expression(w); CheckConst(w); CheckInt(w)
ELSE ORG.MakeConstItem(w, ORB.intType, 1)
END ;
Check(ORS.do, "no DO"); ORG.For1(x, y, z, w, L1);
StatSequence; Check(ORS.end, "no END");
ORG.For2(x, y, w); ORG.BJump(L0); ORG.FixLink(L1); obj.rdo := FALSE
ELSE ORS.Mark(":= expected")
END
ELSE ORS.Mark("identifier expected")
END
ELSIF sym = ORS.case THEN
ORS.Get(sym);
IF sym = ORS.ident THEN
qualident(obj); orgtype := obj.type;
IF (orgtype.form = ORB.Pointer) OR (orgtype.form = ORB.Record) & (obj.class = ORB.Par) THEN
Check(ORS.of, "OF expected"); TypeCase(obj, x); L0 := 0;
WHILE sym = ORS.bar DO
ORS.Get(sym); ORG.FJump(L0); ORG.Fixup(x); obj.type := orgtype; TypeCase(obj, x)
END ;
ORG.Fixup(x); ORG.FixLink(L0); obj.type := orgtype
ELSE ORS.Mark("numeric case not implemented");
Check(ORS.of, "OF expected"); SkipCase;
WHILE sym = ORS.bar DO SkipCase END
END
ELSE ORS.Mark("ident expected")
END ;
Check(ORS.end, "no END")
END ;
ORG.CheckRegs;
IF sym = ORS.semicolon THEN ORS.Get(sym)
ELSIF sym < ORS.semicolon THEN ORS.Mark("missing semicolon?")
END
UNTIL sym > ORS.semicolon
END StatSequence;
(* Types and declarations *)
PROCEDURE IdentList(class: INTEGER; VAR first: ORB.Object);
VAR obj: ORB.Object;
BEGIN
IF sym = ORS.ident THEN
ORB.NewObj(first, ORS.id, class); ORS.Get(sym); CheckExport(first.expo);
WHILE sym = ORS.comma DO
ORS.Get(sym);
IF sym = ORS.ident THEN ORB.NewObj(obj, ORS.id, class); ORS.Get(sym); CheckExport(obj.expo)
ELSE ORS.Mark("ident?")
END
END;
IF sym = ORS.colon THEN ORS.Get(sym) ELSE ORS.Mark(":?") END
ELSE first := NIL
END
END IdentList;
PROCEDURE ArrayType(VAR type: ORB.Type);
VAR x: ORG.Item; typ: ORB.Type; len: LONGINT;
BEGIN NEW(typ); typ.form := ORB.NoTyp;
IF sym = ORS.of THEN (*dynamic array*) len := -1
ELSE expression(x);
IF (x.mode = ORB.Const) & (x.type.form = ORB.Int) & (x.a >= 0) THEN len := x.a
ELSE len := 0; ORS.Mark("not a valid length")
END
END ;
IF sym = ORS.of THEN ORS.Get(sym); Type(typ.base);
IF (typ.base.form = ORB.Array) & (typ.base.len < 0) THEN ORS.Mark("dyn array not allowed") END
ELSIF sym = ORS.comma THEN ORS.Get(sym); ArrayType(typ.base)
ELSE ORS.Mark("missing OF"); typ.base := ORB.intType
END ;
IF len >= 0 THEN typ.size := (len * typ.base.size + 3) DIV 4 * 4 ELSE typ.size := 2*ORG.WordSize (*array desc*) END ;
typ.form := ORB.Array; typ.len := len; type := typ
END ArrayType;
PROCEDURE RecordType(VAR type: ORB.Type);
VAR obj, obj0, new, bot, base: ORB.Object;
typ, tp: ORB.Type;
offset, off, n: LONGINT;
BEGIN NEW(typ); typ.form := ORB.NoTyp; typ.base := NIL; typ.mno := -level; typ.nofpar := 0; offset := 0; bot := NIL;
IF sym = ORS.lparen THEN
ORS.Get(sym); (*record extension*)
IF level # 0 THEN ORS.Mark("extension of local types not implemented") END ;
IF sym = ORS.ident THEN
qualident(base);
IF base.class = ORB.Typ THEN
IF base.type.form = ORB.Record THEN typ.base := base.type
ELSE typ.base := ORB.intType; ORS.Mark("invalid extension")
END ;
typ.nofpar := typ.base.nofpar + 1; (*"nofpar" here abused for extension level*)
bot := typ.base.dsc; offset := typ.base.size
ELSE ORS.Mark("type expected")
END
ELSE ORS.Mark("ident expected")
END ;
Check(ORS.rparen, "no )")
END ;
WHILE sym = ORS.ident DO (*fields*)
n := 0; obj := bot;
WHILE sym = ORS.ident DO
obj0 := obj;
WHILE (obj0 # NIL) & (obj0.name # ORS.id) DO obj0 := obj0.next END ;
IF obj0 # NIL THEN ORS.Mark("mult def") END ;
NEW(new); ORS.CopyId(new.name); new.class := ORB.Fld; new.next := obj; obj := new; INC(n);
ORS.Get(sym); CheckExport(new.expo);
IF (sym # ORS.comma) & (sym # ORS.colon) THEN ORS.Mark("comma expected")
ELSIF sym = ORS.comma THEN ORS.Get(sym)
END
END ;
Check(ORS.colon, "colon expected"); Type(tp);
IF (tp.form = ORB.Array) & (tp.len < 0) THEN ORS.Mark("dyn array not allowed") END ;
IF tp.size > 1 THEN offset := (offset+3) DIV 4 * 4 END ;
offset := offset + n * tp.size; off := offset; obj0 := obj;
WHILE obj0 # bot DO obj0.type := tp; obj0.lev := 0; off := off - tp.size; obj0.val := off; obj0 := obj0.next END ;
bot := obj;
IF sym = ORS.semicolon THEN ORS.Get(sym) ELSIF sym # ORS.end THEN ORS.Mark(" ; or END") END
END ;
typ.form := ORB.Record; typ.dsc := bot; typ.size := (offset + 3) DIV 4 * 4; type := typ
END RecordType;
PROCEDURE FPSection(VAR adr: LONGINT; VAR nofpar: INTEGER);
VAR obj, first: ORB.Object; tp: ORB.Type;
parsize: LONGINT; cl: INTEGER; rdo: BOOLEAN;
BEGIN
IF sym = ORS.var THEN ORS.Get(sym); cl := ORB.Par ELSE cl := ORB.Var END ;
IdentList(cl, first); FormalType(tp, 0); rdo := FALSE;
IF (cl = ORB.Var) & (tp.form >= ORB.Array) THEN cl := ORB.Par; rdo := TRUE END ;
IF (tp.form = ORB.Array) & (tp.len < 0) OR (tp.form = ORB.Record) THEN
parsize := 2*ORG.WordSize (*open array or record, needs second word for length or type tag*)
ELSE parsize := ORG.WordSize
END ;
obj := first;
WHILE obj # NIL DO
INC(nofpar); obj.class := cl; obj.type := tp; obj.rdo := rdo; obj.lev := level; obj.val := adr;
adr := adr + parsize; obj := obj.next
END ;
IF adr >= 52 THEN ORS.Mark("too many parameters") END
END FPSection;
PROCEDURE ProcedureType(ptype: ORB.Type; VAR parblksize: LONGINT);
VAR obj: ORB.Object; size: LONGINT; nofpar: INTEGER;
BEGIN ptype.base := ORB.noType; size := parblksize; nofpar := 0; ptype.dsc := NIL;
IF sym = ORS.lparen THEN
ORS.Get(sym);
IF sym = ORS.rparen THEN ORS.Get(sym)
ELSE FPSection(size, nofpar);
WHILE sym = ORS.semicolon DO ORS.Get(sym); FPSection(size, nofpar) END ;
Check(ORS.rparen, "no )")
END ;
ptype.nofpar := nofpar; parblksize := size;
IF sym = ORS.colon THEN (*function*)
ORS.Get(sym);
IF sym = ORS.ident THEN qualident(obj);
IF (obj.class = ORB.Typ) & (obj.type.form IN {ORB.Byte .. ORB.Pointer, ORB.Proc}) THEN ptype.base := obj.type
ELSE ORS.Mark("illegal function type")
END
ELSE ORS.Mark("type identifier expected")
END
END
END
END ProcedureType;
PROCEDURE FormalType0(VAR typ: ORB.Type; dim: INTEGER);
VAR obj: ORB.Object; dmy: LONGINT;
BEGIN
IF sym = ORS.ident THEN
qualident(obj);
IF obj.class = ORB.Typ THEN typ := obj.type ELSE ORS.Mark("not a type"); typ := ORB.intType END
ELSIF sym = ORS.array THEN
ORS.Get(sym); Check(ORS.of, "OF ?");
IF dim >= 1 THEN ORS.Mark("multi-dimensional open arrays not implemented") END ;
NEW(typ); typ.form := ORB.Array; typ.len := -1; typ.size := 2*ORG.WordSize;
FormalType(typ.base, dim+1)
ELSIF sym = ORS.procedure THEN
ORS.Get(sym); ORB.OpenScope;
NEW(typ); typ.form := ORB.Proc; typ.size := ORG.WordSize; dmy := 0; ProcedureType(typ, dmy);
typ.dsc := ORB.topScope.next; ORB.CloseScope
ELSE ORS.Mark("identifier expected"); typ := ORB.noType
END
END FormalType0;
PROCEDURE CheckRecLevel(lev: INTEGER);
BEGIN
IF lev # 0 THEN ORS.Mark("ptr base must be global") END
END CheckRecLevel;
PROCEDURE Type0(VAR type: ORB.Type);
VAR dmy: LONGINT; obj: ORB.Object; ptbase: PtrBase;
BEGIN type := ORB.intType; (*sync*)
IF (sym # ORS.ident) & (sym < ORS.array) THEN ORS.Mark("not a type");
REPEAT ORS.Get(sym) UNTIL (sym = ORS.ident) OR (sym >= ORS.array)
END ;
IF sym = ORS.ident THEN
qualident(obj);
IF obj.class = ORB.Typ THEN
IF (obj.type # NIL) & (obj.type.form # ORB.NoTyp) THEN type := obj.type END
ELSE ORS.Mark("not a type or undefined")
END
ELSIF sym = ORS.array THEN ORS.Get(sym); ArrayType(type)
ELSIF sym = ORS.record THEN
ORS.Get(sym); RecordType(type); Check(ORS.end, "no END")
ELSIF sym = ORS.pointer THEN
ORS.Get(sym); Check(ORS.to, "no TO");
NEW(type); type.form := ORB.Pointer; type.size := ORG.WordSize; type.base := ORB.intType;
IF sym = ORS.ident THEN
obj := ORB.thisObj(); ORS.Get(sym);
IF obj # NIL THEN
IF (obj.class = ORB.Typ) & (obj.type.form IN {ORB.Record, ORB.NoTyp}) THEN
CheckRecLevel(obj.lev); type.base := obj.type
ELSE ORS.Mark("no valid base type")
END
ELSE CheckRecLevel(level); (*enter into list of forward references to be fixed in Declarations*)
NEW(ptbase); ORS.CopyId(ptbase.name); ptbase.type := type; ptbase.next := pbsList; pbsList := ptbase
END
ELSE Type(type.base);
IF type.base.form # ORB.Record THEN ORS.Mark("must point to record") END ;
CheckRecLevel(level)
END
ELSIF sym = ORS.procedure THEN
ORS.Get(sym); ORB.OpenScope;
NEW(type); type.form := ORB.Proc; type.size := ORG.WordSize; dmy := 0;
ProcedureType(type, dmy); type.dsc := ORB.topScope.next; ORB.CloseScope
ELSE ORS.Mark("illegal type")
END
END Type0;
PROCEDURE Declarations(VAR varsize: LONGINT);
VAR obj, first: ORB.Object;
x: ORG.Item; tp: ORB.Type; ptbase: PtrBase;
expo: BOOLEAN; id: ORS.Ident;
BEGIN (*sync*) pbsList := NIL;
IF (sym < ORS.const) & (sym # ORS.end) THEN ORS.Mark("declaration?");
REPEAT ORS.Get(sym) UNTIL (sym >= ORS.const) OR (sym = ORS.end)
END ;
IF sym = ORS.const THEN
ORS.Get(sym);
WHILE sym = ORS.ident DO
ORS.CopyId(id); ORS.Get(sym); CheckExport(expo);
IF sym = ORS.eql THEN ORS.Get(sym) ELSE ORS.Mark("= ?") END;
expression(x);
IF (x.type.form = ORB.String) & (x.b = 2) THEN ORG.StrToChar(x) END ;
ORB.NewObj(obj, id, ORB.Const); obj.expo := expo;
IF x.mode = ORB.Const THEN obj.val := x.a; obj.lev := x.b; obj.type := x.type
ELSE ORS.Mark("expression not constant"); obj.type := ORB.intType
END;
Check(ORS.semicolon, "; missing")
END
END ;
IF sym = ORS.type THEN
ORS.Get(sym);
WHILE sym = ORS.ident DO
ORS.CopyId(id); ORS.Get(sym); CheckExport(expo);
IF sym = ORS.eql THEN ORS.Get(sym) ELSE ORS.Mark("=?") END ;
Type(tp);
ORB.NewObj(obj, id, ORB.Typ); obj.type := tp; obj.expo := expo; obj.lev := level; tp.typobj := obj;
IF expo & (obj.type.form = ORB.Record) THEN obj.exno := exno; INC(exno) ELSE obj.exno := 0 END ;
IF tp.form = ORB.Record THEN
ptbase := pbsList; (*check whether this is base of a pointer type; search and fixup*)
WHILE ptbase # NIL DO
IF obj.name = ptbase.name THEN ptbase.type.base := obj.type END ;
ptbase := ptbase.next
END ;
IF level = 0 THEN ORG.BuildTD(tp, dc) END (*type descriptor; len used as its address*)
END ;
Check(ORS.semicolon, "; missing")
END
END ;
IF sym = ORS.var THEN
ORS.Get(sym);
WHILE sym = ORS.ident DO
IdentList(ORB.Var, first); Type(tp);
obj := first;
WHILE obj # NIL DO
obj.type := tp; obj.lev := level;
IF tp.size > 1 THEN varsize := (varsize + 3) DIV 4 * 4 (*align*) END ;
obj.val := varsize; varsize := varsize + obj.type.size;
IF obj.expo THEN obj.exno := exno; INC(exno) END ;
obj := obj.next
END ;
Check(ORS.semicolon, "; missing")
END
END ;
varsize := (varsize + 3) DIV 4 * 4;
ptbase := pbsList;
WHILE ptbase # NIL DO
IF ptbase.type.base.form = ORB.Int THEN ORS.Mark("undefined pointer base of") END ;
ptbase := ptbase.next
END ;
IF (sym >= ORS.const) & (sym <= ORS.var) THEN ORS.Mark("declaration in bad order") END
END Declarations;
PROCEDURE ProcedureDecl;
VAR proc: ORB.Object;
type: ORB.Type;
procid: ORS.Ident;
x: ORG.Item;
locblksize, parblksize, L: LONGINT;
int: BOOLEAN;
BEGIN (* ProcedureDecl *) int := FALSE; ORS.Get(sym);
IF sym = ORS.times THEN ORS.Get(sym); int := TRUE END ;
IF sym = ORS.ident THEN
ORS.CopyId(procid); ORS.Get(sym);
ORB.NewObj(proc, ORS.id, ORB.Const); parblksize := 4;
NEW(type); type.form := ORB.Proc; type.size := ORG.WordSize; proc.type := type;
CheckExport(proc.expo);
IF proc.expo THEN proc.exno := exno; INC(exno) END ;
ORB.OpenScope; INC(level); proc.val := -1; type.base := ORB.noType;
ProcedureType(type, parblksize); (*formal parameter list*)
Check(ORS.semicolon, "no ;"); locblksize := parblksize;
Declarations(locblksize);
proc.val := ORG.Here() * 4; proc.type.dsc := ORB.topScope.next;
IF sym = ORS.procedure THEN
L := 0; ORG.FJump(L);
REPEAT ProcedureDecl; Check(ORS.semicolon, "no ;") UNTIL sym # ORS.procedure;
ORG.FixLink(L); proc.val := ORG.Here() * 4; proc.type.dsc := ORB.topScope.next
END ;
ORG.Enter(parblksize, locblksize, int);
IF sym = ORS.begin THEN ORS.Get(sym); StatSequence END ;
IF sym = ORS.return THEN
ORS.Get(sym); expression(x);
IF type.base = ORB.noType THEN ORS.Mark("this is not a function")
ELSIF ~CompTypes(type.base, x.type, FALSE) THEN ORS.Mark("wrong result type")
END
ELSIF type.base.form # ORB.NoTyp THEN
ORS.Mark("function without result"); type.base := ORB.noType
END ;
ORG.Return(type.base.form, x, locblksize, int);
ORB.CloseScope; DEC(level); Check(ORS.end, "no END");
IF sym = ORS.ident THEN
IF ORS.id # procid THEN ORS.Mark("no match") END ;
ORS.Get(sym)
ELSE ORS.Mark("no proc id")
END
END ;
int := FALSE
END ProcedureDecl;
PROCEDURE Module;
VAR key: LONGINT;
obj: ORB.Object;
impid, impid1: ORS.Ident;
BEGIN Texts.WriteString(W, " compiling "); ORS.Get(sym);
IF sym = ORS.module THEN
ORS.Get(sym);
IF sym = ORS.times THEN version := 0; Texts.Write(W, "*"); ORS.Get(sym) ELSE version := 1 END ;
ORB.Init; ORB.OpenScope;
IF sym = ORS.ident THEN
ORS.CopyId(modid); ORS.Get(sym);
Texts.WriteString(W, modid); Texts.Append(Oberon.Log, W.buf);
Oberon.DumpLog; (* voc adaptation; -- noch *)
ELSE ORS.Mark("identifier expected")
END ;
Check(ORS.semicolon, "no ;"); level := 0; dc := 0; exno := 1; key := 0;
IF sym = ORS.import THEN
ORS.Get(sym);
WHILE sym = ORS.ident DO
ORS.CopyId(impid); ORS.Get(sym);
IF sym = ORS.becomes THEN
ORS.Get(sym);
IF sym = ORS.ident THEN ORS.CopyId(impid1); ORS.Get(sym)
ELSE ORS.Mark("id expected")
END
ELSE impid1 := impid
END ;
ORB.Import(impid, impid1);
IF sym = ORS.comma THEN ORS.Get(sym)
ELSIF sym = ORS.ident THEN ORS.Mark("comma missing")
END
END ;
Check(ORS.semicolon, "no ;")
END ;
obj := ORB.topScope.next;
ORG.Open(version); Declarations(dc); ORG.SetDataSize((dc + 3) DIV 4 * 4);
WHILE sym = ORS.procedure DO ProcedureDecl; Check(ORS.semicolon, "no ;") END ;
ORG.Header;
IF sym = ORS.begin THEN ORS.Get(sym); StatSequence END ;
Check(ORS.end, "no END");
IF sym = ORS.ident THEN
IF ORS.id # modid THEN ORS.Mark("no match") END ;
ORS.Get(sym)
ELSE ORS.Mark("identifier missing")
END ;
IF sym # ORS.period THEN ORS.Mark("period missing") END ;
IF (ORS.errcnt = 0) & (version # 0) THEN
ORB.Export(modid, newSF, key);
IF newSF THEN Texts.WriteString(W, " new symbol file") END
END ;
IF ORS.errcnt = 0 THEN
ORG.Close(modid, key, exno);
Texts.WriteInt(W, ORG.pc, 6); Texts.WriteInt(W, dc, 6); Texts.WriteHex(W, key)
ELSE Texts.WriteLn(W); Texts.WriteString(W, "compilation FAILED")
END ;
Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
Oberon.DumpLog; (* voc adaptation; -- noch *)
ORB.CloseScope; pbsList := NIL
ELSE ORS.Mark("must start with MODULE")
END
END Module;
PROCEDURE Option(VAR S: Texts.Scanner);
BEGIN newSF := FALSE;
IF S.nextCh = "/" THEN
Texts.Scan(S); Texts.Scan(S);
IF (S.class = Texts.Name) & (S.s[0] = "s") THEN newSF := TRUE END
END
END Option;
PROCEDURE Compile*;
VAR beg, end, time: LONGINT;
T: Texts.Text;
S: Texts.Scanner;
BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
IF S.class = Texts.Char THEN
IF S.c = "@" THEN
Option(S); Oberon.GetSelection(T, beg, end, time);
IF time >= 0 THEN ORS.Init(T, beg); Module END
ELSIF S.c = "^" THEN
Option(S); Oberon.GetSelection(T, beg, end, time);
IF time >= 0 THEN
Texts.OpenScanner(S, T, beg); Texts.Scan(S);
IF S.class = Texts.Name THEN
Texts.WriteString(W, S.s); NEW(T); Texts.Open(T, S.s);
IF T.len > 0 THEN ORS.Init(T, 0); Module END
END
END
END
ELSE
WHILE S.class = Texts.Name DO
NEW(T); Texts.Open(T, S.s);
IF T.len > 0 THEN Option(S); ORS.Init(T, 0); Module
ELSE Texts.WriteString(W, S.s); Texts.WriteString(W, " not found");
Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
Oberon.DumpLog; (* voc adaptation; -- noch *)
END ;
IF (T.len # 0) & (ORS.errcnt = 0) THEN Texts.Scan(S) ELSE S.class := 0 END
END
END ;
Oberon.Collect(0)
END Compile;
BEGIN Texts.OpenWriter(W); Texts.WriteString(W, "OR Compiler 7.6.2014");
Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
Oberon.DumpLog; (* voc adaptation; -- noch *)
NEW(dummy); dummy.class := ORB.Var; dummy.type := ORB.intType;
expression := expression0; Type := Type0; FormalType := FormalType0;
Compile (* voc adaptation; -- noch *)
END ORP.

325
src/voc07R/ORS.Mod
View file

@ -1,325 +0,0 @@
MODULE ORS; (* NW 19.9.93 / 1.4.2014 Scanner in Oberon-07*)
IMPORT SYSTEM, Texts := CompatTexts, Oberon; (* CompatTexts is voc adaptation by noch *)
TYPE INTEGER = LONGINT; (* voc adaptation by noch *)
(* Oberon Scanner does lexical analysis. Input is Oberon-Text, output is
sequence of symbols, i.e identifiers, numbers, strings, and special symbols.
Recognises all Oberon keywords and skips comments. The keywords are
recorded in a table.
Get(sym) delivers next symbol from input text with Reader R.
Mark(msg) records error and delivers error message with Writer W.
If Get delivers ident, then the identifier (a string) is in variable id, if int or char
in ival, if real in rval, and if string in str (and slen) *)
CONST IdLen* = 32;
NKW = 34; (*nof keywords*)
maxExp = 38; stringBufSize = 256;
(*lexical symbols*)
null = 0; times* = 1; rdiv* = 2; div* = 3; mod* = 4;
and* = 5; plus* = 6; minus* = 7; or* = 8; eql* = 9;
neq* = 10; lss* = 11; leq* = 12; gtr* = 13; geq* = 14;
in* = 15; is* = 16; arrow* = 17; period* = 18;
char* = 20; int* = 21; real* = 22; false* = 23; true* = 24;
nil* = 25; string* = 26; not* = 27; lparen* = 28; lbrak* = 29;
lbrace* = 30; ident* = 31;
if* = 32; while* = 34; repeat* = 35; case* = 36; for* = 37;
comma* = 40; colon* = 41; becomes* = 42; upto* = 43; rparen* = 44;
rbrak* = 45; rbrace* = 46; then* = 47; of* = 48; do* = 49;
to* = 50; by* = 51; semicolon* = 52; end* = 53; bar* = 54;
else* = 55; elsif* = 56; until* = 57; return* = 58;
array* = 60; record* = 61; pointer* = 62; const* = 63; type* = 64;
var* = 65; procedure* = 66; begin* = 67; import* = 68; module* = 69;
TYPE Ident* = ARRAY IdLen OF CHAR;
VAR ival*, slen*: LONGINT; (*results of Get*)
rval*: REAL;
id*: Ident; (*for identifiers*)
str*: ARRAY stringBufSize OF CHAR;
errcnt*: INTEGER;
ch: CHAR; (*last character read*)
errpos: LONGINT;
R: Texts.Reader;
W: Texts.Writer;
k: INTEGER;
KWX: ARRAY 10 OF INTEGER;
keyTab: ARRAY NKW OF
RECORD sym: INTEGER; id: ARRAY 12 OF CHAR END;
PROCEDURE CopyId*(VAR ident: Ident);
BEGIN ident := id
END CopyId;
PROCEDURE Pos*(): LONGINT;
BEGIN RETURN Texts.Pos(R) - 1
END Pos;
PROCEDURE Mark*(msg: ARRAY OF CHAR);
VAR p: LONGINT;
BEGIN p := Pos();
IF (p > errpos) & (errcnt < 25) THEN
Texts.WriteLn(W); Texts.WriteString(W, " pos "); Texts.WriteInt(W, p, 1); Texts.Write(W, " ");
Texts.WriteString(W, msg); Texts.Append(Oberon.Log, W.buf);
Oberon.DumpLog; (* voc adaptation by noch *)
END ;
INC(errcnt); errpos := p + 4
END Mark;
PROCEDURE Identifier(VAR sym: INTEGER);
VAR i, k: INTEGER;
BEGIN i := 0;
REPEAT
IF i < IdLen-1 THEN id[i] := ch; INC(i) END ;
Texts.Read(R, ch)
UNTIL (ch < "0") OR (ch > "9") & (ch < "A") OR (ch > "Z") & (ch < "a") OR (ch > "z");
id[i] := 0X;
IF i < 10 THEN k := KWX[i-1]; (*search for keyword*)
WHILE (id # keyTab[k].id) & (k < KWX[i]) DO INC(k) END ;
IF k < KWX[i] THEN sym := keyTab[k].sym ELSE sym := ident END
ELSE sym := ident
END
END Identifier;
PROCEDURE String;
VAR i: INTEGER;
BEGIN i := 0; Texts.Read(R, ch);
WHILE ~R.eot & (ch # 22X) DO
IF ch >= " " THEN
IF i < stringBufSize-1 THEN str[i] := ch; INC(i) ELSE Mark("string too long") END ;
END ;
Texts.Read(R, ch)
END ;
str[i] := 0X; INC(i); Texts.Read(R, ch); slen := i
END String;
PROCEDURE HexString;
VAR i, m, n: INTEGER;
BEGIN i := 0; Texts.Read(R, ch);
WHILE ~R.eot & (ch # "$") DO
WHILE (ch = " ") OR (ch = 9X) OR (ch = 0DX) DO Texts.Read(R, ch) END ; (*skip*)
IF ("0" <= ch) & (ch <= "9") THEN m := ORD(ch) - 30H
ELSIF ("A" <= ch) & (ch <= "F") THEN m := ORD(ch) - 37H
ELSE m := 0; Mark("hexdig expected")
END ;
Texts.Read(R, ch);
IF ("0" <= ch) & (ch <= "9") THEN n := ORD(ch) - 30H
ELSIF ("A" <= ch) & (ch <= "F") THEN n := ORD(ch) - 37H
ELSE n := 0; Mark("hexdig expected")
END ;
IF i < stringBufSize THEN str[i] := CHR(m*10H + n); INC(i) ELSE Mark("string too long") END ;
Texts.Read(R, ch)
END ;
Texts.Read(R, ch); slen := i (*no 0X appended!*)
END HexString;
PROCEDURE Ten(e: LONGINT): REAL;
VAR x, t: REAL;
BEGIN x := 1.0; t := 10.0;
WHILE e > 0 DO
IF ODD(e) THEN x := t * x END ;
t := t * t; e := e DIV 2
END ;
RETURN x
END Ten;
PROCEDURE Number(VAR sym: INTEGER);
CONST max = 2147483647 (*2^31 - 1*);
VAR i, k, e, n, s, h: LONGINT; x: REAL;
d: ARRAY 16 OF INTEGER;
negE: BOOLEAN;
BEGIN ival := 0; i := 0; n := 0; k := 0;
REPEAT
IF n < 16 THEN d[n] := ORD(ch)-30H; INC(n) ELSE Mark("too many digits"); n := 0 END ;
Texts.Read(R, ch)
UNTIL (ch < "0") OR (ch > "9") & (ch < "A") OR (ch > "F");
IF (ch = "H") OR (ch = "R") OR (ch = "X") THEN (*hex*)
REPEAT h := d[i];
IF h >= 10 THEN h := h-7 END ;
k := k*10H + h; INC(i) (*no overflow check*)
UNTIL i = n;
IF ch = "X" THEN sym := char;
IF k < 100H THEN ival := k ELSE Mark("illegal value"); ival := 0 END
ELSIF ch = "R" THEN sym := real; rval := SYSTEM.VAL(REAL, k)
ELSE sym := int; ival := k
END ;
Texts.Read(R, ch)
ELSIF ch = "." THEN
Texts.Read(R, ch);
IF ch = "." THEN (*double dot*) ch := 7FX; (*decimal integer*)
REPEAT
IF d[i] < 10 THEN
IF k <= (max-d[i]) DIV 10 THEN k := k *10 + d[i] ELSE Mark("too large"); k := 0 END
ELSE Mark("bad integer")
END ;
INC(i)
UNTIL i = n;
sym := int; ival := k
ELSE (*real number*) x := 0.0; e := 0;
REPEAT (*integer part*)
(*x := x * 10.0 + FLT(d[i]); *)
x := x * 10.0 + (d[i]); (* voc adaptation by noch *)
INC(i)
UNTIL i = n;
WHILE (ch >= "0") & (ch <= "9") DO (*fraction*)
(*x := x * 10.0 + FLT(ORD(ch) - 30H);*)
x := x * 10.0 + (ORD(ch) - 30H); (* voc adaptation by noch *)
DEC(e);
Texts.Read(R, ch)
END ;
IF (ch = "E") OR (ch = "D") THEN (*scale factor*)
Texts.Read(R, ch); s := 0;
IF ch = "-" THEN negE := TRUE; Texts.Read(R, ch)
ELSE negE := FALSE;
IF ch = "+" THEN Texts.Read(R, ch) END
END ;
IF (ch >= "0") & (ch <= "9") THEN
REPEAT s := s*10 + ORD(ch)-30H; Texts.Read(R, ch)
UNTIL (ch < "0") OR (ch >"9");
IF negE THEN e := e-s ELSE e := e+s END
ELSE Mark("digit?")
END
END ;
IF e < 0 THEN
IF e >= -maxExp THEN x := x / Ten(-e) ELSE x := 0.0 END
ELSIF e > 0 THEN
IF e <= maxExp THEN x := Ten(e) * x ELSE x := 0.0; Mark("too large") END
END ;
sym := real; rval := x
END
ELSE (*decimal integer*)
REPEAT
IF d[i] < 10 THEN
IF k <= (max-d[i]) DIV 10 THEN k := k*10 + d[i] ELSE Mark("too large"); k := 0 END
ELSE Mark("bad integer")
END ;
INC(i)
UNTIL i = n;
sym := int; ival := k
END
END Number;
PROCEDURE comment;
BEGIN Texts.Read(R, ch);
REPEAT
WHILE ~R.eot & (ch # "*") DO
IF ch = "(" THEN Texts.Read(R, ch);
IF ch = "*" THEN comment END
ELSE Texts.Read(R, ch)
END
END ;
WHILE ch = "*" DO Texts.Read(R, ch) END
UNTIL (ch = ")") OR R.eot;
IF ~R.eot THEN Texts.Read(R, ch) ELSE Mark("unterminated comment") END
END comment;
PROCEDURE Get*(VAR sym: INTEGER);
BEGIN
REPEAT
WHILE ~R.eot & (ch <= " ") DO Texts.Read(R, ch) END;
IF ch < "A" THEN
IF ch < "0" THEN
IF ch = 22X THEN String; sym := string
ELSIF ch = "#" THEN Texts.Read(R, ch); sym := neq
ELSIF ch = "$" THEN HexString; sym := string
ELSIF ch = "&" THEN Texts.Read(R, ch); sym := and
ELSIF ch = "(" THEN Texts.Read(R, ch);
IF ch = "*" THEN sym := null; comment ELSE sym := lparen END
ELSIF ch = ")" THEN Texts.Read(R, ch); sym := rparen
ELSIF ch = "*" THEN Texts.Read(R, ch); sym := times
ELSIF ch = "+" THEN Texts.Read(R, ch); sym := plus
ELSIF ch = "," THEN Texts.Read(R, ch); sym := comma
ELSIF ch = "-" THEN Texts.Read(R, ch); sym := minus
ELSIF ch = "." THEN Texts.Read(R, ch);
IF ch = "." THEN Texts.Read(R, ch); sym := upto ELSE sym := period END
ELSIF ch = "/" THEN Texts.Read(R, ch); sym := rdiv
ELSE Texts.Read(R, ch); (* ! % ' *) sym := null
END
ELSIF ch < ":" THEN Number(sym)
ELSIF ch = ":" THEN Texts.Read(R, ch);
IF ch = "=" THEN Texts.Read(R, ch); sym := becomes ELSE sym := colon END
ELSIF ch = ";" THEN Texts.Read(R, ch); sym := semicolon
ELSIF ch = "<" THEN Texts.Read(R, ch);
IF ch = "=" THEN Texts.Read(R, ch); sym := leq ELSE sym := lss END
ELSIF ch = "=" THEN Texts.Read(R, ch); sym := eql
ELSIF ch = ">" THEN Texts.Read(R, ch);
IF ch = "=" THEN Texts.Read(R, ch); sym := geq ELSE sym := gtr END
ELSE (* ? @ *) Texts.Read(R, ch); sym := null
END
ELSIF ch < "[" THEN Identifier(sym)
ELSIF ch < "a" THEN
IF ch = "[" THEN sym := lbrak
ELSIF ch = "]" THEN sym := rbrak
ELSIF ch = "^" THEN sym := arrow
ELSE (* _ ` *) sym := null
END ;
Texts.Read(R, ch)
ELSIF ch < "{" THEN Identifier(sym) ELSE
IF ch = "{" THEN sym := lbrace
ELSIF ch = "}" THEN sym := rbrace
ELSIF ch = "|" THEN sym := bar
ELSIF ch = "~" THEN sym := not
ELSIF ch = 7FX THEN sym := upto
ELSE sym := null
END ;
Texts.Read(R, ch)
END
UNTIL sym # null
END Get;
PROCEDURE Init*(T: Texts.Text; pos: LONGINT);
BEGIN errpos := pos; errcnt := 0; Texts.OpenReader(R, T, pos); Texts.Read(R, ch)
END Init;
PROCEDURE EnterKW(sym: INTEGER; name: ARRAY OF CHAR);
BEGIN
(*keyTab[k].id := name; *)
COPY(name, keyTab[k].id); (* voc adaptation by noch *)
keyTab[k].sym := sym;
INC(k)
END EnterKW;
BEGIN Texts.OpenWriter(W); k := 0; KWX[0] := 0; KWX[1] := 0;
EnterKW(if, "IF");
EnterKW(do, "DO");
EnterKW(of, "OF");
EnterKW(or, "OR");
EnterKW(to, "TO");
EnterKW(in, "IN");
EnterKW(is, "IS");
EnterKW(by, "BY");
KWX[2] := k;
EnterKW(end, "END");
EnterKW(nil, "NIL");
EnterKW(var, "VAR");
EnterKW(div, "DIV");
EnterKW(mod, "MOD");
EnterKW(for, "FOR");
KWX[3] := k;
EnterKW(else, "ELSE");
EnterKW(then, "THEN");
EnterKW(true, "TRUE");
EnterKW(type, "TYPE");
EnterKW(case, "CASE");
KWX[4] := k;
EnterKW(elsif, "ELSIF");
EnterKW(false, "FALSE");
EnterKW(array, "ARRAY");
EnterKW(begin, "BEGIN");
EnterKW(const, "CONST");
EnterKW(until, "UNTIL");
EnterKW(while, "WHILE");
KWX[5] := k;
EnterKW(record, "RECORD");
EnterKW(repeat, "REPEAT");
EnterKW(return, "RETURN");
EnterKW(import, "IMPORT");
EnterKW(module, "MODULE");
KWX[6] := k;
EnterKW(pointer, "POINTER");
KWX[7] := k; KWX[8] := k;
EnterKW(procedure, "PROCEDURE");
KWX[9] := k
END ORS.

251
src/voc07R/ORTool.Mod
View file

@ -1,251 +0,0 @@
MODULE ORTool; (*NW 18.2.2013*)
IMPORT SYSTEM, Files, Texts, Oberon, ORB;
VAR W: Texts.Writer;
Form: INTEGER; (*result of ReadType*)
mnemo0, mnemo1: ARRAY 16, 4 OF CHAR; (*mnemonics*)
PROCEDURE Read(VAR R: Files.Rider; VAR n: INTEGER);
VAR b: BYTE;
BEGIN Files.ReadByte(R, b);
IF b < 80H THEN n := b ELSE n := b - 100H END
END Read;
PROCEDURE ReadType(VAR R: Files.Rider);
VAR key, len, lev, size, off: INTEGER;
ref, mno, class, form, readonly: INTEGER;
name, modname: ARRAY 32 OF CHAR;
BEGIN Read(R, ref); Texts.Write(W, " "); Texts.Write(W, "[");
IF ref < 0 THEN Texts.Write(W, "^"); Texts.WriteInt(W, -ref, 1)
ELSE Texts.WriteInt(W, ref, 1);
Read(R, form); Texts.WriteString(W, " form = "); Texts.WriteInt(W, form, 1);
IF form = ORB.Pointer THEN ReadType(R)
ELSIF form = ORB.Array THEN
ReadType(R); Files.ReadNum(R, len); Files.ReadNum(R, size);
Texts.WriteString(W, " len = "); Texts.WriteInt(W, len, 1);
Texts.WriteString(W, " size = "); Texts.WriteInt(W, size, 1)
ELSIF form = ORB.Record THEN
ReadType(R); (*base type*)
Files.ReadNum(R, off); Texts.WriteString(W, " exno = "); Texts.WriteInt(W, off, 1);
Files.ReadNum(R, off); Texts.WriteString(W, " extlev = "); Texts.WriteInt(W, off, 1);
Files.ReadNum(R, size); Texts.WriteString(W, " size = "); Texts.WriteInt(W, size, 1);
Texts.Write(W, " "); Texts.Write(W, "{"); Read(R, class);
WHILE class # 0 DO (*fields*)
Files.ReadString(R, name);
IF name[0] # 0X THEN Texts.Write(W, " "); Texts.WriteString(W, name); ReadType(R)
ELSE Texts.WriteString(W, " --")
END ;
Files.ReadNum(R, off); Texts.WriteInt(W, off, 4); Read(R, class)
END ;
Texts.Write(W, "}")
ELSIF form = ORB.Proc THEN
ReadType(R); Texts.Write(W, "("); Read(R, class);
WHILE class # 0 DO
Texts.WriteString(W, " class = "); Texts.WriteInt(W, class, 1); Read(R, readonly);
IF readonly = 1 THEN Texts.Write(W, "#") END ;
ReadType(R); Read(R, class)
END ;
Texts.Write(W, ")")
END ;
Files.ReadString(R, modname);
IF modname[0] # 0X THEN
Files.ReadInt(R, key); Files.ReadString(R, name);
Texts.Write(W, " "); Texts.WriteString(W, modname); Texts.Write(W, "."); Texts.WriteString(W, name);
Texts.WriteHex(W, key)
END
END ;
Form := form; Texts.Write(W, "]")
END ReadType;
PROCEDURE DecSym*; (*decode symbol file*)
VAR class, typno, k: INTEGER;
name: ARRAY 32 OF CHAR;
F: Files.File; R: Files.Rider;
S: Texts.Scanner;
BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
IF S.class = Texts.Name THEN
Texts.WriteString(W, "OR-decode "); Texts.WriteString(W, S.s);
Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
F := Files.Old(S.s);
IF F # NIL THEN
Files.Set(R, F, 0); Files.ReadInt(R, k); Files.ReadInt(R, k);
Files.ReadString(R, name); Texts.WriteString(W, name); Texts.WriteHex(W, k);
Read(R, class); Texts.WriteInt(W, class, 3); (*sym file version*)
IF class = ORB.versionkey THEN
Texts.WriteLn(W); Read(R, class);
WHILE class # 0 DO
Texts.WriteInt(W, class, 4); Files.ReadString(R, name); Texts.Write(W, " "); Texts.WriteString(W, name);
ReadType(R);
IF class = ORB.Typ THEN
Texts.Write(W, "("); Read(R, class);
WHILE class # 0 DO (*pointer base fixup*)
Texts.WriteString(W, " ->"); Texts.WriteInt(W, class, 4); Read(R, class)
END ;
Texts.Write(W, ")")
ELSIF (class = ORB.Const) OR (class = ORB.Var) THEN
Files.ReadNum(R, k); Texts.WriteInt(W, k, 5); (*Reals, Strings!*)
END ;
Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
Read(R, class)
END
ELSE Texts.WriteString(W, " bad symfile version")
END
ELSE Texts.WriteString(W, " not found")
END ;
Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
END
END DecSym;
(* ---------------------------------------------------*)
PROCEDURE WriteReg(r: LONGINT);
BEGIN Texts.Write(W, " ");
IF r < 12 THEN Texts.WriteString(W, " R"); Texts.WriteInt(W, r MOD 10H, 1)
ELSIF r = 12 THEN Texts.WriteString(W, "MT")
ELSIF r = 13 THEN Texts.WriteString(W, "SB")
ELSIF r = 14 THEN Texts.WriteString(W, "SP")
ELSE Texts.WriteString(W, "LNK")
END
END WriteReg;
PROCEDURE opcode(w: LONGINT);
VAR k, op, u, a, b, c: LONGINT;
BEGIN
k := w DIV 40000000H MOD 4;
a := w DIV 1000000H MOD 10H;
b := w DIV 100000H MOD 10H;
op := w DIV 10000H MOD 10H;
u := w DIV 20000000H MOD 2;
IF k = 0 THEN
Texts.WriteString(W, mnemo0[op]);
IF u = 1 THEN Texts.Write(W, "'") END ;
WriteReg(a); WriteReg(b); WriteReg(w MOD 10H)
ELSIF k = 1 THEN
Texts.WriteString(W, mnemo0[op]);
IF u = 1 THEN Texts.Write(W, "'") END ;
WriteReg(a); WriteReg(b); w := w MOD 10000H;
IF w >= 8000H THEN w := w - 10000H END ;
Texts.WriteInt(W, w, 7)
ELSIF k = 2 THEN (*LDR/STR*)
IF u = 1 THEN Texts.WriteString(W, "STR ") ELSE Texts.WriteString(W, "LDR") END ;
WriteReg(a); WriteReg(b); w := w MOD 100000H;
IF w >= 80000H THEN w := w - 100000H END ;
Texts.WriteInt(W, w, 8)
ELSIF k = 3 THEN (*Branch instr*)
Texts.Write(W, "B");
IF ODD(w DIV 10000000H) THEN Texts.Write(W, "L") END ;
Texts.WriteString(W, mnemo1[a]);
IF u = 0 THEN WriteReg(w MOD 10H) ELSE
w := w MOD 100000H;
IF w >= 80000H THEN w := w - 100000H END ;
Texts.WriteInt(W, w, 8)
END
END
END opcode;
PROCEDURE Sync(VAR R: Files.Rider);
VAR ch: CHAR;
BEGIN Files.Read(R, ch); Texts.WriteString(W, "Sync "); Texts.Write(W, ch); Texts.WriteLn(W)
END Sync;
PROCEDURE Write(VAR R: Files.Rider; x: INTEGER);
BEGIN Files.WriteByte(R, x) (* -128 <= x < 128 *)
END Write;
PROCEDURE DecObj*; (*decode object file*)
VAR class, i, n, key, size, fix, adr, data, len: INTEGER;
ch: CHAR;
name: ARRAY 32 OF CHAR;
F: Files.File; R: Files.Rider;
S: Texts.Scanner;
BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
IF S.class = Texts.Name THEN
Texts.WriteString(W, "decode "); Texts.WriteString(W, S.s); F := Files.Old(S.s);
IF F # NIL THEN
Files.Set(R, F, 0); Files.ReadString(R, name); Texts.WriteLn(W); Texts.WriteString(W, name);
Files.ReadInt(R, key); Texts.WriteHex(W, key); Read(R, class); Texts.WriteInt(W, class, 4); (*version*)
Files.ReadInt(R, size); Texts.WriteInt(W, size, 6); Texts.WriteLn(W);
Texts.WriteString(W, "imports:"); Texts.WriteLn(W); Files.ReadString(R, name);
WHILE name[0] # 0X DO
Texts.Write(W, 9X); Texts.WriteString(W, name);
Files.ReadInt(R, key); Texts.WriteHex(W, key); Texts.WriteLn(W);
Files.ReadString(R, name)
END ;
(* Sync(R); *)
Texts.WriteString(W, "type descriptors"); Texts.WriteLn(W);
Files.ReadInt(R, n); n := n DIV 4; i := 0;
WHILE i < n DO Files.ReadInt(R, data); Texts.WriteHex(W, data); INC(i) END ;
Texts.WriteLn(W);
Texts.WriteString(W, "data"); Files.ReadInt(R, data); Texts.WriteInt(W, data, 6); Texts.WriteLn(W);
Texts.WriteString(W, "strings"); Texts.WriteLn(W);
Files.ReadInt(R, n); i := 0;
WHILE i < n DO Files.Read(R, ch); Texts.Write(W, ch); INC(i) END ;
Texts.WriteLn(W);
Texts.WriteString(W, "code"); Texts.WriteLn(W);
Files.ReadInt(R, n); i := 0;
WHILE i < n DO
Files.ReadInt(R, data); Texts.WriteInt(W, i, 4); Texts.Write(W, 9X); Texts.WriteHex(W, data);
Texts.Write(W, 9X); opcode(data); Texts.WriteLn(W); INC(i)
END ;
(* Sync(R); *)
Texts.WriteString(W, "commands:"); Texts.WriteLn(W);
Files.ReadString(R, name);
WHILE name[0] # 0X DO
Texts.Write(W, 9X); Texts.WriteString(W, name);
Files.ReadInt(R, adr); Texts.WriteInt(W, adr, 5); Texts.WriteLn(W);
Files.ReadString(R, name)
END ;
(* Sync(R); *)
Texts.WriteString(W, "entries"); Texts.WriteLn(W);
Files.ReadInt(R, n); i := 0;
WHILE i < n DO
Files.ReadInt(R, adr); Texts.WriteInt(W, adr, 6); INC(i)
END ;
Texts.WriteLn(W);
(* Sync(R); *)
Texts.WriteString(W, "pointer refs"); Texts.WriteLn(W); Files.ReadInt(R, adr);
WHILE adr # -1 DO Texts.WriteInt(W, adr, 6); Files.ReadInt(R, adr) END ;
Texts.WriteLn(W);
(* Sync(R); *)
Files.ReadInt(R, data); Texts.WriteString(W, "fixP = "); Texts.WriteInt(W, data, 8); Texts.WriteLn(W);
Files.ReadInt(R, data); Texts.WriteString(W, "fixD = "); Texts.WriteInt(W, data, 8); Texts.WriteLn(W);
Files.ReadInt(R, data); Texts.WriteString(W, "fixT = "); Texts.WriteInt(W, data, 8); Texts.WriteLn(W);
Files.ReadInt(R, data); Texts.WriteString(W, "entry = "); Texts.WriteInt(W, data, 8); Texts.WriteLn(W);
Files.Read(R, ch);
IF ch # "O" THEN Texts.WriteString(W, "format eror"); Texts.WriteLn(W) END
(* Sync(R); *)
ELSE Texts.WriteString(W, " not found"); Texts.WriteLn(W)
END ;
Texts.Append(Oberon.Log, W.buf)
END
END DecObj;
BEGIN Texts.OpenWriter(W); Texts.WriteString(W, "ORTool 18.2.2013");
Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
mnemo0[0] := "MOV";
mnemo0[1] := "LSL";
mnemo0[2] := "ASR";
mnemo0[3] := "ROR";
mnemo0[4] := "AND";
mnemo0[5] := "ANN";
mnemo0[6] := "IOR";
mnemo0[7] := "XOR";
mnemo0[8] := "ADD";
mnemo0[9] := "SUB";
mnemo0[10] := "MUL";
mnemo0[11] := "DIV";
mnemo0[12] := "FAD";
mnemo0[13] := "FSB";
mnemo0[14] := "FML";
mnemo0[15] := "FDV";
mnemo1[0] := "MI ";
mnemo1[8] := "PL";
mnemo1[1] := "EQ ";
mnemo1[9] := "NE ";
mnemo1[2] := "LS ";
mnemo1[10] := "HI ";
mnemo1[5] := "LT ";
mnemo1[13] := "GE ";
mnemo1[6] := "LE ";
mnemo1[14] := "GT ";
mnemo1[15] := "NO ";
END ORTool.

111
src/voc07R/Oberon.Mod
View file

@ -1,111 +0,0 @@
MODULE Oberon;
(* this module emulates Oberon.Log and Oberon.Par in order to pass agruments to Oberon programs, as it's in Oberon environment;
it creates Oberon.Par from command line arguments;
procedure Dump dumps Oberon.Log to standard output.
-- noch *)
(* Files are commented out, because it's not necessary for work, but can be very useful for debug. See WriteTextToFile procedure; -- noch *)
IMPORT Args, Strings, Texts := CompatTexts, (*Files := CompatFiles,*) Out := Console;
VAR Log*: Texts.Text;
Par*: RECORD
text*: Texts.Text;
pos* : LONGINT;
END;
arguments : ARRAY 2048 OF CHAR;
PROCEDURE GetSelection* (VAR text: Texts.Text; VAR beg, end, time: LONGINT);
(*VAR M: SelectionMsg;*)
BEGIN
(*M.time := -1; Viewers.Broadcast(M); time := M.time;
IF time >= 0 THEN text := M.text; beg := M.beg; end := M.end END*)
END GetSelection;
PROCEDURE Collect*( count : LONGINT);
BEGIN
END Collect;
PROCEDURE ArgsToString(VAR opts : ARRAY OF CHAR);
VAR i : INTEGER;
opt : ARRAY 256 OF CHAR;
BEGIN
i := 1;
opt := ""; COPY ("", opts);
WHILE i < Args.argc DO
Args.Get(i, opt);
Strings.Append(opt, opts);(* Strings.Append (" ", opts);*)
(* ORP calls Texts.Scan, which returns filename, and nextCh would be set to " " if we append here " ". However after that ORP will check nextCh, and if it finds that nextCh is not "/" it's not gonna parse options. That's why Strings.Append is commented out; -- noch *)
INC(i)
END;
END ArgsToString;
PROCEDURE StringToText(VAR arguments : ARRAY OF CHAR; VAR T : Texts.Text);
VAR
W : Texts.Writer;
BEGIN
Texts.OpenWriter(W);
Texts.WriteString(W, arguments);
Texts.Append (T, W.buf);
END StringToText;
(*
PROCEDURE WriteTextToFile(VAR T : Texts.Text; filename : ARRAY OF CHAR);
VAR f : Files.File; r : Files.Rider;
BEGIN
f := Files.New(filename);
Files.Set(r, f, 0);
Texts.Store(r, T);
Files.Register(f);
END WriteTextToFile;
*)
PROCEDURE TextToString(VAR T : Texts.Text; VAR string : ARRAY OF CHAR);
VAR R : Texts.Reader;
ch : CHAR;
i : LONGINT;
BEGIN
COPY("", string);
Texts.OpenReader(R, T, 0);
i := 0;
WHILE Texts.Pos(R) < T.len DO
Texts.Read(R, ch);
string[i] := ch;
INC(i);
END;
(*string[i] := 0X;*)
END TextToString;
PROCEDURE DumpLog*;
VAR s : POINTER TO ARRAY OF CHAR;
BEGIN
NEW(s, Log.len + 1);
COPY("", s^);
TextToString(Log, s^);
Out.String(s^); Out.Ln;
NEW(Log);
Texts.Open(Log, "");
END DumpLog;
BEGIN
NEW(Log);
Texts.Open(Log, "");
NEW(Par.text);
Texts.Open(Par.text, "");
Par.pos := 0;
COPY("", arguments);
ArgsToString(arguments);
StringToText(arguments, Par.text);
(*WriteTextToFile(Par.text, "params.txt");*)
(*WriteTextToFile(Log, "log.txt");*)
(*DumpLog;*)
END Oberon.

BIN
src/voc07R/Oberon10.Scn.Fnt
View file

Binary file not shown.

29
src/voc07R/README.md
View file

@ -1,29 +0,0 @@
RISC crosscompiler
==================
This is a version of re re revised Oberon compiler for Wirth's RISC machine which can be compiled and run with VOC (Vishap Oberon Compiler) on supported platforms.
Files generated can be transferred to RISC machine or emulator and be run there.
Compile
=======
If you have vishap oberon compiler installed, just type
>make
Run
===
>./ORP test.Mod /s
like that.
you may need symbol (.smb) files from RISC Oberon system in order to write programs that import some modules.
some answers
============
- why Oberon10.Scn.Fnt ?
- it's actually not really necessary. because Texts are patched (test for NIL) to not crash if this file does not exist. however, unless I remove dependency from Fonts.Mod I have decided to keep this file here, and thus my added test for NIL is not necessary, and generated output file is completely correct Oberon Text file. Otherwise it would not contain the font name, for instance.

22
src/voc07R/makefile
View file

@ -1,22 +0,0 @@
SETPATH = MODULES=".:x86_64"
VOC0 = $(SETPATH) /opt/voc/bin/voc
all:
#$(VOC0) -s ORS.Mod
#$(VOC0) -s ORB.Mod
#$(VOC0) -s ORG.Mod
$(VOC0) -s CompatFiles.Mod \
Fonts.Mod CompatTexts.Mod Oberon.Mod \
ORS.Mod ORB.Mod ORG.Mod ORP.Mod -M
test:
./ORP -s test.Mod
clean:
rm *.sym
rm *.o
rm *.h
rm *.c

BIN
src/voc07R/test/Oberon.rsc
View file

Binary file not shown.

BIN
src/voc07R/test/Oberon.smb
View file

Binary file not shown.

BIN
src/voc07R/test/Test.Mod
View file

Binary file not shown.

BIN
src/voc07R/test/Texts.rsc
View file

Binary file not shown.

BIN
src/voc07R/test/Texts.smb
View file

Binary file not shown.

3
src/voc07R/test/readme
View file

@ -1,3 +0,0 @@
put ORP binary here and run
> ./ORP Test.Mod

677
src/voc07R/x86/CompatFiles.Mod
View file

@ -1,677 +0,0 @@
MODULE CompatFiles; (* J. Templ 1.12. 89/12.4.95 Oberon files mapped onto Unix files *)
(* modified version of Files, which opens only the file provided and does not scan any path in any environment variable, also ReadLine procedure added; -- noch *)
IMPORT SYSTEM, Unix, Kernel, Args, 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;
fileTabSize = 64;
noDesc = -1;
notDone = -1;
(* file states *)
open = 0; create = 1; close = 2;
TYPE
FileName = ARRAY 101 OF CHAR;
File* = POINTER TO Handle;
Buffer = POINTER TO BufDesc;
Handle = RECORD
workName, registerName: FileName;
tempFile: BOOLEAN;
dev, ino, mtime: LONGINT;
fd-, len, pos: LONGINT;
bufs: ARRAY nofbufs OF Buffer;
swapper, state: INTEGER
END ;
BufDesc = RECORD
f: File;
chg: BOOLEAN;
org, size: LONGINT;
data: ARRAY bufsize OF SYSTEM.BYTE
END ;
Rider* = RECORD
res*: LONGINT;
eof*: BOOLEAN;
buf: Buffer;
org, offset: LONGINT
END ;
Time = POINTER TO TimeDesc;
TimeDesc = RECORD
sec*, min*, hour*, mday*, mon*, year*, wday*, isdst*, zone*, gmtoff*: LONGINT;
(* sec*, min*, hour*, mday*, mon*, year*, wday*, isdst*, zone*, gmtoff*: INTEGER;*)
END ;
VAR
fileTab: ARRAY fileTabSize OF LONGINT (*=File*);
tempno: INTEGER;
(* for localtime *)
PROCEDURE -includetime()
'#include "time.h"';
PROCEDURE -localtime(VAR clock: LONGINT): Time
"(CompatFiles_Time) localtime(clock)";
PROCEDURE -getcwd(VAR cwd: Unix.Name)
"getcwd(cwd, cwd__len)";
PROCEDURE -IdxTrap "__HALT(-1)";
PROCEDURE^ Finalize(o: SYSTEM.PTR);
PROCEDURE Err(s: ARRAY OF CHAR; f: File; errno: LONGINT);
BEGIN
Console.Ln; Console.String("-- "); Console.String(s); Console.String(": ");
IF f # NIL THEN
IF f.registerName # "" THEN Console.String(f.registerName) ELSE Console.String(f.workName) END
END ;
IF errno # 0 THEN Console.String(" errno = "); Console.Int(errno, 1) END ;
Console.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 Kernel.CWD[i] # 0X DO name[i] := Kernel.CWD[i]; INC(i) END;
IF Kernel.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 := SHORT(Unix.Getpid());
WHILE n > 0 DO name[i] := CHR(n MOD 10 + ORD("0")); n := n DIV 10; INC(i) END;
name[i] := 0X
END GetTempName;
PROCEDURE Create(f: File);
VAR stat: Unix.Status; done: BOOLEAN;
errno: LONGINT; err: ARRAY 32 OF CHAR;
BEGIN
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 ;
errno := Unix.Unlink(f.workName); (*unlink first to avoid stale NFS handles and to avoid reuse of inodes*)
f.fd := Unix.Open(f.workName, Unix.rdwr + Unix.creat + Unix.trunc, {2, 4,5, 7,8});
done := f.fd >= 0; errno := Unix.errno();
IF (~done & ((errno = Unix.ENFILE) OR (errno = Unix.EMFILE))) OR (done & (f.fd >= fileTabSize)) THEN
IF done & (f.fd >= fileTabSize) THEN errno := Unix.Close(f.fd) END ;
Kernel.GC(TRUE);
f.fd := Unix.Open(f.workName, Unix.rdwr + Unix.creat + Unix.trunc, {2, 4,5, 7,8});
done := f.fd >= 0
END ;
IF done THEN
IF f.fd >= fileTabSize THEN errno := Unix.Close(f.fd); Err("too many files open", f, 0)
ELSE fileTab[f.fd] := SYSTEM.VAL(LONGINT, f); INC(Kernel.nofiles); Kernel.RegisterObject(f, Finalize);
f.state := open; f.pos := 0; errno := Unix.Fstat(f.fd, stat);
f.dev := stat.dev; f.ino := stat.ino; f.mtime := stat.mtime
END
ELSE errno := Unix.errno();
IF errno = Unix.ENOENT THEN err := "no such directory"
ELSIF (errno = Unix.ENFILE) OR (errno = Unix.EMFILE) THEN err := "too many files open"
ELSE err := "file not created"
END ;
Err(err, f, errno)
END
END
END Create;
PROCEDURE Flush(buf: Buffer);
VAR res: LONGINT; f: File; stat: Unix.Status;
BEGIN
IF buf.chg THEN f := buf.f; Create(f);
IF buf.org # f.pos THEN res := Unix.Lseek(f.fd, buf.org, 0) END ;
res := Unix.Write(f.fd, SYSTEM.ADR(buf.data), buf.size);
IF res < 0 THEN Err("error in writing file", f, Unix.errno()) END ;
f.pos := buf.org + buf.size;
buf.chg := FALSE;
res := Unix.Fstat(f.fd, stat);
f.mtime := stat.mtime
END
END Flush;
PROCEDURE Close* (f: File);
VAR i, res: LONGINT;
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 ;
res := Unix.Fsync(f.fd);
IF res < 0 THEN Err("error in writing file", f, Unix.errno()) END
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); (* supports ~, ~user and blanks inside path *)
VAR i: INTEGER; ch: CHAR; home: ARRAY 256 OF CHAR;
BEGIN
i := 0; ch := Kernel.OBERON[pos];
WHILE (ch = " ") OR (ch = ":") DO INC(pos); ch := Kernel.OBERON[pos] END ;
IF ch = "~" THEN
INC(pos); ch := Kernel.OBERON[pos];
home := ""; Args.GetEnv("HOME", home);
WHILE home[i] # 0X DO dir[i] := home[i]; INC(i) END ;
IF (ch # "/") & (ch # 0X) & (ch # ":") & (ch # " ") THEN
WHILE (i > 0) & (dir[i-1] # "/") DO DEC(i) END
END
END ;
WHILE (ch # 0X) & (ch # ":") DO dir[i] := ch; INC(i); INC(pos); ch := Kernel.OBERON[pos] END ;
WHILE (i > 0) & (dir[i-1] = " ") DO DEC(i) END ;
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(dev, ino: LONGINT; mtime: LONGINT): File;
VAR f: File; i: INTEGER; stat: Unix.Status; res: LONGINT;
BEGIN i := 0;
WHILE i < fileTabSize DO
f := SYSTEM.VAL(File, fileTab[i]);
IF (f # NIL) & (ino = f.ino) & (dev = f.dev) THEN
IF mtime # f.mtime THEN i := 0;
WHILE i < nofbufs DO
IF f.bufs[i] # NIL THEN f.bufs[i].org := -1; f.bufs[i] := NIL END ;
INC(i)
END ;
f.swapper := -1; f.mtime := mtime;
res := Unix.Fstat(f.fd, stat); f.len := stat.size
END ;
RETURN f
END ;
INC(i)
END ;
RETURN NIL
END CacheEntry;
PROCEDURE Old* (name: ARRAY OF CHAR): File;
VAR f: File; fd, res, errno: LONGINT; pos: INTEGER; done: BOOLEAN;
dir, path: ARRAY 256 OF CHAR;
stat: Unix.Status;
BEGIN
IF name # "" THEN
IF HasDir(name) THEN dir := ""; COPY(name, path)
ELSE
pos := 0;
COPY(name, path); (* -- noch *)
(*ScanPath(pos, dir);*) (*MakeFileName(dir, name, path);*) (*ScanPath(pos, dir)*)
END ;
LOOP
fd := Unix.Open(path, Unix.rdwr, {}); done := fd >= 0; errno := Unix.errno();
IF (~done & ((errno = Unix.ENFILE) OR (errno = Unix.EMFILE))) OR (done & (fd >= fileTabSize)) THEN
IF done & (fd >= fileTabSize) THEN res := Unix.Close(fd) END ;
Kernel.GC(TRUE);
fd := Unix.Open(path, Unix.rdwr, {});
done := fd >= 0; errno := Unix.errno();
IF ~done & ((errno = Unix.ENFILE) OR (errno = Unix.EMFILE)) THEN Err("too many files open", f, errno) END
END ;
IF ~done & ((errno = Unix.EACCES) OR (errno = Unix.EROFS) OR (errno = Unix.EAGAIN)) THEN
(* errno EAGAIN observed on Solaris 2.4 *)
fd := Unix.Open(path, Unix.rdonly, {}); done := fd >= 0; errno := Unix.errno()
END ;
IF (~done) & (errno # Unix.ENOENT) THEN
Console.String("warning Files.Old "); Console.String(name);
Console.String(" errno = "); Console.Int(errno, 0); Console.Ln;
END ;
IF done THEN
res := Unix.Fstat(fd, stat);
f := CacheEntry(stat.dev, stat.ino, stat.mtime);
IF f # NIL THEN res := Unix.Close(fd); RETURN f
ELSIF fd >= fileTabSize THEN res := Unix.Close(fd); Err("too many files open", f, 0)
ELSE NEW(f); fileTab[fd] := SYSTEM.VAL(LONGINT, f); INC(Kernel.nofiles); Kernel.RegisterObject(f, Finalize);
f.fd := fd; f.state := open; f.len := stat.size; f.pos := 0; f.swapper := -1; (*all f.buf[i] = NIL*)
COPY(name, f.workName); f.registerName := ""; f.tempFile := FALSE;
f.dev := stat.dev; f.ino := stat.ino; f.mtime := stat.mtime;
RETURN f
END
ELSIF dir = "" THEN RETURN NIL
ELSE (*MakeFileName(dir, name, path);*) (*ScanPath(pos, dir)*)
RETURN NIL
END
END
ELSE RETURN NIL
END
END Old;
PROCEDURE Purge* (f: File);
VAR i: INTEGER; stat: Unix.Status; res: LONGINT;
BEGIN i := 0;
WHILE i < nofbufs DO
IF f.bufs[i] # NIL THEN f.bufs[i].org := -1; f.bufs[i] := NIL END ;
INC(i)
END ;
IF f.fd # noDesc THEN res := Unix.Ftruncate(f.fd, 0); res := Unix.Lseek(f.fd, 0, 0) END ;
f.pos := 0; f.len := 0; f.swapper := -1;
res := Unix.Fstat(f.fd, stat); f.mtime := stat.mtime
END Purge;
PROCEDURE GetDate* (f: File; VAR t, d: LONGINT);
VAR stat: Unix.Status; clock, res: LONGINT; time: Time;
BEGIN
Create(f); res := Unix.Fstat(f.fd, stat);
time := localtime(stat.mtime);
t := time.sec + ASH(time.min, 6) + ASH(time.hour, 12);
d := time.mday + ASH(time.mon+1, 5) + ASH(time.year MOD 100, 9)
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, res: LONGINT; buf: Buffer;
BEGIN
IF f # NIL THEN
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 res := Unix.Lseek(f.fd, org, 0) END ;
n := Unix.ReadBlk(f.fd, buf.data);
IF n < 0 THEN Err("read from file not done", f, Unix.errno()) END ;
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) + offset, SYSTEM.ADR(x) + xpos, min);
INC(offset, min); r.offset := offset; INC(xpos, min); DEC(n, min)
END ;
r.res := 0; r.eof := FALSE
END ReadBytes;
PROCEDURE ReadByte* (VAR r : Rider; VAR x : ARRAY OF SYSTEM.BYTE);
BEGIN
ReadBytes(r, x, 1);
END ReadByte;
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 WriteByte* (VAR r : Rider; x : SYSTEM.BYTE); (* added for compatibility with PO 2013, -- noch *)
BEGIN
Write(r, x);
END WriteByte;
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) + xpos, SYSTEM.ADR(buf.data) + offset, min);
INC(offset, min); r.offset := offset;
IF offset > buf.size THEN INC(buf.f.len, offset - buf.size); buf.size := offset END ;
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 := SHORT(Unix.Unlink(name));
res := SHORT(Unix.errno())
END Delete;
PROCEDURE Rename* (old, new: ARRAY OF CHAR; VAR res: INTEGER);
VAR fdold, fdnew, n, errno, r: LONGINT;
ostat, nstat: Unix.Status;
buf: ARRAY 4096 OF CHAR;
BEGIN
r := Unix.Stat(old, ostat);
IF r >= 0 THEN
r := Unix.Stat(new, nstat);
IF (r >= 0) & ((ostat.dev # nstat.dev) OR (ostat.ino # nstat.ino)) THEN
Delete(new, res); (* work around stale nfs handles *)
END ;
r := Unix.Rename(old, new);
IF r < 0 THEN res := SHORT(Unix.errno());
IF res = Unix.EXDEV THEN (* cross device link, move the file *)
fdold := Unix.Open(old, Unix.rdonly, {});
IF fdold < 0 THEN res := 2; RETURN END ;
fdnew := Unix.Open(new, Unix.rdwr + Unix.creat + Unix.trunc, {2, 4,5, 7,8});
IF fdnew < 0 THEN r := Unix.Close(fdold); res := 3; RETURN END ;
n := Unix.Read(fdold, SYSTEM.ADR(buf), bufsize);
WHILE n > 0 DO
r := Unix.Write(fdnew, SYSTEM.ADR(buf), n);
IF r < 0 THEN errno := Unix.errno(); r := Unix.Close(fdold); r := Unix.Close(fdnew);
Err("cannot move file", NIL, errno)
END ;
n := Unix.Read(fdold, SYSTEM.ADR(buf), bufsize)
END ;
errno := Unix.errno();
r := Unix.Close(fdold); r := Unix.Close(fdnew);
IF n = 0 THEN r := Unix.Unlink(old); res := 0
ELSE Err("cannot move file", NIL, errno)
END ;
ELSE RETURN (* res is Unix.Rename return code *)
END
END ;
res := 0
ELSE res := 2 (* old file not found *)
END
END Rename;
PROCEDURE Register* (f: File);
VAR idx, errno: INTEGER; f1: File; file: ARRAY 104 OF CHAR;
BEGIN
IF (f.state = create) & (f.registerName # "") THEN f.state := close (* shortcut renaming *) END ;
Close(f);
IF f.registerName # "" THEN
Rename(f.workName, f.registerName, errno);
IF errno # 0 THEN COPY(f.registerName, file); HALT(99) END ;
f.workName := f.registerName; f.registerName := ""; f.tempFile := FALSE
END
END Register;
PROCEDURE ChangeDirectory*(path: ARRAY OF CHAR; VAR res: INTEGER);
BEGIN
res := SHORT(Unix.Chdir(path));
getcwd(Kernel.CWD)
END ChangeDirectory;
PROCEDURE FlipBytes(VAR src, dest: ARRAY OF SYSTEM.BYTE);
VAR i, j: LONGINT;
BEGIN
IF ~Kernel.littleEndian THEN i := LEN(src); j := 0;
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 ReadInt* (VAR R: Rider; VAR x: LONGINT); (* to compile OR compiler; -- noch *)
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 ReadInt;
PROCEDURE ReadLInt* (VAR R: Rider; VAR x: LONGINT);
VAR b: ARRAY 4 OF CHAR;
BEGIN ReadBytes(R, b, 4);
x := ORD(b[0]) + ORD(b[1])*100H + ORD(b[2])*10000H + ORD(b[3])*1000000H
END ReadLInt;
PROCEDURE ReadSet* (VAR R: Rider; VAR x: SET);
VAR b: ARRAY 4 OF CHAR;
BEGIN ReadBytes(R, b, 4);
x := SYSTEM.VAL(SET, ORD(b[0]) + ORD(b[1])*100H + ORD(b[2])*10000H + ORD(b[3])*1000000H)
END ReadSet;
PROCEDURE ReadReal* (VAR R: Rider; VAR x: REAL);
VAR b: ARRAY 4 OF CHAR;
BEGIN ReadBytes(R, b, 4); FlipBytes(b, x)
END ReadReal;
PROCEDURE ReadLReal* (VAR R: Rider; VAR x: LONGREAL);
VAR b: ARRAY 8 OF CHAR;
BEGIN ReadBytes(R, b, 8); FlipBytes(b, x)
END ReadLReal;
PROCEDURE ReadString* (VAR R: Rider; VAR x: ARRAY OF CHAR);
VAR i: INTEGER; ch: CHAR;
BEGIN i := 0;
REPEAT Read(R, ch); x[i] := ch; INC(i) UNTIL ch = 0X
END ReadString;
(* need to read line; -- noch *)
PROCEDURE ReadLine* (VAR R: Rider; VAR x: ARRAY OF CHAR);
VAR i: INTEGER; ch: CHAR; b : BOOLEAN;
BEGIN i := 0;
b := FALSE;
REPEAT
Read(R, ch);
IF ((ch = 0X) OR (ch = 0AX) OR (ch = 0DX)) THEN
b := TRUE
ELSE
x[i] := ch;
INC(i);
END;
UNTIL b
END ReadLine;
PROCEDURE ReadNum* (VAR R: Rider; VAR x: LONGINT);
VAR s: SHORTINT; ch: CHAR; n: LONGINT;
BEGIN s := 0; n := 0; Read(R, ch);
WHILE ORD(ch) >= 128 DO INC(n, ASH(ORD(ch) - 128, s) ); INC(s, 7); Read(R, ch) END;
INC(n, ASH(ORD(ch) MOD 64 - ORD(ch) DIV 64 * 64, s) );
x := n
END ReadNum;
PROCEDURE WriteBool* (VAR R: Rider; x: BOOLEAN);
BEGIN Write(R, SYSTEM.VAL(CHAR, x))
END WriteBool;
(* PROCEDURE WriteInt* (VAR R: Rider; x: INTEGER);
VAR b: ARRAY 2 OF CHAR;
BEGIN b[0] := CHR(x); b[1] := CHR(x DIV 256);
WriteBytes(R, b, 2);
END WriteInt;
*)
PROCEDURE WriteInt* (VAR R: Rider; x: LONGINT); (* to compile OR compiler; -- noch *)
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 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: LONGINT);
BEGIN
WHILE (x < - 64) OR (x > 63) DO Write(R, CHR(x MOD 128 + 128)); x := x DIV 128 END;
Write(R, CHR(x MOD 128))
END WriteNum;
PROCEDURE GetName*(f: File; VAR name: ARRAY OF CHAR);
BEGIN
COPY (f.workName, name);
END GetName;
PROCEDURE Finalize(o: SYSTEM.PTR);
VAR f: File; res: LONGINT;
BEGIN
f := SYSTEM.VAL(File, o);
IF f.fd >= 0 THEN
fileTab[f.fd] := 0; res := Unix.Close(f.fd); f.fd := -1; DEC(Kernel.nofiles);
IF f.tempFile THEN res := Unix.Unlink(f.workName) END
END
END Finalize;
PROCEDURE Init;
VAR i: LONGINT;
BEGIN
i := 0; WHILE i < fileTabSize DO fileTab[i] := 0; INC(i) END ;
tempno := -1; Kernel.nofiles := 0
END Init;
BEGIN Init
END CompatFiles.

677
src/voc07R/x86_64/CompatFiles.Mod
View file

@ -1,677 +0,0 @@
MODULE CompatFiles; (* J. Templ 1.12. 89/12.4.95 Oberon files mapped onto Unix files *)
(* modified version of Files, which opens only the file provided and does not scan any path in any environment variable, also ReadLine procedure added; -- noch *)
IMPORT SYSTEM, Unix, Kernel, Args, 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;
fileTabSize = 64;
noDesc = -1;
notDone = -1;
(* file states *)
open = 0; create = 1; close = 2;
TYPE
FileName = ARRAY 101 OF CHAR;
File* = POINTER TO Handle;
Buffer = POINTER TO BufDesc;
Handle = RECORD
workName, registerName: FileName;
tempFile: BOOLEAN;
dev, ino, mtime: LONGINT;
fd-: INTEGER; len, pos: LONGINT;
bufs: ARRAY nofbufs OF Buffer;
swapper, state: INTEGER
END ;
BufDesc = RECORD
f: File;
chg: BOOLEAN;
org, size: LONGINT;
data: ARRAY bufsize OF SYSTEM.BYTE
END ;
Rider* = RECORD
res*: LONGINT;
eof*: BOOLEAN;
buf: Buffer;
org, offset: LONGINT
END ;
Time = POINTER TO TimeDesc;
TimeDesc = RECORD
sec*, min*, hour*, mday*, mon*, year*, wday*, isdst*, zone*, gmtoff*: LONGINT;
(* sec*, min*, hour*, mday*, mon*, year*, wday*, isdst*, zone*, gmtoff*: INTEGER;*)
END ;
VAR
fileTab: ARRAY fileTabSize OF LONGINT (*=File*);
tempno: INTEGER;
(* for localtime *)
PROCEDURE -includetime()
'#include "time.h"';
PROCEDURE -localtime(VAR clock: LONGINT): Time
"(CompatFiles_Time) localtime(clock)";
PROCEDURE -getcwd(VAR cwd: Unix.Name)
"getcwd(cwd, cwd__len)";
PROCEDURE -IdxTrap "__HALT(-1)";
PROCEDURE^ Finalize(o: SYSTEM.PTR);
PROCEDURE Err(s: ARRAY OF CHAR; f: File; errno: LONGINT);
BEGIN
Console.Ln; Console.String("-- "); Console.String(s); Console.String(": ");
IF f # NIL THEN
IF f.registerName # "" THEN Console.String(f.registerName) ELSE Console.String(f.workName) END
END ;
IF errno # 0 THEN Console.String(" errno = "); Console.Int(errno, 1) END ;
Console.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 Kernel.CWD[i] # 0X DO name[i] := Kernel.CWD[i]; INC(i) END;
IF Kernel.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 := SHORT(Unix.Getpid());
WHILE n > 0 DO name[i] := CHR(n MOD 10 + ORD("0")); n := n DIV 10; INC(i) END;
name[i] := 0X
END GetTempName;
PROCEDURE Create(f: File);
VAR stat: Unix.Status; done: BOOLEAN;
errno: LONGINT; err: ARRAY 32 OF CHAR;
BEGIN
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 ;
errno := Unix.Unlink(f.workName); (*unlink first to avoid stale NFS handles and to avoid reuse of inodes*)
f.fd := Unix.Open(f.workName, SYSTEM.VAL(INTEGER, Unix.rdwr + Unix.creat + Unix.trunc), SYSTEM.VAL(LONGINT, {2, 4,5, 7,8}));
done := f.fd >= 0; errno := Unix.errno();
IF (~done & ((errno = Unix.ENFILE) OR (errno = Unix.EMFILE))) OR (done & (f.fd >= fileTabSize)) THEN
IF done & (f.fd >= fileTabSize) THEN errno := Unix.Close(f.fd) END ;
Kernel.GC(TRUE);
f.fd := Unix.Open(f.workName, SYSTEM.VAL(INTEGER, Unix.rdwr + Unix.creat + Unix.trunc), SYSTEM.VAL(LONGINT, {2, 4,5, 7,8}));
done := f.fd >= 0
END ;
IF done THEN
IF f.fd >= fileTabSize THEN errno := Unix.Close(f.fd); Err("too many files open", f, 0)
ELSE fileTab[f.fd] := SYSTEM.VAL(LONGINT, f); INC(Kernel.nofiles); Kernel.RegisterObject(f, Finalize);
f.state := open; f.pos := 0; errno := Unix.Fstat(f.fd, stat);
f.dev := stat.dev; f.ino := stat.ino; f.mtime := stat.mtime
END
ELSE errno := Unix.errno();
IF errno = Unix.ENOENT THEN err := "no such directory"
ELSIF (errno = Unix.ENFILE) OR (errno = Unix.EMFILE) THEN err := "too many files open"
ELSE err := "file not created"
END ;
Err(err, f, errno)
END
END
END Create;
PROCEDURE Flush(buf: Buffer);
VAR res: LONGINT; f: File; stat: Unix.Status;
BEGIN
IF buf.chg THEN f := buf.f; Create(f);
IF buf.org # f.pos THEN res := Unix.Lseek(f.fd, buf.org, 0) END ;
res := Unix.Write(f.fd, SYSTEM.ADR(buf.data), buf.size);
IF res < 0 THEN Err("error in writing file", f, Unix.errno()) END ;
f.pos := buf.org + buf.size;
buf.chg := FALSE;
res := Unix.Fstat(f.fd, stat);
f.mtime := stat.mtime
END
END Flush;
PROCEDURE Close* (f: File);
VAR i, res: LONGINT;
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 ;
res := Unix.Fsync(f.fd);
IF res < 0 THEN Err("error in writing file", f, Unix.errno()) END
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); (* supports ~, ~user and blanks inside path *)
VAR i: INTEGER; ch: CHAR; home: ARRAY 256 OF CHAR;
BEGIN
i := 0; ch := Kernel.OBERON[pos];
WHILE (ch = " ") OR (ch = ":") DO INC(pos); ch := Kernel.OBERON[pos] END ;
IF ch = "~" THEN
INC(pos); ch := Kernel.OBERON[pos];
home := ""; Args.GetEnv("HOME", home);
WHILE home[i] # 0X DO dir[i] := home[i]; INC(i) END ;
IF (ch # "/") & (ch # 0X) & (ch # ":") & (ch # " ") THEN
WHILE (i > 0) & (dir[i-1] # "/") DO DEC(i) END
END
END ;
WHILE (ch # 0X) & (ch # ":") DO dir[i] := ch; INC(i); INC(pos); ch := Kernel.OBERON[pos] END ;
WHILE (i > 0) & (dir[i-1] = " ") DO DEC(i) END ;
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(dev, ino: LONGINT; mtime: LONGINT): File;
VAR f: File; i: INTEGER; stat: Unix.Status; res: LONGINT;
BEGIN i := 0;
WHILE i < fileTabSize DO
f := SYSTEM.VAL(File, fileTab[i]);
IF (f # NIL) & (ino = f.ino) & (dev = f.dev) THEN
IF mtime # f.mtime THEN i := 0;
WHILE i < nofbufs DO
IF f.bufs[i] # NIL THEN f.bufs[i].org := -1; f.bufs[i] := NIL END ;
INC(i)
END ;
f.swapper := -1; f.mtime := mtime;
res := Unix.Fstat(f.fd, stat); f.len := stat.size
END ;
RETURN f
END ;
INC(i)
END ;
RETURN NIL
END CacheEntry;
PROCEDURE Old* (name: ARRAY OF CHAR): File;
VAR f: File; fd, res: INTEGER; errno: LONGINT; pos: INTEGER; done: BOOLEAN;
dir, path: ARRAY 256 OF CHAR;
stat: Unix.Status;
BEGIN
IF name # "" THEN
IF HasDir(name) THEN dir := ""; COPY(name, path)
ELSE
pos := 0;
COPY(name, path); (* -- noch *)
(*ScanPath(pos, dir);*) (*MakeFileName(dir, name, path);*) (*ScanPath(pos, dir)*)
END ;
LOOP
fd := Unix.Open(path, SYSTEM.VAL(INTEGER, Unix.rdwr), (*{}*) 0); done := fd >= 0; errno := Unix.errno();
IF (~done & ((errno = Unix.ENFILE) OR (errno = Unix.EMFILE))) OR (done & (fd >= fileTabSize)) THEN
IF done & (fd >= fileTabSize) THEN res := Unix.Close(fd) END ;
Kernel.GC(TRUE);
fd := Unix.Open(path, SYSTEM.VAL(INTEGER, Unix.rdwr), (*{}*)0);
done := fd >= 0; errno := Unix.errno();
IF ~done & ((errno = Unix.ENFILE) OR (errno = Unix.EMFILE)) THEN Err("too many files open", f, errno) END
END ;
IF ~done & ((errno = Unix.EACCES) OR (errno = Unix.EROFS) OR (errno = Unix.EAGAIN)) THEN
(* errno EAGAIN observed on Solaris 2.4 *)
fd := Unix.Open(path, SYSTEM.VAL(INTEGER, Unix.rdonly), (*{}*)0); done := fd >= 0; errno := Unix.errno()
END ;
IF (~done) & (errno # Unix.ENOENT) THEN
Console.String("warning Files.Old "); Console.String(name);
Console.String(" errno = "); Console.Int(errno, 0); Console.Ln;
END ;
IF done THEN
res := Unix.Fstat(fd, stat);
f := CacheEntry(stat.dev, stat.ino, stat.mtime);
IF f # NIL THEN res := Unix.Close(fd); RETURN f
ELSIF fd >= fileTabSize THEN res := Unix.Close(fd); Err("too many files open", f, 0)
ELSE NEW(f); fileTab[fd] := SYSTEM.VAL(LONGINT, f); INC(Kernel.nofiles); Kernel.RegisterObject(f, Finalize);
f.fd := fd; f.state := open; f.len := stat.size; f.pos := 0; f.swapper := -1; (*all f.buf[i] = NIL*)
COPY(name, f.workName); f.registerName := ""; f.tempFile := FALSE;
f.dev := stat.dev; f.ino := stat.ino; f.mtime := stat.mtime;
RETURN f
END
ELSIF dir = "" THEN RETURN NIL
ELSE (*MakeFileName(dir, name, path);*) (*ScanPath(pos, dir)*)
RETURN NIL
END
END
ELSE RETURN NIL
END
END Old;
PROCEDURE Purge* (f: File);
VAR i: INTEGER; stat: Unix.Status; res: LONGINT;
BEGIN i := 0;
WHILE i < nofbufs DO
IF f.bufs[i] # NIL THEN f.bufs[i].org := -1; f.bufs[i] := NIL END ;
INC(i)
END ;
IF f.fd # noDesc THEN res := Unix.Ftruncate(f.fd, 0); res := Unix.Lseek(f.fd, 0, 0) END ;
f.pos := 0; f.len := 0; f.swapper := -1;
res := Unix.Fstat(f.fd, stat); f.mtime := stat.mtime
END Purge;
PROCEDURE GetDate* (f: File; VAR t, d: LONGINT);
VAR stat: Unix.Status; clock, res: LONGINT; time: Time;
BEGIN
Create(f); res := Unix.Fstat(f.fd, stat);
time := localtime(stat.mtime);
t := time.sec + ASH(time.min, 6) + ASH(time.hour, 12);
d := time.mday + ASH(time.mon+1, 5) + ASH(time.year MOD 100, 9)
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, res: LONGINT; buf: Buffer;
BEGIN
IF f # NIL THEN
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 res := Unix.Lseek(f.fd, org, 0) END ;
n := Unix.ReadBlk(f.fd, buf.data);
IF n < 0 THEN Err("read from file not done", f, Unix.errno()) END ;
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) + offset, SYSTEM.ADR(x) + xpos, min);
INC(offset, min); r.offset := offset; INC(xpos, min); DEC(n, min)
END ;
r.res := 0; r.eof := FALSE
END ReadBytes;
PROCEDURE ReadByte* (VAR r : Rider; VAR x : ARRAY OF SYSTEM.BYTE);
BEGIN
ReadBytes(r, x, 1);
END ReadByte;
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 WriteByte* (VAR r : Rider; x : SYSTEM.BYTE); (* added for compatibility with PO 2013, -- noch *)
BEGIN
Write(r, x);
END WriteByte;
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) + xpos, SYSTEM.ADR(buf.data) + offset, min);
INC(offset, min); r.offset := offset;
IF offset > buf.size THEN INC(buf.f.len, offset - buf.size); buf.size := offset END ;
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 := SHORT(Unix.Unlink(name));
res := SHORT(Unix.errno())
END Delete;
PROCEDURE Rename* (old, new: ARRAY OF CHAR; VAR res: INTEGER);
VAR fdold, fdnew: INTEGER; n, errno, r: LONGINT;
ostat, nstat: Unix.Status;
buf: ARRAY 4096 OF CHAR;
BEGIN
r := Unix.Stat(old, ostat);
IF r >= 0 THEN
r := Unix.Stat(new, nstat);
IF (r >= 0) & ((ostat.dev # nstat.dev) OR (ostat.ino # nstat.ino)) THEN
Delete(new, res); (* work around stale nfs handles *)
END ;
r := Unix.Rename(old, new);
IF r < 0 THEN res := SHORT(Unix.errno());
IF res = Unix.EXDEV THEN (* cross device link, move the file *)
fdold := Unix.Open(old, SYSTEM.VAL(INTEGER, Unix.rdonly), (*{}*)0);
IF fdold < 0 THEN res := 2; RETURN END ;
fdnew := Unix.Open(new, SYSTEM.VAL(INTEGER, Unix.rdwr + Unix.creat + Unix.trunc), SYSTEM.VAL(LONGINT, {2, 4,5, 7,8}));
IF fdnew < 0 THEN r := Unix.Close(fdold); res := 3; RETURN END ;
n := Unix.Read(fdold, SYSTEM.ADR(buf), bufsize);
WHILE n > 0 DO
r := Unix.Write(fdnew, SYSTEM.ADR(buf), n);
IF r < 0 THEN errno := Unix.errno(); r := Unix.Close(fdold); r := Unix.Close(fdnew);
Err("cannot move file", NIL, errno)
END ;
n := Unix.Read(fdold, SYSTEM.ADR(buf), bufsize)
END ;
errno := Unix.errno();
r := Unix.Close(fdold); r := Unix.Close(fdnew);
IF n = 0 THEN r := Unix.Unlink(old); res := 0
ELSE Err("cannot move file", NIL, errno)
END ;
ELSE RETURN (* res is Unix.Rename return code *)
END
END ;
res := 0
ELSE res := 2 (* old file not found *)
END
END Rename;
PROCEDURE Register* (f: File);
VAR idx, errno: INTEGER; f1: File; file: ARRAY 104 OF CHAR;
BEGIN
IF (f.state = create) & (f.registerName # "") THEN f.state := close (* shortcut renaming *) END ;
Close(f);
IF f.registerName # "" THEN
Rename(f.workName, f.registerName, errno);
IF errno # 0 THEN COPY(f.registerName, file); HALT(99) END ;
f.workName := f.registerName; f.registerName := ""; f.tempFile := FALSE
END
END Register;
PROCEDURE ChangeDirectory*(path: ARRAY OF CHAR; VAR res: INTEGER);
BEGIN
res := SHORT(Unix.Chdir(path));
getcwd(Kernel.CWD)
END ChangeDirectory;
PROCEDURE FlipBytes(VAR src, dest: ARRAY OF SYSTEM.BYTE);
VAR i, j: LONGINT;
BEGIN
IF ~Kernel.littleEndian THEN i := LEN(src); j := 0;
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 ReadInt* (VAR R: Rider; VAR x: LONGINT); (* to compile OR compiler; -- noch *)
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 ReadInt;
PROCEDURE ReadLInt* (VAR R: Rider; VAR x: LONGINT);
VAR b: ARRAY 4 OF CHAR;
BEGIN ReadBytes(R, b, 4);
x := ORD(b[0]) + ORD(b[1])*100H + ORD(b[2])*10000H + ORD(b[3])*1000000H
END ReadLInt;
PROCEDURE ReadSet* (VAR R: Rider; VAR x: SET);
VAR b: ARRAY 4 OF CHAR;
BEGIN ReadBytes(R, b, 4);
x := SYSTEM.VAL(SET, ORD(b[0]) + ORD(b[1])*100H + ORD(b[2])*10000H + ORD(b[3])*1000000H)
END ReadSet;
PROCEDURE ReadReal* (VAR R: Rider; VAR x: REAL);
VAR b: ARRAY 4 OF CHAR;
BEGIN ReadBytes(R, b, 4); FlipBytes(b, x)
END ReadReal;
PROCEDURE ReadLReal* (VAR R: Rider; VAR x: LONGREAL);
VAR b: ARRAY 8 OF CHAR;
BEGIN ReadBytes(R, b, 8); FlipBytes(b, x)
END ReadLReal;
PROCEDURE ReadString* (VAR R: Rider; VAR x: ARRAY OF CHAR);
VAR i: INTEGER; ch: CHAR;
BEGIN i := 0;
REPEAT Read(R, ch); x[i] := ch; INC(i) UNTIL ch = 0X
END ReadString;
(* need to read line; -- noch *)
PROCEDURE ReadLine* (VAR R: Rider; VAR x: ARRAY OF CHAR);
VAR i: INTEGER; ch: CHAR; b : BOOLEAN;
BEGIN i := 0;
b := FALSE;
REPEAT
Read(R, ch);
IF ((ch = 0X) OR (ch = 0AX) OR (ch = 0DX)) THEN
b := TRUE
ELSE
x[i] := ch;
INC(i);
END;
UNTIL b
END ReadLine;
PROCEDURE ReadNum* (VAR R: Rider; VAR x: LONGINT);
VAR s: SHORTINT; ch: CHAR; n: LONGINT;
BEGIN s := 0; n := 0; Read(R, ch);
WHILE ORD(ch) >= 128 DO INC(n, ASH(ORD(ch) - 128, s) ); INC(s, 7); Read(R, ch) END;
INC(n, ASH(ORD(ch) MOD 64 - ORD(ch) DIV 64 * 64, s) );
x := n
END ReadNum;
PROCEDURE WriteBool* (VAR R: Rider; x: BOOLEAN);
BEGIN Write(R, SYSTEM.VAL(CHAR, x))
END WriteBool;
(* PROCEDURE WriteInt* (VAR R: Rider; x: INTEGER);
VAR b: ARRAY 2 OF CHAR;
BEGIN b[0] := CHR(x); b[1] := CHR(x DIV 256);
WriteBytes(R, b, 2);
END WriteInt;
*)
PROCEDURE WriteInt* (VAR R: Rider; x: LONGINT); (* to compile OR compiler; -- noch *)
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 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: LONGINT);
BEGIN
WHILE (x < - 64) OR (x > 63) DO Write(R, CHR(x MOD 128 + 128)); x := x DIV 128 END;
Write(R, CHR(x MOD 128))
END WriteNum;
PROCEDURE GetName*(f: File; VAR name: ARRAY OF CHAR);
BEGIN
COPY (f.workName, name);
END GetName;
PROCEDURE Finalize(o: SYSTEM.PTR);
VAR f: File; res: LONGINT;
BEGIN
f := SYSTEM.VAL(File, o);
IF f.fd >= 0 THEN
fileTab[f.fd] := 0; res := Unix.Close(f.fd); f.fd := -1; DEC(Kernel.nofiles);
IF f.tempFile THEN res := Unix.Unlink(f.workName) END
END
END Finalize;
PROCEDURE Init;
VAR i: LONGINT;
BEGIN
i := 0; WHILE i < fileTabSize DO fileTab[i] := 0; INC(i) END ;
tempno := -1; Kernel.nofiles := 0
END Init;
BEGIN Init
END CompatFiles.