diff --git a/src/test/confidence/lola/LSB.Mod b/src/test/confidence/lola/LSB.Mod index 7bebf6d4..2b97d65a 100755 --- a/src/test/confidence/lola/LSB.Mod +++ b/src/test/confidence/lola/LSB.Mod @@ -1,52 +1,52 @@ -MODULE LSB; (*Lola System Compiler Base LSBX, 26.9.2015*) - IMPORT Texts, Oberon; - - CONST - bit* = 0; array* = 1; unit* = 2; (*type forms*) - - (*tags in output*) const* = 1; typ* = 2; var* = 3; lit* = 4; sel* = 7; range* = 8; cons* = 9; - repl* = 10; not* = 11; and* = 12; mul* = 13; div* = 14; or* = 15; xor* = 16; add* = 17; sub* = 18; - eql* = 20; neq* = 21; lss* = 22; geq* = 23; leq* = 24; gtr* = 25; - then* = 30; else* = 31; ts* = 32; next* = 33; - - TYPE - Item* = POINTER TO ItemDesc; - Object* = POINTER TO ObjDesc; - Type* = POINTER TO TypeDesc; - ArrayType* = POINTER TO ArrayTypeDesc; - UnitType* = POINTER TO UnitTypeDesc; - - ItemDesc* = RECORD - tag*: INTEGER; - type*: Type; - val*, size*: LONGINT; - a*, b*: Item - END ; - - ObjDesc* = RECORD (ItemDesc) - next*: Object; - name*: ARRAY 32 OF CHAR; - marked*: BOOLEAN - END ; - - TypeDesc* = RECORD len*, size*: LONGINT; typobj*: Object END ; - ArrayTypeDesc* = RECORD (TypeDesc) eltyp*: Type END ; - UnitTypeDesc* = RECORD (TypeDesc) firstobj*: Object END ; - - VAR root*, top*: Object; - bitType*, integer*, string*: Type; - byteType*, wordType*: ArrayType; - modname*: ARRAY 32 OF CHAR; - - PROCEDURE Register*(name: ARRAY OF CHAR; list: Object); - BEGIN (*modname := name*) COPY(name, modname); top := list - END Register; - -BEGIN NEW(bitType); bitType.len := 0; bitType.size := 1; NEW(integer); NEW(string); - NEW(byteType); byteType.len := 8; byteType.size := 8; byteType.eltyp := bitType; - NEW(wordType); wordType.len := 32; wordType.size := 32; wordType.eltyp := bitType; - NEW(root); root.tag := typ; root.name := "WORD"; root.type := wordType; root.next := NIL; - NEW(top); top.tag := typ; top.name := "BYTE"; top.type := byteType; top.next := root; root := top; - NEW(top); top.tag := typ; top.name := "BIT"; top.type := bitType; top.next := root; root := top -END LSB. - +MODULE LSB; (*Lola System Compiler Base LSBX, 26.9.2015*) + IMPORT Texts, Oberon; + + CONST + bit* = 0; array* = 1; unit* = 2; (*type forms*) + + (*tags in output*) const* = 1; typ* = 2; var* = 3; lit* = 4; sel* = 7; range* = 8; cons* = 9; + repl* = 10; not* = 11; and* = 12; mul* = 13; div* = 14; or* = 15; xor* = 16; add* = 17; sub* = 18; + eql* = 20; neq* = 21; lss* = 22; geq* = 23; leq* = 24; gtr* = 25; + then* = 30; else* = 31; ts* = 32; next* = 33; + + TYPE + Item* = POINTER TO ItemDesc; + Object* = POINTER TO ObjDesc; + Type* = POINTER TO TypeDesc; + ArrayType* = POINTER TO ArrayTypeDesc; + UnitType* = POINTER TO UnitTypeDesc; + + ItemDesc* = RECORD + tag*: INTEGER; + type*: Type; + val*, size*: LONGINT; + a*, b*: Item + END ; + + ObjDesc* = RECORD (ItemDesc) + next*: Object; + name*: ARRAY 32 OF CHAR; + marked*: BOOLEAN + END ; + + TypeDesc* = RECORD len*, size*: LONGINT; typobj*: Object END ; + ArrayTypeDesc* = RECORD (TypeDesc) eltyp*: Type END ; + UnitTypeDesc* = RECORD (TypeDesc) firstobj*: Object END ; + + VAR root*, top*: Object; + bitType*, integer*, string*: Type; + byteType*, wordType*: ArrayType; + modname*: ARRAY 32 OF CHAR; + + PROCEDURE Register*(name: ARRAY OF CHAR; list: Object); + BEGIN (*modname := name*) COPY(name, modname); top := list + END Register; + +BEGIN NEW(bitType); bitType.len := 0; bitType.size := 1; NEW(integer); NEW(string); + NEW(byteType); byteType.len := 8; byteType.size := 8; byteType.eltyp := bitType; + NEW(wordType); wordType.len := 32; wordType.size := 32; wordType.eltyp := bitType; + NEW(root); root.tag := typ; root.name := "WORD"; root.type := wordType; root.next := NIL; + NEW(top); top.tag := typ; top.name := "BYTE"; top.type := byteType; top.next := root; root := top; + NEW(top); top.tag := typ; top.name := "BIT"; top.type := bitType; top.next := root; root := top +END LSB. + diff --git a/src/test/confidence/lola/LSC.Mod b/src/test/confidence/lola/LSC.Mod index 4488d47f..7efad856 100755 --- a/src/test/confidence/lola/LSC.Mod +++ b/src/test/confidence/lola/LSC.Mod @@ -1,536 +1,536 @@ -MODULE LSC; (*Lola System Compiler, NW 8.1.95 / 26.9.2015 for RISC (LSCX)*) - IMPORT Texts, Oberon, LSB, LSS; - - VAR sym: INTEGER; - err: BOOLEAN; (*used at end of Unit*) - top, bot, undef: LSB.Object; - factor: PROCEDURE (VAR x: LSB.Item); (*to avoid forward references*) - expression: PROCEDURE (VAR x: LSB.Item); - Unit: PROCEDURE (VAR locals: LSB.Object); - W: Texts.Writer; - - PROCEDURE Err(n: INTEGER); - BEGIN LSS.Mark("type error"); Texts.WriteInt(W, n, 4); - Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) - END Err; - - PROCEDURE Log(m: LONGINT): LONGINT; - VAR n: LONGINT; - BEGIN n := 1; - WHILE m > 1 DO m := m DIV 2; INC(n) END ; - RETURN n - END Log; - - PROCEDURE New(tag: INTEGER; a, b: LSB.Item): LSB.Item; - VAR z: LSB.Item; - BEGIN NEW(z); z.tag := tag; z.a := a; z.b := b; z.val := b.val; RETURN z - END New; - - PROCEDURE NewObj(class: INTEGER): LSB.Object; (*insert at end, before BIT*) - VAR new, x: LSB.Object; - BEGIN x := top; - WHILE (x.next # bot) & (x.next.name # LSS.id) DO x := x.next END ; - IF x.next = bot THEN - NEW(new); new.name := LSS.id; new.tag := class; new.next := bot; x.next := new - ELSE LSS.Mark("mult def"); new := x - END ; - RETURN new - END NewObj; - - PROCEDURE ThisObj(id: LSS.Ident): LSB.Object; (*find object with name = identifier last read*) - VAR x: LSB.Object; - BEGIN x := top.next; - WHILE (x # NIL) & (x.name # id) DO x := x.next END ; - IF x = NIL THEN LSS.Mark("undef"); x := undef END ; - RETURN x - END ThisObj; - - PROCEDURE CheckTypes(x, y, z: LSB.Item); (*z.type = result type*) - VAR xtyp, ytyp: LSB.Type; - BEGIN xtyp := x.type; ytyp := y.type; z.type := xtyp; z.size := x.size; z.val := x.val; - IF xtyp = LSB.bitType THEN z.type := xtyp; - IF ytyp = LSB.integer THEN (* b + 0 *) - IF y.val >= 2 THEN Err(20); LSS.Mark("only 0 or 1") END - ELSIF ytyp = LSB.string THEN (* b + {...} *) Err(21) - ELSIF ytyp # LSB.bitType THEN Err(22) - END - ELSIF xtyp IS LSB.ArrayType THEN - IF xtyp(LSB.ArrayType).eltyp = LSB.bitType THEN - IF (ytyp IS LSB.ArrayType) & (xtyp(LSB.ArrayType).eltyp = LSB.bitType) THEN - IF xtyp.size # ytyp.size THEN Err(33) END (* x + y *) - ELSIF ytyp = LSB.integer THEN (* w + 5 *) - IF xtyp.size < Log(y.val) THEN Err(30) END - ELSIF ytyp = LSB.string THEN (*x + {...} *) - IF xtyp.size # y.size THEN Err(31) END - ELSIF ytyp # LSB.bitType THEN Err(34) - END - ELSIF (ytyp IS LSB.ArrayType) & (xtyp(LSB.ArrayType).eltyp = ytyp(LSB.ArrayType).eltyp) THEN - IF (xtyp.size # ytyp.size) THEN Err(40) END - ELSE Err(41) - END - ELSIF xtyp = LSB.string THEN - IF ytyp = LSB.bitType THEN (* {...} + b *) Err(12) - ELSIF (ytyp IS LSB.ArrayType) & (ytyp(LSB.ArrayType).eltyp = LSB.bitType) THEN (* {...} + w *) - IF x.size # ytyp.size THEN Err(13) END - ELSIF ytyp = LSB.integer THEN (* {...} + 5*) - IF x.size < Log(y.val) THEN Err(10) END - ELSIF ytyp = LSB.string THEN (* {...} + {...} *) - IF x.size # y.size THEN Err(11) END ; - ELSE Err(14) - END - ELSIF xtyp = LSB.integer THEN - IF (ytyp IS LSB.ArrayType) & (ytyp(LSB.ArrayType).eltyp = LSB.bitType) THEN (* 5 + w *) - IF Log(x.val) > ytyp.size THEN Err(3); LSS.Mark("const too large") END - ELSIF ytyp = LSB.bitType THEN (* 5 + b *) - IF x.val >= 2 THEN Err(2) END - ELSIF ytyp = LSB.integer THEN (* 5 + 5 *) - ELSIF ytyp = LSB.string THEN (* 5 + {...} *) - IF Log(x.val) > y.size THEN Err(12) END - ELSE Err(4) - END - END - END CheckTypes; - - PROCEDURE selector(VAR x: LSB.Item); - VAR y, z: LSB.Item; obj: LSB.Object; - eltyp: LSB.Type; len, kind: LONGINT; - BEGIN - WHILE (sym = LSS.lbrak) OR (sym = LSS.period) DO - IF sym = LSS.lbrak THEN - eltyp := x.type(LSB.ArrayType).eltyp; LSS.Get(sym); expression(y); - IF sym = LSS.colon THEN (*range*) - LSS.Get(sym); expression(z); - IF (y.tag = LSB.lit) & (z.tag = LSB.lit) THEN - len := y.val - z.val + 1; y := New(LSB.range, y, z); x := New(LSB.sel, x, y); x.type := LSB.string; x.size := len - END - ELSE kind := x.val; x := New(LSB.sel, x, y); x.type := eltyp; x.val := kind - END ; - IF sym = LSS.rbrak THEN LSS.Get(sym) ELSE LSS.Mark("rbrak ?") END - ELSE (*sym = LSS.period*) LSS.Get(sym); factor(y); - IF (y.tag = LSB.lit) & (y.val >= x.type.len) THEN LSS.Mark("too large") END ; - eltyp := x.type(LSB.ArrayType).eltyp; kind := x.val; x := New(LSB.sel, x, y); x.type := eltyp; x.val := kind - END - END - END selector; - - PROCEDURE elem(VAR x: LSB.Item; VAR len: LONGINT); - VAR y, z: LSB.Item; m, n: LONGINT; - BEGIN expression(x); - IF (x.type = LSB.integer) OR (x.type = LSB.string) THEN m := x.size ELSE m := x.type.size END ; - IF sym = LSS.repl THEN - LSS.Get(sym); - IF sym = LSS.integer THEN - NEW(y); y.tag := LSB.lit; n := LSS.val; y.val := n; y.type := LSB.integer; LSS.Get(sym); - x := New(LSB.repl, x, y) - END - ELSE n := 1 - END ; - len := m*n - END elem; - - PROCEDURE constructor(VAR x: LSB.Item); - VAR y: LSB.Item; n, len: LONGINT; - BEGIN elem(x, len); - WHILE sym = LSS.comma DO - LSS.Get(sym); elem(y, n); INC(len, n); x := New(LSB.cons, x, y); x.val := len - END ; - x.size := len; x.type := LSB.string; - IF sym = LSS.rbrace THEN LSS.Get(sym) ELSE LSS.Mark("rbrace ?") END - END constructor; - - PROCEDURE factor0(VAR x: LSB.Item); - VAR obj: LSB.Object; y, z: LSB.Item; - n, len: LONGINT; t: LSB.ArrayType; - BEGIN - IF sym = LSS.ident THEN - x := ThisObj(LSS.id); LSS.Get(sym); - IF x.tag = LSB.var THEN selector(x) - ELSIF x.tag = LSB.const THEN n := x.b.val; NEW(x); x.tag := LSB.lit; x.val := n; x.type := LSB.integer - ELSE LSS.Mark("bad factor") - END - ELSIF sym = LSS.lparen THEN - LSS.Get(sym); expression(x); - IF sym = LSS.rparen THEN LSS.Get(sym) ELSE LSS.Mark("rparen ?") END - ELSIF sym = LSS.integer THEN - NEW(x); x.tag := LSB.lit; x.val := LSS.val; x.type := LSB.integer; LSS.Get(sym); - IF sym = LSS.apo THEN LSS.Get(sym); - IF sym = LSS.integer THEN - len := LSS.val; LSS.Get(sym); - IF len < Log(x.val) THEN LSS.Mark("value too large") END - ELSE LSS.Mark("integer ?"); len := 0 - END ; - x.size := len - ELSE len := 0 - END ; - x.size := len - ELSIF sym = LSS.not THEN - LSS.Get(sym); factor(x); y := New(LSB.not, NIL, x); y.type := x.type; y.size := x.size; x := y - ELSIF sym = LSS.lbrace THEN LSS.Get(sym); constructor(x) - ELSE LSS.Mark("bad factor") - END - END factor0; - - PROCEDURE term(VAR x: LSB.Item); - VAR y, z: LSB.Item; op: INTEGER; - BEGIN factor(x); - WHILE (sym >= LSS.times) & (sym <= LSS.and) DO - IF sym = LSS.and THEN op := LSB.and - ELSIF sym = LSS.times THEN op := LSB.mul - ELSIF sym = LSS.div THEN op := LSB.div - END ; - LSS.Get(sym); factor(y); z := New(op, x, y); CheckTypes(x, y, z); x := z - END - END term; - - PROCEDURE SimpleExpression(VAR x: LSB.Item); - VAR y, z: LSB.Item; op: INTEGER; - BEGIN - IF sym = LSS.minus THEN LSS.Get(sym); term(y); - IF y.tag = LSB.lit THEN x := y; x.val := -y.val - ELSE x := New(LSB.sub, NIL, y); x.type := y.type; x.size := y.size - END - ELSIF sym = LSS.plus THEN LSS.Get(sym); term(x); - ELSE term(x) - END ; - WHILE (sym >= LSS.plus) & (sym <= LSS.xor) DO - IF sym = LSS.or THEN op := LSB.or - ELSIF sym = LSS.xor THEN op := LSB.xor - ELSIF sym = LSS.plus THEN op := LSB.add - ELSIF sym = LSS.minus THEN op := LSB.sub - END ; - LSS.Get(sym); term(y); z := New(op, x, y); CheckTypes(x, y, z); x := z - END - END SimpleExpression; - - PROCEDURE UncondExpression(VAR x: LSB.Item); - VAR y, z: LSB.Item; rel: INTEGER; - BEGIN SimpleExpression(x); - IF (sym >= LSS.eql) & (sym <= LSS.geq) THEN - IF sym = LSS.eql THEN rel := LSB.eql - ELSIF sym = LSS.neq THEN rel := LSB.neq - ELSIF sym = LSS.lss THEN rel := LSB.lss - ELSIF sym = LSS.geq THEN rel := LSB.geq - ELSIF sym = LSS.leq THEN rel := LSB.leq - ELSE rel := LSB.gtr - END ; - LSS.Get(sym); SimpleExpression(y); z := New(rel, x, y); CheckTypes(x, y, z); z.type := LSB.bitType; x := z - END - END UncondExpression; - - PROCEDURE expression0(VAR x: LSB.Item); - VAR y, z, w: LSB.Item; - BEGIN UncondExpression(x); - IF sym = LSS.then THEN - IF x.type # LSB.bitType THEN LSS.Mark("Boolean?") END ; - LSS.Get(sym); expression(y); - IF sym = LSS.colon THEN - LSS.Get(sym); expression(z); w := New(LSB.else, y, z); CheckTypes(y, z, w); - x := New(LSB.then, x, w); x.type := w.type; x.size := w.size - ELSE LSS.Mark("colon ?") - END - END - END expression0; - - PROCEDURE CheckAssign(x, y: LSB.Item); - VAR xtyp, ytyp: LSB.Type; - BEGIN xtyp := x.type; ytyp := y.type; - IF xtyp # ytyp THEN - IF xtyp = LSB.bitType THEN - IF (ytyp # LSB.integer) OR (y.val >= 2) THEN Err(70); END - ELSIF xtyp IS LSB.ArrayType THEN - IF xtyp(LSB.ArrayType).eltyp = LSB.bitType THEN - IF (ytyp IS LSB.ArrayType) & (xtyp(LSB.ArrayType).eltyp = LSB.bitType) THEN (*w := w*) - IF xtyp.size # ytyp.size THEN Err(71) END (* x + y *) - ELSIF ytyp = LSB.integer THEN (* w := 5 *) - IF xtyp.size < Log(y.val) THEN Err(72) END - ELSIF ytyp = LSB.string THEN (* w := {...} *) - IF xtyp.size # y.size THEN Err(73) END - ELSE Err(74) - END - ELSE Err(74) - END - END - END - END CheckAssign; - - PROCEDURE Param(fpar: LSB.Object; VAR apar: LSB.Item); - VAR y, z: LSB.Item; - BEGIN expression(y); apar := New(LSB.next, NIL, y); CheckAssign(fpar, y); - IF fpar.val IN {3, 4} THEN (*OUT or INOUT parameter*) - IF ~(y.tag IN {3, 7}) THEN (*actual param is expression?*) LSS.Mark("bad actual param") - ELSIF y.b = NIL THEN y.b := undef - END - END - END Param; - - PROCEDURE Statement; - VAR w, x, y, z, apar, npar: LSB.Item; - unit: LSB.UnitType; fpar: LSB.Object; - BEGIN - IF sym < LSS.ident THEN LSS.Mark("bad factor"); - REPEAT LSS.Get(sym) UNTIL sym >= LSS.ident - END ; - IF sym = LSS.ident THEN - x := ThisObj(LSS.id); z := x; LSS.Get(sym); selector(z); - IF sym = LSS.becomes THEN LSS.Get(sym); - IF x.val >= 5 THEN LSS.Mark("assignment to read-only") END ; - IF (x.b # NIL) & ~(x.type IS LSB.ArrayType) THEN LSS.Mark("mult assign") END ; - expression(y); CheckAssign(z, y); x.b := y; (*tricky*) - IF z # x THEN x.a := z.b; x.val := 1 (*overwriting clk field x.a *) END - ELSIF sym = LSS.lparen THEN LSS.Get(sym); (*unit instantiation*) - IF x.type IS LSB.UnitType THEN - unit := x.type(LSB.UnitType); fpar := unit.firstobj; - IF sym # LSS.rparen THEN - Param(fpar, apar); x.b := apar; fpar := fpar.next; - WHILE sym # LSS.rparen DO - IF sym = LSS.comma THEN LSS.Get(sym) END ; - Param(fpar, npar); - IF fpar.tag >= 3 THEN fpar := fpar.next; apar.a := npar; apar := npar - ELSE LSS.Mark("too many params") - END - END ; - IF fpar.val >= 3 THEN LSS.Mark("too few params") END - END ; - IF sym = LSS.rparen THEN LSS.Get(sym) ELSE LSS.Mark("rparen ?") END - ELSE LSS.Mark("not a module") - END - ELSE LSS.Mark("bad statement") - END - ELSIF sym = LSS.ts THEN (*tri-state*) LSS.Get(sym); - IF sym = LSS.lparen THEN LSS.Get(sym) ELSE LSS.Mark("( missing") END ; - IF sym = LSS.ident THEN - x := ThisObj(LSS.id); x.b := undef; (*INOUT parameter*) - IF x.val # 5 THEN LSS.Mark("not INOUT") END ; - LSS.Get(sym); - IF sym = LSS.comma THEN LSS.Get(sym) END ; - IF sym = LSS.ident THEN y := ThisObj(LSS.id); CheckAssign(x, y); y.b := undef END ; (*output from gate*) - LSS.Get(sym); - IF sym = LSS.comma THEN LSS.Get(sym) END ; - expression(z); - IF (z.tag = LSB.lit) & (z.val <= 1) THEN z.type := LSB.bitType END ; - CheckAssign(x, z); LSS.Get(sym); - IF sym = LSS.comma THEN LSS.Get(sym) END ; - expression(w); (*control*) - IF w.type # LSB.bitType THEN CheckAssign(x, w) END ; - w := New(LSB.next, z, w); x.b := New(LSB.ts, y, w); - IF sym = LSS.rparen THEN LSS.Get(sym) ELSE LSS.Mark(") missing") END - END - END - END Statement; - - PROCEDURE StatSequence; - BEGIN Statement; - WHILE sym <= LSS.semicolon DO - IF sym < LSS.semicolon THEN LSS.Mark("semicolon missing?") END ; - WHILE sym = LSS.semicolon DO LSS.Get(sym) END ; - Statement - END ; - IF sym = LSS.end THEN LSS.Get(sym) ELSE LSS.Mark("END ?") END - END StatSequence; - - (*---------------------------------------------------*) - - (* for variables and registers,, obj.val has the meaning - 0 register - 1 register with imlicit clock "clk" - 2 variable - 3 output parameter - 4 output parameter with register - 5 inout parameter - 6 input parameter *) - - PROCEDURE ConstDeclaration; - VAR obj: LSB.Object; - BEGIN - IF sym = LSS.ident THEN - obj := NewObj(LSB.const); LSS.Get(sym); - IF (sym = LSS.becomes) OR (sym = LSS.eql) THEN LSS.Get(sym) ELSE LSS.Mark(":= ?") END ; - expression(obj.b); obj.type := LSB.integer; - IF sym = LSS.semicolon THEN LSS.Get(sym) ELSE LSS.Mark("semicolon ?") END - ELSE LSS.Mark("ident ?") - END - END ConstDeclaration; - - PROCEDURE Type0(VAR type: LSB.Type); - VAR obj: LSB.Object; len, size: LONGINT; - eltyp: LSB.Type; arrtyp: LSB.ArrayType; - BEGIN len := 1; - IF sym = LSS.lbrak THEN (*array*) LSS.Get(sym); - IF sym = LSS.integer THEN len := LSS.val; LSS.Get(sym) - ELSIF sym = LSS.ident THEN obj := ThisObj(LSS.id); len := obj.val - END ; - IF sym = LSS.rbrak THEN LSS.Get(sym) ELSE LSS.Mark("rbrak ?") END ; - Type0(eltyp); NEW(arrtyp); size := eltyp.size * len; - arrtyp.eltyp := eltyp; type := arrtyp; type.len := len; type.size := size - ELSIF sym = LSS.ident THEN - obj := ThisObj(LSS.id); LSS.Get(sym); - IF obj # NIL THEN - IF obj.tag = LSB.typ THEN type := obj.type ELSE LSS.Mark("not a type"); type := LSB.bitType END - ELSE LSS.Mark("type ?") - END - ELSE type := LSB.bitType; LSS.Mark("ident or [") - END - END Type0; - - PROCEDURE TypeDeclaration; - VAR obj: LSB.Object; utyp: LSB.UnitType; - BEGIN - IF sym = LSS.ident THEN - obj := NewObj(LSB.typ); LSS.Get(sym); - IF (sym = LSS.becomes) OR (sym = LSS.eql) THEN LSS.Get(sym) ELSE LSS.Mark(":= ?") END ; - IF sym = LSS.module THEN - LSS.Get(sym); NEW(utyp); Unit(utyp.firstobj); obj.type := utyp; obj.type.typobj := obj - ELSE Type0(obj.type) - END ; - IF sym = LSS.semicolon THEN LSS.Get(sym) ELSE LSS.Mark("semicolon ?") END - ELSE LSS.Mark("ident ?") - END - END TypeDeclaration; - - PROCEDURE VarList(kind: INTEGER; clk: LSB.Item); - VAR first, new, obj: LSB.Object; type: LSB.Type; - BEGIN obj := NIL; - WHILE sym = LSS.ident DO - new := NewObj(LSB.var); new.name := LSS.id; new.val := kind; first := new; LSS.Get(sym); - IF sym = LSS.comma THEN LSS.Get(sym) ELSIF sym = LSS.ident THEN LSS.Mark("comma missing") END ; - WHILE sym = LSS.ident DO - new := NewObj(LSB.var); new.name := LSS.id; new.val := kind; LSS.Get(sym); - IF sym = LSS.comma THEN LSS.Get(sym) ELSIF sym = LSS.ident THEN LSS.Mark("comma missing") END - END ; - IF sym = LSS.colon THEN - LSS.Get(sym); Type0(type); obj := first; - WHILE obj # bot DO obj.type := type; obj.a := clk; obj := obj.next END - ELSE LSS.Mark("colon ?") - END ; - IF sym = LSS.semicolon THEN LSS.Get(sym) - ELSIF sym # LSS.rparen THEN LSS.Mark("semicolon or rparen missing") - END - END - END VarList; - - PROCEDURE ParamList; - VAR kind: INTEGER; - BEGIN - IF sym = LSS.in THEN LSS.Get(sym); kind := 6 - ELSIF sym = LSS.out THEN LSS.Get(sym); - IF sym = LSS.reg THEN LSS.Get(sym); kind := 4 ELSE kind := 3 END - ELSIF sym = LSS.inout THEN LSS.Get(sym); kind := 5 - END ; - VarList(kind, NIL) - END ParamList; - - PROCEDURE Traverse(x: LSB.Item); - BEGIN - IF x # NIL THEN - IF x IS LSB.Object THEN - IF (x.tag = LSB.var) & (x.val >= 2) THEN (*not reg*) - IF x(LSB.Object).marked THEN (*loop*) - Texts.WriteString(W, x(LSB.Object).name); Texts.Write(W, " "); err := TRUE - ELSIF x.b # NIL THEN x(LSB.Object).marked := TRUE; Traverse(x.b) - END ; - x(LSB.Object).marked := FALSE - END - ELSE Traverse(x.a); Traverse(x.b) - END - END - END Traverse; - - PROCEDURE Unit0(VAR locals: LSB.Object); - VAR obj, oldtop: LSB.Object; kind: INTEGER; clock: LSB.Item; - BEGIN oldtop := top.next; top.next := LSB.root; (*top is dummy*) - IF sym = LSS.lparen THEN LSS.Get(sym) ELSE LSS.Mark("lparen ?") END ; - WHILE (sym = LSS.in) OR (sym = LSS.out) OR (sym = LSS.inout) DO ParamList END ; - IF sym = LSS.rparen THEN LSS.Get(sym) ELSE LSS.Mark("rparen ?") END ; - IF sym = LSS.xor (*arrow*) THEN LSS.Get(sym); locals := top.next - ELSE - IF sym = LSS.semicolon THEN LSS.Get(sym) ELSE LSS.Mark("semicolon ?") END ; - IF sym = LSS.const THEN LSS.Get(sym); - WHILE sym = LSS.ident DO ConstDeclaration END - END ; - IF sym = LSS.type THEN LSS.Get(sym); - WHILE sym = LSS.ident DO TypeDeclaration END - END ; - WHILE (sym = LSS.var) OR (sym = LSS.reg) DO - IF sym = LSS.var THEN LSS.Get(sym); - WHILE sym = LSS.ident DO VarList(2, NIL) END - ELSE (*reg*) kind := 0; LSS.Get(sym); - IF sym = LSS.lparen THEN (*clock*) - LSS.Get(sym); expression(clock); - IF clock.type # LSB.bitType THEN LSS.Mark("clock must be bitType") END ; - IF (clock IS LSB.Object) & (clock(LSB.Object).name = "clk") THEN kind := 1; clock := NIL END ; - IF sym = LSS.rparen THEN LSS.Get(sym) ELSE LSS.Mark("rparen ?") END - ELSE LSS.Mark("lparen expected"); clock := undef - END ; - WHILE sym = LSS.ident DO VarList(kind, clock) END - END - END ; - locals := top.next; - IF sym = LSS.begin THEN LSS.Get(sym); StatSequence END ; - obj := locals; err := FALSE; (*find unassigned variables*) - WHILE obj # LSB.root DO - IF (obj.tag = LSB.var) & (obj.val < 5) THEN - IF (obj.b = NIL) & (obj.val < 4) THEN Texts.WriteString(W, obj.name); Texts.Write(W, " "); err := TRUE - ELSIF obj.b = undef THEN obj.b := NIL - END - END ; - obj := obj.next - END ; - IF err THEN Texts.WriteString(W, " unassigned"); Texts.WriteLn(W) - ELSE obj := locals; err := FALSE; (*find combinatorial loops*) - WHILE obj # LSB.root DO - IF obj.tag = LSB.var THEN obj.marked := TRUE; Traverse(obj.b); obj.marked := FALSE END ; - obj := obj.next - END ; - IF err THEN Texts.WriteString(W, "in loop"); Texts.WriteLn(W) END - END - END ; - IF err THEN Texts.Append(Oberon.Log, W.buf) END ; - top.next := oldtop - END Unit0; - - PROCEDURE Module(T: Texts.Text; pos: LONGINT); - VAR root: LSB.Object; modname: ARRAY 32 OF CHAR; - BEGIN Texts.WriteString(W, "compiling Lola: "); - bot := LSB.root; top.next := bot; LSS.Init(T, pos); LSS.Get(sym); - IF sym = LSS.module THEN - LSS.Get(sym); - IF sym = LSS.ident THEN - modname := LSS.id; Texts.WriteString(W, LSS.id); LSS.Get(sym); - Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); - ELSE LSS.Mark("ident ?") - END ; - Unit(root); - IF sym = LSS.ident THEN LSS.Get(sym); - IF LSS.id # modname THEN LSS.Mark("no match") END - END ; - IF sym # LSS.period THEN LSS.Mark("period ?") END ; - IF ~LSS.error THEN LSB.Register(modname, root) - ELSE Texts.WriteString(W, "compilation failed"); Texts.WriteLn(W); LSB.Register("", LSB.root) - END - ELSE LSS.Mark("module ?") - END ; - Texts.Append(Oberon.Log, W.buf) - END Module; - - PROCEDURE Compile*; - VAR beg, end, time: LONGINT; - S: Texts.Scanner; T: Texts.Text; - BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S); - IF S.class = Texts.Char THEN - IF S.c = "*" THEN - ELSIF S.c = "@" THEN - Oberon.GetSelection(T, beg, end, time); - IF time >= 0 THEN Module(T, beg) END - END - ELSIF S.class = Texts.Name THEN - NEW(T); Texts.Open(T, S.s); Module(T, 0) - END ; - Oberon.Par.pos := Texts.Pos(S); - Texts.Append(Oberon.Log, W.buf) - END Compile; - -BEGIN Texts.OpenWriter(W); - Texts.WriteString(W, "Lola compiler; NW 6.7.2015"); Texts.WriteLn(W); - NEW(top); bot := LSB.root; NEW(undef); undef.tag := 2; undef.type := LSB.bitType; - Unit := Unit0; factor := factor0; expression := expression0; -END LSC. +MODULE LSC; (*Lola System Compiler, NW 8.1.95 / 26.9.2015 for RISC (LSCX)*) + IMPORT Texts, Oberon, LSB, LSS; + + VAR sym: INTEGER; + err: BOOLEAN; (*used at end of Unit*) + top, bot, undef: LSB.Object; + factor: PROCEDURE (VAR x: LSB.Item); (*to avoid forward references*) + expression: PROCEDURE (VAR x: LSB.Item); + Unit: PROCEDURE (VAR locals: LSB.Object); + W: Texts.Writer; + + PROCEDURE Err(n: INTEGER); + BEGIN LSS.Mark("type error"); Texts.WriteInt(W, n, 4); + Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) + END Err; + + PROCEDURE Log(m: LONGINT): LONGINT; + VAR n: LONGINT; + BEGIN n := 1; + WHILE m > 1 DO m := m DIV 2; INC(n) END ; + RETURN n + END Log; + + PROCEDURE New(tag: INTEGER; a, b: LSB.Item): LSB.Item; + VAR z: LSB.Item; + BEGIN NEW(z); z.tag := tag; z.a := a; z.b := b; z.val := b.val; RETURN z + END New; + + PROCEDURE NewObj(class: INTEGER): LSB.Object; (*insert at end, before BIT*) + VAR new, x: LSB.Object; + BEGIN x := top; + WHILE (x.next # bot) & (x.next.name # LSS.id) DO x := x.next END ; + IF x.next = bot THEN + NEW(new); new.name := LSS.id; new.tag := class; new.next := bot; x.next := new + ELSE LSS.Mark("mult def"); new := x + END ; + RETURN new + END NewObj; + + PROCEDURE ThisObj(id: LSS.Ident): LSB.Object; (*find object with name = identifier last read*) + VAR x: LSB.Object; + BEGIN x := top.next; + WHILE (x # NIL) & (x.name # id) DO x := x.next END ; + IF x = NIL THEN LSS.Mark("undef"); x := undef END ; + RETURN x + END ThisObj; + + PROCEDURE CheckTypes(x, y, z: LSB.Item); (*z.type = result type*) + VAR xtyp, ytyp: LSB.Type; + BEGIN xtyp := x.type; ytyp := y.type; z.type := xtyp; z.size := x.size; z.val := x.val; + IF xtyp = LSB.bitType THEN z.type := xtyp; + IF ytyp = LSB.integer THEN (* b + 0 *) + IF y.val >= 2 THEN Err(20); LSS.Mark("only 0 or 1") END + ELSIF ytyp = LSB.string THEN (* b + {...} *) Err(21) + ELSIF ytyp # LSB.bitType THEN Err(22) + END + ELSIF xtyp IS LSB.ArrayType THEN + IF xtyp(LSB.ArrayType).eltyp = LSB.bitType THEN + IF (ytyp IS LSB.ArrayType) & (xtyp(LSB.ArrayType).eltyp = LSB.bitType) THEN + IF xtyp.size # ytyp.size THEN Err(33) END (* x + y *) + ELSIF ytyp = LSB.integer THEN (* w + 5 *) + IF xtyp.size < Log(y.val) THEN Err(30) END + ELSIF ytyp = LSB.string THEN (*x + {...} *) + IF xtyp.size # y.size THEN Err(31) END + ELSIF ytyp # LSB.bitType THEN Err(34) + END + ELSIF (ytyp IS LSB.ArrayType) & (xtyp(LSB.ArrayType).eltyp = ytyp(LSB.ArrayType).eltyp) THEN + IF (xtyp.size # ytyp.size) THEN Err(40) END + ELSE Err(41) + END + ELSIF xtyp = LSB.string THEN + IF ytyp = LSB.bitType THEN (* {...} + b *) Err(12) + ELSIF (ytyp IS LSB.ArrayType) & (ytyp(LSB.ArrayType).eltyp = LSB.bitType) THEN (* {...} + w *) + IF x.size # ytyp.size THEN Err(13) END + ELSIF ytyp = LSB.integer THEN (* {...} + 5*) + IF x.size < Log(y.val) THEN Err(10) END + ELSIF ytyp = LSB.string THEN (* {...} + {...} *) + IF x.size # y.size THEN Err(11) END ; + ELSE Err(14) + END + ELSIF xtyp = LSB.integer THEN + IF (ytyp IS LSB.ArrayType) & (ytyp(LSB.ArrayType).eltyp = LSB.bitType) THEN (* 5 + w *) + IF Log(x.val) > ytyp.size THEN Err(3); LSS.Mark("const too large") END + ELSIF ytyp = LSB.bitType THEN (* 5 + b *) + IF x.val >= 2 THEN Err(2) END + ELSIF ytyp = LSB.integer THEN (* 5 + 5 *) + ELSIF ytyp = LSB.string THEN (* 5 + {...} *) + IF Log(x.val) > y.size THEN Err(12) END + ELSE Err(4) + END + END + END CheckTypes; + + PROCEDURE selector(VAR x: LSB.Item); + VAR y, z: LSB.Item; obj: LSB.Object; + eltyp: LSB.Type; len, kind: LONGINT; + BEGIN + WHILE (sym = LSS.lbrak) OR (sym = LSS.period) DO + IF sym = LSS.lbrak THEN + eltyp := x.type(LSB.ArrayType).eltyp; LSS.Get(sym); expression(y); + IF sym = LSS.colon THEN (*range*) + LSS.Get(sym); expression(z); + IF (y.tag = LSB.lit) & (z.tag = LSB.lit) THEN + len := y.val - z.val + 1; y := New(LSB.range, y, z); x := New(LSB.sel, x, y); x.type := LSB.string; x.size := len + END + ELSE kind := x.val; x := New(LSB.sel, x, y); x.type := eltyp; x.val := kind + END ; + IF sym = LSS.rbrak THEN LSS.Get(sym) ELSE LSS.Mark("rbrak ?") END + ELSE (*sym = LSS.period*) LSS.Get(sym); factor(y); + IF (y.tag = LSB.lit) & (y.val >= x.type.len) THEN LSS.Mark("too large") END ; + eltyp := x.type(LSB.ArrayType).eltyp; kind := x.val; x := New(LSB.sel, x, y); x.type := eltyp; x.val := kind + END + END + END selector; + + PROCEDURE elem(VAR x: LSB.Item; VAR len: LONGINT); + VAR y, z: LSB.Item; m, n: LONGINT; + BEGIN expression(x); + IF (x.type = LSB.integer) OR (x.type = LSB.string) THEN m := x.size ELSE m := x.type.size END ; + IF sym = LSS.repl THEN + LSS.Get(sym); + IF sym = LSS.integer THEN + NEW(y); y.tag := LSB.lit; n := LSS.val; y.val := n; y.type := LSB.integer; LSS.Get(sym); + x := New(LSB.repl, x, y) + END + ELSE n := 1 + END ; + len := m*n + END elem; + + PROCEDURE constructor(VAR x: LSB.Item); + VAR y: LSB.Item; n, len: LONGINT; + BEGIN elem(x, len); + WHILE sym = LSS.comma DO + LSS.Get(sym); elem(y, n); INC(len, n); x := New(LSB.cons, x, y); x.val := len + END ; + x.size := len; x.type := LSB.string; + IF sym = LSS.rbrace THEN LSS.Get(sym) ELSE LSS.Mark("rbrace ?") END + END constructor; + + PROCEDURE factor0(VAR x: LSB.Item); + VAR obj: LSB.Object; y, z: LSB.Item; + n, len: LONGINT; t: LSB.ArrayType; + BEGIN + IF sym = LSS.ident THEN + x := ThisObj(LSS.id); LSS.Get(sym); + IF x.tag = LSB.var THEN selector(x) + ELSIF x.tag = LSB.const THEN n := x.b.val; NEW(x); x.tag := LSB.lit; x.val := n; x.type := LSB.integer + ELSE LSS.Mark("bad factor") + END + ELSIF sym = LSS.lparen THEN + LSS.Get(sym); expression(x); + IF sym = LSS.rparen THEN LSS.Get(sym) ELSE LSS.Mark("rparen ?") END + ELSIF sym = LSS.integer THEN + NEW(x); x.tag := LSB.lit; x.val := LSS.val; x.type := LSB.integer; LSS.Get(sym); + IF sym = LSS.apo THEN LSS.Get(sym); + IF sym = LSS.integer THEN + len := LSS.val; LSS.Get(sym); + IF len < Log(x.val) THEN LSS.Mark("value too large") END + ELSE LSS.Mark("integer ?"); len := 0 + END ; + x.size := len + ELSE len := 0 + END ; + x.size := len + ELSIF sym = LSS.not THEN + LSS.Get(sym); factor(x); y := New(LSB.not, NIL, x); y.type := x.type; y.size := x.size; x := y + ELSIF sym = LSS.lbrace THEN LSS.Get(sym); constructor(x) + ELSE LSS.Mark("bad factor") + END + END factor0; + + PROCEDURE term(VAR x: LSB.Item); + VAR y, z: LSB.Item; op: INTEGER; + BEGIN factor(x); + WHILE (sym >= LSS.times) & (sym <= LSS.and) DO + IF sym = LSS.and THEN op := LSB.and + ELSIF sym = LSS.times THEN op := LSB.mul + ELSIF sym = LSS.div THEN op := LSB.div + END ; + LSS.Get(sym); factor(y); z := New(op, x, y); CheckTypes(x, y, z); x := z + END + END term; + + PROCEDURE SimpleExpression(VAR x: LSB.Item); + VAR y, z: LSB.Item; op: INTEGER; + BEGIN + IF sym = LSS.minus THEN LSS.Get(sym); term(y); + IF y.tag = LSB.lit THEN x := y; x.val := -y.val + ELSE x := New(LSB.sub, NIL, y); x.type := y.type; x.size := y.size + END + ELSIF sym = LSS.plus THEN LSS.Get(sym); term(x); + ELSE term(x) + END ; + WHILE (sym >= LSS.plus) & (sym <= LSS.xor) DO + IF sym = LSS.or THEN op := LSB.or + ELSIF sym = LSS.xor THEN op := LSB.xor + ELSIF sym = LSS.plus THEN op := LSB.add + ELSIF sym = LSS.minus THEN op := LSB.sub + END ; + LSS.Get(sym); term(y); z := New(op, x, y); CheckTypes(x, y, z); x := z + END + END SimpleExpression; + + PROCEDURE UncondExpression(VAR x: LSB.Item); + VAR y, z: LSB.Item; rel: INTEGER; + BEGIN SimpleExpression(x); + IF (sym >= LSS.eql) & (sym <= LSS.geq) THEN + IF sym = LSS.eql THEN rel := LSB.eql + ELSIF sym = LSS.neq THEN rel := LSB.neq + ELSIF sym = LSS.lss THEN rel := LSB.lss + ELSIF sym = LSS.geq THEN rel := LSB.geq + ELSIF sym = LSS.leq THEN rel := LSB.leq + ELSE rel := LSB.gtr + END ; + LSS.Get(sym); SimpleExpression(y); z := New(rel, x, y); CheckTypes(x, y, z); z.type := LSB.bitType; x := z + END + END UncondExpression; + + PROCEDURE expression0(VAR x: LSB.Item); + VAR y, z, w: LSB.Item; + BEGIN UncondExpression(x); + IF sym = LSS.then THEN + IF x.type # LSB.bitType THEN LSS.Mark("Boolean?") END ; + LSS.Get(sym); expression(y); + IF sym = LSS.colon THEN + LSS.Get(sym); expression(z); w := New(LSB.else, y, z); CheckTypes(y, z, w); + x := New(LSB.then, x, w); x.type := w.type; x.size := w.size + ELSE LSS.Mark("colon ?") + END + END + END expression0; + + PROCEDURE CheckAssign(x, y: LSB.Item); + VAR xtyp, ytyp: LSB.Type; + BEGIN xtyp := x.type; ytyp := y.type; + IF xtyp # ytyp THEN + IF xtyp = LSB.bitType THEN + IF (ytyp # LSB.integer) OR (y.val >= 2) THEN Err(70); END + ELSIF xtyp IS LSB.ArrayType THEN + IF xtyp(LSB.ArrayType).eltyp = LSB.bitType THEN + IF (ytyp IS LSB.ArrayType) & (xtyp(LSB.ArrayType).eltyp = LSB.bitType) THEN (*w := w*) + IF xtyp.size # ytyp.size THEN Err(71) END (* x + y *) + ELSIF ytyp = LSB.integer THEN (* w := 5 *) + IF xtyp.size < Log(y.val) THEN Err(72) END + ELSIF ytyp = LSB.string THEN (* w := {...} *) + IF xtyp.size # y.size THEN Err(73) END + ELSE Err(74) + END + ELSE Err(74) + END + END + END + END CheckAssign; + + PROCEDURE Param(fpar: LSB.Object; VAR apar: LSB.Item); + VAR y, z: LSB.Item; + BEGIN expression(y); apar := New(LSB.next, NIL, y); CheckAssign(fpar, y); + IF fpar.val IN {3, 4} THEN (*OUT or INOUT parameter*) + IF ~(y.tag IN {3, 7}) THEN (*actual param is expression?*) LSS.Mark("bad actual param") + ELSIF y.b = NIL THEN y.b := undef + END + END + END Param; + + PROCEDURE Statement; + VAR w, x, y, z, apar, npar: LSB.Item; + unit: LSB.UnitType; fpar: LSB.Object; + BEGIN + IF sym < LSS.ident THEN LSS.Mark("bad factor"); + REPEAT LSS.Get(sym) UNTIL sym >= LSS.ident + END ; + IF sym = LSS.ident THEN + x := ThisObj(LSS.id); z := x; LSS.Get(sym); selector(z); + IF sym = LSS.becomes THEN LSS.Get(sym); + IF x.val >= 5 THEN LSS.Mark("assignment to read-only") END ; + IF (x.b # NIL) & ~(x.type IS LSB.ArrayType) THEN LSS.Mark("mult assign") END ; + expression(y); CheckAssign(z, y); x.b := y; (*tricky*) + IF z # x THEN x.a := z.b; x.val := 1 (*overwriting clk field x.a *) END + ELSIF sym = LSS.lparen THEN LSS.Get(sym); (*unit instantiation*) + IF x.type IS LSB.UnitType THEN + unit := x.type(LSB.UnitType); fpar := unit.firstobj; + IF sym # LSS.rparen THEN + Param(fpar, apar); x.b := apar; fpar := fpar.next; + WHILE sym # LSS.rparen DO + IF sym = LSS.comma THEN LSS.Get(sym) END ; + Param(fpar, npar); + IF fpar.tag >= 3 THEN fpar := fpar.next; apar.a := npar; apar := npar + ELSE LSS.Mark("too many params") + END + END ; + IF fpar.val >= 3 THEN LSS.Mark("too few params") END + END ; + IF sym = LSS.rparen THEN LSS.Get(sym) ELSE LSS.Mark("rparen ?") END + ELSE LSS.Mark("not a module") + END + ELSE LSS.Mark("bad statement") + END + ELSIF sym = LSS.ts THEN (*tri-state*) LSS.Get(sym); + IF sym = LSS.lparen THEN LSS.Get(sym) ELSE LSS.Mark("( missing") END ; + IF sym = LSS.ident THEN + x := ThisObj(LSS.id); x.b := undef; (*INOUT parameter*) + IF x.val # 5 THEN LSS.Mark("not INOUT") END ; + LSS.Get(sym); + IF sym = LSS.comma THEN LSS.Get(sym) END ; + IF sym = LSS.ident THEN y := ThisObj(LSS.id); CheckAssign(x, y); y.b := undef END ; (*output from gate*) + LSS.Get(sym); + IF sym = LSS.comma THEN LSS.Get(sym) END ; + expression(z); + IF (z.tag = LSB.lit) & (z.val <= 1) THEN z.type := LSB.bitType END ; + CheckAssign(x, z); LSS.Get(sym); + IF sym = LSS.comma THEN LSS.Get(sym) END ; + expression(w); (*control*) + IF w.type # LSB.bitType THEN CheckAssign(x, w) END ; + w := New(LSB.next, z, w); x.b := New(LSB.ts, y, w); + IF sym = LSS.rparen THEN LSS.Get(sym) ELSE LSS.Mark(") missing") END + END + END + END Statement; + + PROCEDURE StatSequence; + BEGIN Statement; + WHILE sym <= LSS.semicolon DO + IF sym < LSS.semicolon THEN LSS.Mark("semicolon missing?") END ; + WHILE sym = LSS.semicolon DO LSS.Get(sym) END ; + Statement + END ; + IF sym = LSS.end THEN LSS.Get(sym) ELSE LSS.Mark("END ?") END + END StatSequence; + + (*---------------------------------------------------*) + + (* for variables and registers,, obj.val has the meaning + 0 register + 1 register with imlicit clock "clk" + 2 variable + 3 output parameter + 4 output parameter with register + 5 inout parameter + 6 input parameter *) + + PROCEDURE ConstDeclaration; + VAR obj: LSB.Object; + BEGIN + IF sym = LSS.ident THEN + obj := NewObj(LSB.const); LSS.Get(sym); + IF (sym = LSS.becomes) OR (sym = LSS.eql) THEN LSS.Get(sym) ELSE LSS.Mark(":= ?") END ; + expression(obj.b); obj.type := LSB.integer; + IF sym = LSS.semicolon THEN LSS.Get(sym) ELSE LSS.Mark("semicolon ?") END + ELSE LSS.Mark("ident ?") + END + END ConstDeclaration; + + PROCEDURE Type0(VAR type: LSB.Type); + VAR obj: LSB.Object; len, size: LONGINT; + eltyp: LSB.Type; arrtyp: LSB.ArrayType; + BEGIN len := 1; + IF sym = LSS.lbrak THEN (*array*) LSS.Get(sym); + IF sym = LSS.integer THEN len := LSS.val; LSS.Get(sym) + ELSIF sym = LSS.ident THEN obj := ThisObj(LSS.id); len := obj.val + END ; + IF sym = LSS.rbrak THEN LSS.Get(sym) ELSE LSS.Mark("rbrak ?") END ; + Type0(eltyp); NEW(arrtyp); size := eltyp.size * len; + arrtyp.eltyp := eltyp; type := arrtyp; type.len := len; type.size := size + ELSIF sym = LSS.ident THEN + obj := ThisObj(LSS.id); LSS.Get(sym); + IF obj # NIL THEN + IF obj.tag = LSB.typ THEN type := obj.type ELSE LSS.Mark("not a type"); type := LSB.bitType END + ELSE LSS.Mark("type ?") + END + ELSE type := LSB.bitType; LSS.Mark("ident or [") + END + END Type0; + + PROCEDURE TypeDeclaration; + VAR obj: LSB.Object; utyp: LSB.UnitType; + BEGIN + IF sym = LSS.ident THEN + obj := NewObj(LSB.typ); LSS.Get(sym); + IF (sym = LSS.becomes) OR (sym = LSS.eql) THEN LSS.Get(sym) ELSE LSS.Mark(":= ?") END ; + IF sym = LSS.module THEN + LSS.Get(sym); NEW(utyp); Unit(utyp.firstobj); obj.type := utyp; obj.type.typobj := obj + ELSE Type0(obj.type) + END ; + IF sym = LSS.semicolon THEN LSS.Get(sym) ELSE LSS.Mark("semicolon ?") END + ELSE LSS.Mark("ident ?") + END + END TypeDeclaration; + + PROCEDURE VarList(kind: INTEGER; clk: LSB.Item); + VAR first, new, obj: LSB.Object; type: LSB.Type; + BEGIN obj := NIL; + WHILE sym = LSS.ident DO + new := NewObj(LSB.var); new.name := LSS.id; new.val := kind; first := new; LSS.Get(sym); + IF sym = LSS.comma THEN LSS.Get(sym) ELSIF sym = LSS.ident THEN LSS.Mark("comma missing") END ; + WHILE sym = LSS.ident DO + new := NewObj(LSB.var); new.name := LSS.id; new.val := kind; LSS.Get(sym); + IF sym = LSS.comma THEN LSS.Get(sym) ELSIF sym = LSS.ident THEN LSS.Mark("comma missing") END + END ; + IF sym = LSS.colon THEN + LSS.Get(sym); Type0(type); obj := first; + WHILE obj # bot DO obj.type := type; obj.a := clk; obj := obj.next END + ELSE LSS.Mark("colon ?") + END ; + IF sym = LSS.semicolon THEN LSS.Get(sym) + ELSIF sym # LSS.rparen THEN LSS.Mark("semicolon or rparen missing") + END + END + END VarList; + + PROCEDURE ParamList; + VAR kind: INTEGER; + BEGIN + IF sym = LSS.in THEN LSS.Get(sym); kind := 6 + ELSIF sym = LSS.out THEN LSS.Get(sym); + IF sym = LSS.reg THEN LSS.Get(sym); kind := 4 ELSE kind := 3 END + ELSIF sym = LSS.inout THEN LSS.Get(sym); kind := 5 + END ; + VarList(kind, NIL) + END ParamList; + + PROCEDURE Traverse(x: LSB.Item); + BEGIN + IF x # NIL THEN + IF x IS LSB.Object THEN + IF (x.tag = LSB.var) & (x.val >= 2) THEN (*not reg*) + IF x(LSB.Object).marked THEN (*loop*) + Texts.WriteString(W, x(LSB.Object).name); Texts.Write(W, " "); err := TRUE + ELSIF x.b # NIL THEN x(LSB.Object).marked := TRUE; Traverse(x.b) + END ; + x(LSB.Object).marked := FALSE + END + ELSE Traverse(x.a); Traverse(x.b) + END + END + END Traverse; + + PROCEDURE Unit0(VAR locals: LSB.Object); + VAR obj, oldtop: LSB.Object; kind: INTEGER; clock: LSB.Item; + BEGIN oldtop := top.next; top.next := LSB.root; (*top is dummy*) + IF sym = LSS.lparen THEN LSS.Get(sym) ELSE LSS.Mark("lparen ?") END ; + WHILE (sym = LSS.in) OR (sym = LSS.out) OR (sym = LSS.inout) DO ParamList END ; + IF sym = LSS.rparen THEN LSS.Get(sym) ELSE LSS.Mark("rparen ?") END ; + IF sym = LSS.xor (*arrow*) THEN LSS.Get(sym); locals := top.next + ELSE + IF sym = LSS.semicolon THEN LSS.Get(sym) ELSE LSS.Mark("semicolon ?") END ; + IF sym = LSS.const THEN LSS.Get(sym); + WHILE sym = LSS.ident DO ConstDeclaration END + END ; + IF sym = LSS.type THEN LSS.Get(sym); + WHILE sym = LSS.ident DO TypeDeclaration END + END ; + WHILE (sym = LSS.var) OR (sym = LSS.reg) DO + IF sym = LSS.var THEN LSS.Get(sym); + WHILE sym = LSS.ident DO VarList(2, NIL) END + ELSE (*reg*) kind := 0; LSS.Get(sym); + IF sym = LSS.lparen THEN (*clock*) + LSS.Get(sym); expression(clock); + IF clock.type # LSB.bitType THEN LSS.Mark("clock must be bitType") END ; + IF (clock IS LSB.Object) & (clock(LSB.Object).name = "clk") THEN kind := 1; clock := NIL END ; + IF sym = LSS.rparen THEN LSS.Get(sym) ELSE LSS.Mark("rparen ?") END + ELSE LSS.Mark("lparen expected"); clock := undef + END ; + WHILE sym = LSS.ident DO VarList(kind, clock) END + END + END ; + locals := top.next; + IF sym = LSS.begin THEN LSS.Get(sym); StatSequence END ; + obj := locals; err := FALSE; (*find unassigned variables*) + WHILE obj # LSB.root DO + IF (obj.tag = LSB.var) & (obj.val < 5) THEN + IF (obj.b = NIL) & (obj.val < 4) THEN Texts.WriteString(W, obj.name); Texts.Write(W, " "); err := TRUE + ELSIF obj.b = undef THEN obj.b := NIL + END + END ; + obj := obj.next + END ; + IF err THEN Texts.WriteString(W, " unassigned"); Texts.WriteLn(W) + ELSE obj := locals; err := FALSE; (*find combinatorial loops*) + WHILE obj # LSB.root DO + IF obj.tag = LSB.var THEN obj.marked := TRUE; Traverse(obj.b); obj.marked := FALSE END ; + obj := obj.next + END ; + IF err THEN Texts.WriteString(W, "in loop"); Texts.WriteLn(W) END + END + END ; + IF err THEN Texts.Append(Oberon.Log, W.buf) END ; + top.next := oldtop + END Unit0; + + PROCEDURE Module(T: Texts.Text; pos: LONGINT); + VAR root: LSB.Object; modname: ARRAY 32 OF CHAR; + BEGIN Texts.WriteString(W, "compiling Lola: "); + bot := LSB.root; top.next := bot; LSS.Init(T, pos); LSS.Get(sym); + IF sym = LSS.module THEN + LSS.Get(sym); + IF sym = LSS.ident THEN + modname := LSS.id; Texts.WriteString(W, LSS.id); LSS.Get(sym); + Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); + ELSE LSS.Mark("ident ?") + END ; + Unit(root); + IF sym = LSS.ident THEN LSS.Get(sym); + IF LSS.id # modname THEN LSS.Mark("no match") END + END ; + IF sym # LSS.period THEN LSS.Mark("period ?") END ; + IF ~LSS.error THEN LSB.Register(modname, root) + ELSE Texts.WriteString(W, "compilation failed"); Texts.WriteLn(W); LSB.Register("", LSB.root) + END + ELSE LSS.Mark("module ?") + END ; + Texts.Append(Oberon.Log, W.buf) + END Module; + + PROCEDURE Compile*; + VAR beg, end, time: LONGINT; + S: Texts.Scanner; T: Texts.Text; + BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S); + IF S.class = Texts.Char THEN + IF S.c = "*" THEN + ELSIF S.c = "@" THEN + Oberon.GetSelection(T, beg, end, time); + IF time >= 0 THEN Module(T, beg) END + END + ELSIF S.class = Texts.Name THEN + NEW(T); Texts.Open(T, S.s); Module(T, 0) + END ; + Oberon.Par.pos := Texts.Pos(S); + Texts.Append(Oberon.Log, W.buf) + END Compile; + +BEGIN Texts.OpenWriter(W); + Texts.WriteString(W, "Lola compiler; NW 6.7.2015"); Texts.WriteLn(W); + NEW(top); bot := LSB.root; NEW(undef); undef.tag := 2; undef.type := LSB.bitType; + Unit := Unit0; factor := factor0; expression := expression0; +END LSC. diff --git a/src/test/confidence/lola/LSS.Mod b/src/test/confidence/lola/LSS.Mod index a7e4cc46..809c4e8b 100755 --- a/src/test/confidence/lola/LSS.Mod +++ b/src/test/confidence/lola/LSS.Mod @@ -1,165 +1,165 @@ -MODULE LSS; (* NW 16.10.93 / 1.9.2015*) - IMPORT Texts, Oberon; - - CONST IdLen* = 32; NofKeys = 11; - (*symbols*) null = 0; - arrow* = 1; times* = 2; div* = 3; and* = 4; plus* = 5; minus* = 6; or* = 7; xor* = 8; not* = 9; - eql* = 10; neq* = 11; lss* = 12; leq* = 13; gtr* = 14; geq* = 15; - at* = 16; apo* = 17; period* = 18; comma* = 19; colon* = 20; rparen* = 21; rbrak* = 22; rbrace* = 23; - then* = 24; lparen* = 26; lbrak* = 27; lbrace* = 28; repl* = 29; becomes* = 30; - ident* = 31; integer* = 32; ts* = 33; semicolon* = 40; end* = 41; - const* = 51; type* = 52; reg* = 53; var* = 54; out* = 55; inout* = 56; in* = 57; - begin* = 58; module* = 59; eof = 60; - - TYPE Ident* = ARRAY IdLen OF CHAR; - - VAR val*: LONGINT; - id*: Ident; - error*: BOOLEAN; - - ch: CHAR; - errpos: LONGINT; - R: Texts.Reader; - W: Texts.Writer; - key: ARRAY NofKeys OF Ident; - symno: ARRAY NofKeys OF INTEGER; - - PROCEDURE Mark*(msg: ARRAY OF CHAR); - VAR p: LONGINT; - BEGIN p := Texts.Pos(R); - IF p > errpos+2 THEN - Texts.WriteString(W, " pos "); Texts.WriteInt(W, p, 1); - Texts.WriteString(W, " err: "); 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: 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"); - IF ch = "'" THEN - IF i < IdLen THEN id[i] := ch; INC(i) END ; - Texts.Read(R, ch) - END ; - IF i = IdLen THEN Mark("ident too long"); id[IdLen-1] := 0X - ELSE id[i] := 0X - END ; - i := 0; - WHILE (i < NofKeys) & (id # key[i]) DO INC(i) END ; - IF i < NofKeys THEN sym := symno[i] ELSE sym := ident END - END identifier; - - PROCEDURE Number(VAR sym: INTEGER); - VAR i, k, h, n, d: LONGINT; - hex: BOOLEAN; - dig: ARRAY 16 OF LONGINT; - BEGIN sym := integer; i := 0; k := 0; n := 0; hex := FALSE; - REPEAT - IF n < 16 THEN d := ORD(ch)-30H; - IF d >= 10 THEN hex := TRUE ; d := d - 7 END ; - dig[n] := d; INC(n) - ELSE Mark("too many digits"); n := 0 - END ; - Texts.Read(R, ch) - UNTIL (ch < "0") OR (ch > "9") & (ch < "A") OR (ch > "F"); - IF ch = "H" THEN (*hex*) - REPEAT h := dig[i]; k := k*10H + h; INC(i) (*no overflow check*) - UNTIL i = n; - Texts.Read(R, ch) - ELSE - IF hex THEN Mark("illegal hex digit") END ; - REPEAT k := k*10 + dig[i]; INC(i) UNTIL i = n - END ; - val := k - END Number; - - PROCEDURE comment; - BEGIN Texts.Read(R, ch); - REPEAT - WHILE ~R.eot & (ch # "*") DO - IF ch = "(" THEN Texts.Read(R, ch); - IF ch = "*" THEN comment END - ELSE Texts.Read(R, ch) - END - END ; - WHILE ch = "*" DO Texts.Read(R, ch) END - UNTIL (ch = ")") OR R.eot; - IF ~R.eot THEN Texts.Read(R, ch) ELSE Mark("comment not terminated") END - END comment; - - PROCEDURE Get*(VAR sym: INTEGER); - BEGIN - REPEAT - WHILE ~R.eot & (ch <= " ") DO Texts.Read(R, ch) END; - IF R.eot THEN sym := eof - ELSIF ch < "A" THEN - IF ch < "0" THEN - IF ch = "!" THEN Texts.Read(R, ch); sym := repl - ELSIF ch = "#" THEN Texts.Read(R, ch); sym := neq - ELSIF ch = "$" THEN Texts.Read(R, ch); sym := null - ELSIF ch = "&" THEN Texts.Read(R, ch); sym := and - ELSIF ch = "'" THEN Texts.Read(R, ch); sym := apo - 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); - IF ch = ">" THEN Texts.Read(R, ch); sym := then ELSE sym := minus END - ELSIF ch = "." THEN Texts.Read(R, ch); sym := period - ELSIF ch = "/" THEN Texts.Read(R, ch); sym := div - ELSE sym := null - END - ELSIF ch <= "9" 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 - ELSIF ch = "?" THEN Texts.Read(R, ch); sym := then - ELSIF ch = "@" THEN Texts.Read(R, ch); sym := at - ELSE sym := null - END - ELSIF ch <= "Z" THEN identifier(sym) - ELSIF ch < "a" THEN - IF ch = "[" THEN Texts.Read(R, ch); sym := lbrak - ELSIF ch = "]" THEN Texts.Read(R, ch); sym := rbrak - ELSIF ch = "^" THEN Texts.Read(R, ch); sym := xor - ELSE sym := null - END - ELSIF ch <= "z" THEN identifier(sym) - ELSIF ch <= "{" THEN Texts.Read(R, ch); sym := lbrace - ELSIF ch <= "|" THEN Texts.Read(R, ch); sym := or - ELSIF ch <= "}" THEN Texts.Read(R, ch); sym := rbrace - ELSIF ch <= "~" THEN Texts.Read(R, ch); sym := not - ELSE sym := null - 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; - -BEGIN Texts.OpenWriter(W); - key[ 0] := "BEGIN"; symno[0] := begin; - key[ 1] := "CONST"; symno[1] := const; - key[ 2] := "END"; symno[2] := end; - key[3] := "IN"; symno[3] := in; - key[4] := "INOUT"; symno[4] := inout; - key[5] := "MODULE"; symno[5] := module; - key[6] := "OUT"; symno[6] := out; - key[7] := "REG"; symno[7] := reg; - key[8] := "TYPE"; symno[8] := type; - key[9] := "VAR"; symno[9] := var; - key[10] := "TS"; symno[10] := ts -END LSS. +MODULE LSS; (* NW 16.10.93 / 1.9.2015*) + IMPORT Texts, Oberon; + + CONST IdLen* = 32; NofKeys = 11; + (*symbols*) null = 0; + arrow* = 1; times* = 2; div* = 3; and* = 4; plus* = 5; minus* = 6; or* = 7; xor* = 8; not* = 9; + eql* = 10; neq* = 11; lss* = 12; leq* = 13; gtr* = 14; geq* = 15; + at* = 16; apo* = 17; period* = 18; comma* = 19; colon* = 20; rparen* = 21; rbrak* = 22; rbrace* = 23; + then* = 24; lparen* = 26; lbrak* = 27; lbrace* = 28; repl* = 29; becomes* = 30; + ident* = 31; integer* = 32; ts* = 33; semicolon* = 40; end* = 41; + const* = 51; type* = 52; reg* = 53; var* = 54; out* = 55; inout* = 56; in* = 57; + begin* = 58; module* = 59; eof = 60; + + TYPE Ident* = ARRAY IdLen OF CHAR; + + VAR val*: LONGINT; + id*: Ident; + error*: BOOLEAN; + + ch: CHAR; + errpos: LONGINT; + R: Texts.Reader; + W: Texts.Writer; + key: ARRAY NofKeys OF Ident; + symno: ARRAY NofKeys OF INTEGER; + + PROCEDURE Mark*(msg: ARRAY OF CHAR); + VAR p: LONGINT; + BEGIN p := Texts.Pos(R); + IF p > errpos+2 THEN + Texts.WriteString(W, " pos "); Texts.WriteInt(W, p, 1); + Texts.WriteString(W, " err: "); 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: 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"); + IF ch = "'" THEN + IF i < IdLen THEN id[i] := ch; INC(i) END ; + Texts.Read(R, ch) + END ; + IF i = IdLen THEN Mark("ident too long"); id[IdLen-1] := 0X + ELSE id[i] := 0X + END ; + i := 0; + WHILE (i < NofKeys) & (id # key[i]) DO INC(i) END ; + IF i < NofKeys THEN sym := symno[i] ELSE sym := ident END + END identifier; + + PROCEDURE Number(VAR sym: INTEGER); + VAR i, k, h, n, d: LONGINT; + hex: BOOLEAN; + dig: ARRAY 16 OF LONGINT; + BEGIN sym := integer; i := 0; k := 0; n := 0; hex := FALSE; + REPEAT + IF n < 16 THEN d := ORD(ch)-30H; + IF d >= 10 THEN hex := TRUE ; d := d - 7 END ; + dig[n] := d; INC(n) + ELSE Mark("too many digits"); n := 0 + END ; + Texts.Read(R, ch) + UNTIL (ch < "0") OR (ch > "9") & (ch < "A") OR (ch > "F"); + IF ch = "H" THEN (*hex*) + REPEAT h := dig[i]; k := k*10H + h; INC(i) (*no overflow check*) + UNTIL i = n; + Texts.Read(R, ch) + ELSE + IF hex THEN Mark("illegal hex digit") END ; + REPEAT k := k*10 + dig[i]; INC(i) UNTIL i = n + END ; + val := k + END Number; + + PROCEDURE comment; + BEGIN Texts.Read(R, ch); + REPEAT + WHILE ~R.eot & (ch # "*") DO + IF ch = "(" THEN Texts.Read(R, ch); + IF ch = "*" THEN comment END + ELSE Texts.Read(R, ch) + END + END ; + WHILE ch = "*" DO Texts.Read(R, ch) END + UNTIL (ch = ")") OR R.eot; + IF ~R.eot THEN Texts.Read(R, ch) ELSE Mark("comment not terminated") END + END comment; + + PROCEDURE Get*(VAR sym: INTEGER); + BEGIN + REPEAT + WHILE ~R.eot & (ch <= " ") DO Texts.Read(R, ch) END; + IF R.eot THEN sym := eof + ELSIF ch < "A" THEN + IF ch < "0" THEN + IF ch = "!" THEN Texts.Read(R, ch); sym := repl + ELSIF ch = "#" THEN Texts.Read(R, ch); sym := neq + ELSIF ch = "$" THEN Texts.Read(R, ch); sym := null + ELSIF ch = "&" THEN Texts.Read(R, ch); sym := and + ELSIF ch = "'" THEN Texts.Read(R, ch); sym := apo + 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); + IF ch = ">" THEN Texts.Read(R, ch); sym := then ELSE sym := minus END + ELSIF ch = "." THEN Texts.Read(R, ch); sym := period + ELSIF ch = "/" THEN Texts.Read(R, ch); sym := div + ELSE sym := null + END + ELSIF ch <= "9" 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 + ELSIF ch = "?" THEN Texts.Read(R, ch); sym := then + ELSIF ch = "@" THEN Texts.Read(R, ch); sym := at + ELSE sym := null + END + ELSIF ch <= "Z" THEN identifier(sym) + ELSIF ch < "a" THEN + IF ch = "[" THEN Texts.Read(R, ch); sym := lbrak + ELSIF ch = "]" THEN Texts.Read(R, ch); sym := rbrak + ELSIF ch = "^" THEN Texts.Read(R, ch); sym := xor + ELSE sym := null + END + ELSIF ch <= "z" THEN identifier(sym) + ELSIF ch <= "{" THEN Texts.Read(R, ch); sym := lbrace + ELSIF ch <= "|" THEN Texts.Read(R, ch); sym := or + ELSIF ch <= "}" THEN Texts.Read(R, ch); sym := rbrace + ELSIF ch <= "~" THEN Texts.Read(R, ch); sym := not + ELSE sym := null + 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; + +BEGIN Texts.OpenWriter(W); + key[ 0] := "BEGIN"; symno[0] := begin; + key[ 1] := "CONST"; symno[1] := const; + key[ 2] := "END"; symno[2] := end; + key[3] := "IN"; symno[3] := in; + key[4] := "INOUT"; symno[4] := inout; + key[5] := "MODULE"; symno[5] := module; + key[6] := "OUT"; symno[6] := out; + key[7] := "REG"; symno[7] := reg; + key[8] := "TYPE"; symno[8] := type; + key[9] := "VAR"; symno[9] := var; + key[10] := "TS"; symno[10] := ts +END LSS. diff --git a/src/test/confidence/lola/LSV.Mod b/src/test/confidence/lola/LSV.Mod index 35d45295..6c87497f 100755 --- a/src/test/confidence/lola/LSV.Mod +++ b/src/test/confidence/lola/LSV.Mod @@ -1,238 +1,238 @@ -MODULE LSV; (*Lola System: display Verilog; generate txt-File; NW 31.8.2015*) - IMPORT Files, Texts, Oberon, LSB; - - VAR W: Texts.Writer; - nofgen: INTEGER; - Constructor: PROCEDURE (VAR x: LSB.Item); (*to avoid forward reference*) - F: Files.File; R: Files.Rider; - C: ARRAY 64, 6 OF CHAR; - - PROCEDURE Write(ch: CHAR); - BEGIN Files.Write(R, ch) - END Write; - - PROCEDURE WriteLn; - BEGIN Files.Write(R, 0DX); Files.Write(R, 0AX) - END WriteLn; - - PROCEDURE WriteInt(x: LONGINT); (* x >= 0 *) - VAR i: INTEGER; d: ARRAY 14 OF LONGINT; - BEGIN i := 0; - IF x < 0 THEN Files.Write(R, "-"); x := -x END ; - REPEAT d[i] := x MOD 10; x := x DIV 10; INC(i) UNTIL x = 0; - REPEAT DEC(i); Files.Write(R, CHR(d[i] + 30H)) UNTIL i = 0 - END WriteInt; - - PROCEDURE WriteHex(x: LONGINT); (*x >= 0*) - VAR i: INTEGER; d: ARRAY 8 OF LONGINT; - BEGIN i := 0; - REPEAT d[i] := x MOD 10H; x := x DIV 10H; INC(i) UNTIL (x = 0) OR (i = 8); - REPEAT DEC(i); - IF d[i] >= 10 THEN Files.Write(R, CHR(d[i] + 37H)) ELSE Files.Write(R, CHR(d[i] + 30H)) END - UNTIL i = 0 - END WriteHex; - - PROCEDURE WriteString(s: ARRAY OF CHAR); - VAR i: INTEGER; - BEGIN i := 0; - WHILE s[i] # 0X DO Files.Write(R, s[i]); INC(i) END - END WriteString; - - (* ------------------------------- *) - - PROCEDURE Type(typ: LSB.Type); - VAR obj: LSB.Object; - BEGIN - IF typ IS LSB.ArrayType THEN - IF typ(LSB.ArrayType).eltyp # LSB.bitType THEN - Write("["); WriteInt(typ.len - 1); WriteString(":0]"); Type(typ(LSB.ArrayType).eltyp) - END - ELSIF typ IS LSB.UnitType THEN (* obj := typ(LSB.UnitType).firstobj; *) - END - END Type; - - PROCEDURE BitArrLen(typ: LSB.Type); - VAR eltyp: LSB.Type; - BEGIN - IF typ IS LSB.ArrayType THEN - eltyp := typ(LSB.ArrayType).eltyp; - WHILE eltyp IS LSB.ArrayType DO typ := eltyp; eltyp := typ(LSB.ArrayType).eltyp END ; - IF eltyp = LSB.bitType THEN - Write("["); WriteInt(typ.len - 1);WriteString(":0] ") - END - END - END BitArrLen; - - PROCEDURE Expression(x: LSB.Item); - VAR z: LSB.Item; - BEGIN - IF x # NIL THEN - IF x IS LSB.Object THEN WriteString(x(LSB.Object).name) - ELSIF x.tag = LSB.cons THEN - Write("{"); Constructor(x); Write("}") - ELSE - IF x.tag = LSB.repl THEN - Write("{"); WriteInt(x.b.val); Write("{"); Expression(x.a); - Write("}"); Write("}") - ELSE - IF (x.tag >= LSB.and) & (x.tag <= LSB.gtr) THEN Write("(") END ; - Expression(x.a); - IF x.tag = LSB.sel THEN Write("["); Expression(x.b); Write("]") - ELSIF x.tag = LSB.lit THEN - IF x.size # 0 THEN WriteInt(x.size); Write("'"); Write("h"); WriteHex(x.val) - ELSE WriteInt(x.val) - END - ELSE WriteString(C[x.tag]); Expression(x.b) - END ; - IF (x.tag >= LSB.and) & (x.tag <= LSB.gtr) THEN Write(")") END - END - END - END - END Expression; - - PROCEDURE Elem(VAR x: LSB.Item); - BEGIN - IF x.tag = LSB.repl THEN - Write("{"); WriteInt(x.b.val); Write("{"); Expression(x.a); WriteString("}}") - ELSE Expression(x) - END - END Elem; - - PROCEDURE Constructor0(VAR x: LSB.Item); - BEGIN - IF x.tag = LSB.cons THEN Constructor(x.a); WriteString(", "); Elem(x.b) ELSE Elem(x) END - END Constructor0; - - PROCEDURE Declaration(obj: LSB.Object); - VAR apar: LSB.Item; typ: LSB.Type; - BEGIN typ := obj.type; - IF obj.type IS LSB.UnitType THEN WriteString("unit ") ELSE Type(obj.type) END ; - IF obj.tag = LSB.var THEN - IF obj.type IS LSB.UnitType THEN - apar := obj.a; WriteLn; Write("["); - WHILE apar # NIL DO Expression(apar.b); apar := apar.a END ; - Write("]") - END - ELSIF obj.tag = LSB.const THEN WriteString(" = "); WriteInt(obj.val) - END - END Declaration; - - PROCEDURE ObjList0(obj: LSB.Object); (*declarations*) - VAR obj1: LSB.Object; param: BOOLEAN; - BEGIN param := TRUE; - WHILE obj # LSB.root DO - IF (obj.tag = LSB.var) & ~(obj.type IS LSB.UnitType) THEN - IF obj.val <= 1 THEN WriteString("reg ") - ELSIF obj.val = 2 THEN WriteString("wire ") - ELSIF obj.val = 3 THEN WriteString("output ") - ELSIF obj.val = 4 THEN WriteString("output reg ") - ELSIF obj.val = 5 THEN WriteString("inout ") - ELSIF obj.val = 6 THEN WriteString("input ") - ELSE WriteString("??? ") - END ; - BitArrLen(obj.type); WriteString(obj.name); - obj1 := obj.next; - WHILE (obj1 # LSB.top) & (obj1.type = obj.type) & (obj1.val = obj.val) DO - WriteString(", "); obj := obj1; WriteString(obj.name); obj1 := obj.next - END ; - IF param & (obj.val >= 3) & (obj1.val < 3) THEN (*end param list*) param := FALSE; Write(")") - END ; - IF (obj.type # LSB.bitType) & (obj.type(LSB.ArrayType).eltyp # LSB.bitType) THEN Type(obj.type) END ; - IF param THEN Write(",") ELSE Write(";") END ; - WriteLn - ELSIF obj.tag = LSB.const THEN - END ; - obj := obj.next - END - END ObjList0; - - PROCEDURE ActParam(VAR x: LSB.Item; fpar: LSB.Object); - BEGIN Write("."); WriteString(fpar.name); Write("("); Expression(x); Write(")") - END ActParam; - - PROCEDURE ObjList1(obj: LSB.Object); (*assignments to variables*) - VAR apar, x: LSB.Item; fpar: LSB.Object; size: LONGINT; - BEGIN - WHILE obj # LSB.root DO - IF (obj.tag = LSB.var) OR (obj.tag = LSB.const) THEN - IF obj.type IS LSB.UnitType THEN - WriteString(obj.type.typobj.name); Write(" "); WriteString(obj.name); - apar := obj.b; fpar := obj.type(LSB.UnitType).firstobj; - Write("("); ActParam(apar.b, fpar); apar := apar.a; fpar := fpar.next; (*actual param list*) - WHILE apar # NIL DO WriteString(", "); ActParam(apar.b, fpar); apar := apar.a; fpar := fpar.next END ; - Write(")"); Write(";"); WriteLn - ELSIF (obj.b # NIL) & (obj.val = 5) THEN (*tri-state*) - size := obj.type.size; x := obj.b; - IF x.tag = LSB.ts THEN - IF obj.type = LSB.bitType THEN - WriteString("IOBUF block"); INC(nofgen); WriteInt(nofgen); WriteString(" (.IO("); WriteString(obj.name); - WriteString("), .O("); WriteString(x.a(LSB.Object).name); WriteString("), .I("); x := x.b; - IF x.a.type = LSB.bitType THEN Expression(x.a) ELSE WriteString(x.a(LSB.Object).name) END ; - WriteString("), .T("); - IF x.b.type = LSB.bitType THEN Expression(x.b) ELSE WriteString(x.b(LSB.Object).name) END ; - WriteString("));") - ELSE (*array type*) - IF nofgen = 0 THEN WriteString("genvar i;"); WriteLn END ; - INC(nofgen); WriteString("generate"); WriteLn; - WriteString("for (i = 0; i < "); WriteInt(size); WriteString("; i = i+1) begin : bufblock"); WriteInt(nofgen); WriteLn; - WriteString("IOBUF block (.IO("); WriteString(obj.name); - WriteString("[i]), .O("); WriteString(x.a(LSB.Object).name); WriteString("[i]), .I("); x := x.b; - WriteString(x.a(LSB.Object).name); WriteString("[i]), .T("); - IF x.b.type = LSB.bitType THEN Expression(x.b) ELSE WriteString(x.b(LSB.Object).name); WriteString("[i]") END ; - WriteString("));"); WriteLn; WriteString("end"); WriteLn; WriteString("endgenerate") - END ; - WriteLn - END - ELSIF (obj.b # NIL) & (obj.val >= 2) THEN - WriteString("assign "); WriteString(obj.name); - IF (obj.a # NIL) THEN Write("["); Expression(obj.a); Write("]") END ; - WriteString(" = "); Expression(obj.b); Write(";"); WriteLn - END - ELSIF obj.tag = LSB.typ THEN (*instantiation; actual parameters*) - END ; - obj := obj.next - END - END ObjList1; - - PROCEDURE ObjList2(obj: LSB.Object); (*assignments to registers*) - VAR apar: LSB.Item; kind: LONGINT; clk: LSB.Item; - BEGIN - WHILE obj # LSB.root DO - IF (obj.tag = LSB.var) & ~(obj.type IS LSB.UnitType) & (obj.val < 2) THEN - WriteString("always @ (posedge "); kind := obj.val; - IF kind = 0 THEN Expression(obj.a) - ELSE (*kind = 1*) WriteString("clk") - END ; - WriteString(") begin "); - REPEAT WriteString(obj.name); - IF (kind = 1) & (obj.a # NIL) THEN Write("["); Expression(obj.a); Write("]") END ; - WriteString(" <= "); Expression(obj.b); Write(";"); WriteLn; obj := obj.next - UNTIL (obj = LSB.top) OR (obj.val # kind); - WriteString("end"); WriteLn - ELSE obj := obj.next - END - END - END ObjList2; - - PROCEDURE List*; - VAR S: Texts.Scanner; - BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S); - IF (S.class = Texts.Name) OR (S.class = Texts.String) THEN - Texts.WriteString(W, LSB.modname); Texts.WriteString(W, " translating to "); Texts.WriteString(W, S.s); - F := Files.New(S.s); Files.Set(R, F, 0); - WriteString("`timescale 1ns / 1 ps"); WriteLn; nofgen := 0; - WriteString("module "); WriteString(LSB.modname); WriteString("( // translated from Lola"); WriteLn; - ObjList0(LSB.top); ObjList1(LSB.top); ObjList2(LSB.top); - WriteString("endmodule"); WriteLn; - Files.Register(F); Texts.WriteString(W, " done"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) - END - END List; - -BEGIN Texts.OpenWriter(W); Constructor := Constructor0; - C[LSB.const] := "CONST"; C[LSB.typ] := "TYPE"; C[LSB.var] := "VAR"; - C[LSB.lit] := "LIT"; C[LSB.sel] := "SEL"; C[LSB.range] := ":"; C[LSB.cons] := ","; - C[LSB.or] := " | "; C[LSB.xor] := " ^ "; C[LSB.and] := " & "; C[LSB.not] := "~"; - C[LSB.add] := " + "; C[LSB.sub] := " - "; C[LSB.mul] := " * "; C[LSB.div] := " / "; - C[LSB.eql] := " == "; C[LSB.neq] := " != "; C[LSB.lss] := " < "; C[LSB.geq] := " >= "; C[LSB.leq] := " <= "; C[LSB.gtr] := " > "; - C[LSB.then] := " ? "; C[LSB.else] := " : "; C[LSB.ts] := "TS"; C[LSB.next] := "--" -END LSV. +MODULE LSV; (*Lola System: display Verilog; generate txt-File; NW 31.8.2015*) + IMPORT Files, Texts, Oberon, LSB; + + VAR W: Texts.Writer; + nofgen: INTEGER; + Constructor: PROCEDURE (VAR x: LSB.Item); (*to avoid forward reference*) + F: Files.File; R: Files.Rider; + C: ARRAY 64, 6 OF CHAR; + + PROCEDURE Write(ch: CHAR); + BEGIN Files.Write(R, ch) + END Write; + + PROCEDURE WriteLn; + BEGIN Files.Write(R, 0DX); Files.Write(R, 0AX) + END WriteLn; + + PROCEDURE WriteInt(x: LONGINT); (* x >= 0 *) + VAR i: INTEGER; d: ARRAY 14 OF LONGINT; + BEGIN i := 0; + IF x < 0 THEN Files.Write(R, "-"); x := -x END ; + REPEAT d[i] := x MOD 10; x := x DIV 10; INC(i) UNTIL x = 0; + REPEAT DEC(i); Files.Write(R, CHR(d[i] + 30H)) UNTIL i = 0 + END WriteInt; + + PROCEDURE WriteHex(x: LONGINT); (*x >= 0*) + VAR i: INTEGER; d: ARRAY 8 OF LONGINT; + BEGIN i := 0; + REPEAT d[i] := x MOD 10H; x := x DIV 10H; INC(i) UNTIL (x = 0) OR (i = 8); + REPEAT DEC(i); + IF d[i] >= 10 THEN Files.Write(R, CHR(d[i] + 37H)) ELSE Files.Write(R, CHR(d[i] + 30H)) END + UNTIL i = 0 + END WriteHex; + + PROCEDURE WriteString(s: ARRAY OF CHAR); + VAR i: INTEGER; + BEGIN i := 0; + WHILE s[i] # 0X DO Files.Write(R, s[i]); INC(i) END + END WriteString; + + (* ------------------------------- *) + + PROCEDURE Type(typ: LSB.Type); + VAR obj: LSB.Object; + BEGIN + IF typ IS LSB.ArrayType THEN + IF typ(LSB.ArrayType).eltyp # LSB.bitType THEN + Write("["); WriteInt(typ.len - 1); WriteString(":0]"); Type(typ(LSB.ArrayType).eltyp) + END + ELSIF typ IS LSB.UnitType THEN (* obj := typ(LSB.UnitType).firstobj; *) + END + END Type; + + PROCEDURE BitArrLen(typ: LSB.Type); + VAR eltyp: LSB.Type; + BEGIN + IF typ IS LSB.ArrayType THEN + eltyp := typ(LSB.ArrayType).eltyp; + WHILE eltyp IS LSB.ArrayType DO typ := eltyp; eltyp := typ(LSB.ArrayType).eltyp END ; + IF eltyp = LSB.bitType THEN + Write("["); WriteInt(typ.len - 1);WriteString(":0] ") + END + END + END BitArrLen; + + PROCEDURE Expression(x: LSB.Item); + VAR z: LSB.Item; + BEGIN + IF x # NIL THEN + IF x IS LSB.Object THEN WriteString(x(LSB.Object).name) + ELSIF x.tag = LSB.cons THEN + Write("{"); Constructor(x); Write("}") + ELSE + IF x.tag = LSB.repl THEN + Write("{"); WriteInt(x.b.val); Write("{"); Expression(x.a); + Write("}"); Write("}") + ELSE + IF (x.tag >= LSB.and) & (x.tag <= LSB.gtr) THEN Write("(") END ; + Expression(x.a); + IF x.tag = LSB.sel THEN Write("["); Expression(x.b); Write("]") + ELSIF x.tag = LSB.lit THEN + IF x.size # 0 THEN WriteInt(x.size); Write("'"); Write("h"); WriteHex(x.val) + ELSE WriteInt(x.val) + END + ELSE WriteString(C[x.tag]); Expression(x.b) + END ; + IF (x.tag >= LSB.and) & (x.tag <= LSB.gtr) THEN Write(")") END + END + END + END + END Expression; + + PROCEDURE Elem(VAR x: LSB.Item); + BEGIN + IF x.tag = LSB.repl THEN + Write("{"); WriteInt(x.b.val); Write("{"); Expression(x.a); WriteString("}}") + ELSE Expression(x) + END + END Elem; + + PROCEDURE Constructor0(VAR x: LSB.Item); + BEGIN + IF x.tag = LSB.cons THEN Constructor(x.a); WriteString(", "); Elem(x.b) ELSE Elem(x) END + END Constructor0; + + PROCEDURE Declaration(obj: LSB.Object); + VAR apar: LSB.Item; typ: LSB.Type; + BEGIN typ := obj.type; + IF obj.type IS LSB.UnitType THEN WriteString("unit ") ELSE Type(obj.type) END ; + IF obj.tag = LSB.var THEN + IF obj.type IS LSB.UnitType THEN + apar := obj.a; WriteLn; Write("["); + WHILE apar # NIL DO Expression(apar.b); apar := apar.a END ; + Write("]") + END + ELSIF obj.tag = LSB.const THEN WriteString(" = "); WriteInt(obj.val) + END + END Declaration; + + PROCEDURE ObjList0(obj: LSB.Object); (*declarations*) + VAR obj1: LSB.Object; param: BOOLEAN; + BEGIN param := TRUE; + WHILE obj # LSB.root DO + IF (obj.tag = LSB.var) & ~(obj.type IS LSB.UnitType) THEN + IF obj.val <= 1 THEN WriteString("reg ") + ELSIF obj.val = 2 THEN WriteString("wire ") + ELSIF obj.val = 3 THEN WriteString("output ") + ELSIF obj.val = 4 THEN WriteString("output reg ") + ELSIF obj.val = 5 THEN WriteString("inout ") + ELSIF obj.val = 6 THEN WriteString("input ") + ELSE WriteString("??? ") + END ; + BitArrLen(obj.type); WriteString(obj.name); + obj1 := obj.next; + WHILE (obj1 # LSB.top) & (obj1.type = obj.type) & (obj1.val = obj.val) DO + WriteString(", "); obj := obj1; WriteString(obj.name); obj1 := obj.next + END ; + IF param & (obj.val >= 3) & (obj1.val < 3) THEN (*end param list*) param := FALSE; Write(")") + END ; + IF (obj.type # LSB.bitType) & (obj.type(LSB.ArrayType).eltyp # LSB.bitType) THEN Type(obj.type) END ; + IF param THEN Write(",") ELSE Write(";") END ; + WriteLn + ELSIF obj.tag = LSB.const THEN + END ; + obj := obj.next + END + END ObjList0; + + PROCEDURE ActParam(VAR x: LSB.Item; fpar: LSB.Object); + BEGIN Write("."); WriteString(fpar.name); Write("("); Expression(x); Write(")") + END ActParam; + + PROCEDURE ObjList1(obj: LSB.Object); (*assignments to variables*) + VAR apar, x: LSB.Item; fpar: LSB.Object; size: LONGINT; + BEGIN + WHILE obj # LSB.root DO + IF (obj.tag = LSB.var) OR (obj.tag = LSB.const) THEN + IF obj.type IS LSB.UnitType THEN + WriteString(obj.type.typobj.name); Write(" "); WriteString(obj.name); + apar := obj.b; fpar := obj.type(LSB.UnitType).firstobj; + Write("("); ActParam(apar.b, fpar); apar := apar.a; fpar := fpar.next; (*actual param list*) + WHILE apar # NIL DO WriteString(", "); ActParam(apar.b, fpar); apar := apar.a; fpar := fpar.next END ; + Write(")"); Write(";"); WriteLn + ELSIF (obj.b # NIL) & (obj.val = 5) THEN (*tri-state*) + size := obj.type.size; x := obj.b; + IF x.tag = LSB.ts THEN + IF obj.type = LSB.bitType THEN + WriteString("IOBUF block"); INC(nofgen); WriteInt(nofgen); WriteString(" (.IO("); WriteString(obj.name); + WriteString("), .O("); WriteString(x.a(LSB.Object).name); WriteString("), .I("); x := x.b; + IF x.a.type = LSB.bitType THEN Expression(x.a) ELSE WriteString(x.a(LSB.Object).name) END ; + WriteString("), .T("); + IF x.b.type = LSB.bitType THEN Expression(x.b) ELSE WriteString(x.b(LSB.Object).name) END ; + WriteString("));") + ELSE (*array type*) + IF nofgen = 0 THEN WriteString("genvar i;"); WriteLn END ; + INC(nofgen); WriteString("generate"); WriteLn; + WriteString("for (i = 0; i < "); WriteInt(size); WriteString("; i = i+1) begin : bufblock"); WriteInt(nofgen); WriteLn; + WriteString("IOBUF block (.IO("); WriteString(obj.name); + WriteString("[i]), .O("); WriteString(x.a(LSB.Object).name); WriteString("[i]), .I("); x := x.b; + WriteString(x.a(LSB.Object).name); WriteString("[i]), .T("); + IF x.b.type = LSB.bitType THEN Expression(x.b) ELSE WriteString(x.b(LSB.Object).name); WriteString("[i]") END ; + WriteString("));"); WriteLn; WriteString("end"); WriteLn; WriteString("endgenerate") + END ; + WriteLn + END + ELSIF (obj.b # NIL) & (obj.val >= 2) THEN + WriteString("assign "); WriteString(obj.name); + IF (obj.a # NIL) THEN Write("["); Expression(obj.a); Write("]") END ; + WriteString(" = "); Expression(obj.b); Write(";"); WriteLn + END + ELSIF obj.tag = LSB.typ THEN (*instantiation; actual parameters*) + END ; + obj := obj.next + END + END ObjList1; + + PROCEDURE ObjList2(obj: LSB.Object); (*assignments to registers*) + VAR apar: LSB.Item; kind: LONGINT; clk: LSB.Item; + BEGIN + WHILE obj # LSB.root DO + IF (obj.tag = LSB.var) & ~(obj.type IS LSB.UnitType) & (obj.val < 2) THEN + WriteString("always @ (posedge "); kind := obj.val; + IF kind = 0 THEN Expression(obj.a) + ELSE (*kind = 1*) WriteString("clk") + END ; + WriteString(") begin "); + REPEAT WriteString(obj.name); + IF (kind = 1) & (obj.a # NIL) THEN Write("["); Expression(obj.a); Write("]") END ; + WriteString(" <= "); Expression(obj.b); Write(";"); WriteLn; obj := obj.next + UNTIL (obj = LSB.top) OR (obj.val # kind); + WriteString("end"); WriteLn + ELSE obj := obj.next + END + END + END ObjList2; + + PROCEDURE List*; + VAR S: Texts.Scanner; + BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S); + IF (S.class = Texts.Name) OR (S.class = Texts.String) THEN + Texts.WriteString(W, LSB.modname); Texts.WriteString(W, " translating to "); Texts.WriteString(W, S.s); + F := Files.New(S.s); Files.Set(R, F, 0); + WriteString("`timescale 1ns / 1 ps"); WriteLn; nofgen := 0; + WriteString("module "); WriteString(LSB.modname); WriteString("( // translated from Lola"); WriteLn; + ObjList0(LSB.top); ObjList1(LSB.top); ObjList2(LSB.top); + WriteString("endmodule"); WriteLn; + Files.Register(F); Texts.WriteString(W, " done"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) + END + END List; + +BEGIN Texts.OpenWriter(W); Constructor := Constructor0; + C[LSB.const] := "CONST"; C[LSB.typ] := "TYPE"; C[LSB.var] := "VAR"; + C[LSB.lit] := "LIT"; C[LSB.sel] := "SEL"; C[LSB.range] := ":"; C[LSB.cons] := ","; + C[LSB.or] := " | "; C[LSB.xor] := " ^ "; C[LSB.and] := " & "; C[LSB.not] := "~"; + C[LSB.add] := " + "; C[LSB.sub] := " - "; C[LSB.mul] := " * "; C[LSB.div] := " / "; + C[LSB.eql] := " == "; C[LSB.neq] := " != "; C[LSB.lss] := " < "; C[LSB.geq] := " >= "; C[LSB.leq] := " <= "; C[LSB.gtr] := " > "; + C[LSB.then] := " ? "; C[LSB.else] := " : "; C[LSB.ts] := "TS"; C[LSB.next] := "--" +END LSV. diff --git a/src/test/confidence/lola/RISC5.Lola b/src/test/confidence/lola/RISC5.Lola index 3a2980a0..24af46fb 100755 --- a/src/test/confidence/lola/RISC5.Lola +++ b/src/test/confidence/lola/RISC5.Lola @@ -1,214 +1,214 @@ -MODULE RISC5 (IN clk, rst, stallX: BIT; (*NW 26.10.2015*) - IN inbus, codebus: WORD; - OUT adr: [24] BIT; - rd, wr, ben: BIT; - outbus: WORD); - - CONST StartAdr = 3FF800H'22; - - TYPE PROM := MODULE (IN clk: BIT; - IN adr: [9] BIT; - OUT data: WORD) ^; - - Multiplier := MODULE (IN clk, run, u: BIT; - OUT stall: BIT; - IN x, y: WORD; - OUT z: [64] BIT) ^; - - Divider := MODULE (IN clk, run, u: BIT; - OUT stall: BIT; - IN x, y: WORD; - OUT quot, rem: WORD) ^; - - FPAdder := MODULE (IN clk, run, u, v: BIT; OUT stall: BIT; - IN x, y: WORD; OUT z: WORD) ^; - - FPMultiplier := MODULE (IN clk, run: BIT; OUT stall: BIT; - IN x, y: WORD; OUT z: WORD) ^; - - FPDivider := MODULE (IN clk, run: BIT; OUT stall: BIT; - IN x, y: WORD; OUT z: WORD) ^; - - REG (clk) PC: [22] BIT; (*program counter*) - IR: WORD; (*instruction register*) - N, Z, C, OV: BIT; (*condition flags*) - stall1, PMsel: BIT; - R: [16] WORD; (*data registers*) - H: WORD; (*auxiliary register*) - - VAR PM: PROM; (*mem for boot loader*) - mulUnit: Multiplier; - divUnit: Divider; - faddUnit: FPAdder; - fmulUnit: FPMultiplier; - fdivUnit: FPDivider; - - pcmux, nxpc: [22] BIT; - cond, S: BIT; - sa, sb, sc: BIT; - - ins, pmout: WORD; - p, q, u, v, w: BIT; (*instruction fields*) - op, ira, ira0, irb, irc: [4] BIT; - cc: [3] BIT; - imm: [16] BIT; - off: [20] BIT; - offL: [24] BIT; - - regwr, stall, stallL, stallM, stallD, stallFA, stallFM, stallFD: BIT; - sc1, sc0: [2] BIT; (*shift counts*) - - a0, a1, a2, a3: BIT; - inbusL, outbusB0, outbusB1, outbusB2, outbusB3: BYTE; - inbusH: [24] BIT; - - A, B, C0, C1, aluRes, regmux: WORD; - s1, s2, s3, t1, t2, t3: WORD; (*shifting*) - quotient, remainder: WORD; - product: [64] BIT; - fsum, fprod, fquot: WORD; - - Add, Sub, Mul, Div: BIT; - Fadd, Fsub, Fmul, Fdiv: BIT; - Ldr, Str, Br: BIT; - -BEGIN PM(clk, pcmux[8:0], pmout); - mulUnit (clk, Mul, ~u, stallM, B, C1, product); - divUnit (clk, Div, ~u, stallD, B, C1, quotient, remainder); - faddUnit (clk, Fadd|Fsub, u, v, stallFA, B, {Fsub^C0.31, C0[30:0]}, fsum); - fmulUnit (clk, Fmul, stallFM, B, C0, fprod); - fdivUnit (clk, Fdiv, stallFD, B, C0, fquot); - - ins := PMsel -> pmout : IR; (*current instruction*) - p := ins.31; (*instruction fields*) - q := ins.30; - u := ins.29; - v := ins.28; - w := ins.16; - cc:= ins[26:24]; - ira := ins[27:24]; - irb := ins[23:20]; - op := ins[19:16]; - irc := ins[3:0]; - imm := ins[15:0]; (*reg instr*) - off := ins[19:0]; (*mem instr*) - offL := ins[23:0]; (*branch instr*) - - Add := ~p & (op = 8); - Sub := ~p & (op = 9); - Mul := ~p & (op = 10); - Div := ~p & (op = 11); - Fadd := ~p & (op = 12); - Fsub := ~p & (op = 13); - Fmul := ~p & (op = 14); - Fdiv := ~p & (op = 15); - Ldr := p & ~q & ~u; - Str := p & ~q & u; - Br := p & q; - - (*ALU*) - A := R[ira0]; (*main data path*) - B := R[irb]; - C0 := R[irc]; - C1 := q -> {v!16, imm} : C0 ; - ira0 := Br -> 15'4 : ira; - adr := stallL -> B[23:0] + {0'4, off} : {pcmux, 0'2}; - rd := Ldr & ~stallX & ~stall1; - wr := Str & ~stallX & ~stall1; - ben := p & ~q & v & ~stallX & ~stall1; (*byte enable*) - - sc0 := C1[1:0]; - sc1 := C1[3:2]; - - (*right shifter*) - s1 := (sc0 = 3) -> {(w -> B[2:0] : {B.31 ! 3}), B[31:3]} : - (sc0 = 2) -> {(w -> B[1:0] : {B.31 ! 2}), B[31:2]} : - (sc0 = 1) -> {(w -> B.0 : B.31), B[31:1]} : B; - s2 := (sc1 = 3) -> {(w -> s1[11:0] : {B.31 ! 12}), s1[31:12]} : - (sc1 = 2) -> {(w -> s1[7:0] : {B.31 ! 8}), s1[31:8]} : - (sc1 = 1) -> {(w -> s1[3:0] : {B.31 ! 4}), s1[31:4]} : s1; - s3 := C1.4 -> {(w -> s2[15:0] : {s2.31 ! 16}), s2[31:16]} : s2; - - (*left shifter*) - t1 := (sc0 = 3) -> {B[28:0], 0'3} : - (sc0 = 2) -> {B[29:0], 0'2} : - (sc0 = 1) -> {B[30:0], 0'1} : B; - t2 := (sc1 = 3) -> {t1[19:0], 0'12} : - (sc1 = 2) -> {t1[23:0], 0'8} : - (sc1 = 1) -> {t1[27:0], 0'4} : t1; - t3 := C1.4 -> {t2[15:0], 0'16} : t2; - - aluRes := - ~op.3 -> - (~op.2 -> - (~op.1 -> - (~op.0 -> (*Mov*) - (q -> - (~u -> {v!16 , imm} : {imm, 0'16}) : - (~u -> C0 : (~v -> H : {N, Z, C, OV, 0'20, 58H'8}))) : - t3 ): (*Lsl*) - s3) : (*Asr, Ror*) - (~op.1 -> - (~op.0 -> B & C1 : B & ~C1) : (*And, Ann*) - (~op.0 -> B | C1 : B ^ C1)) ): (*Ior, Xor*) - (~op.2 -> - (~op.1 -> - (~op.0 -> B + C + (u&C) : B - C1 - (u&C)) : (*Add, Sub*) - (~op.0 -> product[31:0] : quotient)) : (*Mul, Div*) - (~op.1 -> - fsum : (*Fad, Fsb*) - (~op.0 -> fprod : fquot))) ; (*Fml, Fdv*) - - regwr := ~p & ~stall | (Ldr & ~stallX & ~stall1) | (Br & cond & v & ~stallX); - a0 := ~adr.1 & ~adr.0; - a1 := ~adr.1 & adr.0; - a2 := adr.1 & ~adr.0; - a3 := adr.1 & adr.0; - inbusL := (~ben | a0) -> inbus[7:0] : a1 -> inbus[15:8] : a2 -> inbus[23:16] : inbus[31:24]; - inbusH := ~ben -> inbus[31:8] : 0'24; - regmux := Ldr -> {inbusH, inbusL} : (Br & v) -> {0'8, nxpc, 0'2} : aluRes ; - - outbusB0 := A[7:0]; - outbusB1 := ben & a1 -> A[7:0] : A[15:8]; - outbusB2 := ben & a2 -> A[7:0] : A[23:16]; - outbusB3 := ben & a3 -> A[7:0] : A[31:24]; - outbus := {outbusB3, outbusB2, outbusB1, outbusB0}; - - (*control unit*) - S := N ^ OV; - nxpc := PC + 1; - cond := ins.27 ^ ( - (cc = 0) & N | (*MI, PL*) - (cc = 1) & Z | (*EQ, NE*) - (cc = 2) & C | (*CS, CC*) - (cc = 3) & OV | (*VS, VC*) - (cc = 4) & (C|Z) | (*LS, HI*) - (cc = 5) & S | (*LT, GE*) - (cc = 6) & (S|Z) | (*LE, GT*) - (cc = 7)); - pcmux := ~rst -> 3FF800H'22 : - stall -> PC : - (Br & cond & u) -> offL[21:0] + nxpc : - (Br & cond & ~u) -> C0[23:2] : nxpc; - - sa := aluRes.31; - sb := B.31; - sc := C1.31; - - stall := stallL | stallM | stallD | stallFA | stallFM | stallFD | stallX; - stallL := (Ldr | Str) & ~stall1; - - (*assignments to registers*) - PC := pcmux; - PMsel := ~rst | (pcmux[21:12] = 03FFH'10); - IR := stall -> IR : codebus; - stall1 := stallX -> stall1 : stallL; - R[ira0] := regwr -> regmux : A; - N := regwr -> regmux.31 : N; - Z := regwr -> (regmux = 0) : Z; - C := Add -> (sb&sc) | (~sa&~sb&sc) | (~sa&sb&~sc&sa) : - Sub -> (~sb&sc) | (sa&~sb&~sc) | (sa&sb&sc) : C; - OV := Add -> (sa&~sb&~sc) | (~sa&sb&sc) : - Sub -> (sa&~sb&sc) | (~sa&sb&~sc) : OV; - H := Mul -> product[63:32] : Div -> remainder : H -END RISC5. +MODULE RISC5 (IN clk, rst, stallX: BIT; (*NW 26.10.2015*) + IN inbus, codebus: WORD; + OUT adr: [24] BIT; + rd, wr, ben: BIT; + outbus: WORD); + + CONST StartAdr = 3FF800H'22; + + TYPE PROM := MODULE (IN clk: BIT; + IN adr: [9] BIT; + OUT data: WORD) ^; + + Multiplier := MODULE (IN clk, run, u: BIT; + OUT stall: BIT; + IN x, y: WORD; + OUT z: [64] BIT) ^; + + Divider := MODULE (IN clk, run, u: BIT; + OUT stall: BIT; + IN x, y: WORD; + OUT quot, rem: WORD) ^; + + FPAdder := MODULE (IN clk, run, u, v: BIT; OUT stall: BIT; + IN x, y: WORD; OUT z: WORD) ^; + + FPMultiplier := MODULE (IN clk, run: BIT; OUT stall: BIT; + IN x, y: WORD; OUT z: WORD) ^; + + FPDivider := MODULE (IN clk, run: BIT; OUT stall: BIT; + IN x, y: WORD; OUT z: WORD) ^; + + REG (clk) PC: [22] BIT; (*program counter*) + IR: WORD; (*instruction register*) + N, Z, C, OV: BIT; (*condition flags*) + stall1, PMsel: BIT; + R: [16] WORD; (*data registers*) + H: WORD; (*auxiliary register*) + + VAR PM: PROM; (*mem for boot loader*) + mulUnit: Multiplier; + divUnit: Divider; + faddUnit: FPAdder; + fmulUnit: FPMultiplier; + fdivUnit: FPDivider; + + pcmux, nxpc: [22] BIT; + cond, S: BIT; + sa, sb, sc: BIT; + + ins, pmout: WORD; + p, q, u, v, w: BIT; (*instruction fields*) + op, ira, ira0, irb, irc: [4] BIT; + cc: [3] BIT; + imm: [16] BIT; + off: [20] BIT; + offL: [24] BIT; + + regwr, stall, stallL, stallM, stallD, stallFA, stallFM, stallFD: BIT; + sc1, sc0: [2] BIT; (*shift counts*) + + a0, a1, a2, a3: BIT; + inbusL, outbusB0, outbusB1, outbusB2, outbusB3: BYTE; + inbusH: [24] BIT; + + A, B, C0, C1, aluRes, regmux: WORD; + s1, s2, s3, t1, t2, t3: WORD; (*shifting*) + quotient, remainder: WORD; + product: [64] BIT; + fsum, fprod, fquot: WORD; + + Add, Sub, Mul, Div: BIT; + Fadd, Fsub, Fmul, Fdiv: BIT; + Ldr, Str, Br: BIT; + +BEGIN PM(clk, pcmux[8:0], pmout); + mulUnit (clk, Mul, ~u, stallM, B, C1, product); + divUnit (clk, Div, ~u, stallD, B, C1, quotient, remainder); + faddUnit (clk, Fadd|Fsub, u, v, stallFA, B, {Fsub^C0.31, C0[30:0]}, fsum); + fmulUnit (clk, Fmul, stallFM, B, C0, fprod); + fdivUnit (clk, Fdiv, stallFD, B, C0, fquot); + + ins := PMsel -> pmout : IR; (*current instruction*) + p := ins.31; (*instruction fields*) + q := ins.30; + u := ins.29; + v := ins.28; + w := ins.16; + cc:= ins[26:24]; + ira := ins[27:24]; + irb := ins[23:20]; + op := ins[19:16]; + irc := ins[3:0]; + imm := ins[15:0]; (*reg instr*) + off := ins[19:0]; (*mem instr*) + offL := ins[23:0]; (*branch instr*) + + Add := ~p & (op = 8); + Sub := ~p & (op = 9); + Mul := ~p & (op = 10); + Div := ~p & (op = 11); + Fadd := ~p & (op = 12); + Fsub := ~p & (op = 13); + Fmul := ~p & (op = 14); + Fdiv := ~p & (op = 15); + Ldr := p & ~q & ~u; + Str := p & ~q & u; + Br := p & q; + + (*ALU*) + A := R[ira0]; (*main data path*) + B := R[irb]; + C0 := R[irc]; + C1 := q -> {v!16, imm} : C0 ; + ira0 := Br -> 15'4 : ira; + adr := stallL -> B[23:0] + {0'4, off} : {pcmux, 0'2}; + rd := Ldr & ~stallX & ~stall1; + wr := Str & ~stallX & ~stall1; + ben := p & ~q & v & ~stallX & ~stall1; (*byte enable*) + + sc0 := C1[1:0]; + sc1 := C1[3:2]; + + (*right shifter*) + s1 := (sc0 = 3) -> {(w -> B[2:0] : {B.31 ! 3}), B[31:3]} : + (sc0 = 2) -> {(w -> B[1:0] : {B.31 ! 2}), B[31:2]} : + (sc0 = 1) -> {(w -> B.0 : B.31), B[31:1]} : B; + s2 := (sc1 = 3) -> {(w -> s1[11:0] : {B.31 ! 12}), s1[31:12]} : + (sc1 = 2) -> {(w -> s1[7:0] : {B.31 ! 8}), s1[31:8]} : + (sc1 = 1) -> {(w -> s1[3:0] : {B.31 ! 4}), s1[31:4]} : s1; + s3 := C1.4 -> {(w -> s2[15:0] : {s2.31 ! 16}), s2[31:16]} : s2; + + (*left shifter*) + t1 := (sc0 = 3) -> {B[28:0], 0'3} : + (sc0 = 2) -> {B[29:0], 0'2} : + (sc0 = 1) -> {B[30:0], 0'1} : B; + t2 := (sc1 = 3) -> {t1[19:0], 0'12} : + (sc1 = 2) -> {t1[23:0], 0'8} : + (sc1 = 1) -> {t1[27:0], 0'4} : t1; + t3 := C1.4 -> {t2[15:0], 0'16} : t2; + + aluRes := + ~op.3 -> + (~op.2 -> + (~op.1 -> + (~op.0 -> (*Mov*) + (q -> + (~u -> {v!16 , imm} : {imm, 0'16}) : + (~u -> C0 : (~v -> H : {N, Z, C, OV, 0'20, 58H'8}))) : + t3 ): (*Lsl*) + s3) : (*Asr, Ror*) + (~op.1 -> + (~op.0 -> B & C1 : B & ~C1) : (*And, Ann*) + (~op.0 -> B | C1 : B ^ C1)) ): (*Ior, Xor*) + (~op.2 -> + (~op.1 -> + (~op.0 -> B + C + (u&C) : B - C1 - (u&C)) : (*Add, Sub*) + (~op.0 -> product[31:0] : quotient)) : (*Mul, Div*) + (~op.1 -> + fsum : (*Fad, Fsb*) + (~op.0 -> fprod : fquot))) ; (*Fml, Fdv*) + + regwr := ~p & ~stall | (Ldr & ~stallX & ~stall1) | (Br & cond & v & ~stallX); + a0 := ~adr.1 & ~adr.0; + a1 := ~adr.1 & adr.0; + a2 := adr.1 & ~adr.0; + a3 := adr.1 & adr.0; + inbusL := (~ben | a0) -> inbus[7:0] : a1 -> inbus[15:8] : a2 -> inbus[23:16] : inbus[31:24]; + inbusH := ~ben -> inbus[31:8] : 0'24; + regmux := Ldr -> {inbusH, inbusL} : (Br & v) -> {0'8, nxpc, 0'2} : aluRes ; + + outbusB0 := A[7:0]; + outbusB1 := ben & a1 -> A[7:0] : A[15:8]; + outbusB2 := ben & a2 -> A[7:0] : A[23:16]; + outbusB3 := ben & a3 -> A[7:0] : A[31:24]; + outbus := {outbusB3, outbusB2, outbusB1, outbusB0}; + + (*control unit*) + S := N ^ OV; + nxpc := PC + 1; + cond := ins.27 ^ ( + (cc = 0) & N | (*MI, PL*) + (cc = 1) & Z | (*EQ, NE*) + (cc = 2) & C | (*CS, CC*) + (cc = 3) & OV | (*VS, VC*) + (cc = 4) & (C|Z) | (*LS, HI*) + (cc = 5) & S | (*LT, GE*) + (cc = 6) & (S|Z) | (*LE, GT*) + (cc = 7)); + pcmux := ~rst -> 3FF800H'22 : + stall -> PC : + (Br & cond & u) -> offL[21:0] + nxpc : + (Br & cond & ~u) -> C0[23:2] : nxpc; + + sa := aluRes.31; + sb := B.31; + sc := C1.31; + + stall := stallL | stallM | stallD | stallFA | stallFM | stallFD | stallX; + stallL := (Ldr | Str) & ~stall1; + + (*assignments to registers*) + PC := pcmux; + PMsel := ~rst | (pcmux[21:12] = 03FFH'10); + IR := stall -> IR : codebus; + stall1 := stallX -> stall1 : stallL; + R[ira0] := regwr -> regmux : A; + N := regwr -> regmux.31 : N; + Z := regwr -> (regmux = 0) : Z; + C := Add -> (sb&sc) | (~sa&~sb&sc) | (~sa&sb&~sc&sa) : + Sub -> (~sb&sc) | (sa&~sb&~sc) | (sa&sb&sc) : C; + OV := Add -> (sa&~sb&~sc) | (~sa&sb&sc) : + Sub -> (sa&~sb&sc) | (~sa&sb&~sc) : OV; + H := Mul -> product[63:32] : Div -> remainder : H +END RISC5. diff --git a/src/test/confidence/lola/expected b/src/test/confidence/lola/expected index 4a6b1bb8..12f87669 100644 --- a/src/test/confidence/lola/expected +++ b/src/test/confidence/lola/expected @@ -1,113 +1,113 @@ -`timescale 1ns / 1 ps -module RISC5( // translated from Lola -input clk, rst, stallX, -input [31:0] inbus, codebus, -output [23:0] adr, -output rd, wr, ben, -output [31:0] outbus); -reg [21:0] PC; -reg [31:0] IR; -reg N, Z, C, OV, stall1, PMsel; -reg [31:0] R[15:0]; -reg [31:0] H; -wire [21:0] pcmux, nxpc; -wire cond, S, sa, sb, sc; -wire [31:0] ins, pmout; -wire p, q, u, v, w; -wire [3:0] op, ira, ira0, irb, irc; -wire [2:0] cc; -wire [15:0] imm; -wire [19:0] off; -wire [23:0] offL; -wire regwr, stall, stallL, stallM, stallD, stallFA, stallFM, stallFD; -wire [1:0] sc1, sc0; -wire a0, a1, a2, a3; -wire [7:0] inbusL, outbusB0, outbusB1, outbusB2, outbusB3; -wire [23:0] inbusH; -wire [31:0] A, B, C0, C1, aluRes, regmux, s1, s2, s3, t1, t2, t3, quotient, remainder; -wire [63:0] product; -wire [31:0] fsum, fprod, fquot; -wire Add, Sub, Mul, Div, Fadd, Fsub, Fmul, Fdiv, Ldr, Str, Br; -assign adr = stallL ? (B[23:0] + {4'h0, off}) : {pcmux, 2'h0}; -assign rd = ((Ldr & ~stallX) & ~stall1); -assign wr = ((Str & ~stallX) & ~stall1); -assign ben = ((((p & ~q) & v) & ~stallX) & ~stall1); -assign outbus = {outbusB3, outbusB2, outbusB1, outbusB0}; -PROM PM(.clk(clk), .adr(pcmux[8:0]), .data(pmout)); -Multiplier mulUnit(.clk(clk), .run(Mul), .u(~u), .stall(stallM), .x(B), .y(C1), .z(product)); -Divider divUnit(.clk(clk), .run(Div), .u(~u), .stall(stallD), .x(B), .y(C1), .quot(quotient), .rem(remainder)); -FPAdder faddUnit(.clk(clk), .run((Fadd | Fsub)), .u(u), .v(v), .stall(stallFA), .x(B), .y({(Fsub ^ C0[31]), C0[30:0]}), .z(fsum)); -FPMultiplier fmulUnit(.clk(clk), .run(Fmul), .stall(stallFM), .x(B), .y(C0), .z(fprod)); -FPDivider fdivUnit(.clk(clk), .run(Fdiv), .stall(stallFD), .x(B), .y(C0), .z(fquot)); -assign pcmux = ~rst ? 22'h3FF800 : stall ? PC : ((Br & cond) & u) ? (offL[21:0] + nxpc) : ((Br & cond) & ~u) ? C0[23:2] : nxpc; -assign nxpc = (PC + 1); -assign cond = (ins[27] ^ (((((((((cc == 0) & N) | ((cc == 1) & Z)) | ((cc == 2) & C)) | ((cc == 3) & OV)) | ((cc == 4) & (C | Z))) | ((cc == 5) & S)) | ((cc == 6) & (S | Z))) | (cc == 7))); -assign S = (N ^ OV); -assign sa = aluRes[31]; -assign sb = B[31]; -assign sc = C1[31]; -assign ins = PMsel ? pmout : IR; -assign p = ins[31]; -assign q = ins[30]; -assign u = ins[29]; -assign v = ins[28]; -assign w = ins[16]; -assign op = ins[19:16]; -assign ira = ins[27:24]; -assign ira0 = Br ? 4'hF : ira; -assign irb = ins[23:20]; -assign irc = ins[3:0]; -assign cc = ins[26:24]; -assign imm = ins[15:0]; -assign off = ins[19:0]; -assign offL = ins[23:0]; -assign regwr = (((~p & ~stall) | ((Ldr & ~stallX) & ~stall1)) | (((Br & cond) & v) & ~stallX)); -assign stall = ((((((stallL | stallM) | stallD) | stallFA) | stallFM) | stallFD) | stallX); -assign stallL = ((Ldr | Str) & ~stall1); -assign sc1 = C1[3:2]; -assign sc0 = C1[1:0]; -assign a0 = (~adr[1] & ~adr[0]); -assign a1 = (~adr[1] & adr[0]); -assign a2 = (adr[1] & ~adr[0]); -assign a3 = (adr[1] & adr[0]); -assign inbusL = (~ben | a0) ? inbus[7:0] : a1 ? inbus[15:8] : a2 ? inbus[23:16] : inbus[31:24]; -assign outbusB0 = A[7:0]; -assign outbusB1 = (ben & a1) ? A[7:0] : A[15:8]; -assign outbusB2 = (ben & a2) ? A[7:0] : A[23:16]; -assign outbusB3 = (ben & a3) ? A[7:0] : A[31:24]; -assign inbusH = ~ben ? inbus[31:8] : 24'h0; -assign A = R[ira0]; -assign B = R[irb]; -assign C0 = R[irc]; -assign C1 = q ? {{16{v}}, imm} : C0; -assign aluRes = ~op[3] ? ~op[2] ? ~op[1] ? ~op[0] ? q ? ~u ? {{16{v}}, imm} : {imm, 16'h0} : ~u ? C0 : ~v ? H : {N, Z, C, OV, 20'h0, 8'h58} : t3 : s3 : ~op[1] ? ~op[0] ? (B & C1) : (B & ~C1) : ~op[0] ? (B | C1) : (B ^ C1) : ~op[2] ? ~op[1] ? ~op[0] ? ((B + C) + (u & C)) : ((B - C1) - (u & C)) : ~op[0] ? product[31:0] : quotient : ~op[1] ? fsum : ~op[0] ? fprod : fquot; -assign regmux = Ldr ? {inbusH, inbusL} : (Br & v) ? {8'h0, nxpc, 2'h0} : aluRes; -assign s1 = (sc0 == 3) ? {w ? B[2:0] : {3{B[31]}}, B[31:3]} : (sc0 == 2) ? {w ? B[1:0] : {2{B[31]}}, B[31:2]} : (sc0 == 1) ? {w ? B[0] : B[31], B[31:1]} : B; -assign s2 = (sc1 == 3) ? {w ? s1[11:0] : {12{B[31]}}, s1[31:12]} : (sc1 == 2) ? {w ? s1[7:0] : {8{B[31]}}, s1[31:8]} : (sc1 == 1) ? {w ? s1[3:0] : {4{B[31]}}, s1[31:4]} : s1; -assign s3 = C1[4] ? {w ? s2[15:0] : {16{s2[31]}}, s2[31:16]} : s2; -assign t1 = (sc0 == 3) ? {B[28:0], 3'h0} : (sc0 == 2) ? {B[29:0], 2'h0} : (sc0 == 1) ? {B[30:0], 1'h0} : B; -assign t2 = (sc1 == 3) ? {t1[19:0], 12'h0} : (sc1 == 2) ? {t1[23:0], 8'h0} : (sc1 == 1) ? {t1[27:0], 4'h0} : t1; -assign t3 = C1[4] ? {t2[15:0], 16'h0} : t2; -assign Add = (~p & (op == 8)); -assign Sub = (~p & (op == 9)); -assign Mul = (~p & (op == 10)); -assign Div = (~p & (op == 11)); -assign Fadd = (~p & (op == 12)); -assign Fsub = (~p & (op == 13)); -assign Fmul = (~p & (op == 14)); -assign Fdiv = (~p & (op == 15)); -assign Ldr = ((p & ~q) & ~u); -assign Str = ((p & ~q) & u); -assign Br = (p & q); -always @ (posedge clk) begin PC <= pcmux; -IR <= stall ? IR : codebus; -N <= regwr ? regmux[31] : N; -Z <= regwr ? (regmux == 0) : Z; -C <= Add ? (((sb & sc) | ((~sa & ~sb) & sc)) | (((~sa & sb) & ~sc) & sa)) : Sub ? (((~sb & sc) | ((sa & ~sb) & ~sc)) | ((sa & sb) & sc)) : C; -OV <= Add ? (((sa & ~sb) & ~sc) | ((~sa & sb) & sc)) : Sub ? (((sa & ~sb) & sc) | ((~sa & sb) & ~sc)) : OV; -stall1 <= stallX ? stall1 : stallL; -PMsel <= (~rst | (pcmux[21:12] == 10'h3FF)); -R[ira0] <= regwr ? regmux : A; -H <= Mul ? product[63:32] : Div ? remainder : H; -end -endmodule +`timescale 1ns / 1 ps +module RISC5( // translated from Lola +input clk, rst, stallX, +input [31:0] inbus, codebus, +output [23:0] adr, +output rd, wr, ben, +output [31:0] outbus); +reg [21:0] PC; +reg [31:0] IR; +reg N, Z, C, OV, stall1, PMsel; +reg [31:0] R[15:0]; +reg [31:0] H; +wire [21:0] pcmux, nxpc; +wire cond, S, sa, sb, sc; +wire [31:0] ins, pmout; +wire p, q, u, v, w; +wire [3:0] op, ira, ira0, irb, irc; +wire [2:0] cc; +wire [15:0] imm; +wire [19:0] off; +wire [23:0] offL; +wire regwr, stall, stallL, stallM, stallD, stallFA, stallFM, stallFD; +wire [1:0] sc1, sc0; +wire a0, a1, a2, a3; +wire [7:0] inbusL, outbusB0, outbusB1, outbusB2, outbusB3; +wire [23:0] inbusH; +wire [31:0] A, B, C0, C1, aluRes, regmux, s1, s2, s3, t1, t2, t3, quotient, remainder; +wire [63:0] product; +wire [31:0] fsum, fprod, fquot; +wire Add, Sub, Mul, Div, Fadd, Fsub, Fmul, Fdiv, Ldr, Str, Br; +assign adr = stallL ? (B[23:0] + {4'h0, off}) : {pcmux, 2'h0}; +assign rd = ((Ldr & ~stallX) & ~stall1); +assign wr = ((Str & ~stallX) & ~stall1); +assign ben = ((((p & ~q) & v) & ~stallX) & ~stall1); +assign outbus = {outbusB3, outbusB2, outbusB1, outbusB0}; +PROM PM(.clk(clk), .adr(pcmux[8:0]), .data(pmout)); +Multiplier mulUnit(.clk(clk), .run(Mul), .u(~u), .stall(stallM), .x(B), .y(C1), .z(product)); +Divider divUnit(.clk(clk), .run(Div), .u(~u), .stall(stallD), .x(B), .y(C1), .quot(quotient), .rem(remainder)); +FPAdder faddUnit(.clk(clk), .run((Fadd | Fsub)), .u(u), .v(v), .stall(stallFA), .x(B), .y({(Fsub ^ C0[31]), C0[30:0]}), .z(fsum)); +FPMultiplier fmulUnit(.clk(clk), .run(Fmul), .stall(stallFM), .x(B), .y(C0), .z(fprod)); +FPDivider fdivUnit(.clk(clk), .run(Fdiv), .stall(stallFD), .x(B), .y(C0), .z(fquot)); +assign pcmux = ~rst ? 22'h3FF800 : stall ? PC : ((Br & cond) & u) ? (offL[21:0] + nxpc) : ((Br & cond) & ~u) ? C0[23:2] : nxpc; +assign nxpc = (PC + 1); +assign cond = (ins[27] ^ (((((((((cc == 0) & N) | ((cc == 1) & Z)) | ((cc == 2) & C)) | ((cc == 3) & OV)) | ((cc == 4) & (C | Z))) | ((cc == 5) & S)) | ((cc == 6) & (S | Z))) | (cc == 7))); +assign S = (N ^ OV); +assign sa = aluRes[31]; +assign sb = B[31]; +assign sc = C1[31]; +assign ins = PMsel ? pmout : IR; +assign p = ins[31]; +assign q = ins[30]; +assign u = ins[29]; +assign v = ins[28]; +assign w = ins[16]; +assign op = ins[19:16]; +assign ira = ins[27:24]; +assign ira0 = Br ? 4'hF : ira; +assign irb = ins[23:20]; +assign irc = ins[3:0]; +assign cc = ins[26:24]; +assign imm = ins[15:0]; +assign off = ins[19:0]; +assign offL = ins[23:0]; +assign regwr = (((~p & ~stall) | ((Ldr & ~stallX) & ~stall1)) | (((Br & cond) & v) & ~stallX)); +assign stall = ((((((stallL | stallM) | stallD) | stallFA) | stallFM) | stallFD) | stallX); +assign stallL = ((Ldr | Str) & ~stall1); +assign sc1 = C1[3:2]; +assign sc0 = C1[1:0]; +assign a0 = (~adr[1] & ~adr[0]); +assign a1 = (~adr[1] & adr[0]); +assign a2 = (adr[1] & ~adr[0]); +assign a3 = (adr[1] & adr[0]); +assign inbusL = (~ben | a0) ? inbus[7:0] : a1 ? inbus[15:8] : a2 ? inbus[23:16] : inbus[31:24]; +assign outbusB0 = A[7:0]; +assign outbusB1 = (ben & a1) ? A[7:0] : A[15:8]; +assign outbusB2 = (ben & a2) ? A[7:0] : A[23:16]; +assign outbusB3 = (ben & a3) ? A[7:0] : A[31:24]; +assign inbusH = ~ben ? inbus[31:8] : 24'h0; +assign A = R[ira0]; +assign B = R[irb]; +assign C0 = R[irc]; +assign C1 = q ? {{16{v}}, imm} : C0; +assign aluRes = ~op[3] ? ~op[2] ? ~op[1] ? ~op[0] ? q ? ~u ? {{16{v}}, imm} : {imm, 16'h0} : ~u ? C0 : ~v ? H : {N, Z, C, OV, 20'h0, 8'h58} : t3 : s3 : ~op[1] ? ~op[0] ? (B & C1) : (B & ~C1) : ~op[0] ? (B | C1) : (B ^ C1) : ~op[2] ? ~op[1] ? ~op[0] ? ((B + C) + (u & C)) : ((B - C1) - (u & C)) : ~op[0] ? product[31:0] : quotient : ~op[1] ? fsum : ~op[0] ? fprod : fquot; +assign regmux = Ldr ? {inbusH, inbusL} : (Br & v) ? {8'h0, nxpc, 2'h0} : aluRes; +assign s1 = (sc0 == 3) ? {w ? B[2:0] : {3{B[31]}}, B[31:3]} : (sc0 == 2) ? {w ? B[1:0] : {2{B[31]}}, B[31:2]} : (sc0 == 1) ? {w ? B[0] : B[31], B[31:1]} : B; +assign s2 = (sc1 == 3) ? {w ? s1[11:0] : {12{B[31]}}, s1[31:12]} : (sc1 == 2) ? {w ? s1[7:0] : {8{B[31]}}, s1[31:8]} : (sc1 == 1) ? {w ? s1[3:0] : {4{B[31]}}, s1[31:4]} : s1; +assign s3 = C1[4] ? {w ? s2[15:0] : {16{s2[31]}}, s2[31:16]} : s2; +assign t1 = (sc0 == 3) ? {B[28:0], 3'h0} : (sc0 == 2) ? {B[29:0], 2'h0} : (sc0 == 1) ? {B[30:0], 1'h0} : B; +assign t2 = (sc1 == 3) ? {t1[19:0], 12'h0} : (sc1 == 2) ? {t1[23:0], 8'h0} : (sc1 == 1) ? {t1[27:0], 4'h0} : t1; +assign t3 = C1[4] ? {t2[15:0], 16'h0} : t2; +assign Add = (~p & (op == 8)); +assign Sub = (~p & (op == 9)); +assign Mul = (~p & (op == 10)); +assign Div = (~p & (op == 11)); +assign Fadd = (~p & (op == 12)); +assign Fsub = (~p & (op == 13)); +assign Fmul = (~p & (op == 14)); +assign Fdiv = (~p & (op == 15)); +assign Ldr = ((p & ~q) & ~u); +assign Str = ((p & ~q) & u); +assign Br = (p & q); +always @ (posedge clk) begin PC <= pcmux; +IR <= stall ? IR : codebus; +N <= regwr ? regmux[31] : N; +Z <= regwr ? (regmux == 0) : Z; +C <= Add ? (((sb & sc) | ((~sa & ~sb) & sc)) | (((~sa & sb) & ~sc) & sa)) : Sub ? (((~sb & sc) | ((sa & ~sb) & ~sc)) | ((sa & sb) & sc)) : C; +OV <= Add ? (((sa & ~sb) & ~sc) | ((~sa & sb) & sc)) : Sub ? (((sa & ~sb) & sc) | ((~sa & sb) & ~sc)) : OV; +stall1 <= stallX ? stall1 : stallL; +PMsel <= (~rst | (pcmux[21:12] == 10'h3FF)); +R[ira0] <= regwr ? regmux : A; +H <= Mul ? product[63:32] : Div ? remainder : H; +end +endmodule diff --git a/src/test/confidence/lola/lola.Mod b/src/test/confidence/lola/lola.Mod index b330e008..eccebbfd 100755 --- a/src/test/confidence/lola/lola.Mod +++ b/src/test/confidence/lola/lola.Mod @@ -1,12 +1,12 @@ -MODULE Lola; (* Command line runner for Lola to verilog compilation *) - IMPORT LSB, LSC, LSV, Platform, Console; -BEGIN - IF Platform.ArgCount < 3 THEN - Console.String("Lola - compile lola source to verilog source."); Console.Ln; Console.Ln; - Console.String("usage:"); Console.Ln; Console.Ln; - Console.String(" lola lola-source-file verilog-source-file"); Console.Ln; Console.Ln; - ELSE - LSC.Compile; - IF LSB.modname # "" THEN LSV.List END - END -END Lola. +MODULE Lola; (* Command line runner for Lola to verilog compilation *) + IMPORT LSB, LSC, LSV, Platform, Console; +BEGIN + IF Platform.ArgCount < 3 THEN + Console.String("Lola - compile lola source to verilog source."); Console.Ln; Console.Ln; + Console.String("usage:"); Console.Ln; Console.Ln; + Console.String(" lola lola-source-file verilog-source-file"); Console.Ln; Console.Ln; + ELSE + LSC.Compile; + IF LSB.modname # "" THEN LSV.List END + END +END Lola. diff --git a/src/test/confidence/lola/result b/src/test/confidence/lola/result index 4a6b1bb8..12f87669 100644 --- a/src/test/confidence/lola/result +++ b/src/test/confidence/lola/result @@ -1,113 +1,113 @@ -`timescale 1ns / 1 ps -module RISC5( // translated from Lola -input clk, rst, stallX, -input [31:0] inbus, codebus, -output [23:0] adr, -output rd, wr, ben, -output [31:0] outbus); -reg [21:0] PC; -reg [31:0] IR; -reg N, Z, C, OV, stall1, PMsel; -reg [31:0] R[15:0]; -reg [31:0] H; -wire [21:0] pcmux, nxpc; -wire cond, S, sa, sb, sc; -wire [31:0] ins, pmout; -wire p, q, u, v, w; -wire [3:0] op, ira, ira0, irb, irc; -wire [2:0] cc; -wire [15:0] imm; -wire [19:0] off; -wire [23:0] offL; -wire regwr, stall, stallL, stallM, stallD, stallFA, stallFM, stallFD; -wire [1:0] sc1, sc0; -wire a0, a1, a2, a3; -wire [7:0] inbusL, outbusB0, outbusB1, outbusB2, outbusB3; -wire [23:0] inbusH; -wire [31:0] A, B, C0, C1, aluRes, regmux, s1, s2, s3, t1, t2, t3, quotient, remainder; -wire [63:0] product; -wire [31:0] fsum, fprod, fquot; -wire Add, Sub, Mul, Div, Fadd, Fsub, Fmul, Fdiv, Ldr, Str, Br; -assign adr = stallL ? (B[23:0] + {4'h0, off}) : {pcmux, 2'h0}; -assign rd = ((Ldr & ~stallX) & ~stall1); -assign wr = ((Str & ~stallX) & ~stall1); -assign ben = ((((p & ~q) & v) & ~stallX) & ~stall1); -assign outbus = {outbusB3, outbusB2, outbusB1, outbusB0}; -PROM PM(.clk(clk), .adr(pcmux[8:0]), .data(pmout)); -Multiplier mulUnit(.clk(clk), .run(Mul), .u(~u), .stall(stallM), .x(B), .y(C1), .z(product)); -Divider divUnit(.clk(clk), .run(Div), .u(~u), .stall(stallD), .x(B), .y(C1), .quot(quotient), .rem(remainder)); -FPAdder faddUnit(.clk(clk), .run((Fadd | Fsub)), .u(u), .v(v), .stall(stallFA), .x(B), .y({(Fsub ^ C0[31]), C0[30:0]}), .z(fsum)); -FPMultiplier fmulUnit(.clk(clk), .run(Fmul), .stall(stallFM), .x(B), .y(C0), .z(fprod)); -FPDivider fdivUnit(.clk(clk), .run(Fdiv), .stall(stallFD), .x(B), .y(C0), .z(fquot)); -assign pcmux = ~rst ? 22'h3FF800 : stall ? PC : ((Br & cond) & u) ? (offL[21:0] + nxpc) : ((Br & cond) & ~u) ? C0[23:2] : nxpc; -assign nxpc = (PC + 1); -assign cond = (ins[27] ^ (((((((((cc == 0) & N) | ((cc == 1) & Z)) | ((cc == 2) & C)) | ((cc == 3) & OV)) | ((cc == 4) & (C | Z))) | ((cc == 5) & S)) | ((cc == 6) & (S | Z))) | (cc == 7))); -assign S = (N ^ OV); -assign sa = aluRes[31]; -assign sb = B[31]; -assign sc = C1[31]; -assign ins = PMsel ? pmout : IR; -assign p = ins[31]; -assign q = ins[30]; -assign u = ins[29]; -assign v = ins[28]; -assign w = ins[16]; -assign op = ins[19:16]; -assign ira = ins[27:24]; -assign ira0 = Br ? 4'hF : ira; -assign irb = ins[23:20]; -assign irc = ins[3:0]; -assign cc = ins[26:24]; -assign imm = ins[15:0]; -assign off = ins[19:0]; -assign offL = ins[23:0]; -assign regwr = (((~p & ~stall) | ((Ldr & ~stallX) & ~stall1)) | (((Br & cond) & v) & ~stallX)); -assign stall = ((((((stallL | stallM) | stallD) | stallFA) | stallFM) | stallFD) | stallX); -assign stallL = ((Ldr | Str) & ~stall1); -assign sc1 = C1[3:2]; -assign sc0 = C1[1:0]; -assign a0 = (~adr[1] & ~adr[0]); -assign a1 = (~adr[1] & adr[0]); -assign a2 = (adr[1] & ~adr[0]); -assign a3 = (adr[1] & adr[0]); -assign inbusL = (~ben | a0) ? inbus[7:0] : a1 ? inbus[15:8] : a2 ? inbus[23:16] : inbus[31:24]; -assign outbusB0 = A[7:0]; -assign outbusB1 = (ben & a1) ? A[7:0] : A[15:8]; -assign outbusB2 = (ben & a2) ? A[7:0] : A[23:16]; -assign outbusB3 = (ben & a3) ? A[7:0] : A[31:24]; -assign inbusH = ~ben ? inbus[31:8] : 24'h0; -assign A = R[ira0]; -assign B = R[irb]; -assign C0 = R[irc]; -assign C1 = q ? {{16{v}}, imm} : C0; -assign aluRes = ~op[3] ? ~op[2] ? ~op[1] ? ~op[0] ? q ? ~u ? {{16{v}}, imm} : {imm, 16'h0} : ~u ? C0 : ~v ? H : {N, Z, C, OV, 20'h0, 8'h58} : t3 : s3 : ~op[1] ? ~op[0] ? (B & C1) : (B & ~C1) : ~op[0] ? (B | C1) : (B ^ C1) : ~op[2] ? ~op[1] ? ~op[0] ? ((B + C) + (u & C)) : ((B - C1) - (u & C)) : ~op[0] ? product[31:0] : quotient : ~op[1] ? fsum : ~op[0] ? fprod : fquot; -assign regmux = Ldr ? {inbusH, inbusL} : (Br & v) ? {8'h0, nxpc, 2'h0} : aluRes; -assign s1 = (sc0 == 3) ? {w ? B[2:0] : {3{B[31]}}, B[31:3]} : (sc0 == 2) ? {w ? B[1:0] : {2{B[31]}}, B[31:2]} : (sc0 == 1) ? {w ? B[0] : B[31], B[31:1]} : B; -assign s2 = (sc1 == 3) ? {w ? s1[11:0] : {12{B[31]}}, s1[31:12]} : (sc1 == 2) ? {w ? s1[7:0] : {8{B[31]}}, s1[31:8]} : (sc1 == 1) ? {w ? s1[3:0] : {4{B[31]}}, s1[31:4]} : s1; -assign s3 = C1[4] ? {w ? s2[15:0] : {16{s2[31]}}, s2[31:16]} : s2; -assign t1 = (sc0 == 3) ? {B[28:0], 3'h0} : (sc0 == 2) ? {B[29:0], 2'h0} : (sc0 == 1) ? {B[30:0], 1'h0} : B; -assign t2 = (sc1 == 3) ? {t1[19:0], 12'h0} : (sc1 == 2) ? {t1[23:0], 8'h0} : (sc1 == 1) ? {t1[27:0], 4'h0} : t1; -assign t3 = C1[4] ? {t2[15:0], 16'h0} : t2; -assign Add = (~p & (op == 8)); -assign Sub = (~p & (op == 9)); -assign Mul = (~p & (op == 10)); -assign Div = (~p & (op == 11)); -assign Fadd = (~p & (op == 12)); -assign Fsub = (~p & (op == 13)); -assign Fmul = (~p & (op == 14)); -assign Fdiv = (~p & (op == 15)); -assign Ldr = ((p & ~q) & ~u); -assign Str = ((p & ~q) & u); -assign Br = (p & q); -always @ (posedge clk) begin PC <= pcmux; -IR <= stall ? IR : codebus; -N <= regwr ? regmux[31] : N; -Z <= regwr ? (regmux == 0) : Z; -C <= Add ? (((sb & sc) | ((~sa & ~sb) & sc)) | (((~sa & sb) & ~sc) & sa)) : Sub ? (((~sb & sc) | ((sa & ~sb) & ~sc)) | ((sa & sb) & sc)) : C; -OV <= Add ? (((sa & ~sb) & ~sc) | ((~sa & sb) & sc)) : Sub ? (((sa & ~sb) & sc) | ((~sa & sb) & ~sc)) : OV; -stall1 <= stallX ? stall1 : stallL; -PMsel <= (~rst | (pcmux[21:12] == 10'h3FF)); -R[ira0] <= regwr ? regmux : A; -H <= Mul ? product[63:32] : Div ? remainder : H; -end -endmodule +`timescale 1ns / 1 ps +module RISC5( // translated from Lola +input clk, rst, stallX, +input [31:0] inbus, codebus, +output [23:0] adr, +output rd, wr, ben, +output [31:0] outbus); +reg [21:0] PC; +reg [31:0] IR; +reg N, Z, C, OV, stall1, PMsel; +reg [31:0] R[15:0]; +reg [31:0] H; +wire [21:0] pcmux, nxpc; +wire cond, S, sa, sb, sc; +wire [31:0] ins, pmout; +wire p, q, u, v, w; +wire [3:0] op, ira, ira0, irb, irc; +wire [2:0] cc; +wire [15:0] imm; +wire [19:0] off; +wire [23:0] offL; +wire regwr, stall, stallL, stallM, stallD, stallFA, stallFM, stallFD; +wire [1:0] sc1, sc0; +wire a0, a1, a2, a3; +wire [7:0] inbusL, outbusB0, outbusB1, outbusB2, outbusB3; +wire [23:0] inbusH; +wire [31:0] A, B, C0, C1, aluRes, regmux, s1, s2, s3, t1, t2, t3, quotient, remainder; +wire [63:0] product; +wire [31:0] fsum, fprod, fquot; +wire Add, Sub, Mul, Div, Fadd, Fsub, Fmul, Fdiv, Ldr, Str, Br; +assign adr = stallL ? (B[23:0] + {4'h0, off}) : {pcmux, 2'h0}; +assign rd = ((Ldr & ~stallX) & ~stall1); +assign wr = ((Str & ~stallX) & ~stall1); +assign ben = ((((p & ~q) & v) & ~stallX) & ~stall1); +assign outbus = {outbusB3, outbusB2, outbusB1, outbusB0}; +PROM PM(.clk(clk), .adr(pcmux[8:0]), .data(pmout)); +Multiplier mulUnit(.clk(clk), .run(Mul), .u(~u), .stall(stallM), .x(B), .y(C1), .z(product)); +Divider divUnit(.clk(clk), .run(Div), .u(~u), .stall(stallD), .x(B), .y(C1), .quot(quotient), .rem(remainder)); +FPAdder faddUnit(.clk(clk), .run((Fadd | Fsub)), .u(u), .v(v), .stall(stallFA), .x(B), .y({(Fsub ^ C0[31]), C0[30:0]}), .z(fsum)); +FPMultiplier fmulUnit(.clk(clk), .run(Fmul), .stall(stallFM), .x(B), .y(C0), .z(fprod)); +FPDivider fdivUnit(.clk(clk), .run(Fdiv), .stall(stallFD), .x(B), .y(C0), .z(fquot)); +assign pcmux = ~rst ? 22'h3FF800 : stall ? PC : ((Br & cond) & u) ? (offL[21:0] + nxpc) : ((Br & cond) & ~u) ? C0[23:2] : nxpc; +assign nxpc = (PC + 1); +assign cond = (ins[27] ^ (((((((((cc == 0) & N) | ((cc == 1) & Z)) | ((cc == 2) & C)) | ((cc == 3) & OV)) | ((cc == 4) & (C | Z))) | ((cc == 5) & S)) | ((cc == 6) & (S | Z))) | (cc == 7))); +assign S = (N ^ OV); +assign sa = aluRes[31]; +assign sb = B[31]; +assign sc = C1[31]; +assign ins = PMsel ? pmout : IR; +assign p = ins[31]; +assign q = ins[30]; +assign u = ins[29]; +assign v = ins[28]; +assign w = ins[16]; +assign op = ins[19:16]; +assign ira = ins[27:24]; +assign ira0 = Br ? 4'hF : ira; +assign irb = ins[23:20]; +assign irc = ins[3:0]; +assign cc = ins[26:24]; +assign imm = ins[15:0]; +assign off = ins[19:0]; +assign offL = ins[23:0]; +assign regwr = (((~p & ~stall) | ((Ldr & ~stallX) & ~stall1)) | (((Br & cond) & v) & ~stallX)); +assign stall = ((((((stallL | stallM) | stallD) | stallFA) | stallFM) | stallFD) | stallX); +assign stallL = ((Ldr | Str) & ~stall1); +assign sc1 = C1[3:2]; +assign sc0 = C1[1:0]; +assign a0 = (~adr[1] & ~adr[0]); +assign a1 = (~adr[1] & adr[0]); +assign a2 = (adr[1] & ~adr[0]); +assign a3 = (adr[1] & adr[0]); +assign inbusL = (~ben | a0) ? inbus[7:0] : a1 ? inbus[15:8] : a2 ? inbus[23:16] : inbus[31:24]; +assign outbusB0 = A[7:0]; +assign outbusB1 = (ben & a1) ? A[7:0] : A[15:8]; +assign outbusB2 = (ben & a2) ? A[7:0] : A[23:16]; +assign outbusB3 = (ben & a3) ? A[7:0] : A[31:24]; +assign inbusH = ~ben ? inbus[31:8] : 24'h0; +assign A = R[ira0]; +assign B = R[irb]; +assign C0 = R[irc]; +assign C1 = q ? {{16{v}}, imm} : C0; +assign aluRes = ~op[3] ? ~op[2] ? ~op[1] ? ~op[0] ? q ? ~u ? {{16{v}}, imm} : {imm, 16'h0} : ~u ? C0 : ~v ? H : {N, Z, C, OV, 20'h0, 8'h58} : t3 : s3 : ~op[1] ? ~op[0] ? (B & C1) : (B & ~C1) : ~op[0] ? (B | C1) : (B ^ C1) : ~op[2] ? ~op[1] ? ~op[0] ? ((B + C) + (u & C)) : ((B - C1) - (u & C)) : ~op[0] ? product[31:0] : quotient : ~op[1] ? fsum : ~op[0] ? fprod : fquot; +assign regmux = Ldr ? {inbusH, inbusL} : (Br & v) ? {8'h0, nxpc, 2'h0} : aluRes; +assign s1 = (sc0 == 3) ? {w ? B[2:0] : {3{B[31]}}, B[31:3]} : (sc0 == 2) ? {w ? B[1:0] : {2{B[31]}}, B[31:2]} : (sc0 == 1) ? {w ? B[0] : B[31], B[31:1]} : B; +assign s2 = (sc1 == 3) ? {w ? s1[11:0] : {12{B[31]}}, s1[31:12]} : (sc1 == 2) ? {w ? s1[7:0] : {8{B[31]}}, s1[31:8]} : (sc1 == 1) ? {w ? s1[3:0] : {4{B[31]}}, s1[31:4]} : s1; +assign s3 = C1[4] ? {w ? s2[15:0] : {16{s2[31]}}, s2[31:16]} : s2; +assign t1 = (sc0 == 3) ? {B[28:0], 3'h0} : (sc0 == 2) ? {B[29:0], 2'h0} : (sc0 == 1) ? {B[30:0], 1'h0} : B; +assign t2 = (sc1 == 3) ? {t1[19:0], 12'h0} : (sc1 == 2) ? {t1[23:0], 8'h0} : (sc1 == 1) ? {t1[27:0], 4'h0} : t1; +assign t3 = C1[4] ? {t2[15:0], 16'h0} : t2; +assign Add = (~p & (op == 8)); +assign Sub = (~p & (op == 9)); +assign Mul = (~p & (op == 10)); +assign Div = (~p & (op == 11)); +assign Fadd = (~p & (op == 12)); +assign Fsub = (~p & (op == 13)); +assign Fmul = (~p & (op == 14)); +assign Fdiv = (~p & (op == 15)); +assign Ldr = ((p & ~q) & ~u); +assign Str = ((p & ~q) & u); +assign Br = (p & q); +always @ (posedge clk) begin PC <= pcmux; +IR <= stall ? IR : codebus; +N <= regwr ? regmux[31] : N; +Z <= regwr ? (regmux == 0) : Z; +C <= Add ? (((sb & sc) | ((~sa & ~sb) & sc)) | (((~sa & sb) & ~sc) & sa)) : Sub ? (((~sb & sc) | ((sa & ~sb) & ~sc)) | ((sa & sb) & sc)) : C; +OV <= Add ? (((sa & ~sb) & ~sc) | ((~sa & sb) & sc)) : Sub ? (((sa & ~sb) & sc) | ((~sa & sb) & ~sc)) : OV; +stall1 <= stallX ? stall1 : stallL; +PMsel <= (~rst | (pcmux[21:12] == 10'h3FF)); +R[ira0] <= regwr ? regmux : A; +H <= Mul ? product[63:32] : Div ? remainder : H; +end +endmodule diff --git a/src/voc07R/CompatTexts.Mod b/src/voc07R/CompatTexts.Mod index 62b9073a..8e8b45ac 100644 --- a/src/voc07R/CompatTexts.Mod +++ b/src/voc07R/CompatTexts.Mod @@ -1,585 +1,585 @@ -MODULE CompatTexts; (*JG 21.11.90 / NW 11.7.90 / 24.12.95 / 22.11.10 / 26.3.2014*) - IMPORT Files := CompatFiles, Fonts; - - TYPE INTEGER = LONGINT; (* voc adaptation by noch *) - BYTE = CHAR; - - CONST (*scanner symbol classes*) - Inval* = 0; (*invalid symbol*) - Name* = 1; (*name s (length len)*) - String* = 2; (*literal string s (length len)*) - Int* = 3; (*integer i (decimal or hexadecimal)*) - Real* = 4; (*real number x*) - Char* = 6; (*special character c*) - - (* TextBlock = TextTag "1" offset run {run} "0" len {AsciiCode}. - run = fnt [name] col voff len. *) - - TAB = 9X; CR = 0DX; maxD = 9; - TextTag = 0F1X; - replace* = 0; insert* = 1; delete* = 2; unmark* = 3; (*op-codes*) - - TYPE Piece = POINTER TO PieceDesc; - PieceDesc = RECORD - f: Files.File; - off, len: LONGINT; - fnt: Fonts.Font; - col, voff: INTEGER; - prev, next: Piece - END; - - Text* = POINTER TO TextDesc; - Notifier* = PROCEDURE (T: Text; op: INTEGER; beg, end: LONGINT); - TextDesc* = RECORD - len*: LONGINT; - changed*: BOOLEAN; - notify*: Notifier; - trailer: Piece; - pce: Piece; (*cache*) - org: LONGINT; (*cache*) - END; - - Reader* = RECORD - eot*: BOOLEAN; - fnt*: Fonts.Font; - col*, voff*: INTEGER; - ref: Piece; - org: LONGINT; - off: LONGINT; - rider: Files.Rider - END; - - Scanner* = RECORD (Reader) - nextCh*: CHAR; - line*, class*: INTEGER; - i*: LONGINT; - x*: REAL; - y*: LONGREAL; - c*: CHAR; - len*: INTEGER; - s*: ARRAY 32 OF CHAR - END; - - Buffer* = POINTER TO BufDesc; - BufDesc* = RECORD - len*: LONGINT; - header, last: Piece - END; - - Writer* = RECORD - buf*: Buffer; - fnt*: Fonts.Font; - col*, voff*: INTEGER; - rider: Files.Rider - END; - - VAR TrailerFile: Files.File; - - (* voc adaptation by noch *) - PROCEDURE FLOOR(x : REAL): INTEGER; - BEGIN - RETURN ENTIER(x) - END FLOOR; - - PROCEDURE LSL (x, n : INTEGER): INTEGER; - BEGIN - RETURN ASH(x, n); - END LSL; - - PROCEDURE ASR (x, n : INTEGER): INTEGER; - BEGIN - RETURN ASH(x, n); - END ASR; - - - (* -------------------- Filing ------------------------*) - - PROCEDURE Trailer(): Piece; - VAR Q: Piece; - BEGIN NEW(Q); - Q.f := TrailerFile; Q.off := -1; Q.len := 1; Q.fnt := NIL; Q.col := 0; Q.voff := 0; RETURN Q - END Trailer; - - PROCEDURE Load* (VAR R: Files.Rider; T: Text); - VAR Q, q, p: Piece; - off: LONGINT; - N, fno: INTEGER; bt: BYTE; - f: Files.File; - FName: ARRAY 32 OF CHAR; - Dict: ARRAY 32 OF Fonts.Font; - BEGIN f := Files.Base(R); N := 1; Q := Trailer(); p := Q; - Files.ReadInt(R, off); Files.ReadByte(R, bt); - (*fno := bt;*) - fno := ORD(bt); (* voc adaptation by noch *) - WHILE fno # 0 DO - IF fno = N THEN - Files.ReadString(R, FName); - Dict[N] := Fonts.This(FName); INC(N) - END; - NEW(q); q.fnt := Dict[fno]; - Files.ReadByte(R, bt); - (*q.col := bt;*) - q.col := ORD(bt); (* voc adaptation by noch *) - Files.ReadByte(R, bt); - (*q.voff := ASR(LSL(bt, -24), 24);*) - q.voff := ASR(LSL(ORD(bt), -24), 24); (* voc adaptation by noch *) - Files.ReadInt(R, q.len); - Files.ReadByte(R, bt); - (*fno := bt;*) - fno := ORD(bt); (* voc adaptation by noch *) - q.f := f; q.off := off; off := off + q.len; - p.next := q; q.prev := p; p := q - END; - p.next := Q; Q.prev := p; - T.trailer := Q; Files.ReadInt(R, T.len); (*Files.Set(R, f, Files.Pos(R) + T.len)*) - END Load; - - PROCEDURE Open* (T: Text; name: ARRAY OF CHAR); - VAR f: Files.File; R: Files.Rider; Q, q: Piece; - tag: CHAR; len: LONGINT; - BEGIN f := Files.Old(name); - IF f # NIL THEN - Files.Set(R, f, 0); Files.Read(R, tag); - IF tag = TextTag THEN Load(R, T) - ELSE (*Ascii file*) - len := Files.Length(f); Q := Trailer(); - NEW(q); q.fnt := Fonts.Default; q.col := 1; q.voff := 0; q.f := f; q.off := 0; q.len := len; - Q.next := q; q.prev := Q; q.next := Q; Q.prev := q; T.trailer := Q; T.len := len - END - ELSE (*create new text*) - Q := Trailer(); Q.next := Q; Q.prev := Q; T.trailer := Q; T.len := 0 - END ; - T.changed := FALSE; T.org := -1; T.pce := T.trailer (*init cache*) - END Open; - - PROCEDURE Store* (VAR W: Files.Rider; T: Text); - VAR p, q: Piece; - R: Files.Rider; - off, rlen, pos: LONGINT; - N, n: INTEGER; - ch: CHAR; - Dict: ARRAY 32, 32 OF CHAR; - BEGIN pos := Files.Pos(W); Files.WriteInt(W, 0); (*place holder*) - N := 1; p := T.trailer.next; - WHILE p # T.trailer DO - rlen := p.len; q := p.next; - WHILE (q # T.trailer) & (q.fnt = p.fnt) & (q.col = p.col) & (q.voff = p.voff) DO - rlen := rlen + q.len; q := q.next - END; - (*Dict[N] := p.fnt.name;*) - IF p.fnt # NIL THEN COPY(p.fnt.name, Dict[N]) END; (* voc adaptation by noch *) - n := 1; - IF p.fnt # NIL THEN (* voc adaptation by noch *) - WHILE Dict[n] # p.fnt.name DO INC(n) END; - END; - (*Files.WriteByte(W, n);*) - Files.WriteByte(W, SHORT(SHORT(n))); (* voc adaptation by noch *) - IF p.fnt # NIL THEN (* voc adaptation by noch *) - IF n = N THEN Files.WriteString(W, p.fnt.name); INC(N) END; - END; - (*Files.WriteByte(W, p.col);*) - Files.WriteByte(W, SHORT(SHORT(p.col))); (* voc adaptation by noch *) - (*Files.WriteByte(W, p.voff);*) - Files.WriteByte(W, SHORT(SHORT(p.voff))); (* voc adaptation by noch *) - Files.WriteInt(W, rlen); - p := q - END; - Files.WriteByte(W, 0); Files.WriteInt(W, T.len); - off := Files.Pos(W); p := T.trailer.next; - WHILE p # T.trailer DO - rlen := p.len; Files.Set(R, p.f, p.off); - WHILE rlen > 0 DO Files.Read(R, ch); Files.Write(W, ch); DEC(rlen) END ; - p := p.next - END ; - Files.Set(W, Files.Base(W), pos); Files.WriteInt(W, off); (*fixup*) - T.changed := FALSE; - IF T.notify # NIL THEN T.notify(T, unmark, 0, 0) END - END Store; - - PROCEDURE Close*(T: Text; name: ARRAY OF CHAR); - VAR f: Files.File; w: Files.Rider; - BEGIN f := Files.New(name); Files.Set(w, f, 0); - Files.Write(w, TextTag); Store(w, T); Files.Register(f) - END Close; - - (* -------------------- Editing ----------------------- *) - - PROCEDURE OpenBuf* (B: Buffer); - BEGIN NEW(B.header); (*null piece*) - B.last := B.header; B.len := 0 - END OpenBuf; - - PROCEDURE FindPiece (T: Text; pos: LONGINT; VAR org: LONGINT; VAR pce: Piece); - VAR p: Piece; porg: LONGINT; - BEGIN p := T.pce; porg := T.org; - IF pos >= porg THEN - WHILE pos >= porg + p.len DO INC(porg, p.len); p := p.next END - ELSE p := p.prev; DEC(porg, p.len); - WHILE pos < porg DO p := p.prev; DEC(porg, p.len) END - END ; - T.pce := p; T.org := porg; (*update cache*) - pce := p; org := porg - END FindPiece; - - PROCEDURE SplitPiece (p: Piece; off: LONGINT; VAR pr: Piece); - VAR q: Piece; - BEGIN - IF off > 0 THEN NEW(q); - q.fnt := p.fnt; q.col := p.col; q.voff := p.voff; - q.len := p.len - off; - q.f := p.f; q.off := p.off + off; - p.len := off; - q.next := p.next; p.next := q; - q.prev := p; q.next.prev := q; - pr := q - ELSE pr := p - END - END SplitPiece; - - PROCEDURE Save* (T: Text; beg, end: LONGINT; B: Buffer); - VAR p, q, qb, qe: Piece; org: LONGINT; - BEGIN - IF end > T.len THEN end := T.len END; - FindPiece(T, beg, org, p); - NEW(qb); qb^ := p^; - qb.len := qb.len - (beg - org); - qb.off := qb.off + (beg - org); - qe := qb; - WHILE end > org + p.len DO - org := org + p.len; p := p.next; - NEW(q); q^ := p^; qe.next := q; q.prev := qe; qe := q - END; - qe.next := NIL; qe.len := qe.len - (org + p.len - end); - B.last.next := qb; qb.prev := B.last; B.last := qe; - B.len := B.len + (end - beg) - END Save; - - PROCEDURE Copy* (SB, DB: Buffer); - VAR Q, q, p: Piece; - BEGIN p := SB.header; Q := DB.last; - WHILE p # SB.last DO p := p.next; - NEW(q); q^ := p^; Q.next := q; q.prev := Q; Q := q - END; - DB.last := Q; DB.len := DB.len + SB.len - END Copy; - - PROCEDURE Insert* (T: Text; pos: LONGINT; B: Buffer); - VAR pl, pr, p, qb, qe: Piece; org, end: LONGINT; - BEGIN - FindPiece(T, pos, org, p); SplitPiece(p, pos - org, pr); - IF T.org >= org THEN T.org := org - p.prev.len; T.pce := p.prev END ; - pl := pr.prev; qb := B.header.next; - IF (qb # NIL) & (qb.f = pl.f) & (qb.off = pl.off + pl.len) - & (qb.fnt = pl.fnt) & (qb.col = pl.col) & (qb.voff = pl.voff) THEN - pl.len := pl.len + qb.len; qb := qb.next - END; - IF qb # NIL THEN qe := B.last; - qb.prev := pl; pl.next := qb; qe.next := pr; pr.prev := qe - END; - T.len := T.len + B.len; end := pos + B.len; - B.last := B.header; B.last.next := NIL; B.len := 0; - T.changed := TRUE; - (*T.notify(T, insert, pos, end)*) - IF T.notify # NIL THEN - T.notify(T, insert, pos, end) - END(* voc adaptation by noch *) - END Insert; - - PROCEDURE Append* (T: Text; B: Buffer); - BEGIN Insert(T, T.len, B) - END Append; - - PROCEDURE Delete* (T: Text; beg, end: LONGINT; B: Buffer); - VAR pb, pe, pbr, per: Piece; orgb, orge: LONGINT; - BEGIN - IF end > T.len THEN end := T.len END; - FindPiece(T, beg, orgb, pb); SplitPiece(pb, beg - orgb, pbr); - FindPiece(T, end, orge, pe); - SplitPiece(pe, end - orge, per); - IF T.org >= orgb THEN (*adjust cache*) - T.org := orgb - pb.prev.len; T.pce := pb.prev - END; - B.header.next := pbr; B.last := per.prev; - B.last.next := NIL; B.len := end - beg; - per.prev := pbr.prev; pbr.prev.next := per; - T.len := T.len - B.len; - T.changed := TRUE; - IF T.notify # NIL THEN (* noch *) - T.notify(T, delete, beg, end) - END - END Delete; - - PROCEDURE ChangeLooks* (T: Text; beg, end: LONGINT; sel: SET; fnt: Fonts.Font; col, voff: INTEGER); - VAR pb, pe, p: Piece; org: LONGINT; - BEGIN - IF end > T.len THEN end := T.len END; - FindPiece(T, beg, org, p); SplitPiece(p, beg - org, pb); - FindPiece(T, end, org, p); SplitPiece(p, end - org, pe); - p := pb; - REPEAT - IF 0 IN sel THEN p.fnt := fnt END; - IF 1 IN sel THEN p.col := col END; - IF 2 IN sel THEN p.voff := voff END; - p := p.next - UNTIL p = pe; - T.changed := TRUE; - IF T.notify # NIL THEN (* noch *) - T.notify(T, replace, beg, end) - END - END ChangeLooks; - - PROCEDURE Attributes*(T: Text; pos: LONGINT; VAR fnt: Fonts.Font; VAR col, voff: INTEGER); - VAR p: Piece; org: LONGINT; - BEGIN FindPiece(T, pos, org, p); fnt := p.fnt; col := p.col; voff := p.voff - END Attributes; - - (* ------------------ Access: Readers ------------------------- *) - - PROCEDURE OpenReader* (VAR R: Reader; T: Text; pos: LONGINT); - VAR p: Piece; org: LONGINT; - BEGIN FindPiece(T, pos, org, p); - R.ref := p; R.org := org; R.off := pos - org; - Files.Set(R.rider, p.f, p.off + R.off); R.eot := FALSE - END OpenReader; - - PROCEDURE Read* (VAR R: Reader; VAR ch: CHAR); - BEGIN Files.Read(R.rider, ch); - R.fnt := R.ref.fnt; R.col := R.ref.col; R.voff := R.ref.voff; - INC(R.off); - IF R.off = R.ref.len THEN - IF R.ref.f = TrailerFile THEN R.eot := TRUE END; - R.org := R.org + R.off; R.off := 0; - R.ref := R.ref.next; R.org := R.org + R.off; R.off := 0; - Files.Set(R.rider, R.ref.f, R.ref.off) - END - END Read; - - PROCEDURE Pos* (VAR R: Reader): LONGINT; - BEGIN RETURN R.org + R.off - END Pos; - - (* ------------------ Access: Scanners (NW) ------------------------- *) - - PROCEDURE OpenScanner* (VAR S: Scanner; T: Text; pos: LONGINT); - BEGIN OpenReader(S, T, pos); S.line := 0; S.nextCh := " " - END OpenScanner; - - (*floating point formats: - x = 1.m * 2^(e-127) bit 0: sign, bits 1- 8: e, bits 9-31: m - x = 1.m * 2^(e-1023) bit 0: sign, bits 1-11: e, bits 12-63: m *) - - PROCEDURE Ten(n: INTEGER): REAL; - VAR t, p: REAL; - BEGIN t := 1.0; p := 10.0; (*compute 10^n *) - WHILE n > 0 DO - IF ODD(n) THEN t := p * t END ; - p := p*p; n := n DIV 2 - END ; - RETURN t - END Ten; - - PROCEDURE Scan* (VAR S: Scanner); - CONST maxExp = 38; maxM = 16777216; (*2^24*) - VAR ch, term: CHAR; - neg, negE, hex: BOOLEAN; - i, j, h, d, e, n, s: INTEGER; - k: LONGINT; - x: REAL; - BEGIN ch := S.nextCh; i := 0; - WHILE (ch = " ") OR (ch = TAB) OR (ch = CR) DO - IF ch = CR THEN INC(S.line) END ; - Read(S, ch) - END ; - IF ("A" <= ch) & (ch <= "Z") OR ("a" <= ch) & (ch <= "z") THEN (*name*) - REPEAT S.s[i] := ch; INC(i); Read(S, ch) - UNTIL ((ch < "0") & (ch # ".") OR ("9" < ch) & (ch < "A") OR ("Z" < ch) & (ch < "a") OR ("z" < ch)) OR (i = 31); - S.s[i] := 0X; S.len := i; S.class := Name - ELSIF ch = 22X THEN (*string*) - Read(S, ch); - WHILE (ch # 22X) & (ch >= " ") & (i # 31) DO S.s[i] := ch; INC(i); Read(S, ch) END; - S.s[i] := 0X; S.len := i+1; Read(S, ch); S.class := String - ELSE hex := FALSE; - IF ch = "-" THEN neg := TRUE; Read(S, ch) ELSE neg := FALSE END ; - IF ("0" <= ch) & (ch <= "9") THEN (*number*) - n := ORD(ch) - 30H; h := n; Read(S, ch); - WHILE ("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F") DO - IF ch <= "9" THEN d := ORD(ch) - 30H ELSE d := ORD(ch) - 37H; hex := TRUE END ; - n := 10*n + d; h := 10H*h + d; Read(S, ch) - END ; - IF ch = "H" THEN (*hex integer*) Read(S, ch); S.i := h; S.class := Int (*neg?*) - ELSIF ch = "." THEN (*real number*) - Read(S, ch); x := 0.0; e := 0; j := 0; - WHILE ("0" <= ch) & (ch <= "9") DO (*fraction*) - h := 10*n + (ORD(ch) - 30H); - IF h < maxM THEN n := h; INC(j) END ; - Read(S, ch) - END ; - IF ch = "E" THEN (*scale factor*) - s := 0; Read(S, ch); - IF ch = "-" THEN negE := TRUE; Read(S, ch) - ELSE negE := FALSE; - IF ch = "+" THEN Read(S, ch) END - END ; - WHILE ("0" <= ch) & (ch <= "9") DO - s := s*10 + ORD(ch) - 30H; Read(S, ch) - END ; - IF negE THEN DEC(e, s) ELSE INC(e, s) END ; - END ; - (*x := FLT(n);*) - x := n; (* voc adaptation by noch *) - DEC(e, j); - IF e < 0 THEN - IF e >= -maxExp THEN x := x / Ten(-e) ELSE x := 0.0 END - ELSIF e > 0 THEN - IF e <= maxExp THEN x := Ten(e) * x ELSE x := 0.0 END - END ; - IF neg THEN S.x := -x ELSE S.x := x END ; - IF hex THEN S.class := 0 ELSE S.class := Real END - ELSE (*decimal integer*) - IF neg THEN S.i := -n ELSE S.i := n END; - IF hex THEN S.class := Inval ELSE S.class := Int END - END - ELSE (*spectal character*) S.class := Char; - IF neg THEN S.c := "-" ELSE S.c := ch; Read(S, ch) END - END - END ; - S.nextCh := ch - END Scan; - - (* --------------- Access: Writers (NW) ------------------ *) - - PROCEDURE OpenWriter* (VAR W: Writer); - BEGIN NEW(W.buf); - OpenBuf(W.buf); W.fnt := Fonts.Default; W.col := 15; W.voff := 0; - Files.Set(W.rider, Files.New(""), 0) - END OpenWriter; - - PROCEDURE SetFont* (VAR W: Writer; fnt: Fonts.Font); - BEGIN W.fnt := fnt - END SetFont; - - PROCEDURE SetColor* (VAR W: Writer; col: INTEGER); - BEGIN W.col := col - END SetColor; - - PROCEDURE SetOffset* (VAR W: Writer; voff: INTEGER); - BEGIN W.voff := voff - END SetOffset; - - PROCEDURE Write* (VAR W: Writer; ch: CHAR); - VAR p: Piece; - BEGIN - IF (W.buf.last.fnt # W.fnt) OR (W.buf.last.col # W.col) OR (W.buf.last.voff # W.voff) THEN - NEW(p); p.f := Files.Base(W.rider); p.off := Files.Pos(W.rider); p.len := 0; - p.fnt := W.fnt; p.col := W.col; p.voff:= W.voff; - p.next := NIL; W.buf.last.next := p; - p.prev := W.buf.last; W.buf.last := p - END; - Files.Write(W.rider, ch); - INC(W.buf.last.len); INC(W.buf.len) - END Write; - - PROCEDURE WriteLn* (VAR W: Writer); - BEGIN Write(W, CR) - END WriteLn; - - PROCEDURE WriteString* (VAR W: Writer; s: ARRAY OF CHAR); - VAR i: INTEGER; - BEGIN i := 0; - WHILE s[i] >= " " DO Write(W, s[i]); INC(i) END - END WriteString; - - PROCEDURE WriteInt* (VAR W: Writer; x, n: LONGINT); - VAR i: INTEGER; x0: LONGINT; - a: ARRAY 10 OF CHAR; - BEGIN - (*IF ROR(x, 31) = 1 THEN WriteString(W, " -2147483648") - ELSE*) i := 0; (* voc adaptation by noch *) - IF x < 0 THEN DEC(n); x0 := -x ELSE x0 := x END; - REPEAT - a[i] := CHR(x0 MOD 10 + 30H); x0 := x0 DIV 10; INC(i) - UNTIL x0 = 0; - WHILE n > i DO Write(W, " "); DEC(n) END; - IF x < 0 THEN Write(W, "-") END; - REPEAT DEC(i); Write(W, a[i]) UNTIL i = 0 - (*END*) - END WriteInt; - - PROCEDURE WriteHex* (VAR W: Writer; x: LONGINT); - VAR i: INTEGER; y: LONGINT; - a: ARRAY 10 OF CHAR; - BEGIN i := 0; Write(W, " "); - REPEAT y := x MOD 10H; - IF y < 10 THEN a[i] := CHR(y + 30H) ELSE a[i] := CHR(y + 37H) END; - x := x DIV 10H; INC(i) - UNTIL i = 8; - REPEAT DEC(i); Write(W, a[i]) UNTIL i = 0 - END WriteHex; -(* commented out because it's not necessary to compile OR compiler; -- noch - PROCEDURE WriteReal* (VAR W: Writer; x: REAL; n: INTEGER); - VAR e, i, m: INTEGER; x0: REAL; neg: BOOLEAN; - d: ARRAY 16 OF CHAR; - BEGIN - IF x = 0.0 THEN - WriteString(W, " 0.0"); i := 5; - WHILE i < n DO Write(W, " "); INC(i) END - ELSE - IF x < 0.0 THEN x := -x; neg := TRUE ELSE neg := FALSE END ; - x0 := x; UNPK(x0, e); - IF e = 255 THEN WriteString(W, " NaN") - ELSE - REPEAT Write(W, " "); DEC(n) UNTIL n <= 14; - IF neg THEN Write(W, "-") ELSE Write(W, " ") END ; - e := e * 77 DIV 256 - 6; - IF e >= 0 THEN x := x / Ten(e) ELSE x := x * Ten(-e) END ; - IF x >= 10.0E6 THEN x := 0.1*x; INC(e) END ; - m := FLOOR(x + 0.5); i := 0; - IF x >= 10.0E6 THEN x := 0.1*x; INC(e) END ; - REPEAT d[i] := CHR(m MOD 10 + 30H); m := m DIV 10; INC(i) UNTIL m = 0; - DEC(i); Write(W, d[i]); Write(W, "."); - IF i < n-6 THEN n := 0 ELSE n := 13-n END ; - WHILE i > n DO DEC(i); Write(W, d[i]) END ; - Write(W, "E"); INC(e, 6); - IF e < 0 THEN Write(W, "-"); e := -e ELSE Write(W, "+") END ; - Write(W, CHR(e DIV 10 + 30H)); Write(W, CHR(e MOD 10 + 30H)) - END - END - END WriteReal; - *) - PROCEDURE WriteRealFix* (VAR W: Writer; x: REAL; n, k: INTEGER); - VAR i, m: INTEGER; neg: BOOLEAN; - d: ARRAY 12 OF CHAR; - BEGIN - IF x = 0.0 THEN WriteString(W, " 0") - ELSE - IF x < 0.0 THEN x := -x; neg := TRUE ELSE neg := FALSE END ; - IF k > 7 THEN k := 7 END ; - x := Ten(k) * x; m := FLOOR(x + 0.5); - i := 0; - REPEAT d[i] := CHR(m MOD 10 + 30H); m := m DIV 10; INC(i) UNTIL m = 0; - REPEAT Write(W, " "); DEC(n) UNTIL n <= i+3; - IF neg THEN Write(W, "-"); DEC(n) ELSE Write(W, " ") END ; - WHILE i > k DO DEC(i); Write(W, d[i]) END ; - Write(W, "."); - WHILE k > i DO DEC(k); Write(W, "0") END ; - WHILE i > 0 DO DEC(i); Write(W, d[i]) END - END - END WriteRealFix; - - PROCEDURE WritePair(VAR W: Writer; ch: CHAR; x: LONGINT); - BEGIN Write(W, ch); - Write(W, CHR(x DIV 10 + 30H)); Write(W, CHR(x MOD 10 + 30H)) - END WritePair; - - PROCEDURE WriteClock* (VAR W: Writer; d: LONGINT); - BEGIN - WritePair(W, " ", d DIV 20000H MOD 20H); (*day*) - WritePair(W, ".", d DIV 400000H MOD 10H); (*month*) - WritePair(W, ".", d DIV 4000000H MOD 40H); (*year*) - WritePair(W, " ", d DIV 1000H MOD 20H); (*hour*) - WritePair(W, ":", d DIV 40H MOD 40H); (*min*) - WritePair(W, ":", d MOD 40H) (*sec*) - END WriteClock; - -BEGIN TrailerFile := Files.New("") -END CompatTexts. +MODULE CompatTexts; (*JG 21.11.90 / NW 11.7.90 / 24.12.95 / 22.11.10 / 26.3.2014*) + IMPORT Files := CompatFiles, Fonts; + + TYPE INTEGER = LONGINT; (* voc adaptation by noch *) + BYTE = CHAR; + + CONST (*scanner symbol classes*) + Inval* = 0; (*invalid symbol*) + Name* = 1; (*name s (length len)*) + String* = 2; (*literal string s (length len)*) + Int* = 3; (*integer i (decimal or hexadecimal)*) + Real* = 4; (*real number x*) + Char* = 6; (*special character c*) + + (* TextBlock = TextTag "1" offset run {run} "0" len {AsciiCode}. + run = fnt [name] col voff len. *) + + TAB = 9X; CR = 0DX; maxD = 9; + TextTag = 0F1X; + replace* = 0; insert* = 1; delete* = 2; unmark* = 3; (*op-codes*) + + TYPE Piece = POINTER TO PieceDesc; + PieceDesc = RECORD + f: Files.File; + off, len: LONGINT; + fnt: Fonts.Font; + col, voff: INTEGER; + prev, next: Piece + END; + + Text* = POINTER TO TextDesc; + Notifier* = PROCEDURE (T: Text; op: INTEGER; beg, end: LONGINT); + TextDesc* = RECORD + len*: LONGINT; + changed*: BOOLEAN; + notify*: Notifier; + trailer: Piece; + pce: Piece; (*cache*) + org: LONGINT; (*cache*) + END; + + Reader* = RECORD + eot*: BOOLEAN; + fnt*: Fonts.Font; + col*, voff*: INTEGER; + ref: Piece; + org: LONGINT; + off: LONGINT; + rider: Files.Rider + END; + + Scanner* = RECORD (Reader) + nextCh*: CHAR; + line*, class*: INTEGER; + i*: LONGINT; + x*: REAL; + y*: LONGREAL; + c*: CHAR; + len*: INTEGER; + s*: ARRAY 32 OF CHAR + END; + + Buffer* = POINTER TO BufDesc; + BufDesc* = RECORD + len*: LONGINT; + header, last: Piece + END; + + Writer* = RECORD + buf*: Buffer; + fnt*: Fonts.Font; + col*, voff*: INTEGER; + rider: Files.Rider + END; + + VAR TrailerFile: Files.File; + + (* voc adaptation by noch *) + PROCEDURE FLOOR(x : REAL): INTEGER; + BEGIN + RETURN ENTIER(x) + END FLOOR; + + PROCEDURE LSL (x, n : INTEGER): INTEGER; + BEGIN + RETURN ASH(x, n); + END LSL; + + PROCEDURE ASR (x, n : INTEGER): INTEGER; + BEGIN + RETURN ASH(x, n); + END ASR; + + + (* -------------------- Filing ------------------------*) + + PROCEDURE Trailer(): Piece; + VAR Q: Piece; + BEGIN NEW(Q); + Q.f := TrailerFile; Q.off := -1; Q.len := 1; Q.fnt := NIL; Q.col := 0; Q.voff := 0; RETURN Q + END Trailer; + + PROCEDURE Load* (VAR R: Files.Rider; T: Text); + VAR Q, q, p: Piece; + off: LONGINT; + N, fno: INTEGER; bt: BYTE; + f: Files.File; + FName: ARRAY 32 OF CHAR; + Dict: ARRAY 32 OF Fonts.Font; + BEGIN f := Files.Base(R); N := 1; Q := Trailer(); p := Q; + Files.ReadInt(R, off); Files.ReadByte(R, bt); + (*fno := bt;*) + fno := ORD(bt); (* voc adaptation by noch *) + WHILE fno # 0 DO + IF fno = N THEN + Files.ReadString(R, FName); + Dict[N] := Fonts.This(FName); INC(N) + END; + NEW(q); q.fnt := Dict[fno]; + Files.ReadByte(R, bt); + (*q.col := bt;*) + q.col := ORD(bt); (* voc adaptation by noch *) + Files.ReadByte(R, bt); + (*q.voff := ASR(LSL(bt, -24), 24);*) + q.voff := ASR(LSL(ORD(bt), -24), 24); (* voc adaptation by noch *) + Files.ReadInt(R, q.len); + Files.ReadByte(R, bt); + (*fno := bt;*) + fno := ORD(bt); (* voc adaptation by noch *) + q.f := f; q.off := off; off := off + q.len; + p.next := q; q.prev := p; p := q + END; + p.next := Q; Q.prev := p; + T.trailer := Q; Files.ReadInt(R, T.len); (*Files.Set(R, f, Files.Pos(R) + T.len)*) + END Load; + + PROCEDURE Open* (T: Text; name: ARRAY OF CHAR); + VAR f: Files.File; R: Files.Rider; Q, q: Piece; + tag: CHAR; len: LONGINT; + BEGIN f := Files.Old(name); + IF f # NIL THEN + Files.Set(R, f, 0); Files.Read(R, tag); + IF tag = TextTag THEN Load(R, T) + ELSE (*Ascii file*) + len := Files.Length(f); Q := Trailer(); + NEW(q); q.fnt := Fonts.Default; q.col := 1; q.voff := 0; q.f := f; q.off := 0; q.len := len; + Q.next := q; q.prev := Q; q.next := Q; Q.prev := q; T.trailer := Q; T.len := len + END + ELSE (*create new text*) + Q := Trailer(); Q.next := Q; Q.prev := Q; T.trailer := Q; T.len := 0 + END ; + T.changed := FALSE; T.org := -1; T.pce := T.trailer (*init cache*) + END Open; + + PROCEDURE Store* (VAR W: Files.Rider; T: Text); + VAR p, q: Piece; + R: Files.Rider; + off, rlen, pos: LONGINT; + N, n: INTEGER; + ch: CHAR; + Dict: ARRAY 32, 32 OF CHAR; + BEGIN pos := Files.Pos(W); Files.WriteInt(W, 0); (*place holder*) + N := 1; p := T.trailer.next; + WHILE p # T.trailer DO + rlen := p.len; q := p.next; + WHILE (q # T.trailer) & (q.fnt = p.fnt) & (q.col = p.col) & (q.voff = p.voff) DO + rlen := rlen + q.len; q := q.next + END; + (*Dict[N] := p.fnt.name;*) + IF p.fnt # NIL THEN COPY(p.fnt.name, Dict[N]) END; (* voc adaptation by noch *) + n := 1; + IF p.fnt # NIL THEN (* voc adaptation by noch *) + WHILE Dict[n] # p.fnt.name DO INC(n) END; + END; + (*Files.WriteByte(W, n);*) + Files.WriteByte(W, SHORT(SHORT(n))); (* voc adaptation by noch *) + IF p.fnt # NIL THEN (* voc adaptation by noch *) + IF n = N THEN Files.WriteString(W, p.fnt.name); INC(N) END; + END; + (*Files.WriteByte(W, p.col);*) + Files.WriteByte(W, SHORT(SHORT(p.col))); (* voc adaptation by noch *) + (*Files.WriteByte(W, p.voff);*) + Files.WriteByte(W, SHORT(SHORT(p.voff))); (* voc adaptation by noch *) + Files.WriteInt(W, rlen); + p := q + END; + Files.WriteByte(W, 0); Files.WriteInt(W, T.len); + off := Files.Pos(W); p := T.trailer.next; + WHILE p # T.trailer DO + rlen := p.len; Files.Set(R, p.f, p.off); + WHILE rlen > 0 DO Files.Read(R, ch); Files.Write(W, ch); DEC(rlen) END ; + p := p.next + END ; + Files.Set(W, Files.Base(W), pos); Files.WriteInt(W, off); (*fixup*) + T.changed := FALSE; + IF T.notify # NIL THEN T.notify(T, unmark, 0, 0) END + END Store; + + PROCEDURE Close*(T: Text; name: ARRAY OF CHAR); + VAR f: Files.File; w: Files.Rider; + BEGIN f := Files.New(name); Files.Set(w, f, 0); + Files.Write(w, TextTag); Store(w, T); Files.Register(f) + END Close; + + (* -------------------- Editing ----------------------- *) + + PROCEDURE OpenBuf* (B: Buffer); + BEGIN NEW(B.header); (*null piece*) + B.last := B.header; B.len := 0 + END OpenBuf; + + PROCEDURE FindPiece (T: Text; pos: LONGINT; VAR org: LONGINT; VAR pce: Piece); + VAR p: Piece; porg: LONGINT; + BEGIN p := T.pce; porg := T.org; + IF pos >= porg THEN + WHILE pos >= porg + p.len DO INC(porg, p.len); p := p.next END + ELSE p := p.prev; DEC(porg, p.len); + WHILE pos < porg DO p := p.prev; DEC(porg, p.len) END + END ; + T.pce := p; T.org := porg; (*update cache*) + pce := p; org := porg + END FindPiece; + + PROCEDURE SplitPiece (p: Piece; off: LONGINT; VAR pr: Piece); + VAR q: Piece; + BEGIN + IF off > 0 THEN NEW(q); + q.fnt := p.fnt; q.col := p.col; q.voff := p.voff; + q.len := p.len - off; + q.f := p.f; q.off := p.off + off; + p.len := off; + q.next := p.next; p.next := q; + q.prev := p; q.next.prev := q; + pr := q + ELSE pr := p + END + END SplitPiece; + + PROCEDURE Save* (T: Text; beg, end: LONGINT; B: Buffer); + VAR p, q, qb, qe: Piece; org: LONGINT; + BEGIN + IF end > T.len THEN end := T.len END; + FindPiece(T, beg, org, p); + NEW(qb); qb^ := p^; + qb.len := qb.len - (beg - org); + qb.off := qb.off + (beg - org); + qe := qb; + WHILE end > org + p.len DO + org := org + p.len; p := p.next; + NEW(q); q^ := p^; qe.next := q; q.prev := qe; qe := q + END; + qe.next := NIL; qe.len := qe.len - (org + p.len - end); + B.last.next := qb; qb.prev := B.last; B.last := qe; + B.len := B.len + (end - beg) + END Save; + + PROCEDURE Copy* (SB, DB: Buffer); + VAR Q, q, p: Piece; + BEGIN p := SB.header; Q := DB.last; + WHILE p # SB.last DO p := p.next; + NEW(q); q^ := p^; Q.next := q; q.prev := Q; Q := q + END; + DB.last := Q; DB.len := DB.len + SB.len + END Copy; + + PROCEDURE Insert* (T: Text; pos: LONGINT; B: Buffer); + VAR pl, pr, p, qb, qe: Piece; org, end: LONGINT; + BEGIN + FindPiece(T, pos, org, p); SplitPiece(p, pos - org, pr); + IF T.org >= org THEN T.org := org - p.prev.len; T.pce := p.prev END ; + pl := pr.prev; qb := B.header.next; + IF (qb # NIL) & (qb.f = pl.f) & (qb.off = pl.off + pl.len) + & (qb.fnt = pl.fnt) & (qb.col = pl.col) & (qb.voff = pl.voff) THEN + pl.len := pl.len + qb.len; qb := qb.next + END; + IF qb # NIL THEN qe := B.last; + qb.prev := pl; pl.next := qb; qe.next := pr; pr.prev := qe + END; + T.len := T.len + B.len; end := pos + B.len; + B.last := B.header; B.last.next := NIL; B.len := 0; + T.changed := TRUE; + (*T.notify(T, insert, pos, end)*) + IF T.notify # NIL THEN + T.notify(T, insert, pos, end) + END(* voc adaptation by noch *) + END Insert; + + PROCEDURE Append* (T: Text; B: Buffer); + BEGIN Insert(T, T.len, B) + END Append; + + PROCEDURE Delete* (T: Text; beg, end: LONGINT; B: Buffer); + VAR pb, pe, pbr, per: Piece; orgb, orge: LONGINT; + BEGIN + IF end > T.len THEN end := T.len END; + FindPiece(T, beg, orgb, pb); SplitPiece(pb, beg - orgb, pbr); + FindPiece(T, end, orge, pe); + SplitPiece(pe, end - orge, per); + IF T.org >= orgb THEN (*adjust cache*) + T.org := orgb - pb.prev.len; T.pce := pb.prev + END; + B.header.next := pbr; B.last := per.prev; + B.last.next := NIL; B.len := end - beg; + per.prev := pbr.prev; pbr.prev.next := per; + T.len := T.len - B.len; + T.changed := TRUE; + IF T.notify # NIL THEN (* noch *) + T.notify(T, delete, beg, end) + END + END Delete; + + PROCEDURE ChangeLooks* (T: Text; beg, end: LONGINT; sel: SET; fnt: Fonts.Font; col, voff: INTEGER); + VAR pb, pe, p: Piece; org: LONGINT; + BEGIN + IF end > T.len THEN end := T.len END; + FindPiece(T, beg, org, p); SplitPiece(p, beg - org, pb); + FindPiece(T, end, org, p); SplitPiece(p, end - org, pe); + p := pb; + REPEAT + IF 0 IN sel THEN p.fnt := fnt END; + IF 1 IN sel THEN p.col := col END; + IF 2 IN sel THEN p.voff := voff END; + p := p.next + UNTIL p = pe; + T.changed := TRUE; + IF T.notify # NIL THEN (* noch *) + T.notify(T, replace, beg, end) + END + END ChangeLooks; + + PROCEDURE Attributes*(T: Text; pos: LONGINT; VAR fnt: Fonts.Font; VAR col, voff: INTEGER); + VAR p: Piece; org: LONGINT; + BEGIN FindPiece(T, pos, org, p); fnt := p.fnt; col := p.col; voff := p.voff + END Attributes; + + (* ------------------ Access: Readers ------------------------- *) + + PROCEDURE OpenReader* (VAR R: Reader; T: Text; pos: LONGINT); + VAR p: Piece; org: LONGINT; + BEGIN FindPiece(T, pos, org, p); + R.ref := p; R.org := org; R.off := pos - org; + Files.Set(R.rider, p.f, p.off + R.off); R.eot := FALSE + END OpenReader; + + PROCEDURE Read* (VAR R: Reader; VAR ch: CHAR); + BEGIN Files.Read(R.rider, ch); + R.fnt := R.ref.fnt; R.col := R.ref.col; R.voff := R.ref.voff; + INC(R.off); + IF R.off = R.ref.len THEN + IF R.ref.f = TrailerFile THEN R.eot := TRUE END; + R.org := R.org + R.off; R.off := 0; + R.ref := R.ref.next; R.org := R.org + R.off; R.off := 0; + Files.Set(R.rider, R.ref.f, R.ref.off) + END + END Read; + + PROCEDURE Pos* (VAR R: Reader): LONGINT; + BEGIN RETURN R.org + R.off + END Pos; + + (* ------------------ Access: Scanners (NW) ------------------------- *) + + PROCEDURE OpenScanner* (VAR S: Scanner; T: Text; pos: LONGINT); + BEGIN OpenReader(S, T, pos); S.line := 0; S.nextCh := " " + END OpenScanner; + + (*floating point formats: + x = 1.m * 2^(e-127) bit 0: sign, bits 1- 8: e, bits 9-31: m + x = 1.m * 2^(e-1023) bit 0: sign, bits 1-11: e, bits 12-63: m *) + + PROCEDURE Ten(n: INTEGER): REAL; + VAR t, p: REAL; + BEGIN t := 1.0; p := 10.0; (*compute 10^n *) + WHILE n > 0 DO + IF ODD(n) THEN t := p * t END ; + p := p*p; n := n DIV 2 + END ; + RETURN t + END Ten; + + PROCEDURE Scan* (VAR S: Scanner); + CONST maxExp = 38; maxM = 16777216; (*2^24*) + VAR ch, term: CHAR; + neg, negE, hex: BOOLEAN; + i, j, h, d, e, n, s: INTEGER; + k: LONGINT; + x: REAL; + BEGIN ch := S.nextCh; i := 0; + WHILE (ch = " ") OR (ch = TAB) OR (ch = CR) DO + IF ch = CR THEN INC(S.line) END ; + Read(S, ch) + END ; + IF ("A" <= ch) & (ch <= "Z") OR ("a" <= ch) & (ch <= "z") THEN (*name*) + REPEAT S.s[i] := ch; INC(i); Read(S, ch) + UNTIL ((ch < "0") & (ch # ".") OR ("9" < ch) & (ch < "A") OR ("Z" < ch) & (ch < "a") OR ("z" < ch)) OR (i = 31); + S.s[i] := 0X; S.len := i; S.class := Name + ELSIF ch = 22X THEN (*string*) + Read(S, ch); + WHILE (ch # 22X) & (ch >= " ") & (i # 31) DO S.s[i] := ch; INC(i); Read(S, ch) END; + S.s[i] := 0X; S.len := i+1; Read(S, ch); S.class := String + ELSE hex := FALSE; + IF ch = "-" THEN neg := TRUE; Read(S, ch) ELSE neg := FALSE END ; + IF ("0" <= ch) & (ch <= "9") THEN (*number*) + n := ORD(ch) - 30H; h := n; Read(S, ch); + WHILE ("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F") DO + IF ch <= "9" THEN d := ORD(ch) - 30H ELSE d := ORD(ch) - 37H; hex := TRUE END ; + n := 10*n + d; h := 10H*h + d; Read(S, ch) + END ; + IF ch = "H" THEN (*hex integer*) Read(S, ch); S.i := h; S.class := Int (*neg?*) + ELSIF ch = "." THEN (*real number*) + Read(S, ch); x := 0.0; e := 0; j := 0; + WHILE ("0" <= ch) & (ch <= "9") DO (*fraction*) + h := 10*n + (ORD(ch) - 30H); + IF h < maxM THEN n := h; INC(j) END ; + Read(S, ch) + END ; + IF ch = "E" THEN (*scale factor*) + s := 0; Read(S, ch); + IF ch = "-" THEN negE := TRUE; Read(S, ch) + ELSE negE := FALSE; + IF ch = "+" THEN Read(S, ch) END + END ; + WHILE ("0" <= ch) & (ch <= "9") DO + s := s*10 + ORD(ch) - 30H; Read(S, ch) + END ; + IF negE THEN DEC(e, s) ELSE INC(e, s) END ; + END ; + (*x := FLT(n);*) + x := n; (* voc adaptation by noch *) + DEC(e, j); + IF e < 0 THEN + IF e >= -maxExp THEN x := x / Ten(-e) ELSE x := 0.0 END + ELSIF e > 0 THEN + IF e <= maxExp THEN x := Ten(e) * x ELSE x := 0.0 END + END ; + IF neg THEN S.x := -x ELSE S.x := x END ; + IF hex THEN S.class := 0 ELSE S.class := Real END + ELSE (*decimal integer*) + IF neg THEN S.i := -n ELSE S.i := n END; + IF hex THEN S.class := Inval ELSE S.class := Int END + END + ELSE (*spectal character*) S.class := Char; + IF neg THEN S.c := "-" ELSE S.c := ch; Read(S, ch) END + END + END ; + S.nextCh := ch + END Scan; + + (* --------------- Access: Writers (NW) ------------------ *) + + PROCEDURE OpenWriter* (VAR W: Writer); + BEGIN NEW(W.buf); + OpenBuf(W.buf); W.fnt := Fonts.Default; W.col := 15; W.voff := 0; + Files.Set(W.rider, Files.New(""), 0) + END OpenWriter; + + PROCEDURE SetFont* (VAR W: Writer; fnt: Fonts.Font); + BEGIN W.fnt := fnt + END SetFont; + + PROCEDURE SetColor* (VAR W: Writer; col: INTEGER); + BEGIN W.col := col + END SetColor; + + PROCEDURE SetOffset* (VAR W: Writer; voff: INTEGER); + BEGIN W.voff := voff + END SetOffset; + + PROCEDURE Write* (VAR W: Writer; ch: CHAR); + VAR p: Piece; + BEGIN + IF (W.buf.last.fnt # W.fnt) OR (W.buf.last.col # W.col) OR (W.buf.last.voff # W.voff) THEN + NEW(p); p.f := Files.Base(W.rider); p.off := Files.Pos(W.rider); p.len := 0; + p.fnt := W.fnt; p.col := W.col; p.voff:= W.voff; + p.next := NIL; W.buf.last.next := p; + p.prev := W.buf.last; W.buf.last := p + END; + Files.Write(W.rider, ch); + INC(W.buf.last.len); INC(W.buf.len) + END Write; + + PROCEDURE WriteLn* (VAR W: Writer); + BEGIN Write(W, CR) + END WriteLn; + + PROCEDURE WriteString* (VAR W: Writer; s: ARRAY OF CHAR); + VAR i: INTEGER; + BEGIN i := 0; + WHILE s[i] >= " " DO Write(W, s[i]); INC(i) END + END WriteString; + + PROCEDURE WriteInt* (VAR W: Writer; x, n: LONGINT); + VAR i: INTEGER; x0: LONGINT; + a: ARRAY 10 OF CHAR; + BEGIN + (*IF ROR(x, 31) = 1 THEN WriteString(W, " -2147483648") + ELSE*) i := 0; (* voc adaptation by noch *) + IF x < 0 THEN DEC(n); x0 := -x ELSE x0 := x END; + REPEAT + a[i] := CHR(x0 MOD 10 + 30H); x0 := x0 DIV 10; INC(i) + UNTIL x0 = 0; + WHILE n > i DO Write(W, " "); DEC(n) END; + IF x < 0 THEN Write(W, "-") END; + REPEAT DEC(i); Write(W, a[i]) UNTIL i = 0 + (*END*) + END WriteInt; + + PROCEDURE WriteHex* (VAR W: Writer; x: LONGINT); + VAR i: INTEGER; y: LONGINT; + a: ARRAY 10 OF CHAR; + BEGIN i := 0; Write(W, " "); + REPEAT y := x MOD 10H; + IF y < 10 THEN a[i] := CHR(y + 30H) ELSE a[i] := CHR(y + 37H) END; + x := x DIV 10H; INC(i) + UNTIL i = 8; + REPEAT DEC(i); Write(W, a[i]) UNTIL i = 0 + END WriteHex; +(* commented out because it's not necessary to compile OR compiler; -- noch + PROCEDURE WriteReal* (VAR W: Writer; x: REAL; n: INTEGER); + VAR e, i, m: INTEGER; x0: REAL; neg: BOOLEAN; + d: ARRAY 16 OF CHAR; + BEGIN + IF x = 0.0 THEN + WriteString(W, " 0.0"); i := 5; + WHILE i < n DO Write(W, " "); INC(i) END + ELSE + IF x < 0.0 THEN x := -x; neg := TRUE ELSE neg := FALSE END ; + x0 := x; UNPK(x0, e); + IF e = 255 THEN WriteString(W, " NaN") + ELSE + REPEAT Write(W, " "); DEC(n) UNTIL n <= 14; + IF neg THEN Write(W, "-") ELSE Write(W, " ") END ; + e := e * 77 DIV 256 - 6; + IF e >= 0 THEN x := x / Ten(e) ELSE x := x * Ten(-e) END ; + IF x >= 10.0E6 THEN x := 0.1*x; INC(e) END ; + m := FLOOR(x + 0.5); i := 0; + IF x >= 10.0E6 THEN x := 0.1*x; INC(e) END ; + REPEAT d[i] := CHR(m MOD 10 + 30H); m := m DIV 10; INC(i) UNTIL m = 0; + DEC(i); Write(W, d[i]); Write(W, "."); + IF i < n-6 THEN n := 0 ELSE n := 13-n END ; + WHILE i > n DO DEC(i); Write(W, d[i]) END ; + Write(W, "E"); INC(e, 6); + IF e < 0 THEN Write(W, "-"); e := -e ELSE Write(W, "+") END ; + Write(W, CHR(e DIV 10 + 30H)); Write(W, CHR(e MOD 10 + 30H)) + END + END + END WriteReal; + *) + PROCEDURE WriteRealFix* (VAR W: Writer; x: REAL; n, k: INTEGER); + VAR i, m: INTEGER; neg: BOOLEAN; + d: ARRAY 12 OF CHAR; + BEGIN + IF x = 0.0 THEN WriteString(W, " 0") + ELSE + IF x < 0.0 THEN x := -x; neg := TRUE ELSE neg := FALSE END ; + IF k > 7 THEN k := 7 END ; + x := Ten(k) * x; m := FLOOR(x + 0.5); + i := 0; + REPEAT d[i] := CHR(m MOD 10 + 30H); m := m DIV 10; INC(i) UNTIL m = 0; + REPEAT Write(W, " "); DEC(n) UNTIL n <= i+3; + IF neg THEN Write(W, "-"); DEC(n) ELSE Write(W, " ") END ; + WHILE i > k DO DEC(i); Write(W, d[i]) END ; + Write(W, "."); + WHILE k > i DO DEC(k); Write(W, "0") END ; + WHILE i > 0 DO DEC(i); Write(W, d[i]) END + END + END WriteRealFix; + + PROCEDURE WritePair(VAR W: Writer; ch: CHAR; x: LONGINT); + BEGIN Write(W, ch); + Write(W, CHR(x DIV 10 + 30H)); Write(W, CHR(x MOD 10 + 30H)) + END WritePair; + + PROCEDURE WriteClock* (VAR W: Writer; d: LONGINT); + BEGIN + WritePair(W, " ", d DIV 20000H MOD 20H); (*day*) + WritePair(W, ".", d DIV 400000H MOD 10H); (*month*) + WritePair(W, ".", d DIV 4000000H MOD 40H); (*year*) + WritePair(W, " ", d DIV 1000H MOD 20H); (*hour*) + WritePair(W, ":", d DIV 40H MOD 40H); (*min*) + WritePair(W, ":", d MOD 40H) (*sec*) + END WriteClock; + +BEGIN TrailerFile := Files.New("") +END CompatTexts. diff --git a/src/voc07R/Fonts.Mod b/src/voc07R/Fonts.Mod index 1798cfb6..15dabaf1 100644 --- a/src/voc07R/Fonts.Mod +++ b/src/voc07R/Fonts.Mod @@ -1,146 +1,146 @@ -MODULE Fonts; (*JG 18.11.90; PDR 8.6.12; NW 25.3.2013*) - IMPORT SYSTEM, Files := CompatFiles; - - TYPE INTEGER = LONGINT; (* voc adaptation by noch *) - BYTE = CHAR; - - CONST FontFileId = 0DBH; - - TYPE Font* = POINTER TO FontDesc; - FontDesc* = RECORD - name*: ARRAY 32 OF CHAR; - height*, minX*, maxX*, minY*, maxY*: INTEGER; - next*: Font; - T: ARRAY 128 OF INTEGER; - raster: ARRAY 2360 OF BYTE - END ; - - LargeFontDesc = RECORD (FontDesc) ext: ARRAY 2560 OF BYTE END ; - LargeFont = POINTER TO LargeFontDesc; - - (* raster sizes: Syntax8 1367, Syntax10 1628, Syntax12 1688, Syntax14 1843, Syntax14b 1983, - Syntax16 2271, Syntax20 3034, Syntac24 4274, Syntax24b 4302 *) - -VAR Default*, root*: Font; - -PROCEDURE GetPat*(fnt: Font; ch: CHAR; VAR dx, x, y, w, h, patadr: INTEGER); - VAR pa: INTEGER; dxb, xb, yb, wb, hb: BYTE; -BEGIN pa := fnt.T[ORD(ch) MOD 80H]; patadr := pa; - SYSTEM.GET(pa-3, dxb); SYSTEM.GET(pa-2, xb); SYSTEM.GET(pa-1, yb); SYSTEM.GET(pa, wb); SYSTEM.GET(pa+1, hb); - (*dx := dxb;*) - dx := ORD(dxb); (* voc adaptation by noch *) - (*x := xb;*) - x := ORD(xb); (* voc adaptation by noch *) - (*y := yb;*) - y := ORD(yb); (* voc adaptation by noch *) - (*w := wb;*) - w := ORD(wb); (* voc adaptation by noch *) - (*h := hb;*) - h := ORD(hb); (* voc adaptation by noch *) - (*IF yb < 128 THEN y := yb ELSE y := yb - 256 END*) - IF ORD(yb) < 128 THEN y := ORD(yb) ELSE y := ORD(yb) - 256 END (* voc adaptation by noch *) -END GetPat; - -PROCEDURE This*(name: ARRAY OF CHAR): Font; - - TYPE RunRec = RECORD beg, end: BYTE END ; - BoxRec = RECORD dx, x, y, w, h: BYTE END ; - - VAR F: Font; LF: LargeFont; - f: Files.File; R: Files.Rider; - NofRuns, NofBoxes: BYTE; - NofBytes: INTEGER; - height, minX, maxX, minY, maxY: BYTE; - i, j, k, m, n: INTEGER; - a, a0: INTEGER; - b, beg, end: BYTE; - run: ARRAY 16 OF RunRec; - box: ARRAY 512 OF BoxRec; - - PROCEDURE RdInt16(VAR R: Files.Rider; VAR b0: BYTE); - VAR b1: BYTE; - BEGIN Files.ReadByte(R, b0); Files.ReadByte(R, b1) - END RdInt16; - -BEGIN F := root; - WHILE (F # NIL) & (name # F.name) DO F := F.next END; - IF F = NIL THEN - f := Files.Old(name); - IF f # NIL THEN - Files.Set(R, f, 0); Files.ReadByte(R, b); - (*IF b = FontFileId THEN*) - IF ORD(b) = FontFileId THEN (* voc adaptation by noch *) - Files.ReadByte(R, b); (*abstraction*) - Files.ReadByte(R, b); (*family*) - Files.ReadByte(R, b); (*variant*) - NEW(F); - (*F.name := name;*) - COPY(name, F.name); (* voc adaptation by noch *) - RdInt16(R, height); RdInt16(R, minX); RdInt16(R, maxX); RdInt16(R, minY); RdInt16(R, maxY); RdInt16(R, NofRuns); - (*NofBoxes := 0;*) (* voc adaptation by noch *) - NofBoxes := 0X; - k := 0; - (*WHILE k # NofRuns DO*) - WHILE k # ORD(NofRuns) DO (* voc adaptation by noch *) - RdInt16(R, beg); - run[k].beg := beg; RdInt16(R, end); - run[k].end := end; - (*NofBoxes := NofBoxes + end - beg;*) - NofBoxes := CHR(ORD(NofBoxes) + ORD(end) - ORD(beg)); (* voc adaptation by noch *) - INC(k) - END; - NofBytes := 5; j := 0; - (*WHILE j # NofBoxes DO*) - WHILE j # ORD(NofBoxes) DO (* voc adaptation by noch *) - RdInt16(R, box[j].dx); RdInt16(R, box[j].x); RdInt16(R, box[j].y); - RdInt16(R, box[j].w); RdInt16(R, box[j].h); - (*NofBytes := NofBytes + 5 + (box[j].w + 7) DIV 8 * box[j].h;*) - NofBytes := (NofBytes + 5 + (ORD(box[j].w) + 7) DIV 8 * ORD(box[j].h)); (* voc adaptation by noch *) - INC(j) - END; - IF NofBytes < 2300 THEN NEW(F) ELSE NEW(LF); F := LF END ; - (*F.name := name;*) - COPY(name, F.name); (* voc adaptation by noch *) - (*F.height := height; F.minX := minX; F.maxX := maxX; F.maxY := maxY;*) - F.height := ORD(height); F.minX := ORD(minX); F.maxX := ORD(maxX); F.maxY := ORD(maxY); (* voc adaptation by noch *) - (*IF minY >= 80H THEN F.minY := minY - 100H ELSE F.minY := minY END ;*) - IF ORD(minY) >= 80H THEN F.minY := ORD(minY) - 100H ELSE F.minY := ORD(minY) END ; (* voc adaptation by noch *) - a0 := SYSTEM.ADR(F.raster); - SYSTEM.PUT(a0, 0X); SYSTEM.PUT(a0+1, 0X); SYSTEM.PUT(a0+2, 0X); SYSTEM.PUT(a0+3, 0X); SYSTEM.PUT(a0+4, 0X); - (*null pattern for characters not in a run*) - INC(a0, 2); a := a0+3; j := 0; k := 0; m := 0; - (*WHILE k < NofRuns DO*) - WHILE k < ORD(NofRuns) DO - (*WHILE (m < run[k].beg) & (m < 128) DO F.T[m] := a0; INC(m) END;*) - WHILE (m < ORD(run[k].beg)) & (m < 128) DO F.T[m] := a0; INC(m) END; (* voc adaptation by noch *) - (*WHILE (m < run[k].end) & (m < 128) DO*) (* voc adaptation by noch *) - WHILE (m < ORD(run[k].end)) & (m < 128) DO - F.T[m] := a+3; - SYSTEM.PUT(a, box[j].dx); SYSTEM.PUT(a+1, box[j].x); SYSTEM.PUT(a+2, box[j].y); - SYSTEM.PUT(a+3, box[j].w); SYSTEM.PUT(a+4, box[j].h); INC(a, 5); - (*n := (box[j].w + 7) DIV 8 * box[j].h;*) - n := (ORD(box[j].w) + 7) DIV 8 * ORD(box[j].h); (* voc adaptation by noch *) - WHILE n # 0 DO DEC(n); Files.ReadByte(R, b); SYSTEM.PUT(a, b); INC(a) END ; - INC(j); INC(m) - END; - INC(k) - END; - WHILE m < 128 DO F.T[m] := a0; INC(m) END ; - F.next := root; root := F - ELSE (*bad file id*) F := Default - END - ELSE (*font file not available*) F := Default - END - END; - RETURN F -END This; - -PROCEDURE Free*; (*remove all but first two from font list*) - VAR f: Font; -BEGIN f := root.next; - IF f # NIL THEN f := f.next END ; - f.next := NIL -END Free; - -BEGIN root := NIL; Default := This("Oberon10.Scn.Fnt") -END Fonts. +MODULE Fonts; (*JG 18.11.90; PDR 8.6.12; NW 25.3.2013*) + IMPORT SYSTEM, Files := CompatFiles; + + TYPE INTEGER = LONGINT; (* voc adaptation by noch *) + BYTE = CHAR; + + CONST FontFileId = 0DBH; + + TYPE Font* = POINTER TO FontDesc; + FontDesc* = RECORD + name*: ARRAY 32 OF CHAR; + height*, minX*, maxX*, minY*, maxY*: INTEGER; + next*: Font; + T: ARRAY 128 OF INTEGER; + raster: ARRAY 2360 OF BYTE + END ; + + LargeFontDesc = RECORD (FontDesc) ext: ARRAY 2560 OF BYTE END ; + LargeFont = POINTER TO LargeFontDesc; + + (* raster sizes: Syntax8 1367, Syntax10 1628, Syntax12 1688, Syntax14 1843, Syntax14b 1983, + Syntax16 2271, Syntax20 3034, Syntac24 4274, Syntax24b 4302 *) + +VAR Default*, root*: Font; + +PROCEDURE GetPat*(fnt: Font; ch: CHAR; VAR dx, x, y, w, h, patadr: INTEGER); + VAR pa: INTEGER; dxb, xb, yb, wb, hb: BYTE; +BEGIN pa := fnt.T[ORD(ch) MOD 80H]; patadr := pa; + SYSTEM.GET(pa-3, dxb); SYSTEM.GET(pa-2, xb); SYSTEM.GET(pa-1, yb); SYSTEM.GET(pa, wb); SYSTEM.GET(pa+1, hb); + (*dx := dxb;*) + dx := ORD(dxb); (* voc adaptation by noch *) + (*x := xb;*) + x := ORD(xb); (* voc adaptation by noch *) + (*y := yb;*) + y := ORD(yb); (* voc adaptation by noch *) + (*w := wb;*) + w := ORD(wb); (* voc adaptation by noch *) + (*h := hb;*) + h := ORD(hb); (* voc adaptation by noch *) + (*IF yb < 128 THEN y := yb ELSE y := yb - 256 END*) + IF ORD(yb) < 128 THEN y := ORD(yb) ELSE y := ORD(yb) - 256 END (* voc adaptation by noch *) +END GetPat; + +PROCEDURE This*(name: ARRAY OF CHAR): Font; + + TYPE RunRec = RECORD beg, end: BYTE END ; + BoxRec = RECORD dx, x, y, w, h: BYTE END ; + + VAR F: Font; LF: LargeFont; + f: Files.File; R: Files.Rider; + NofRuns, NofBoxes: BYTE; + NofBytes: INTEGER; + height, minX, maxX, minY, maxY: BYTE; + i, j, k, m, n: INTEGER; + a, a0: INTEGER; + b, beg, end: BYTE; + run: ARRAY 16 OF RunRec; + box: ARRAY 512 OF BoxRec; + + PROCEDURE RdInt16(VAR R: Files.Rider; VAR b0: BYTE); + VAR b1: BYTE; + BEGIN Files.ReadByte(R, b0); Files.ReadByte(R, b1) + END RdInt16; + +BEGIN F := root; + WHILE (F # NIL) & (name # F.name) DO F := F.next END; + IF F = NIL THEN + f := Files.Old(name); + IF f # NIL THEN + Files.Set(R, f, 0); Files.ReadByte(R, b); + (*IF b = FontFileId THEN*) + IF ORD(b) = FontFileId THEN (* voc adaptation by noch *) + Files.ReadByte(R, b); (*abstraction*) + Files.ReadByte(R, b); (*family*) + Files.ReadByte(R, b); (*variant*) + NEW(F); + (*F.name := name;*) + COPY(name, F.name); (* voc adaptation by noch *) + RdInt16(R, height); RdInt16(R, minX); RdInt16(R, maxX); RdInt16(R, minY); RdInt16(R, maxY); RdInt16(R, NofRuns); + (*NofBoxes := 0;*) (* voc adaptation by noch *) + NofBoxes := 0X; + k := 0; + (*WHILE k # NofRuns DO*) + WHILE k # ORD(NofRuns) DO (* voc adaptation by noch *) + RdInt16(R, beg); + run[k].beg := beg; RdInt16(R, end); + run[k].end := end; + (*NofBoxes := NofBoxes + end - beg;*) + NofBoxes := CHR(ORD(NofBoxes) + ORD(end) - ORD(beg)); (* voc adaptation by noch *) + INC(k) + END; + NofBytes := 5; j := 0; + (*WHILE j # NofBoxes DO*) + WHILE j # ORD(NofBoxes) DO (* voc adaptation by noch *) + RdInt16(R, box[j].dx); RdInt16(R, box[j].x); RdInt16(R, box[j].y); + RdInt16(R, box[j].w); RdInt16(R, box[j].h); + (*NofBytes := NofBytes + 5 + (box[j].w + 7) DIV 8 * box[j].h;*) + NofBytes := (NofBytes + 5 + (ORD(box[j].w) + 7) DIV 8 * ORD(box[j].h)); (* voc adaptation by noch *) + INC(j) + END; + IF NofBytes < 2300 THEN NEW(F) ELSE NEW(LF); F := LF END ; + (*F.name := name;*) + COPY(name, F.name); (* voc adaptation by noch *) + (*F.height := height; F.minX := minX; F.maxX := maxX; F.maxY := maxY;*) + F.height := ORD(height); F.minX := ORD(minX); F.maxX := ORD(maxX); F.maxY := ORD(maxY); (* voc adaptation by noch *) + (*IF minY >= 80H THEN F.minY := minY - 100H ELSE F.minY := minY END ;*) + IF ORD(minY) >= 80H THEN F.minY := ORD(minY) - 100H ELSE F.minY := ORD(minY) END ; (* voc adaptation by noch *) + a0 := SYSTEM.ADR(F.raster); + SYSTEM.PUT(a0, 0X); SYSTEM.PUT(a0+1, 0X); SYSTEM.PUT(a0+2, 0X); SYSTEM.PUT(a0+3, 0X); SYSTEM.PUT(a0+4, 0X); + (*null pattern for characters not in a run*) + INC(a0, 2); a := a0+3; j := 0; k := 0; m := 0; + (*WHILE k < NofRuns DO*) + WHILE k < ORD(NofRuns) DO + (*WHILE (m < run[k].beg) & (m < 128) DO F.T[m] := a0; INC(m) END;*) + WHILE (m < ORD(run[k].beg)) & (m < 128) DO F.T[m] := a0; INC(m) END; (* voc adaptation by noch *) + (*WHILE (m < run[k].end) & (m < 128) DO*) (* voc adaptation by noch *) + WHILE (m < ORD(run[k].end)) & (m < 128) DO + F.T[m] := a+3; + SYSTEM.PUT(a, box[j].dx); SYSTEM.PUT(a+1, box[j].x); SYSTEM.PUT(a+2, box[j].y); + SYSTEM.PUT(a+3, box[j].w); SYSTEM.PUT(a+4, box[j].h); INC(a, 5); + (*n := (box[j].w + 7) DIV 8 * box[j].h;*) + n := (ORD(box[j].w) + 7) DIV 8 * ORD(box[j].h); (* voc adaptation by noch *) + WHILE n # 0 DO DEC(n); Files.ReadByte(R, b); SYSTEM.PUT(a, b); INC(a) END ; + INC(j); INC(m) + END; + INC(k) + END; + WHILE m < 128 DO F.T[m] := a0; INC(m) END ; + F.next := root; root := F + ELSE (*bad file id*) F := Default + END + ELSE (*font file not available*) F := Default + END + END; + RETURN F +END This; + +PROCEDURE Free*; (*remove all but first two from font list*) + VAR f: Font; +BEGIN f := root.next; + IF f # NIL THEN f := f.next END ; + f.next := NIL +END Free; + +BEGIN root := NIL; Default := This("Oberon10.Scn.Fnt") +END Fonts. diff --git a/src/voc07R/ORB.Mod b/src/voc07R/ORB.Mod index 61d23f4f..3427bb2e 100644 --- a/src/voc07R/ORB.Mod +++ b/src/voc07R/ORB.Mod @@ -1,447 +1,447 @@ -MODULE ORB; (*NW 25.6.2014 in Oberon-07*) - IMPORT Files := CompatFiles (* voc adaptation by noch *) - , ORS; - (*Definition of data types Object and Type, which together form the data structure - called "symbol table". Contains procedures for creation of Objects, and for search: - NewObj, this, thisimport, thisfield (and OpenScope, CloseScope). - Handling of import and export, i.e. reading and writing of "symbol files" is done by procedures - Import and Export. This module contains the list of standard identifiers, with which - the symbol table (universe), and that of the pseudo-module SYSTEM are initialized. *) - - TYPE INTEGER = LONGINT; (* voc adaptation by noch *) - BYTE = CHAR; - - CONST versionkey* = 1; maxTypTab = 64; - (* class values*) Head* = 0; - Const* = 1; Var* = 2; Par* = 3; Fld* = 4; Typ* = 5; - SProc* = 6; SFunc* = 7; Mod* = 8; - - (* form values*) - Byte* = 1; Bool* = 2; Char* = 3; Int* = 4; Real* = 5; Set* = 6; - Pointer* = 7; NilTyp* = 8; NoTyp* = 9; Proc* = 10; - String* = 11; Array* = 12; Record* = 13; - - TYPE Object* = POINTER TO ObjDesc; - Module* = POINTER TO ModDesc; - Type* = POINTER TO TypeDesc; - - ObjDesc*= RECORD - class*, lev*, exno*: INTEGER; - expo*, rdo*: BOOLEAN; (*exported / read-only*) - next*, dsc*: Object; - type*: Type; - name*: ORS.Ident; - val*: LONGINT - END ; - - ModDesc* = RECORD (ObjDesc) orgname*: ORS.Ident END ; - - TypeDesc* = RECORD - form*, ref*, mno*: INTEGER; (*ref is only used for import/export*) - nofpar*: INTEGER; (*for procedures, extension level for records*) - len*: LONGINT; (*for arrays, len < 0 => open array; for records: adr of descriptor*) - dsc*, typobj*: Object; - base*: Type; (*for arrays, records, pointers*) - size*: LONGINT; (*in bytes; always multiple of 4, except for Byte, Bool and Char*) - END ; - - (* Object classes and the meaning of "val": - class val - ---------- - Var address - Par address - Const value - Fld offset - Typ type descriptor (TD) address - SProc inline code number - SFunc inline code number - Mod key - - Type forms and the meaning of "dsc" and "base": - form dsc base - ------------------------ - Pointer - type of dereferenced object - Proc params result type - Array - type of elements - Record fields extension *) - - VAR topScope*, universe, system*: Object; - byteType*, boolType*, charType*: Type; - intType*, realType*, setType*, nilType*, noType*, strType*: Type; - nofmod, Ref: INTEGER; - typtab: ARRAY maxTypTab OF Type; - - PROCEDURE NewObj*(VAR obj: Object; id: ORS.Ident; class: INTEGER); (*insert new Object with name id*) - VAR new, x: Object; - BEGIN x := topScope; - WHILE (x.next # NIL) & (x.next.name # id) DO x := x.next END ; - IF x.next = NIL THEN - NEW(new); new.name := id; new.class := class; new.next := NIL; new.rdo := FALSE; new.dsc := NIL; - x.next := new; obj := new - ELSE obj := x.next; ORS.Mark("mult def") - END - END NewObj; - - PROCEDURE thisObj*(): Object; - VAR s, x: Object; - BEGIN s := topScope; - REPEAT x := s.next; - WHILE (x # NIL) & (x.name # ORS.id) DO x := x.next END ; - s := s.dsc - UNTIL (x # NIL) OR (s = NIL); - RETURN x - END thisObj; - - PROCEDURE thisimport*(mod: Object): Object; - VAR obj: Object; - BEGIN - IF mod.rdo THEN - IF mod.name[0] # 0X THEN - obj := mod.dsc; - WHILE (obj # NIL) & (obj.name # ORS.id) DO obj := obj.next END - ELSE obj := NIL - END - ELSE obj := NIL - END ; - RETURN obj - END thisimport; - - PROCEDURE thisfield*(rec: Type): Object; - VAR fld: Object; - BEGIN fld := rec.dsc; - WHILE (fld # NIL) & (fld.name # ORS.id) DO fld := fld.next END ; - RETURN fld - END thisfield; - - PROCEDURE OpenScope*; - VAR s: Object; - BEGIN NEW(s); s.class := Head; s.dsc := topScope; s.next := NIL; topScope := s - END OpenScope; - - PROCEDURE CloseScope*; - BEGIN topScope := topScope.dsc - END CloseScope; - - (*------------------------------- Import ---------------------------------*) - - PROCEDURE MakeFileName*(VAR FName: ORS.Ident; name, ext: ARRAY OF CHAR); - VAR i, j: INTEGER; - BEGIN i := 0; j := 0; (*assume name suffix less than 4 characters*) - WHILE (i < ORS.IdLen-5) & (name[i] > 0X) DO FName[i] := name[i]; INC(i) END ; - REPEAT FName[i]:= ext[j]; INC(i); INC(j) UNTIL ext[j] = 0X; - FName[i] := 0X - END MakeFileName; - - PROCEDURE ThisModule(name, orgname: ORS.Ident; non: BOOLEAN; key: LONGINT): Object; - VAR mod: Module; obj, obj1: Object; - BEGIN obj1 := topScope; obj := obj1.next; (*search for module*) - WHILE (obj # NIL) & (obj.name # name) DO obj1 := obj; obj := obj1.next END ; - IF obj = NIL THEN (*insert new module*) - NEW(mod); mod.class := Mod; mod.rdo := FALSE; - mod.name := name; mod.orgname := orgname; mod.val := key; - mod.lev := nofmod; INC(nofmod); mod.type := noType; mod.dsc := NIL; mod.next := NIL; - obj1.next := mod; obj := mod - ELSE (*module already present*) - IF non THEN ORS.Mark("invalid import order") END - END ; - RETURN obj - END ThisModule; - - PROCEDURE Read(VAR R: Files.Rider; VAR x: INTEGER); - VAR b: BYTE; - BEGIN Files.ReadByte(R, b); - (*IF b < 80H THEN x := b ELSE x := b - 100H END*) - IF b < 80X THEN x := ORD(b) ELSE x := ORD(b) - 100H END (* voc adaptation by noch *) - END Read; - - PROCEDURE InType(VAR R: Files.Rider; thismod: Object; VAR T: Type); - VAR key: LONGINT; - ref, class, mno, form, np, readonly: INTEGER; - new, fld, par, obj, mod, impmod: Object; - t: Type; - name, modname: ORS.Ident; - BEGIN Read(R, ref); - IF ref < 0 THEN T := typtab[-ref] (*already read*) - ELSE NEW(t); T := t; typtab[ref] := t; t.mno := thismod.lev; - Read(R, form); t.form := form; - IF form = Pointer THEN InType(R, thismod, t.base); t.size := 4 - ELSIF form = Array THEN - InType(R, thismod, t.base); Files.ReadNum(R, t.len); Files.ReadNum(R, t.size) - ELSIF form = Record THEN - InType(R, thismod, t.base); - IF t.base.form = NoTyp THEN t.base := NIL; obj := NIL ELSE obj := t.base.dsc END ; - Files.ReadNum(R, t.len); (*TD adr/exno*) - Files.ReadNum(R, t.nofpar); (*ext level*) - Files.ReadNum(R, t.size); - Read(R, class); - WHILE class # 0 DO (*fields*) - NEW(fld); fld.class := class; Files.ReadString(R, fld.name); - IF fld.name[0] # 0X THEN fld.expo := TRUE; InType(R, thismod, fld.type) ELSE fld.expo := FALSE; fld.type := nilType END ; - Files.ReadNum(R, fld.val); fld.next := obj; obj := fld; Read(R, class) - END ; - t.dsc := obj - ELSIF form = Proc THEN - InType(R, thismod, t.base); - obj := NIL; np := 0; Read(R, class); - WHILE class # 0 DO (*parameters*) - NEW(par); par.class := class; Read(R, readonly); par.rdo := readonly = 1; - InType(R, thismod, par.type); par.next := obj; obj := par; INC(np); Read(R, class) - END ; - t.dsc := obj; t.nofpar := np; t.size := 4 - END ; - Files.ReadString(R, modname); - IF modname[0] # 0X THEN (*re-import*) - Files.ReadInt(R, key); Files.ReadString(R, name); - mod := ThisModule(modname, modname, FALSE, key); - obj := mod.dsc; (*search type*) - WHILE (obj # NIL) & (obj.name # name) DO obj := obj.next END ; - IF obj # NIL THEN T := obj.type (*type object found in object list of mod*) - ELSE (*insert new type object in object list of mod*) - NEW(obj); obj.name := name; obj.class := Typ; obj.next := mod.dsc; mod.dsc := obj; obj.type := t; - t.mno := mod.lev; t.typobj := obj; T := t - END ; - typtab[ref] := T - END - END - END InType; - - PROCEDURE Import*(VAR modid, modid1: ORS.Ident); - VAR key: LONGINT; class, k: INTEGER; - obj: Object; t: Type; - thismod: Object; - modname, fname: ORS.Ident; - F: Files.File; R: Files.Rider; - BEGIN - IF modid1 = "SYSTEM" THEN - thismod := ThisModule(modid, modid1, TRUE, key); DEC(nofmod); - thismod.lev := 0; thismod.dsc := system; thismod.rdo := TRUE - ELSE MakeFileName(fname, modid1, ".smb"); F := Files.Old(fname); - IF F # NIL THEN - Files.Set(R, F, 0); Files.ReadInt(R, key); Files.ReadInt(R, key); Files.ReadString(R, modname); - thismod := ThisModule(modid, modid1, TRUE, key); thismod.rdo := TRUE; - Read(R, class); (*version key*) - IF class # versionkey THEN ORS.Mark("wrong version") END ; - Read(R, class); - WHILE class # 0 DO - NEW(obj); obj.class := class; Files.ReadString(R, obj.name); - InType(R, thismod, obj.type); obj.lev := -thismod.lev; - IF class = Typ THEN - t := obj.type; t.typobj := obj; Read(R, k); (*fixup bases of previously declared pointer types*) - WHILE k # 0 DO typtab[k].base := t; Read(R, k) END - ELSE - IF class = Const THEN - IF obj.type.form = Real THEN Files.ReadInt(R, obj.val) ELSE Files.ReadNum(R, obj.val) END - ELSIF class = Var THEN Files.ReadNum(R, obj.val); obj.rdo := TRUE - END - END ; - obj.next := thismod.dsc; thismod.dsc := obj; Read(R, class) - END ; - ELSE ORS.Mark("import not available") - END - END - END Import; - - (*-------------------------------- Export ---------------------------------*) - - PROCEDURE Write(VAR R: Files.Rider; x: INTEGER); - BEGIN - (*Files.WriteByte(R, x)*) - Files.WriteByte(R, SHORT(SHORT(x))) (* voc adaptation by noch *) - END Write; - - PROCEDURE OutType(VAR R: Files.Rider; t: Type); - VAR obj, mod, fld: Object; - - PROCEDURE OutPar(VAR R: Files.Rider; par: Object; n: INTEGER); - VAR cl: INTEGER; - BEGIN - IF n > 0 THEN - OutPar(R, par.next, n-1); cl := par.class; - Write(R, cl); - IF par.rdo THEN Write(R, 1) ELSE Write(R, 0) END ; - OutType(R, par.type) - END - END OutPar; - - PROCEDURE FindHiddenPointers(VAR R: Files.Rider; typ: Type; offset: LONGINT); - VAR fld: Object; i, n: LONGINT; - BEGIN - IF (typ.form = Pointer) OR (typ.form = NilTyp) THEN Write(R, Fld); Write(R, 0); Files.WriteNum(R, offset) - ELSIF typ.form = Record THEN fld := typ.dsc; - WHILE fld # NIL DO FindHiddenPointers(R, fld.type, fld.val + offset); fld := fld.next END - ELSIF typ.form = Array THEN i := 0; n := typ.len; - WHILE i < n DO FindHiddenPointers(R, typ.base, typ.base.size * i + offset); INC(i) END - END - END FindHiddenPointers; - - BEGIN - IF t.ref > 0 THEN (*type was already output*) Write(R, -t.ref) - ELSE obj := t.typobj; - IF obj # NIL THEN Write(R, Ref); t.ref := Ref; INC(Ref) ELSE (*anonymous*) Write(R, 0) END ; - Write(R, t.form); - IF t.form = Pointer THEN OutType(R, t.base) - ELSIF t.form = Array THEN OutType(R, t.base); Files.WriteNum(R, t.len); Files.WriteNum(R, t.size) - ELSIF t.form = Record THEN - IF t.base # NIL THEN OutType(R, t.base) ELSE OutType(R, noType) END ; - IF obj # NIL THEN Files.WriteNum(R, obj.exno) ELSE Write(R, 0) END ; - Files.WriteNum(R, t.nofpar); Files.WriteNum(R, t.size); - fld := t.dsc; - WHILE fld # NIL DO (*fields*) - IF fld.expo THEN - Write(R, Fld); Files.WriteString(R, fld.name); OutType(R, fld.type); Files.WriteNum(R, fld.val) - ELSE FindHiddenPointers(R, fld.type, fld.val) (*offset*) - END ; - fld := fld.next - END ; - Write(R, 0) - ELSIF t.form = Proc THEN OutType(R, t.base); OutPar(R, t.dsc, t.nofpar); Write(R, 0) - END ; - IF (t.mno > 0) & (obj # NIL) THEN (*re-export, output name*) - mod := topScope.next; - WHILE (mod # NIL) & (mod.lev # t.mno) DO mod := mod.next END ; - IF mod # NIL THEN Files.WriteString(R, mod.name); Files.WriteInt(R, mod.val); Files.WriteString(R, obj.name) - ELSE ORS.Mark("re-export not found"); Write(R, 0) - END - ELSE Write(R, 0) - END - END - END OutType; - - PROCEDURE Export*(VAR modid: ORS.Ident; VAR newSF: BOOLEAN; VAR key: LONGINT); - VAR x, sum, oldkey: LONGINT; - obj, obj0: Object; - filename: ORS.Ident; - F, F1: Files.File; R, R1: Files.Rider; - BEGIN Ref := Record + 1; MakeFileName(filename, modid, ".smb"); - F := Files.New(filename); Files.Set(R, F, 0); - Files.WriteInt(R, 0); (*placeholder*) - Files.WriteInt(R, 0); (*placeholder for key to be inserted at the end*) - Files.WriteString(R, modid); Write(R, versionkey); - obj := topScope.next; - WHILE obj # NIL DO - IF obj.expo THEN - Write(R, obj.class); Files.WriteString(R, obj.name); - OutType(R, obj.type); - IF obj.class = Typ THEN - IF obj.type.form = Record THEN - obj0 := topScope.next; (*check whether this is base of previously declared pointer types*) - WHILE obj0 # obj DO - IF (obj0.type.form = Pointer) & (obj0.type.base = obj.type) & (obj0.type.ref > 0) THEN Write(R, obj0.type.ref) END ; - obj0 := obj0.next - END - END ; - Write(R, 0) - ELSIF obj.class = Const THEN - IF obj.type.form = Proc THEN Files.WriteNum(R, obj.exno) - ELSIF obj.type.form = Real THEN Files.WriteInt(R, obj.val) - ELSE Files.WriteNum(R, obj.val) - END - ELSIF obj.class = Var THEN - Files.WriteNum(R, obj.exno); - IF obj.type.form = String THEN - Files.WriteNum(R, obj.val DIV 10000H); obj.val := obj.val MOD 10000H - END - END - END ; - obj := obj.next - END ; - REPEAT Write(R, 0) UNTIL Files.Length(F) MOD 4 = 0; - FOR Ref := Record+1 TO maxTypTab-1 DO typtab[Ref] := NIL END ; - Files.Set(R, F, 0); sum := 0; Files.ReadInt(R, x); (* compute key (checksum) *) - WHILE ~R.eof DO sum := sum + x; Files.ReadInt(R, x) END ; - F1 := Files.Old(filename); (*sum is new key*) - IF F1 # NIL THEN Files.Set(R1, F1, 4); Files.ReadInt(R1, oldkey) ELSE oldkey := sum+1 END ; - IF sum # oldkey THEN - IF newSF OR (F1 = NIL) THEN - key := sum; newSF := TRUE; Files.Set(R, F, 4); Files.WriteInt(R, sum); Files.Register(F) (*insert checksum*) - ELSE ORS.Mark("new symbol file inhibited") - END - ELSE newSF := FALSE; key := sum - END - END Export; - - PROCEDURE Init*; - BEGIN topScope := universe; nofmod := 1 - END Init; - - PROCEDURE type(ref, form: INTEGER; size: LONGINT): Type; - VAR tp: Type; - BEGIN NEW(tp); tp.form := form; tp.size := size; tp.ref := ref; tp.base := NIL; - typtab[ref] := tp; RETURN tp - END type; - - PROCEDURE enter(name: ARRAY OF CHAR; cl: INTEGER; type: Type; n: LONGINT); - VAR obj: Object; - BEGIN - NEW(obj); - (*obj.name := name; *) - COPY(name, obj.name); (* voc adaptation by noch *) - obj.class := cl; - obj.type := type; - obj.val := n; - obj.dsc := NIL; - IF cl = Typ THEN type.typobj := obj END ; - obj.next := system; system := obj - END enter; - -BEGIN - byteType := type(Byte, Int, 1); - boolType := type(Bool, Bool, 1); - charType := type(Char, Char,1); - intType := type(Int, Int, 4); - realType := type(Real, Real, 4); - setType := type(Set, Set,4); - nilType := type(NilTyp, NilTyp, 4); - noType := type(NoTyp, NoTyp, 4); - strType := type(String, String, 8); - - (*initialize universe with data types and in-line procedures; - LONGINT is synonym to INTEGER, LONGREAL to REAL. - LED, ADC, SBC; LDPSR, LDREG, REG, COND are not in language definition*) - system := NIL; (*n = procno*10 + nofpar*) - enter("UML", SFunc, intType, 132); (*functions*) - enter("SBC", SFunc, intType, 122); - enter("ADC", SFunc, intType, 112); - enter("ROR", SFunc, intType, 92); - enter("ASR", SFunc, intType, 82); - enter("LSL", SFunc, intType, 72); - enter("LEN", SFunc, intType, 61); - enter("CHR", SFunc, charType, 51); - enter("ORD", SFunc, intType, 41); - enter("FLT", SFunc, realType, 31); - enter("FLOOR", SFunc, intType, 21); - enter("ODD", SFunc, boolType, 11); - enter("ABS", SFunc, intType, 1); - enter("LED", SProc, noType, 81); (*procedures*) - enter("UNPK", SProc, noType, 72); - enter("PACK", SProc, noType, 62); - enter("NEW", SProc, noType, 51); - enter("ASSERT", SProc, noType, 41); - enter("EXCL", SProc, noType, 32); - enter("INCL", SProc, noType, 22); - enter("DEC", SProc, noType, 11); - enter("INC", SProc, noType, 1); - enter("SET", Typ, setType, 0); (*types*) - enter("BOOLEAN", Typ, boolType, 0); - enter("BYTE", Typ, byteType, 0); - enter("CHAR", Typ, charType, 0); - enter("LONGREAL", Typ, realType, 0); - enter("REAL", Typ, realType, 0); - enter("LONGINT", Typ, intType, 0); - enter("INTEGER", Typ, intType, 0); - topScope := NIL; OpenScope; topScope.next := system; universe := topScope; - - system := NIL; (* initialize "unsafe" pseudo-module SYSTEM*) - enter("H", SFunc, intType, 201); (*functions*) - enter("COND", SFunc, boolType, 191); - enter("SIZE", SFunc, intType, 181); - enter("ADR", SFunc, intType, 171); - enter("VAL", SFunc, intType, 162); - enter("REG", SFunc, intType, 151); - enter("BIT", SFunc, boolType, 142); - enter("LDREG", SProc, noType, 142); (*procedures*) - enter("LDPSR", SProc, noType, 131); - enter("COPY", SProc, noType, 123); - enter("PUT", SProc, noType, 112); - enter("GET", SProc, noType, 102); -END ORB. +MODULE ORB; (*NW 25.6.2014 in Oberon-07*) + IMPORT Files := CompatFiles (* voc adaptation by noch *) + , ORS; + (*Definition of data types Object and Type, which together form the data structure + called "symbol table". Contains procedures for creation of Objects, and for search: + NewObj, this, thisimport, thisfield (and OpenScope, CloseScope). + Handling of import and export, i.e. reading and writing of "symbol files" is done by procedures + Import and Export. This module contains the list of standard identifiers, with which + the symbol table (universe), and that of the pseudo-module SYSTEM are initialized. *) + + TYPE INTEGER = LONGINT; (* voc adaptation by noch *) + BYTE = CHAR; + + CONST versionkey* = 1; maxTypTab = 64; + (* class values*) Head* = 0; + Const* = 1; Var* = 2; Par* = 3; Fld* = 4; Typ* = 5; + SProc* = 6; SFunc* = 7; Mod* = 8; + + (* form values*) + Byte* = 1; Bool* = 2; Char* = 3; Int* = 4; Real* = 5; Set* = 6; + Pointer* = 7; NilTyp* = 8; NoTyp* = 9; Proc* = 10; + String* = 11; Array* = 12; Record* = 13; + + TYPE Object* = POINTER TO ObjDesc; + Module* = POINTER TO ModDesc; + Type* = POINTER TO TypeDesc; + + ObjDesc*= RECORD + class*, lev*, exno*: INTEGER; + expo*, rdo*: BOOLEAN; (*exported / read-only*) + next*, dsc*: Object; + type*: Type; + name*: ORS.Ident; + val*: LONGINT + END ; + + ModDesc* = RECORD (ObjDesc) orgname*: ORS.Ident END ; + + TypeDesc* = RECORD + form*, ref*, mno*: INTEGER; (*ref is only used for import/export*) + nofpar*: INTEGER; (*for procedures, extension level for records*) + len*: LONGINT; (*for arrays, len < 0 => open array; for records: adr of descriptor*) + dsc*, typobj*: Object; + base*: Type; (*for arrays, records, pointers*) + size*: LONGINT; (*in bytes; always multiple of 4, except for Byte, Bool and Char*) + END ; + + (* Object classes and the meaning of "val": + class val + ---------- + Var address + Par address + Const value + Fld offset + Typ type descriptor (TD) address + SProc inline code number + SFunc inline code number + Mod key + + Type forms and the meaning of "dsc" and "base": + form dsc base + ------------------------ + Pointer - type of dereferenced object + Proc params result type + Array - type of elements + Record fields extension *) + + VAR topScope*, universe, system*: Object; + byteType*, boolType*, charType*: Type; + intType*, realType*, setType*, nilType*, noType*, strType*: Type; + nofmod, Ref: INTEGER; + typtab: ARRAY maxTypTab OF Type; + + PROCEDURE NewObj*(VAR obj: Object; id: ORS.Ident; class: INTEGER); (*insert new Object with name id*) + VAR new, x: Object; + BEGIN x := topScope; + WHILE (x.next # NIL) & (x.next.name # id) DO x := x.next END ; + IF x.next = NIL THEN + NEW(new); new.name := id; new.class := class; new.next := NIL; new.rdo := FALSE; new.dsc := NIL; + x.next := new; obj := new + ELSE obj := x.next; ORS.Mark("mult def") + END + END NewObj; + + PROCEDURE thisObj*(): Object; + VAR s, x: Object; + BEGIN s := topScope; + REPEAT x := s.next; + WHILE (x # NIL) & (x.name # ORS.id) DO x := x.next END ; + s := s.dsc + UNTIL (x # NIL) OR (s = NIL); + RETURN x + END thisObj; + + PROCEDURE thisimport*(mod: Object): Object; + VAR obj: Object; + BEGIN + IF mod.rdo THEN + IF mod.name[0] # 0X THEN + obj := mod.dsc; + WHILE (obj # NIL) & (obj.name # ORS.id) DO obj := obj.next END + ELSE obj := NIL + END + ELSE obj := NIL + END ; + RETURN obj + END thisimport; + + PROCEDURE thisfield*(rec: Type): Object; + VAR fld: Object; + BEGIN fld := rec.dsc; + WHILE (fld # NIL) & (fld.name # ORS.id) DO fld := fld.next END ; + RETURN fld + END thisfield; + + PROCEDURE OpenScope*; + VAR s: Object; + BEGIN NEW(s); s.class := Head; s.dsc := topScope; s.next := NIL; topScope := s + END OpenScope; + + PROCEDURE CloseScope*; + BEGIN topScope := topScope.dsc + END CloseScope; + + (*------------------------------- Import ---------------------------------*) + + PROCEDURE MakeFileName*(VAR FName: ORS.Ident; name, ext: ARRAY OF CHAR); + VAR i, j: INTEGER; + BEGIN i := 0; j := 0; (*assume name suffix less than 4 characters*) + WHILE (i < ORS.IdLen-5) & (name[i] > 0X) DO FName[i] := name[i]; INC(i) END ; + REPEAT FName[i]:= ext[j]; INC(i); INC(j) UNTIL ext[j] = 0X; + FName[i] := 0X + END MakeFileName; + + PROCEDURE ThisModule(name, orgname: ORS.Ident; non: BOOLEAN; key: LONGINT): Object; + VAR mod: Module; obj, obj1: Object; + BEGIN obj1 := topScope; obj := obj1.next; (*search for module*) + WHILE (obj # NIL) & (obj.name # name) DO obj1 := obj; obj := obj1.next END ; + IF obj = NIL THEN (*insert new module*) + NEW(mod); mod.class := Mod; mod.rdo := FALSE; + mod.name := name; mod.orgname := orgname; mod.val := key; + mod.lev := nofmod; INC(nofmod); mod.type := noType; mod.dsc := NIL; mod.next := NIL; + obj1.next := mod; obj := mod + ELSE (*module already present*) + IF non THEN ORS.Mark("invalid import order") END + END ; + RETURN obj + END ThisModule; + + PROCEDURE Read(VAR R: Files.Rider; VAR x: INTEGER); + VAR b: BYTE; + BEGIN Files.ReadByte(R, b); + (*IF b < 80H THEN x := b ELSE x := b - 100H END*) + IF b < 80X THEN x := ORD(b) ELSE x := ORD(b) - 100H END (* voc adaptation by noch *) + END Read; + + PROCEDURE InType(VAR R: Files.Rider; thismod: Object; VAR T: Type); + VAR key: LONGINT; + ref, class, mno, form, np, readonly: INTEGER; + new, fld, par, obj, mod, impmod: Object; + t: Type; + name, modname: ORS.Ident; + BEGIN Read(R, ref); + IF ref < 0 THEN T := typtab[-ref] (*already read*) + ELSE NEW(t); T := t; typtab[ref] := t; t.mno := thismod.lev; + Read(R, form); t.form := form; + IF form = Pointer THEN InType(R, thismod, t.base); t.size := 4 + ELSIF form = Array THEN + InType(R, thismod, t.base); Files.ReadNum(R, t.len); Files.ReadNum(R, t.size) + ELSIF form = Record THEN + InType(R, thismod, t.base); + IF t.base.form = NoTyp THEN t.base := NIL; obj := NIL ELSE obj := t.base.dsc END ; + Files.ReadNum(R, t.len); (*TD adr/exno*) + Files.ReadNum(R, t.nofpar); (*ext level*) + Files.ReadNum(R, t.size); + Read(R, class); + WHILE class # 0 DO (*fields*) + NEW(fld); fld.class := class; Files.ReadString(R, fld.name); + IF fld.name[0] # 0X THEN fld.expo := TRUE; InType(R, thismod, fld.type) ELSE fld.expo := FALSE; fld.type := nilType END ; + Files.ReadNum(R, fld.val); fld.next := obj; obj := fld; Read(R, class) + END ; + t.dsc := obj + ELSIF form = Proc THEN + InType(R, thismod, t.base); + obj := NIL; np := 0; Read(R, class); + WHILE class # 0 DO (*parameters*) + NEW(par); par.class := class; Read(R, readonly); par.rdo := readonly = 1; + InType(R, thismod, par.type); par.next := obj; obj := par; INC(np); Read(R, class) + END ; + t.dsc := obj; t.nofpar := np; t.size := 4 + END ; + Files.ReadString(R, modname); + IF modname[0] # 0X THEN (*re-import*) + Files.ReadInt(R, key); Files.ReadString(R, name); + mod := ThisModule(modname, modname, FALSE, key); + obj := mod.dsc; (*search type*) + WHILE (obj # NIL) & (obj.name # name) DO obj := obj.next END ; + IF obj # NIL THEN T := obj.type (*type object found in object list of mod*) + ELSE (*insert new type object in object list of mod*) + NEW(obj); obj.name := name; obj.class := Typ; obj.next := mod.dsc; mod.dsc := obj; obj.type := t; + t.mno := mod.lev; t.typobj := obj; T := t + END ; + typtab[ref] := T + END + END + END InType; + + PROCEDURE Import*(VAR modid, modid1: ORS.Ident); + VAR key: LONGINT; class, k: INTEGER; + obj: Object; t: Type; + thismod: Object; + modname, fname: ORS.Ident; + F: Files.File; R: Files.Rider; + BEGIN + IF modid1 = "SYSTEM" THEN + thismod := ThisModule(modid, modid1, TRUE, key); DEC(nofmod); + thismod.lev := 0; thismod.dsc := system; thismod.rdo := TRUE + ELSE MakeFileName(fname, modid1, ".smb"); F := Files.Old(fname); + IF F # NIL THEN + Files.Set(R, F, 0); Files.ReadInt(R, key); Files.ReadInt(R, key); Files.ReadString(R, modname); + thismod := ThisModule(modid, modid1, TRUE, key); thismod.rdo := TRUE; + Read(R, class); (*version key*) + IF class # versionkey THEN ORS.Mark("wrong version") END ; + Read(R, class); + WHILE class # 0 DO + NEW(obj); obj.class := class; Files.ReadString(R, obj.name); + InType(R, thismod, obj.type); obj.lev := -thismod.lev; + IF class = Typ THEN + t := obj.type; t.typobj := obj; Read(R, k); (*fixup bases of previously declared pointer types*) + WHILE k # 0 DO typtab[k].base := t; Read(R, k) END + ELSE + IF class = Const THEN + IF obj.type.form = Real THEN Files.ReadInt(R, obj.val) ELSE Files.ReadNum(R, obj.val) END + ELSIF class = Var THEN Files.ReadNum(R, obj.val); obj.rdo := TRUE + END + END ; + obj.next := thismod.dsc; thismod.dsc := obj; Read(R, class) + END ; + ELSE ORS.Mark("import not available") + END + END + END Import; + + (*-------------------------------- Export ---------------------------------*) + + PROCEDURE Write(VAR R: Files.Rider; x: INTEGER); + BEGIN + (*Files.WriteByte(R, x)*) + Files.WriteByte(R, SHORT(SHORT(x))) (* voc adaptation by noch *) + END Write; + + PROCEDURE OutType(VAR R: Files.Rider; t: Type); + VAR obj, mod, fld: Object; + + PROCEDURE OutPar(VAR R: Files.Rider; par: Object; n: INTEGER); + VAR cl: INTEGER; + BEGIN + IF n > 0 THEN + OutPar(R, par.next, n-1); cl := par.class; + Write(R, cl); + IF par.rdo THEN Write(R, 1) ELSE Write(R, 0) END ; + OutType(R, par.type) + END + END OutPar; + + PROCEDURE FindHiddenPointers(VAR R: Files.Rider; typ: Type; offset: LONGINT); + VAR fld: Object; i, n: LONGINT; + BEGIN + IF (typ.form = Pointer) OR (typ.form = NilTyp) THEN Write(R, Fld); Write(R, 0); Files.WriteNum(R, offset) + ELSIF typ.form = Record THEN fld := typ.dsc; + WHILE fld # NIL DO FindHiddenPointers(R, fld.type, fld.val + offset); fld := fld.next END + ELSIF typ.form = Array THEN i := 0; n := typ.len; + WHILE i < n DO FindHiddenPointers(R, typ.base, typ.base.size * i + offset); INC(i) END + END + END FindHiddenPointers; + + BEGIN + IF t.ref > 0 THEN (*type was already output*) Write(R, -t.ref) + ELSE obj := t.typobj; + IF obj # NIL THEN Write(R, Ref); t.ref := Ref; INC(Ref) ELSE (*anonymous*) Write(R, 0) END ; + Write(R, t.form); + IF t.form = Pointer THEN OutType(R, t.base) + ELSIF t.form = Array THEN OutType(R, t.base); Files.WriteNum(R, t.len); Files.WriteNum(R, t.size) + ELSIF t.form = Record THEN + IF t.base # NIL THEN OutType(R, t.base) ELSE OutType(R, noType) END ; + IF obj # NIL THEN Files.WriteNum(R, obj.exno) ELSE Write(R, 0) END ; + Files.WriteNum(R, t.nofpar); Files.WriteNum(R, t.size); + fld := t.dsc; + WHILE fld # NIL DO (*fields*) + IF fld.expo THEN + Write(R, Fld); Files.WriteString(R, fld.name); OutType(R, fld.type); Files.WriteNum(R, fld.val) + ELSE FindHiddenPointers(R, fld.type, fld.val) (*offset*) + END ; + fld := fld.next + END ; + Write(R, 0) + ELSIF t.form = Proc THEN OutType(R, t.base); OutPar(R, t.dsc, t.nofpar); Write(R, 0) + END ; + IF (t.mno > 0) & (obj # NIL) THEN (*re-export, output name*) + mod := topScope.next; + WHILE (mod # NIL) & (mod.lev # t.mno) DO mod := mod.next END ; + IF mod # NIL THEN Files.WriteString(R, mod.name); Files.WriteInt(R, mod.val); Files.WriteString(R, obj.name) + ELSE ORS.Mark("re-export not found"); Write(R, 0) + END + ELSE Write(R, 0) + END + END + END OutType; + + PROCEDURE Export*(VAR modid: ORS.Ident; VAR newSF: BOOLEAN; VAR key: LONGINT); + VAR x, sum, oldkey: LONGINT; + obj, obj0: Object; + filename: ORS.Ident; + F, F1: Files.File; R, R1: Files.Rider; + BEGIN Ref := Record + 1; MakeFileName(filename, modid, ".smb"); + F := Files.New(filename); Files.Set(R, F, 0); + Files.WriteInt(R, 0); (*placeholder*) + Files.WriteInt(R, 0); (*placeholder for key to be inserted at the end*) + Files.WriteString(R, modid); Write(R, versionkey); + obj := topScope.next; + WHILE obj # NIL DO + IF obj.expo THEN + Write(R, obj.class); Files.WriteString(R, obj.name); + OutType(R, obj.type); + IF obj.class = Typ THEN + IF obj.type.form = Record THEN + obj0 := topScope.next; (*check whether this is base of previously declared pointer types*) + WHILE obj0 # obj DO + IF (obj0.type.form = Pointer) & (obj0.type.base = obj.type) & (obj0.type.ref > 0) THEN Write(R, obj0.type.ref) END ; + obj0 := obj0.next + END + END ; + Write(R, 0) + ELSIF obj.class = Const THEN + IF obj.type.form = Proc THEN Files.WriteNum(R, obj.exno) + ELSIF obj.type.form = Real THEN Files.WriteInt(R, obj.val) + ELSE Files.WriteNum(R, obj.val) + END + ELSIF obj.class = Var THEN + Files.WriteNum(R, obj.exno); + IF obj.type.form = String THEN + Files.WriteNum(R, obj.val DIV 10000H); obj.val := obj.val MOD 10000H + END + END + END ; + obj := obj.next + END ; + REPEAT Write(R, 0) UNTIL Files.Length(F) MOD 4 = 0; + FOR Ref := Record+1 TO maxTypTab-1 DO typtab[Ref] := NIL END ; + Files.Set(R, F, 0); sum := 0; Files.ReadInt(R, x); (* compute key (checksum) *) + WHILE ~R.eof DO sum := sum + x; Files.ReadInt(R, x) END ; + F1 := Files.Old(filename); (*sum is new key*) + IF F1 # NIL THEN Files.Set(R1, F1, 4); Files.ReadInt(R1, oldkey) ELSE oldkey := sum+1 END ; + IF sum # oldkey THEN + IF newSF OR (F1 = NIL) THEN + key := sum; newSF := TRUE; Files.Set(R, F, 4); Files.WriteInt(R, sum); Files.Register(F) (*insert checksum*) + ELSE ORS.Mark("new symbol file inhibited") + END + ELSE newSF := FALSE; key := sum + END + END Export; + + PROCEDURE Init*; + BEGIN topScope := universe; nofmod := 1 + END Init; + + PROCEDURE type(ref, form: INTEGER; size: LONGINT): Type; + VAR tp: Type; + BEGIN NEW(tp); tp.form := form; tp.size := size; tp.ref := ref; tp.base := NIL; + typtab[ref] := tp; RETURN tp + END type; + + PROCEDURE enter(name: ARRAY OF CHAR; cl: INTEGER; type: Type; n: LONGINT); + VAR obj: Object; + BEGIN + NEW(obj); + (*obj.name := name; *) + COPY(name, obj.name); (* voc adaptation by noch *) + obj.class := cl; + obj.type := type; + obj.val := n; + obj.dsc := NIL; + IF cl = Typ THEN type.typobj := obj END ; + obj.next := system; system := obj + END enter; + +BEGIN + byteType := type(Byte, Int, 1); + boolType := type(Bool, Bool, 1); + charType := type(Char, Char,1); + intType := type(Int, Int, 4); + realType := type(Real, Real, 4); + setType := type(Set, Set,4); + nilType := type(NilTyp, NilTyp, 4); + noType := type(NoTyp, NoTyp, 4); + strType := type(String, String, 8); + + (*initialize universe with data types and in-line procedures; + LONGINT is synonym to INTEGER, LONGREAL to REAL. + LED, ADC, SBC; LDPSR, LDREG, REG, COND are not in language definition*) + system := NIL; (*n = procno*10 + nofpar*) + enter("UML", SFunc, intType, 132); (*functions*) + enter("SBC", SFunc, intType, 122); + enter("ADC", SFunc, intType, 112); + enter("ROR", SFunc, intType, 92); + enter("ASR", SFunc, intType, 82); + enter("LSL", SFunc, intType, 72); + enter("LEN", SFunc, intType, 61); + enter("CHR", SFunc, charType, 51); + enter("ORD", SFunc, intType, 41); + enter("FLT", SFunc, realType, 31); + enter("FLOOR", SFunc, intType, 21); + enter("ODD", SFunc, boolType, 11); + enter("ABS", SFunc, intType, 1); + enter("LED", SProc, noType, 81); (*procedures*) + enter("UNPK", SProc, noType, 72); + enter("PACK", SProc, noType, 62); + enter("NEW", SProc, noType, 51); + enter("ASSERT", SProc, noType, 41); + enter("EXCL", SProc, noType, 32); + enter("INCL", SProc, noType, 22); + enter("DEC", SProc, noType, 11); + enter("INC", SProc, noType, 1); + enter("SET", Typ, setType, 0); (*types*) + enter("BOOLEAN", Typ, boolType, 0); + enter("BYTE", Typ, byteType, 0); + enter("CHAR", Typ, charType, 0); + enter("LONGREAL", Typ, realType, 0); + enter("REAL", Typ, realType, 0); + enter("LONGINT", Typ, intType, 0); + enter("INTEGER", Typ, intType, 0); + topScope := NIL; OpenScope; topScope.next := system; universe := topScope; + + system := NIL; (* initialize "unsafe" pseudo-module SYSTEM*) + enter("H", SFunc, intType, 201); (*functions*) + enter("COND", SFunc, boolType, 191); + enter("SIZE", SFunc, intType, 181); + enter("ADR", SFunc, intType, 171); + enter("VAL", SFunc, intType, 162); + enter("REG", SFunc, intType, 151); + enter("BIT", SFunc, boolType, 142); + enter("LDREG", SProc, noType, 142); (*procedures*) + enter("LDPSR", SProc, noType, 131); + enter("COPY", SProc, noType, 123); + enter("PUT", SProc, noType, 112); + enter("GET", SProc, noType, 102); +END ORB. diff --git a/src/voc07R/ORG.Mod b/src/voc07R/ORG.Mod index 9495337c..fef42932 100644 --- a/src/voc07R/ORG.Mod +++ b/src/voc07R/ORG.Mod @@ -1,1134 +1,1134 @@ -MODULE ORG; (* NW 24.6.2014 code generator in Oberon-07 for RISC*) - IMPORT SYSTEM, Files := CompatFiles, ORS, ORB; - (*Code generator for Oberon compiler for RISC processor. - Procedural interface to Parser OSAP; result in array "code". - Procedure Close writes code-files*) - - (* voc adaptation by noch *) - TYPE INTEGER = LONGINT; - BYTE = CHAR; - - CONST WordSize* = 4; - StkOrg0 = -64; VarOrg0 = 0; (*for RISC-0 only*) - MT = 12; SB = 13; SP = 14; LNK = 15; (*dedicated registers*) - maxCode = 8000; maxStrx = 2400; maxTD = 120; C24 = 1000000H; - Reg = 10; RegI = 11; Cond = 12; (*internal item modes*) - - (*frequently used opcodes*) U = 2000H; V = 1000H; - Mov = 0; Lsl = 1; Asr = 2; Ror= 3; And = 4; Ann = 5; Ior = 6; Xor = 7; - Add = 8; Sub = 9; Cmp = 9; Mul = 10; Div = 11; - Fad = 12; Fsb = 13; Fml = 14; Fdv = 15; - Ldr = 8; Str = 10; - BR = 0; BLR = 1; BC = 2; BL = 3; - MI = 0; PL = 8; EQ = 1; NE = 9; LT = 5; GE = 13; LE = 6; GT = 14; - - TYPE Item* = RECORD - mode*: INTEGER; - type*: ORB.Type; - a*, b*, r: LONGINT; - rdo*: BOOLEAN (*read only*) - END ; - - (* Item forms and meaning of fields: - mode r a b - -------------------------------- - Const - value (proc adr) (immediate value) - Var base off - (direct adr) - Par - off0 off1 (indirect adr) - Reg regno - RegI regno off - - Cond cond Fchain Tchain *) - - VAR pc*, varsize: LONGINT; (*program counter, data index*) - tdx, strx: LONGINT; - entry: LONGINT; (*main entry point*) - RH: LONGINT; (*available registers R[0] ... R[H-1]*) - curSB: LONGINT; (*current static base in SB*) - frame: LONGINT; (*frame offset changed in SaveRegs and RestoreRegs*) - fixorgP, fixorgD, fixorgT: LONGINT; (*origins of lists of locations to be fixed up by loader*) - check: BOOLEAN; (*emit run-time checks*) - version: INTEGER; (* 0 = RISC-0, 1 = RISC-5 *) - - relmap: ARRAY 6 OF INTEGER; (*condition codes for relations*) - code: ARRAY maxCode OF LONGINT; - data: ARRAY maxTD OF LONGINT; (*type descriptors*) - str: ARRAY maxStrx OF CHAR; - - (* voc adaptation by noch *) - PROCEDURE LSL (x, n : INTEGER): INTEGER; - - BEGIN - - RETURN ASH(x, n); - END LSL; - - - (*instruction assemblers according to formats*) - - PROCEDURE Put0(op, a, b, c: LONGINT); - BEGIN (*emit format-0 instruction*) - code[pc] := ((a*10H + b) * 10H + op) * 10000H + c; INC(pc) - END Put0; - - PROCEDURE Put1(op, a, b, im: LONGINT); - BEGIN (*emit format-1 instruction, -10000H <= im < 10000H*) - IF im < 0 THEN INC(op, V) END ; - code[pc] := (((a+40H) * 10H + b) * 10H + op) * 10000H + (im MOD 10000H); INC(pc) - END Put1; - - PROCEDURE Put1a(op, a, b, im: LONGINT); - BEGIN (*same as Pu1, but with range test -10000H <= im < 10000H*) - IF (im >= -10000H) & (im <= 0FFFFH) THEN Put1(op, a, b, im) - ELSE Put1(Mov+U, RH, 0, im DIV 10000H); - IF im MOD 10000H # 0 THEN Put1(Ior, RH, RH, im MOD 10000H) END ; - Put0(op, a, b, RH) - END - END Put1a; - - PROCEDURE Put2(op, a, b, off: LONGINT); - BEGIN (*emit load/store instruction*) - code[pc] := ((op * 10H + a) * 10H + b) * 100000H + (off MOD 100000H); INC(pc) - END Put2; - - PROCEDURE Put3(op, cond, off: LONGINT); - BEGIN (*emit branch instruction*) - code[pc] := ((op+12) * 10H + cond) * 1000000H + (off MOD 1000000H); INC(pc) - END Put3; - - PROCEDURE incR; - BEGIN - IF RH < MT-1 THEN INC(RH) ELSE ORS.Mark("register stack overflow") END - END incR; - - PROCEDURE CheckRegs*; - BEGIN - IF RH # 0 THEN ORS.Mark("Reg Stack"); RH := 0 END ; - IF pc >= maxCode - 40 THEN ORS.Mark("Program too long") END - END CheckRegs; - - PROCEDURE SetCC(VAR x: Item; n: LONGINT); - BEGIN x.mode := Cond; x.a := 0; x.b := 0; x.r := n - END SetCC; - - PROCEDURE Trap(cond, num: LONGINT); - BEGIN num := ORS.Pos()*100H + num*10H + MT; Put3(BLR, cond, num) - END Trap; - - (*handling of forward reference, fixups of branch addresses and constant tables*) - - PROCEDURE negated(cond: LONGINT): LONGINT; - BEGIN - IF cond < 8 THEN cond := cond+8 ELSE cond := cond-8 END ; - RETURN cond - END negated; - - PROCEDURE invalSB; - BEGIN curSB := 1 - END invalSB; - - PROCEDURE fix(at, with: LONGINT); - BEGIN code[at] := code[at] DIV C24 * C24 + (with MOD C24) - END fix; - - PROCEDURE FixLink*(L: LONGINT); - VAR L1: LONGINT; - BEGIN invalSB; - WHILE L # 0 DO L1 := code[L] MOD 40000H; fix(L, pc-L-1); L := L1 END - END FixLink; - - PROCEDURE FixLinkWith(L0, dst: LONGINT); - VAR L1: LONGINT; - BEGIN - WHILE L0 # 0 DO - L1 := code[L0] MOD C24; - code[L0] := code[L0] DIV C24 * C24 + ((dst - L0 - 1) MOD C24); L0 := L1 - END - END FixLinkWith; - - PROCEDURE merged(L0, L1: LONGINT): LONGINT; - VAR L2, L3: LONGINT; - BEGIN - IF L0 # 0 THEN L3 := L0; - REPEAT L2 := L3; L3 := code[L2] MOD 40000H UNTIL L3 = 0; - code[L2] := code[L2] + L1; L1 := L0 - END ; - RETURN L1 - END merged; - - (* loading of operands and addresses into registers *) - - PROCEDURE GetSB(base: LONGINT); - BEGIN - IF (version # 0) & ((base # curSB) OR (base # 0)) THEN - Put2(Ldr, SB, -base, pc-fixorgD); fixorgD := pc-1; curSB := base - END - END GetSB; - - PROCEDURE NilCheck; - BEGIN IF check THEN Trap(EQ, 4) END - END NilCheck; - - PROCEDURE load(VAR x: Item); - VAR op: LONGINT; - BEGIN - IF x.type.size = 1 THEN op := Ldr+1 ELSE op := Ldr END ; - IF x.mode # Reg THEN - IF x.mode = ORB.Const THEN - IF x.type.form = ORB.Proc THEN - IF x.r > 0 THEN ORS.Mark("not allowed") - ELSIF x.r = 0 THEN Put3(BL, 7, 0); Put1a(Sub, RH, LNK, pc*4 - x.a) - ELSE GetSB(x.r); Put1(Add, RH, SB, x.a + 100H) (*mark as progbase-relative*) - END - ELSIF (x.a <= 0FFFFH) & (x.a >= -10000H) THEN Put1(Mov, RH, 0, x.a) - ELSE Put1(Mov+U, RH, 0, x.a DIV 10000H MOD 10000H); - IF x.a MOD 10000H # 0 THEN Put1(Ior, RH, RH, x.a MOD 10000H) END - END ; - x.r := RH; incR - ELSIF x.mode = ORB.Var THEN - IF x.r > 0 THEN (*local*) Put2(op, RH, SP, x.a + frame) - ELSE GetSB(x.r); Put2(op, RH, SB, x.a) - END ; - x.r := RH; incR - ELSIF x.mode = ORB.Par THEN Put2(Ldr, RH, SP, x.a + frame); Put2(op, RH, RH, x.b); x.r := RH; incR - ELSIF x.mode = RegI THEN Put2(op, x.r, x.r, x.a) - ELSIF x.mode = Cond THEN - Put3(BC, negated(x.r), 2); - FixLink(x.b); Put1(Mov, RH, 0, 1); Put3(BC, 7, 1); - FixLink(x.a); Put1(Mov, RH, 0, 0); x.r := RH; incR - END ; - x.mode := Reg - END - END load; - - PROCEDURE loadAdr(VAR x: Item); - BEGIN - IF x.mode = ORB.Var THEN - IF x.r > 0 THEN (*local*) Put1a(Add, RH, SP, x.a + frame) - ELSE GetSB(x.r); Put1a(Add, RH, SB, x.a) - END ; - x.r := RH; incR - ELSIF x.mode = ORB.Par THEN Put2(Ldr, RH, SP, x.a + frame); - IF x.b # 0 THEN Put1a(Add, RH, RH, x.b) END ; - x.r := RH; incR - ELSIF x.mode = RegI THEN - IF x.a # 0 THEN Put1a(Add, x.r, x.r, x.a) END - ELSE ORS.Mark("address error") - END ; - x.mode := Reg - END loadAdr; - - PROCEDURE loadCond(VAR x: Item); - BEGIN - IF x.type.form = ORB.Bool THEN - IF x.mode = ORB.Const THEN x.r := 15 - x.a*8 - ELSE load(x); - IF code[pc-1] DIV 40000000H # -2 THEN Put1(Cmp, x.r, x.r, 0) END ; - x.r := NE; DEC(RH) - END ; - x.mode := Cond; x.a := 0; x.b := 0 - ELSE ORS.Mark("not Boolean?") - END - END loadCond; - - PROCEDURE loadTypTagAdr(T: ORB.Type); - VAR x: Item; - BEGIN x.mode := ORB.Var; x.a := T.len; x.r := -T.mno; loadAdr(x) - END loadTypTagAdr; - - PROCEDURE loadStringAdr(VAR x: Item); - BEGIN GetSB(0); Put1a(Add, RH, SB, varsize+x.a); x.mode := Reg; x.r := RH; incR - END loadStringAdr; - - (* Items: Conversion from constants or from Objects on the Heap to Items on the Stack*) - - PROCEDURE MakeConstItem*(VAR x: Item; typ: ORB.Type; val: LONGINT); - BEGIN x.mode := ORB.Const; x.type := typ; x.a := val - END MakeConstItem; - - PROCEDURE MakeRealItem*(VAR x: Item; val: REAL); - BEGIN x.mode := ORB.Const; x.type := ORB.realType; x.a := SYSTEM.VAL(LONGINT, val) - END MakeRealItem; - - PROCEDURE MakeStringItem*(VAR x: Item; len: LONGINT); (*copies string from ORS-buffer to ORG-string array*) - VAR i: LONGINT; - BEGIN x.mode := ORB.Const; x.type := ORB.strType; x.a := strx; x.b := len; i := 0; - IF strx + len + 4 < maxStrx THEN - WHILE len > 0 DO str[strx] := ORS.str[i]; INC(strx); INC(i); DEC(len) END ; - WHILE strx MOD 4 # 0 DO str[strx] := 0X; INC(strx) END - ELSE ORS.Mark("too many strings") - END - END MakeStringItem; - - PROCEDURE MakeItem*(VAR x: Item; y: ORB.Object; curlev: LONGINT); - BEGIN x.mode := y.class; x.type := y.type; x.a := y.val; x.rdo := y.rdo; - IF y.class = ORB.Par THEN x.b := 0 - ELSIF y.class = ORB.Typ THEN x.a := y.type.len; x.r := -y.lev - ELSIF (y.class = ORB.Const) & (y.type.form = ORB.String) THEN x.b := y.lev (*len*) - ELSE x.r := y.lev - END ; - IF (y.lev > 0) & (y.lev # curlev) & (y.class # ORB.Const) THEN ORS.Mark("level error, not accessible") END - END MakeItem; - - (* Code generation for Selectors, Variables, Constants *) - - PROCEDURE Field*(VAR x: Item; y: ORB.Object); (* x := x.y *) - BEGIN; - IF x.mode = ORB.Var THEN - IF x.r >= 0 THEN x.a := x.a + y.val - ELSE loadAdr(x); x.mode := RegI; x.a := y.val - END - ELSIF x.mode = RegI THEN x.a := x.a + y.val - ELSIF x.mode = ORB.Par THEN x.b := x.b + y.val - END - END Field; - - PROCEDURE Index*(VAR x, y: Item); (* x := x[y] *) - VAR s, lim: LONGINT; - BEGIN s := x.type.base.size; lim := x.type.len; - IF (y.mode = ORB.Const) & (lim >= 0) THEN - IF (y.a < 0) OR (y.a >= lim) THEN ORS.Mark("bad index") END ; - IF x.mode IN {ORB.Var, RegI} THEN x.a := y.a * s + x.a - ELSIF x.mode = ORB.Par THEN x.b := y.a * s + x.b - END - ELSE load(y); - IF check THEN (*check array bounds*) - IF lim >= 0 THEN Put1a(Cmp, RH, y.r, lim) - ELSE (*open array*) - IF x.mode IN {ORB.Var, ORB.Par} THEN Put2(Ldr, RH, SP, x.a+4+frame); Put0(Cmp, RH, y.r, RH) - ELSE ORS.Mark("error in Index") - END - END ; - Trap(10, 1) (*BCC*) - END ; - IF s = 4 THEN Put1(Lsl, y.r, y.r, 2) ELSIF s > 1 THEN Put1a(Mul, y.r, y.r, s) END ; - IF x.mode = ORB.Var THEN - IF x.r > 0 THEN Put0(Add, y.r, SP, y.r); INC(x.a, frame) - ELSE GetSB(x.r); - IF x.r = 0 THEN Put0(Add, y.r, SB, y.r) - ELSE Put1a(Add, RH, SB, x.a); Put0(Add, y.r, RH, y.r); x.a := 0 - END - END ; - x.r := y.r; x.mode := RegI - ELSIF x.mode = ORB.Par THEN - Put2(Ldr, RH, SP, x.a + frame); - Put0(Add, y.r, RH, y.r); x.mode := RegI; x.r := y.r; x.a := x.b - ELSIF x.mode = RegI THEN Put0(Add, x.r, x.r, y.r); DEC(RH) - END - END - END Index; - - PROCEDURE DeRef*(VAR x: Item); - BEGIN - IF x.mode = ORB.Var THEN - IF x.r > 0 THEN (*local*) Put2(Ldr, RH, SP, x.a + frame) ELSE GetSB(x.r); Put2(Ldr, RH, SB, x.a) END ; - NilCheck; x.r := RH; incR - ELSIF x.mode = ORB.Par THEN - Put2(Ldr, RH, SP, x.a + frame); Put2(Ldr, RH, RH, x.b); NilCheck; x.r := RH; incR - ELSIF x.mode = RegI THEN Put2(Ldr, x.r, x.r, x.a); NilCheck - ELSIF x.mode # Reg THEN ORS.Mark("bad mode in DeRef") - END ; - x.mode := RegI; x.a := 0; x.b := 0 - END DeRef; - - PROCEDURE Q(T: ORB.Type; VAR dcw: LONGINT); - BEGIN (*one entry of type descriptor extension table*) - IF T.base # NIL THEN - Q(T.base, dcw); data[dcw] := (T.mno*1000H + T.len) * 1000H + dcw - fixorgT; - fixorgT := dcw; INC(dcw) - END - END Q; - - PROCEDURE FindPtrFlds(typ: ORB.Type; off: LONGINT; VAR dcw: LONGINT); - VAR fld: ORB.Object; i, s: LONGINT; - BEGIN - IF (typ.form = ORB.Pointer) OR (typ.form = ORB.NilTyp) THEN data[dcw] := off; INC(dcw) - ELSIF typ.form = ORB.Record THEN - fld := typ.dsc; - WHILE fld # NIL DO FindPtrFlds(fld.type, fld.val + off, dcw); fld := fld.next END - ELSIF typ.form = ORB.Array THEN - s := typ.base.size; - FOR i := 0 TO typ.len-1 DO FindPtrFlds(typ.base, i*s + off, dcw) END - END - END FindPtrFlds; - - PROCEDURE BuildTD*(T: ORB.Type; VAR dc: LONGINT); - VAR dcw, k, s: LONGINT; (*dcw = word address*) - BEGIN dcw := dc DIV 4; s := T.size; (*convert size for heap allocation*) - IF s <= 24 THEN s := 32 ELSIF s <= 56 THEN s := 64 ELSIF s <= 120 THEN s := 128 - ELSE s := (s+263) DIV 256 * 256 - END ; - T.len := dc; data[dcw] := s; INC(dcw); - k := T.nofpar; (*extension level!*) - IF k > 3 THEN ORS.Mark("ext level too large") - ELSE Q(T, dcw); - WHILE k < 3 DO data[dcw] := -1; INC(dcw); INC(k) END - END ; - FindPtrFlds(T, 0, dcw); data[dcw] := -1; INC(dcw); tdx := dcw; dc := dcw*4; - IF tdx >= maxTD THEN ORS.Mark("too many record types"); tdx := 0 END - END BuildTD; - - PROCEDURE TypeTest*(VAR x: Item; T: ORB.Type; varpar, isguard: BOOLEAN); - VAR pc0: LONGINT; - BEGIN (*fetch tag into RH*) - IF varpar THEN Put2(Ldr, RH, SP, x.a+4+frame) - ELSE load(x); - pc0 := pc; Put3(BC, EQ, 0); (*NIL belongs to every pointer type*) - Put2(Ldr, RH, x.r, -8) - END ; - Put2(Ldr, RH, RH, T.nofpar*4); incR; - loadTypTagAdr(T); (*tag of T*) - Put0(Cmp, RH-1, RH-1, RH-2); DEC(RH, 2); - IF ~varpar THEN fix(pc0, pc - pc0 - 1) END ; - IF isguard THEN - IF check THEN Trap(NE, 2) END - ELSE SetCC(x, EQ); - IF ~varpar THEN DEC(RH) END - END - END TypeTest; - - (* Code generation for Boolean operators *) - - PROCEDURE Not*(VAR x: Item); (* x := ~x *) - VAR t: LONGINT; - BEGIN - IF x.mode # Cond THEN loadCond(x) END ; - x.r := negated(x.r); t := x.a; x.a := x.b; x.b := t - END Not; - - PROCEDURE And1*(VAR x: Item); (* x := x & *) - BEGIN - IF x.mode # Cond THEN loadCond(x) END ; - Put3(BC, negated(x.r), x.a); x.a := pc-1; FixLink(x.b); x.b := 0 - END And1; - - PROCEDURE And2*(VAR x, y: Item); - BEGIN - IF y.mode # Cond THEN loadCond(y) END ; - x.a := merged(y.a, x.a); x.b := y.b; x.r := y.r - END And2; - - PROCEDURE Or1*(VAR x: Item); (* x := x OR *) - BEGIN - IF x.mode # Cond THEN loadCond(x) END ; - Put3(BC, x.r, x.b); x.b := pc-1; FixLink(x.a); x.a := 0 - END Or1; - - PROCEDURE Or2*(VAR x, y: Item); - BEGIN - IF y.mode # Cond THEN loadCond(y) END ; - x.a := y.a; x.b := merged(y.b, x.b); x.r := y.r - END Or2; - - (* Code generation for arithmetic operators *) - - PROCEDURE Neg*(VAR x: Item); (* x := -x *) - BEGIN - IF x.type.form = ORB.Int THEN - IF x.mode = ORB.Const THEN x.a := -x.a - ELSE load(x); Put1(Mov, RH, 0, 0); Put0(Sub, x.r, RH, x.r) - END - ELSIF x.type.form = ORB.Real THEN - IF x.mode = ORB.Const THEN x.a := x.a + 7FFFFFFFH + 1 - ELSE load(x); Put1(Mov, RH, 0, 0); Put0(Fsb, x.r, RH, x.r) - END - ELSE (*form = Set*) - IF x.mode = ORB.Const THEN x.a := -x.a-1 - ELSE load(x); Put1(Xor, x.r, x.r, -1) - END - END - END Neg; - - PROCEDURE AddOp*(op: LONGINT; VAR x, y: Item); (* x := x +- y *) - BEGIN - IF op = ORS.plus THEN - IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN x.a := x.a + y.a - ELSIF y.mode = ORB.Const THEN load(x); - IF y.a # 0 THEN Put1a(Add, x.r, x.r, y.a) END - ELSE load(x); load(y); Put0(Add, RH-2, x.r, y.r); DEC(RH); x.r := RH-1 - END - ELSE (*op = ORS.minus*) - IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN x.a := x.a - y.a - ELSIF y.mode = ORB.Const THEN load(x); - IF y.a # 0 THEN Put1a(Sub, x.r, x.r, y.a) END - ELSE load(x); load(y); Put0(Sub, RH-2, x.r, y.r); DEC(RH); x.r := RH-1 - END - END - END AddOp; - - PROCEDURE log2(m: LONGINT; VAR e: LONGINT): LONGINT; - BEGIN e := 0; - WHILE ~ODD(m) DO m := m DIV 2; INC(e) END ; - RETURN m - END log2; - - PROCEDURE MulOp*(VAR x, y: Item); (* x := x * y *) - VAR e: LONGINT; - BEGIN - IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN x.a := x.a * y.a - ELSIF (y.mode = ORB.Const) & (y.a >= 2) & (log2(y.a, e) = 1) THEN load(x); Put1(Lsl, x.r, x.r, e) - ELSIF y.mode = ORB.Const THEN load(x); Put1a(Mul, x.r, x.r, y.a) - ELSIF (x.mode = ORB.Const) & (x.a >= 2) & (log2(x.a, e) = 1) THEN load(y); Put1(Lsl, y.r, y.r, e); x.mode := Reg; x.r := y.r - ELSIF x.mode = ORB.Const THEN load(y); Put1a(Mul, y.r, y.r, x.a); x.mode := Reg; x.r := y.r - ELSE load(x); load(y); Put0(Mul, RH-2, x.r, y.r); DEC(RH); x.r := RH-1 - END - END MulOp; - - PROCEDURE DivOp*(op: LONGINT; VAR x, y: Item); (* x := x op y *) - VAR e: LONGINT; - BEGIN - IF op = ORS.div THEN - IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN - IF y.a > 0 THEN x.a := x.a DIV y.a ELSE ORS.Mark("bad divisor") END - ELSIF (y.mode = ORB.Const) & (y.a >= 2) & (log2(y.a, e) = 1) THEN load(x); Put1(Asr, x.r, x.r, e) - ELSIF y.mode = ORB.Const THEN - IF y.a > 0 THEN load(x); Put1a(Div, x.r, x.r, y.a) ELSE ORS.Mark("bad divisor") END - ELSE load(y); - IF check THEN Trap(LE, 6) END ; - load(x); Put0(Div, RH-2, x.r, y.r); DEC(RH); x.r := RH-1 - END - ELSE (*op = ORS.mod*) - IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN - IF y.a > 0 THEN x.a := x.a MOD y.a ELSE ORS.Mark("bad modulus") END - ELSIF (y.mode = ORB.Const) & (y.a >= 2) & (log2(y.a, e) = 1) THEN load(x); - IF e <= 16 THEN Put1(And, x.r, x.r, y.a-1) ELSE Put1(Lsl, x.r, x.r, 32-e); Put1(Ror, x.r, x.r, 32-e) END - ELSIF y.mode = ORB.Const THEN - IF y.a > 0 THEN load(x); Put1a(Div, x.r, x.r, y.a); Put0(Mov+U, x.r, 0, 0) ELSE ORS.Mark("bad modulus") END - ELSE load(y); - IF check THEN Trap(LE, 6) END ; - load(x); Put0(Div, RH-2, x.r, y.r); Put0(Mov+U, RH-2, 0, 0); DEC(RH); x.r := RH-1 - END - END - END DivOp; - - (* Code generation for REAL operators *) - - PROCEDURE RealOp*(op: INTEGER; VAR x, y: Item); (* x := x op y *) - BEGIN load(x); load(y); - IF op = ORS.plus THEN Put0(Fad, RH-2, x.r, y.r) - ELSIF op = ORS.minus THEN Put0(Fsb, RH-2, x.r, y.r) - ELSIF op = ORS.times THEN Put0(Fml, RH-2, x.r, y.r) - ELSIF op = ORS.rdiv THEN Put0(Fdv, RH-2, x.r, y.r) - END ; - DEC(RH); x.r := RH-1 - END RealOp; - - (* Code generation for set operators *) - - PROCEDURE Singleton*(VAR x: Item); (* x := {x} *) - BEGIN - IF x.mode = ORB.Const THEN - x.a := LSL(1, x.a) - ELSE load(x); Put1(Mov, RH, 0, 1); Put0(Lsl, x.r, RH, x.r) - END - END Singleton; - - PROCEDURE Set*(VAR x, y: Item); (* x := {x .. y} *) - BEGIN - IF (x.mode = ORB.Const) & ( y.mode = ORB.Const) THEN - IF x.a <= y.a THEN x.a := LSL(2, y.a) - LSL(1, x.a) ELSE x.a := 0 END - ELSE - IF (x.mode = ORB.Const) & (x.a < 16) THEN x.a := LSL(-1, x.a) - ELSE load(x); Put1(Mov, RH, 0, -1); Put0(Lsl, x.r, RH, x.r) - END ; - IF (y.mode = ORB.Const) & (y.a < 16) THEN Put1(Mov, RH, 0, LSL(-2, y.a)); y.mode := Reg; y.r := RH; incR - ELSE load(y); Put1(Mov, RH, 0, -2); Put0(Lsl, y.r, RH, y.r) - END ; - IF x.mode = ORB.Const THEN - IF x.a # 0 THEN Put1(Xor, y.r, y.r, -1); Put1a(And, RH-1, y.r, x.a) END ; - x.mode := Reg; x.r := RH-1 - ELSE DEC(RH); Put0(Ann, RH-1, x.r, y.r) - END - END - END Set; - - PROCEDURE In*(VAR x, y: Item); (* x := x IN y *) - BEGIN load(y); - IF x.mode = ORB.Const THEN Put1(Ror, y.r, y.r, (x.a + 1) MOD 20H); DEC(RH) - ELSE load(x); Put1(Add, x.r, x.r, 1); Put0(Ror, y.r, y.r, x.r); DEC(RH, 2) - END ; - SetCC(x, MI) - END In; - - PROCEDURE SetOp*(op: LONGINT; VAR x, y: Item); (* x := x op y *) - VAR xset, yset: SET; (*x.type.form = Set*) - BEGIN - IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN - xset := SYSTEM.VAL(SET, x.a); yset := SYSTEM.VAL(SET, y.a); - IF op = ORS.plus THEN xset := xset + yset - ELSIF op = ORS.minus THEN xset := xset - yset - ELSIF op = ORS.times THEN xset := xset * yset - ELSIF op = ORS.rdiv THEN xset := xset / yset - END ; - x.a := SYSTEM.VAL(LONGINT, xset) - ELSIF y.mode = ORB.Const THEN - load(x); - IF op = ORS.plus THEN Put1a(Ior, x.r, x.r, y.a) - ELSIF op = ORS.minus THEN Put1a(Ann, x.r, x.r, y.a) - ELSIF op = ORS.times THEN Put1a(And, x.r, x.r, y.a) - ELSIF op = ORS.rdiv THEN Put1a(Xor, x.r, x.r, y.a) - END ; - ELSE load(x); load(y); - IF op = ORS.plus THEN Put0(Ior, RH-2, x.r, y.r) - ELSIF op = ORS.minus THEN Put0(Ann, RH-2, x.r, y.r) - ELSIF op = ORS.times THEN Put0(And, RH-2, x.r, y.r) - ELSIF op = ORS.rdiv THEN Put0(Xor, RH-2, x.r, y.r) - END ; - DEC(RH); x.r := RH-1 - END - END SetOp; - - (* Code generation for relations *) - - PROCEDURE IntRelation*(op: INTEGER; VAR x, y: Item); (* x := x < y *) - BEGIN - IF (y.mode = ORB.Const) & (y.type.form # ORB.Proc) THEN - load(x); - IF (y.a # 0) OR ~(op IN {ORS.eql, ORS.neq}) OR (code[pc-1] DIV 40000000H # -2) THEN Put1a(Cmp, x.r, x.r, y.a) END ; - DEC(RH) - ELSE load(x); load(y); Put0(Cmp, x.r, x.r, y.r); DEC(RH, 2) - END ; - SetCC(x, relmap[op - ORS.eql]) - END IntRelation; - - PROCEDURE SetRelation*(op: INTEGER; VAR x, y: Item); (* x := x < y *) - BEGIN load(x); - IF (op = ORS.eql) OR (op = ORS.neq) THEN - IF y.mode = ORB.Const THEN Put1a(Cmp, x.r, x.r, y.a); DEC(RH) - ELSE load(y); Put0(Cmp, x.r, x.r, y.r); DEC(RH, 2) - END ; - SetCC(x, relmap[op - ORS.eql]) - ELSE ORS.Mark("illegal relation") - END - END SetRelation; - - PROCEDURE RealRelation*(op: INTEGER; VAR x, y: Item); (* x := x < y *) - BEGIN load(x); - IF (y.mode = ORB.Const) & (y.a = 0) THEN DEC(RH) - ELSE load(y); Put0(Fsb, x.r, x.r, y.r); DEC(RH, 2) - END ; - SetCC(x, relmap[op - ORS.eql]) - END RealRelation; - - PROCEDURE StringRelation*(op: INTEGER; VAR x, y: Item); (* x := x < y *) - (*x, y are char arrays or strings*) - BEGIN - IF x.type.form = ORB.String THEN loadStringAdr(x) ELSE loadAdr(x) END ; - IF y.type.form = ORB.String THEN loadStringAdr(y) ELSE loadAdr(y) END ; - Put2(Ldr+1, RH, x.r, 0); Put1(Add, x.r, x.r, 1); - Put2(Ldr+1, RH+1, y.r, 0); Put1(Add, y.r, y.r, 1); - Put0(Cmp, RH+2, RH, RH+1); Put3(BC, NE, 2); - Put1(Cmp, RH+2, RH, 0); Put3(BC, NE, -8); - DEC(RH, 2); SetCC(x, relmap[op - ORS.eql]) - END StringRelation; - - (* Code generation of Assignments *) - - PROCEDURE StrToChar*(VAR x: Item); - BEGIN x.type := ORB.charType; DEC(strx, 4); x.a := ORD(str[x.a]) - END StrToChar; - - PROCEDURE Store*(VAR x, y: Item); (* x := y *) - VAR op: LONGINT; - BEGIN load(y); - IF x.type.size = 1 THEN op := Str+1 ELSE op := Str END ; - IF x.mode = ORB.Var THEN - IF x.r > 0 THEN (*local*) Put2(op, y.r, SP, x.a + frame) - ELSE GetSB(x.r); Put2(op, y.r, SB, x.a) - END - ELSIF x.mode = ORB.Par THEN Put2(Ldr, RH, SP, x.a + frame); Put2(op, y.r, RH, x.b); - ELSIF x.mode = RegI THEN Put2(op, y.r, x.r, x.a); DEC(RH); - ELSE ORS.Mark("bad mode in Store") - END ; - DEC(RH) - END Store; - - PROCEDURE StoreStruct*(VAR x, y: Item); (* x := y, frame = 0 *) - VAR s, pc0: LONGINT; - BEGIN loadAdr(x); loadAdr(y); - IF (x.type.form = ORB.Array) & (x.type.len > 0) THEN - IF y.type.len >= 0 THEN - IF x.type.len >= y.type.len THEN Put1a(Mov, RH, 0, (y.type.size+3) DIV 4) - ELSE ORS.Mark("source array too long") - END - ELSE (*y is open array*) - Put2(Ldr, RH, SP, y.a+4); s := y.type.base.size; (*element size*) - pc0 := pc; Put3(BC, EQ, 0); - IF s = 1 THEN Put1(Add, RH, RH, 3); Put1(Asr, RH, RH, 2) - ELSIF s # 4 THEN Put1a(Mul, RH, RH, s DIV 4) - END ; - IF check THEN - Put1a(Mov, RH+1, 0, (x.type.size+3) DIV 4); Put0(Cmp, RH+1, RH, RH+1); Trap(GT, 3) - END ; - fix(pc0, pc + 5 - pc0) - END - ELSIF x.type.form = ORB.Record THEN Put1a(Mov, RH, 0, x.type.size DIV 4) - ELSE ORS.Mark("inadmissible assignment") - END ; - Put2(Ldr, RH+1, y.r, 0); Put1(Add, y.r, y.r, 4); - Put2(Str, RH+1, x.r, 0); Put1(Add, x.r, x.r, 4); - Put1(Sub, RH, RH, 1); Put3(BC, NE, -6); DEC(RH, 2) - END StoreStruct; - - PROCEDURE CopyString*(VAR x, y: Item); (*from x to y*) - VAR len: LONGINT; - BEGIN loadAdr(y); len := y.type.len; - IF len >= 0 THEN - IF x.b > len THEN ORS.Mark("string too long") END - ELSIF check THEN Put2(Ldr, RH, y.r, 4); (*array length check*) - Put1(Cmp, RH, RH, x.b); Trap(NE, 3) - END ; - loadStringAdr(x); - Put2(Ldr, RH, x.r, 0); Put1(Add, x.r, x.r, 4); - Put2(Str, RH, y.r, 0); Put1(Add, y.r, y.r, 4); - Put1(Asr, RH, RH, 24); Put3(BC, NE, -6); DEC(RH, 2) - END CopyString; - - (* Code generation for parameters *) - - PROCEDURE VarParam*(VAR x: Item; ftype: ORB.Type); - VAR xmd: INTEGER; - BEGIN xmd := x.mode; loadAdr(x); - IF (ftype.form = ORB.Array) & (ftype.len < 0) THEN (*open array*) - IF x.type.len >= 0 THEN Put1a(Mov, RH, 0, x.type.len) ELSE Put2(Ldr, RH, SP, x.a+4+frame) END ; - incR - ELSIF ftype.form = ORB.Record THEN - IF xmd = ORB.Par THEN Put2(Ldr, RH, SP, x.a+4+frame); incR ELSE loadTypTagAdr(x.type) END - END - END VarParam; - - PROCEDURE ValueParam*(VAR x: Item); - BEGIN load(x) - END ValueParam; - - PROCEDURE OpenArrayParam*(VAR x: Item); - BEGIN loadAdr(x); - IF x.type.len >= 0 THEN Put1a(Mov, RH, 0, x.type.len) ELSE Put2(Ldr, RH, SP, x.a+4+frame) END ; - incR - END OpenArrayParam; - - PROCEDURE StringParam*(VAR x: Item); - BEGIN loadStringAdr(x); Put1(Mov, RH, 0, x.b); incR (*len*) - END StringParam; - - (*For Statements*) - - PROCEDURE For0*(VAR x, y: Item); - BEGIN load(y) - END For0; - - PROCEDURE For1*(VAR x, y, z, w: Item; VAR L: LONGINT); - BEGIN - IF z.mode = ORB.Const THEN Put1a(Cmp, RH, y.r, z.a) - ELSE load(z); Put0(Cmp, RH-1, y.r, z.r); DEC(RH) - END ; - L := pc; - IF w.a > 0 THEN Put3(BC, GT, 0) - ELSIF w.a < 0 THEN Put3(BC, LT, 0) - ELSE ORS.Mark("zero increment"); Put3(BC, MI, 0) - END ; - Store(x, y) - END For1; - - PROCEDURE For2*(VAR x, y, w: Item); - BEGIN load(x); DEC(RH); Put1a(Add, x.r, x.r, w.a) - END For2; - - (* Branches, procedure calls, procedure prolog and epilog *) - - PROCEDURE Here*(): LONGINT; - BEGIN invalSB; RETURN pc - END Here; - - PROCEDURE FJump*(VAR L: LONGINT); - BEGIN Put3(BC, 7, L); L := pc-1 - END FJump; - - PROCEDURE CFJump*(VAR x: Item); - BEGIN - IF x.mode # Cond THEN loadCond(x) END ; - Put3(BC, negated(x.r), x.a); FixLink(x.b); x.a := pc-1 - END CFJump; - - PROCEDURE BJump*(L: LONGINT); - BEGIN Put3(BC, 7, L-pc-1) - END BJump; - - PROCEDURE CBJump*(VAR x: Item; L: LONGINT); - BEGIN - IF x.mode # Cond THEN loadCond(x) END ; - Put3(BC, negated(x.r), L-pc-1); FixLink(x.b); FixLinkWith(x.a, L) - END CBJump; - - PROCEDURE Fixup*(VAR x: Item); - BEGIN FixLink(x.a) - END Fixup; - - PROCEDURE SaveRegs(r: LONGINT); (* R[0 .. r-1]*) - VAR r0: LONGINT; - BEGIN (*r > 0*) r0 := 0; - Put1(Sub, SP, SP, r*4); INC(frame, 4*r); - REPEAT Put2(Str, r0, SP, (r-r0-1)*4); INC(r0) UNTIL r0 = r - END SaveRegs; - - PROCEDURE RestoreRegs(r: LONGINT); (*R[0 .. r-1]*) - VAR r0: LONGINT; - BEGIN (*r > 0*) r0 := r; - REPEAT DEC(r0); Put2(Ldr, r0, SP, (r-r0-1)*4) UNTIL r0 = 0; - Put1(Add, SP, SP, r*4); DEC(frame, 4*r) - END RestoreRegs; - - PROCEDURE PrepCall*(VAR x: Item; VAR r: LONGINT); - BEGIN (*x.type.form = ORB.Proc*) - IF x.mode > ORB.Par THEN load(x) END ; - r := RH; - IF RH > 0 THEN SaveRegs(RH); RH := 0 END - END PrepCall; - - PROCEDURE Call*(VAR x: Item; r: LONGINT); - BEGIN (*x.type.form = ORB.Proc*) - IF x.mode = ORB.Const THEN - IF x.r >= 0 THEN Put3(BL, 7, (x.a DIV 4)-pc-1) - ELSE (*imported*) - IF pc - fixorgP < 1000H THEN - Put3(BL, 7, ((-x.r) * 100H + x.a) * 1000H + pc-fixorgP); fixorgP := pc-1 - ELSE ORS.Mark("fixup impossible") - END - END - ELSE - IF x.mode <= ORB.Par THEN load(x); DEC(RH) - ELSE Put2(Ldr, RH, SP, 0); Put1(Add, SP, SP, 4); DEC(r); DEC(frame, 4) - END ; - IF check THEN Trap(EQ, 5) END ; - Put3(BLR, 7, RH) - END ; - IF x.type.base.form = ORB.NoTyp THEN (*procedure*) RH := 0 - ELSE (*function*) - IF r > 0 THEN Put0(Mov, r, 0, 0); RestoreRegs(r) END ; - x.mode := Reg; x.r := r; RH := r+1 - END ; - invalSB - END Call; - - PROCEDURE Enter*(parblksize, locblksize: LONGINT; int: BOOLEAN); - VAR a, r: LONGINT; - BEGIN invalSB; frame := 0; - IF ~int THEN (*procedure prolog*) - a := 4; r := 0; - Put1(Sub, SP, SP, locblksize); Put2(Str, LNK, SP, 0); - WHILE a < parblksize DO Put2(Str, r, SP, a); INC(r); INC(a, 4) END - ELSE (*interrupt procedure*) - Put1(Sub, SP, SP, 12); Put2(Str, 0, SP, 0); Put2(Str, 1, SP, 4); Put2(Str, SB, SP, 8) - (*R0, R1, SB saved os stack*) - END - END Enter; - - PROCEDURE Return*(form: INTEGER; VAR x: Item; size: LONGINT; int: BOOLEAN); - BEGIN - IF form # ORB.NoTyp THEN load(x) END ; - IF ~int THEN (*procedure epilog*) - Put2(Ldr, LNK, SP, 0); Put1(Add, SP, SP, size); Put3(BR, 7, LNK) - ELSE (*interrupt return, restore SB, R1, R0*) - Put2(Ldr, SB, SP, 8); Put2(Ldr, 1, SP, 4); Put2(Ldr, 0, SP, 0); Put1(Add, SP, SP, 12); Put3(BR, 7, 10H) - END ; - RH := 0 - END Return; - - (* In-line code procedures*) - - PROCEDURE Increment*(upordown: LONGINT; VAR x, y: Item); - VAR op, zr, v: LONGINT; - BEGIN (*frame = 0*) - IF upordown = 0 THEN op := Add ELSE op := Sub END ; - IF x.type = ORB.byteType THEN v := 1 ELSE v := 0 END ; - IF y.type.form = ORB.NoTyp THEN y.mode := ORB.Const; y.a := 1 END ; - IF (x.mode = ORB.Var) & (x.r > 0) THEN - zr := RH; Put2(Ldr+v, zr, SP, x.a); incR; - IF y.mode = ORB.Const THEN Put1a(op, zr, zr, y.a) ELSE load(y); Put0(op, zr, zr, y.r); DEC(RH) END ; - Put2(Str+v, zr, SP, x.a); DEC(RH) - ELSE loadAdr(x); zr := RH; Put2(Ldr+v, RH, x.r, 0); incR; - IF y.mode = ORB.Const THEN Put1a(op, zr, zr, y.a) ELSE load(y); Put0(op, zr, zr, y.r); DEC(RH) END ; - Put2(Str+v, zr, x.r, 0); DEC(RH, 2) - END - END Increment; - - PROCEDURE Include*(inorex: LONGINT; VAR x, y: Item); - VAR op, zr: LONGINT; - BEGIN loadAdr(x); zr := RH; Put2(Ldr, RH, x.r, 0); incR; - IF inorex = 0 THEN op := Ior ELSE op := Ann END ; - IF y.mode = ORB.Const THEN Put1a(op, zr, zr, LSL(1, y.a)) - ELSE load(y); Put1(Mov, RH, 0, 1); Put0(Lsl, y.r, RH, y.r); Put0(op, zr, zr, y.r); DEC(RH) - END ; - Put2(Str, zr, x.r, 0); DEC(RH, 2) - END Include; - - PROCEDURE Assert*(VAR x: Item); - VAR cond: LONGINT; - BEGIN - IF x.mode # Cond THEN loadCond(x) END ; - IF x.a = 0 THEN cond := negated(x.r) - ELSE Put3(BC, x.r, x.b); FixLink(x.a); x.b := pc-1; cond := 7 - END ; - Trap(cond, 7); FixLink(x.b) - END Assert; - - PROCEDURE New*(VAR x: Item); - BEGIN loadAdr(x); loadTypTagAdr(x.type.base); Put3(BLR, 7, MT); RH := 0; invalSB - END New; - - PROCEDURE Pack*(VAR x, y: Item); - VAR z: Item; - BEGIN z := x; load(x); load(y); - Put1(Lsl, y.r, y.r, 23); Put0(Add, x.r, x.r, y.r); DEC(RH); Store(z, x) - END Pack; - - PROCEDURE Unpk*(VAR x, y: Item); - VAR z, e0: Item; - BEGIN z := x; load(x); e0.mode := Reg; e0.r := RH; e0.type := ORB.intType; - Put1(Asr, RH, x.r, 23); Put1(Sub, RH, RH, 127); Store(y, e0); incR; - Put1(Lsl, RH, RH, 23); Put0(Sub, x.r, x.r, RH); Store(z, x) - END Unpk; - - PROCEDURE Led*(VAR x: Item); - BEGIN load(x); Put1(Mov, RH, 0, -60); Put2(Str, x.r, RH, 0); DEC(RH) - END Led; - - PROCEDURE Get*(VAR x, y: Item); - BEGIN load(x); x.type := y.type; x.mode := RegI; x.a := 0; Store(y, x) - END Get; - - PROCEDURE Put*(VAR x, y: Item); - BEGIN load(x); x.type := y.type; x.mode := RegI; x.a := 0; Store(x, y) - END Put; - - PROCEDURE Copy*(VAR x, y, z: Item); - BEGIN load(x); load(y); - IF z.mode = ORB.Const THEN - IF z.a > 0 THEN load(z) ELSE ORS.Mark("bad count") END - ELSE load(z); - IF check THEN Trap(LT, 3) END ; - Put3(BC, EQ, 6) - END ; - Put2(Ldr, RH, x.r, 0); Put1(Add, x.r, x.r, 4); - Put2(Str, RH, y.r, 0); Put1(Add, y.r, y.r, 4); - Put1(Sub, z.r, z.r, 1); Put3(BC, NE, -6); DEC(RH, 3) - END Copy; - - PROCEDURE LDPSR*(VAR x: Item); - BEGIN (*x.mode = Const*) Put3(0, 15, x.a + 20H) - END LDPSR; - - PROCEDURE LDREG*(VAR x, y: Item); - BEGIN - IF y.mode = ORB.Const THEN Put1a(Mov, x.a, 0, y.a) - ELSE load(y); Put0(Mov, x.a, 0, y.r); DEC(RH) - END - END LDREG; - - (*In-line code functions*) - - PROCEDURE Abs*(VAR x: Item); - BEGIN - IF x.mode = ORB.Const THEN x.a := ABS(x.a) - ELSE load(x); - IF x.type.form = ORB.Real THEN Put1(Lsl, x.r, x.r, 1); Put1(Ror, x.r, x.r, 1) - ELSE Put1(Cmp, x.r, x.r, 0); Put3(BC, GE, 2); Put1(Mov, RH, 0, 0); Put0(Sub, x.r, RH, x.r) - END - END - END Abs; - - PROCEDURE Odd*(VAR x: Item); - BEGIN load(x); Put1(And, x.r, x.r, 1); SetCC(x, NE); DEC(RH) - END Odd; - - PROCEDURE Floor*(VAR x: Item); - BEGIN load(x); Put1(Mov+U, RH, 0, 4B00H); Put0(Fad+V, x.r, x.r, RH) - END Floor; - - PROCEDURE Float*(VAR x: Item); - BEGIN load(x); Put1(Mov+U, RH, 0, 4B00H); Put0(Fad+U, x.r, x.r, RH) - END Float; - - PROCEDURE Ord*(VAR x: Item); - BEGIN - IF x.mode IN {ORB.Var, ORB.Par, RegI} THEN load(x) END - END Ord; - - PROCEDURE Len*(VAR x: Item); - BEGIN - IF x.type.len >= 0 THEN x.mode := ORB.Const; x.a := x.type.len - ELSE (*open array*) Put2(Ldr, RH, SP, x.a + 4 + frame); x.mode := Reg; x.r := RH; incR - END - END Len; - - PROCEDURE Shift*(fct: LONGINT; VAR x, y: Item); - VAR op: LONGINT; - BEGIN load(x); - IF fct = 0 THEN op := Lsl ELSIF fct = 1 THEN op := Asr ELSE op := Ror END ; - IF y.mode = ORB.Const THEN Put1(op, x.r, x.r, y.a MOD 20H) - ELSE load(y); Put0(op, RH-2, x.r, y.r); DEC(RH); x.r := RH-1 - END - END Shift; - - PROCEDURE ADC*(VAR x, y: Item); - BEGIN load(x); load(y); Put0(Add+2000H, x.r, x.r, y.r); DEC(RH) - END ADC; - - PROCEDURE SBC*(VAR x, y: Item); - BEGIN load(x); load(y); Put0(Sub+2000H, x.r, x.r, y.r); DEC(RH) - END SBC; - - PROCEDURE UML*(VAR x, y: Item); - BEGIN load(x); load(y); Put0(Mul+2000H, x.r, x.r, y.r); DEC(RH) - END UML; - - PROCEDURE Bit*(VAR x, y: Item); - BEGIN load(x); Put2(Ldr, x.r, x.r, 0); - IF y.mode = ORB.Const THEN Put1(Ror, x.r, x.r, y.a+1); DEC(RH) - ELSE load(y); Put1(Add, y.r, y.r, 1); Put0(Ror, x.r, x.r, y.r); DEC(RH, 2) - END ; - SetCC(x, MI) - END Bit; - - PROCEDURE Register*(VAR x: Item); - BEGIN (*x.mode = Const*) - Put0(Mov, RH, 0, x.a MOD 10H); x.mode := Reg; x.r := RH; incR - END Register; - - PROCEDURE H*(VAR x: Item); - BEGIN (*x.mode = Const*) - Put0(Mov + U + x.a MOD 2 * V, RH, 0, 0); x.mode := Reg; x.r := RH; incR - END H; - - PROCEDURE Adr*(VAR x: Item); - BEGIN - IF x.mode IN {ORB.Var, ORB.Par, RegI} THEN loadAdr(x) - ELSIF (x.mode = ORB.Const) & (x.type.form = ORB.Proc) THEN load(x) - ELSIF (x.mode = ORB.Const) & (x.type.form = ORB.String) THEN loadStringAdr(x) - ELSE ORS.Mark("not addressable") - END - END Adr; - - PROCEDURE Condition*(VAR x: Item); - BEGIN (*x.mode = Const*) SetCC(x, x.a) - END Condition; - - PROCEDURE Open*(v: INTEGER); - BEGIN pc := 0; tdx := 0; strx := 0; RH := 0; fixorgP := 0; fixorgD := 0; fixorgT := 0; check := v # 0; version := v; - IF v = 0 THEN pc := 8 END - END Open; - - PROCEDURE SetDataSize*(dc: LONGINT); - BEGIN varsize := dc - END SetDataSize; - - PROCEDURE Header*; - BEGIN entry := pc*4; - IF version = 0 THEN code[0] := 0E7000000H-1 + pc; Put1a(Mov, SB, 0, VarOrg0); Put1a(Mov, SP, 0, StkOrg0) (*RISC-0*) - ELSE Put1(Sub, SP, SP, 4); Put2(Str, LNK, SP, 0); invalSB - END - END Header; - - PROCEDURE NofPtrs(typ: ORB.Type): LONGINT; - VAR fld: ORB.Object; n: LONGINT; - BEGIN - IF (typ.form = ORB.Pointer) OR (typ.form = ORB.NilTyp) THEN n := 1 - ELSIF typ.form = ORB.Record THEN - fld := typ.dsc; n := 0; - WHILE fld # NIL DO n := NofPtrs(fld.type) + n; fld := fld.next END - ELSIF typ.form = ORB.Array THEN n := NofPtrs(typ.base) * typ.len - ELSE n := 0 - END ; - RETURN n - END NofPtrs; - - PROCEDURE FindPtrs(VAR R: Files.Rider; typ: ORB.Type; adr: LONGINT); - VAR fld: ORB.Object; i, s: LONGINT; - BEGIN - IF (typ.form = ORB.Pointer) OR (typ.form = ORB.NilTyp) THEN Files.WriteInt(R, adr) - ELSIF typ.form = ORB.Record THEN - fld := typ.dsc; - WHILE fld # NIL DO FindPtrs(R, fld.type, fld.val + adr); fld := fld.next END - ELSIF typ.form = ORB.Array THEN - s := typ.base.size; - FOR i := 0 TO typ.len-1 DO FindPtrs(R, typ.base, i*s + adr) END - END - END FindPtrs; - - PROCEDURE Close*(VAR modid: ORS.Ident; key, nofent: LONGINT); - VAR obj: ORB.Object; - i, comsize, nofimps, nofptrs, size: LONGINT; - name: ORS.Ident; - F: Files.File; R: Files.Rider; - BEGIN (*exit code*) - IF version = 0 THEN Put1(Mov, 0, 0, 0); Put3(BR, 7, 0) (*RISC-0*) - ELSE Put2(Ldr, LNK, SP, 0); Put1(Add, SP, SP, 4); Put3(BR, 7, LNK) - END ; - obj := ORB.topScope.next; nofimps := 0; comsize := 4; nofptrs := 0; - WHILE obj # NIL DO - IF (obj.class = ORB.Mod) & (obj.dsc # ORB.system) THEN INC(nofimps) (*count imports*) - ELSIF (obj.exno # 0) & (obj.class = ORB.Const) & (obj.type.form = ORB.Proc) - & (obj.type.nofpar = 0) & (obj.type.base = ORB.noType) THEN i := 0; (*count commands*) - WHILE obj.name[i] # 0X DO INC(i) END ; - i := (i+4) DIV 4 * 4; INC(comsize, i+4) - ELSIF obj.class = ORB.Var THEN INC(nofptrs, NofPtrs(obj.type)) (*count pointers*) - END ; - obj := obj.next - END ; - size := varsize + strx + comsize + (pc + nofimps + nofent + nofptrs + 1)*4; (*varsize includes type descriptors*) - - ORB.MakeFileName(name, modid, ".rsc"); (*write code file*) - F := Files.New(name); Files.Set(R, F, 0); Files.WriteString(R, modid); Files.WriteInt(R, key); - (*Files.WriteByte(R, version);*) (* who writes like that? -- noch *) - Files.WriteByte(R, SHORT(SHORT(version))); (* voc adaptation by noch *) - Files.WriteInt(R, size); - obj := ORB.topScope.next; - WHILE (obj # NIL) & (obj.class = ORB.Mod) DO (*imports*) - IF obj.dsc # ORB.system THEN Files.WriteString(R, obj(ORB.Module).orgname); Files.WriteInt(R, obj.val) END ; - obj := obj.next - END ; - Files.Write(R, 0X); - Files.WriteInt(R, tdx*4); - i := 0; - WHILE i < tdx DO Files.WriteInt(R, data[i]); INC(i) END ; (*type descriptors*) - Files.WriteInt(R, varsize - tdx*4); (*data*) - Files.WriteInt(R, strx); - FOR i := 0 TO strx-1 DO Files.Write(R, str[i]) END ; (*strings*) - Files.WriteInt(R, pc); (*code len*) - FOR i := 0 TO pc-1 DO Files.WriteInt(R, code[i]) END ; (*program*) - obj := ORB.topScope.next; - WHILE obj # NIL DO (*commands*) - IF (obj.exno # 0) & (obj.class = ORB.Const) & (obj.type.form = ORB.Proc) & - (obj.type.nofpar = 0) & (obj.type.base = ORB.noType) THEN - Files.WriteString(R, obj.name); Files.WriteInt(R, obj.val) - END ; - obj := obj.next - END ; - Files.Write(R, 0X); - Files.WriteInt(R, nofent); Files.WriteInt(R, entry); - obj := ORB.topScope.next; - WHILE obj # NIL DO (*entries*) - IF obj.exno # 0 THEN - IF (obj.class = ORB.Const) & (obj.type.form = ORB.Proc) OR (obj.class = ORB.Var) THEN - Files.WriteInt(R, obj.val) - ELSIF obj.class = ORB.Typ THEN - IF obj.type.form = ORB.Record THEN Files.WriteInt(R, obj.type.len MOD 10000H) - ELSIF (obj.type.form = ORB.Pointer) & ((obj.type.base.typobj = NIL) OR (obj.type.base.typobj.exno = 0)) THEN - Files.WriteInt(R, obj.type.base.len MOD 10000H) - END - END - END ; - obj := obj.next - END ; - obj := ORB.topScope.next; - WHILE obj # NIL DO (*pointer variables*) - IF obj.class = ORB.Var THEN FindPtrs(R, obj.type, obj.val) END ; - obj := obj.next - END ; - Files.WriteInt(R, -1); - Files.WriteInt(R, fixorgP); Files.WriteInt(R, fixorgD); Files.WriteInt(R, fixorgT); Files.WriteInt(R, entry); - Files.Write(R, "O"); Files.Register(F) - END Close; - -BEGIN - relmap[0] := 1; relmap[1] := 9; relmap[2] := 5; relmap[3] := 6; relmap[4] := 14; relmap[5] := 13 -END ORG. +MODULE ORG; (* NW 24.6.2014 code generator in Oberon-07 for RISC*) + IMPORT SYSTEM, Files := CompatFiles, ORS, ORB; + (*Code generator for Oberon compiler for RISC processor. + Procedural interface to Parser OSAP; result in array "code". + Procedure Close writes code-files*) + + (* voc adaptation by noch *) + TYPE INTEGER = LONGINT; + BYTE = CHAR; + + CONST WordSize* = 4; + StkOrg0 = -64; VarOrg0 = 0; (*for RISC-0 only*) + MT = 12; SB = 13; SP = 14; LNK = 15; (*dedicated registers*) + maxCode = 8000; maxStrx = 2400; maxTD = 120; C24 = 1000000H; + Reg = 10; RegI = 11; Cond = 12; (*internal item modes*) + + (*frequently used opcodes*) U = 2000H; V = 1000H; + Mov = 0; Lsl = 1; Asr = 2; Ror= 3; And = 4; Ann = 5; Ior = 6; Xor = 7; + Add = 8; Sub = 9; Cmp = 9; Mul = 10; Div = 11; + Fad = 12; Fsb = 13; Fml = 14; Fdv = 15; + Ldr = 8; Str = 10; + BR = 0; BLR = 1; BC = 2; BL = 3; + MI = 0; PL = 8; EQ = 1; NE = 9; LT = 5; GE = 13; LE = 6; GT = 14; + + TYPE Item* = RECORD + mode*: INTEGER; + type*: ORB.Type; + a*, b*, r: LONGINT; + rdo*: BOOLEAN (*read only*) + END ; + + (* Item forms and meaning of fields: + mode r a b + -------------------------------- + Const - value (proc adr) (immediate value) + Var base off - (direct adr) + Par - off0 off1 (indirect adr) + Reg regno + RegI regno off - + Cond cond Fchain Tchain *) + + VAR pc*, varsize: LONGINT; (*program counter, data index*) + tdx, strx: LONGINT; + entry: LONGINT; (*main entry point*) + RH: LONGINT; (*available registers R[0] ... R[H-1]*) + curSB: LONGINT; (*current static base in SB*) + frame: LONGINT; (*frame offset changed in SaveRegs and RestoreRegs*) + fixorgP, fixorgD, fixorgT: LONGINT; (*origins of lists of locations to be fixed up by loader*) + check: BOOLEAN; (*emit run-time checks*) + version: INTEGER; (* 0 = RISC-0, 1 = RISC-5 *) + + relmap: ARRAY 6 OF INTEGER; (*condition codes for relations*) + code: ARRAY maxCode OF LONGINT; + data: ARRAY maxTD OF LONGINT; (*type descriptors*) + str: ARRAY maxStrx OF CHAR; + + (* voc adaptation by noch *) + PROCEDURE LSL (x, n : INTEGER): INTEGER; + + BEGIN + + RETURN ASH(x, n); + END LSL; + + + (*instruction assemblers according to formats*) + + PROCEDURE Put0(op, a, b, c: LONGINT); + BEGIN (*emit format-0 instruction*) + code[pc] := ((a*10H + b) * 10H + op) * 10000H + c; INC(pc) + END Put0; + + PROCEDURE Put1(op, a, b, im: LONGINT); + BEGIN (*emit format-1 instruction, -10000H <= im < 10000H*) + IF im < 0 THEN INC(op, V) END ; + code[pc] := (((a+40H) * 10H + b) * 10H + op) * 10000H + (im MOD 10000H); INC(pc) + END Put1; + + PROCEDURE Put1a(op, a, b, im: LONGINT); + BEGIN (*same as Pu1, but with range test -10000H <= im < 10000H*) + IF (im >= -10000H) & (im <= 0FFFFH) THEN Put1(op, a, b, im) + ELSE Put1(Mov+U, RH, 0, im DIV 10000H); + IF im MOD 10000H # 0 THEN Put1(Ior, RH, RH, im MOD 10000H) END ; + Put0(op, a, b, RH) + END + END Put1a; + + PROCEDURE Put2(op, a, b, off: LONGINT); + BEGIN (*emit load/store instruction*) + code[pc] := ((op * 10H + a) * 10H + b) * 100000H + (off MOD 100000H); INC(pc) + END Put2; + + PROCEDURE Put3(op, cond, off: LONGINT); + BEGIN (*emit branch instruction*) + code[pc] := ((op+12) * 10H + cond) * 1000000H + (off MOD 1000000H); INC(pc) + END Put3; + + PROCEDURE incR; + BEGIN + IF RH < MT-1 THEN INC(RH) ELSE ORS.Mark("register stack overflow") END + END incR; + + PROCEDURE CheckRegs*; + BEGIN + IF RH # 0 THEN ORS.Mark("Reg Stack"); RH := 0 END ; + IF pc >= maxCode - 40 THEN ORS.Mark("Program too long") END + END CheckRegs; + + PROCEDURE SetCC(VAR x: Item; n: LONGINT); + BEGIN x.mode := Cond; x.a := 0; x.b := 0; x.r := n + END SetCC; + + PROCEDURE Trap(cond, num: LONGINT); + BEGIN num := ORS.Pos()*100H + num*10H + MT; Put3(BLR, cond, num) + END Trap; + + (*handling of forward reference, fixups of branch addresses and constant tables*) + + PROCEDURE negated(cond: LONGINT): LONGINT; + BEGIN + IF cond < 8 THEN cond := cond+8 ELSE cond := cond-8 END ; + RETURN cond + END negated; + + PROCEDURE invalSB; + BEGIN curSB := 1 + END invalSB; + + PROCEDURE fix(at, with: LONGINT); + BEGIN code[at] := code[at] DIV C24 * C24 + (with MOD C24) + END fix; + + PROCEDURE FixLink*(L: LONGINT); + VAR L1: LONGINT; + BEGIN invalSB; + WHILE L # 0 DO L1 := code[L] MOD 40000H; fix(L, pc-L-1); L := L1 END + END FixLink; + + PROCEDURE FixLinkWith(L0, dst: LONGINT); + VAR L1: LONGINT; + BEGIN + WHILE L0 # 0 DO + L1 := code[L0] MOD C24; + code[L0] := code[L0] DIV C24 * C24 + ((dst - L0 - 1) MOD C24); L0 := L1 + END + END FixLinkWith; + + PROCEDURE merged(L0, L1: LONGINT): LONGINT; + VAR L2, L3: LONGINT; + BEGIN + IF L0 # 0 THEN L3 := L0; + REPEAT L2 := L3; L3 := code[L2] MOD 40000H UNTIL L3 = 0; + code[L2] := code[L2] + L1; L1 := L0 + END ; + RETURN L1 + END merged; + + (* loading of operands and addresses into registers *) + + PROCEDURE GetSB(base: LONGINT); + BEGIN + IF (version # 0) & ((base # curSB) OR (base # 0)) THEN + Put2(Ldr, SB, -base, pc-fixorgD); fixorgD := pc-1; curSB := base + END + END GetSB; + + PROCEDURE NilCheck; + BEGIN IF check THEN Trap(EQ, 4) END + END NilCheck; + + PROCEDURE load(VAR x: Item); + VAR op: LONGINT; + BEGIN + IF x.type.size = 1 THEN op := Ldr+1 ELSE op := Ldr END ; + IF x.mode # Reg THEN + IF x.mode = ORB.Const THEN + IF x.type.form = ORB.Proc THEN + IF x.r > 0 THEN ORS.Mark("not allowed") + ELSIF x.r = 0 THEN Put3(BL, 7, 0); Put1a(Sub, RH, LNK, pc*4 - x.a) + ELSE GetSB(x.r); Put1(Add, RH, SB, x.a + 100H) (*mark as progbase-relative*) + END + ELSIF (x.a <= 0FFFFH) & (x.a >= -10000H) THEN Put1(Mov, RH, 0, x.a) + ELSE Put1(Mov+U, RH, 0, x.a DIV 10000H MOD 10000H); + IF x.a MOD 10000H # 0 THEN Put1(Ior, RH, RH, x.a MOD 10000H) END + END ; + x.r := RH; incR + ELSIF x.mode = ORB.Var THEN + IF x.r > 0 THEN (*local*) Put2(op, RH, SP, x.a + frame) + ELSE GetSB(x.r); Put2(op, RH, SB, x.a) + END ; + x.r := RH; incR + ELSIF x.mode = ORB.Par THEN Put2(Ldr, RH, SP, x.a + frame); Put2(op, RH, RH, x.b); x.r := RH; incR + ELSIF x.mode = RegI THEN Put2(op, x.r, x.r, x.a) + ELSIF x.mode = Cond THEN + Put3(BC, negated(x.r), 2); + FixLink(x.b); Put1(Mov, RH, 0, 1); Put3(BC, 7, 1); + FixLink(x.a); Put1(Mov, RH, 0, 0); x.r := RH; incR + END ; + x.mode := Reg + END + END load; + + PROCEDURE loadAdr(VAR x: Item); + BEGIN + IF x.mode = ORB.Var THEN + IF x.r > 0 THEN (*local*) Put1a(Add, RH, SP, x.a + frame) + ELSE GetSB(x.r); Put1a(Add, RH, SB, x.a) + END ; + x.r := RH; incR + ELSIF x.mode = ORB.Par THEN Put2(Ldr, RH, SP, x.a + frame); + IF x.b # 0 THEN Put1a(Add, RH, RH, x.b) END ; + x.r := RH; incR + ELSIF x.mode = RegI THEN + IF x.a # 0 THEN Put1a(Add, x.r, x.r, x.a) END + ELSE ORS.Mark("address error") + END ; + x.mode := Reg + END loadAdr; + + PROCEDURE loadCond(VAR x: Item); + BEGIN + IF x.type.form = ORB.Bool THEN + IF x.mode = ORB.Const THEN x.r := 15 - x.a*8 + ELSE load(x); + IF code[pc-1] DIV 40000000H # -2 THEN Put1(Cmp, x.r, x.r, 0) END ; + x.r := NE; DEC(RH) + END ; + x.mode := Cond; x.a := 0; x.b := 0 + ELSE ORS.Mark("not Boolean?") + END + END loadCond; + + PROCEDURE loadTypTagAdr(T: ORB.Type); + VAR x: Item; + BEGIN x.mode := ORB.Var; x.a := T.len; x.r := -T.mno; loadAdr(x) + END loadTypTagAdr; + + PROCEDURE loadStringAdr(VAR x: Item); + BEGIN GetSB(0); Put1a(Add, RH, SB, varsize+x.a); x.mode := Reg; x.r := RH; incR + END loadStringAdr; + + (* Items: Conversion from constants or from Objects on the Heap to Items on the Stack*) + + PROCEDURE MakeConstItem*(VAR x: Item; typ: ORB.Type; val: LONGINT); + BEGIN x.mode := ORB.Const; x.type := typ; x.a := val + END MakeConstItem; + + PROCEDURE MakeRealItem*(VAR x: Item; val: REAL); + BEGIN x.mode := ORB.Const; x.type := ORB.realType; x.a := SYSTEM.VAL(LONGINT, val) + END MakeRealItem; + + PROCEDURE MakeStringItem*(VAR x: Item; len: LONGINT); (*copies string from ORS-buffer to ORG-string array*) + VAR i: LONGINT; + BEGIN x.mode := ORB.Const; x.type := ORB.strType; x.a := strx; x.b := len; i := 0; + IF strx + len + 4 < maxStrx THEN + WHILE len > 0 DO str[strx] := ORS.str[i]; INC(strx); INC(i); DEC(len) END ; + WHILE strx MOD 4 # 0 DO str[strx] := 0X; INC(strx) END + ELSE ORS.Mark("too many strings") + END + END MakeStringItem; + + PROCEDURE MakeItem*(VAR x: Item; y: ORB.Object; curlev: LONGINT); + BEGIN x.mode := y.class; x.type := y.type; x.a := y.val; x.rdo := y.rdo; + IF y.class = ORB.Par THEN x.b := 0 + ELSIF y.class = ORB.Typ THEN x.a := y.type.len; x.r := -y.lev + ELSIF (y.class = ORB.Const) & (y.type.form = ORB.String) THEN x.b := y.lev (*len*) + ELSE x.r := y.lev + END ; + IF (y.lev > 0) & (y.lev # curlev) & (y.class # ORB.Const) THEN ORS.Mark("level error, not accessible") END + END MakeItem; + + (* Code generation for Selectors, Variables, Constants *) + + PROCEDURE Field*(VAR x: Item; y: ORB.Object); (* x := x.y *) + BEGIN; + IF x.mode = ORB.Var THEN + IF x.r >= 0 THEN x.a := x.a + y.val + ELSE loadAdr(x); x.mode := RegI; x.a := y.val + END + ELSIF x.mode = RegI THEN x.a := x.a + y.val + ELSIF x.mode = ORB.Par THEN x.b := x.b + y.val + END + END Field; + + PROCEDURE Index*(VAR x, y: Item); (* x := x[y] *) + VAR s, lim: LONGINT; + BEGIN s := x.type.base.size; lim := x.type.len; + IF (y.mode = ORB.Const) & (lim >= 0) THEN + IF (y.a < 0) OR (y.a >= lim) THEN ORS.Mark("bad index") END ; + IF x.mode IN {ORB.Var, RegI} THEN x.a := y.a * s + x.a + ELSIF x.mode = ORB.Par THEN x.b := y.a * s + x.b + END + ELSE load(y); + IF check THEN (*check array bounds*) + IF lim >= 0 THEN Put1a(Cmp, RH, y.r, lim) + ELSE (*open array*) + IF x.mode IN {ORB.Var, ORB.Par} THEN Put2(Ldr, RH, SP, x.a+4+frame); Put0(Cmp, RH, y.r, RH) + ELSE ORS.Mark("error in Index") + END + END ; + Trap(10, 1) (*BCC*) + END ; + IF s = 4 THEN Put1(Lsl, y.r, y.r, 2) ELSIF s > 1 THEN Put1a(Mul, y.r, y.r, s) END ; + IF x.mode = ORB.Var THEN + IF x.r > 0 THEN Put0(Add, y.r, SP, y.r); INC(x.a, frame) + ELSE GetSB(x.r); + IF x.r = 0 THEN Put0(Add, y.r, SB, y.r) + ELSE Put1a(Add, RH, SB, x.a); Put0(Add, y.r, RH, y.r); x.a := 0 + END + END ; + x.r := y.r; x.mode := RegI + ELSIF x.mode = ORB.Par THEN + Put2(Ldr, RH, SP, x.a + frame); + Put0(Add, y.r, RH, y.r); x.mode := RegI; x.r := y.r; x.a := x.b + ELSIF x.mode = RegI THEN Put0(Add, x.r, x.r, y.r); DEC(RH) + END + END + END Index; + + PROCEDURE DeRef*(VAR x: Item); + BEGIN + IF x.mode = ORB.Var THEN + IF x.r > 0 THEN (*local*) Put2(Ldr, RH, SP, x.a + frame) ELSE GetSB(x.r); Put2(Ldr, RH, SB, x.a) END ; + NilCheck; x.r := RH; incR + ELSIF x.mode = ORB.Par THEN + Put2(Ldr, RH, SP, x.a + frame); Put2(Ldr, RH, RH, x.b); NilCheck; x.r := RH; incR + ELSIF x.mode = RegI THEN Put2(Ldr, x.r, x.r, x.a); NilCheck + ELSIF x.mode # Reg THEN ORS.Mark("bad mode in DeRef") + END ; + x.mode := RegI; x.a := 0; x.b := 0 + END DeRef; + + PROCEDURE Q(T: ORB.Type; VAR dcw: LONGINT); + BEGIN (*one entry of type descriptor extension table*) + IF T.base # NIL THEN + Q(T.base, dcw); data[dcw] := (T.mno*1000H + T.len) * 1000H + dcw - fixorgT; + fixorgT := dcw; INC(dcw) + END + END Q; + + PROCEDURE FindPtrFlds(typ: ORB.Type; off: LONGINT; VAR dcw: LONGINT); + VAR fld: ORB.Object; i, s: LONGINT; + BEGIN + IF (typ.form = ORB.Pointer) OR (typ.form = ORB.NilTyp) THEN data[dcw] := off; INC(dcw) + ELSIF typ.form = ORB.Record THEN + fld := typ.dsc; + WHILE fld # NIL DO FindPtrFlds(fld.type, fld.val + off, dcw); fld := fld.next END + ELSIF typ.form = ORB.Array THEN + s := typ.base.size; + FOR i := 0 TO typ.len-1 DO FindPtrFlds(typ.base, i*s + off, dcw) END + END + END FindPtrFlds; + + PROCEDURE BuildTD*(T: ORB.Type; VAR dc: LONGINT); + VAR dcw, k, s: LONGINT; (*dcw = word address*) + BEGIN dcw := dc DIV 4; s := T.size; (*convert size for heap allocation*) + IF s <= 24 THEN s := 32 ELSIF s <= 56 THEN s := 64 ELSIF s <= 120 THEN s := 128 + ELSE s := (s+263) DIV 256 * 256 + END ; + T.len := dc; data[dcw] := s; INC(dcw); + k := T.nofpar; (*extension level!*) + IF k > 3 THEN ORS.Mark("ext level too large") + ELSE Q(T, dcw); + WHILE k < 3 DO data[dcw] := -1; INC(dcw); INC(k) END + END ; + FindPtrFlds(T, 0, dcw); data[dcw] := -1; INC(dcw); tdx := dcw; dc := dcw*4; + IF tdx >= maxTD THEN ORS.Mark("too many record types"); tdx := 0 END + END BuildTD; + + PROCEDURE TypeTest*(VAR x: Item; T: ORB.Type; varpar, isguard: BOOLEAN); + VAR pc0: LONGINT; + BEGIN (*fetch tag into RH*) + IF varpar THEN Put2(Ldr, RH, SP, x.a+4+frame) + ELSE load(x); + pc0 := pc; Put3(BC, EQ, 0); (*NIL belongs to every pointer type*) + Put2(Ldr, RH, x.r, -8) + END ; + Put2(Ldr, RH, RH, T.nofpar*4); incR; + loadTypTagAdr(T); (*tag of T*) + Put0(Cmp, RH-1, RH-1, RH-2); DEC(RH, 2); + IF ~varpar THEN fix(pc0, pc - pc0 - 1) END ; + IF isguard THEN + IF check THEN Trap(NE, 2) END + ELSE SetCC(x, EQ); + IF ~varpar THEN DEC(RH) END + END + END TypeTest; + + (* Code generation for Boolean operators *) + + PROCEDURE Not*(VAR x: Item); (* x := ~x *) + VAR t: LONGINT; + BEGIN + IF x.mode # Cond THEN loadCond(x) END ; + x.r := negated(x.r); t := x.a; x.a := x.b; x.b := t + END Not; + + PROCEDURE And1*(VAR x: Item); (* x := x & *) + BEGIN + IF x.mode # Cond THEN loadCond(x) END ; + Put3(BC, negated(x.r), x.a); x.a := pc-1; FixLink(x.b); x.b := 0 + END And1; + + PROCEDURE And2*(VAR x, y: Item); + BEGIN + IF y.mode # Cond THEN loadCond(y) END ; + x.a := merged(y.a, x.a); x.b := y.b; x.r := y.r + END And2; + + PROCEDURE Or1*(VAR x: Item); (* x := x OR *) + BEGIN + IF x.mode # Cond THEN loadCond(x) END ; + Put3(BC, x.r, x.b); x.b := pc-1; FixLink(x.a); x.a := 0 + END Or1; + + PROCEDURE Or2*(VAR x, y: Item); + BEGIN + IF y.mode # Cond THEN loadCond(y) END ; + x.a := y.a; x.b := merged(y.b, x.b); x.r := y.r + END Or2; + + (* Code generation for arithmetic operators *) + + PROCEDURE Neg*(VAR x: Item); (* x := -x *) + BEGIN + IF x.type.form = ORB.Int THEN + IF x.mode = ORB.Const THEN x.a := -x.a + ELSE load(x); Put1(Mov, RH, 0, 0); Put0(Sub, x.r, RH, x.r) + END + ELSIF x.type.form = ORB.Real THEN + IF x.mode = ORB.Const THEN x.a := x.a + 7FFFFFFFH + 1 + ELSE load(x); Put1(Mov, RH, 0, 0); Put0(Fsb, x.r, RH, x.r) + END + ELSE (*form = Set*) + IF x.mode = ORB.Const THEN x.a := -x.a-1 + ELSE load(x); Put1(Xor, x.r, x.r, -1) + END + END + END Neg; + + PROCEDURE AddOp*(op: LONGINT; VAR x, y: Item); (* x := x +- y *) + BEGIN + IF op = ORS.plus THEN + IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN x.a := x.a + y.a + ELSIF y.mode = ORB.Const THEN load(x); + IF y.a # 0 THEN Put1a(Add, x.r, x.r, y.a) END + ELSE load(x); load(y); Put0(Add, RH-2, x.r, y.r); DEC(RH); x.r := RH-1 + END + ELSE (*op = ORS.minus*) + IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN x.a := x.a - y.a + ELSIF y.mode = ORB.Const THEN load(x); + IF y.a # 0 THEN Put1a(Sub, x.r, x.r, y.a) END + ELSE load(x); load(y); Put0(Sub, RH-2, x.r, y.r); DEC(RH); x.r := RH-1 + END + END + END AddOp; + + PROCEDURE log2(m: LONGINT; VAR e: LONGINT): LONGINT; + BEGIN e := 0; + WHILE ~ODD(m) DO m := m DIV 2; INC(e) END ; + RETURN m + END log2; + + PROCEDURE MulOp*(VAR x, y: Item); (* x := x * y *) + VAR e: LONGINT; + BEGIN + IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN x.a := x.a * y.a + ELSIF (y.mode = ORB.Const) & (y.a >= 2) & (log2(y.a, e) = 1) THEN load(x); Put1(Lsl, x.r, x.r, e) + ELSIF y.mode = ORB.Const THEN load(x); Put1a(Mul, x.r, x.r, y.a) + ELSIF (x.mode = ORB.Const) & (x.a >= 2) & (log2(x.a, e) = 1) THEN load(y); Put1(Lsl, y.r, y.r, e); x.mode := Reg; x.r := y.r + ELSIF x.mode = ORB.Const THEN load(y); Put1a(Mul, y.r, y.r, x.a); x.mode := Reg; x.r := y.r + ELSE load(x); load(y); Put0(Mul, RH-2, x.r, y.r); DEC(RH); x.r := RH-1 + END + END MulOp; + + PROCEDURE DivOp*(op: LONGINT; VAR x, y: Item); (* x := x op y *) + VAR e: LONGINT; + BEGIN + IF op = ORS.div THEN + IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN + IF y.a > 0 THEN x.a := x.a DIV y.a ELSE ORS.Mark("bad divisor") END + ELSIF (y.mode = ORB.Const) & (y.a >= 2) & (log2(y.a, e) = 1) THEN load(x); Put1(Asr, x.r, x.r, e) + ELSIF y.mode = ORB.Const THEN + IF y.a > 0 THEN load(x); Put1a(Div, x.r, x.r, y.a) ELSE ORS.Mark("bad divisor") END + ELSE load(y); + IF check THEN Trap(LE, 6) END ; + load(x); Put0(Div, RH-2, x.r, y.r); DEC(RH); x.r := RH-1 + END + ELSE (*op = ORS.mod*) + IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN + IF y.a > 0 THEN x.a := x.a MOD y.a ELSE ORS.Mark("bad modulus") END + ELSIF (y.mode = ORB.Const) & (y.a >= 2) & (log2(y.a, e) = 1) THEN load(x); + IF e <= 16 THEN Put1(And, x.r, x.r, y.a-1) ELSE Put1(Lsl, x.r, x.r, 32-e); Put1(Ror, x.r, x.r, 32-e) END + ELSIF y.mode = ORB.Const THEN + IF y.a > 0 THEN load(x); Put1a(Div, x.r, x.r, y.a); Put0(Mov+U, x.r, 0, 0) ELSE ORS.Mark("bad modulus") END + ELSE load(y); + IF check THEN Trap(LE, 6) END ; + load(x); Put0(Div, RH-2, x.r, y.r); Put0(Mov+U, RH-2, 0, 0); DEC(RH); x.r := RH-1 + END + END + END DivOp; + + (* Code generation for REAL operators *) + + PROCEDURE RealOp*(op: INTEGER; VAR x, y: Item); (* x := x op y *) + BEGIN load(x); load(y); + IF op = ORS.plus THEN Put0(Fad, RH-2, x.r, y.r) + ELSIF op = ORS.minus THEN Put0(Fsb, RH-2, x.r, y.r) + ELSIF op = ORS.times THEN Put0(Fml, RH-2, x.r, y.r) + ELSIF op = ORS.rdiv THEN Put0(Fdv, RH-2, x.r, y.r) + END ; + DEC(RH); x.r := RH-1 + END RealOp; + + (* Code generation for set operators *) + + PROCEDURE Singleton*(VAR x: Item); (* x := {x} *) + BEGIN + IF x.mode = ORB.Const THEN + x.a := LSL(1, x.a) + ELSE load(x); Put1(Mov, RH, 0, 1); Put0(Lsl, x.r, RH, x.r) + END + END Singleton; + + PROCEDURE Set*(VAR x, y: Item); (* x := {x .. y} *) + BEGIN + IF (x.mode = ORB.Const) & ( y.mode = ORB.Const) THEN + IF x.a <= y.a THEN x.a := LSL(2, y.a) - LSL(1, x.a) ELSE x.a := 0 END + ELSE + IF (x.mode = ORB.Const) & (x.a < 16) THEN x.a := LSL(-1, x.a) + ELSE load(x); Put1(Mov, RH, 0, -1); Put0(Lsl, x.r, RH, x.r) + END ; + IF (y.mode = ORB.Const) & (y.a < 16) THEN Put1(Mov, RH, 0, LSL(-2, y.a)); y.mode := Reg; y.r := RH; incR + ELSE load(y); Put1(Mov, RH, 0, -2); Put0(Lsl, y.r, RH, y.r) + END ; + IF x.mode = ORB.Const THEN + IF x.a # 0 THEN Put1(Xor, y.r, y.r, -1); Put1a(And, RH-1, y.r, x.a) END ; + x.mode := Reg; x.r := RH-1 + ELSE DEC(RH); Put0(Ann, RH-1, x.r, y.r) + END + END + END Set; + + PROCEDURE In*(VAR x, y: Item); (* x := x IN y *) + BEGIN load(y); + IF x.mode = ORB.Const THEN Put1(Ror, y.r, y.r, (x.a + 1) MOD 20H); DEC(RH) + ELSE load(x); Put1(Add, x.r, x.r, 1); Put0(Ror, y.r, y.r, x.r); DEC(RH, 2) + END ; + SetCC(x, MI) + END In; + + PROCEDURE SetOp*(op: LONGINT; VAR x, y: Item); (* x := x op y *) + VAR xset, yset: SET; (*x.type.form = Set*) + BEGIN + IF (x.mode = ORB.Const) & (y.mode = ORB.Const) THEN + xset := SYSTEM.VAL(SET, x.a); yset := SYSTEM.VAL(SET, y.a); + IF op = ORS.plus THEN xset := xset + yset + ELSIF op = ORS.minus THEN xset := xset - yset + ELSIF op = ORS.times THEN xset := xset * yset + ELSIF op = ORS.rdiv THEN xset := xset / yset + END ; + x.a := SYSTEM.VAL(LONGINT, xset) + ELSIF y.mode = ORB.Const THEN + load(x); + IF op = ORS.plus THEN Put1a(Ior, x.r, x.r, y.a) + ELSIF op = ORS.minus THEN Put1a(Ann, x.r, x.r, y.a) + ELSIF op = ORS.times THEN Put1a(And, x.r, x.r, y.a) + ELSIF op = ORS.rdiv THEN Put1a(Xor, x.r, x.r, y.a) + END ; + ELSE load(x); load(y); + IF op = ORS.plus THEN Put0(Ior, RH-2, x.r, y.r) + ELSIF op = ORS.minus THEN Put0(Ann, RH-2, x.r, y.r) + ELSIF op = ORS.times THEN Put0(And, RH-2, x.r, y.r) + ELSIF op = ORS.rdiv THEN Put0(Xor, RH-2, x.r, y.r) + END ; + DEC(RH); x.r := RH-1 + END + END SetOp; + + (* Code generation for relations *) + + PROCEDURE IntRelation*(op: INTEGER; VAR x, y: Item); (* x := x < y *) + BEGIN + IF (y.mode = ORB.Const) & (y.type.form # ORB.Proc) THEN + load(x); + IF (y.a # 0) OR ~(op IN {ORS.eql, ORS.neq}) OR (code[pc-1] DIV 40000000H # -2) THEN Put1a(Cmp, x.r, x.r, y.a) END ; + DEC(RH) + ELSE load(x); load(y); Put0(Cmp, x.r, x.r, y.r); DEC(RH, 2) + END ; + SetCC(x, relmap[op - ORS.eql]) + END IntRelation; + + PROCEDURE SetRelation*(op: INTEGER; VAR x, y: Item); (* x := x < y *) + BEGIN load(x); + IF (op = ORS.eql) OR (op = ORS.neq) THEN + IF y.mode = ORB.Const THEN Put1a(Cmp, x.r, x.r, y.a); DEC(RH) + ELSE load(y); Put0(Cmp, x.r, x.r, y.r); DEC(RH, 2) + END ; + SetCC(x, relmap[op - ORS.eql]) + ELSE ORS.Mark("illegal relation") + END + END SetRelation; + + PROCEDURE RealRelation*(op: INTEGER; VAR x, y: Item); (* x := x < y *) + BEGIN load(x); + IF (y.mode = ORB.Const) & (y.a = 0) THEN DEC(RH) + ELSE load(y); Put0(Fsb, x.r, x.r, y.r); DEC(RH, 2) + END ; + SetCC(x, relmap[op - ORS.eql]) + END RealRelation; + + PROCEDURE StringRelation*(op: INTEGER; VAR x, y: Item); (* x := x < y *) + (*x, y are char arrays or strings*) + BEGIN + IF x.type.form = ORB.String THEN loadStringAdr(x) ELSE loadAdr(x) END ; + IF y.type.form = ORB.String THEN loadStringAdr(y) ELSE loadAdr(y) END ; + Put2(Ldr+1, RH, x.r, 0); Put1(Add, x.r, x.r, 1); + Put2(Ldr+1, RH+1, y.r, 0); Put1(Add, y.r, y.r, 1); + Put0(Cmp, RH+2, RH, RH+1); Put3(BC, NE, 2); + Put1(Cmp, RH+2, RH, 0); Put3(BC, NE, -8); + DEC(RH, 2); SetCC(x, relmap[op - ORS.eql]) + END StringRelation; + + (* Code generation of Assignments *) + + PROCEDURE StrToChar*(VAR x: Item); + BEGIN x.type := ORB.charType; DEC(strx, 4); x.a := ORD(str[x.a]) + END StrToChar; + + PROCEDURE Store*(VAR x, y: Item); (* x := y *) + VAR op: LONGINT; + BEGIN load(y); + IF x.type.size = 1 THEN op := Str+1 ELSE op := Str END ; + IF x.mode = ORB.Var THEN + IF x.r > 0 THEN (*local*) Put2(op, y.r, SP, x.a + frame) + ELSE GetSB(x.r); Put2(op, y.r, SB, x.a) + END + ELSIF x.mode = ORB.Par THEN Put2(Ldr, RH, SP, x.a + frame); Put2(op, y.r, RH, x.b); + ELSIF x.mode = RegI THEN Put2(op, y.r, x.r, x.a); DEC(RH); + ELSE ORS.Mark("bad mode in Store") + END ; + DEC(RH) + END Store; + + PROCEDURE StoreStruct*(VAR x, y: Item); (* x := y, frame = 0 *) + VAR s, pc0: LONGINT; + BEGIN loadAdr(x); loadAdr(y); + IF (x.type.form = ORB.Array) & (x.type.len > 0) THEN + IF y.type.len >= 0 THEN + IF x.type.len >= y.type.len THEN Put1a(Mov, RH, 0, (y.type.size+3) DIV 4) + ELSE ORS.Mark("source array too long") + END + ELSE (*y is open array*) + Put2(Ldr, RH, SP, y.a+4); s := y.type.base.size; (*element size*) + pc0 := pc; Put3(BC, EQ, 0); + IF s = 1 THEN Put1(Add, RH, RH, 3); Put1(Asr, RH, RH, 2) + ELSIF s # 4 THEN Put1a(Mul, RH, RH, s DIV 4) + END ; + IF check THEN + Put1a(Mov, RH+1, 0, (x.type.size+3) DIV 4); Put0(Cmp, RH+1, RH, RH+1); Trap(GT, 3) + END ; + fix(pc0, pc + 5 - pc0) + END + ELSIF x.type.form = ORB.Record THEN Put1a(Mov, RH, 0, x.type.size DIV 4) + ELSE ORS.Mark("inadmissible assignment") + END ; + Put2(Ldr, RH+1, y.r, 0); Put1(Add, y.r, y.r, 4); + Put2(Str, RH+1, x.r, 0); Put1(Add, x.r, x.r, 4); + Put1(Sub, RH, RH, 1); Put3(BC, NE, -6); DEC(RH, 2) + END StoreStruct; + + PROCEDURE CopyString*(VAR x, y: Item); (*from x to y*) + VAR len: LONGINT; + BEGIN loadAdr(y); len := y.type.len; + IF len >= 0 THEN + IF x.b > len THEN ORS.Mark("string too long") END + ELSIF check THEN Put2(Ldr, RH, y.r, 4); (*array length check*) + Put1(Cmp, RH, RH, x.b); Trap(NE, 3) + END ; + loadStringAdr(x); + Put2(Ldr, RH, x.r, 0); Put1(Add, x.r, x.r, 4); + Put2(Str, RH, y.r, 0); Put1(Add, y.r, y.r, 4); + Put1(Asr, RH, RH, 24); Put3(BC, NE, -6); DEC(RH, 2) + END CopyString; + + (* Code generation for parameters *) + + PROCEDURE VarParam*(VAR x: Item; ftype: ORB.Type); + VAR xmd: INTEGER; + BEGIN xmd := x.mode; loadAdr(x); + IF (ftype.form = ORB.Array) & (ftype.len < 0) THEN (*open array*) + IF x.type.len >= 0 THEN Put1a(Mov, RH, 0, x.type.len) ELSE Put2(Ldr, RH, SP, x.a+4+frame) END ; + incR + ELSIF ftype.form = ORB.Record THEN + IF xmd = ORB.Par THEN Put2(Ldr, RH, SP, x.a+4+frame); incR ELSE loadTypTagAdr(x.type) END + END + END VarParam; + + PROCEDURE ValueParam*(VAR x: Item); + BEGIN load(x) + END ValueParam; + + PROCEDURE OpenArrayParam*(VAR x: Item); + BEGIN loadAdr(x); + IF x.type.len >= 0 THEN Put1a(Mov, RH, 0, x.type.len) ELSE Put2(Ldr, RH, SP, x.a+4+frame) END ; + incR + END OpenArrayParam; + + PROCEDURE StringParam*(VAR x: Item); + BEGIN loadStringAdr(x); Put1(Mov, RH, 0, x.b); incR (*len*) + END StringParam; + + (*For Statements*) + + PROCEDURE For0*(VAR x, y: Item); + BEGIN load(y) + END For0; + + PROCEDURE For1*(VAR x, y, z, w: Item; VAR L: LONGINT); + BEGIN + IF z.mode = ORB.Const THEN Put1a(Cmp, RH, y.r, z.a) + ELSE load(z); Put0(Cmp, RH-1, y.r, z.r); DEC(RH) + END ; + L := pc; + IF w.a > 0 THEN Put3(BC, GT, 0) + ELSIF w.a < 0 THEN Put3(BC, LT, 0) + ELSE ORS.Mark("zero increment"); Put3(BC, MI, 0) + END ; + Store(x, y) + END For1; + + PROCEDURE For2*(VAR x, y, w: Item); + BEGIN load(x); DEC(RH); Put1a(Add, x.r, x.r, w.a) + END For2; + + (* Branches, procedure calls, procedure prolog and epilog *) + + PROCEDURE Here*(): LONGINT; + BEGIN invalSB; RETURN pc + END Here; + + PROCEDURE FJump*(VAR L: LONGINT); + BEGIN Put3(BC, 7, L); L := pc-1 + END FJump; + + PROCEDURE CFJump*(VAR x: Item); + BEGIN + IF x.mode # Cond THEN loadCond(x) END ; + Put3(BC, negated(x.r), x.a); FixLink(x.b); x.a := pc-1 + END CFJump; + + PROCEDURE BJump*(L: LONGINT); + BEGIN Put3(BC, 7, L-pc-1) + END BJump; + + PROCEDURE CBJump*(VAR x: Item; L: LONGINT); + BEGIN + IF x.mode # Cond THEN loadCond(x) END ; + Put3(BC, negated(x.r), L-pc-1); FixLink(x.b); FixLinkWith(x.a, L) + END CBJump; + + PROCEDURE Fixup*(VAR x: Item); + BEGIN FixLink(x.a) + END Fixup; + + PROCEDURE SaveRegs(r: LONGINT); (* R[0 .. r-1]*) + VAR r0: LONGINT; + BEGIN (*r > 0*) r0 := 0; + Put1(Sub, SP, SP, r*4); INC(frame, 4*r); + REPEAT Put2(Str, r0, SP, (r-r0-1)*4); INC(r0) UNTIL r0 = r + END SaveRegs; + + PROCEDURE RestoreRegs(r: LONGINT); (*R[0 .. r-1]*) + VAR r0: LONGINT; + BEGIN (*r > 0*) r0 := r; + REPEAT DEC(r0); Put2(Ldr, r0, SP, (r-r0-1)*4) UNTIL r0 = 0; + Put1(Add, SP, SP, r*4); DEC(frame, 4*r) + END RestoreRegs; + + PROCEDURE PrepCall*(VAR x: Item; VAR r: LONGINT); + BEGIN (*x.type.form = ORB.Proc*) + IF x.mode > ORB.Par THEN load(x) END ; + r := RH; + IF RH > 0 THEN SaveRegs(RH); RH := 0 END + END PrepCall; + + PROCEDURE Call*(VAR x: Item; r: LONGINT); + BEGIN (*x.type.form = ORB.Proc*) + IF x.mode = ORB.Const THEN + IF x.r >= 0 THEN Put3(BL, 7, (x.a DIV 4)-pc-1) + ELSE (*imported*) + IF pc - fixorgP < 1000H THEN + Put3(BL, 7, ((-x.r) * 100H + x.a) * 1000H + pc-fixorgP); fixorgP := pc-1 + ELSE ORS.Mark("fixup impossible") + END + END + ELSE + IF x.mode <= ORB.Par THEN load(x); DEC(RH) + ELSE Put2(Ldr, RH, SP, 0); Put1(Add, SP, SP, 4); DEC(r); DEC(frame, 4) + END ; + IF check THEN Trap(EQ, 5) END ; + Put3(BLR, 7, RH) + END ; + IF x.type.base.form = ORB.NoTyp THEN (*procedure*) RH := 0 + ELSE (*function*) + IF r > 0 THEN Put0(Mov, r, 0, 0); RestoreRegs(r) END ; + x.mode := Reg; x.r := r; RH := r+1 + END ; + invalSB + END Call; + + PROCEDURE Enter*(parblksize, locblksize: LONGINT; int: BOOLEAN); + VAR a, r: LONGINT; + BEGIN invalSB; frame := 0; + IF ~int THEN (*procedure prolog*) + a := 4; r := 0; + Put1(Sub, SP, SP, locblksize); Put2(Str, LNK, SP, 0); + WHILE a < parblksize DO Put2(Str, r, SP, a); INC(r); INC(a, 4) END + ELSE (*interrupt procedure*) + Put1(Sub, SP, SP, 12); Put2(Str, 0, SP, 0); Put2(Str, 1, SP, 4); Put2(Str, SB, SP, 8) + (*R0, R1, SB saved os stack*) + END + END Enter; + + PROCEDURE Return*(form: INTEGER; VAR x: Item; size: LONGINT; int: BOOLEAN); + BEGIN + IF form # ORB.NoTyp THEN load(x) END ; + IF ~int THEN (*procedure epilog*) + Put2(Ldr, LNK, SP, 0); Put1(Add, SP, SP, size); Put3(BR, 7, LNK) + ELSE (*interrupt return, restore SB, R1, R0*) + Put2(Ldr, SB, SP, 8); Put2(Ldr, 1, SP, 4); Put2(Ldr, 0, SP, 0); Put1(Add, SP, SP, 12); Put3(BR, 7, 10H) + END ; + RH := 0 + END Return; + + (* In-line code procedures*) + + PROCEDURE Increment*(upordown: LONGINT; VAR x, y: Item); + VAR op, zr, v: LONGINT; + BEGIN (*frame = 0*) + IF upordown = 0 THEN op := Add ELSE op := Sub END ; + IF x.type = ORB.byteType THEN v := 1 ELSE v := 0 END ; + IF y.type.form = ORB.NoTyp THEN y.mode := ORB.Const; y.a := 1 END ; + IF (x.mode = ORB.Var) & (x.r > 0) THEN + zr := RH; Put2(Ldr+v, zr, SP, x.a); incR; + IF y.mode = ORB.Const THEN Put1a(op, zr, zr, y.a) ELSE load(y); Put0(op, zr, zr, y.r); DEC(RH) END ; + Put2(Str+v, zr, SP, x.a); DEC(RH) + ELSE loadAdr(x); zr := RH; Put2(Ldr+v, RH, x.r, 0); incR; + IF y.mode = ORB.Const THEN Put1a(op, zr, zr, y.a) ELSE load(y); Put0(op, zr, zr, y.r); DEC(RH) END ; + Put2(Str+v, zr, x.r, 0); DEC(RH, 2) + END + END Increment; + + PROCEDURE Include*(inorex: LONGINT; VAR x, y: Item); + VAR op, zr: LONGINT; + BEGIN loadAdr(x); zr := RH; Put2(Ldr, RH, x.r, 0); incR; + IF inorex = 0 THEN op := Ior ELSE op := Ann END ; + IF y.mode = ORB.Const THEN Put1a(op, zr, zr, LSL(1, y.a)) + ELSE load(y); Put1(Mov, RH, 0, 1); Put0(Lsl, y.r, RH, y.r); Put0(op, zr, zr, y.r); DEC(RH) + END ; + Put2(Str, zr, x.r, 0); DEC(RH, 2) + END Include; + + PROCEDURE Assert*(VAR x: Item); + VAR cond: LONGINT; + BEGIN + IF x.mode # Cond THEN loadCond(x) END ; + IF x.a = 0 THEN cond := negated(x.r) + ELSE Put3(BC, x.r, x.b); FixLink(x.a); x.b := pc-1; cond := 7 + END ; + Trap(cond, 7); FixLink(x.b) + END Assert; + + PROCEDURE New*(VAR x: Item); + BEGIN loadAdr(x); loadTypTagAdr(x.type.base); Put3(BLR, 7, MT); RH := 0; invalSB + END New; + + PROCEDURE Pack*(VAR x, y: Item); + VAR z: Item; + BEGIN z := x; load(x); load(y); + Put1(Lsl, y.r, y.r, 23); Put0(Add, x.r, x.r, y.r); DEC(RH); Store(z, x) + END Pack; + + PROCEDURE Unpk*(VAR x, y: Item); + VAR z, e0: Item; + BEGIN z := x; load(x); e0.mode := Reg; e0.r := RH; e0.type := ORB.intType; + Put1(Asr, RH, x.r, 23); Put1(Sub, RH, RH, 127); Store(y, e0); incR; + Put1(Lsl, RH, RH, 23); Put0(Sub, x.r, x.r, RH); Store(z, x) + END Unpk; + + PROCEDURE Led*(VAR x: Item); + BEGIN load(x); Put1(Mov, RH, 0, -60); Put2(Str, x.r, RH, 0); DEC(RH) + END Led; + + PROCEDURE Get*(VAR x, y: Item); + BEGIN load(x); x.type := y.type; x.mode := RegI; x.a := 0; Store(y, x) + END Get; + + PROCEDURE Put*(VAR x, y: Item); + BEGIN load(x); x.type := y.type; x.mode := RegI; x.a := 0; Store(x, y) + END Put; + + PROCEDURE Copy*(VAR x, y, z: Item); + BEGIN load(x); load(y); + IF z.mode = ORB.Const THEN + IF z.a > 0 THEN load(z) ELSE ORS.Mark("bad count") END + ELSE load(z); + IF check THEN Trap(LT, 3) END ; + Put3(BC, EQ, 6) + END ; + Put2(Ldr, RH, x.r, 0); Put1(Add, x.r, x.r, 4); + Put2(Str, RH, y.r, 0); Put1(Add, y.r, y.r, 4); + Put1(Sub, z.r, z.r, 1); Put3(BC, NE, -6); DEC(RH, 3) + END Copy; + + PROCEDURE LDPSR*(VAR x: Item); + BEGIN (*x.mode = Const*) Put3(0, 15, x.a + 20H) + END LDPSR; + + PROCEDURE LDREG*(VAR x, y: Item); + BEGIN + IF y.mode = ORB.Const THEN Put1a(Mov, x.a, 0, y.a) + ELSE load(y); Put0(Mov, x.a, 0, y.r); DEC(RH) + END + END LDREG; + + (*In-line code functions*) + + PROCEDURE Abs*(VAR x: Item); + BEGIN + IF x.mode = ORB.Const THEN x.a := ABS(x.a) + ELSE load(x); + IF x.type.form = ORB.Real THEN Put1(Lsl, x.r, x.r, 1); Put1(Ror, x.r, x.r, 1) + ELSE Put1(Cmp, x.r, x.r, 0); Put3(BC, GE, 2); Put1(Mov, RH, 0, 0); Put0(Sub, x.r, RH, x.r) + END + END + END Abs; + + PROCEDURE Odd*(VAR x: Item); + BEGIN load(x); Put1(And, x.r, x.r, 1); SetCC(x, NE); DEC(RH) + END Odd; + + PROCEDURE Floor*(VAR x: Item); + BEGIN load(x); Put1(Mov+U, RH, 0, 4B00H); Put0(Fad+V, x.r, x.r, RH) + END Floor; + + PROCEDURE Float*(VAR x: Item); + BEGIN load(x); Put1(Mov+U, RH, 0, 4B00H); Put0(Fad+U, x.r, x.r, RH) + END Float; + + PROCEDURE Ord*(VAR x: Item); + BEGIN + IF x.mode IN {ORB.Var, ORB.Par, RegI} THEN load(x) END + END Ord; + + PROCEDURE Len*(VAR x: Item); + BEGIN + IF x.type.len >= 0 THEN x.mode := ORB.Const; x.a := x.type.len + ELSE (*open array*) Put2(Ldr, RH, SP, x.a + 4 + frame); x.mode := Reg; x.r := RH; incR + END + END Len; + + PROCEDURE Shift*(fct: LONGINT; VAR x, y: Item); + VAR op: LONGINT; + BEGIN load(x); + IF fct = 0 THEN op := Lsl ELSIF fct = 1 THEN op := Asr ELSE op := Ror END ; + IF y.mode = ORB.Const THEN Put1(op, x.r, x.r, y.a MOD 20H) + ELSE load(y); Put0(op, RH-2, x.r, y.r); DEC(RH); x.r := RH-1 + END + END Shift; + + PROCEDURE ADC*(VAR x, y: Item); + BEGIN load(x); load(y); Put0(Add+2000H, x.r, x.r, y.r); DEC(RH) + END ADC; + + PROCEDURE SBC*(VAR x, y: Item); + BEGIN load(x); load(y); Put0(Sub+2000H, x.r, x.r, y.r); DEC(RH) + END SBC; + + PROCEDURE UML*(VAR x, y: Item); + BEGIN load(x); load(y); Put0(Mul+2000H, x.r, x.r, y.r); DEC(RH) + END UML; + + PROCEDURE Bit*(VAR x, y: Item); + BEGIN load(x); Put2(Ldr, x.r, x.r, 0); + IF y.mode = ORB.Const THEN Put1(Ror, x.r, x.r, y.a+1); DEC(RH) + ELSE load(y); Put1(Add, y.r, y.r, 1); Put0(Ror, x.r, x.r, y.r); DEC(RH, 2) + END ; + SetCC(x, MI) + END Bit; + + PROCEDURE Register*(VAR x: Item); + BEGIN (*x.mode = Const*) + Put0(Mov, RH, 0, x.a MOD 10H); x.mode := Reg; x.r := RH; incR + END Register; + + PROCEDURE H*(VAR x: Item); + BEGIN (*x.mode = Const*) + Put0(Mov + U + x.a MOD 2 * V, RH, 0, 0); x.mode := Reg; x.r := RH; incR + END H; + + PROCEDURE Adr*(VAR x: Item); + BEGIN + IF x.mode IN {ORB.Var, ORB.Par, RegI} THEN loadAdr(x) + ELSIF (x.mode = ORB.Const) & (x.type.form = ORB.Proc) THEN load(x) + ELSIF (x.mode = ORB.Const) & (x.type.form = ORB.String) THEN loadStringAdr(x) + ELSE ORS.Mark("not addressable") + END + END Adr; + + PROCEDURE Condition*(VAR x: Item); + BEGIN (*x.mode = Const*) SetCC(x, x.a) + END Condition; + + PROCEDURE Open*(v: INTEGER); + BEGIN pc := 0; tdx := 0; strx := 0; RH := 0; fixorgP := 0; fixorgD := 0; fixorgT := 0; check := v # 0; version := v; + IF v = 0 THEN pc := 8 END + END Open; + + PROCEDURE SetDataSize*(dc: LONGINT); + BEGIN varsize := dc + END SetDataSize; + + PROCEDURE Header*; + BEGIN entry := pc*4; + IF version = 0 THEN code[0] := 0E7000000H-1 + pc; Put1a(Mov, SB, 0, VarOrg0); Put1a(Mov, SP, 0, StkOrg0) (*RISC-0*) + ELSE Put1(Sub, SP, SP, 4); Put2(Str, LNK, SP, 0); invalSB + END + END Header; + + PROCEDURE NofPtrs(typ: ORB.Type): LONGINT; + VAR fld: ORB.Object; n: LONGINT; + BEGIN + IF (typ.form = ORB.Pointer) OR (typ.form = ORB.NilTyp) THEN n := 1 + ELSIF typ.form = ORB.Record THEN + fld := typ.dsc; n := 0; + WHILE fld # NIL DO n := NofPtrs(fld.type) + n; fld := fld.next END + ELSIF typ.form = ORB.Array THEN n := NofPtrs(typ.base) * typ.len + ELSE n := 0 + END ; + RETURN n + END NofPtrs; + + PROCEDURE FindPtrs(VAR R: Files.Rider; typ: ORB.Type; adr: LONGINT); + VAR fld: ORB.Object; i, s: LONGINT; + BEGIN + IF (typ.form = ORB.Pointer) OR (typ.form = ORB.NilTyp) THEN Files.WriteInt(R, adr) + ELSIF typ.form = ORB.Record THEN + fld := typ.dsc; + WHILE fld # NIL DO FindPtrs(R, fld.type, fld.val + adr); fld := fld.next END + ELSIF typ.form = ORB.Array THEN + s := typ.base.size; + FOR i := 0 TO typ.len-1 DO FindPtrs(R, typ.base, i*s + adr) END + END + END FindPtrs; + + PROCEDURE Close*(VAR modid: ORS.Ident; key, nofent: LONGINT); + VAR obj: ORB.Object; + i, comsize, nofimps, nofptrs, size: LONGINT; + name: ORS.Ident; + F: Files.File; R: Files.Rider; + BEGIN (*exit code*) + IF version = 0 THEN Put1(Mov, 0, 0, 0); Put3(BR, 7, 0) (*RISC-0*) + ELSE Put2(Ldr, LNK, SP, 0); Put1(Add, SP, SP, 4); Put3(BR, 7, LNK) + END ; + obj := ORB.topScope.next; nofimps := 0; comsize := 4; nofptrs := 0; + WHILE obj # NIL DO + IF (obj.class = ORB.Mod) & (obj.dsc # ORB.system) THEN INC(nofimps) (*count imports*) + ELSIF (obj.exno # 0) & (obj.class = ORB.Const) & (obj.type.form = ORB.Proc) + & (obj.type.nofpar = 0) & (obj.type.base = ORB.noType) THEN i := 0; (*count commands*) + WHILE obj.name[i] # 0X DO INC(i) END ; + i := (i+4) DIV 4 * 4; INC(comsize, i+4) + ELSIF obj.class = ORB.Var THEN INC(nofptrs, NofPtrs(obj.type)) (*count pointers*) + END ; + obj := obj.next + END ; + size := varsize + strx + comsize + (pc + nofimps + nofent + nofptrs + 1)*4; (*varsize includes type descriptors*) + + ORB.MakeFileName(name, modid, ".rsc"); (*write code file*) + F := Files.New(name); Files.Set(R, F, 0); Files.WriteString(R, modid); Files.WriteInt(R, key); + (*Files.WriteByte(R, version);*) (* who writes like that? -- noch *) + Files.WriteByte(R, SHORT(SHORT(version))); (* voc adaptation by noch *) + Files.WriteInt(R, size); + obj := ORB.topScope.next; + WHILE (obj # NIL) & (obj.class = ORB.Mod) DO (*imports*) + IF obj.dsc # ORB.system THEN Files.WriteString(R, obj(ORB.Module).orgname); Files.WriteInt(R, obj.val) END ; + obj := obj.next + END ; + Files.Write(R, 0X); + Files.WriteInt(R, tdx*4); + i := 0; + WHILE i < tdx DO Files.WriteInt(R, data[i]); INC(i) END ; (*type descriptors*) + Files.WriteInt(R, varsize - tdx*4); (*data*) + Files.WriteInt(R, strx); + FOR i := 0 TO strx-1 DO Files.Write(R, str[i]) END ; (*strings*) + Files.WriteInt(R, pc); (*code len*) + FOR i := 0 TO pc-1 DO Files.WriteInt(R, code[i]) END ; (*program*) + obj := ORB.topScope.next; + WHILE obj # NIL DO (*commands*) + IF (obj.exno # 0) & (obj.class = ORB.Const) & (obj.type.form = ORB.Proc) & + (obj.type.nofpar = 0) & (obj.type.base = ORB.noType) THEN + Files.WriteString(R, obj.name); Files.WriteInt(R, obj.val) + END ; + obj := obj.next + END ; + Files.Write(R, 0X); + Files.WriteInt(R, nofent); Files.WriteInt(R, entry); + obj := ORB.topScope.next; + WHILE obj # NIL DO (*entries*) + IF obj.exno # 0 THEN + IF (obj.class = ORB.Const) & (obj.type.form = ORB.Proc) OR (obj.class = ORB.Var) THEN + Files.WriteInt(R, obj.val) + ELSIF obj.class = ORB.Typ THEN + IF obj.type.form = ORB.Record THEN Files.WriteInt(R, obj.type.len MOD 10000H) + ELSIF (obj.type.form = ORB.Pointer) & ((obj.type.base.typobj = NIL) OR (obj.type.base.typobj.exno = 0)) THEN + Files.WriteInt(R, obj.type.base.len MOD 10000H) + END + END + END ; + obj := obj.next + END ; + obj := ORB.topScope.next; + WHILE obj # NIL DO (*pointer variables*) + IF obj.class = ORB.Var THEN FindPtrs(R, obj.type, obj.val) END ; + obj := obj.next + END ; + Files.WriteInt(R, -1); + Files.WriteInt(R, fixorgP); Files.WriteInt(R, fixorgD); Files.WriteInt(R, fixorgT); Files.WriteInt(R, entry); + Files.Write(R, "O"); Files.Register(F) + END Close; + +BEGIN + relmap[0] := 1; relmap[1] := 9; relmap[2] := 5; relmap[3] := 6; relmap[4] := 14; relmap[5] := 13 +END ORG. diff --git a/src/voc07R/ORP.Mod b/src/voc07R/ORP.Mod index 7c59e50f..99e6ee83 100644 --- a/src/voc07R/ORP.Mod +++ b/src/voc07R/ORP.Mod @@ -1,997 +1,997 @@ -MODULE ORP; (*N. Wirth 1.7.97 / 7.6.2014 Oberon compiler for RISC in Oberon-07*) - IMPORT Texts := CompatTexts, Oberon, ORS, ORB, ORG; - (*Author: Niklaus Wirth, 2014. - Parser of Oberon-RISC compiler. Uses Scanner ORS to obtain symbols (tokens), - ORB for definition of data structures and for handling import and export, and - ORG to produce binary code. ORP performs type checking and data allocation. - Parser is target-independent, except for part of the handling of allocations.*) - - TYPE INTEGER = LONGINT; (* voc adaptation by noch *) - - TYPE PtrBase = POINTER TO PtrBaseDesc; - PtrBaseDesc = RECORD (*list of names of pointer base types*) - name: ORS.Ident; type: ORB.Type; next: PtrBase - END ; - - VAR sym: INTEGER; (*last symbol read*) - dc: LONGINT; (*data counter*) - level, exno, version: INTEGER; - newSF: BOOLEAN; (*option flag*) - expression: PROCEDURE (VAR x: ORG.Item); (*to avoid forward reference*) - Type: PROCEDURE (VAR type: ORB.Type); - FormalType: PROCEDURE (VAR typ: ORB.Type; dim: INTEGER); - modid: ORS.Ident; - pbsList: PtrBase; (*list of names of pointer base types*) - dummy: ORB.Object; - W: Texts.Writer; - - PROCEDURE Check(s: INTEGER; msg: ARRAY OF CHAR); - BEGIN - IF sym = s THEN ORS.Get(sym) ELSE ORS.Mark(msg) END - END Check; - - PROCEDURE qualident(VAR obj: ORB.Object); - BEGIN obj := ORB.thisObj(); ORS.Get(sym); - IF obj = NIL THEN ORS.Mark("undef"); obj := dummy END ; - IF (sym = ORS.period) & (obj.class = ORB.Mod) THEN - ORS.Get(sym); - IF sym = ORS.ident THEN obj := ORB.thisimport(obj); ORS.Get(sym); - IF obj = NIL THEN ORS.Mark("undef"); obj := dummy END - ELSE ORS.Mark("identifier expected"); obj := dummy - END - END - END qualident; - - PROCEDURE CheckBool(VAR x: ORG.Item); - BEGIN - IF x.type.form # ORB.Bool THEN ORS.Mark("not Boolean"); x.type := ORB.boolType END - END CheckBool; - - PROCEDURE CheckInt(VAR x: ORG.Item); - BEGIN - IF x.type.form # ORB.Int THEN ORS.Mark("not Integer"); x.type := ORB.intType END - END CheckInt; - - PROCEDURE CheckReal(VAR x: ORG.Item); - BEGIN - IF x.type.form # ORB.Real THEN ORS.Mark("not Real"); x.type := ORB.realType END - END CheckReal; - - PROCEDURE CheckSet(VAR x: ORG.Item); - BEGIN - IF x.type.form # ORB.Set THEN ORS.Mark("not Set"); x.type := ORB.setType END - END CheckSet; - - PROCEDURE CheckSetVal(VAR x: ORG.Item); - BEGIN - IF x.type.form # ORB.Int THEN ORS.Mark("not Int"); x.type := ORB.setType - ELSIF x.mode = ORB.Const THEN - IF (x.a < 0) OR (x.a >= 32) THEN ORS.Mark("invalid set") END - END - END CheckSetVal; - - PROCEDURE CheckConst(VAR x: ORG.Item); - BEGIN - IF x.mode # ORB.Const THEN ORS.Mark("not a constant"); x.mode := ORB.Const END - END CheckConst; - - PROCEDURE CheckReadOnly(VAR x: ORG.Item); - BEGIN - IF x.rdo THEN ORS.Mark("read-only") END - END CheckReadOnly; - - PROCEDURE CheckExport(VAR expo: BOOLEAN); - BEGIN - IF sym = ORS.times THEN - expo := TRUE; ORS.Get(sym); - IF level # 0 THEN ORS.Mark("remove asterisk") END - ELSE expo := FALSE - END - END CheckExport; - - PROCEDURE IsExtension(t0, t1: ORB.Type): BOOLEAN; - BEGIN (*t1 is an extension of t0*) - RETURN (t0 = t1) OR (t1 # NIL) & IsExtension(t0, t1.base) - END IsExtension; - - (* expressions *) - - PROCEDURE TypeTest(VAR x: ORG.Item; T: ORB.Type; guard: BOOLEAN); - VAR xt: ORB.Type; - BEGIN xt := x.type; - WHILE (xt # T) & (xt # NIL) DO xt := xt.base END ; - IF xt # T THEN xt := x.type; - IF (xt.form = ORB.Pointer) & (T.form = ORB.Pointer) THEN - IF IsExtension(xt.base, T.base) THEN ORG.TypeTest(x, T.base, FALSE, guard); x.type := T - ELSE ORS.Mark("not an extension") - END - ELSIF (xt.form = ORB.Record) & (T.form = ORB.Record) & (x.mode = ORB.Par) THEN - IF IsExtension(xt, T) THEN ORG.TypeTest(x, T, TRUE, guard); x.type := T - ELSE ORS.Mark("not an extension") - END - ELSE ORS.Mark("incompatible types") - END - ELSIF ~guard THEN ORG.MakeConstItem(x, ORB.boolType, 1) - END ; - IF ~guard THEN x.type := ORB.boolType END - END TypeTest; - - PROCEDURE selector(VAR x: ORG.Item); - VAR y: ORG.Item; obj: ORB.Object; - BEGIN - WHILE (sym = ORS.lbrak) OR (sym = ORS.period) OR (sym = ORS.arrow) - OR (sym = ORS.lparen) & (x.type.form IN {ORB.Record, ORB.Pointer}) DO - IF sym = ORS.lbrak THEN - REPEAT ORS.Get(sym); expression(y); - IF x.type.form = ORB.Array THEN - CheckInt(y); ORG.Index(x, y); x.type := x.type.base - ELSE ORS.Mark("not an array") - END - UNTIL sym # ORS.comma; - Check(ORS.rbrak, "no ]") - ELSIF sym = ORS.period THEN ORS.Get(sym); - IF sym = ORS.ident THEN - IF x.type.form = ORB.Pointer THEN ORG.DeRef(x); x.type := x.type.base END ; - IF x.type.form = ORB.Record THEN - obj := ORB.thisfield(x.type); ORS.Get(sym); - IF obj # NIL THEN ORG.Field(x, obj); x.type := obj.type - ELSE ORS.Mark("undef") - END - ELSE ORS.Mark("not a record") - END - ELSE ORS.Mark("ident?") - END - ELSIF sym = ORS.arrow THEN - ORS.Get(sym); - IF x.type.form = ORB.Pointer THEN ORG.DeRef(x); x.type := x.type.base - ELSE ORS.Mark("not a pointer") - END - ELSIF (sym = ORS.lparen) & (x.type.form IN {ORB.Record, ORB.Pointer}) THEN (*type guard*) - ORS.Get(sym); - IF sym = ORS.ident THEN - qualident(obj); - IF obj.class = ORB.Typ THEN TypeTest(x, obj.type, TRUE) - ELSE ORS.Mark("guard type expected") - END - ELSE ORS.Mark("not an identifier") - END ; - Check(ORS.rparen, " ) missing") - END - END - END selector; - - PROCEDURE CompTypes(t0, t1: ORB.Type; varpar: BOOLEAN): BOOLEAN; - - PROCEDURE EqualSignatures(t0, t1: ORB.Type): BOOLEAN; - VAR p0, p1: ORB.Object; com: BOOLEAN; - BEGIN com := TRUE; - IF (t0.base = t1.base) & (t0.nofpar = t1.nofpar) THEN - p0 := t0.dsc; p1 := t1.dsc; - WHILE p0 # NIL DO - IF (p0.class = p1.class) & CompTypes(p0.type, p1.type, TRUE) & - (*(ORD(p0.rdo) = ORD(p1.rdo))*) - (p0.rdo = p1.rdo) (* voc adaptation by noch *) - THEN - IF p0.type.form >= ORB.Array THEN com := CompTypes(p0.type, p1.type, (p0.class = ORB.Par)) END ; - p0 := p0.next; p1 := p1.next - ELSE p0 := NIL; com := FALSE - END - END - ELSE com := FALSE - END ; - RETURN com - END EqualSignatures; - - BEGIN (*Compatible Types*) - RETURN (t0 = t1) - OR (t0.form = ORB.Array) & (t1.form = ORB.Array) & CompTypes(t0.base, t1.base, varpar) - OR (t0.form = ORB.Pointer) & (t1.form = ORB.Pointer) & IsExtension(t0.base, t1.base) - OR (t0.form = ORB.Record) & (t1.form = ORB.Record) & IsExtension(t0, t1) - OR (t0.form = ORB.Proc) & (t1.form = ORB.Proc) & EqualSignatures(t0, t1) - OR (t0.form IN {ORB.Pointer, ORB.Proc}) & (t1.form = ORB.NilTyp) - OR (t0.form = ORB.NilTyp) & (t1.form IN {ORB.Pointer, ORB.Proc}) - OR ~varpar & (t0.form = ORB.Int) & (t1.form = ORB.Int) - END CompTypes; - - PROCEDURE Parameter(par: ORB.Object); - VAR x: ORG.Item; varpar: BOOLEAN; - BEGIN expression(x); - IF par # NIL THEN - varpar := par.class = ORB.Par; - IF CompTypes(par.type, x.type, varpar) THEN - IF ~varpar THEN ORG.ValueParam(x) - ELSE (*par.class = Par*) - IF ~par.rdo THEN CheckReadOnly(x) END ; - ORG.VarParam(x, par.type) - END - ELSIF ~varpar & (par.type.form = ORB.Int) & (x.type.form = ORB.Int) THEN - ORG.ValueParam(x) - ELSIF (x.type.form = ORB.String) & (x.b = 2) & (par.class = ORB.Var) & (par.type.form = ORB.Char) THEN - ORG.StrToChar(x); ORG.ValueParam(x) - ELSIF (x.type.form = ORB.Array) & (par.type.form = ORB.Array) & - (x.type.base.form = par.type.base.form) & (par.type.len < 0) THEN - ORG.OpenArrayParam(x); - ELSIF (x.type.form = ORB.String) & varpar & par.rdo & (par.type.form = ORB.Array) & - (par.type.base.form = ORB.Char) & (par.type.len < 0) THEN ORG.StringParam(x) - ELSIF (par.type.form = ORB.Array) & (par.type.base.form = ORB.Int) & (par.type.size = x.type.size) THEN - ORG.VarParam(x, par.type) - ELSE ORS.Mark("incompatible parameters") - END - END - END Parameter; - - PROCEDURE ParamList(VAR x: ORG.Item); - VAR n: INTEGER; par: ORB.Object; - BEGIN par := x.type.dsc; n := 0; - IF sym # ORS.rparen THEN - Parameter(par); n := 1; - WHILE sym <= ORS.comma DO - Check(sym, "comma?"); - IF par # NIL THEN par := par.next END ; - INC(n); Parameter(par) - END ; - Check(ORS.rparen, ") missing") - ELSE ORS.Get(sym); - END ; - IF n < x.type.nofpar THEN ORS.Mark("too few params") - ELSIF n > x.type.nofpar THEN ORS.Mark("too many params") - END - END ParamList; - - PROCEDURE StandFunc(VAR x: ORG.Item; fct: LONGINT; restyp: ORB.Type); - VAR y: ORG.Item; n, npar: LONGINT; - BEGIN Check(ORS.lparen, "no ("); - npar := fct MOD 10; fct := fct DIV 10; expression(x); n := 1; - WHILE sym = ORS.comma DO ORS.Get(sym); expression(y); INC(n) END ; - Check(ORS.rparen, "no )"); - IF n = npar THEN - IF fct = 0 THEN (*ABS*) - IF x.type.form IN {ORB.Int, ORB.Real} THEN ORG.Abs(x); restyp := x.type ELSE ORS.Mark("bad type") END - ELSIF fct = 1 THEN (*ODD*) CheckInt(x); ORG.Odd(x) - ELSIF fct = 2 THEN (*FLOOR*) CheckReal(x); ORG.Floor(x) - ELSIF fct = 3 THEN (*FLT*) CheckInt(x); ORG.Float(x) - ELSIF fct = 4 THEN (*ORD*) - IF x.type.form <= ORB.Proc THEN ORG.Ord(x) - ELSIF (x.type.form = ORB.String) & (x.b = 2) THEN ORG.StrToChar(x) - ELSE ORS.Mark("bad type") - END - ELSIF fct = 5 THEN (*CHR*) CheckInt(x); ORG.Ord(x) - ELSIF fct = 6 THEN (*LEN*) - IF x.type.form = ORB.Array THEN ORG.Len(x) ELSE ORS.Mark("not an array") END - ELSIF fct IN {7, 8, 9} THEN (*LSL, ASR, ROR*) CheckInt(y); - IF x.type.form IN {ORB.Int, ORB.Set} THEN ORG.Shift(fct-7, x, y); restyp := x.type ELSE ORS.Mark("bad type") END - ELSIF fct = 11 THEN (*ADC*) ORG.ADC(x, y) - ELSIF fct = 12 THEN (*SBC*) ORG.SBC(x, y) - ELSIF fct = 13 THEN (*UML*) ORG.UML(x, y) - ELSIF fct = 14 THEN (*BIT*) CheckInt(x); CheckInt(y); ORG.Bit(x, y) - ELSIF fct = 15 THEN (*REG*) CheckConst(x); CheckInt(x); ORG.Register(x) - ELSIF fct = 16 THEN (*VAL*) - IF (x.mode= ORB.Typ) & (x.type.size <= y.type.size) THEN restyp := x.type; x := y - ELSE ORS.Mark("casting not allowed") - END - ELSIF fct = 17 THEN (*ADR*) ORG.Adr(x) - ELSIF fct = 18 THEN (*SIZE*) - IF x.mode = ORB.Typ THEN ORG.MakeConstItem(x, ORB.intType, x.type.size) - ELSE ORS.Mark("must be a type") - END - ELSIF fct = 19 THEN (*COND*) CheckConst(x); CheckInt(x); ORG.Condition(x) - ELSIF fct = 20 THEN (*H*) CheckConst(x); CheckInt(x); ORG.H(x) - END ; - x.type := restyp - ELSE ORS.Mark("wrong nof params") - END - END StandFunc; - - PROCEDURE element(VAR x: ORG.Item); - VAR y: ORG.Item; - BEGIN expression(x); CheckSetVal(x); - IF sym = ORS.upto THEN ORS.Get(sym); expression(y); CheckSetVal(y); ORG.Set(x, y) - ELSE ORG.Singleton(x) - END ; - x.type := ORB.setType - END element; - - PROCEDURE set(VAR x: ORG.Item); - VAR y: ORG.Item; - BEGIN - IF sym >= ORS.if THEN - IF sym # ORS.rbrace THEN ORS.Mark(" } missing") END ; - ORG.MakeConstItem(x, ORB.setType, 0) (*empty set*) - ELSE element(x); - WHILE (sym < ORS.rparen) OR (sym > ORS.rbrace) DO - IF sym = ORS.comma THEN ORS.Get(sym) - ELSIF sym # ORS.rbrace THEN ORS.Mark("missing comma") - END ; - element(y); ORG.SetOp(ORS.plus, x, y) - END - END - END set; - - PROCEDURE factor(VAR x: ORG.Item); - VAR obj: ORB.Object; rx: LONGINT; - BEGIN (*sync*) - IF (sym < ORS.char) OR (sym > ORS.ident) THEN ORS.Mark("expression expected"); - REPEAT ORS.Get(sym) UNTIL (sym >= ORS.char) & (sym <= ORS.ident) - END ; - IF sym = ORS.ident THEN - qualident(obj); - IF obj.class = ORB.SFunc THEN StandFunc(x, obj.val, obj.type) - ELSE ORG.MakeItem(x, obj, level); selector(x); - IF sym = ORS.lparen THEN - ORS.Get(sym); - IF (x.type.form = ORB.Proc) & (x.type.base.form # ORB.NoTyp) THEN - ORG.PrepCall(x, rx); ParamList(x); ORG.Call(x, rx); x.type := x.type.base - ELSE ORS.Mark("not a function"); ParamList(x) - END - END - END - ELSIF sym = ORS.int THEN ORG.MakeConstItem(x, ORB.intType, ORS.ival); ORS.Get(sym) - ELSIF sym = ORS.real THEN ORG.MakeRealItem(x, ORS.rval); ORS.Get(sym) - ELSIF sym = ORS.char THEN ORG.MakeConstItem(x, ORB.charType, ORS.ival); ORS.Get(sym) - ELSIF sym = ORS.nil THEN ORS.Get(sym); ORG.MakeConstItem(x, ORB.nilType, 0) - ELSIF sym = ORS.string THEN ORG.MakeStringItem(x, ORS.slen); ORS.Get(sym) - ELSIF sym = ORS.lparen THEN ORS.Get(sym); expression(x); Check(ORS.rparen, "no )") - ELSIF sym = ORS.lbrace THEN ORS.Get(sym); set(x); Check(ORS.rbrace, "no }") - ELSIF sym = ORS.not THEN ORS.Get(sym); factor(x); CheckBool(x); ORG.Not(x) - ELSIF sym = ORS.false THEN ORS.Get(sym); ORG.MakeConstItem(x, ORB.boolType, 0) - ELSIF sym = ORS.true THEN ORS.Get(sym); ORG.MakeConstItem(x, ORB.boolType, 1) - ELSE ORS.Mark("not a factor"); ORG.MakeItem(x, NIL, level) - END - END factor; - - PROCEDURE term(VAR x: ORG.Item); - VAR y: ORG.Item; op, f: INTEGER; - BEGIN factor(x); f := x.type.form; - WHILE (sym >= ORS.times) & (sym <= ORS.and) DO - op := sym; ORS.Get(sym); - IF op = ORS.times THEN - IF f = ORB.Int THEN factor(y); CheckInt(y); ORG.MulOp(x, y) - ELSIF f = ORB.Real THEN factor(y); CheckReal(y); ORG.RealOp(op, x, y) - ELSIF f = ORB.Set THEN factor(y); CheckSet(y); ORG.SetOp(op, x, y) - ELSE ORS.Mark("bad type") - END - ELSIF (op = ORS.div) OR (op = ORS.mod) THEN - CheckInt(x); factor(y); CheckInt(y); ORG.DivOp(op, x, y) - ELSIF op = ORS.rdiv THEN - IF f = ORB.Real THEN factor(y); CheckReal(y); ORG.RealOp(op, x, y) - ELSIF f = ORB.Set THEN factor(y); CheckSet(y); ORG.SetOp(op, x, y) - ELSE ORS.Mark("bad type") - END - ELSE (*op = and*) CheckBool(x); ORG.And1(x); factor(y); CheckBool(y); ORG.And2(x, y) - END - END - END term; - - PROCEDURE SimpleExpression(VAR x: ORG.Item); - VAR y: ORG.Item; op: INTEGER; - BEGIN - IF sym = ORS.minus THEN ORS.Get(sym); term(x); - IF x.type.form IN {ORB.Int, ORB.Real, ORB.Set} THEN ORG.Neg(x) ELSE CheckInt(x) END - ELSIF sym = ORS.plus THEN ORS.Get(sym); term(x); - ELSE term(x) - END ; - WHILE (sym >= ORS.plus) & (sym <= ORS.or) DO - op := sym; ORS.Get(sym); - IF op = ORS.or THEN ORG.Or1(x); CheckBool(x); term(y); CheckBool(y); ORG.Or2(x, y) - ELSIF x.type.form = ORB.Int THEN term(y); CheckInt(y); ORG.AddOp(op, x, y) - ELSIF x.type.form = ORB.Real THEN term(y); CheckReal(y); ORG.RealOp(op, x, y) - ELSE CheckSet(x); term(y); CheckSet(y); ORG.SetOp(op, x, y) - END - END - END SimpleExpression; - - PROCEDURE expression0(VAR x: ORG.Item); - VAR y: ORG.Item; obj: ORB.Object; rel, xf, yf: INTEGER; - BEGIN SimpleExpression(x); - IF (sym >= ORS.eql) & (sym <= ORS.geq) THEN - rel := sym; ORS.Get(sym); SimpleExpression(y); xf := x.type.form; yf := y.type.form; - IF CompTypes(x.type, y.type, FALSE) OR - (xf = ORB.Pointer) & (yf = ORB.Pointer) & IsExtension(y.type.base, x.type.base) THEN - IF (xf IN {ORB.Char, ORB.Int}) THEN ORG.IntRelation(rel, x, y) - ELSIF xf = ORB.Real THEN ORG.RealRelation(rel, x, y) - ELSIF xf = ORB.Set THEN ORG.SetRelation(rel, x, y) - ELSIF (xf IN {ORB.Pointer, ORB.Proc, ORB.NilTyp}) THEN - IF rel <= ORS.neq THEN ORG.IntRelation(rel, x, y) ELSE ORS.Mark("only = or #") END - ELSIF (xf = ORB.Array) & (x.type.base.form = ORB.Char) OR (xf = ORB.String) THEN - ORG.StringRelation(rel, x, y) - ELSE ORS.Mark("illegal comparison") - END - ELSIF (xf = ORB.Array) & (x.type.base.form = ORB.Char) & - ((yf = ORB.String) OR (yf = ORB.Array) & (y.type.base.form = ORB.Char)) - OR (yf = ORB.Array) & (y.type.base.form = ORB.Char) & (xf = ORB.String) THEN - ORG.StringRelation(rel, x, y) - ELSIF (xf = ORB.Char) & (yf = ORB.String) & (y.b = 2) THEN - ORG.StrToChar(y); ORG.IntRelation(rel, x, y) - ELSIF (yf = ORB.Char) & (xf = ORB.String) & (x.b = 2) THEN - ORG.StrToChar(x); ORG.IntRelation(rel, x, y) - ELSE ORS.Mark("illegal comparison") - END ; - x.type := ORB.boolType - ELSIF sym = ORS.in THEN - ORS.Get(sym); SimpleExpression(y); - IF (x.type.form = ORB.Int) & (y.type.form = ORB.Set) THEN ORG.In(x, y) - ELSE ORS.Mark("illegal operands of IN") - END ; - x.type := ORB.boolType - ELSIF sym = ORS.is THEN - ORS.Get(sym); qualident(obj); TypeTest(x, obj.type, FALSE) ; - x.type := ORB.boolType - END - END expression0; - - (* statements *) - - PROCEDURE StandProc(pno: LONGINT); - VAR nap, npar: LONGINT; (*nof actual/formal parameters*) - x, y, z: ORG.Item; - BEGIN Check(ORS.lparen, "no ("); - npar := pno MOD 10; pno := pno DIV 10; expression(x); nap := 1; - IF sym = ORS.comma THEN - ORS.Get(sym); expression(y); nap := 2; z.type := ORB.noType; - WHILE sym = ORS.comma DO ORS.Get(sym); expression(z); INC(nap) END - ELSE y.type := ORB.noType - END ; - Check(ORS.rparen, "no )"); - IF (npar = nap) OR (pno IN {0, 1}) THEN - IF pno IN {0, 1} THEN (*INC, DEC*) - CheckInt(x); CheckReadOnly(x); - IF y.type # ORB.noType THEN CheckInt(y) END ; - ORG.Increment(pno, x, y) - ELSIF pno IN {2, 3} THEN (*INCL, EXCL*) - CheckSet(x); CheckReadOnly(x); CheckInt(y); ORG.Include(pno-2, x, y) - ELSIF pno = 4 THEN CheckBool(x); ORG.Assert(x) - ELSIF pno = 5 THEN(*NEW*) CheckReadOnly(x); - IF (x.type.form = ORB.Pointer) & (x.type.base.form = ORB.Record) THEN ORG.New(x) - ELSE ORS.Mark("not a pointer to record") - END - ELSIF pno = 6 THEN CheckReal(x); CheckInt(y); CheckReadOnly(x); ORG.Pack(x, y) - ELSIF pno = 7 THEN CheckReal(x); CheckInt(y); CheckReadOnly(x); ORG.Unpk(x, y) - ELSIF pno = 8 THEN - IF x.type.form <= ORB.Set THEN ORG.Led(x) ELSE ORS.Mark("bad type") END - ELSIF pno = 10 THEN CheckInt(x); ORG.Get(x, y) - ELSIF pno = 11 THEN CheckInt(x); ORG.Put(x, y) - ELSIF pno = 12 THEN CheckInt(x); CheckInt(y); CheckInt(z); ORG.Copy(x, y, z) - ELSIF pno = 13 THEN CheckConst(x); CheckInt(x); ORG.LDPSR(x) - ELSIF pno = 14 THEN CheckInt(x); ORG.LDREG(x, y) - END - ELSE ORS.Mark("wrong nof parameters") - END - END StandProc; - - PROCEDURE StatSequence; - VAR obj: ORB.Object; - orgtype: ORB.Type; (*original type of case var*) - x, y, z, w: ORG.Item; - L0, L1, rx: LONGINT; - - PROCEDURE TypeCase(obj: ORB.Object; VAR x: ORG.Item); - VAR typobj: ORB.Object; - BEGIN - IF sym = ORS.ident THEN - qualident(typobj); ORG.MakeItem(x, obj, level); - IF typobj.class # ORB.Typ THEN ORS.Mark("not a type") END ; - TypeTest(x, typobj.type, FALSE); obj.type := typobj.type; - ORG.CFJump(x); Check(ORS.colon, ": expected"); StatSequence - ELSE ORG.CFJump(x); ORS.Mark("type id expected") - END - END TypeCase; - - PROCEDURE SkipCase; - BEGIN - WHILE sym # ORS.colon DO ORS.Get(sym) END ; - ORS.Get(sym); StatSequence - END SkipCase; - - BEGIN (* StatSequence *) - REPEAT (*sync*) obj := NIL; - IF ~((sym = ORS.ident) OR (sym >= ORS.if) & (sym <= ORS.for) OR (sym >= ORS.semicolon)) THEN - ORS.Mark("statement expected"); - REPEAT ORS.Get(sym) UNTIL (sym = ORS.ident) OR (sym >= ORS.if) - END ; - IF sym = ORS.ident THEN - qualident(obj); ORG.MakeItem(x, obj, level); - IF x.mode = ORB.SProc THEN StandProc(obj.val) - ELSE selector(x); - IF sym = ORS.becomes THEN (*assignment*) - ORS.Get(sym); CheckReadOnly(x); expression(y); - IF CompTypes(x.type, y.type, FALSE) OR (x.type.form = ORB.Int) & (y.type.form = ORB.Int) THEN - IF (x.type.form <= ORB.Pointer) OR (x.type.form = ORB.Proc) THEN ORG.Store(x, y) - ELSIF y.type.size # 0 THEN ORG.StoreStruct(x, y) - END - ELSIF (x.type.form = ORB.Char) & (y.type.form = ORB.String) & (y.b = 2) THEN - ORG.StrToChar(y); ORG.Store(x, y) - ELSIF (x.type.form = ORB.Array) & (x.type.base.form = ORB.Char) & - (y.type.form = ORB.String) THEN ORG.CopyString(y, x) - ELSE ORS.Mark("illegal assignment") - END - ELSIF sym = ORS.eql THEN ORS.Mark("should be :="); ORS.Get(sym); expression(y) - ELSIF sym = ORS.lparen THEN (*procedure call*) - ORS.Get(sym); - IF (x.type.form = ORB.Proc) & (x.type.base.form = ORB.NoTyp) THEN - ORG.PrepCall(x, rx); ParamList(x); ORG.Call(x, rx) - ELSE ORS.Mark("not a procedure"); ParamList(x) - END - ELSIF x.type.form = ORB.Proc THEN (*procedure call without parameters*) - IF x.type.nofpar > 0 THEN ORS.Mark("missing parameters") END ; - IF x.type.base.form = ORB.NoTyp THEN ORG.PrepCall(x, rx); ORG.Call(x, rx) ELSE ORS.Mark("not a procedure") END - ELSIF x.mode = ORB.Typ THEN ORS.Mark("illegal assignment") - ELSE ORS.Mark("not a procedure") - END - END - ELSIF sym = ORS.if THEN - ORS.Get(sym); expression(x); CheckBool(x); ORG.CFJump(x); - Check(ORS.then, "no THEN"); - StatSequence; L0 := 0; - WHILE sym = ORS.elsif DO - ORS.Get(sym); ORG.FJump(L0); ORG.Fixup(x); expression(x); CheckBool(x); - ORG.CFJump(x); Check(ORS.then, "no THEN"); StatSequence - END ; - IF sym = ORS.else THEN ORS.Get(sym); ORG.FJump(L0); ORG.Fixup(x); StatSequence - ELSE ORG.Fixup(x) - END ; - ORG.FixLink(L0); Check(ORS.end, "no END") - ELSIF sym = ORS.while THEN - ORS.Get(sym); L0 := ORG.Here(); expression(x); CheckBool(x); ORG.CFJump(x); - Check(ORS.do, "no DO"); StatSequence; ORG.BJump(L0); - WHILE sym = ORS.elsif DO - ORS.Get(sym); ORG.Fixup(x); expression(x); CheckBool(x); ORG.CFJump(x); - Check(ORS.do, "no DO"); StatSequence; ORG.BJump(L0) - END ; - ORG.Fixup(x); Check(ORS.end, "no END") - ELSIF sym = ORS.repeat THEN - ORS.Get(sym); L0 := ORG.Here(); StatSequence; - IF sym = ORS.until THEN - ORS.Get(sym); expression(x); CheckBool(x); ORG.CBJump(x, L0) - ELSE ORS.Mark("missing UNTIL") - END - ELSIF sym = ORS.for THEN - ORS.Get(sym); - IF sym = ORS.ident THEN - qualident(obj); ORG.MakeItem(x, obj, level); CheckInt(x); CheckReadOnly(x); - IF sym = ORS.becomes THEN - ORS.Get(sym); expression(y); CheckInt(y); ORG.For0(x, y); L0 := ORG.Here(); - Check(ORS.to, "no TO"); expression(z); CheckInt(z); obj.rdo := TRUE; - IF sym = ORS.by THEN ORS.Get(sym); expression(w); CheckConst(w); CheckInt(w) - ELSE ORG.MakeConstItem(w, ORB.intType, 1) - END ; - Check(ORS.do, "no DO"); ORG.For1(x, y, z, w, L1); - StatSequence; Check(ORS.end, "no END"); - ORG.For2(x, y, w); ORG.BJump(L0); ORG.FixLink(L1); obj.rdo := FALSE - ELSE ORS.Mark(":= expected") - END - ELSE ORS.Mark("identifier expected") - END - ELSIF sym = ORS.case THEN - ORS.Get(sym); - IF sym = ORS.ident THEN - qualident(obj); orgtype := obj.type; - IF (orgtype.form = ORB.Pointer) OR (orgtype.form = ORB.Record) & (obj.class = ORB.Par) THEN - Check(ORS.of, "OF expected"); TypeCase(obj, x); L0 := 0; - WHILE sym = ORS.bar DO - ORS.Get(sym); ORG.FJump(L0); ORG.Fixup(x); obj.type := orgtype; TypeCase(obj, x) - END ; - ORG.Fixup(x); ORG.FixLink(L0); obj.type := orgtype - ELSE ORS.Mark("numeric case not implemented"); - Check(ORS.of, "OF expected"); SkipCase; - WHILE sym = ORS.bar DO SkipCase END - END - ELSE ORS.Mark("ident expected") - END ; - Check(ORS.end, "no END") - END ; - ORG.CheckRegs; - IF sym = ORS.semicolon THEN ORS.Get(sym) - ELSIF sym < ORS.semicolon THEN ORS.Mark("missing semicolon?") - END - UNTIL sym > ORS.semicolon - END StatSequence; - - (* Types and declarations *) - - PROCEDURE IdentList(class: INTEGER; VAR first: ORB.Object); - VAR obj: ORB.Object; - BEGIN - IF sym = ORS.ident THEN - ORB.NewObj(first, ORS.id, class); ORS.Get(sym); CheckExport(first.expo); - WHILE sym = ORS.comma DO - ORS.Get(sym); - IF sym = ORS.ident THEN ORB.NewObj(obj, ORS.id, class); ORS.Get(sym); CheckExport(obj.expo) - ELSE ORS.Mark("ident?") - END - END; - IF sym = ORS.colon THEN ORS.Get(sym) ELSE ORS.Mark(":?") END - ELSE first := NIL - END - END IdentList; - - PROCEDURE ArrayType(VAR type: ORB.Type); - VAR x: ORG.Item; typ: ORB.Type; len: LONGINT; - BEGIN NEW(typ); typ.form := ORB.NoTyp; - IF sym = ORS.of THEN (*dynamic array*) len := -1 - ELSE expression(x); - IF (x.mode = ORB.Const) & (x.type.form = ORB.Int) & (x.a >= 0) THEN len := x.a - ELSE len := 0; ORS.Mark("not a valid length") - END - END ; - IF sym = ORS.of THEN ORS.Get(sym); Type(typ.base); - IF (typ.base.form = ORB.Array) & (typ.base.len < 0) THEN ORS.Mark("dyn array not allowed") END - ELSIF sym = ORS.comma THEN ORS.Get(sym); ArrayType(typ.base) - ELSE ORS.Mark("missing OF"); typ.base := ORB.intType - END ; - IF len >= 0 THEN typ.size := (len * typ.base.size + 3) DIV 4 * 4 ELSE typ.size := 2*ORG.WordSize (*array desc*) END ; - typ.form := ORB.Array; typ.len := len; type := typ - END ArrayType; - - PROCEDURE RecordType(VAR type: ORB.Type); - VAR obj, obj0, new, bot, base: ORB.Object; - typ, tp: ORB.Type; - offset, off, n: LONGINT; - BEGIN NEW(typ); typ.form := ORB.NoTyp; typ.base := NIL; typ.mno := -level; typ.nofpar := 0; offset := 0; bot := NIL; - IF sym = ORS.lparen THEN - ORS.Get(sym); (*record extension*) - IF level # 0 THEN ORS.Mark("extension of local types not implemented") END ; - IF sym = ORS.ident THEN - qualident(base); - IF base.class = ORB.Typ THEN - IF base.type.form = ORB.Record THEN typ.base := base.type - ELSE typ.base := ORB.intType; ORS.Mark("invalid extension") - END ; - typ.nofpar := typ.base.nofpar + 1; (*"nofpar" here abused for extension level*) - bot := typ.base.dsc; offset := typ.base.size - ELSE ORS.Mark("type expected") - END - ELSE ORS.Mark("ident expected") - END ; - Check(ORS.rparen, "no )") - END ; - WHILE sym = ORS.ident DO (*fields*) - n := 0; obj := bot; - WHILE sym = ORS.ident DO - obj0 := obj; - WHILE (obj0 # NIL) & (obj0.name # ORS.id) DO obj0 := obj0.next END ; - IF obj0 # NIL THEN ORS.Mark("mult def") END ; - NEW(new); ORS.CopyId(new.name); new.class := ORB.Fld; new.next := obj; obj := new; INC(n); - ORS.Get(sym); CheckExport(new.expo); - IF (sym # ORS.comma) & (sym # ORS.colon) THEN ORS.Mark("comma expected") - ELSIF sym = ORS.comma THEN ORS.Get(sym) - END - END ; - Check(ORS.colon, "colon expected"); Type(tp); - IF (tp.form = ORB.Array) & (tp.len < 0) THEN ORS.Mark("dyn array not allowed") END ; - IF tp.size > 1 THEN offset := (offset+3) DIV 4 * 4 END ; - offset := offset + n * tp.size; off := offset; obj0 := obj; - WHILE obj0 # bot DO obj0.type := tp; obj0.lev := 0; off := off - tp.size; obj0.val := off; obj0 := obj0.next END ; - bot := obj; - IF sym = ORS.semicolon THEN ORS.Get(sym) ELSIF sym # ORS.end THEN ORS.Mark(" ; or END") END - END ; - typ.form := ORB.Record; typ.dsc := bot; typ.size := (offset + 3) DIV 4 * 4; type := typ - END RecordType; - - PROCEDURE FPSection(VAR adr: LONGINT; VAR nofpar: INTEGER); - VAR obj, first: ORB.Object; tp: ORB.Type; - parsize: LONGINT; cl: INTEGER; rdo: BOOLEAN; - BEGIN - IF sym = ORS.var THEN ORS.Get(sym); cl := ORB.Par ELSE cl := ORB.Var END ; - IdentList(cl, first); FormalType(tp, 0); rdo := FALSE; - IF (cl = ORB.Var) & (tp.form >= ORB.Array) THEN cl := ORB.Par; rdo := TRUE END ; - IF (tp.form = ORB.Array) & (tp.len < 0) OR (tp.form = ORB.Record) THEN - parsize := 2*ORG.WordSize (*open array or record, needs second word for length or type tag*) - ELSE parsize := ORG.WordSize - END ; - obj := first; - WHILE obj # NIL DO - INC(nofpar); obj.class := cl; obj.type := tp; obj.rdo := rdo; obj.lev := level; obj.val := adr; - adr := adr + parsize; obj := obj.next - END ; - IF adr >= 52 THEN ORS.Mark("too many parameters") END - END FPSection; - - PROCEDURE ProcedureType(ptype: ORB.Type; VAR parblksize: LONGINT); - VAR obj: ORB.Object; size: LONGINT; nofpar: INTEGER; - BEGIN ptype.base := ORB.noType; size := parblksize; nofpar := 0; ptype.dsc := NIL; - IF sym = ORS.lparen THEN - ORS.Get(sym); - IF sym = ORS.rparen THEN ORS.Get(sym) - ELSE FPSection(size, nofpar); - WHILE sym = ORS.semicolon DO ORS.Get(sym); FPSection(size, nofpar) END ; - Check(ORS.rparen, "no )") - END ; - ptype.nofpar := nofpar; parblksize := size; - IF sym = ORS.colon THEN (*function*) - ORS.Get(sym); - IF sym = ORS.ident THEN qualident(obj); - IF (obj.class = ORB.Typ) & (obj.type.form IN {ORB.Byte .. ORB.Pointer, ORB.Proc}) THEN ptype.base := obj.type - ELSE ORS.Mark("illegal function type") - END - ELSE ORS.Mark("type identifier expected") - END - END - END - END ProcedureType; - - PROCEDURE FormalType0(VAR typ: ORB.Type; dim: INTEGER); - VAR obj: ORB.Object; dmy: LONGINT; - BEGIN - IF sym = ORS.ident THEN - qualident(obj); - IF obj.class = ORB.Typ THEN typ := obj.type ELSE ORS.Mark("not a type"); typ := ORB.intType END - ELSIF sym = ORS.array THEN - ORS.Get(sym); Check(ORS.of, "OF ?"); - IF dim >= 1 THEN ORS.Mark("multi-dimensional open arrays not implemented") END ; - NEW(typ); typ.form := ORB.Array; typ.len := -1; typ.size := 2*ORG.WordSize; - FormalType(typ.base, dim+1) - ELSIF sym = ORS.procedure THEN - ORS.Get(sym); ORB.OpenScope; - NEW(typ); typ.form := ORB.Proc; typ.size := ORG.WordSize; dmy := 0; ProcedureType(typ, dmy); - typ.dsc := ORB.topScope.next; ORB.CloseScope - ELSE ORS.Mark("identifier expected"); typ := ORB.noType - END - END FormalType0; - - PROCEDURE CheckRecLevel(lev: INTEGER); - BEGIN - IF lev # 0 THEN ORS.Mark("ptr base must be global") END - END CheckRecLevel; - - PROCEDURE Type0(VAR type: ORB.Type); - VAR dmy: LONGINT; obj: ORB.Object; ptbase: PtrBase; - BEGIN type := ORB.intType; (*sync*) - IF (sym # ORS.ident) & (sym < ORS.array) THEN ORS.Mark("not a type"); - REPEAT ORS.Get(sym) UNTIL (sym = ORS.ident) OR (sym >= ORS.array) - END ; - IF sym = ORS.ident THEN - qualident(obj); - IF obj.class = ORB.Typ THEN - IF (obj.type # NIL) & (obj.type.form # ORB.NoTyp) THEN type := obj.type END - ELSE ORS.Mark("not a type or undefined") - END - ELSIF sym = ORS.array THEN ORS.Get(sym); ArrayType(type) - ELSIF sym = ORS.record THEN - ORS.Get(sym); RecordType(type); Check(ORS.end, "no END") - ELSIF sym = ORS.pointer THEN - ORS.Get(sym); Check(ORS.to, "no TO"); - NEW(type); type.form := ORB.Pointer; type.size := ORG.WordSize; type.base := ORB.intType; - IF sym = ORS.ident THEN - obj := ORB.thisObj(); ORS.Get(sym); - IF obj # NIL THEN - IF (obj.class = ORB.Typ) & (obj.type.form IN {ORB.Record, ORB.NoTyp}) THEN - CheckRecLevel(obj.lev); type.base := obj.type - ELSE ORS.Mark("no valid base type") - END - ELSE CheckRecLevel(level); (*enter into list of forward references to be fixed in Declarations*) - NEW(ptbase); ORS.CopyId(ptbase.name); ptbase.type := type; ptbase.next := pbsList; pbsList := ptbase - END - ELSE Type(type.base); - IF type.base.form # ORB.Record THEN ORS.Mark("must point to record") END ; - CheckRecLevel(level) - END - ELSIF sym = ORS.procedure THEN - ORS.Get(sym); ORB.OpenScope; - NEW(type); type.form := ORB.Proc; type.size := ORG.WordSize; dmy := 0; - ProcedureType(type, dmy); type.dsc := ORB.topScope.next; ORB.CloseScope - ELSE ORS.Mark("illegal type") - END - END Type0; - - PROCEDURE Declarations(VAR varsize: LONGINT); - VAR obj, first: ORB.Object; - x: ORG.Item; tp: ORB.Type; ptbase: PtrBase; - expo: BOOLEAN; id: ORS.Ident; - BEGIN (*sync*) pbsList := NIL; - IF (sym < ORS.const) & (sym # ORS.end) THEN ORS.Mark("declaration?"); - REPEAT ORS.Get(sym) UNTIL (sym >= ORS.const) OR (sym = ORS.end) - END ; - IF sym = ORS.const THEN - ORS.Get(sym); - WHILE sym = ORS.ident DO - ORS.CopyId(id); ORS.Get(sym); CheckExport(expo); - IF sym = ORS.eql THEN ORS.Get(sym) ELSE ORS.Mark("= ?") END; - expression(x); - IF (x.type.form = ORB.String) & (x.b = 2) THEN ORG.StrToChar(x) END ; - ORB.NewObj(obj, id, ORB.Const); obj.expo := expo; - IF x.mode = ORB.Const THEN obj.val := x.a; obj.lev := x.b; obj.type := x.type - ELSE ORS.Mark("expression not constant"); obj.type := ORB.intType - END; - Check(ORS.semicolon, "; missing") - END - END ; - IF sym = ORS.type THEN - ORS.Get(sym); - WHILE sym = ORS.ident DO - ORS.CopyId(id); ORS.Get(sym); CheckExport(expo); - IF sym = ORS.eql THEN ORS.Get(sym) ELSE ORS.Mark("=?") END ; - Type(tp); - ORB.NewObj(obj, id, ORB.Typ); obj.type := tp; obj.expo := expo; obj.lev := level; tp.typobj := obj; - IF expo & (obj.type.form = ORB.Record) THEN obj.exno := exno; INC(exno) ELSE obj.exno := 0 END ; - IF tp.form = ORB.Record THEN - ptbase := pbsList; (*check whether this is base of a pointer type; search and fixup*) - WHILE ptbase # NIL DO - IF obj.name = ptbase.name THEN ptbase.type.base := obj.type END ; - ptbase := ptbase.next - END ; - IF level = 0 THEN ORG.BuildTD(tp, dc) END (*type descriptor; len used as its address*) - END ; - Check(ORS.semicolon, "; missing") - END - END ; - IF sym = ORS.var THEN - ORS.Get(sym); - WHILE sym = ORS.ident DO - IdentList(ORB.Var, first); Type(tp); - obj := first; - WHILE obj # NIL DO - obj.type := tp; obj.lev := level; - IF tp.size > 1 THEN varsize := (varsize + 3) DIV 4 * 4 (*align*) END ; - obj.val := varsize; varsize := varsize + obj.type.size; - IF obj.expo THEN obj.exno := exno; INC(exno) END ; - obj := obj.next - END ; - Check(ORS.semicolon, "; missing") - END - END ; - varsize := (varsize + 3) DIV 4 * 4; - ptbase := pbsList; - WHILE ptbase # NIL DO - IF ptbase.type.base.form = ORB.Int THEN ORS.Mark("undefined pointer base of") END ; - ptbase := ptbase.next - END ; - IF (sym >= ORS.const) & (sym <= ORS.var) THEN ORS.Mark("declaration in bad order") END - END Declarations; - - PROCEDURE ProcedureDecl; - VAR proc: ORB.Object; - type: ORB.Type; - procid: ORS.Ident; - x: ORG.Item; - locblksize, parblksize, L: LONGINT; - int: BOOLEAN; - BEGIN (* ProcedureDecl *) int := FALSE; ORS.Get(sym); - IF sym = ORS.times THEN ORS.Get(sym); int := TRUE END ; - IF sym = ORS.ident THEN - ORS.CopyId(procid); ORS.Get(sym); - ORB.NewObj(proc, ORS.id, ORB.Const); parblksize := 4; - NEW(type); type.form := ORB.Proc; type.size := ORG.WordSize; proc.type := type; - CheckExport(proc.expo); - IF proc.expo THEN proc.exno := exno; INC(exno) END ; - ORB.OpenScope; INC(level); proc.val := -1; type.base := ORB.noType; - ProcedureType(type, parblksize); (*formal parameter list*) - Check(ORS.semicolon, "no ;"); locblksize := parblksize; - Declarations(locblksize); - proc.val := ORG.Here() * 4; proc.type.dsc := ORB.topScope.next; - IF sym = ORS.procedure THEN - L := 0; ORG.FJump(L); - REPEAT ProcedureDecl; Check(ORS.semicolon, "no ;") UNTIL sym # ORS.procedure; - ORG.FixLink(L); proc.val := ORG.Here() * 4; proc.type.dsc := ORB.topScope.next - END ; - ORG.Enter(parblksize, locblksize, int); - IF sym = ORS.begin THEN ORS.Get(sym); StatSequence END ; - IF sym = ORS.return THEN - ORS.Get(sym); expression(x); - IF type.base = ORB.noType THEN ORS.Mark("this is not a function") - ELSIF ~CompTypes(type.base, x.type, FALSE) THEN ORS.Mark("wrong result type") - END - ELSIF type.base.form # ORB.NoTyp THEN - ORS.Mark("function without result"); type.base := ORB.noType - END ; - ORG.Return(type.base.form, x, locblksize, int); - ORB.CloseScope; DEC(level); Check(ORS.end, "no END"); - IF sym = ORS.ident THEN - IF ORS.id # procid THEN ORS.Mark("no match") END ; - ORS.Get(sym) - ELSE ORS.Mark("no proc id") - END - END ; - int := FALSE - END ProcedureDecl; - - PROCEDURE Module; - VAR key: LONGINT; - obj: ORB.Object; - impid, impid1: ORS.Ident; - BEGIN Texts.WriteString(W, " compiling "); ORS.Get(sym); - IF sym = ORS.module THEN - ORS.Get(sym); - IF sym = ORS.times THEN version := 0; Texts.Write(W, "*"); ORS.Get(sym) ELSE version := 1 END ; - ORB.Init; ORB.OpenScope; - IF sym = ORS.ident THEN - ORS.CopyId(modid); ORS.Get(sym); - Texts.WriteString(W, modid); Texts.Append(Oberon.Log, W.buf); - Oberon.DumpLog; (* voc adaptation; -- noch *) - ELSE ORS.Mark("identifier expected") - END ; - Check(ORS.semicolon, "no ;"); level := 0; dc := 0; exno := 1; key := 0; - IF sym = ORS.import THEN - ORS.Get(sym); - WHILE sym = ORS.ident DO - ORS.CopyId(impid); ORS.Get(sym); - IF sym = ORS.becomes THEN - ORS.Get(sym); - IF sym = ORS.ident THEN ORS.CopyId(impid1); ORS.Get(sym) - ELSE ORS.Mark("id expected") - END - ELSE impid1 := impid - END ; - ORB.Import(impid, impid1); - IF sym = ORS.comma THEN ORS.Get(sym) - ELSIF sym = ORS.ident THEN ORS.Mark("comma missing") - END - END ; - Check(ORS.semicolon, "no ;") - END ; - obj := ORB.topScope.next; - ORG.Open(version); Declarations(dc); ORG.SetDataSize((dc + 3) DIV 4 * 4); - WHILE sym = ORS.procedure DO ProcedureDecl; Check(ORS.semicolon, "no ;") END ; - ORG.Header; - IF sym = ORS.begin THEN ORS.Get(sym); StatSequence END ; - Check(ORS.end, "no END"); - IF sym = ORS.ident THEN - IF ORS.id # modid THEN ORS.Mark("no match") END ; - ORS.Get(sym) - ELSE ORS.Mark("identifier missing") - END ; - IF sym # ORS.period THEN ORS.Mark("period missing") END ; - IF (ORS.errcnt = 0) & (version # 0) THEN - ORB.Export(modid, newSF, key); - IF newSF THEN Texts.WriteString(W, " new symbol file") END - END ; - IF ORS.errcnt = 0 THEN - ORG.Close(modid, key, exno); - Texts.WriteInt(W, ORG.pc, 6); Texts.WriteInt(W, dc, 6); Texts.WriteHex(W, key) - ELSE Texts.WriteLn(W); Texts.WriteString(W, "compilation FAILED") - END ; - Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); - Oberon.DumpLog; (* voc adaptation; -- noch *) - ORB.CloseScope; pbsList := NIL - ELSE ORS.Mark("must start with MODULE") - END - END Module; - - PROCEDURE Option(VAR S: Texts.Scanner); - BEGIN newSF := FALSE; - IF S.nextCh = "/" THEN - Texts.Scan(S); Texts.Scan(S); - IF (S.class = Texts.Name) & (S.s[0] = "s") THEN newSF := TRUE END - END - END Option; - - PROCEDURE Compile*; - VAR beg, end, time: LONGINT; - T: Texts.Text; - S: Texts.Scanner; - BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S); - IF S.class = Texts.Char THEN - IF S.c = "@" THEN - Option(S); Oberon.GetSelection(T, beg, end, time); - IF time >= 0 THEN ORS.Init(T, beg); Module END - ELSIF S.c = "^" THEN - Option(S); Oberon.GetSelection(T, beg, end, time); - IF time >= 0 THEN - Texts.OpenScanner(S, T, beg); Texts.Scan(S); - IF S.class = Texts.Name THEN - Texts.WriteString(W, S.s); NEW(T); Texts.Open(T, S.s); - IF T.len > 0 THEN ORS.Init(T, 0); Module END - END - END - END - ELSE - WHILE S.class = Texts.Name DO - NEW(T); Texts.Open(T, S.s); - IF T.len > 0 THEN Option(S); ORS.Init(T, 0); Module - ELSE Texts.WriteString(W, S.s); Texts.WriteString(W, " not found"); - Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); - Oberon.DumpLog; (* voc adaptation; -- noch *) - END ; - IF (T.len # 0) & (ORS.errcnt = 0) THEN Texts.Scan(S) ELSE S.class := 0 END - END - END ; - Oberon.Collect(0) - END Compile; - -BEGIN Texts.OpenWriter(W); Texts.WriteString(W, "OR Compiler 7.6.2014"); - Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); - Oberon.DumpLog; (* voc adaptation; -- noch *) - NEW(dummy); dummy.class := ORB.Var; dummy.type := ORB.intType; - expression := expression0; Type := Type0; FormalType := FormalType0; - - Compile (* voc adaptation; -- noch *) -END ORP. +MODULE ORP; (*N. Wirth 1.7.97 / 7.6.2014 Oberon compiler for RISC in Oberon-07*) + IMPORT Texts := CompatTexts, Oberon, ORS, ORB, ORG; + (*Author: Niklaus Wirth, 2014. + Parser of Oberon-RISC compiler. Uses Scanner ORS to obtain symbols (tokens), + ORB for definition of data structures and for handling import and export, and + ORG to produce binary code. ORP performs type checking and data allocation. + Parser is target-independent, except for part of the handling of allocations.*) + + TYPE INTEGER = LONGINT; (* voc adaptation by noch *) + + TYPE PtrBase = POINTER TO PtrBaseDesc; + PtrBaseDesc = RECORD (*list of names of pointer base types*) + name: ORS.Ident; type: ORB.Type; next: PtrBase + END ; + + VAR sym: INTEGER; (*last symbol read*) + dc: LONGINT; (*data counter*) + level, exno, version: INTEGER; + newSF: BOOLEAN; (*option flag*) + expression: PROCEDURE (VAR x: ORG.Item); (*to avoid forward reference*) + Type: PROCEDURE (VAR type: ORB.Type); + FormalType: PROCEDURE (VAR typ: ORB.Type; dim: INTEGER); + modid: ORS.Ident; + pbsList: PtrBase; (*list of names of pointer base types*) + dummy: ORB.Object; + W: Texts.Writer; + + PROCEDURE Check(s: INTEGER; msg: ARRAY OF CHAR); + BEGIN + IF sym = s THEN ORS.Get(sym) ELSE ORS.Mark(msg) END + END Check; + + PROCEDURE qualident(VAR obj: ORB.Object); + BEGIN obj := ORB.thisObj(); ORS.Get(sym); + IF obj = NIL THEN ORS.Mark("undef"); obj := dummy END ; + IF (sym = ORS.period) & (obj.class = ORB.Mod) THEN + ORS.Get(sym); + IF sym = ORS.ident THEN obj := ORB.thisimport(obj); ORS.Get(sym); + IF obj = NIL THEN ORS.Mark("undef"); obj := dummy END + ELSE ORS.Mark("identifier expected"); obj := dummy + END + END + END qualident; + + PROCEDURE CheckBool(VAR x: ORG.Item); + BEGIN + IF x.type.form # ORB.Bool THEN ORS.Mark("not Boolean"); x.type := ORB.boolType END + END CheckBool; + + PROCEDURE CheckInt(VAR x: ORG.Item); + BEGIN + IF x.type.form # ORB.Int THEN ORS.Mark("not Integer"); x.type := ORB.intType END + END CheckInt; + + PROCEDURE CheckReal(VAR x: ORG.Item); + BEGIN + IF x.type.form # ORB.Real THEN ORS.Mark("not Real"); x.type := ORB.realType END + END CheckReal; + + PROCEDURE CheckSet(VAR x: ORG.Item); + BEGIN + IF x.type.form # ORB.Set THEN ORS.Mark("not Set"); x.type := ORB.setType END + END CheckSet; + + PROCEDURE CheckSetVal(VAR x: ORG.Item); + BEGIN + IF x.type.form # ORB.Int THEN ORS.Mark("not Int"); x.type := ORB.setType + ELSIF x.mode = ORB.Const THEN + IF (x.a < 0) OR (x.a >= 32) THEN ORS.Mark("invalid set") END + END + END CheckSetVal; + + PROCEDURE CheckConst(VAR x: ORG.Item); + BEGIN + IF x.mode # ORB.Const THEN ORS.Mark("not a constant"); x.mode := ORB.Const END + END CheckConst; + + PROCEDURE CheckReadOnly(VAR x: ORG.Item); + BEGIN + IF x.rdo THEN ORS.Mark("read-only") END + END CheckReadOnly; + + PROCEDURE CheckExport(VAR expo: BOOLEAN); + BEGIN + IF sym = ORS.times THEN + expo := TRUE; ORS.Get(sym); + IF level # 0 THEN ORS.Mark("remove asterisk") END + ELSE expo := FALSE + END + END CheckExport; + + PROCEDURE IsExtension(t0, t1: ORB.Type): BOOLEAN; + BEGIN (*t1 is an extension of t0*) + RETURN (t0 = t1) OR (t1 # NIL) & IsExtension(t0, t1.base) + END IsExtension; + + (* expressions *) + + PROCEDURE TypeTest(VAR x: ORG.Item; T: ORB.Type; guard: BOOLEAN); + VAR xt: ORB.Type; + BEGIN xt := x.type; + WHILE (xt # T) & (xt # NIL) DO xt := xt.base END ; + IF xt # T THEN xt := x.type; + IF (xt.form = ORB.Pointer) & (T.form = ORB.Pointer) THEN + IF IsExtension(xt.base, T.base) THEN ORG.TypeTest(x, T.base, FALSE, guard); x.type := T + ELSE ORS.Mark("not an extension") + END + ELSIF (xt.form = ORB.Record) & (T.form = ORB.Record) & (x.mode = ORB.Par) THEN + IF IsExtension(xt, T) THEN ORG.TypeTest(x, T, TRUE, guard); x.type := T + ELSE ORS.Mark("not an extension") + END + ELSE ORS.Mark("incompatible types") + END + ELSIF ~guard THEN ORG.MakeConstItem(x, ORB.boolType, 1) + END ; + IF ~guard THEN x.type := ORB.boolType END + END TypeTest; + + PROCEDURE selector(VAR x: ORG.Item); + VAR y: ORG.Item; obj: ORB.Object; + BEGIN + WHILE (sym = ORS.lbrak) OR (sym = ORS.period) OR (sym = ORS.arrow) + OR (sym = ORS.lparen) & (x.type.form IN {ORB.Record, ORB.Pointer}) DO + IF sym = ORS.lbrak THEN + REPEAT ORS.Get(sym); expression(y); + IF x.type.form = ORB.Array THEN + CheckInt(y); ORG.Index(x, y); x.type := x.type.base + ELSE ORS.Mark("not an array") + END + UNTIL sym # ORS.comma; + Check(ORS.rbrak, "no ]") + ELSIF sym = ORS.period THEN ORS.Get(sym); + IF sym = ORS.ident THEN + IF x.type.form = ORB.Pointer THEN ORG.DeRef(x); x.type := x.type.base END ; + IF x.type.form = ORB.Record THEN + obj := ORB.thisfield(x.type); ORS.Get(sym); + IF obj # NIL THEN ORG.Field(x, obj); x.type := obj.type + ELSE ORS.Mark("undef") + END + ELSE ORS.Mark("not a record") + END + ELSE ORS.Mark("ident?") + END + ELSIF sym = ORS.arrow THEN + ORS.Get(sym); + IF x.type.form = ORB.Pointer THEN ORG.DeRef(x); x.type := x.type.base + ELSE ORS.Mark("not a pointer") + END + ELSIF (sym = ORS.lparen) & (x.type.form IN {ORB.Record, ORB.Pointer}) THEN (*type guard*) + ORS.Get(sym); + IF sym = ORS.ident THEN + qualident(obj); + IF obj.class = ORB.Typ THEN TypeTest(x, obj.type, TRUE) + ELSE ORS.Mark("guard type expected") + END + ELSE ORS.Mark("not an identifier") + END ; + Check(ORS.rparen, " ) missing") + END + END + END selector; + + PROCEDURE CompTypes(t0, t1: ORB.Type; varpar: BOOLEAN): BOOLEAN; + + PROCEDURE EqualSignatures(t0, t1: ORB.Type): BOOLEAN; + VAR p0, p1: ORB.Object; com: BOOLEAN; + BEGIN com := TRUE; + IF (t0.base = t1.base) & (t0.nofpar = t1.nofpar) THEN + p0 := t0.dsc; p1 := t1.dsc; + WHILE p0 # NIL DO + IF (p0.class = p1.class) & CompTypes(p0.type, p1.type, TRUE) & + (*(ORD(p0.rdo) = ORD(p1.rdo))*) + (p0.rdo = p1.rdo) (* voc adaptation by noch *) + THEN + IF p0.type.form >= ORB.Array THEN com := CompTypes(p0.type, p1.type, (p0.class = ORB.Par)) END ; + p0 := p0.next; p1 := p1.next + ELSE p0 := NIL; com := FALSE + END + END + ELSE com := FALSE + END ; + RETURN com + END EqualSignatures; + + BEGIN (*Compatible Types*) + RETURN (t0 = t1) + OR (t0.form = ORB.Array) & (t1.form = ORB.Array) & CompTypes(t0.base, t1.base, varpar) + OR (t0.form = ORB.Pointer) & (t1.form = ORB.Pointer) & IsExtension(t0.base, t1.base) + OR (t0.form = ORB.Record) & (t1.form = ORB.Record) & IsExtension(t0, t1) + OR (t0.form = ORB.Proc) & (t1.form = ORB.Proc) & EqualSignatures(t0, t1) + OR (t0.form IN {ORB.Pointer, ORB.Proc}) & (t1.form = ORB.NilTyp) + OR (t0.form = ORB.NilTyp) & (t1.form IN {ORB.Pointer, ORB.Proc}) + OR ~varpar & (t0.form = ORB.Int) & (t1.form = ORB.Int) + END CompTypes; + + PROCEDURE Parameter(par: ORB.Object); + VAR x: ORG.Item; varpar: BOOLEAN; + BEGIN expression(x); + IF par # NIL THEN + varpar := par.class = ORB.Par; + IF CompTypes(par.type, x.type, varpar) THEN + IF ~varpar THEN ORG.ValueParam(x) + ELSE (*par.class = Par*) + IF ~par.rdo THEN CheckReadOnly(x) END ; + ORG.VarParam(x, par.type) + END + ELSIF ~varpar & (par.type.form = ORB.Int) & (x.type.form = ORB.Int) THEN + ORG.ValueParam(x) + ELSIF (x.type.form = ORB.String) & (x.b = 2) & (par.class = ORB.Var) & (par.type.form = ORB.Char) THEN + ORG.StrToChar(x); ORG.ValueParam(x) + ELSIF (x.type.form = ORB.Array) & (par.type.form = ORB.Array) & + (x.type.base.form = par.type.base.form) & (par.type.len < 0) THEN + ORG.OpenArrayParam(x); + ELSIF (x.type.form = ORB.String) & varpar & par.rdo & (par.type.form = ORB.Array) & + (par.type.base.form = ORB.Char) & (par.type.len < 0) THEN ORG.StringParam(x) + ELSIF (par.type.form = ORB.Array) & (par.type.base.form = ORB.Int) & (par.type.size = x.type.size) THEN + ORG.VarParam(x, par.type) + ELSE ORS.Mark("incompatible parameters") + END + END + END Parameter; + + PROCEDURE ParamList(VAR x: ORG.Item); + VAR n: INTEGER; par: ORB.Object; + BEGIN par := x.type.dsc; n := 0; + IF sym # ORS.rparen THEN + Parameter(par); n := 1; + WHILE sym <= ORS.comma DO + Check(sym, "comma?"); + IF par # NIL THEN par := par.next END ; + INC(n); Parameter(par) + END ; + Check(ORS.rparen, ") missing") + ELSE ORS.Get(sym); + END ; + IF n < x.type.nofpar THEN ORS.Mark("too few params") + ELSIF n > x.type.nofpar THEN ORS.Mark("too many params") + END + END ParamList; + + PROCEDURE StandFunc(VAR x: ORG.Item; fct: LONGINT; restyp: ORB.Type); + VAR y: ORG.Item; n, npar: LONGINT; + BEGIN Check(ORS.lparen, "no ("); + npar := fct MOD 10; fct := fct DIV 10; expression(x); n := 1; + WHILE sym = ORS.comma DO ORS.Get(sym); expression(y); INC(n) END ; + Check(ORS.rparen, "no )"); + IF n = npar THEN + IF fct = 0 THEN (*ABS*) + IF x.type.form IN {ORB.Int, ORB.Real} THEN ORG.Abs(x); restyp := x.type ELSE ORS.Mark("bad type") END + ELSIF fct = 1 THEN (*ODD*) CheckInt(x); ORG.Odd(x) + ELSIF fct = 2 THEN (*FLOOR*) CheckReal(x); ORG.Floor(x) + ELSIF fct = 3 THEN (*FLT*) CheckInt(x); ORG.Float(x) + ELSIF fct = 4 THEN (*ORD*) + IF x.type.form <= ORB.Proc THEN ORG.Ord(x) + ELSIF (x.type.form = ORB.String) & (x.b = 2) THEN ORG.StrToChar(x) + ELSE ORS.Mark("bad type") + END + ELSIF fct = 5 THEN (*CHR*) CheckInt(x); ORG.Ord(x) + ELSIF fct = 6 THEN (*LEN*) + IF x.type.form = ORB.Array THEN ORG.Len(x) ELSE ORS.Mark("not an array") END + ELSIF fct IN {7, 8, 9} THEN (*LSL, ASR, ROR*) CheckInt(y); + IF x.type.form IN {ORB.Int, ORB.Set} THEN ORG.Shift(fct-7, x, y); restyp := x.type ELSE ORS.Mark("bad type") END + ELSIF fct = 11 THEN (*ADC*) ORG.ADC(x, y) + ELSIF fct = 12 THEN (*SBC*) ORG.SBC(x, y) + ELSIF fct = 13 THEN (*UML*) ORG.UML(x, y) + ELSIF fct = 14 THEN (*BIT*) CheckInt(x); CheckInt(y); ORG.Bit(x, y) + ELSIF fct = 15 THEN (*REG*) CheckConst(x); CheckInt(x); ORG.Register(x) + ELSIF fct = 16 THEN (*VAL*) + IF (x.mode= ORB.Typ) & (x.type.size <= y.type.size) THEN restyp := x.type; x := y + ELSE ORS.Mark("casting not allowed") + END + ELSIF fct = 17 THEN (*ADR*) ORG.Adr(x) + ELSIF fct = 18 THEN (*SIZE*) + IF x.mode = ORB.Typ THEN ORG.MakeConstItem(x, ORB.intType, x.type.size) + ELSE ORS.Mark("must be a type") + END + ELSIF fct = 19 THEN (*COND*) CheckConst(x); CheckInt(x); ORG.Condition(x) + ELSIF fct = 20 THEN (*H*) CheckConst(x); CheckInt(x); ORG.H(x) + END ; + x.type := restyp + ELSE ORS.Mark("wrong nof params") + END + END StandFunc; + + PROCEDURE element(VAR x: ORG.Item); + VAR y: ORG.Item; + BEGIN expression(x); CheckSetVal(x); + IF sym = ORS.upto THEN ORS.Get(sym); expression(y); CheckSetVal(y); ORG.Set(x, y) + ELSE ORG.Singleton(x) + END ; + x.type := ORB.setType + END element; + + PROCEDURE set(VAR x: ORG.Item); + VAR y: ORG.Item; + BEGIN + IF sym >= ORS.if THEN + IF sym # ORS.rbrace THEN ORS.Mark(" } missing") END ; + ORG.MakeConstItem(x, ORB.setType, 0) (*empty set*) + ELSE element(x); + WHILE (sym < ORS.rparen) OR (sym > ORS.rbrace) DO + IF sym = ORS.comma THEN ORS.Get(sym) + ELSIF sym # ORS.rbrace THEN ORS.Mark("missing comma") + END ; + element(y); ORG.SetOp(ORS.plus, x, y) + END + END + END set; + + PROCEDURE factor(VAR x: ORG.Item); + VAR obj: ORB.Object; rx: LONGINT; + BEGIN (*sync*) + IF (sym < ORS.char) OR (sym > ORS.ident) THEN ORS.Mark("expression expected"); + REPEAT ORS.Get(sym) UNTIL (sym >= ORS.char) & (sym <= ORS.ident) + END ; + IF sym = ORS.ident THEN + qualident(obj); + IF obj.class = ORB.SFunc THEN StandFunc(x, obj.val, obj.type) + ELSE ORG.MakeItem(x, obj, level); selector(x); + IF sym = ORS.lparen THEN + ORS.Get(sym); + IF (x.type.form = ORB.Proc) & (x.type.base.form # ORB.NoTyp) THEN + ORG.PrepCall(x, rx); ParamList(x); ORG.Call(x, rx); x.type := x.type.base + ELSE ORS.Mark("not a function"); ParamList(x) + END + END + END + ELSIF sym = ORS.int THEN ORG.MakeConstItem(x, ORB.intType, ORS.ival); ORS.Get(sym) + ELSIF sym = ORS.real THEN ORG.MakeRealItem(x, ORS.rval); ORS.Get(sym) + ELSIF sym = ORS.char THEN ORG.MakeConstItem(x, ORB.charType, ORS.ival); ORS.Get(sym) + ELSIF sym = ORS.nil THEN ORS.Get(sym); ORG.MakeConstItem(x, ORB.nilType, 0) + ELSIF sym = ORS.string THEN ORG.MakeStringItem(x, ORS.slen); ORS.Get(sym) + ELSIF sym = ORS.lparen THEN ORS.Get(sym); expression(x); Check(ORS.rparen, "no )") + ELSIF sym = ORS.lbrace THEN ORS.Get(sym); set(x); Check(ORS.rbrace, "no }") + ELSIF sym = ORS.not THEN ORS.Get(sym); factor(x); CheckBool(x); ORG.Not(x) + ELSIF sym = ORS.false THEN ORS.Get(sym); ORG.MakeConstItem(x, ORB.boolType, 0) + ELSIF sym = ORS.true THEN ORS.Get(sym); ORG.MakeConstItem(x, ORB.boolType, 1) + ELSE ORS.Mark("not a factor"); ORG.MakeItem(x, NIL, level) + END + END factor; + + PROCEDURE term(VAR x: ORG.Item); + VAR y: ORG.Item; op, f: INTEGER; + BEGIN factor(x); f := x.type.form; + WHILE (sym >= ORS.times) & (sym <= ORS.and) DO + op := sym; ORS.Get(sym); + IF op = ORS.times THEN + IF f = ORB.Int THEN factor(y); CheckInt(y); ORG.MulOp(x, y) + ELSIF f = ORB.Real THEN factor(y); CheckReal(y); ORG.RealOp(op, x, y) + ELSIF f = ORB.Set THEN factor(y); CheckSet(y); ORG.SetOp(op, x, y) + ELSE ORS.Mark("bad type") + END + ELSIF (op = ORS.div) OR (op = ORS.mod) THEN + CheckInt(x); factor(y); CheckInt(y); ORG.DivOp(op, x, y) + ELSIF op = ORS.rdiv THEN + IF f = ORB.Real THEN factor(y); CheckReal(y); ORG.RealOp(op, x, y) + ELSIF f = ORB.Set THEN factor(y); CheckSet(y); ORG.SetOp(op, x, y) + ELSE ORS.Mark("bad type") + END + ELSE (*op = and*) CheckBool(x); ORG.And1(x); factor(y); CheckBool(y); ORG.And2(x, y) + END + END + END term; + + PROCEDURE SimpleExpression(VAR x: ORG.Item); + VAR y: ORG.Item; op: INTEGER; + BEGIN + IF sym = ORS.minus THEN ORS.Get(sym); term(x); + IF x.type.form IN {ORB.Int, ORB.Real, ORB.Set} THEN ORG.Neg(x) ELSE CheckInt(x) END + ELSIF sym = ORS.plus THEN ORS.Get(sym); term(x); + ELSE term(x) + END ; + WHILE (sym >= ORS.plus) & (sym <= ORS.or) DO + op := sym; ORS.Get(sym); + IF op = ORS.or THEN ORG.Or1(x); CheckBool(x); term(y); CheckBool(y); ORG.Or2(x, y) + ELSIF x.type.form = ORB.Int THEN term(y); CheckInt(y); ORG.AddOp(op, x, y) + ELSIF x.type.form = ORB.Real THEN term(y); CheckReal(y); ORG.RealOp(op, x, y) + ELSE CheckSet(x); term(y); CheckSet(y); ORG.SetOp(op, x, y) + END + END + END SimpleExpression; + + PROCEDURE expression0(VAR x: ORG.Item); + VAR y: ORG.Item; obj: ORB.Object; rel, xf, yf: INTEGER; + BEGIN SimpleExpression(x); + IF (sym >= ORS.eql) & (sym <= ORS.geq) THEN + rel := sym; ORS.Get(sym); SimpleExpression(y); xf := x.type.form; yf := y.type.form; + IF CompTypes(x.type, y.type, FALSE) OR + (xf = ORB.Pointer) & (yf = ORB.Pointer) & IsExtension(y.type.base, x.type.base) THEN + IF (xf IN {ORB.Char, ORB.Int}) THEN ORG.IntRelation(rel, x, y) + ELSIF xf = ORB.Real THEN ORG.RealRelation(rel, x, y) + ELSIF xf = ORB.Set THEN ORG.SetRelation(rel, x, y) + ELSIF (xf IN {ORB.Pointer, ORB.Proc, ORB.NilTyp}) THEN + IF rel <= ORS.neq THEN ORG.IntRelation(rel, x, y) ELSE ORS.Mark("only = or #") END + ELSIF (xf = ORB.Array) & (x.type.base.form = ORB.Char) OR (xf = ORB.String) THEN + ORG.StringRelation(rel, x, y) + ELSE ORS.Mark("illegal comparison") + END + ELSIF (xf = ORB.Array) & (x.type.base.form = ORB.Char) & + ((yf = ORB.String) OR (yf = ORB.Array) & (y.type.base.form = ORB.Char)) + OR (yf = ORB.Array) & (y.type.base.form = ORB.Char) & (xf = ORB.String) THEN + ORG.StringRelation(rel, x, y) + ELSIF (xf = ORB.Char) & (yf = ORB.String) & (y.b = 2) THEN + ORG.StrToChar(y); ORG.IntRelation(rel, x, y) + ELSIF (yf = ORB.Char) & (xf = ORB.String) & (x.b = 2) THEN + ORG.StrToChar(x); ORG.IntRelation(rel, x, y) + ELSE ORS.Mark("illegal comparison") + END ; + x.type := ORB.boolType + ELSIF sym = ORS.in THEN + ORS.Get(sym); SimpleExpression(y); + IF (x.type.form = ORB.Int) & (y.type.form = ORB.Set) THEN ORG.In(x, y) + ELSE ORS.Mark("illegal operands of IN") + END ; + x.type := ORB.boolType + ELSIF sym = ORS.is THEN + ORS.Get(sym); qualident(obj); TypeTest(x, obj.type, FALSE) ; + x.type := ORB.boolType + END + END expression0; + + (* statements *) + + PROCEDURE StandProc(pno: LONGINT); + VAR nap, npar: LONGINT; (*nof actual/formal parameters*) + x, y, z: ORG.Item; + BEGIN Check(ORS.lparen, "no ("); + npar := pno MOD 10; pno := pno DIV 10; expression(x); nap := 1; + IF sym = ORS.comma THEN + ORS.Get(sym); expression(y); nap := 2; z.type := ORB.noType; + WHILE sym = ORS.comma DO ORS.Get(sym); expression(z); INC(nap) END + ELSE y.type := ORB.noType + END ; + Check(ORS.rparen, "no )"); + IF (npar = nap) OR (pno IN {0, 1}) THEN + IF pno IN {0, 1} THEN (*INC, DEC*) + CheckInt(x); CheckReadOnly(x); + IF y.type # ORB.noType THEN CheckInt(y) END ; + ORG.Increment(pno, x, y) + ELSIF pno IN {2, 3} THEN (*INCL, EXCL*) + CheckSet(x); CheckReadOnly(x); CheckInt(y); ORG.Include(pno-2, x, y) + ELSIF pno = 4 THEN CheckBool(x); ORG.Assert(x) + ELSIF pno = 5 THEN(*NEW*) CheckReadOnly(x); + IF (x.type.form = ORB.Pointer) & (x.type.base.form = ORB.Record) THEN ORG.New(x) + ELSE ORS.Mark("not a pointer to record") + END + ELSIF pno = 6 THEN CheckReal(x); CheckInt(y); CheckReadOnly(x); ORG.Pack(x, y) + ELSIF pno = 7 THEN CheckReal(x); CheckInt(y); CheckReadOnly(x); ORG.Unpk(x, y) + ELSIF pno = 8 THEN + IF x.type.form <= ORB.Set THEN ORG.Led(x) ELSE ORS.Mark("bad type") END + ELSIF pno = 10 THEN CheckInt(x); ORG.Get(x, y) + ELSIF pno = 11 THEN CheckInt(x); ORG.Put(x, y) + ELSIF pno = 12 THEN CheckInt(x); CheckInt(y); CheckInt(z); ORG.Copy(x, y, z) + ELSIF pno = 13 THEN CheckConst(x); CheckInt(x); ORG.LDPSR(x) + ELSIF pno = 14 THEN CheckInt(x); ORG.LDREG(x, y) + END + ELSE ORS.Mark("wrong nof parameters") + END + END StandProc; + + PROCEDURE StatSequence; + VAR obj: ORB.Object; + orgtype: ORB.Type; (*original type of case var*) + x, y, z, w: ORG.Item; + L0, L1, rx: LONGINT; + + PROCEDURE TypeCase(obj: ORB.Object; VAR x: ORG.Item); + VAR typobj: ORB.Object; + BEGIN + IF sym = ORS.ident THEN + qualident(typobj); ORG.MakeItem(x, obj, level); + IF typobj.class # ORB.Typ THEN ORS.Mark("not a type") END ; + TypeTest(x, typobj.type, FALSE); obj.type := typobj.type; + ORG.CFJump(x); Check(ORS.colon, ": expected"); StatSequence + ELSE ORG.CFJump(x); ORS.Mark("type id expected") + END + END TypeCase; + + PROCEDURE SkipCase; + BEGIN + WHILE sym # ORS.colon DO ORS.Get(sym) END ; + ORS.Get(sym); StatSequence + END SkipCase; + + BEGIN (* StatSequence *) + REPEAT (*sync*) obj := NIL; + IF ~((sym = ORS.ident) OR (sym >= ORS.if) & (sym <= ORS.for) OR (sym >= ORS.semicolon)) THEN + ORS.Mark("statement expected"); + REPEAT ORS.Get(sym) UNTIL (sym = ORS.ident) OR (sym >= ORS.if) + END ; + IF sym = ORS.ident THEN + qualident(obj); ORG.MakeItem(x, obj, level); + IF x.mode = ORB.SProc THEN StandProc(obj.val) + ELSE selector(x); + IF sym = ORS.becomes THEN (*assignment*) + ORS.Get(sym); CheckReadOnly(x); expression(y); + IF CompTypes(x.type, y.type, FALSE) OR (x.type.form = ORB.Int) & (y.type.form = ORB.Int) THEN + IF (x.type.form <= ORB.Pointer) OR (x.type.form = ORB.Proc) THEN ORG.Store(x, y) + ELSIF y.type.size # 0 THEN ORG.StoreStruct(x, y) + END + ELSIF (x.type.form = ORB.Char) & (y.type.form = ORB.String) & (y.b = 2) THEN + ORG.StrToChar(y); ORG.Store(x, y) + ELSIF (x.type.form = ORB.Array) & (x.type.base.form = ORB.Char) & + (y.type.form = ORB.String) THEN ORG.CopyString(y, x) + ELSE ORS.Mark("illegal assignment") + END + ELSIF sym = ORS.eql THEN ORS.Mark("should be :="); ORS.Get(sym); expression(y) + ELSIF sym = ORS.lparen THEN (*procedure call*) + ORS.Get(sym); + IF (x.type.form = ORB.Proc) & (x.type.base.form = ORB.NoTyp) THEN + ORG.PrepCall(x, rx); ParamList(x); ORG.Call(x, rx) + ELSE ORS.Mark("not a procedure"); ParamList(x) + END + ELSIF x.type.form = ORB.Proc THEN (*procedure call without parameters*) + IF x.type.nofpar > 0 THEN ORS.Mark("missing parameters") END ; + IF x.type.base.form = ORB.NoTyp THEN ORG.PrepCall(x, rx); ORG.Call(x, rx) ELSE ORS.Mark("not a procedure") END + ELSIF x.mode = ORB.Typ THEN ORS.Mark("illegal assignment") + ELSE ORS.Mark("not a procedure") + END + END + ELSIF sym = ORS.if THEN + ORS.Get(sym); expression(x); CheckBool(x); ORG.CFJump(x); + Check(ORS.then, "no THEN"); + StatSequence; L0 := 0; + WHILE sym = ORS.elsif DO + ORS.Get(sym); ORG.FJump(L0); ORG.Fixup(x); expression(x); CheckBool(x); + ORG.CFJump(x); Check(ORS.then, "no THEN"); StatSequence + END ; + IF sym = ORS.else THEN ORS.Get(sym); ORG.FJump(L0); ORG.Fixup(x); StatSequence + ELSE ORG.Fixup(x) + END ; + ORG.FixLink(L0); Check(ORS.end, "no END") + ELSIF sym = ORS.while THEN + ORS.Get(sym); L0 := ORG.Here(); expression(x); CheckBool(x); ORG.CFJump(x); + Check(ORS.do, "no DO"); StatSequence; ORG.BJump(L0); + WHILE sym = ORS.elsif DO + ORS.Get(sym); ORG.Fixup(x); expression(x); CheckBool(x); ORG.CFJump(x); + Check(ORS.do, "no DO"); StatSequence; ORG.BJump(L0) + END ; + ORG.Fixup(x); Check(ORS.end, "no END") + ELSIF sym = ORS.repeat THEN + ORS.Get(sym); L0 := ORG.Here(); StatSequence; + IF sym = ORS.until THEN + ORS.Get(sym); expression(x); CheckBool(x); ORG.CBJump(x, L0) + ELSE ORS.Mark("missing UNTIL") + END + ELSIF sym = ORS.for THEN + ORS.Get(sym); + IF sym = ORS.ident THEN + qualident(obj); ORG.MakeItem(x, obj, level); CheckInt(x); CheckReadOnly(x); + IF sym = ORS.becomes THEN + ORS.Get(sym); expression(y); CheckInt(y); ORG.For0(x, y); L0 := ORG.Here(); + Check(ORS.to, "no TO"); expression(z); CheckInt(z); obj.rdo := TRUE; + IF sym = ORS.by THEN ORS.Get(sym); expression(w); CheckConst(w); CheckInt(w) + ELSE ORG.MakeConstItem(w, ORB.intType, 1) + END ; + Check(ORS.do, "no DO"); ORG.For1(x, y, z, w, L1); + StatSequence; Check(ORS.end, "no END"); + ORG.For2(x, y, w); ORG.BJump(L0); ORG.FixLink(L1); obj.rdo := FALSE + ELSE ORS.Mark(":= expected") + END + ELSE ORS.Mark("identifier expected") + END + ELSIF sym = ORS.case THEN + ORS.Get(sym); + IF sym = ORS.ident THEN + qualident(obj); orgtype := obj.type; + IF (orgtype.form = ORB.Pointer) OR (orgtype.form = ORB.Record) & (obj.class = ORB.Par) THEN + Check(ORS.of, "OF expected"); TypeCase(obj, x); L0 := 0; + WHILE sym = ORS.bar DO + ORS.Get(sym); ORG.FJump(L0); ORG.Fixup(x); obj.type := orgtype; TypeCase(obj, x) + END ; + ORG.Fixup(x); ORG.FixLink(L0); obj.type := orgtype + ELSE ORS.Mark("numeric case not implemented"); + Check(ORS.of, "OF expected"); SkipCase; + WHILE sym = ORS.bar DO SkipCase END + END + ELSE ORS.Mark("ident expected") + END ; + Check(ORS.end, "no END") + END ; + ORG.CheckRegs; + IF sym = ORS.semicolon THEN ORS.Get(sym) + ELSIF sym < ORS.semicolon THEN ORS.Mark("missing semicolon?") + END + UNTIL sym > ORS.semicolon + END StatSequence; + + (* Types and declarations *) + + PROCEDURE IdentList(class: INTEGER; VAR first: ORB.Object); + VAR obj: ORB.Object; + BEGIN + IF sym = ORS.ident THEN + ORB.NewObj(first, ORS.id, class); ORS.Get(sym); CheckExport(first.expo); + WHILE sym = ORS.comma DO + ORS.Get(sym); + IF sym = ORS.ident THEN ORB.NewObj(obj, ORS.id, class); ORS.Get(sym); CheckExport(obj.expo) + ELSE ORS.Mark("ident?") + END + END; + IF sym = ORS.colon THEN ORS.Get(sym) ELSE ORS.Mark(":?") END + ELSE first := NIL + END + END IdentList; + + PROCEDURE ArrayType(VAR type: ORB.Type); + VAR x: ORG.Item; typ: ORB.Type; len: LONGINT; + BEGIN NEW(typ); typ.form := ORB.NoTyp; + IF sym = ORS.of THEN (*dynamic array*) len := -1 + ELSE expression(x); + IF (x.mode = ORB.Const) & (x.type.form = ORB.Int) & (x.a >= 0) THEN len := x.a + ELSE len := 0; ORS.Mark("not a valid length") + END + END ; + IF sym = ORS.of THEN ORS.Get(sym); Type(typ.base); + IF (typ.base.form = ORB.Array) & (typ.base.len < 0) THEN ORS.Mark("dyn array not allowed") END + ELSIF sym = ORS.comma THEN ORS.Get(sym); ArrayType(typ.base) + ELSE ORS.Mark("missing OF"); typ.base := ORB.intType + END ; + IF len >= 0 THEN typ.size := (len * typ.base.size + 3) DIV 4 * 4 ELSE typ.size := 2*ORG.WordSize (*array desc*) END ; + typ.form := ORB.Array; typ.len := len; type := typ + END ArrayType; + + PROCEDURE RecordType(VAR type: ORB.Type); + VAR obj, obj0, new, bot, base: ORB.Object; + typ, tp: ORB.Type; + offset, off, n: LONGINT; + BEGIN NEW(typ); typ.form := ORB.NoTyp; typ.base := NIL; typ.mno := -level; typ.nofpar := 0; offset := 0; bot := NIL; + IF sym = ORS.lparen THEN + ORS.Get(sym); (*record extension*) + IF level # 0 THEN ORS.Mark("extension of local types not implemented") END ; + IF sym = ORS.ident THEN + qualident(base); + IF base.class = ORB.Typ THEN + IF base.type.form = ORB.Record THEN typ.base := base.type + ELSE typ.base := ORB.intType; ORS.Mark("invalid extension") + END ; + typ.nofpar := typ.base.nofpar + 1; (*"nofpar" here abused for extension level*) + bot := typ.base.dsc; offset := typ.base.size + ELSE ORS.Mark("type expected") + END + ELSE ORS.Mark("ident expected") + END ; + Check(ORS.rparen, "no )") + END ; + WHILE sym = ORS.ident DO (*fields*) + n := 0; obj := bot; + WHILE sym = ORS.ident DO + obj0 := obj; + WHILE (obj0 # NIL) & (obj0.name # ORS.id) DO obj0 := obj0.next END ; + IF obj0 # NIL THEN ORS.Mark("mult def") END ; + NEW(new); ORS.CopyId(new.name); new.class := ORB.Fld; new.next := obj; obj := new; INC(n); + ORS.Get(sym); CheckExport(new.expo); + IF (sym # ORS.comma) & (sym # ORS.colon) THEN ORS.Mark("comma expected") + ELSIF sym = ORS.comma THEN ORS.Get(sym) + END + END ; + Check(ORS.colon, "colon expected"); Type(tp); + IF (tp.form = ORB.Array) & (tp.len < 0) THEN ORS.Mark("dyn array not allowed") END ; + IF tp.size > 1 THEN offset := (offset+3) DIV 4 * 4 END ; + offset := offset + n * tp.size; off := offset; obj0 := obj; + WHILE obj0 # bot DO obj0.type := tp; obj0.lev := 0; off := off - tp.size; obj0.val := off; obj0 := obj0.next END ; + bot := obj; + IF sym = ORS.semicolon THEN ORS.Get(sym) ELSIF sym # ORS.end THEN ORS.Mark(" ; or END") END + END ; + typ.form := ORB.Record; typ.dsc := bot; typ.size := (offset + 3) DIV 4 * 4; type := typ + END RecordType; + + PROCEDURE FPSection(VAR adr: LONGINT; VAR nofpar: INTEGER); + VAR obj, first: ORB.Object; tp: ORB.Type; + parsize: LONGINT; cl: INTEGER; rdo: BOOLEAN; + BEGIN + IF sym = ORS.var THEN ORS.Get(sym); cl := ORB.Par ELSE cl := ORB.Var END ; + IdentList(cl, first); FormalType(tp, 0); rdo := FALSE; + IF (cl = ORB.Var) & (tp.form >= ORB.Array) THEN cl := ORB.Par; rdo := TRUE END ; + IF (tp.form = ORB.Array) & (tp.len < 0) OR (tp.form = ORB.Record) THEN + parsize := 2*ORG.WordSize (*open array or record, needs second word for length or type tag*) + ELSE parsize := ORG.WordSize + END ; + obj := first; + WHILE obj # NIL DO + INC(nofpar); obj.class := cl; obj.type := tp; obj.rdo := rdo; obj.lev := level; obj.val := adr; + adr := adr + parsize; obj := obj.next + END ; + IF adr >= 52 THEN ORS.Mark("too many parameters") END + END FPSection; + + PROCEDURE ProcedureType(ptype: ORB.Type; VAR parblksize: LONGINT); + VAR obj: ORB.Object; size: LONGINT; nofpar: INTEGER; + BEGIN ptype.base := ORB.noType; size := parblksize; nofpar := 0; ptype.dsc := NIL; + IF sym = ORS.lparen THEN + ORS.Get(sym); + IF sym = ORS.rparen THEN ORS.Get(sym) + ELSE FPSection(size, nofpar); + WHILE sym = ORS.semicolon DO ORS.Get(sym); FPSection(size, nofpar) END ; + Check(ORS.rparen, "no )") + END ; + ptype.nofpar := nofpar; parblksize := size; + IF sym = ORS.colon THEN (*function*) + ORS.Get(sym); + IF sym = ORS.ident THEN qualident(obj); + IF (obj.class = ORB.Typ) & (obj.type.form IN {ORB.Byte .. ORB.Pointer, ORB.Proc}) THEN ptype.base := obj.type + ELSE ORS.Mark("illegal function type") + END + ELSE ORS.Mark("type identifier expected") + END + END + END + END ProcedureType; + + PROCEDURE FormalType0(VAR typ: ORB.Type; dim: INTEGER); + VAR obj: ORB.Object; dmy: LONGINT; + BEGIN + IF sym = ORS.ident THEN + qualident(obj); + IF obj.class = ORB.Typ THEN typ := obj.type ELSE ORS.Mark("not a type"); typ := ORB.intType END + ELSIF sym = ORS.array THEN + ORS.Get(sym); Check(ORS.of, "OF ?"); + IF dim >= 1 THEN ORS.Mark("multi-dimensional open arrays not implemented") END ; + NEW(typ); typ.form := ORB.Array; typ.len := -1; typ.size := 2*ORG.WordSize; + FormalType(typ.base, dim+1) + ELSIF sym = ORS.procedure THEN + ORS.Get(sym); ORB.OpenScope; + NEW(typ); typ.form := ORB.Proc; typ.size := ORG.WordSize; dmy := 0; ProcedureType(typ, dmy); + typ.dsc := ORB.topScope.next; ORB.CloseScope + ELSE ORS.Mark("identifier expected"); typ := ORB.noType + END + END FormalType0; + + PROCEDURE CheckRecLevel(lev: INTEGER); + BEGIN + IF lev # 0 THEN ORS.Mark("ptr base must be global") END + END CheckRecLevel; + + PROCEDURE Type0(VAR type: ORB.Type); + VAR dmy: LONGINT; obj: ORB.Object; ptbase: PtrBase; + BEGIN type := ORB.intType; (*sync*) + IF (sym # ORS.ident) & (sym < ORS.array) THEN ORS.Mark("not a type"); + REPEAT ORS.Get(sym) UNTIL (sym = ORS.ident) OR (sym >= ORS.array) + END ; + IF sym = ORS.ident THEN + qualident(obj); + IF obj.class = ORB.Typ THEN + IF (obj.type # NIL) & (obj.type.form # ORB.NoTyp) THEN type := obj.type END + ELSE ORS.Mark("not a type or undefined") + END + ELSIF sym = ORS.array THEN ORS.Get(sym); ArrayType(type) + ELSIF sym = ORS.record THEN + ORS.Get(sym); RecordType(type); Check(ORS.end, "no END") + ELSIF sym = ORS.pointer THEN + ORS.Get(sym); Check(ORS.to, "no TO"); + NEW(type); type.form := ORB.Pointer; type.size := ORG.WordSize; type.base := ORB.intType; + IF sym = ORS.ident THEN + obj := ORB.thisObj(); ORS.Get(sym); + IF obj # NIL THEN + IF (obj.class = ORB.Typ) & (obj.type.form IN {ORB.Record, ORB.NoTyp}) THEN + CheckRecLevel(obj.lev); type.base := obj.type + ELSE ORS.Mark("no valid base type") + END + ELSE CheckRecLevel(level); (*enter into list of forward references to be fixed in Declarations*) + NEW(ptbase); ORS.CopyId(ptbase.name); ptbase.type := type; ptbase.next := pbsList; pbsList := ptbase + END + ELSE Type(type.base); + IF type.base.form # ORB.Record THEN ORS.Mark("must point to record") END ; + CheckRecLevel(level) + END + ELSIF sym = ORS.procedure THEN + ORS.Get(sym); ORB.OpenScope; + NEW(type); type.form := ORB.Proc; type.size := ORG.WordSize; dmy := 0; + ProcedureType(type, dmy); type.dsc := ORB.topScope.next; ORB.CloseScope + ELSE ORS.Mark("illegal type") + END + END Type0; + + PROCEDURE Declarations(VAR varsize: LONGINT); + VAR obj, first: ORB.Object; + x: ORG.Item; tp: ORB.Type; ptbase: PtrBase; + expo: BOOLEAN; id: ORS.Ident; + BEGIN (*sync*) pbsList := NIL; + IF (sym < ORS.const) & (sym # ORS.end) THEN ORS.Mark("declaration?"); + REPEAT ORS.Get(sym) UNTIL (sym >= ORS.const) OR (sym = ORS.end) + END ; + IF sym = ORS.const THEN + ORS.Get(sym); + WHILE sym = ORS.ident DO + ORS.CopyId(id); ORS.Get(sym); CheckExport(expo); + IF sym = ORS.eql THEN ORS.Get(sym) ELSE ORS.Mark("= ?") END; + expression(x); + IF (x.type.form = ORB.String) & (x.b = 2) THEN ORG.StrToChar(x) END ; + ORB.NewObj(obj, id, ORB.Const); obj.expo := expo; + IF x.mode = ORB.Const THEN obj.val := x.a; obj.lev := x.b; obj.type := x.type + ELSE ORS.Mark("expression not constant"); obj.type := ORB.intType + END; + Check(ORS.semicolon, "; missing") + END + END ; + IF sym = ORS.type THEN + ORS.Get(sym); + WHILE sym = ORS.ident DO + ORS.CopyId(id); ORS.Get(sym); CheckExport(expo); + IF sym = ORS.eql THEN ORS.Get(sym) ELSE ORS.Mark("=?") END ; + Type(tp); + ORB.NewObj(obj, id, ORB.Typ); obj.type := tp; obj.expo := expo; obj.lev := level; tp.typobj := obj; + IF expo & (obj.type.form = ORB.Record) THEN obj.exno := exno; INC(exno) ELSE obj.exno := 0 END ; + IF tp.form = ORB.Record THEN + ptbase := pbsList; (*check whether this is base of a pointer type; search and fixup*) + WHILE ptbase # NIL DO + IF obj.name = ptbase.name THEN ptbase.type.base := obj.type END ; + ptbase := ptbase.next + END ; + IF level = 0 THEN ORG.BuildTD(tp, dc) END (*type descriptor; len used as its address*) + END ; + Check(ORS.semicolon, "; missing") + END + END ; + IF sym = ORS.var THEN + ORS.Get(sym); + WHILE sym = ORS.ident DO + IdentList(ORB.Var, first); Type(tp); + obj := first; + WHILE obj # NIL DO + obj.type := tp; obj.lev := level; + IF tp.size > 1 THEN varsize := (varsize + 3) DIV 4 * 4 (*align*) END ; + obj.val := varsize; varsize := varsize + obj.type.size; + IF obj.expo THEN obj.exno := exno; INC(exno) END ; + obj := obj.next + END ; + Check(ORS.semicolon, "; missing") + END + END ; + varsize := (varsize + 3) DIV 4 * 4; + ptbase := pbsList; + WHILE ptbase # NIL DO + IF ptbase.type.base.form = ORB.Int THEN ORS.Mark("undefined pointer base of") END ; + ptbase := ptbase.next + END ; + IF (sym >= ORS.const) & (sym <= ORS.var) THEN ORS.Mark("declaration in bad order") END + END Declarations; + + PROCEDURE ProcedureDecl; + VAR proc: ORB.Object; + type: ORB.Type; + procid: ORS.Ident; + x: ORG.Item; + locblksize, parblksize, L: LONGINT; + int: BOOLEAN; + BEGIN (* ProcedureDecl *) int := FALSE; ORS.Get(sym); + IF sym = ORS.times THEN ORS.Get(sym); int := TRUE END ; + IF sym = ORS.ident THEN + ORS.CopyId(procid); ORS.Get(sym); + ORB.NewObj(proc, ORS.id, ORB.Const); parblksize := 4; + NEW(type); type.form := ORB.Proc; type.size := ORG.WordSize; proc.type := type; + CheckExport(proc.expo); + IF proc.expo THEN proc.exno := exno; INC(exno) END ; + ORB.OpenScope; INC(level); proc.val := -1; type.base := ORB.noType; + ProcedureType(type, parblksize); (*formal parameter list*) + Check(ORS.semicolon, "no ;"); locblksize := parblksize; + Declarations(locblksize); + proc.val := ORG.Here() * 4; proc.type.dsc := ORB.topScope.next; + IF sym = ORS.procedure THEN + L := 0; ORG.FJump(L); + REPEAT ProcedureDecl; Check(ORS.semicolon, "no ;") UNTIL sym # ORS.procedure; + ORG.FixLink(L); proc.val := ORG.Here() * 4; proc.type.dsc := ORB.topScope.next + END ; + ORG.Enter(parblksize, locblksize, int); + IF sym = ORS.begin THEN ORS.Get(sym); StatSequence END ; + IF sym = ORS.return THEN + ORS.Get(sym); expression(x); + IF type.base = ORB.noType THEN ORS.Mark("this is not a function") + ELSIF ~CompTypes(type.base, x.type, FALSE) THEN ORS.Mark("wrong result type") + END + ELSIF type.base.form # ORB.NoTyp THEN + ORS.Mark("function without result"); type.base := ORB.noType + END ; + ORG.Return(type.base.form, x, locblksize, int); + ORB.CloseScope; DEC(level); Check(ORS.end, "no END"); + IF sym = ORS.ident THEN + IF ORS.id # procid THEN ORS.Mark("no match") END ; + ORS.Get(sym) + ELSE ORS.Mark("no proc id") + END + END ; + int := FALSE + END ProcedureDecl; + + PROCEDURE Module; + VAR key: LONGINT; + obj: ORB.Object; + impid, impid1: ORS.Ident; + BEGIN Texts.WriteString(W, " compiling "); ORS.Get(sym); + IF sym = ORS.module THEN + ORS.Get(sym); + IF sym = ORS.times THEN version := 0; Texts.Write(W, "*"); ORS.Get(sym) ELSE version := 1 END ; + ORB.Init; ORB.OpenScope; + IF sym = ORS.ident THEN + ORS.CopyId(modid); ORS.Get(sym); + Texts.WriteString(W, modid); Texts.Append(Oberon.Log, W.buf); + Oberon.DumpLog; (* voc adaptation; -- noch *) + ELSE ORS.Mark("identifier expected") + END ; + Check(ORS.semicolon, "no ;"); level := 0; dc := 0; exno := 1; key := 0; + IF sym = ORS.import THEN + ORS.Get(sym); + WHILE sym = ORS.ident DO + ORS.CopyId(impid); ORS.Get(sym); + IF sym = ORS.becomes THEN + ORS.Get(sym); + IF sym = ORS.ident THEN ORS.CopyId(impid1); ORS.Get(sym) + ELSE ORS.Mark("id expected") + END + ELSE impid1 := impid + END ; + ORB.Import(impid, impid1); + IF sym = ORS.comma THEN ORS.Get(sym) + ELSIF sym = ORS.ident THEN ORS.Mark("comma missing") + END + END ; + Check(ORS.semicolon, "no ;") + END ; + obj := ORB.topScope.next; + ORG.Open(version); Declarations(dc); ORG.SetDataSize((dc + 3) DIV 4 * 4); + WHILE sym = ORS.procedure DO ProcedureDecl; Check(ORS.semicolon, "no ;") END ; + ORG.Header; + IF sym = ORS.begin THEN ORS.Get(sym); StatSequence END ; + Check(ORS.end, "no END"); + IF sym = ORS.ident THEN + IF ORS.id # modid THEN ORS.Mark("no match") END ; + ORS.Get(sym) + ELSE ORS.Mark("identifier missing") + END ; + IF sym # ORS.period THEN ORS.Mark("period missing") END ; + IF (ORS.errcnt = 0) & (version # 0) THEN + ORB.Export(modid, newSF, key); + IF newSF THEN Texts.WriteString(W, " new symbol file") END + END ; + IF ORS.errcnt = 0 THEN + ORG.Close(modid, key, exno); + Texts.WriteInt(W, ORG.pc, 6); Texts.WriteInt(W, dc, 6); Texts.WriteHex(W, key) + ELSE Texts.WriteLn(W); Texts.WriteString(W, "compilation FAILED") + END ; + Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); + Oberon.DumpLog; (* voc adaptation; -- noch *) + ORB.CloseScope; pbsList := NIL + ELSE ORS.Mark("must start with MODULE") + END + END Module; + + PROCEDURE Option(VAR S: Texts.Scanner); + BEGIN newSF := FALSE; + IF S.nextCh = "/" THEN + Texts.Scan(S); Texts.Scan(S); + IF (S.class = Texts.Name) & (S.s[0] = "s") THEN newSF := TRUE END + END + END Option; + + PROCEDURE Compile*; + VAR beg, end, time: LONGINT; + T: Texts.Text; + S: Texts.Scanner; + BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S); + IF S.class = Texts.Char THEN + IF S.c = "@" THEN + Option(S); Oberon.GetSelection(T, beg, end, time); + IF time >= 0 THEN ORS.Init(T, beg); Module END + ELSIF S.c = "^" THEN + Option(S); Oberon.GetSelection(T, beg, end, time); + IF time >= 0 THEN + Texts.OpenScanner(S, T, beg); Texts.Scan(S); + IF S.class = Texts.Name THEN + Texts.WriteString(W, S.s); NEW(T); Texts.Open(T, S.s); + IF T.len > 0 THEN ORS.Init(T, 0); Module END + END + END + END + ELSE + WHILE S.class = Texts.Name DO + NEW(T); Texts.Open(T, S.s); + IF T.len > 0 THEN Option(S); ORS.Init(T, 0); Module + ELSE Texts.WriteString(W, S.s); Texts.WriteString(W, " not found"); + Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); + Oberon.DumpLog; (* voc adaptation; -- noch *) + END ; + IF (T.len # 0) & (ORS.errcnt = 0) THEN Texts.Scan(S) ELSE S.class := 0 END + END + END ; + Oberon.Collect(0) + END Compile; + +BEGIN Texts.OpenWriter(W); Texts.WriteString(W, "OR Compiler 7.6.2014"); + Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); + Oberon.DumpLog; (* voc adaptation; -- noch *) + NEW(dummy); dummy.class := ORB.Var; dummy.type := ORB.intType; + expression := expression0; Type := Type0; FormalType := FormalType0; + + Compile (* voc adaptation; -- noch *) +END ORP. diff --git a/src/voc07R/ORS.Mod b/src/voc07R/ORS.Mod index e17db698..1d005e38 100644 --- a/src/voc07R/ORS.Mod +++ b/src/voc07R/ORS.Mod @@ -1,325 +1,325 @@ -MODULE ORS; (* NW 19.9.93 / 1.4.2014 Scanner in Oberon-07*) - IMPORT SYSTEM, Texts := CompatTexts, Oberon; (* CompatTexts is voc adaptation by noch *) - - TYPE INTEGER = LONGINT; (* voc adaptation by noch *) - -(* Oberon Scanner does lexical analysis. Input is Oberon-Text, output is - sequence of symbols, i.e identifiers, numbers, strings, and special symbols. - Recognises all Oberon keywords and skips comments. The keywords are - recorded in a table. - Get(sym) delivers next symbol from input text with Reader R. - Mark(msg) records error and delivers error message with Writer W. - If Get delivers ident, then the identifier (a string) is in variable id, if int or char - in ival, if real in rval, and if string in str (and slen) *) - - CONST IdLen* = 32; - NKW = 34; (*nof keywords*) - maxExp = 38; stringBufSize = 256; - - (*lexical symbols*) - null = 0; times* = 1; rdiv* = 2; div* = 3; mod* = 4; - and* = 5; plus* = 6; minus* = 7; or* = 8; eql* = 9; - neq* = 10; lss* = 11; leq* = 12; gtr* = 13; geq* = 14; - in* = 15; is* = 16; arrow* = 17; period* = 18; - char* = 20; int* = 21; real* = 22; false* = 23; true* = 24; - nil* = 25; string* = 26; not* = 27; lparen* = 28; lbrak* = 29; - lbrace* = 30; ident* = 31; - if* = 32; while* = 34; repeat* = 35; case* = 36; for* = 37; - comma* = 40; colon* = 41; becomes* = 42; upto* = 43; rparen* = 44; - rbrak* = 45; rbrace* = 46; then* = 47; of* = 48; do* = 49; - to* = 50; by* = 51; semicolon* = 52; end* = 53; bar* = 54; - else* = 55; elsif* = 56; until* = 57; return* = 58; - array* = 60; record* = 61; pointer* = 62; const* = 63; type* = 64; - var* = 65; procedure* = 66; begin* = 67; import* = 68; module* = 69; - - TYPE Ident* = ARRAY IdLen OF CHAR; - - VAR ival*, slen*: LONGINT; (*results of Get*) - rval*: REAL; - id*: Ident; (*for identifiers*) - str*: ARRAY stringBufSize OF CHAR; - errcnt*: INTEGER; - - ch: CHAR; (*last character read*) - errpos: LONGINT; - R: Texts.Reader; - W: Texts.Writer; - k: INTEGER; - KWX: ARRAY 10 OF INTEGER; - keyTab: ARRAY NKW OF - RECORD sym: INTEGER; id: ARRAY 12 OF CHAR END; - - PROCEDURE CopyId*(VAR ident: Ident); - BEGIN ident := id - END CopyId; - - PROCEDURE Pos*(): LONGINT; - BEGIN RETURN Texts.Pos(R) - 1 - END Pos; - - PROCEDURE Mark*(msg: ARRAY OF CHAR); - VAR p: LONGINT; - BEGIN p := Pos(); - IF (p > errpos) & (errcnt < 25) THEN - Texts.WriteLn(W); Texts.WriteString(W, " pos "); Texts.WriteInt(W, p, 1); Texts.Write(W, " "); - Texts.WriteString(W, msg); Texts.Append(Oberon.Log, W.buf); - Oberon.DumpLog; (* voc adaptation by noch *) - END ; - INC(errcnt); errpos := p + 4 - END Mark; - - PROCEDURE Identifier(VAR sym: INTEGER); - VAR i, k: INTEGER; - BEGIN i := 0; - REPEAT - IF i < IdLen-1 THEN id[i] := ch; INC(i) END ; - Texts.Read(R, ch) - UNTIL (ch < "0") OR (ch > "9") & (ch < "A") OR (ch > "Z") & (ch < "a") OR (ch > "z"); - id[i] := 0X; - IF i < 10 THEN k := KWX[i-1]; (*search for keyword*) - WHILE (id # keyTab[k].id) & (k < KWX[i]) DO INC(k) END ; - IF k < KWX[i] THEN sym := keyTab[k].sym ELSE sym := ident END - ELSE sym := ident - END - END Identifier; - - PROCEDURE String; - VAR i: INTEGER; - BEGIN i := 0; Texts.Read(R, ch); - WHILE ~R.eot & (ch # 22X) DO - IF ch >= " " THEN - IF i < stringBufSize-1 THEN str[i] := ch; INC(i) ELSE Mark("string too long") END ; - END ; - Texts.Read(R, ch) - END ; - str[i] := 0X; INC(i); Texts.Read(R, ch); slen := i - END String; - - PROCEDURE HexString; - VAR i, m, n: INTEGER; - BEGIN i := 0; Texts.Read(R, ch); - WHILE ~R.eot & (ch # "$") DO - WHILE (ch = " ") OR (ch = 9X) OR (ch = 0DX) DO Texts.Read(R, ch) END ; (*skip*) - IF ("0" <= ch) & (ch <= "9") THEN m := ORD(ch) - 30H - ELSIF ("A" <= ch) & (ch <= "F") THEN m := ORD(ch) - 37H - ELSE m := 0; Mark("hexdig expected") - END ; - Texts.Read(R, ch); - IF ("0" <= ch) & (ch <= "9") THEN n := ORD(ch) - 30H - ELSIF ("A" <= ch) & (ch <= "F") THEN n := ORD(ch) - 37H - ELSE n := 0; Mark("hexdig expected") - END ; - IF i < stringBufSize THEN str[i] := CHR(m*10H + n); INC(i) ELSE Mark("string too long") END ; - Texts.Read(R, ch) - END ; - Texts.Read(R, ch); slen := i (*no 0X appended!*) - END HexString; - - PROCEDURE Ten(e: LONGINT): REAL; - VAR x, t: REAL; - BEGIN x := 1.0; t := 10.0; - WHILE e > 0 DO - IF ODD(e) THEN x := t * x END ; - t := t * t; e := e DIV 2 - END ; - RETURN x - END Ten; - - PROCEDURE Number(VAR sym: INTEGER); - CONST max = 2147483647 (*2^31 - 1*); - VAR i, k, e, n, s, h: LONGINT; x: REAL; - d: ARRAY 16 OF INTEGER; - negE: BOOLEAN; - BEGIN ival := 0; i := 0; n := 0; k := 0; - REPEAT - IF n < 16 THEN d[n] := ORD(ch)-30H; INC(n) ELSE Mark("too many digits"); n := 0 END ; - Texts.Read(R, ch) - UNTIL (ch < "0") OR (ch > "9") & (ch < "A") OR (ch > "F"); - IF (ch = "H") OR (ch = "R") OR (ch = "X") THEN (*hex*) - REPEAT h := d[i]; - IF h >= 10 THEN h := h-7 END ; - k := k*10H + h; INC(i) (*no overflow check*) - UNTIL i = n; - IF ch = "X" THEN sym := char; - IF k < 100H THEN ival := k ELSE Mark("illegal value"); ival := 0 END - ELSIF ch = "R" THEN sym := real; rval := SYSTEM.VAL(REAL, k) - ELSE sym := int; ival := k - END ; - Texts.Read(R, ch) - ELSIF ch = "." THEN - Texts.Read(R, ch); - IF ch = "." THEN (*double dot*) ch := 7FX; (*decimal integer*) - REPEAT - IF d[i] < 10 THEN - IF k <= (max-d[i]) DIV 10 THEN k := k *10 + d[i] ELSE Mark("too large"); k := 0 END - ELSE Mark("bad integer") - END ; - INC(i) - UNTIL i = n; - sym := int; ival := k - ELSE (*real number*) x := 0.0; e := 0; - REPEAT (*integer part*) - (*x := x * 10.0 + FLT(d[i]); *) - x := x * 10.0 + (d[i]); (* voc adaptation by noch *) - INC(i) - UNTIL i = n; - WHILE (ch >= "0") & (ch <= "9") DO (*fraction*) - (*x := x * 10.0 + FLT(ORD(ch) - 30H);*) - x := x * 10.0 + (ORD(ch) - 30H); (* voc adaptation by noch *) - DEC(e); - Texts.Read(R, ch) - END ; - IF (ch = "E") OR (ch = "D") THEN (*scale factor*) - Texts.Read(R, ch); s := 0; - IF ch = "-" THEN negE := TRUE; Texts.Read(R, ch) - ELSE negE := FALSE; - IF ch = "+" THEN Texts.Read(R, ch) END - END ; - IF (ch >= "0") & (ch <= "9") THEN - REPEAT s := s*10 + ORD(ch)-30H; Texts.Read(R, ch) - UNTIL (ch < "0") OR (ch >"9"); - IF negE THEN e := e-s ELSE e := e+s END - ELSE Mark("digit?") - END - END ; - IF e < 0 THEN - IF e >= -maxExp THEN x := x / Ten(-e) ELSE x := 0.0 END - ELSIF e > 0 THEN - IF e <= maxExp THEN x := Ten(e) * x ELSE x := 0.0; Mark("too large") END - END ; - sym := real; rval := x - END - ELSE (*decimal integer*) - REPEAT - IF d[i] < 10 THEN - IF k <= (max-d[i]) DIV 10 THEN k := k*10 + d[i] ELSE Mark("too large"); k := 0 END - ELSE Mark("bad integer") - END ; - INC(i) - UNTIL i = n; - sym := int; ival := k - END - END Number; - - PROCEDURE comment; - BEGIN Texts.Read(R, ch); - REPEAT - WHILE ~R.eot & (ch # "*") DO - IF ch = "(" THEN Texts.Read(R, ch); - IF ch = "*" THEN comment END - ELSE Texts.Read(R, ch) - END - END ; - WHILE ch = "*" DO Texts.Read(R, ch) END - UNTIL (ch = ")") OR R.eot; - IF ~R.eot THEN Texts.Read(R, ch) ELSE Mark("unterminated comment") END - END comment; - - PROCEDURE Get*(VAR sym: INTEGER); - BEGIN - REPEAT - WHILE ~R.eot & (ch <= " ") DO Texts.Read(R, ch) END; - IF ch < "A" THEN - IF ch < "0" THEN - IF ch = 22X THEN String; sym := string - ELSIF ch = "#" THEN Texts.Read(R, ch); sym := neq - ELSIF ch = "$" THEN HexString; sym := string - ELSIF ch = "&" THEN Texts.Read(R, ch); sym := and - ELSIF ch = "(" THEN Texts.Read(R, ch); - IF ch = "*" THEN sym := null; comment ELSE sym := lparen END - ELSIF ch = ")" THEN Texts.Read(R, ch); sym := rparen - ELSIF ch = "*" THEN Texts.Read(R, ch); sym := times - ELSIF ch = "+" THEN Texts.Read(R, ch); sym := plus - ELSIF ch = "," THEN Texts.Read(R, ch); sym := comma - ELSIF ch = "-" THEN Texts.Read(R, ch); sym := minus - ELSIF ch = "." THEN Texts.Read(R, ch); - IF ch = "." THEN Texts.Read(R, ch); sym := upto ELSE sym := period END - ELSIF ch = "/" THEN Texts.Read(R, ch); sym := rdiv - ELSE Texts.Read(R, ch); (* ! % ' *) sym := null - END - ELSIF ch < ":" THEN Number(sym) - ELSIF ch = ":" THEN Texts.Read(R, ch); - IF ch = "=" THEN Texts.Read(R, ch); sym := becomes ELSE sym := colon END - ELSIF ch = ";" THEN Texts.Read(R, ch); sym := semicolon - ELSIF ch = "<" THEN Texts.Read(R, ch); - IF ch = "=" THEN Texts.Read(R, ch); sym := leq ELSE sym := lss END - ELSIF ch = "=" THEN Texts.Read(R, ch); sym := eql - ELSIF ch = ">" THEN Texts.Read(R, ch); - IF ch = "=" THEN Texts.Read(R, ch); sym := geq ELSE sym := gtr END - ELSE (* ? @ *) Texts.Read(R, ch); sym := null - END - ELSIF ch < "[" THEN Identifier(sym) - ELSIF ch < "a" THEN - IF ch = "[" THEN sym := lbrak - ELSIF ch = "]" THEN sym := rbrak - ELSIF ch = "^" THEN sym := arrow - ELSE (* _ ` *) sym := null - END ; - Texts.Read(R, ch) - ELSIF ch < "{" THEN Identifier(sym) ELSE - IF ch = "{" THEN sym := lbrace - ELSIF ch = "}" THEN sym := rbrace - ELSIF ch = "|" THEN sym := bar - ELSIF ch = "~" THEN sym := not - ELSIF ch = 7FX THEN sym := upto - ELSE sym := null - END ; - Texts.Read(R, ch) - END - UNTIL sym # null - END Get; - - PROCEDURE Init*(T: Texts.Text; pos: LONGINT); - BEGIN errpos := pos; errcnt := 0; Texts.OpenReader(R, T, pos); Texts.Read(R, ch) - END Init; - - PROCEDURE EnterKW(sym: INTEGER; name: ARRAY OF CHAR); - BEGIN - (*keyTab[k].id := name; *) - COPY(name, keyTab[k].id); (* voc adaptation by noch *) - keyTab[k].sym := sym; - INC(k) - END EnterKW; - -BEGIN Texts.OpenWriter(W); k := 0; KWX[0] := 0; KWX[1] := 0; - EnterKW(if, "IF"); - EnterKW(do, "DO"); - EnterKW(of, "OF"); - EnterKW(or, "OR"); - EnterKW(to, "TO"); - EnterKW(in, "IN"); - EnterKW(is, "IS"); - EnterKW(by, "BY"); - KWX[2] := k; - EnterKW(end, "END"); - EnterKW(nil, "NIL"); - EnterKW(var, "VAR"); - EnterKW(div, "DIV"); - EnterKW(mod, "MOD"); - EnterKW(for, "FOR"); - KWX[3] := k; - EnterKW(else, "ELSE"); - EnterKW(then, "THEN"); - EnterKW(true, "TRUE"); - EnterKW(type, "TYPE"); - EnterKW(case, "CASE"); - KWX[4] := k; - EnterKW(elsif, "ELSIF"); - EnterKW(false, "FALSE"); - EnterKW(array, "ARRAY"); - EnterKW(begin, "BEGIN"); - EnterKW(const, "CONST"); - EnterKW(until, "UNTIL"); - EnterKW(while, "WHILE"); - KWX[5] := k; - EnterKW(record, "RECORD"); - EnterKW(repeat, "REPEAT"); - EnterKW(return, "RETURN"); - EnterKW(import, "IMPORT"); - EnterKW(module, "MODULE"); - KWX[6] := k; - EnterKW(pointer, "POINTER"); - KWX[7] := k; KWX[8] := k; - EnterKW(procedure, "PROCEDURE"); - KWX[9] := k -END ORS. +MODULE ORS; (* NW 19.9.93 / 1.4.2014 Scanner in Oberon-07*) + IMPORT SYSTEM, Texts := CompatTexts, Oberon; (* CompatTexts is voc adaptation by noch *) + + TYPE INTEGER = LONGINT; (* voc adaptation by noch *) + +(* Oberon Scanner does lexical analysis. Input is Oberon-Text, output is + sequence of symbols, i.e identifiers, numbers, strings, and special symbols. + Recognises all Oberon keywords and skips comments. The keywords are + recorded in a table. + Get(sym) delivers next symbol from input text with Reader R. + Mark(msg) records error and delivers error message with Writer W. + If Get delivers ident, then the identifier (a string) is in variable id, if int or char + in ival, if real in rval, and if string in str (and slen) *) + + CONST IdLen* = 32; + NKW = 34; (*nof keywords*) + maxExp = 38; stringBufSize = 256; + + (*lexical symbols*) + null = 0; times* = 1; rdiv* = 2; div* = 3; mod* = 4; + and* = 5; plus* = 6; minus* = 7; or* = 8; eql* = 9; + neq* = 10; lss* = 11; leq* = 12; gtr* = 13; geq* = 14; + in* = 15; is* = 16; arrow* = 17; period* = 18; + char* = 20; int* = 21; real* = 22; false* = 23; true* = 24; + nil* = 25; string* = 26; not* = 27; lparen* = 28; lbrak* = 29; + lbrace* = 30; ident* = 31; + if* = 32; while* = 34; repeat* = 35; case* = 36; for* = 37; + comma* = 40; colon* = 41; becomes* = 42; upto* = 43; rparen* = 44; + rbrak* = 45; rbrace* = 46; then* = 47; of* = 48; do* = 49; + to* = 50; by* = 51; semicolon* = 52; end* = 53; bar* = 54; + else* = 55; elsif* = 56; until* = 57; return* = 58; + array* = 60; record* = 61; pointer* = 62; const* = 63; type* = 64; + var* = 65; procedure* = 66; begin* = 67; import* = 68; module* = 69; + + TYPE Ident* = ARRAY IdLen OF CHAR; + + VAR ival*, slen*: LONGINT; (*results of Get*) + rval*: REAL; + id*: Ident; (*for identifiers*) + str*: ARRAY stringBufSize OF CHAR; + errcnt*: INTEGER; + + ch: CHAR; (*last character read*) + errpos: LONGINT; + R: Texts.Reader; + W: Texts.Writer; + k: INTEGER; + KWX: ARRAY 10 OF INTEGER; + keyTab: ARRAY NKW OF + RECORD sym: INTEGER; id: ARRAY 12 OF CHAR END; + + PROCEDURE CopyId*(VAR ident: Ident); + BEGIN ident := id + END CopyId; + + PROCEDURE Pos*(): LONGINT; + BEGIN RETURN Texts.Pos(R) - 1 + END Pos; + + PROCEDURE Mark*(msg: ARRAY OF CHAR); + VAR p: LONGINT; + BEGIN p := Pos(); + IF (p > errpos) & (errcnt < 25) THEN + Texts.WriteLn(W); Texts.WriteString(W, " pos "); Texts.WriteInt(W, p, 1); Texts.Write(W, " "); + Texts.WriteString(W, msg); Texts.Append(Oberon.Log, W.buf); + Oberon.DumpLog; (* voc adaptation by noch *) + END ; + INC(errcnt); errpos := p + 4 + END Mark; + + PROCEDURE Identifier(VAR sym: INTEGER); + VAR i, k: INTEGER; + BEGIN i := 0; + REPEAT + IF i < IdLen-1 THEN id[i] := ch; INC(i) END ; + Texts.Read(R, ch) + UNTIL (ch < "0") OR (ch > "9") & (ch < "A") OR (ch > "Z") & (ch < "a") OR (ch > "z"); + id[i] := 0X; + IF i < 10 THEN k := KWX[i-1]; (*search for keyword*) + WHILE (id # keyTab[k].id) & (k < KWX[i]) DO INC(k) END ; + IF k < KWX[i] THEN sym := keyTab[k].sym ELSE sym := ident END + ELSE sym := ident + END + END Identifier; + + PROCEDURE String; + VAR i: INTEGER; + BEGIN i := 0; Texts.Read(R, ch); + WHILE ~R.eot & (ch # 22X) DO + IF ch >= " " THEN + IF i < stringBufSize-1 THEN str[i] := ch; INC(i) ELSE Mark("string too long") END ; + END ; + Texts.Read(R, ch) + END ; + str[i] := 0X; INC(i); Texts.Read(R, ch); slen := i + END String; + + PROCEDURE HexString; + VAR i, m, n: INTEGER; + BEGIN i := 0; Texts.Read(R, ch); + WHILE ~R.eot & (ch # "$") DO + WHILE (ch = " ") OR (ch = 9X) OR (ch = 0DX) DO Texts.Read(R, ch) END ; (*skip*) + IF ("0" <= ch) & (ch <= "9") THEN m := ORD(ch) - 30H + ELSIF ("A" <= ch) & (ch <= "F") THEN m := ORD(ch) - 37H + ELSE m := 0; Mark("hexdig expected") + END ; + Texts.Read(R, ch); + IF ("0" <= ch) & (ch <= "9") THEN n := ORD(ch) - 30H + ELSIF ("A" <= ch) & (ch <= "F") THEN n := ORD(ch) - 37H + ELSE n := 0; Mark("hexdig expected") + END ; + IF i < stringBufSize THEN str[i] := CHR(m*10H + n); INC(i) ELSE Mark("string too long") END ; + Texts.Read(R, ch) + END ; + Texts.Read(R, ch); slen := i (*no 0X appended!*) + END HexString; + + PROCEDURE Ten(e: LONGINT): REAL; + VAR x, t: REAL; + BEGIN x := 1.0; t := 10.0; + WHILE e > 0 DO + IF ODD(e) THEN x := t * x END ; + t := t * t; e := e DIV 2 + END ; + RETURN x + END Ten; + + PROCEDURE Number(VAR sym: INTEGER); + CONST max = 2147483647 (*2^31 - 1*); + VAR i, k, e, n, s, h: LONGINT; x: REAL; + d: ARRAY 16 OF INTEGER; + negE: BOOLEAN; + BEGIN ival := 0; i := 0; n := 0; k := 0; + REPEAT + IF n < 16 THEN d[n] := ORD(ch)-30H; INC(n) ELSE Mark("too many digits"); n := 0 END ; + Texts.Read(R, ch) + UNTIL (ch < "0") OR (ch > "9") & (ch < "A") OR (ch > "F"); + IF (ch = "H") OR (ch = "R") OR (ch = "X") THEN (*hex*) + REPEAT h := d[i]; + IF h >= 10 THEN h := h-7 END ; + k := k*10H + h; INC(i) (*no overflow check*) + UNTIL i = n; + IF ch = "X" THEN sym := char; + IF k < 100H THEN ival := k ELSE Mark("illegal value"); ival := 0 END + ELSIF ch = "R" THEN sym := real; rval := SYSTEM.VAL(REAL, k) + ELSE sym := int; ival := k + END ; + Texts.Read(R, ch) + ELSIF ch = "." THEN + Texts.Read(R, ch); + IF ch = "." THEN (*double dot*) ch := 7FX; (*decimal integer*) + REPEAT + IF d[i] < 10 THEN + IF k <= (max-d[i]) DIV 10 THEN k := k *10 + d[i] ELSE Mark("too large"); k := 0 END + ELSE Mark("bad integer") + END ; + INC(i) + UNTIL i = n; + sym := int; ival := k + ELSE (*real number*) x := 0.0; e := 0; + REPEAT (*integer part*) + (*x := x * 10.0 + FLT(d[i]); *) + x := x * 10.0 + (d[i]); (* voc adaptation by noch *) + INC(i) + UNTIL i = n; + WHILE (ch >= "0") & (ch <= "9") DO (*fraction*) + (*x := x * 10.0 + FLT(ORD(ch) - 30H);*) + x := x * 10.0 + (ORD(ch) - 30H); (* voc adaptation by noch *) + DEC(e); + Texts.Read(R, ch) + END ; + IF (ch = "E") OR (ch = "D") THEN (*scale factor*) + Texts.Read(R, ch); s := 0; + IF ch = "-" THEN negE := TRUE; Texts.Read(R, ch) + ELSE negE := FALSE; + IF ch = "+" THEN Texts.Read(R, ch) END + END ; + IF (ch >= "0") & (ch <= "9") THEN + REPEAT s := s*10 + ORD(ch)-30H; Texts.Read(R, ch) + UNTIL (ch < "0") OR (ch >"9"); + IF negE THEN e := e-s ELSE e := e+s END + ELSE Mark("digit?") + END + END ; + IF e < 0 THEN + IF e >= -maxExp THEN x := x / Ten(-e) ELSE x := 0.0 END + ELSIF e > 0 THEN + IF e <= maxExp THEN x := Ten(e) * x ELSE x := 0.0; Mark("too large") END + END ; + sym := real; rval := x + END + ELSE (*decimal integer*) + REPEAT + IF d[i] < 10 THEN + IF k <= (max-d[i]) DIV 10 THEN k := k*10 + d[i] ELSE Mark("too large"); k := 0 END + ELSE Mark("bad integer") + END ; + INC(i) + UNTIL i = n; + sym := int; ival := k + END + END Number; + + PROCEDURE comment; + BEGIN Texts.Read(R, ch); + REPEAT + WHILE ~R.eot & (ch # "*") DO + IF ch = "(" THEN Texts.Read(R, ch); + IF ch = "*" THEN comment END + ELSE Texts.Read(R, ch) + END + END ; + WHILE ch = "*" DO Texts.Read(R, ch) END + UNTIL (ch = ")") OR R.eot; + IF ~R.eot THEN Texts.Read(R, ch) ELSE Mark("unterminated comment") END + END comment; + + PROCEDURE Get*(VAR sym: INTEGER); + BEGIN + REPEAT + WHILE ~R.eot & (ch <= " ") DO Texts.Read(R, ch) END; + IF ch < "A" THEN + IF ch < "0" THEN + IF ch = 22X THEN String; sym := string + ELSIF ch = "#" THEN Texts.Read(R, ch); sym := neq + ELSIF ch = "$" THEN HexString; sym := string + ELSIF ch = "&" THEN Texts.Read(R, ch); sym := and + ELSIF ch = "(" THEN Texts.Read(R, ch); + IF ch = "*" THEN sym := null; comment ELSE sym := lparen END + ELSIF ch = ")" THEN Texts.Read(R, ch); sym := rparen + ELSIF ch = "*" THEN Texts.Read(R, ch); sym := times + ELSIF ch = "+" THEN Texts.Read(R, ch); sym := plus + ELSIF ch = "," THEN Texts.Read(R, ch); sym := comma + ELSIF ch = "-" THEN Texts.Read(R, ch); sym := minus + ELSIF ch = "." THEN Texts.Read(R, ch); + IF ch = "." THEN Texts.Read(R, ch); sym := upto ELSE sym := period END + ELSIF ch = "/" THEN Texts.Read(R, ch); sym := rdiv + ELSE Texts.Read(R, ch); (* ! % ' *) sym := null + END + ELSIF ch < ":" THEN Number(sym) + ELSIF ch = ":" THEN Texts.Read(R, ch); + IF ch = "=" THEN Texts.Read(R, ch); sym := becomes ELSE sym := colon END + ELSIF ch = ";" THEN Texts.Read(R, ch); sym := semicolon + ELSIF ch = "<" THEN Texts.Read(R, ch); + IF ch = "=" THEN Texts.Read(R, ch); sym := leq ELSE sym := lss END + ELSIF ch = "=" THEN Texts.Read(R, ch); sym := eql + ELSIF ch = ">" THEN Texts.Read(R, ch); + IF ch = "=" THEN Texts.Read(R, ch); sym := geq ELSE sym := gtr END + ELSE (* ? @ *) Texts.Read(R, ch); sym := null + END + ELSIF ch < "[" THEN Identifier(sym) + ELSIF ch < "a" THEN + IF ch = "[" THEN sym := lbrak + ELSIF ch = "]" THEN sym := rbrak + ELSIF ch = "^" THEN sym := arrow + ELSE (* _ ` *) sym := null + END ; + Texts.Read(R, ch) + ELSIF ch < "{" THEN Identifier(sym) ELSE + IF ch = "{" THEN sym := lbrace + ELSIF ch = "}" THEN sym := rbrace + ELSIF ch = "|" THEN sym := bar + ELSIF ch = "~" THEN sym := not + ELSIF ch = 7FX THEN sym := upto + ELSE sym := null + END ; + Texts.Read(R, ch) + END + UNTIL sym # null + END Get; + + PROCEDURE Init*(T: Texts.Text; pos: LONGINT); + BEGIN errpos := pos; errcnt := 0; Texts.OpenReader(R, T, pos); Texts.Read(R, ch) + END Init; + + PROCEDURE EnterKW(sym: INTEGER; name: ARRAY OF CHAR); + BEGIN + (*keyTab[k].id := name; *) + COPY(name, keyTab[k].id); (* voc adaptation by noch *) + keyTab[k].sym := sym; + INC(k) + END EnterKW; + +BEGIN Texts.OpenWriter(W); k := 0; KWX[0] := 0; KWX[1] := 0; + EnterKW(if, "IF"); + EnterKW(do, "DO"); + EnterKW(of, "OF"); + EnterKW(or, "OR"); + EnterKW(to, "TO"); + EnterKW(in, "IN"); + EnterKW(is, "IS"); + EnterKW(by, "BY"); + KWX[2] := k; + EnterKW(end, "END"); + EnterKW(nil, "NIL"); + EnterKW(var, "VAR"); + EnterKW(div, "DIV"); + EnterKW(mod, "MOD"); + EnterKW(for, "FOR"); + KWX[3] := k; + EnterKW(else, "ELSE"); + EnterKW(then, "THEN"); + EnterKW(true, "TRUE"); + EnterKW(type, "TYPE"); + EnterKW(case, "CASE"); + KWX[4] := k; + EnterKW(elsif, "ELSIF"); + EnterKW(false, "FALSE"); + EnterKW(array, "ARRAY"); + EnterKW(begin, "BEGIN"); + EnterKW(const, "CONST"); + EnterKW(until, "UNTIL"); + EnterKW(while, "WHILE"); + KWX[5] := k; + EnterKW(record, "RECORD"); + EnterKW(repeat, "REPEAT"); + EnterKW(return, "RETURN"); + EnterKW(import, "IMPORT"); + EnterKW(module, "MODULE"); + KWX[6] := k; + EnterKW(pointer, "POINTER"); + KWX[7] := k; KWX[8] := k; + EnterKW(procedure, "PROCEDURE"); + KWX[9] := k +END ORS. diff --git a/src/voc07R/ORTool.Mod b/src/voc07R/ORTool.Mod index 3c3f9411..e0a08d42 100644 --- a/src/voc07R/ORTool.Mod +++ b/src/voc07R/ORTool.Mod @@ -1,251 +1,251 @@ -MODULE ORTool; (*NW 18.2.2013*) - IMPORT SYSTEM, Files, Texts, Oberon, ORB; - VAR W: Texts.Writer; - Form: INTEGER; (*result of ReadType*) - mnemo0, mnemo1: ARRAY 16, 4 OF CHAR; (*mnemonics*) - - PROCEDURE Read(VAR R: Files.Rider; VAR n: INTEGER); - VAR b: BYTE; - BEGIN Files.ReadByte(R, b); - IF b < 80H THEN n := b ELSE n := b - 100H END - END Read; - - PROCEDURE ReadType(VAR R: Files.Rider); - VAR key, len, lev, size, off: INTEGER; - ref, mno, class, form, readonly: INTEGER; - name, modname: ARRAY 32 OF CHAR; - BEGIN Read(R, ref); Texts.Write(W, " "); Texts.Write(W, "["); - IF ref < 0 THEN Texts.Write(W, "^"); Texts.WriteInt(W, -ref, 1) - ELSE Texts.WriteInt(W, ref, 1); - Read(R, form); Texts.WriteString(W, " form = "); Texts.WriteInt(W, form, 1); - IF form = ORB.Pointer THEN ReadType(R) - ELSIF form = ORB.Array THEN - ReadType(R); Files.ReadNum(R, len); Files.ReadNum(R, size); - Texts.WriteString(W, " len = "); Texts.WriteInt(W, len, 1); - Texts.WriteString(W, " size = "); Texts.WriteInt(W, size, 1) - ELSIF form = ORB.Record THEN - ReadType(R); (*base type*) - Files.ReadNum(R, off); Texts.WriteString(W, " exno = "); Texts.WriteInt(W, off, 1); - Files.ReadNum(R, off); Texts.WriteString(W, " extlev = "); Texts.WriteInt(W, off, 1); - Files.ReadNum(R, size); Texts.WriteString(W, " size = "); Texts.WriteInt(W, size, 1); - Texts.Write(W, " "); Texts.Write(W, "{"); Read(R, class); - WHILE class # 0 DO (*fields*) - Files.ReadString(R, name); - IF name[0] # 0X THEN Texts.Write(W, " "); Texts.WriteString(W, name); ReadType(R) - ELSE Texts.WriteString(W, " --") - END ; - Files.ReadNum(R, off); Texts.WriteInt(W, off, 4); Read(R, class) - END ; - Texts.Write(W, "}") - ELSIF form = ORB.Proc THEN - ReadType(R); Texts.Write(W, "("); Read(R, class); - WHILE class # 0 DO - Texts.WriteString(W, " class = "); Texts.WriteInt(W, class, 1); Read(R, readonly); - IF readonly = 1 THEN Texts.Write(W, "#") END ; - ReadType(R); Read(R, class) - END ; - Texts.Write(W, ")") - END ; - Files.ReadString(R, modname); - IF modname[0] # 0X THEN - Files.ReadInt(R, key); Files.ReadString(R, name); - Texts.Write(W, " "); Texts.WriteString(W, modname); Texts.Write(W, "."); Texts.WriteString(W, name); - Texts.WriteHex(W, key) - END - END ; - Form := form; Texts.Write(W, "]") - END ReadType; - - PROCEDURE DecSym*; (*decode symbol file*) - VAR class, typno, k: INTEGER; - name: ARRAY 32 OF CHAR; - F: Files.File; R: Files.Rider; - S: Texts.Scanner; - BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S); - IF S.class = Texts.Name THEN - Texts.WriteString(W, "OR-decode "); Texts.WriteString(W, S.s); - Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); - F := Files.Old(S.s); - IF F # NIL THEN - Files.Set(R, F, 0); Files.ReadInt(R, k); Files.ReadInt(R, k); - Files.ReadString(R, name); Texts.WriteString(W, name); Texts.WriteHex(W, k); - Read(R, class); Texts.WriteInt(W, class, 3); (*sym file version*) - IF class = ORB.versionkey THEN - Texts.WriteLn(W); Read(R, class); - WHILE class # 0 DO - Texts.WriteInt(W, class, 4); Files.ReadString(R, name); Texts.Write(W, " "); Texts.WriteString(W, name); - ReadType(R); - IF class = ORB.Typ THEN - Texts.Write(W, "("); Read(R, class); - WHILE class # 0 DO (*pointer base fixup*) - Texts.WriteString(W, " ->"); Texts.WriteInt(W, class, 4); Read(R, class) - END ; - Texts.Write(W, ")") - ELSIF (class = ORB.Const) OR (class = ORB.Var) THEN - Files.ReadNum(R, k); Texts.WriteInt(W, k, 5); (*Reals, Strings!*) - END ; - Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); - Read(R, class) - END - ELSE Texts.WriteString(W, " bad symfile version") - END - ELSE Texts.WriteString(W, " not found") - END ; - Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) - END - END DecSym; - -(* ---------------------------------------------------*) - - PROCEDURE WriteReg(r: LONGINT); - BEGIN Texts.Write(W, " "); - IF r < 12 THEN Texts.WriteString(W, " R"); Texts.WriteInt(W, r MOD 10H, 1) - ELSIF r = 12 THEN Texts.WriteString(W, "MT") - ELSIF r = 13 THEN Texts.WriteString(W, "SB") - ELSIF r = 14 THEN Texts.WriteString(W, "SP") - ELSE Texts.WriteString(W, "LNK") - END - END WriteReg; - - PROCEDURE opcode(w: LONGINT); - VAR k, op, u, a, b, c: LONGINT; - BEGIN - k := w DIV 40000000H MOD 4; - a := w DIV 1000000H MOD 10H; - b := w DIV 100000H MOD 10H; - op := w DIV 10000H MOD 10H; - u := w DIV 20000000H MOD 2; - IF k = 0 THEN - Texts.WriteString(W, mnemo0[op]); - IF u = 1 THEN Texts.Write(W, "'") END ; - WriteReg(a); WriteReg(b); WriteReg(w MOD 10H) - ELSIF k = 1 THEN - Texts.WriteString(W, mnemo0[op]); - IF u = 1 THEN Texts.Write(W, "'") END ; - WriteReg(a); WriteReg(b); w := w MOD 10000H; - IF w >= 8000H THEN w := w - 10000H END ; - Texts.WriteInt(W, w, 7) - ELSIF k = 2 THEN (*LDR/STR*) - IF u = 1 THEN Texts.WriteString(W, "STR ") ELSE Texts.WriteString(W, "LDR") END ; - WriteReg(a); WriteReg(b); w := w MOD 100000H; - IF w >= 80000H THEN w := w - 100000H END ; - Texts.WriteInt(W, w, 8) - ELSIF k = 3 THEN (*Branch instr*) - Texts.Write(W, "B"); - IF ODD(w DIV 10000000H) THEN Texts.Write(W, "L") END ; - Texts.WriteString(W, mnemo1[a]); - IF u = 0 THEN WriteReg(w MOD 10H) ELSE - w := w MOD 100000H; - IF w >= 80000H THEN w := w - 100000H END ; - Texts.WriteInt(W, w, 8) - END - END - END opcode; - - PROCEDURE Sync(VAR R: Files.Rider); - VAR ch: CHAR; - BEGIN Files.Read(R, ch); Texts.WriteString(W, "Sync "); Texts.Write(W, ch); Texts.WriteLn(W) - END Sync; - - PROCEDURE Write(VAR R: Files.Rider; x: INTEGER); - BEGIN Files.WriteByte(R, x) (* -128 <= x < 128 *) - END Write; - - PROCEDURE DecObj*; (*decode object file*) - VAR class, i, n, key, size, fix, adr, data, len: INTEGER; - ch: CHAR; - name: ARRAY 32 OF CHAR; - F: Files.File; R: Files.Rider; - S: Texts.Scanner; - BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S); - IF S.class = Texts.Name THEN - Texts.WriteString(W, "decode "); Texts.WriteString(W, S.s); F := Files.Old(S.s); - IF F # NIL THEN - Files.Set(R, F, 0); Files.ReadString(R, name); Texts.WriteLn(W); Texts.WriteString(W, name); - Files.ReadInt(R, key); Texts.WriteHex(W, key); Read(R, class); Texts.WriteInt(W, class, 4); (*version*) - Files.ReadInt(R, size); Texts.WriteInt(W, size, 6); Texts.WriteLn(W); - Texts.WriteString(W, "imports:"); Texts.WriteLn(W); Files.ReadString(R, name); - WHILE name[0] # 0X DO - Texts.Write(W, 9X); Texts.WriteString(W, name); - Files.ReadInt(R, key); Texts.WriteHex(W, key); Texts.WriteLn(W); - Files.ReadString(R, name) - END ; - (* Sync(R); *) - Texts.WriteString(W, "type descriptors"); Texts.WriteLn(W); - Files.ReadInt(R, n); n := n DIV 4; i := 0; - WHILE i < n DO Files.ReadInt(R, data); Texts.WriteHex(W, data); INC(i) END ; - Texts.WriteLn(W); - Texts.WriteString(W, "data"); Files.ReadInt(R, data); Texts.WriteInt(W, data, 6); Texts.WriteLn(W); - Texts.WriteString(W, "strings"); Texts.WriteLn(W); - Files.ReadInt(R, n); i := 0; - WHILE i < n DO Files.Read(R, ch); Texts.Write(W, ch); INC(i) END ; - Texts.WriteLn(W); - Texts.WriteString(W, "code"); Texts.WriteLn(W); - Files.ReadInt(R, n); i := 0; - WHILE i < n DO - Files.ReadInt(R, data); Texts.WriteInt(W, i, 4); Texts.Write(W, 9X); Texts.WriteHex(W, data); - Texts.Write(W, 9X); opcode(data); Texts.WriteLn(W); INC(i) - END ; - (* Sync(R); *) - Texts.WriteString(W, "commands:"); Texts.WriteLn(W); - Files.ReadString(R, name); - WHILE name[0] # 0X DO - Texts.Write(W, 9X); Texts.WriteString(W, name); - Files.ReadInt(R, adr); Texts.WriteInt(W, adr, 5); Texts.WriteLn(W); - Files.ReadString(R, name) - END ; - (* Sync(R); *) - Texts.WriteString(W, "entries"); Texts.WriteLn(W); - Files.ReadInt(R, n); i := 0; - WHILE i < n DO - Files.ReadInt(R, adr); Texts.WriteInt(W, adr, 6); INC(i) - END ; - Texts.WriteLn(W); - (* Sync(R); *) - Texts.WriteString(W, "pointer refs"); Texts.WriteLn(W); Files.ReadInt(R, adr); - WHILE adr # -1 DO Texts.WriteInt(W, adr, 6); Files.ReadInt(R, adr) END ; - Texts.WriteLn(W); - (* Sync(R); *) - Files.ReadInt(R, data); Texts.WriteString(W, "fixP = "); Texts.WriteInt(W, data, 8); Texts.WriteLn(W); - Files.ReadInt(R, data); Texts.WriteString(W, "fixD = "); Texts.WriteInt(W, data, 8); Texts.WriteLn(W); - Files.ReadInt(R, data); Texts.WriteString(W, "fixT = "); Texts.WriteInt(W, data, 8); Texts.WriteLn(W); - Files.ReadInt(R, data); Texts.WriteString(W, "entry = "); Texts.WriteInt(W, data, 8); Texts.WriteLn(W); - Files.Read(R, ch); - IF ch # "O" THEN Texts.WriteString(W, "format eror"); Texts.WriteLn(W) END - (* Sync(R); *) - ELSE Texts.WriteString(W, " not found"); Texts.WriteLn(W) - END ; - Texts.Append(Oberon.Log, W.buf) - END - END DecObj; - -BEGIN Texts.OpenWriter(W); Texts.WriteString(W, "ORTool 18.2.2013"); - Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); - mnemo0[0] := "MOV"; - mnemo0[1] := "LSL"; - mnemo0[2] := "ASR"; - mnemo0[3] := "ROR"; - mnemo0[4] := "AND"; - mnemo0[5] := "ANN"; - mnemo0[6] := "IOR"; - mnemo0[7] := "XOR"; - mnemo0[8] := "ADD"; - mnemo0[9] := "SUB"; - mnemo0[10] := "MUL"; - mnemo0[11] := "DIV"; - mnemo0[12] := "FAD"; - mnemo0[13] := "FSB"; - mnemo0[14] := "FML"; - mnemo0[15] := "FDV"; - mnemo1[0] := "MI "; - mnemo1[8] := "PL"; - mnemo1[1] := "EQ "; - mnemo1[9] := "NE "; - mnemo1[2] := "LS "; - mnemo1[10] := "HI "; - mnemo1[5] := "LT "; - mnemo1[13] := "GE "; - mnemo1[6] := "LE "; - mnemo1[14] := "GT "; - mnemo1[15] := "NO "; -END ORTool. +MODULE ORTool; (*NW 18.2.2013*) + IMPORT SYSTEM, Files, Texts, Oberon, ORB; + VAR W: Texts.Writer; + Form: INTEGER; (*result of ReadType*) + mnemo0, mnemo1: ARRAY 16, 4 OF CHAR; (*mnemonics*) + + PROCEDURE Read(VAR R: Files.Rider; VAR n: INTEGER); + VAR b: BYTE; + BEGIN Files.ReadByte(R, b); + IF b < 80H THEN n := b ELSE n := b - 100H END + END Read; + + PROCEDURE ReadType(VAR R: Files.Rider); + VAR key, len, lev, size, off: INTEGER; + ref, mno, class, form, readonly: INTEGER; + name, modname: ARRAY 32 OF CHAR; + BEGIN Read(R, ref); Texts.Write(W, " "); Texts.Write(W, "["); + IF ref < 0 THEN Texts.Write(W, "^"); Texts.WriteInt(W, -ref, 1) + ELSE Texts.WriteInt(W, ref, 1); + Read(R, form); Texts.WriteString(W, " form = "); Texts.WriteInt(W, form, 1); + IF form = ORB.Pointer THEN ReadType(R) + ELSIF form = ORB.Array THEN + ReadType(R); Files.ReadNum(R, len); Files.ReadNum(R, size); + Texts.WriteString(W, " len = "); Texts.WriteInt(W, len, 1); + Texts.WriteString(W, " size = "); Texts.WriteInt(W, size, 1) + ELSIF form = ORB.Record THEN + ReadType(R); (*base type*) + Files.ReadNum(R, off); Texts.WriteString(W, " exno = "); Texts.WriteInt(W, off, 1); + Files.ReadNum(R, off); Texts.WriteString(W, " extlev = "); Texts.WriteInt(W, off, 1); + Files.ReadNum(R, size); Texts.WriteString(W, " size = "); Texts.WriteInt(W, size, 1); + Texts.Write(W, " "); Texts.Write(W, "{"); Read(R, class); + WHILE class # 0 DO (*fields*) + Files.ReadString(R, name); + IF name[0] # 0X THEN Texts.Write(W, " "); Texts.WriteString(W, name); ReadType(R) + ELSE Texts.WriteString(W, " --") + END ; + Files.ReadNum(R, off); Texts.WriteInt(W, off, 4); Read(R, class) + END ; + Texts.Write(W, "}") + ELSIF form = ORB.Proc THEN + ReadType(R); Texts.Write(W, "("); Read(R, class); + WHILE class # 0 DO + Texts.WriteString(W, " class = "); Texts.WriteInt(W, class, 1); Read(R, readonly); + IF readonly = 1 THEN Texts.Write(W, "#") END ; + ReadType(R); Read(R, class) + END ; + Texts.Write(W, ")") + END ; + Files.ReadString(R, modname); + IF modname[0] # 0X THEN + Files.ReadInt(R, key); Files.ReadString(R, name); + Texts.Write(W, " "); Texts.WriteString(W, modname); Texts.Write(W, "."); Texts.WriteString(W, name); + Texts.WriteHex(W, key) + END + END ; + Form := form; Texts.Write(W, "]") + END ReadType; + + PROCEDURE DecSym*; (*decode symbol file*) + VAR class, typno, k: INTEGER; + name: ARRAY 32 OF CHAR; + F: Files.File; R: Files.Rider; + S: Texts.Scanner; + BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S); + IF S.class = Texts.Name THEN + Texts.WriteString(W, "OR-decode "); Texts.WriteString(W, S.s); + Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); + F := Files.Old(S.s); + IF F # NIL THEN + Files.Set(R, F, 0); Files.ReadInt(R, k); Files.ReadInt(R, k); + Files.ReadString(R, name); Texts.WriteString(W, name); Texts.WriteHex(W, k); + Read(R, class); Texts.WriteInt(W, class, 3); (*sym file version*) + IF class = ORB.versionkey THEN + Texts.WriteLn(W); Read(R, class); + WHILE class # 0 DO + Texts.WriteInt(W, class, 4); Files.ReadString(R, name); Texts.Write(W, " "); Texts.WriteString(W, name); + ReadType(R); + IF class = ORB.Typ THEN + Texts.Write(W, "("); Read(R, class); + WHILE class # 0 DO (*pointer base fixup*) + Texts.WriteString(W, " ->"); Texts.WriteInt(W, class, 4); Read(R, class) + END ; + Texts.Write(W, ")") + ELSIF (class = ORB.Const) OR (class = ORB.Var) THEN + Files.ReadNum(R, k); Texts.WriteInt(W, k, 5); (*Reals, Strings!*) + END ; + Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); + Read(R, class) + END + ELSE Texts.WriteString(W, " bad symfile version") + END + ELSE Texts.WriteString(W, " not found") + END ; + Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) + END + END DecSym; + +(* ---------------------------------------------------*) + + PROCEDURE WriteReg(r: LONGINT); + BEGIN Texts.Write(W, " "); + IF r < 12 THEN Texts.WriteString(W, " R"); Texts.WriteInt(W, r MOD 10H, 1) + ELSIF r = 12 THEN Texts.WriteString(W, "MT") + ELSIF r = 13 THEN Texts.WriteString(W, "SB") + ELSIF r = 14 THEN Texts.WriteString(W, "SP") + ELSE Texts.WriteString(W, "LNK") + END + END WriteReg; + + PROCEDURE opcode(w: LONGINT); + VAR k, op, u, a, b, c: LONGINT; + BEGIN + k := w DIV 40000000H MOD 4; + a := w DIV 1000000H MOD 10H; + b := w DIV 100000H MOD 10H; + op := w DIV 10000H MOD 10H; + u := w DIV 20000000H MOD 2; + IF k = 0 THEN + Texts.WriteString(W, mnemo0[op]); + IF u = 1 THEN Texts.Write(W, "'") END ; + WriteReg(a); WriteReg(b); WriteReg(w MOD 10H) + ELSIF k = 1 THEN + Texts.WriteString(W, mnemo0[op]); + IF u = 1 THEN Texts.Write(W, "'") END ; + WriteReg(a); WriteReg(b); w := w MOD 10000H; + IF w >= 8000H THEN w := w - 10000H END ; + Texts.WriteInt(W, w, 7) + ELSIF k = 2 THEN (*LDR/STR*) + IF u = 1 THEN Texts.WriteString(W, "STR ") ELSE Texts.WriteString(W, "LDR") END ; + WriteReg(a); WriteReg(b); w := w MOD 100000H; + IF w >= 80000H THEN w := w - 100000H END ; + Texts.WriteInt(W, w, 8) + ELSIF k = 3 THEN (*Branch instr*) + Texts.Write(W, "B"); + IF ODD(w DIV 10000000H) THEN Texts.Write(W, "L") END ; + Texts.WriteString(W, mnemo1[a]); + IF u = 0 THEN WriteReg(w MOD 10H) ELSE + w := w MOD 100000H; + IF w >= 80000H THEN w := w - 100000H END ; + Texts.WriteInt(W, w, 8) + END + END + END opcode; + + PROCEDURE Sync(VAR R: Files.Rider); + VAR ch: CHAR; + BEGIN Files.Read(R, ch); Texts.WriteString(W, "Sync "); Texts.Write(W, ch); Texts.WriteLn(W) + END Sync; + + PROCEDURE Write(VAR R: Files.Rider; x: INTEGER); + BEGIN Files.WriteByte(R, x) (* -128 <= x < 128 *) + END Write; + + PROCEDURE DecObj*; (*decode object file*) + VAR class, i, n, key, size, fix, adr, data, len: INTEGER; + ch: CHAR; + name: ARRAY 32 OF CHAR; + F: Files.File; R: Files.Rider; + S: Texts.Scanner; + BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S); + IF S.class = Texts.Name THEN + Texts.WriteString(W, "decode "); Texts.WriteString(W, S.s); F := Files.Old(S.s); + IF F # NIL THEN + Files.Set(R, F, 0); Files.ReadString(R, name); Texts.WriteLn(W); Texts.WriteString(W, name); + Files.ReadInt(R, key); Texts.WriteHex(W, key); Read(R, class); Texts.WriteInt(W, class, 4); (*version*) + Files.ReadInt(R, size); Texts.WriteInt(W, size, 6); Texts.WriteLn(W); + Texts.WriteString(W, "imports:"); Texts.WriteLn(W); Files.ReadString(R, name); + WHILE name[0] # 0X DO + Texts.Write(W, 9X); Texts.WriteString(W, name); + Files.ReadInt(R, key); Texts.WriteHex(W, key); Texts.WriteLn(W); + Files.ReadString(R, name) + END ; + (* Sync(R); *) + Texts.WriteString(W, "type descriptors"); Texts.WriteLn(W); + Files.ReadInt(R, n); n := n DIV 4; i := 0; + WHILE i < n DO Files.ReadInt(R, data); Texts.WriteHex(W, data); INC(i) END ; + Texts.WriteLn(W); + Texts.WriteString(W, "data"); Files.ReadInt(R, data); Texts.WriteInt(W, data, 6); Texts.WriteLn(W); + Texts.WriteString(W, "strings"); Texts.WriteLn(W); + Files.ReadInt(R, n); i := 0; + WHILE i < n DO Files.Read(R, ch); Texts.Write(W, ch); INC(i) END ; + Texts.WriteLn(W); + Texts.WriteString(W, "code"); Texts.WriteLn(W); + Files.ReadInt(R, n); i := 0; + WHILE i < n DO + Files.ReadInt(R, data); Texts.WriteInt(W, i, 4); Texts.Write(W, 9X); Texts.WriteHex(W, data); + Texts.Write(W, 9X); opcode(data); Texts.WriteLn(W); INC(i) + END ; + (* Sync(R); *) + Texts.WriteString(W, "commands:"); Texts.WriteLn(W); + Files.ReadString(R, name); + WHILE name[0] # 0X DO + Texts.Write(W, 9X); Texts.WriteString(W, name); + Files.ReadInt(R, adr); Texts.WriteInt(W, adr, 5); Texts.WriteLn(W); + Files.ReadString(R, name) + END ; + (* Sync(R); *) + Texts.WriteString(W, "entries"); Texts.WriteLn(W); + Files.ReadInt(R, n); i := 0; + WHILE i < n DO + Files.ReadInt(R, adr); Texts.WriteInt(W, adr, 6); INC(i) + END ; + Texts.WriteLn(W); + (* Sync(R); *) + Texts.WriteString(W, "pointer refs"); Texts.WriteLn(W); Files.ReadInt(R, adr); + WHILE adr # -1 DO Texts.WriteInt(W, adr, 6); Files.ReadInt(R, adr) END ; + Texts.WriteLn(W); + (* Sync(R); *) + Files.ReadInt(R, data); Texts.WriteString(W, "fixP = "); Texts.WriteInt(W, data, 8); Texts.WriteLn(W); + Files.ReadInt(R, data); Texts.WriteString(W, "fixD = "); Texts.WriteInt(W, data, 8); Texts.WriteLn(W); + Files.ReadInt(R, data); Texts.WriteString(W, "fixT = "); Texts.WriteInt(W, data, 8); Texts.WriteLn(W); + Files.ReadInt(R, data); Texts.WriteString(W, "entry = "); Texts.WriteInt(W, data, 8); Texts.WriteLn(W); + Files.Read(R, ch); + IF ch # "O" THEN Texts.WriteString(W, "format eror"); Texts.WriteLn(W) END + (* Sync(R); *) + ELSE Texts.WriteString(W, " not found"); Texts.WriteLn(W) + END ; + Texts.Append(Oberon.Log, W.buf) + END + END DecObj; + +BEGIN Texts.OpenWriter(W); Texts.WriteString(W, "ORTool 18.2.2013"); + Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); + mnemo0[0] := "MOV"; + mnemo0[1] := "LSL"; + mnemo0[2] := "ASR"; + mnemo0[3] := "ROR"; + mnemo0[4] := "AND"; + mnemo0[5] := "ANN"; + mnemo0[6] := "IOR"; + mnemo0[7] := "XOR"; + mnemo0[8] := "ADD"; + mnemo0[9] := "SUB"; + mnemo0[10] := "MUL"; + mnemo0[11] := "DIV"; + mnemo0[12] := "FAD"; + mnemo0[13] := "FSB"; + mnemo0[14] := "FML"; + mnemo0[15] := "FDV"; + mnemo1[0] := "MI "; + mnemo1[8] := "PL"; + mnemo1[1] := "EQ "; + mnemo1[9] := "NE "; + mnemo1[2] := "LS "; + mnemo1[10] := "HI "; + mnemo1[5] := "LT "; + mnemo1[13] := "GE "; + mnemo1[6] := "LE "; + mnemo1[14] := "GT "; + mnemo1[15] := "NO "; +END ORTool.