From a22c894fd4d90a9a179871000274bbf6c8b4494b Mon Sep 17 00:00:00 2001 From: norayr Date: Tue, 29 Nov 2016 13:13:48 +0400 Subject: [PATCH] removed ORP PO13 compiler version from the voc source tree. -- noch --- src/voc07R/CompatTexts.Mod | 585 --------------- src/voc07R/Fonts.Mod | 146 ---- src/voc07R/ORB.Mod | 447 ------------ src/voc07R/ORG.Mod | 1134 ----------------------------- src/voc07R/ORP.Mod | 997 ------------------------- src/voc07R/ORS.Mod | 325 --------- src/voc07R/ORTool.Mod | 251 ------- src/voc07R/Oberon.Mod | 111 --- src/voc07R/Oberon10.Scn.Fnt | Bin 2284 -> 0 bytes src/voc07R/README.md | 29 - src/voc07R/makefile | 22 - src/voc07R/test/Oberon.rsc | Bin 7295 -> 0 bytes src/voc07R/test/Oberon.smb | Bin 1372 -> 0 bytes src/voc07R/test/Test.Mod | Bin 248 -> 0 bytes src/voc07R/test/Texts.rsc | Bin 12142 -> 0 bytes src/voc07R/test/Texts.smb | Bin 1212 -> 0 bytes src/voc07R/test/readme | 3 - src/voc07R/x86/CompatFiles.Mod | 677 ----------------- src/voc07R/x86_64/CompatFiles.Mod | 677 ----------------- 19 files changed, 5404 deletions(-) delete mode 100644 src/voc07R/CompatTexts.Mod delete mode 100644 src/voc07R/Fonts.Mod delete mode 100644 src/voc07R/ORB.Mod delete mode 100644 src/voc07R/ORG.Mod delete mode 100644 src/voc07R/ORP.Mod delete mode 100644 src/voc07R/ORS.Mod delete mode 100644 src/voc07R/ORTool.Mod delete mode 100644 src/voc07R/Oberon.Mod delete mode 100644 src/voc07R/Oberon10.Scn.Fnt delete mode 100644 src/voc07R/README.md delete mode 100644 src/voc07R/makefile delete mode 100644 src/voc07R/test/Oberon.rsc delete mode 100644 src/voc07R/test/Oberon.smb delete mode 100644 src/voc07R/test/Test.Mod delete mode 100644 src/voc07R/test/Texts.rsc delete mode 100644 src/voc07R/test/Texts.smb delete mode 100644 src/voc07R/test/readme delete mode 100644 src/voc07R/x86/CompatFiles.Mod delete mode 100644 src/voc07R/x86_64/CompatFiles.Mod diff --git a/src/voc07R/CompatTexts.Mod b/src/voc07R/CompatTexts.Mod deleted file mode 100644 index 8e8b45ac..00000000 --- a/src/voc07R/CompatTexts.Mod +++ /dev/null @@ -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. diff --git a/src/voc07R/Fonts.Mod b/src/voc07R/Fonts.Mod deleted file mode 100644 index 15dabaf1..00000000 --- a/src/voc07R/Fonts.Mod +++ /dev/null @@ -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. diff --git a/src/voc07R/ORB.Mod b/src/voc07R/ORB.Mod deleted file mode 100644 index 3427bb2e..00000000 --- a/src/voc07R/ORB.Mod +++ /dev/null @@ -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. diff --git a/src/voc07R/ORG.Mod b/src/voc07R/ORG.Mod deleted file mode 100644 index fef42932..00000000 --- a/src/voc07R/ORG.Mod +++ /dev/null @@ -1,1134 +0,0 @@ -MODULE ORG; (* NW 24.6.2014 code generator in Oberon-07 for RISC*) - IMPORT SYSTEM, Files := CompatFiles, ORS, ORB; - (*Code generator for Oberon compiler for RISC processor. - Procedural interface to Parser OSAP; result in array "code". - Procedure Close writes code-files*) - - (* voc adaptation by noch *) - TYPE INTEGER = LONGINT; - BYTE = CHAR; - - CONST WordSize* = 4; - StkOrg0 = -64; VarOrg0 = 0; (*for RISC-0 only*) - MT = 12; SB = 13; SP = 14; LNK = 15; (*dedicated registers*) - maxCode = 8000; maxStrx = 2400; maxTD = 120; C24 = 1000000H; - Reg = 10; RegI = 11; Cond = 12; (*internal item modes*) - - (*frequently used opcodes*) U = 2000H; V = 1000H; - Mov = 0; Lsl = 1; Asr = 2; Ror= 3; And = 4; Ann = 5; Ior = 6; Xor = 7; - Add = 8; Sub = 9; Cmp = 9; Mul = 10; Div = 11; - Fad = 12; Fsb = 13; Fml = 14; Fdv = 15; - Ldr = 8; Str = 10; - BR = 0; BLR = 1; BC = 2; BL = 3; - MI = 0; PL = 8; EQ = 1; NE = 9; LT = 5; GE = 13; LE = 6; GT = 14; - - TYPE Item* = RECORD - mode*: INTEGER; - type*: ORB.Type; - a*, b*, r: LONGINT; - rdo*: BOOLEAN (*read only*) - END ; - - (* Item forms and meaning of fields: - mode r a b - -------------------------------- - Const - value (proc adr) (immediate value) - Var base off - (direct adr) - Par - off0 off1 (indirect adr) - Reg regno - RegI regno off - - Cond cond Fchain Tchain *) - - VAR pc*, varsize: LONGINT; (*program counter, data index*) - tdx, strx: LONGINT; - entry: LONGINT; (*main entry point*) - RH: LONGINT; (*available registers R[0] ... R[H-1]*) - curSB: LONGINT; (*current static base in SB*) - frame: LONGINT; (*frame offset changed in SaveRegs and RestoreRegs*) - fixorgP, fixorgD, fixorgT: LONGINT; (*origins of lists of locations to be fixed up by loader*) - check: BOOLEAN; (*emit run-time checks*) - version: INTEGER; (* 0 = RISC-0, 1 = RISC-5 *) - - relmap: ARRAY 6 OF INTEGER; (*condition codes for relations*) - code: ARRAY maxCode OF LONGINT; - data: ARRAY maxTD OF LONGINT; (*type descriptors*) - str: ARRAY maxStrx OF CHAR; - - (* voc adaptation by noch *) - PROCEDURE LSL (x, n : INTEGER): INTEGER; - - BEGIN - - RETURN ASH(x, n); - END LSL; - - - (*instruction assemblers according to formats*) - - PROCEDURE Put0(op, a, b, c: LONGINT); - BEGIN (*emit format-0 instruction*) - code[pc] := ((a*10H + b) * 10H + op) * 10000H + c; INC(pc) - END Put0; - - PROCEDURE Put1(op, a, b, im: LONGINT); - BEGIN (*emit format-1 instruction, -10000H <= im < 10000H*) - IF im < 0 THEN INC(op, V) END ; - code[pc] := (((a+40H) * 10H + b) * 10H + op) * 10000H + (im MOD 10000H); INC(pc) - END Put1; - - PROCEDURE Put1a(op, a, b, im: LONGINT); - BEGIN (*same as Pu1, but with range test -10000H <= im < 10000H*) - IF (im >= -10000H) & (im <= 0FFFFH) THEN Put1(op, a, b, im) - ELSE Put1(Mov+U, RH, 0, im DIV 10000H); - IF im MOD 10000H # 0 THEN Put1(Ior, RH, RH, im MOD 10000H) END ; - Put0(op, a, b, RH) - END - END Put1a; - - PROCEDURE Put2(op, a, b, off: LONGINT); - BEGIN (*emit load/store instruction*) - code[pc] := ((op * 10H + a) * 10H + b) * 100000H + (off MOD 100000H); INC(pc) - END Put2; - - PROCEDURE Put3(op, cond, off: LONGINT); - BEGIN (*emit branch instruction*) - code[pc] := ((op+12) * 10H + cond) * 1000000H + (off MOD 1000000H); INC(pc) - END Put3; - - PROCEDURE incR; - BEGIN - IF RH < MT-1 THEN INC(RH) ELSE ORS.Mark("register stack overflow") END - END incR; - - PROCEDURE CheckRegs*; - BEGIN - IF RH # 0 THEN ORS.Mark("Reg Stack"); RH := 0 END ; - IF pc >= maxCode - 40 THEN ORS.Mark("Program too long") END - END CheckRegs; - - PROCEDURE SetCC(VAR x: Item; n: LONGINT); - BEGIN x.mode := Cond; x.a := 0; x.b := 0; x.r := n - END SetCC; - - PROCEDURE Trap(cond, num: LONGINT); - BEGIN num := ORS.Pos()*100H + num*10H + MT; Put3(BLR, cond, num) - END Trap; - - (*handling of forward reference, fixups of branch addresses and constant tables*) - - PROCEDURE negated(cond: LONGINT): LONGINT; - BEGIN - IF cond < 8 THEN cond := cond+8 ELSE cond := cond-8 END ; - RETURN cond - END negated; - - PROCEDURE invalSB; - BEGIN curSB := 1 - END invalSB; - - PROCEDURE fix(at, with: LONGINT); - BEGIN code[at] := code[at] DIV C24 * C24 + (with MOD C24) - END fix; - - PROCEDURE FixLink*(L: LONGINT); - VAR L1: LONGINT; - BEGIN invalSB; - WHILE L # 0 DO L1 := code[L] MOD 40000H; fix(L, pc-L-1); L := L1 END - END FixLink; - - PROCEDURE FixLinkWith(L0, dst: LONGINT); - VAR L1: LONGINT; - BEGIN - WHILE L0 # 0 DO - L1 := code[L0] MOD C24; - code[L0] := code[L0] DIV C24 * C24 + ((dst - L0 - 1) MOD C24); L0 := L1 - END - END FixLinkWith; - - PROCEDURE merged(L0, L1: LONGINT): LONGINT; - VAR L2, L3: LONGINT; - BEGIN - IF L0 # 0 THEN L3 := L0; - REPEAT L2 := L3; L3 := code[L2] MOD 40000H UNTIL L3 = 0; - code[L2] := code[L2] + L1; L1 := L0 - END ; - RETURN L1 - END merged; - - (* loading of operands and addresses into registers *) - - PROCEDURE GetSB(base: LONGINT); - BEGIN - IF (version # 0) & ((base # curSB) OR (base # 0)) THEN - Put2(Ldr, SB, -base, pc-fixorgD); fixorgD := pc-1; curSB := base - END - END GetSB; - - PROCEDURE NilCheck; - BEGIN IF check THEN Trap(EQ, 4) END - END NilCheck; - - PROCEDURE load(VAR x: Item); - VAR op: LONGINT; - BEGIN - IF x.type.size = 1 THEN op := Ldr+1 ELSE op := Ldr END ; - IF x.mode # Reg THEN - IF x.mode = ORB.Const THEN - IF x.type.form = ORB.Proc THEN - IF x.r > 0 THEN ORS.Mark("not allowed") - ELSIF x.r = 0 THEN Put3(BL, 7, 0); Put1a(Sub, RH, LNK, pc*4 - x.a) - ELSE GetSB(x.r); Put1(Add, RH, SB, x.a + 100H) (*mark as progbase-relative*) - END - ELSIF (x.a <= 0FFFFH) & (x.a >= -10000H) THEN Put1(Mov, RH, 0, x.a) - ELSE Put1(Mov+U, RH, 0, x.a DIV 10000H MOD 10000H); - IF x.a MOD 10000H # 0 THEN Put1(Ior, RH, RH, x.a MOD 10000H) END - END ; - x.r := RH; incR - ELSIF x.mode = ORB.Var THEN - IF x.r > 0 THEN (*local*) Put2(op, RH, SP, x.a + frame) - ELSE GetSB(x.r); Put2(op, RH, SB, x.a) - END ; - x.r := RH; incR - ELSIF x.mode = ORB.Par THEN Put2(Ldr, RH, SP, x.a + frame); Put2(op, RH, RH, x.b); x.r := RH; incR - ELSIF x.mode = RegI THEN Put2(op, x.r, x.r, x.a) - ELSIF x.mode = Cond THEN - Put3(BC, negated(x.r), 2); - FixLink(x.b); Put1(Mov, RH, 0, 1); Put3(BC, 7, 1); - FixLink(x.a); Put1(Mov, RH, 0, 0); x.r := RH; incR - END ; - x.mode := Reg - END - END load; - - PROCEDURE loadAdr(VAR x: Item); - BEGIN - IF x.mode = ORB.Var THEN - IF x.r > 0 THEN (*local*) Put1a(Add, RH, SP, x.a + frame) - ELSE GetSB(x.r); Put1a(Add, RH, SB, x.a) - END ; - x.r := RH; incR - ELSIF x.mode = ORB.Par THEN Put2(Ldr, RH, SP, x.a + frame); - IF x.b # 0 THEN Put1a(Add, RH, RH, x.b) END ; - x.r := RH; incR - ELSIF x.mode = RegI THEN - IF x.a # 0 THEN Put1a(Add, x.r, x.r, x.a) END - ELSE ORS.Mark("address error") - END ; - x.mode := Reg - END loadAdr; - - PROCEDURE loadCond(VAR x: Item); - BEGIN - IF x.type.form = ORB.Bool THEN - IF x.mode = ORB.Const THEN x.r := 15 - x.a*8 - ELSE load(x); - IF code[pc-1] DIV 40000000H # -2 THEN Put1(Cmp, x.r, x.r, 0) END ; - x.r := NE; DEC(RH) - END ; - x.mode := Cond; x.a := 0; x.b := 0 - ELSE ORS.Mark("not Boolean?") - END - END loadCond; - - PROCEDURE loadTypTagAdr(T: ORB.Type); - VAR x: Item; - BEGIN x.mode := ORB.Var; x.a := T.len; x.r := -T.mno; loadAdr(x) - END loadTypTagAdr; - - PROCEDURE loadStringAdr(VAR x: Item); - BEGIN GetSB(0); Put1a(Add, RH, SB, varsize+x.a); x.mode := Reg; x.r := RH; incR - END loadStringAdr; - - (* Items: Conversion from constants or from Objects on the Heap to Items on the Stack*) - - PROCEDURE MakeConstItem*(VAR x: Item; typ: ORB.Type; val: LONGINT); - BEGIN x.mode := ORB.Const; x.type := typ; x.a := val - END MakeConstItem; - - PROCEDURE MakeRealItem*(VAR x: Item; val: REAL); - BEGIN x.mode := ORB.Const; x.type := ORB.realType; x.a := SYSTEM.VAL(LONGINT, val) - END MakeRealItem; - - PROCEDURE MakeStringItem*(VAR x: Item; len: LONGINT); (*copies string from ORS-buffer to ORG-string array*) - VAR i: LONGINT; - BEGIN x.mode := ORB.Const; x.type := ORB.strType; x.a := strx; x.b := len; i := 0; - IF strx + len + 4 < maxStrx THEN - WHILE len > 0 DO str[strx] := ORS.str[i]; INC(strx); INC(i); DEC(len) END ; - WHILE strx MOD 4 # 0 DO str[strx] := 0X; INC(strx) END - ELSE ORS.Mark("too many strings") - END - END MakeStringItem; - - PROCEDURE MakeItem*(VAR x: Item; y: ORB.Object; curlev: LONGINT); - BEGIN x.mode := y.class; x.type := y.type; x.a := y.val; x.rdo := y.rdo; - IF y.class = ORB.Par THEN x.b := 0 - ELSIF y.class = ORB.Typ THEN x.a := y.type.len; x.r := -y.lev - ELSIF (y.class = ORB.Const) & (y.type.form = ORB.String) THEN x.b := y.lev (*len*) - ELSE x.r := y.lev - END ; - IF (y.lev > 0) & (y.lev # curlev) & (y.class # ORB.Const) THEN ORS.Mark("level error, not accessible") END - END MakeItem; - - (* Code generation for Selectors, Variables, Constants *) - - PROCEDURE Field*(VAR x: Item; y: ORB.Object); (* x := x.y *) - BEGIN; - IF x.mode = ORB.Var THEN - IF x.r >= 0 THEN x.a := x.a + y.val - ELSE loadAdr(x); x.mode := RegI; x.a := y.val - END - ELSIF x.mode = RegI THEN x.a := x.a + y.val - ELSIF x.mode = ORB.Par THEN x.b := x.b + y.val - END - END Field; - - PROCEDURE Index*(VAR x, y: Item); (* x := x[y] *) - VAR s, lim: LONGINT; - BEGIN s := x.type.base.size; lim := x.type.len; - IF (y.mode = ORB.Const) & (lim >= 0) THEN - IF (y.a < 0) OR (y.a >= lim) THEN ORS.Mark("bad index") END ; - IF x.mode IN {ORB.Var, RegI} THEN x.a := y.a * s + x.a - ELSIF x.mode = ORB.Par THEN x.b := y.a * s + x.b - END - ELSE load(y); - IF check THEN (*check array bounds*) - IF lim >= 0 THEN Put1a(Cmp, RH, y.r, lim) - ELSE (*open array*) - IF x.mode IN {ORB.Var, ORB.Par} THEN Put2(Ldr, RH, SP, x.a+4+frame); Put0(Cmp, RH, y.r, RH) - ELSE ORS.Mark("error in Index") - END - END ; - Trap(10, 1) (*BCC*) - END ; - IF s = 4 THEN Put1(Lsl, y.r, y.r, 2) ELSIF s > 1 THEN Put1a(Mul, y.r, y.r, s) END ; - IF x.mode = ORB.Var THEN - IF x.r > 0 THEN Put0(Add, y.r, SP, y.r); INC(x.a, frame) - ELSE GetSB(x.r); - IF x.r = 0 THEN Put0(Add, y.r, SB, y.r) - ELSE Put1a(Add, RH, SB, x.a); Put0(Add, y.r, RH, y.r); x.a := 0 - END - END ; - x.r := y.r; x.mode := RegI - ELSIF x.mode = ORB.Par THEN - Put2(Ldr, RH, SP, x.a + frame); - Put0(Add, y.r, RH, y.r); x.mode := RegI; x.r := y.r; x.a := x.b - ELSIF x.mode = RegI THEN Put0(Add, x.r, x.r, y.r); DEC(RH) - END - END - END Index; - - PROCEDURE DeRef*(VAR x: Item); - BEGIN - IF x.mode = ORB.Var THEN - IF x.r > 0 THEN (*local*) Put2(Ldr, RH, SP, x.a + frame) ELSE GetSB(x.r); Put2(Ldr, RH, SB, x.a) END ; - NilCheck; x.r := RH; incR - ELSIF x.mode = ORB.Par THEN - Put2(Ldr, RH, SP, x.a + frame); Put2(Ldr, RH, RH, x.b); NilCheck; x.r := RH; incR - ELSIF x.mode = RegI THEN Put2(Ldr, x.r, x.r, x.a); NilCheck - ELSIF x.mode # Reg THEN ORS.Mark("bad mode in DeRef") - END ; - x.mode := RegI; x.a := 0; x.b := 0 - END DeRef; - - PROCEDURE Q(T: ORB.Type; VAR dcw: LONGINT); - BEGIN (*one entry of type descriptor extension table*) - IF T.base # NIL THEN - Q(T.base, dcw); data[dcw] := (T.mno*1000H + T.len) * 1000H + dcw - fixorgT; - fixorgT := dcw; INC(dcw) - END - END Q; - - PROCEDURE FindPtrFlds(typ: ORB.Type; off: LONGINT; VAR dcw: LONGINT); - VAR fld: ORB.Object; i, s: LONGINT; - BEGIN - IF (typ.form = ORB.Pointer) OR (typ.form = ORB.NilTyp) THEN data[dcw] := off; INC(dcw) - ELSIF typ.form = ORB.Record THEN - fld := typ.dsc; - WHILE fld # NIL DO FindPtrFlds(fld.type, fld.val + off, dcw); fld := fld.next END - ELSIF typ.form = ORB.Array THEN - s := typ.base.size; - FOR i := 0 TO typ.len-1 DO FindPtrFlds(typ.base, i*s + off, dcw) END - END - END FindPtrFlds; - - PROCEDURE BuildTD*(T: ORB.Type; VAR dc: LONGINT); - VAR dcw, k, s: LONGINT; (*dcw = word address*) - BEGIN dcw := dc DIV 4; s := T.size; (*convert size for heap allocation*) - IF s <= 24 THEN s := 32 ELSIF s <= 56 THEN s := 64 ELSIF s <= 120 THEN s := 128 - ELSE s := (s+263) DIV 256 * 256 - END ; - T.len := dc; data[dcw] := s; INC(dcw); - k := T.nofpar; (*extension level!*) - IF k > 3 THEN ORS.Mark("ext level too large") - ELSE Q(T, dcw); - WHILE k < 3 DO data[dcw] := -1; INC(dcw); INC(k) END - END ; - FindPtrFlds(T, 0, dcw); data[dcw] := -1; INC(dcw); tdx := dcw; dc := dcw*4; - IF tdx >= maxTD THEN ORS.Mark("too many record types"); tdx := 0 END - END BuildTD; - - PROCEDURE TypeTest*(VAR x: Item; T: ORB.Type; varpar, isguard: BOOLEAN); - VAR pc0: LONGINT; - BEGIN (*fetch tag into RH*) - IF varpar THEN Put2(Ldr, RH, SP, x.a+4+frame) - ELSE load(x); - pc0 := pc; Put3(BC, EQ, 0); (*NIL belongs to every pointer type*) - Put2(Ldr, RH, x.r, -8) - END ; - Put2(Ldr, RH, RH, T.nofpar*4); incR; - loadTypTagAdr(T); (*tag of T*) - Put0(Cmp, RH-1, RH-1, RH-2); DEC(RH, 2); - IF ~varpar THEN fix(pc0, pc - pc0 - 1) END ; - IF isguard THEN - IF check THEN Trap(NE, 2) END - ELSE SetCC(x, EQ); - IF ~varpar THEN DEC(RH) END - END - END TypeTest; - - (* Code generation for Boolean operators *) - - PROCEDURE Not*(VAR x: Item); (* x := ~x *) - VAR t: LONGINT; - BEGIN - IF x.mode # Cond THEN loadCond(x) END ; - x.r := negated(x.r); t := x.a; x.a := x.b; x.b := t - END Not; - - PROCEDURE And1*(VAR x: Item); (* x := x & *) - BEGIN - IF x.mode # Cond THEN loadCond(x) END ; - Put3(BC, negated(x.r), x.a); x.a := pc-1; FixLink(x.b); x.b := 0 - END And1; - - PROCEDURE And2*(VAR x, y: Item); - BEGIN - IF y.mode # Cond THEN loadCond(y) END ; - x.a := merged(y.a, x.a); x.b := y.b; x.r := y.r - END And2; - - PROCEDURE Or1*(VAR x: Item); (* x := x OR *) - BEGIN - IF x.mode # Cond THEN loadCond(x) END ; - Put3(BC, x.r, x.b); x.b := pc-1; FixLink(x.a); x.a := 0 - END Or1; - - PROCEDURE Or2*(VAR x, y: Item); - BEGIN - IF y.mode # Cond THEN loadCond(y) END ; - x.a := y.a; x.b := merged(y.b, x.b); x.r := y.r - END Or2; - - (* Code generation for arithmetic operators *) - - PROCEDURE Neg*(VAR x: Item); (* x := -x *) - BEGIN - IF x.type.form = ORB.Int THEN - IF x.mode = ORB.Const THEN x.a := -x.a - ELSE load(x); Put1(Mov, RH, 0, 0); Put0(Sub, x.r, RH, x.r) - END - ELSIF x.type.form = ORB.Real THEN - IF x.mode = ORB.Const THEN x.a := x.a + 7FFFFFFFH + 1 - ELSE load(x); Put1(Mov, RH, 0, 0); Put0(Fsb, x.r, RH, x.r) - END - ELSE (*form = Set*) - IF x.mode = ORB.Const THEN x.a := -x.a-1 - ELSE load(x); Put1(Xor, x.r, x.r, -1) - END - END - END Neg; - - PROCEDURE AddOp*(op: LONGINT; VAR x, y: Item); (* x := x +- y *) - BEGIN - IF op = ORS.plus THEN - IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN x.a := x.a + y.a - ELSIF y.mode = ORB.Const THEN load(x); - IF y.a # 0 THEN Put1a(Add, x.r, x.r, y.a) END - ELSE load(x); load(y); Put0(Add, RH-2, x.r, y.r); DEC(RH); x.r := RH-1 - END - ELSE (*op = ORS.minus*) - IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN x.a := x.a - y.a - ELSIF y.mode = ORB.Const THEN load(x); - IF y.a # 0 THEN Put1a(Sub, x.r, x.r, y.a) END - ELSE load(x); load(y); Put0(Sub, RH-2, x.r, y.r); DEC(RH); x.r := RH-1 - END - END - END AddOp; - - PROCEDURE log2(m: LONGINT; VAR e: LONGINT): LONGINT; - BEGIN e := 0; - WHILE ~ODD(m) DO m := m DIV 2; INC(e) END ; - RETURN m - END log2; - - PROCEDURE MulOp*(VAR x, y: Item); (* x := x * y *) - VAR e: LONGINT; - BEGIN - IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN x.a := x.a * y.a - ELSIF (y.mode = ORB.Const) & (y.a >= 2) & (log2(y.a, e) = 1) THEN load(x); Put1(Lsl, x.r, x.r, e) - ELSIF y.mode = ORB.Const THEN load(x); Put1a(Mul, x.r, x.r, y.a) - ELSIF (x.mode = ORB.Const) & (x.a >= 2) & (log2(x.a, e) = 1) THEN load(y); Put1(Lsl, y.r, y.r, e); x.mode := Reg; x.r := y.r - ELSIF x.mode = ORB.Const THEN load(y); Put1a(Mul, y.r, y.r, x.a); x.mode := Reg; x.r := y.r - ELSE load(x); load(y); Put0(Mul, RH-2, x.r, y.r); DEC(RH); x.r := RH-1 - END - END MulOp; - - PROCEDURE DivOp*(op: LONGINT; VAR x, y: Item); (* x := x op y *) - VAR e: LONGINT; - BEGIN - IF op = ORS.div THEN - IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN - IF y.a > 0 THEN x.a := x.a DIV y.a ELSE ORS.Mark("bad divisor") END - ELSIF (y.mode = ORB.Const) & (y.a >= 2) & (log2(y.a, e) = 1) THEN load(x); Put1(Asr, x.r, x.r, e) - ELSIF y.mode = ORB.Const THEN - IF y.a > 0 THEN load(x); Put1a(Div, x.r, x.r, y.a) ELSE ORS.Mark("bad divisor") END - ELSE load(y); - IF check THEN Trap(LE, 6) END ; - load(x); Put0(Div, RH-2, x.r, y.r); DEC(RH); x.r := RH-1 - END - ELSE (*op = ORS.mod*) - IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN - IF y.a > 0 THEN x.a := x.a MOD y.a ELSE ORS.Mark("bad modulus") END - ELSIF (y.mode = ORB.Const) & (y.a >= 2) & (log2(y.a, e) = 1) THEN load(x); - IF e <= 16 THEN Put1(And, x.r, x.r, y.a-1) ELSE Put1(Lsl, x.r, x.r, 32-e); Put1(Ror, x.r, x.r, 32-e) END - ELSIF y.mode = ORB.Const THEN - IF y.a > 0 THEN load(x); Put1a(Div, x.r, x.r, y.a); Put0(Mov+U, x.r, 0, 0) ELSE ORS.Mark("bad modulus") END - ELSE load(y); - IF check THEN Trap(LE, 6) END ; - load(x); Put0(Div, RH-2, x.r, y.r); Put0(Mov+U, RH-2, 0, 0); DEC(RH); x.r := RH-1 - END - END - END DivOp; - - (* Code generation for REAL operators *) - - PROCEDURE RealOp*(op: INTEGER; VAR x, y: Item); (* x := x op y *) - BEGIN load(x); load(y); - IF op = ORS.plus THEN Put0(Fad, RH-2, x.r, y.r) - ELSIF op = ORS.minus THEN Put0(Fsb, RH-2, x.r, y.r) - ELSIF op = ORS.times THEN Put0(Fml, RH-2, x.r, y.r) - ELSIF op = ORS.rdiv THEN Put0(Fdv, RH-2, x.r, y.r) - END ; - DEC(RH); x.r := RH-1 - END RealOp; - - (* Code generation for set operators *) - - PROCEDURE Singleton*(VAR x: Item); (* x := {x} *) - BEGIN - IF x.mode = ORB.Const THEN - x.a := LSL(1, x.a) - ELSE load(x); Put1(Mov, RH, 0, 1); Put0(Lsl, x.r, RH, x.r) - END - END Singleton; - - PROCEDURE Set*(VAR x, y: Item); (* x := {x .. y} *) - BEGIN - IF (x.mode = ORB.Const) & ( y.mode = ORB.Const) THEN - IF x.a <= y.a THEN x.a := LSL(2, y.a) - LSL(1, x.a) ELSE x.a := 0 END - ELSE - IF (x.mode = ORB.Const) & (x.a < 16) THEN x.a := LSL(-1, x.a) - ELSE load(x); Put1(Mov, RH, 0, -1); Put0(Lsl, x.r, RH, x.r) - END ; - IF (y.mode = ORB.Const) & (y.a < 16) THEN Put1(Mov, RH, 0, LSL(-2, y.a)); y.mode := Reg; y.r := RH; incR - ELSE load(y); Put1(Mov, RH, 0, -2); Put0(Lsl, y.r, RH, y.r) - END ; - IF x.mode = ORB.Const THEN - IF x.a # 0 THEN Put1(Xor, y.r, y.r, -1); Put1a(And, RH-1, y.r, x.a) END ; - x.mode := Reg; x.r := RH-1 - ELSE DEC(RH); Put0(Ann, RH-1, x.r, y.r) - END - END - END Set; - - PROCEDURE In*(VAR x, y: Item); (* x := x IN y *) - BEGIN load(y); - IF x.mode = ORB.Const THEN Put1(Ror, y.r, y.r, (x.a + 1) MOD 20H); DEC(RH) - ELSE load(x); Put1(Add, x.r, x.r, 1); Put0(Ror, y.r, y.r, x.r); DEC(RH, 2) - END ; - SetCC(x, MI) - END In; - - PROCEDURE SetOp*(op: LONGINT; VAR x, y: Item); (* x := x op y *) - VAR xset, yset: SET; (*x.type.form = Set*) - BEGIN - IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN - xset := SYSTEM.VAL(SET, x.a); yset := SYSTEM.VAL(SET, y.a); - IF op = ORS.plus THEN xset := xset + yset - ELSIF op = ORS.minus THEN xset := xset - yset - ELSIF op = ORS.times THEN xset := xset * yset - ELSIF op = ORS.rdiv THEN xset := xset / yset - END ; - x.a := SYSTEM.VAL(LONGINT, xset) - ELSIF y.mode = ORB.Const THEN - load(x); - IF op = ORS.plus THEN Put1a(Ior, x.r, x.r, y.a) - ELSIF op = ORS.minus THEN Put1a(Ann, x.r, x.r, y.a) - ELSIF op = ORS.times THEN Put1a(And, x.r, x.r, y.a) - ELSIF op = ORS.rdiv THEN Put1a(Xor, x.r, x.r, y.a) - END ; - ELSE load(x); load(y); - IF op = ORS.plus THEN Put0(Ior, RH-2, x.r, y.r) - ELSIF op = ORS.minus THEN Put0(Ann, RH-2, x.r, y.r) - ELSIF op = ORS.times THEN Put0(And, RH-2, x.r, y.r) - ELSIF op = ORS.rdiv THEN Put0(Xor, RH-2, x.r, y.r) - END ; - DEC(RH); x.r := RH-1 - END - END SetOp; - - (* Code generation for relations *) - - PROCEDURE IntRelation*(op: INTEGER; VAR x, y: Item); (* x := x < y *) - BEGIN - IF (y.mode = ORB.Const) & (y.type.form # ORB.Proc) THEN - load(x); - IF (y.a # 0) OR ~(op IN {ORS.eql, ORS.neq}) OR (code[pc-1] DIV 40000000H # -2) THEN Put1a(Cmp, x.r, x.r, y.a) END ; - DEC(RH) - ELSE load(x); load(y); Put0(Cmp, x.r, x.r, y.r); DEC(RH, 2) - END ; - SetCC(x, relmap[op - ORS.eql]) - END IntRelation; - - PROCEDURE SetRelation*(op: INTEGER; VAR x, y: Item); (* x := x < y *) - BEGIN load(x); - IF (op = ORS.eql) OR (op = ORS.neq) THEN - IF y.mode = ORB.Const THEN Put1a(Cmp, x.r, x.r, y.a); DEC(RH) - ELSE load(y); Put0(Cmp, x.r, x.r, y.r); DEC(RH, 2) - END ; - SetCC(x, relmap[op - ORS.eql]) - ELSE ORS.Mark("illegal relation") - END - END SetRelation; - - PROCEDURE RealRelation*(op: INTEGER; VAR x, y: Item); (* x := x < y *) - BEGIN load(x); - IF (y.mode = ORB.Const) & (y.a = 0) THEN DEC(RH) - ELSE load(y); Put0(Fsb, x.r, x.r, y.r); DEC(RH, 2) - END ; - SetCC(x, relmap[op - ORS.eql]) - END RealRelation; - - PROCEDURE StringRelation*(op: INTEGER; VAR x, y: Item); (* x := x < y *) - (*x, y are char arrays or strings*) - BEGIN - IF x.type.form = ORB.String THEN loadStringAdr(x) ELSE loadAdr(x) END ; - IF y.type.form = ORB.String THEN loadStringAdr(y) ELSE loadAdr(y) END ; - Put2(Ldr+1, RH, x.r, 0); Put1(Add, x.r, x.r, 1); - Put2(Ldr+1, RH+1, y.r, 0); Put1(Add, y.r, y.r, 1); - Put0(Cmp, RH+2, RH, RH+1); Put3(BC, NE, 2); - Put1(Cmp, RH+2, RH, 0); Put3(BC, NE, -8); - DEC(RH, 2); SetCC(x, relmap[op - ORS.eql]) - END StringRelation; - - (* Code generation of Assignments *) - - PROCEDURE StrToChar*(VAR x: Item); - BEGIN x.type := ORB.charType; DEC(strx, 4); x.a := ORD(str[x.a]) - END StrToChar; - - PROCEDURE Store*(VAR x, y: Item); (* x := y *) - VAR op: LONGINT; - BEGIN load(y); - IF x.type.size = 1 THEN op := Str+1 ELSE op := Str END ; - IF x.mode = ORB.Var THEN - IF x.r > 0 THEN (*local*) Put2(op, y.r, SP, x.a + frame) - ELSE GetSB(x.r); Put2(op, y.r, SB, x.a) - END - ELSIF x.mode = ORB.Par THEN Put2(Ldr, RH, SP, x.a + frame); Put2(op, y.r, RH, x.b); - ELSIF x.mode = RegI THEN Put2(op, y.r, x.r, x.a); DEC(RH); - ELSE ORS.Mark("bad mode in Store") - END ; - DEC(RH) - END Store; - - PROCEDURE StoreStruct*(VAR x, y: Item); (* x := y, frame = 0 *) - VAR s, pc0: LONGINT; - BEGIN loadAdr(x); loadAdr(y); - IF (x.type.form = ORB.Array) & (x.type.len > 0) THEN - IF y.type.len >= 0 THEN - IF x.type.len >= y.type.len THEN Put1a(Mov, RH, 0, (y.type.size+3) DIV 4) - ELSE ORS.Mark("source array too long") - END - ELSE (*y is open array*) - Put2(Ldr, RH, SP, y.a+4); s := y.type.base.size; (*element size*) - pc0 := pc; Put3(BC, EQ, 0); - IF s = 1 THEN Put1(Add, RH, RH, 3); Put1(Asr, RH, RH, 2) - ELSIF s # 4 THEN Put1a(Mul, RH, RH, s DIV 4) - END ; - IF check THEN - Put1a(Mov, RH+1, 0, (x.type.size+3) DIV 4); Put0(Cmp, RH+1, RH, RH+1); Trap(GT, 3) - END ; - fix(pc0, pc + 5 - pc0) - END - ELSIF x.type.form = ORB.Record THEN Put1a(Mov, RH, 0, x.type.size DIV 4) - ELSE ORS.Mark("inadmissible assignment") - END ; - Put2(Ldr, RH+1, y.r, 0); Put1(Add, y.r, y.r, 4); - Put2(Str, RH+1, x.r, 0); Put1(Add, x.r, x.r, 4); - Put1(Sub, RH, RH, 1); Put3(BC, NE, -6); DEC(RH, 2) - END StoreStruct; - - PROCEDURE CopyString*(VAR x, y: Item); (*from x to y*) - VAR len: LONGINT; - BEGIN loadAdr(y); len := y.type.len; - IF len >= 0 THEN - IF x.b > len THEN ORS.Mark("string too long") END - ELSIF check THEN Put2(Ldr, RH, y.r, 4); (*array length check*) - Put1(Cmp, RH, RH, x.b); Trap(NE, 3) - END ; - loadStringAdr(x); - Put2(Ldr, RH, x.r, 0); Put1(Add, x.r, x.r, 4); - Put2(Str, RH, y.r, 0); Put1(Add, y.r, y.r, 4); - Put1(Asr, RH, RH, 24); Put3(BC, NE, -6); DEC(RH, 2) - END CopyString; - - (* Code generation for parameters *) - - PROCEDURE VarParam*(VAR x: Item; ftype: ORB.Type); - VAR xmd: INTEGER; - BEGIN xmd := x.mode; loadAdr(x); - IF (ftype.form = ORB.Array) & (ftype.len < 0) THEN (*open array*) - IF x.type.len >= 0 THEN Put1a(Mov, RH, 0, x.type.len) ELSE Put2(Ldr, RH, SP, x.a+4+frame) END ; - incR - ELSIF ftype.form = ORB.Record THEN - IF xmd = ORB.Par THEN Put2(Ldr, RH, SP, x.a+4+frame); incR ELSE loadTypTagAdr(x.type) END - END - END VarParam; - - PROCEDURE ValueParam*(VAR x: Item); - BEGIN load(x) - END ValueParam; - - PROCEDURE OpenArrayParam*(VAR x: Item); - BEGIN loadAdr(x); - IF x.type.len >= 0 THEN Put1a(Mov, RH, 0, x.type.len) ELSE Put2(Ldr, RH, SP, x.a+4+frame) END ; - incR - END OpenArrayParam; - - PROCEDURE StringParam*(VAR x: Item); - BEGIN loadStringAdr(x); Put1(Mov, RH, 0, x.b); incR (*len*) - END StringParam; - - (*For Statements*) - - PROCEDURE For0*(VAR x, y: Item); - BEGIN load(y) - END For0; - - PROCEDURE For1*(VAR x, y, z, w: Item; VAR L: LONGINT); - BEGIN - IF z.mode = ORB.Const THEN Put1a(Cmp, RH, y.r, z.a) - ELSE load(z); Put0(Cmp, RH-1, y.r, z.r); DEC(RH) - END ; - L := pc; - IF w.a > 0 THEN Put3(BC, GT, 0) - ELSIF w.a < 0 THEN Put3(BC, LT, 0) - ELSE ORS.Mark("zero increment"); Put3(BC, MI, 0) - END ; - Store(x, y) - END For1; - - PROCEDURE For2*(VAR x, y, w: Item); - BEGIN load(x); DEC(RH); Put1a(Add, x.r, x.r, w.a) - END For2; - - (* Branches, procedure calls, procedure prolog and epilog *) - - PROCEDURE Here*(): LONGINT; - BEGIN invalSB; RETURN pc - END Here; - - PROCEDURE FJump*(VAR L: LONGINT); - BEGIN Put3(BC, 7, L); L := pc-1 - END FJump; - - PROCEDURE CFJump*(VAR x: Item); - BEGIN - IF x.mode # Cond THEN loadCond(x) END ; - Put3(BC, negated(x.r), x.a); FixLink(x.b); x.a := pc-1 - END CFJump; - - PROCEDURE BJump*(L: LONGINT); - BEGIN Put3(BC, 7, L-pc-1) - END BJump; - - PROCEDURE CBJump*(VAR x: Item; L: LONGINT); - BEGIN - IF x.mode # Cond THEN loadCond(x) END ; - Put3(BC, negated(x.r), L-pc-1); FixLink(x.b); FixLinkWith(x.a, L) - END CBJump; - - PROCEDURE Fixup*(VAR x: Item); - BEGIN FixLink(x.a) - END Fixup; - - PROCEDURE SaveRegs(r: LONGINT); (* R[0 .. r-1]*) - VAR r0: LONGINT; - BEGIN (*r > 0*) r0 := 0; - Put1(Sub, SP, SP, r*4); INC(frame, 4*r); - REPEAT Put2(Str, r0, SP, (r-r0-1)*4); INC(r0) UNTIL r0 = r - END SaveRegs; - - PROCEDURE RestoreRegs(r: LONGINT); (*R[0 .. r-1]*) - VAR r0: LONGINT; - BEGIN (*r > 0*) r0 := r; - REPEAT DEC(r0); Put2(Ldr, r0, SP, (r-r0-1)*4) UNTIL r0 = 0; - Put1(Add, SP, SP, r*4); DEC(frame, 4*r) - END RestoreRegs; - - PROCEDURE PrepCall*(VAR x: Item; VAR r: LONGINT); - BEGIN (*x.type.form = ORB.Proc*) - IF x.mode > ORB.Par THEN load(x) END ; - r := RH; - IF RH > 0 THEN SaveRegs(RH); RH := 0 END - END PrepCall; - - PROCEDURE Call*(VAR x: Item; r: LONGINT); - BEGIN (*x.type.form = ORB.Proc*) - IF x.mode = ORB.Const THEN - IF x.r >= 0 THEN Put3(BL, 7, (x.a DIV 4)-pc-1) - ELSE (*imported*) - IF pc - fixorgP < 1000H THEN - Put3(BL, 7, ((-x.r) * 100H + x.a) * 1000H + pc-fixorgP); fixorgP := pc-1 - ELSE ORS.Mark("fixup impossible") - END - END - ELSE - IF x.mode <= ORB.Par THEN load(x); DEC(RH) - ELSE Put2(Ldr, RH, SP, 0); Put1(Add, SP, SP, 4); DEC(r); DEC(frame, 4) - END ; - IF check THEN Trap(EQ, 5) END ; - Put3(BLR, 7, RH) - END ; - IF x.type.base.form = ORB.NoTyp THEN (*procedure*) RH := 0 - ELSE (*function*) - IF r > 0 THEN Put0(Mov, r, 0, 0); RestoreRegs(r) END ; - x.mode := Reg; x.r := r; RH := r+1 - END ; - invalSB - END Call; - - PROCEDURE Enter*(parblksize, locblksize: LONGINT; int: BOOLEAN); - VAR a, r: LONGINT; - BEGIN invalSB; frame := 0; - IF ~int THEN (*procedure prolog*) - a := 4; r := 0; - Put1(Sub, SP, SP, locblksize); Put2(Str, LNK, SP, 0); - WHILE a < parblksize DO Put2(Str, r, SP, a); INC(r); INC(a, 4) END - ELSE (*interrupt procedure*) - Put1(Sub, SP, SP, 12); Put2(Str, 0, SP, 0); Put2(Str, 1, SP, 4); Put2(Str, SB, SP, 8) - (*R0, R1, SB saved os stack*) - END - END Enter; - - PROCEDURE Return*(form: INTEGER; VAR x: Item; size: LONGINT; int: BOOLEAN); - BEGIN - IF form # ORB.NoTyp THEN load(x) END ; - IF ~int THEN (*procedure epilog*) - Put2(Ldr, LNK, SP, 0); Put1(Add, SP, SP, size); Put3(BR, 7, LNK) - ELSE (*interrupt return, restore SB, R1, R0*) - Put2(Ldr, SB, SP, 8); Put2(Ldr, 1, SP, 4); Put2(Ldr, 0, SP, 0); Put1(Add, SP, SP, 12); Put3(BR, 7, 10H) - END ; - RH := 0 - END Return; - - (* In-line code procedures*) - - PROCEDURE Increment*(upordown: LONGINT; VAR x, y: Item); - VAR op, zr, v: LONGINT; - BEGIN (*frame = 0*) - IF upordown = 0 THEN op := Add ELSE op := Sub END ; - IF x.type = ORB.byteType THEN v := 1 ELSE v := 0 END ; - IF y.type.form = ORB.NoTyp THEN y.mode := ORB.Const; y.a := 1 END ; - IF (x.mode = ORB.Var) & (x.r > 0) THEN - zr := RH; Put2(Ldr+v, zr, SP, x.a); incR; - IF y.mode = ORB.Const THEN Put1a(op, zr, zr, y.a) ELSE load(y); Put0(op, zr, zr, y.r); DEC(RH) END ; - Put2(Str+v, zr, SP, x.a); DEC(RH) - ELSE loadAdr(x); zr := RH; Put2(Ldr+v, RH, x.r, 0); incR; - IF y.mode = ORB.Const THEN Put1a(op, zr, zr, y.a) ELSE load(y); Put0(op, zr, zr, y.r); DEC(RH) END ; - Put2(Str+v, zr, x.r, 0); DEC(RH, 2) - END - END Increment; - - PROCEDURE Include*(inorex: LONGINT; VAR x, y: Item); - VAR op, zr: LONGINT; - BEGIN loadAdr(x); zr := RH; Put2(Ldr, RH, x.r, 0); incR; - IF inorex = 0 THEN op := Ior ELSE op := Ann END ; - IF y.mode = ORB.Const THEN Put1a(op, zr, zr, LSL(1, y.a)) - ELSE load(y); Put1(Mov, RH, 0, 1); Put0(Lsl, y.r, RH, y.r); Put0(op, zr, zr, y.r); DEC(RH) - END ; - Put2(Str, zr, x.r, 0); DEC(RH, 2) - END Include; - - PROCEDURE Assert*(VAR x: Item); - VAR cond: LONGINT; - BEGIN - IF x.mode # Cond THEN loadCond(x) END ; - IF x.a = 0 THEN cond := negated(x.r) - ELSE Put3(BC, x.r, x.b); FixLink(x.a); x.b := pc-1; cond := 7 - END ; - Trap(cond, 7); FixLink(x.b) - END Assert; - - PROCEDURE New*(VAR x: Item); - BEGIN loadAdr(x); loadTypTagAdr(x.type.base); Put3(BLR, 7, MT); RH := 0; invalSB - END New; - - PROCEDURE Pack*(VAR x, y: Item); - VAR z: Item; - BEGIN z := x; load(x); load(y); - Put1(Lsl, y.r, y.r, 23); Put0(Add, x.r, x.r, y.r); DEC(RH); Store(z, x) - END Pack; - - PROCEDURE Unpk*(VAR x, y: Item); - VAR z, e0: Item; - BEGIN z := x; load(x); e0.mode := Reg; e0.r := RH; e0.type := ORB.intType; - Put1(Asr, RH, x.r, 23); Put1(Sub, RH, RH, 127); Store(y, e0); incR; - Put1(Lsl, RH, RH, 23); Put0(Sub, x.r, x.r, RH); Store(z, x) - END Unpk; - - PROCEDURE Led*(VAR x: Item); - BEGIN load(x); Put1(Mov, RH, 0, -60); Put2(Str, x.r, RH, 0); DEC(RH) - END Led; - - PROCEDURE Get*(VAR x, y: Item); - BEGIN load(x); x.type := y.type; x.mode := RegI; x.a := 0; Store(y, x) - END Get; - - PROCEDURE Put*(VAR x, y: Item); - BEGIN load(x); x.type := y.type; x.mode := RegI; x.a := 0; Store(x, y) - END Put; - - PROCEDURE Copy*(VAR x, y, z: Item); - BEGIN load(x); load(y); - IF z.mode = ORB.Const THEN - IF z.a > 0 THEN load(z) ELSE ORS.Mark("bad count") END - ELSE load(z); - IF check THEN Trap(LT, 3) END ; - Put3(BC, EQ, 6) - END ; - Put2(Ldr, RH, x.r, 0); Put1(Add, x.r, x.r, 4); - Put2(Str, RH, y.r, 0); Put1(Add, y.r, y.r, 4); - Put1(Sub, z.r, z.r, 1); Put3(BC, NE, -6); DEC(RH, 3) - END Copy; - - PROCEDURE LDPSR*(VAR x: Item); - BEGIN (*x.mode = Const*) Put3(0, 15, x.a + 20H) - END LDPSR; - - PROCEDURE LDREG*(VAR x, y: Item); - BEGIN - IF y.mode = ORB.Const THEN Put1a(Mov, x.a, 0, y.a) - ELSE load(y); Put0(Mov, x.a, 0, y.r); DEC(RH) - END - END LDREG; - - (*In-line code functions*) - - PROCEDURE Abs*(VAR x: Item); - BEGIN - IF x.mode = ORB.Const THEN x.a := ABS(x.a) - ELSE load(x); - IF x.type.form = ORB.Real THEN Put1(Lsl, x.r, x.r, 1); Put1(Ror, x.r, x.r, 1) - ELSE Put1(Cmp, x.r, x.r, 0); Put3(BC, GE, 2); Put1(Mov, RH, 0, 0); Put0(Sub, x.r, RH, x.r) - END - END - END Abs; - - PROCEDURE Odd*(VAR x: Item); - BEGIN load(x); Put1(And, x.r, x.r, 1); SetCC(x, NE); DEC(RH) - END Odd; - - PROCEDURE Floor*(VAR x: Item); - BEGIN load(x); Put1(Mov+U, RH, 0, 4B00H); Put0(Fad+V, x.r, x.r, RH) - END Floor; - - PROCEDURE Float*(VAR x: Item); - BEGIN load(x); Put1(Mov+U, RH, 0, 4B00H); Put0(Fad+U, x.r, x.r, RH) - END Float; - - PROCEDURE Ord*(VAR x: Item); - BEGIN - IF x.mode IN {ORB.Var, ORB.Par, RegI} THEN load(x) END - END Ord; - - PROCEDURE Len*(VAR x: Item); - BEGIN - IF x.type.len >= 0 THEN x.mode := ORB.Const; x.a := x.type.len - ELSE (*open array*) Put2(Ldr, RH, SP, x.a + 4 + frame); x.mode := Reg; x.r := RH; incR - END - END Len; - - PROCEDURE Shift*(fct: LONGINT; VAR x, y: Item); - VAR op: LONGINT; - BEGIN load(x); - IF fct = 0 THEN op := Lsl ELSIF fct = 1 THEN op := Asr ELSE op := Ror END ; - IF y.mode = ORB.Const THEN Put1(op, x.r, x.r, y.a MOD 20H) - ELSE load(y); Put0(op, RH-2, x.r, y.r); DEC(RH); x.r := RH-1 - END - END Shift; - - PROCEDURE ADC*(VAR x, y: Item); - BEGIN load(x); load(y); Put0(Add+2000H, x.r, x.r, y.r); DEC(RH) - END ADC; - - PROCEDURE SBC*(VAR x, y: Item); - BEGIN load(x); load(y); Put0(Sub+2000H, x.r, x.r, y.r); DEC(RH) - END SBC; - - PROCEDURE UML*(VAR x, y: Item); - BEGIN load(x); load(y); Put0(Mul+2000H, x.r, x.r, y.r); DEC(RH) - END UML; - - PROCEDURE Bit*(VAR x, y: Item); - BEGIN load(x); Put2(Ldr, x.r, x.r, 0); - IF y.mode = ORB.Const THEN Put1(Ror, x.r, x.r, y.a+1); DEC(RH) - ELSE load(y); Put1(Add, y.r, y.r, 1); Put0(Ror, x.r, x.r, y.r); DEC(RH, 2) - END ; - SetCC(x, MI) - END Bit; - - PROCEDURE Register*(VAR x: Item); - BEGIN (*x.mode = Const*) - Put0(Mov, RH, 0, x.a MOD 10H); x.mode := Reg; x.r := RH; incR - END Register; - - PROCEDURE H*(VAR x: Item); - BEGIN (*x.mode = Const*) - Put0(Mov + U + x.a MOD 2 * V, RH, 0, 0); x.mode := Reg; x.r := RH; incR - END H; - - PROCEDURE Adr*(VAR x: Item); - BEGIN - IF x.mode IN {ORB.Var, ORB.Par, RegI} THEN loadAdr(x) - ELSIF (x.mode = ORB.Const) & (x.type.form = ORB.Proc) THEN load(x) - ELSIF (x.mode = ORB.Const) & (x.type.form = ORB.String) THEN loadStringAdr(x) - ELSE ORS.Mark("not addressable") - END - END Adr; - - PROCEDURE Condition*(VAR x: Item); - BEGIN (*x.mode = Const*) SetCC(x, x.a) - END Condition; - - PROCEDURE Open*(v: INTEGER); - BEGIN pc := 0; tdx := 0; strx := 0; RH := 0; fixorgP := 0; fixorgD := 0; fixorgT := 0; check := v # 0; version := v; - IF v = 0 THEN pc := 8 END - END Open; - - PROCEDURE SetDataSize*(dc: LONGINT); - BEGIN varsize := dc - END SetDataSize; - - PROCEDURE Header*; - BEGIN entry := pc*4; - IF version = 0 THEN code[0] := 0E7000000H-1 + pc; Put1a(Mov, SB, 0, VarOrg0); Put1a(Mov, SP, 0, StkOrg0) (*RISC-0*) - ELSE Put1(Sub, SP, SP, 4); Put2(Str, LNK, SP, 0); invalSB - END - END Header; - - PROCEDURE NofPtrs(typ: ORB.Type): LONGINT; - VAR fld: ORB.Object; n: LONGINT; - BEGIN - IF (typ.form = ORB.Pointer) OR (typ.form = ORB.NilTyp) THEN n := 1 - ELSIF typ.form = ORB.Record THEN - fld := typ.dsc; n := 0; - WHILE fld # NIL DO n := NofPtrs(fld.type) + n; fld := fld.next END - ELSIF typ.form = ORB.Array THEN n := NofPtrs(typ.base) * typ.len - ELSE n := 0 - END ; - RETURN n - END NofPtrs; - - PROCEDURE FindPtrs(VAR R: Files.Rider; typ: ORB.Type; adr: LONGINT); - VAR fld: ORB.Object; i, s: LONGINT; - BEGIN - IF (typ.form = ORB.Pointer) OR (typ.form = ORB.NilTyp) THEN Files.WriteInt(R, adr) - ELSIF typ.form = ORB.Record THEN - fld := typ.dsc; - WHILE fld # NIL DO FindPtrs(R, fld.type, fld.val + adr); fld := fld.next END - ELSIF typ.form = ORB.Array THEN - s := typ.base.size; - FOR i := 0 TO typ.len-1 DO FindPtrs(R, typ.base, i*s + adr) END - END - END FindPtrs; - - PROCEDURE Close*(VAR modid: ORS.Ident; key, nofent: LONGINT); - VAR obj: ORB.Object; - i, comsize, nofimps, nofptrs, size: LONGINT; - name: ORS.Ident; - F: Files.File; R: Files.Rider; - BEGIN (*exit code*) - IF version = 0 THEN Put1(Mov, 0, 0, 0); Put3(BR, 7, 0) (*RISC-0*) - ELSE Put2(Ldr, LNK, SP, 0); Put1(Add, SP, SP, 4); Put3(BR, 7, LNK) - END ; - obj := ORB.topScope.next; nofimps := 0; comsize := 4; nofptrs := 0; - WHILE obj # NIL DO - IF (obj.class = ORB.Mod) & (obj.dsc # ORB.system) THEN INC(nofimps) (*count imports*) - ELSIF (obj.exno # 0) & (obj.class = ORB.Const) & (obj.type.form = ORB.Proc) - & (obj.type.nofpar = 0) & (obj.type.base = ORB.noType) THEN i := 0; (*count commands*) - WHILE obj.name[i] # 0X DO INC(i) END ; - i := (i+4) DIV 4 * 4; INC(comsize, i+4) - ELSIF obj.class = ORB.Var THEN INC(nofptrs, NofPtrs(obj.type)) (*count pointers*) - END ; - obj := obj.next - END ; - size := varsize + strx + comsize + (pc + nofimps + nofent + nofptrs + 1)*4; (*varsize includes type descriptors*) - - ORB.MakeFileName(name, modid, ".rsc"); (*write code file*) - F := Files.New(name); Files.Set(R, F, 0); Files.WriteString(R, modid); Files.WriteInt(R, key); - (*Files.WriteByte(R, version);*) (* who writes like that? -- noch *) - Files.WriteByte(R, SHORT(SHORT(version))); (* voc adaptation by noch *) - Files.WriteInt(R, size); - obj := ORB.topScope.next; - WHILE (obj # NIL) & (obj.class = ORB.Mod) DO (*imports*) - IF obj.dsc # ORB.system THEN Files.WriteString(R, obj(ORB.Module).orgname); Files.WriteInt(R, obj.val) END ; - obj := obj.next - END ; - Files.Write(R, 0X); - Files.WriteInt(R, tdx*4); - i := 0; - WHILE i < tdx DO Files.WriteInt(R, data[i]); INC(i) END ; (*type descriptors*) - Files.WriteInt(R, varsize - tdx*4); (*data*) - Files.WriteInt(R, strx); - FOR i := 0 TO strx-1 DO Files.Write(R, str[i]) END ; (*strings*) - Files.WriteInt(R, pc); (*code len*) - FOR i := 0 TO pc-1 DO Files.WriteInt(R, code[i]) END ; (*program*) - obj := ORB.topScope.next; - WHILE obj # NIL DO (*commands*) - IF (obj.exno # 0) & (obj.class = ORB.Const) & (obj.type.form = ORB.Proc) & - (obj.type.nofpar = 0) & (obj.type.base = ORB.noType) THEN - Files.WriteString(R, obj.name); Files.WriteInt(R, obj.val) - END ; - obj := obj.next - END ; - Files.Write(R, 0X); - Files.WriteInt(R, nofent); Files.WriteInt(R, entry); - obj := ORB.topScope.next; - WHILE obj # NIL DO (*entries*) - IF obj.exno # 0 THEN - IF (obj.class = ORB.Const) & (obj.type.form = ORB.Proc) OR (obj.class = ORB.Var) THEN - Files.WriteInt(R, obj.val) - ELSIF obj.class = ORB.Typ THEN - IF obj.type.form = ORB.Record THEN Files.WriteInt(R, obj.type.len MOD 10000H) - ELSIF (obj.type.form = ORB.Pointer) & ((obj.type.base.typobj = NIL) OR (obj.type.base.typobj.exno = 0)) THEN - Files.WriteInt(R, obj.type.base.len MOD 10000H) - END - END - END ; - obj := obj.next - END ; - obj := ORB.topScope.next; - WHILE obj # NIL DO (*pointer variables*) - IF obj.class = ORB.Var THEN FindPtrs(R, obj.type, obj.val) END ; - obj := obj.next - END ; - Files.WriteInt(R, -1); - Files.WriteInt(R, fixorgP); Files.WriteInt(R, fixorgD); Files.WriteInt(R, fixorgT); Files.WriteInt(R, entry); - Files.Write(R, "O"); Files.Register(F) - END Close; - -BEGIN - relmap[0] := 1; relmap[1] := 9; relmap[2] := 5; relmap[3] := 6; relmap[4] := 14; relmap[5] := 13 -END ORG. diff --git a/src/voc07R/ORP.Mod b/src/voc07R/ORP.Mod deleted file mode 100644 index 99e6ee83..00000000 --- a/src/voc07R/ORP.Mod +++ /dev/null @@ -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. diff --git a/src/voc07R/ORS.Mod b/src/voc07R/ORS.Mod deleted file mode 100644 index 1d005e38..00000000 --- a/src/voc07R/ORS.Mod +++ /dev/null @@ -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. diff --git a/src/voc07R/ORTool.Mod b/src/voc07R/ORTool.Mod deleted file mode 100644 index e0a08d42..00000000 --- a/src/voc07R/ORTool.Mod +++ /dev/null @@ -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. diff --git a/src/voc07R/Oberon.Mod b/src/voc07R/Oberon.Mod deleted file mode 100644 index b2da7dee..00000000 --- a/src/voc07R/Oberon.Mod +++ /dev/null @@ -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. diff --git a/src/voc07R/Oberon10.Scn.Fnt b/src/voc07R/Oberon10.Scn.Fnt deleted file mode 100644 index 15f999211bf7ec25781c232d43af678d6d0b9385..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 2284 zcmaJ?&5qgTsd;#1@;->u+P8+B)H6F z;mUz$*=L!_exIv7P7e~5j$JC(&sSeL>JRe6XKN8@<$jJ*ON91ZewJV4SNTnTmp|lB z`Ahy5`lvKwp?G*MH3M6Xr;$@l{b-|BX$q_^Wijygi10Y6B&1jmTMdtS_P~>Otf96l*%UobPyN{KQ(H!_ zNZH3zjaXQ>PJIwnu1o%y&jMcsjY121ReUY9hq(bSA)N-qE?LV+m#pR3l0{>QzQkr! zWS3$edt*l>Hl|a~zSM{bAF(JKjG*md4hd;SRk-pg3;ha$+%LPMaQ5Z2M3gLL`n1h6 zCwO`f$bCp1@qX#83FxiNTp1_3@v+OLEmz~TC>8u@yT|QRO=C~_yPqxYWM+-`o*WoN zWUfk$r`kRG$Tg_3OV+JVG-A;ktMlb8q43t{87(vOR56nw#xh_2W;__-P2_i!zbMXw zJXtVE3CNq#$HinaLwWj3RK<4674u~#mA{;2=~ryZpGEy*`#&w;Vt&7zLgDnk)wD}~ zk6AP`=W8k-hv+L~s?bk;sLah3Yuh#aoVCf{T4(T5U}@dtT8G8)aN@$lrs;+xU2^obn@lo? z&@>HRZa1-ACnXr$!T*zuv7<(BC&uILLbH8#f!$=hX@9-0s`cwhCalo$l~~jaqka3& z-QC^4-@LiKJ$$|2H%*T;c>6Jdw_`t$l%ekd6fd{5zd2l80s2VL6JFXWl~p0LBsc}Y zKBVWp@c9_UujwSjwxSUMPE>^O>O z`q-r&gS9o>I*a8J$Lg;oa8-^(fNG^e4|M$w^5a{LVWo(1p%PP|h8Ck|@Rh48Q`arB z_1317sC|(|vPouRtm_z4qsNwA)1yUPI4make - -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. - diff --git a/src/voc07R/makefile b/src/voc07R/makefile deleted file mode 100644 index 5343361c..00000000 --- a/src/voc07R/makefile +++ /dev/null @@ -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 - diff --git a/src/voc07R/test/Oberon.rsc b/src/voc07R/test/Oberon.rsc deleted file mode 100644 index d0e49fa8d0fcdda90d1814c62979d5dbe3af6c4b..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 7295 zcma)B3v69w9sl1)*W0xncU^(Lw%xIob){nsk2vC@=XPZo;Q&P*Vi-w>t6@pq8oG(# zjOTV;z|8Bq#HbJ=XKb295K1J72__JU3KHp6BbA`uD&1NcWQ&ly&0+oh{^$E{Pj6dB zlP~9c{NJzd|J~klZ}0uPc1qh zUieL%y|UsySrE4D!w&@_s_{hjHvAG3U3|e5>%q@Nk}q zNJXTnt^94kXGH1%Cc~GAj04uI0~~NY;$iN69I140o{C7q`IanpKqCVhgHfrEHtkdz zgAr+sh$IgIM#z_Z2v45>oSr^Gy5dzhu)_rB0Nw@}ggm%TN`&%4E^3xP*d&uTUnKI| z+7i7$?@7QN*(j2IT*g2zkfjo`$E3A0Dwko%rkJdaZCsQ1J7n4ym%22F9*IMqh^*~A zH$6Q?`N;3N>FL5U&^jukKKa%fzH!6%&eYNZ_v2kce6jQ zy~6b8vzO&VyM*PWEhr~)(b%SfHk{?Fz-GFyb}NJ3%8lL15r4E@xv||X7qA`T*2H*n z#LlZEiC7KxlRD2I{3P4Mzr)NA#vJetY#p!4aSk0k+6^=^IDgC1L{E&WE&}=|8NQY zg=#M3LCvgiSTA2iJhMJEXq^ab9Mt{<@?qw@2Kfjb6pwlNJA;SVLyZb*a2U^?BQ~@i zTK#T-jO5R}B%QGZ_$N>c$lsn@{ub|@1^8P$dv5t#o2@lAvi?h!)N|$p2I5FiUnSd$ z7=V4E@aq)yL~ePAeFwDz>lwdUUjqidcGTZh(!KvO@axw)6VRlu@0y2ZG(^+NYW+)^ zaYHi!n$@6r_bi${*{Gp;M@Y^!nA6s7e@!k4xdl8fGk$jW)*!!vz2$cAM>RR<TpZ%Yq$XV^ z4Qcu(Oe1_h(#AN14<U3D^f{S_lU1=Z(~x*Tez_F1IIT;iRGfSF)jv;9^D z;+*%U`&?a)cbWUkI^+TG)EfF1I2tQH{X<#o-89#x`6toWXa6jt!;l(1verhAHpG4C zqu!~1IcHxTvD{OiPY}!N{J=<_Wo5F_vtABsPd^Zz zG1pA^*Bf*AX52r{PZzKnbM2-pSLauZvP2{(e!anrsOnV)L zv~*<4LUk%`*4Kd^^+FBsXUXyFxpIVMraZ`van=si?}I=V>emJRxKI7&(5+lGN53## z>RP1PwyLNfX(H#nF2oS@>b!Qiqk#J1U$uZ` z4$B+<(cfllydzJtb*SBt757Ur8;7r=_@b|2Tu8+H)>DSPi0Qvk($T%Fg>o-^Dwm{~qhm-mqa6ed`OJPkKr(u84Ez+qtwW@&r zu(*!<$pT=DYs9((zLedkO&88l_9c=XGQAaZ&waa@a-}htXP!G1tWiIL^|@xgU-7m! z>xvfBpPKc`7R85N3QztvkF8y)6K&xRv{1)v0(YRhuSIJE`C#q2hgy^m*9!YYOAhu{ zx#E#A2lBxO`uo@6u#VyPq2g6vPI)}^`D%CgUTcke_2qh(0Y-g^I2^~B=WY)63HK4~ zu6tj)TxD^;%(G;sC{v%(4rC(kH-fe5fc0kr-TWDO>lK#r+Ba{hP1viI`mGd(_4kaa zk=D2K!JPjTFj5jD-6rq0Aip*uuN~B?A9gr}NRmB!g|i87BNu1!lv8j~ZyK?O{%R_M zm}`a2T1{T^O;>@uj6qiWe*5l!`CGwEoUTXylSTt*AZDkchQ>zNt{t=-d^_;v8uLso z?hW`Wh@I!x2KU$tYxVaO@J-`)8onjvGtYcHCgr z@W&M2@h_uqUS<4NDl^`Cyq7dD0FQd6Yx-c0PS!VT!aB9J2X<_4FY2@uJgrVfKBWb@ ze8|We;JJI+H77CmYwxwnz^T>Tco_3o%!S-Fa3j)~v>$I-$cM95+ zeK%?Rm1X3mBQ_qKW*l_FFEUs zn7N1f^O(PAe((C}xoPdAY<~R&Yx*jBo<55kpKac@z4xYFdj@*tB+9$HYgfPYqd)pW??CTvc?1iTS}`1q zyD<7NhA{YFv!fWtFzBj0#=97k7-ulfW3Uy7V~k-I2Y_%=op&Z+w?{|8A2bu<6~ diff --git a/src/voc07R/test/Oberon.smb b/src/voc07R/test/Oberon.smb deleted file mode 100644 index 148bd4143863ecdd9e2db981b0cf3209b2feb8a9..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 1372 zcmZuxU2hXd6g_u6t{2w}1_C4y+5n}{0xj)RUy&mhq=ZCG%E#kkkCRo_JJ!xPZg}bM z=x^vRp|3pg-ZrQak%C%Ts!YSZv$g}G(n>pf?$?=n&s_lcva|bQ<%!Ns2BMb9Y`?29 z0=YbHZDB;z)*aL8Tfs8jXE;rsvIkK&&eT!NC?$p z9uM$Zsb<{Pc+GZ{8~xmx9QBBUX4GSh>go|jHN`ys3zg*N@B{C9FYEQ)vfaSR=u|Wm zXfd(9G~U5q&%>o=9(T1^OSGW2O{as=ylR;gqgmC-98Ombn5C3`gx16|KYZGtk zQnV&TL$#%MEdEt0X?yl4ujy2`Tw*dwJQM9Jsw|%ov|py0lnkZhJEa*Dh40N#1)=+ZO(uL-3d3a(3ELENc4aM<|~KA$>NuTU$2hQTCij`uorP2&M6bAtDa$n)QYa` zg{mV%!AqsK2RVLcHpc@Vc$1s|>V%vcGM~DfR%Bo&gZrieZU!7mjQV5SrXwbo4yrbtj-d#s?Hr*iUv&0z$}SOr%}M1 zcV0Dx%-``mPe16c+14U(N!x7-T@PQJz;|`BvFWDx zCqC7>-^pnr;8T)DP2eKM0r@QZ?m*`H)eT$uzi18pfQwbw}eC^9qmmZ8Ehv}8HY0ZIzkJz9}XAy5;&sQ2&&)>aeUOeWuZZ+@OW zLdau{9DB7~kn*U=PHE(!hvBwlEUr@uT24B`ILQjeE2!j6Pa(LR!3Aeq8rPgc+|MI? zSaT4tayBByPRr4_Hguol7~3#mgH%p|K+K{KwWQQzr`kY-;9un3{})sBV_y$u$|-Pn bkhE_@5Tv=DO$5_CHrJTuyVsKU9|YqU*UktpwP}FnQ7A%A8C?F8@ov-=}ZH(2?YYvu}EiNT-vUa7|EU30Rj<)1oihn z_ubW#yr^jA&3pHrbI(2Je?IPcZ*|#?cieWXyYnac!OXxJ&YgeL%{SiaZo2#B@1FmM zw?Me!t>@l!&pPJ{Tr;V^9OF)|W-k4Sluzz~Ez4MRjSKT=y^Q<0#8aQpV(#6A#npXk z@#GWUutx*qu)Z*lCjBHsbp2_Ko;Tabx%_EoojI^=U~tRUfk92>^Zlnwr~IxxyOObP zZtqg(8r)IlD&MJhQ-wv&?Q`zsA#8i8-c{o08%rimV(wXYun7CO%{{SXVrIr&!hU}I z{E~@`b3^Fs$1g3JfLAj7_=q2ahabP;$L-0Oy&r0DQ@fTq_sqenE|qeFtBg0h$|Ks7 z=i;V=+3C%$Qf9A0o;ylRXSs95o!kRo&P@$3&9+U4@dn2AmF)BeR~hStk1M{`xx>06 zrTnSygu_;zXt`f$D1Rr6Q-#oW;lbQuJWcM1$Kf+`Irrw$HybO@Mb1o5pSY zZ%q?9#`3$3kNPowkCidd%J?CUrkf_97s(^fSHE?mu3tKV|BP3D zjLw?n#rJV^zNe?LV7?SxzjR_V`h)dD2b0*@Q6qM+IflQuG@q@;%EkCzzPR3H_hpE6 z_AO!KNaKFtJ4KfI`2jFL$+b-n5I3*8M&{j7(Hjyv@lv{!7(Cm#N$I|HEIU1jZKpB^ zZe`-6Kzdd4sbBUqwvbQxeRbrMY_hpEEtWs>r;Sf>%@9-!&BZLlB?Kf&*78C+NLwqj~)1@S++j947rXvw~W|!aW>5V^D@I+ zH0Qc9EIte^j$U3y?zotkDBJjmUq`%qd6}%mept88VvTi6vnDTEk+uC~i|S5~#T4|F z34Oip(!WoPAC0res9+7;<@}1Ifvb`)w4Kz zDDRpIs%O|yjJ_bfvc>4Z?8JrCE94Awf{oU@&LMDnw4S+)+c^Br%*;{YS3n+@mvvyC ztba^oJ>g}s{$bTXZsX3kk%#XOOO|*f_b7S>pD`|d=GwMt(b3&7 zlg)vS?xm=!4c+slXjR)po;+@Ts%=_!N}l{Yhxej3@XePRkvV66ZyUJgON&$UU|6ar zUW6n2ls})+3!8?Qqmt7yk^+Y7$YXkbP2izIpATq8YYWZSUn&H4%j%q!fb8?0~-(6`2MT6t^m7A%sz_8VXhJ4;3f8W z=)!v6J8WK{{^$CA{a5`yZ(iM(Zt1%Jy6ObjXzrv`t^WmePxve;$j-_`o0A$e+duhO zi^kjWM?-;rrds=Dd-OxilWWiEp0#>y^9S1v18f?X+|Uc@b+Xk7V$hu z+x#!ZuR4^}nct)~!Ef?z*iShq~q0y`IEebnz)xOI7pD=Bqrf&IZW> ziy}3}dJba4o`oO%pY@XMHSm*8%8v`lk1YPZDdi*iHtOy0K02*~c=J7&%?~8=AL#&h ze-7FFdCC069q5`ZN;jLoI+?$*gLsy&E2TQl5%Bl)+Y|cT9r!+r?#cYU$^1Uu!@AB4 z`Qb4rOP)XLZJ&Qg_@C^+Pgy(j4XbCQXR5C{7`+ zk`IRKh8nmc)5qoCb}CP04>)&8?^jKqCp#76l2_JPHuO@HkU4T5{SrQ-ADhjWoP06e zY5tGi?Nm)5=WCxw#=E!+d&sS9m+&d|Qgb+G>V$p3-S{>od;@d&gms*_h^^Z67kyjZOfB%*_MCu|#YbcINrljZT%B%{#*5aNj_R8^VQrMfWJv|=#)jbPh z&pvU~*E2Vdw)9whr}Cxz3fP-|ANMq2VB_l~pP0P4M>VAs{c%r{>%x8(1LDIlsC9k` z2gy*bz&COyXOMjE=X^~ehlYR5ykRz!!!{T9vPS(SweyJ0Uz)QRimun4K5uVMae!ac zXKu`>ZW-S#3Ev%_Pqo+Ld`x3!eURZ&&Y5qb$8&}?u~Alh@Gf-N;^e8EkCSI|miO|z z^f`;(&FC*C^#8DXDf)%vsor^Pn3H)e$cbpL=;rSNi?hb(fx=eoCO{ z6Z)o=hEM39TcKM_d?cY?uu}0}igvHG_zwEWr>6HcqPv)9vlrZapYlcVJIh7m`>K~0 z;w1Wp$+h}ydHH?m;p?;E`>!i4f5dNo`0tg9nPN00d(r2$l_$iG`JsN5#h7ZV`u+{* zW%Jop7N=2eRf4Mx9j3^JC?u?SIiKdnd&Y2Wn)&gY4~3%$d&P4QrH3r6{|`{H1rAAlLX-ubCSg zXReW6_g}qbjl~8<-eLnhPl%2Fd9eY{Bkc7kI6j6C9!I~g+aB+&sqORZ+7oA+yD&V6j$&G%z*8ENVF@Myh zX~))rX{8u^yC_ZTSZDrKjWs!2HFma##=Wdlt^2vX3$xGV>*nJ72kSh(pIT@5;@=bS z;|L03Q zk4F2}gGc`;Jok3G!oBrwaM9lH+B;}L>(Oz)bPVqU*&5iS<)dpUo4h0A$2eNsXShff zXOrn-^IQ828_jcm&dx`DhL7espKQJp-SHPT*>@DnGm~+9pXHj)V%1~y%4c#GNgty> z&}VUeMxFomE==gj?c0mw%Qo@qtk+m__}=04EG*fxkj$6GXEJ}&XK|-_VXyfQx<2@T zHDHu4MLRxZeqcPB#Rt&^A2MI;=3QEt(|1{1)H)01?oTqm-b(p+(gUV#ADkC&vSGlvG1l&ve~95S&trU#)3;^y5o3)!<7azr;hFC^ zM>Vf!euuI67_1Rf9-FD*^TFkR&}9hutou?DH^(L8N@Og-#yu$-{hHD4gvL9{apflZ z4CN}P9zx%udJ4(8j6Og#eN&U(v;LSG-pHPk-;WG*Kc?r?c|I9^x2N_Bv>|BpT}Q60 zLE8fj9go~OmuBB6Rzu@^lzs0s9q-v()e$_0f{xOAH!+bxhMsru9A(_3^jeFIGZGvF zX8%j?9BAll*vlt;>#pugY#gp)v;4H`zN}jio1YB_(khaVfuFB_wB5ID|wdxHsD(>>u=Mt_9H93 z9$#AAXuV=;C?%Vo+-T=R)%2*6%*_)3-`tav}2QNvq$8sV&1XbT6Y)ED#UqU&Zu$i5`mCznZu1bF2%sVt_q` zeQ$E-tSYB5=}6hy&U3IsG1Bk4hE$)WxAbrsw@0}N2FEm(jmWe7lH9aym!QLu#J2O$ zaVt7XkInP=E`V=-Oe~uh6X(Fgw^fS?(Zqi$GV#qEyawP)+eW@t{RpIHQ1ama~BDl=DhG0J@f=xqp@Qz^6{9S z56v|0=KMV3=k;y4%az!dwMFMvJITP;lW8Ba*7lVg`kq&{wvT6O@NqrM=UT72Uu!+N zG^TnD4PCV7N>>m6P9Im3nh#^*c?>%b%U_yPEs{RWRma52WRPk0o6IhgnZ)X(=Cxkq z_mi29=`1qQvAT!kOOMl%xrlR;ytRChT#dQM4LmDfzDFO7Z&_0*hBI|=firy*ead~Q z{~N&Gc>6mu(~JFYou<2bD6lu3)Hel8La&si25NuKynQdYmxnWa72Ol`j zpUlS(8r}?r+te4lzRfC3EljIdCr$ z&wkyqLDLg_i(upD`UXu_c#lPH9Bm);n4U8TR;hREOZFiasxLn6`K6cU zLQE1b4{zZ&p(@|E68V3p`-wfi>F|W<1@6B0S3HEiv{ql7#QyMY^S+JD|2C@l#imEu z!+NoH)6?o|CiiFC4?!=gZ{yE;OZ8gPTk_$hf46VGi*kQ$yrcRK>|Flg%h^}5LXW54 zVWl(gZr01c-*^9@hjL0awaxc{G4-W-ru-%Gc95JVw@035AJrbk4`+eSeD%Ss_4Qll z9}1~9srHwpQ+^+2o^S7+=#$pvO@G$LvW0j(7OYBcNvO}I9>jU&0g_%Q#&GgX%Z&$@*7 z*X%DG!?*6-pzQ5#u)X!%fXzQk@Cv>OIzjg~zOln>?8L_B&{6AxjeJ9~SegIs zBOBp+RC{w4?}>A#3}sx4qu;K^$QOu_3NgaDH8Ko#^bF=t`H;22cU6A~qi?dm=<>IG zFW)_z#7=r2FwuKS?2_|Zwo{Y}z4SneHRkPEJb7qbafhoLx`)0EY{xt7|FRmLXpG|- za6)EP_cPFa3f<9pWCgna4Kf36((|4Kr+}$2YemLyW@glLSbr4w6=%1?PwdT+aSLYcU8+mwF!D4g+F`73lef>KfY;%b(gdhCi)Rm!kIwl+NOIf&6r}S(wr#bBv#_Aat z-22$<-Wm4N|5XJ2&SU@I(pw4F#l$Rk!&v^KFR#Y7V&IL0FZfNo>6kbbo}=&t+0e<) zQ-}Nc-@c#Mm`Bc9(O!Y(s7Iln>#tFdu+_fF&h>eVOUL{ViTT%vd2|}N96Rp%tgXHC6{}%!gP#6Por3eN(OeJjfKL>@(Wt&Klv(Z{!elIM9TTXs1A1 z2JNRcXx-4xh4w;<7GyRjGM`S-&Q4@5PS!n9gC==DU|u$acZ{UB{?0-2=S}x=AwymM zGVe3QhyKsHEME24yemE9)`7%li6(;96}WETx{vEIt_QfDC1d`HmCq7=sv!M%@?JW= z`&hl3FIe|--At$a0w?WGehr=Cx|%NG0j^K*-#qn8(I)4%Wl&^6g`tnno^QJ(+BT>x?stIMHg&JstTlvq6VpJHyO89T~A~?Rf~l9D1Lwi z3qUMbu;3Sf(n3`fi8_TdV}}|EVR>Pnd+y`hIW_=1eOq66qW0nlLOcw19UlqABWFh; z5uzD~Ua*Ozz)*~&DAtrANYU7GLL@^XR2|=GkqhAkkqSu?qOE)t6Dx>ru;YZ=Oe~oe z7%h)gdjfM3;}R7a=-6}jF+S2OkeuDez_4s>Il-oC<4j6l1*~qa(j&w7RETe|^_EoB z!uL^>I8~eQM3sf^O3X{#F)enr>msShmgdaE(xrsS@~>qbQ0)4THz(!^QYsze%r3adCFUWv` z8(ZlAf1bm9`}{}{RV;QmRVIlru~D&W57SP{Q7xh*&F28EvNCDX`Fs)ZRacA HGG_h_Vq;QE diff --git a/src/voc07R/test/readme b/src/voc07R/test/readme deleted file mode 100644 index 9108c517..00000000 --- a/src/voc07R/test/readme +++ /dev/null @@ -1,3 +0,0 @@ -put ORP binary here and run - -> ./ORP Test.Mod diff --git a/src/voc07R/x86/CompatFiles.Mod b/src/voc07R/x86/CompatFiles.Mod deleted file mode 100644 index d7a9c06e..00000000 --- a/src/voc07R/x86/CompatFiles.Mod +++ /dev/null @@ -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. diff --git a/src/voc07R/x86_64/CompatFiles.Mod b/src/voc07R/x86_64/CompatFiles.Mod deleted file mode 100644 index 785a9666..00000000 --- a/src/voc07R/x86_64/CompatFiles.Mod +++ /dev/null @@ -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.