diff --git a/src/voc07R/ORB.Mod b/src/voc07R/ORB.Mod new file mode 100644 index 00000000..b695526f --- /dev/null +++ b/src/voc07R/ORB.Mod @@ -0,0 +1,437 @@ +MODULE ORB; (*NW 7.10.2013 in Oberon-07*) + IMPORT Files, 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. *) + + 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 + 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 := 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) (* -128 <= x < 128 *) + 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 + IF t.base.ref > 0 THEN Write(R, -t.base.ref) + ELSIF (t.base.typobj = NIL) OR ~t.base.typobj.expo THEN (*base not exported*) Write(R, -1) + ELSE OutType(R, t.base) + END + 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) + 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; (* compute key (checksum) *) + WHILE ~R.eof DO Files.ReadInt(R, x); sum := sum + 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 THEN + key := sum; 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; 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, MSK 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/ORC.Mod b/src/voc07R/ORC.Mod new file mode 100644 index 00000000..84bfb97a --- /dev/null +++ b/src/voc07R/ORC.Mod @@ -0,0 +1,206 @@ +MODULE ORC; (*Connection to RISC; NW 11.11.2013*) + IMPORT SYSTEM, Files, Texts, Oberon, V24; + CONST portno = 1; (*RS-232*) + BlkLen = 255; pno = 1; + REQ = 20X; REC = 21X; SND = 22X; CLS = 23X; ACK = 10X; + Tout = 1000; + + VAR res: LONGINT; + W: Texts.Writer; + + PROCEDURE Flush*; + VAR ch: CHAR; + BEGIN + WHILE V24.Available(portno) > 0 DO V24.Receive(portno, ch, res); Texts.Write(W, ch) END ; + Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) + END Flush; + + PROCEDURE Open*; + VAR ch: CHAR; + BEGIN V24.Start(pno, 19200, 8, V24.ParNo, V24.Stop1, res); + WHILE V24.Available(pno) > 0 DO V24.Receive(pno, ch, res) END ; + IF res > 0 THEN Texts.WriteString(W, "open V24, error ="); Texts.WriteInt(W, res, 4) + ELSE Texts.WriteString(W, "connection open") + END ; + Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) + END Open; + + PROCEDURE TestReq*; + VAR ch: CHAR; + BEGIN V24.Send(pno, REQ, res); Rec(ch); Texts.WriteInt(W, ORD(ch), 4); + Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) + END TestReq; + + PROCEDURE SendInt(x: LONGINT); + VAR i: INTEGER; + BEGIN i := 4; + WHILE i > 0 DO + DEC(i); V24.Send(portno, CHR(x), res); x := x DIV 100H + END + END SendInt; + + PROCEDURE Load*; (*linked boot file F.bin*) + VAR i, m, n, w: LONGINT; + 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 (*input file name*) + Texts.WriteString(W, S.s); F := Files.Old(S.s); + IF F # NIL THEN + Files.Set(R, F, 0); Files.ReadLInt(R, n); Files.ReadLInt(R, m); n := n DIV 4; + Texts.WriteInt(W, n, 6); Texts.WriteString(W, " loading "); Texts.Append(Oberon.Log, W.buf); + i := 0; SendInt(n*4); SendInt(m); + WHILE i < n DO + IF i + 1024 < n THEN m := i + 1024 ELSE m := n END ; + WHILE i < m DO Files.ReadLInt(R, w); SendInt(w); INC(i) END ; + Texts.Write(W, "."); Texts.Append(Oberon.Log, W.buf) + END ; + SendInt(0); Texts.WriteString(W, "done") + ELSE Texts.WriteString(W, " not found") + END ; + Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) + END + END Load; + +(* ------------ send and receive files ------------ *) + + PROCEDURE Rec(VAR ch: CHAR); (*receive with timeout*) + VAR time: LONGINT; + BEGIN time := Oberon.Time() + 3000; + LOOP + IF V24.Available(pno) > 0 THEN V24.Receive(pno, ch, res); EXIT END ; + IF Oberon.Time() >= time THEN ch := 0X; EXIT END + END + END Rec; + + PROCEDURE SendName(VAR s: ARRAY OF CHAR); + VAR i: INTEGER; ch: CHAR; + BEGIN i := 0; ch := s[0]; + WHILE ch > 0X DO V24.Send(pno, ch, res); INC(i); ch := s[i] END ; + V24.Send(pno, 0X, res) + END SendName; + + PROCEDURE Send*; + VAR ch, code: CHAR; + n, n0, L: LONGINT; + F: Files.File; R: Files.Rider; + S: Texts.Scanner; + BEGIN V24.Send(pno, REQ, res); Rec(code); + IF code = ACK THEN + Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S); + WHILE S.class = Texts.Name DO + Texts.WriteString(W, S.s); F := Files.Old(S.s); + IF F # NIL THEN + V24.Send(pno, REC, res); SendName(S.s); Rec(code); + IF code = ACK THEN + Texts.WriteString(W, " sending "); + L := Files.Length(F); Files.Set(R, F, 0); + REPEAT (*send paket*) + IF L > BlkLen THEN n := BlkLen ELSE n := L END ; + n0 := n; V24.Send(pno, CHR(n), res); DEC(L, n); + WHILE n > 0 DO Files.Read(R, ch); V24.Send(pno, ch, res); DEC(n) END ; + Rec(code); + IF code = ACK THEN Texts.Write(W, ".") ELSE Texts.Write(W, "*"); n := 0 END ; + Texts.Append(Oberon.Log, W.buf) + UNTIL n0 < BlkLen; + Rec(code) + ELSE Texts.WriteString(W, " no response"); Texts.WriteInt(W, ORD(code), 4) + END + ELSE Texts.WriteString(W, " not found") + END ; + Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); Texts.Scan(S) + END + ELSE Texts.WriteString(W, " connection not open"); + Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) + END + END Send; + + PROCEDURE Receive*; + VAR ch, code: CHAR; + n, L, LL: LONGINT; + F: Files.File; R: Files.Rider; + orgname: ARRAY 32 OF CHAR; + S: Texts.Scanner; + BEGIN V24.Send(pno, REQ, res); Rec(code); + IF code = ACK THEN + Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S); + WHILE S.class = Texts.Name DO + Texts.WriteString(W, S.s); COPY(S.s, orgname); + F := Files.New(S.s); Files.Set(R, F, 0); LL := 0; + V24.Send(pno, SND, res); SendName(S.s); Rec(code); + IF code = ACK THEN + Texts.WriteString(W, " receiving "); + REPEAT Rec(ch); L := ORD(ch); n := L; + WHILE n > 0 DO V24.Receive(pno, ch, res); Files.Write(R, ch); DEC(n) END ; + V24.Send(pno, ACK, res); LL := LL + L; Texts.Write(W, "."); Texts.Append(Oberon.Log, W.buf) + UNTIL L < BlkLen; + Files.Register(F); Texts.WriteInt(W, LL, 6) + ELSE Texts.WriteString(W, " no response"); Texts.WriteInt(W, ORD(code), 4) + END ; + Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); Texts.Scan(S) + END + ELSE Texts.WriteString(W, " connection not open"); + Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) + END + END Receive; + + PROCEDURE Close*; + BEGIN V24.Send(pno, CLS, res); + Texts.WriteString(W, "Server closed"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) + END Close; + +(* ------------ Oberon-0 commands ------------ *) + + PROCEDURE RecByte(VAR ch: CHAR); + VAR T: LONGINT; ch0: CHAR; + BEGIN T := Oberon.Time() + Tout; + REPEAT UNTIL (V24.Available(portno) > 0) OR (Oberon.Time() >= T); + IF V24.Available(portno) > 0 THEN V24.Receive(portno, ch, res) ELSE ch := 0X END ; + END RecByte; + + PROCEDURE RecInt(VAR x: LONGINT); + VAR i, k, T: LONGINT; ch: CHAR; + BEGIN i := 4; k := 0; + REPEAT + DEC(i); V24.Receive(portno, ch, res); + k := SYSTEM.ROT(ORD(ch)+k, -8) + UNTIL i = 0; + x := k + END RecInt; + + PROCEDURE SR*; (*send, then receive sequence of items*) + VAR S: Texts.Scanner; i, k: LONGINT; ch, xch: CHAR; + BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S); + WHILE (S.class # Texts.Char) & (S.c # "~") DO + IF S.class = Texts.Int THEN Texts.WriteInt(W, S.i, 6); SendInt(S.i) + ELSIF S.class = Texts.Real THEN + Texts.WriteReal(W, S.x, 12); SendInt(SYSTEM.VAL(LONGINT, S.x)) + ELSIF S.class IN {Texts.Name, Texts.String} THEN + Texts.Write(W, " "); Texts.WriteString(W, S.s); i := 0; + REPEAT ch := S.s[i]; V24.Send(portno, ch, res); INC(i) UNTIL ch = 0X + ELSIF S.class = Texts.Char THEN Texts.Write(W, S.c) + ELSE Texts.WriteString(W, "bad value") + END ; + Texts.Scan(S) + END ; + Texts.Write(W, "|"); (*Texts.Append(Oberon.Log, W.buf);*) + (*receive input*) + REPEAT RecByte(xch); + IF xch = 0X THEN Texts.WriteString(W, " timeout"); Flush + ELSIF xch = 1X THEN RecInt(k); Texts.WriteInt(W, k, 6) + ELSIF xch = 2X THEN RecInt(k); Texts.WriteHex(W, k) + ELSIF xch = 3X THEN RecInt(k); Texts.WriteReal(W, SYSTEM.VAL(REAL, k), 15) + ELSIF xch = 4X THEN Texts.Write(W, " "); V24.Receive(portno, ch, res); + WHILE ch > 0X DO Texts.Write(W, ch); V24.Receive(portno, ch, res) END + ELSIF xch = 5X THEN V24.Receive(portno, ch, res); Texts.Write(W, ch) + ELSIF xch = 6X THEN Texts.WriteLn(W) + ELSIF xch = 7X THEN Texts.Write(W, "~"); xch := 0X + ELSIF xch = 8X THEN RecByte(ch); Texts.WriteInt(W, ORD(ch), 4); Texts.Append(Oberon.Log, W.buf) + ELSE xch := 0X + END + UNTIL xch = 0X; + Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) + END SR; + +BEGIN Texts.OpenWriter(W); +END ORC. diff --git a/src/voc07R/ORG.Mod b/src/voc07R/ORG.Mod new file mode 100644 index 00000000..d2f420ad --- /dev/null +++ b/src/voc07R/ORG.Mod @@ -0,0 +1,1125 @@ +MODULE ORG; (* NW 10.10.2013 code generator in Oberon-07 for RISC*) + IMPORT SYSTEM, Files, ORS, ORB; + (*Code generator for Oberon compiler for RISC processor. + Procedural interface to Parser OSAP; result in array "code". + Procedure Close writes code-files*) + + 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; + 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*) + fixorgP, fixorgD, fixorgT: LONGINT; (*origins of lists of locations to be fixed up by loader*) + check, inhibitCalls: 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; + + (*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, 1000H) END ; (*set v-bit*) + 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 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 SaveRegs(r: LONGINT); (* R[0 .. r-1] to be saved; R[r .. RH-1] to be moved down*) + VAR rs, rd: LONGINT; (*r > 0*) + BEGIN rs := r; rd := 0; + REPEAT DEC(rs); Put1(Sub, SP, SP, 4); Put2(Str, rs, SP, 0) UNTIL rs = 0; + rs := r; rd := 0; + WHILE rs < RH DO Put0(Mov, rd, 0, rs); INC(rs); INC(rd) END ; + RH := rd + END SaveRegs; + + PROCEDURE RestoreRegs(r: LONGINT; VAR x: Item); (*R[0 .. r-1] to be restored*) + VAR rd: LONGINT; (*r > 0*) + BEGIN Put0(Mov, r, 0, 0); rd := 0; + REPEAT Put2(Ldr, rd, SP, 0); Put1(Add, SP, SP, 4); INC(rd) UNTIL rd = r + END RestoreRegs; + + 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 Put3(BLR, cond, ORS.Pos()*100H + num*10H + MT) + 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.Var THEN + IF x.r > 0 THEN (*local*) Put2(op, RH, SP, x.a) + 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); Put2(op, RH, RH, x.b); x.r := RH; incR + ELSIF 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 = 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) + 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); + 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); Put0(Cmp, RH, y.r, RH) + ELSE ORS.Mark("error in Index") + END + END ; + Trap(10, 1) + END ; + IF s = 4 THEN Put1(Lsl, y.r, y.r, 2) ELSIF s > 1 THEN Put1(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) + 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); + 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) 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); 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 ; + 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); + BEGIN (*fetch tag into RH*) + IF varpar THEN Put2(Ldr, RH, SP, x.a+4) + ELSE load(x); NilCheck; Put2(Ldr, RH, x.r, -8) + END ; + Put2(Ldr, RH, RH, T.nofpar*4); incR; + loadTypTagAdr(T); (*tag of T*) + Put0(Cmp, RH, RH-1, RH-2); DEC(RH, 2); + 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 < 10H) 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 < 10H) THEN Put1(Mov, RH, 0, LSL(-2, y.a)); y.mode := Reg; y.r := RH; INC(RH) + 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) + ELSE GetSB(x.r); Put2(op, y.r, SB, x.a) + END + ELSIF x.mode = ORB.Par THEN Put2(Ldr, RH, SP, x.a); 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 *) + 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 Put1(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 Put1(Mul, RH, RH, s DIV 4) + END ; + IF check THEN + Put1(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 Put1(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 Put1(Mov, RH, 0, x.type.len) ELSE Put2(Ldr, RH, SP, x.a+4) END ; + incR + ELSIF ftype.form = ORB.Record THEN + IF xmd = ORB.Par THEN Put2(Ldr, RH, SP, x.a+4); 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) 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 PrepCall*(VAR x: Item; VAR r: LONGINT); + BEGIN + IF x.type.form = ORB.Proc THEN + IF x.mode # ORB.Const THEN + load(x); code[pc-1] := code[pc-1] + 0B000000H; x.r := 11; DEC(RH); inhibitCalls := TRUE; + IF check THEN Trap(EQ, 5) END + END + ELSE ORS.Mark("not a procedure") + END ; + r := RH + END PrepCall; + + PROCEDURE Call*(VAR x: Item; r: LONGINT); + BEGIN + IF inhibitCalls & (x.r # 11) THEN ORS.Mark("inadmissible call") ELSE inhibitCalls := FALSE END ; + IF r > 0 THEN SaveRegs(r) END ; + IF x.type.form = ORB.Proc THEN + 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 Put3(BLR, 7, x.r) + END + ELSE ORS.Mark("not a procedure") + END ; + IF x.type.base.form = ORB.NoTyp THEN RH := 0 + ELSE + IF r > 0 THEN RestoreRegs(r, x) 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; + 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, 8); Put2(Str, 0, SP, 0); Put2(Str, 1, SP, 4) + (*R0 and R1 saved, but NOT LNK*) + 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*) + Put2(Ldr, 1, SP, 4); Put2(Ldr, 0, SP, 0); Put1(Add, SP, SP, 8); 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 + 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 Put1(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 Put1(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 zr: LONGINT; + BEGIN loadAdr(x); zr := RH; Put2(Ldr, RH, x.r, 0); incR; + IF inorex = 0 THEN (*include*) + IF y.mode = ORB.Const THEN Put1(Ior, zr, zr, LSL(1, y.a)) + ELSE load(y); Put1(Mov, RH, 0, 1); Put0(Lsl, y.r, RH, y.r); Put0(Ior, zr, zr, y.r); DEC(RH) + END + ELSE (*exclude*) + IF y.mode = ORB.Const THEN Put1(And, zr, zr, -LSL(1, y.a)-1) + ELSE load(y); Put1(Mov, RH, 0, 1); Put0(Lsl, y.r, RH, y.r); Put1(Xor, y.r, y.r, -1); Put0(And, zr, zr, y.r); DEC(RH) + END + 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+1000H, 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); 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 * 1000H), 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; inhibitCalls := FALSE; + 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; Put1(Mov, SB, 0, 16); Put1(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); + 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 new file mode 100644 index 00000000..1cfec152 --- /dev/null +++ b/src/voc07R/ORP.Mod @@ -0,0 +1,974 @@ +MODULE ORP; (*N. Wirth 1.7.97 / 5.11.2013 Oberon compiler for RISC in Oberon-07*) + IMPORT Texts, Oberon, ORS, ORB, ORG; + (*Author: Niklaus Wirth, 2011. + 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 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)) 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) & (par.class = ORB.Par) & (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); ORG.PrepCall(x, rx); ParamList(x); + IF (x.type.form = ORB.Proc) & (x.type.base.form # ORB.NoTyp) THEN + ORG.Call(x, rx); x.type := x.type.base + ELSE ORS.Mark("not a function") + 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; + + 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); ORG.PrepCall(x, rx); ParamList(x); + IF (x.type.form = ORB.Proc) & (x.type.base.form = ORB.NoTyp) THEN ORG.Call(x, rx) + ELSE ORS.Mark("not a procedure") + 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 + ORS.Mark("bad case var") + END ; + 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("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 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 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; 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 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 type.base := obj.type + ELSE ORS.Mark("no valid base type") + END + END ; + NEW(ptbase); ORS.CopyId(ptbase.name); ptbase.type := type; ptbase.next := pbsList; pbsList := ptbase + ELSE Type(type.base); + IF type.base.form # ORB.Record THEN ORS.Mark("must point to record") END + 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 + IF ptbase.type.base = ORB.intType THEN ptbase.type.base := obj.type ELSE ORS.Mark("recursive record?") END + END ; + ptbase := ptbase.next + END ; + tp.len := dc; + 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); + (*Texts.WriteLn(W); Texts.WriteString(W, procid); Texts.WriteInt(W, ORG.Here(), 7);*) + 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) + 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 THEN + ORB.Export(modid, newSF, key); + IF newSF THEN Texts.WriteLn(W); Texts.WriteString(W, "new symbol file ") END + END ; + IF ORS.errcnt = 0 THEN + ORG.Close(modid, key, exno); Texts.WriteLn(W); Texts.WriteString(W, "compilation done "); + Texts.WriteInt(W, ORG.pc, 6); Texts.WriteInt(W, dc, 6) + ELSE Texts.WriteLn(W); Texts.WriteString(W, "compilation FAILED") + END ; + Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); + 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) + 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 5.11.2013"); + Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); + NEW(dummy); dummy.class := ORB.Var; dummy.type := ORB.intType; + expression := expression0; Type := Type0; FormalType := FormalType0 +END ORP. diff --git a/src/voc07R/ORS.Mod b/src/voc07R/ORS.Mod new file mode 100644 index 00000000..0538de01 --- /dev/null +++ b/src/voc07R/ORS.Mod @@ -0,0 +1,319 @@ +MODULE ORS; (* NW 19.9.93 / 10.10.2013 Scanner in Oberon-07*) + IMPORT SYSTEM, Texts, Oberon; + +(* 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; WS = 4; (*Word size*) + 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; + eof = 70; + + 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) + 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*); maxM = 16777216; (*2^24*) + 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 + h := k*10 + d[i]; + IF h < max THEN k := h ELSE Mark("too large") 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*) h := k*10 + d[i]; + IF h < maxM THEN k := h ELSE Mark("too many digits") END ; + INC(i) + UNTIL i = n; + WHILE (ch >= "0") & (ch <= "9") DO (*fraction*) + h := k*10 + ORD(ch) - 30H; + IF h < maxM THEN k := h ELSE Mark("too many digits*") END ; + DEC(e); Texts.Read(R, ch) + END ; + x := FLT(k); + 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; 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.