Skip to content

Instantly share code, notes, and snippets.

@eterps

eterps/io.mod

Created May 28, 2019 20:00
Show Gist options
  • Save eterps/9ba52f44ed1741ed5d7ad5910147148f to your computer and use it in GitHub Desktop.
Save eterps/9ba52f44ed1741ed5d7ad5910147148f to your computer and use it in GitHub Desktop.
Download ZIP
Raw
io.mod
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.
Raw
osg.mod
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.
Raw
osp.mod
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 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.
Raw
oss.mod
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.
Raw
risc.mod
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.
Raw
test_oberon0.mod
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.
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment