Syntax10.Scn.FntSyntax10i.Scn.Fnt0WStampElemsAlloc8 Aug 2Syntax10b.Scn.Fnt]WpVersionElemsAllocBeg#Syntax10.Scn.FntPowerMac WindowsWindowsPowerMac#Syntax10.Scn.Fnt22OPB := POPB, OPT := POPT, OPS := POPS, OPM := POPMWindows 2pVersionElemsAllocEndYf#;00/) '3zb &+# 4  " C_]T! q!k  N< % # 1 6',Mw#Y  ^! 5&4,  g 24f&4!Vi   <' la_Z b&> w'$ *l*r`<z MODULE Analyzer; (*<< SHML 7 Apr 92,  search OptionChar !! *) (* Created by Stefan H._M. Ludwig, ludwig@inf.ethz.ch, 7 Apr 92. Based on OP2 and OPP by NW, RC 6 Mar 89 / 10 Feb 94. Changes: Changes from modules OP2 and OPP are marked with <<. Other changes and bug fixes are marked with the date of the change. 26 Feb 96, SHML, fixed bug in Check of CheckScope. External types must not be checked! 3 Jul 96, SHML, fixed bug in UseObj. For loop variables might be usedSet! *) IMPORT (*<<*) Kernel, Texts, TextFrames, Viewers, Oberon, OPB, OPT, OPS, OPM; (* OPB := iOPB, OPT := iOPT, OPS := iOPS, OPM := iOPM; *) 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*) (*<< function number*) haltfn = 0; newfn = 1; ordfn = 4; minfn = 7; maxfn = 8; chrfn = 9; sizefn = 12; incfn = 13; decfn = 14; inclfn = 15; exclfn = 16; lenfn = 17; copyfn = 18; adrfn = 20; getfn = 24; getrfn = 26; valfn = 29; sysnewfn = 30; (* node 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; clean = OPM.LANotAlloc; (*<< values for obj.linkadr: untouched *) used = clean+1; usedSet = clean+2; set = clean+3; (*<< used, used then set, set *) setUsed = clean+4; setUsedP = clean+5; (*<< set then used, possibly set and used (var par) *) noChange = (setUsedP+15) DIV 16 * 16; (*<< for loop variables shouldn't be changed *) (*<< error messages *) neverUsed = 900; neverSet = 901; usedBSet = 902; setBNUsed = 903; usedVarPar = 904; outerScope = 905; interAcc = 906; redefinition = 907; newdefinition = 908; statAfterRetEx = 909; loopVarSet = 910; impliedTypeGuard = 911; evaluationSeq = 912; (*<< warning options *) varpar = 0; (*<< variable parameters *) exported = 1; (*<< exported items *) intermediate = 2; (*<< declaration/use of intermediate items *) levels = 3; (*<< used before set for variables in different scopes *) tbProcs = 4; (*<< redefinition or new definition of a type bound procedure *) sideEffects = 5; (*<< evaluation sequence and side effects may conflict *) defopt = {}; OptionChar = "\"; (*<<*) SignOnMessage = "Analyzer SHML 26 Feb 96"; (*<<*) TYPE CaseTable = ARRAY OPM.MaxCases OF RECORD low, high: LONGINT END ; Entry = POINTER TO EntryDesc; (*<< list of warning positions *) EntryDesc = RECORD (*<<*) next: Entry; n: INTEGER; pos: LONGINT END ; VAR (*<< OP2 *) (* global because of the GC call *) source: Texts.Text; sourceR: Texts.Reader; S: Texts.Scanner; v: Viewers.Viewer; (*<< OPP *) sym, level: SHORTINT; LoopLevel: INTEGER; TDinit, lastTDinit: OPT.Node; nofFwdPtr: INTEGER; FwdPtr: ARRAY 64 OF OPT.Struct; options: SET; (*<<*) errHead: Entry; (*<< root for warning position list *) totStats, nofStats: LONGINT; (*<< (total) number of statements in module(s) *) init: BOOLEAN; (*<< has startup message been written? *) (*<< OPP procedures *) 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 err2(n: INTEGER; pos: LONGINT); (*<<*) VAR e, h: Entry; BEGIN e := errHead; WHILE (e.next # NIL) & (e.next.pos < pos) DO e := e.next END ; IF e.next = NIL THEN NEW(e.next); h := e.next (* end of list *) ELSIF (e.next.pos = pos) & (e.next.n = n) THEN RETURN (* don't allow duplicates *) ELSE NEW(h); h.next := e.next; e.next := h END ; h.n := n; h.pos := pos END err2; PROCEDURE CheckScope(scope: OPT.Object); (*<<*) PROCEDURE^ Check(obj: OPT.Object); PROCEDURE CheckTyp(typ: OPT.Struct); BEGIN IF (typ.form = Pointer) & (typ.BaseTyp.strobj = NIL) THEN (* only if PTR TO RECORD END *) typ := typ.BaseTyp END ; IF (typ.form = Comp) & (typ.comp = Record) THEN Check(typ.link) END END CheckTyp; PROCEDURE Check(obj: OPT.Object); BEGIN IF obj # NIL THEN Check(obj.left); IF (obj.linkadr # setUsed) & ((exported IN options) OR (obj.vis = internal) OR (obj.mode = Mod)) THEN CASE obj.mode OF | Var, VarPar, Fld: CASE obj.linkadr OF | clean: err2(neverUsed, obj.adr) | used: err2(neverSet, obj.adr) | usedSet: IF obj.mode # Fld THEN err2(usedBSet, obj.adr) END | set: err2(setBNUsed, obj.adr) | setUsedP: IF (varpar IN options) & (obj.mode # Fld) THEN err2(usedVarPar, obj.adr) END END ; IF obj.typ.strobj = NIL THEN CheckTyp(obj.typ) END (*x: RECORD ... END*) | Con, Typ: CASE obj.linkadr OF set: err2(neverUsed, obj.adr) END | LProc, XProc, CProc, IProc: CASE obj.linkadr OF set: err2(neverUsed, obj.adr) END | TProc: (* neverUsed not determinable for redefined methods because of dynamic binding *) IF ((obj.link.typ.form = Pointer) & (obj.link.typ.BaseTyp.BaseTyp = NIL) OR (* (obj.link.typ.comp = Record) & *) (obj.link.typ.BaseTyp = NIL)) & (obj.linkadr = set) THEN err2(neverUsed, obj.adr) END | Mod: err2(neverUsed, obj.adr) END END ; (*IF*) CASE obj.mode OF | LProc, XProc, IProc, TProc: CheckScope(obj.scope) | Typ: (* checking of fields and type bound procedures, only if not imported type! 26 Feb 96 *) IF obj.typ.mno = 0 THEN CheckTyp(obj.typ) END ELSE END ; Check(obj.right) END END Check; BEGIN Check(scope.right) END CheckScope; PROCEDURE CheckOuter; (*<< check outer scopes for obj with OPS.name*) VAR o: OPT.Object; BEGIN IF intermediate IN options THEN OPT.Find(o); IF o # NIL THEN err2(outerScope, OPM.errpos) END END END CheckOuter; PROCEDURE UseType(obj: OPT.Object; pos: LONGINT); (*<< type obj gets used*) BEGIN IF (obj # NIL) & ((obj.vis = internal) OR (exported IN options)) THEN IF (intermediate IN options) & (obj.mnolev # level) & (obj.mnolev > 0) THEN (*mnolev > 0 -> intermediate*) err2(interAcc, pos) END ; CASE obj.linkadr OF clean, set: obj.linkadr := setUsed | used, setUsed: (* used only for non-declared type *) END END END UseType; PROCEDURE UseObj(obj: OPT.Object; markUseBSet: BOOLEAN; pos: LONGINT); (*<< obj gets used *) BEGIN IF (obj # NIL) & (obj.mnolev >= 0) THEN IF (intermediate IN options) & (obj.mnolev # level) & (obj.mnolev > 0) & (obj.mode < LProc) THEN err2(interAcc, pos) END ; CASE obj.linkadr OF | clean: IF (obj.mode = Con) OR (obj.mode # Fld) & (obj.mnolev # level) & ~(levels IN options) THEN obj.linkadr := setUsed ELSE obj.linkadr := used; IF markUseBSet & (obj.mode # SProc) & (obj.mode # Fld) & (obj.typ.form # Comp) THEN err2(usedBSet, pos) END END | set: obj.linkadr := setUsed | used, usedSet, setUsed, setUsedP, used+noChange, usedSet+noChange, setUsed+noChange, setUsedP+noChange: END END END UseObj; PROCEDURE SetObj(obj: OPT.Object; varPar: BOOLEAN; pos: LONGINT); (*<< var/proc/const/field obj gets set*) BEGIN IF (obj # NIL) & (obj.mnolev >= 0) THEN CASE obj.linkadr OF | clean: IF varPar THEN obj.linkadr := setUsedP ELSE obj.linkadr := set END | used: IF varPar THEN obj.linkadr := setUsedP ELSIF (obj.mnolev = level) OR (levels IN options) THEN obj.linkadr := usedSet ELSIF ~(levels IN options) THEN obj.linkadr := setUsed END | usedSet, setUsed, setUsedP: | set: IF varPar THEN obj.linkadr := setUsed END | setUsed+noChange, setUsedP+noChange: err2(loopVarSet, pos) (* for loop variable gets set!*) END END END SetObj; PROCEDURE Selector(x: OPT.Node; assignment, varPar, markUseBSet: BOOLEAN; pos: LONGINT); (*<<*) BEGIN IF assignment THEN CASE x.class OF | Nvar, Nvarpar, Nfield: IF (x.class # Nfield) & (intermediate IN options) & (x.obj.mnolev # level) & (x.obj.mnolev > 0) THEN err2(interAcc, pos) (* assignment to intermediate *) END ; SetObj(x.obj, varPar, pos); x := x.left (* assignment to b in {a.}b := ... *) | Nindex: (* assignment to b in {a.}b{[i]} := ... *) REPEAT x := x.left UNTIL x.class # Nindex; IF x.class IN {Nvar, Nvarpar, Nfield} THEN SetObj(x.obj, varPar, pos); x := x.left END ELSE END ; WHILE (x# NIL) & (x.class IN {Nvar, Nvarpar, Nfield}) DO SetObj(x.obj, varPar, pos); x := x.left END END ; WHILE x # NIL DO IF x.class IN {Nvar, Nvarpar, Nfield, Nconst, Nproc} THEN UseObj(x.obj, markUseBSet, pos) END ; x := x.left END END Selector; PROCEDURE qualident(VAR id: OPT.Object); VAR obj: OPT.Object; lev: SHORTINT; m: BOOLEAN; (*<< m *) BEGIN (*sym = ident*) OPT.Find(obj); OPS.Get(sym); m := FALSE; (*<<*) IF (sym = period) & (obj # NIL) & (obj^.mode = Mod) THEN obj.linkadr := setUsed; (*<< module gets used (set by default) *) m := TRUE; (*<< it's a module! *) 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 ; IF m & (obj # NIL) THEN obj.linkadr := setUsed END ; (*<< imported obj get used always! *) 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); UseType(base, OPM.errpos); (*<< type gets used*) 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; fld.adr := OPM.errpos; fld.linkadr := clean; (*<<*) 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); UseType(id, OPM.errpos); (*<< type gets used*) 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 CheckOuter; (*<<*) OPT.Insert(OPS.name, par); OPS.Get(sym); par.adr := OPM.errpos; (*<<*) par^.mode := mode; par^.link := NIL; IF mode = VarPar THEN par.linkadr := setUsed ELSE par.linkadr := set END ; (*<< parameters are set*) 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); UseType(res, OPM.errpos); (*<< type gets used*) 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); UseType(id, OPM.errpos); (*<< type gets used*) 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; UseObj(proc, TRUE, proc.adr) (*<< touch super proc*) ELSE err(74) END ELSE err(75) END ELSE UseObj(obj, TRUE, obj.adr) (*<< touch obj only if not super call! *) 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); UseType(obj, OPM.errpos); (*<< type gets used*) ELSE err(52) END ELSE err(ident) END ; CheckSym(rparen) ELSE EXIT END END END selector; PROCEDURE^ StandProcCall(VAR x: OPT.Node); (*<<*) PROCEDURE ActualParameters(VAR aparlist: OPT.Node; fpar: OPT.Object); VAR apar, last: OPT.Node; id: OPT.Object; moreThan1: BOOLEAN; (*<< id, moreThan1 *) BEGIN aparlist := NIL; last := NIL; IF sym # rparen THEN moreThan1 := (fpar # NIL) & (fpar.link # NIL); (*<<*) LOOP (*<< Expression(apar) old code *) IF (fpar # NIL) & (fpar.mode = VarPar) THEN (*<<*) qualident(id); apar := OPB.NewLeaf(id); selector(apar); IF (apar.class = Nproc) & (apar.obj.mode = SProc) & (apar.obj.adr = valfn) THEN StandProcCall(apar) END ; Selector(apar, TRUE, TRUE, TRUE, OPM.errpos) ELSE (*<<*) Expression(apar); IF (sideEffects IN options) & moreThan1 & (apar.class = Ncall) THEN (*<< proc_calls in param_list: code might depend on evaluation sequence (if more than one param.) *) err2(evaluationSeq, OPM.errpos) END END ; 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; id: OPT.Object; (*<< id *) 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(apar) old code *) CASE m OF (*<<*) | newfn, sysnewfn: (* id will be set by NEW => varPar = FALSE *) qualident(id); x := OPB.NewLeaf(id); selector(x); IF (x.class = Nproc) & (x.obj.mode = SProc) & (x.obj.adr = valfn) THEN StandProcCall(x) END ; Selector(x, TRUE, FALSE, TRUE, OPM.errpos) | incfn, decfn, inclfn, exclfn: (* id will be used and then set *) qualident(id); x := OPB.NewLeaf(id); selector(x); IF (x.class = Nproc) & (x.obj.mode = SProc) & (x.obj.adr = valfn) THEN StandProcCall(x) END ; Selector(x, FALSE, FALSE, TRUE, OPM.errpos); (* use *) Selector(x, TRUE, FALSE, TRUE, OPM.errpos) (* set *) | adrfn: IF sym = ident THEN (* no usedBSet message if ADR(id) *) qualident(id); x := OPB.NewLeaf(id); selector(x); Selector(x, FALSE, FALSE, FALSE, OPM.errpos) ELSE Expression(x) END | lenfn: qualident(id); x := OPB.NewLeaf(id); selector(x); Selector(x, FALSE, FALSE, FALSE, OPM.errpos) (* no usedBSet message if LEN(id) *) ELSE Expression(x) END ; OPB.StPar0(x, m); n := 1 ELSIF n = 1 THEN (*<< Expression(y); old code *) IF m IN {copyfn, getfn, getrfn} THEN (*<< id will be set by COPY, GET, GETREG => varPar = FALSE *) qualident(id); y := OPB.NewLeaf(id); selector(y); IF (y.class = Nproc) & (y.obj.mode = SProc) & (y.obj.adr = valfn) THEN StandProcCall(y) END ; Selector(y, TRUE, FALSE, TRUE, OPM.errpos) ELSE Expression(y) END ; 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; pos: LONGINT; (*<< pos *) BEGIN IF sym < lparen THEN err(13); REPEAT OPS.Get(sym) UNTIL sym >= lparen END ; IF sym = ident THEN qualident(id); pos := OPM.curpos; (*<<*) x := OPB.NewLeaf(id); selector(x); IF (x.class = Nfield) & (x.obj.mode = TProc) & (x.obj.link.mode = VarPar) & (x.obj.link.typ.comp = Record) THEN Selector(x.left, TRUE, TRUE, TRUE, pos) (*<< receiver is var parameter and record *) END ; Selector(x, FALSE, FALSE, TRUE, pos); (*<<*) IF (x^.class = Nproc) & (x^.obj^.mode = SProc) THEN IF ~(x.obj.adr IN {ordfn, minfn, maxfn, chrfn, sizefn, lenfn, adrfn, valfn}) THEN INC(nofStats) END ; (*<<*) StandProcCall(x) (* x may be NIL *) ELSIF sym = lparen THEN OPS.Get(sym); OPB.PrepCall(x, fpar); ActualParameters(apar, fpar); INC(nofStats); (*<<*) OPB.Call(x, apar, fpar); CheckSym(rparen); IF level > 0 THEN OPT.topScope^.link^.leaf := FALSE END ELSIF id.mode = Typ THEN UseType(id, OPM.errpos) (*<< type gets used, e.g. SIZE(Node) *) 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); UseType(obj, OPM.errpos); (*<< type gets used*) 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); UseType(obj, OPM.errpos); (*<< type gets used*) 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; pos1, pos2: LONGINT; (*<<*) BEGIN OPS.Get(sym); mode := TProc; IF level > 0 THEN err(73) END ; pos1 := OPM.errpos; (*<<*) 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 ; pos2 := OPM.errpos; proc.adr := pos2; proc.linkadr := set; (*<< methods are set*) INC(level); OPT.OpenScope(level, proc); OPT.Insert(objName, proc^.link); proc^.link^.mode := objMode; proc^.link^.typ := objTyp; proc^.link.adr := pos1; IF objMode = VarPar THEN proc^.link.linkadr := setUsed ELSE proc^.link.linkadr := set END ; (*<< receiver is set*) 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 tbProcs IN options THEN (*<< redefinition of TB proc or new definition in extended type *) IF baseProc # NIL THEN err2(redefinition, pos2) ELSIF recTyp^.extlev > 0 THEN err2(newdefinition, pos2) END 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 ; CheckOuter; (*<<*) OPT.Insert(name, proc) END ; proc.adr := OPM.errpos; proc.linkadr := set; (*<< procedures are set *) 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; oldSym: SHORTINT; (*<< oldSym*) s, x, y, z, apar, last, lastif: OPT.Node; pos, pos1, pos2: LONGINT; name: OPS.Name; (*<< pos, pos1, pos2 *) 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 ; INC(nofStats); oldSym := null; (*<<*) IF sym = ident THEN pos1 := OPM.curpos; (*<<*) qualident(id); x := OPB.NewLeaf(id); selector(x); IF sym = becomes THEN pos2 := OPM.curpos; (*<<*) OPS.Get(sym); Expression(y); Selector(x, TRUE, FALSE, TRUE, pos1); (*<< id gets set for the first time *) OPB.Assign(x, y); IF (x.left.class = Neguard) & (x.right.typ.comp = Record) THEN (*<< record assignment to varpar *) err2(impliedTypeGuard, pos2) END 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 IF (x.class = Nfield) & (x.obj.mode = TProc) & (x.obj.link.mode = VarPar) & (x.obj.link.typ.comp = Record) THEN Selector(x.left, TRUE, TRUE, TRUE, pos1) (*<< receiver is var parameter and record *) END ; Selector(x, FALSE, FALSE, TRUE, pos1); (*<< proc in node x gets called *) 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); SetObj(id, FALSE, OPM.errpos); UseObj(id, TRUE, OPM.errpos); (*<< for variable gets set & used*) INC(id.linkadr, noChange); (*<< loop variable shouldn't be changed!*) 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; t.linkadr := setUsed; (*<< temporary var gets set and used*) 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); DEC(id.linkadr, noChange) (*<< reset noChange attribute for loopvariable*) 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); UseObj(id, TRUE, OPM.errpos); (*<<*) 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); UseType(t, OPM.errpos); (*<< type gets used*) 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; pos1 := 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; oldSym := exit (*<<*) 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; oldSym := return (*<<*) ELSE DEC(nofStats) (*<< empty statement*) 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 ; IF (exit <= oldSym) & (oldSym <= return) & ((sym < bar) OR (until < sym)) THEN (*<< statement after return/exit*) err2(statAfterRetEx, pos) 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; pos, save: LONGINT; (*<<*) BEGIN first := NIL; last := NIL; nofFwdPtr := 0; save := nofStats; (*<<*) LOOP IF sym = const THEN OPS.Get(sym); WHILE sym = ident DO CheckOuter; (*<<*) OPT.Insert(OPS.name, obj); CheckMark(obj^.vis); obj^.typ := OPT.sinttyp; obj^.mode := Var; (* Var to avoid recursive definition *) pos := OPM.errpos; (*<<*) 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 is not copied *) obj.adr := pos; obj.linkadr := set; (*<< constants are set by default*) CheckSym(semicolon) END END ; IF sym = type THEN OPS.Get(sym); WHILE sym = ident DO CheckOuter; (*<<*) OPT.Insert(OPS.name, obj); obj^.mode := Typ; obj^.typ := OPT.undftyp; CheckMark(obj^.vis); obj.adr := OPM.errpos; obj.linkadr := set; (*<< types are set by default*) 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; UseType(obj, obj.adr); (*<<*) 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 CheckOuter; (*<<*) OPT.Insert(OPS.name, obj); CheckMark(obj^.vis); obj.adr := OPM.errpos; obj.linkadr := clean; (*<<*) 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 ; nofStats := save; (*<<*) 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; opt: SET); (*<< opt *) VAR impName, aliasName: OPS.Name; obj: OPT.Object; (*<< obj *) procdec, statseq: OPT.Node; c: LONGINT; BEGIN LoopLevel := 0; level := 0; options := opt; NEW(errHead); nofStats := 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); COPY(aliasName, OPS.name); (*<<*) OPT.Find(obj); IF obj # NIL THEN obj.adr := OPM.errpos; obj.linkadr := set END ; (*<< modules are set by default *) 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 ; CheckScope(OPT.topScope) (*<<*) END ELSE err(ident) END ; TDinit := NIL; lastTDinit := NIL END Module; PROCEDURE WriteWarnings; (*<<*) VAR e: Entry; BEGIN IF errHead.next = NIL THEN OPM.LogWStr(" done") ELSE e := errHead.next; WHILE e # NIL DO OPM.Mark(-e.n, e.pos); e := e.next END END ; errHead := NIL END WriteWarnings; (*<= 0 THEN Texts.OpenScanner(S, source, beg); pos := Texts.Pos(S); Texts.Scan(S); NEW(source); WHILE (S.class = Texts.Name) & (pos < end) & ~error DO Texts.Open(source, S.s); IF source.len # 0 THEN Do(S.s, 0) ELSE OPM.LogWStr(S.s); OPM.LogWStr(" not found"); OPM.LogWLn; error := TRUE END END END ELSIF S.c = "@" THEN Oberon.GetSelection(source, beg, end, time); IF time >= 0 THEN Do("", beg) END END ELSE NEW(source); WHILE (S.class = Texts.Name) & ~error DO Texts.Open(source, S.s); IF source.len # 0 THEN Do(S.s, 0) ELSE OPM.LogWStr(S.s); OPM.LogWStr(" not found"); OPM.LogWLn; error := TRUE END END END ; IF (totStats > 0) & (totStats # nofStats) THEN (*<<*) OPM.LogWNum(totStats, 6); OPM.LogWStr(" statements in total"); OPM.LogWLn END END Analyze; BEGIN init := FALSE END Analyzer.Analyze * Analyzer.Analyze (("*" | "@") ["/" opt] | {name ["/" opt]} "~" | "^") Options (complementing each other): i redeclaration of/use of/assignment to intermediate items t redefinition of and newly inserted type bound procedures u used before set for different scopes v use of var parameters x use/initialization of exported items s evaluation sequence of function calls 900 never used 901 never set 902 used before set 903 set but never used 904 used as varpar, possibly not set 905 also declared in outer scope 906 access/assignment to intermediate 907 redefinition 908 new definition 909 statement after RETURN/EXIT 910 for loop variable set 911 implied type guard in record assignment 912 call might depend on evaluation sequence of params.