MODULE DevCPP;
(**
project = "BlackBox"
organization = "www.oberon.ch"
contributors = "Oberon microsystems"
version = "System/Rsrc/About"
copyright = "System/Rsrc/About"
license = "Docu/BB-License"
references = "ftp://ftp.inf.ethz.ch/pub/software/Oberon/OberonV4/Docu/OP2.Paper.ps"
changes = ""
issues = ""
**)
IMPORT
DevCPM, DevCPT, DevCPB, DevCPS;
CONST
anchorVarPar = TRUE;
(* numtyp values *)
char = 1; integer = 2; real = 4; int64 = 5; real32 = 6; real64 = 7;
(*symbol values*)
null = 0; 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; dollar = 18; period = 19;
comma = 20; colon = 21; upto = 22; rparen = 23; rbrak = 24;
rbrace = 25; of = 26; then = 27; do = 28; to = 29;
by = 30; not = 33;
lparen = 40; lbrak = 41; lbrace = 42; becomes = 44;
number = 45; nil = 46; string = 47; ident = 48; semicolon = 49;
bar = 50; end = 51; else = 52; elsif = 53; until = 54;
if = 55; case = 56; while = 57; repeat = 58; for = 59;
loop = 60; with = 61; exit = 62; return = 63; array = 64;
record = 65; pointer = 66; begin = 67; const = 68; type = 69;
var = 70; out = 71; procedure = 72; close = 73; import = 74;
module = 75; eof = 76;
(* object modes *)
Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7;
SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13; Attr = 20;
(* Structure forms *)
Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6;
Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12;
Pointer = 13; ProcTyp = 14; Comp = 15;
Char16 = 16; String16 = 17; Int64 = 18;
intSet = {Int8..Int32, Int64}; charSet = {Char8, Char16};
(* composite structure forms *)
Basic = 1; Array = 2; DynArr = 3; Record = 4;
(*function number*)
haltfn = 0; newfn = 1; incfn = 13; sysnewfn = 30;
(* nodes classes *)
Nvar = 0; Nvarpar = 1; Nfield = 2; Nderef = 3; Nindex = 4; Nguard = 5; Neguard = 6;
Nconst = 7; Ntype = 8; Nproc = 9; Nupto = 10; Nmop = 11; Ndop = 12; Ncall = 13;
Ninittd = 14; Nif = 15; Ncaselse = 16; Ncasedo = 17; Nenter = 18; Nassign = 19;
Nifelse = 20; Ncase = 21; Nwhile = 22; Nrepeat = 23; Nloop = 24; Nexit = 25;
Nreturn = 26; Nwith = 27; Ntrap = 28; Ncomp = 30;
(* node subclasses *)
super = 1;
(* module visibility of objects *)
internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4;
(* procedure flags (conval.setval) *)
hasBody = 1; isRedef = 2; slNeeded = 3; imVar = 4;
(* attribute flags (attr.adr, struct.attribute, proc.conval.setval)*)
newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20;
(* case statement flags (conval.setval) *)
useTable = 1; useTree = 2;
(* sysflags *)
nilBit = 1; inBit = 2; outBit = 4; newBit = 8; iidBit = 16; interface = 10; som = 20; jstr = -13;
TYPE
Elem = POINTER TO RECORD
next: Elem;
struct: DevCPT.Struct;
obj, base: DevCPT.Object;
pos: INTEGER;
name: DevCPT.String
END;
VAR
sym, level: BYTE;
LoopLevel: SHORTINT;
TDinit, lastTDinit: DevCPT.Node;
userList: Elem;
recList: Elem;
hasReturn: BOOLEAN;
numUsafeVarPar, numFuncVarPar: INTEGER;
PROCEDURE^ Type(VAR typ: DevCPT.Struct; VAR name: DevCPT.String);
PROCEDURE^ Expression(VAR x: DevCPT.Node);
PROCEDURE^ Block(VAR procdec, statseq: DevCPT.Node);
(* forward type handling *)
PROCEDURE IncompleteType (typ: DevCPT.Struct): BOOLEAN;
BEGIN
IF typ.form = Pointer THEN typ := typ.BaseTyp END;
RETURN (typ = DevCPT.undftyp) OR (typ.comp = Record) & (typ.BaseTyp = DevCPT.undftyp)
END IncompleteType;
PROCEDURE SetType (struct: DevCPT.Struct; obj: DevCPT.Object; typ: DevCPT.Struct; name: DevCPT.String);
VAR u: Elem;
BEGIN
IF obj # NIL THEN obj.typ := typ ELSE struct.BaseTyp := typ END;
IF name # NIL THEN
NEW(u); u.struct := struct; u.obj := obj; u.pos := DevCPM.errpos; u.name := name;
u.next := userList; userList := u
END
END SetType;
PROCEDURE CheckAlloc (VAR typ: DevCPT.Struct; dynAllowed: BOOLEAN; pos: INTEGER);
BEGIN
typ.pvused := TRUE;
IF typ.comp = DynArr THEN
IF ~dynAllowed THEN DevCPM.Mark(88, pos); typ := DevCPT.undftyp END
ELSIF typ.comp = Record THEN
IF (typ.attribute = absAttr) OR (typ.attribute = limAttr) & (typ.mno # 0) THEN
DevCPM.Mark(193, pos); typ := DevCPT.undftyp
END
END
END CheckAlloc;
PROCEDURE CheckRecursiveType (outer, inner: DevCPT.Struct; pos: INTEGER);
VAR fld: DevCPT.Object;
BEGIN
IF outer = inner THEN DevCPM.Mark(58, pos)
ELSIF inner.comp IN {Array, DynArr} THEN CheckRecursiveType(outer, inner.BaseTyp, pos)
ELSIF inner.comp = Record THEN
fld := inner.link;
WHILE (fld # NIL) & (fld.mode = Fld) DO
CheckRecursiveType(outer, fld.typ, pos);
fld := fld.link
END;
IF inner.BaseTyp # NIL THEN CheckRecursiveType(outer, inner.BaseTyp, pos) END
END
END CheckRecursiveType;
PROCEDURE FixType (struct: DevCPT.Struct; obj: DevCPT.Object; typ: DevCPT.Struct; pos: INTEGER);
(* fix forward reference *)
VAR t: DevCPT.Struct; f, bf: DevCPT.Object; i: SHORTINT;
BEGIN
IF obj # NIL THEN
IF obj.mode = Var THEN (* variable type *)
IF struct # NIL THEN (* receiver type *)
IF (typ.form # Pointer) OR (typ.BaseTyp # struct) THEN DevCPM.Mark(180, pos) END;
ELSE CheckAlloc(typ, obj.mnolev > level, pos) (* TRUE for parameters *)
END
ELSIF obj.mode = VarPar THEN (* varpar type *)
IF struct # NIL THEN (* varpar receiver type *)
IF typ # struct THEN DevCPM.Mark(180, pos) END
END
ELSIF obj.mode = Fld THEN (* field type *)
CheckAlloc(typ, FALSE, pos);
CheckRecursiveType(struct, typ, pos)
ELSIF obj.mode = TProc THEN (* proc return type *)
IF typ.form = Comp THEN typ := DevCPT.undftyp; DevCPM.Mark(54, pos) END
ELSIF obj.mode = Typ THEN (* alias type *)
IF typ.form IN {Byte..Set, Char16, Int64} THEN (* make alias structure *)
t := DevCPT.NewStr(typ.form, Basic); i := t.ref;
t^ := typ^; t.ref := i; t.strobj := obj; t.mno := 0;
t.BaseTyp := typ; typ := t
END;
IF obj.vis # internal THEN
IF typ.comp = Record THEN typ.exp := TRUE
ELSIF typ.form = Pointer THEN typ.BaseTyp.exp := TRUE
END
END
ELSE HALT(100)
END;
obj.typ := typ
ELSE
IF struct.form = Pointer THEN (* pointer base type *)
IF typ.comp = Record THEN DevCPM.PropagateRecPtrSysFlag(typ.sysflag, struct.sysflag)
ELSIF typ.comp IN {Array, DynArr} THEN DevCPM.PropagateArrPtrSysFlag(typ.sysflag, struct.sysflag)
ELSE typ := DevCPT.undftyp; DevCPM.Mark(57, pos)
END;
struct.untagged := struct.sysflag > 0;
IF (struct.strobj # NIL) & (struct.strobj.vis # internal) THEN typ.exp := TRUE END;
ELSIF struct.comp = Array THEN (* array base type *)
CheckAlloc(typ, FALSE, pos);
CheckRecursiveType(struct, typ, pos)
ELSIF struct.comp = DynArr THEN (* array base type *)
CheckAlloc(typ, TRUE, pos);
CheckRecursiveType(struct, typ, pos)
ELSIF struct.comp = Record THEN (* record base type *)
IF typ.form = Pointer THEN typ := typ.BaseTyp END;
typ.pvused := TRUE; struct.extlev := SHORT(SHORT(typ.extlev + 1));
DevCPM.PropagateRecordSysFlag(typ.sysflag, struct.sysflag);
IF (typ.attribute = 0) OR (typ.attribute = limAttr) & (typ.mno # 0) THEN DevCPM.Mark(181, pos)
ELSIF (struct.attribute = absAttr) & (typ.attribute # absAttr) THEN DevCPM.Mark(191, pos)
ELSIF (typ.attribute = limAttr) & (struct.attribute # limAttr) THEN DevCPM.Mark(197, pos)
END;
f := struct.link;
WHILE f # NIL DO (* check for field name conflicts *)
DevCPT.FindField(f.name, typ, bf);
IF bf # NIL THEN DevCPM.Mark(1, pos) END;
f := f.link
END;
CheckRecursiveType(struct, typ, pos);
struct.untagged := struct.sysflag > 0;
ELSIF struct.form = ProcTyp THEN (* proc type return type *)
IF typ.form = Comp THEN typ := DevCPT.undftyp; DevCPM.Mark(54, pos) END;
ELSE HALT(100)
END;
struct.BaseTyp := typ
END
END FixType;
PROCEDURE CheckForwardTypes;
VAR u, next: Elem; progress: BOOLEAN;
BEGIN
u := userList; userList := NIL;
WHILE u # NIL DO
next := u.next; DevCPS.name := u.name^$; DevCPT.Find(DevCPS.name, u.base);
IF u.base = NIL THEN DevCPM.Mark(0, u.pos)
ELSIF u.base.mode # Typ THEN DevCPM.Mark(72, u.pos)
ELSE u.next := userList; userList := u (* reinsert *)
END;
u := next
END;
REPEAT (* iteration for multy level alias *)
u := userList; userList := NIL; progress := FALSE;
WHILE u # NIL DO
next := u.next;
IF IncompleteType(u.base.typ) THEN
u.next := userList; userList := u (* reinsert *)
ELSE
progress := TRUE;
FixType(u.struct, u.obj, u.base.typ, u.pos)
END;
u := next
END
UNTIL (userList = NIL) OR ~progress;
u := userList; (* remaining type relations are cyclic *)
WHILE u # NIL DO
IF (u.obj = NIL) OR (u.obj.mode = Typ) THEN DevCPM.Mark(58, u.pos) END;
u := u.next
END;
END CheckForwardTypes;
PROCEDURE CheckUnimpl (m: DevCPT.Object; typ: DevCPT.Struct; pos: INTEGER);
VAR obj: DevCPT.Object;
BEGIN
IF m # NIL THEN
IF (m.mode = TProc) & (absAttr IN m.conval.setval) THEN
DevCPT.FindField(m.name^, typ, obj);
IF (obj = NIL) OR (obj.mode # TProc) OR (absAttr IN obj.conval.setval) THEN
DevCPM.Mark(192, pos);
DevCPM.LogWLn; DevCPM.LogWStr(""); DevCPM.LogWStr(m.name^);
DevCPM.LogWStr(" not implemented");
IF typ.strobj # NIL THEN
DevCPM.LogWStr(" in "); DevCPM.LogWStr(typ.strobj.name^)
END
END
END;
CheckUnimpl(m.left, typ, pos);
CheckUnimpl(m.right, typ, pos)
END
END CheckUnimpl;
PROCEDURE CheckRecords (rec: Elem);
VAR b: DevCPT.Struct;
BEGIN
WHILE rec # NIL DO (* check for unimplemented methods in base type *)
b := rec.struct.BaseTyp;
WHILE (b # NIL) & (b # DevCPT.undftyp) DO
CheckUnimpl(b.link, rec.struct, rec.pos);
b := b.BaseTyp
END;
rec := rec.next
END
END CheckRecords;
PROCEDURE err(n: SHORTINT);
BEGIN DevCPM.err(n)
END err;
PROCEDURE CheckSym(s: SHORTINT);
BEGIN
IF sym = s THEN DevCPS.Get(sym) ELSE DevCPM.err(s) END
END CheckSym;
PROCEDURE qualident(VAR id: DevCPT.Object);
VAR obj: DevCPT.Object; lev: BYTE;
BEGIN (*sym = ident*)
DevCPT.Find(DevCPS.name, obj); DevCPS.Get(sym);
IF (sym = period) & (obj # NIL) & (obj.mode = Mod) THEN
DevCPS.Get(sym);
IF sym = ident THEN
DevCPT.FindImport(DevCPS.name, obj, obj); DevCPS.Get(sym)
ELSE err(ident); obj := NIL
END
END ;
IF obj = NIL THEN err(0);
obj := DevCPT.NewObj(); obj.mode := Var; obj.typ := DevCPT.undftyp; obj.adr := 0
ELSE lev := obj.mnolev;
IF (obj.mode IN {Var, VarPar}) & (lev # level) THEN
obj.leaf := FALSE;
IF lev > 0 THEN DevCPB.StaticLink(SHORT(SHORT(level-lev)), TRUE) END (* !!! *)
END
END ;
id := obj
END qualident;
PROCEDURE ConstExpression(VAR x: DevCPT.Node);
BEGIN Expression(x);
IF x.class # Nconst THEN
err(50); x := DevCPB.NewIntConst(1)
END
END ConstExpression;
PROCEDURE CheckMark(obj: DevCPT.Object); (* !!! *)
VAR n: INTEGER; mod: ARRAY 256 OF DevCPT.String;
BEGIN DevCPS.Get(sym);
IF (sym = times) OR (sym = minus) THEN
IF (level > 0) OR ~(obj.mode IN {Var, Fld, TProc}) & (sym = minus) THEN err(41) END ;
IF sym = times THEN obj.vis := external ELSE obj.vis := externalR END ;
DevCPS.Get(sym)
ELSE obj.vis := internal
END;
IF (obj.mode IN {TProc, LProc, XProc, CProc, Var, Typ, Con, Fld}) & (sym = lbrak) THEN
DevCPS.Get(sym);
IF (sym = number) & (DevCPS.numtyp = char) THEN
NEW(DevCPS.str, 2); DevCPS.str[0] := SHORT(CHR(DevCPS.intval)); DevCPS.str[1] := 0X; sym := string
END;
IF sym = string THEN
IF DevCPS.str^ # "" THEN obj.entry := DevCPS.str END;
DevCPS.Get(sym); n := 0;
IF (sym = comma) & (obj.mode IN {LProc, XProc, CProc, Var, Con}) THEN
DevCPS.Get(sym);
IF (sym = number) & (DevCPS.numtyp = char) THEN
NEW(DevCPS.str, 2); DevCPS.str[0] := SHORT(CHR(DevCPS.intval)); DevCPS.str[1] := 0X; sym := string
END;
IF sym = string THEN
obj.library := obj.entry; obj.entry := NIL;
IF DevCPS.str^ # "" THEN obj.entry := DevCPS.str END;
DevCPS.Get(sym);
ELSE err(string)
END
END;
WHILE sym = comma DO
DevCPS.Get(sym);
IF (sym = number) & (DevCPS.numtyp = char) THEN
NEW(DevCPS.str, 2); DevCPS.str[0] := SHORT(CHR(DevCPS.intval)); DevCPS.str[1] := 0X; sym := string
END;
IF sym = string THEN
IF n < LEN(mod) THEN mod[n] := DevCPS.str; INC(n)
ELSE err(235)
END;
DevCPS.Get(sym)
ELSE err(string)
END
END;
IF n > 0 THEN
NEW(obj.modifiers, n);
WHILE n > 0 DO DEC(n); obj.modifiers[n] := mod[n] END
END
ELSE err(string)
END;
CheckSym(rbrak);
IF DevCPM.options * {DevCPM.interface, DevCPM.java} = {} THEN err(225) END
END
END CheckMark;
PROCEDURE CheckSysFlag (VAR sysflag: SHORTINT;
GetSF: PROCEDURE(id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT));
VAR x: DevCPT.Object; i: SHORTINT;
BEGIN
sysflag := 0;
IF sym = lbrak THEN
DevCPS.Get(sym);
WHILE (sym = number) OR (sym = ident) OR (sym = string) DO
IF sym = number THEN
IF DevCPS.numtyp = integer THEN
i := SHORT(DevCPS.intval); GetSF("", i, sysflag)
ELSE err(225)
END
ELSIF sym = ident THEN
DevCPT.Find(DevCPS.name, x);
IF (x # NIL) & (x.mode = Con) & (x.typ.form IN {Int8, Int16, Int32}) THEN
i := SHORT(x.conval.intval); GetSF("", i, sysflag)
ELSE
GetSF(DevCPS.name, 0, sysflag)
END
ELSE
GetSF(DevCPS.str^, 0, sysflag)
END;
DevCPS.Get(sym);
IF (sym = comma) OR (sym = plus) THEN DevCPS.Get(sym) END
END;
CheckSym(rbrak)
END
END CheckSysFlag;
PROCEDURE Receiver(VAR mode, vis: BYTE; VAR name: DevCPT.Name; VAR typ, rec: DevCPT.Struct);
VAR obj: DevCPT.Object; tname: DevCPT.String;
BEGIN typ := DevCPT.undftyp; rec := NIL; vis := 0;
IF sym = var THEN DevCPS.Get(sym); mode := VarPar;
ELSIF sym = in THEN DevCPS.Get(sym); mode := VarPar; vis := inPar (* ??? *)
ELSE mode := Var
END ;
name := DevCPS.name; CheckSym(ident); CheckSym(colon);
IF sym # ident THEN err(ident) END;
Type(typ, tname);
IF tname = NIL THEN
IF typ.form = Pointer THENrec := typ.BaseTyp ELSE rec := typ END;
IF ~((mode = Var) & (typ.form = Pointer) & (rec.comp = Record) OR
(mode = VarPar) & (typ.comp = Record)) THEN err(70); rec := NIL END;
IF (rec # NIL) & (rec.mno # level) THEN err(72); rec := NIL END
ELSE err(0)
END;
CheckSym(rparen);
IF rec = NIL THEN rec := DevCPT.NewStr(Comp, Record); rec.BaseTyp := NIL END
END Receiver;
PROCEDURE FormalParameters(
VAR firstPar: DevCPT.Object; VAR resTyp: DevCPT.Struct; VAR name: DevCPT.String
);
VAR mode, vis: BYTE; sys: SHORTINT;
par, first, last, res, newPar, iidPar: DevCPT.Object; typ: DevCPT.Struct;
BEGIN
first := NIL; last := firstPar;
newPar := NIL; iidPar := NIL;
IF (sym = ident) OR (sym = var) OR (sym = in) OR (sym = out) THEN
LOOP
sys := 0; vis := 0;
IF sym = var THEN DevCPS.Get(sym); mode := VarPar
ELSIF sym = in THEN DevCPS.Get(sym); mode := VarPar; vis := inPar
ELSIF sym = out THEN DevCPS.Get(sym); mode := VarPar; vis := outPar
ELSE mode := Var
END ;
IF mode = VarPar THEN CheckSysFlag(sys, DevCPM.GetVarParSysFlag) END;
IF ODD(sys DIV inBit) THEN vis := inPar
ELSIF ODD(sys DIV outBit) THEN vis := outPar
END;
IF ODD(sys DIV newBit) & (vis # outPar) THEN err(225)
ELSIF ODD(sys DIV iidBit) & (vis # inPar) THEN err(225)
END;
LOOP
IF sym = ident THEN
DevCPT.Insert(DevCPS.name, par); DevCPS.Get(sym);
par.mode := mode; par.link := NIL; par.vis := vis; par.sysflag := SHORT(sys);
IF first = NIL THEN first := par END ;
IF firstPar = NIL THEN firstPar := par ELSE last.link := par END ;
last := par
ELSE err(ident)
END;
IF sym = comma THEN DevCPS.Get(sym)
ELSIF sym = ident THEN err(comma)
ELSIF sym = var THEN err(comma); DevCPS.Get(sym)
ELSE EXIT
END
END ;
CheckSym(colon); Type(typ, name);
IF mode # VarPar THEN CheckAlloc(typ, TRUE, DevCPM.errpos) END;
IF (mode = VarPar) & (vis = inPar) & (typ.form # Undef) & (typ.form # Comp) & (typ.sysflag = 0) THEN err(177)
END;
(* typ.pbused is set when parameter type name is parsed *)
WHILE first # NIL DO
SetType (NIL, first, typ, name);
IF DevCPM.com IN DevCPM.options THEN
IF ODD(sys DIV newBit) THEN
IF (newPar # NIL) OR (typ.form # Pointer) OR (typ.sysflag # interface) THEN err(168) END;
newPar := first
ELSIF ODD(sys DIV iidBit) THEN
IF (iidPar # NIL) OR (typ # DevCPT.guidtyp) THEN err(168) END;
iidPar := first
END
END;
first := first.link
END;
IF sym = semicolon THEN DevCPS.Get(sym)
ELSIF sym = ident THEN err(semicolon)
ELSE EXIT
END
END
END;
CheckSym(rparen);
IF (newPar = NIL) # (iidPar = NIL) THEN err(168) END;
name := NIL;
IF sym = colon THEN
DevCPS.Get(sym);
Type(resTyp, name);
IF resTyp.form = Comp THEN resTyp := DevCPT.undftyp; err(54) END
ELSE resTyp := DevCPT.notyp
END
END FormalParameters;
PROCEDURE CheckOverwrite (proc, base: DevCPT.Object; rec: DevCPT.Struct);
VAR o, bo: DevCPT.Object;
BEGIN
IF base # NIL THEN
IF base.conval.setval * {absAttr, empAttr, extAttr} = {} THEN err(182) END;
IF (proc.link.mode # base.link.mode) OR (proc.link.vis # base.link.vis)
OR ~DevCPT.Extends(proc.link.typ, base.link.typ) THEN err(115) END;
o := proc.link; bo := base.link;
WHILE (o # NIL) & (bo # NIL) DO
IF (bo.sysflag # 0) & (o.sysflag = 0) THEN (* propagate sysflags *)
o.sysflag := bo.sysflag
END;
o := o.link; bo := bo.link
END;
DevCPB.CheckParameters(proc.link.link, base.link.link, FALSE);
IF ~DevCPT.Extends(proc.typ, base.typ) THEN err(117) END;
IF (base.vis # proc.vis) & ((proc.vis # internal) OR rec.exp) THEN err(183) END;
INCL(proc.conval.setval, isRedef)
END;
END CheckOverwrite;
PROCEDURE GetAttributes (proc, base: DevCPT.Object; owner: DevCPT.Struct); (* read method attributes *)
VAR attr, battr: SET; o: DevCPT.Object;
BEGIN
attr := {};
IF sym = comma THEN (* read attributes *)
DevCPS.Get(sym);
IF sym = ident THEN
DevCPT.Find(DevCPS.name, o);
IF (o # NIL) & (o.mode = SProc) & (o.adr = newfn) THEN
IF ~(DevCPM.oberon IN DevCPM.options) THEN INCL(attr, newAttr) ELSE err(178) END;
DevCPS.Get(sym);
IF sym = comma THEN
DevCPS.Get(sym);
IF sym = ident THEN DevCPT.Find(DevCPS.name, o) ELSE o := NIL; err(ident) END
ELSE o := NIL
END
END;
IF o # NIL THEN
IF (o.mode # Attr) OR (o.adr = limAttr) OR (DevCPM.oberon IN DevCPM.options) THEN err(178)
ELSE INCL(attr, o.adr)
END;
DevCPS.Get(sym)
END
ELSE err(ident)
END
END;
IF (base = NIL) & ~(newAttr IN attr) THEN err(185); INCL(attr, newAttr)
ELSIF (base # NIL) & (newAttr IN attr) THEN err(186)
END;
IF absAttr IN attr THEN
IF owner.attribute # absAttr THEN err(190) END;
IF (proc.vis = internal) & owner.exp THEN err(179) END
END;
IF (owner.attribute = 0) OR (owner.attribute = limAttr) THEN
IF (empAttr IN attr) & (newAttr IN attr) THEN err(187)
(*
ELSIF extAttr IN attr THEN err(188)
*)
END
END;
IF base # NIL THEN
battr := base.conval.setval;
IF empAttr IN battr THEN
IF absAttr IN attr THEN err(189) END
ELSIF ~(absAttr IN battr) THEN
IF (absAttr IN attr) OR (empAttr IN attr) THEN err(189) END
END
END;
IF empAttr IN attr THEN
IF proc.typ # DevCPT.notyp THEN err(195)
ELSE
o := proc.link; WHILE (o # NIL) & (o.vis # outPar) DO o := o.link END;
IF o # NIL THEN err(195) END
END
END;
IF (owner.sysflag = interface) & ~(absAttr IN attr) THEN err(162) END;
proc.conval.setval := attr
END GetAttributes;
PROCEDURE RecordType(VAR typ: DevCPT.Struct; attr: DevCPT.Object);
VAR fld, first, last, base: DevCPT.Object; r: Elem; ftyp: DevCPT.Struct; name: DevCPT.String;
BEGIN typ := DevCPT.NewStr(Comp, Record); typ.BaseTyp := NIL;
CheckSysFlag(typ.sysflag, DevCPM.GetRecordSysFlag);
IF attr # NIL THEN
IF ~(DevCPM.oberon IN DevCPM.options) & (attr.adr # empAttr) THEN typ.attribute := SHORT(SHORT(attr.adr))
ELSE err(178)
END
END;
IF typ.sysflag = interface THEN
IF (DevCPS.str # NIL) & (DevCPS.str[0] = "{") THEN typ.ext := DevCPS.str END;
IF typ.attribute # absAttr THEN err(163) END;
IF sym # lparen THEN err(160) END
END;
IF sym = lparen THEN
DevCPS.Get(sym); (*record extension*)
IF sym = ident THEN
Type(ftyp, name);
IF ftyp.form = Pointer THEN ftyp := ftyp.BaseTyp END;
SetType(typ, NIL, ftyp, name);
IF (ftyp.comp = Record) & (ftyp # DevCPT.anytyp) THEN
ftyp.pvused := TRUE; typ.extlev := SHORT(SHORT(ftyp.extlev + 1));
DevCPM.PropagateRecordSysFlag(ftyp.sysflag, typ.sysflag);
IF (ftyp.attribute = 0) OR (ftyp.attribute = limAttr) & (ftyp.mno # 0) THEN err(181)
ELSIF (typ.attribute = absAttr) & (ftyp.attribute # absAttr) & ~(DevCPM.java IN DevCPM.options) THEN err(191)
ELSIF (ftyp.attribute = limAttr) & (typ.attribute # limAttr) THEN err(197)
END
ELSIF ftyp # DevCPT.undftyp THEN err(53)
END
ELSE err(ident)
END ;
IF typ.attribute # absAttr THEN (* save typ for unimplemented method check *)
NEW(r); r.struct := typ; r.pos := DevCPM.errpos; r.next := recList; recList := r
END;
CheckSym(rparen)
END;
(*
DevCPT.OpenScope(0, NIL);
*)
first := NIL; last := NIL;
LOOP
IF sym = ident THEN
LOOP
IF sym = ident THEN
IF (typ.BaseTyp # NIL) & (typ.BaseTyp # DevCPT.undftyp) THEN
DevCPT.FindBaseField(DevCPS.name, typ, fld);
IF fld # NIL THEN err(1) END
END ;
DevCPT.InsertField(DevCPS.name, typ, fld);
fld.mode := Fld; fld.link := NIL; fld.typ := DevCPT.undftyp;
CheckMark(fld);
IF first = NIL THEN first := fld END ;
IF last = NIL THEN typ.link := fld ELSE last.link := fld END ;
last := fld
ELSE err(ident)
END ;
IF sym = comma THEN DevCPS.Get(sym)
ELSIF sym = ident THEN err(comma)
ELSE EXIT
END
END ;
CheckSym(colon); Type(ftyp, name);
CheckAlloc(ftyp, FALSE, DevCPM.errpos);
WHILE first # NIL DO
SetType(typ, first, ftyp, name); first := first.link
END;
IF typ.sysflag = interface THEN err(161) END
END;
IF sym = semicolon THEN DevCPS.Get(sym)
ELSIF sym = ident THEN err(semicolon)
ELSE EXIT
END
END;
(*
IF typ.link # NIL THEN ASSERT(typ.link = DevCPT.topScope.right) END;
typ.link := DevCPT.topScope.right; DevCPT.CloseScope;
*)
typ.untagged := typ.sysflag > 0;
DevCPB.Inittd(TDinit, lastTDinit, typ); CheckSym(end)
END RecordType;
PROCEDURE ArrayType(VAR typ: DevCPT.Struct);
VAR x: DevCPT.Node; n: INTEGER; sysflag: SHORTINT; name: DevCPT.String;
BEGIN CheckSysFlag(sysflag, DevCPM.GetArraySysFlag);
IF sym = of THEN (*dynamic array*)
typ := DevCPT.NewStr(Comp, DynArr); typ.mno := 0; typ.sysflag := sysflag;
DevCPS.Get(sym); Type(typ.BaseTyp, name); SetType(typ, NIL, typ.BaseTyp, name);
CheckAlloc(typ.BaseTyp, TRUE, DevCPM.errpos);
IF typ.BaseTyp.comp = DynArr THEN typ.n := typ.BaseTyp.n + 1 ELSE typ.n := 0 END
ELSE
typ := DevCPT.NewStr(Comp, Array); typ.sysflag := sysflag; ConstExpression(x);
IF x.typ.form IN {Int8, Int16, Int32} THEN n := x.conval.intval;
IF (n <= 0) OR (n > DevCPM.MaxIndex) THEN err(63); n := 1 END
ELSE err(42); n := 1
END ;
typ.n := n;
IF sym = of THEN
DevCPS.Get(sym); Type(typ.BaseTyp, name); SetType(typ, NIL, typ.BaseTyp, name);
CheckAlloc(typ.BaseTyp, FALSE, DevCPM.errpos)
ELSIF sym = comma THEN
DevCPS.Get(sym);
IF sym # of THEN ArrayType(typ.BaseTyp) END
ELSE err(35)
END
END;
typ.untagged := typ.sysflag > 0
END ArrayType;
PROCEDURE PointerType(VAR typ: DevCPT.Struct);
VAR id: DevCPT.Object; name: DevCPT.String;
BEGIN typ := DevCPT.NewStr(Pointer, Basic); CheckSysFlag(typ.sysflag, DevCPM.GetPointerSysFlag);
CheckSym(to);
Type(typ.BaseTyp, name);
SetType(typ, NIL, typ.BaseTyp, name);
IF (typ.BaseTyp # DevCPT.undftyp) & (typ.BaseTyp.comp = Basic) THEN
typ.BaseTyp := DevCPT.undftyp; err(57)
END;
IF typ.BaseTyp.comp = Record THEN DevCPM.PropagateRecPtrSysFlag(typ.BaseTyp.sysflag, typ.sysflag)
ELSIF typ.BaseTyp.comp IN {Array, DynArr} THEN DevCPM.PropagateArrPtrSysFlag(typ.BaseTyp.sysflag, typ.sysflag)
END;
typ.untagged := typ.sysflag > 0
END PointerType;
PROCEDURE Type (VAR typ: DevCPT.Struct; VAR name: DevCPT.String); (* name # NIL => forward reference *)
VAR id: DevCPT.Object; tname: DevCPT.String;
BEGIN
typ := DevCPT.undftyp; name := NIL;
IF sym < lparen THEN err(12);
REPEAT DevCPS.Get(sym) UNTIL sym >= lparen
END ;
IF sym = ident THEN
DevCPT.Find(DevCPS.name, id);
IF (id = NIL) OR (id.mode = -1) OR (id.mode = Typ) & IncompleteType(id.typ) THEN (* forward type definition *)
name := DevCPT.NewName(DevCPS.name); DevCPS.Get(sym);
IF (id = NIL) & (sym = period) THEN (* missing module *)
err(0); DevCPS.Get(sym); name := NIL;
IF sym = ident THEN DevCPS.Get(sym) END
ELSIF sym = record THEN (* wrong attribute *)
err(178); DevCPS.Get(sym); name := NIL; RecordType(typ, NIL)
END
ELSE
qualident(id);
IF id.mode = Typ THEN
IF ~(DevCPM.oberon IN DevCPM.options)
& ((id.typ = DevCPT.lreal64typ) OR (id.typ = DevCPT.lint64typ) OR (id.typ = DevCPT.lchar16typ)) THEN
err(198)
END;
typ := id.typ
ELSIF id.mode = Attr THEN
IF sym = record THEN
DevCPS.Get(sym); RecordType(typ, id)
ELSE err(12)
END
ELSE err(52)
END
END
ELSIF sym = array THEN
DevCPS.Get(sym); ArrayType(typ)
ELSIF sym = record THEN
DevCPS.Get(sym); RecordType(typ, NIL)
ELSIF sym = pointer THEN
DevCPS.Get(sym); PointerType(typ)
ELSIF sym = procedure THEN
DevCPS.Get(sym); typ := DevCPT.NewStr(ProcTyp, Basic);
CheckSysFlag(typ.sysflag, DevCPM.GetProcTypSysFlag);
typ.untagged := typ.sysflag > 0;
IF sym = lparen THEN
DevCPS.Get(sym); DevCPT.OpenScope(level, NIL);
FormalParameters(typ.link, typ.BaseTyp, tname); SetType(typ, NIL, typ.BaseTyp, tname); DevCPT.CloseScope
ELSE typ.BaseTyp := DevCPT.notyp; typ.link := NIL
END
ELSE err(12)
END ;
LOOP
IF (sym >= semicolon) & (sym <= else) OR (sym = rparen) OR (sym = eof)
OR (sym = number) OR (sym = comma) OR (sym = string) THEN EXIT END;
err(15); IF sym = ident THEN EXIT END;
DevCPS.Get(sym)
END
END Type;
PROCEDURE ActualParameters(VAR aparlist: DevCPT.Node; fpar: DevCPT.Object; VAR pre, lastp: DevCPT.Node);
VAR apar, last, newPar, iidPar, n: DevCPT.Node;
BEGIN
aparlist := NIL; last := NIL;
IF sym # rparen THEN
newPar := NIL; iidPar := NIL;
LOOP Expression(apar);
IF fpar # NIL THEN
IF (apar.typ.form = Pointer) & (fpar.typ.form = Comp) THEN DevCPB.DeRef(apar) END;
DevCPB.Param(apar, fpar);
IF (fpar.mode = Var) OR (fpar.vis = inPar) THEN DevCPB.CheckBuffering(apar, NIL, fpar, pre, lastp) END;
DevCPB.Link(aparlist, last, apar);
IF ODD(fpar.sysflag DIV newBit) THEN newPar := apar
ELSIF ODD(fpar.sysflag DIV iidBit) THEN iidPar := apar
END;
IF (newPar # NIL) & (iidPar # NIL) THEN DevCPB.CheckNewParamPair(newPar, iidPar) END;
IF anchorVarPar & (fpar.mode = VarPar) & ~(DevCPM.java IN DevCPM.options)
OR (DevCPM.allSysVal IN DevCPM.options) (* source output: avoid double evaluation *)
& ((fpar.mode = VarPar) & (fpar.typ.comp = Record) & ~fpar.typ.untagged
OR (fpar.typ.comp = DynArr) & ~fpar.typ.untagged) THEN
n := apar;
WHILE n.class IN {Nfield, Nindex, Nguard} DO n := n.left END;
IF (n.class = Nderef) & (n.subcl = 0) THEN
IF n.left.class = Nguard THEN n := n.left END;
DevCPB.CheckVarParBuffering(n.left, pre, lastp)
END
END;
fpar := fpar.link
ELSE err(64)
END;
IF sym = comma THEN DevCPS.Get(sym)
ELSIF (lparen <= sym) & (sym <= ident) THEN err(comma)
ELSE EXIT
END
END
END;
IF fpar # NIL THEN err(65) END
END ActualParameters;
PROCEDURE selector(VAR x: DevCPT.Node);
VAR obj, proc, p, fpar: DevCPT.Object; y, apar, pre, lastp: DevCPT.Node; typ: DevCPT.Struct; name: DevCPT.Name;
BEGIN
LOOP
IF sym = lbrak THEN DevCPS.Get(sym);
LOOP
IF (x.typ # NIL) & (x.typ.form = Pointer) THEN DevCPB.DeRef(x) END ;
Expression(y); DevCPB.Index(x, y);
IF sym = comma THEN DevCPS.Get(sym) ELSE EXIT END
END ;
CheckSym(rbrak)
ELSIF sym = period THEN DevCPS.Get(sym);
IF sym = ident THEN name := DevCPS.name; DevCPS.Get(sym);
IF x.typ # NIL THEN
IF x.typ.form = Pointer THEN DevCPB.DeRef(x) END ;
IF x.typ.comp = Record THEN
typ := x.typ; DevCPT.FindField(name, typ, obj); DevCPB.Field(x, obj);
IF (obj # NIL) & (obj.mode = TProc) THEN
IF sym = arrow THEN(* super call *) DevCPS.Get(sym);
y := x.left;
IF y.class = Nderef THEN y := y.left END ; (* y = record variable *)
IF y.obj # NIL THEN
proc := DevCPT.topScope; (* find innermost scope which owner is a TProc *)
WHILE (proc.link # NIL) & (proc.link.mode # TProc) DO proc := proc.left END ;
IF (proc.link = NIL) OR (proc.link.link # y.obj) (* OR (proc.link.name^ # name) *) THEN err(75)
END ;
typ := y.obj.typ;
IF typ.form = Pointer THEN typ := typ.BaseTyp END ;
DevCPT.FindBaseField(x.obj.name^, typ, p);
IF p # NIL THEN
x.subcl := super; x.typ := p.typ; (* correct result type *)
IF p.conval.setval * {absAttr, empAttr} # {} THEN err(194) END;
IF (p.vis = externalR) & (p.mnolev < 0) & (proc.link.name^ # name) THEN err(196) END;
ELSE err(74)
END
ELSE err(75)
END
ELSE
proc := obj;
WHILE (proc.mnolev >= 0) & ~(newAttr IN proc.conval.setval) & (typ.BaseTyp # NIL) DO
(* find base method *)
typ := typ.BaseTyp; DevCPT.FindField(name, typ, proc);
END;
IF (proc.vis = externalR) & (proc.mnolev < 0) THEN err(196) END;
END ;
IF (obj.typ # DevCPT.notyp) & (sym # lparen) THEN err(lparen) END
END
ELSE err(53)
END
ELSE err(52)
END
ELSE err(ident)
END
ELSIF sym = arrow THEN DevCPS.Get(sym); DevCPB.DeRef(x)
ELSIF sym = dollar THEN
IF x.typ.form = Pointer THEN DevCPB.DeRef(x) END;
DevCPS.Get(sym); DevCPB.StrDeref(x)
ELSIF sym = lparen THEN
IF (x.obj # NIL) & (x.obj.mode IN {XProc, LProc, CProc, TProc}) THEN typ := x.obj.typ
ELSIF x.typ.form = ProcTyp THEN typ := x.typ.BaseTyp
ELSIF x.class = Nproc THEN EXIT (* standard procedure *)
ELSE typ := NIL
END;
IF typ # DevCPT.notyp THEN
DevCPS.Get(sym);
IF typ = NIL THEN (* type guard *)
IF sym = ident THEN
qualident(obj);
IF obj.mode = Typ THEN DevCPB.TypTest(x, obj, TRUE)
ELSE err(52)
END
ELSE err(ident)
END
ELSE (* function call *)
pre := NIL; lastp := NIL;
DevCPB.PrepCall(x, fpar);
IF (x.obj # NIL) & (x.obj.mode = TProc) THEN DevCPB.CheckBuffering(x.left, NIL, x.obj.link, pre, lastp)
END;
ActualParameters(apar, fpar, pre, lastp);
DevCPB.Call(x, apar, fpar);
IF pre # NIL THEN DevCPB.Construct(Ncomp, pre, x); pre.typ := x.typ; x := pre END;
IF level > 0 THEN DevCPT.topScope.link.leaf := FALSE END
END;
CheckSym(rparen)
ELSE EXIT
END
(*
ELSIF (sym = lparen) & (x.class # Nproc) & (x.typ.form # ProcTyp) &
((x.obj = NIL) OR (x.obj.mode # TProc)) THEN
DevCPS.Get(sym);
IF sym = ident THEN
qualident(obj);
IF obj.mode = Typ THEN DevCPB.TypTest(x, obj, TRUE)
ELSE err(52)
END
ELSE err(ident)
END ;
CheckSym(rparen)
*)
ELSE EXIT
END
END
END selector;
PROCEDURE StandProcCall(VAR x: DevCPT.Node);
VAR y: DevCPT.Node; m: BYTE; n: SHORTINT;
BEGIN m := SHORT(SHORT(x.obj.adr)); n := 0;
IF sym = lparen THEN DevCPS.Get(sym);
IF sym # rparen THEN
LOOP
IF n = 0 THEN Expression(x); DevCPB.StPar0(x, m); n := 1
ELSIF n = 1 THEN Expression(y); DevCPB.StPar1(x, y, m); n := 2
ELSE Expression(y); DevCPB.StParN(x, y, m, n); INC(n)
END ;
IF sym = comma THEN DevCPS.Get(sym)
ELSIF (lparen <= sym) & (sym <= ident) THEN err(comma)
ELSE EXIT
END
END ;
CheckSym(rparen)
ELSE DevCPS.Get(sym)
END ;
DevCPB.StFct(x, m, n)
ELSE err(lparen)
END ;
IF (level > 0) & ((m = newfn) OR (m = sysnewfn)) THEN DevCPT.topScope.link.leaf := FALSE END
END StandProcCall;
PROCEDURE Element(VAR x: DevCPT.Node);
VAR y: DevCPT.Node;
BEGIN Expression(x);
IF sym = upto THEN
DevCPS.Get(sym); Expression(y); DevCPB.SetRange(x, y)
ELSE DevCPB.SetElem(x)
END
END Element;
PROCEDURE Sets(VAR x: DevCPT.Node);
VAR y: DevCPT.Node;
BEGIN
IF sym # rbrace THEN
Element(x);
LOOP
IF sym = comma THEN DevCPS.Get(sym)
ELSIF (lparen <= sym) & (sym <= ident) THEN err(comma)
ELSE EXIT
END ;
Element(y); DevCPB.Op(plus, x, y)
END
ELSE x := DevCPB.EmptySet()
END ;
CheckSym(rbrace)
END Sets;
PROCEDURE Factor(VAR x: DevCPT.Node);
VAR fpar, id: DevCPT.Object; apar: DevCPT.Node;
BEGIN
IF sym < not THEN err(13);
REPEAT DevCPS.Get(sym) UNTIL sym >= lparen
END ;
IF sym = ident THEN
qualident(id); x := DevCPB.NewLeaf(id); selector(x);
IF (x.class = Nproc) & (x.obj.mode = SProc) THEN StandProcCall(x) (* x may be NIL *)
(*
ELSIF sym = lparen THEN
DevCPS.Get(sym); DevCPB.PrepCall(x, fpar);
ActualParameters(apar, fpar);
DevCPB.Call(x, apar, fpar);
CheckSym(rparen);
IF level > 0 THEN DevCPT.topScope.link.leaf := FALSE END
*)
END
ELSIF sym = number THEN
CASE DevCPS.numtyp OF
char:
x := DevCPB.NewIntConst(DevCPS.intval); x.typ := DevCPT.char8typ;
IF DevCPS.intval > 255 THEN x.typ := DevCPT.char16typ END
| integer: x := DevCPB.NewIntConst(DevCPS.intval)
| int64: x := DevCPB.NewLargeIntConst(DevCPS.intval, DevCPS.realval)
| real: x := DevCPB.NewRealConst(DevCPS.realval, NIL)
| real32: x := DevCPB.NewRealConst(DevCPS.realval, DevCPT.real32typ)
| real64: x := DevCPB.NewRealConst(DevCPS.realval, DevCPT.real64typ)
END ;
DevCPS.Get(sym)
ELSIF sym = string THEN
x := DevCPB.NewString(DevCPS.str, DevCPS.lstr, DevCPS.intval);
DevCPS.Get(sym)
ELSIF sym = nil THEN
x := DevCPB.Nil(); DevCPS.Get(sym)
ELSIF sym = lparen THEN
DevCPS.Get(sym); Expression(x); CheckSym(rparen)
ELSIF sym = lbrak THEN
DevCPS.Get(sym); err(lparen); Expression(x); CheckSym(rparen)
ELSIF sym = lbrace THEN DevCPS.Get(sym); Sets(x)
ELSIF sym = not THEN
DevCPS.Get(sym); Factor(x); DevCPB.MOp(not, x)
ELSE err(13); DevCPS.Get(sym); x := NIL
END ;
IF x = NIL THEN x := DevCPB.NewIntConst(1); x.typ := DevCPT.undftyp END
END Factor;
PROCEDURE Term(VAR x: DevCPT.Node);
VAR y: DevCPT.Node; mulop: BYTE;
BEGIN Factor(x);
WHILE (times <= sym) & (sym <= and) DO
mulop := sym; DevCPS.Get(sym);
Factor(y); DevCPB.Op(mulop, x, y)
END
END Term;
PROCEDURE SimpleExpression(VAR x: DevCPT.Node);
VAR y: DevCPT.Node; addop: BYTE;
BEGIN
IF sym = minus THEN DevCPS.Get(sym); Term(x); DevCPB.MOp(minus, x)
ELSIF sym = plus THEN DevCPS.Get(sym); Term(x); DevCPB.MOp(plus, x)
ELSE Term(x)
END ;
WHILE (plus <= sym) & (sym <= or) DO
addop := sym; DevCPS.Get(sym); Term(y);
IF x.typ.form = Pointer THEN DevCPB.DeRef(x) END;
IF (x.typ.comp IN {Array, DynArr}) & (x.typ.BaseTyp.form IN charSet) (* OR (x.typ.sysflag = jstr) *) THEN
DevCPB.StrDeref(x)
END;
IF y.typ.form = Pointer THEN DevCPB.DeRef(y) END;
IF (y.typ.comp IN {Array, DynArr}) & (y.typ.BaseTyp.form IN charSet) (* OR (y.typ.sysflag = jstr) *) THEN
DevCPB.StrDeref(y)
END;
DevCPB.Op(addop, x, y)
END
END SimpleExpression;
PROCEDURE Expression(VAR x: DevCPT.Node);
VAR y, pre, last: DevCPT.Node; obj: DevCPT.Object; relation: BYTE;
BEGIN SimpleExpression(x);
IF (eql <= sym) & (sym <= geq) THEN
relation := sym; DevCPS.Get(sym); SimpleExpression(y);
pre := NIL; last := NIL;
IF (x.typ.comp IN {Array, DynArr}) & (x.typ.BaseTyp.form IN charSet) THEN
DevCPB.StrDeref(x)
END;
IF (y.typ.comp IN {Array, DynArr}) & (y.typ.BaseTyp.form IN charSet) THEN
DevCPB.StrDeref(y)
END;
DevCPB.CheckBuffering(x, NIL, NIL, pre, last);
DevCPB.CheckBuffering(y, NIL, NIL, pre, last);
DevCPB.Op(relation, x, y);
IF pre # NIL THEN DevCPB.Construct(Ncomp, pre, x); pre.typ := x.typ; x := pre END
ELSIF sym = in THEN
DevCPS.Get(sym); SimpleExpression(y); DevCPB.In(x, y)
ELSIF sym = is THEN
DevCPS.Get(sym);
IF sym = ident THEN
qualident(obj);
IF obj.mode = Typ THEN DevCPB.TypTest(x, obj, FALSE)
ELSE err(52)
END
ELSE err(ident)
END
END
END Expression;
PROCEDURE ProcedureDeclaration(VAR x: DevCPT.Node);
VAR proc, fwd: DevCPT.Object;
name: DevCPT.Name;
mode: BYTE;
forward: BOOLEAN;
sys: SHORTINT;
PROCEDURE GetCode;
VAR ext: DevCPT.ConstExt; i, n, c: INTEGER; s: ARRAY 256 OF SHORTCHAR;
BEGIN
n := 0;
IF sym = string THEN
NEW(ext, DevCPS.intval);
WHILE DevCPS.str[n] # 0X DO ext[n+1] := DevCPS.str[n]; INC(n) END ;
ext^[0] := SHORT(CHR(n)); DevCPS.Get(sym);
ELSE
LOOP
IF sym = number THEN c := DevCPS.intval; INC(n);
IF (c < 0) OR (c > 255) OR (n = 255) THEN
err(64); c := 1; n := 1
END ;
DevCPS.Get(sym); s[n] := SHORT(CHR(c))
END ;
IF sym = comma THEN DevCPS.Get(sym)
ELSIF sym = number THEN err(comma)
ELSE s[0] := SHORT(CHR(n)); EXIT
END
END;
NEW(ext, n + 1); i := 0;
WHILE i <= n DO ext[i] := s[i]; INC(i) END;
END;
proc.conval.ext := ext;
INCL(proc.conval.setval, hasBody)
END GetCode;
PROCEDURE GetParams;
VAR name: DevCPT.String;
BEGIN
proc.mode := mode; proc.typ := DevCPT.notyp;
proc.sysflag := SHORT(sys);
proc.conval.setval := {};
IF sym = lparen THEN
DevCPS.Get(sym); FormalParameters(proc.link, proc.typ, name);
IF name # NIL THEN err(0) END
END;
CheckForwardTypes; userList := NIL;
IF fwd # NIL THEN
DevCPB.CheckParameters(proc.link, fwd.link, TRUE);
IF ~DevCPT.EqualType(proc.typ, fwd.typ) THEN err(117) END ;
proc := fwd; DevCPT.topScope := proc.scope;
IF mode = IProc THEN proc.mode := IProc END
END
END GetParams;
PROCEDURE Body;
VAR procdec, statseq: DevCPT.Node; c: INTEGER;
BEGIN
c := DevCPM.errpos;
INCL(proc.conval.setval, hasBody);
CheckSym(semicolon); Block(procdec, statseq);
DevCPB.Enter(procdec, statseq, proc); x := procdec;
x.conval := DevCPT.NewConst(); x.conval.intval := c; x.conval.intval2 := DevCPM.startpos;
CheckSym(end);
IF sym = ident THEN
IF DevCPS.name # proc.name^ THEN err(4) END ;
DevCPS.Get(sym)
ELSE err(ident)
END
END Body;
PROCEDURE TProcDecl;
VAR baseProc, o, bo: DevCPT.Object;
objTyp, recTyp: DevCPT.Struct;
objMode, objVis: BYTE;
objName: DevCPT.Name;
pnode: DevCPT.Node;
fwdAttr: SET;
BEGIN
DevCPS.Get(sym); mode := TProc;
IF level > 0 THEN err(73) END;
Receiver(objMode, objVis, objName, objTyp, recTyp);
IF sym = ident THEN
name := DevCPS.name;
DevCPT.FindField(name, recTyp, fwd);
DevCPT.FindBaseField(name, recTyp, baseProc);
IF (baseProc # NIL) & (baseProc.mode # TProc) THEN baseProc := NIL; err(1) END ;
IF fwd = baseProc THEN fwd := NIL END ;
IF (fwd # NIL) & (fwd.mnolev # level) THEN fwd := NIL END ;
IF (fwd # NIL) & (fwd.mode = TProc) & (fwd.conval.setval * {hasBody, absAttr, empAttr} = {}) THEN
(* there exists a corresponding forward declaration *)
proc := DevCPT.NewObj(); proc.leaf := TRUE;
proc.mode := TProc; proc.conval := DevCPT.NewConst();
CheckMark(proc);
IF fwd.vis # proc.vis THEN err(118) END;
fwdAttr := fwd.conval.setval
ELSE
IF fwd # NIL THEN err(1); fwd := NIL END ;
DevCPT.InsertField(name, recTyp, proc);
proc.mode := TProc; proc.conval := DevCPT.NewConst();
CheckMark(proc);
IF recTyp.strobj # NIL THEN (* preserve declaration order *)
o := recTyp.strobj.link;
IF o = NIL THEN recTyp.strobj.link := proc
ELSE
WHILE o.nlink # NIL DO o := o.nlink END;
o.nlink := proc
END
END
END;
INC(level); DevCPT.OpenScope(level, proc);
DevCPT.Insert(objName, proc.link); proc.link.mode := objMode; proc.link.vis := objVis; proc.link.typ := objTyp;
ASSERT(DevCPT.topScope # NIL);
GetParams; (* may change proc := fwd !!! *)
ASSERT(DevCPT.topScope # NIL);
GetAttributes(proc, baseProc, recTyp);
IF (fwd # NIL) & (fwdAttr / proc.conval.setval * {absAttr, empAttr, extAttr} # {}) THEN err(184) END;
CheckOverwrite(proc, baseProc, recTyp);
IF ~forward THEN
IF empAttr IN proc.conval.setval THEN (* insert empty procedure *)
pnode := NIL; DevCPB.Enter(pnode, NIL, proc);
pnode.conval := DevCPT.NewConst();
pnode.conval.intval := DevCPM.errpos;
pnode.conval.intval2 := DevCPM.errpos;
x := pnode;
ELSIF DevCPM.noCode IN DevCPM.options THEN INCL(proc.conval.setval, hasBody)
ELSIF ~(absAttr IN proc.conval.setval) THEN Body
END;
proc.adr := 0
ELSE
proc.adr := DevCPM.errpos;
IF proc.conval.setval * {empAttr, absAttr} # {} THEN err(184) END
END;
DEC(level); DevCPT.CloseScope;
ELSE err(ident)
END;
END TProcDecl;
BEGIN proc := NIL; forward := FALSE; x := NIL; mode := LProc; sys := 0;
IF (sym # ident) & (sym # lparen) THEN
CheckSysFlag(sys, DevCPM.GetProcSysFlag);
IF sys # 0 THEN
IF ODD(sys DIV DevCPM.CProcFlag) THEN mode := CProc END
ELSE
IF sym = times THEN (* mode set later in DevCPB.CheckAssign *)
ELSIF sym = arrow THEN forward := TRUE
ELSE err(ident)
END;
DevCPS.Get(sym)
END
END ;
IF sym = lparen THEN TProcDecl
ELSIF sym = ident THEN DevCPT.Find(DevCPS.name, fwd);
name := DevCPS.name;
IF (fwd # NIL) & ((fwd.mnolev # level) OR (fwd.mode = SProc)) THEN fwd := NIL END ;
IF (fwd # NIL) & (fwd.mode IN {LProc, XProc}) & ~(hasBody IN fwd.conval.setval) THEN
(* there exists a corresponding forward declaration *)
proc := DevCPT.NewObj(); proc.leaf := TRUE;
proc.mode := mode; proc.conval := DevCPT.NewConst();
CheckMark(proc);
IF fwd.vis # proc.vis THEN err(118) END
ELSE
IF fwd # NIL THEN err(1); fwd := NIL END ;
DevCPT.Insert(name, proc);
proc.mode := mode; proc.conval := DevCPT.NewConst();
CheckMark(proc);
END ;
IF (proc.vis # internal) & (mode = LProc) THEN mode := XProc END ;
IF (mode # LProc) & (level > 0) THEN err(73) END ;
INC(level); DevCPT.OpenScope(level, proc);
proc.link := NIL; GetParams; (* may change proc := fwd !!! *)
IF mode = CProc THEN GetCode
ELSIF DevCPM.noCode IN DevCPM.options THEN INCL(proc.conval.setval, hasBody)
ELSIF ~forward THEN Body; proc.adr := 0
ELSE proc.adr := DevCPM.errpos
END ;
DEC(level); DevCPT.CloseScope
ELSE err(ident)
END
END ProcedureDeclaration;
PROCEDURE CaseLabelList(VAR lab, root: DevCPT.Node; LabelForm: SHORTINT; VAR min, max: INTEGER);
VAR x, y, lastlab: DevCPT.Node; i, f: SHORTINT; xval, yval: INTEGER;
PROCEDURE Insert(VAR n: DevCPT.Node); (* build binary tree of label ranges *) (* !!! *)
BEGIN
IF n = NIL THEN
IF x.hint # 1 THEN n := x END
ELSIF yval < n.conval.intval THEN Insert(n.left)
ELSIF xval > n.conval.intval2 THEN Insert(n.right)
ELSE err(63)
END
END Insert;
BEGIN lab := NIL; lastlab := NIL;
LOOP ConstExpression(x); f := x.typ.form;
IF f IN {Int8..Int32} + charSet THENxval := x.conval.intval
ELSE err(61); xval := 1
END ;
IF (f IN {Int8..Int32}) # (LabelForm IN {Int8..Int32}) THEN err(60) END;
IF sym = upto THEN
DevCPS.Get(sym); ConstExpression(y); yval := y.conval.intval;
IF (y.typ.form IN {Int8..Int32}) # (LabelForm IN {Int8..Int32}) THEN err(60) END;
IF yval < xval THEN err(63); yval := xval END
ELSE yval := xval
END ;
x.conval.intval2 := yval;
IF xval < min THEN min := xval END;
IF yval > max THEN max := yval END;
IF lab = NIL THEN lab := x; Insert(root)
ELSIF yval < lab.conval.intval - 1 THEN x.link := lab; lab := x; Insert(root)
ELSIF yval = lab.conval.intval - 1 THEN x.hint := 1; Insert(root); lab.conval.intval := xval
ELSIF xval = lab.conval.intval2 + 1 THEN x.hint := 1; Insert(root); lab.conval.intval2 := yval
ELSE
y := lab;
WHILE (y.link # NIL) & (xval > y.link.conval.intval2 + 1) DO y := y.link END;
IF y.link = NIL THEN y.link := x; Insert(root)
ELSIF yval < y.link.conval.intval - 1 THEN x.link := y.link; y.link := x; Insert(root)
ELSIF yval = y.link.conval.intval - 1 THEN x.hint := 1; Insert(root); y.link.conval.intval := xval
ELSIF xval = y.link.conval.intval2 + 1 THEN x.hint := 1; Insert(root); y.link.conval.intval2 := yval
END
END;
IF sym = comma THEN DevCPS.Get(sym)
ELSIF (sym = number) OR (sym = ident) THEN err(comma)
ELSE EXIT
END
END
END CaseLabelList;
PROCEDURE StatSeq(VAR stat: DevCPT.Node);
VAR fpar, id, t, obj: DevCPT.Object; idtyp: DevCPT.Struct; e: BOOLEAN;
s, x, y, z, apar, last, lastif, pre, lastp: DevCPT.Node; pos, p: INTEGER; name: DevCPT.Name;
PROCEDURE CasePart(VAR x: DevCPT.Node);
VAR low, high: INTEGER; e: BOOLEAN; cases, lab, y, lastcase, root: DevCPT.Node;
BEGIN
Expression(x);
IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
ELSIF x.typ.form = Int64 THEN err(260)
ELSIF ~(x.typ.form IN {Int8..Int32} + charSet) THEN err(125)
END ;
CheckSym(of); cases := NIL; lastcase := NIL; root := NIL;
low := MAX(INTEGER); high := MIN(INTEGER);
LOOP
IF sym < bar THEN
CaseLabelList(lab, root, x.typ.form, low, high);
CheckSym(colon); StatSeq(y);
DevCPB.Construct(Ncasedo, lab, y); DevCPB.Link(cases, lastcase, lab)
END ;
IF sym = bar THEN DevCPS.Get(sym) ELSE EXIT END
END;
e := sym = else;
IF e THEN DevCPS.Get(sym); StatSeq(y) ELSE y := NIL END ;
DevCPB.Construct(Ncaselse, cases, y); DevCPB.Construct(Ncase, x, cases);
cases.conval := DevCPT.NewConst();
cases.conval.intval := low; cases.conval.intval2 := high;
IF e THEN cases.conval.setval := {1} ELSE cases.conval.setval := {} END;
DevCPB.OptimizeCase(root); cases.link := root (* !!! *)
END CasePart;
PROCEDURE SetPos(x: DevCPT.Node);
BEGIN
x.conval := DevCPT.NewConst(); x.conval.intval := pos
END SetPos;
PROCEDURE CheckBool(VAR x: DevCPT.Node);
BEGIN
IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126); x := DevCPB.NewBoolConst(FALSE)
ELSIF x.typ.form # Bool THEN err(120); x := DevCPB.NewBoolConst(FALSE)
END
END CheckBool;
BEGIN stat := NIL; last := NIL;
LOOP x := NIL;
IF sym < ident THEN err(14);
REPEAT DevCPS.Get(sym) UNTIL sym >= ident
END ;
pos := DevCPM.startpos;
IF sym = ident THEN
qualident(id); x := DevCPB.NewLeaf(id); selector(x);
IF sym = becomes THEN
DevCPS.Get(sym); Expression(y);
IF (y.typ.form = Pointer) & (x.typ.form = Comp) THEN DevCPB.DeRef(y) END;
pre := NIL; lastp := NIL;
DevCPB.CheckBuffering(y, x, NIL, pre, lastp);
DevCPB.Assign(x, y);
IF pre # NIL THEN SetPos(x); DevCPB.Construct(Ncomp, pre, x); x := pre END;
ELSIF sym = eql THEN
err(becomes); DevCPS.Get(sym); Expression(y); DevCPB.Assign(x, y)
ELSIF (x.class = Nproc) & (x.obj.mode = SProc) THEN
StandProcCall(x);
IF (x # NIL) & (x.typ # DevCPT.notyp) THEN err(55) END;
IF (x # NIL) & (x.class = Nifelse) THEN (* error pos for ASSERT *)
SetPos(x.left); SetPos(x.left.right)
END
ELSIF x.class = Ncall THEN err(55)
ELSE
pre := NIL; lastp := NIL;
DevCPB.PrepCall(x, fpar);
IF (x.obj # NIL) & (x.obj.mode = TProc) THEN DevCPB.CheckBuffering(x.left, NIL, x.obj.link, pre, lastp) END;
IF sym = lparen THEN
DevCPS.Get(sym); ActualParameters(apar, fpar, pre, lastp); CheckSym(rparen)
ELSE apar := NIL;
IF fpar # NIL THEN err(65) END
END ;
DevCPB.Call(x, apar, fpar);
IF x.typ # DevCPT.notyp THEN err(55) END;
IF pre # NIL THEN SetPos(x); DevCPB.Construct(Ncomp, pre, x); x := pre END;
IF level > 0 THEN DevCPT.topScope.link.leaf := FALSE END
END
ELSIF sym = if THEN
DevCPS.Get(sym); pos := DevCPM.startpos; Expression(x); CheckBool(x); CheckSym(then); StatSeq(y);
DevCPB.Construct(Nif, x, y); SetPos(x); lastif := x;
WHILE sym = elsif DO
DevCPS.Get(sym); pos := DevCPM.startpos; Expression(y); CheckBool(y); CheckSym(then); StatSeq(z);
DevCPB.Construct(Nif, y, z); SetPos(y); DevCPB.Link(x, lastif, y)
END ;
pos := DevCPM.startpos;
IF sym = else THEN DevCPS.Get(sym); StatSeq(y) ELSE y := NIL END ;
DevCPB.Construct(Nifelse, x, y); CheckSym(end); DevCPB.OptIf(x);
ELSIF sym = case THEN
DevCPS.Get(sym); pos := DevCPM.startpos; CasePart(x); CheckSym(end)
ELSIF sym = while THEN
DevCPS.Get(sym); pos := DevCPM.startpos; Expression(x); CheckBool(x); CheckSym(do); StatSeq(y);
DevCPB.Construct(Nwhile, x, y); CheckSym(end)
ELSIF sym = repeat THEN
DevCPS.Get(sym); StatSeq(x);
IF sym = until THEN DevCPS.Get(sym); pos := DevCPM.startpos; Expression(y); CheckBool(y)
ELSE err(43)
END ;
DevCPB.Construct(Nrepeat, x, y)
ELSIF sym = for THEN
DevCPS.Get(sym); pos := DevCPM.startpos;
IF sym = ident THEN qualident(id);
IF ~(id.typ.form IN intSet) THEN err(68) END ;
CheckSym(becomes); Expression(y);
x := DevCPB.NewLeaf(id); DevCPB.Assign(x, y); SetPos(x);
CheckSym(to); pos := DevCPM.startpos; Expression(y);
IF y.class # Nconst THEN
DevCPB.GetTempVar("@for", x.left.typ, t);
z := DevCPB.NewLeaf(t); DevCPB.Assign(z, y); SetPos(z); DevCPB.Link(stat, last, z);
y := DevCPB.NewLeaf(t)
ELSE
DevCPB.CheckAssign(x.left.typ, y)
END ;
DevCPB.Link(stat, last, x);
p := DevCPM.startpos;
IF sym = by THEN DevCPS.Get(sym); ConstExpression(z) ELSE z := DevCPB.NewIntConst(1) END ;
x := DevCPB.NewLeaf(id);
IF z.conval.intval > 0 THEN DevCPB.Op(leq, x, y)
ELSIF z.conval.intval < 0 THEN DevCPB.Op(geq, x, y)
ELSE err(63); DevCPB.Op(geq, x, y)
END ;
CheckSym(do); StatSeq(s);
y := DevCPB.NewLeaf(id); DevCPB.StPar1(y, z, incfn); pos := DevCPM.startpos; SetPos(y);
IF s = NIL THEN s := y
ELSE z := s;
WHILE z.link # NIL DO z := z.link END ;
z.link := y
END ;
CheckSym(end); DevCPB.Construct(Nwhile, x, s); pos := p
ELSE err(ident)
END
ELSIF sym = loop THEN
DevCPS.Get(sym); INC(LoopLevel); StatSeq(x); DEC(LoopLevel);
DevCPB.Construct(Nloop, x, NIL); CheckSym(end)
ELSIF sym = with THEN
DevCPS.Get(sym); idtyp := NIL; x := NIL;
LOOP
IF sym < bar THEN
pos := DevCPM.startpos;
IF sym = ident THEN
qualident(id); y := DevCPB.NewLeaf(id);
IF (id # NIL) & (id.typ.form = Pointer) & ((id.mode = VarPar) OR ~id.leaf) THEN
err(-302) (* warning 302 *)
END ;
CheckSym(colon);
IF sym = ident THEN qualident(t);
IF t.mode = Typ THEN
IF id # NIL THEN
idtyp := id.typ; DevCPB.TypTest(y, t, FALSE); id.typ := t.typ;
IF id.ptyp = NIL THEN id.ptyp := idtyp END
ELSE err(130)
END
ELSE err(52)
END
ELSE err(ident)
END
ELSE err(ident)
END ;
CheckSym(do); StatSeq(s); DevCPB.Construct(Nif, y, s); SetPos(y);
IF idtyp # NIL THEN
IF id.ptyp = idtyp THEN id.ptyp := NIL END;
id.typ := idtyp; idtyp := NIL
END ;
IF x = NIL THEN x := y; lastif := x ELSE DevCPB.Link(x, lastif, y) END
END;
IF sym = bar THEN DevCPS.Get(sym) ELSE EXIT END
END;
e := sym = else; pos := DevCPM.startpos;
IF e THEN DevCPS.Get(sym); StatSeq(s) ELSE s := NIL END ;
DevCPB.Construct(Nwith, x, s); CheckSym(end);
IF e THEN x.subcl := 1 END
ELSIF sym = exit THEN
DevCPS.Get(sym);
IF LoopLevel = 0 THEN err(46) END ;
DevCPB.Construct(Nexit, x, NIL)
ELSIF sym = return THEN DevCPS.Get(sym);
IF sym < semicolon THEN Expression(x) END ;
IF level > 0 THEN DevCPB.Return(x, DevCPT.topScope.link)
ELSE (* not standard Oberon *) DevCPB.Return(x, NIL)
END;
hasReturn := TRUE
END ;
IF x # NIL THEN SetPos(x); DevCPB.Link(stat, last, x) END ;
IF sym = semicolon THEN DevCPS.Get(sym)
ELSIF (sym <= ident) OR (if <= sym) & (sym <= return) THEN err(semicolon)
ELSE EXIT
END
END
END StatSeq;
PROCEDURE Block(VAR procdec, statseq: DevCPT.Node);
VAR typ: DevCPT.Struct;
obj, first, last, o: DevCPT.Object;
x, lastdec: DevCPT.Node;
i: SHORTINT;
rname: DevCPT.Name;
name: DevCPT.String;
rec: Elem;
BEGIN
IF ((sym < begin) OR (sym > var)) & (sym # procedure) & (sym # end) & (sym # close) THEN err(36) END;
first := NIL; last := NIL; userList := NIL; recList := NIL;
LOOP
IF sym = const THEN
DevCPS.Get(sym);
WHILE sym = ident DO
DevCPT.Insert(DevCPS.name, obj);
obj.mode := Con; CheckMark(obj);
obj.typ := DevCPT.int8typ; obj.mode := Var; (* Var to avoid recursive definition *)
IF sym = eql THEN
DevCPS.Get(sym); ConstExpression(x)
ELSIF sym = becomes THEN
err(eql); DevCPS.Get(sym); ConstExpression(x)
ELSE err(eql); x := DevCPB.NewIntConst(1)
END ;
obj.mode := Con; obj.typ := x.typ; obj.conval := x.conval; (* ConstDesc ist not copied *)
CheckSym(semicolon)
END
END ;
IF sym = type THEN
DevCPS.Get(sym);
WHILE sym = ident DO
DevCPT.Insert(DevCPS.name, obj); obj.mode := Typ; obj.typ := DevCPT.undftyp;
CheckMark(obj); obj.mode := -1;
IF sym # eql THEN err(eql) END;
IF (sym = eql) OR (sym = becomes) OR (sym = colon) THEN
DevCPS.Get(sym); Type(obj.typ, name); SetType(NIL, obj, obj.typ, name);
END;
obj.mode := Typ;
IF obj.typ.form IN {Byte..Set, Char16, Int64} THEN (* make alias structure *)
typ := DevCPT.NewStr(obj.typ.form, Basic); i := typ.ref;
typ^ := obj.typ^; typ.ref := i; typ.strobj := NIL; typ.mno := 0; typ.txtpos := DevCPM.errpos;
typ.BaseTyp := obj.typ; obj.typ := typ;
END;
IF obj.typ.strobj = NIL THEN obj.typ.strobj := obj END ;
IF obj.typ.form = Pointer THEN (* !!! *)
typ := obj.typ.BaseTyp;
IF (typ # NIL) & (typ.comp = Record) & (typ.strobj = NIL) THEN
(* pointer to unnamed record: name record as "pointerName^" *)
rname := obj.name^$; i := 0;
WHILE rname[i] # 0X DO INC(i) END;
rname[i] := "^"; rname[i+1] := 0X;
DevCPT.Insert(rname, o); o.mode := Typ; o.typ := typ; typ.strobj := o
END
END;
IF obj.vis # internal THEN
typ := obj.typ;
IF typ.form = Pointer THEN typ := typ.BaseTyp END;
IF typ.comp = Record THEN typ.exp := TRUE END
END;
CheckSym(semicolon)
END
END ;
IF sym = var THEN
DevCPS.Get(sym);
WHILE sym = ident DO
LOOP
IF sym = ident THEN
DevCPT.Insert(DevCPS.name, obj);
obj.mode := Var; obj.link := NIL; obj.leaf := obj.vis = internal; obj.typ := DevCPT.undftyp;
CheckMark(obj);
IF first = NIL THEN first := obj END ;
IF last = NIL THEN DevCPT.topScope.scope := obj ELSE last.link := obj END ;
last := obj
ELSE err(ident)
END ;
IF sym = comma THEN DevCPS.Get(sym)
ELSIF sym = ident THEN err(comma)
ELSE EXIT
END
END ;
CheckSym(colon); Type(typ, name);
CheckAlloc(typ, FALSE, DevCPM.errpos);
WHILE first # NIL DO SetType(NIL, first, typ, name); first := first.link END ;
CheckSym(semicolon)
END
END ;
IF (sym < const) OR (sym > var) THEN EXIT END ;
END ;
CheckForwardTypes;
userList := NIL; rec := recList; recList := NIL;
DevCPT.topScope.adr := DevCPM.errpos;
procdec := NIL; lastdec := NIL;
IF (sym # procedure) & (sym # begin) & (sym # end) & (sym # close) THEN err(37) END;
WHILE sym = procedure DO
DevCPS.Get(sym); ProcedureDeclaration(x);
IF x # NIL THEN
IF lastdec = NIL THEN procdec := x ELSE lastdec.link := x END ;
lastdec := x
END ;
CheckSym(semicolon)
END ;
IF DevCPM.noerr & ~(DevCPM.oberon IN DevCPM.options) THEN CheckRecords(rec) END;
hasReturn := FALSE;
IF (sym # begin) & (sym # end) & (sym # close) THEN err(38) END;
IF sym = begin THEN DevCPS.Get(sym); StatSeq(statseq)
ELSE statseq := NIL
END ;
IF (DevCPT.topScope.link # NIL) & (DevCPT.topScope.link.typ # DevCPT.notyp)
& ~hasReturn & (DevCPT.topScope.link.sysflag = 0) THEN err(133) END;
IF (level = 0) & (TDinit # NIL) THEN
lastTDinit.link := statseq; statseq := TDinit
END
END Block;
PROCEDURE Module*(VAR prog: DevCPT.Node);
VAR impName, aliasName: DevCPT.Name;
procdec, statseq: DevCPT.Node;
c, sf: INTEGER; done: BOOLEAN;
BEGIN
DevCPS.Init; LoopLevel := 0; level := 0; DevCPS.Get(sym);
IF sym = module THEN DevCPS.Get(sym) ELSE err(16) END ;
IF sym = ident THEN
DevCPT.Open(DevCPS.name); DevCPS.Get(sym);
DevCPT.libName := "";
IF sym = lbrak THEN
INCL(DevCPM.options, DevCPM.interface); DevCPS.Get(sym);
IF sym = eql THEN DevCPS.Get(sym)
ELSE INCL(DevCPM.options, DevCPM.noCode)
END;
IF sym = string THEN DevCPT.libName := DevCPS.str^$; DevCPS.Get(sym)
ELSE err(string)
END;
CheckSym(rbrak)
END;
CheckSym(semicolon);
IF sym = import THEN DevCPS.Get(sym);
LOOP
IF sym = ident THEN
aliasName := DevCPS.name$; impName := aliasName$; DevCPS.Get(sym);
IF sym = becomes THEN DevCPS.Get(sym);
IF sym = ident THEN impName := DevCPS.name$; DevCPS.Get(sym) ELSE err(ident) END
END ;
DevCPT.Import(aliasName, impName, done)
ELSE err(ident)
END ;
IF sym = comma THEN DevCPS.Get(sym)
ELSIF sym = ident THEN err(comma)
ELSE EXIT
END
END ;
CheckSym(semicolon)
END ;
IF DevCPM.noerr THEN TDinit := NIL; lastTDinit := NIL; c := DevCPM.errpos;
Block(procdec, statseq); DevCPB.Enter(procdec, statseq, NIL); prog := procdec;
prog.conval := DevCPT.NewConst(); prog.conval.intval := c; prog.conval.intval2 := DevCPM.startpos;
IF sym = close THEN DevCPS.Get(sym); StatSeq(prog.link) END;
prog.conval.realval := DevCPM.startpos;
CheckSym(end);
IF sym = ident THEN
IF DevCPS.name # DevCPT.SelfName THEN err(4) END ;
DevCPS.Get(sym)
ELSE err(ident)
END;
IF sym # period THEN err(period) END
END
ELSE err(ident)
END ;
TDinit := NIL; lastTDinit := NIL;
DevCPS.str := NIL
END Module;
END DevCPP.