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
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: 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 => {
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.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] };
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; (M2S.source).Close [] }};
END.