vishapoberon/compiler
1
0
Fork 0
mirror of https://github.com/vishapoberon/compiler.git synced 2026-04-05 23:22:25 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

Project Oberon 2013 edition compiler source added

Browse source
This commit is contained in:
Norayr Chilingarian 2014-01-24 17:11:12 +04:00
parent eace02450d
commit cf06850388
5 changed files with 3061 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

437
src/voc07R/ORB.Mod Normal file
View file

@ -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.

206
src/voc07R/ORC.Mod Normal file
View file

@ -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.

1125
src/voc07R/ORG.Mod Normal file
View file

File diff suppressed because it is too large Load diff

974
src/voc07R/ORP.Mod Normal file
View file

@ -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.

319
src/voc07R/ORS.Mod Normal file
View file

@ -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.