From: Michael D. Lowis Date: Tue, 20 Apr 2021 19:28:02 +0000 (-0400) Subject: Add oberon0 code from wirth for reference X-Git-Url: https://git.mdlowis.com/?a=commitdiff_plain;h=dd5d673e4d369b843c309046fc04dee5c8f06974;p=proto%2Fobnc.git Add oberon0 code from wirth for reference --- diff --git a/cerise/oberon0/IO.Mod b/cerise/oberon0/IO.Mod new file mode 100644 index 0000000..f248fbf --- /dev/null +++ b/cerise/oberon0/IO.Mod @@ -0,0 +1,30 @@ +MODULE IO; (*for Oberon0 NW 29.4.2017*) + IMPORT Texts,Oberon; + VAR S: Texts.Scanner; W: Texts.Writer; + + PROCEDURE OpenInput*; + BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S) + END OpenInput; + + PROCEDURE ReadInt*(VAR x: LONGINT); + BEGIN x := S.i; Texts.Scan(S) + END ReadInt; + + PROCEDURE Class*(): INTEGER; + BEGIN RETURN S.class + END Class; + + PROCEDURE Write*(ch: CHAR); + BEGIN Texts.Write(W, ch) + END Write; + + PROCEDURE WriteInt*(x: LONGINT; n: INTEGER); + BEGIN Texts.WriteInt(W, x, n) + END WriteInt; + + PROCEDURE WriteLn*; + BEGIN Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) + END WriteLn; + +BEGIN Texts.OpenWriter(W) +END IO. diff --git a/cerise/oberon0/OSG.Mod b/cerise/oberon0/OSG.Mod new file mode 100644 index 0000000..f7c15dd --- /dev/null +++ b/cerise/oberon0/OSG.Mod @@ -0,0 +1,565 @@ +MODULE OSG; (* NW 19.12.94 / 20.10.07 / OSGX 9.5.2017*) + IMPORT SYSTEM, Files, Texts, Oberon, OSS; + + CONST MemSize = 8192; + (* class / mode*) Head* = 0; + Const* = 1; Var* = 2; Par* = 3; Fld* = 4; Typ* = 5; + SProc* = 6; SFunc* = 7; Proc* = 8; NoTyp* = 9; Reg = 10; RegI = 11; Cond = 12; + SB = 13; SP = 14; LNK = 15; (*reserved registers*) + (* form *) Boolean* = 0; Integer* = 1; Array* = 2; Record* = 3; + + (*frequently used opcodes*) U = 2000H; + 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; + Ldw = 0; Stw = 2; + 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 Object* = POINTER TO ObjDesc; + Type* = POINTER TO TypeDesc; + + Item* = RECORD + mode*, lev*: INTEGER; + type*: Type; + a*, b, r: LONGINT + END ; + + ObjDesc*= RECORD + class*, lev*: INTEGER; + next*, dsc*: Object; + type*: Type; + name*: OSS.Ident; + val*, nofpar*: LONGINT; + comd*: BOOLEAN + END ; + + TypeDesc* = RECORD + form*: INTEGER; + dsc*: Object; + base*: Type; + size*, len*, nofpar*: LONGINT + END ; + + VAR boolType*, intType*: Type; + curlev*, pc*: INTEGER; + curSB: INTEGER; + entry, fixlist, fixorgD: LONGINT; + RH: LONGINT; (*register stack pointer*) + W: Texts.Writer; + relmap: ARRAY 6 OF INTEGER; + code*: ARRAY MemSize OF LONGINT; + mnemo0, mnemo1: ARRAY 16, 4 OF CHAR; (*for decoder*) + + 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*) + IF im < 0 THEN INC(op, 1000H) END ; (*set v-bit*) + code[pc] := (((a+40H) * 10H + b) * 10H + op) * 10000H + (im MOD 10000H); INC(pc) + END Put1; + + PROCEDURE Put2(op, a, b, off: LONGINT); + BEGIN (*emit load/store instruction*) + code[pc] := (((op+8) * 10H + a) * 10H + b) * 100000H + (off MOD 10000H); 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 < SB THEN INC(RH) ELSE OSS.Mark("register stack overflow") END + END incR; + + PROCEDURE CheckRegs*; + BEGIN + IF RH # 0 THEN + (* Texts.WriteString(W, "RegStack!"); Texts.WriteInt(W, R, 4); + Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) *) + OSS.Mark("Reg Stack"); RH := 0 + 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 TestRange(x: LONGINT); + BEGIN (*16-bit entity*) + IF (x > 0FFFFH) OR (x < -10000H) THEN OSS.Mark("value too large") END + END TestRange; + + 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 1000000H * 1000000H + (with MOD 1000000H) + END fix; + + PROCEDURE FixLink*(L: LONGINT); + VAR L1: LONGINT; + BEGIN + WHILE L # 0 DO + IF L < MemSize THEN L1 := code[L] MOD 40000H; fix(L, pc-L-1); L := L1 END + END + END FixLink; + + PROCEDURE GetSB; + BEGIN + IF curSB = 1 THEN Put2(Ldw, SB, 0, pc-fixorgD); fixorgD := pc-1; curSB := 0 END + END GetSB; + + PROCEDURE load(VAR x: Item); + BEGIN + IF x.mode # Reg THEN + IF x.mode = Var THEN + IF x.r > 0 THEN (*local*) Put2(Ldw, RH, SP, x.a) ELSE GetSB; Put2(Ldw, RH, SB, x.a) END ; + x.r := RH; incR + ELSIF x.mode = Par THEN Put2(Ldw, RH, x.r, x.a); Put2(Ldw, RH, RH, 0); x.r := RH; incR + ELSIF x.mode = Const THEN + IF (x.a >= 10000H) OR (x.a < -10000H) THEN OSS.Mark("const too large") END ; + Put1(Mov, RH, 0, x.a); x.r := RH; incR + ELSIF x.mode = RegI THEN Put2(Ldw, x.r, x.r, x.a) + ELSIF x.mode = Cond THEN + Put3(2, negated(x.r), 2); + FixLink(x.b); Put1(Mov, RH, 0, 1); Put3(2, 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 = Var THEN + IF x.r > 0 THEN (*local*) Put1(Add, RH, SP, x.a); x.r := RH ELSE GetSB; Put1(Add, RH, SB, x.a) END ; + incR + ELSIF x.mode = Par THEN Put2(Ldw, RH, SP, x.a); Put1(Add, RH, RH, x.b); x.r := RH; incR + ELSIF (x.mode = RegI) & (x.a # 0) THEN Put1(Add, x.r, x.r, x.a) + ELSE OSS.Mark("address error") + END ; + x.mode := Reg + END loadAdr; + + PROCEDURE loadCond(VAR x: Item); + BEGIN + IF x.type.form = Boolean THEN + IF x.mode = Const THEN x.r := 15 - x.a*8 ELSE load(x); Put1(Cmp, x.r, x.r, 0); x.r := NE; DEC(RH) END ; + x.mode := Cond; x.a := 0; x.b := 0 + ELSE OSS.Mark("not Boolean") + END + END loadCond; + + 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; + + (*-----------------------------------------------*) + + PROCEDURE IncLevel*(n: INTEGER); + BEGIN curlev := curlev + n + END IncLevel; + + PROCEDURE MakeConstItem*(VAR x: Item; typ: Type; val: LONGINT); + BEGIN + x.mode := Const; + x.type := typ; + x.a := val + END MakeConstItem; + + PROCEDURE MakeItem*(VAR x: Item; y: Object; curlev: LONGINT); + VAR r: LONGINT; + BEGIN x.mode := y.class; x.type := y.type; x.a := y.val; x.r := y.lev; + IF y.class = Par THEN x.b := 0 END ; + IF (y.lev > 0) & (y.lev # curlev) & (y.class # Const) THEN OSS.Mark("level error") END + END MakeItem; + + PROCEDURE Field*(VAR x: Item; y: Object); (* x := x.y *) + BEGIN + IF (x.mode = Var) OR (x.mode = RegI) THEN x.a := x.a + y.val + ELSIF x.mode = Par THEN Put2(Ldw, RH, x.r, x.a); x.mode := RegI; x.r := RH; x.a := y.val; incR + END + END Field; + + PROCEDURE Index*(VAR x, y: Item); (* x := x[y] *) + VAR s: LONGINT; + BEGIN + IF y.mode = Const THEN + IF (y.a < 0) OR (y.a >= x.type.len) THEN OSS.Mark("bad index") END ; + IF x.mode = Par THEN Put2(Ldw, RH, x.r, x.a); x.mode := RegI; x.a := 0 END ; + x.a := x.a + y.a * x.type.base.size + ELSE s := x.type.base.size; + IF y.mode # Reg THEN load(y) END ; + IF s = 4 THEN Put1(Lsl, y.r, y.r, 2) ELSE Put1(Mul, y.r, y.r, s) END ; + IF x.mode = Var THEN + IF x.r > 0 THEN Put0(Add, y.r, SP, y.r) ELSE GetSB; Put0(Add, y.r, SB, y.r) END ; + x.mode := RegI; x.r := y.r + ELSIF x.mode = Par THEN + Put2(Ldw, RH, SP, x.a); Put0(Add, y.r, RH, y.r); x.mode := RegI; x.r := y.r + ELSIF x.mode = RegI THEN Put0(Add, x.r, x.r, y.r); DEC(RH) + END + END + END Index; + + (* 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.mode = Const THEN x.a := -x.a + ELSE load(x); Put1(Mov, RH, 0, 0); Put0(Sub, x.r, RH, x.r) + END + END Neg; + + PROCEDURE AddOp*(op: LONGINT; VAR x, y: Item); (* x := x +- y *) + BEGIN + IF op = OSS.plus THEN + IF (x.mode = Const) & (y.mode = Const) THEN x.a := x.a + y.a + ELSIF y.mode = Const THEN load(x); + IF y.a # 0 THEN Put1(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 = OSS.minus*) + IF (x.mode = Const) & (y.mode = Const) THEN x.a := x.a - y.a + ELSIF y.mode = Const THEN load(x); + IF y.a # 0 THEN Put1(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 MulOp*(VAR x, y: Item); (* x := x * y *) + BEGIN + IF (x.mode = Const) & (y.mode = Const) THEN x.a := x.a * y.a + ELSIF (y.mode = Const) & (y.a = 2) THEN load(x); Put1(Lsl, x.r, x.r, 1) + ELSIF y.mode = Const THEN load(x); Put1(Mul, x.r, x.r, y.a) + ELSIF x.mode = Const THEN load(y); Put1(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 *) + BEGIN + IF op = OSS.div THEN + IF (x.mode = Const) & (y.mode = Const) THEN + IF y.a > 0 THEN x.a := x.a DIV y.a ELSE OSS.Mark("bad divisor") END + ELSIF (y.mode = Const) & (y.a = 2) THEN load(x); Put1(Asr, x.r, x.r, 1) + ELSIF y.mode = Const THEN + IF y.a > 0 THEN load(x); Put1(Div, x.r, x.r, y.a) ELSE OSS.Mark("bad divisor") END + ELSE load(y); load(x); Put0(Div, RH-2, x.r, y.r); DEC(RH); x.r := RH-1 + END + ELSE (*op = OSS.mod*) + IF (x.mode = Const) & (y.mode = Const) THEN + IF y.a > 0 THEN x.a := x.a MOD y.a ELSE OSS.Mark("bad modulus") END + ELSIF (y.mode = Const) & (y.a = 2) THEN load(x); Put1(And, x.r, x.r, 1) + ELSIF y.mode = Const THEN + IF y.a > 0 THEN load(x); Put1(Div, x.r, x.r, y.a); Put0(Mov+U, x.r, 0, 0) ELSE OSS.Mark("bad modulus") END + ELSE load(y); 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; + + PROCEDURE Relation*(op: INTEGER; VAR x, y: Item); (* x := x ? y *) + BEGIN + IF y.mode = Const THEN load(x); Put1(Cmp, x.r, x.r, y.a); DEC(RH) + ELSE load(x); load(y); Put0(Cmp, x.r, x.r, y.r); DEC(RH, 2) + END ; + SetCC(x, relmap[op - OSS.eql]) + END Relation; + + PROCEDURE Store*(VAR x, y: Item); (* x := y *) + BEGIN load(y); + IF x.mode = Var THEN + IF x.r > 0 THEN (*local*) Put2(Stw, y.r, SP, x.a) ELSE GetSB; Put2(Stw, y.r, SB, x.a) END + ELSIF x.mode = Par THEN Put2(Ldw, RH, SP, x.a); Put2(Stw, y.r, RH, x.b) + ELSIF x.mode = RegI THEN Put2(Stw, y.r, x.r, x.a); DEC(RH) + ELSE OSS.Mark("illegal assignment") + END ; + DEC(RH) + END Store; + + PROCEDURE VarParam*(VAR x: Item; ftype: Type); + VAR xmd: INTEGER; + BEGIN xmd := x.mode; loadAdr(x); + IF (ftype.form = Array) & (ftype.len < 0) THEN (*open array*) + IF x.type.len >= 0 THEN Put1(Mov, RH, 0, x.type.len) ELSE Put2(Ldw, RH, SP, x.a+4) END ; + incR + ELSIF ftype.form = Record THEN + IF xmd = Par THEN Put2(Ldw, RH, SP, x.a+4); incR 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 Put1(Mov, RH, 0, x.type.len) ELSE Put2(Ldw, RH, SP, x.a+4) END ; + incR + END OpenArrayParam; + + (*---------------------------------*) + + PROCEDURE CFJump*(VAR x: Item); (*conditional forward jump*) + BEGIN + IF x.mode # Cond THEN loadCond(x) END ; + Put3(2, negated(x.r), x.a); FixLink(x.b); x.a := pc-1 + END CFJump; + + PROCEDURE FJump*(VAR L: LONGINT); (*unconditional forward jump*) + BEGIN Put3(2, 7, L); L := pc-1 + END FJump; + + PROCEDURE CBJump*(VAR x: Item; L: LONGINT); (*conditional backward jump*) + BEGIN + IF x.mode # Cond THEN loadCond(x) END ; + Put3(2, negated(x.r), L-pc-1) + END CBJump; + + PROCEDURE BJump*(L: LONGINT); (*unconditional backward jump*) + BEGIN Put3(2, 7, L-pc-1) + END BJump; + + PROCEDURE Call*(VAR obj: Object); + BEGIN Put3(3, 7, (obj.val DIV 4) - pc-1); RH := 0 + END Call; + + PROCEDURE Enter*(parblksize, locblksize: LONGINT; comd: BOOLEAN); + VAR a, r: LONGINT; + BEGIN a := 4; r := 0; Put1(Sub, SP, SP, locblksize); Put2(Stw, LNK, SP, 0); + WHILE a < parblksize DO Put2(Stw, r, SP, a); INC(r); INC(a, 4) END ; + (* IF comd THEN Put2(Ldw, SB, 0, 0) END *) + END Enter; + + PROCEDURE Return*(size: LONGINT); + BEGIN Put2(Ldw, LNK, SP, 0); Put1(Add, SP, SP, size); Put3(BR, 7, LNK); RH := 0 + END Return; + + PROCEDURE Ord*(VAR x: Item); + BEGIN load(x); x.type := intType + END Ord; + + PROCEDURE OpenInput*; + BEGIN Put3(3, 7, pc - fixlist + 101000H); fixlist := pc-1; invalSB + END OpenInput; + + PROCEDURE ReadInt*(VAR x: Item); + BEGIN loadAdr(x); Put3(3, 7, pc - fixlist + 102000H); fixlist := pc-1; DEC(RH); invalSB + END ReadInt; + + PROCEDURE eot*(VAR x: Item); + BEGIN Put3(3, 7, pc - fixlist + 103000H); fixlist := pc-1; Put1(Cmp, 0, 0, Texts.Int); SetCC(x, NE); invalSB + END eot; + + PROCEDURE WriteChar*(VAR x: Item); + BEGIN load(x); Put3(3, 7, pc - fixlist + 104000H); fixlist:= pc-1; DEC(RH); invalSB + END WriteChar; + + PROCEDURE WriteInt*(VAR x, y: Item); + BEGIN load(x); load(y); Put3(3, 7, pc - fixlist + 105000H); fixlist := pc-1; DEC(RH, 2); invalSB + END WriteInt; + + PROCEDURE WriteLn*; + BEGIN Put3(3, 7, pc - fixlist + 106000H); fixlist := pc-1; invalSB + END WriteLn; + + PROCEDURE Switch*(VAR x: Item); + BEGIN Put1(Mov, RH, 0, -60); Put2(Ldw, RH, RH, 0); + x.mode := Reg; x.type := intType; x.r := RH; INC(RH) + END Switch; + + PROCEDURE LED*(VAR x: Item); + BEGIN load(x); Put1(Mov, RH, 0, -60); Put2(Stw, x.r, RH, 0); DEC(RH) + END LED ; + + PROCEDURE Open*; + BEGIN curlev := 0; pc := 0; RH := 0; fixlist := 0; fixorgD := 0 + END Open; + + PROCEDURE Header*(size: LONGINT); + BEGIN entry := pc*4; Put1(Sub, SP, SP, 4); Put2(Stw, LNK, SP, 0); invalSB + END Header; + + PROCEDURE MakeFileName(VAR FName: OSS.Ident; name, ext: ARRAY OF CHAR); + VAR i, j: INTEGER; + BEGIN i := 0; j := 0; (*assume name suffix less than 4 characters*) + WHILE (i < OSS.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 Close*(VAR modid: OSS.Ident; key, datasize: LONGINT; topScope: Object); (*write code file*) + VAR i, nofent, nofimp, comsize, size: INTEGER; + obj: Object; + name: OSS.Ident; + F: Files.File; R: Files.Rider; + BEGIN Put2(Ldw, LNK, SP, 0); Put1(Add, SP, SP, 4); Put3(BR, 7, LNK); + obj := topScope.next; comsize := 4; nofent := 1; nofimp := 1; + WHILE obj # NIL DO + IF obj.comd THEN i := 0; (*count entries and commands*) + WHILE obj.name[i] # 0X DO INC(i) END ; + i := (i+4) DIV 4 * 4; INC(comsize, i+4); INC(nofent); INC(nofimp) + END ; + obj := obj.next + END ; + size := datasize + comsize + (pc + nofimp + nofent + 1)*4; + 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.Write(R, 1X); (*version*) + Files.WriteInt(R, size); + Files.WriteString(R, "IO"); Files.WriteInt(R, 3A8372E2H); Files.Write(R, 0X); (*import*) + Files.WriteInt(R, 0); (*no type descriptors*) + Files.WriteInt(R, datasize); (*data*) + Files.WriteInt(R, 0); (*no strings*) + Files.WriteInt(R, pc); (*code len*) + FOR i := 0 TO pc-1 DO Files.WriteInt(R, code[i]) END ; (*program*) + obj := topScope.next; + WHILE obj # NIL DO (*commands*) + IF obj.comd 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); (*of program body*) + obj := topScope.next; + WHILE obj # NIL DO (*entries*) + IF obj.comd THEN Files.WriteInt(R, obj.val) END ; + obj := obj.next + END ; + Files.WriteInt(R, -1); (*no pointer variables*) + Files.WriteInt(R, fixlist); Files.WriteInt(R, fixorgD); Files.WriteInt(R, 0); Files.WriteInt(R, entry); + Files.Write(R, "O"); Files.Register(F) + END Close; + + (*-------------------- output -----------------------*) + + PROCEDURE WriteReg(r: LONGINT); + BEGIN Texts.Write(W, " "); + IF r < 13 THEN Texts.Write(W, "R"); Texts.WriteInt(W, r, 1) + ELSIF r = 13 THEN Texts.WriteString(W, "SB") + ELSIF r = 14 THEN Texts.WriteString(W, "SP") + ELSIF r = 15 THEN Texts.WriteString(W, "LNK") + END + END WriteReg; + + PROCEDURE Decode*; + VAR i, w, a, b, c, op: LONGINT; + BEGIN Texts.WriteHex(W, code[0]); Texts.WriteHex(W, code[1]); Texts.WriteLn(W); + i := 0; + WHILE i < pc DO + w := code[i]; + a := w DIV 1000000H MOD 10H; + b := w DIV 100000H MOD 10H; + Texts.WriteInt(W, i, 4); Texts.WriteHex(W, w); Texts.Write(W, 9X); + IF ASR(w, 31) = 0 THEN (*~p: register instruction*) + op := w DIV 10000H MOD 10H; + Texts.WriteString(W, mnemo0[op]); WriteReg(a); WriteReg(b); + IF ~ODD(w DIV 40000000H) THEN (*~q*) WriteReg(w MOD 10H) + ELSE c := w MOD 10000H;; + IF ODD(w DIV 10000000H) THEN (*v*) c := c + 0FFFF0000H END ; + Texts.WriteInt(W, c, 8) + END + ELSIF ~ODD(w DIV 40000000H) THEN (*load/store*) + IF ODD(w DIV 20000000H) THEN Texts.WriteString(W, "STW ") ELSE Texts.WriteString(W, "LDW") END ; + WriteReg(a); WriteReg(b); Texts.WriteInt(W, w MOD 100000H, 8) + ELSE (*Branch instr*) + Texts.Write(W, "B"); + IF ODD(w DIV 10000000H) THEN Texts.Write(W, "L") END ; + Texts.WriteString(W, mnemo1[a]); + IF ~ODD(w DIV 20000000H) THEN WriteReg(w MOD 10H) ELSE + w := w MOD 1000000H; + IF w >= 800000H THEN w := w - 1000000H END ; + Texts.WriteInt(W, w, 8) + END + END ; + Texts.WriteLn(W); INC(i) + END ; + Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) + END Decode; + + PROCEDURE HexCh(k: LONGINT): CHAR; + BEGIN + IF k >= 10 THEN INC(k, 27H) END ; + RETURN CHR(k+30H) + END HexCh; + +BEGIN Texts.OpenWriter(W); + NEW(boolType); boolType.form := Boolean; boolType.size := 4; + NEW(intType); intType.form := Integer; intType.size := 4; + relmap[0] := EQ; relmap[1] := NE; relmap[2] := LT; relmap[3] := LE; relmap[4] := GT; relmap[5] := GE; + mnemo0[Mov] := "MOV"; + mnemo0[Lsl] := "LSL"; + mnemo0[Asr] := "ASR"; + mnemo0[Ror] := "ROR"; + mnemo0[And] := "AND"; + mnemo0[Ann] := "ANN"; + mnemo0[Ior] := "IOR"; + mnemo0[Xor] := "XOR"; + mnemo0[Add] := "ADD"; + mnemo0[Sub] := "SUB"; + mnemo0[Mul] := "MUL"; + mnemo0[Div] := "DIV"; + mnemo1[PL] := "PL "; + mnemo1[MI] := "MI "; + mnemo1[EQ] := "EQ "; + mnemo1[NE] := "NE "; + mnemo1[LT] := "LT "; + mnemo1[GE] := "GE "; + mnemo1[LE] := "LE "; + mnemo1[GT] := "GT "; + mnemo1[15] := "NO "; +END OSG. diff --git a/cerise/oberon0/OSP.Mod b/cerise/oberon0/OSP.Mod new file mode 100644 index 0000000..58be0a2 --- /dev/null +++ b/cerise/oberon0/OSP.Mod @@ -0,0 +1,569 @@ +MODULE OSP; (* NW 23.9.93 / 9,5.2017 OSPX*) + IMPORT Texts, Oberon, OSS, OSG; + + CONST WordSize = 4; + VAR sym, level: INTEGER; + topScope, universe, dummy: OSG.Object; + expression: PROCEDURE (VAR x: OSG.Item); (*to avoid forward reference*) + W: Texts.Writer; + + PROCEDURE NewObj(VAR obj: OSG.Object; class: INTEGER); + VAR new, x: OSG.Object; + BEGIN x := topScope; + WHILE (x.next # NIL) & (x.next.name # OSS.id) DO x := x.next END ; + IF x.next = NIL THEN + NEW(new); new.name := OSS.id; new.class := class; new.next := NIL; + x.next := new; obj := new + ELSE obj := x.next; OSS.Mark("mult def") + END + END NewObj; + + PROCEDURE find(VAR obj: OSG.Object); + VAR s, x: OSG.Object; + BEGIN s := topScope; + REPEAT x := s.next; + WHILE (x # NIL) & (x.name # OSS.id) DO x := x.next END ; + s := s.dsc + UNTIL (x # NIL) OR (s = NIL); + IF x = NIL THEN x := dummy; OSS.Mark("undef") END ; + obj := x + END find; + + PROCEDURE FindField(VAR obj: OSG.Object; list: OSG.Object); + BEGIN + WHILE (list # NIL) & (list.name # OSS.id) DO list := list.next END ; + IF list # NIL THEN obj := list ELSE OSS.Mark("undef"); obj := dummy END + END FindField; + + PROCEDURE Check(s: INTEGER; msg: ARRAY OF CHAR); + BEGIN + IF sym = s THEN OSS.Get(sym) ELSE OSS.Mark(msg) END + END Check; + + PROCEDURE CheckInt(VAR x: OSG.Item); + BEGIN + IF x.type.form # OSG.Integer THEN OSS.Mark("not integer") END + END CheckInt; + + PROCEDURE CheckBool(VAR x: OSG.Item); + BEGIN + IF x.type.form # OSG.Boolean THEN OSS.Mark("not Boolean") END + END CheckBool; + + PROCEDURE OpenScope; + VAR s: OSG.Object; + BEGIN NEW(s); s.class := OSG.Head; s.dsc := topScope; s.next := NIL; topScope := s + END OpenScope; + + PROCEDURE CloseScope; + BEGIN topScope := topScope.dsc + END CloseScope; + + (* -------------------- Parser ---------------------*) + + PROCEDURE selector(VAR x: OSG.Item); + VAR y: OSG.Item; obj: OSG.Object; + BEGIN + WHILE (sym = OSS.lbrak) OR (sym = OSS.period) DO + IF sym = OSS.lbrak THEN + OSS.Get(sym); expression(y); + IF x.type.form = OSG.Array THEN + CheckInt(y); OSG.Index(x, y); x.type := x.type.base + ELSE OSS.Mark("not an array") + END ; + Check(OSS.rbrak, "no ]") + ELSE (*period*) OSS.Get(sym); + IF sym = OSS.ident THEN + IF x.type.form = OSG.Record THEN + FindField(obj, x.type.dsc); OSS.Get(sym); + IF obj # NIL THEN OSG.Field(x, obj); x.type := obj.type END + ELSE OSS.Mark("not a record") + END + ELSE OSS.Mark("ident?") + END + END + END + END selector; + + PROCEDURE CompTypes(t0, t1: OSG.Type): BOOLEAN; + BEGIN (*Compatible Types*) + RETURN (t0 = t1) + OR (t0.form = OSG.Array) & (t1.form = OSG.Array) & CompTypes(t0.base, t1.base) + END CompTypes; + + PROCEDURE Parameter(par: OSG.Object); + VAR x: OSG.Item; varpar: BOOLEAN; + BEGIN expression(x); + IF par # NIL THEN + varpar := par.class = OSG.Par; + IF CompTypes(par.type, x.type) THEN + IF ~varpar THEN OSG.ValueParam(x) + ELSE OSG.VarParam(x, par.type) + END + ELSIF (x.type.form = OSG.Array) & (par.type.form = OSG.Array) & + (x.type.base.form = par.type.base.form) & (par.type.len < 0) THEN + OSG.OpenArrayParam(x) + ELSE OSS.Mark("incompatible parameters") + END + END + END Parameter; + + PROCEDURE ParamList(VAR obj: OSG.Object); + VAR n: INTEGER; par: OSG.Object; + BEGIN par := obj.dsc; n := 0; + IF sym # OSS.rparen THEN + Parameter(par); n := 1; + WHILE sym <= OSS.comma DO + Check(sym, "comma?"); + IF par # NIL THEN par := par.next END ; + INC(n); Parameter(par) + END ; + Check(OSS.rparen, ") missing") + ELSE OSS.Get(sym); + END ; + IF n < obj.nofpar THEN OSS.Mark("too few params") + ELSIF n > obj.nofpar THEN OSS.Mark("too many params") + END + END ParamList; + + PROCEDURE StandFunc(VAR x: OSG.Item; fctno: LONGINT); + VAR y, z: OSG.Item; + BEGIN + IF sym = OSS.lparen THEN + OSS.Get(sym); + IF fctno = 0 THEN (*ORD*) expression(x); OSG.Ord(x) + ELSIF fctno = 1 THEN (*eot*) OSG.eot(x) + ELSE (*fctno = 2*) OSG.Switch(x) + END ; + IF sym = OSS.rparen THEN OSS.Get(sym) ELSE OSS.Mark("rparen expected") END + ELSE OSS.Mark("param missing"); OSG.MakeConstItem(x, OSG.intType, 0) + END + END StandFunc; + + PROCEDURE factor(VAR x: OSG.Item); + VAR obj: OSG.Object; + BEGIN (*sync*) + IF (sym < OSS.char) OR (sym > OSS.ident) THEN + OSS.Mark("expression expected"); + REPEAT OSS.Get(sym) UNTIL (sym >= OSS.int) & (sym <= OSS.ident) + END ; + IF sym = OSS.ident THEN + find(obj); + OSS.Get(sym); + IF obj.class = OSG.SFunc THEN + IF obj.type = NIL THEN + OSS.Mark("not a function"); + obj.type := OSG.intType + END ; + StandFunc(x, obj.val); x.type := obj.type + ELSE + OSG.MakeItem(x, obj, level); + selector(x) + END + ELSIF sym = OSS.int THEN + OSG.MakeConstItem(x, OSG.intType, OSS.val); + OSS.Get(sym) + ELSIF sym = OSS.char THEN + OSG.MakeConstItem(x, OSG.intType, OSS.val); + OSS.Get(sym) + ELSIF sym = OSS.lparen THEN + OSS.Get(sym); + IF sym # OSS.rparen THEN expression(x) END ; + Check(OSS.rparen, "no )") + ELSIF sym = OSS.not THEN + OSS.Get(sym); + factor(x); + CheckBool(x); + OSG.Not(x) + ELSIF sym = OSS.false THEN + OSS.Get(sym); + OSG.MakeConstItem(x, OSG.boolType, 0) + ELSIF sym = OSS.true THEN + OSS.Get(sym); + OSG.MakeConstItem(x, OSG.boolType, 1) + ELSE + OSS.Mark("factor?"); + OSG.MakeItem(x, dummy, level) + END + END factor; + + PROCEDURE term(VAR x: OSG.Item); + VAR y: OSG.Item; op: INTEGER; + BEGIN factor(x); + WHILE (sym >= OSS.times) & (sym <= OSS.and) DO + op := sym; OSS.Get(sym); + IF op = OSS.times THEN + CheckInt(x); + factor(y); + CheckInt(y); + OSG.MulOp(x, y) + ELSIF (op = OSS.div) OR (op = OSS.mod) THEN + CheckInt(x); + factor(y); + CheckInt(y); + OSG.DivOp(op, x, y) + ELSE (*op = and*) + CheckBool(x); + OSG.And1(x); + factor(y); + CheckBool(y); + OSG.And2(x, y) + END + END + END term; + + PROCEDURE SimpleExpression(VAR x: OSG.Item); + VAR y: OSG.Item; op: INTEGER; + BEGIN + IF sym = OSS.plus THEN + OSS.Get(sym); + term(x); + CheckInt(x) + ELSIF sym = OSS.minus THEN + OSS.Get(sym); + term(x); + CheckInt(x); + OSG.Neg(x) + ELSE + term(x) + END; + + WHILE (sym >= OSS.plus) & (sym <= OSS.or) DO + op := sym; OSS.Get(sym); + IF op = OSS.or THEN + OSG.Or1(x); + CheckBool(x); + term(y); + CheckBool(y); + OSG.Or2(x, y) + ELSE + CheckInt(x); + term(y); + CheckInt(y); + OSG.AddOp(op, x, y) + END + END + END SimpleExpression; + + PROCEDURE expression0(VAR x: OSG.Item); + VAR y: OSG.Item; op: INTEGER; + BEGIN SimpleExpression(x); + IF (sym >= OSS.eql) & (sym <= OSS.geq) THEN + op := sym; + OSS.Get(sym); + SimpleExpression(y); + IF x.type = y.type THEN + OSG.Relation(op, x, y) + ELSE + OSS.Mark("incompatible types") + END ; + x.type := OSG.boolType + END + END expression0; + + PROCEDURE StandProc(pno: LONGINT); + VAR x, y: OSG.Item; + BEGIN + IF pno = 0 THEN OSG.OpenInput + ELSIF pno IN {1, 2, 3, 5} THEN + IF sym = OSS.lparen THEN OSS.Get(sym); expression(x); + IF pno = 1 THEN OSG.ReadInt(x); + ELSIF pno = 2 THEN + IF sym = OSS.comma THEN OSS.Get(sym); expression(y); OSG.WriteInt(x, y) ELSE OSS.Mark("no comma") END + ELSIF pno = 3 THEN OSG.WriteChar(x) + ELSIF pno = 5 THEN OSG.LED(x) + END ; + IF sym = OSS.rparen THEN OSS.Get(sym) ELSE OSS.Mark("no rparen") END + ELSE OSS.Mark(" missing lparen") + END + ELSIF pno = 4 THEN OSG.WriteLn + ELSE OSS.Mark("undef proc") + END + END StandProc; + + PROCEDURE StatSequence; + VAR par, obj: OSG.Object; x, y: OSG.Item; n, L: LONGINT; + BEGIN (* StatSequence *) + REPEAT (*sync*) obj := NIL; + IF ~((sym = OSS.ident) OR (sym >= OSS.if) & (sym <= OSS.repeat) OR (sym >= OSS.semicolon)) THEN + OSS.Mark("statement expected"); + REPEAT OSS.Get(sym) UNTIL (sym = OSS.ident) OR (sym >= OSS.if) + END ; + IF sym = OSS.ident THEN + find(obj); OSS.Get(sym); + IF obj.class = OSG.SProc THEN StandProc(obj.val) + ELSE OSG.MakeItem(x, obj, level); selector(x); + IF sym = OSS.becomes THEN (*assignment*) + OSS.Get(sym); expression(y); + IF (x.type.form IN {OSG.Boolean, OSG.Integer}) & (x.type.form = y.type.form) THEN OSG.Store(x, y) + ELSE OSS.Mark("incompatible assignment") + END + ELSIF sym = OSS.eql THEN OSS.Mark("should be :="); OSS.Get(sym); expression(y) + ELSIF sym = OSS.lparen THEN (*procedure call*) + OSS.Get(sym); + IF (obj.class = OSG.Proc) & (obj.type = NIL) THEN ParamList(obj); OSG.Call(obj); + ELSE OSS.Mark("not a procedure") + END + ELSIF obj.class = OSG.Proc THEN (*procedure call without parameters*) + IF obj.nofpar > 0 THEN OSS.Mark("missing parameters") END ; + IF obj.type = NIL THEN OSG.Call(obj) ELSE OSS.Mark("not a procedure") END + ELSIF (obj.class = OSG.SProc) & (obj.val = 3) THEN OSG.WriteLn + ELSIF obj.class = OSG.Typ THEN OSS.Mark("illegal assignment") + ELSE OSS.Mark("not a procedure") + END + END + ELSIF sym = OSS.if THEN + OSS.Get(sym); expression(x); CheckBool(x); OSG.CFJump(x); Check(OSS.then, "no THEN"); + StatSequence; L := 0; + WHILE sym = OSS.elsif DO + OSS.Get(sym); OSG.FJump(L); OSG.FixLink(x.a); expression(x); CheckBool(x); OSG.CFJump(x); + IF sym = OSS.then THEN OSS.Get(sym) ELSE OSS.Mark("THEN?") END ; + StatSequence + END ; + IF sym = OSS.else THEN + OSS.Get(sym); OSG.FJump(L); OSG.FixLink(x.a); StatSequence + ELSE OSG.FixLink(x.a) + END ; + OSG.FixLink(L); + IF sym = OSS.end THEN OSS.Get(sym) ELSE OSS.Mark("END?") END + ELSIF sym = OSS.while THEN + OSS.Get(sym); L := OSG.pc; expression(x); CheckBool(x); OSG.CFJump(x); + Check(OSS.do, "no DO"); StatSequence; OSG.BJump(L); OSG.FixLink(x.a); + Check(OSS.end, "no END") + ELSIF sym = OSS.repeat THEN + OSS.Get(sym); L := OSG.pc; StatSequence; + IF sym = OSS.until THEN + OSS.Get(sym); expression(x); CheckBool(x); OSG.CBJump(x, L) + ELSE OSS.Mark("missing UNTIL"); OSS.Get(sym) + END + END ; + OSG.CheckRegs; + IF sym = OSS.semicolon THEN OSS.Get(sym) + ELSIF sym < OSS.semicolon THEN OSS.Mark("missing semicolon?") + END + UNTIL sym > OSS.semicolon + END StatSequence; + + PROCEDURE IdentList(class: INTEGER; VAR first: OSG.Object); + VAR obj: OSG.Object; + BEGIN + IF sym = OSS.ident THEN + NewObj(first, class); OSS.Get(sym); + WHILE sym = OSS.comma DO + OSS.Get(sym); + IF sym = OSS.ident THEN NewObj(obj, class); OSS.Get(sym) + ELSE OSS.Mark("ident?") + END + END; + Check(OSS.colon, "no :") + END + END IdentList; + + PROCEDURE Type(VAR type: OSG.Type); + VAR obj, first: OSG.Object; x: OSG.Item; tp: OSG.Type; + BEGIN type := OSG.intType; (*sync*) + IF (sym # OSS.ident) & (sym < OSS.array) THEN OSS.Mark("type?"); + REPEAT OSS.Get(sym) UNTIL (sym = OSS.ident) OR (sym >= OSS.array) + END ; + IF sym = OSS.ident THEN + find(obj); OSS.Get(sym); + IF obj.class = OSG.Typ THEN type := obj.type ELSE OSS.Mark("type?") END + ELSIF sym = OSS.array THEN + OSS.Get(sym); expression(x); + IF (x.mode # OSG.Const) OR (x.a < 0) THEN OSS.Mark("bad index") END ; + IF sym = OSS.of THEN OSS.Get(sym) ELSE OSS.Mark("OF?") END ; + Type(tp); NEW(type); type.form := OSG.Array; type.base := tp; + type.len := x.a; type.size := type.len * tp.size + ELSIF sym = OSS.record THEN + OSS.Get(sym); NEW(type); type.form := OSG.Record; type.size := 0; OpenScope; + REPEAT + IF sym = OSS.ident THEN + IdentList(OSG.Fld, first); Type(tp); obj := first; + WHILE obj # NIL DO + obj.type := tp; obj.val := type.size; type.size := type.size + obj.type.size; obj := obj.next + END + END ; + IF sym = OSS.semicolon THEN OSS.Get(sym) + ELSIF sym = OSS.ident THEN OSS.Mark("; ?") + END + UNTIL sym # OSS.ident; + type.dsc := topScope.next; CloseScope; Check(OSS.end, "no END") + ELSE OSS.Mark("ident?") + END + END Type; + + PROCEDURE Declarations(VAR varsize: LONGINT); + VAR obj, first: OSG.Object; + x: OSG.Item; tp: OSG.Type; L: LONGINT; + BEGIN (*sync*) + IF (sym < OSS.const) & (sym # OSS.end) THEN + (* error and attempt recovery *) + OSS.Mark("declaration?"); + REPEAT OSS.Get(sym) UNTIL (sym >= OSS.const) OR (sym = OSS.end) + END ; + + IF sym = OSS.const THEN + OSS.Get(sym); + WHILE sym = OSS.ident DO + NewObj(obj, OSG.Const); OSS.Get(sym); + IF sym = OSS.eql THEN OSS.Get(sym) ELSE OSS.Mark("=?") END; + expression(x); + IF x.mode = OSG.Const THEN + obj.val := x.a; obj.type := x.type + ELSE + OSS.Mark("expression not constant") + END ; + Check(OSS.semicolon, "; expected") + END + END ; + + IF sym = OSS.type THEN + OSS.Get(sym); + WHILE sym = OSS.ident DO + NewObj(obj, OSG.Typ); OSS.Get(sym); + IF sym = OSS.eql THEN OSS.Get(sym) ELSE OSS.Mark("=?") END ; + Type(obj.type); Check(OSS.semicolon, "; expected") + END + END ; + + IF sym = OSS.var THEN + OSS.Get(sym); + WHILE sym = OSS.ident DO + IdentList(OSG.Var, first); Type(tp); + obj := first; + WHILE obj # NIL DO + obj.type := tp; obj.lev := level; + obj.val := varsize; varsize := varsize + obj.type.size; obj := obj.next + END ; + Check(OSS.semicolon, "; expected") + END + END ; + IF (sym >= OSS.const) & (sym <= OSS.var) THEN OSS.Mark("declaration in bad order") END + END Declarations; + + PROCEDURE ProcedureDecl; + CONST marksize = 4; + VAR proc, obj: OSG.Object; + procid: OSS.Ident; + nofpar: INTEGER; + locblksize, parblksize: LONGINT; + + PROCEDURE FPSection(VAR adr: LONGINT; VAR nofpar: INTEGER); + VAR obj, first: OSG.Object; tp: OSG.Type; parsize: LONGINT; + BEGIN + IF sym = OSS.var THEN OSS.Get(sym); IdentList(OSG.Par, first) + ELSE IdentList(OSG.Var, first) + END ; + IF sym = OSS.ident THEN + find(obj); OSS.Get(sym); + IF obj.class = OSG.Typ THEN tp := obj.type ELSE OSS.Mark("type?"); tp := OSG.intType END + ELSE OSS.Mark("ident?"); tp := OSG.intType + END ; + IF first.class = OSG.Var THEN + parsize := tp.size; + IF tp.form >= OSG.Array THEN OSS.Mark("no struct params") END ; + ELSE parsize := WordSize + END ; + obj := first; + WHILE obj # NIL DO + INC(nofpar); obj.type := tp; obj.lev := level; obj.val := adr; adr := adr + parsize; + obj := obj.next + END + END FPSection; + + BEGIN (* ProcedureDecl *) OSS.Get(sym); + IF sym = OSS.ident THEN + procid := OSS.id; NewObj(proc, OSG.Proc); OSS.Get(sym); parblksize := marksize; nofpar := 0; + (* Texts.Write(W, "%"); Texts.WriteInt(W, sym, 4); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); *) + OpenScope; INC(level); proc.val := -1; + IF sym = OSS.times THEN proc.comd := TRUE; OSS.Get(sym) ELSE proc.comd := FALSE END ; + IF sym = OSS.lparen THEN + OSS.Get(sym); + IF sym = OSS.rparen THEN OSS.Get(sym) + ELSE FPSection(parblksize, nofpar); + WHILE sym = OSS.semicolon DO OSS.Get(sym); FPSection(parblksize, nofpar) END ; + IF sym = OSS.rparen THEN OSS.Get(sym) ELSE OSS.Mark(")?") END ; + IF proc.comd THEN OSS.Mark("no params allowed") END + END + END ; + locblksize := parblksize; proc.type := NIL; proc.dsc := topScope.next; proc.nofpar := nofpar; + Check(OSS.semicolon, "; expected"); + Declarations(locblksize); proc.dsc := topScope.next; + WHILE sym = OSS.procedure DO + ProcedureDecl; Check(OSS.semicolon, "; expected") + END ; + proc.val := OSG.pc * 4; OSG.Enter(parblksize, locblksize, proc.comd); + IF sym = OSS.begin THEN OSS.Get(sym); StatSequence END ; + Check(OSS.end, "no END"); + IF sym = OSS.ident THEN + IF procid # OSS.id THEN OSS.Mark("no match") END ; + OSS.Get(sym) + END ; + OSG.Return(locblksize); DEC(level); CloseScope + END + END ProcedureDecl; + + PROCEDURE Module; + VAR modid: OSS.Ident; dc: LONGINT; + BEGIN + Texts.WriteString(W, " compiling "); + IF sym = OSS.module THEN + OSS.Get(sym); OSG.Open; OpenScope; dc := 0; level := 0; + IF sym = OSS.ident THEN + modid := OSS.id; OSS.Get(sym); + Texts.WriteString(W, modid); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) + ELSE + OSS.Mark("ident?") + END ; + Check(OSS.semicolon, "; expected"); + Declarations(dc); + WHILE sym = OSS.procedure DO ProcedureDecl; Check(OSS.semicolon, "; expected") END ; + OSG.Header(dc); + IF sym = OSS.begin THEN OSS.Get(sym); StatSequence END ; + Check(OSS.end, "no END"); + IF sym = OSS.ident THEN + IF modid # OSS.id THEN OSS.Mark("no match") END ; + OSS.Get(sym) + ELSE OSS.Mark("ident?") + END ; + IF sym # OSS.period THEN OSS.Mark(". ?") END ; + IF ~OSS.error THEN + OSG.Close(modid, 1, dc, topScope); Texts.WriteString(W, "code generated "); Texts.WriteString(W, modid); + Texts.WriteInt(W, OSG.pc, 6); Texts.WriteInt(W, dc, 6); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) + END ; + CloseScope + ELSE OSS.Mark("MODULE?") + END + END Module; + + PROCEDURE Compile*; + VAR beg, end, time: LONGINT; T: Texts.Text; + BEGIN Oberon.GetSelection(T, beg, end, time); + IF time >= 0 THEN OSS.Init(T, beg); OSS.Get(sym); Module END + END Compile; + + PROCEDURE enter(name: ARRAY OF CHAR; cl: INTEGER; n: LONGINT; type: OSG.Type); + VAR obj: OSG.Object; + BEGIN NEW(obj); + obj.class := cl; obj.val := n; obj.name := name; obj.type := type; obj.dsc := NIL; + obj.next := topScope.next; topScope.next := obj + END enter; + +BEGIN Texts.OpenWriter(W); Texts.WriteString(W, "Oberon-0 Compiler OSP 9.5.2017"); + Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); + NEW(dummy); dummy.class := OSG.Var; dummy.type := OSG.intType; dummy.val := 0; + expression := expression0; + topScope := NIL; OpenScope;; + enter("ORD", OSG.SFunc, 0, OSG.intType); + enter("eot", OSG.SFunc, 1, OSG.boolType); + enter("Switch", OSG.SFunc, 2, OSG.intType); + enter("OpenInput", OSG.SProc, 0, NIL); + enter("ReadInt", OSG.SProc, 1, NIL); + enter("WriteInt", OSG.SProc, 2, NIL); + enter("WriteChar", OSG.SProc, 3, NIL); + enter("WriteLn", OSG.SProc, 4, NIL); + enter("LED", OSG.SProc, 5, NIL); + enter("BOOLEAN", OSG.Typ, 0, OSG.boolType); + enter("INTEGER", OSG.Typ, 1, OSG.intType); + universe := topScope +END OSP. diff --git a/cerise/oberon0/OSS.Mod b/cerise/oberon0/OSS.Mod new file mode 100644 index 0000000..2bc77b9 --- /dev/null +++ b/cerise/oberon0/OSS.Mod @@ -0,0 +1,178 @@ +MODULE OSS; (* NW 19.9.93 / 17.11.94 / 1.11.2013*) + IMPORT Texts, Oberon; + + CONST IdLen* = 16; KW = 34; maxInt = 2147483647; + + (*lexical symbols of Oberon*) + null = 0; times* = 1; div* = 3; mod* = 4; + and* = 5; plus* = 6; minus* = 7; or* = 8; eql* = 9; + neq* = 10; lss* = 11; leq* = 12; gtr* = 13; geq* = 14; + period* = 18; char* = 20; int* = 21; false* = 23; true* = 24; + not* = 27; lparen* = 28; lbrak* = 29; + ident* = 31; if* = 32; while* = 34; + repeat* = 35; + comma* = 40; colon* = 41; becomes* = 42; rparen* = 44; + rbrak* = 45; then* = 47; of* = 48; do* = 49; + semicolon* = 52; end* = 53; + else* = 55; elsif* = 56; until* = 57; + array* = 60; record* = 61; const* = 63; type* = 64; + var* = 65; procedure* = 66; begin* = 67; module* = 69; + eof = 70; + + TYPE Ident* = ARRAY IdLen OF CHAR; + + VAR val*: LONGINT; + id*: Ident; + error*: BOOLEAN; + + ch: CHAR; + nkw: INTEGER; + errpos: LONGINT; + R: Texts.Reader; + W: Texts.Writer; + keyTab: ARRAY KW OF (*keywords of Oberon*) + RECORD sym: INTEGER; id: ARRAY 12 OF CHAR END; + + PROCEDURE Mark*(msg: ARRAY OF CHAR); + VAR p: LONGINT; + BEGIN p := Texts.Pos(R) - 1; + IF p > errpos THEN + Texts.WriteString(W, " pos "); Texts.WriteInt(W, p, 1); + Texts.Write(W, " "); Texts.WriteString(W, msg); + Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) + END ; + errpos := p; error := TRUE + END Mark; + + PROCEDURE Identifier(VAR sym: INTEGER); + VAR i, k: INTEGER; + BEGIN i := 0; + REPEAT + IF i < IdLen 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; k := 0; + WHILE (k < nkw) & (id # keyTab[k].id) DO INC(k) END ; + IF k < nkw THEN sym := keyTab[k].sym ELSE sym := ident END + END Identifier; + + PROCEDURE Number(VAR sym: INTEGER); + BEGIN val := 0; sym := int; + REPEAT + IF val <= (maxInt - ORD(ch) + ORD("0")) DIV 10 THEN + val := 10 * val + (ORD(ch) - ORD("0")) + ELSE Mark("number too large"); val := 0 + END ; + Texts.Read(R, ch) + UNTIL (ch < "0") OR (ch > "9") + END Number; + + PROCEDURE comment; + BEGIN + REPEAT + REPEAT Texts.Read(R, ch); + WHILE ch = "(" DO Texts.Read(R, ch); + IF ch = "*" THEN comment END + END ; + UNTIL (ch = "*") OR R.eot; + REPEAT Texts.Read(R, ch) UNTIL (ch # "*") OR R.eot + UNTIL (ch = ")") OR R.eot; + IF ~R.eot THEN Texts.Read(R, ch) ELSE Mark("comment not terminated") 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 + Texts.Read(R, ch); val := ORD(ch); + REPEAT Texts.Read(R, ch) UNTIL (ch = 22X) OR R.eot; + Texts.Read(R, ch); sym := char + ELSIF ch = "#" THEN Texts.Read(R, ch); sym := neq + 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); sym := period + ELSIF ch = "/" THEN Texts.Read(R, ch); sym := null + 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 := null + ELSE (* _ ` *) sym := null + END ; + Texts.Read(R, ch) + ELSIF ch < "{" THEN Identifier(sym) ELSE + IF ch = "{" THEN sym := null + ELSIF ch = "}" THEN sym := null + ELSIF ch = "|" THEN sym := null + ELSIF ch = "~" THEN sym := not + ELSE sym := null + END ; + Texts.Read(R, ch) + END + UNTIL sym # null + END Get; + + PROCEDURE Init*(T: Texts.Text; pos: LONGINT); + BEGIN error := FALSE; errpos := pos; Texts.OpenReader(R, T, pos); Texts.Read(R, ch) + END Init; + + PROCEDURE EnterKW(sym: INTEGER; name: ARRAY OF CHAR); + BEGIN keyTab[nkw].sym := sym; COPY(name, keyTab[nkw].id); INC(nkw) + END EnterKW; + +BEGIN Texts.OpenWriter(W); error := TRUE; nkw := 0; + EnterKW(array, "ARRAY"); + EnterKW(begin, "BEGIN"); + EnterKW(null, "BY"); + EnterKW(const, "CONST"); + EnterKW(div, "DIV"); + EnterKW(do, "DO"); + EnterKW(else, "ELSE"); + EnterKW(elsif, "ELSIF"); + EnterKW(end, "END"); + EnterKW(false, "FALSE"); + EnterKW(null, "FOR"); + EnterKW(if, "IF"); + EnterKW(null, "IMPORT"); + EnterKW(null, "IN"); + EnterKW(null, "IS"); + EnterKW(mod, "MOD"); + EnterKW(module, "MODULE"); + EnterKW(null, "NIL"); + EnterKW(of, "OF"); + EnterKW(or, "OR"); + EnterKW(null, "POINTER"); + EnterKW(procedure, "PROCEDURE"); + EnterKW(record, "RECORD"); + EnterKW(repeat, "REPEAT"); + EnterKW(null, "RETURN"); + EnterKW(then, "THEN"); + EnterKW(null, "TO"); + EnterKW(true, "TRUE"); + EnterKW(type, "TYPE"); + EnterKW(until, "UNTIL"); + EnterKW(var, "VAR"); + EnterKW(while, "WHILE") +END OSS. diff --git a/cerise/oberon0/RISC.Mod b/cerise/oberon0/RISC.Mod new file mode 100644 index 0000000..3e4d739 --- /dev/null +++ b/cerise/oberon0/RISC.Mod @@ -0,0 +1,78 @@ +MODULE RISC; (*NW 22.9.07 / 15.12.2013*) + IMPORT SYSTEM, Texts, Oberon; + CONST + MOV = 0; LSL = 1; ASR = 2; ROR = 3; AND = 4; ANN = 5; IOR = 6; XOR = 7; + ADD = 8; SUB = 9; MUL = 10; Div = 11; + + VAR IR: LONGINT; (*instruction register*) + PC: LONGINT; (*program counter*) + N, Z: BOOLEAN; (*condition flags*) + R: ARRAY 16 OF LONGINT; + H: LONGINT; (*aux register for division*) + + PROCEDURE Execute*(VAR M: ARRAY OF LONGINT; pc: LONGINT; + VAR S: Texts.Scanner; VAR W: Texts.Writer); + VAR a, b, op, im: LONGINT; (*instruction fields*) + adr, A, B, C: LONGINT; + MemSize: LONGINT; + BEGIN PC := 0; R[13] := pc * 4; R[14] := LEN(M)*4; + REPEAT (*interpretation cycle*) + IR := M[PC]; INC(PC); + a := IR DIV 1000000H MOD 10H; + b := IR DIV 100000H MOD 10H; + op := IR DIV 10000H MOD 10H; + im := IR MOD 10000H; + IF ~ODD(ASH(IR, -31)) THEN (*~p: register instruction*) + B := R[b]; + IF ~ODD(ASH(IR, -30)) THEN (*~q*) C := R[IR MOD 10H] + ELSIF ~ODD(ASH(IR, -28)) THEN (*q&~v*) C := im + ELSE (*q&v*) C := im + 0FFFF0000H + END ; + CASE op OF + MOV: IF ~ODD(ASH(IR, -29)) THEN A := C ELSE A := H END | + LSL: A := SYSTEM.LSH(B, C) | + ASR: A := ASH(B, -C) | + ROR: A := SYSTEM.ROT(B, -C) | + AND: A := SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, B) * SYSTEM.VAL(SET, C)) | + ANN: A := SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, B) - SYSTEM.VAL(SET, C)) | + IOR: A := SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, B) + SYSTEM.VAL(SET, C)) | + XOR: A := SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, B) / SYSTEM.VAL(SET, C)) | + ADD: A := B + C | + SUB: A := B - C | + MUL: A := B * C | + Div: A := B DIV C; H := B MOD C + END ; + R[a] := A; N := A < 0; Z := A = 0 + ELSIF ~ODD(ASH(IR, -30)) THEN (*p & ~q: memory instruction*) + adr := (R[b] + IR MOD 100000H) DIV 4; + IF ~ODD(ASH(IR, -29)) THEN + IF adr >= 0 THEN (*load*) R[a] := M[adr]; N := A < 0; Z := A = 0 + ELSE (*input*) + IF adr = -1 THEN (*ReadInt*) Texts.Scan(S); R[a] := S.i; + ELSIF adr = -2 THEN (*eot*) Z := S.class # Texts.Int + END + END + ELSE + IF adr >= 0 THEN (*store*) M[adr] := R[a]; + ELSE (*output*); + IF adr = -1 THEN Texts.WriteInt(W, R[a], 4) + ELSIF adr = -2 THEN Texts.Write(W, CHR(R[a] MOD 80H)) + ELSIF adr = -3 THEN Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) + END + END + END + ELSE (* p & q: branch instruction*) + IF (a = 0) & N OR (a = 1) & Z OR (a = 5) & N OR (a = 6) & (N OR Z) OR (a = 7) OR + (a = 8) & ~N OR (a = 9) & ~Z OR (a = 13) & ~N OR (a = 14) & ~(N OR Z) THEN + IF ODD(ASH(IR, -28)) THEN R[15] := PC * 4 END ; + IF ODD(ASH(IR, -29)) THEN PC := (PC + (IR MOD 1000000H)) MOD 40000H + ELSE PC := R[IR MOD 10H] DIV 4 + END + END + END + UNTIL PC = 0; + Texts.Append(Oberon.Log, W.buf) + END Execute; +END RISC. + + diff --git a/cerise/oberon0/TestOberon0.Mod b/cerise/oberon0/TestOberon0.Mod new file mode 100644 index 0000000..e2da69e --- /dev/null +++ b/cerise/oberon0/TestOberon0.Mod @@ -0,0 +1,137 @@ +OSP.Compile @ +TestOberon0.Permutations 2 3 4~ +TestOberon0.MagicSquares 3~. +TestOberon0.PrimeNumbers 12 +TestOberon0.Fractions 16 +TestOberon0.Powers 16 + +MODULE TestOberon0; + VAR n: INTEGER; + a: ARRAY 10 OF INTEGER; + + PROCEDURE perm(k: INTEGER); + VAR i, x: INTEGER; + BEGIN + IF k = 0 THEN i := 0; + WHILE i < n DO WriteInt(a[i], 5); i := i+1 END ; + WriteLn; + ELSE perm(k-1); i := 0; + WHILE i < k-1 DO + x := a[i]; a[i] := a[k-1]; a[k-1] := x; + perm(k-1); + x := a[i]; a[i] := a[k-1]; a[k-1] := x; + i := i+1 + END + END + END perm; + + PROCEDURE Permutations*; + BEGIN OpenInput; n := 0; + WHILE ~eot() DO ReadInt(a[n]); n := n+1 END ; + perm(n) + END Permutations; + + PROCEDURE MagicSquares*; (*magic square of order 3, 5, 7, ... *) + VAR i, j, x, nx, nsq, n: INTEGER; + M: ARRAY 13 OF ARRAY 13 OF INTEGER; + BEGIN OpenInput; + IF ~eot() THEN + ReadInt(n); nsq := n*n; x := 0; + i := n DIV 2; j := n-1; + WHILE x < nsq DO + nx := n + x; j := (j-1) MOD n; x := x+1; M[i][j] := x; + WHILE x < nx DO + i := (i+1) MOD n; j := (j+1) MOD n; + x := x+1; M[i][j] := x + END + END ; + i := 0; + WHILE i < n DO + j := 0; + WHILE j < n DO WriteInt(M[i][j], 6); j := j+1 END ; + i := i+1; WriteLn + END + END + END MagicSquares; + + PROCEDURE PrimeNumbers*; + VAR i, k, m, x, inc, lim, sqr: INTEGER; prim: BOOLEAN; + p: ARRAY 400 OF INTEGER; + v: ARRAY 20 OF INTEGER; + BEGIN OpenInput; ReadInt(n); + x := 1; inc := 4; lim := 1; sqr := 4; m := 0; i := 3; + WHILE i <= n DO + REPEAT x := x + inc; inc := 6 - inc; + IF sqr <= x THEN (*sqr = p[lim]^2*) + v[lim] := sqr; lim := lim + 1; sqr := p[lim]*p[lim] + END ; + k := 2; prim := TRUE; + WHILE prim & (k < lim) DO + k := k+1; + IF v[k] < x THEN v[k] := v[k] + p[k] END ; + prim := x # v[k] + END + UNTIL prim; + p[i] := x; WriteInt(x, 5); i := i+1; + IF m = 10 THEN WriteLn; m := 0 ELSE m := m+1 END + END ; + IF m > 0 THEN WriteLn END + END PrimeNumbers; + + PROCEDURE Fractions*; (* Tabulate fractions 1/n*) + CONST Base = 10; N = 32; + VAR i, j, m, r, n: INTEGER; + d: ARRAY N OF INTEGER; (*digits*) + x: ARRAY N OF INTEGER; (*index*) + BEGIN OpenInput; + IF ~eot() THEN + ReadInt(n); i := 2; + WHILE i <= n DO j := 0; + WHILE j < i DO x[j] := 0; j := j+1 END ; + m := 0; r := 1; + WHILE x[r] = 0 DO + x[r] := m; r := Base*r; d[m] := r DIV i; r := r MOD i; m := m+1 + END ; + WriteInt(i, 5); WriteChar(9); WriteChar(46); j := 0; + WHILE j < x[r] DO WriteChar(d[j] + 48); j := j+1 END ; + WriteChar(32); (*blank*) + WHILE j < m DO WriteChar(d[j] + 48); j := j+1 END ; + WriteLn; i := i+1 + END + END + END Fractions; + + PROCEDURE Powers*; + CONST N = 32; M = 11; (*M ~ N*log2*) + VAR i, k, n, exp: INTEGER; + c, r, t: INTEGER; + d: ARRAY M OF INTEGER; + f: ARRAY N OF INTEGER; + BEGIN OpenInput; + IF ~eot() THEN + ReadInt(n); d[0] := 1; k := 1; exp := 1; + WHILE exp < n DO + (*compute d = 2^exp*) + c := 0; (*carry*) i := 0; + WHILE i < k DO + t := 2*d[i] + c; + IF t < 10 THEN d[i] := t; c := 0 ELSE d[i] := t - 10; c := 1 END ; + i := i+1 + END ; + IF c = 1 THEN d[k] := 1; k := k+1 END ; + (*write d*) i := M; + WHILE i > k DO i := i-1; WriteChar(32) (*blank*) END ; + WHILE i > 0 DO i := i-1; WriteChar(d[i] + 48) END ; + WriteInt(exp, M); + (*compute f = 2^-exp*) + WriteChar(9);; WriteChar(46); r := 0; i := 1; + WHILE i < exp DO + r := 10*r + f[i]; f[i] := r DIV 2; r := r MOD 2; + WriteChar(f[i] + 48); i := i+1 + END ; + f[exp] := 5; WriteChar(53); (*5*) WriteLn; exp := exp + 1 + END + END + END Powers; + +END TestOberon0.