
<<FILE: M2PImpl.mesa>>
<<Modula-2 Parser>>
<<Last Edited by: Gutknecht, September 18, 1985 1:10:25 pm PDT>>
    <<Satterthwaite December 11, 1985 3:21:00 pm PST>>

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
<<procedure heading in definition module or forward declaration>>
{ 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] }}};
<<proc = procedure object, pd = extension -->>
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 };

<<Module Loops -->>

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 };

<<End Loops>>

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;
<<obj^.conval _ x^.val -->>
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: PROCEDURE [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: PROCEDURE =
{ 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 => {
<<allocate anonymous variable for address>>
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 };

<<begin StatSeq>>
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 };

<<begin Block>>
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];
<<fixup proc entry and init>>
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.Concat [ Rope.FromProc [len: M2S.IdBuf[j].ORD-1, p: nextCh], 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; IO.Put [M2S.log, 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; IO.Put [M2S.log, 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"];
IO.Put [M2S.log, 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"];
IO.Put [M2S.log, 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];
IO.Close [M2R.RefFile] }
ELSE
{ IO.Put [M2S.log, IO.rope["errors detected "]];
IO.Reset [M2R.RefFile] };
M2T.CloseScope }}
ELSE err [10] }
ELSE err [28] };

<<type and expression parser>>

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^;
<<enter label range into ordered table -->>
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 }};

<<initialization and main entry>>

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; IO.Close [M2S.source] }};

END.



