Oberon/V2/Compiler
< Oberon
MODULE Compiler; (*NW 7.6.87 / 16.3.91*)
IMPORT Texts, Files, TextFrames, Viewers, Oberon, OCS, OCT, OCC, OCE, OCH;
CONST NofCases = 128; MaxEntry = 64; ModNameLen = 20;
RecDescSize = 8; AdrSize = 4; ProcSize = 4; PtrSize = 4;
XParOrg = 12; LParOrg = 8; LDataSize = 2000H;
(*symbol values*)
times = 1; slash = 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; comma = 19;
colon = 20; upto = 21; rparen = 22; rbrak = 23; rbrace = 24;
of = 25; then = 26; do = 27; to = 28; lparen = 29;
lbrak = 30; lbrace = 31; not = 32; becomes = 33; number = 34;
nil = 35; string = 36; ident = 37; semicolon = 38; bar = 39;
end = 40; else = 41; elsif = 42; until = 43; if = 44;
case = 45; while = 46; repeat = 47; loop = 48; with = 49;
exit = 50; return = 51; array = 52; record = 53; pointer = 54;
begin = 55; const = 56; type = 57; var = 58; procedure = 59;
import = 60; module = 61;
(*object and item modes*)
Var = 1; Ind = 3; Con = 8; Fld = 12; Typ = 13;
LProc = 14; XProc = 15; SProc = 16; CProc = 17; IProc = 18; Mod = 19;
(*structure forms*)
Undef = 0; Pointer = 13; ProcTyp = 14; Array = 15; DynArr = 16; Record = 17;
intSet = {4 .. 6}; labeltyps = {3 .. 6};
VAR W: Texts.Writer;
sym, entno: INTEGER;
newSF: BOOLEAN;
LoopLevel, ExitNo: INTEGER;
LoopExit: ARRAY 16 OF INTEGER;
PROCEDURE^ Type(VAR typ: OCT.Struct);
PROCEDURE^ FormalType(VAR typ: OCT.Struct);
PROCEDURE^ Expression(VAR x: OCT.Item);
PROCEDURE^ Block(VAR dsize: LONGINT);
PROCEDURE CheckSym(s: INTEGER);
BEGIN
IF sym = s THEN OCS.Get(sym) ELSE OCS.Mark(s) END
END CheckSym;
PROCEDURE qualident(VAR x: OCT.Item);
VAR mnolev: INTEGER; obj: OCT.Object;
BEGIN (*sym = ident*)
OCT.Find(obj, mnolev); OCS.Get(sym);
IF (sym = period) & (obj # NIL) & (obj.mode = Mod) THEN
OCS.Get(sym); mnolev := SHORT(-obj.a0);
IF sym = ident THEN
OCT.FindImport(obj, obj); OCS.Get(sym)
ELSE OCS.Mark(10); obj := NIL
END
END ;
x.lev := mnolev; x.obj := obj;
IF obj # NIL THEN
x.mode := obj.mode; x.typ := obj.typ; x.a0 := obj.a0; x.a1 := obj.a1
ELSE OCS.Mark(0); x.mode := Var;
x.typ := OCT.undftyp; x.a0 := 0; x.obj := NIL
END
END qualident;
PROCEDURE ConstExpression(VAR x: OCT.Item);
BEGIN Expression(x);
IF x.mode # Con THEN
OCS.Mark(50); x.mode := Con; x.typ := OCT.inttyp; x.a0 := 1
END
END ConstExpression;
PROCEDURE NewStr(form: INTEGER): OCT.Struct;
VAR typ: OCT.Struct;
BEGIN NEW(typ);
typ.form := form; typ.mno := 0; typ.size := 4; typ.ref := 0;
typ.BaseTyp := OCT.undftyp; typ.strobj := NIL; RETURN typ
END NewStr;
PROCEDURE CheckMark(VAR mk: BOOLEAN);
BEGIN OCS.Get(sym);
IF sym = times THEN
IF OCC.level = 0 THEN mk := TRUE ELSE mk := FALSE; OCS.Mark(47) END ;
OCS.Get(sym)
ELSE mk := FALSE
END
END CheckMark;
PROCEDURE CheckUndefPointerTypes;
VAR obj: OCT.Object;
BEGIN obj := OCT.topScope.next;
WHILE obj # NIL DO
IF obj.mode = Undef THEN OCS.Mark(48) END ;
obj := obj.next
END
END CheckUndefPointerTypes;
PROCEDURE RecordType(VAR typ: OCT.Struct);
VAR adr, size: LONGINT;
fld, fld0, fld1: OCT.Object;
ftyp, btyp: OCT.Struct;
base: OCT.Item;
BEGIN adr := 0; typ := NewStr(Record); typ.BaseTyp := NIL; typ.n := 0;
IF sym = lparen THEN
OCS.Get(sym); (*record extension*)
IF sym = ident THEN
qualident(base);
IF (base.mode = Typ) & (base.typ.form = Record) THEN
typ.BaseTyp := base.typ; typ.n := base.typ.n + 1; adr := base.typ.size
ELSE OCS.Mark(52)
END
ELSE OCS.Mark(10)
END ;
CheckSym(rparen)
END ;
OCT.OpenScope(0); fld := NIL; fld1 := OCT.topScope;
LOOP
IF sym = ident THEN
LOOP
IF sym = ident THEN
IF typ.BaseTyp # NIL THEN
OCT.FindField(typ.BaseTyp, fld0);
IF fld0 # NIL THEN OCS.Mark(1) END
END ;
OCT.Insert(OCS.name, fld); CheckMark(fld.marked); fld.mode := Fld
ELSE OCS.Mark(10)
END ;
IF sym = comma THEN OCS.Get(sym)
ELSIF sym = ident THEN OCS.Mark(19)
ELSE EXIT
END
END ;
CheckSym(colon); Type(ftyp); size := ftyp.size; btyp := ftyp;
WHILE btyp.form = Array DO btyp := btyp.BaseTyp END ;
IF btyp.size >= 4 THEN INC(adr, (-adr) MOD 4)
ELSIF btyp.size = 2 THEN INC(adr, adr MOD 2)
END ;
WHILE fld1.next # NIL DO
fld1 := fld1.next; fld1.typ := ftyp; fld1.a0 := adr; INC(adr, size)
END
END ;
IF sym = semicolon THEN OCS.Get(sym)
ELSIF sym = ident THEN OCS.Mark(38)
ELSE EXIT
END
END ;
typ.size := (-adr) MOD 4 + adr; typ.link := OCT.topScope.next;
CheckUndefPointerTypes; OCT.CloseScope
END RecordType;
PROCEDURE ArrayType(VAR typ: OCT.Struct);
VAR x: OCT.Item; f, n: INTEGER;
BEGIN typ := NewStr(Array); ConstExpression(x); f := x.typ.form;
IF f IN intSet THEN
IF (x.a0 > 0) & (x.a0 <= MAX(INTEGER)) THEN n := SHORT(x.a0)
ELSE n := 1; OCS.Mark(63)
END
ELSE OCS.Mark(51); n := 1
END ;
typ.n := n; OCC.AllocBounds(0, n-1, typ.adr);
IF sym = of THEN
OCS.Get(sym); Type(typ.BaseTyp)
ELSIF sym = comma THEN
OCS.Get(sym); ArrayType(typ.BaseTyp)
ELSE OCS.Mark(34)
END ;
typ.size := n * typ.BaseTyp.size
END ArrayType;
PROCEDURE FormalParameters(VAR resTyp: OCT.Struct; VAR psize: LONGINT);
VAR mode: SHORTINT;
adr, size: LONGINT; res: OCT.Item;
par, par1: OCT.Object; typ: OCT.Struct;
BEGIN par1 := OCT.topScope; adr := 0;
IF (sym = ident) OR (sym = var) THEN
LOOP
IF sym = var THEN OCS.Get(sym); mode := Ind ELSE mode := Var END ;
LOOP
IF sym = ident THEN
OCT.Insert(OCS.name, par); OCS.Get(sym); par.mode := mode
ELSE OCS.Mark(10)
END ;
IF sym = comma THEN OCS.Get(sym)
ELSIF sym = ident THEN OCS.Mark(19)
ELSIF sym = var THEN OCS.Mark(19); OCS.Get(sym)
ELSE EXIT
END
END ;
CheckSym(colon); FormalType(typ);
IF mode = Ind THEN (*VAR param*)
IF typ.form = Record THEN size := RecDescSize
ELSIF typ.form = DynArr THEN size := typ.size
ELSE size := AdrSize
END
ELSE size := (-typ.size) MOD 4 + typ.size
END ;
WHILE par1.next # NIL DO
par1 := par1.next; par1.typ := typ; DEC(adr, size); par1.a0 := adr
END ;
IF sym = semicolon THEN OCS.Get(sym)
ELSIF sym = ident THEN OCS.Mark(38)
ELSE EXIT
END
END
END ;
psize := psize - adr; par := OCT.topScope.next;
WHILE par # NIL DO INC(par.a0, psize); par := par.next END ;
CheckSym(rparen);
IF sym = colon THEN
OCS.Get(sym); resTyp := OCT.undftyp;
IF sym = ident THEN qualident(res);
IF res.mode = Typ THEN
IF res.typ.form <= ProcTyp THEN resTyp := res.typ ELSE OCS.Mark(54) END
ELSE OCS.Mark(52)
END
ELSE OCS.Mark(10)
END
ELSE resTyp := OCT.notyp
END
END FormalParameters;
PROCEDURE ProcType(VAR typ: OCT.Struct);
VAR psize: LONGINT;
BEGIN typ := NewStr(ProcTyp); typ.size := ProcSize;
IF sym = lparen THEN
OCS.Get(sym); OCT.OpenScope(OCC.level); psize := XParOrg;
FormalParameters(typ.BaseTyp, psize); typ.link := OCT.topScope.next;
OCT.CloseScope
ELSE typ.BaseTyp := OCT.notyp; typ.link := NIL
END
END ProcType;
PROCEDURE HasPtr(typ: OCT.Struct): BOOLEAN;
VAR fld: OCT.Object;
BEGIN
IF typ.form = Pointer THEN RETURN TRUE
ELSIF typ.form = Array THEN RETURN HasPtr(typ.BaseTyp)
ELSIF typ.form = Record THEN
IF (typ.BaseTyp # NIL) & HasPtr(typ.BaseTyp) THEN RETURN TRUE END ;
fld := typ.link;
WHILE fld # NIL DO
IF (fld.name = "") OR HasPtr(fld.typ) THEN RETURN TRUE END ;
fld := fld.next
END
END ;
RETURN FALSE
END HasPtr;
PROCEDURE SetPtrBase(ptyp, btyp: OCT.Struct);
BEGIN
IF (btyp.form = Record) OR (btyp.form = Array) & ~HasPtr(btyp.BaseTyp) THEN
ptyp.BaseTyp := btyp
ELSE ptyp.BaseTyp := OCT.undftyp; OCS.Mark(57)
END
END SetPtrBase;
PROCEDURE Type(VAR typ: OCT.Struct);
VAR lev: INTEGER; obj: OCT.Object; x: OCT.Item;
BEGIN typ := OCT.undftyp;
IF sym < lparen THEN OCS.Mark(12);
REPEAT OCS.Get(sym) UNTIL sym >= lparen
END ;
IF sym = ident THEN qualident(x);
IF x.mode = Typ THEN typ := x.typ;
IF typ = OCT.notyp THEN OCS.Mark(58) END
ELSE OCS.Mark(52)
END
ELSIF sym = array THEN
OCS.Get(sym); ArrayType(typ)
ELSIF sym = record THEN
OCS.Get(sym); RecordType(typ); OCC.AllocTypDesc(typ); CheckSym(end)
ELSIF sym = pointer THEN
OCS.Get(sym); typ := NewStr(Pointer); typ.link := NIL; typ.size := PtrSize;
CheckSym(to);
IF sym = ident THEN OCT.Find(obj, lev);
IF obj = NIL THEN (*forward ref*)
OCT.Insert(OCS.name, obj); typ.BaseTyp := OCT.undftyp;
obj.mode := Undef; obj.typ := typ; OCS.Get(sym)
ELSE qualident(x);
IF x.mode = Typ THEN SetPtrBase(typ, x.typ)
ELSE typ.BaseTyp := OCT.undftyp; OCS.Mark(52)
END
END
ELSE Type(x.typ); SetPtrBase(typ, x.typ)
END
ELSIF sym = procedure THEN
OCS.Get(sym); ProcType(typ)
ELSE OCS.Mark(12)
END ;
IF (sym < semicolon) OR (else < sym) THEN OCS.Mark(15);
WHILE (sym < ident) OR (else < sym) & (sym < begin) DO
OCS.Get(sym)
END
END
END Type;
PROCEDURE FormalType(VAR typ: OCT.Struct);
VAR x: OCT.Item; typ0: OCT.Struct; a, s: LONGINT;
BEGIN typ := OCT.undftyp; a := 0;
WHILE sym = array DO
OCS.Get(sym); CheckSym(of); INC(a, 4)
END ;
IF sym = ident THEN qualident(x);
IF x.mode = Typ THEN typ := x.typ;
IF typ = OCT.notyp THEN OCS.Mark(58) END
ELSE OCS.Mark(52)
END
ELSIF sym = procedure THEN OCS.Get(sym); ProcType(typ)
ELSE OCS.Mark(10)
END ;
s := a + 8;
WHILE a > 0 DO
typ0 := NewStr(DynArr); typ0.BaseTyp := typ;
typ0.size := s-a; typ0.adr := typ0.size-4; typ0.mno := 0; typ := typ0; DEC(a, 4)
END
END FormalType;
PROCEDURE selector(VAR x: OCT.Item);
VAR fld: OCT.Object; y: OCT.Item;
BEGIN
LOOP
IF sym = lbrak THEN OCS.Get(sym);
LOOP
IF (x.typ # NIL) & (x.typ.form = Pointer) THEN OCE.DeRef(x) END ;
Expression(y); OCE.Index(x, y);
IF sym = comma THEN OCS.Get(sym) ELSE EXIT END
END ;
CheckSym(rbrak)
ELSIF sym = period THEN OCS.Get(sym);
IF sym = ident THEN
IF x.typ # NIL THEN
IF x.typ.form = Pointer THEN OCE.DeRef(x) END ;
IF x.typ.form = Record THEN
OCT.FindField(x.typ, fld); OCE.Field(x, fld)
ELSE OCS.Mark(53)
END
ELSE OCS.Mark(52)
END ;
OCS.Get(sym)
ELSE OCS.Mark(10)
END
ELSIF sym = arrow THEN
OCS.Get(sym); OCE.DeRef(x)
ELSIF (sym = lparen) & (x.mode < Typ) & (x.typ.form # ProcTyp) THEN
OCS.Get(sym);
IF sym = ident THEN
qualident(y);
IF y.mode = Typ THEN OCE.TypTest(x, y, FALSE)
ELSE OCS.Mark(52)
END
ELSE OCS.Mark(10)
END ;
CheckSym(rparen)
ELSE EXIT
END
END
END selector;
PROCEDURE IsParam(obj: OCT.Object): BOOLEAN;
BEGIN RETURN (obj # NIL) & (obj.mode <= Ind) & (obj.a0 > 0)
END IsParam;
PROCEDURE ActualParameters(VAR x: OCT.Item; fpar: OCT.Object);
VAR apar: OCT.Item; R: SET;
BEGIN
IF sym # rparen THEN
R := OCC.RegSet;
LOOP Expression(apar);
IF IsParam(fpar) THEN
OCH.Param(apar, fpar); fpar := fpar.next
ELSE OCS.Mark(64)
END ;
OCC.FreeRegs(R);
IF sym = comma THEN OCS.Get(sym)
ELSIF (lparen <= sym) & (sym <= ident) THEN OCS.Mark(19)
ELSE EXIT
END
END
END ;
IF IsParam(fpar) THEN OCS.Mark(65) END
END ActualParameters;
PROCEDURE StandProcCall(VAR x: OCT.Item);
VAR y: OCT.Item; m, n: INTEGER;
BEGIN m := SHORT(x.a0); n := 0;
IF sym = lparen THEN OCS.Get(sym);
IF sym # rparen THEN
LOOP
IF n = 0 THEN Expression(x); OCE.StPar1(x, m); n := 1
ELSIF n = 1 THEN Expression(y); OCE.StPar2(x, y, m); n := 2
ELSIF n = 2 THEN Expression(y); OCE.StPar3(x, y, m); n := 3
ELSE OCS.Mark(64); Expression(y)
END ;
IF sym = comma THEN OCS.Get(sym)
ELSIF (lparen <= sym) & (sym <= ident) THEN OCS.Mark(19)
ELSE EXIT
END
END ;
CheckSym(rparen)
ELSE OCS.Get(sym)
END ;
OCE.StFct(x, m, n)
ELSE OCS.Mark(29)
END
END StandProcCall;
PROCEDURE Element(VAR x: OCT.Item);
VAR e1, e2: OCT.Item;
BEGIN Expression(e1);
IF sym = upto THEN
OCS.Get(sym); Expression(e2); OCE.Set1(x, e1, e2)
ELSE OCE.Set0(x, e1)
END ;
END Element;
PROCEDURE Sets(VAR x: OCT.Item);
VAR y: OCT.Item;
BEGIN x.typ := OCT.settyp; y.typ := OCT.settyp;
IF sym # rbrace THEN
Element(x);
LOOP
IF sym = comma THEN OCS.Get(sym)
ELSIF (lparen <= sym) & (sym <= ident) THEN OCS.Mark(19)
ELSE EXIT
END ;
Element(y); OCE.Op(plus, x, y) (*x := x+y*)
END
ELSE x.mode := Con; x.a0 := 0
END ;
CheckSym(rbrace)
END Sets;
PROCEDURE Factor(VAR x: OCT.Item);
VAR fpar: OCT.Object; gR, fR: SET;
BEGIN
IF sym < lparen THEN OCS.Mark(13);
REPEAT OCS.Get(sym) UNTIL sym >= lparen
END ;
IF sym = ident THEN
qualident(x); selector(x);
IF x.mode = SProc THEN StandProcCall(x)
ELSIF sym = lparen THEN
OCS.Get(sym); OCH.PrepCall(x, fpar);
OCC.SaveRegisters(gR, fR, x); ActualParameters(x, fpar);
OCH.Call(x); OCC.RestoreRegisters(gR, fR, x);
CheckSym(rparen)
END
ELSIF sym = number THEN
OCS.Get(sym); x.mode := Con;
CASE OCS.numtyp OF
1: x.typ := OCT.chartyp; x.a0 := OCS.intval
| 2: x.a0 := OCS.intval; OCE.SetIntType(x)
| 3: x.typ := OCT.realtyp; OCE.AssReal(x, OCS.realval)
| 4: x.typ := OCT.lrltyp; OCE.AssLReal(x, OCS.lrlval)
END
ELSIF sym = string THEN
x.typ := OCT.stringtyp; x.mode := Con;
OCC.AllocString(OCS.name, x); OCS.Get(sym)
ELSIF sym = nil THEN
OCS.Get(sym); x.typ := OCT.niltyp; x.mode := Con; x.a0 := 0
ELSIF sym = lparen THEN
OCS.Get(sym); Expression(x); CheckSym(rparen)
ELSIF sym = lbrak THEN
OCS.Get(sym); OCS.Mark(29); Expression(x); CheckSym(rparen)
ELSIF sym = lbrace THEN OCS.Get(sym); Sets(x)
ELSIF sym = not THEN
OCS.Get(sym); Factor(x); OCE.MOp(not, x)
ELSE OCS.Mark(13); OCS.Get(sym); x.typ := OCT.undftyp; x.mode := Var; x.a0 := 0
END
END Factor;
PROCEDURE Term(VAR x: OCT.Item);
VAR y: OCT.Item; mulop: INTEGER;
BEGIN Factor(x);
WHILE (times <= sym) & (sym <= and) DO
mulop := sym; OCS.Get(sym);
IF mulop = and THEN OCE.MOp(and, x) END ;
Factor(y); OCE.Op(mulop, x, y)
END
END Term;
PROCEDURE SimpleExpression(VAR x: OCT.Item);
VAR y: OCT.Item; addop: INTEGER;
BEGIN
IF sym = minus THEN OCS.Get(sym); Term(x); OCE.MOp(minus, x)
ELSIF sym = plus THEN OCS.Get(sym); Term(x); OCE.MOp(plus, x)
ELSE Term(x)
END ;
WHILE (plus <= sym) & (sym <= or) DO
addop := sym; OCS.Get(sym);
IF addop = or THEN OCE.MOp(or, x) END ;
Term(y); OCE.Op(addop, x, y)
END
END SimpleExpression;
PROCEDURE Expression(VAR x: OCT.Item);
VAR y: OCT.Item; relation: INTEGER;
BEGIN SimpleExpression(x);
IF (eql <= sym) & (sym <= geq) THEN
relation := sym; OCS.Get(sym);
IF x.typ = OCT.booltyp THEN OCE.MOp(relation, x) END ;
SimpleExpression(y); OCE.Op(relation, x, y)
ELSIF sym = in THEN
OCS.Get(sym); SimpleExpression(y); OCE.In(x, y)
ELSIF sym = is THEN
IF x.mode >= Typ THEN OCS.Mark(112) END ;
OCS.Get(sym);
IF sym = ident THEN
qualident(y);
IF y.mode = Typ THEN OCE.TypTest(x, y, TRUE) ELSE OCS.Mark(52) END
ELSE OCS.Mark(10)
END
END
END Expression;
PROCEDURE ProcedureDeclaration;
VAR proc, proc1, par: OCT.Object;
L1: INTEGER;
mode: SHORTINT; body: BOOLEAN;
psize, dsize: LONGINT;
BEGIN dsize := 0; proc := NIL; body := TRUE;
IF (sym # ident) & (OCC.level = 0) THEN
IF sym = times THEN mode := XProc
ELSIF sym = arrow THEN (*forward*) mode := XProc; body := FALSE
ELSIF sym = plus THEN mode := IProc
ELSIF sym = minus THEN mode := CProc; body := FALSE
ELSE mode := LProc; OCS.Mark(10)
END ;
OCS.Get(sym)
ELSE mode := LProc
END ;
IF sym = ident THEN
IF OCC.level = 0 THEN OCT.Find(proc1, L1) ELSE proc1 := NIL END;
IF (proc1 # NIL) & (proc1.mode = XProc)&(OCC.Entry(SHORT(proc1.a0)) = 0) THEN
(*there exists a corresponding forward declaration*)
IF mode = LProc THEN mode := XProc END ;
NEW(proc); CheckMark(proc.marked)
ELSE
IF proc1 # NIL THEN OCS.Mark(1); proc1 := NIL END ;
OCT.Insert(OCS.name, proc); CheckMark(proc.marked);
IF proc.marked & (mode = LProc) THEN mode := XProc END ;
IF mode = LProc THEN proc.a0 := OCC.pc
ELSIF mode # CProc THEN
IF entno < MaxEntry THEN proc.a0 := entno; INC(entno)
ELSE proc.a0 := 1; OCS.Mark(226)
END
END
END ;
proc.mode := mode; proc.typ := OCT.notyp; proc.dsc := NIL; proc.a1 := 0;
INC(OCC.level); OCT.OpenScope(OCC.level);
IF (mode = LProc) & (OCC.level = 1) THEN psize := LParOrg
ELSE psize := XParOrg
END ;
IF sym = lparen THEN
OCS.Get(sym); FormalParameters(proc.typ, psize); proc.dsc := OCT.topScope.next
END ;
IF proc1 # NIL THEN (*forward*)
OCH.CompareParLists(proc.dsc, proc1.dsc);
IF proc.typ # proc1.typ THEN OCS.Mark(118) END ;
proc := proc1; proc.dsc := OCT.topScope.next
END ;
IF mode = CProc THEN
IF sym = number THEN proc.a0 := OCS.intval; OCS.Get(sym)
ELSE OCS.Mark(17)
END
END ;
IF body THEN
CheckSym(semicolon); OCT.topScope.typ := proc.typ;
OCT.topScope.a1 := mode*10000H + psize; (*for RETURN statements*)
OCH.Enter(mode, proc.a0, L1); par := proc.dsc;
WHILE par # NIL DO
(*code for dynamic array value parameters*)
IF (par.typ.form = DynArr) & (par.mode = Var) THEN
OCH.CopyDynArray(par.a0, par.typ)
END ;
par := par.next
END ;
Block(dsize); proc.dsc := OCT.topScope.next; (*update*)
IF proc.typ = OCT.notyp THEN OCH.Return(proc.mode, psize)
ELSE OCH.Trap(17)
END ;
IF dsize >= LDataSize THEN OCS.Mark(209); dsize := 0 END ;
OCC.FixupWith(L1, dsize); proc.a2 := OCC.pc;
IF sym = ident THEN
IF OCS.name # proc.name THEN OCS.Mark(4) END ;
OCS.Get(sym)
ELSE OCS.Mark(10)
END
END ;
DEC(OCC.level); OCT.CloseScope
END
END ProcedureDeclaration;
PROCEDURE CaseLabelList(LabelForm: INTEGER;
VAR n: INTEGER; VAR tab: ARRAY OF OCH.LabelRange);
VAR x, y: OCT.Item; i, f: INTEGER;
BEGIN
IF ~(LabelForm IN labeltyps) THEN OCS.Mark(61) END ;
LOOP ConstExpression(x); f := x.typ.form;
IF f IN intSet THEN
IF LabelForm < f THEN OCS.Mark(60) END
ELSIF f # LabelForm THEN OCS.Mark(60)
END ;
IF sym = upto THEN
OCS.Get(sym); ConstExpression(y);
IF (y.typ.form # f) & ~((f IN intSet) & (y.typ.form IN intSet)) THEN OCS.Mark(60)
END ;
IF y.a0 < x.a0 THEN OCS.Mark(63); y.a0 := x.a0 END
ELSE y := x
END ;
(*enter label range into ordered table*) i := n;
IF i < NofCases THEN
LOOP
IF i = 0 THEN EXIT END ;
IF tab[i-1].low <= y.a0 THEN
IF tab[i-1].high >= x.a0 THEN OCS.Mark(62) END ;
EXIT
END ;
tab[i] := tab[i-1]; DEC(i)
END ;
tab[i].low := SHORT(x.a0); tab[i].high := SHORT(y.a0);
tab[i].label := OCC.pc; INC(n)
ELSE OCS.Mark(213)
END ;
IF sym = comma THEN OCS.Get(sym)
ELSIF (sym = number) OR (sym = ident) THEN OCS.Mark(19)
ELSE EXIT
END
END
END CaseLabelList;
PROCEDURE StatSeq;
VAR fpar: OCT.Object; xtyp: OCT.Struct;
x, y: OCT.Item; L0, L1, ExitIndex: INTEGER;
PROCEDURE CasePart;
VAR x: OCT.Item; n, L0, L1, L2, L3: INTEGER;
tab: ARRAY NofCases OF OCH.LabelRange;
BEGIN n := 0; L3 := 0;
Expression(x); OCH.CaseIn(x, L0, L1); OCC.FreeRegs({});
CheckSym(of);
LOOP
IF sym < bar THEN
CaseLabelList(x.typ.form, n, tab);
CheckSym(colon); StatSeq; OCH.FJ(L3)
END ;
IF sym = bar THEN OCS.Get(sym) ELSE EXIT END
END ;
L2 := OCC.pc;
IF sym = else THEN
OCS.Get(sym); StatSeq; OCH.FJ(L3)
ELSE OCH.Trap(16)
END ;
OCH.CaseOut(L0, L1, L2, L3, n, tab)
END CasePart;
BEGIN
LOOP
IF sym < ident THEN OCS.Mark(14);
REPEAT OCS.Get(sym) UNTIL sym >= ident
END ;
IF sym = ident THEN
qualident(x); selector(x);
IF sym = becomes THEN
OCS.Get(sym); Expression(y); OCH.Assign(x, y, FALSE)
ELSIF sym = eql THEN
OCS.Mark(33); OCS.Get(sym); Expression(y); OCH.Assign(x, y, FALSE)
ELSIF x.mode = SProc THEN
StandProcCall(x);
IF x.typ # OCT.notyp THEN OCS.Mark(55) END
ELSE OCH.PrepCall(x, fpar);
IF sym = lparen THEN
OCS.Get(sym); ActualParameters(x, fpar); CheckSym(rparen)
ELSIF IsParam(fpar) THEN OCS.Mark(65)
END ;
OCH.Call(x);
IF x.typ # OCT.notyp THEN OCS.Mark(55) END
END
ELSIF sym = if THEN
OCS.Get(sym); Expression(x); OCH.CFJ(x, L0); OCC.FreeRegs({});
CheckSym(then); StatSeq; L1 := 0;
WHILE sym = elsif DO
OCS.Get(sym); OCH.FJ(L1); OCC.FixLink(L0);
Expression(x); OCH.CFJ(x, L0); OCC.FreeRegs({});
CheckSym(then); StatSeq
END ;
IF sym = else THEN
OCS.Get(sym); OCH.FJ(L1); OCC.FixLink(L0); StatSeq
ELSE OCC.FixLink(L0)
END ;
OCC.FixLink(L1); CheckSym(end)
ELSIF sym = case THEN
OCS.Get(sym); CasePart; CheckSym(end)
ELSIF sym = while THEN
OCS.Get(sym); L1 := OCC.pc;
Expression(x); OCH.CFJ(x, L0); OCC.FreeRegs({});
CheckSym(do); StatSeq; OCH.BJ(L1); OCC.FixLink(L0);
CheckSym(end)
ELSIF sym = repeat THEN
OCS.Get(sym); L0 := OCC.pc; StatSeq;
IF sym = until THEN
OCS.Get(sym); Expression(x); OCH.CBJ(x, L0)
ELSE OCS.Mark(43)
END
ELSIF sym = loop THEN
OCS.Get(sym); ExitIndex := ExitNo; INC(LoopLevel);
L0 := OCC.pc; StatSeq; OCH.BJ(L0); DEC(LoopLevel);
WHILE ExitNo > ExitIndex DO
DEC(ExitNo); OCC.fixup(LoopExit[ExitNo])
END ;
CheckSym(end)
ELSIF sym = with THEN
OCS.Get(sym); x.obj := NIL; xtyp := NIL;
IF sym = ident THEN
qualident(x); CheckSym(colon);
IF sym = ident THEN qualident(y);
IF y.mode = Typ THEN
IF x.obj # NIL THEN
xtyp := x.typ; OCE.TypTest(x, y, FALSE); x.obj.typ := x.typ
ELSE OCS.Mark(130)
END
ELSE OCS.Mark(52)
END
ELSE OCS.Mark(10)
END
ELSE OCS.Mark(10)
END ;
CheckSym(do); OCC.FreeRegs({}); StatSeq; CheckSym(end);
IF xtyp# NIL THEN x.obj.typ := xtyp END
ELSIF sym = exit THEN
OCS.Get(sym); OCH.FJ(L0);
IF LoopLevel = 0 THEN OCS.Mark(45)
ELSIF ExitNo < 16 THEN LoopExit[ExitNo] := L0; INC(ExitNo)
ELSE OCS.Mark(214)
END
ELSIF sym = return THEN OCS.Get(sym);
IF OCC.level > 0 THEN
IF sym < semicolon THEN
Expression(x); OCH.Result(x, OCT.topScope.typ)
ELSIF OCT.topScope.typ # OCT.notyp THEN OCS.Mark(124)
END ;
OCH.Return(SHORT(OCT.topScope.a1 DIV 10000H), SHORT(OCT.topScope.a1))
ELSE (*return from module body*)
IF sym < semicolon THEN Expression(x); OCS.Mark(124) END ;
OCH.Return(XProc, XParOrg)
END
END ;
OCC.FreeRegs({});
IF sym = semicolon THEN OCS.Get(sym)
ELSIF (sym <= ident) OR (if <= sym) & (sym <= return) THEN OCS.Mark(38)
ELSE EXIT
END
END
END StatSeq;
PROCEDURE Block(VAR dsize: LONGINT);
VAR typ, forward: OCT.Struct;
obj, first: OCT.Object;
x: OCT.Item;
L0: INTEGER;
adr, size: LONGINT;
mk: BOOLEAN;
id0: ARRAY 32 OF CHAR;
BEGIN adr := -dsize; obj := OCT.topScope;
WHILE obj.next # NIL DO obj := obj.next END ;
LOOP
IF sym = const THEN
OCS.Get(sym);
WHILE sym = ident DO
COPY(OCS.name, id0); CheckMark(mk);
IF sym = eql THEN OCS.Get(sym); ConstExpression(x)
ELSIF sym = becomes THEN OCS.Mark(9); OCS.Get(sym); ConstExpression(x)
ELSE OCS.Mark(9)
END ;
OCT.Insert(id0, obj); obj.mode := SHORT(x.mode);
obj.typ := x.typ; obj.a0 := x.a0; obj.a1 := x.a1; obj.marked := mk;
CheckSym(semicolon)
END
END ;
IF sym = type THEN
OCS.Get(sym);
WHILE sym = ident DO
typ := OCT.undftyp; OCT.Insert(OCS.name, obj); forward := obj.typ;
obj.mode := Typ; obj.typ := OCT.notyp; CheckMark(obj.marked);
IF sym = eql THEN OCS.Get(sym); Type(typ)
ELSIF (sym = becomes) OR (sym = colon) THEN
OCS.Mark(9); OCS.Get(sym); Type(typ)
ELSE OCS.Mark(9)
END ;
obj.typ := typ;
IF typ.strobj = NIL THEN typ.strobj := obj END ;
IF forward # NIL THEN (*fixup*) SetPtrBase(forward, typ) END ;
CheckSym(semicolon)
END
END ;
IF sym = var THEN
OCS.Get(sym);
WHILE sym = ident DO
OCT.Insert(OCS.name, obj); first := obj; CheckMark(obj.marked); obj.mode := Var;
LOOP
IF sym = comma THEN OCS.Get(sym)
ELSIF sym = ident THEN OCS.Mark(19)
ELSE EXIT
END ;
IF sym = ident THEN
OCT.Insert(OCS.name, obj); CheckMark(obj.marked); obj.mode := Var
ELSE OCS.Mark(10)
END
END ;
CheckSym(colon); Type(typ); size := typ.size;
IF size >= 4 THEN DEC(adr, adr MOD 4)
ELSIF size = 2 THEN DEC(adr, adr MOD 2)
END ;
WHILE first # NIL DO
first.typ := typ; DEC(adr, size); first.a0 := adr; first := first.next
END ;
CheckSym(semicolon)
END
END ;
IF (sym < const) OR (sym > var) THEN EXIT END ;
END ;
CheckUndefPointerTypes;
IF OCC.level = 0 THEN OCH.LFJ(L0) ELSE OCH.FJ(L0) END ;
WHILE sym = procedure DO
OCS.Get(sym); ProcedureDeclaration; CheckSym(semicolon)
END ;
IF OCC.level = 0 THEN OCC.fixupL(L0); OCC.InitTypDescs
ELSE OCC.fixupC(L0)
END ;
IF sym = begin THEN OCS.Get(sym); StatSeq END ;
dsize := (adr MOD 4) - adr; CheckSym(end)
END Block;
PROCEDURE CompilationUnit(source: Texts.Text; pos: LONGINT);
VAR L0: INTEGER; ch: CHAR;
time, date, key, dsize: LONGINT;
modid, impid, FName: ARRAY 32 OF CHAR;
PROCEDURE MakeFileName(VAR name, FName: ARRAY OF CHAR;
ext: ARRAY OF CHAR);
VAR i, j: INTEGER; ch: CHAR;
BEGIN i := 0;
LOOP ch := name[i];
IF ch = 0X THEN EXIT END ;
FName[i] := ch; INC(i)
END ;
j := 0;
REPEAT ch := ext[j]; FName[i] := ch; INC(i); INC(j)
UNTIL ch = 0X
END MakeFileName;
BEGIN entno := 1; dsize := 0; LoopLevel := 0; ExitNo := 0;
OCC.Init; OCT.Init; OCS.Init(source, pos); OCS.Get(sym);
Texts.WriteString(W, " compiling ");
IF sym = module THEN OCS.Get(sym) ELSE OCS.Mark(16) END ;
IF sym = ident THEN
Texts.WriteString(W, OCS.name); Texts.Append(Oberon.Log, W.buf);
L0 := 0; ch := OCS.name[0];
WHILE (ch # 0X) & (L0 < ModNameLen-1) DO
modid[L0] := ch; INC(L0); ch := OCS.name[L0]
END ;
modid[L0] := 0X;
IF ch # 0X THEN OCS.Mark(228) END ;
OCT.OpenScope(0); OCS.Get(sym);
CheckSym(semicolon); OCH.Enter(Mod, 0, L0);
IF sym = import THEN
OCS.Get(sym);
LOOP
IF sym = ident THEN
COPY(OCS.name, impid); OCS.Get(sym);
MakeFileName(impid, FName, ".Sym");
IF sym = becomes THEN OCS.Get(sym);
IF sym = ident THEN
MakeFileName(OCS.name, FName, ".Sym"); OCS.Get(sym)
ELSE OCS.Mark(10)
END
END ;
OCT.Import(impid, modid, FName)
ELSE OCS.Mark(10)
END ;
IF sym = comma THEN OCS.Get(sym)
ELSIF sym = ident THEN OCS.Mark(19)
ELSE EXIT
END
END ;
CheckSym(semicolon)
END ;
IF ~OCS.scanerr THEN
OCC.SetLinkTable(OCT.nofGmod+1);
Block(dsize); OCH.Return(XProc, 12);
IF sym = ident THEN
IF OCS.name # modid THEN OCS.Mark(4) END ;
OCS.Get(sym)
ELSE OCS.Mark(10)
END ;
IF sym # period THEN OCS.Mark(18) END ;
IF ~OCS.scanerr THEN
Oberon.GetClock(time, date); key := (date MOD 4000H) * 20000H + time;
MakeFileName(modid, FName, ".Sym");
OCT.Export(modid, FName, newSF, key);
IF newSF THEN Texts.WriteString(W, " new symbol file") END ;
IF ~OCS.scanerr THEN
MakeFileName(modid, FName, ".Obj");
OCC.OutCode(FName, modid, key, entno, dsize);
Texts.WriteInt(W, OCC.pc, 6); Texts.WriteInt(W, dsize, 6)
END
END
END ;
OCT.CloseScope
ELSE OCS.Mark(10)
END;
OCC.Close; OCT.Close;
Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
END CompilationUnit;
PROCEDURE Compile*;
VAR beg, end, time: LONGINT;
T: Texts.Text;
S: Texts.Scanner;
v: Viewers.Viewer;
PROCEDURE Options;
VAR ch: CHAR;
BEGIN
IF S.nextCh = "/" THEN
LOOP Texts.Read(S, ch);
IF ch = "x" THEN OCE.inxchk := FALSE
ELSIF ch = "t" THEN OCC.typchk := FALSE
ELSIF ch = "s" THEN newSF := TRUE
ELSE S.nextCh := ch; EXIT
END
END
END
END Options;
BEGIN OCE.inxchk := TRUE; OCC.typchk := TRUE; newSF := FALSE;
Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
IF S.class = Texts.Char THEN
IF S.c = "*" THEN
v := Oberon.MarkedViewer();
IF (v.dsc # NIL) & (v.dsc.next IS TextFrames.Frame) THEN
Options; CompilationUnit(v.dsc.next(TextFrames.Frame).text, 0)
END
ELSIF S.c = "^" THEN
Oberon.GetSelection(T, beg, end, time);
IF time >= 0 THEN
Texts.OpenScanner(S, T, beg); Texts.Scan(S);
IF S.class = Texts.Name THEN
Options; Texts.WriteString(W, S.s); NEW(T); Texts.Open(T, S.s);
IF T.len # 0 THEN CompilationUnit(T, 0)
ELSE Texts.WriteString(W, " not found");
Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
END
END
END
ELSIF S.c = "@" THEN
Oberon.GetSelection(T, beg, end, time);
IF time >= 0 THEN Options; CompilationUnit(T, beg) END
END
ELSE NEW(T);
WHILE S.class = Texts.Name DO
Options; Texts.WriteString(W, S.s); Texts.Open(T, S.s);
IF T.len # 0 THEN CompilationUnit(T, 0)
ELSE Texts.WriteString(W, " not found");
Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
END ;
Texts.Scan(S)
END
END ;
Oberon.Collect(0)
END Compile;
BEGIN Texts.OpenWriter(W);
Texts.WriteString(W, "Compiler NW 1.8.91"); Texts.WriteLn(W);
Texts.Append(Oberon.Log, W.buf)
END Compiler.