DIRECTORY BasicTime: TYPE USING [Now, ToPupTime], Rope: TYPE USING [ROPE, FromProc, Concat], FS: TYPE USING [StreamOpen, Error], IO: TYPE USING [STREAM, Close, Reset, Put, rope, char], M2D: TYPE USING [MaxCodeLength, StrForm, ObjPtr, HeaderPtr, ConstPtr, TypPtr, VarPtr, ProcPtr, ModulePtr, FieldPtr, Structure, StrPtr, EnumPtr, RangePtr, SetPtr, PointerPtr, ProcTypPtr, ArrayPtr, RecordPtr, ParPtr, WordSize, PDPtr, CDPtr, BDesc, undftyp, notyp, cardtyp, inttyp, dbltyp, realtyp, bitstyp, chartyp, stringtyp, UNION, sysmod, mainmod], M2G: TYPE USING [ItemPtr, Item, rngchk, LabelTabPtr, LabelTable, NofCases, GenItem, GenSingSet, GenSet, GenTrap, GenCase1, GenCase2, GenCase3, GenFor1, GenFor2, GenFor3, GenFor4, GenWith, PrepAss, GenAssign, PrepCall, GenCall, GenReturn, GenEnterM, GenInitM, GenEnterP, GenInitP, GenIndex, GenField, GenDeRef, GenParam, LoadAdr, Load, LoadStk, GenFJ, GenCFJ, GenBJ, GenCBJ, GenIn, GenOp, GenNeg, GenNot, GenAnd, GenOr, GenStParam, GenStFct], M2I: TYPE USING [pc, InitGenerator, Entry, FixJmp, FixLink, FixAD, FixSL, FixDO, FixLR, CheckCode, OutCodeFile, AllocString], M2R: TYPE USING [ModNo, ModList, RefFile, InitRef, Create, OpenRef, InRef, CloseRef, OutUnit, OutPos], M2S: TYPE USING [Symbol, source, sourcepos, log, sym, numtyp, intval, scanerr, IdBuf, id, InitScanner, GetSym, Diff, KeepId, Mark, dblval, realval], M2T: TYPE USING [Scope, InitTableHandler, InitImpExp, NewScope, NewObj, NewProc, NewPar, NewImp, NewExp, LinkScope, ParamLink, CloseScope, FirstObj, LastObj, Mark, Release, Find, FindExport, CheckUDP, ValidateExports, FindField], M2P: TYPE; M2PImpl: CEDAR PROGRAM IMPORTS BasicTime, FS, Rope, IO, M2D, M2G, M2I, M2R, M2S, M2T EXPORTS M2P = BEGIN NofExits: CARDINAL = 16; LoopLevels: CARDINAL = 4; pno, pnoI: CARDINAL; isdef, isimp: BOOLEAN; err: PROC [n: CARDINAL] = { M2S.Mark [n] }; CheckSym: PROC [s: M2S.Symbol, n: CARDINAL] = { IF M2S.sym = s THEN M2S.GetSym ELSE M2S.Mark [n] }; qualident: PROC RETURNS [obj: M2D.ObjPtr] = { -- sym = ident -- obj _ M2T.Find [M2S.id]; M2S.GetSym; WHILE (M2S.sym = $period) AND (obj # NIL) AND (obj^.class = Module) DO M2S.GetSym; IF M2S.sym = $ident THEN { obj _ M2T.FindExport [M2S.id, NARROW [obj]]; M2S.GetSym } ELSE err [10] ENDLOOP }; RefPoint: PROC = { M2R.OutPos [M2S.sourcepos MOD 65536, M2I.pc] }; CheckParameters: PROC [proc: M2D.ProcPtr] = { -- compare object list with parameter list from definition module -- par: M2D.ParPtr _ proc^.firstParam; FOR obj: M2D.ObjPtr _ M2T.FirstObj [], obj^.next WHILE obj # NIL DO IF par # NIL THEN { var: M2D.VarPtr = NARROW [obj]; IF obj^.typ # par^.typ THEN IF (obj^.typ^.form = Array) AND (par^.typ^.form = Array) THEN { objarray: M2D.ArrayPtr = NARROW [obj^.typ]; pararray: M2D.ArrayPtr = NARROW [par^.typ]; IF objarray^.ElemTyp # pararray^.ElemTyp THEN err [69] } ELSE err [69]; IF var^.varpar # par^.varpar THEN err [68]; par _ par^.next } ELSE err [66]; ENDLOOP; IF par # NIL THEN err [70] }; MakeParameters: PROC [proc: M2D.ProcPtr] = { -- construct parameter list from object list -- FOR obj: M2D.ObjPtr _ M2T.FirstObj [], obj^.next WHILE obj # NIL DO var: M2D.VarPtr = NARROW [obj]; M2T.NewPar [obj^.typ, var^.varpar]; ENDLOOP; proc^.firstParam _ M2T.ParamLink [] }; Priority: PROC RETURNS [prio: CARDINAL] = { x: M2G.ItemPtr = NEW [M2G.Item]; IF M2S.sym = $lbrak THEN { M2S.GetSym; ConstExpression [x]; IF (x^.typ = M2D.cardtyp) AND (x^.val.C < 16) THEN prio _ x^.val.C + 1 ELSE { err [145]; prio _ 0 }; CheckSym [$rbrak, 16]; RETURN [prio] }}; ImportList: PROC [impmod: M2D.ObjPtr] = { IF (impmod # NIL) AND (impmod^.class # Module) THEN { impmod _ NIL; err [55] }; DO IF M2S.sym = $ident THEN { obj: M2D.ObjPtr = (IF impmod = NIL THEN M2T.Find [M2S.id] ELSE M2T.FindExport [M2S.id, NARROW [impmod]]); IF obj # NIL THEN M2T.NewImp [obj] ELSE err [50]; M2S.GetSym } ELSE err [10]; IF M2S.sym = $comma THEN M2S.GetSym ELSE IF M2S.sym = $ident THEN err [11] ELSE EXIT ENDLOOP; CheckSym [$semicolon, 12] }; ExportList: PROC = { DO IF M2S.sym = $ident THEN { M2T.NewExp [M2S.id]; M2S.KeepId; M2S.GetSym } ELSE err [10]; SELECT M2S.sym FROM $comma => M2S.GetSym; $ident => err [11]; ENDCASE => EXIT ENDLOOP; CheckSym [$semicolon, 12] }; ProcedureDeclaration: PROC [pAnc: M2D.PDPtr, mAnc: M2D.ModulePtr] = { i: CARDINAL; obj, res: M2D.ObjPtr; scope: M2D.HeaderPtr; proc: M2D.ProcPtr; cd: M2D.CDPtr _ NIL; pd: M2D.PDPtr _ NIL; M2T.InitImpExp; IF pAnc^.lev = 0 THEN obj _ M2T.Find [M2S.id] ELSE obj _ NIL; IF (obj # NIL) AND (obj^.class = Proc) THEN { proc _ NARROW [obj]; pd _ NARROW [proc^.bd]; IF pd^.pc = 0 THEN { scope _ M2T.NewScope [Proc]; CheckSym [$ident, 10]; IF M2S.sym = $lparen THEN { M2S.GetSym; FormalParameters [pd]; CheckParameters [proc]; IF M2S.sym = $colon THEN { M2S.GetSym; IF M2S.sym = $ident THEN { res _ qualident []; IF (res = NIL) OR (res^.class # Typ) OR (res^.typ # obj^.typ) THEN err [71] } ELSE err [10] } ELSE IF obj^.typ # M2D.notyp THEN err [72] } ELSE IF proc^.firstParam # NIL THEN err [73] }}; IF (proc = NIL) OR (pd # NIL AND pd^.pc # 0) THEN { obj _ M2T.NewObj [M2S.id, Proc]; M2S.KeepId; obj^.typ _ M2D.notyp; proc _ NARROW [obj]; pd _ NEW [M2D.BDesc.Block]; proc^.bd _ pd; pno _ pno + 1; pd^.num _ pno; pd^.lev _ pAnc^.lev + 1; scope _ M2T.NewScope [Proc]; CheckSym [$ident, 10]; IF M2S.sym = $lparen THEN { M2S.GetSym; FormalParameters [pd]; MakeParameters [proc]; IF M2S.sym = $colon THEN { M2S.GetSym; obj^.typ _ M2D.undftyp; IF M2S.sym = $ident THEN { res _ qualident []; IF (res # NIL) AND (res^.class = Typ) THEN obj^.typ _ res^.typ ELSE err [52] } ELSE err [10] }}}; IF NOT isdef THEN { CheckSym [$semicolon, 12]; M2T.Mark; IF M2S.sym = $code THEN { M2S.GetSym; cd _ NEW [M2D.BDesc.Code]; proc^.bd _ cd; cd^.num _ 0; IF pd^.num > pnoI THEN pno _ pno - 1 ELSE err [74]; -- declared in def mod -- proc^.bd _ cd; i _ 0; DO IF M2S.sym = $number THEN { M2S.GetSym; IF (i < M2D.MaxCodeLength) AND (M2S.numtyp = cardint) AND (M2S.intval < 256) THEN { cd^.cod [i] _ M2S.intval; i _ i + 1 } ELSE err [91] }; IF M2S.sym = $semicolon THEN M2S.GetSym ELSE IF M2S.sym = $number THEN err [12] ELSE EXIT ENDLOOP; cd^.length _ i; CheckSym [$end, 20]; IF M2S.sym = $ident THEN { IF M2S.Diff [M2S.id, obj^.name] # 0 THEN err [77]; M2S.GetSym } ELSE err [10] } ELSE IF M2S.sym = $forward THEN M2S.GetSym ELSE { pd^.pAnc _ pAnc; pd^.mAnc _ mAnc; pd^.LNK _ pd^.cell; pd^.cell _ pd^.cell + 2; Block [obj, FALSE] }; M2R.OutUnit [obj] ; M2T.Release } ELSE pd^.pc _ 0; M2T.CloseScope }; ModuleDeclaration: PROC [anc: M2D.PDPtr] = { modid, prio: CARDINAL; qual: BOOLEAN _ FALSE; impmod: M2D.ObjPtr; module: M2D.ModulePtr; M2T.InitImpExp; modid _ M2S.id; M2S.KeepId; CheckSym [$ident, 10]; prio _ Priority []; CheckSym [$semicolon, 12]; WHILE (M2S.sym = $from) OR (M2S.sym = $import) DO IF M2S.sym = $from THEN { M2S.GetSym; IF M2S.sym = $ident THEN { impmod _ M2T.Find [M2S.id]; M2S.GetSym } ELSE err [1]; CheckSym [$import, 30] } ELSE M2S.GetSym; ImportList [impmod] ENDLOOP; IF M2S.sym = $export THEN { M2S.GetSym; IF M2S.sym = $qualified THEN { M2S.GetSym; qual _ TRUE }; ExportList }; module _ NARROW [M2T.NewObj [modid, Module]]; module^.typ _ M2D.notyp; module^.firstObj _ NIL; module^.key _ 0; pno _ pno + 1; module^.mod _ pno; module^.prio _ prio; [] _ M2T.NewScope [Module]; module^.pAnc _ anc; Block [module, qual]; M2R.OutUnit [module]; M2T.CloseScope }; h: CARDINAL _ 0; k: CARDINAL _ 0; index: ARRAY [0..LoopLevels) OF CARDINAL; label: ARRAY [0..NofExits) OF CARDINAL; EnterLoop: PROC = { index [h] _ k; h _ h + 1 }; RecordExit: PROC [L: CARDINAL] = { IF h = 0 THEN err [39] ELSE IF k < NofExits THEN { label [k] _ L; k _ k + 1 } ELSE err [93] }; ExitLoop: PROC = { h _ h - 1; WHILE k > index [h] DO k _ k - 1; M2I.FixJmp [label[k], M2I.pc] ENDLOOP }; Block: PROC [ancestor: M2D.ObjPtr, qual: BOOLEAN] = { M0, M1, M2, M3, C3: CARDINAL; mAnc: M2D.ModulePtr; pAnc: M2D.PDPtr; dummy: M2G.ItemPtr _ NEW [M2G.Item]; Declarations: PROC = { id0: CARDINAL; obj: M2D.ObjPtr; typ: M2D.StrPtr; DO SELECT M2S.sym FROM $const => { x: M2G.ItemPtr = NEW [M2G.Item _ [contxt: pAnc]]; M2S.GetSym; WHILE M2S.sym = $ident DO const: M2D.ConstPtr _ NIL; id0 _ M2S.id; M2S.KeepId; M2S.GetSym; IF M2S.sym = $eql THEN { M2S.GetSym; ConstExpression [x] } ELSE IF M2S.sym = $becomes THEN { err [18]; M2S.GetSym; ConstExpression [x] } ELSE err [18]; obj _ M2T.NewObj [id0, Const]; const _ NARROW [obj]; obj^.typ _ x^.typ; const^.conval.D0 _ x^.val.D0; const^.conval.D1 _ x^.val.D1; const^.conval.D2 _ x^.val.D2; const^.conval.D3 _ x^.val.D3; IF x^.typ = M2D.stringtyp THEN { const^.conval.D2 _ M2S.id; M2S.KeepId }; CheckSym [$semicolon, 12] ENDLOOP }; $type => { M2S.GetSym; WHILE M2S.sym = $ident DO newtypdef: BOOLEAN _ TRUE; typ _ M2D.undftyp; obj _ NIL; IF isimp AND (pAnc^.lev = 0) THEN { obj _ M2T.Find [M2S.id]; IF (obj # NIL) AND (obj^.class = Typ) AND (obj^.typ^.form = Opaque) THEN newtypdef _ FALSE }; IF newtypdef THEN { id0 _ M2S.id; M2S.KeepId; obj _ M2T.NewObj [id0, Typ]; obj^.name _ 0 -- prevent recursive definition -- }; M2S.GetSym; IF M2S.sym = $eql THEN { M2S.GetSym; typ _ Type [] } ELSE IF (M2S.sym = $becomes) OR (M2S.sym = $colon) THEN { err [18]; M2S.GetSym; typ _ Type [] } ELSE IF isdef THEN typ _ OpaqueType [] ELSE err [18]; obj^.name _ id0; IF newtypdef THEN { type: M2D.TypPtr = NARROW [obj]; obj^.typ _ typ; type^.mod _ M2D.mainmod; IF typ^.strobj = NIL THEN typ^.strobj _ type } ELSE IF typ^.form = Pointer THEN obj^.typ _ typ -- was obj^.typ^ _ typ^ ELSE err [86]; M2T.CheckUDP [obj]; -- check for undefined pointer types -- CheckSym [$semicolon, 12] ENDLOOP }; $var => { M2S.GetSym; WHILE M2S.sym = $ident DO ob0: M2D.ObjPtr _ M2T.LastObj []; DO IF M2S.sym = $ident THEN { obj _ M2T.NewObj [M2S.id, Var]; M2S.KeepId; M2S.GetSym } ELSE err [10]; IF M2S.sym = $comma THEN M2S.GetSym ELSE IF M2S.sym = $ident THEN err [11] ELSE EXIT ENDLOOP; CheckSym [$colon, 13]; typ _ Type []; WHILE ob0 # obj DO var0: M2D.VarPtr _ NIL; ob0 _ ob0^.next; var0 _ NARROW [ob0]; ob0^.typ _ typ; var0^.varpar _ FALSE; var0^.mod _ 0; var0^.lev _ pAnc^.lev; IF pAnc^.cell >= 256 THEN { err [99]; pAnc^.cell _ 0 }; var0^.cell _ pAnc^.cell; pAnc^.cell _ pAnc^.cell + 1; IF (typ^.form = Array) OR (typ^.form = Record) THEN pAnc^.adr _ pAnc^.adr + typ^.size ENDLOOP; CheckSym [$semicolon, 12] ENDLOOP }; $procedure => { M2S.GetSym; ProcedureDeclaration [pAnc, mAnc]; CheckSym [$semicolon, 12] }; $module => { M2S.GetSym; ModuleDeclaration [pAnc]; CheckSym [$semicolon, 12] }; ENDCASE => IF (M2S.sym # $begin) AND (M2S.sym # $end) THEN { err [36]; DO M2S.GetSym; IF (M2S.sym >= $begin) OR (M2S.sym = $end) THEN EXIT ENDLOOP }; IF (M2S.sym <= $begin) OR (M2S.sym = $eof) THEN EXIT ENDLOOP }; StatSeq: PROC = { L0, L1: CARDINAL; obj: M2D.ObjPtr; fpar: M2D.ParPtr; x: M2G.ItemPtr = NEW [M2G.Item _ [contxt: pAnc]]; y: M2G.ItemPtr = NEW [M2G.Item _ [contxt: pAnc]]; ProcCall: PROC [x: M2G.ItemPtr] = { IF M2S.sym = $lparen THEN { M2S.GetSym; ActualParameters [x]; CheckSym [$rparen, 15] } ELSE { fpar _ M2G.PrepCall [x]; IF fpar = NIL THEN M2G.GenCall [x] ELSE err [65] }; IF x^.typ # M2D.notyp THEN err [76] }; CasePart: PROC = { n, L0, L1, L2: CARDINAL; x: M2G.ItemPtr = NEW [M2G.Item _ [contxt: pAnc]]; tab: M2G.LabelTabPtr _ NEW [M2G.LabelTable]; n _ 0; L2 _ 0; Expression [x]; L0 _ M2G.GenCase1 [x]; CheckSym [$of, 23]; DO IF M2S.sym < $bar THEN { n _ CaseLabelList [x^.typ, n, tab]; CheckSym [$colon, 13]; StatSeq; L2 _ M2G.GenCase2 [L2]}; IF M2S.sym = $bar THEN M2S.GetSym ELSE EXIT ENDLOOP; L1 _ M2I.pc; IF M2S.sym = $else THEN { M2S.GetSym; StatSeq; L2 _ M2G.GenCase2 [L2] } ELSE M2G.GenTrap [4]; RefPoint; M2G.GenCase3 [L0, L1, L2, n, tab] }; ForPart: PROC = { obj: M2D.ObjPtr _ NIL; L0, L1: CARDINAL; v: M2G.ItemPtr = NEW [M2G.Item _ [contxt: pAnc]]; e1: M2G.ItemPtr = NEW [M2G.Item _ [contxt: pAnc]]; e2: M2G.ItemPtr = NEW [M2G.Item _ [contxt: pAnc]]; e3: M2G.ItemPtr = NEW [M2G.Item _ [contxt: pAnc]]; IF M2S.sym = $ident THEN { obj _ M2T.Find [M2S.id]; IF obj # NIL THEN { IF obj^.class = Var THEN { var: M2D.VarPtr = NARROW [obj]; IF var^.varpar OR (var^.mod > 0) THEN err [75] }} ELSE err [50]; M2S.GetSym } ELSE err [10]; M2G.GenItem [v, obj, M2T.Scope]; M2G.PrepAss [v]; IF M2S.sym = $becomes THEN M2S.GetSym ELSE { err [19]; IF M2S.sym = $eql THEN M2S.GetSym }; Expression [e1]; M2G.GenFor1 [v, e1]; CheckSym [$to, 24]; M2G.GenItem [v, obj, M2T.Scope]; Expression [e2]; M2G.GenFor2 [v, e2]; IF M2S.sym = $by THEN { M2S.GetSym; ConstExpression [e3] } ELSE { e3^.typ _ M2D.inttyp; e3^.mode _ conMd; e3^.val.I _ 1 }; [L0, L1] _ M2G.GenFor3 [v, e2, e3]; CheckSym [$do, 25]; StatSeq; M2G.GenItem [v, obj, M2T.Scope]; M2G.GenFor4 [v, e3, L0, L1] }; WithPart: PROC = { scope: M2D.HeaderPtr = M2T.NewScope [Typ]; v: M2G.ItemPtr = NEW [M2G.Item _ [contxt: pAnc]]; x: M2G.ItemPtr = NEW [M2G.Item _ [contxt: pAnc]]; x^.typ _ NIL; IF M2S.sym = $ident THEN { Selector [x, qualident []]; WITH x^.typ SELECT FROM record: M2D.RecordPtr => { IF pAnc^.cell >= 256 THEN { err [99]; pAnc^.cell _ 0 }; IF pAnc^.cell >= 16 THEN { v^.mode _ ladrMd; v^.reg _ pAnc^.LNK+1; v^.off _ pAnc^.cell } ELSE { v^.mode _ regMd; v^.reg _ pAnc^.cell }; M2G.GenWith [v, x]; scope^.cell _ pAnc^.cell; pAnc^.cell _ pAnc^.cell + 1; scope^.next _ record^.firstFld }; ENDCASE => { x^.typ _ M2D.undftyp; err [57] }} ELSE err [10]; CheckSym [$do, 25]; StatSeq; M2T.CloseScope }; DO IF M2S.sym < $ident THEN { err [35]; DO M2S.GetSym; IF M2S.sym >= $ident THEN EXIT ENDLOOP }; SELECT M2S.sym FROM $ident => { RefPoint; obj _ qualident []; Selector [x, obj]; IF M2S.sym = $becomes THEN { M2S.GetSym; M2G.PrepAss [x]; Expression [y]; M2G.GenAssign [x, y] } ELSE IF M2S.sym = $eql THEN { err [19]; M2S.GetSym; M2G.PrepAss [x]; Expression [y]; M2G.GenAssign [x, y] } ELSE IF x^.mode = codMd THEN { cd: M2D.CDPtr = NARROW [NARROW [x^.obj, M2D.ProcPtr].bd]; IF cd^.num > 0 THEN { StandProcCall [x]; IF x^.typ # M2D.notyp THEN err [76] } ELSE ProcCall [x] } ELSE ProcCall [x] }; $if => { M2S.GetSym; RefPoint; Expression [x]; L0 _ M2G.GenCFJ [x]; CheckSym [$then, 27]; StatSeq; L1 _ 0; WHILE (M2S.sym = $elsif) OR (M2S.sym = $bar) DO M2S.GetSym; L1 _ M2G.GenFJ [L1]; M2I.FixLink [L0, M2I.pc]; RefPoint; Expression [x]; L0 _ M2G.GenCFJ [x]; CheckSym [$then, 27]; StatSeq ENDLOOP; IF M2S.sym = $else THEN { M2S.GetSym; L1 _ M2G.GenFJ [L1]; M2I.FixLink [L0, M2I.pc]; StatSeq } ELSE M2I.FixLink [L0, M2I.pc]; M2I.FixLink [L1, M2I.pc]; CheckSym [$end, 20] }; $case => { M2S.GetSym; RefPoint; CasePart; CheckSym [$end, 20] }; $while => { M2S.GetSym; L1 _ M2I.pc; RefPoint; Expression [x]; L0 _ M2G.GenCFJ [x]; CheckSym [$do, 25]; StatSeq; M2G.GenBJ [L1]; M2I.FixLink [L0, M2I.pc]; WHILE M2S.sym = $bar DO M2S.GetSym; RefPoint; Expression [x]; L0 _ M2G.GenCFJ [x]; CheckSym [$do, 25]; StatSeq; M2G.GenBJ [L1]; M2I.FixLink [L0, M2I.pc] ENDLOOP; CheckSym [$end, 20] }; $repeat => { M2S.GetSym; L0 _ M2I.pc; StatSeq; IF M2S.sym = $until THEN { M2S.GetSym; RefPoint; Expression [x]; M2G.GenCBJ [x, L0] } ELSE err [26] }; $loop => { M2S.GetSym; EnterLoop; L0 _ M2I.pc; StatSeq; M2G.GenBJ [L0]; ExitLoop; CheckSym [$end, 20] }; $for => { M2S.GetSym; RefPoint; ForPart; CheckSym [$end, 20] }; $with => { M2S.GetSym; WithPart; CheckSym [$end, 20] }; $exit => { M2S.GetSym; L0 _ M2G.GenFJ [L0]; RecordExit [L0] }; $return => { M2S.GetSym; IF M2S.sym < $semicolon THEN Expression [x] ELSE x^.typ _ NIL; M0 _ M2G.GenReturn [x, ancestor, M0] }; ENDCASE; M2I.CheckCode; IF M2S.sym = $semicolon THEN M2S.GetSym ELSE IF (M2S.sym <= $ident) OR (M2S.sym >= $if) AND (M2S.sym <= $for) THEN err [12] ELSE EXIT ENDLOOP }; WITH ancestor SELECT FROM module: M2D.ModulePtr => { mAnc _ module; pAnc _ module^.pAnc; Declarations; module^.firstObj _ M2T.FirstObj []; M2T.ValidateExports [module, qual]; module^.pc _ M2I.pc; IF ancestor = M2D.mainmod THEN { M2I.Entry [0]; M2 _ M2G.GenInitM [module, M2R.ModNo] } ELSE M2G.GenEnterM [module]; IF M2S.sym = $begin THEN { IF isdef THEN err [37]; M2S.GetSym; StatSeq; RefPoint; M0 _ M2G.GenReturn [dummy, ancestor, M0]; IF (ancestor = M2D.mainmod) AND (pAnc^.adr > 0) THEN M2I.FixDO [M2, pAnc^.cell] }}; proc: M2D.ProcPtr => { pd: M2D.PDPtr = NARROW [proc^.bd]; pAnc _ pd; mAnc _ pd^.mAnc; Declarations; pd^.firstLocal _ M2T.FirstObj []; pd^.pc _ M2I.pc; M2I.Entry [pd^.num]; [M0, M1] _ M2G.GenEnterP [proc]; [M2, M3, C3] _ M2G.GenInitP [proc]; IF M2S.sym = $begin THEN { IF isdef THEN err [37]; M2S.GetSym; StatSeq; RefPoint; IF ancestor^.typ = M2D.notyp THEN { dummy^.typ _ NIL; M0 _ M2G.GenReturn [dummy, ancestor, M0] } ELSE M2G.GenTrap [9]; IF pd^.needsBUP OR (pd^.cell >= 16) THEN M2I.FixAD [M0, pd^.LNK+1, pd^.cell + pd^.adr] ELSE M2I.FixAD [M0, pd^.LNK+1, pd^.adr]; IF pd^.needsBUP THEN M2I.FixSL [M1, pd^.LNK]; IF pd^.adr > 0 THEN IF pd^.needsBUP OR (pd^.cell >= 16) THEN M2I.FixDO [M2, pd^.cell] ELSE M2I.FixDO [M2, 0]; M2I.FixLR [M3, C3, pd^.cell] }}; ENDCASE; CheckSym [$end, 20]; IF M2S.sym = $ident THEN { IF M2S.Diff [M2S.id, ancestor^.name] # 0 THEN err [77]; M2S.GetSym } ELSE err [10] }; CompilationUnit: PROC = { id0, prio, adr: CARDINAL; fname: Rope.ROPE; impok: BOOLEAN; importMod: M2D.ObjPtr; FileName: PROC [j: CARDINAL, ext: Rope.ROPE] RETURNS [Rope.ROPE] = { nextCh: PROC RETURNS [CHAR] = { j _ j + 1; RETURN [M2S.IdBuf [j]] }; RETURN [ (Rope.FromProc[len: M2S.IdBuf[j].ORD-1, p: nextCh]).Concat [ ext ]] }; ImportModule: PROC = { IF M2S.sym = $ident THEN { IF M2S.Diff [M2S.id, M2D.sysmod^.name] = 0 THEN importMod _ M2D.sysmod ELSE { pno, adr: CARDINAL; fname _ FileName [M2S.id, ".SBL"]; M2S.log.Put [IO.rope["in:"], IO.rope[fname], IO.char[' ]]; [importMod, adr, pno] _ M2R.InRef [fname]; IF importMod = NIL THEN { impok _ FALSE; M2S.log.Put [IO.rope["failed "]] }}; M2S.GetSym } ELSE err [10] }; isdef _ FALSE; isimp _ FALSE; impok _ TRUE; prio _ 0; M2T.InitImpExp; M2S.GetSym; IF M2S.sym = $definition THEN { M2S.GetSym; isdef _ TRUE } ELSE IF M2S.sym = $implementation THEN { M2S.GetSym; isimp _ TRUE }; IF M2S.sym = $module THEN { M2S.GetSym; IF M2S.sym = $ident THEN { id0 _ M2S.id; M2S.KeepId; M2S.GetSym; IF NOT isdef THEN prio _ Priority []; CheckSym [$semicolon, 12]; IF isimp THEN { fname _ FileName [id0, ".SBL"]; M2S.log.Put [IO.rope["in:"], IO.rope[fname], IO.char[' ]]; [M2D.mainmod, adr, pno] _ M2R.InRef [fname]; IF M2D.mainmod # NIL THEN { M2D.mainmod^.prio _ prio; M2D.mainmod^.pAnc _ NEW [M2D.BDesc.Block _ [Block[LNK: 0, cell: 2, adr: 0]]] } ELSE { impok _ FALSE; M2S.log.Put [IO.rope["failed "]] }} ELSE { M2D.mainmod _ M2R.Create [id0, M2D.sysmod^.key]; pno _ 0; M2D.mainmod^.prio _ prio; M2D.mainmod^.pAnc _ NEW [M2D.BDesc.Block _ [Block[LNK: 0, cell: 2, adr: 0]]] }; WHILE (M2S.sym = $from) OR (M2S.sym = $import) DO IF M2S.sym = $from THEN { M2S.GetSym; ImportModule; CheckSym [$import, 30]; ImportList [importMod] } ELSE -- M2S.sym = import -- { M2S.GetSym; DO ImportModule; IF importMod # NIL THEN M2T.NewImp [importMod]; IF M2S.sym = $comma THEN M2S.GetSym ELSE IF M2S.sym # $ident THEN EXIT ENDLOOP; CheckSym [$semicolon, 12] } ENDLOOP; IF M2S.sym = $export THEN { M2S.GetSym; err [38]; WHILE M2S.sym # $semicolon DO M2S.GetSym ENDLOOP; M2S.GetSym }; IF impok THEN { pnoI _ pno; [] _ M2T.NewScope [Module]; M2T.LinkScope; IF isdef THEN fname _ FileName [id0, ".SBL"] ELSE fname _ FileName [id0, ".RFC"]; M2S.log.Put [IO.rope["out:"], IO.rope[fname], IO.char[' ]]; M2R.RefFile _ FS.StreamOpen [fname, $create]; M2R.OpenRef; Block [M2D.mainmod, TRUE]; IF M2S.sym # $period THEN err [14]; IF NOT isdef THEN -- check for undefined procedure bodies -- { FOR hdr: M2D.ObjPtr _ M2T.FirstObj [], hdr^.next WHILE hdr # NIL DO WITH hdr SELECT FROM proc: M2D.ProcPtr => WITH proc^.bd SELECT FROM pd: M2D.PDPtr => IF pd^.pc = 0 THEN err [89]; ENDCASE; ENDCASE; ENDLOOP }; IF NOT M2S.scanerr THEN { IF NOT isdef THEN { fname _ FileName [id0, ".OBJ"]; M2S.log.Put [IO.rope["out:"], IO.rope[fname], IO.char[' ]]; M2I.OutCodeFile [fname, pnoI+1, M2D.mainmod^.pAnc^.cell+M2D.mainmod^.pAnc^.adr, M2R.ModNo, M2R.ModList^.next] }; M2R.OutUnit [M2D.mainmod]; M2R.CloseRef [M2D.mainmod^.pAnc^.adr, pno]; (M2R.RefFile).Close [] } ELSE { M2S.log.Put [IO.rope["errors detected "]]; (M2R.RefFile).Reset [] }; M2T.CloseScope }} ELSE err [10] } ELSE err [28] }; MaxInt: CARDINAL = 77777B; EnumTypSize : CARDINAL = 1; SetTypSize: CARDINAL = 1; PointerTypSize: CARDINAL = 1; ProcTypSize: CARDINAL = 1; DynArrDesSize: CARDINAL = 2; dummyContxt: M2D.PDPtr _ NEW [M2D.BDesc.Block _ [Block[cell: 2]]]; CheckComp: PROC [t0, t1: M2D.StrPtr] = { IF (t0 # t1) AND ((t0 # M2D.inttyp) OR (t1 # M2D.cardtyp)) THEN err [61] }; CaseLabelList: PROC [Ltyp: M2D.StrPtr, n: CARDINAL, tab: M2G.LabelTabPtr] RETURNS [N: CARDINAL] = { x: M2G.ItemPtr = NEW [M2G.Item]; y: M2G.ItemPtr = NEW [M2G.Item]; f: M2D.StrForm = Ltyp^.form; IF f = Range THEN { range: M2D.RangePtr = NARROW [Ltyp]; Ltyp _ range^.BaseTyp } ELSE IF (f > Int) AND (f # Enum) THEN err [38]; DO ConstExpression [x]; CheckComp [Ltyp, x.typ]; IF M2S.sym = $ellipsis THEN { M2S.GetSym; ConstExpression [y]; CheckComp [Ltyp, y.typ] } ELSE y^ _ x^; IF n < M2G.NofCases THEN { i: CARDINAL _ n; DO IF i = 0 THEN EXIT; IF tab[i-1].low <= y.val.I THEN { IF tab[i-1].high >= x.val.I THEN err [62]; EXIT }; tab[i] _ tab[i-1]; i _ i-1 ENDLOOP; tab[i].low _ x.val.I; tab[i].high _ y.val.I; tab[i].label _ M2I.pc; n _ n + 1 } ELSE err [92]; IF M2S.sym = $comma THEN M2S.GetSym ELSE IF (M2S.sym >= $lparen) AND (M2S.sym <= $ident) THEN err [11] ELSE EXIT ENDLOOP; N _ n }; FieldListSequence: PROC [adr: CARDINAL] RETURNS [maxAdr: CARDINAL] = {fld0, fld1, tagfldtyp: M2D.ObjPtr; typ: M2D.StrPtr; VariantPart: PROC = { tabPtr: M2G.LabelTabPtr = NEW [M2G.LabelTable]; lastadr: CARDINAL; N: CARDINAL; maxAdr _ adr; N _ 0; DO IF M2S.sym < $bar THEN { N _ CaseLabelList [typ, N, tabPtr]; CheckSym [$colon, 13]; lastadr _ FieldListSequence [adr]; IF lastadr > maxAdr THEN maxAdr _ lastadr }; IF M2S.sym = $bar THEN M2S.GetSym ELSE EXIT ENDLOOP; IF M2S.sym = $else THEN { M2S.GetSym; lastadr _ FieldListSequence [adr]; IF lastadr > maxAdr THEN maxAdr _ lastadr }}; typ _ M2D.undftyp; IF (M2S.sym = $ident) OR (M2S.sym = $case) THEN DO IF M2S.sym = $ident THEN { fld0 _ M2T.LastObj []; fld1 _ fld0; DO IF M2S.sym = $ident THEN { fld1 _ M2T.NewObj [M2S.id, Field]; M2S.KeepId; M2S.GetSym } ELSE err [10]; IF M2S.sym = $comma THEN M2S.GetSym ELSE IF M2S.sym = $ident THEN err [11] ELSE EXIT ENDLOOP; CheckSym [$colon, 13]; typ _ Type []; WHILE fld0 # fld1 DO fld0 _ fld0^.next; { field: M2D.FieldPtr = NARROW [fld0]; fld0^.typ _ typ; field^.offset _ adr }; adr _ adr + typ^.size ENDLOOP } ELSE IF M2S.sym = $case THEN { M2S.GetSym; fld1 _ NIL; tagfldtyp _ NIL; IF M2S.sym = $ident THEN { fld1 _ M2T.NewObj [M2S.id, Field]; M2S.KeepId; M2S.GetSym }; CheckSym [$colon, 13]; IF M2S.sym = $ident THEN tagfldtyp _ qualident [] ELSE err [10]; IF (tagfldtyp # NIL) AND (tagfldtyp^.class = Typ) THEN typ _ tagfldtyp^.typ ELSE err [52]; IF fld1 # NIL THEN { field: M2D.FieldPtr = NARROW [fld1]; field^.offset _ adr; fld1^.typ _ typ; adr _ adr + typ^.size }; CheckSym [$of, 23]; VariantPart; adr _ maxAdr; CheckSym [$end, 20] }; IF M2S.sym = $semicolon THEN M2S.GetSym ELSE IF M2S.sym = $ident THEN err [12] ELSE EXIT ENDLOOP; maxAdr _ adr }; SubRange: PROC RETURNS [range: M2D.RangePtr] = { x: M2G.ItemPtr = NEW [M2G.Item]; y: M2G.ItemPtr = NEW [M2G.Item]; f: M2D.StrForm; range _ NEW [M2D.Structure.Range]; ConstExpression [x]; f _ x^.typ^.form; IF (f <= Int) OR (f = Enum) THEN range^.min _ x^.val.I ELSE err [82]; CheckSym [$ellipsis, 21]; ConstExpression [y]; CheckComp [x^.typ, y^.typ]; IF (y^.typ = M2D.cardtyp) AND (y^.val.C > MaxInt) THEN err [95]; range^.max _ y^.val.I; IF range^.min > range^.max THEN err [63]; range^.BaseTyp _ x^.typ; range^.size _ x^.typ^.size }; SimpleType: PROC RETURNS [typ: M2D.StrPtr _ M2D.undftyp] = { obj: M2D.ObjPtr; typ0: M2D.StrPtr; n: CARDINAL; IF M2S.sym = $ident THEN { range: M2D.RangePtr _ NIL; obj _ qualident []; IF (obj # NIL) AND (obj^.class = Typ) THEN typ _ obj^.typ ELSE err [52]; IF M2S.sym = $lbrak THEN { M2S.GetSym; typ0 _ typ; typ _ range _ SubRange []; IF range^.BaseTyp # typ0 THEN IF (typ0 = M2D.inttyp) AND(range^.BaseTyp = M2D.cardtyp) THEN range^.BaseTyp _ M2D.inttyp ELSE err [61]; IF M2S.sym = $rbrak THEN M2S.GetSym ELSE { err [16]; IF M2S.sym = $rparen THEN M2S.GetSym }}} ELSE IF M2S.sym = $lparen THEN { enum: M2D.EnumPtr _ NIL; M2S.GetSym; typ _ enum _ NEW [M2D.Structure.Enum]; obj _ NIL; n _ 0; DO const: M2D.ConstPtr _ NIL; IF M2S.sym = $ident THEN { obj _ M2T.NewObj [M2S.id, Const]; M2S.KeepId; const _ NARROW [obj]; const^.conval.C _ n; n _ n + 1; obj^.typ _ typ; M2S.GetSym } ELSE err [10]; IF M2S.sym = $comma THEN M2S.GetSym ELSE IF M2S.sym = $ident THEN err [11] ELSE EXIT ENDLOOP; enum^.NofConst _ n; typ^.size _ EnumTypSize; CheckSym [$rparen, 15] } ELSE IF M2S.sym = $lbrak THEN { M2S.GetSym; typ _ SubRange []; IF M2S.sym = $rbrak THEN M2S.GetSym ELSE { err [16]; IF M2S.sym = $rparen THEN M2S.GetSym }} ELSE err [32] }; FormalType: PROC RETURNS [typ: M2D.StrPtr _ M2D.undftyp] = { objtyp: M2D.ObjPtr; array: M2D.ArrayPtr _ NIL; IF M2S.sym = $array THEN { M2S.GetSym; typ _ array _ NEW [M2D.Structure.Array]; typ^.strobj _ NIL; typ^.size _ DynArrDesSize; array^.dyn _ TRUE; CheckSym [$of, 23]; IF M2S.sym = $ident THEN { objtyp _ qualident []; IF (objtyp # NIL) AND (objtyp^.class = Typ) THEN array^.ElemTyp _ objtyp^.typ ELSE err [52] } ELSE err [10] } ELSE IF M2S.sym = $ident THEN { objtyp _ qualident []; IF (objtyp # NIL) AND (objtyp^.class = Typ) THEN typ _ objtyp^.typ ELSE err [52] } ELSE err [10] }; FormalTypeList: PROC [proctyp: M2D.ProcTypPtr] = { obj: M2D.ObjPtr; partyp: M2D.StrPtr; isvar: BOOLEAN; IF (M2S.sym = $ident) OR (M2S.sym = $var) OR (M2S.sym = $array) THEN DO IF M2S.sym = $var THEN { M2S.GetSym; isvar _ TRUE } ELSE isvar _ FALSE; partyp _ FormalType []; M2T.NewPar [partyp, isvar]; IF M2S.sym = $comma THEN M2S.GetSym ELSE IF M2S.sym = $ident THEN err [11] ELSE EXIT ENDLOOP; CheckSym [$rparen, 15]; proctyp^.firstPar _ M2T.ParamLink []; IF M2S.sym = $colon THEN { M2S.GetSym; proctyp^.resTyp _ M2D.undftyp; IF M2S.sym = $ident THEN { obj _ qualident []; IF (obj # NIL) AND (obj^.class = Typ) THEN proctyp^.resTyp _ obj^.typ ELSE err [52] } ELSE err [10] } ELSE proctyp^.resTyp _ M2D.notyp }; ArrayType: PROC RETURNS [typ: M2D.StrPtr] = { a, b: INTEGER; array: M2D.ArrayPtr; typ _ array _ NEW [M2D.Structure.Array]; array^.dyn _ FALSE; a _ 0; array^.IndexTyp _ SimpleType []; IF array^.IndexTyp^.form = Range THEN { range: M2D.RangePtr = NARROW [array^.IndexTyp]; a _ range^.min; b _ range^.max } ELSE { err [94]; b _ 0 }; IF M2S.sym = $of THEN { M2S.GetSym; array^.ElemTyp _ Type [] } ELSE IF M2S.sym = $comma THEN { M2S.GetSym; array^.ElemTyp _ ArrayType [] } ELSE { err [23]; array^.ElemTyp _ M2D.undftyp }; a _ b-a+1; b _ array^.ElemTyp^.size; IF array^.ElemTyp^.form = Char THEN {} ELSE IF MaxInt / b >= a THEN a _ a*b ELSE { err [210]; a _ 1 }; typ^.size _ a }; OpaqueType: PROC RETURNS [typ: M2D.StrPtr] = { typ _ NEW [M2D.Structure.Opaque]; typ^.size _ PointerTypSize }; Type: PROC RETURNS [typ: M2D.StrPtr] = { obj: M2D.ObjPtr; IF M2S.sym < $lparen THEN { err [33]; DO M2S.GetSym; IF M2S.sym >= $lparen THEN EXIT ENDLOOP }; SELECT M2S.sym FROM $array => { M2S.GetSym; typ _ ArrayType [] }; $record => { record: M2D.RecordPtr _ NIL; M2S.GetSym; typ _ record _ NEW [M2D.Structure.Record]; obj _ M2T.NewScope [Typ]; -- header -- typ^.size _ FieldListSequence [0]; record^.firstFld _ obj^.next; CheckSym [$end, 20]; M2T.CloseScope }; $set => { set: M2D.SetPtr _ NIL; M2S.GetSym; CheckSym [$of, 23]; typ _ set _ NEW [M2D.Structure.Set]; set^.BaseTyp _ SimpleType []; WITH set^.BaseTyp SELECT FROM enum: M2D.EnumPtr => { IF enum^.NofConst > M2D.WordSize THEN err [209] }; range: M2D.RangePtr => { IF (range^.min < 0) OR (range^.max >= M2D.WordSize) THEN err [209] } ENDCASE => err [60]; typ^.size _ SetTypSize }; $pointer => { pointer: M2D.PointerPtr _ NIL; M2S.GetSym; typ _ pointer _ NEW [M2D.Structure.Pointer]; pointer^.BaseId _ 0; typ^.size _ PointerTypSize; CheckSym [$to, 24]; IF M2S.sym = $ident THEN { obj _ qualident []; IF obj = NIL THEN { pointer^.BaseTyp _ M2D.undftyp; pointer^.BaseId _ M2S.id; M2S.KeepId-- forward ref --} ELSE IF obj^.class = Typ THEN pointer^.BaseTyp _ obj^.typ ELSE err [52] } ELSE pointer^.BaseTyp _ Type [] }; $procedure => { proctyp: M2D.ProcTypPtr; M2S.GetSym; typ _ proctyp _ NEW [M2D.Structure.ProcTyp]; M2T.NewProc; typ^.size _ ProcTypSize; IF M2S.sym = $lparen THEN { M2S.GetSym; FormalTypeList [proctyp] } ELSE proctyp^.resTyp _ NIL }; ENDCASE => typ _ SimpleType []; IF (M2S.sym < $semicolon) OR (M2S.sym > $else) THEN { err [34]; WHILE (M2S.sym < $ident) OR (M2S.sym > $else) AND (M2S.sym < $begin) DO M2S.GetSym ENDLOOP }}; Selector: PROC [x: M2G.ItemPtr, obj: M2D.ObjPtr] = { y: M2G.ItemPtr = NEW [M2G.Item _ [contxt: x^.contxt]]; M2G.GenItem [x, obj, M2T.Scope]; DO IF M2S.sym = $lbrak THEN { M2S.GetSym; DO M2G.LoadAdr [x]; Expression [y]; M2G.GenIndex [x, y]; IF M2S.sym = $comma THEN M2S.GetSym ELSE EXIT ENDLOOP; CheckSym [$rbrak, 16] } ELSE IF M2S.sym = $period THEN { M2S.GetSym; IF M2S.sym = $ident THEN { IF (x^.typ # NIL) AND (x^.typ^.form = Record) THEN { obj _ M2T.FindField [M2S.id, NARROW[x^.typ]]; M2G.GenField [x, obj] } ELSE err [57]; M2S.GetSym } ELSE err [10] } ELSE IF M2S.sym = $arrow THEN { M2S.GetSym; M2G.GenDeRef [x] } ELSE EXIT ENDLOOP }; FormalParameters: PROC [pd: M2D.PDPtr] = { isvar: BOOLEAN; par, par0: M2D.ObjPtr; typ0: M2D.StrPtr; pd^.cell _ 0; pd^.adr _ 0; IF (M2S.sym = $ident) OR (M2S.sym = $var) THEN DO par0 _ M2T.LastObj []; isvar _ FALSE; IF M2S.sym = $var THEN { M2S.GetSym; isvar _ TRUE }; DO IF M2S.sym = $ident THEN { par _ M2T.NewObj [M2S.id, Var]; M2S.KeepId; M2S.GetSym } ELSE err [10]; IF M2S.sym = $comma THEN M2S.GetSym ELSE IF M2S.sym = $ident THEN err [11] ELSE IF M2S.sym = $var THEN { err [11]; M2S.GetSym } ELSE EXIT ENDLOOP; CheckSym [$colon, 13]; typ0 _ FormalType []; par0 _ par0^.next; WHILE par0 # NIL DO var0: M2D.VarPtr = NARROW [par0]; par0^.typ _ typ0; var0^.mod _ 0; var0^.lev _ pd^.lev; var0^.varpar _ isvar; IF pd^.cell >= 14 THEN { err [99]; pd^.cell _ 0 }; var0^.cell _ pd^.cell; pd^.cell _ pd^.cell + 1; IF typ0^.form = Array THEN { array: M2D.ArrayPtr = NARROW [typ0]; IF array^.dyn THEN { IF pd^.cell >= 14 THEN { err [99]; pd^.cell _ 0 }; pd^.cell _ pd^.cell + 1 } -- size ELSE IF NOT isvar THEN pd^.adr _ pd^.adr + typ0^.size } ELSE IF (typ0^.form = Record) AND NOT isvar THEN pd^.adr _ pd^.adr + typ0^.size; par0 _ par0^.next ENDLOOP; IF M2S.sym = $semicolon THEN M2S.GetSym ELSE IF M2S.sym = $ident THEN err [12] ELSE EXIT ENDLOOP; CheckSym [$rparen, 15] }; ActualParameters: PROC [x: M2G.ItemPtr] = { apar: M2G.ItemPtr = NEW [M2G.Item _ [contxt: x^.contxt]]; fpar: M2D.ParPtr _ M2G.PrepCall [x]; IF M2S.sym # $rparen THEN DO Expression [apar]; IF fpar # NIL THEN { M2G.GenParam [apar, fpar]; x^.expRegs _ M2D.UNION [x^.expRegs, apar^.expRegs]; fpar _ fpar^.next } ELSE err [64]; IF M2S.sym = $comma THEN M2S.GetSym ELSE IF (M2S.sym >= $lparen) AND (M2S.sym <= $ident) THEN err [11] ELSE EXIT ENDLOOP; IF fpar = NIL THEN M2G.GenCall [x] ELSE err [65] }; StandProcCall: PROC [p: M2G.ItemPtr] = { cd: M2D.CDPtr = NARROW [NARROW [p^.obj, M2D.ProcPtr].bd]; m: CARDINAL = cd^.num; n: CARDINAL; x: M2G.ItemPtr _ NEW [M2G.Item _ [contxt: p^.contxt]]; IF m = 1 THEN { M2G.GenTrap [10]; p^.typ _ M2D.notyp } ELSE { CheckSym [$lparen, 22]; n _ 0; DO Expression [x]; M2G.GenStParam [p, x, m, n]; n _ n + 1; IF M2S.sym = $comma THEN M2S.GetSym ELSE IF M2S.sym # $ident THEN EXIT ENDLOOP; CheckSym [$rparen, 15]; M2G.GenStFct [p, m, n] }}; Element: PROC [x: M2G.ItemPtr] = { e1: M2G.ItemPtr = NEW [M2G.Item _ [contxt: x^.contxt]]; e2: M2G.ItemPtr = NEW [M2G.Item _ [contxt: x^.contxt]]; Expression [e1]; IF M2S.sym = $ellipsis THEN { M2S.GetSym; IF e1^.mode = conMd THEN { Expression [e2]; IF e2^.mode # conMd THEN err [90] } ELSE { M2G.Load [e1]; Expression [e2] }; M2G.GenSet [x, e1, e2] } ELSE M2G.GenSingSet [x, e1] }; Sets: PROC [x: M2G.ItemPtr, styp: M2D.StrPtr] = { y: M2G.ItemPtr = NEW [M2G.Item _ [contxt: x^.contxt]]; x^.typ _ styp; y^.typ _ styp; IF M2S.sym # $rbrace THEN { Element [x]; DO IF M2S.sym = $comma THEN M2S.GetSym ELSE IF (M2S.sym >= $lparen) AND (M2S.sym <= $ident) THEN err [11] ELSE EXIT; M2G.Load [x]; Element [y]; M2G.Load [y]; M2G.GenOp [plus, x, y] ENDLOOP } ELSE { x^.mode _ conMd; x^.val.S _ ALL [FALSE] }; CheckSym [$rbrace, 17] }; Factor: PROC [x: M2G.ItemPtr] = { obj: M2D.ObjPtr; xt: M2D.StrPtr; IF M2S.sym < $lparen THEN { err [31]; DO M2S.GetSym; IF M2S.sym >= $lparen THEN EXIT ENDLOOP }; SELECT M2S.sym FROM $ident => { obj _ qualident []; IF M2S.sym = $lbrace THEN { M2S.GetSym; IF (obj # NIL) AND (obj^.class = Typ) AND (obj^.typ^.form = Set) THEN Sets [x, obj^.typ] ELSE { err [52]; Sets [x, M2D.bitstyp] }} ELSE { Selector [x, obj]; IF x^.mode = codMd THEN { cd: M2D.CDPtr = NARROW [NARROW [x^.obj, M2D.ProcPtr].bd]; IF cd^.num > 0 THEN StandProcCall [x] } ELSE IF M2S.sym = $lparen THEN { M2S.GetSym; IF x^.mode = typMd THEN -- type transfer function -- { xt _ x^.typ; Expression [x]; M2G.Load [x]; IF xt^.size # x.typ^.size THEN err [81]; x^.typ _ xt } ELSE ActualParameters [x]; CheckSym [$rparen, 15] }}}; $number => { M2S.GetSym; x^.mode _ conMd; SELECT M2S.numtyp FROM cardint => { x^.typ _ M2D.cardtyp; x^.val.C _ M2S.intval }; longint => { x^.typ _ M2D.dbltyp; x^.val.D _ M2S.dblval }; char => { x^.typ _ M2D.chartyp; x^.val.C _ M2S.intval }; real => { x^.typ _ M2D.realtyp; x^.val.R _ M2S.realval }; longreal => { x^.typ _ M2D.realtyp; x^.val.R _ M2S.realval } ENDCASE }; $string => { x^.typ _ M2D.stringtyp; x^.mode _ conMd; [ x^.val.D0, x^.val.D1 ] _ M2I.AllocString [M2S.id]; M2S.GetSym }; $lparen => { M2S.GetSym; Expression [x]; CheckSym [$rparen, 15] }; $lbrace => { M2S.GetSym; Sets [x, M2D.bitstyp] }; $not => { M2S.GetSym; Factor [x]; M2G.GenNot [x] }; ENDCASE => { err [31]; x^.typ _ M2D.undftyp; x^.mode _ stkMd } }; Term: PROC [x: M2G.ItemPtr] = { y: M2G.ItemPtr = NEW [M2G.Item _ [contxt: x^.contxt]]; mulop: M2S.Symbol; Factor [x]; WHILE (M2S.sym >= $times) AND (M2S.sym <= $and) DO mulop _ M2S.sym; M2S.GetSym; IF x^.mode # conMd THEN IF x^.typ^.form = Set THEN M2G.Load [x] ELSE M2G.LoadStk [x]; IF mulop = $and THEN M2G.GenAnd [x]; Factor [y]; IF y^.mode # conMd THEN IF y^.typ^.form = Set THEN M2G.Load [y] ELSE M2G.LoadStk [y]; M2G.GenOp [mulop, x, y] ENDLOOP }; SimpleExpression: PROC [x: M2G.ItemPtr] = { y: M2G.ItemPtr = NEW [M2G.Item _ [contxt: x^.contxt]]; addop: M2S.Symbol; IF M2S.sym = $minus THEN { M2S.GetSym; Term [x]; M2G.GenNeg [x] } ELSE { IF M2S.sym = $plus THEN M2S.GetSym; Term [x] }; WHILE (M2S.sym >= $plus) AND (M2S.sym <= $or) DO addop _ M2S.sym; M2S.GetSym; IF addop = $or THEN { IF x^.mode # conMd THEN M2G.LoadStk [x]; M2G.GenOr [x]; Term [y]; IF y^.mode # conMd THEN M2G.LoadStk [y] } ELSE { M2G.Load [x]; Term [y]; M2G.Load [y] }; M2G.GenOp [addop, x, y] ENDLOOP }; Expression: PROC [x: M2G.ItemPtr] = { y: M2G.ItemPtr = NEW [M2G.Item _ [contxt: x^.contxt]]; relation: M2S.Symbol; SimpleExpression [x]; IF (M2S.sym >= $eql) AND (M2S.sym <= $geq) THEN { relation _ M2S.sym; M2S.GetSym; IF x^.mode # conMd THEN IF x^.typ^.form = Set THEN M2G.Load [x] ELSE M2G.LoadStk [x]; SimpleExpression [y]; IF y^.mode # conMd THEN M2G.Load [y]; M2G.GenOp [relation, x, y] } ELSE IF M2S.sym = $in THEN { M2S.GetSym; IF x^.mode # conMd THEN M2G.LoadStk [x]; SimpleExpression [y]; M2G.Load [y]; M2G.GenIn [x, y] }}; ConstExpression: PROC [x: M2G.ItemPtr] = { x^.contxt _ dummyContxt; Expression [x]; IF x^.mode # conMd THEN { err [44]; x^.mode _ conMd; x^.val.C _ 1 }}; InitP: PUBLIC PROC [log: IO.STREAM, fname: Rope.ROPE] = { opened: BOOLEAN _ TRUE; module: M2D.ModulePtr _ NIL; M2T.InitTableHandler; M2S.InitScanner; M2S.log _ log; M2R.InitRef; M2I.InitGenerator; module _ M2D.sysmod; module^.key _ BasicTime.ToPupTime[BasicTime.Now []]; M2S.source _ FS.StreamOpen [fname ! FS.Error => { opened _ FALSE; CONTINUE }]; IF opened THEN { M2G.rngchk _ TRUE; CompilationUnit; (M2S.source).Close [] }}; END. èFILE: M2PImpl.mesa Modula-2 Parser Last Edited by: Gutknecht, September 18, 1985 1:10:25 pm PDT Satterthwaite May 9, 1986 12:10:00 pm PDT procedure heading in definition module or forward declaration proc = procedure object, pd = extension -- Module Loops -- End Loops obj^.conval _ x^.val -- allocate anonymous variable for address begin StatSeq begin Block fixup proc entry and init type and expression parser enter label range into ordered table -- initialization and main entry Ê*Ò˜Jšœ™Jšœ™™Jšœ ˜—Jšœ˜———Jšœ*™*šœœœ˜J˜$šœœ˜%Jšœœ"˜*Jšœ ˜ Jšœœœ Ÿ˜MJ˜J˜š˜šœœ˜'Jšœœœœ(˜yJšœ ˜—Jšœœ ˜'Jšœœœ ˜'Jšœ˜ —Jšœ˜Jšœ˜J˜šœ˜Jšœœ"œ ˜4J˜ —Jšœ ˜—Jšœœœ ˜*šœ$˜(Jšœœ%˜,Jšœ œ˜—J˜!—Jšœ ˜J˜J˜—šžœœ˜*Jšœœœœ˜/Jšœ*˜*Jšœ+˜+J˜*J˜šœœ˜1šœœ˜%Jšœœ+˜CJšœ ˜ J˜—Jšœ ˜J˜—Jšœ˜šœœ˜'Jšœœœ˜9J˜ —Jšœ œ˜-Jšœ,œ˜AJšœ6˜6J˜J˜Jšœ˜Jšœ'˜'J˜—šœ™J˜Jšœœ œ˜!Jšœœœœ˜)Jšœœœœ˜'J˜šž œœ ˜/J˜—šž œœœ˜ Jšœœœ ˜Jšœœ˜6šœ ˜J˜——šžœœ˜J˜ Jšœœ*œ˜JJ˜——Jšœ ™ J˜šžœœœ˜3J˜Jšœœ˜ Jšœ%˜%Jšœœ ˜$J˜šž œœ˜Jšœœ˜Jšœ!˜!J˜š˜šœ ˜šœœ˜=Jšœ ˜ šœ˜Jšœœ˜J˜%šœ˜J˜#—šœœ˜J˜-—Jšœ ˜Jšœ'œ˜4Jšœ˜Jšœ™Jšœ;˜;Jšœ;˜;šœ˜Jšœ*˜*—J˜—Jšœ˜ —šœ˜šœ˜Jšœ œœ˜Jšœœ˜šœœœ˜<š œœœœ˜HJšœ œ˜——šœ ˜J˜8JšœŸ"œ˜3—J˜ Jšœœ˜4šœœœ˜7J˜'—Jšœœœ˜&Jšœ ˜J˜šœ ˜Jšœœ˜"Jšœ(˜(Jšœœœ˜.—JšœœœŸ˜GJšœ ˜JšœŸ'˜;J˜—Jšœ˜ —šœ˜šœœ"˜;š˜šœ˜J˜:—Jšœ ˜Jšœœ ˜#Jšœœœ ˜&Jšœ˜ —Jšœ˜J˜%šœ ˜Jšœœ˜Jšœœ˜%Jšœœ˜%Jšœ%˜%Jšœœ˜7Jšœ5˜5šœœ˜3Jšœ!˜!——Jšœ˜J˜—Jšœ˜ —šœ˜Jšœ?˜?—šœ˜Jšœ6˜6—šœ˜ šœœ˜/J˜ šœ ˜Jšœœœ˜4—Jšœ˜ —Jšœœœ˜4———Jšœ˜ J˜—šžœœ˜Jšœ œ˜Jšœ"˜"Jšœœ˜1Jšœœ˜1J˜šžœœ˜!šœœ˜Jšœ<˜<—šœ˜Jšœœœœ ˜3—Jšœœ ˜&J˜Jšžœœ˜Jšœœ˜Jšœœ˜1Jšœœ˜,J˜J˜:š˜šœ˜J˜%J˜8—Jšœœ œ˜+—Jšœ˜J˜ Jšœœ0˜GJšœ˜J˜.J˜—šžœœ˜Jšœœ œ˜*Jšœœ˜1Jšœœ˜2Jšœœ˜2Jšœœ˜2šœœ˜3šœœ˜šœœ˜Jšœœ˜!Jšœ œœ ˜1——Jšœ ˜J˜ —Jšœ ˜J˜1Jšœœ ˜%šœ ˜Jšœœ˜$—J˜%J˜J˜1J˜šœ˜Jšœ$˜$—š˜Jšœ;˜;—J˜#J˜J˜ J˜J˜—šžœœ˜Jšœ,˜,Jšœœ˜1Jšœœ˜1Jšœ œ˜ šœœ˜6šœœ˜šœ˜Jšœ'™'Jšœœ˜7šœ˜Jšœ#œ˜?—Jšœ*˜.Jšœ˜Jšœ6˜6Jšœ!˜!—Jšœ'˜.——Jšœ ˜Jšœ.˜.J˜——Jšœ ™ š˜šœœ ˜$šœ ˜Jšœœ˜—Jšœ˜ —šœ ˜šœ ˜ Jšœ2˜2šœ˜J˜E—šœœœ ˜'JšœC˜C—šœœ˜Jšœœœ˜;šœ œ˜(Jšœœ ˜%—Jšœ˜—Jšœ˜—šœ˜J˜Jšœ'˜'——Jšœ˜J˜Jšœœ ˜'Jš œœœœœ ˜SJšœ˜ —Jšœ˜ J˜—Jšœ ™ šœ œ˜šœ˜Jšœ#˜#Jšœ1˜1J˜#J˜šœ˜Jšœ8˜8—Jšœ˜šœœœœ ˜2Jšœ˜Jšœ)˜)šœœ˜4Jšœ˜———šœ˜Jšœœ ˜"Jšœ˜Jšœ/˜/J˜%Jšœ ˜ Jšœ#˜#šœœœœ ˜2Jšœ˜šœ˜!Jšœœ,˜>—Jšœ˜Jšœ™šœœ˜(Jšœœ˜-—Jšœœ ˜(Jšœœœ˜-šœ ˜Jšœœœ˜AJšœ˜—Jšœ ˜ ——Jšœ˜—J˜šœ˜Jšœœ'œ ˜9J˜ —šœ ˜J˜——šžœœ˜Jšœœ˜Jšœ œ œ˜!Jšœ˜J˜š žœœœ œœœ˜BJš œ œœœœ˜FJšœ$œ"˜OJ˜—šž œœ˜šœœ˜Jšœœ)œ˜Hš˜Jšœ œ˜Jšœ"˜"Jšœ œœœ ˜:J˜*šœ œ˜Jšœ œœ˜5——J˜ —Jšœ ˜J˜—Jšœœ œ œ ˜5J˜Jšœœœ˜:š˜Jšœœœ˜?—šœœ˜'šœ˜Jšœ'˜'Jšœœœ˜%J˜šœ˜ Jšœ!˜!Jšœ œœœ ˜:Jšœ,˜,šœœ˜Jšœ˜Jšœœœ˜N—Jšœ œœ˜9—š˜Jšœ;˜;Jšœ˜Jšœœœ˜O—šœœ˜1šœ˜J˜3J˜—šœŸ˜J˜ šœ˜Jšœ œœ˜/Jšœœ ˜#š˜Jšœœ˜——Jšœ˜J˜——Jšœ˜šœœ˜1Jšœœ œ˜1J˜ —šœ˜ J˜8Jšœœ˜,Jšœ ˜$Jšœ œœœ ˜;Jšœœ˜-J˜ Jšœœ˜Jšœœ ˜#šœœœŸ*˜<šœœ.œœ˜Ešœœ˜šœ˜šœ œ˜Jšœœ œ ˜-Jšœ˜——Jšœ˜——Jšœ˜ —šœœ ˜šœœœ˜Jšœ!˜!Jšœ œœœ ˜;Jšœp˜p—Jšœ˜Jšœ+˜+Jšœ œ ˜—š˜Jšœœ˜,Jšœ œ ˜—J˜——Jšœ ˜—Jšœ ˜J˜—šœ™J˜šœœ ˜J˜—Jšœœ˜Jšœ œ˜Jšœœ˜Jšœ œ˜Jšœœ˜J˜Jšœœ&˜BJ˜šž œœ˜&Jš œœ œœœ ˜MJ˜—š ž œœœœœ˜aJšœœ ˜"Jšœœ ˜ Jšœ˜šœ ˜Jšœœ ˜>—š˜Jšœ œ œ ˜*—šœ.˜0šœ˜J˜<—Jšœ ˜ Jšœ'™'šœœœ˜+š˜Jšœœœ˜šœ˜Jšœœœ ˜,Jšœ˜—J˜—Jšœ˜JšœD˜DJšœ ˜ —Jšœ ˜Jšœœ ˜#š˜Jšœœœ ˜=Jšœ˜ ——Jšœ˜Jšœ˜J˜—š žœœœœ œ˜DJšœ4˜4J˜šž œœ˜Jšœœ˜1šœ œœ˜J˜—Jšœ˜š˜šœ˜Jšœ<˜—J˜Jšœœœ ˜@Jšœœœœ˜KJšœ ˜šœœ˜Jšœœ˜&J˜>—J˜.J˜—Jšœœ ˜'Jšœœœ ˜&Jšœ˜ —Jšœ˜J˜—J˜—šžœœœ˜.Jšœœ ˜"Jšœœ ˜ Jšœ˜Jšœœ˜"J˜&Jšœ œ œœ ˜EJ˜JJšœœœ ˜@Jšœ˜Jšœœ ˜)Jšœ6˜6J˜—šž œœœ"˜:Jšœ(œ˜1šœœœ˜5Jšœ˜Jš œœœœœ ˜Hšœœ˜&Jšœ&˜&šœ˜šœœ˜=J˜—Jšœ ˜—Jšœœ ˜#š˜Jšœ œœ˜4———šœœœœ˜9Jšœ ˜ Jšœ œ˜&Jšœœ˜šœœ˜šœ˜Jšœ/˜/Jšœœ˜*Jšœ˜J˜ —Jšœ ˜Jšœœ ˜#Jšœœœ ˜&Jšœ˜ —Jšœ˜J˜,J˜—šœœ˜J˜ Jšœœ ˜#šœ ˜Jšœœ˜'Jšœ ˜J˜———šž œœœ"˜:Jšœ,œ˜0šœœ˜&Jšœœ˜(Jšœœ*œ˜@J˜šœœ˜1šœ œœ˜0J˜—Jšœ ˜—Jšœ ˜—š˜šœ˜J˜šœ œœ˜0J˜—Jšœ ˜—Jšœ ˜J˜——šžœœ˜0Jšœ.œ˜6šœœœ˜Dš˜Jšœœœ˜3Jšœ œ˜Jšœ3˜3Jšœœ ˜#Jšœœœ ˜&Jšœ˜ —Jšœ˜—J˜=šœ˜J˜,šœœ˜.Jšœœœœ˜EJšœ ˜—Jšœ ˜—Jšœ˜#J˜—šž œœœ˜+Jšœœ˜%Jšœœ˜(Jšœ œ˜J˜ šœ˜%Jšœœ˜1Jšœ ˜ —Jšœ˜Jšœœ)˜>š˜Jšœœ.˜FJšœ,˜0—J˜$Jšœœ˜&š˜Jšœœ˜Jšœ˜—Jšœ˜J˜—šž œœœ˜,Jšœœ6˜AJ˜—šžœœœ˜'Jšœ˜šœœ ˜%šœ ˜Jšœœ˜—Jšœ˜ —šœ ˜Jšœ-˜-šœ ˜ Jšœœ ˜*Jšœœ˜*JšœŸ ˜&J˜"J˜J˜J˜—šœ˜Jšœœ!˜8Jšœ œ˜$Jšœ˜šœœ˜šœ˜Jšœœœ ˜4—šœ˜Jšœœœœ ˜F——Jšœ ˜J˜—šœ ˜ Jšœœ ˜,Jšœœ˜,J˜0J˜šœœ˜.šœœ˜Jšœ;˜;Jšœ Ÿœ˜—š˜Jšœœœ ˜D——Jšœ˜"—šœ ˜ Jšœ&˜&Jšœœ&˜9Jšœ˜Jšœœ)˜BJšœœ˜—Jšœ˜J˜—šœœœ ˜?šœœœ˜GJ˜ —Jšœ˜ —J˜—šžœœ$˜2Jšœœ"˜8J˜ š˜šœœ˜&š˜J˜5Jšœœ œ˜-—Jšœ˜J˜—šœœœ˜,šœ˜šœœ œœ˜4Jšœœ ˜/J˜—Jšœ ˜J˜ —Jšœ ˜—Jšœœœ!˜>Jšœ˜ —Jšœ˜ J˜—šžœœ˜(Jšœ œ*˜:Jšœ˜šœœ˜.šœ œ˜(Jšœœœ˜4š˜šœ˜J˜:—Jšœ ˜Jšœœ ˜#Jšœœœ ˜&Jšœœœ˜4Jšœ˜ —Jšœ˜J˜J˜(šœœ˜Jšœœ˜!J˜ J˜*Jšœœ˜2Jšœ/˜/šœ˜Jšœœ˜&šœ ˜Jšœœœ˜4JšœŸ˜!—Jšœœœœ!˜7—š œœœœ˜0Jšœ˜—J˜—Jšœ˜Jšœœ ˜'Jšœœœ ˜'Jšœ˜ —Jšœ˜—Jšœ˜J˜—šžœœ˜)Jšœœ#˜—šœ˜J˜——šžœœ˜Jšœœ"˜8Jšœ˜J˜ šœœ˜2J˜šœ˜Jšœœœ˜=—Jšœœ˜$J˜ šœ˜Jšœœœ˜=—Jšœ˜—Jšœ˜ J˜—šžœœ˜)Jšœœ"˜8Jšœ˜Jšœœ)˜Aš˜Jšœœœ ˜%J˜ —šœœ˜0J˜šœ ˜Jšœœœ˜*J˜Jšœœ˜)—Jšœ*˜.J˜—Jšœ˜ J˜—šž œœ˜#Jšœœ"˜8Jšœ˜J˜šœœ˜/J˜!šœ˜Jšœœœ˜=—Jšœ˜Jšœœ ˜%Jšœ˜—šœœœ˜(Jšœœ˜(Jšœ#˜#Jšœ˜J˜——šžœœ˜(Jšœ˜Jšœ˜Jšœ˜Jšœ/˜/J˜——šœ™J˜š žœœœœœœ˜7Jšœ œœ˜Jšœœ˜Jšœ˜Jšœ˜Jšœ˜Jšœ˜Jšœ4˜4Jš œ œœœœ˜Nšœ˜Jšœœœ œ ˜?——J˜—šœ˜J˜J˜——…—Œø¹²