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