IMPLEMENTATION MODULE QbeGen; IMPORT FileIO, SymTab; VAR out : FileIO.File; opened : BOOLEAN; inBody : BOOLEAN; dead : BOOLEAN; (* TRUE past a terminator: next instruction opens an unreachable block with a fresh label, so the .ssa stays valid QBE (no dangling temps, no instruction outside a block). *) nTemp : CARDINAL; nLab : CARDINAL; loopTop : CARDINAL; loopSt : ARRAY [0 .. 15] OF QVal; nR : CARDINAL; (* non-zero REAL consts flushed at BeginBody *) rNames : ARRAY [0 .. 31] OF QVal; rVals : ARRAY [0 .. 31] OF QVal; nStr : CARDINAL; (* string-literal data counter *) strNams : ARRAY [0 .. 4095] OF QVal; strTexts : ARRAY [0 .. 4095] OF ARRAY [0 .. 255] OF CHAR; (* UString literals: decoded codepoints, recorded for EndModule. *) ustrN : CARDINAL; ustrNams : ARRAY [0 .. 255] OF QVal; ustrStart : ARRAY [0 .. 255] OF CARDINAL; ustrCount : ARRAY [0 .. 255] OF CARDINAL; ustrPool : ARRAY [0 .. 8191] OF INTEGER; ustrUsed : CARDINAL; (* array constructors: pooled static descriptors *) ctorN : CARDINAL; ctorNam : ARRAY [0 .. 255] OF QVal; ctorTxt : ARRAY [0 .. 255] OF ARRAY [0 .. 4095] OF CHAR; ctorUse : ARRAY [0 .. 255] OF BOOLEAN; (* FALSE once inlined as a field *) ctorTop : CARDINAL; ctorTyp : ARRAY [0 .. 7] OF INTEGER; ctorCnt : ARRAY [0 .. 7] OF CARDINAL; ctorBuf : ARRAY [0 .. 7] OF ARRAY [0 .. 4095] OF CHAR; ctorEv : ARRAY [0 .. 7] OF ARRAY [0 .. 255] OF QVal; ctorEk : ARRAY [0 .. 7] OF ARRAY [0 .. 255] OF INTEGER; withTop : CARDINAL; withSt : ARRAY [0 .. 7] OF QVal; noEmit : BOOLEAN; (* TRUE while parsing nested procedures in 4.1: SymTab tracks, QbeGen suppresses output *) inFunc : BOOLEAN; (* TRUE inside an emitted function body *) useStack : BOOLEAN;(* TRUE: NewHeap allocates stack slots *) funcRes : CHAR; (* current function result class *) nLoc : CARDINAL; (* function-local name table entries *) locNames : ARRAY [0 .. 255] OF SymTab.Name; locTag : ARRAY [0 .. 255] OF INTEGER; (* 0 slot, 1 data, 2 addr *) locRep : ARRAY [0 .. 255] OF QVal; (* slot temp / mangled / addr *) locCls : ARRAY [0 .. 255] OF CHAR; locTyp : ARRAY [0 .. 255] OF INTEGER; funcDepth : CARDINAL; (* open BeginFuncs; main body = 0 *) scopeTop : CARDINAL; (* open procedure scopes *) scopeBase : ARRAY [0 .. 16] OF CARDINAL; scopeLink : ARRAY [0 .. 15] OF QVal; (* per-scope link records *) slTmp : QVal; (* current static-link param temp *) hdrComma : BOOLEAN; stkLink : ARRAY [0 .. 15] OF QVal; (* per-call static links *) stkExt : ARRAY [0 .. 15] OF BOOLEAN; (* per-call external flag *) stkInd : ARRAY [0 .. 15] OF BOOLEAN; (* per-call indirect flag *) outSel : CARDINAL; (* 0 = file, else nestBufs[outSel-1] *) nInit : CARDINAL; initNames : ARRAY [0 .. 31] OF QVal; sessBuf : ARRAY [0 .. 4194303] OF CHAR; (* whole image, buffered (4 MiB: must hold the compiler's own image text when self-hosting) *) sessUsed : CARDINAL; nestBufs : ARRAY [0 .. 15] OF ARRAY [0 .. 65535] OF CHAR; nestUsed : ARRAY [0 .. 15] OF CARDINAL; (* Short-circuit AND/OR: the RHS operand's code is buffered here (delayTop > 0) and replayed inside the branch. *) delayBuf : ARRAY [0 .. 15] OF ARRAY [0 .. 8191] OF CHAR; delayUsed : ARRAY [0 .. 15] OF CARDINAL; delayTop : CARDINAL; (* one buffer per nesting depth: each nested function stays contiguous no matter how deep the parse interleaves *) nPar : CARDINAL; (* recorded formal params for the header *) parCls : ARRAY [0 .. 63] OF CHAR; parTmp : ARRAY [0 .. 63] OF QVal; parNam : ARRAY [0 .. 63] OF SymTab.Name; parVar : ARRAY [0 .. 63] OF BOOLEAN; parTyp : ARRAY [0 .. 63] OF INTEGER; argBuf : ARRAY [0 .. 4095] OF CHAR; (* accumulated call args *) hbuf : ARRAY [0 .. 2047] OF CHAR; (* buffered function header *) nArg : CARDINAL; recvQ : QVal; (* armed class-method receiver *) recvArmed : BOOLEAN; callDepth : CARDINAL; (* nested-call stack *) stkName : ARRAY [0 .. 15] OF QVal; stkRes : ARRAY [0 .. 15] OF CHAR; stkArg : ARRAY [0 .. 15] OF ARRAY [0 .. 1023] OF CHAR; stkN : ARRAY [0 .. 15] OF CARDINAL; funcName : QVal; (* current function / call target *) curModName : SymTab.Name; (* module being compiled (global names) *) nVal : ARRAY [0 .. 255] OF QVal; (* VAR-actual note keys *) nAddr : ARRAY [0 .. 255] OF QVal; (* VAR-actual note addresses *) nn : CARDINAL; (* Forward-global designator patch sites: a not-yet-declared identifier inside a procedure body emits "site =l copy 0" plus a load/store operand "fwd"; both are text-patched once the module's declarations are complete. *) nFwd : CARDINAL; dbgFwd : INTEGER; fwdSite : ARRAY [0 .. 255] OF SymTab.Name; (* real name to patch in *) fwdOper : ARRAY [0 .. 255] OF QVal; (* final load/store class *) fwdGlob : ARRAY [0 .. 255] OF BOOLEAN; (* ---------------- small string utilities ---------------- *) PROCEDURE Len (s: ARRAY OF CHAR): CARDINAL; VAR i : CARDINAL; BEGIN i := 0; WHILE (i <= HIGH(s)) AND (s[i] # CHR(0)) DO INC(i) END; RETURN i END Len; PROCEDURE Cpy (VAR d: ARRAY OF CHAR; s: ARRAY OF CHAR); VAR i : CARDINAL; BEGIN i := 0; WHILE (i <= HIGH(d)) AND (i <= HIGH(s)) AND (s[i] # CHR(0)) DO d[i] := s[i]; INC(i) END; IF i <= HIGH(d) THEN d[i] := CHR(0) END END Cpy; PROCEDURE App (VAR d: ARRAY OF CHAR; s: ARRAY OF CHAR); VAR i, j : CARDINAL; BEGIN i := 0; WHILE (i <= HIGH(d)) AND (d[i] # CHR(0)) DO INC(i) END; j := 0; WHILE (i <= HIGH(d)) AND (j <= HIGH(s)) AND (s[j] # CHR(0)) DO d[i] := s[j]; INC(i); INC(j) END; IF i <= HIGH(d) THEN d[i] := CHR(0) END END App; PROCEDURE BufApp (VAR buf: ARRAY OF CHAR; VAR used: CARDINAL; s: ARRAY OF CHAR; eol: BOOLEAN); VAR j : CARDINAL; BEGIN j := 0; WHILE (used < HIGH(buf)) AND (j <= HIGH(s)) AND (s[j] # CHR(0)) DO buf[used] := s[j]; INC(used); INC(j) END; IF eol AND (used < HIGH(buf)) THEN buf[used] := CHR(10); INC(used) END; IF used <= HIGH(buf) THEN buf[used] := CHR(0) END END BufApp; PROCEDURE WEmit (s: ARRAY OF CHAR; eol: BOOLEAN); (* Single output sink: the session buffer, or a nesting-depth buffer for nested functions (QBE rejects definitions inside functions, so nested bodies hoist until EndModule). *) VAR b, u, j : CARDINAL; BEGIN IF NOT opened OR noEmit THEN RETURN END; IF delayTop > 0 THEN b := delayTop - 1; u := delayUsed[b]; j := 0; WHILE (u < HIGH(delayBuf[b])) AND (j <= HIGH(s)) AND (s[j] # CHR(0)) DO delayBuf[b][u] := s[j]; INC(u); INC(j) END; IF eol AND (u < HIGH(delayBuf[b])) THEN delayBuf[b][u] := CHR(10); INC(u) END; IF u <= HIGH(delayBuf[b]) THEN delayBuf[b][u] := CHR(0) END; delayUsed[b] := u; RETURN END; IF outSel = 0 THEN BufApp(sessBuf, sessUsed, s, eol); RETURN END; b := outSel - 1; IF b > HIGH(nestBufs) THEN b := HIGH(nestBufs) END; u := nestUsed[b]; j := 0; WHILE (u < HIGH(nestBufs[b])) AND (j <= HIGH(s)) AND (s[j] # CHR(0)) DO nestBufs[b][u] := s[j]; INC(u); INC(j) END; IF eol AND (u < HIGH(nestBufs[b])) THEN nestBufs[b][u] := CHR(10); INC(u) END; IF u <= HIGH(nestBufs[b]) THEN nestBufs[b][u] := CHR(0) END; nestUsed[b] := u END WEmit; PROCEDURE W (s: ARRAY OF CHAR); BEGIN WEmit(s, FALSE) END W; PROCEDURE WL (s: ARRAY OF CHAR); BEGIN WEmit(s, TRUE) END WL; PROCEDURE SetNoEmit (b: BOOLEAN); BEGIN noEmit := b END SetNoEmit; PROCEDURE DelayBegin; (* Start buffering output (the RHS operand of a short-circuit AND/OR). *) BEGIN IF delayTop <= HIGH(delayBuf) THEN delayUsed[delayTop] := 0; delayBuf[delayTop][0] := CHR(0); INC(delayTop) END END DelayBegin; PROCEDURE DelayEnd; (* Stop buffering (restore the previous output sink). *) BEGIN IF delayTop > 0 THEN DEC(delayTop) END END DelayEnd; PROCEDURE DelayFlush; (* Emit the buffered RHS operand's code into the current sink. DelayEnd already popped delayTop, so the just-used buffer index is delayTop itself. *) VAR b: CARDINAL; BEGIN b := delayTop; IF b <= HIGH(delayBuf) THEN WEmit(delayBuf[b], FALSE) END END DelayFlush; PROCEDURE Slot4 (VAR s: QVal); BEGIN NewTemp(s); Revive; W(" "); W(s); W(" =l alloc4 4"); WL("") END Slot4; PROCEDURE StoreW (slot: ARRAY OF CHAR; val: ARRAY OF CHAR); BEGIN Revive; W(" storew "); W(val); W(", "); WL(slot) END StoreW; PROCEDURE LoadW (slot: ARRAY OF CHAR; VAR q: QVal); BEGIN NewTemp(q); Revive; W(" "); W(q); W(" =w loadw "); WL(slot) END LoadW; PROCEDURE SetModule (name: ARRAY OF CHAR); (* Names the module whose globals are being emitted (QBE symbols become "_" so separate modules never collide). *) BEGIN Cpy(curModName, name) END SetModule; PROCEDURE SymRef (name: ARRAY OF CHAR; VAR ref: QVal); (* "$_" for module-level entries (avoids cross-module collisions); "$" fallback otherwise. *) VAR g : SymTab.Name; BEGIN Cpy(ref, "$"); IF SymTab.GlobalRef(name, g) THEN App(ref, g) ELSE App(ref, name) END END SymRef; PROCEDURE Wc (c: CHAR); (* Writes a single class character (w/d/l). *) VAR s : ARRAY [0 .. 1] OF CHAR; BEGIN s[0] := c; s[1] := CHR(0); W(s) END Wc; PROCEDURE AppNum (VAR d: ARRAY OF CHAR; v: CARDINAL); (* Appends v in decimal to d. *) VAR buf : ARRAY [0 .. 15] OF CHAR; n, i, L : CARDINAL; BEGIN n := 0; IF v = 0 THEN buf[0] := "0"; n := 1 END; WHILE (v > 0) AND (n <= HIGH(buf)) DO buf[n] := CHR(ORD("0") + v MOD 10); v := v DIV 10; INC(n) END; i := n; WHILE i > 0 DO DEC(i); L := Len(d); IF L < HIGH(d) THEN d[L] := buf[i]; d[L + 1] := CHR(0) END END END AppNum; PROCEDURE FwdDesignator (): INTEGER; (* Reserves a forward-global patch site and returns its id. *) BEGIN IF nFwd > HIGH(fwdSite) THEN RETURN 0 END; INC(nFwd); RETURN VAL(INTEGER, nFwd) END FwdDesignator; PROCEDURE FwdMangle (id: INTEGER; VAR q: QVal); BEGIN Cpy(q, "$fwd"); AppNum(q, VAL(CARDINAL, id)) END FwdMangle; PROCEDURE FwdAddrOper (id: INTEGER; VAR q: QVal); (* Stand-in address operand for forward site id. *) BEGIN FwdMangle(id, q) END FwdAddrOper; PROCEDURE FwdPatch (site, id: INTEGER; name: ARRAY OF CHAR; oper: CHAR; global: BOOLEAN); (* Records the resolved designator for placeholder id. The class letter (`oper`) re-classes the load whose operand is the placeholder; the symbol replaces the placeholder everywhere. *) VAR k: INTEGER; nm: QVal; BEGIN k := id - 1; IF (k < 0) OR (k > VAL(INTEGER, HIGH(fwdSite))) THEN RETURN END; IF global THEN SymRef(name, nm); Cpy(fwdSite[k], nm) ELSE Cpy(fwdSite[k], name) END; fwdOper[k][0] := oper; fwdOper[k][1] := CHR(0); fwdGlob[k] := global END FwdPatch; PROCEDURE FwdElemPatch (id: INTEGER; oper: CHAR); VAR k: INTEGER; BEGIN k := id - 1; IF (k >= 0) AND (k <= VAL(INTEGER, HIGH(fwdSite))) THEN fwdOper[k][0] := oper; fwdOper[k][1] := CHR(0) END END FwdElemPatch; PROCEDURE FixLoadClass (ph: ARRAY OF CHAR; cls: CHAR); (* Re-class " = load " -> " = load ". The default emit for an unresolved alias is `l` (pointer-like). *) VAR i, j, n: CARDINAL; found: BOOLEAN; BEGIN n := Len(ph); i := 0; WHILE i + n <= sessUsed DO (* "=c loadc " is 9 chars: '=', c, ' ', 'l','o','a','d', c, ' ' *) found := (i + 9 + n <= sessUsed); IF found THEN found := (sessBuf[i] = "=") AND (sessBuf[i+2] = " ") AND (sessBuf[i+3] = "l") AND (sessBuf[i+4] = "o") AND (sessBuf[i+5] = "a") AND (sessBuf[i+6] = "d") AND (sessBuf[i+8] = " ") AND (sessBuf[i+1] = sessBuf[i+7]) END; IF found THEN j := 0; found := TRUE; WHILE (j < n) AND found DO IF sessBuf[i + 9 + j] # ph[j] THEN found := FALSE END; INC(j) END END; IF found THEN sessBuf[i + 1] := cls; sessBuf[i + 7] := cls END; INC(i) END END FixLoadClass; PROCEDURE FixStoreClass (ph: ARRAY OF CHAR; cls: CHAR); (* Re-class "store , " -> "store , ": blinks the opcode word that opens the line holding the operand . *) VAR i, j, n: CARDINAL; found: BOOLEAN; BEGIN n := Len(ph); i := 0; WHILE i + n <= sessUsed DO found := TRUE; j := 0; WHILE (j < n) AND found DO IF sessBuf[i + j] # ph[j] THEN found := FALSE END; INC(j) END; IF found THEN j := i; WHILE (j > 0) AND (sessBuf[j - 1] # CHR(10)) DO DEC(j) END; WHILE (j < i) AND ((sessBuf[j] = " ") OR (sessBuf[j] = CHR(9))) DO INC(j) END; IF (j + 6 <= i) AND (sessBuf[j] = "s") AND (sessBuf[j+1] = "t") AND (sessBuf[j+2] = "o") AND (sessBuf[j+3] = "r") AND (sessBuf[j+4] = "e") THEN sessBuf[j + 5] := cls END END; INC(i) END END FixStoreClass; PROCEDURE BufReplaceAll (pat, rep: ARRAY OF CHAR); (* Literal substring replacement over sessBuf (in place, memmove semantics for both growth and shrink). *) VAR i, j: CARDINAL; n, m, tail, k: CARDINAL; found: BOOLEAN; BEGIN n := Len(pat); m := Len(rep); IF (n = 0) OR (m = 0) THEN RETURN END; i := 0; WHILE i + n <= sessUsed DO found := TRUE; j := 0; WHILE (j < n) AND found DO IF sessBuf[i + j] # pat[j] THEN found := FALSE END; INC(j) END; IF NOT found THEN INC(i) ELSE IF m > n THEN tail := sessUsed; k := m - n; IF tail + k <= HIGH(sessBuf) THEN WHILE tail > i + n DO DEC(tail); sessBuf[tail + k] := sessBuf[tail] END; sessUsed := sessUsed + k END ELSIF m < n THEN tail := i + n; k := n - m; WHILE tail < sessUsed DO sessBuf[tail - k] := sessBuf[tail]; INC(tail) END; sessUsed := sessUsed - k END; j := 0; WHILE j < m DO sessBuf[i + j] := rep[j]; INC(j) END; i := i + m END END; IF sessUsed <= HIGH(sessBuf) THEN sessBuf[sessUsed] := CHR(0) END END BufReplaceAll; PROCEDURE FwdPatchAll; (* Rewrites each forward placeholder into the real designator, and re-classes the load that reads through it. Loads are emitted by the frontend as " = load "; the default class is `w`, so for a `d`/`l` slot the opcode is rewritten to loadd/loadl. Stores are emitted as "store , "; the class letter of the store is rewritten in place. *) VAR k: INTEGER; ph, sym: QVal; c: CHAR; BEGIN k := 0; WHILE k < VAL(INTEGER, nFwd) DO IF fwdSite[k][0] # CHR(0) THEN FwdMangle(k + 1, ph); Cpy(sym, fwdSite[k]); IF fwdOper[k][0] = CHR(0) THEN c := "w" ELSE c := fwdOper[k][0] END; FixLoadClass(ph, c); FixStoreClass(ph, c); BufReplaceAll(ph, sym) END; INC(k) END; nFwd := 0 END FwdPatchAll; (* ---------------- exported helpers ---------------- *) PROCEDURE CopyOp (s: ARRAY OF CHAR; VAR d: ARRAY OF CHAR); BEGIN Cpy(d, s) END CopyOp; PROCEDURE NoteAddr (val: ARRAY OF CHAR; addr: ARRAY OF CHAR); (* Records value-temp → address mapping for VAR actuals. Ring of 256: safe because SSA temps are never reused (stale entries can never false-match, only age out on pathological expressions). *) BEGIN Cpy(nVal[nn], val); Cpy(nAddr[nn], addr); nn := nn + 1; IF nn > HIGH(nVal) THEN nn := 0 END END NoteAddr; PROCEDURE AddrOfVal (val: ARRAY OF CHAR; VAR addr: QVal): BOOLEAN; VAR i : CARDINAL; BEGIN i := 0; WHILE i <= HIGH(nVal) DO IF SymTab.Equal(nVal[i], val) THEN Cpy(addr, nAddr[i]); RETURN TRUE END; INC(i) END; RETURN FALSE END AddrOfVal; PROCEDURE AddrOf (name: ARRAY OF CHAR; VAR q: QVal); VAR idx : INTEGER; levels : CARDINAL; BEGIN IF LocFindUp(name, levels, idx) THEN IF levels = 0 THEN IF locTag[idx] = 1 THEN Cpy(q, "$"); App(q, locRep[idx]) ELSE Cpy(q, locRep[idx]) END ELSE UpAddrOf(idx, levels, q) END; RETURN END; SymRef(name, q) END AddrOf; PROCEDURE IntStr (v: INTEGER; VAR s: QVal); VAR neg : BOOLEAN; mag : CARDINAL; buf : ARRAY [0 .. 15] OF CHAR; n, i, L : CARDINAL; t : CHAR; BEGIN neg := v < 0; IF neg THEN mag := VAL(CARDINAL, -v) ELSE mag := VAL(CARDINAL, v) END; n := 0; IF mag = 0 THEN buf[0] := "0"; n := 1 END; WHILE (mag > 0) AND (n < HIGH(buf)) DO buf[n] := CHR(ORD("0") + mag MOD 10); mag := mag DIV 10; INC(n) END; i := 0; WHILE i < n DIV 2 DO t := buf[i]; buf[i] := buf[n - 1 - i]; buf[n - 1 - i] := t; INC(i) END; s[0] := CHR(0); IF neg THEN App(s, "-") END; i := 0; WHILE i < n DO L := Len(s); IF L < HIGH(s) THEN s[L] := buf[i]; s[L + 1] := CHR(0) END; INC(i) END END IntStr; PROCEDURE HexVal (ch: CHAR): INTEGER; BEGIN IF (ch >= "0") AND (ch <= "9") THEN RETURN ORD(ch) - ORD("0") END; IF (ch >= "A") AND (ch <= "F") THEN RETURN ORD(ch) - ORD("A") + 10 END; IF (ch >= "a") AND (ch <= "f") THEN RETURN ORD(ch) - ORD("a") + 10 END; RETURN 0 END HexVal; PROCEDURE NormInt (s: ARRAY OF CHAR; VAR d: QVal); (* "0xFF" -> "255", plain decimals are copied through. *) VAR n, i : CARDINAL; v : INTEGER; BEGIN n := Len(s); IF (n > 2) AND (s[0] = "0") AND ((s[1] = "x") OR (s[1] = "X")) THEN v := 0; i := 2; WHILE i < n DO v := v * 16 + HexVal(s[i]); INC(i) END; IntStr(v, d) ELSE Cpy(d, s) END END NormInt; PROCEDURE NormLit (s: ARRAY OF CHAR; VAR d: QVal; VAR isCh: BOOLEAN); (* Full V3 integer literal: octal B/b, hex H/h and C/c suffixes plus the 0x/0X prefix; C marks a character constant. The suffix letter is excluded from the digit run (HexVal would read 'B' as 11). A 0x/0X prefix takes priority over any trailing B/C/H (C-style hex digits, so 0xB is 11, never an octal suffix). *) VAR n, i, hi, base : CARDINAL; v : INTEGER; ch : CHAR; BEGIN n := Len(s); isCh := FALSE; IF n = 0 THEN Cpy(d, "0"); RETURN END; i := 0; IF (n >= 3) AND (s[0] = "0") AND ((s[1] = "x") OR (s[1] = "X")) THEN base := 16; hi := n; i := 2 ELSE ch := s[n - 1]; IF (ch = "B") OR (ch = "b") THEN base := 8; hi := n - 1 ELSIF (ch = "H") OR (ch = "h") THEN base := 16; hi := n - 1 ELSIF (ch = "C") OR (ch = "c") THEN base := 16; hi := n - 1; isCh := TRUE ELSE base := 10; hi := n END END; v := 0; WHILE i < hi DO v := v * VAL(INTEGER, base) + HexVal(s[i]); INC(i) END; IntStr(v, d) END NormLit; PROCEDURE NormReal (s: ARRAY OF CHAR; VAR d: QVal); (* "3.14" -> "d_3.14" (QBE double immediates carry a d_ prefix). *) BEGIN Cpy(d, "d_"); App(d, s) END NormReal; PROCEDURE CharVal (s: ARRAY OF CHAR): INTEGER; BEGIN IF Len(s) >= 2 THEN RETURN ORD(s[1]) END; RETURN 0 END CharVal; PROCEDURE NegFold (a: ARRAY OF CHAR; VAR q: QVal); (* Safe for a and q being the same variable. *) VAR i, j, L : CARDINAL; tmp : QVal; BEGIN Cpy(tmp, a); IF Len(tmp) = 0 THEN Cpy(q, "0"); RETURN END; IF tmp[0] = "-" THEN i := 1; j := 0; WHILE (tmp[i] # CHR(0)) AND (j < HIGH(q)) DO q[j] := tmp[i]; INC(i); INC(j) END; IF j <= HIGH(q) THEN q[j] := CHR(0) END ELSIF (tmp[0] = "d") AND (Len(tmp) > 1) AND (tmp[1] = "_") THEN Cpy(q, "d_-"); i := 2; WHILE tmp[i] # CHR(0) DO L := Len(q); IF L < HIGH(q) THEN q[L] := tmp[i]; q[L + 1] := CHR(0) END; INC(i) END ELSE Cpy(q, "-"); App(q, tmp) END END NegFold; PROCEDURE IsImm (s: ARRAY OF CHAR): BOOLEAN; BEGIN IF Len(s) = 0 THEN RETURN FALSE END; RETURN ((s[0] >= "0") AND (s[0] <= "9")) OR (s[0] = "-") OR (s[0] = "d") END IsImm; PROCEDURE ParseInt (s: ARRAY OF CHAR; VAR v: INTEGER): BOOLEAN; VAR i, nd, d: CARDINAL; neg: BOOLEAN; BEGIN v := 0; i := 0; neg := FALSE; nd := 0; IF (i <= HIGH(s)) AND (s[i] = "-") THEN neg := TRUE; INC(i) END; IF (i > HIGH(s)) OR (s[i] = CHR(0)) THEN RETURN FALSE END; WHILE (i <= HIGH(s)) AND (s[i] # CHR(0)) DO d := ORD(s[i]); IF (d < ORD("0")) OR (d > ORD("9")) THEN RETURN FALSE END; v := v * 10 + VAL(INTEGER, d - ORD("0")); INC(i); INC(nd) END; IF nd = 0 THEN RETURN FALSE END; IF neg THEN v := -v END; RETURN TRUE END ParseInt; PROCEDURE Fold2 (kind: INTEGER; a, b: ARRAY OF CHAR; VAR r: QVal): BOOLEAN; VAR x, y, z: INTEGER; BEGIN IF NOT ParseInt(a, x) THEN RETURN FALSE END; IF NOT ParseInt(b, y) THEN RETURN FALSE END; IF kind = 0 THEN z := x + y ELSIF kind = 1 THEN z := x - y ELSIF kind = 2 THEN z := x * y ELSIF kind = 3 THEN IF y = 0 THEN RETURN FALSE END; z := x DIV y ELSE IF y = 0 THEN RETURN FALSE END; z := x MOD y END; IntStr(z, r); RETURN TRUE END Fold2; (* ---------------- module / data section ---------------- *) PROCEDURE OpenModule (name: ARRAY OF CHAR); VAR i : CARDINAL; BEGIN opened := TRUE; inBody := FALSE; dead := FALSE; nTemp := 0; nLab := 0; loopTop := 0; nR := 0; nStr := 0; withTop := 0; noEmit := FALSE; inFunc := FALSE; useStack := FALSE; ctorN := 0; ctorTop := 0; nLoc := 0; nPar := 0; nArg := 0; nn := 0; callDepth := 0; recvArmed := FALSE; funcDepth := 0; scopeTop := 0; scopeBase[0] := 0; nInit := 0; outSel := 0; sessUsed := 0; sessBuf[0] := CHR(0); delayTop := 0; ustrN := 0; ustrUsed := 0; i := 0; WHILE i <= HIGH(nestBufs) DO nestBufs[i][0] := CHR(0); nestUsed[i] := 0; INC(i) END; WL("# QBE IR generated by the V3 step-1 backend"); WL("") END OpenModule; PROCEDURE DataLine (name: ARRAY OF CHAR; isReal: BOOLEAN; init: ARRAY OF CHAR); BEGIN IF NOT opened THEN RETURN END; W("data $"); W(name); IF isReal THEN W(" = { d ") ELSE W(" = { w ") END; W(init); WL(" }") END DataLine; PROCEDURE DataLineL (name: ARRAY OF CHAR; init: ARRAY OF CHAR); BEGIN IF NOT opened THEN RETURN END; W("data $"); W(name); W(" = { l "); W(init); WL(" }") END DataLineL; PROCEDURE DeclLocal (name: ARRAY OF CHAR; t: INTEGER); (* Function-local variable: stack slot + static init, recorded. *) VAR slot : QVal; BEGIN AllocLocal(t, slot); LocAdd(name, 0, slot, ResClass(t), t) END DeclLocal; PROCEDURE DeclVar (name: ARRAY OF CHAR; t: INTEGER); (* Module-level variable: emitted as data "$_". *) VAR g : QVal; BEGIN IF inFunc THEN DeclLocal(name, t); RETURN END; Cpy(g, curModName); App(g, "_"); App(g, name); IF SymTab.ClassOf(t) = SymTab.ClReal THEN DataLine(g, TRUE, "0") ELSIF SymTab.ClassOf(t) = SymTab.ClArray THEN DeclArr(g, t) ELSIF SymTab.ClassOf(t) = SymTab.ClSet THEN DeclSet(g, t) ELSIF (SymTab.ClassOf(t) = SymTab.ClRecord) OR (SymTab.ClassOf(t) = SymTab.ClClass) THEN DeclRec(g, t) ELSIF (SymTab.ClassOf(t) = SymTab.ClPtr) OR (SymTab.ClassOf(t) = SymTab.ClLong) OR (SymTab.ClassOf(t) = SymTab.ClProc) THEN DataLineL(g, "0") ELSE DataLine(g, FALSE, "0") END END DeclVar; PROCEDURE IsZeroReal (val: ARRAY OF CHAR): BOOLEAN; (* TRUE when the "d_..." literal denotes zero (checked textually). *) VAR i : CARDINAL; seen : BOOLEAN; ch : CHAR; BEGIN i := 0; IF (Len(val) > 1) AND (val[0] = "d") AND (val[1] = "_") THEN i := 2 END; IF (Len(val) > i) AND (val[i] = "-") THEN INC(i) END; seen := FALSE; WHILE val[i] # CHR(0) DO ch := val[i]; IF (ch >= "0") AND (ch <= "9") THEN seen := TRUE; IF ch # "0" THEN RETURN FALSE END ELSIF (ch # ".") AND (ch # "E") AND (ch # "e") AND (ch # "+") AND (ch # "-") THEN RETURN FALSE END; INC(i) END; RETURN seen END IsZeroReal; PROCEDURE DeclConst (name: ARRAY OF CHAR; val: ARRAY OF CHAR; t: INTEGER); VAR cls : INTEGER; mang : QVal; BEGIN cls := SymTab.ClassOf(t); IF inFunc THEN Cpy(mang, funcName); App(mang, "_"); App(mang, name); LocAdd(name, 1, mang, ResClass(t), t) ELSE Cpy(mang, curModName); App(mang, "_"); App(mang, name) END; IF (cls = SymTab.ClStr) OR NOT IsImm(val) THEN DataLine(mang, FALSE, "0"); RETURN END; IF cls = SymTab.ClLong THEN DataLineL(mang, val) ELSIF cls = SymTab.ClReal THEN (* This qbe accepts only integer/zero literals in "data": non-zero REALs flush at BeginBody. *) DataLine(mang, TRUE, "0"); IF NOT IsZeroReal(val) AND (nR <= HIGH(rNames)) THEN Cpy(rNames[nR], mang); Cpy(rVals[nR], val); INC(nR) END ELSE DataLine(mang, FALSE, val) END END DeclConst; (* ---------------- function body ---------------- *) PROCEDURE BeginInit (mod: ARRAY OF CHAR); (* Module BEGIN body as `_init`; main calls it at startup. *) VAR sym : QVal; BEGIN IF NOT opened THEN RETURN END; Cpy(sym, mod); App(sym, "_init"); WL(""); W("export function w $"); W(sym); WL("() {"); WL("@start"); IF nInit <= HIGH(initNames) THEN Cpy(initNames[nInit], sym); INC(nInit) END END BeginInit; PROCEDURE EndInit; BEGIN Revive; WL(" ret 0"); WL("}") END EndInit; PROCEDURE BeginBody; VAR i : CARDINAL; t : QVal; BEGIN IF NOT opened OR inBody THEN RETURN END; WL(""); WL("export function w $main() {"); WL("@start"); inBody := TRUE; i := 0; WHILE i < nR DO NewTemp(t); W(" "); W(t); W(" =d copy "); WL(rVals[i]); StoreVar(rNames[i], t, TRUE); INC(i) END; i := 0; WHILE i < nInit DO W(" call $"); W(initNames[i]); WL("()"); INC(i) END END BeginBody; PROCEDURE CloseModule; BEGIN IF NOT opened THEN RETURN END; WL("# no code: unit lowering waits for step 4"); FileIO.Close(out); opened := FALSE END CloseModule; PROCEDURE EndModule (name: ARRAY OF CHAR); VAR i : CARDINAL; fname : ARRAY [0 .. 127] OF CHAR; ref : QVal; BEGIN IF NOT opened THEN RETURN END; IF NOT inBody THEN BeginBody END; IF SymTab.Lookup("ExitCode") AND (SymTab.SymKind("ExitCode") = SymTab.KindVar) AND SymTab.IsIntFamily(SymTab.SymType("ExitCode")) THEN Cpy(ref, "$"); App(ref, name); App(ref, "_ExitCode"); W(" %ec =w loadw "); WL(ref); WL(" ret %ec") ELSE WL(" ret 0") END; WL("}"); (* hoisted nested functions, then deferred data *) i := 0; WHILE i <= HIGH(nestBufs) DO IF nestUsed[i] > 0 THEN BufApp(sessBuf, sessUsed, nestBufs[i], FALSE) END; INC(i) END; FlushStrings; FlushUStrings; FlushCtors; EmitVTables; FwdPatchAll; (* the image is named after the program module *) fname[0] := CHR(0); App(fname, "gen_ssa/"); App(fname, name); App(fname, ".ssa"); FileIO.Open(out, fname, TRUE); IF FileIO.Okay THEN (* Flush exactly sessUsed bytes. FileIO.WriteString scans for a NUL and misbehaves for multi-megabyte buffers, so write the image byte by byte up to sessUsed. *) i := 0; WHILE i < sessUsed DO FileIO.Write(out, sessBuf[i]); INC(i) END END; FileIO.Close(out); opened := FALSE END EndModule; (* ---------------- functions and calls (step 4.1) ---------------- *) (* Module-level procedures only (nested → NoEmit until 4.2). Value params arrive as SSA values and are copied to slots; composite value params arrive as addresses and are copied; VAR params stay addresses. Locals live in stack slots. *) PROCEDURE LocFind (name: ARRAY OF CHAR): INTEGER; VAR i : CARDINAL; BEGIN i := 0; WHILE i < nLoc DO IF SymTab.Equal(locNames[i], name) THEN RETURN VAL(INTEGER, i) END; INC(i) END; RETURN -1 END LocFind; PROCEDURE ScopeBegin; (* Pushes a procedure scope (always balanced, even under NoEmit). *) BEGIN IF scopeTop > HIGH(scopeLink) THEN RETURN END; scopeBase[scopeTop] := nLoc; INC(scopeTop); scopeBase[scopeTop] := nLoc END ScopeBegin; PROCEDURE ScopeEnd; BEGIN IF scopeTop > 0 THEN DEC(scopeTop); nLoc := scopeBase[scopeTop] END END ScopeEnd; PROCEDURE LocFindUp (name: ARRAY OF CHAR; VAR levels: CARDINAL; VAR flat: INTEGER): BOOLEAN; (* Innermost procedure scope holding name; levels = scopes crossed, flat = table index. FALSE when purely global. *) VAR s, top, lo, hi, j : CARDINAL; BEGIN levels := 0; flat := -1; IF scopeTop = 0 THEN RETURN FALSE END; top := scopeTop - 1; s := top; LOOP lo := scopeBase[s]; IF s = top THEN hi := nLoc ELSE hi := scopeBase[s + 1] END; j := lo; WHILE j < hi DO IF SymTab.Equal(locNames[j], name) THEN levels := top - s; flat := VAL(INTEGER, j); RETURN TRUE END; INC(j) END; IF s = 0 THEN RETURN FALSE END; DEC(s) END END LocFindUp; PROCEDURE LocAdd (name: ARRAY OF CHAR; tag: INTEGER; rep: ARRAY OF CHAR; cls: CHAR; typ: INTEGER); VAR idx : CARDINAL; off : QVal; lk : QVal; BEGIN IF noEmit THEN RETURN END; IF (scopeTop = 0) OR (nLoc > HIGH(locNames)) THEN RETURN END; idx := nLoc - scopeBase[scopeTop - 1]; IF idx > 63 THEN RETURN END; Cpy(locNames[nLoc], name); locTag[nLoc] := tag; Cpy(locRep[nLoc], rep); locCls[nLoc] := cls; locTyp[nLoc] := typ; INC(nLoc); IF tag = 1 THEN RETURN END; Cpy(lk, scopeLink[scopeTop - 1]); IntStr(VAL(INTEGER, 8 * (idx + 1)), off); NewTemp(lk); Op3L("add", lk, scopeLink[scopeTop - 1], off); Revive; W(" storel "); W(rep); W(", "); WL(lk) END LocAdd; PROCEDURE LocFull (): BOOLEAN; (* TRUE past 64 locals in the current scope (→ 233). *) BEGIN IF scopeTop = 0 THEN RETURN FALSE END; RETURN nLoc - scopeBase[scopeTop - 1] > 63 END LocFull; PROCEDURE UpAddr (levels: CARDINAL; rel: CARDINAL; VAR q: QVal); (* Address of an up-level local: walks the static chain, then loads the link cell (slot address or actual address). *) VAR cur, t, off : QVal; L : CARDINAL; BEGIN Cpy(cur, scopeLink[scopeTop - 1]); L := levels; WHILE L > 0 DO NewTemp(t); Revive; W(" "); W(t); W(" =l loadl "); WL(cur); Cpy(cur, t); DEC(L) END; IntStr(VAL(INTEGER, 8 * (rel + 1)), off); NewTemp(t); Op3L("add", t, cur, off); NewTemp(q); Revive; W(" "); W(q); W(" =l loadl "); WL(t) END UpAddr; PROCEDURE ResClass (t: INTEGER): CHAR; VAR cls : INTEGER; BEGIN cls := SymTab.ClassOf(t); IF cls = SymTab.ClReal THEN RETURN "d" END; IF (cls = SymTab.ClArray) OR (cls = SymTab.ClSet) OR (cls = SymTab.ClRecord) OR (cls = SymTab.ClClass) OR (cls = SymTab.ClPtr) OR (cls = SymTab.ClLong) OR (cls = SymTab.ClProc) THEN RETURN "l" END; RETURN "w" END ResClass; PROCEDURE Mangled (pname: ARRAY OF CHAR; uid: CARDINAL; VAR q: QVal); (* External procedures bind to their C link name; everything else mangles to _ (deterministic, collision-free). *) VAR link, base : SymTab.Name; BEGIN IF SymTab.ProcLink(pname, link) THEN Cpy(q, link); RETURN END; IF NOT SymTab.SymBase(pname, base) THEN Cpy(base, pname) END; Cpy(q, base); App(q, "_"); AppNum(q, uid) END Mangled; PROCEDURE AllocLocal (t: INTEGER; VAR slot: QVal); (* Stack slot sized for t's inline footprint; arrays/records get full objects + static init. Scalar/pointer/set slots are zero-initialized: QBE rejects reads of never-stored slots, and the frontend emits a dead load for assignment targets (Test2 heritage, harmless for zero-initialized globals). Locals match the globals' zero-init convention. *) VAR cls : INTEGER; nb : QVal; BEGIN cls := SymTab.ClassOf(t); NewTemp(slot); Revive; W(" "); W(slot); IF (cls = SymTab.ClArray) THEN IntStr(VAL(INTEGER, HeapSize(t)), nb); W(" =l alloc8 "); WL(nb); InitStack(slot, t) ELSIF (cls = SymTab.ClRecord) OR (cls = SymTab.ClClass) THEN IntStr(VAL(INTEGER, SymTab.TypeSize(t)), nb); W(" =l alloc8 "); WL(nb); InitStack(slot, t) ELSIF cls = SymTab.ClSet THEN IntStr(VAL(INTEGER, SymTab.SetWords(t) * 4), nb); W(" =l alloc8 "); WL(nb); SetZero(slot, SymTab.SetWords(t)) ELSIF cls = SymTab.ClReal THEN W(" =l alloc8 8"); WL(""); W(" stored d_0.0, "); WL(slot) ELSIF (cls = SymTab.ClPtr) OR (cls = SymTab.ClLong) OR (cls = SymTab.ClProc) THEN W(" =l alloc8 8"); WL(""); W(" storel 0, "); WL(slot) ELSE W(" =l alloc4 4"); WL(""); W(" storew 0, "); WL(slot) END END AllocLocal; PROCEDURE BeginFunc (mangled: ARRAY OF CHAR); (* Opens function context and scope; the header (with a leading static-link param) buffers until EndFuncHeader. FORWARD/DefUnit paths discard via AbortFunc. *) BEGIN ScopeBegin; INC(funcDepth); inFunc := TRUE; nPar := 0; funcRes := "w"; Cpy(funcName, mangled); hbuf[0] := CHR(0); NewTemp(slTmp); HApp("l "); HApp(slTmp); hdrComma := TRUE; IF funcDepth > 1 THEN outSel := funcDepth - 1; IF outSel > HIGH(nestBufs) + 1 THEN outSel := HIGH(nestBufs) + 1 END ELSE outSel := 0 END END BeginFunc; PROCEDURE SetFuncRes (t: INTEGER); BEGIN funcRes := ResClass(t) END SetFuncRes; PROCEDURE HApp (s: ARRAY OF CHAR); (* Appends to the header buffer (bounded: FormalParams cap it). *) VAR i, j : CARDINAL; BEGIN i := 0; WHILE (i <= HIGH(hbuf)) AND (hbuf[i] # CHR(0)) DO INC(i) END; j := 0; WHILE (i < HIGH(hbuf)) AND (j <= HIGH(s)) AND (s[j] # CHR(0)) DO hbuf[i] := s[j]; INC(i); INC(j) END; IF i <= HIGH(hbuf) THEN hbuf[i] := CHR(0) END END HApp; PROCEDURE FuncParam (name: ARRAY OF CHAR; isVar: BOOLEAN; t: INTEGER): BOOLEAN; VAR c : CHAR; tmp : QVal; buf : ARRAY [0 .. 71] OF CHAR; BEGIN IF noEmit THEN RETURN TRUE END; IF nPar > HIGH(parCls) THEN RETURN FALSE END; IF isVar THEN c := "l" ELSE c := ResClass(t) END; parCls[nPar] := c; NewTemp(tmp); Cpy(parTmp[nPar], tmp); Cpy(parNam[nPar], name); parVar[nPar] := isVar; parTyp[nPar] := t; IF hdrComma THEN HApp(", ") END; hdrComma := TRUE; buf[0] := c; buf[1] := " "; buf[2] := CHR(0); App(buf, tmp); HApp(buf); INC(nPar); RETURN TRUE END FuncParam; PROCEDURE EndFuncHeader; (* Flushes the buffered header + body label, allocates the link record ([0] = parent link), then emits entry copies. *) VAR i : CARDINAL; slot, nb, lk : QVal; cls : INTEGER; BEGIN W("export function "); Wc(funcRes); W(" $"); W(funcName); W("("); W(hbuf); WL(") {"); WL("@start"); inBody := TRUE; NewTemp(lk); Cpy(scopeLink[scopeTop - 1], lk); Revive; W(" "); W(lk); W(" =l alloc8 520"); WL(""); W(" storel "); W(slTmp); W(", "); WL(lk); i := 0; WHILE i < nPar DO cls := SymTab.ClassOf(parTyp[i]); IF parVar[i] THEN LocAdd(parNam[i], 2, parTmp[i], parCls[i], parTyp[i]) ELSE AllocLocal(parTyp[i], slot); LocAdd(parNam[i], 0, slot, parCls[i], parTyp[i]); IF cls = SymTab.ClArray THEN CopyArray(slot, parTmp[i], parTyp[i]) ELSIF cls = SymTab.ClSet THEN CopySet(slot, parTmp[i], SymTab.SetWords(parTyp[i]), SymTab.SetWords(parTyp[i])) ELSIF (cls = SymTab.ClRecord) OR (cls = SymTab.ClClass) THEN CopyRecord(slot, parTmp[i], parTyp[i]) ELSIF cls = SymTab.ClReal THEN Revive; W(" stored "); W(parTmp[i]); W(", "); WL(slot) ELSIF (cls = SymTab.ClPtr) OR (cls = SymTab.ClProc) OR (cls = SymTab.ClLong) THEN Revive; W(" storel "); W(parTmp[i]); W(", "); WL(slot) ELSE Revive; W(" storew "); W(parTmp[i]); W(", "); WL(slot) END END; INC(i) END END EndFuncHeader; PROCEDURE AbortFunc; (* Discards function context without emitting (DefUnit headings, FORWARD, methods): pops the scope, restores the depth. *) BEGIN ScopeEnd; IF funcDepth > 0 THEN DEC(funcDepth) END; inFunc := funcDepth > 0; inBody := FALSE; nPar := 0; IF funcDepth > 1 THEN outSel := funcDepth - 1 ELSE outSel := 0 END END AbortFunc; PROCEDURE EndFunc (resT: INTEGER); VAR rc : CHAR; BEGIN rc := ResClass(resT); Revive; IF rc = "d" THEN WL(" ret d_0.0") ELSIF rc = "l" THEN WL(" ret 0") ELSE WL(" ret 0") END; WL("}"); ScopeEnd; IF funcDepth > 0 THEN DEC(funcDepth) END; inFunc := funcDepth > 0; inBody := FALSE; IF funcDepth > 1 THEN outSel := funcDepth - 1 ELSE outSel := 0 END END EndFunc; PROCEDURE EmitRet (q: ARRAY OF CHAR; hasVal: BOOLEAN); BEGIN Revive; IF hasVal THEN W(" ret "); WL(q) ELSE WL(" ret 0") END; dead := TRUE END EmitRet; PROCEDURE ProcAddr (mangled: ARRAY OF CHAR; VAR q: QVal); BEGIN Cpy(q, "$"); App(q, mangled) END ProcAddr; PROCEDURE CallBeginInd (callee: ARRAY OF CHAR; resT: INTEGER; isExt: BOOLEAN); (* Indirect call through the code pointer in `callee`. *) BEGIN IF callDepth > HIGH(stkName) THEN RETURN END; Cpy(stkName[callDepth], callee); stkRes[callDepth] := ResClass(resT); stkExt[callDepth] := isExt; stkInd[callDepth] := TRUE; Cpy(stkLink[callDepth], "0"); stkArg[callDepth][0] := CHR(0); stkN[callDepth] := 0; INC(callDepth); IF recvArmed THEN IF NOT CallArg(recvQ, "l") THEN END; recvArmed := FALSE END END CallBeginInd; PROCEDURE VirtCallBegin (obj: ARRAY OF CHAR; slot: INTEGER; resT: INTEGER); (* Virtual dispatch: load obj's vtable pointer, fetch slot `slot`, and begin an indirect call through it. The receiver (obj) must be armed (ArmRecv). *) VAR vt, off, ea, fp: QVal; BEGIN NewTemp(vt); W(" "); W(vt); W(" =l loadl "); WL(obj); IntStr(slot * 8, off); NewTemp(ea); Op3L("add", ea, vt, off); NewTemp(fp); W(" "); W(fp); W(" =l loadl "); WL(ea); CallBeginInd(fp, resT, FALSE) END VirtCallBegin; PROCEDURE ArmRecv (q: ARRAY OF CHAR); (* Arms the receiver for the next class-method call: CallBegin passes it as the hidden first argument. *) BEGIN Cpy(recvQ, q); recvArmed := TRUE END ArmRecv; PROCEDURE CallBegin (mangled: ARRAY OF CHAR; resT: INTEGER; fdep: CARDINAL; isExt: BOOLEAN); (* Pushes a call level; the static link is resolved now (caller context cannot change mid-call): module callers pass 0, others walk the chain (inFuncDepth - fdep) from their link record. External callees take no static link. *) VAR walks : INTEGER; cur, t : QVal; BEGIN IF callDepth > HIGH(stkName) THEN RETURN END; Cpy(stkName[callDepth], mangled); stkRes[callDepth] := ResClass(resT); stkExt[callDepth] := isExt; stkInd[callDepth] := FALSE; stkArg[callDepth][0] := CHR(0); stkN[callDepth] := 0; IF isExt THEN Cpy(stkLink[callDepth], "0") ELSIF funcDepth = 0 THEN Cpy(stkLink[callDepth], "0") ELSE walks := VAL(INTEGER, funcDepth) - VAL(INTEGER, fdep); Cpy(cur, scopeLink[scopeTop - 1]); WHILE walks > 0 DO NewTemp(t); Revive; W(" "); W(t); W(" =l loadl "); WL(cur); Cpy(cur, t); DEC(walks) END; Cpy(stkLink[callDepth], cur) END; INC(callDepth); IF recvArmed THEN (* class method: the receiver is the hidden first argument *) IF NOT CallArg(recvQ, "l") THEN END; recvArmed := FALSE END END CallBegin; PROCEDURE CallArg (q: ARRAY OF CHAR; cls: CHAR): BOOLEAN; (* Appends "c operand, " to the current level. FALSE when full. *) VAR need, have, i, j, d : CARDINAL; BEGIN d := callDepth - 1; IF callDepth = 0 THEN RETURN FALSE END; IF d > HIGH(stkArg) THEN d := HIGH(stkArg) END; need := Len(q) + 5; have := Len(stkArg[d]); IF (stkN[d] >= 64) OR (have + need > HIGH(stkArg[d])) THEN RETURN FALSE END; i := have; j := 0; stkArg[d][i] := cls; INC(i); stkArg[d][i] := " "; INC(i); WHILE q[j] # CHR(0) DO stkArg[d][i] := q[j]; INC(i); INC(j) END; stkArg[d][i] := ","; INC(i); stkArg[d][i] := " "; INC(i); stkArg[d][i] := CHR(0); INC(stkN[d]); RETURN TRUE END CallArg; PROCEDURE CallEnd (wantRes: BOOLEAN; VAR q: QVal); VAR i, d : CARDINAL; rc : CHAR; body : ARRAY [0 .. 1023] OF CHAR; BEGIN IF callDepth = 0 THEN Cpy(q, "0"); RETURN END; DEC(callDepth); d := callDepth; IF d > HIGH(stkArg) THEN d := HIGH(stkArg) END; Cpy(funcName, stkName[d]); rc := stkRes[d]; i := 0; WHILE (stkArg[d][i] # CHR(0)) AND (i < HIGH(body)) DO body[i] := stkArg[d][i]; INC(i) END; IF (i >= 2) AND (body[i-2] = ",") THEN body[i-2] := CHR(0) ELSE body[i] := CHR(0) END; Revive; IF wantRes THEN NewTemp(q); W(" "); W(q); W(" ="); Wc(rc) ELSE W(" ") END; IF stkInd[d] THEN W(" call "); W(funcName); W("(") (* callee operand already %-prefixed *) ELSE W(" call $"); W(funcName); W("(") END; IF stkExt[d] THEN W(body) (* C callee: no static link *) ELSE W("l "); W(stkLink[d]); IF body[0] # CHR(0) THEN W(", "); W(body) END END; WL(")") END CallEnd; PROCEDURE InitStack (addr: ARRAY OF CHAR; t: INTEGER); BEGIN useStack := TRUE; InitHeap(addr, t); useStack := FALSE END InitStack; PROCEDURE ArgClass (t: INTEGER): CHAR; (* Formal/actual class for call emission. *) BEGIN RETURN ResClass(t) END ArgClass; PROCEDURE CArg (q: ARRAY OF CHAR; t: INTEGER; VAR out: QVal; VAR cls: CHAR); BEGIN cls := ArgClass(t); IF SymTab.ClassOf(t) = SymTab.ClStr THEN NewTemp(out); Op3L("add", out, q, "8"); cls := "l" ELSIF (SymTab.ClassOf(t) = SymTab.ClArray) AND SymTab.IsCharArray(t) THEN NewTemp(out); Op3L("add", out, q, "8"); cls := "l" ELSE Cpy(out, q) END END CArg; PROCEDURE CArgAdd (q: ARRAY OF CHAR; t: INTEGER; VAR out: QVal; VAR cls: CHAR); BEGIN CArg(q, t, out, cls); IF NOT CallArg(out, cls) THEN END END CArgAdd; (* ---------------- temporaries and operators ---------------- *) PROCEDURE NewTemp (VAR t: QVal); BEGIN Cpy(t, "%t"); AppNum(t, nTemp); INC(nTemp) END NewTemp; PROCEDURE LocLoadFlat (idx: INTEGER; long: BOOLEAN; VAR q: QVal); (* Loads a same-scope entry: slots/data by class (or long for pointers), addr entries via ElemLoad. *) BEGIN IF locTag[idx] = 2 THEN ElemLoad(locRep[idx], locTyp[idx], q); RETURN END; NewTemp(q); Revive; W(" "); W(q); IF long THEN W(" =l loadl ") ELSIF locCls[idx] = "d" THEN W(" =d loadd ") ELSE W(" =w loadw ") END; IF locTag[idx] = 1 THEN W("$") END; WL(locRep[idx]) END LocLoadFlat; PROCEDURE LocStoreFlat (idx: INTEGER; q: ARRAY OF CHAR; long: BOOLEAN); (* Stores a same-scope entry: slots/data by class (or long), addr via ElemStore. Data stores are grammar-unreachable (consts). *) BEGIN IF locTag[idx] = 2 THEN ElemStore(locRep[idx], q, locTyp[idx]); RETURN END; Revive; IF long THEN W(" storel ") ELSIF locCls[idx] = "d" THEN W(" stored ") ELSE W(" storew ") END; W(q); W(", "); IF locTag[idx] = 1 THEN W("$") END; WL(locRep[idx]) END LocStoreFlat; PROCEDURE UpLoad (flat: INTEGER; levels: CARDINAL; long: BOOLEAN; VAR q: QVal); (* Up-level load: data entries live globally; otherwise the link cell yields the address and ElemLoad reads through it. *) VAR a : QVal; rel : CARDINAL; BEGIN IF locTag[flat] = 1 THEN NewTemp(q); Revive; W(" "); W(q); IF long THEN W(" =l loadl $") ELSIF locCls[flat] = "d" THEN W(" =d loadd $") ELSE W(" =w loadw $") END; WL(locRep[flat]); RETURN END; rel := VAL(CARDINAL, flat) - scopeBase[scopeTop - 1 - levels]; UpAddr(levels, rel, a); ElemLoad(a, locTyp[flat], q) END UpLoad; PROCEDURE UpStore (flat: INTEGER; levels: CARDINAL; q: ARRAY OF CHAR; long: BOOLEAN); VAR a : QVal; rel : CARDINAL; BEGIN IF locTag[flat] = 1 THEN Revive; IF long THEN W(" storel ") ELSIF locCls[flat] = "d" THEN W(" stored ") ELSE W(" storew ") END; W(q); W(", $"); WL(locRep[flat]); RETURN END; rel := VAL(CARDINAL, flat) - scopeBase[scopeTop - 1 - levels]; UpAddr(levels, rel, a); ElemStore(a, q, locTyp[flat]) END UpStore; PROCEDURE UpAddrOf (flat: INTEGER; levels: CARDINAL; VAR q: QVal); (* Up-level address: data entries name globals; otherwise the link cell holds it (composites) or points at it. For scalars the cell IS the usable address (slot or actual address). *) VAR a : QVal; rel : CARDINAL; BEGIN IF locTag[flat] = 1 THEN Cpy(q, "$"); App(q, locRep[flat]); RETURN END; rel := VAL(CARDINAL, flat) - scopeBase[scopeTop - 1 - levels]; UpAddr(levels, rel, q) END UpAddrOf; PROCEDURE LoadDesignator (name: ARRAY OF CHAR; t: INTEGER; k: INTEGER; VAR q: QVal): BOOLEAN; VAR cls : INTEGER; BEGIN cls := SymTab.ClassOf(t); IF SymTab.Equal(name, "TRUE") THEN Cpy(q, "1"); RETURN TRUE ELSIF SymTab.Equal(name, "FALSE") THEN Cpy(q, "0"); RETURN TRUE ELSIF SymTab.Equal(name, "NIL") THEN Cpy(q, "0"); RETURN TRUE END; IF (k = SymTab.KindVar) OR (k = SymTab.KindParam) OR (k = SymTab.KindConst) THEN IF (cls = SymTab.ClInt) OR (cls = SymTab.ClBool) OR (cls = SymTab.ClChar) OR (cls = SymTab.ClReal) THEN LoadVar(name, cls = SymTab.ClReal, q); RETURN TRUE ELSIF (cls = SymTab.ClPtr) OR (cls = SymTab.ClProc) THEN LoadPtr(name, q); RETURN TRUE ELSIF (cls = SymTab.ClArray) OR (cls = SymTab.ClSet) OR (cls = SymTab.ClRecord) OR (cls = SymTab.ClClass) THEN AddrOf(name, q); RETURN TRUE END END; Cpy(q, "0"); RETURN FALSE END LoadDesignator; PROCEDURE LoadVar (name: ARRAY OF CHAR; isReal: BOOLEAN; VAR q: QVal); VAR idx : INTEGER; levels : CARDINAL; ref : QVal; BEGIN IF LocFindUp(name, levels, idx) THEN IF levels = 0 THEN LocLoadFlat(idx, FALSE, q) ELSE UpLoad(idx, levels, FALSE, q) END; RETURN END; NewTemp(q); Revive; SymRef(name, ref); W(" "); W(q); IF isReal THEN W(" =d loadd ") ELSE W(" =w loadw ") END; WL(ref) END LoadVar; PROCEDURE LoadPtr (name: ARRAY OF CHAR; VAR q: QVal); VAR idx : INTEGER; levels : CARDINAL; ref : QVal; BEGIN IF LocFindUp(name, levels, idx) THEN IF levels = 0 THEN LocLoadFlat(idx, TRUE, q) ELSE UpLoad(idx, levels, TRUE, q) END; RETURN END; NewTemp(q); Revive; SymRef(name, ref); W(" "); W(q); W(" =l loadl "); WL(ref) END LoadPtr; PROCEDURE LoadLong (name: ARRAY OF CHAR; VAR q: QVal); VAR idx : INTEGER; levels : CARDINAL; ref : QVal; BEGIN IF LocFindUp(name, levels, idx) THEN IF levels = 0 THEN LocLoadFlat(idx, TRUE, q) ELSE UpLoad(idx, levels, TRUE, q) END; RETURN END; NewTemp(q); Revive; SymRef(name, ref); W(" "); W(q); W(" =l loadl "); WL(ref) END LoadLong; PROCEDURE StoreLong (name: ARRAY OF CHAR; q: ARRAY OF CHAR); VAR idx : INTEGER; levels : CARDINAL; ref : QVal; BEGIN IF LocFindUp(name, levels, idx) THEN IF levels = 0 THEN LocStoreFlat(idx, q, TRUE) ELSE UpStore(idx, levels, q, TRUE) END; RETURN END; Revive; SymRef(name, ref); W(" storel "); W(q); W(", "); WL(ref) END StoreLong; PROCEDURE WidenLong (a: ARRAY OF CHAR; VAR q: QVal); (* INTEGER (w) -> LONGINT (l) via extsw. *) BEGIN NewTemp(q); Revive; W(" "); W(q); W(" =l extsw "); WL(a) END WidenLong; PROCEDURE CmpLong (op: INTEGER; l, r: ARRAY OF CHAR; VAR q: QVal); (* 64-bit comparison (result w). *) VAR mn : ARRAY [0 .. 7] OF CHAR; BEGIN mn[0] := CHR(0); IF op = SymTab.OpEq THEN Cpy(mn, "ceql") ELSIF (op = SymTab.OpNeq1) OR (op = SymTab.OpNeq2) THEN Cpy(mn, "cnel") ELSIF op = SymTab.OpLt THEN Cpy(mn, "csltl") ELSIF op = SymTab.OpLe THEN Cpy(mn, "cslel") ELSIF op = SymTab.OpGt THEN Cpy(mn, "csgtl") ELSE Cpy(mn, "csgel") END; NewTemp(q); Op3(mn, q, l, r, FALSE) END CmpLong; PROCEDURE StoreVar (name: ARRAY OF CHAR; q: ARRAY OF CHAR; isReal: BOOLEAN); VAR idx : INTEGER; levels : CARDINAL; ref : QVal; BEGIN IF LocFindUp(name, levels, idx) THEN IF levels = 0 THEN LocStoreFlat(idx, q, FALSE) ELSE UpStore(idx, levels, q, FALSE) END; RETURN END; Revive; SymRef(name, ref); IF isReal THEN W(" stored ") ELSE W(" storew ") END; W(q); W(", "); WL(ref) END StoreVar; PROCEDURE StorePtr (name: ARRAY OF CHAR; q: ARRAY OF CHAR); VAR idx : INTEGER; levels : CARDINAL; ref : QVal; BEGIN IF LocFindUp(name, levels, idx) THEN IF levels = 0 THEN LocStoreFlat(idx, q, TRUE) ELSE UpStore(idx, levels, q, TRUE) END; RETURN END; Revive; SymRef(name, ref); W(" storel "); W(q); W(", "); WL(ref) END StorePtr; PROCEDURE Op3 (mn: ARRAY OF CHAR; res, l, r: ARRAY OF CHAR; isReal: BOOLEAN); BEGIN Revive; W(" "); W(res); IF isReal THEN W(" =d ") ELSE W(" =w ") END; W(mn); W(" "); W(l); W(", "); WL(r) END Op3; PROCEDURE AbsQ (a: ARRAY OF CHAR; VAR q: QVal; isReal: BOOLEAN); VAR c, neg : QVal; lNeg, lPos, lDone : QVal; BEGIN IF isReal THEN Cmp(SymTab.OpLt, a, "d_0.0", c, TRUE) ELSE Cmp(SymTab.OpLt, a, "0", c, FALSE) END; NewLabel(lNeg); NewLabel(lPos); NewLabel(lDone); NewTemp(neg); NegQ(a, neg, isReal); Jnz(c, lNeg, lPos); EmitLabel(lNeg); CopyOp(neg, q); Jmp(lDone); EmitLabel(lPos); CopyOp(a, q); EmitLabel(lDone) END AbsQ; PROCEDURE NegQ (a: ARRAY OF CHAR; VAR q: QVal; isReal: BOOLEAN); BEGIN NewTemp(q); IF isReal THEN Op3("sub", q, "d_0.0", a, TRUE) ELSE Op3("sub", q, "0", a, FALSE) END END NegQ; PROCEDURE ConvIR (a: ARRAY OF CHAR; VAR q: QVal); (* INTEGER -> REAL widening for assignments (swtof). *) BEGIN NewTemp(q); Revive; W(" "); W(q); W(" =d swtof "); WL(a) END ConvIR; PROCEDURE NarrowLong (a: ARRAY OF CHAR; VAR q: QVal); (* LONGINT (l) -> INTEGER (w): keep the low 32 bits. *) BEGIN NewTemp(q); Revive; W(" "); W(q); W(" =w copy "); WL(a) END NarrowLong; PROCEDURE ConvRI (a: ARRAY OF CHAR; VAR q: QVal); (* REAL -> INTEGER (truncate toward zero). *) BEGIN NewTemp(q); Revive; W(" "); W(q); W(" =w dtosi "); WL(a) END ConvRI; PROCEDURE ConvRL (a: ARRAY OF CHAR; VAR q: QVal); (* REAL -> LONGINT (truncate toward zero). *) BEGIN NewTemp(q); Revive; W(" "); W(q); W(" =l dtosi "); WL(a) END ConvRL; PROCEDURE ConvLR (a: ARRAY OF CHAR; VAR q: QVal); (* LONGINT -> REAL. *) BEGIN NewTemp(q); Revive; W(" "); W(q); W(" =d sltof "); WL(a) END ConvLR; PROCEDURE NotQ (a: ARRAY OF CHAR; VAR q: QVal); BEGIN NewTemp(q); Op3("xor", q, "1", a, FALSE) END NotQ; PROCEDURE CapQ (a: ARRAY OF CHAR; VAR q: QVal); (* Branchless UPCASE: q := a - 32 * (a >= 'a' AND a <= 'z'). *) VAR lo, hi, in1, delta: QVal; BEGIN NewTemp(lo); Op3("csgew", lo, a, "97", FALSE); NewTemp(hi); Op3("cslew", hi, a, "122", FALSE); NewTemp(in1); Op3("and", in1, lo, hi, FALSE); NewTemp(delta); Op3("mul", delta, in1, "32", FALSE); NewTemp(q); Op3("sub", q, a, delta, FALSE) END CapQ; PROCEDURE NewLabel (VAR l: QVal); BEGIN Cpy(l, "@L"); AppNum(l, nLab); INC(nLab) END NewLabel; PROCEDURE Revive; (* Opens an unreachable block if past a terminator. Keeps every temporary defined and every instruction inside a block, even for dead source tails (EXIT followed by more statements) and CASE chains whose compares follow a Jmp. Counter-driven: fixpoint-safe. *) VAR b: QVal; BEGIN IF opened AND dead THEN NewLabel(b); WL(b); dead := FALSE END END Revive; PROCEDURE EmitLabel (l: ARRAY OF CHAR); BEGIN WL(l); dead := FALSE END EmitLabel; PROCEDURE Jmp (l: ARRAY OF CHAR); BEGIN IF dead THEN RETURN END; (* unreachable: a terminator with no intervening label can never be reached; emitting it would end the block and orphan whatever follows. *) W(" jmp "); WL(l); dead := TRUE END Jmp; PROCEDURE Jnz (c, t, f: ARRAY OF CHAR); BEGIN IF dead THEN RETURN END; W(" jnz "); W(c); W(", "); W(t); W(", "); WL(f); dead := TRUE END Jnz; PROCEDURE Cmp (op: INTEGER; l, r: ARRAY OF CHAR; VAR q: QVal; isReal: BOOLEAN); VAR mn : ARRAY [0 .. 7] OF CHAR; BEGIN mn[0] := CHR(0); IF isReal THEN IF op = SymTab.OpEq THEN Cpy(mn, "ceqd") ELSIF (op = SymTab.OpNeq1) OR (op = SymTab.OpNeq2) THEN Cpy(mn, "cned") ELSIF op = SymTab.OpLt THEN Cpy(mn, "cltd") ELSIF op = SymTab.OpLe THEN Cpy(mn, "cled") ELSIF op = SymTab.OpGt THEN Cpy(mn, "cgtd") ELSE Cpy(mn, "cged") END ELSE IF op = SymTab.OpEq THEN Cpy(mn, "ceqw") ELSIF (op = SymTab.OpNeq1) OR (op = SymTab.OpNeq2) THEN Cpy(mn, "cnew") ELSIF op = SymTab.OpLt THEN Cpy(mn, "csltw") ELSIF op = SymTab.OpLe THEN Cpy(mn, "cslew") ELSIF op = SymTab.OpGt THEN Cpy(mn, "csgtw") ELSE Cpy(mn, "csgew") END END; NewTemp(q); Op3(mn, q, l, r, FALSE) END Cmp; PROCEDURE StrEq (op: INTEGER; l, r: ARRAY OF CHAR; VAR q: QVal); (* String equality via the shim: q := (l = r) as a BOOLEAN, negated for OpNeq. Operands are descriptor addresses; the shim strcmps the NUL-terminated contents. *) VAR t: QVal; BEGIN NewTemp(q); W(" "); W(q); W(" =w call $m2streq(l "); W(l); W(", l "); W(r); WL(")"); IF (op = SymTab.OpNeq1) OR (op = SymTab.OpNeq2) THEN NewTemp(t); W(" "); W(t); W(" =w xor "); W(q); WL(", 1"); Cpy(q, t) END END StrEq; PROCEDURE StrLen (s: ARRAY OF CHAR; VAR q: QVal); (* q := the number of characters before the NUL (INTEGER). *) BEGIN NewTemp(q); W(" "); W(q); W(" =w call $m2strlen(l "); W(s); WL(")") END StrLen; PROCEDURE StrAssign (dst, src: ARRAY OF CHAR); (* Copy the string src into the CHAR array at dst (content copy, truncated to the destination capacity, NUL-terminated). *) BEGIN W(" call $m2strassign(l "); W(dst); W(", l "); W(src); WL(")") END StrAssign; PROCEDURE UAssign (dst, src: ARRAY OF CHAR); (* Copy a U"..." descriptor (count + 4-byte codepoints) into the UCHAR array at dst: min(count, capacity) codepoints + a 0 terminator. *) BEGIN W(" call $m2uassign(l "); W(dst); W(", l "); W(src); WL(")") END UAssign; PROCEDURE UStrLen (s: ARRAY OF CHAR; VAR q: QVal); (* q := the UString codepoint count (INTEGER). *) VAR t: QVal; BEGIN NewTemp(t); W(" "); W(t); W(" =w call $m2ustrlen(l "); W(s); WL(")"); Cpy(q, t) END UStrLen; PROCEDURE DecQ (VAR q: QVal); (* q := q - 1 (w domain; q is an INTEGER count). *) VAR t: QVal; BEGIN NewTemp(t); Op3("sub", t, q, "1", FALSE); Cpy(q, t) END DecQ; PROCEDURE UStrCat (a, b: ARRAY OF CHAR; VAR q: QVal); (* q := a + b (a UString descriptor in the shim's concat buffer). *) BEGIN NewTemp(q); W(" "); W(q); W(" =l call $m2ustrcat(l "); W(a); W(", l "); W(b); WL(")") END UStrCat; PROCEDURE UStrFrom (cp: ARRAY OF CHAR; VAR q: QVal); (* q := a 1-codepoint UString descriptor for the UCHAR value cp. *) BEGIN NewTemp(q); W(" "); W(q); W(" =l call $m2ustrfrom(l "); W(cp); WL(")") END UStrFrom; PROCEDURE StrCat (a, b: ARRAY OF CHAR; VAR q: QVal); (* q := a + b (a descriptor in the shim's concat buffer). *) BEGIN NewTemp(q); W(" "); W(q); W(" =l call $m2strcat(l "); W(a); W(", l "); W(b); WL(")") END StrCat; (* ---------------- arrays: length-prefixed layout ---------------- *) (* Indexes and counts are LONGCARD (l) in emitted code; immediates pass through, w-temps widen via extsw. Traps call $abort + hlt (interim; runtime/syslib/Trap replaces them later). *) PROCEDURE ElemCls (t: SymTab.TypeIndex): INTEGER; BEGIN RETURN SymTab.ClassOf(SymTab.ArrayElem(t)) END ElemCls; PROCEDURE ElemSize (t: SymTab.TypeIndex): CARDINAL; (* Storage size of t's elements: CHAR 1, REAL 8, nested/pointer 8, else 4. t is an array (or string) descriptor. *) VAR cls: INTEGER; BEGIN cls := SymTab.ClassOf(t); IF cls = SymTab.ClStr THEN RETURN 1 END; cls := ElemCls(t); IF cls = SymTab.ClChar THEN RETURN 1 ELSIF cls = SymTab.ClReal THEN RETURN 8 ELSIF (cls = SymTab.ClArray) OR (cls = SymTab.ClPtr) OR (cls = SymTab.ClLong) THEN RETURN 8 ELSE RETURN 4 END END ElemSize; PROCEDURE Op3L (mn: ARRAY OF CHAR; res, l, r: ARRAY OF CHAR); BEGIN Revive; W(" "); W(res); W(" =l "); W(mn); W(" "); W(l); W(", "); WL(r) END Op3L; PROCEDURE HaltQ; BEGIN Revive; WL(" call $exit(w 1)"); WL(" hlt"); dead := TRUE END HaltQ; PROCEDURE Trap; BEGIN Revive; WL(" call $abort()"); WL(" hlt"); dead := TRUE END Trap; (* ---------------- records: flat blobs, pointer fields ---------------- *) (* Scalars/sets inline, array fields as 8-byte pointers to static descriptors, nested records inline. Static offsets throughout. *) PROCEDURE ArrBodyItems (prefix: ARRAY OF CHAR; t: INTEGER); (* Inline contents of an array descriptor (no "data $name = {" wrapper and no closing brace): "l [, ...]". Nested levels are referenced as $prefix_i (emitted by ArrData). *) VAR n, i: CARDINAL; elem: SymTab.TypeIndex; ecls: INTEGER; esz: CARDINAL; bv: QVal; BEGIN n := SymTab.ArrayLen(t); elem := SymTab.ArrayElem(t); ecls := SymTab.ClassOf(elem); W("l "); IntStr(VAL(INTEGER, n), bv); W(bv); IF ecls = SymTab.ClArray THEN i := 0; WHILE i < n DO W(", l $"); W(prefix); W("_"); IntStr(VAL(INTEGER, i), bv); W(bv); INC(i) END ELSE IF ecls = SymTab.ClChar THEN (* CHAR: n data bytes + one NUL terminator slot *) W(", z "); IntStr(VAL(INTEGER, n + 1), bv); W(bv) ELSIF ecls = SymTab.ClUChar THEN (* UCHAR: n codepoints + one 0-codepoint terminator slot *) W(", z "); IntStr(VAL(INTEGER, (n + 1) * 4), bv); W(bv) ELSE IF (ecls = SymTab.ClReal) OR (ecls = SymTab.ClPtr) OR (ecls = SymTab.ClProc) THEN esz := 8 ELSE esz := 4 END; IF n > 0 THEN W(", z "); IntStr(VAL(INTEGER, n * esz), bv); W(bv) END END END END ArrBodyItems; PROCEDURE ArrData (name: ARRAY OF CHAR; t: INTEGER); (* "data $name = { }" plus, for nested levels, the recursive sub-descriptor data $name_i. *) VAR n, i: CARDINAL; elem: SymTab.TypeIndex; bv: QVal; sub: QVal; BEGIN IF NOT opened THEN RETURN END; W("data $"); W(name); W(" = { "); ArrBodyItems(name, t); WL(" }"); elem := SymTab.ArrayElem(t); IF SymTab.ClassOf(elem) = SymTab.ClArray THEN n := SymTab.ArrayLen(t); i := 0; WHILE i < n DO Cpy(sub, name); App(sub, "_"); IntStr(VAL(INTEGER, i), bv); App(sub, bv); ArrData(sub, elem); INC(i) END END END ArrData; PROCEDURE RecStatics (recname: ARRAY OF CHAR; t: SymTab.TypeIndex); (* Pre-pass: static sub-descriptors for NESTED array fields (the top-level array field is now inline in the record), recursive. *) VAR n, i, k, an: CARDINAL; fn: SymTab.Name; ft, et: SymTab.TypeIndex; cls: INTEGER; sub, bv: QVal; BEGIN n := SymTab.FieldCount(t); i := 0; WHILE i < n DO SymTab.FieldName(t, i, fn); ft := SymTab.FieldType(t, fn); cls := SymTab.ClassOf(ft); IF cls = SymTab.ClArray THEN et := SymTab.ArrayElem(ft); IF SymTab.ClassOf(et) = SymTab.ClArray THEN an := SymTab.ArrayLen(ft); k := 0; WHILE k < an DO Cpy(sub, recname); App(sub, "_"); App(sub, fn); App(sub, "_"); IntStr(VAL(INTEGER, k), bv); App(sub, bv); ArrData(sub, et); INC(k) END END ELSIF (cls = SymTab.ClRecord) OR (cls = SymTab.ClClass) THEN Cpy(sub, recname); App(sub, "_"); App(sub, fn); RecStatics(sub, ft) END; INC(i) END END RecStatics; PROCEDURE RecItems (t: SymTab.TypeIndex; prefix: ARRAY OF CHAR; VAR first: BOOLEAN); (* Comma-separated item list (no wrapper); nested records inline. Emission order follows the (prepend-built) field chain, i.e. reverse declaration; offsets (not positions) place everything. *) VAR n, i, k, w: CARDINAL; fn: SymTab.Name; ft: SymTab.TypeIndex; cls: INTEGER; sub: QVal; PROCEDURE Sep; BEGIN IF first THEN first := FALSE ELSE W(", ") END END Sep; BEGIN n := SymTab.FieldCount(t); i := 0; WHILE i < n DO SymTab.FieldName(t, i, fn); ft := SymTab.FieldType(t, fn); cls := SymTab.ClassOf(ft); IF cls = SymTab.ClReal THEN Sep; W("d 0") ELSIF cls = SymTab.ClChar THEN Sep; W("b 0") ELSIF cls = SymTab.ClArray THEN (* array field: inline descriptor (was a pointer) *) Sep; Cpy(sub, prefix); App(sub, "_"); App(sub, fn); ArrBodyItems(sub, ft) ELSIF cls = SymTab.ClSet THEN w := SymTab.SetWords(ft); IF w = 0 THEN w := 1 END; Sep; W("w 0"); k := 1; WHILE k < w DO W(", w 0"); INC(k) END ELSIF (cls = SymTab.ClRecord) OR (cls = SymTab.ClClass) THEN Cpy(sub, prefix); App(sub, "_"); App(sub, fn); RecItems(ft, sub, first) ELSE Sep; W("w 0") END; INC(i) END END RecItems; PROCEDURE VtRef (t: INTEGER; VAR q: QVal); (* The class's vtable symbol ($vt_). *) VAR bv: QVal; BEGIN Cpy(q, "$vt_"); IntStr(t, bv); App(q, bv) END VtRef; PROCEDURE EmitVTables; (* One data array per class with a vtable: slots (inherited first) as method code addresses. *) VAR k, j, n: CARDINAL; t: INTEGER; nm: SymTab.Name; mg, vt: QVal; BEGIN IF NOT opened THEN RETURN END; k := 0; WHILE k < SymTab.VtClassCount() DO t := SymTab.VtClassAt(k); n := SymTab.VtCount(t); VtRef(t, vt); W("data "); W(vt); W(" = { "); j := 0; WHILE j < n DO IF SymTab.VtName(t, j, nm) THEN IF j > 0 THEN W(", ") END; IF SymTab.VtHasBody(t, j) THEN Mangled(nm, SymTab.VtUid(t, j), mg); W("l $"); W(mg) ELSE W("l 0") (* declared but never implemented *) END END; INC(j) END; IF n = 0 THEN W("l 0") END; WL(" }"); INC(k) END END EmitVTables; PROCEDURE DeclRec (name: ARRAY OF CHAR; t: INTEGER); VAR first: BOOLEAN; vt, sz: QVal; BEGIN IF NOT opened THEN RETURN END; IF SymTab.IsVariant(t) AND (SymTab.ClassOf(t) = SymTab.ClRecord) THEN (* variant record: fields overlay, so emit one zero-filled blob of the record's (max) size *) IntStr(VAL(INTEGER, SymTab.TypeSize(t)), sz); W("data $"); W(name); W(" = { z "); W(sz); WL(" }"); RETURN END; RecStatics(name, t); W("data $"); W(name); W(" = { "); first := TRUE; (* a class with a vtable stores its vtable pointer at offset 0 *) IF (SymTab.ClassOf(t) = SymTab.ClClass) AND SymTab.HasVTable(t) THEN VtRef(t, vt); W("l "); W(vt); first := FALSE END; RecItems(t, name, first); IF first THEN W("w 0") END; WL(" }") END DeclRec; PROCEDURE FieldAddr (base: ARRAY OF CHAR; off: INTEGER; VAR q: QVal); VAR sb: QVal; BEGIN NewTemp(q); IntStr(off, sb); Op3L("add", q, base, sb) END FieldAddr; PROCEDURE ThisBase (VAR q: QVal); (* The current method's receiver address (the hidden THIS VAR param). *) BEGIN AddrOf("THIS", q) END ThisBase; PROCEDURE PushWith (base: ARRAY OF CHAR); BEGIN IF withTop <= HIGH(withSt) THEN Cpy(withSt[withTop], base); INC(withTop) END END PushWith; PROCEDURE PopWith; BEGIN IF withTop > 0 THEN DEC(withTop) END END PopWith; PROCEDURE TopWith (VAR base: QVal): BOOLEAN; BEGIN IF withTop = 0 THEN RETURN FALSE END; Cpy(base, withSt[withTop - 1]); RETURN TRUE END TopWith; PROCEDURE CopyRecord (dst: ARRAY OF CHAR; src: ARRAY OF CHAR; t: INTEGER); (* Whole-record copy: a flat byte blit of the record's (max) size. Records are flat blobs (scalars/sets/pointers inline, arrays and nested records inline), so this is correct — and the only correct choice for variant records, whose fields overlay. *) VAR n: QVal; BEGIN IntStr(VAL(INTEGER, SymTab.TypeSize(t)), n); Revive; W(" call $memcpy(l "); W(dst); W(", l "); W(src); W(", l "); W(n); WL(")") END CopyRecord; PROCEDURE WordsBytes (words: CARDINAL): CARDINAL; BEGIN IF words = 0 THEN RETURN 8 END; RETURN ((words * 4 + 7) DIV 8) * 8 END WordsBytes; PROCEDURE DeclSet (name: ARRAY OF CHAR; t: INTEGER); VAR w, i: CARDINAL; BEGIN IF NOT opened THEN RETURN END; w := SymTab.SetWords(t); IF w = 0 THEN w := 1 END; W("data $"); W(name); W(" = { w 0"); i := 1; WHILE i < w DO W(", w 0"); INC(i) END; WL(" }") END DeclSet; PROCEDURE NewSetTemp (words: CARDINAL; VAR q: QVal); VAR nb: QVal; BEGIN NewTemp(q); Revive; IntStr(VAL(INTEGER, WordsBytes(words)), nb); W(" "); W(q); W(" =l alloc8 "); WL(nb) END NewSetTemp; PROCEDURE SetZero (addr: ARRAY OF CHAR; words: CARDINAL); VAR i: CARDINAL; a, z, off: QVal; BEGIN NewTemp(z); Op3("xor", z, "0", "0", FALSE); i := 0; WHILE i < words DO NewTemp(a); IntStr(VAL(INTEGER, i * 4), off); Op3L("add", a, addr, off); Revive; W(" storew "); W(z); W(", "); WL(a); INC(i) END END SetZero; PROCEDURE SetBit (addr: ARRAY OF CHAR; val: ARRAY OF CHAR; lo: INTEGER; span: CARDINAL); (* ORs one element in: off = val - lo trapped in [0, span). *) VAR off, offL, hiS, loS: QVal; wi, bi, wil, off4, wa, wcur, m, wn: QVal; BEGIN NewTemp(off); IntStr(lo, loS); Op3("sub", off, val, loS, FALSE); WidenIndex(off, offL); IntStr(VAL(INTEGER, span) - 1, hiS); CheckRange(offL, "0", hiS); NewTemp(wi); Op3("shr", wi, off, "5", FALSE); NewTemp(bi); Op3("and", bi, off, "31", FALSE); WidenIndex(wi, wil); NewTemp(off4); Op3L("mul", off4, wil, "4"); NewTemp(wa); Op3L("add", wa, addr, off4); NewTemp(m); Op3("shl", m, "1", bi, FALSE); NewTemp(wcur); W(" "); W(wcur); W(" =w loadw "); WL(wa); NewTemp(wn); Op3("or", wn, wcur, m, FALSE); Revive; W(" storew "); W(wn); W(", "); WL(wa) END SetBit; PROCEDURE SetClearBit (addr: ARRAY OF CHAR; val: ARRAY OF CHAR; lo: INTEGER; span: CARDINAL); (* ANDs one element out: off = val - lo trapped in [0, span). *) VAR off, offL, hiS, loS: QVal; wi, bi, wil, off4, wa, wcur, m, nm, wn: QVal; BEGIN NewTemp(off); IntStr(lo, loS); Op3("sub", off, val, loS, FALSE); WidenIndex(off, offL); IntStr(VAL(INTEGER, span) - 1, hiS); CheckRange(offL, "0", hiS); NewTemp(wi); Op3("shr", wi, off, "5", FALSE); NewTemp(bi); Op3("and", bi, off, "31", FALSE); WidenIndex(wi, wil); NewTemp(off4); Op3L("mul", off4, wil, "4"); NewTemp(wa); Op3L("add", wa, addr, off4); NewTemp(m); Op3("shl", m, "1", bi, FALSE); NewTemp(nm); Op3("xor", nm, m, "-1", FALSE); NewTemp(wcur); W(" "); W(wcur); W(" =w loadw "); WL(wa); NewTemp(wn); Op3("and", wn, wcur, nm, FALSE); Revive; W(" storew "); W(wn); W(", "); WL(wa) END SetClearBit; PROCEDURE SetShift (src: ARRAY OF CHAR; n: ARRAY OF CHAR; words: CARDINAL; span: CARDINAL; isRot: BOOLEAN; VAR q: QVal); (* Bit-by-bit shift/rotate by a runtime amount n over [0, span); bits that leave the span are dropped (SHIFT) or wrapped (ROTATE). *) VAR out, nn, sp, hi, i: QVal; wi, bi, wil, off4, wa, m, t, bit, nzb: QVal; j, c, cs, jw: QVal; ok1, ok2, ok, wj, bj, wjl, o2, wb2, mm, mm2, mm3: QVal; wcur, wn, ip1: QVal; ltop, lbody, lend: QVal; BEGIN NewSetTemp(words, out); SetZero(out, words); Cpy(nn, n); IntStr(VAL(INTEGER, span), sp); IntStr(VAL(INTEGER, span) - 1, hi); IF isRot THEN NewTemp(j); Op3("rem", j, n, sp, FALSE); NewTemp(ok1); Op3("add", ok1, j, sp, FALSE); NewTemp(cs); Op3("rem", cs, ok1, sp, FALSE); Cpy(nn, cs) END; NewTemp(i); Op3("add", i, "0", "0", FALSE); NewLabel(ltop); NewLabel(lbody); NewLabel(lend); EmitLabel(ltop); NewTemp(c); Op3("cslew", c, i, hi, FALSE); Jnz(c, lbody, lend); EmitLabel(lbody); NewTemp(wi); Op3("shr", wi, i, "5", FALSE); NewTemp(bi); Op3("and", bi, i, "31", FALSE); WidenIndex(wi, wil); NewTemp(off4); Op3L("mul", off4, wil, "4"); NewTemp(wa); Op3L("add", wa, src, off4); NewTemp(m); Op3("shl", m, "1", bi, FALSE); NewTemp(t); W(" "); W(t); W(" =w loadw "); WL(wa); NewTemp(bit); Op3("and", bit, t, m, FALSE); NewTemp(nzb); Op3("cnew", nzb, bit, "0", FALSE); NewTemp(j); Op3("add", j, i, nn, FALSE); IF isRot THEN NewTemp(c); Op3("csgew", c, j, sp, FALSE); NewTemp(cs); Op3("mul", cs, c, sp, FALSE); NewTemp(jw); Op3("sub", jw, j, cs, FALSE); Cpy(j, jw) END; NewTemp(ok1); Op3("csgew", ok1, j, "0", FALSE); NewTemp(ok2); Op3("cslew", ok2, j, hi, FALSE); NewTemp(ok); Op3("and", ok, ok1, ok2, FALSE); NewTemp(wj); Op3("shr", wj, j, "5", FALSE); NewTemp(bj); Op3("and", bj, j, "31", FALSE); WidenIndex(wj, wjl); NewTemp(o2); Op3L("mul", o2, wjl, "4"); NewTemp(wb2); Op3L("add", wb2, out, o2); NewTemp(mm); Op3("shl", mm, "1", bj, FALSE); NewTemp(mm2); Op3("mul", mm2, mm, nzb, FALSE); NewTemp(mm3); Op3("mul", mm3, mm2, ok, FALSE); NewTemp(wcur); W(" "); W(wcur); W(" =w loadw "); WL(wb2); NewTemp(wn); Op3("or", wn, wcur, mm3, FALSE); Revive; W(" storew "); W(wn); W(", "); WL(wb2); Op3("add", i, i, "1", FALSE); Jmp(ltop); EmitLabel(lend); Cpy(q, out) END SetShift; PROCEDURE SetRange (addr: ARRAY OF CHAR; a: ARRAY OF CHAR; b: ARRAY OF CHAR; lo: INTEGER; span: CARDINAL); VAR al, bl, hiS: QVal; cur, c: QVal; ltop, lbody, lend: QVal; BEGIN WidenIndex(a, al); WidenIndex(b, bl); IntStr(VAL(INTEGER, span) - 1, hiS); CheckRange(al, "0", hiS); CheckRange(bl, "0", hiS); NewTemp(cur); Op3("add", cur, a, "0", FALSE); NewLabel(ltop); NewLabel(lbody); NewLabel(lend); EmitLabel(ltop); NewTemp(c); Op3("cslew", c, cur, b, FALSE); Jnz(c, lbody, lend); EmitLabel(lbody); SetBit(addr, cur, lo, span); Op3("add", cur, cur, "1", FALSE); Jmp(ltop); EmitLabel(lend) END SetRange; PROCEDURE SetBinOp (sel: INTEGER; l: ARRAY OF CHAR; r: ARRAY OF CHAR; lw, rw: CARDINAL; VAR q: QVal); (* Union/intersection/difference/symdiff over possibly different spans: overlap via op, larger-side extras copied (union/symdiff/ left-diff) or zeroed. Result has max words. *) VAR i, m, res: CARDINAL; la, ra, ta, a, b, c, nb, z: QVal; BEGIN m := lw; IF rw < m THEN m := rw END; res := lw; IF rw > res THEN res := rw END; NewSetTemp(res, q); NewTemp(z); Op3("xor", z, "0", "0", FALSE); i := 0; WHILE i < m DO IntStr(VAL(INTEGER, i * 4), nb); NewTemp(la); Op3L("add", la, l, nb); NewTemp(ra); Op3L("add", ra, r, nb); NewTemp(ta); Op3L("add", ta, q, nb); NewTemp(a); W(" "); W(a); W(" =w loadw "); WL(la); NewTemp(b); W(" "); W(b); W(" =w loadw "); WL(ra); NewTemp(c); IF sel = 0 THEN Op3("or", c, a, b, FALSE) ELSIF sel = 1 THEN Op3("and", c, a, b, FALSE) ELSIF sel = 2 THEN NewTemp(nb); Op3("xor", nb, b, "-1", FALSE); Op3("and", c, a, nb, FALSE) ELSE Op3("xor", c, a, b, FALSE) END; Revive; W(" storew "); W(c); W(", "); WL(ta); INC(i) END; WHILE i < lw DO IntStr(VAL(INTEGER, i * 4), nb); NewTemp(la); Op3L("add", la, l, nb); NewTemp(ta); Op3L("add", ta, q, nb); IF (sel = 0) OR (sel = 2) OR (sel = 3) THEN NewTemp(a); W(" "); W(a); W(" =w loadw "); WL(la); Revive; W(" storew "); W(a); W(", "); WL(ta) ELSE Revive; W(" storew "); W(z); W(", "); WL(ta) END; INC(i) END; WHILE i < rw DO IntStr(VAL(INTEGER, i * 4), nb); NewTemp(ra); Op3L("add", ra, r, nb); NewTemp(ta); Op3L("add", ta, q, nb); IF (sel = 0) OR (sel = 3) THEN NewTemp(b); W(" "); W(b); W(" =w loadw "); WL(ra); Revive; W(" storew "); W(b); W(", "); WL(ta) ELSE Revive; W(" storew "); W(z); W(", "); WL(ta) END; INC(i) END END SetBinOp; PROCEDURE CmpSet (op: INTEGER; l: ARRAY OF CHAR; r: ARRAY OF CHAR; lw, rw: CARDINAL; VAR q: QVal); VAR i, m: CARDINAL; la, ra, a, b, c, acc, nb: QVal; BEGIN NewTemp(acc); Op3("xor", acc, "1", "0", FALSE); m := lw; IF rw < m THEN m := rw END; i := 0; WHILE i < m DO IntStr(VAL(INTEGER, i * 4), nb); NewTemp(la); Op3L("add", la, l, nb); NewTemp(ra); Op3L("add", ra, r, nb); NewTemp(a); W(" "); W(a); W(" =w loadw "); WL(la); NewTemp(b); W(" "); W(b); W(" =w loadw "); WL(ra); NewTemp(c); Op3("ceqw", c, a, b, FALSE); NewTemp(q); Op3("and", q, acc, c, FALSE); CopyOp(q, acc); INC(i) END; WHILE i < lw DO IntStr(VAL(INTEGER, i * 4), nb); NewTemp(la); Op3L("add", la, l, nb); NewTemp(a); W(" "); W(a); W(" =w loadw "); WL(la); NewTemp(c); Op3("ceqw", c, a, "0", FALSE); NewTemp(q); Op3("and", q, acc, c, FALSE); CopyOp(q, acc); INC(i) END; WHILE i < rw DO IntStr(VAL(INTEGER, i * 4), nb); NewTemp(ra); Op3L("add", ra, r, nb); NewTemp(b); W(" "); W(b); W(" =w loadw "); WL(ra); NewTemp(c); Op3("ceqw", c, b, "0", FALSE); NewTemp(q); Op3("and", q, acc, c, FALSE); CopyOp(q, acc); INC(i) END; IF (op = SymTab.OpNeq1) OR (op = SymTab.OpNeq2) THEN NewTemp(q); Op3("xor", q, acc, "1", FALSE) ELSE CopyOp(acc, q) END END CmpSet; PROCEDURE CopySet (dst: ARRAY OF CHAR; src: ARRAY OF CHAR; dw, sw: CARDINAL); (* Copies min words via memcpy, zero-fills dst extras. Src extras beyond dst must be zero (trap) — otherwise out-of-span bits would vanish silently on narrowing assignment. *) VAR m, i: CARDINAL; n, da, sa, a, z, off, c: QVal; qr, acc, lok, lbad: QVal; BEGIN m := dw; IF sw < m THEN m := sw END; IF sw > dw THEN NewTemp(acc); Op3("xor", acc, "1", "0", FALSE); i := dw; WHILE i < sw DO IntStr(VAL(INTEGER, i * 4), off); NewTemp(a); Op3L("add", a, src, off); NewTemp(c); W(" "); W(c); W(" =w loadw "); WL(a); NewTemp(qr); Op3("ceqw", qr, c, "0", FALSE); NewTemp(c); Op3("and", c, acc, qr, FALSE); CopyOp(c, acc); INC(i) END; NewLabel(lok); NewLabel(lbad); Jnz(acc, lok, lbad); EmitLabel(lbad); Trap; EmitLabel(lok) END; IF m > 0 THEN IntStr(VAL(INTEGER, m * 4), n); NewTemp(qr); W(" "); W(qr); W(" =l call $memcpy(l "); W(dst); W(", l "); W(src); W(", l "); W(n); WL(")") END; NewTemp(z); Op3("xor", z, "0", "0", FALSE); i := m; WHILE i < dw DO NewTemp(a); IntStr(VAL(INTEGER, i * 4), off); Op3L("add", a, dst, off); Revive; W(" storew "); W(z); W(", "); WL(a); INC(i) END END CopySet; PROCEDURE InSet (x: ARRAY OF CHAR; s: ARRAY OF CHAR; lo: INTEGER; span: CARDINAL; VAR q: QVal); (* Membership bit test with span trap; q is fresh w 0/1. *) VAR off, offL, hiS, loS: QVal; wi, bi, wil, off4, wa, wcur, m, a: QVal; spanS: QVal; BEGIN NewTemp(off); IntStr(lo, loS); Op3("sub", off, x, loS, FALSE); WidenIndex(off, offL); IntStr(VAL(INTEGER, span) - 1, spanS); CheckRange(offL, "0", spanS); NewTemp(wi); Op3("shr", wi, off, "5", FALSE); NewTemp(bi); Op3("and", bi, off, "31", FALSE); WidenIndex(wi, wil); NewTemp(off4); Op3L("mul", off4, wil, "4"); NewTemp(wa); Op3L("add", wa, s, off4); NewTemp(wcur); W(" "); W(wcur); W(" =w loadw "); WL(wa); NewTemp(m); Op3("shl", m, "1", bi, FALSE); NewTemp(a); Op3("and", a, wcur, m, FALSE); NewTemp(q); Op3("cnew", q, a, "0", FALSE) END InSet; PROCEDURE WidenIndex (idx: ARRAY OF CHAR; VAR q: QVal); BEGIN IF IsImm(idx) THEN Cpy(q, idx) ELSE NewTemp(q); Revive; W(" "); W(q); W(" =l extsw "); WL(idx) END END WidenIndex; PROCEDURE OpenHi (base: ARRAY OF CHAR; VAR q: QVal); VAR c: QVal; BEGIN NewTemp(c); Revive; W(" "); W(c); W(" =l loadl "); WL(base); NewTemp(q); Op3L("sub", q, c, "1") END OpenHi; PROCEDURE OpenHiChar (base: ARRAY OF CHAR; VAR q: QVal); (* q := loadl(base) — the open-array count, i.e. the index of the NUL terminator slot that CHAR arrays reserve. *) BEGIN NewTemp(q); Revive; W(" "); W(q); W(" =l loadl "); WL(base) END OpenHiChar; PROCEDURE LoadCount (base: ARRAY OF CHAR; VAR q: QVal); BEGIN NewTemp(q); Revive; W(" "); W(q); W(" =l loadl "); WL(base) END LoadCount; PROCEDURE CheckRange (idx, lo, hi: ARRAY OF CHAR); (* l-domain operands (widened index, immediates, or open hi temp); comparisons are long (result w). *) VAR c1, c2, c: QVal; lok, lbad: QVal; BEGIN NewTemp(c1); Op3("csgel", c1, idx, lo, FALSE); NewTemp(c2); Op3("cslel", c2, idx, hi, FALSE); NewTemp(c); Op3("and", c, c1, c2, FALSE); NewLabel(lok); NewLabel(lbad); Jnz(c, lok, lbad); EmitLabel(lbad); Trap; EmitLabel(lok) END CheckRange; PROCEDURE ElemAddr (base, idx, lo: ARRAY OF CHAR; elemT: INTEGER; VAR q: QVal); (* q := base + 8 + (idx - lo) * elemSize in l, fresh temp. elemT is the array descriptor (open or fixed); all operands l-domain (immediates pass, temps pre-widened). *) VAR t1, t2, tb, sb: QVal; BEGIN NewTemp(t1); Op3L("sub", t1, idx, lo); IntStr(VAL(INTEGER, ElemSize(elemT)), sb); NewTemp(t2); Op3L("mul", t2, t1, sb); NewTemp(tb); Op3L("add", tb, base, "8"); NewTemp(q); Op3L("add", q, tb, t2) END ElemAddr; PROCEDURE ElemLoad (addr: ARRAY OF CHAR; t: INTEGER; VAR q: QVal); (* Loads one element of (element-)type t. Nested/pointer elements are addresses (loadl). *) VAR cls: INTEGER; BEGIN cls := SymTab.ClassOf(t); NewTemp(q); Revive; W(" "); W(q); IF cls = SymTab.ClReal THEN W(" =d loadd ") ELSIF (cls = SymTab.ClArray) OR (cls = SymTab.ClPtr) OR (cls = SymTab.ClLong) OR (cls = SymTab.ClProc) OR (cls = SymTab.ClClass) THEN W(" =l loadl ") ELSIF cls = SymTab.ClChar THEN W(" =w loadub ") ELSE W(" =w loadw ") END; WL(addr) END ElemLoad; PROCEDURE ElemStore (addr, v: ARRAY OF CHAR; t: INTEGER); VAR cls: INTEGER; BEGIN cls := SymTab.ClassOf(t); Revive; IF cls = SymTab.ClReal THEN W(" stored ") ELSIF (cls = SymTab.ClArray) OR (cls = SymTab.ClPtr) OR (cls = SymTab.ClLong) OR (cls = SymTab.ClProc) OR (cls = SymTab.ClClass) THEN W(" storel ") ELSIF cls = SymTab.ClChar THEN W(" storeb ") ELSE W(" storew ") END; W(v); W(", "); WL(addr) END ElemStore; PROCEDURE CopyArray (dst: ARRAY OF CHAR; src: ARRAY OF CHAR; t: INTEGER); (* Whole-array copy with runtime count check + blit. Nested levels recurse through a runtime loop; counts mismatch traps. dst/src are descriptor address operands; t is the destination type. *) VAR dc, sc, ok: QVal; lok, lbad: QVal; ecls: INTEGER; n, da, sa: QVal; sb: QVal; qr: QVal; i, c, de, se, di, si, dd0, doff, sd0, soff: QVal; ltop, lbody, lend: QVal; BEGIN NewTemp(dc); Revive; W(" "); W(dc); W(" =l loadl "); WL(dst); NewTemp(sc); W(" "); W(sc); W(" =l loadl "); WL(src); NewTemp(ok); Op3("ceql", ok, dc, sc, FALSE); NewLabel(lok); NewLabel(lbad); Jnz(ok, lok, lbad); EmitLabel(lbad); Trap; EmitLabel(lok); ecls := ElemCls(t); IF (ecls = SymTab.ClArray) THEN NewTemp(i); W(" "); W(i); W(" =l copy 0"); WL(""); NewLabel(ltop); NewLabel(lbody); NewLabel(lend); EmitLabel(ltop); NewTemp(c); Op3("csltl", c, i, dc, FALSE); Jnz(c, lbody, lend); EmitLabel(lbody); NewTemp(dd0); Op3L("add", dd0, dst, "8"); NewTemp(doff); Op3L("mul", doff, i, "8"); NewTemp(de); Op3L("add", de, dd0, doff); NewTemp(sd0); Op3L("add", sd0, src, "8"); NewTemp(soff); Op3L("mul", soff, i, "8"); NewTemp(se); Op3L("add", se, sd0, soff); NewTemp(di); W(" "); W(di); W(" =l loadl "); WL(de); NewTemp(si); W(" "); W(si); W(" =l loadl "); WL(se); CopyArray(di, si, SymTab.ArrayElem(t)); Op3L("add", i, i, "1"); Jmp(ltop); EmitLabel(lend) ELSE IntStr(VAL(INTEGER, ElemSize(t)), sb); NewTemp(n); Op3L("mul", n, dc, sb); NewTemp(da); Op3L("add", da, dst, "8"); NewTemp(sa); Op3L("add", sa, src, "8"); NewTemp(qr); W(" "); W(qr); W(" =l call $memcpy(l "); W(da); W(", l "); W(sa); W(", l "); W(n); WL(")") END END CopyArray; PROCEDURE DeclStr (text: ARRAY OF CHAR; VAR q: QVal); (* Records a quoted literal for top-level emission at EndModule and returns its address operand ($strN). Data definitions may only appear outside functions, but literals occur mid-body. *) VAR nm: QVal; BEGIN Cpy(nm, "str"); AppNum(nm, nStr); IF nStr <= HIGH(strNams) THEN Cpy(strNams[nStr], nm); Cpy(strTexts[nStr], text); INC(nStr) END; Cpy(q, "$"); App(q, nm) END DeclStr; PROCEDURE DeclUStr (text: ARRAY OF CHAR; VAR q: QVal; VAR single: BOOLEAN; VAR cp: INTEGER; VAR ok: BOOLEAN); (* text is the raw lexeme U'...' / U"..." Strict RFC3629-decode the bytes between the quotes. Exactly one codepoint -> single:=TRUE, cp:=it. Otherwise record a UString descriptor and q := "$ustrN". ok:=FALSE for invalid UTF-8 (overlong / surrogate / >10FFFF / truncation). *) VAR L, i, cnt, base: CARDINAL; b0, b1, b2, b3, ch: INTEGER; nm: QVal; PROCEDURE Cont (VAR b: INTEGER): BOOLEAN; (* consume a continuation byte, or fail *) BEGIN IF i >= L - 1 THEN RETURN FALSE END; b := ORD(text[i]); INC(i); RETURN (b >= 128) AND (b <= 191) END Cont; BEGIN single := FALSE; cp := 0; ok := TRUE; q[0] := "0"; q[1] := CHR(0); L := Len(text); IF (L < 3) OR (text[0] # "U") THEN ok := FALSE; RETURN END; i := 2; cnt := 0; base := ustrUsed; WHILE i < L - 1 DO b0 := ORD(text[i]); INC(i); ch := -1; IF b0 <= 127 THEN ch := b0 ELSIF (b0 >= 194) AND (b0 <= 223) THEN IF Cont(b1) THEN ch := ((b0 - 192) * 64) + (b1 - 128) END ELSIF (b0 >= 224) AND (b0 <= 239) THEN IF Cont(b1) AND Cont(b2) THEN ch := ((b0 - 224) * 4096) + ((b1 - 128) * 64) + (b2 - 128); IF ch < 2048 THEN ch := -1 END END ELSIF (b0 >= 240) AND (b0 <= 244) THEN IF Cont(b1) AND Cont(b2) AND Cont(b3) THEN ch := ((b0 - 240) * 262144) + ((b1 - 128) * 4096) + ((b2 - 128) * 64) + (b3 - 128); IF ch < 65536 THEN ch := -1 END END ELSE ok := FALSE END; IF ok AND (ch < 0) THEN ok := FALSE END; IF ok AND (ch >= 55296) AND (ch <= 57343) THEN ok := FALSE END; IF ok AND (ch > 1114111) THEN ok := FALSE END; IF NOT ok THEN RETURN END; IF ustrUsed <= HIGH(ustrPool) THEN ustrPool[ustrUsed] := ch; INC(ustrUsed) END; INC(cnt) END; IF cnt = 1 THEN single := TRUE; cp := ustrPool[base] ELSE Cpy(nm, "ustr"); AppNum(nm, ustrN); IF ustrN <= HIGH(ustrNams) THEN Cpy(ustrNams[ustrN], nm); ustrStart[ustrN] := base; ustrCount[ustrN] := cnt; INC(ustrN) END; Cpy(q, "$"); App(q, nm) END END DeclUStr; PROCEDURE FlushUStrings; VAR k, i: CARDINAL; bv: QVal; BEGIN IF NOT opened THEN RETURN END; k := 0; WHILE k < ustrN DO W("data $"); W(ustrNams[k]); W(" = { l "); IntStr(VAL(INTEGER, ustrCount[k]), bv); W(bv); i := 0; WHILE i < ustrCount[k] DO W(", w "); IntStr(ustrPool[ustrStart[k] + i], bv); W(bv); INC(i) END; WL(" }"); INC(k) END END FlushUStrings; PROCEDURE DeclCharStr (ch: ARRAY OF CHAR; VAR q: QVal); VAR v: INTEGER; txt: ARRAY [0 .. 3] OF CHAR; BEGIN IF ParseInt(ch, v) AND (v >= 0) AND (v < 256) THEN txt[0] := '"'; txt[1] := CHR(v); txt[2] := '"'; txt[3] := CHR(0); DeclStr(txt, q) ELSE Cpy(q, "0") END END DeclCharStr; PROCEDURE FindStrPos (v: ARRAY OF CHAR; VAR k: CARDINAL): BOOLEAN; VAR j: CARDINAL; sv: QVal; BEGIN j := 0; WHILE j < nStr DO Cpy(sv, "$"); App(sv, strNams[j]); IF SymTab.Equal(sv, v) THEN k := j; RETURN TRUE END; INC(j) END; RETURN FALSE END FindStrPos; PROCEDURE StrFold (a, b: ARRAY OF CHAR; clsA, clsB: INTEGER; VAR q: QVal; VAR ok: BOOLEAN); (* Constant-fold `a + b` into one string literal descriptor. *) VAR ka, kb: CARDINAL; ta, tb, joined: ARRAY [0 .. 1023] OF CHAR; oa, ob, ord: INTEGER; i, L: CARDINAL; isCharA, isCharB: BOOLEAN; PROCEDURE AppendInner (VAR s: ARRAY OF CHAR; txt: ARRAY OF CHAR); VAR n: CARDINAL; c2: ARRAY [0 .. 1] OF CHAR; BEGIN n := Len(txt); IF n >= 2 THEN i := 1; WHILE i < n - 1 DO c2[0] := txt[i]; c2[1] := CHR(0); App(s, c2); INC(i) END END END AppendInner; BEGIN ok := FALSE; isCharA := (clsA = SymTab.ClChar) OR (clsA = SymTab.ClEnum) OR (clsA = SymTab.ClBool); isCharB := (clsB = SymTab.ClChar) OR (clsB = SymTab.ClEnum) OR (clsB = SymTab.ClBool); IF isCharA THEN IF NOT ParseInt(a, oa) THEN RETURN END ELSIF NOT FindStrPos(a, ka) THEN RETURN END; IF isCharB THEN IF NOT ParseInt(b, ob) THEN RETURN END ELSIF NOT FindStrPos(b, kb) THEN RETURN END; joined[0] := '"'; joined[1] := CHR(0); IF isCharA THEN IF (oa < 0) OR (oa > 255) THEN RETURN END; joined[1] := CHR(oa); joined[2] := CHR(0) ELSE AppendInner(joined, strTexts[ka]) END; IF isCharB THEN IF (ob < 0) OR (ob > 255) THEN RETURN END; L := Len(joined); joined[L] := CHR(ob); joined[L + 1] := CHR(0) ELSE AppendInner(joined, strTexts[kb]) END; L := Len(joined); joined[L] := '"'; joined[L + 1] := CHR(0); DeclStr(joined, q); ok := TRUE END StrFold; PROCEDURE FlushStrings; (* Emits all recorded string literals as top-level data. *) VAR k, i, L: CARDINAL; bv: QVal; BEGIN IF NOT opened THEN RETURN END; k := 0; WHILE k < nStr DO L := Len(strTexts[k]); IF L >= 2 THEN W("data $"); W(strNams[k]); W(" = { l "); IntStr(VAL(INTEGER, L - 2), bv); W(bv); i := 1; WHILE i < L - 1 DO W(", b "); IntStr(ORD(strTexts[k][i]), bv); W(bv); INC(i) END; W(", b 0"); (* NUL terminator (count excludes it) *) WL(" }") END; INC(k) END END FlushStrings; PROCEDURE DeclArr (name: ARRAY OF CHAR; t: INTEGER); BEGIN IF SymTab.IsOpenArray(t) OR (SymTab.ArrayDepth(t) = 0) THEN DataLine(name, FALSE, "0"); RETURN END; ArrData(name, t) END DeclArr; (* ---------------- array constructors (step: `T{...}`) ---------------- *) (* A constructor becomes a pooled static descriptor with the same layout as a declared array: "l , " (CHAR/UCHAR get a trailing zero terminator slot, like ArrBodyItems). Nested arrays are emitted as their own pooled descriptors and referenced by `l $ctoK` so the runtime descriptor pointers stay valid. *) PROCEDURE IsBakeOp (v: ARRAY OF CHAR): BOOLEAN; (* TRUE when v may be embedded in a static descriptor: an immediate, or a pooled constructor/label reference ($ctoN). A plain global address ($mod_var) is NOT bakeable into an inline field. *) BEGIN IF (v[0] = CHR(0)) OR (v[0] = "%") THEN RETURN FALSE END; IF v[0] # "$" THEN RETURN TRUE END; (* accept $ctoN only *) RETURN (v[1] = "c") AND (v[2] = "t") AND (v[3] = "o") END IsBakeOp; PROCEDURE CtorItem (VAR buf: ARRAY OF CHAR; v: ARRAY OF CHAR; cls: INTEGER); BEGIN App(buf, ", "); IF cls = SymTab.ClChar THEN App(buf, "b ") ELSIF cls = SymTab.ClReal THEN App(buf, "d ") ELSIF (cls = SymTab.ClPtr) OR (cls = SymTab.ClProc) OR (cls = SymTab.ClLong) OR (cls = SymTab.ClArray) THEN App(buf, "l ") ELSE App(buf, "w ") END; App(buf, v) END CtorItem; PROCEDURE RecItem (VAR s: ARRAY OF CHAR; VAR first: BOOLEAN; v: ARRAY OF CHAR; cls: INTEGER); (* Record field item with a leading separator when not first. *) BEGIN IF first THEN first := FALSE ELSE App(s, ", ") END; IF cls = SymTab.ClChar THEN App(s, "b ") ELSIF cls = SymTab.ClReal THEN App(s, "d ") ELSIF (cls = SymTab.ClPtr) OR (cls = SymTab.ClProc) OR (cls = SymTab.ClLong) OR (cls = SymTab.ClArray) THEN App(s, "l ") ELSE App(s, "w ") END; App(s, v) END RecItem; PROCEDURE ArrZeroBody (VAR s: ARRAY OF CHAR; t: INTEGER); (* "l , z " — an all-zero array body (used for a record's unprovided array field). *) VAR n: CARDINAL; elem: SymTab.TypeIndex; ecls: INTEGER; esz: CARDINAL; bv: QVal; BEGIN n := SymTab.ArrayLen(t); elem := SymTab.ArrayElem(t); ecls := SymTab.ClassOf(elem); App(s, "l "); IntStr(VAL(INTEGER, n), bv); App(s, bv); IF ecls = SymTab.ClChar THEN App(s, ", z "); IntStr(VAL(INTEGER, n + 1), bv); App(s, bv) ELSIF ecls = SymTab.ClUChar THEN App(s, ", z "); IntStr(VAL(INTEGER, (n + 1) * 4), bv); App(s, bv) ELSE IF (ecls = SymTab.ClReal) OR (ecls = SymTab.ClPtr) OR (ecls = SymTab.ClProc) OR (ecls = SymTab.ClArray) OR (ecls = SymTab.ClLong) THEN esz := 8 ELSE esz := 4 END; IF n > 0 THEN App(s, ", z "); IntStr(VAL(INTEGER, n * esz), bv); App(s, bv) END END END ArrZeroBody; PROCEDURE FindCtor (v: ARRAY OF CHAR): INTEGER; VAR k: CARDINAL; sv: QVal; BEGIN k := 0; WHILE k < ctorN DO Cpy(sv, "$"); App(sv, ctorNam[k]); IF SymTab.Equal(sv, v) THEN RETURN VAL(INTEGER, k) END; INC(k) END; RETURN -1 END FindCtor; (* default items for a nested record field, appended to s *) PROCEDURE RecItemDefaults (VAR s: ARRAY OF CHAR; VAR first: BOOLEAN; prefix: ARRAY OF CHAR; t: INTEGER); VAR i, n, cls, w: INTEGER; fn: SymTab.Name; ft: SymTab.TypeIndex; sub: QVal; BEGIN n := VAL(INTEGER, SymTab.FieldCount(t)); i := 0; WHILE i < n DO SymTab.FieldName(t, i, fn); ft := SymTab.FieldType(t, fn); cls := SymTab.ClassOf(ft); IF first THEN first := FALSE ELSE App(s, ", ") END; IF cls = SymTab.ClReal THEN App(s, "d 0") ELSIF cls = SymTab.ClChar THEN App(s, "b 0") ELSIF cls = SymTab.ClArray THEN ArrZeroBody(s, ft) ELSIF cls = SymTab.ClSet THEN w := VAL(INTEGER, SymTab.SetWords(ft)); IF w = 0 THEN w := 1 END; App(s, "w 0"); WHILE w > 1 DO App(s, ", w 0"); DEC(w) END ELSIF (cls = SymTab.ClRecord) OR (cls = SymTab.ClClass) THEN Cpy(sub, prefix); App(sub, "_"); App(sub, fn); RecItemDefaults(s, first, sub, ft) ELSE App(s, "w 0") END; INC(i) END END RecItemDefaults; PROCEDURE CtorBegin (t: INTEGER); BEGIN IF ctorTop > HIGH(ctorTyp) THEN RETURN END; ctorTyp[ctorTop] := t; ctorCnt[ctorTop] := 0; ctorBuf[ctorTop][0] := CHR(0); INC(ctorTop) END CtorBegin; PROCEDURE CtorElemType (t: INTEGER; cnt: CARDINAL): SymTab.TypeIndex; (* the type of the cnt-th constructor element: array element, or the cnt-th record field in declaration order. *) VAR fn: SymTab.Name; BEGIN IF SymTab.ClassOf(t) = SymTab.ClArray THEN RETURN SymTab.ArrayElem(t) END; SymTab.FieldName(t, cnt, fn); IF fn[0] = CHR(0) THEN RETURN SymTab.InvalidType END; RETURN SymTab.FieldType(t, fn) END CtorElemType; PROCEDURE StrDesc (v: ARRAY OF CHAR; elemT: INTEGER; VAR out: QVal); (* v is a $strN descriptor; build a CHAR-array descriptor of type elemT from its text (padded/NUL-terminated) and return "$ctoM". *) VAR k: CARDINAL; found: BOOLEAN; txt, bv, sv: QVal; buf: ARRAY [0 .. 4095] OF CHAR; n, i, L: CARDINAL; BEGIN Cpy(out, v); IF (ctorN > HIGH(ctorNam)) THEN RETURN END; found := FALSE; k := 0; WHILE (k < nStr) AND NOT found DO Cpy(sv, "$"); App(sv, strNams[k]); IF SymTab.Equal(sv, v) THEN Cpy(txt, strTexts[k]); found := TRUE ELSE INC(k) END END; IF NOT found THEN RETURN END; L := Len(txt); n := SymTab.ArrayLen(elemT); buf[0] := CHR(0); App(buf, "l "); IntStr(VAL(INTEGER, n), bv); App(buf, bv); i := 0; WHILE i < n DO IF (i + 1 < L - 1) AND ((i + 1) <= HIGH(txt)) THEN IntStr(ORD(txt[i + 1]), bv) ELSE Cpy(bv, "0") END; CtorItem(buf, bv, SymTab.ClChar); INC(i) END; App(buf, ", b 0"); Cpy(ctorNam[ctorN], "cto"); AppNum(ctorNam[ctorN], ctorN); Cpy(ctorTxt[ctorN], buf); ctorUse[ctorN] := TRUE; INC(ctorN); Cpy(out, "$"); App(out, ctorNam[ctorN - 1]) END StrDesc; PROCEDURE AppCtorElem (v: ARRAY OF CHAR; cls: INTEGER); VAR cnt: CARDINAL; BEGIN IF ctorTop = 0 THEN RETURN END; cnt := ctorCnt[ctorTop - 1]; IF cnt > HIGH(ctorEv[0]) THEN RETURN END; Cpy(ctorEv[ctorTop - 1][cnt], v); ctorEk[ctorTop - 1][cnt] := cls; INC(ctorCnt[ctorTop - 1]) END AppCtorElem; PROCEDURE CtorElem (v: ARRAY OF CHAR); (* Record the next constructor element. The element type is derived from the constructor's type and the element index. A string literal filling a CHAR element expands into consecutive elements. *) VAR t, elemT, cls, k, si: INTEGER; cnt: CARDINAL; vv, bv: QVal; isStr: BOOLEAN; BEGIN IF ctorTop = 0 THEN RETURN END; t := ctorTyp[ctorTop - 1]; elemT := CtorElemType(t, ctorCnt[ctorTop - 1]); cls := SymTab.ClassOf(elemT); isStr := (Len(v) > 3) AND (v[0] = "$") AND (v[1] = "s") AND (v[2] = "t"); IF cls = SymTab.ClChar THEN IF isStr AND FindStrPos(v, cnt) THEN k := 1; WHILE k < VAL(INTEGER, Len(strTexts[cnt])) - 1 DO IntStr(ORD(strTexts[cnt][k]), bv); AppCtorElem(bv, SymTab.ClChar); INC(k) END; RETURN END; AppCtorElem(v, SymTab.ClChar); RETURN END; Cpy(vv, v); IF (cls = SymTab.ClArray) AND isStr AND (SymTab.ClassOf(SymTab.ArrayElem(elemT)) = SymTab.ClChar) THEN StrDesc(v, elemT, vv) END; AppCtorElem(vv, cls) END CtorElem; PROCEDURE NewCtorTemp (t: INTEGER; VAR q: QVal); VAR nb: QVal; BEGIN NewTemp(q); Revive; IntStr(VAL(INTEGER, HeapSize(t)), nb); W(" "); W(q); W(" =l alloc8 "); WL(nb) END NewCtorTemp; PROCEDURE InitArrHeader (addr: ARRAY OF CHAR; t: INTEGER); (* Store an inline array's count header (and CHAR/UCHAR terminator slot) at addr, so a following CopyArray sees matching counts. *) VAR nb, ea: QVal; BEGIN IF SymTab.ClassOf(t) # SymTab.ClArray THEN RETURN END; IntStr(VAL(INTEGER, SymTab.ArrayLen(t)), nb); Revive; W(" storel "); W(nb); W(", "); WL(addr); IF SymTab.IsCharArray(t) THEN IntStr(VAL(INTEGER, 8 + SymTab.ArrayLen(t)), nb); NewTemp(ea); Op3L("add", ea, addr, nb); Revive; W(" storeb 0, "); WL(ea) END; IF SymTab.IsUCharArray(t) THEN IntStr(VAL(INTEGER, 8 + SymTab.ArrayLen(t) * 4), nb); NewTemp(ea); Op3L("add", ea, addr, nb); Revive; W(" storew 0, "); WL(ea) END END InitArrHeader; PROCEDURE CtorArrStatic (VAR s: ARRAY OF CHAR; lvl: CARDINAL; t: INTEGER; cnt: CARDINAL); VAR elem, ecls, n, k, ci: INTEGER; v: QVal; BEGIN elem := SymTab.ArrayElem(t); ecls := SymTab.ClassOf(elem); n := VAL(INTEGER, SymTab.ArrayLen(t)); App(s, "l "); IntStr(n, v); App(s, v); k := 0; WHILE k < n DO IF k < VAL(INTEGER, cnt) THEN Cpy(v, ctorEv[lvl][k]) ELSE Cpy(v, "0") END; CtorItem(s, v, ecls); INC(k) END; IF ecls = SymTab.ClChar THEN App(s, ", b 0") ELSIF ecls = SymTab.ClUChar THEN App(s, ", w 0") END END CtorArrStatic; PROCEDURE CtorRecStatic (VAR s: ARRAY OF CHAR; lvl: CARDINAL; t: INTEGER; cnt: CARDINAL); (* Static record body: fields in declaration order; an array/record field given as a nested constructor is inlined (and that child descriptor is marked consumed). *) VAR i, n, cls, ci, w: INTEGER; fn: SymTab.Name; ft: SymTab.TypeIndex; v, bv: QVal; first: BOOLEAN; BEGIN first := TRUE; IF (SymTab.ClassOf(t) = SymTab.ClClass) AND SymTab.HasVTable(t) THEN VtRef(t, bv); App(s, "l "); App(s, bv); first := FALSE END; n := VAL(INTEGER, SymTab.FieldCount(t)); i := 0; WHILE i < n DO SymTab.FieldName(t, i, fn); ft := SymTab.FieldType(t, fn); cls := SymTab.ClassOf(ft); v[0] := CHR(0); IF i < VAL(INTEGER, cnt) THEN Cpy(v, ctorEv[lvl][i]) END; IF (v[0] # CHR(0)) AND (v[0] = "$") AND ((cls = SymTab.ClArray) OR (cls = SymTab.ClRecord) OR (cls = SymTab.ClClass)) THEN ci := FindCtor(v); IF first THEN first := FALSE ELSE App(s, ", ") END; IF ci >= 0 THEN App(s, ctorTxt[ci]); ctorUse[ci] := FALSE ELSIF cls = SymTab.ClArray THEN ArrZeroBody(s, ft) ELSE App(s, "w 0") END ELSIF v[0] # CHR(0) THEN RecItem(s, first, v, cls) ELSIF (cls = SymTab.ClRecord) OR (cls = SymTab.ClClass) THEN IF first THEN first := FALSE ELSE App(s, ", ") END; Cpy(bv, ctorNam[ctorN]); App(bv, "_"); App(bv, fn); RecItemDefaults(s, first, bv, ft) ELSE IF first THEN first := FALSE ELSE App(s, ", ") END; IF cls = SymTab.ClReal THEN App(s, "d 0") ELSIF cls = SymTab.ClChar THEN App(s, "b 0") ELSIF cls = SymTab.ClArray THEN ArrZeroBody(s, ft) ELSIF cls = SymTab.ClSet THEN w := VAL(INTEGER, SymTab.SetWords(ft)); IF w = 0 THEN w := 1 END; App(s, "w 0"); WHILE w > 1 DO App(s, ", w 0"); DEC(w) END ELSE App(s, "w 0") END END; INC(i) END; IF first THEN App(s, "w 0") END END CtorRecStatic; PROCEDURE CtorEnd (VAR q: QVal); VAR t, cls, lvl, k, n, cnt, esz, off, ci: INTEGER; allc: BOOLEAN; bv, a, v: QVal; s: ARRAY [0 .. 4095] OF CHAR; ft, elem: SymTab.TypeIndex; nm: SymTab.Name; BEGIN IF ctorTop = 0 THEN Cpy(q, "0"); RETURN END; DEC(ctorTop); lvl := VAL(INTEGER, ctorTop); IF noEmit THEN Cpy(q, "0"); RETURN END; t := ctorTyp[ctorTop]; cnt := VAL(INTEGER, ctorCnt[ctorTop]); cls := SymTab.ClassOf(t); IF (cls # SymTab.ClArray) AND (cls # SymTab.ClRecord) AND (cls # SymTab.ClClass) THEN Cpy(q, "0"); RETURN END; allc := TRUE; k := 0; WHILE k < cnt DO IF NOT IsBakeOp(ctorEv[lvl][k]) THEN allc := FALSE END; INC(k) END; IF allc AND (ctorN <= HIGH(ctorNam)) THEN s[0] := CHR(0); IF cls = SymTab.ClArray THEN CtorArrStatic(s, ctorTop, t, ctorCnt[ctorTop]) ELSE CtorRecStatic(s, ctorTop, t, ctorCnt[ctorTop]) END; Cpy(ctorNam[ctorN], "cto"); AppNum(ctorNam[ctorN], ctorN); Cpy(ctorTxt[ctorN], s); ctorUse[ctorN] := TRUE; INC(ctorN); Cpy(q, "$"); App(q, ctorNam[ctorN - 1]) ELSE (* runtime construction: an all-zero descriptor filled in place *) NewCtorTemp(t, q); IF cls = SymTab.ClArray THEN IntStr(VAL(INTEGER, SymTab.ArrayLen(t)), bv); Revive; W(" storel "); W(bv); W(", "); WL(q); elem := SymTab.ArrayElem(t); esz := VAL(INTEGER, ElemSize(t)); n := VAL(INTEGER, SymTab.ArrayLen(t)); k := 0; WHILE k < n DO off := 8 + k * esz; FieldAddr(q, off, a); IF k < cnt THEN Cpy(v, ctorEv[lvl][k]); ElemStore(a, v, elem) ELSE ElemStore(a, "0", elem) END; INC(k) END; IF SymTab.ClassOf(elem) = SymTab.ClChar THEN off := 8 + n; FieldAddr(q, off, a); Revive; W(" storeb 0, "); WL(a) ELSIF SymTab.ClassOf(elem) = SymTab.ClUChar THEN off := 8 + n * 4; FieldAddr(q, off, a); Revive; W(" storew 0, "); WL(a) END ELSE (* record / class *) IF (cls = SymTab.ClClass) AND SymTab.HasVTable(t) THEN VtRef(t, bv); off := SymTab.VptrOffset(t); FieldAddr(q, off, a); Revive; W(" storel "); W(bv); W(", "); WL(a) END; n := VAL(INTEGER, SymTab.FieldCount(t)); k := 0; WHILE k < n DO SymTab.FieldName(t, k, nm); ft := SymTab.FieldType(t, nm); off := SymTab.FieldOffset(t, nm); FieldAddr(q, off, a); IF k < cnt THEN Cpy(v, ctorEv[lvl][k]); IF SymTab.ClassOf(ft) = SymTab.ClArray THEN InitArrHeader(a, ft); CopyArray(a, v, ft) ELSIF (SymTab.ClassOf(ft) = SymTab.ClRecord) OR (SymTab.ClassOf(ft) = SymTab.ClClass) THEN CopyRecord(a, v, ft) ELSIF SymTab.ClassOf(ft) = SymTab.ClSet THEN CopySet(a, v, SymTab.SetWords(ft), SymTab.SetWords(ft)) ELSE ElemStore(a, v, ft) END ELSIF (SymTab.ClassOf(ft) = SymTab.ClReal) OR (SymTab.ClassOf(ft) = SymTab.ClChar) OR (SymTab.ClassOf(ft) = SymTab.ClInt) OR (SymTab.ClassOf(ft) = SymTab.ClBool) OR (SymTab.ClassOf(ft) = SymTab.ClEnum) OR (SymTab.ClassOf(ft) = SymTab.ClLong) OR (SymTab.ClassOf(ft) = SymTab.ClPtr) OR (SymTab.ClassOf(ft) = SymTab.ClProc) THEN ElemStore(a, "0", ft) END; INC(k) END END END END CtorEnd; PROCEDURE FlushCtors; VAR k: CARDINAL; BEGIN IF NOT opened THEN RETURN END; k := 0; WHILE k < ctorN DO IF ctorUse[k] THEN W("data $"); W(ctorNam[k]); W(" = { "); W(ctorTxt[k]); WL(" }") END; INC(k) END END FlushCtors; PROCEDURE PushLoop (exit: ARRAY OF CHAR); BEGIN IF loopTop <= HIGH(loopSt) THEN Cpy(loopSt[loopTop], exit); INC(loopTop) END END PushLoop; PROCEDURE PopLoop; BEGIN IF loopTop > 0 THEN DEC(loopTop) END END PopLoop; PROCEDURE TopLoop (VAR exit: QVal): BOOLEAN; BEGIN IF loopTop = 0 THEN RETURN FALSE END; Cpy(exit, loopSt[loopTop - 1]); RETURN TRUE END TopLoop; PROCEDURE CmpL (op: INTEGER; l, r: ARRAY OF CHAR; VAR q: QVal); VAR mn : ARRAY [0 .. 7] OF CHAR; BEGIN mn[0] := CHR(0); IF op = SymTab.OpEq THEN Cpy(mn, "ceql") ELSE Cpy(mn, "cnel") END; NewTemp(q); Op3(mn, q, l, r, FALSE) END CmpL; PROCEDURE Remark (s: ARRAY OF CHAR); BEGIN Revive; W("# "); WL(s) END Remark; (* ---------------- heap (step 3.6: extern malloc/free) ---------------- *) (* Only the object skeleton is initialized (array counts); elements and members stay garbage per Wirth, except nested objects which are allocated recursively. DISPOSE is shallow (documented). *) PROCEDURE HeapSize (t: INTEGER): CARDINAL; VAR cls: INTEGER; n: CARDINAL; BEGIN cls := SymTab.ClassOf(t); IF cls = SymTab.ClArray THEN n := SymTab.ArrayLen(t) * ElemSize(t); IF SymTab.IsCharArray(t) THEN n := n + 1 END; IF SymTab.IsUCharArray(t) THEN n := n + 4 END; RETURN 8 + n END; RETURN SymTab.TypeSize(t) END HeapSize; PROCEDURE NewHeap (t: SymTab.TypeIndex; VAR q: QVal); VAR nb: QVal; BEGIN NewTemp(q); Revive; IntStr(VAL(INTEGER, HeapSize(t)), nb); W(" "); W(q); IF useStack THEN W(" =l alloc8 "); W(nb); WL("") ELSE W(" =l call $malloc(l "); W(nb); WL(")") END END NewHeap; PROCEDURE FreeHeap (v: ARRAY OF CHAR); BEGIN Revive; W(" call $free(l "); W(v); WL(")") END FreeHeap; PROCEDURE InitHeap (addr: ARRAY OF CHAR; t: SymTab.TypeIndex); VAR cls, ecls: INTEGER; n, i: CARDINAL; fn: SymTab.Name; ft: SymTab.TypeIndex; nb, ea, eb, fa, fb: QVal; BEGIN cls := SymTab.ClassOf(t); IF (cls = SymTab.ClClass) AND SymTab.HasVTable(t) THEN (* install the class's vtable pointer *) VtRef(t, eb); IntStr(SymTab.VptrOffset(t), nb); NewTemp(ea); Op3L("add", ea, addr, nb); Revive; W(" storel "); W(eb); W(", "); WL(ea) END; IF cls = SymTab.ClArray THEN IntStr(VAL(INTEGER, SymTab.ArrayLen(t)), nb); Revive; W(" storel "); W(nb); W(", "); WL(addr); IF SymTab.IsCharArray(t) THEN (* NUL terminator slot at index = count *) IntStr(VAL(INTEGER, 8 + SymTab.ArrayLen(t)), nb); NewTemp(ea); Op3L("add", ea, addr, nb); Revive; W(" storeb 0, "); WL(ea) END; IF SymTab.IsUCharArray(t) THEN (* 0-codepoint terminator at index = count (4-byte element) *) IntStr(VAL(INTEGER, 8 + SymTab.ArrayLen(t) * 4), nb); NewTemp(ea); Op3L("add", ea, addr, nb); Revive; W(" storew 0, "); WL(ea) END; ecls := SymTab.ClassOf(SymTab.ArrayElem(t)); IF ecls = SymTab.ClArray THEN n := SymTab.ArrayLen(t); i := 0; WHILE i < n DO IntStr(VAL(INTEGER, 8 + i * 8), nb); NewTemp(ea); Op3L("add", ea, addr, nb); NewHeap(SymTab.ArrayElem(t), eb); InitHeap(eb, SymTab.ArrayElem(t)); (* init the sub-array *) Revive; W(" storel "); W(eb); W(", "); WL(ea); INC(i) END END ELSIF (cls = SymTab.ClRecord) OR (cls = SymTab.ClClass) THEN n := SymTab.FieldCount(t); i := 0; WHILE i < n DO SymTab.FieldName(t, i, fn); ft := SymTab.FieldType(t, fn); ecls := SymTab.ClassOf(ft); IF ecls = SymTab.ClArray THEN (* inline array field: initialize its header in place *) IntStr(SymTab.FieldOffset(t, fn), nb); NewTemp(fa); Op3L("add", fa, addr, nb); InitHeap(fa, ft) ELSIF (ecls = SymTab.ClRecord) OR (ecls = SymTab.ClClass) THEN IntStr(SymTab.FieldOffset(t, fn), nb); NewTemp(fa); Op3L("add", fa, addr, nb); InitHeap(fa, ft) END; INC(i) END END END InitHeap; BEGIN opened := FALSE; inBody := FALSE; dead := FALSE; nTemp := 0; nLab := 0; loopTop := 0; nR := 0; nStr := 0; withTop := 0; noEmit := FALSE; inFunc := FALSE; useStack := FALSE; nLoc := 0; nPar := 0; nArg := 0; nn := 0; callDepth := 0; recvArmed := FALSE; funcDepth := 0; scopeTop := 0; scopeBase[0] := 0; outSel := 0 END QbeGen.