IMPLEMENTATION MODULE Lower;
(* Scalar/boolean/control-flow walk (L0-L2): see Lower.def and
docs/plan-lower.md. The mutually recursive walkers are declared in
Lower.def (gm2's link pass rejects FORWARD, V3 has no whole-module
pass, so a definition-visible declaration breaks the cycle). *)
IMPORT AST, SymTab, QbeGen;
(* ---------------- self-contained symbol tables (zero SymTab surface) ----
Flat arrays only, no ARRAY OF RECORD: a record's array field loses its
length word in static array data, and V3 miscompiles that when the
field is passed as an open array (docs/wip/nested-array-field-bug.mod).
Names live in flat CHAR arrays indexed manually at slot * 64. *)
CONST
MaxSym = 8192; (* whole-session: >4096 vars/consts/params *)
MaxName = 63;
MaxProc = 2048; (* whole-session: the compiler declares >1200 procs *)
MaxImp = 512; (* per-unit imports *)
MaxPar = 32;
HashSize = 16384; (* power of two > MaxSym, MaxProc: open addressing *)
MaxCFold = 256; (* named compile-time set constants per session *)
MaxCFoldW = 16; (* mask words (512 bits); wider sets are a 230 *)
VAR
symName : ARRAY [0 .. MaxSym * 64 - 1] OF CHAR;
symKind : ARRAY [0 .. MaxSym - 1] OF INTEGER;
symTy : ARRAY [0 .. MaxSym - 1] OF SymTab.TypeIndex;
symVal : ARRAY [0 .. MaxSym * 64 - 1] OF CHAR; (* const value, flat *)
nSyms : CARDINAL;
procName : ARRAY [0 .. MaxProc * 64 - 1] OF CHAR;
procUid : ARRAY [0 .. MaxProc - 1] OF CARDINAL;
procRes : ARRAY [0 .. MaxProc - 1] OF SymTab.TypeIndex;
procDep : ARRAY [0 .. MaxProc - 1] OF CARDINAL;
procExt : ARRAY [0 .. MaxProc - 1] OF BOOLEAN;
procVa : ARRAY [0 .. MaxProc - 1] OF BOOLEAN; (* C varargs *)
procNpar : ARRAY [0 .. MaxProc - 1] OF CARDINAL;
parTy : ARRAY [0 .. MaxProc * MaxPar - 1] OF SymTab.TypeIndex;
parVar : ARRAY [0 .. MaxProc * MaxPar - 1] OF BOOLEAN;
parName : ARRAY [0 .. MaxProc * MaxPar * 64 - 1] OF CHAR;
nProcs : CARDINAL;
(* Open-addressing indexes into symName/procName: entry = index+1,
0 = empty. A whole-session linear scan is too slow (thousands of
lookups over thousands of entries), so FindSym/FindProc hash. *)
symHash : ARRAY [0 .. HashSize - 1] OF INTEGER;
procHash : ARRAY [0 .. HashSize - 1] OF INTEGER;
(* Per-unit imports (FROM M IMPORT P): the exact proc entry for a
name, so an unqualified call resolves to the imported proc even
when another module declares the same name. Reset each unit. *)
impProc : ARRAY [0 .. MaxImp - 1] OF INTEGER;
impName : ARRAY [0 .. MaxImp * 64 - 1] OF CHAR;
nImps : CARDINAL;
(* Record-array globals too large to expand inline: their template is
emitted with their data and their elements are initialised by a
run-time loop (QbeGen.InitRecArray) in the unit's init. Per unit. *)
nCountInit : CARDINAL;
countArr : ARRAY [0 .. 63] OF SymTab.Name;
countTyp : ARRAY [0 .. 63] OF SymTab.TypeIndex;
(* GOTO/labels: user label name -> QbeGen label, per procedure. *)
nUserLab : CARDINAL;
userLabNm : ARRAY [0 .. 255 * 64 - 1] OF CHAR;
userLabQ : ARRAY [0 .. 255] OF QbeGen.QVal;
(* Scoping: each symbol records the procedure that owns it (-1 =
module level); FindSym searches the emitted procedure's chain
innermost-first so common names (s, i, k) do not collide across
procedures. *)
symOwner : ARRAY [0 .. MaxSym - 1] OF INTEGER;
procParent : ARRAY [0 .. MaxProc - 1] OF INTEGER;
procSymBase : ARRAY [0 .. MaxProc - 1] OF CARDINAL;
procSymTop : ARRAY [0 .. MaxProc - 1] OF CARDINAL;
scopeStack : ARRAY [0 .. MaxProc - 1] OF INTEGER;
scopeTop : CARDINAL;
curScopeProc : INTEGER; (* owner while parsing: enclosing proc *)
emitProc : INTEGER; (* owner while emitting: current proc *)
qualUid : CARDINAL; (* uid of the last M.P alias resolved *)
qualIsVar : BOOLEAN; (* last M.P alias is a proc-typed variable *)
withRec : ARRAY [0 .. 15] OF SymTab.TypeIndex;
withTop : CARDINAL;
curMethCls : SymTab.TypeIndex; (* class bound by the last obj.Method *)
curImplCls : SymTab.TypeIndex; (* class whose implementation is open *)
curUnitName : SymTab.Name; (* unit being re-emitted (LowerSession) *)
(* Compile-time set constants (SET CONSTs): masks the grammar computes
and Lower re-emits as pooled static data. Name-keyed, latest wins,
exactly like symVal. *)
cfoldN : CARDINAL;
cfoldName : ARRAY [0 .. MaxCFold * 64 - 1] OF CHAR;
cfoldW : ARRAY [0 .. MaxCFold - 1] OF CARDINAL;
cfoldLo : ARRAY [0 .. MaxCFold - 1] OF INTEGER;
cfoldMask : ARRAY [0 .. MaxCFold * MaxCFoldW - 1] OF CARDINAL;
PROCEDURE CopyN (src: ARRAY OF CHAR; VAR dst: ARRAY OF CHAR);
VAR i: CARDINAL;
BEGIN
i := 0;
WHILE (i < MaxName) AND (src[i] # CHR(0)) DO dst[i] := src[i]; INC(i) END;
dst[i] := CHR(0)
END CopyN;
PROCEDURE CopySpan (VAR src: ARRAY OF CHAR; VAR dst: ARRAY OF CHAR;
srcOff, dstOff: CARDINAL);
(* src is a VAR open array on purpose: gm2 copies a value open-array
formal to a stack VLA of its full length, which overflows the stack
for the multi-megabyte tables below. *)
VAR i: CARDINAL;
BEGIN
i := 0;
WHILE (i < MaxName) AND (src[srcOff + i] # CHR(0)) DO
dst[dstOff + i] := src[srcOff + i]; INC(i)
END;
dst[dstOff + i] := CHR(0)
END CopySpan;
PROCEDURE HashStr (name: ARRAY OF CHAR): CARDINAL;
VAR h: CARDINAL; i: CARDINAL;
BEGIN
h := 5381; i := 0;
WHILE (i <= HIGH(name)) AND (name[i] # CHR(0)) DO
h := (h * 33 + VAL(CARDINAL, ORD(name[i]))) MOD HashSize; INC(i)
END;
RETURN h
END HashStr;
PROCEDURE SpanEq (VAR arr: ARRAY OF CHAR; off: CARDINAL;
name: ARRAY OF CHAR): BOOLEAN;
VAR j: CARDINAL;
BEGIN
j := 0;
WHILE (j < MaxName) AND (name[j] # CHR(0)) DO
IF arr[off + j] # name[j] THEN RETURN FALSE END;
INC(j)
END;
RETURN arr[off + j] = name[j]
END SpanEq;
PROCEDURE HashPut (VAR htab: ARRAY OF INTEGER; VAR names: ARRAY OF CHAR;
name: ARRAY OF CHAR; idx: CARDINAL);
(* Insert idx, replacing an existing entry with the same name so the
latest declaration wins (the linear scan used to search backward). *)
VAR h: CARDINAL;
BEGIN
h := HashStr(name);
LOOP
IF htab[h] = 0 THEN htab[h] := VAL(INTEGER, idx) + 1; RETURN END;
IF SpanEq(names, VAL(CARDINAL, htab[h] - 1) * 64, name) THEN
htab[h] := VAL(INTEGER, idx) + 1; RETURN
END;
h := (h + 1) MOD HashSize
END
END HashPut;
PROCEDURE HashGet (VAR htab: ARRAY OF INTEGER; VAR names: ARRAY OF CHAR;
name: ARRAY OF CHAR): INTEGER;
VAR h: CARDINAL;
BEGIN
h := HashStr(name);
LOOP
IF htab[h] = 0 THEN RETURN -1 END;
IF SpanEq(names, VAL(CARDINAL, htab[h] - 1) * 64, name) THEN
RETURN htab[h] - 1
END;
h := (h + 1) MOD HashSize
END
END HashGet;
PROCEDURE Reset;
VAR i: CARDINAL;
BEGIN
nSyms := 0; nProcs := 0;
scopeTop := 0; curScopeProc := -1; emitProc := -1;
i := 0;
WHILE i < HashSize DO symHash[i] := 0; procHash[i] := 0; INC(i) END
END Reset;
PROCEDURE NoteVar (name: ARRAY OF CHAR; kind: INTEGER; t: SymTab.TypeIndex);
BEGIN
IF nSyms >= MaxSym THEN RETURN END;
CopySpan(name, symName, 0, nSyms * 64);
symKind[nSyms] := kind; symTy[nSyms] := t;
symOwner[nSyms] := curScopeProc;
HashPut(symHash, symName, name, nSyms);
INC(nSyms)
END NoteVar;
PROCEDURE NoteConstVal (val: ARRAY OF CHAR);
(* Records the evaluated value of the CONST just entered by NoteVar.
Const values are per-unit and cross-module names collide (every
module has EOL), so they live here, not in SymTab. *)
BEGIN
IF nSyms > 0 THEN CopySpan(val, symVal, 0, (nSyms - 1) * 64) END
END NoteConstVal;
PROCEDURE ScopeEnter;
(* Called at a procedure heading, before NoteProc. Pushes the enclosing
procedure as the parent scope. *)
BEGIN
IF scopeTop <= HIGH(scopeStack) THEN
scopeStack[scopeTop] := curScopeProc;
INC(scopeTop)
END
END ScopeEnter;
PROCEDURE ScopeLeave;
BEGIN
IF curScopeProc >= 0 THEN procSymTop[curScopeProc] := nSyms END;
IF scopeTop > 0 THEN
DEC(scopeTop);
curScopeProc := scopeStack[scopeTop]
END
END ScopeLeave;
PROCEDURE ReenterScopeProc (ty: INTEGER);
(* Restores a previously noted proc entry as current for the re-parse
pass (its registration ran once in the skip pass): pushes the
current owner and resumes ty, so the Block-end ScopeLeave pops back
and nested NoteProc/NoteVar attach under the right parent. *)
BEGIN
IF (ty < 0) OR (ty >= VAL(INTEGER, nProcs)) THEN RETURN END;
IF scopeTop <= HIGH(scopeStack) THEN
scopeStack[scopeTop] := curScopeProc;
INC(scopeTop)
END;
curScopeProc := ty
END ReenterScopeProc;
PROCEDURE CurScopeProc (): INTEGER;
(* The proc entry NoteProc most recently made current (ty stamped on the
NkProcDecl); captured by the parser's span table for the re-parse. *)
BEGIN
RETURN curScopeProc
END CurScopeProc;
PROCEDURE NoteProc (name: ARRAY OF CHAR; uid: CARDINAL;
res: SymTab.TypeIndex; depth: CARDINAL; ext: BOOLEAN);
BEGIN
IF nProcs >= MaxProc THEN RETURN END;
CopySpan(name, procName, 0, nProcs * 64);
procUid[nProcs] := uid; procRes[nProcs] := res;
procDep[nProcs] := depth; procExt[nProcs] := ext;
procNpar[nProcs] := 0;
procParent[nProcs] := curScopeProc;
procSymBase[nProcs] := nSyms;
curScopeProc := VAL(INTEGER, nProcs);
HashPut(procHash, procName, name, nProcs);
INC(nProcs)
END NoteProc;
PROCEDURE AliasProc (name: ARRAY OF CHAR; uid: CARDINAL;
res: SymTab.TypeIndex; depth: CARDINAL; ext: BOOLEAN);
(* A generic procedure formal bound to an actual procedure: add a
proc-table entry so calls through the formal resolve to the actual,
without disturbing the scope stack (unlike NoteProc). *)
BEGIN
IF nProcs >= MaxProc THEN RETURN END;
CopySpan(name, procName, 0, nProcs * 64);
procUid[nProcs] := uid; procRes[nProcs] := res;
procDep[nProcs] := depth; procExt[nProcs] := ext;
procNpar[nProcs] := 0;
procParent[nProcs] := -1;
procSymBase[nProcs] := nSyms;
HashPut(procHash, procName, name, nProcs);
INC(nProcs)
END AliasProc;
PROCEDURE MarkProcExternal;
(* The grammar calls this from the EXTERNAL branch, after NoteProc, so
the walk records that the callee takes no static link. *)
BEGIN
IF nProcs > 0 THEN procExt[nProcs - 1] := TRUE END
END MarkProcExternal;
PROCEDURE NoteCProc (name: ARRAY OF CHAR);
(* FROM libc IMPORT P: a permissive C varargs external. NoteProc sets
curScopeProc; restore it so the next import is not seen as nested. *)
VAR save: INTEGER;
BEGIN
save := curScopeProc;
curScopeProc := -1;
NoteProc(name, 0, SymTab.InvalidType, 0, TRUE);
curScopeProc := save;
IF nProcs > 0 THEN
procExt[nProcs - 1] := TRUE;
procVa[nProcs - 1] := TRUE;
procNpar[nProcs - 1] := 0;
procParent[nProcs - 1] := -1
END
END NoteCProc;
PROCEDURE NoteProcNode (n: AST.Node);
(* Records the proc-table index in the NkProcDecl's ty field, so
LowerDecls can find the exact entry. FindProc(name) would return the
last duplicate (e.g. the two nested `Sep`s), giving the wrong uid and
the wrong scope for its locals. *)
BEGIN
IF nProcs > 0 THEN AST.SetTy(n, VAL(INTEGER, nProcs - 1)) END
END NoteProcNode;
PROCEDURE ProcInfoIdx (pi: INTEGER; VAR uid: CARDINAL;
VAR res: SymTab.TypeIndex; VAR depth: CARDINAL;
VAR ext: BOOLEAN; VAR npar: CARDINAL): BOOLEAN;
BEGIN
IF (pi < 0) OR (pi >= VAL(INTEGER, nProcs)) THEN RETURN FALSE END;
uid := procUid[pi]; res := procRes[pi]; depth := procDep[pi];
ext := procExt[pi]; npar := procNpar[pi];
IF npar > MaxPar THEN npar := MaxPar END;
RETURN TRUE
END ProcInfoIdx;
PROCEDURE ParamInfoIdx (pi: INTEGER; i: CARDINAL;
VAR t: SymTab.TypeIndex; VAR isVar: BOOLEAN;
VAR pn: ARRAY OF CHAR): BOOLEAN;
BEGIN
IF (pi < 0) OR (pi >= MaxProc)
OR (i >= procNpar[pi]) OR (procNpar[pi] > MaxPar) THEN
RETURN FALSE
END;
t := parTy[VAL(CARDINAL, pi) * MaxPar + i];
isVar := parVar[VAL(CARDINAL, pi) * MaxPar + i];
CopySpan(parName, pn, VAL(CARDINAL, pi) * MaxPar * 64 + i * 64, 0);
RETURN TRUE
END ParamInfoIdx;
PROCEDURE SetProcRes (t: SymTab.TypeIndex);
BEGIN
IF nProcs > 0 THEN procRes[nProcs - 1] := t END
END SetProcRes;
PROCEDURE NoteParam (name: ARRAY OF CHAR; t: SymTab.TypeIndex; isVar: BOOLEAN);
VAR j: CARDINAL;
BEGIN
IF nProcs = 0 THEN RETURN END;
j := procNpar[nProcs - 1];
IF j >= MaxPar THEN RETURN END;
CopySpan(name, parName, 0, (nProcs - 1) * MaxPar * 64 + j * 64);
parTy[(nProcs - 1) * MaxPar + j] := t;
parVar[(nProcs - 1) * MaxPar + j] := isVar;
procNpar[nProcs - 1] := j + 1
END NoteParam;
PROCEDURE NameEq (i: CARDINAL; name: ARRAY OF CHAR): BOOLEAN;
VAR j: CARDINAL;
BEGIN
j := 0;
WHILE (j < MaxName) AND (name[j] # CHR(0)) DO
IF symName[i * 64 + j] # name[j] THEN RETURN FALSE END;
INC(j)
END;
RETURN symName[i * 64 + j] = name[j]
END NameEq;
PROCEDURE FindSym (name: ARRAY OF CHAR; VAR kind: INTEGER;
VAR t: SymTab.TypeIndex): BOOLEAN;
(* Locals/params of the emitted procedure (and its enclosing procedures)
shadow module-level symbols, so walk the scope chain innermost-first
and only then fall back to the hash for a module-level symbol. *)
VAR i: INTEGER; owner: INTEGER;
BEGIN
owner := emitProc;
WHILE owner >= 0 DO
(* procSymTop is unset for headings that never ScopeLeave (class
method declarations); fall back to the whole table then. *)
IF procSymTop[owner] > 0 THEN
i := VAL(INTEGER, procSymTop[owner]) - 1
ELSE i := VAL(INTEGER, nSyms) - 1
END;
WHILE i >= VAL(INTEGER, procSymBase[owner]) DO
IF (symOwner[i] = owner) AND NameEq(VAL(CARDINAL, i), name) THEN
kind := symKind[i]; t := symTy[i]; RETURN TRUE
END;
DEC(i)
END;
owner := procParent[owner]
END;
i := HashGet(symHash, symName, name);
IF (i >= 0) AND (symOwner[i] = -1) THEN
kind := symKind[i]; t := symTy[i]; RETURN TRUE
END;
RETURN FALSE
END FindSym;
PROCEDURE GetConstVal (name: ARRAY OF CHAR; VAR v: ARRAY OF CHAR): BOOLEAN;
VAR i: INTEGER;
BEGIN
i := HashGet(symHash, symName, name);
IF (i >= 0) AND (symKind[i] = SymTab.KindConst) THEN
CopySpan(symVal, v, VAL(CARDINAL, i) * 64, 0);
IF v[0] # CHR(0) THEN RETURN TRUE END
END;
(* a literal propagated with its enum type lives only in SymTab *)
v[0] := CHR(0);
RETURN SymTab.GetSymVal(name, v)
END GetConstVal;
PROCEDURE SetConstVal (name: ARRAY OF CHAR; val: ARRAY OF CHAR);
(* Refresh a CONST's recorded value after Lower re-emits its aggregate
constructor (the grammar's value was suppressed under NoEmit). *)
VAR i: INTEGER;
BEGIN
i := HashGet(symHash, symName, name);
IF i >= 0 THEN CopySpan(val, symVal, 0, VAL(CARDINAL, i) * 64) END
END SetConstVal;
PROCEDURE ProcNameEq (i: CARDINAL; name: ARRAY OF CHAR): BOOLEAN;
VAR j: CARDINAL;
BEGIN
j := 0;
WHILE (j < MaxName) AND (name[j] # CHR(0)) DO
IF procName[i * 64 + j] # name[j] THEN RETURN FALSE END;
INC(j)
END;
RETURN procName[i * 64 + j] = name[j]
END ProcNameEq;
PROCEDURE ProcVisible (i: INTEGER): BOOLEAN;
(* TRUE when proc i is nested directly in the emitted procedure or one
of its enclosing procedures (or is module-level). *)
VAR owner: INTEGER;
BEGIN
owner := emitProc;
WHILE owner >= 0 DO
IF procParent[i] = owner THEN RETURN TRUE END;
owner := procParent[owner]
END;
RETURN procParent[i] = -1
END ProcVisible;
PROCEDURE ImpNameEq (i: CARDINAL; name: ARRAY OF CHAR): BOOLEAN;
BEGIN
RETURN SpanEq(impName, i * 64, name)
END ImpNameEq;
PROCEDURE FindProc (name: ARRAY OF CHAR): INTEGER;
(* Scope-aware: a nested procedure (e.g. one of two `Sep`s) must resolve
to the one in the emitted procedure's chain, not the last duplicate.
The current unit's imports win over any same-named proc. *)
VAR i: INTEGER; owner: INTEGER;
BEGIN
i := 0;
WHILE i < VAL(INTEGER, nImps) DO
IF ImpNameEq(VAL(CARDINAL, i), name) THEN RETURN impProc[i] END;
INC(i)
END;
i := HashGet(procHash, procName, name);
IF (i >= 0) AND ProcVisible(i) THEN RETURN i END;
owner := emitProc;
WHILE owner >= 0 DO
i := VAL(INTEGER, nProcs) - 1;
WHILE i > 0 DO
DEC(i);
IF (procParent[i] = owner) AND ProcNameEq(VAL(CARDINAL, i), name) THEN
RETURN i
END
END;
owner := procParent[owner]
END;
i := VAL(INTEGER, nProcs) - 1;
WHILE i > 0 DO
DEC(i);
IF (procParent[i] = -1) AND ProcNameEq(VAL(CARDINAL, i), name) THEN
RETURN i
END
END;
RETURN -1
END FindProc;
PROCEDURE FindProcByUid (uid: CARDINAL): INTEGER;
(* Exact proc entry for a module-qualified call (M.P): the base name may
be duplicated across modules, but the uid is unique. *)
VAR i: INTEGER;
BEGIN
i := VAL(INTEGER, nProcs);
WHILE i > 0 DO
DEC(i);
IF procUid[i] = uid THEN RETURN i END
END;
RETURN -1
END FindProcByUid;
PROCEDURE NoteImportedProc (name: ARRAY OF CHAR);
(* FROM M IMPORT P (a procedure): remember the exact proc entry so an
unqualified call resolves to the imported proc, not a same-named
proc declared in another module. Reset at each unit. *)
VAR pi: INTEGER;
BEGIN
IF SymTab.SymKind(name) # SymTab.KindProc THEN RETURN END;
pi := FindProcByUid(SymTab.ProcUid(name));
IF pi < 0 THEN RETURN END;
IF nImps >= MaxImp THEN RETURN END;
impProc[nImps] := pi;
CopySpan(name, impName, 0, nImps * 64);
INC(nImps)
END NoteImportedProc;
PROCEDURE Resolve (nm: ARRAY OF CHAR; VAR k: INTEGER;
VAR t: SymTab.TypeIndex): BOOLEAN;
VAR kind: INTEGER; ti: SymTab.TypeIndex;
BEGIN
IF FindSym(nm, kind, ti) THEN k := kind; t := ti; RETURN TRUE END;
IF SymTab.Lookup(nm) THEN k := SymTab.SymKind(nm); t := SymTab.SymType(nm);
RETURN TRUE
END;
(* A bare procedure used as a value: it lives in the proc table.
Sibling method names must fall through so LowerDesign can bind
THIS, so exclude methods of the open class implementation. *)
IF FindProc(nm) >= 0 THEN
IF (curImplCls = SymTab.InvalidType)
OR NOT SymTab.MethodExists(curImplCls, nm) THEN
k := SymTab.KindProc; t := SymTab.InvalidType; RETURN TRUE
END
END;
RETURN FALSE
END Resolve;
PROCEDURE ProcInfo (nm: ARRAY OF CHAR; VAR uid: CARDINAL;
VAR res: SymTab.TypeIndex; VAR depth: CARDINAL;
VAR ext: BOOLEAN; VAR npar: CARDINAL): BOOLEAN;
VAR i: INTEGER;
BEGIN
i := FindProc(nm);
IF (i < 0) OR (i >= MaxProc) THEN RETURN FALSE END;
uid := procUid[i]; res := procRes[i]; depth := procDep[i];
ext := procExt[i]; npar := procNpar[i];
IF npar > MaxPar THEN npar := MaxPar END;
RETURN TRUE
END ProcInfo;
PROCEDURE ParamInfo (nm: ARRAY OF CHAR; i: CARDINAL;
VAR t: SymTab.TypeIndex; VAR isVar: BOOLEAN;
VAR pn: ARRAY OF CHAR): BOOLEAN;
VAR k: INTEGER;
BEGIN
k := FindProc(nm);
IF (k < 0) OR (k >= MaxProc) THEN RETURN FALSE END;
IF (i >= procNpar[k]) OR (procNpar[k] > MaxPar) THEN RETURN FALSE END;
t := parTy[VAL(CARDINAL, k) * MaxPar + i];
isVar := parVar[VAL(CARDINAL, k) * MaxPar + i];
CopySpan(parName, pn, VAL(CARDINAL, k) * MaxPar * 64 + i * 64, 0);
RETURN TRUE
END ParamInfo;
PROCEDURE WithField (nm: ARRAY OF CHAR; VAR k: INTEGER;
VAR t: SymTab.TypeIndex; VAR q: QbeGen.QVal): BOOLEAN;
(* Resolves a bare ident as a field of an open WITH record (innermost
first), leaving the field address in q and k=KindField. *)
VAR wt: CARDINAL; fo: INTEGER; qb: QbeGen.QVal;
BEGIN
wt := withTop;
WHILE wt > 0 DO
DEC(wt);
IF SymTab.FieldExists(withRec[wt], nm) THEN
t := SymTab.FieldType(withRec[wt], nm);
fo := SymTab.FieldOffset(withRec[wt], nm);
k := SymTab.KindField;
IF QbeGen.TopWith(qb) THEN QbeGen.FieldAddr(qb, fo, q)
ELSE QbeGen.CopyOp("0", q)
END;
RETURN TRUE
END
END;
RETURN FALSE
END WithField;
PROCEDURE Name (n: AST.Node; VAR s: ARRAY OF CHAR);
BEGIN
IF n = AST.NoNode THEN s[0] := CHR(0)
ELSE AST.Txt(AST.Child(n, 0), s)
END
END Name;
(* ---------------- compile-time set constants ----------------
A SET CONST's value must be static data. Set literals are emitted as
runtime temporaries, so the grammar computes the bit mask here (where
the element expressions are already validated) and Lower re-emits it
as a pooled descriptor (`QbeGen.PoolSet`). Only masks up to MaxCFoldW
words (512 bits) are folded; a wider SET CONST stays a clear 230. *)
PROCEDURE Pow2 (b: INTEGER): CARDINAL;
VAR p: CARDINAL; k: INTEGER;
BEGIN
p := 1; k := 0;
WHILE k < b DO p := p * 2; INC(k) END;
RETURN p
END Pow2;
PROCEDURE MaskZero (VAR mask: ARRAY OF CARDINAL; words: CARDINAL);
VAR i: CARDINAL;
BEGIN
i := 0;
WHILE (i < words) AND (i <= HIGH(mask)) DO mask[i] := 0; INC(i) END
END MaskZero;
PROCEDURE MaskSetBit (VAR mask: ARRAY OF CARDINAL; bit: INTEGER);
VAR w, b: INTEGER; p: CARDINAL; idx: CARDINAL;
BEGIN
IF (bit < 0) OR (bit >= VAL(INTEGER, MaxCFoldW) * 32) THEN RETURN END;
w := bit DIV 32; b := bit MOD 32;
IF w > VAL(INTEGER, HIGH(mask)) THEN RETURN END;
idx := VAL(CARDINAL, w); p := Pow2(b);
IF (mask[idx] DIV p) MOD 2 = 0 THEN mask[idx] := mask[idx] + p END
END MaskSetBit;
PROCEDURE MaskGetBit (VAR mask: ARRAY OF CARDINAL; bit: INTEGER): INTEGER;
VAR w, b: INTEGER; p: CARDINAL;
BEGIN
IF (bit < 0) OR (bit >= VAL(INTEGER, MaxCFoldW) * 32) THEN RETURN 0 END;
w := bit DIV 32; b := bit MOD 32;
IF w > VAL(INTEGER, HIGH(mask)) THEN RETURN 0 END;
p := Pow2(b);
IF (mask[VAL(CARDINAL, w)] DIV p) MOD 2 = 1 THEN RETURN 1 END;
RETURN 0
END MaskGetBit;
PROCEDURE EvalOrdConst (n: AST.Node; VAR v: INTEGER): BOOLEAN;
(* The integer value of a compile-time ordinal expression, matching the
grammar's folding (literals, named CONSTs, unary +/-, + - * DIV MOD). *)
VAR k: INTEGER; s, cv: QbeGen.QVal; nm: SymTab.Name;
a, b: INTEGER; isCh: BOOLEAN;
BEGIN
IF n = AST.NoNode THEN RETURN FALSE END;
k := AST.Kind(n);
IF k = AST.NkIntLit THEN
Name(n, s); QbeGen.NormInt(s, cv); RETURN SymTab.ConstInt(cv, v)
ELSIF k = AST.NkCharLit THEN
Name(n, s);
IF (s[0] = "'") OR (s[0] = '"') THEN
v := QbeGen.CharVal(s); RETURN TRUE
END;
QbeGen.NormLit(s, cv, isCh); RETURN SymTab.ConstInt(cv, v)
ELSIF k = AST.NkStrLit THEN
(* a 1-character string literal "c" is a CHAR constant *)
Name(n, s);
IF SymTab.StrLen(s) = 3 THEN v := QbeGen.CharVal(s); RETURN TRUE END;
RETURN FALSE
ELSIF k = AST.NkDesignator THEN
IF (AST.NChild(n) # 1) OR (AST.Kind(AST.Child(n, 0)) # AST.NkIdent) THEN
RETURN FALSE END;
Name(AST.Child(n, 0), nm);
IF SymTab.Equal(nm, "TRUE") THEN v := 1; RETURN TRUE END;
IF SymTab.Equal(nm, "FALSE") THEN v := 0; RETURN TRUE END;
IF SymTab.Lookup(nm) AND (SymTab.SymKind(nm) = SymTab.KindConst)
AND SymTab.GetSymVal(nm, cv) AND QbeGen.IsImm(cv) THEN
RETURN SymTab.ConstInt(cv, v)
END;
RETURN FALSE
ELSIF k = AST.NkUnary THEN
IF AST.Op(n) = AST.OpSub THEN
IF EvalOrdConst(AST.Child(n, 0), v) THEN v := -v; RETURN TRUE END
ELSIF AST.Op(n) = AST.OpAdd THEN
RETURN EvalOrdConst(AST.Child(n, 0), v)
END;
RETURN FALSE
ELSIF k = AST.NkBinExpr THEN
IF EvalOrdConst(AST.Child(n, 0), a)
AND EvalOrdConst(AST.Child(n, 1), b) THEN
IF AST.Op(n) = AST.OpAdd THEN v := a + b
ELSIF AST.Op(n) = AST.OpSub THEN v := a - b
ELSIF AST.Op(n) = AST.OpMul THEN v := a * b
ELSIF AST.Op(n) = AST.OpDiv THEN
IF b = 0 THEN RETURN FALSE END; v := a DIV b
ELSIF AST.Op(n) = AST.OpMod THEN
IF b = 0 THEN RETURN FALSE END; v := a MOD b
ELSE RETURN FALSE
END;
RETURN TRUE
END;
RETURN FALSE
END;
RETURN FALSE
END EvalOrdConst;
PROCEDURE EvalSetElem (el: AST.Node; VAR mask: ARRAY OF CARDINAL;
lo: INTEGER; span: CARDINAL): BOOLEAN;
VAR a, b: INTEGER;
BEGIN
IF AST.Kind(el) = AST.NkSubrange THEN
IF NOT EvalOrdConst(AST.Child(el, 0), a)
OR NOT EvalOrdConst(AST.Child(el, 1), b) THEN RETURN FALSE END;
IF (a < lo) OR (b < lo) OR (a > b)
OR (b >= lo + VAL(INTEGER, span)) THEN RETURN FALSE END;
WHILE a <= b DO MaskSetBit(mask, a - lo); INC(a) END;
RETURN TRUE
END;
IF NOT EvalOrdConst(el, a) THEN RETURN FALSE END;
IF (a < lo) OR (a >= lo + VAL(INTEGER, span)) THEN RETURN FALSE END;
MaskSetBit(mask, a - lo);
RETURN TRUE
END EvalSetElem;
PROCEDURE NoteSetMask (name: ARRAY OF CHAR; mask: ARRAY OF CARDINAL;
words: CARDINAL; lo: INTEGER);
VAR i: CARDINAL;
BEGIN
IF cfoldN >= MaxCFold THEN RETURN END;
CopySpan(name, cfoldName, 0, cfoldN * 64);
cfoldW[cfoldN] := words; cfoldLo[cfoldN] := lo;
i := 0;
WHILE i < MaxCFoldW DO
IF (i < words) AND (i <= HIGH(mask)) THEN
cfoldMask[cfoldN * MaxCFoldW + i] := mask[i]
ELSE cfoldMask[cfoldN * MaxCFoldW + i] := 0
END;
INC(i)
END;
INC(cfoldN)
END NoteSetMask;
PROCEDURE LookupSetMask (name: ARRAY OF CHAR; VAR mask: ARRAY OF CARDINAL;
VAR words: CARDINAL; VAR lo: INTEGER): BOOLEAN;
VAR i: INTEGER; k: CARDINAL;
BEGIN
i := VAL(INTEGER, cfoldN) - 1;
WHILE i >= 0 DO
IF SpanEq(cfoldName, VAL(CARDINAL, i) * 64, name) THEN
words := cfoldW[i]; lo := cfoldLo[i];
k := 0;
WHILE (k < words) AND (k <= HIGH(mask)) DO
mask[k] := cfoldMask[VAL(CARDINAL, i) * MaxCFoldW + k]; INC(k)
END;
RETURN TRUE
END;
DEC(i)
END;
RETURN FALSE
END LookupSetMask;
PROCEDURE EvalSetConst (n: AST.Node; VAR mask: ARRAY OF CARDINAL;
VAR words: CARDINAL; VAR lo: INTEGER): BOOLEAN;
VAR k, i, a, b, r: INTEGER;
t: SymTab.TypeIndex;
span: CARDINAL;
seq, el, next: AST.Node;
m1, m2: ARRAY [0 .. MaxCFoldW - 1] OF CARDINAL;
w1, w2: CARDINAL;
l1, l2: INTEGER;
op: INTEGER;
nm: SymTab.Name;
BEGIN
IF n = AST.NoNode THEN RETURN FALSE END;
k := AST.Kind(n);
IF (k = AST.NkSetLit) OR (k = AST.NkBraceLit) THEN
t := AST.Ty(n);
IF (k = AST.NkBraceLit) AND (SymTab.ClassOf(t) # SymTab.ClSet) THEN
RETURN FALSE
END;
IF t = SymTab.InvalidType THEN
lo := 0; words := 8; span := 256
ELSE
lo := SymTab.SetBaseLo(t); words := SymTab.SetWords(t);
span := SymTab.SetCount(t);
IF words = 0 THEN words := 8; span := 256; lo := 0 END
END;
IF words > MaxCFoldW THEN RETURN FALSE END;
MaskZero(mask, words);
IF k = AST.NkSetLit THEN
i := 0;
WHILE i < VAL(INTEGER, AST.NChild(n)) DO
el := AST.Child(n, VAL(CARDINAL, i));
IF NOT EvalSetElem(el, mask, lo, span) THEN RETURN FALSE END;
INC(i)
END
ELSE
seq := n;
WHILE seq # AST.NoNode DO
i := 0;
WHILE i < VAL(INTEGER, AST.NChild(seq)) DO
el := AST.Child(seq, VAL(CARDINAL, i));
IF AST.Kind(el) # AST.NkBlock THEN
IF NOT EvalSetElem(el, mask, lo, span) THEN RETURN FALSE END
END;
INC(i)
END;
next := AST.NoNode;
IF AST.NChild(seq) > 0 THEN
next := AST.Child(seq, AST.NChild(seq) - 1);
IF AST.Kind(next) # AST.NkBlock THEN next := AST.NoNode END
END;
seq := next
END
END;
RETURN TRUE
ELSIF k = AST.NkDesignator THEN
IF (AST.NChild(n) # 1) OR (AST.Kind(AST.Child(n, 0)) # AST.NkIdent) THEN
RETURN FALSE END;
Name(AST.Child(n, 0), nm);
RETURN LookupSetMask(nm, mask, words, lo)
ELSIF k = AST.NkBinExpr THEN
op := AST.Op(n);
IF (op # AST.OpAdd) AND (op # AST.OpSub)
AND (op # AST.OpMul) AND (op # AST.OpDiv) THEN
RETURN FALSE END;
IF NOT EvalSetConst(AST.Child(n, 0), m1, w1, l1)
OR NOT EvalSetConst(AST.Child(n, 1), m2, w2, l2) THEN
RETURN FALSE END;
IF l1 # l2 THEN RETURN FALSE END;
lo := l1;
words := w1; IF w2 > words THEN words := w2 END;
IF words > MaxCFoldW THEN RETURN FALSE END;
MaskZero(mask, words);
i := 0;
WHILE i < VAL(INTEGER, words) * 32 DO
a := MaskGetBit(m1, i); b := MaskGetBit(m2, i);
IF op = AST.OpAdd THEN r := a; IF b = 1 THEN r := 1 END
ELSIF op = AST.OpMul THEN
IF (a = 1) AND (b = 1) THEN r := 1 ELSE r := 0 END
ELSIF op = AST.OpSub THEN r := a; IF b = 1 THEN r := 0 END
ELSE r := (a + b) MOD 2
END;
IF r # 0 THEN MaskSetBit(mask, i) END;
INC(i)
END;
RETURN TRUE
END;
RETURN FALSE
END EvalSetConst;
PROCEDURE SetConstMaskOf (n: AST.Node; VAR mask: ARRAY OF CARDINAL;
VAR words: CARDINAL; VAR lo: INTEGER): BOOLEAN;
BEGIN
words := 0; lo := 0;
RETURN EvalSetConst(n, mask, words, lo)
END SetConstMaskOf;
PROCEDURE ParamName (proc: ARRAY OF CHAR; i: CARDINAL;
VAR s: ARRAY OF CHAR);
VAR t: SymTab.TypeIndex; isV: BOOLEAN;
BEGIN
IF NOT ParamInfo(proc, i, t, isV, s) THEN s[0] := CHR(0) END
END ParamName;
PROCEDURE IsArith (op: INTEGER): BOOLEAN;
BEGIN
RETURN (op = AST.OpAdd) OR (op = AST.OpSub) OR (op = AST.OpMul)
OR (op = AST.OpDiv) OR (op = AST.OpMod)
END IsArith;
PROCEDURE IsRel (op: INTEGER): BOOLEAN;
BEGIN
RETURN ((op >= AST.OpEq) AND (op <= AST.OpGe)) OR (op = AST.OpIn)
END IsRel;
PROCEDURE RelSym (a: INTEGER; VAR s: INTEGER): BOOLEAN;
BEGIN
IF a = AST.OpEq THEN s := SymTab.OpEq
ELSIF a = AST.OpNe THEN s := SymTab.OpNeq1
ELSIF a = AST.OpLt THEN s := SymTab.OpLt
ELSIF a = AST.OpLe THEN s := SymTab.OpLe
ELSIF a = AST.OpGt THEN s := SymTab.OpGt
ELSIF a = AST.OpGe THEN s := SymTab.OpGe
ELSE RETURN FALSE
END;
RETURN TRUE
END RelSym;
PROCEDURE IsScalarClass (cls: INTEGER): BOOLEAN;
BEGIN
RETURN (cls = SymTab.ClInt) OR (cls = SymTab.ClBool)
OR (cls = SymTab.ClChar) OR (cls = SymTab.ClUChar)
OR (cls = SymTab.ClEnum)
END IsScalarClass;
PROCEDURE IsSimpleScalar (n: AST.Node): BOOLEAN;
VAR nm: SymTab.Name; k: INTEGER; t: SymTab.TypeIndex;
BEGIN
IF (AST.Kind(n) # AST.NkDesignator) OR (AST.NChild(n) # 1) THEN
RETURN FALSE END;
IF AST.Kind(AST.Child(n, 0)) # AST.NkIdent THEN RETURN FALSE END;
Name(AST.Child(n, 0), nm);
IF NOT Resolve(nm, k, t) THEN RETURN FALSE END;
IF (k # SymTab.KindVar) AND (k # SymTab.KindParam)
AND (k # SymTab.KindConst) THEN
RETURN FALSE END;
IF SymTab.Equal(nm, "TRUE") OR SymTab.Equal(nm, "FALSE") THEN
RETURN TRUE END;
RETURN IsScalarClass(SymTab.ClassOf(t))
END IsSimpleScalar;
PROCEDURE CalleeName (call: AST.Node; VAR nm: SymTab.Name);
(* The callee of NkCall: child 0 is a designator (or bare ident). *)
VAR d: AST.Node;
BEGIN
nm[0] := CHR(0);
d := AST.Child(call, 0);
IF d = AST.NoNode THEN RETURN END;
IF AST.Kind(d) = AST.NkDesignator THEN d := AST.Child(d, 0) END;
IF (d # AST.NoNode) AND (AST.Kind(d) = AST.NkIdent) THEN Name(d, nm) END
END CalleeName;
PROCEDURE CallResultType (call: AST.Node; VAR t: SymTab.TypeIndex): BOOLEAN;
(* The result type of a call used as a designator base (F().M()). *)
VAR nm: SymTab.Name; uid, depth, np: CARDINAL; res: SymTab.TypeIndex;
ext: BOOLEAN; pi: INTEGER;
BEGIN
t := SymTab.InvalidType;
CalleeName(call, nm);
pi := FindProc(nm);
IF pi >= 0 THEN
IF ProcInfoIdx(pi, uid, res, depth, ext, np) THEN t := res; RETURN TRUE END;
RETURN FALSE
END;
IF SymTab.Lookup(nm) AND (SymTab.SymKind(nm) = SymTab.KindProc) THEN
t := SymTab.ProcRes(nm); RETURN TRUE
END;
RETURN FALSE
END CallResultType;
PROCEDURE IsMethodCall (n: AST.Node): BOOLEAN;
(* n is a call whose callee resolves to a class method: `obj.Method`,
`p^.Method`, or a bare sibling name inside an implementation. *)
VAR d, sel: AST.Node; nm, fn: SymTab.Name; k: INTEGER; t: SymTab.TypeIndex;
i: CARDINAL;
BEGIN
IF (AST.Kind(n) # AST.NkCall) OR (AST.NChild(n) < 1) THEN RETURN FALSE END;
d := AST.Child(n, 0);
IF AST.Kind(d) # AST.NkDesignator THEN RETURN FALSE END;
IF AST.NChild(d) = 1 THEN
(* bare name: a sibling method inside a class implementation? *)
Name(AST.Child(d, 0), nm);
RETURN (curImplCls # SymTab.InvalidType)
AND SymTab.MethodExists(curImplCls, nm)
END;
IF AST.Kind(AST.Child(d, 0)) = AST.NkCall THEN
(* F().M(): the base is a call; take its result type *)
IF NOT CallResultType(AST.Child(d, 0), t) THEN RETURN FALSE END
ELSE
Name(AST.Child(d, 0), nm);
IF NOT Resolve(nm, k, t) THEN RETURN FALSE END
END;
i := 1;
WHILE i < AST.NChild(d) DO
sel := AST.Child(d, i);
IF AST.Op(sel) = AST.SelField THEN
Name(AST.Child(sel, 0), fn);
IF (t # SymTab.InvalidType) AND (SymTab.ClassOf(t) = SymTab.ClClass)
AND SymTab.MethodExists(t, fn) THEN
RETURN i = AST.NChild(d) - 1
END;
IF (t = SymTab.InvalidType) OR NOT SymTab.FieldExists(t, fn) THEN
RETURN FALSE
END;
t := SymTab.FieldType(t, fn)
ELSIF AST.Op(sel) = AST.SelIndex THEN
IF (t = SymTab.InvalidType) OR (SymTab.ClassOf(t) # SymTab.ClArray) THEN
RETURN FALSE
END;
t := SymTab.ArrayElem(t)
ELSIF AST.Op(sel) = AST.SelDeref THEN
IF (t = SymTab.InvalidType) OR (SymTab.ClassOf(t) # SymTab.ClPtr) THEN
RETURN FALSE
END;
t := SymTab.PtrBase(t)
ELSE RETURN FALSE
END;
INC(i)
END;
RETURN FALSE
END IsMethodCall;
PROCEDURE CalleeAlias (call: AST.Node; VAR mal: SymTab.Name): BOOLEAN;
(* Callee is `M.P` (module-qualified): materialize the export alias. *)
VAR d, sel: AST.Node; nm, fn, al: SymTab.Name; k: INTEGER;
t: SymTab.TypeIndex;
BEGIN
d := AST.Child(call, 0);
IF (AST.Kind(d) # AST.NkDesignator) OR (AST.NChild(d) # 2) THEN
RETURN FALSE
END;
sel := AST.Child(d, 1);
IF AST.Op(sel) # AST.SelField THEN RETURN FALSE END;
Name(AST.Child(d, 0), nm);
IF NOT Resolve(nm, k, t) THEN RETURN FALSE END;
IF k # SymTab.KindModule THEN RETURN FALSE END;
Name(AST.Child(sel, 0), fn);
IF NOT SymTab.MaterializeAlias(nm, fn, al) THEN RETURN FALSE END;
(* Lower's proc table is keyed by the base name (the mangled symbol
is _), so return fn, not the materialized alias. The
uid comes from the alias, which is module-exact. *)
qualIsVar := SymTab.SymKind(al) # SymTab.KindProc;
qualUid := SymTab.ProcUid(al);
CopyN(fn, mal);
RETURN TRUE
END CalleeAlias;
PROCEDURE FinalLoad (t: SymTab.TypeIndex; sfx: BOOLEAN; VAR q: QbeGen.QVal);
(* Fact's final load after a designator/result suffix: scalars/pointers
are loaded from their address; aggregates keep the address. *)
VAR cls: INTEGER; q2: QbeGen.QVal;
BEGIN
IF NOT sfx THEN RETURN END;
IF t = SymTab.InvalidType THEN QbeGen.CopyOp("0", q); RETURN END;
cls := SymTab.ClassOf(t);
IF (cls # SymTab.ClRecord) AND (cls # SymTab.ClSet)
AND (cls # SymTab.ClArray) AND (cls # SymTab.ClClass) THEN
QbeGen.ElemLoad(q, t, q2); QbeGen.CopyOp(q2, q)
END
END FinalLoad;
PROCEDURE LowerDesign (n: AST.Node; VAR t: SymTab.TypeIndex; VAR k: INTEGER;
VAR q: QbeGen.QVal; VAR qn: SymTab.Name;
VAR sfx: BOOLEAN);
(* Base ident then selectors (mirrors the grammar's Design). Leaves the
address in q with sfx=TRUE for selectors; base vars/consts load. *)
VAR nm, fn, mal: SymTab.Name; cv: QbeGen.QVal; cls, op: INTEGER;
i: CARDINAL; sel: AST.Node; eT, it: SymTab.TypeIndex;
iq, ql, qlo, qhi, qe: QbeGen.QVal;
lo, hi, fo: INTEGER; isOpen: BOOLEAN;
BEGIN
IF AST.Kind(AST.Child(n, 0)) = AST.NkCall THEN
(* a call result used as a designator base: P()^, P()^.field,
A()[i]. The call yields a value (a pointer/record address);
sfx=FALSE so a following ^ does not reload it. *)
LowerExpr(AST.Child(n, 0), t, q);
k := -1; qn[0] := CHR(0); sfx := FALSE
ELSE
Name(AST.Child(n, 0), nm);
QbeGen.CopyOp(nm, qn);
sfx := FALSE;
IF NOT Resolve(nm, k, t) THEN
IF WithField(nm, k, t, q) THEN
sfx := TRUE
ELSIF (curImplCls # SymTab.InvalidType)
AND SymTab.MethodExists(curImplCls, nm) THEN
(* bare sibling method name inside a class implementation *)
QbeGen.ThisBase(q);
QbeGen.ArmRecv(q);
curMethCls := curImplCls; k := SymTab.KindProc;
t := SymTab.InvalidType; sfx := FALSE
ELSE
t := SymTab.InvalidType; k := -1; QbeGen.CopyOp("0", q); RETURN
END
END;
IF k = SymTab.KindConst THEN
IF SymTab.Equal(nm, "TRUE") THEN
t := SymTab.BoolType(); QbeGen.CopyOp("1", q)
ELSIF SymTab.Equal(nm, "FALSE") THEN
t := SymTab.BoolType(); QbeGen.CopyOp("0", q)
ELSIF SymTab.Equal(nm, "NIL") THEN
QbeGen.CopyOp("0", q)
ELSE
cls := SymTab.ClassOf(t);
IF (cls = SymTab.ClArray) OR (cls = SymTab.ClRecord)
OR (cls = SymTab.ClClass) OR (cls = SymTab.ClStr)
OR (cls = SymTab.ClUStr) OR (cls = SymTab.ClSet) THEN
(* aggregate/string const: its value IS the descriptor address *)
IF GetConstVal(nm, cv) THEN QbeGen.CopyOp(cv, q)
ELSE QbeGen.CopyOp("0", q)
END
ELSIF (cls = SymTab.ClInt) OR (cls = SymTab.ClChar)
OR (cls = SymTab.ClEnum) OR (cls = SymTab.ClLong)
OR (cls = SymTab.ClBool) THEN
IF GetConstVal(nm, cv) AND QbeGen.IsImm(cv) THEN
QbeGen.CopyOp(cv, q)
ELSE QbeGen.CopyOp("0", q)
END
ELSIF cls = SymTab.ClReal THEN
(* a real CONST lives in its data symbol; load it *)
QbeGen.LoadVar(nm, TRUE, q)
ELSE QbeGen.CopyOp("0", q)
END
END
ELSIF (k = SymTab.KindVar) OR (k = SymTab.KindParam) THEN
cls := SymTab.ClassOf(t);
IF AST.Op(n) = 1 THEN
(* a forward module-level reference: the grammar's FwdAddrOper
leaves an address (sfx=TRUE), not a loaded value *)
QbeGen.AddrOf(nm, q); sfx := TRUE
ELSIF (cls = SymTab.ClInt) OR (cls = SymTab.ClBool)
OR (cls = SymTab.ClChar) OR (cls = SymTab.ClUChar)
OR (cls = SymTab.ClEnum) OR (cls = SymTab.ClReal) THEN
QbeGen.LoadVar(nm, cls = SymTab.ClReal, q)
ELSIF (cls = SymTab.ClPtr) OR (cls = SymTab.ClProc) THEN
QbeGen.LoadPtr(nm, q)
ELSIF cls = SymTab.ClLong THEN
QbeGen.LoadLong(nm, q)
ELSE QbeGen.AddrOf(nm, q)
END
ELSIF k = SymTab.KindField THEN
(* q already holds the field address (WithField) *)
ELSE QbeGen.CopyOp("0", q)
END;
END;
i := 1;
WHILE i < AST.NChild(n) DO
sel := AST.Child(n, i);
op := AST.Op(sel);
IF op = AST.SelField THEN
Name(AST.Child(sel, 0), fn);
IF k = SymTab.KindModule THEN
(* qualified L.x: materialize the export, then load it *)
IF SymTab.MaterializeAlias(nm, fn, mal) THEN
QbeGen.CopyOp(mal, qn);
t := SymTab.SymType(mal); k := SymTab.SymKind(mal); sfx := FALSE;
IF k = SymTab.KindProc THEN QbeGen.CopyOp("0", q)
ELSIF NOT QbeGen.LoadDesignator(mal, t, k, q) THEN
t := SymTab.InvalidType; QbeGen.CopyOp("0", q)
END
ELSE t := SymTab.InvalidType; QbeGen.CopyOp("0", q)
END
ELSIF t = SymTab.InvalidType THEN
ELSIF (SymTab.ClassOf(t) = SymTab.ClClass)
AND SymTab.MethodExists(t, fn) THEN
(* obj.Method: bind the receiver; the call supplies the value *)
QbeGen.ArmRecv(q);
QbeGen.CopyOp(fn, qn);
curMethCls := t; k := SymTab.KindProc; t := SymTab.InvalidType
ELSIF NOT SymTab.FieldExists(t, fn) THEN t := SymTab.InvalidType
ELSE
fo := SymTab.FieldOffset(t, fn);
t := SymTab.FieldType(t, fn);
QbeGen.FieldAddr(q, fo, qe);
QbeGen.CopyOp(qe, q);
sfx := TRUE
END
ELSIF op = AST.SelIndex THEN
LowerExpr(AST.Child(sel, 0), it, iq);
IF t = SymTab.InvalidType THEN
ELSE
QbeGen.WidenIndex(iq, ql);
isOpen := SymTab.IsOpenArray(t);
IF isOpen THEN
QbeGen.CopyOp("0", qlo);
IF SymTab.IsCharArray(t) OR SymTab.IsUCharArray(t) THEN
QbeGen.OpenHiChar(q, qhi)
ELSE QbeGen.OpenHi(q, qhi)
END
ELSE
lo := SymTab.ArrayLo(t); hi := SymTab.ArrayHi(t);
IF SymTab.IsCharArray(t) OR SymTab.IsUCharArray(t) THEN
hi := hi + 1
END;
QbeGen.IntStr(lo, qlo); QbeGen.IntStr(hi, qhi)
END;
QbeGen.CheckRange(ql, qlo, qhi);
eT := SymTab.ArrayElem(t);
QbeGen.ElemAddr(q, ql, qlo, t, qe);
IF SymTab.ClassOf(eT) = SymTab.ClArray THEN
QbeGen.ElemLoad(qe, eT, q)
ELSE QbeGen.CopyOp(qe, q)
END;
t := eT; sfx := TRUE
END
ELSIF op = AST.SelDeref THEN
IF t = SymTab.InvalidType THEN
ELSIF SymTab.ClassOf(t) # SymTab.ClPtr THEN t := SymTab.InvalidType
ELSE
IF sfx THEN QbeGen.ElemLoad(q, t, qe); QbeGen.CopyOp(qe, q) END;
t := SymTab.PtrBase(t); sfx := TRUE
END
END;
INC(i)
END
END LowerDesign;
PROCEDURE CompositeRes (t: SymTab.TypeIndex): BOOLEAN;
(* TRUE for a composite (by-value) function result: record/array/set.
Such results use a hidden destination pointer (sret). *)
VAR cls: INTEGER;
BEGIN
IF t = SymTab.InvalidType THEN RETURN FALSE END;
cls := SymTab.ClassOf(t);
RETURN (cls = SymTab.ClRecord) OR (cls = SymTab.ClArray)
OR (cls = SymTab.ClSet) OR (cls = SymTab.ClClass)
END CompositeRes;
PROCEDURE UserLabel (name: ARRAY OF CHAR; VAR q: QbeGen.QVal);
(* The QbeGen label for a user label/goto name (per procedure). *)
VAR i: CARDINAL;
BEGIN
i := 0;
WHILE i < nUserLab DO
IF SpanEq(userLabNm, i * 64, name) THEN q := userLabQ[i]; RETURN END;
INC(i)
END;
QbeGen.NewLabel(q);
IF nUserLab <= HIGH(userLabQ) THEN
CopySpan(name, userLabNm, 0, nUserLab * 64);
userLabQ[nUserLab] := q;
INC(nUserLab)
END
END UserLabel;
PROCEDURE LowerCall (n: AST.Node; VAR t: SymTab.TypeIndex;
VAR q: QbeGen.QVal; want: BOOLEAN);
VAR nm, pn, cqn: SymTab.Name; i, ai: CARDINAL; at, ft, res: SymTab.TypeIndex;
qa, qt, qe, mg, qres: QbeGen.QVal; conv, isV, qual, ind, isC, va: BOOLEAN;
uid, depth, np: CARDINAL; ext: BOOLEAN; ck: INTEGER; pi: INTEGER;
ct: SymTab.TypeIndex; csfx: BOOLEAN; cl: CHAR;
seq, next, arg: AST.Node;
BEGIN
qual := CalleeAlias(n, nm);
ind := FALSE; isC := FALSE; va := FALSE; pi := -1; ext := FALSE;
IF qual AND qualIsVar THEN
(* M.Error where Error is a procedure-typed variable: indirect. *)
LowerDesign(AST.Child(n, 0), ct, ck, qa, cqn, csfx);
IF (ct # SymTab.InvalidType)
AND (SymTab.ClassOf(ct) = SymTab.ClProc) THEN
ind := TRUE;
res := SymTab.ProcTypeRes(ct);
np := SymTab.ProcTypeNPar(ct);
QbeGen.CallBeginInd(qa, res, FALSE)
ELSE
res := SymTab.InvalidType;
QbeGen.CallBegin(nm, res, 0, FALSE)
END
ELSIF qual THEN
(* M.P: the base name may be duplicated across modules, so select
the exact proc entry by the alias's uid. *)
pi := FindProcByUid(qualUid);
IF ProcInfoIdx(pi, uid, res, depth, ext, np) THEN
IF ext THEN QbeGen.CopyOp(nm, mg) ELSE QbeGen.Mangled(nm, uid, mg) END;
QbeGen.CallBegin(mg, res, depth, ext)
ELSE
res := SymTab.InvalidType;
QbeGen.CallBegin(nm, res, 0, FALSE)
END
ELSE
CalleeName(n, nm);
IF FindSym(nm, ck, ct)
AND ((ck = SymTab.KindVar) OR (ck = SymTab.KindParam))
AND (SymTab.ClassOf(ct) = SymTab.ClProc) THEN
(* indirect call through a procedure-typed variable *)
ind := TRUE;
LowerDesign(AST.Child(n, 0), ct, ck, qa, cqn, csfx);
res := SymTab.ProcTypeRes(ct);
np := SymTab.ProcTypeNPar(ct);
QbeGen.CallBeginInd(qa, res, FALSE)
ELSIF ProcInfo(nm, uid, res, depth, ext, np) THEN
pi := FindProc(nm);
IF ext THEN
(* External callee: bind to its C link name (the procedure's
own name); SymTab.ProcLink cannot be consulted after
EndUnit. *)
QbeGen.CopyOp(nm, mg)
ELSE
QbeGen.Mangled(nm, uid, mg)
END;
QbeGen.CallBegin(mg, res, depth, ext)
ELSE
(* not in Lower's table: a predef C proc (SYSTEM.TRANSFER,
NEWPROCESS, ...) lives in SymTab with a C link name *)
IF SymTab.Lookup(nm) AND (SymTab.SymKind(nm) = SymTab.KindProc) THEN
isC := TRUE;
res := SymTab.ProcRes(nm);
np := SymTab.ProcNPar(nm);
IF SymTab.ProcLink(nm, pn) THEN
QbeGen.CallBegin(pn, res, 0, TRUE)
ELSE
QbeGen.CallBegin(nm, res, 0, FALSE)
END
ELSE
res := SymTab.InvalidType;
QbeGen.CallBegin(nm, res, 0, FALSE)
END
END
END;
IF CompositeRes(res) THEN
(* composite result: pass a hidden destination pointer first *)
QbeGen.AllocLocal(res, qres);
IF NOT QbeGen.CallArg(qres, "l") THEN END
END;
va := (pi >= 0) AND (pi < VAL(INTEGER, nProcs)) AND procVa[pi];
(* actuals are a chunked sequence (AstCallNode): follow the NkBlock
continuations so a call with >MaxChild-1 arguments is complete *)
ai := 0;
seq := n;
WHILE seq # AST.NoNode DO
i := 0;
IF seq = n THEN i := 1 END; (* skip the callee in the head *)
WHILE i < AST.NChild(seq) DO
arg := AST.Child(seq, i);
IF AST.Kind(arg) # AST.NkBlock THEN
LowerExpr(arg, at, qe);
IF ind THEN
ft := SymTab.ProcTypeParamType(ct, ai);
isV := SymTab.ProcTypeParamIsVar(ct, ai)
ELSIF va THEN
ft := at; isV := FALSE
ELSIF isC THEN
ft := SymTab.ParamType(nm, ai);
isV := SymTab.ParamIsVar(nm, ai)
ELSE
IF NOT ParamInfoIdx(pi, ai, ft, isV, pn) THEN END
END;
IF va THEN
(* permissive C variadic argument *)
QbeGen.CArgAdd(qe, at, qa, cl)
ELSIF isV THEN
IF (SymTab.ClassOf(at) = SymTab.ClChar)
AND (SymTab.ClassOf(ft) = SymTab.ClArray)
AND (SymTab.ClassOf(SymTab.ArrayElem(ft)) = SymTab.ClChar)
AND QbeGen.IsImm(qe) THEN
(* 1-char string literal passed to a VAR ARRAY OF CHAR:
pass its static descriptor *)
QbeGen.DeclCharStr(qe, qa);
IF NOT QbeGen.CallArg(qa, "l") THEN END
ELSIF QbeGen.AddrOfVal(qe, qa) THEN
IF NOT QbeGen.CallArg(qa, "l") THEN END
END
ELSE
IF (SymTab.ClassOf(at) = SymTab.ClChar)
AND (SymTab.ClassOf(ft) = SymTab.ClArray)
AND (SymTab.ClassOf(SymTab.ArrayElem(ft)) = SymTab.ClChar)
AND QbeGen.IsImm(qe) THEN
(* 1-char string literal passed to ARRAY OF CHAR: pass its
static descriptor, not the char code *)
QbeGen.DeclCharStr(qe, qa);
IF NOT QbeGen.CallArg(qa, "l") THEN END
ELSE
conv := (SymTab.ClassOf(ft) = SymTab.ClReal)
AND SymTab.IsIntFamily(at);
IF conv THEN
QbeGen.ConvIR(qe, qt);
IF NOT QbeGen.CallArg(qt, "d") THEN END
ELSE
IF NOT QbeGen.CallArg(qe, QbeGen.ArgClass(ft)) THEN END
END
END
END;
INC(ai)
END;
INC(i)
END;
next := AST.NoNode;
IF AST.NChild(seq) > 0 THEN
next := AST.Child(seq, AST.NChild(seq) - 1);
IF AST.Kind(next) # AST.NkBlock THEN next := AST.NoNode END
END;
seq := next
END;
IF want THEN
t := res; QbeGen.CallEnd(TRUE, q);
IF CompositeRes(res) THEN QbeGen.CopyOp(qres, q) END
ELSE
t := SymTab.InvalidType; QbeGen.CopyOp("0", q); QbeGen.CallEnd(FALSE, q)
END
END LowerCall;
PROCEDURE IsBuiltin (nm: ARRAY OF CHAR): BOOLEAN;
BEGIN
RETURN SymTab.Equal(nm, "ABS") OR SymTab.Equal(nm, "ODD")
OR SymTab.Equal(nm, "CAP")
OR SymTab.Equal(nm, "CHR") OR SymTab.Equal(nm, "ORD")
OR SymTab.Equal(nm, "UCHR") OR SymTab.Equal(nm, "CHR8")
OR SymTab.Equal(nm, "UORD")
OR SymTab.Equal(nm, "SIZE") OR SymTab.Equal(nm, "TSIZE")
OR SymTab.Equal(nm, "LEN") OR SymTab.Equal(nm, "HIGH")
OR SymTab.Equal(nm, "VAL")
OR SymTab.Equal(nm, "MIN") OR SymTab.Equal(nm, "MAX")
OR SymTab.Equal(nm, "SHIFT") OR SymTab.Equal(nm, "ROTATE")
OR SymTab.Equal(nm, "ADR")
OR SymTab.Equal(nm, "INC") OR SymTab.Equal(nm, "DEC")
OR SymTab.Equal(nm, "INCL") OR SymTab.Equal(nm, "EXCL")
OR SymTab.Equal(nm, "NEW") OR SymTab.Equal(nm, "DISPOSE")
END IsBuiltin;
PROCEDURE LowerBuiltinExpr (n: AST.Node; nm: SymTab.Name;
VAR t: SymTab.TypeIndex; VAR q: QbeGen.QVal);
(* Value builtins (Fact). *)
VAR et, et2, dt, vt: SymTab.TypeIndex; qa, qt, q2, qd, qr: QbeGen.QVal;
k, lo, hi, c1, c2, ucp: INTEGER; qn, vn: SymTab.Name; sfx: BOOLEAN;
isMax, isU, uok: BOOLEAN;
BEGIN
IF SymTab.Equal(nm, "ODD") THEN
LowerExpr(AST.Child(n, 1), et, q);
QbeGen.NewTemp(qt);
QbeGen.Op3("and", qt, q, "1", FALSE); (* x & 1 *)
QbeGen.NewTemp(qa);
QbeGen.Cmp(SymTab.OpNeq1, qt, "0", qa, FALSE); (* <> 0 *)
QbeGen.CopyOp(qa, q); t := SymTab.BoolType()
ELSIF SymTab.Equal(nm, "ABS") THEN
LowerExpr(AST.Child(n, 1), et, q);
QbeGen.AbsQ(q, qa, SymTab.ClassOf(et) = SymTab.ClReal);
QbeGen.CopyOp(qa, q); t := et
ELSIF SymTab.Equal(nm, "CAP") THEN
LowerExpr(AST.Child(n, 1), et, q);
QbeGen.CapQ(q, qa); QbeGen.CopyOp(qa, q); t := SymTab.CharType()
ELSIF SymTab.Equal(nm, "CHR") THEN
LowerExpr(AST.Child(n, 1), et, q); t := SymTab.CharType()
ELSIF SymTab.Equal(nm, "ORD") THEN
LowerExpr(AST.Child(n, 1), et, q); t := SymTab.IntType()
ELSIF SymTab.Equal(nm, "UCHR") THEN
LowerExpr(AST.Child(n, 1), et, q); t := SymTab.UCharType()
ELSIF SymTab.Equal(nm, "CHR8") THEN
LowerExpr(AST.Child(n, 1), et, q);
QbeGen.WidenLong(q, qa); QbeGen.CheckRange(qa, "0", "255");
t := SymTab.CharType()
ELSIF SymTab.Equal(nm, "UORD") THEN
LowerExpr(AST.Child(n, 1), et, q); t := SymTab.IntType()
ELSIF SymTab.Equal(nm, "SIZE") OR SymTab.Equal(nm, "TSIZE") THEN
LowerDesign(AST.Child(n, 1), dt, k, qd, qn, sfx);
QbeGen.IntStr(VAL(INTEGER, SymTab.ObjectSize(dt)), q);
t := SymTab.IntType()
ELSIF SymTab.Equal(nm, "MIN") OR SymTab.Equal(nm, "MAX") THEN
isMax := SymTab.Equal(nm, "MAX");
LowerDesign(AST.Child(n, 1), dt, k, qd, qn, sfx);
IF SymTab.ClassOf(dt) = SymTab.ClReal THEN
IF isMax THEN QbeGen.NormReal("3.402823e38", q)
ELSE QbeGen.NormReal("-3.402823e38", q) END;
t := SymTab.RealType()
ELSIF SymTab.ClassOf(dt) = SymTab.ClLong THEN
IF isMax THEN QbeGen.CopyOp("9223372036854775807", q)
ELSE QbeGen.CopyOp("-9223372036854775808", q) END;
t := SymTab.LongType()
ELSIF SymTab.TypeBounds(dt, lo, hi) THEN
IF isMax THEN QbeGen.IntStr(hi, q) ELSE QbeGen.IntStr(lo, q) END;
t := SymTab.IntType()
ELSE t := SymTab.InvalidType; QbeGen.CopyOp("0", q)
END
ELSIF SymTab.Equal(nm, "LEN") OR SymTab.Equal(nm, "HIGH") THEN
IF AST.Kind(AST.Child(n, 1)) = AST.NkStrLit THEN
(* LEN("literal"): the content length of the literal; a real
string literal is still declared, as the grammar does *)
Name(AST.Child(n, 1), qn);
IF (qn[0] = "U") OR (qn[0] = "u") THEN
QbeGen.DeclUStr(qn, qd, isU, ucp, uok);
IF NOT uok THEN t := SymTab.InvalidType; QbeGen.CopyOp("0", q)
ELSIF isU THEN
IF SymTab.Equal(nm, "HIGH") THEN QbeGen.CopyOp("0", q)
ELSE QbeGen.CopyOp("1", q)
END;
t := SymTab.IntType()
ELSE
QbeGen.UStrLen(qd, qr);
IF SymTab.Equal(nm, "HIGH") THEN QbeGen.DecQ(qr) END;
QbeGen.CopyOp(qr, q); t := SymTab.IntType()
END
ELSE
IF SymTab.StrLen(qn) = 3 THEN c1 := 1
ELSE QbeGen.DeclStr(qn, qd); c1 := SymTab.StrLen(qn) - 2
END;
IF SymTab.Equal(nm, "HIGH") THEN DEC(c1) END;
QbeGen.IntStr(c1, q); t := SymTab.IntType()
END
ELSE
LowerDesign(AST.Child(n, 1), dt, k, qd, qn, sfx);
IF dt = SymTab.InvalidType THEN
t := SymTab.InvalidType; QbeGen.CopyOp("0", q)
ELSIF SymTab.ClassOf(dt) = SymTab.ClArray THEN
IF SymTab.Equal(nm, "HIGH") THEN
IF SymTab.IsOpenArray(dt) THEN QbeGen.OpenHi(qd, q)
ELSE QbeGen.IntStr(SymTab.ArrayHi(dt), q) END
ELSE
IF SymTab.IsOpenArray(dt) THEN QbeGen.LoadCount(qd, q)
ELSE QbeGen.IntStr(VAL(INTEGER, SymTab.ArrayLen(dt)), q) END
END;
t := SymTab.IntType()
ELSE
t := SymTab.InvalidType; QbeGen.CopyOp("0", q)
END
END;
ELSIF SymTab.Equal(nm, "VAL") THEN
Name(AST.Child(n, 1), vn);
IF NOT SymTab.Lookup(vn) THEN
t := SymTab.InvalidType; QbeGen.CopyOp("0", q)
ELSE
vt := SymTab.SymType(vn);
LowerExpr(AST.Child(n, 2), et, q);
c1 := SymTab.ClassOf(et); c2 := SymTab.ClassOf(vt);
IF (c1 = SymTab.ClInt) AND (c2 = SymTab.ClLong) THEN
QbeGen.WidenLong(q, qa); QbeGen.CopyOp(qa, q); t := vt
ELSIF (c1 = SymTab.ClLong) AND (c2 = SymTab.ClInt) THEN
QbeGen.NarrowLong(q, qa); QbeGen.CopyOp(qa, q); t := vt
ELSIF (c1 = SymTab.ClInt) AND (c2 = SymTab.ClReal) THEN
QbeGen.ConvIR(q, qa); QbeGen.CopyOp(qa, q); t := vt
ELSIF (c1 = SymTab.ClLong) AND (c2 = SymTab.ClReal) THEN
QbeGen.ConvLR(q, qa); QbeGen.CopyOp(qa, q); t := vt
ELSIF (c1 = SymTab.ClReal) AND (c2 = SymTab.ClInt) THEN
QbeGen.ConvRI(q, qa); QbeGen.CopyOp(qa, q); t := vt
ELSIF (c1 = SymTab.ClReal) AND (c2 = SymTab.ClLong) THEN
QbeGen.ConvRL(q, qa); QbeGen.CopyOp(qa, q); t := vt
ELSIF (c1 = SymTab.ClSet) AND (c2 = SymTab.ClInt) THEN
(* a set as its (first) machine word *)
QbeGen.LoadW(q, qa); QbeGen.CopyOp(qa, q); t := vt
ELSIF (c1 = SymTab.ClInt) AND (c2 = SymTab.ClSet) THEN
(* a word as a set value: zero-filled one-word temp *)
c2 := SymTab.SetWords(vt);
IF c2 = 0 THEN c2 := 1 END;
QbeGen.NewSetTemp(VAL(CARDINAL, c2), qa);
QbeGen.SetZero(qa, VAL(CARDINAL, c2));
QbeGen.StoreW(qa, q); QbeGen.CopyOp(qa, q); t := vt
ELSE t := vt (* same representation: no-op *)
END
END
ELSIF SymTab.Equal(nm, "SHIFT") OR SymTab.Equal(nm, "ROTATE") THEN
LowerExpr(AST.Child(n, 1), et, q);
LowerExpr(AST.Child(n, 2), et2, q2);
QbeGen.SetShift(q, q2, SymTab.SetWords(et), SymTab.SetCount(et),
SymTab.Equal(nm, "ROTATE"), qt);
t := et; QbeGen.CopyOp(qt, q)
ELSIF SymTab.Equal(nm, "ADR") THEN
LowerDesign(AST.Child(n, 1), dt, k, qd, qn, sfx);
IF k = SymTab.KindProc THEN
(* ADR of a procedure is its code address *)
LowerProcAddr(qn, q)
ELSIF sfx THEN QbeGen.CopyOp(qd, q)
ELSIF (k = SymTab.KindVar) OR (k = SymTab.KindParam) THEN
QbeGen.AddrOf(qn, q)
ELSE QbeGen.CopyOp("0", q)
END;
t := SymTab.AddrType()
ELSE t := SymTab.InvalidType; QbeGen.CopyOp("0", q)
END
END LowerBuiltinExpr;
PROCEDURE LowerBuiltinStmt (n: AST.Node; nm: SymTab.Name);
(* Statement builtins (AssOrCall): INC/DEC, INCL/EXCL, NEW/DISPOSE. *)
VAR dt, at, et2, bt: SymTab.TypeIndex; dk: INTEGER;
qd, qv, qe, qn2, qstep, qm: QbeGen.QVal;
qn: SymTab.Name; sfx, isInc: BOOLEAN;
BEGIN
IF SymTab.Equal(nm, "INC") OR SymTab.Equal(nm, "DEC") THEN
isInc := SymTab.Equal(nm, "INC");
QbeGen.CopyOp("1", qstep);
LowerDesign(AST.Child(n, 1), dt, dk, qd, qn, sfx);
IF AST.NChild(n) > 2 THEN LowerExpr(AST.Child(n, 2), et2, qstep) END;
IF dt = SymTab.InvalidType THEN
ELSE
IF sfx OR (dk = SymTab.KindField) THEN QbeGen.ElemLoad(qd, dt, qv)
ELSE QbeGen.LoadVar(qn, FALSE, qv)
END;
QbeGen.NewTemp(qn2);
IF isInc THEN QbeGen.Op3("add", qn2, qv, qstep, FALSE)
ELSE QbeGen.Op3("sub", qn2, qv, qstep, FALSE)
END;
IF sfx OR (dk = SymTab.KindField) THEN QbeGen.ElemStore(qd, qn2, dt)
ELSE QbeGen.StoreVar(qn, qn2, FALSE)
END
END
ELSIF SymTab.Equal(nm, "INCL") OR SymTab.Equal(nm, "EXCL") THEN
isInc := SymTab.Equal(nm, "INCL");
LowerDesign(AST.Child(n, 1), at, dk, qd, qn, sfx);
LowerExpr(AST.Child(n, 2), et2, qe);
IF at = SymTab.InvalidType THEN
ELSIF SymTab.ClassOf(at) # SymTab.ClSet THEN
ELSE
IF isInc THEN QbeGen.SetBit(qd, qe, SymTab.SetBaseLo(at), SymTab.SetCount(at))
ELSE QbeGen.SetClearBit(qd, qe, SymTab.SetBaseLo(at), SymTab.SetCount(at))
END
END
ELSIF SymTab.Equal(nm, "NEW") THEN
LowerDesign(AST.Child(n, 1), dt, dk, qd, qn, sfx);
IF dt = SymTab.InvalidType THEN
ELSIF SymTab.ClassOf(dt) # SymTab.ClPtr THEN
ELSE
bt := SymTab.PtrBase(dt);
IF bt # SymTab.InvalidType THEN
QbeGen.NewHeap(bt, qm); QbeGen.InitHeap(qm, bt);
IF sfx OR (dk = SymTab.KindField) THEN QbeGen.ElemStore(qd, qm, dt)
ELSE QbeGen.StorePtr(qn, qm)
END
END
END
ELSIF SymTab.Equal(nm, "DISPOSE") THEN
LowerDesign(AST.Child(n, 1), dt, dk, qd, qn, sfx);
IF dt = SymTab.InvalidType THEN
ELSIF SymTab.ClassOf(dt) # SymTab.ClPtr THEN
ELSE
IF sfx OR (dk = SymTab.KindField) THEN QbeGen.ElemLoad(qd, dt, qv)
ELSE QbeGen.LoadPtr(qn, qv)
END;
QbeGen.FreeHeap(qv);
IF sfx OR (dk = SymTab.KindField) THEN QbeGen.ElemStore(qd, "0", dt)
ELSE QbeGen.StorePtr(qn, "0")
END
END
END
END LowerBuiltinStmt;
PROCEDURE LowerMethod (m: AST.Node; ct: SymTab.TypeIndex);
(* A class method: hidden THIS receiver, then declared formals; the body
runs with THIS pushed as the WITH base (bare field names resolve). *)
VAR nm, txt: SymTab.Name; mg, thisQ: QbeGen.QVal;
uid, depth, np: CARDINAL; res, pt: SymTab.TypeIndex;
pv, ext: BOOLEAN; j: CARDINAL; saveCls: SymTab.TypeIndex;
savedProc: INTEGER;
BEGIN
IF (AST.Op(m) # 0) AND (AST.Op(m) # 3) THEN RETURN END;
Name(AST.Child(m, 0), nm);
IF NOT ProcInfo(nm, uid, res, depth, ext, np) THEN RETURN END;
QbeGen.Mangled(nm, SymTab.ClassMethodUid(ct, nm), mg);
QbeGen.BeginFunc(mg);
IF NOT QbeGen.FuncParam("THIS", TRUE, ct) THEN END;
IF CompositeRes(res) THEN
IF NOT QbeGen.FuncParam("__res", TRUE, res) THEN END
END;
j := 0;
WHILE j < np DO
IF NOT ParamInfo(nm, j, pt, pv, txt) THEN END;
IF NOT QbeGen.FuncParam(txt, pv OR SymTab.IsOpenArray(pt), pt) THEN END;
INC(j)
END;
QbeGen.SetFuncRes(res);
QbeGen.EndFuncHeader;
QbeGen.ThisBase(thisQ);
saveCls := curImplCls;
curImplCls := ct;
QbeGen.PushWith(thisQ);
IF withTop <= HIGH(withRec) THEN withRec[withTop] := ct; INC(withTop) END;
savedProc := emitProc;
emitProc := FindProc(nm);
LowerDecls(AST.Child(m, 2));
nUserLab := 0;
LowerStmt(AST.Child(m, 1));
emitProc := savedProc;
IF withTop > 0 THEN DEC(withTop) END;
curImplCls := saveCls;
QbeGen.PopWith;
QbeGen.EndFunc(res)
END LowerMethod;
PROCEDURE LowerMethods (seq: AST.Node; ct: SymTab.TypeIndex);
VAR i: CARDINAL; m: AST.Node;
BEGIN
IF seq = AST.NoNode THEN RETURN END;
i := 0;
WHILE i < AST.NChild(seq) DO
m := AST.Child(seq, i);
IF i = AST.MaxChild - 1 THEN LowerMethods(m, ct)
ELSIF AST.Kind(m) = AST.NkFieldDecl THEN LowerMethods(m, ct)
ELSIF AST.Kind(m) = AST.NkProcDecl THEN LowerMethod(m, ct)
END;
INC(i)
END
END LowerMethods;
PROCEDURE LowerMethodHeadings (seq: AST.Node; ct: SymTab.TypeIndex);
(* Class-declaration method headings: emit+discard a function header per
method so the backend temp counters advance exactly as the legacy
parse did (the implementation's temps then line up). *)
VAR i, j: CARDINAL; m: AST.Node; nm, txt: SymTab.Name;
mg: QbeGen.QVal; uid, depth, np: CARDINAL; res, pt: SymTab.TypeIndex;
pv, ext: BOOLEAN;
BEGIN
IF seq = AST.NoNode THEN RETURN END;
i := 0;
WHILE i < AST.NChild(seq) DO
m := AST.Child(seq, i);
IF i = AST.MaxChild - 1 THEN LowerMethodHeadings(m, ct)
ELSIF AST.Kind(m) = AST.NkFieldDecl THEN LowerMethodHeadings(m, ct)
ELSIF AST.Kind(m) = AST.NkProcDecl THEN
Name(AST.Child(m, 0), nm);
IF ProcInfo(nm, uid, res, depth, ext, np) THEN
QbeGen.Mangled(nm, SymTab.ClassMethodUid(ct, nm), mg);
QbeGen.BeginFunc(mg);
j := 0;
WHILE j < np DO
IF NOT ParamInfo(nm, j, pt, pv, txt) THEN END;
IF NOT QbeGen.FuncParam(txt, pv OR SymTab.IsOpenArray(pt), pt) THEN END;
INC(j)
END;
QbeGen.SetFuncRes(res);
QbeGen.AbortFunc
END
END;
INC(i)
END
END LowerMethodHeadings;
PROCEDURE LowerMethodCall (n: AST.Node; VAR t: SymTab.TypeIndex;
VAR q: QbeGen.QVal; want: BOOLEAN);
VAR d: AST.Node; ct, res, ft, at: SymTab.TypeIndex;
cq, mg, qa, qt, qe, qres: QbeGen.QVal; fn, pn: SymTab.Name;
k, vs: INTEGER; i: CARDINAL; sfx, isV, conv: BOOLEAN;
BEGIN
d := AST.Child(n, 0);
curMethCls := SymTab.InvalidType;
LowerDesign(d, ct, k, cq, pn, sfx);
ct := curMethCls;
IF ct = SymTab.InvalidType THEN
t := SymTab.InvalidType; QbeGen.CopyOp("0", q); RETURN
END;
IF AST.NChild(d) = 1 THEN
Name(AST.Child(d, 0), fn)
ELSE
Name(AST.Child(AST.Child(d, AST.NChild(d) - 1), 0), fn)
END;
res := SymTab.ClassMethodRes(ct, fn);
vs := SymTab.VirtSlot(ct, fn);
IF vs >= 0 THEN QbeGen.VirtCallBegin(cq, vs, res)
ELSE
QbeGen.Mangled(fn, SymTab.ClassMethodUid(ct, fn), mg);
QbeGen.CallBegin(mg, res, 0, FALSE)
END;
IF CompositeRes(res) THEN
QbeGen.AllocLocal(res, qres);
IF NOT QbeGen.CallArg(qres, "l") THEN END
END;
i := 1;
WHILE i < AST.NChild(n) DO
LowerExpr(AST.Child(n, i), at, qe);
ft := SymTab.ClassMethodParamType(ct, fn, i - 1);
isV := SymTab.ClassMethodParamIsVar(ct, fn, i - 1);
IF isV THEN
IF QbeGen.AddrOfVal(qe, qa) THEN
IF NOT QbeGen.CallArg(qa, "l") THEN END
END
ELSE
conv := (SymTab.ClassOf(ft) = SymTab.ClReal) AND SymTab.IsIntFamily(at);
IF conv THEN
QbeGen.ConvIR(qe, qt);
IF NOT QbeGen.CallArg(qt, "d") THEN END
ELSE
IF NOT QbeGen.CallArg(qe, QbeGen.ArgClass(ft)) THEN END
END
END;
INC(i)
END;
IF want THEN t := res; QbeGen.CallEnd(TRUE, q);
IF CompositeRes(res) THEN QbeGen.CopyOp(qres, q) END
ELSE t := SymTab.InvalidType; QbeGen.CopyOp("0", q); QbeGen.CallEnd(FALSE, q)
END
END LowerMethodCall;
PROCEDURE LowerCase (n: AST.Node);
(* CASE as a compare-chain (mirrors CaseStat/CaseAlt/CaseLabel). The
arm list is chunked (AstAppend) so a CASE with more than MaxChild
alternatives is not truncated. *)
VAR i, j: CARDINAL; arm, lab, seq, next: AST.Node;
tsel, t2, t3: SymTab.TypeIndex;
qsel, q2, q3, qc, qd, qe, lEnd, lBody, lAfter, lNext: QbeGen.QVal;
BEGIN
LowerExpr(AST.Child(n, 0), tsel, qsel);
QbeGen.NewLabel(lEnd);
(* pass 1: alternatives (ELSE arms come after) *)
seq := AST.Child(n, 1);
WHILE seq # AST.NoNode DO
i := 0;
WHILE i < AST.NChild(seq) DO
arm := AST.Child(seq, i);
IF AST.Kind(arm) = AST.NkBlock THEN
(* continuation chunk *)
ELSIF AST.Op(arm) = 1 THEN
(* ELSE arm: emitted in pass 2 *)
ELSE
QbeGen.NewLabel(lBody); QbeGen.NewLabel(lAfter);
j := 0;
WHILE j + 1 < AST.NChild(arm) DO
lab := AST.Child(arm, j);
IF AST.Kind(lab) = AST.NkSubrange THEN
LowerExpr(AST.Child(lab, 0), t2, q2);
QbeGen.NewLabel(lNext);
QbeGen.Cmp(SymTab.OpEq, qsel, q2, qc, FALSE);
QbeGen.Jnz(qc, lBody, lNext);
QbeGen.EmitLabel(lNext);
LowerExpr(AST.Child(lab, 1), t3, q3);
QbeGen.Cmp(SymTab.OpGe, qsel, q2, qc, FALSE);
QbeGen.Cmp(SymTab.OpLe, qsel, q3, qd, FALSE);
QbeGen.NewTemp(qe);
QbeGen.Op3("and", qe, qc, qd, FALSE);
QbeGen.NewLabel(lNext);
QbeGen.Jnz(qe, lBody, lNext);
QbeGen.EmitLabel(lNext)
ELSE
LowerExpr(lab, t2, q2);
QbeGen.NewLabel(lNext);
QbeGen.Cmp(SymTab.OpEq, qsel, q2, qc, FALSE);
QbeGen.Jnz(qc, lBody, lNext);
QbeGen.EmitLabel(lNext)
END;
INC(j)
END;
QbeGen.Jmp(lAfter);
QbeGen.EmitLabel(lBody);
LowerStmt(AST.Child(arm, AST.NChild(arm) - 1));
QbeGen.Jmp(lEnd);
QbeGen.EmitLabel(lAfter)
END;
INC(i)
END;
next := AST.NoNode;
IF AST.NChild(seq) > 0 THEN
next := AST.Child(seq, AST.NChild(seq) - 1);
IF AST.Kind(next) # AST.NkBlock THEN next := AST.NoNode END
END;
seq := next
END;
(* pass 2: ELSE arms *)
seq := AST.Child(n, 1);
WHILE seq # AST.NoNode DO
i := 0;
WHILE i < AST.NChild(seq) DO
arm := AST.Child(seq, i);
IF (AST.Kind(arm) # AST.NkBlock) AND (AST.Op(arm) = 1) THEN
LowerStmt(AST.Child(arm, 0))
END;
INC(i)
END;
next := AST.NoNode;
IF AST.NChild(seq) > 0 THEN
next := AST.Child(seq, AST.NChild(seq) - 1);
IF AST.Kind(next) # AST.NkBlock THEN next := AST.NoNode END
END;
seq := next
END;
QbeGen.EmitLabel(lEnd)
END LowerCase;
PROCEDURE LowerWith (n: AST.Node);
(* WITH: push each record's base address, lower the body, pop only the
levels this WITH pushed (a nested WITH must restore the outer one). *)
VAR i, base: CARDINAL; dt: SymTab.TypeIndex; dk: INTEGER;
qd: QbeGen.QVal; qn: SymTab.Name; sfx: BOOLEAN;
BEGIN
base := withTop;
i := 0;
WHILE i + 1 < AST.NChild(n) DO
LowerDesign(AST.Child(n, i), dt, dk, qd, qn, sfx);
QbeGen.PushWith(qd);
IF withTop <= HIGH(withRec) THEN
withRec[withTop] := dt; INC(withTop)
END;
INC(i)
END;
LowerStmt(AST.Child(n, AST.NChild(n) - 1));
WHILE withTop > base DO DEC(withTop); QbeGen.PopWith END
END LowerWith;
PROCEDURE LowerProcAddr (nm: ARRAY OF CHAR; VAR q: QbeGen.QVal);
(* Code address of a procedure used as a value (assign to a procedure
variable): $_, or the plain C link for external procs. *)
VAR uid, depth, np: CARDINAL; res: SymTab.TypeIndex; ext: BOOLEAN;
mg: QbeGen.QVal;
base: SymTab.Name; ok: BOOLEAN;
BEGIN
ok := ProcInfo(nm, uid, res, depth, ext, np);
IF NOT ok THEN
(* a qualified/imported procedure appears under its base symbol
name in the proc table *)
IF SymTab.SymBase(nm, base) THEN
ok := ProcInfo(base, uid, res, depth, ext, np)
END
END;
IF ok THEN
IF ext THEN QbeGen.CopyOp(nm, mg) ELSE QbeGen.Mangled(nm, uid, mg) END;
QbeGen.ProcAddr(mg, q)
ELSE QbeGen.CopyOp("0", q)
END
END LowerProcAddr;
PROCEDURE LowerExprFull (n: AST.Node; VAR t: SymTab.TypeIndex;
VAR q: QbeGen.QVal; VAR k: INTEGER;
VAR qn: SymTab.Name; VAR sfx: BOOLEAN;
asAddr: BOOLEAN);
VAR t2: SymTab.TypeIndex; q2, qt, qf, qs, qr, qaddr, qa, qb: QbeGen.QVal;
lNext, lFalse, lTrue, lDone: QbeGen.QVal;
kind, op, rop, ucp: INTEGER;
folded, isR, isCh, isU, uok: BOOLEAN;
i: CARDINAL; el, seq, next: AST.Node;
lw, rw, mw: CARDINAL; idx: INTEGER; fok, isL: BOOLEAN;
lt, rt: SymTab.TypeIndex; qw: QbeGen.QVal;
BEGIN
IF AST.Kind(n) = AST.NkDesignator THEN
LowerDesign(n, t, k, q, qn, sfx);
IF k = SymTab.KindProc THEN
(* bare procedure used as a value: its code address *)
LowerProcAddr(qn, q);
RETURN
END;
(* Record value->address for VAR actuals, mirroring the grammar's
Design. AddrOfVal cannot rely on the grammar's notes: its ring
(256) wraps long before a whole-session emit finishes. *)
IF sfx THEN QbeGen.CopyOp(q, qaddr) ELSE QbeGen.AddrOf(qn, qaddr) END;
IF NOT asAddr THEN FinalLoad(t, sfx, q) END;
IF (k = SymTab.KindVar) OR (k = SymTab.KindParam)
OR (k = SymTab.KindField) THEN
QbeGen.NoteAddr(q, qaddr)
ELSIF sfx AND (t # SymTab.InvalidType)
AND ((SymTab.ClassOf(t) = SymTab.ClArray)
OR (SymTab.ClassOf(t) = SymTab.ClSet)
OR (SymTab.ClassOf(t) = SymTab.ClRecord)) THEN
QbeGen.NoteAddr(q, qaddr)
END;
RETURN
END;
k := -1; qn[0] := CHR(0); sfx := FALSE;
IF AST.Kind(n) = AST.NkIntLit THEN
Name(n, qn); QbeGen.NormInt(qn, q); t := SymTab.IntType()
ELSIF AST.Kind(n) = AST.NkCharLit THEN
Name(n, qn); QbeGen.NormLit(qn, q, isCh); t := SymTab.CharType()
ELSIF AST.Kind(n) = AST.NkRealLit THEN
Name(n, qn); QbeGen.NormReal(qn, q); t := SymTab.RealType()
ELSIF AST.Kind(n) = AST.NkStrLit THEN
Name(n, qn);
IF (qn[0] = "U") OR (qn[0] = "u") THEN
(* U"..." / U'...': one codepoint -> UCHAR, else a ustring *)
QbeGen.DeclUStr(qn, q, isU, ucp, uok);
IF NOT uok THEN
t := SymTab.InvalidType; QbeGen.CopyOp("0", q)
ELSIF isU THEN
t := SymTab.UCharType(); QbeGen.IntStr(ucp, q)
ELSE
t := AST.Ty(n); IF t = -1 THEN t := SymTab.NewUStr() END; QbeGen.NoteAddr(q, q)
END
ELSIF SymTab.StrLen(qn) = 3 THEN
t := SymTab.CharType(); QbeGen.IntStr(QbeGen.CharVal(qn), q)
ELSE
t := AST.Ty(n); IF t = -1 THEN t := SymTab.NewStr() END; QbeGen.DeclStr(qn, q); QbeGen.NoteAddr(q, q)
END
ELSIF AST.Kind(n) = AST.NkSetLit THEN
t := AST.Ty(n); IF t = -1 THEN t := SymTab.NewSet(SymTab.NewSubR(0, 255)) END;
QbeGen.NewSetTemp(8, q); QbeGen.SetZero(q, 8);
i := 0;
WHILE i < AST.NChild(n) DO
el := AST.Child(n, i);
IF AST.Kind(el) = AST.NkSubrange THEN
LowerExpr(AST.Child(el, 0), t2, q2);
LowerExpr(AST.Child(el, 1), t2, qt);
QbeGen.SetRange(q, q2, qt, SymTab.SetBaseLo(t), SymTab.SetCount(t))
ELSE
LowerExpr(el, t2, q2);
QbeGen.SetBit(q, q2, SymTab.SetBaseLo(t), SymTab.SetCount(t))
END;
INC(i)
END
ELSIF AST.Kind(n) = AST.NkBraceLit THEN
(* T{...} typed brace literal: a set here (the type was recorded by
the grammar in the node's ty field). Array/record/class
constructors are not lowered here yet. *)
t := AST.Ty(n);
IF (t # SymTab.InvalidType) AND (SymTab.ClassOf(t) = SymTab.ClSet) THEN
IF SymTab.SetWords(t) = 0 THEN
QbeGen.NewSetTemp(8, q); QbeGen.SetZero(q, 8)
ELSE
QbeGen.NewSetTemp(SymTab.SetWords(t), q);
QbeGen.SetZero(q, SymTab.SetWords(t))
END;
seq := n;
WHILE seq # AST.NoNode DO
i := 0;
WHILE i < AST.NChild(seq) DO
el := AST.Child(seq, i);
IF AST.Kind(el) # AST.NkBlock THEN
IF AST.Kind(el) = AST.NkSubrange THEN
LowerExpr(AST.Child(el, 0), t2, q2);
LowerExpr(AST.Child(el, 1), t2, qt);
QbeGen.SetRange(q, q2, qt, SymTab.SetBaseLo(t),
SymTab.SetCount(t))
ELSE
LowerExpr(el, t2, q2);
QbeGen.SetBit(q, q2, SymTab.SetBaseLo(t), SymTab.SetCount(t))
END
END;
INC(i)
END;
next := AST.NoNode;
IF AST.NChild(seq) > 0 THEN
next := AST.Child(seq, AST.NChild(seq) - 1);
IF AST.Kind(next) # AST.NkBlock THEN next := AST.NoNode END
END;
seq := next
END
ELSIF (t # SymTab.InvalidType)
AND ((SymTab.ClassOf(t) = SymTab.ClArray)
OR (SymTab.ClassOf(t) = SymTab.ClRecord)
OR (SymTab.ClassOf(t) = SymTab.ClClass)) THEN
(* T{...} aggregate constructor *)
QbeGen.CtorBegin(t);
seq := n;
WHILE seq # AST.NoNode DO
i := 0;
WHILE i < AST.NChild(seq) DO
el := AST.Child(seq, i);
IF AST.Kind(el) # AST.NkBlock THEN
LowerExpr(el, t2, q2);
QbeGen.CtorElem(q2)
END;
INC(i)
END;
next := AST.NoNode;
IF AST.NChild(seq) > 0 THEN
next := AST.Child(seq, AST.NChild(seq) - 1);
IF AST.Kind(next) # AST.NkBlock THEN next := AST.NoNode END
END;
seq := next
END;
QbeGen.CtorEnd(q)
ELSE
t := SymTab.InvalidType; QbeGen.CopyOp("0", q)
END
ELSIF AST.Kind(n) = AST.NkDesignator THEN
LowerDesign(n, t, k, q, qn, sfx)
ELSIF AST.Kind(n) = AST.NkCall THEN
IF IsMethodCall(n) THEN LowerMethodCall(n, t, q, TRUE)
ELSE
CalleeName(n, qn);
IF IsBuiltin(qn) THEN LowerBuiltinExpr(n, qn, t, q)
ELSE LowerCall(n, t, q, TRUE)
END
END
ELSIF AST.Kind(n) = AST.NkUnary THEN
LowerExpr(AST.Child(n, 0), t, q);
IF AST.Op(n) = AST.OpSub THEN
IF QbeGen.IsImm(q) THEN QbeGen.NegFold(q, q)
ELSE QbeGen.NewTemp(qt);
QbeGen.NegQ(q, qt, SymTab.ClassOf(t) = SymTab.ClReal);
QbeGen.CopyOp(qt, q)
END
ELSE
QbeGen.NotQ(q, qt); QbeGen.CopyOp(qt, q); t := SymTab.BoolType()
END
ELSIF AST.Kind(n) = AST.NkBinExpr THEN
op := AST.Op(n);
IF IsRel(op) THEN
LowerExpr(AST.Child(n, 0), t, q);
LowerExpr(AST.Child(n, 1), t2, q2);
rop := SymTab.OpEq; folded := RelSym(op, rop);
IF op = AST.OpIn THEN
QbeGen.InSet(q, q2, SymTab.SetBaseLo(t2), SymTab.SetCount(t2), qt);
t := SymTab.BoolType(); QbeGen.CopyOp(qt, q)
ELSIF (SymTab.ClassOf(t) = SymTab.ClPtr)
OR (SymTab.ClassOf(t2) = SymTab.ClPtr) THEN
QbeGen.CmpL(rop, q, q2, qt);
t := SymTab.BoolType(); QbeGen.CopyOp(qt, q)
ELSIF (SymTab.ClassOf(t) = SymTab.ClSet)
OR (SymTab.ClassOf(t2) = SymTab.ClSet) THEN
QbeGen.CmpSet(rop, q, q2, SymTab.SetWords(t), SymTab.SetWords(t2), qt);
t := SymTab.BoolType(); QbeGen.CopyOp(qt, q)
ELSIF SymTab.StrCompat(t, t2) THEN
QbeGen.StrEq(rop, q, q2, qt);
t := SymTab.BoolType(); QbeGen.CopyOp(qt, q)
ELSIF SymTab.IsLongFamily(t) OR SymTab.IsLongFamily(t2) THEN
IF SymTab.IsIntFamily(t) THEN QbeGen.WidenLong(q, qf); QbeGen.CopyOp(qf, q) END;
IF SymTab.IsIntFamily(t2) THEN QbeGen.WidenLong(q2, qf); QbeGen.CopyOp(qf, q2) END;
QbeGen.CmpLong(rop, q, q2, qt);
t := SymTab.BoolType(); QbeGen.CopyOp(qt, q)
ELSE
isR := (t # SymTab.InvalidType) AND (SymTab.ClassOf(t) = SymTab.ClReal);
t := SymTab.BoolType();
QbeGen.Cmp(rop, q, q2, qt, isR);
QbeGen.CopyOp(qt, q)
END
ELSIF op = AST.OpAnd THEN
LowerExpr(AST.Child(n, 0), t, q);
QbeGen.DelayBegin;
LowerExpr(AST.Child(n, 1), t2, q2);
QbeGen.DelayEnd;
QbeGen.Slot4(qs);
QbeGen.NewLabel(lNext); QbeGen.NewLabel(lFalse); QbeGen.NewLabel(lDone);
QbeGen.Jnz(q, lNext, lFalse);
QbeGen.EmitLabel(lNext);
QbeGen.DelayFlush;
QbeGen.StoreW(qs, q2);
QbeGen.Jmp(lDone);
QbeGen.EmitLabel(lFalse);
QbeGen.StoreW(qs, "0");
QbeGen.Jmp(lDone);
QbeGen.EmitLabel(lDone);
QbeGen.LoadW(qs, qr);
QbeGen.CopyOp(qr, q);
t := SymTab.BoolType()
ELSIF op = AST.OpOr THEN
LowerExpr(AST.Child(n, 0), t, q);
QbeGen.DelayBegin;
LowerExpr(AST.Child(n, 1), t2, q2);
QbeGen.DelayEnd;
QbeGen.Slot4(qs);
QbeGen.NewLabel(lTrue); QbeGen.NewLabel(lNext); QbeGen.NewLabel(lDone);
QbeGen.Jnz(q, lTrue, lNext);
QbeGen.EmitLabel(lTrue);
QbeGen.StoreW(qs, "1");
QbeGen.Jmp(lDone);
QbeGen.EmitLabel(lNext);
QbeGen.DelayFlush;
QbeGen.StoreW(qs, q2);
QbeGen.Jmp(lDone);
QbeGen.EmitLabel(lDone);
QbeGen.LoadW(qs, qr);
QbeGen.CopyOp(qr, q);
t := SymTab.BoolType()
ELSE
LowerExpr(AST.Child(n, 0), t, q);
LowerExpr(AST.Child(n, 1), t2, q2);
IF (t # SymTab.InvalidType) AND (t2 # SymTab.InvalidType)
AND (SymTab.ClassOf(t) = SymTab.ClSet)
AND (SymTab.ClassOf(t2) = SymTab.ClSet) THEN
(* set union/diff (Add/Sub) or intersection/symdiff (Mul/Div) *)
lw := SymTab.SetWords(t); rw := SymTab.SetWords(t2);
mw := lw; IF rw > mw THEN mw := rw END;
IF op = AST.OpAdd THEN idx := 0
ELSIF op = AST.OpSub THEN idx := 2
ELSIF op = AST.OpMul THEN idx := 1
ELSE idx := 3
END;
QbeGen.SetBinOp(idx, q, q2, lw, rw, qt);
t := SymTab.NewSet(SymTab.NewSubR(0, VAL(INTEGER, mw) * 32 - 1));
QbeGen.CopyOp(qt, q)
ELSIF (op = AST.OpAdd)
AND (SymTab.StrCompat(t, t2)
OR (SymTab.IsStrType(t) AND (SymTab.ClassOf(t2) = SymTab.ClChar))
OR ((SymTab.ClassOf(t) = SymTab.ClChar) AND SymTab.IsStrType(t2))) THEN
QbeGen.StrFold(q, q2, SymTab.ClassOf(t), SymTab.ClassOf(t2), qt, fok);
IF NOT fok THEN
IF SymTab.StrCompat(t, t2) THEN QbeGen.StrCat(q, q2, qt)
ELSIF SymTab.IsStrType(t) THEN
QbeGen.DeclCharStr(q2, qs); QbeGen.StrCat(q, qs, qt)
ELSE
QbeGen.DeclCharStr(q, qs); QbeGen.StrCat(qs, q2, qt)
END
END;
t := SymTab.NewStr(); QbeGen.CopyOp(qt, q)
ELSIF (op = AST.OpAdd)
AND (SymTab.UStrCompat(t, t2)
OR ((SymTab.ClassOf(t) = SymTab.ClUChar)
AND (SymTab.ClassOf(t2) = SymTab.ClUStr))
OR ((SymTab.ClassOf(t) = SymTab.ClUStr)
AND (SymTab.ClassOf(t2) = SymTab.ClUChar))
OR ((SymTab.ClassOf(t) = SymTab.ClUChar)
AND (SymTab.ClassOf(t2) = SymTab.ClUChar))) THEN
(* UString concatenation: a UCHAR operand becomes a
1-codepoint UString; the result is a descriptor *)
IF SymTab.ClassOf(t) = SymTab.ClUStr THEN QbeGen.CopyOp(q, qa)
ELSE QbeGen.UStrFrom(q, qa)
END;
IF SymTab.ClassOf(t2) = SymTab.ClUStr THEN QbeGen.UStrCat(qa, q2, qt)
ELSE QbeGen.UStrFrom(q2, qb); QbeGen.UStrCat(qa, qb, qt)
END;
t := SymTab.NewUStr(); QbeGen.CopyOp(qt, q)
ELSE
lt := t; rt := t2;
IF (SymTab.ClassOf(lt) = SymTab.ClReal)
OR (SymTab.ClassOf(rt) = SymTab.ClReal) THEN
t := SymTab.RealType()
ELSIF SymTab.IsLongFamily(lt) OR SymTab.IsLongFamily(rt) THEN
t := SymTab.LongType()
ELSE t := SymTab.IntType()
END;
isL := SymTab.IsLongFamily(t);
isR := SymTab.ClassOf(t) = SymTab.ClReal;
kind := 0;
IF op = AST.OpSub THEN kind := 1
ELSIF op = AST.OpMul THEN kind := 2
ELSIF op = AST.OpDiv THEN kind := 3
ELSIF op = AST.OpMod THEN kind := 4
END;
folded := FALSE;
IF (NOT isL) AND (NOT isR) AND QbeGen.IsImm(q) AND QbeGen.IsImm(q2) THEN
folded := QbeGen.Fold2(kind, q, q2, qf)
END;
IF folded THEN QbeGen.CopyOp(qf, q)
ELSE
IF isL THEN
IF SymTab.IsIntFamily(lt) THEN
QbeGen.WidenLong(q, qw); QbeGen.CopyOp(qw, q)
END;
IF SymTab.IsIntFamily(rt) THEN
QbeGen.WidenLong(q2, qw); QbeGen.CopyOp(qw, q2)
END;
QbeGen.NewTemp(qt);
IF op = AST.OpAdd THEN QbeGen.Op3L("add", qt, q, q2)
ELSIF op = AST.OpSub THEN QbeGen.Op3L("sub", qt, q, q2)
ELSIF op = AST.OpMul THEN QbeGen.Op3L("mul", qt, q, q2)
ELSE QbeGen.Op3L("div", qt, q, q2)
END
ELSE
QbeGen.NewTemp(qt);
IF op = AST.OpAdd THEN QbeGen.Op3("add", qt, q, q2, isR)
ELSIF op = AST.OpSub THEN QbeGen.Op3("sub", qt, q, q2, isR)
ELSIF op = AST.OpMul THEN QbeGen.Op3("mul", qt, q, q2, isR)
ELSIF op = AST.OpDiv THEN QbeGen.Op3("div", qt, q, q2, isR)
ELSE QbeGen.Op3("rem", qt, q, q2, isR)
END
END;
QbeGen.CopyOp(qt, q)
END
END
END
END
END LowerExprFull;
PROCEDURE LowerExpr (n: AST.Node; VAR t: SymTab.TypeIndex;
VAR q: QbeGen.QVal);
VAR k: INTEGER; qn: SymTab.Name; sfx: BOOLEAN;
BEGIN
LowerExprFull(n, t, q, k, qn, sfx, FALSE)
END LowerExpr;
PROCEDURE LowerStmt (seq: AST.Node);
VAR i: CARDINAL; c, els, by: AST.Node; k: INTEGER;
t, t2, t3, dt, et: SymTab.TypeIndex;
q, q2, qt, qf, qd, qe: QbeGen.QVal;
qlo, qhi, qk, qb, ql, qby: QbeGen.QVal; step: INTEGER;
lTop, lBody, lEnd, lThen, lElse, lNext, lFalse, lDone, lx: QbeGen.QVal;
qn, lv: SymTab.Name;
kind, op, rop, cls: INTEGER;
sfx, folded, isR, conv, wconv, hasElse: BOOLEAN;
BEGIN
IF seq = AST.NoNode THEN RETURN END;
k := AST.Kind(seq);
IF k = AST.NkBlock THEN
i := 0;
WHILE i < AST.NChild(seq) DO
LowerStmt(AST.Child(seq, i)); INC(i)
END
ELSIF k = AST.NkAssign THEN
LowerDesign(AST.Child(seq, 0), dt, cls, qd, qn, sfx);
LowerExpr(AST.Child(seq, 1), et, qe);
isR := (dt # SymTab.InvalidType) AND (SymTab.ClassOf(dt) = SymTab.ClReal);
conv := isR AND SymTab.IsIntFamily(et);
wconv := (dt # SymTab.InvalidType) AND SymTab.IsLongFamily(dt)
AND SymTab.IsIntFamily(et);
IF sfx OR (cls = SymTab.KindField) THEN
IF SymTab.ClassOf(dt) = SymTab.ClArray THEN
IF (et # SymTab.InvalidType) AND (SymTab.ClassOf(et) = SymTab.ClUStr)
AND SymTab.IsUCharArray(dt) THEN QbeGen.UAssign(qd, qe)
ELSIF SymTab.StrCompat(dt, et) THEN QbeGen.StrAssign(qd, qe)
ELSE QbeGen.CopyArray(qd, qe, dt)
END
ELSIF SymTab.ClassOf(dt) = SymTab.ClSet THEN
QbeGen.CopySet(qd, qe, SymTab.SetWords(dt), SymTab.SetWords(et))
ELSIF SymTab.ClassOf(dt) = SymTab.ClRecord THEN
QbeGen.CopyRecord(qd, qe, dt)
ELSIF SymTab.IsLongFamily(dt) THEN
IF wconv THEN QbeGen.WidenLong(qe, ql); QbeGen.ElemStore(qd, ql, dt)
ELSE QbeGen.ElemStore(qd, qe, dt)
END
ELSIF conv THEN QbeGen.ConvIR(qe, qt); QbeGen.ElemStore(qd, qt, dt)
ELSE QbeGen.ElemStore(qd, qe, dt)
END
ELSE
IF SymTab.ClassOf(dt) = SymTab.ClArray THEN
IF (et # SymTab.InvalidType) AND (SymTab.ClassOf(et) = SymTab.ClUStr)
AND SymTab.IsUCharArray(dt) THEN QbeGen.UAssign(qd, qe)
ELSIF SymTab.StrCompat(dt, et) THEN QbeGen.StrAssign(qd, qe)
ELSE QbeGen.CopyArray(qd, qe, dt)
END
ELSIF SymTab.ClassOf(dt) = SymTab.ClSet THEN
QbeGen.CopySet(qd, qe, SymTab.SetWords(dt), SymTab.SetWords(et))
ELSIF SymTab.ClassOf(dt) = SymTab.ClRecord THEN
QbeGen.CopyRecord(qd, qe, dt)
ELSIF (SymTab.ClassOf(dt) = SymTab.ClPtr)
OR (SymTab.ClassOf(dt) = SymTab.ClProc) THEN
QbeGen.StorePtr(qn, qe)
ELSIF SymTab.IsLongFamily(dt) THEN
IF wconv THEN QbeGen.WidenLong(qe, ql); QbeGen.StoreLong(qn, ql)
ELSE QbeGen.StoreLong(qn, qe)
END
ELSIF conv THEN QbeGen.ConvIR(qe, qt); QbeGen.StoreVar(qn, qt, TRUE)
ELSE QbeGen.StoreVar(qn, qe, isR)
END
END
ELSIF k = AST.NkIf THEN
LowerExpr(AST.Child(seq, 0), t, q);
QbeGen.NewLabel(lThen); QbeGen.NewLabel(lElse); QbeGen.NewLabel(lEnd);
QbeGen.Jnz(q, lThen, lElse); QbeGen.EmitLabel(lThen);
LowerStmt(AST.Child(seq, 1));
QbeGen.Jmp(lEnd);
els := AST.Child(seq, 2); hasElse := FALSE;
WHILE (els # AST.NoNode) AND (AST.Kind(els) = AST.NkIf) DO
QbeGen.EmitLabel(lElse); QbeGen.NewLabel(lElse);
LowerExpr(AST.Child(els, 0), t, q);
QbeGen.NewLabel(lThen); QbeGen.Jnz(q, lThen, lElse);
QbeGen.EmitLabel(lThen);
LowerStmt(AST.Child(els, 1));
QbeGen.Jmp(lEnd);
els := AST.Child(els, 2)
END;
IF els # AST.NoNode THEN
QbeGen.EmitLabel(lElse); hasElse := TRUE; LowerStmt(els)
END;
IF hasElse THEN QbeGen.EmitLabel(lEnd)
ELSE QbeGen.EmitLabel(lElse); QbeGen.EmitLabel(lEnd)
END
ELSIF k = AST.NkWhile THEN
QbeGen.NewLabel(lTop); QbeGen.NewLabel(lBody); QbeGen.NewLabel(lEnd);
QbeGen.EmitLabel(lTop);
LowerExpr(AST.Child(seq, 0), t, q);
QbeGen.Jnz(q, lBody, lEnd); QbeGen.EmitLabel(lBody);
LowerStmt(AST.Child(seq, 1));
QbeGen.Jmp(lTop); QbeGen.EmitLabel(lEnd)
ELSIF k = AST.NkRepeat THEN
QbeGen.NewLabel(lTop); QbeGen.NewLabel(lEnd); QbeGen.EmitLabel(lTop);
LowerStmt(AST.Child(seq, 0));
LowerExpr(AST.Child(seq, 1), t, q);
QbeGen.Jnz(q, lEnd, lTop); QbeGen.EmitLabel(lEnd)
ELSIF k = AST.NkLoop THEN
QbeGen.NewLabel(lTop); QbeGen.NewLabel(lEnd);
QbeGen.PushLoop(lEnd); QbeGen.EmitLabel(lTop);
LowerStmt(AST.Child(seq, 0));
QbeGen.Jmp(lTop); QbeGen.PopLoop; QbeGen.EmitLabel(lEnd)
ELSIF k = AST.NkExit THEN
IF QbeGen.TopLoop(lx) THEN QbeGen.Jmp(lx) END
ELSIF k = AST.NkFor THEN
Name(AST.Child(seq, 0), lv);
LowerExpr(AST.Child(seq, 1), t, qlo);
LowerExpr(AST.Child(seq, 2), t2, qhi);
(* optional BY step: a constant, default +1; its sign also
selects the termination comparison *)
step := 1;
IF AST.Child(seq, 3) # AST.NoNode THEN
LowerExpr(AST.Child(seq, 3), t3, qby);
IF NOT SymTab.ConstInt(qby, step) THEN step := 1
ELSIF step = 0 THEN step := 1
END
END;
QbeGen.StoreVar(lv, qlo, FALSE);
QbeGen.NewLabel(lTop); QbeGen.NewLabel(lBody); QbeGen.NewLabel(lEnd);
QbeGen.EmitLabel(lTop);
QbeGen.LoadVar(lv, FALSE, qt);
QbeGen.NewTemp(qk);
IF step > 0 THEN QbeGen.Op3("cslew", qk, qt, qhi, FALSE)
ELSE QbeGen.Op3("csgew", qk, qt, qhi, FALSE)
END;
QbeGen.Jnz(qk, lBody, lEnd);
QbeGen.EmitLabel(lBody);
LowerStmt(AST.Child(seq, 4));
QbeGen.LoadVar(lv, FALSE, qt);
QbeGen.IntStr(step, qb);
QbeGen.NewTemp(qk);
QbeGen.Op3("add", qk, qt, qb, FALSE);
QbeGen.StoreVar(lv, qk, FALSE);
QbeGen.Jmp(lTop); QbeGen.EmitLabel(lEnd)
ELSIF k = AST.NkHalt THEN
IF AST.Child(seq, 0) # AST.NoNode THEN
LowerExpr(AST.Child(seq, 0), t, q) END;
QbeGen.HaltQ
ELSIF k = AST.NkGoto THEN
Name(AST.Child(seq, 0), qn);
UserLabel(qn, q);
QbeGen.Jmp(q)
ELSIF k = AST.NkLabel THEN
Name(AST.Child(seq, 0), qn);
UserLabel(qn, q);
QbeGen.EmitLabel(q)
ELSIF k = AST.NkReturn THEN
IF AST.Child(seq, 0) = AST.NoNode THEN
QbeGen.EmitRet(q, FALSE)
ELSE
LowerExpr(AST.Child(seq, 0), t, q);
IF (emitProc >= 0) AND (emitProc < VAL(INTEGER, nProcs))
AND CompositeRes(procRes[emitProc]) THEN
(* composite result: copy into the hidden destination *)
QbeGen.AddrOf("__res", qt);
IF SymTab.ClassOf(procRes[emitProc]) = SymTab.ClArray THEN
QbeGen.CopyArray(qt, q, procRes[emitProc])
ELSIF SymTab.ClassOf(procRes[emitProc]) = SymTab.ClSet THEN
QbeGen.CopySet(qt, q, SymTab.SetWords(procRes[emitProc]),
SymTab.SetWords(procRes[emitProc]))
ELSE QbeGen.CopyRecord(qt, q, procRes[emitProc])
END;
QbeGen.EmitRet("0", FALSE)
ELSE
conv := (SymTab.ClassOf(SymTab.CurRes()) = SymTab.ClReal)
AND SymTab.IsIntFamily(t);
IF conv THEN QbeGen.ConvIR(q, qt); QbeGen.EmitRet(qt, TRUE)
ELSE QbeGen.EmitRet(q, TRUE)
END
END
END
ELSIF k = AST.NkCase THEN LowerCase(seq)
ELSIF k = AST.NkWith THEN LowerWith(seq)
ELSIF k = AST.NkCall THEN
IF IsMethodCall(seq) THEN LowerMethodCall(seq, t, q, FALSE)
ELSE
CalleeName(seq, qn);
IF IsBuiltin(qn) THEN LowerBuiltinStmt(seq, qn)
ELSE LowerCall(seq, t, q, FALSE)
END
END
END
END LowerStmt;
PROCEDURE ReenterGlobals (seq: AST.Node);
(* Re-registers a nested module's non-exported globals in the enclosing
(still-open) module scope, so QbeGen.GlobalRef can resolve their
"_" symbols after the nested scope has been popped. *)
VAR i, j: CARDINAL; c: AST.Node; nm: SymTab.Name; chunk, vn: AST.Node;
BEGIN
IF seq = AST.NoNode THEN RETURN END;
i := 0;
WHILE i < AST.NChild(seq) DO
c := AST.Child(seq, i);
IF i = AST.MaxChild - 1 THEN ReenterGlobals(c)
ELSIF AST.Kind(c) = AST.NkDeclSeq THEN ReenterGlobals(c)
ELSIF AST.Kind(c) = AST.NkVarDecl THEN
chunk := c;
WHILE chunk # AST.NoNode DO
j := 0;
WHILE j < AST.NChild(chunk) DO
vn := AST.Child(chunk, j);
IF AST.Kind(vn) = AST.NkIdent THEN
Name(vn, nm);
IF SymTab.ReenterModGlobal(nm, SymTab.KindVar, curUnitName) THEN
SymTab.SetSymType(nm, AST.Ty(c))
END
END;
INC(j)
END;
IF AST.NChild(chunk) > 0 THEN
vn := AST.Child(chunk, AST.NChild(chunk) - 1);
IF AST.Kind(vn) = AST.NkBlock THEN chunk := vn
ELSE chunk := AST.NoNode END
ELSE chunk := AST.NoNode END
END
ELSIF (AST.Kind(c) = AST.NkTypeDecl)
OR (AST.Kind(c) = AST.NkClassDecl) THEN
(* a nested module's TYPE/CLASS: re-register it so ObjectSize and
GlobalRef can resolve it after the nested scope is popped *)
IF AST.NChild(c) >= 1 THEN
Name(AST.Child(c, 0), nm);
IF SymTab.ReenterModGlobal(nm, SymTab.KindType, curUnitName) THEN
SymTab.SetSymType(nm, AST.Ty(c))
END
END
END;
INC(i)
END
END ReenterGlobals;
PROCEDURE EmitVarNames (c: AST.Node);
(* Emit DeclVar for each name of an NkVarDecl; the names are a chunked
sequence (AstAppend), so follow NkBlock continuations. *)
VAR j: CARDINAL; chunk, vn: AST.Node; nm: SymTab.Name;
BEGIN
chunk := c;
WHILE chunk # AST.NoNode DO
j := 0;
WHILE j < AST.NChild(chunk) DO
vn := AST.Child(chunk, j);
IF AST.Kind(vn) = AST.NkIdent THEN
Name(vn, nm);
QbeGen.DeclVar(nm, AST.Ty(c));
IF (NOT QbeGen.InFunction())
AND (SymTab.ClassOf(AST.Ty(c)) = SymTab.ClArray)
AND QbeGen.RecArrayNeedsInit(SymTab.ArrayLen(AST.Ty(c)),
AST.Ty(c))
AND (nCountInit <= HIGH(countArr)) THEN
QbeGen.DeclRecTemplate(nm, SymTab.ArrayElem(AST.Ty(c)));
countArr[nCountInit] := nm;
countTyp[nCountInit] := AST.Ty(c);
INC(nCountInit)
END
END;
INC(j)
END;
IF AST.NChild(chunk) > 0 THEN
vn := AST.Child(chunk, AST.NChild(chunk) - 1);
IF AST.Kind(vn) = AST.NkBlock THEN chunk := vn
ELSE chunk := AST.NoNode END
ELSE chunk := AST.NoNode END
END
END EmitVarNames;
PROCEDURE EmitCountInits;
(* Initialise the length words of record-array globals that were emitted
compactly (recorded by EmitVarNames). *)
VAR k: CARDINAL;
BEGIN
k := 0;
WHILE k < nCountInit DO
QbeGen.InitRecArray(countArr[k], countTyp[k]);
INC(k)
END
END EmitCountInits;
PROCEDURE LowerDecls (seq: AST.Node);
VAR i, j: CARDINAL; c: AST.Node; nm, txt: SymTab.Name; qv: QbeGen.QVal;
mg: QbeGen.QVal; uid, depth, np: CARDINAL; res, pt: SymTab.TypeIndex;
ext, pv: BOOLEAN; kk: INTEGER; ct: SymTab.TypeIndex; savedProc: INTEGER;
chunk, vn: AST.Node; pi: INTEGER;
mk: ARRAY [0 .. MaxCFoldW - 1] OF CARDINAL; mw: CARDINAL; mlo: INTEGER;
BEGIN
IF seq = AST.NoNode THEN RETURN END;
i := 0;
WHILE i < AST.NChild(seq) DO
c := AST.Child(seq, i);
IF i = AST.MaxChild - 1 THEN LowerDecls(c)
ELSIF AST.Kind(c) = AST.NkDeclSeq THEN LowerDecls(c)
ELSIF AST.Kind(c) = AST.NkClassDecl THEN
Name(AST.Child(c, 0), nm);
IF Resolve(nm, kk, ct) THEN
IF SymTab.ClassOf(ct) = SymTab.ClClass THEN
IF AST.Op(c) = 1 THEN
LowerMethods(AST.Child(c, 3), ct);
IF AST.Child(c, 2) # AST.NoNode THEN
QbeGen.BeginInit(nm);
LowerStmt(AST.Child(c, 2));
QbeGen.EndInit
END
ELSE
LowerMethodHeadings(AST.Child(c, 3), ct)
END
END
END
ELSIF AST.Kind(c) = AST.NkUnit THEN
Name(AST.Child(c, 0), nm);
ReenterGlobals(AST.Child(c, 1));
LowerDecls(AST.Child(c, 1));
IF AST.Child(c, 2) # AST.NoNode THEN
QbeGen.BeginInit(nm);
LowerStmt(AST.Child(c, 2));
QbeGen.EndInit
END
ELSIF AST.Kind(c) = AST.NkVarDecl THEN
(* op=1 marks a forward-typed global: emit it after the rest,
as the grammar's FlushPend does *)
IF AST.Op(c) # 1 THEN EmitVarNames(c) END
ELSIF AST.Kind(c) = AST.NkConstDecl THEN
Name(AST.Child(c, 0), nm);
kk := SymTab.ClassOf(AST.Ty(c));
IF kk = SymTab.ClSet THEN
(* SET CONST: static data from the mask the grammar computed *)
IF LookupSetMask(nm, mk, mw, mlo) THEN
QbeGen.PoolSet(mk, mw, qv); SetConstVal(nm, qv)
ELSE SetConstVal(nm, "0")
END
ELSIF (kk = SymTab.ClArray) OR (kk = SymTab.ClRecord)
OR (kk = SymTab.ClClass) OR (kk = SymTab.ClStr)
OR (kk = SymTab.ClUStr) THEN
(* aggregate/string CONST: re-emit the constructor/string so
its static data is produced (the grammar's CtorEnd/DeclStr
are suppressed under NoEmit), then refresh the value *)
LowerExpr(AST.Child(c, 1), ct, qv);
SetConstVal(nm, qv)
ELSIF GetConstVal(nm, qv) AND QbeGen.IsImm(qv) THEN
(* scalar: use the evaluated value recorded by NoteConstVal *)
QbeGen.DeclConst(nm, qv, AST.Ty(c))
END
ELSIF AST.Kind(c) = AST.NkProcDecl THEN
Name(AST.Child(c, 0), nm);
pi := AST.Ty(c); (* proc-table index recorded by NoteProcNode *)
IF (pi < 0) OR (pi >= VAL(INTEGER, nProcs)) THEN pi := FindProc(nm) END;
IF ProcInfoIdx(pi, uid, res, depth, ext, np) THEN
QbeGen.Mangled(nm, uid, mg);
QbeGen.BeginFunc(mg);
IF CompositeRes(res) THEN
IF NOT QbeGen.FuncParam("__res", TRUE, res) THEN END
END;
j := 0;
WHILE j < np DO
IF ParamInfoIdx(pi, j, pt, pv, txt) THEN
IF NOT QbeGen.FuncParam(txt, pv OR SymTab.IsOpenArray(pt), pt) THEN END
END;
INC(j)
END;
QbeGen.SetFuncRes(res);
IF AST.Child(c, 1) = AST.NoNode THEN
(* declaration-only (definition module): replay the heading *)
QbeGen.AbortFunc
ELSE
QbeGen.EndFuncHeader;
savedProc := emitProc;
emitProc := pi;
LowerDecls(AST.Child(c, 2));
nUserLab := 0;
LowerStmt(AST.Child(c, 1));
emitProc := savedProc;
QbeGen.EndFunc(res)
END
END
END;
INC(i)
END
END LowerDecls;
PROCEDURE MaterializeGlobals (unitName: ARRAY OF CHAR; decls: AST.Node);
(* Make a unit's module-level VAR/CONST visible in the (global) scope
Lower runs in at session end, so GlobalRef resolves "_". *)
VAR i, j: CARDINAL; c: AST.Node; nm: SymTab.Name; chunk, vn: AST.Node;
BEGIN
IF decls = AST.NoNode THEN RETURN END;
i := 0;
WHILE i < AST.NChild(decls) DO
c := AST.Child(decls, i);
IF i = AST.MaxChild - 1 THEN MaterializeGlobals(unitName, c)
ELSIF AST.Kind(c) = AST.NkDeclSeq THEN MaterializeGlobals(unitName, c)
ELSIF (AST.Kind(c) = AST.NkVarDecl) OR (AST.Kind(c) = AST.NkConstDecl) THEN
chunk := c;
WHILE chunk # AST.NoNode DO
j := 0;
WHILE j < AST.NChild(chunk) DO
vn := AST.Child(chunk, j);
IF AST.Kind(vn) = AST.NkIdent THEN
Name(vn, nm);
IF NOT SymTab.MaterializeReplace(unitName, nm) THEN END
END;
INC(j)
END;
IF AST.NChild(chunk) > 0 THEN
vn := AST.Child(chunk, AST.NChild(chunk) - 1);
IF AST.Kind(vn) = AST.NkBlock THEN chunk := vn
ELSE chunk := AST.NoNode END
ELSE chunk := AST.NoNode END
END
ELSIF (AST.Kind(c) = AST.NkTypeDecl) OR (AST.Kind(c) = AST.NkClassDecl) THEN
IF AST.NChild(c) >= 1 THEN
Name(AST.Child(c, 0), nm);
IF NOT SymTab.MaterializeReplace(unitName, nm) THEN END
END
END;
INC(i)
END
END MaterializeGlobals;
PROCEDURE LowerDeferredVars (seq: AST.Node);
(* Emit the forward-typed globals (NkVarDecl op=1) after the rest of the
unit's declarations, matching the grammar's FlushPend ordering. *)
VAR i: CARDINAL; c: AST.Node;
BEGIN
IF seq = AST.NoNode THEN RETURN END;
i := 0;
WHILE i < AST.NChild(seq) DO
c := AST.Child(seq, i);
IF i = AST.MaxChild - 1 THEN LowerDeferredVars(c)
ELSIF AST.Kind(c) = AST.NkDeclSeq THEN LowerDeferredVars(c)
ELSIF (AST.Kind(c) = AST.NkVarDecl) AND (AST.Op(c) = 1) THEN
EmitVarNames(c)
END;
INC(i)
END
END LowerDeferredVars;
PROCEDURE LowerOneUnit (u: AST.Node; isProg: BOOLEAN);
VAR nm: SymTab.Name;
BEGIN
nCountInit := 0;
Name(AST.Child(u, 0), nm);
CopySpan(nm, curUnitName, 0, 0);
QbeGen.SetModule(nm);
MaterializeGlobals(nm, AST.Child(u, 1));
LowerDecls(AST.Child(u, 1));
LowerDeferredVars(AST.Child(u, 1));
IF isProg THEN
QbeGen.BeginBody;
EmitCountInits;
nUserLab := 0;
LowerStmt(AST.Child(u, 2))
ELSIF AST.Child(u, 2) # AST.NoNode THEN
QbeGen.BeginInit(nm);
EmitCountInits;
nUserLab := 0;
LowerStmt(AST.Child(u, 2));
QbeGen.EndInit
ELSIF nCountInit > 0 THEN
QbeGen.BeginInit(nm);
EmitCountInits;
QbeGen.EndInit
END
END LowerOneUnit;
PROCEDURE BeginSession (progName: ARRAY OF CHAR);
(* Per-unit Lower emission. The grammar still runs its inline emit while
parsing, but under NoEmit it only mutates QbeGen's counters (nothing
reaches the buffer). For each unit: BeginUnit snapshots the state
*before* parsing; after parsing, LowerUnitNow restores that snapshot
and lets Lower re-emit the unit from the same counter values the
legacy inline path would have used, so the image stays byte-identical.
EndSession writes the accumulated session image. *)
BEGIN
withTop := 0;
curImplCls := SymTab.InvalidType;
scopeTop := 0; curScopeProc := -1; emitProc := -1;
QbeGen.OpenModule(progName);
QbeGen.SetNoEmit(TRUE)
END BeginSession;
PROCEDURE BeginUnit;
(* Snapshot the pre-parse state so Lower can discard the grammar's
suppressed inline mutations for this unit. *)
BEGIN
nImps := 0;
QbeGen.SaveSession
END BeginUnit;
PROCEDURE LowerUnitNow (unit: AST.Node; isProg: BOOLEAN);
BEGIN
IF unit = AST.NoNode THEN RETURN END;
QbeGen.RestoreSession;
QbeGen.SetNoEmit(FALSE);
LowerOneUnit(unit, isProg);
QbeGen.SetNoEmit(TRUE)
END LowerUnitNow;
PROCEDURE EndSession;
BEGIN
QbeGen.SetNoEmit(FALSE);
QbeGen.EndModule(curUnitName)
END EndSession;
BEGIN
scopeTop := 0; curScopeProc := -1; emitProc := -1
END Lower.