Wirth-AT-grammars/TopSpeedV3-grammar/build/QbeGen.def

DEFINITION MODULE QbeGen;
(* Fresh QBE backend for m2compiler-V3, Step 1: minimal integer pipeline.

   Emits QBE SSA text to "gen_ssa/<Module>.ssa" (run the M2 driver from
   compiler/). Step-1 subset: INTEGER globals/CONSTs, integer
   expressions (+ - * DIV MOD, leading sign, parens), assignment.
   Every expression synthesizes a QBE operand in q (immediate like
   "42"/"-5" or fresh "%tN"); invalid types synthesize "0" so the
   .ssa stays assembleable.

   Test convention: a global VAR ExitCode : INTEGER makes generated
   $main return its value as the process exit code, else return 0. *)

TYPE
  QVal = ARRAY [0 .. 63] OF CHAR;

PROCEDURE OpenModule (name: ARRAY OF CHAR);
(* Opens gen_ssa/<name>.ssa, resets counters. *)

PROCEDURE DeclVar (name: ARRAY OF CHAR; t: INTEGER);
(* Emits "data $name = { w 0 }". t is a SymTab.TypeIndex (reserved
   for later steps; step 1 only sees INTEGER). *)

PROCEDURE DeclConst (name: ARRAY OF CHAR; val: ARRAY OF CHAR; t: INTEGER);
(* Emits "data $name = { w val }" for literal val, else a 0
   placeholder (caller reports 230). *)

PROCEDURE BeginInit (mod: ARRAY OF CHAR);
(* Emits an IMPLEMENTATION module's BEGIN body as `<mod>_init` and
   records it; main calls each at startup. *)

PROCEDURE EndInit;

PROCEDURE BeginBody;
(* Emits "export function w $main() {@start" (once). *)

PROCEDURE EndModule (name: ARRAY OF CHAR);
(* Return sequence, hoisted data, then writes the whole image to
   gen_ssa/<name>.ssa (name = program module). *)

PROCEDURE CloseModule;
(* Closes the .ssa without emitting a function (units whose
   lowering waits for step 4: definitions, implementations,
   and any unit containing nested modules). *)

PROCEDURE DelayBegin;
PROCEDURE DelayEnd;
PROCEDURE DelayFlush;
(* Short-circuit AND/OR: DelayBegin buffers the RHS operand's code,
   DelayEnd restores output, DelayFlush replays the buffer where the
   branch needs it. *)

PROCEDURE Slot4 (VAR s: QVal);
(* s := fresh 4-byte stack slot (address).
   Used to merge short-circuit AND/OR results: each branch stores into
   the slot and the merge block loads it — robust regardless of how
   many blocks the RHS operand's code spans. *)
PROCEDURE StoreW (slot: ARRAY OF CHAR; val: ARRAY OF CHAR);
PROCEDURE LoadW (slot: ARRAY OF CHAR; VAR q: QVal);

PROCEDURE SetNoEmit (b: BOOLEAN);
(* Suppresses all output while TRUE (nested procedures in 4.1:
   SymTab tracks, QbeGen stays silent). *)

PROCEDURE SetModule (name: ARRAY OF CHAR);
(* Names the module being compiled; its globals emit as
   "<mod>_<name>" so separate modules never collide. *)

PROCEDURE Mangled (pname: ARRAY OF CHAR; uid: CARDINAL; VAR q: QVal);
(* q := "name_uid" (function symbols; same-named methods never
   collide; deterministic). *)

PROCEDURE BeginFunc (mangled: ARRAY OF CHAR);
(* Opens function context (locals cleared, header buffering). *)

PROCEDURE SetFuncRes (t: INTEGER);
(* Sets the buffered header's result class. *)

PROCEDURE FuncParam (name: ARRAY OF CHAR; isVar: BOOLEAN;
                     t: INTEGER): BOOLEAN;
(* Records one formal (FALSE past 64 → 233). Header class 'l'
   for all composites; entry copies restore value semantics. *)

PROCEDURE EndFuncHeader;
(* Emits the header + body label + entry copies (params to slots). *)

PROCEDURE AbortFunc;
(* Discards function context without emitting (DefUnit headings,
   FORWARD, methods, nested-in-4.1). *)

PROCEDURE EndFunc (resT: INTEGER);
(* Default return by result class, close, leave function context. *)

PROCEDURE EmitRet (q: ARRAY OF CHAR; hasVal: BOOLEAN);
(* Emits "ret q" (or dummy "ret 0"); always a terminator. *)

PROCEDURE ProcAddr (mangled: ARRAY OF CHAR; VAR q: QVal);
(* q := "$<mangled>" — a procedure's code address as a value (for
   assigning a procedure to a procedure variable). *)

PROCEDURE VirtCallBegin (obj: ARRAY OF CHAR; slot: INTEGER; resT: INTEGER);
(* Begin a virtual (vtable) call: dispatch through obj's slot. *)

PROCEDURE ArmRecv (q: ARRAY OF CHAR);
(* Arms the receiver for the next class-method call (CallBegin passes
   it as the hidden first argument). *)

PROCEDURE CallBegin (mangled: ARRAY OF CHAR; resT: INTEGER;
                       fdep: CARDINAL; isExt: BOOLEAN);
(* Starts accumulating a call's actuals; resolves the static link
   from the caller's context and the callee's lexical depth.
   External (C) callees get no static link. *)

PROCEDURE CallBeginInd (callee: ARRAY OF CHAR; resT: INTEGER;
                         isExt: BOOLEAN);
(* Indirect call through the code pointer `callee`. The static link
   is 0 (top-level procedure values; nested values are not yet
   supported). resT/isExt describe the signature. *)

PROCEDURE CallArg (q: ARRAY OF CHAR; cls: CHAR): BOOLEAN;
(* Appends one typed actual (FALSE when full → 233). *)

PROCEDURE CallEnd (wantRes: BOOLEAN; VAR q: QVal);
(* Emits the call (result temp in q when wanted). *)

PROCEDURE InitStack (addr: ARRAY OF CHAR; t: INTEGER);
(* Like InitHeap but nested objects go to stack slots. *)

PROCEDURE ArgClass (t: INTEGER): CHAR;
(* Formal/actual class for call emission. *)

PROCEDURE LocFull (): BOOLEAN;
(* TRUE past 64 locals in the current scope (→ 233). *)

PROCEDURE NewTemp (VAR t: QVal);
(* Fresh "%tN" operand (deterministic counter: fixpoint-safe). *)

PROCEDURE NewLabel (VAR l: QVal);
(* Fresh "@LN" label (deterministic counter). *)

PROCEDURE EmitLabel (l: ARRAY OF CHAR);
PROCEDURE Jmp (l: ARRAY OF CHAR);
PROCEDURE Jnz (c, t, f: ARRAY OF CHAR);
(* "jnz c, @t, @f". *)

PROCEDURE Cmp (op: INTEGER; l, r: ARRAY OF CHAR; VAR q: QVal;
              isReal: BOOLEAN);
(* Integer comparison selected by a SymTab.OpEq..OpGe code
   (ceqw/cnew/csltw/cslew/csgtw/csgew); q := fresh w holding 0/1.
   isReal reserved; step 2 passes FALSE. *)

PROCEDURE CmpL (op: INTEGER; l, r: ARRAY OF CHAR; VAR q: QVal);
(* Address comparison (ceql/cnel, =/# only); q := fresh w. *)

PROCEDURE NewHeap (t: INTEGER; VAR q: QVal);
(* q := malloc(HeapSize(t)) via extern call (object skeleton). *)

PROCEDURE FreeHeap (v: ARRAY OF CHAR);
(* call $free(l v). Shallow (nested objects leak — documented). *)

PROCEDURE InitHeap (addr: ARRAY OF CHAR; t: INTEGER);
(* Stores static counts and allocates nested objects recursively;
   elements/members otherwise garbage per Wirth. *)

PROCEDURE NotQ (a: ARRAY OF CHAR; VAR q: QVal);
(* q := fresh w holding "NOT a" (xor 1, a). *)

PROCEDURE CapQ (a: ARRAY OF CHAR; VAR q: QVal);
(* q := fresh w holding UPCASE(a): ASCII a-z mapped to A-Z. *)

PROCEDURE PushLoop (exit: ARRAY OF CHAR);
PROCEDURE PopLoop;
PROCEDURE TopLoop (VAR exit: QVal): BOOLEAN;
(* Innermost LOOP exit label; FALSE when outside any LOOP. *)

PROCEDURE LoadVar (name: ARRAY OF CHAR; isReal: BOOLEAN; VAR q: QVal);
(* q := fresh temp holding $name (isReal reserved; step 1: FALSE). *)

PROCEDURE LoadPtr (name: ARRAY OF CHAR; VAR q: QVal);
(* q := fresh l temp holding the pointer $name. *)

PROCEDURE LoadDesignator (name: ARRAY OF CHAR; t: INTEGER; k: INTEGER;
                           VAR q: QVal): BOOLEAN;
(* Loads a resolved designator by kind/type class (used for
   qualified L.x access). FALSE for kinds with no value (230). *)

PROCEDURE StoreVar (name: ARRAY OF CHAR; q: ARRAY OF CHAR; isReal: BOOLEAN);
(* "storew q, $name" (isReal reserved; step 1: FALSE). *)

PROCEDURE StorePtr (name: ARRAY OF CHAR; q: ARRAY OF CHAR);
(* "storel q, $name". *)

PROCEDURE LoadLong (name: ARRAY OF CHAR; VAR q: QVal);
(* q := fresh l temp holding the 64-bit value $name. *)

PROCEDURE StoreLong (name: ARRAY OF CHAR; q: ARRAY OF CHAR);
(* "storel q, $name" for 64-bit integers. *)

PROCEDURE WidenLong (a: ARRAY OF CHAR; VAR q: QVal);
(* INTEGER (w) -> LONGINT (l) via extsw. *)

PROCEDURE CmpLong (op: INTEGER; l, r: ARRAY OF CHAR; VAR q: QVal);
(* 64-bit comparison (ceql/cnel/csltl/...); q is fresh w 0/1. *)

PROCEDURE Op3 (mn: ARRAY OF CHAR; res, l, r: ARRAY OF CHAR;
               isReal: BOOLEAN);
(* "res =w mn l, r" with mn = add/sub/mul/div/rem. *)

PROCEDURE AbsQ (a: ARRAY OF CHAR; VAR q: QVal; isReal: BOOLEAN);
(* q := |a| (compare + negate-select). *)

PROCEDURE NegQ (a: ARRAY OF CHAR; VAR q: QVal; isReal: BOOLEAN);
(* q := fresh temp holding "-a". a and q must differ. *)

PROCEDURE NarrowLong (a: ARRAY OF CHAR; VAR q: QVal);
(* LONGINT -> INTEGER (low 32 bits). *)

PROCEDURE ConvRI (a: ARRAY OF CHAR; VAR q: QVal);
(* REAL -> INTEGER (truncate). *)

PROCEDURE ConvRL (a: ARRAY OF CHAR; VAR q: QVal);
(* REAL -> LONGINT (truncate). *)

PROCEDURE ConvLR (a: ARRAY OF CHAR; VAR q: QVal);
(* LONGINT -> REAL. *)

PROCEDURE ConvIR (a: ARRAY OF CHAR; VAR q: QVal);
(* q := fresh double holding "swtof a" (INTEGER -> REAL widening). *)

PROCEDURE CopyOp (s: ARRAY OF CHAR; VAR d: ARRAY OF CHAR);

PROCEDURE NoteAddr (val: ARRAY OF CHAR; addr: ARRAY OF CHAR);
(* Records a value-temp → address mapping for VAR actuals. *)

PROCEDURE AddrOfVal (val: ARRAY OF CHAR; VAR addr: QVal): BOOLEAN;
(* Retrieves the recorded address (FALSE → actual is not an
   addressable designator → 233). *)
PROCEDURE AddrOf (name: ARRAY OF CHAR; VAR q: QVal);
(* q := "$name" descriptor-address operand. *)
PROCEDURE IntStr (v: INTEGER; VAR s: QVal);
PROCEDURE NormInt (s: ARRAY OF CHAR; VAR d: QVal);
(* "0xFF" -> "255"; plain decimals copied through. *)

PROCEDURE NormLit (s: ARRAY OF CHAR; VAR d: QVal; VAR isCh: BOOLEAN);
(* Full V3 integer literal normalization:
      "12"                -> "12"            (decimal)
      "60B"/"60b"         -> "48"            (octal, suffix stripped)
      "0FFH"/"0ffh"       -> "255"           (hex)
      "0x1F"/"0X20"       -> "31"/"32"       (hex)
      "0C"/"03C"/"012C"   -> "0"/"3"/"12"    (hex, isCh := TRUE)
   isCh is TRUE for the character-constant C/c suffix only. *)

PROCEDURE NormReal (s: ARRAY OF CHAR; VAR d: QVal);
(* "3.14" -> "d_3.14" (QBE double immediates carry a d_ prefix). *)

PROCEDURE CharVal (s: ARRAY OF CHAR): INTEGER;
(* ORD of a 1-character literal such as 'a'. *)

PROCEDURE NegFold (a: ARRAY OF CHAR; VAR q: QVal);
(* Folds unary minus into a literal ("5" -> "-5"). Safe for same var. *)

PROCEDURE IsImm (s: ARRAY OF CHAR): BOOLEAN;
(* TRUE for literal operands (not %temporaries). *)

PROCEDURE Fold2 (kind: INTEGER; a, b: ARRAY OF CHAR; VAR r: QVal): BOOLEAN;
(* Constant-folds integer binary ops when both operands are signed
   decimal literals: kind 0=+ 1=- 2=* 3=DIV 4=MOD. r gets the result
   and TRUE is returned; otherwise r is untouched and FALSE. *)

PROCEDURE Remark (s: ARRAY OF CHAR);
(* Emits a "# s" comment line. *)

(* ---------------- arrays (step 3.1: length-prefixed layout) ---------------- *)
(* Every array value: LONGCARD count + packed elements. Indexes and
   counts are LONGCARD (l) inside emitted code; immediates pass
   through, w-temps widen via extsw. *)

PROCEDURE DeclArr (name: ARRAY OF CHAR; t: INTEGER);
(* Recursive data emission for fixed arrays (`data $name = { l n,
   ... }`, nested levels as `$name_i`). CHAR→b, int-family/bool/
   enum→w, REAL→d, nested/pointer→l, all zero. *)

PROCEDURE DeclStr (text: ARRAY OF CHAR; VAR q: QVal);
(* Emits `data $strN = { l len, b ... }` for a quoted literal and
   returns its address operand. Deterministic counter. *)

PROCEDURE DeclUStr (text: ARRAY OF CHAR; VAR q: QVal;
                    VAR single: BOOLEAN; VAR cp: INTEGER;
                    VAR ok: BOOLEAN);
(* Strict RFC3629-decode a `U'...'`/`U"..."` lexeme. one codepoint ->
   single=TRUE, cp=it; otherwise a UString descriptor ($ustrN) in q.
   ok=FALSE on invalid UTF-8 (caller reports 234). *)

PROCEDURE DeclCharStr (ch: ARRAY OF CHAR; VAR q: QVal);
(* ch is the decimal ordinal of a CHAR literal; emits the equivalent
   1-character string descriptor and returns its address. Lets a
   1-char string literal be passed to an ARRAY OF CHAR formal. *)

PROCEDURE WidenIndex (idx: ARRAY OF CHAR; VAR q: QVal);
(* Immediates copy through; w-temps widen via extsw to l. *)

PROCEDURE OpenHi (base: ARRAY OF CHAR; VAR q: QVal);
(* q := loadl(base) - 1 in l (open-array upper bound). *)

PROCEDURE OpenHiChar (base: ARRAY OF CHAR; VAR q: QVal);
(* q := loadl(base) in l (CHAR arrays allow index = count: the NUL
   terminator slot). *)

PROCEDURE LoadCount (base: ARRAY OF CHAR; VAR q: QVal);
(* q := loadl(base) in l (open-array element count). *)

PROCEDURE CheckRange (idx, lo, hi: ARRAY OF CHAR);
(* Trap unless lo <= idx <= hi (l-domain operands). *)

PROCEDURE ElemAddr (base, idx, lo: ARRAY OF CHAR; elemT: INTEGER;
                    VAR q: QVal);
(* q := base + 8 + (idx - lo) * elemSizeOf(elemT's array) in l.
   elemT is the array descriptor (open or fixed). *)

PROCEDURE ElemLoad (addr: ARRAY OF CHAR; t: INTEGER; VAR q: QVal);
PROCEDURE ElemStore (addr, v: ARRAY OF CHAR; t: INTEGER);
(* Element access by element-type index (CHAR→loadub … nested→loadl). *)

PROCEDURE Op3L (mn: ARRAY OF CHAR; res, l, r: ARRAY OF CHAR);
(* "=l mn l, r" (address/count arithmetic). *)

PROCEDURE CopyArray (dst: ARRAY OF CHAR; src: ARRAY OF CHAR;
                      t: INTEGER);
(* Whole-array copy with runtime count check + blit, recursive for
   nested levels via a runtime loop. Counts mismatch traps. *)

PROCEDURE HaltQ;
(* HALT: terminate the process via exit(1) (noreturn). *)

PROCEDURE Trap;
(* call $abort(); hlt. Interim trap until runtime/syslib/Trap;
   sets the dead flag (terminator). *)

(* ---------------- sets (step 3.3: multi-word masks, no header) ---------------- *)
(* Set values are memory addresses (globals or alloc8 temps holding
   W words). All counts static; bit positions runtime-checked. *)

PROCEDURE DeclSet (name: ARRAY OF CHAR; t: INTEGER);
(* `data $name = { w 0, ... }` with SetWords(t) words (fallback
   single word when unsuitable — grammar already 230'd it). *)

PROCEDURE NewSetTemp (words: CARDINAL; VAR q: QVal);
(* Fresh alloc8 stack slot for a set value; q is its address. *)

PROCEDURE SetZero (addr: ARRAY OF CHAR; words: CARDINAL);
(* Zeroes W words at addr. *)

PROCEDURE SetBit (addr: ARRAY OF CHAR; val: ARRAY OF CHAR;
                   lo: INTEGER; span: CARDINAL);
(* ORs one element in: bit = val - lo, trapped outside [0, span). *)

PROCEDURE SetRange (addr: ARRAY OF CHAR; a: ARRAY OF CHAR;
                     b: ARRAY OF CHAR; lo: INTEGER; span: CARDINAL);
(* ORs every value in [a..b] (empty when inverted): ends trapped
   in span, then a w-domain counter loop over SetBit. *)

PROCEDURE SetBinOp (sel: INTEGER; l: ARRAY OF CHAR; r: ARRAY OF CHAR;
                    lw, rw: CARDINAL; VAR q: QVal);
(* sel 0 union / 1 intersection / 2 difference / 3 symdiff over
   possibly different spans (overlap via op, extras copied or
   zeroed); result has max words, q is its address. *)

PROCEDURE StrEq (op: INTEGER; l, r: ARRAY OF CHAR; VAR q: QVal);
(* String equality (`=`/`OpNeq`) via the shim; result BOOLEAN. *)

PROCEDURE StrLen (s: ARRAY OF CHAR; VAR q: QVal);
(* q := the string length (characters before the NUL), INTEGER. *)

PROCEDURE StrAssign (dst, src: ARRAY OF CHAR);
(* Content copy of a string into a CHAR array (NUL-terminated). *)

PROCEDURE UAssign (dst, src: ARRAY OF CHAR);
(* Content copy of a U"..." descriptor into a UCHAR array. *)

PROCEDURE UStrLen (s: ARRAY OF CHAR; VAR q: QVal);
(* q := the UString codepoint count (INTEGER). *)

PROCEDURE DecQ (VAR q: QVal);
(* q := q - 1 (l domain). *)

PROCEDURE UStrCat (a, b: ARRAY OF CHAR; VAR q: QVal);
(* q := a + b in the shim's UString concat buffer. *)

PROCEDURE UStrFrom (cp: ARRAY OF CHAR; VAR q: QVal);
(* q := a 1-codepoint UString descriptor for the UCHAR value cp. *)

PROCEDURE StrCat (a, b: ARRAY OF CHAR; VAR q: QVal);
(* q := a + b in the shim's concat buffer (a descriptor address). *)

PROCEDURE CmpSet (op: INTEGER; l: ARRAY OF CHAR; r: ARRAY OF CHAR;
                  lw, rw: CARDINAL; VAR q: QVal);
(* =/# over min words plus zero-checks on the larger side's extras;
   q is fresh w 0/1. op is a SymTab.OpEq/Neq code. *)

PROCEDURE CopySet (dst: ARRAY OF CHAR; src: ARRAY OF CHAR;
                    dw, sw: CARDINAL);
(* Copies min words via memcpy, zero-fills dst extras. *)

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. *)

(* ---------------- records (step 3.4: flat blobs, pointer fields) ---------------- *)
(* Records are flat: scalars/sets inline, array fields as 8-byte
   pointers to static descriptors, nested records inline. Field
   offsets are static (SymTab.FieldOffset). *)

PROCEDURE DeclRec (name: ARRAY OF CHAR; t: INTEGER);
(* `data $name = { ... }` flat emission with per-field statics. *)

PROCEDURE FieldAddr (base: ARRAY OF CHAR; off: INTEGER; VAR q: QVal);
(* q := base + off in l, fresh temp. *)

PROCEDURE ThisBase (VAR q: QVal);
(* The current method's receiver address (hidden THIS VAR parameter). *)

PROCEDURE PushWith (base: ARRAY OF CHAR);
PROCEDURE PopWith;
PROCEDURE TopWith (VAR base: QVal): BOOLEAN;
(* Innermost WITH base address; FALSE outside any WITH. *)

PROCEDURE CopyRecord (dst: ARRAY OF CHAR; src: ARRAY OF CHAR;
                       t: INTEGER);
(* Deep whole-record copy: scalars/sets by load/store, arrays via
   CopyArray on dereferenced fields, nested records recurse. *)

(* ---------------- internal helpers ---------------- *)
(* Declared here so they are visible throughout the implementation
   (ISO Modula-2: declaration before use) without FORWARD, which the
   gm2 whole-program pass rejects. Not part of the backend's usable
   API; do not call from generated parser code. *)

PROCEDURE LocFindUp (name: ARRAY OF CHAR; VAR levels: CARDINAL;
                     VAR flat: INTEGER): BOOLEAN;
PROCEDURE LocAdd (name: ARRAY OF CHAR; tag: INTEGER; rep: ARRAY OF CHAR;
                   cls: CHAR; typ: INTEGER);
PROCEDURE ResClass (t: INTEGER): CHAR;
PROCEDURE AllocLocal (t: INTEGER; VAR slot: QVal);
PROCEDURE HApp (s: ARRAY OF CHAR);
PROCEDURE UpAddrOf (flat: INTEGER; levels: CARDINAL; VAR q: QVal);
PROCEDURE Revive;
PROCEDURE FlushStrings;

PROCEDURE EmitVTables;
(* Emit a data array per class that has virtual methods. *)

PROCEDURE VtRef (t: INTEGER; VAR q: QVal);
(* The class's vtable symbol ($vt_<typeindex>). *)

PROCEDURE FlushUStrings;
(* Emit the recorded UString literal descriptors as top-level data. *)
PROCEDURE ArrData (name: ARRAY OF CHAR; t: INTEGER);
PROCEDURE HeapSize (t: INTEGER): CARDINAL;

END QbeGen.