home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Amiga MA Magazine 1998 #6
/
amigamamagazinepolishissue1998.iso
/
coders
/
jËzyki_programowania
/
oberon
/
system
/
opp.mod
(
.txt
)
< prev
next >
Wrap
Oberon Text
|
1977-12-31
|
35KB
|
1,013 lines
Syntax24.Scn.Fnt
Syntax10b.Scn.Fnt
Syntax10.Scn.Fnt
Syntax10i.Scn.Fnt
(* Notify Ralf for maintenance of Non-FPU source *)
MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *)
IMPORT
OPT, OPS, OPM, OPB;
CONST
(* numtyp values *)
char = 1; integer = 2; real = 3; longreal = 4;
(* 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; period = 18; comma = 19;
colon = 20; upto = 21; rparen = 22; rbrak = 23; rbrace = 24;
of = 25; then = 26; do = 27; to = 28; by = 29;
lparen = 30; lbrak = 31; lbrace = 32; not = 33; becomes = 34;
number = 35; nil = 36; string = 37; ident = 38; semicolon = 39;
bar = 40; end = 41; else = 42; elsif = 43; until = 44;
if = 45; case = 46; while = 47; repeat = 48; for = 49;
loop = 50; with = 51; exit = 52; return = 53; array = 54;
record = 55; pointer = 56; begin = 57; const = 58; type = 59;
var = 60; procedure = 61; import = 62; module = 63; eof = 64;
(* 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;
(* Structure forms *)
Undef = 0; Byte = 1; Bool = 2; Char = 3; SInt = 4; Int = 5; LInt = 6;
Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12;
Pointer = 13; ProcTyp = 14; Comp = 15;
intSet = {SInt..LInt};
(* 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;
(* node subclasses *)
super = 1;
(* module visibility of objects *)
internal = 0; external = 1; externalR = 2;
(* procedure flags (conval^.setval) *)
hasBody = 1; isRedef = 2; slNeeded = 3;
TYPE
CaseTable = ARRAY OPM.MaxCases OF
RECORD
low, high: LONGINT
END ;
sym, level: SHORTINT;
LoopLevel: INTEGER;
TDinit, lastTDinit: OPT.Node;
nofFwdPtr: INTEGER;
FwdPtr: ARRAY 64 OF OPT.Struct;
PROCEDURE^ Type(VAR typ, banned: OPT.Struct);
PROCEDURE^ Expression(VAR x: OPT.Node);
PROCEDURE^ Block(VAR procdec, statseq: OPT.Node);
PROCEDURE err(n: INTEGER);
BEGIN OPM.err(n)
END err;
PROCEDURE CheckSym(s: INTEGER);
BEGIN
IF sym = s THEN OPS.Get(sym) ELSE OPM.err(s) END
END CheckSym;
PROCEDURE qualident(VAR id: OPT.Object);
VAR obj: OPT.Object; lev: SHORTINT;
BEGIN (*sym = ident*)
OPT.Find(obj); OPS.Get(sym);
IF (sym = period) & (obj # NIL) & (obj^.mode = Mod) THEN
OPS.Get(sym);
IF sym = ident THEN
OPT.FindImport(obj, obj); OPS.Get(sym)
ELSE err(ident); obj := NIL
END
END ;
IF obj = NIL THEN err(0);
obj := OPT.NewObj(); obj^.mode := Var; obj^.typ := OPT.undftyp; obj^.adr := 0
ELSE lev := obj^.mnolev;
IF (obj^.mode IN {Var, VarPar}) & (lev # level) THEN
obj^.leaf := FALSE;
IF lev > 0 THEN OPB.StaticLink(level-lev) END
END
END ;
id := obj
END qualident;
PROCEDURE ConstExpression(VAR x: OPT.Node);
BEGIN Expression(x);
IF x^.class # Nconst THEN
err(50); x := OPB.NewIntConst(1)
END
END ConstExpression;
PROCEDURE CheckMark(VAR vis: SHORTINT);
BEGIN OPS.Get(sym);
IF (sym = times) OR (sym = minus) THEN
IF level > 0 THEN err(47) END ;
IF sym = times THEN vis := external ELSE vis := externalR END ;
OPS.Get(sym)
ELSE vis := internal
END
END CheckMark;
PROCEDURE CheckSysFlag(VAR sysflag: INTEGER; default: INTEGER);
VAR x: OPT.Node; sf: LONGINT;
BEGIN
IF sym = lbrak THEN OPS.Get(sym); ConstExpression(x);
IF x^.typ^.form IN intSet THEN sf := x^.conval^.intval;
IF (sf < 0) OR (sf > OPM.MaxSysFlag) THEN err(220); sf := 0 END
ELSE err(51); sf := 0
END ;
sysflag := SHORT(sf); CheckSym(rbrak)
ELSE sysflag := default
END
END CheckSysFlag;
PROCEDURE RecordType(VAR typ, banned: OPT.Struct);
VAR fld, first, last, base: OPT.Object;
ftyp: OPT.Struct; sysflag: INTEGER;
BEGIN typ := OPT.NewStr(Comp, Record); typ^.BaseTyp := NIL;
CheckSysFlag(sysflag, -1);
IF sym = lparen THEN
OPS.Get(sym); (*record extension*)
IF sym = ident THEN
qualident(base);
IF (base^.mode = Typ) & (base^.typ^.comp = Record) THEN
IF base^.typ = banned THEN err(58)
ELSE typ^.BaseTyp := base^.typ; typ^.extlev := base^.typ^.extlev + 1; typ^.sysflag := base^.typ^.sysflag
END
ELSE err(52)
END
ELSE err(ident)
END ;
CheckSym(rparen)
END ;
IF sysflag >= 0 THEN typ^.sysflag := sysflag END ;
OPT.OpenScope(0, NIL); first := NIL; last := NIL;
LOOP
IF sym = ident THEN
LOOP
IF sym = ident THEN
IF typ^.BaseTyp # NIL THEN
OPT.FindField(OPS.name, typ^.BaseTyp, fld);
IF fld # NIL THEN err(1) END
END ;
OPT.Insert(OPS.name, fld); CheckMark(fld^.vis);
fld^.mode := Fld; fld^.link := NIL; fld^.typ := OPT.undftyp;
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 OPS.Get(sym)
ELSIF sym = ident THEN err(comma)
ELSE EXIT
END
END ;
CheckSym(colon); Type(ftyp, banned);
IF ftyp^.comp = DynArr THEN ftyp := OPT.undftyp; err(88) END ;
WHILE first # NIL DO
first^.typ := ftyp; first := first^.link
END
END ;
IF sym = semicolon THEN OPS.Get(sym)
ELSIF sym = ident THEN err(semicolon)
ELSE EXIT
END
END ;
OPT.CloseScope
END RecordType;
PROCEDURE ArrayType(VAR typ, banned: OPT.Struct);
VAR x: OPT.Node; n: LONGINT; sysflag: INTEGER;
BEGIN CheckSysFlag(sysflag, 0);
IF sym = of THEN (*dynamic array*)
typ := OPT.NewStr(Comp, DynArr); typ^.mno := 0; typ^.sysflag := sysflag;
OPS.Get(sym); Type(typ^.BaseTyp, banned);
IF typ^.BaseTyp^.comp = DynArr THEN typ^.n := typ^.BaseTyp^.n + 1
ELSE typ^.n := 0
END
ELSE
typ := OPT.NewStr(Comp, Array); typ^.sysflag := sysflag; ConstExpression(x);
IF x^.typ^.form IN intSet THEN n := x^.conval^.intval;
IF (n <= 0) OR (n > OPM.MaxIndex) THEN err(63); n := 1 END
ELSE err(51); n := 1
END ;
typ^.n := n;
IF sym = of THEN
OPS.Get(sym); Type(typ^.BaseTyp, banned)
ELSIF sym = comma THEN
OPS.Get(sym); IF sym # of THEN ArrayType(typ^.BaseTyp, banned) END
ELSE err(35)
END ;
IF typ^.BaseTyp^.comp = DynArr THEN typ^.BaseTyp := OPT.undftyp; err(88) END
END
END ArrayType;
PROCEDURE PointerType(VAR typ: OPT.Struct);
VAR id: OPT.Object;
BEGIN typ := OPT.NewStr(Pointer, Basic); CheckSysFlag(typ^.sysflag, 0);
CheckSym(to);
IF sym = ident THEN OPT.Find(id);
IF id = NIL THEN
IF nofFwdPtr < LEN(FwdPtr) THEN FwdPtr[nofFwdPtr] := typ; INC(nofFwdPtr)
ELSE err(224)
END ;
typ^.link := OPT.NewObj(); COPY(OPS.name, typ^.link^.name);
typ^.BaseTyp := OPT.undftyp; OPS.Get(sym) (*forward ref*)
ELSE qualident(id);
IF id^.mode = Typ THEN
IF id^.typ^.comp IN {Array, DynArr, Record} THEN
typ^.BaseTyp := id^.typ
ELSE typ^.BaseTyp := OPT.undftyp; err(57)
END
ELSE typ^.BaseTyp := OPT.undftyp; err(52)
END
END
ELSE Type(typ^.BaseTyp, OPT.notyp);
IF ~(typ^.BaseTyp^.comp IN {Array, DynArr, Record}) THEN
typ^.BaseTyp := OPT.undftyp; err(57)
END
END
END PointerType;
PROCEDURE FormalParameters(VAR firstPar: OPT.Object; VAR resTyp: OPT.Struct);
VAR mode: SHORTINT;
par, first, last, res: OPT.Object; typ: OPT.Struct;
BEGIN first := NIL; last := firstPar;
IF (sym = ident) OR (sym = var) THEN
LOOP
IF sym = var THEN OPS.Get(sym); mode := VarPar ELSE mode := Var END ;
LOOP
IF sym = ident THEN
OPT.Insert(OPS.name, par); OPS.Get(sym);
par^.mode := mode; par^.link := NIL;
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 OPS.Get(sym)
ELSIF sym = ident THEN err(comma)
ELSIF sym = var THEN err(comma); OPS.Get(sym)
ELSE EXIT
END
END ;
CheckSym(colon); Type(typ, OPT.notyp);
WHILE first # NIL DO first^.typ := typ; first := first^.link END ;
IF sym = semicolon THEN OPS.Get(sym)
ELSIF sym = ident THEN err(semicolon)
ELSE EXIT
END
END
END ;
CheckSym(rparen);
IF sym = colon THEN
OPS.Get(sym); resTyp := OPT.undftyp;
IF sym = ident THEN qualident(res);
IF res^.mode = Typ THEN
IF res^.typ^.form < Comp THEN resTyp := res^.typ
ELSE err(54)
END
ELSE err(52)
END
ELSE err(ident)
END
ELSE resTyp := OPT.notyp
END
END FormalParameters;
PROCEDURE TypeDecl(VAR typ, banned: OPT.Struct);
VAR id: OPT.Object;
BEGIN typ := OPT.undftyp;
IF sym < lparen THEN err(12);
REPEAT OPS.Get(sym) UNTIL sym >= lparen
END ;
IF sym = ident THEN qualident(id);
IF id^.mode = Typ THEN
IF id^.typ # banned THEN typ := id^.typ ELSE err(58) END
ELSE err(52)
END
ELSIF sym = array THEN
OPS.Get(sym); ArrayType(typ, banned)
ELSIF sym = record THEN
OPS.Get(sym); RecordType(typ, banned);
OPB.Inittd(TDinit, lastTDinit, typ); CheckSym(end)
ELSIF sym = pointer THEN
OPS.Get(sym); PointerType(typ)
ELSIF sym = procedure THEN
OPS.Get(sym); typ := OPT.NewStr(ProcTyp, Basic); CheckSysFlag(typ^.sysflag, 0);
IF sym = lparen THEN
OPS.Get(sym); OPT.OpenScope(level, NIL);
FormalParameters(typ^.link, typ^.BaseTyp); OPT.CloseScope
ELSE typ^.BaseTyp := OPT.notyp; typ^.link := NIL
END
ELSE err(12)
END ;
LOOP
IF (sym >= semicolon) & (sym <= else) OR (sym = rparen) OR (sym = eof) THEN EXIT END;
err(15); IF sym = ident THEN EXIT END;
OPS.Get(sym)
END
END TypeDecl;
PROCEDURE Type(VAR typ, banned: OPT.Struct);
BEGIN TypeDecl(typ, banned);
IF (typ^.form = Pointer) & (typ^.BaseTyp = OPT.undftyp) & (typ^.strobj = NIL) THEN err(0) END
END Type;
PROCEDURE selector(VAR x: OPT.Node);
VAR obj, proc: OPT.Object; y: OPT.Node; typ: OPT.Struct; name: OPS.Name;
BEGIN
LOOP
IF sym = lbrak THEN OPS.Get(sym);
LOOP
IF (x^.typ # NIL) & (x^.typ^.form = Pointer) THEN OPB.DeRef(x) END ;
Expression(y); OPB.Index(x, y);
IF sym = comma THEN OPS.Get(sym) ELSE EXIT END
END ;
CheckSym(rbrak)
ELSIF sym = period THEN OPS.Get(sym);
IF sym = ident THEN name := OPS.name; OPS.Get(sym);
IF x^.typ # NIL THEN
IF x^.typ^.form = Pointer THEN OPB.DeRef(x) END ;
IF x^.typ^.comp = Record THEN
OPT.FindField(name, x^.typ, obj); OPB.Field(x, obj);
IF (obj # NIL) & (obj^.mode = TProc) THEN
IF sym = arrow THEN (* super call *) OPS.Get(sym);
y := x^.left;
IF y^.class = Nderef THEN y := y^.left END ; (* y = record variable *)
IF y^.obj # NIL THEN
proc := OPT.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) THEN err(75) END ;
typ := y^.obj^.typ;
IF typ^.form = Pointer THEN typ := typ^.BaseTyp END ;
OPT.FindField(x^.obj^.name, typ^.BaseTyp, proc);
IF proc # NIL THEN x^.subcl := super ELSE err(74) END
ELSE err(75)
END
END ;
IF (obj^.typ # OPT.notyp) & (sym # lparen) THEN err(lparen) END
END
ELSE err(53)
END
ELSE err(52)
END
ELSE err(ident)
END
ELSIF sym = arrow THEN OPS.Get(sym); OPB.DeRef(x)
ELSIF (sym = lparen) & (x^.class < Nconst) & (x^.typ^.form # ProcTyp) &
((x^.obj = NIL) OR (x^.obj^.mode # TProc)) THEN
OPS.Get(sym);
IF sym = ident THEN
qualident(obj);
IF obj^.mode = Typ THEN OPB.TypTest(x, obj, TRUE)
ELSE err(52)
END
ELSE err(ident)
END ;
CheckSym(rparen)
ELSE EXIT
END
END
END selector;
PROCEDURE ActualParameters(VAR aparlist: OPT.Node; fpar: OPT.Object);
VAR apar, last: OPT.Node;
BEGIN aparlist := NIL; last := NIL;
IF sym # rparen THEN
LOOP Expression(apar);
IF fpar # NIL THEN
OPB.Param(apar, fpar); OPB.Link(aparlist, last, apar);
fpar := fpar^.link;
ELSE err(64)
END ;
IF sym = comma THEN OPS.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 StandProcCall(VAR x: OPT.Node);
VAR y: OPT.Node; m: SHORTINT; n: INTEGER;
BEGIN m := SHORT(SHORT(x^.obj^.adr)); n := 0;
IF sym = lparen THEN OPS.Get(sym);
IF sym # rparen THEN
LOOP
IF n = 0 THEN Expression(x); OPB.StPar0(x, m); n := 1
ELSIF n = 1 THEN Expression(y); OPB.StPar1(x, y, m); n := 2
ELSE Expression(y); OPB.StParN(x, y, m, n); INC(n)
END ;
IF sym = comma THEN OPS.Get(sym)
ELSIF (lparen <= sym) & (sym <= ident) THEN err(comma)
ELSE EXIT
END
END ;
CheckSym(rparen)
ELSE OPS.Get(sym)
END ;
OPB.StFct(x, m, n)
ELSE err(lparen)
END ;
IF (level > 0) & ((m = newfn) OR (m = sysnewfn)) THEN OPT.topScope^.link^.leaf := FALSE END
END StandProcCall;
PROCEDURE Element(VAR x: OPT.Node);
VAR y: OPT.Node;
BEGIN Expression(x);
IF sym = upto THEN
OPS.Get(sym); Expression(y); OPB.SetRange(x, y)
ELSE OPB.SetElem(x)
END
END Element;
PROCEDURE Sets(VAR x: OPT.Node);
VAR y: OPT.Node;
BEGIN
IF sym # rbrace THEN
Element(x);
LOOP
IF sym = comma THEN OPS.Get(sym)
ELSIF (lparen <= sym) & (sym <= ident) THEN err(comma)
ELSE EXIT
END ;
Element(y); OPB.Op(plus, x, y)
END
ELSE x := OPB.EmptySet()
END ;
CheckSym(rbrace)
END Sets;
PROCEDURE Factor(VAR x: OPT.Node);
VAR fpar, id: OPT.Object; apar: OPT.Node;
BEGIN
IF sym < lparen THEN err(13);
REPEAT OPS.Get(sym) UNTIL sym >= lparen
END ;
IF sym = ident THEN
qualident(id); x := OPB.NewLeaf(id); selector(x);
IF (x^.class = Nproc) & (x^.obj^.mode = SProc) THEN StandProcCall(x) (* x may be NIL *)
ELSIF sym = lparen THEN
OPS.Get(sym); OPB.PrepCall(x, fpar);
ActualParameters(apar, fpar);
OPB.Call(x, apar, fpar);
CheckSym(rparen);
IF level > 0 THEN OPT.topScope^.link^.leaf := FALSE END
END
ELSIF sym = number THEN
CASE OPS.numtyp OF
char: x := OPB.NewIntConst(OPS.intval); x^.typ := OPT.chartyp
| integer: x := OPB.NewIntConst(OPS.intval)
| real: x := OPB.NewRealConst(OPS.realval, OPT.realtyp)
| longreal: x := OPB.NewRealConst(OPS.lrlval, OPT.lrltyp)
END ;
OPS.Get(sym)
ELSIF sym = string THEN
x := OPB.NewString(OPS.str, OPS.intval); OPS.Get(sym)
ELSIF sym = nil THEN
x := OPB.Nil(); OPS.Get(sym)
ELSIF sym = lparen THEN
OPS.Get(sym); Expression(x); CheckSym(rparen)
ELSIF sym = lbrak THEN
OPS.Get(sym); err(lparen); Expression(x); CheckSym(rparen)
ELSIF sym = lbrace THEN OPS.Get(sym); Sets(x)
ELSIF sym = not THEN
OPS.Get(sym); Factor(x); OPB.MOp(not, x)
ELSE err(13); OPS.Get(sym); x := NIL
END ;
IF x = NIL THEN x := OPB.NewIntConst(1); x^.typ := OPT.undftyp END
END Factor;
PROCEDURE Term(VAR x: OPT.Node);
VAR y: OPT.Node; mulop: SHORTINT;
BEGIN Factor(x);
WHILE (times <= sym) & (sym <= and) DO
mulop := sym; OPS.Get(sym);
Factor(y); OPB.Op(mulop, x, y)
END
END Term;
PROCEDURE SimpleExpression(VAR x: OPT.Node);
VAR y: OPT.Node; addop: SHORTINT;
BEGIN
IF sym = minus THEN OPS.Get(sym); Term(x); OPB.MOp(minus, x)
ELSIF sym = plus THEN OPS.Get(sym); Term(x); OPB.MOp(plus, x)
ELSE Term(x)
END ;
WHILE (plus <= sym) & (sym <= or) DO
addop := sym; OPS.Get(sym);
Term(y); OPB.Op(addop, x, y)
END
END SimpleExpression;
PROCEDURE Expression(VAR x: OPT.Node);
VAR y: OPT.Node; obj: OPT.Object; relation: SHORTINT;
BEGIN SimpleExpression(x);
IF (eql <= sym) & (sym <= geq) THEN
relation := sym; OPS.Get(sym);
SimpleExpression(y); OPB.Op(relation, x, y)
ELSIF sym = in THEN
OPS.Get(sym); SimpleExpression(y); OPB.In(x, y)
ELSIF sym = is THEN
OPS.Get(sym);
IF sym = ident THEN
qualident(obj);
IF obj^.mode = Typ THEN OPB.TypTest(x, obj, FALSE)
ELSE err(52)
END
ELSE err(ident)
END
END
END Expression;
PROCEDURE Receiver(VAR mode: SHORTINT; VAR name: OPS.Name; VAR typ, rec: OPT.Struct);
VAR obj: OPT.Object;
BEGIN typ := OPT.undftyp; rec := NIL;
IF sym = var THEN OPS.Get(sym); mode := VarPar ELSE mode := Var END ;
name := OPS.name; CheckSym(ident); CheckSym(colon);
IF sym = ident THEN OPT.Find(obj); OPS.Get(sym);
IF obj = NIL THEN err(0)
ELSIF obj^.mode # Typ THEN err(72)
ELSE typ := obj^.typ; rec := typ;
IF rec^.form = Pointer THEN rec := rec^.BaseTyp 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
END
ELSE err(ident)
END ;
CheckSym(rparen);
IF rec = NIL THEN rec := OPT.NewStr(Comp, Record); rec^.BaseTyp := NIL END
END Receiver;
PROCEDURE Extends(x, b: OPT.Struct): BOOLEAN;
BEGIN
IF (b^.form = Pointer) & (x^.form = Pointer) THEN b := b^.BaseTyp; x := x^.BaseTyp END ;
IF (b^.comp = Record) & (x^.comp = Record) THEN
REPEAT x := x^.BaseTyp UNTIL (x = NIL) OR (x = b)
END ;
RETURN x = b
END Extends;
PROCEDURE ProcedureDeclaration(VAR x: OPT.Node);
VAR proc, fwd: OPT.Object;
name: OPS.Name;
mode, vis: SHORTINT;
forward: BOOLEAN;
PROCEDURE GetCode;
VAR ext: OPT.ConstExt; n: INTEGER; c: LONGINT;
BEGIN
ext := OPT.NewExt(); proc^.conval^.ext := ext; n := 0;
IF sym = string THEN
WHILE OPS.str[n] # 0X DO ext[n+1] := OPS.str[n]; INC(n) END ;
ext^[0] := CHR(n); OPS.Get(sym)
ELSE
LOOP
IF sym = number THEN c := OPS.intval; INC(n);
IF (c < 0) OR (c > 255) OR (n = OPT.MaxConstLen) THEN
err(64); c := 1; n := 1
END ;
OPS.Get(sym); ext^[n] := CHR(c)
END ;
IF sym = comma THEN OPS.Get(sym)
ELSIF sym = number THEN err(comma)
ELSE ext^[0] := CHR(n); EXIT
END
END
END ;
INCL(proc^.conval^.setval, hasBody)
END GetCode;
PROCEDURE GetParams;
BEGIN
proc^.vis := vis; proc^.mode := mode; proc^.typ := OPT.notyp;
proc^.conval := OPT.NewConst(); proc^.conval^.setval := {};
IF sym = lparen THEN
OPS.Get(sym); FormalParameters(proc^.link, proc^.typ)
END ;
IF fwd # NIL THEN
OPB.CheckParameters(proc^.link, fwd^.link, TRUE);
IF proc^.typ # fwd^.typ THEN err(117) END ;
proc := fwd; OPT.topScope := proc^.scope;
IF mode = IProc THEN proc^.mode := IProc END
END
END GetParams;
PROCEDURE Body;
VAR procdec, statseq: OPT.Node; c: LONGINT;
BEGIN
c := OPM.errpos;
INCL(proc^.conval^.setval, hasBody);
CheckSym(semicolon); Block(procdec, statseq);
OPB.Enter(procdec, statseq, proc); x := procdec;
x^.conval := OPT.NewConst(); x^.conval^.intval := c;
IF sym = ident THEN
IF OPS.name # proc^.name THEN err(4) END ;
OPS.Get(sym)
ELSE err(ident)
END
END Body;
PROCEDURE TProcDecl;
VAR baseProc: OPT.Object;
objTyp, recTyp: OPT.Struct;
objMode: SHORTINT;
objName: OPS.Name;
BEGIN
OPS.Get(sym); mode := TProc;
IF level > 0 THEN err(73) END ;
Receiver(objMode, objName, objTyp, recTyp);
IF sym = ident THEN
name := OPS.name; CheckMark(vis);
OPT.FindField(name, recTyp, fwd);
OPT.FindField(name, recTyp^.BaseTyp, baseProc);
IF (baseProc # NIL) & (baseProc^.mode # TProc) THEN baseProc := NIL END ;
IF fwd = baseProc THEN fwd := NIL END ;
IF (fwd # NIL) & (fwd^.mnolev # level) THEN fwd := NIL END ;
IF (fwd # NIL) & (fwd^.mode = TProc) & ~(hasBody IN fwd^.conval^.setval) THEN
(* there exists a corresponding forward declaration *)
proc := OPT.NewObj(); proc^.leaf := TRUE;
IF fwd^.vis # vis THEN err(118) END
ELSE
IF fwd # NIL THEN err(1); fwd := NIL END ;
OPT.OpenScope(0, NIL); OPT.topScope^.right := recTyp^.link; OPT.Insert(name, proc);
recTyp^.link := OPT.topScope^.right; OPT.CloseScope;
END ;
INC(level); OPT.OpenScope(level, proc);
OPT.Insert(objName, proc^.link); proc^.link^.mode := objMode; proc^.link^.typ := objTyp;
GetParams;
IF baseProc # NIL THEN
IF (objMode # baseProc^.link^.mode) OR ~Extends(objTyp, baseProc^.link^.typ) THEN err(115) END ;
OPB.CheckParameters(proc^.link^.link, baseProc^.link^.link, FALSE);
IF proc^.typ # baseProc^.typ THEN err(117) END ;
IF (baseProc^.vis = external) & (proc^.vis = internal) &
(recTyp^.strobj # NIL) & (recTyp^.strobj^.vis = external) THEN err(109)
END ;
INCL(proc^.conval^.setval, isRedef)
END ;
IF ~forward THEN Body END ;
DEC(level); OPT.CloseScope
ELSE err(ident)
END
END TProcDecl;
BEGIN proc := NIL; forward := FALSE; x := NIL; mode := LProc;
IF (sym # ident) & (sym # lparen) THEN
IF sym = times THEN (* mode set later in OPB.CheckAssign *)
ELSIF sym = arrow THEN forward := TRUE
ELSIF sym = plus THEN mode := IProc
ELSIF sym = minus THEN mode := CProc
ELSE err(ident)
END ;
IF (mode IN {IProc, CProc}) & ~OPT.SYSimported THEN err(135) END ;
OPS.Get(sym)
END ;
IF sym = lparen THEN TProcDecl
ELSIF sym = ident THEN OPT.Find(fwd);
name := OPS.name; CheckMark(vis);
IF (vis # internal) & (mode = LProc) THEN mode := XProc END ;
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 := OPT.NewObj(); proc^.leaf := TRUE;
IF fwd^.vis # vis THEN err(118) END
ELSE
IF fwd # NIL THEN err(1); fwd := NIL END ;
OPT.Insert(name, proc)
END ;
IF (mode # LProc) & (level > 0) THEN err(73) END ;
INC(level); OPT.OpenScope(level, proc);
proc^.link := NIL; GetParams;
IF mode = CProc THEN GetCode
ELSIF ~forward THEN Body
END ;
DEC(level); OPT.CloseScope
ELSE err(ident)
END
END ProcedureDeclaration;
PROCEDURE CaseLabelList(VAR lab: OPT.Node; LabelForm: INTEGER; VAR n: INTEGER; VAR tab: CaseTable);
VAR x, y, lastlab: OPT.Node; i, f: INTEGER; xval, yval: LONGINT;
BEGIN lab := NIL; lastlab := NIL;
LOOP ConstExpression(x); f := x^.typ^.form;
IF f IN intSet + {Char} THEN xval := x^.conval^.intval
ELSE err(61); xval := 1
END ;
IF f IN intSet THEN
IF LabelForm < f THEN err(60) END
ELSIF LabelForm # f THEN err(60)
END ;
IF sym = upto THEN
OPS.Get(sym); ConstExpression(y); yval := y^.conval^.intval;
IF (y^.typ^.form # f) & ~((f IN intSet) & (y^.typ^.form IN intSet)) THEN err(60) END ;
IF yval < xval THEN err(63); yval := xval END
ELSE yval := xval
END ;
x^.conval^.intval2 := yval;
(*enter label range into ordered table*) i := n;
IF i < OPM.MaxCases THEN
LOOP
IF i = 0 THEN EXIT END ;
IF tab[i-1].low <= yval THEN
IF tab[i-1].high >= xval THEN err(62) END ;
EXIT
END ;
tab[i] := tab[i-1]; DEC(i)
END ;
tab[i].low := xval; tab[i].high := yval; INC(n)
ELSE err(213)
END ;
OPB.Link(lab, lastlab, x);
IF sym = comma THEN OPS.Get(sym)
ELSIF (sym = number) OR (sym = ident) THEN err(comma)
ELSE EXIT
END
END
END CaseLabelList;
PROCEDURE StatSeq(VAR stat: OPT.Node);
VAR fpar, id, t, obj: OPT.Object; idtyp: OPT.Struct; e: BOOLEAN;
s, x, y, z, apar, last, lastif: OPT.Node; pos: LONGINT; name: OPS.Name;
PROCEDURE CasePart(VAR x: OPT.Node);
VAR n: INTEGER; low, high: LONGINT; e: BOOLEAN;
tab: CaseTable; cases, lab, y, lastcase: OPT.Node;
BEGIN
Expression(x); pos := OPM.errpos;
IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
ELSIF ~(x^.typ^.form IN {Char..LInt}) THEN err(125)
END ;
CheckSym(of); cases := NIL; lastcase := NIL; n := 0;
LOOP
IF sym < bar THEN
CaseLabelList(lab, x^.typ^.form, n, tab);
CheckSym(colon); StatSeq(y);
OPB.Construct(Ncasedo, lab, y); OPB.Link(cases, lastcase, lab)
END ;
IF sym = bar THEN OPS.Get(sym) ELSE EXIT END
END ;
IF n > 0 THEN low := tab[0].low; high := tab[n-1].high;
IF high - low > OPM.MaxCaseRange THEN err(209) END
ELSE low := 1; high := 0
END ;
e := sym = else;
IF e THEN OPS.Get(sym); StatSeq(y) ELSE y := NIL END ;
OPB.Construct(Ncaselse, cases, y); OPB.Construct(Ncase, x, cases);
cases^.conval := OPT.NewConst();
cases^.conval^.intval := low; cases^.conval^.intval2 := high;
IF e THEN cases^.conval^.setval := {1} ELSE cases^.conval^.setval := {} END
END CasePart;
PROCEDURE SetPos(x: OPT.Node);
BEGIN
x^.conval := OPT.NewConst(); x^.conval^.intval := pos
END SetPos;
PROCEDURE CheckBool(VAR x: OPT.Node);
BEGIN
IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126); x := OPB.NewBoolConst(FALSE)
ELSIF x^.typ^.form # Bool THEN err(120); x := OPB.NewBoolConst(FALSE)
END ;
pos := OPM.errpos
END CheckBool;
BEGIN stat := NIL; last := NIL;
LOOP x := NIL;
IF sym < ident THEN err(14);
REPEAT OPS.Get(sym) UNTIL sym >= ident
END ;
IF sym = ident THEN
qualident(id); x := OPB.NewLeaf(id); selector(x);
IF sym = becomes THEN
OPS.Get(sym); Expression(y); OPB.Assign(x, y)
ELSIF sym = eql THEN
err(becomes); OPS.Get(sym); Expression(y); OPB.Assign(x, y)
ELSIF (x^.class = Nproc) & (x^.obj^.mode = SProc) THEN
StandProcCall(x);
IF (x # NIL) & (x^.typ # OPT.notyp) THEN err(55) END
ELSE OPB.PrepCall(x, fpar);
IF sym = lparen THEN
OPS.Get(sym); ActualParameters(apar, fpar); CheckSym(rparen)
ELSE apar := NIL;
IF fpar # NIL THEN err(65) END
END ;
OPB.Call(x, apar, fpar);
IF x^.typ # OPT.notyp THEN err(55) END ;
IF level > 0 THEN OPT.topScope^.link^.leaf := FALSE END
END ;
pos := OPM.errpos
ELSIF sym = if THEN
OPS.Get(sym); Expression(x); CheckBool(x); CheckSym(then); StatSeq(y);
OPB.Construct(Nif, x, y); SetPos(x); lastif := x;
WHILE sym = elsif DO
OPS.Get(sym); Expression(y); CheckBool(y); CheckSym(then); StatSeq(z);
OPB.Construct(Nif, y, z); SetPos(y); OPB.Link(x, lastif, y);
END ;
IF sym = else THEN OPS.Get(sym); StatSeq(y)
ELSE y := NIL
END ;
OPB.Construct(Nifelse, x, y); CheckSym(end); OPB.OptIf(x); pos := OPM.errpos
ELSIF sym = case THEN
OPS.Get(sym); CasePart(x); CheckSym(end)
ELSIF sym = while THEN
OPS.Get(sym); Expression(x); CheckBool(x); CheckSym(do); StatSeq(y);
OPB.Construct(Nwhile, x, y); CheckSym(end)
ELSIF sym = repeat THEN
OPS.Get(sym); StatSeq(x);
IF sym = until THEN OPS.Get(sym); Expression(y); CheckBool(y)
ELSE err(until)
END ;
OPB.Construct(Nrepeat, x, y)
ELSIF sym = for THEN
OPS.Get(sym);
IF sym = ident THEN qualident(id);
IF ~(id^.typ^.form IN intSet) THEN err(68) END ;
CheckSym(becomes); Expression(y); pos := OPM.errpos;
x := OPB.NewLeaf(id); OPB.Assign(x, y); SetPos(x);
CheckSym(to); Expression(y); pos := OPM.errpos;
IF y^.class # Nconst THEN
name := "@@"; OPT.Insert(name, t); t^.name := "@for";
t^.mode := Var; t^.typ := x^.left^.typ;
obj := OPT.topScope^.scope;
IF obj = NIL THEN OPT.topScope^.scope := t
ELSE
WHILE obj^.link # NIL DO obj := obj^.link END ;
obj^.link := t
END ;
z := OPB.NewLeaf(t); OPB.Assign(z, y); SetPos(z); OPB.Link(stat, last, z);
y := OPB.NewLeaf(t)
ELSIF (y^.typ^.form < SInt) OR (y^.typ^.form > x^.left^.typ^.form) THEN err(113)
END ;
OPB.Link(stat, last, x);
IF sym = by THEN OPS.Get(sym); ConstExpression(z) ELSE z := OPB.NewIntConst(1) END ;
pos := OPM.errpos; x := OPB.NewLeaf(id);
IF z^.conval^.intval > 0 THEN OPB.Op(leq, x, y)
ELSIF z^.conval^.intval < 0 THEN OPB.Op(geq, x, y)
ELSE err(63); OPB.Op(geq, x, y)
END ;
CheckSym(do); StatSeq(s);
y := OPB.NewLeaf(id); OPB.StPar1(y, z, incfn); 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); OPB.Construct(Nwhile, x, s)
ELSE err(ident)
END
ELSIF sym = loop THEN
OPS.Get(sym); INC(LoopLevel); StatSeq(x); DEC(LoopLevel);
OPB.Construct(Nloop, x, NIL); CheckSym(end); pos := OPM.errpos
ELSIF sym = with THEN
OPS.Get(sym); idtyp := NIL; x := NIL;
LOOP
IF sym = ident THEN
qualident(id); y := OPB.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; OPB.TypTest(y, t, FALSE); id^.typ := t^.typ
ELSE err(130)
END
ELSE err(52)
END
ELSE err(ident)
END
ELSE err(ident)
END ;
pos := OPM.errpos; CheckSym(do); StatSeq(s); OPB.Construct(Nif, y, s); SetPos(y);
IF idtyp # NIL THEN id^.typ := idtyp; idtyp := NIL END ;
IF x = NIL THEN x := y; lastif := x ELSE OPB.Link(x, lastif, y) END ;
IF sym = bar THEN OPS.Get(sym) ELSE EXIT END
END;
e := sym = else;
IF e THEN OPS.Get(sym); StatSeq(s) ELSE s := NIL END ;
OPB.Construct(Nwith, x, s); CheckSym(end);
IF e THEN x^.subcl := 1 END
ELSIF sym = exit THEN
OPS.Get(sym);
IF LoopLevel = 0 THEN err(46) END ;
OPB.Construct(Nexit, x, NIL);
pos := OPM.errpos
ELSIF sym = return THEN OPS.Get(sym);
IF sym < semicolon THEN Expression(x) END ;
IF level > 0 THEN OPB.Return(x, OPT.topScope^.link)
ELSE (* not standard Oberon *) OPB.Return(x, NIL)
END ;
pos := OPM.errpos
END ;
IF x # NIL THEN SetPos(x); OPB.Link(stat, last, x) END ;
IF sym = semicolon THEN OPS.Get(sym)
ELSIF (sym <= ident) OR (if <= sym) & (sym <= return) THEN err(semicolon)
ELSE EXIT
END
END
END StatSeq;
PROCEDURE Block(VAR procdec, statseq: OPT.Node);
VAR typ: OPT.Struct;
obj, first, last: OPT.Object;
x, lastdec: OPT.Node;
i: INTEGER;
BEGIN first := NIL; last := NIL; nofFwdPtr := 0;
LOOP
IF sym = const THEN
OPS.Get(sym);
WHILE sym = ident DO
OPT.Insert(OPS.name, obj); CheckMark(obj^.vis);
obj^.typ := OPT.sinttyp; obj^.mode := Var; (* Var to avoid recursive definition *)
IF sym = eql THEN
OPS.Get(sym); ConstExpression(x)
ELSIF sym = becomes THEN
err(eql); OPS.Get(sym); ConstExpression(x)
ELSE err(eql); x := OPB.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
OPS.Get(sym);
WHILE sym = ident DO
OPT.Insert(OPS.name, obj); obj^.mode := Typ; obj^.typ := OPT.undftyp;
CheckMark(obj^.vis);
IF sym = eql THEN
OPS.Get(sym); TypeDecl(obj^.typ, obj^.typ)
ELSIF (sym = becomes) OR (sym = colon) THEN
err(eql); OPS.Get(sym); TypeDecl(obj^.typ, obj^.typ)
ELSE err(eql)
END ;
IF obj^.typ^.strobj = NIL THEN obj^.typ^.strobj := obj END ;
IF obj^.typ^.comp IN {Record, Array, DynArr} THEN
i := 0;
WHILE i < nofFwdPtr DO typ := FwdPtr[i]; INC(i);
IF typ^.link^.name = obj^.name THEN typ^.BaseTyp := obj^.typ; typ^.link^.name := "" END
END
END ;
CheckSym(semicolon)
END
END ;
IF sym = var THEN
OPS.Get(sym);
WHILE sym = ident DO
LOOP
IF sym = ident THEN
OPT.Insert(OPS.name, obj); CheckMark(obj^.vis);
obj^.mode := Var; obj^.link := NIL; obj^.leaf := obj^.vis = internal; obj^.typ := OPT.undftyp;
IF first = NIL THEN first := obj END ;
IF last = NIL THEN OPT.topScope^.scope := obj ELSE last^.link := obj END ;
last := obj
ELSE err(ident)
END ;
IF sym = comma THEN OPS.Get(sym)
ELSIF sym = ident THEN err(comma)
ELSE EXIT
END
END ;
CheckSym(colon); Type(typ, OPT.notyp);
IF typ^.comp = DynArr THEN typ := OPT.undftyp; err(88) END ;
WHILE first # NIL DO first^.typ := typ; first := first^.link END ;
CheckSym(semicolon)
END
END ;
IF (sym < const) OR (sym > var) THEN EXIT END ;
END ;
i := 0;
WHILE i < nofFwdPtr DO
IF FwdPtr[i]^.link^.name # "" THEN err(128) END ;
FwdPtr[i] := NIL; (* garbage collection *)
INC(i)
END ;
OPT.topScope^.adr := OPM.errpos;
procdec := NIL; lastdec := NIL;
WHILE sym = procedure DO
OPS.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 sym = begin THEN OPS.Get(sym); StatSeq(statseq)
ELSE statseq := NIL
END ;
IF (level = 0) & (TDinit # NIL) THEN
lastTDinit^.link := statseq; statseq := TDinit
END ;
CheckSym(end)
END Block;
PROCEDURE Module*(VAR prog: OPT.Node; VAR modName: OPS.Name);
VAR impName, aliasName: OPS.Name;
procdec, statseq: OPT.Node;
c: LONGINT;
BEGIN
LoopLevel := 0; level := 0;
OPS.Get(sym);
IF sym = module THEN OPS.Get(sym) ELSE err(16) END ;
IF sym = ident THEN
COPY(OPS.name, modName); OPS.Get(sym); CheckSym(semicolon);
IF sym = import THEN OPS.Get(sym);
LOOP
IF sym = ident THEN
COPY(OPS.name, aliasName); COPY(aliasName, impName); OPS.Get(sym);
IF sym = becomes THEN OPS.Get(sym);
IF sym = ident THEN COPY(OPS.name, impName); OPS.Get(sym) ELSE err(ident) END
END ;
OPT.Import(aliasName, impName, modName)
ELSE err(ident)
END ;
IF sym = comma THEN OPS.Get(sym)
ELSIF sym = ident THEN err(comma)
ELSE EXIT
END
END ;
CheckSym(semicolon)
END ;
IF OPM.noerr THEN TDinit := NIL; lastTDinit := NIL; c := OPM.errpos;
Block(procdec, statseq); OPB.Enter(procdec, statseq, NIL); prog := procdec;
prog^.conval := OPT.NewConst(); prog^.conval^.intval := c;
IF sym = ident THEN
IF OPS.name # modName THEN err(4) END ;
OPS.Get(sym)
ELSE err(ident)
END ;
IF sym # period THEN err(period) END
END
ELSE err(ident)
END ;
TDinit := NIL; lastTDinit := NIL
END Module;
END OPP.