M2compiler-V3/compiler/src/SymTab.mod

IMPLEMENTATION MODULE SymTab;

IMPORT FileIO;
FROM Storage IMPORT ALLOCATE;  (* gm2 needs this for NEW substitution *)

CONST
  MaxTypes  = 4096;
  MaxVt     = 1024;   (* total virtual-method slots across all classes *)
  MaxPend   = 256;
  MaxMods   = 64;
  ResDepth  = 64;
  MaxPP     = 1024;   (* total procedure-type parameter slots *)
  MaxEnumLit = 8192;  (* enumeration literals, for export/import *)

  (* descriptor forms *)
  FNone = 0; FAlias = 1; FSub = 2; FEnum = 3; FArray = 4;
  FRecord = 5; FSet = 6; FPtr = 7; FStr = 8;
  FInt = 9; FReal = 10; FChar = 11; FBool = 12;
  FClass = 13; FOpenArr = 14; FNil = 15; FLong = 16; FProc = 17;
  FUChar = 18; FUStr = 19;

  (* signatures compared by the strict 231 check are bounded to this many
     formals (self-hosting uses far fewer). *)
  MaxSnap = 16;
  HighSnap = MaxSnap - 1;

TYPE
  SymPtr = POINTER TO SymNode;
  ScopePtr = POINTER TO ScopeNode;
  FieldPtr = POINTER TO FieldNode;
  SymNode = RECORD
    name  : Name;
    kind  : INTEGER;
    typ   : TypeIndex;
    scope : ScopePtr;   (* owning scope *)
    left  : SymPtr;     (* BST links within the owning scope *)
    right : SymPtr;
    rslt  : TypeIndex;  (* KindProc result type, InvalidType = none *)
    plink : SymPtr;     (* next formal, positional chain *)
    isVar : BOOLEAN;    (* KindParam: VAR formal *)
    fwd   : BOOLEAN;    (* KindProc: FORWARD body pending *)
    virt  : BOOLEAN;    (* KindProc: VIRTUAL method *)
    fdep  : CARDINAL;   (* KindProc: lexical function-nesting depth *)
    snapRes : TypeIndex;  (* KindProc: DEFINITION result (ResumeProc) *)
    snapT : ARRAY [0 .. MaxSnap - 1] OF TypeIndex;  (* DEF formal types *)
    snapV : ARRAY [0 .. MaxSnap - 1] OF BOOLEAN;    (* DEF formal VARs *)
    nSnap : CARDINAL;   (* KindProc: number of snapshot formals *)
    fsnap : BOOLEAN;    (* KindProc: signature snapshotted, compare *)
    vslot : INTEGER;    (* KindProc VIRTUAL: vtable slot (-1 = none) *)
    hasBody : BOOLEAN;  (* KindProc: a body was resumed/emitted *)
    ext   : BOOLEAN;    (* KindProc: EXTERNAL (no body emitted) *)
    link  : Name;       (* KindProc: external link (C) name *)
    varargs : BOOLEAN;  (* KindProc: C varargs (FROM libc IMPORT) *)
    sym   : Name;       (* base symbol name (differs from name for
                           qualified aliases) *)
    mod   : Name;       (* defining module (for QBE global names) *)
    uid   : CARDINAL;   (* KindProc: unique id for name mangling *)
    val   : Name;       (* KindConst: literal value text, "" if none *)
  END;
  ScopeNode = RECORD
    parent : ScopePtr;  (* scope tree link *)
    root   : SymPtr;    (* BST root of this scope's symbols *)
    level  : CARDINAL;
    link   : ScopePtr;  (* creation-order chain for PrintTable *)
    ofRec  : TypeIndex; (* record/class whose members live here *)
  END;
  FieldNode = RECORD
    name  : Name;
    typ   : TypeIndex;
    owner : TypeIndex;
    next  : FieldPtr;   (* next field of the same owner *)
    off   : INTEGER;    (* declaration-order byte offset *)
    ord   : CARDINAL;   (* declaration rank (chain is reverse) *)
  END;

VAR
  curScope : ScopePtr;
  scopeList : ScopePtr;  (* all scopes, creation order *)
  scopeTail : ScopePtr;
  fields : FieldPtr;     (* all record fields, newest first *)
  nFields : CARDINAL;
  pend : ARRAY [0 .. MaxPend - 1] OF SymPtr;
  nPend : CARDINAL;
  pendF : ARRAY [0 .. MaxPend - 1] OF FieldPtr;
  nPendF : CARDINAL;
  tform : ARRAY [0 .. MaxTypes - 1] OF INTEGER;
  tref : ARRAY [0 .. MaxTypes - 1] OF TypeIndex;
  tbytebuf : ARRAY [0 .. MaxTypes - 1] OF BOOLEAN; (* ARRAY OF BYTE open formal (gm2 ext) *)
  tlo : ARRAY [0 .. MaxTypes - 1] OF INTEGER;
  thi : ARRAY [0 .. MaxTypes - 1] OF INTEGER;
  tenum : ARRAY [0 .. MaxTypes - 1] OF CARDINAL; (* enum literal count *)
  (* Enumeration literals, keyed by their enum type: an enum type's
     literals are exported/imported together with the type (ISO). *)
  enumLitN : CARDINAL;
  enumLitDone : ARRAY [0 .. MaxTypes - 1] OF BOOLEAN;
  enumLitStart : ARRAY [0 .. MaxTypes - 1] OF CARDINAL;
  enumLitNm : ARRAY [0 .. MaxEnumLit * 64 - 1] OF CHAR;  (* flat *)
  (* module-level forward type references awaiting completion *)
  pfwdN : CARDINAL;
  pfwdName : ARRAY [0 .. 255] OF Name;
  pfwdT : ARRAY [0 .. 255] OF TypeIndex;
  (* deferred procedure bodies (two-phase parse): a skipped body's own
     scope, saved while still current, restored for the re-parse pass *)
  uidBase : ARRAY [0 .. 1023] OF Name;  (* uid -> base name (mangling) *)
  nDefer : CARDINAL;
  deferProc : ARRAY [0 .. 255] OF SymPtr;
  deferScope : ARRAY [0 .. 255] OF ScopePtr;
  tparent : ARRAY [0 .. MaxTypes - 1] OF TypeIndex;
  tscope : ARRAY [0 .. MaxTypes - 1] OF ScopePtr;
  tdone : ARRAY [0 .. MaxTypes - 1] OF BOOLEAN;
  (* per-class vtables: each class owns a slice of the shared pool *)
  vtBase : ARRAY [0 .. MaxTypes - 1] OF CARDINAL;
  nVirt  : ARRAY [0 .. MaxTypes - 1] OF CARDINAL;
  vtName : ARRAY [0 .. MaxVt - 1] OF Name;      (* virtual method name *)
  vtUid  : ARRAY [0 .. MaxVt - 1] OF CARDINAL;  (* its uid *)
  vtTop  : CARDINAL;
  vtBuilt : ARRAY [0 .. MaxTypes - 1] OF BOOLEAN;
  tvptr  : ARRAY [0 .. MaxTypes - 1] OF INTEGER;  (* vptr field offset, -1 none *)
  vtl    : ARRAY [0 .. MaxTypes - 1] OF TypeIndex;  (* classes with a vtable *)
  nVtl   : CARDINAL;
  (* class whose CLASS IMPLEMENTATION body is currently open (nested
     impls stack); bare method names resolve against it *)
  implStk : ARRAY [0 .. 15] OF TypeIndex;
  nImpl   : CARDINAL;
  tvtag : ARRAY [0 .. MaxTypes - 1] OF BOOLEAN;  (* record has variants *)
  ttag : ARRAY [0 .. MaxTypes - 1] OF FieldPtr;  (* variant CASE selector *)
  alo : ARRAY [0 .. MaxTypes - 1] OF INTEGER;
  ahi : ARRAY [0 .. MaxTypes - 1] OF INTEGER;
  blo : ARRAY [0 .. 7] OF INTEGER;
  bhi : ARRAY [0 .. 7] OF INTEGER;
  nBounds : CARDINAL;
  nTypes : CARDINAL;
  curProc : SymPtr;   (* heading being declared *)
  curPTail : SymPtr;  (* positional param chain tail *)
  snapT : ARRAY [0 .. 15] OF TypeIndex;  (* signature snapshot scratch *)
  snapV : ARRAY [0 .. 15] OF BOOLEAN;
  procStk : ARRAY [0 .. 15] OF SymPtr;
  nProc : CARDINAL;
  nextUid : CARDINAL;
  dInt, dCard, dReal, dChar, dBool, dNil, dAddr, dLong : TypeIndex;
  dUChar : TypeIndex;    (* UCHAR: 32-bit codepoint *)
  dBitset : TypeIndex;   (* BITSET = SET OF [0..15] *)
  dProc : TypeIndex;     (* PROC: parameterless procedure type *)
  globScope : ScopePtr;  (* the global scope (module names live here) *)
  curMod : INTEGER;      (* current registry slot, -1 between units *)
  curUnit : INTEGER;     (* UnitProg/Def/Impl, -1 between units *)
  nMods : CARDINAL;
  modNames : ARRAY [0 .. MaxMods - 1] OF Name;
  modScopes : ARRAY [0 .. MaxMods - 1] OF ScopePtr;
  modKind : ARRAY [0 .. MaxMods - 1] OF INTEGER;
  modImpl : ARRAY [0 .. MaxMods - 1] OF BOOLEAN;
  haveProg : BOOLEAN;
  typeBlockDepth : CARDINAL;  (* > 0 inside a TYPE block *)
  procp    : ARRAY [0 .. MaxPP - 1] OF TypeIndex;  (* proc-type params *)
  procvis  : ARRAY [0 .. MaxPP - 1] OF BOOLEAN;    (* VAR flags *)
  procstart : ARRAY [0 .. MaxTypes - 1] OF CARDINAL;
  procn    : ARRAY [0 .. MaxTypes - 1] OF CARDINAL;
  nProcP   : CARDINAL;

(* ---------------- strings ---------------- *)

PROCEDURE Assign (VAR dest: ARRAY OF CHAR; src: ARRAY OF CHAR);
  VAR i : CARDINAL;
  BEGIN
    i := 0;
    WHILE (i < HIGH(dest)) AND (src[i] # CHR(0)) DO
      dest[i] := src[i]; INC(i)
    END;
    dest[i] := CHR(0)
  END Assign;

PROCEDURE Equal (a, b: ARRAY OF CHAR): BOOLEAN;
  VAR i : CARDINAL;
  BEGIN
    i := 0;
    LOOP
      IF a[i] # b[i] THEN RETURN FALSE END;
      IF a[i] = CHR(0) THEN RETURN TRUE END;
      INC(i)
    END
  END Equal;

PROCEDURE Less (a, b: ARRAY OF CHAR): BOOLEAN;
(* Lexicographic order on NUL-terminated strings (BST key order). *)
  VAR i : CARDINAL;
  BEGIN
    i := 0;
    LOOP
      IF a[i] # b[i] THEN RETURN ORD(a[i]) < ORD(b[i]) END;
      IF a[i] = CHR(0) THEN RETURN FALSE END;
      INC(i)
    END
  END Less;

PROCEDURE StrLen (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 StrLen;

PROCEDURE ConstInt (q: ARRAY OF CHAR; VAR v: INTEGER): BOOLEAN;
  VAR i, d: CARDINAL;
    neg: BOOLEAN;
  BEGIN
    v := 0; i := 0; neg := FALSE;
    IF q[0] = "-" THEN neg := TRUE; i := 1 END;
    IF (i >= HIGH(q)) OR (q[i] = CHR(0)) THEN RETURN FALSE END;
    WHILE (i < HIGH(q)) AND (q[i] # CHR(0)) DO
      d := ORD(q[i]);
      IF (d < ORD("0")) OR (d > ORD("9")) THEN RETURN FALSE END;
      v := v * 10 + VAL(INTEGER, d - ORD("0")); INC(i)
    END;
    IF neg THEN v := -v END;
    RETURN TRUE
  END ConstInt;

(* ---------------- scope tree + per-scope BST ---------------- *)

PROCEDURE NewScope (parent: ScopePtr; level: CARDINAL): ScopePtr;
(* Heap-allocates a scope and appends it to the creation chain. *)
  VAR s: ScopePtr;
  BEGIN
    NEW(s);
    s^.parent := parent;
    s^.root := NIL;
    s^.level := level;
    s^.link := NIL;
    s^.ofRec := InvalidType;
    IF scopeList = NIL THEN scopeList := s ELSE scopeTail^.link := s END;
    scopeTail := s;
    RETURN s
  END NewScope;

PROCEDURE TreeFind (root: SymPtr; name: ARRAY OF CHAR): SymPtr;
(* BST search within one scope; NIL if absent. *)
  BEGIN
    WHILE root # NIL DO
      IF Equal(root^.name, name) THEN RETURN root END;
      IF Less(name, root^.name) THEN root := root^.left
      ELSE root := root^.right
      END
    END;
    RETURN NIL
  END TreeFind;

PROCEDURE TreeInsert (s: ScopePtr; node: SymPtr): BOOLEAN;
(* BST insert of node into scope s; FALSE on duplicate. *)
  VAR cur, parent: SymPtr;
    goLeft: BOOLEAN;
  BEGIN
    cur := s^.root; parent := NIL; goLeft := FALSE;
    WHILE cur # NIL DO
      IF Equal(cur^.name, node^.name) THEN RETURN FALSE END;
      parent := cur;
      IF Less(node^.name, cur^.name) THEN
        cur := cur^.left; goLeft := TRUE
      ELSE
        cur := cur^.right; goLeft := FALSE
      END
    END;
    node^.left := NIL;
    node^.right := NIL;
    node^.scope := s;
    IF parent = NIL THEN s^.root := node
    ELSIF goLeft THEN parent^.left := node
    ELSE parent^.right := node
    END;
    RETURN TRUE
  END TreeInsert;

PROCEDURE FindScope (name: ARRAY OF CHAR; s0: ScopePtr): SymPtr;
(* Innermost visible node from scope s0, or NIL; walks the chain up. *)
  VAR s: ScopePtr;
    r: SymPtr;
  BEGIN
    s := s0;
    WHILE s # NIL DO
      r := TreeFind(s^.root, name);
      IF r # NIL THEN RETURN r END;
      s := s^.parent
    END;
    RETURN NIL
  END FindScope;

PROCEDURE Find (name: ARRAY OF CHAR): SymPtr;
(* Innermost visible node or NIL; walks the scope chain up. *)
  BEGIN
    RETURN FindScope(name, curScope)
  END Find;

PROCEDURE SetNodeMod (node: SymPtr);
(* Records the defining module for global-symbol naming. *)
  BEGIN
    IF curMod >= 0 THEN Assign(node^.mod, modNames[curMod])
    ELSE node^.mod[0] := CHR(0)
    END
  END SetNodeMod;

PROCEDURE RawEnter (name: ARRAY OF CHAR; kind: INTEGER): SymPtr;
(* Heap-allocates a symbol and links it into the current scope's
   BST; NIL on duplicate (node released to nobody: dropped). *)
  VAR node: SymPtr;
  BEGIN
    NEW(node);
    Assign(node^.name, name);
    Assign(node^.sym, name);
    SetNodeMod(node);
    node^.kind := kind;
    node^.typ := InvalidType;
    node^.scope := curScope;
    node^.left := NIL;
    node^.right := NIL;
    node^.val[0] := CHR(0);
    node^.fsnap := FALSE;   (* no DEFINITION signature snapshotted *)
    node^.ext := FALSE;
    node^.varargs := FALSE;
    IF NOT TreeInsert(curScope, node) THEN RETURN NIL END;
    RETURN node
  END RawEnter;

PROCEDURE Enter (name: ARRAY OF CHAR; kind: INTEGER): BOOLEAN;
  BEGIN
    RETURN RawEnter(name, kind) # NIL
  END Enter;

PROCEDURE ReenterModGlobal (name: ARRAY OF CHAR; kind: INTEGER;
                            modName: ARRAY OF CHAR): BOOLEAN;
  VAR node: SymPtr;
  BEGIN
    node := RawEnter(name, kind);
    IF node = NIL THEN RETURN FALSE END;
    Assign(node^.mod, modName);
    RETURN TRUE
  END ReenterModGlobal;

PROCEDURE EnterPending (name: ARRAY OF CHAR; kind: INTEGER): BOOLEAN;
  VAR node: SymPtr;
  BEGIN
    node := RawEnter(name, kind);
    IF (node # NIL) AND (nPend < MaxPend) THEN
      pend[nPend] := node; INC(nPend)
    END;
    RETURN node # NIL
  END EnterPending;

PROCEDURE VarParamOk (actual, formal: TypeIndex): BOOLEAN;
(* Addressable-designator compatibility for VAR formals: same type,
   or fixed array into open array with same element type, or string
   literal into open CHAR array. *)
  VAR fa, fe: TypeIndex;
  BEGIN
    IF (actual = InvalidType) OR (formal = InvalidType) THEN
      RETURN TRUE
    END;
    IF SameType(actual, formal) THEN RETURN TRUE END;
    (* ADDRESS is interchangeable with any pointer for VAR params
       (ADDRESS is a predefined alias, so ClassOf is enough here) *)
    IF (formal = dAddr) AND (ClassOf(actual) = ClPtr) THEN
      RETURN TRUE
    END;
    IF (actual = dAddr) AND (ClassOf(formal) = ClPtr) THEN
      RETURN TRUE
    END;
    IF IsOpenArray(formal)
 AND (ClassOf(actual) = ClArray) AND (ArrayDepth(actual) = 1) THEN
      fa := ArrayElem(actual); fe := ArrayElem(formal);
      IF SameType(fa, fe) THEN RETURN TRUE END
    END;
    IF IsOpenArray(formal) AND (ClassOf(actual) = ClStr) THEN
      fe := ArrayElem(formal);
      IF ClassOf(fe) = ClChar THEN RETURN TRUE END
    END;
    IF IsOpenArray(formal) AND (ClassOf(actual) = ClUStr) THEN
      fe := ArrayElem(formal);
      IF ClassOf(fe) = ClUChar THEN RETURN TRUE END
    END;
    (* gm2 compatibility: a scalar VAR actual of a *different* type is
       accepted when it has the same storage footprint (e.g. INTEGER for
       VAR WORD, SHORTREAL for VAR WORD).  Composite types stay strict. *)
    IF (ClassOf(actual) # ClArray) AND (ClassOf(actual) # ClRecord)
       AND (ClassOf(actual) # ClClass)
       AND (ClassOf(formal) # ClArray) AND (ClassOf(formal) # ClRecord)
       AND (ClassOf(formal) # ClClass)
       AND (ObjectSize(actual) > 0) AND (ObjectSize(actual) = ObjectSize(formal)) THEN
      RETURN TRUE
    END;
    RETURN FALSE
  END VarParamOk;

PROCEDURE FormalOk (a, b: TypeIndex): BOOLEAN;
(* Value-formal equivalence for the strict 231 check: the same type, or
   both integer-family (one family per the scalar model), or two
   string-compatible types. *)
  BEGIN
    IF (a = InvalidType) OR (b = InvalidType) THEN
      (* an unresolved type is not honest evidence; treat as ok so a
         single root 221/201 is not multiplied by 231 *)
      RETURN TRUE
    END;
    IF SameType(a, b) THEN RETURN TRUE END;
    IF IsIntFamily(a) AND IsIntFamily(b) THEN RETURN TRUE END;
    (* Open-array formals are structurally compatible when their element
       types match: each `ARRAY OF T` declaration allocates a fresh
       descriptor, so a DEFINITION/IMPLEMENTATION pair never shares the
       type index and SameType would otherwise reject it. *)
    IF IsOpenArray(a) AND IsOpenArray(b) THEN
      RETURN SameType(ArrayElem(a), ArrayElem(b))
    END;
    (* Procedure types are built fresh per parse, so a
       DEFINITION/IMPLEMENTATION pair never shares the index; compare
       structurally (same result and parameter types). *)
    IF (tform[Resolve(a)] = FProc) AND (tform[Resolve(b)] = FProc) THEN
      RETURN ProcTypesOk(Resolve(a), Resolve(b))
    END;
    RETURN StrCompat(a, b)
  END FormalOk;

PROCEDURE FixPending (t: TypeIndex) : BOOLEAN;
(* Assigns type t to all pending entries, clears the buffer, and
   returns TRUE.  When the current procedure heading resumed a
   DEFINITION (snapshot present), this is where a formal's type is
   known, so the just-typed formals are compared against the
   snapshot: FALSE = a strict-231 mismatch. *)
  VAR i, base, k, n: CARDINAL;
    f: SymPtr;
    isV, ok: BOOLEAN;
  BEGIN
    n := nPend;              (* formals typed by this call *)
    i := 0;
    WHILE i < nPend DO
      pend[i]^.typ := t; INC(i)
    END;
    nPend := 0;
    IF (curProc = NIL) OR (curProc^.nSnap = 0) THEN RETURN TRUE END;
    (* number of formals already in the chain *)
    base := 0;
    f := curProc^.plink;
    WHILE f # NIL DO INC(base); f := f^.plink END;
    IF base > curProc^.nSnap THEN RETURN FALSE END;
    (* the just-typed formals are chain indexes base-n .. base-1 *)
    FOR k := 0 TO n - 1 DO
      IF base >= n THEN
        (* walk to index base-n+k *)
        f := curProc^.plink;
        i := 0;
        WHILE (i < base - n + k) AND (f # NIL) DO
          f := f^.plink; INC(i)
        END;
        IF f # NIL THEN
          isV := f^.isVar;
          IF isV THEN ok := VarParamOk(f^.typ, curProc^.snapT[base - n + k])
          ELSE ok := FormalOk(f^.typ, curProc^.snapT[base - n + k]) END;
          IF (isV # curProc^.snapV[base - n + k]) OR NOT ok THEN
            RETURN FALSE
          END
        END
      END
    END;
    RETURN TRUE
  END FixPending;

PROCEDURE PendCount (): CARDINAL;
  BEGIN
    RETURN nPend
  END PendCount;

PROCEDURE PendName (i: CARDINAL; VAR n: Name);
  BEGIN
    IF i < nPend THEN Assign(n, pend[i]^.name)
    ELSE n[0] := CHR(0)
    END
  END PendName;

PROCEDURE Resolve (t: TypeIndex): TypeIndex;
  VAR n: CARDINAL;
  BEGIN
    n := 0;
    WHILE (n < ResDepth) AND (t >= 0) AND (t < VAL(INTEGER, nTypes))
 AND (tform[t] = FAlias) DO
      t := tref[t]; INC(n)
    END;
    IF (t < 0) OR (t >= VAL(INTEGER, nTypes)) THEN
      RETURN InvalidType
    END;
    RETURN t
  END Resolve;

PROCEDURE ParentOf (t: TypeIndex): TypeIndex;
(* The single parent class of t, or InvalidType. *)
  VAR r: TypeIndex;
  BEGIN
    r := Resolve(t);
    IF (r >= 0) AND (r < VAL(INTEGER, nTypes))
       AND (tform[r] = FClass) THEN
      RETURN tparent[r]
    END;
    RETURN InvalidType
  END ParentOf;

PROCEDURE PushProc (node: SymPtr);
  BEGIN
    IF nProc <= HIGH(procStk) THEN
      procStk[nProc] := node; INC(nProc)
    END
  END PushProc;

PROCEDURE OwnField (rec: TypeIndex; name: ARRAY OF CHAR): FieldPtr;
(* A field declared directly in rec (no parent walk). *)
  VAR f: FieldPtr;
  BEGIN
    IF (rec < 0) OR (rec >= VAL(INTEGER, nTypes)) THEN RETURN NIL END;
    IF (tform[rec] # FRecord) AND (tform[rec] # FClass) THEN RETURN NIL END;
    f := fields;
    WHILE f # NIL DO
      IF (f^.owner = rec) AND Equal(f^.name, name) THEN RETURN f END;
      f := f^.next
    END;
    RETURN NIL
  END OwnField;

PROCEDURE FindField (rec: TypeIndex; name: ARRAY OF CHAR): FieldPtr;
(* Looks in rec, then up the single-inheritance chain. *)
  VAR f: FieldPtr;
    r, p: TypeIndex;
    guard: CARDINAL;
  BEGIN
    f := OwnField(rec, name);
    IF f # NIL THEN RETURN f END;
    r := Resolve(rec);
    IF (r = InvalidType) OR (tform[r] # FClass) THEN RETURN NIL END;
    guard := 0;
    p := ParentOf(r);
    WHILE (p # InvalidType) AND (guard < ResDepth) DO
      f := OwnField(p, name);
      IF f # NIL THEN RETURN f END;
      r := p;
      p := ParentOf(r);
      INC(guard)
    END;
    RETURN NIL
  END FindField;

PROCEDURE FieldPending (rec: TypeIndex; name: ARRAY OF CHAR): BOOLEAN;
  VAR f: FieldPtr;
  BEGIN
    IF FindField(rec, name) # NIL THEN RETURN FALSE END;
    NEW(f);
    Assign(f^.name, name);
    f^.typ := InvalidType;
    f^.owner := rec;
    f^.next := fields;
    fields := f;
    IF (rec >= 0) AND (rec < VAL(INTEGER, nTypes)) THEN
      tdone[rec] := FALSE
    END;
    IF nPendF < MaxPend THEN
      pendF[nPendF] := f; INC(nPendF)
    END;
    INC(nFields);
    RETURN TRUE
  END FieldPending;

PROCEDURE FixPendingF (rec: TypeIndex; t: TypeIndex);
  VAR i, j: CARDINAL;
  BEGIN
    i := 0;
    WHILE i < nPendF DO
      IF pendF[i]^.owner = rec THEN
        pendF[i]^.typ := t;
        (* remove by swap with last *)
        j := nPendF - 1;
        pendF[i] := pendF[j];
        DEC(nPendF)
      ELSE
        INC(i)
      END
    END
  END FixPendingF;

PROCEDURE Lookup (name: ARRAY OF CHAR): BOOLEAN;
  BEGIN
    RETURN Find(name) # NIL
  END Lookup;

PROCEDURE SymType (name: ARRAY OF CHAR): TypeIndex;
  VAR node: SymPtr;
  BEGIN
    node := Find(name);
    IF node = NIL THEN RETURN InvalidType END;
    RETURN node^.typ
  END SymType;

PROCEDURE SetSymType (name: ARRAY OF CHAR; t: TypeIndex);
  VAR node: SymPtr;
  BEGIN
    node := Find(name);
    IF node # NIL THEN node^.typ := t END
  END SetSymType;

PROCEDURE SymKind (name: ARRAY OF CHAR): INTEGER;
  VAR node: SymPtr;
  BEGIN
    node := Find(name);
    IF node = NIL THEN RETURN -1 END;
    RETURN node^.kind
  END SymKind;

PROCEDURE SetSymVal (name: ARRAY OF CHAR; v: ARRAY OF CHAR);
  VAR node: SymPtr;
  BEGIN
    node := Find(name);
    IF node # NIL THEN Assign(node^.val, v) END
  END SetSymVal;

PROCEDURE GetSymVal (name: ARRAY OF CHAR; VAR v: ARRAY OF CHAR): BOOLEAN;
  VAR node: SymPtr;
  BEGIN
    node := Find(name);
    IF node = NIL THEN
      v[0] := CHR(0); RETURN FALSE
    END;
    IF node^.val[0] = CHR(0) THEN
      v[0] := CHR(0); RETURN FALSE
    END;
    Assign(v, node^.val);
    RETURN TRUE
  END GetSymVal;

PROCEDURE PushScope;
  BEGIN
    curScope := NewScope(curScope, curScope^.level + 1)
  END PushScope;

PROCEDURE PopScope;
  BEGIN
    (* Nodes stay allocated but become unreachable via the chain. *)
    IF curScope^.parent # NIL THEN curScope := curScope^.parent END
  END PopScope;

(* ---------------- type descriptors (unchanged) ---------------- *)

PROCEDURE NewDesc (form: INTEGER; ref: TypeIndex): TypeIndex;
  BEGIN
    IF nTypes >= MaxTypes THEN RETURN InvalidType END;
    tform[nTypes] := form;
    tref[nTypes] := ref;
    tbytebuf[nTypes] := FALSE;
    tdone[nTypes] := FALSE;
    tvtag[nTypes] := FALSE;
    vtBase[nTypes] := 0;
    nVirt[nTypes] := 0;
    vtBuilt[nTypes] := FALSE;
    tvptr[nTypes] := -1;
    ttag[nTypes] := NIL;
    INC(nTypes);
    RETURN VAL(INTEGER, nTypes - 1)
  END NewDesc;

PROCEDURE NewAlias (): TypeIndex;
  BEGIN
    RETURN NewDesc(FAlias, InvalidType)
  END NewAlias;

PROCEDURE EnterTypeParam (name: ARRAY OF CHAR): BOOLEAN;
(* A generic formal type parameter: an unresolved alias type.  The
   definition and implementation modules repeat the formals, so a
   second entry of the same name reuses the first. *)
  VAR t: TypeIndex;
  BEGIN
    IF Lookup(name) AND (SymKind(name) = KindType) THEN RETURN TRUE END;
    t := NewAlias();
    IF t = InvalidType THEN RETURN FALSE END;
    IF NOT Enter(name, KindType) THEN RETURN FALSE END;
    SetSymType(name, t);
    RETURN TRUE
  END EnterTypeParam;

PROCEDURE EnterTypeParamBound (name: ARRAY OF CHAR;
                               actual: TypeIndex): BOOLEAN;
(* A generic formal type parameter bound to a concrete actual: an alias
   type whose target is the actual, entered in the current (module)
   scope.  Used during instantiation re-parse. *)
  VAR t: TypeIndex;
  BEGIN
    IF Lookup(name) AND (SymKind(name) = KindType) THEN RETURN TRUE END;
    t := NewAlias();
    IF t = InvalidType THEN RETURN FALSE END;
    IF NOT Enter(name, KindType) THEN RETURN FALSE END;
    SetSymType(name, t);
    SetTarget(t, actual);
    RETURN TRUE
  END EnterTypeParamBound;

PROCEDURE NewSubR (lo, hi: INTEGER): TypeIndex;
  VAR t: TypeIndex;
  BEGIN
    t := NewDesc(FSub, InvalidType);
    IF t # InvalidType THEN tlo[t] := lo; thi[t] := hi END;
    RETURN t
  END NewSubR;

PROCEDURE NewEnum (): TypeIndex;
  BEGIN
    RETURN NewDesc(FEnum, InvalidType)
  END NewEnum;

PROCEDURE SetEnumCount (t: TypeIndex; n: CARDINAL);
  VAR r: TypeIndex;
  BEGIN
    r := Resolve(t);
    IF (r # InvalidType) AND (tform[r] = FEnum) THEN tenum[r] := n END
  END SetEnumCount;

PROCEDURE EnumCount (t: TypeIndex): CARDINAL;
  VAR r: TypeIndex;
  BEGIN
    r := Resolve(t);
    IF (r = InvalidType) OR (tform[r] # FEnum) THEN RETURN 0 END;
    RETURN tenum[r]
  END EnumCount;

PROCEDURE LitPut (off: CARDINAL; name: ARRAY OF CHAR);
  VAR i: CARDINAL;
  BEGIN
    i := 0;
    WHILE (i < 63) AND (name[i] # CHR(0)) AND (off + i <= HIGH(enumLitNm)) DO
      enumLitNm[off + i] := name[i]; INC(i)
    END;
    IF off + i <= HIGH(enumLitNm) THEN enumLitNm[off + i] := CHR(0) END
  END LitPut;

PROCEDURE LitGet (off: CARDINAL; VAR name: Name);
  VAR i: CARDINAL;
  BEGIN
    i := 0;
    WHILE (i < 63) AND (off + i <= HIGH(enumLitNm))
          AND (enumLitNm[off + i] # CHR(0)) DO
      name[i] := enumLitNm[off + i]; INC(i)
    END;
    name[i] := CHR(0)
  END LitGet;

PROCEDURE NoteEnumLit (t: TypeIndex; name: ARRAY OF CHAR);
(* Registers one enumeration literal (called by the grammar's Enum). *)
  VAR r: TypeIndex;
  BEGIN
    r := Resolve(t);
    IF r = InvalidType THEN RETURN END;
    IF enumLitN >= MaxEnumLit THEN RETURN END;
    IF NOT enumLitDone[r] THEN
      enumLitStart[r] := enumLitN; enumLitDone[r] := TRUE
    END;
    LitPut(enumLitN * 64, name); INC(enumLitN)
  END NoteEnumLit;

PROCEDURE OrdStr (v: INTEGER; VAR s: Name);
  VAR buf: ARRAY [0 .. 15] OF CHAR;
    n, i, m: CARDINAL;
  BEGIN
    IF v < 0 THEN m := 0 ELSE m := VAL(CARDINAL, v) END;
    n := 0;
    IF m = 0 THEN buf[0] := "0"; n := 1 END;
    WHILE (m > 0) AND (n < HIGH(buf)) DO
      buf[n] := CHR(ORD("0") + m MOD 10); m := m DIV 10; INC(n)
    END;
    i := 0;
    WHILE i < n DO s[i] := buf[n - 1 - i]; INC(i) END;
    s[n] := CHR(0)
  END OrdStr;

PROCEDURE EnumLitName (t: TypeIndex; i: CARDINAL; VAR name: Name);
  VAR r: TypeIndex; base: CARDINAL;
  BEGIN
    name[0] := CHR(0);
    r := Resolve(t);
    IF (r = InvalidType) OR NOT enumLitDone[r] OR (i >= tenum[r]) THEN
      RETURN
    END;
    base := enumLitStart[r] + i;
    IF base < MaxEnumLit THEN LitGet(base * 64, name) END
  END EnumLitName;

PROCEDURE EnterEnumLits (t: TypeIndex): CARDINAL;
(* Makes an enum type's literals visible in the current scope (the type
   was just declared/imported).  Returns how many were newly entered. *)
  VAR r: TypeIndex; i, n, added: CARDINAL; nm: Name; node: SymPtr;
  BEGIN
    r := Resolve(t);
    IF (r = InvalidType) OR (tform[r] # FEnum) THEN RETURN 0 END;
    added := 0;
    n := tenum[r];
    i := 0;
    WHILE i < n DO
      EnumLitName(t, i, nm);
      IF (nm[0] # CHR(0)) AND (TreeFind(curScope^.root, nm) = NIL) THEN
        node := RawEnter(nm, KindConst);
        IF node # NIL THEN
          node^.typ := t;
          OrdStr(VAL(INTEGER, i), node^.val);
          INC(added)
        END
      END;
      INC(i)
    END;
    RETURN added
  END EnterEnumLits;

PROCEDURE NewArrayB (elem: TypeIndex; lo, hi: INTEGER): TypeIndex;
  VAR t: TypeIndex;
  BEGIN
    t := NewDesc(FArray, elem);
    IF t # InvalidType THEN alo[t] := lo; ahi[t] := hi END;
    RETURN t
  END NewArrayB;

PROCEDURE NewOpenArray (elem: TypeIndex): TypeIndex;
  BEGIN
    RETURN NewDesc(FOpenArr, elem)
  END NewOpenArray;

PROCEDURE BoundBegin;
  BEGIN
    nBounds := 0
  END BoundBegin;

PROCEDURE BoundAdd (lo, hi: INTEGER): BOOLEAN;
  BEGIN
    IF nBounds > HIGH(blo) THEN RETURN FALSE END;
    blo[nBounds] := lo; bhi[nBounds] := hi; INC(nBounds);
    RETURN TRUE
  END BoundAdd;

PROCEDURE BoundCount (): CARDINAL;
  BEGIN RETURN nBounds END BoundCount;

PROCEDURE BoundLo (i: CARDINAL): INTEGER;
  BEGIN
    IF i < nBounds THEN RETURN blo[i] ELSE RETURN 0 END
  END BoundLo;

PROCEDURE BoundHi (i: CARDINAL): INTEGER;
  BEGIN
    IF i < nBounds THEN RETURN bhi[i] ELSE RETURN -1 END
  END BoundHi;

PROCEDURE NewRecord (): TypeIndex;
  BEGIN
    RETURN NewDesc(FRecord, -1)
  END NewRecord;


PROCEDURE NewSet (base: TypeIndex): TypeIndex;
  BEGIN
    RETURN NewDesc(FSet, base)
  END NewSet;

PROCEDURE NewPtr (base: TypeIndex): TypeIndex;
  BEGIN
    RETURN NewDesc(FPtr, base)
  END NewPtr;

PROCEDURE NewStr (): TypeIndex;
  BEGIN
    RETURN NewDesc(FStr, InvalidType)
  END NewStr;

PROCEDURE NewUStr (): TypeIndex;
  BEGIN
    RETURN NewDesc(FUStr, InvalidType)
  END NewUStr;

PROCEDURE NewClass (): TypeIndex;
  VAR t: TypeIndex;
  BEGIN
    t := NewDesc(FClass, InvalidType);
    IF t # InvalidType THEN
      tparent[t] := InvalidType; tscope[t] := NIL
    END;
    RETURN t
  END NewClass;

PROCEDURE SetParent (t, p: TypeIndex);
  BEGIN
    IF (t >= 0) AND (t < VAL(INTEGER, nTypes)) AND (tform[t] = FClass) THEN
      tparent[t] := p
    END
  END SetParent;





PROCEDURE Unresolved (t: TypeIndex): BOOLEAN;
(* TRUE for a not-yet-completed type: an unbound alias whose target is
   still InvalidType (a generic formal, or a forward/pending type). *)
  BEGIN
    RETURN Resolve(t) = InvalidType
  END Unresolved;

PROCEDURE IsOrdinal (t: TypeIndex): BOOLEAN;
(* An ordinal type: integer family, CHAR, UCHAR, BOOLEAN or an
   enumeration (drives CASE/variant selectors). *)
  VAR c: INTEGER;
  BEGIN
    IF Resolve(t) = InvalidType THEN RETURN FALSE END;
    c := ClassOf(t);
    RETURN (c = ClInt) OR (c = ClChar) OR (c = ClUChar)
        OR (c = ClBool) OR (c = ClEnum)
  END IsOrdinal;

PROCEDURE ResetFields (rec: TypeIndex);
(* Starts a fresh variant branch: drops any still-pending fields of
   rec (their identifiers saw no ":" yet) and clears its layout so
   the next branch overlays from the tag slot.  Field names already
   committed in an earlier branch stay in the record's scope. *)
  VAR i: CARDINAL;
    r: TypeIndex;
  BEGIN
    r := Resolve(rec);
    i := 0;
    WHILE i < nPendF DO
      IF pendF[i]^.owner = r THEN
        nPendF := nPendF - 1;
        pendF[i] := pendF[nPendF]
      ELSE
        INC(i)
      END
    END;
    IF (r >= 0) AND (r < VAL(INTEGER, nTypes)) THEN
      tdone[r] := FALSE
    END
  END ResetFields;

PROCEDURE SetVariantTag (rec: TypeIndex; name: ARRAY OF CHAR);
(* Records the variant CASE selector field of rec (by name); called
   just after the tag's type is fixed, before the variant branches. *)
  VAR r: TypeIndex;
  BEGIN
    r := Resolve(rec);
    IF (r >= 0) AND (r < VAL(INTEGER, nTypes)) THEN
      ttag[r] := FindField(r, name)
    END
  END SetVariantTag;

PROCEDURE MarkVariant (rec: TypeIndex);
(* Records that this record has a variant part (its fields overlap
   from the tag slot on, so whole-record comparison is 236). *)
  VAR r: TypeIndex;
  BEGIN
    r := Resolve(rec);
    IF (r >= 0) AND (r < VAL(INTEGER, nTypes)) THEN
      tvtag[r] := TRUE
    END
  END MarkVariant;

PROCEDURE IsVariant (rec: TypeIndex): BOOLEAN;
  VAR r: TypeIndex;
  BEGIN
    r := Resolve(rec);
    IF (r >= 0) AND (r < VAL(INTEGER, nTypes)) THEN
      RETURN tvtag[r]
    END;
    RETURN FALSE
  END IsVariant;

PROCEDURE PushClassScope (t: TypeIndex);
  VAR r: TypeIndex;
  BEGIN
    r := Resolve(t);
    IF (r = InvalidType) OR (tform[r] # FClass) THEN RETURN END;
    PushScope;
    tscope[r] := curScope
  END PushClassScope;

PROCEDURE SetTarget (t, base: TypeIndex);
  BEGIN
    IF (t >= 0) AND (t < VAL(INTEGER, nTypes)) AND (tform[t] = FAlias) THEN
      tref[t] := base
    END
  END SetTarget;

PROCEDURE IntType (): TypeIndex;
  BEGIN RETURN dInt END IntType;

PROCEDURE UCharType (): TypeIndex;
  BEGIN RETURN dUChar END UCharType;

PROCEDURE AddrType (): TypeIndex;
  BEGIN RETURN dAddr END AddrType;

PROCEDURE LongType (): TypeIndex;
  BEGIN RETURN dLong END LongType;
PROCEDURE RealType (): TypeIndex;
  BEGIN RETURN dReal END RealType;
PROCEDURE CharType (): TypeIndex;
  BEGIN RETURN dChar END CharType;
PROCEDURE BoolType (): TypeIndex;
  BEGIN RETURN dBool END BoolType;

PROCEDURE ClassOf (t: TypeIndex): INTEGER;
  VAR r: TypeIndex;
  BEGIN
    r := Resolve(t);
    IF r = InvalidType THEN
      (* an opaque/undeclared alias (e.g. gm2's String) is pointer-like *)
      IF (t >= 0) AND (t < VAL(INTEGER, nTypes))
         AND (tform[t] = FAlias) THEN
        RETURN ClPtr
      END;
      RETURN ClInvalid
    END;
    CASE tform[r] OF
      FInt : RETURN ClInt
    | FLong : RETURN ClLong
    | FReal : RETURN ClReal
    | FChar : RETURN ClChar
    | FBool : RETURN ClBool
    | FEnum : RETURN ClEnum
    | FArray : RETURN ClArray
    | FOpenArr : RETURN ClArray
    | FRecord : RETURN ClRecord
    | FSet : RETURN ClSet
    | FPtr : RETURN ClPtr
    | FStr : RETURN ClStr
    | FClass : RETURN ClClass
    | FProc : RETURN ClProc
    | FUChar : RETURN ClUChar
    | FUStr : RETURN ClUStr
    | FNil : RETURN ClNil
    | FSub : IF tref[r] = InvalidType THEN RETURN ClInt
             ELSE RETURN ClassOf(tref[r]) END
    ELSE RETURN ClInvalid
    END
  END ClassOf;

PROCEDURE IsIntFamily (t: TypeIndex): BOOLEAN;
  BEGIN
    RETURN ClassOf(t) = ClInt
  END IsIntFamily;

PROCEDURE IsLongFamily (t: TypeIndex): BOOLEAN;
  BEGIN
    RETURN ClassOf(t) = ClLong
  END IsLongFamily;

PROCEDURE SameType (a, b: TypeIndex): BOOLEAN;
  BEGIN
    IF (a = InvalidType) OR (b = InvalidType) THEN RETURN TRUE END;
    RETURN Resolve(a) = Resolve(b)
  END SameType;

PROCEDURE FieldExists (rec: TypeIndex; name: ARRAY OF CHAR): BOOLEAN;
  BEGIN
    RETURN FindField(Resolve(rec), name) # NIL
  END FieldExists;

PROCEDURE FieldType (rec: TypeIndex; name: ARRAY OF CHAR): TypeIndex;
  VAR f: FieldPtr;
  BEGIN
    f := FindField(Resolve(rec), name);
    IF f = NIL THEN RETURN InvalidType END;
    RETURN f^.typ
  END FieldType;

PROCEDURE ArrayElem (t: TypeIndex): TypeIndex;
  VAR r: TypeIndex;
  BEGIN
    r := Resolve(t);
    IF (r = InvalidType) OR ((tform[r] # FArray)
 AND (tform[r] # FOpenArr)) THEN
      RETURN InvalidType
    END;
    RETURN tref[r]
  END ArrayElem;

PROCEDURE IsOpenArray (t: TypeIndex): BOOLEAN;
  VAR r: TypeIndex;
  BEGIN
    r := Resolve(t);
    IF r = InvalidType THEN RETURN FALSE END;
    RETURN tform[r] = FOpenArr
  END IsOpenArray;

PROCEDURE MarkByteBuf (t: TypeIndex);
(* Marks an open-array type as an `ARRAY OF BYTE` formal (the gm2
   untyped-buffer extension): a scalar actual is then accepted. *)
  VAR r: TypeIndex;
  BEGIN
    r := Resolve(t);
    IF r # InvalidType THEN tbytebuf[r] := TRUE END
  END MarkByteBuf;

PROCEDURE IsByteBuf (t: TypeIndex): BOOLEAN;
  VAR r: TypeIndex;
  BEGIN
    r := Resolve(t);
    IF r = InvalidType THEN RETURN FALSE END;
    RETURN tbytebuf[r]
  END IsByteBuf;

PROCEDURE ByteBufOk (at, ft: TypeIndex): BOOLEAN;
(* gm2 compatibility: a scalar, pointer or string actual is accepted
   for an `ARRAY OF BYTE` formal (the callee sees a byte buffer). *)
  VAR c: INTEGER;
  BEGIN
    IF NOT IsByteBuf(ft) THEN RETURN FALSE END;
    c := ClassOf(at);
    RETURN (c = ClInt) OR (c = ClChar) OR (c = ClBool) OR (c = ClEnum)
        OR (c = ClPtr) OR (c = ClLong) OR (c = ClStr)
  END ByteBufOk;

PROCEDURE ArrayLo (t: TypeIndex): INTEGER;
  VAR r: TypeIndex;
  BEGIN
    r := Resolve(t);
    IF (r = InvalidType) OR (tform[r] # FArray) THEN RETURN 0 END;
    RETURN alo[r]
  END ArrayLo;

PROCEDURE ArrayHi (t: TypeIndex): INTEGER;
  VAR r: TypeIndex;
  BEGIN
    r := Resolve(t);
    IF (r = InvalidType) OR (tform[r] # FArray) THEN RETURN 0 END;
    RETURN ahi[r]
  END ArrayHi;

PROCEDURE ArrayLen (t: TypeIndex): CARDINAL;
  VAR r: TypeIndex;
    lo, hi: INTEGER;
  BEGIN
    r := Resolve(t);
    IF (r = InvalidType) OR (tform[r] # FArray) THEN RETURN 0 END;
    lo := alo[r]; hi := ahi[r];
    IF hi < lo THEN RETURN 0 END;
    RETURN VAL(CARDINAL, hi - lo + 1)
  END ArrayLen;

PROCEDURE ArrayDepth (t: TypeIndex): CARDINAL;
  VAR r: TypeIndex;
    d: CARDINAL;
  BEGIN
    d := 0; r := Resolve(t);
    WHILE (r # InvalidType) AND ((tform[r] = FArray)
           OR (tform[r] = FOpenArr)) DO
      INC(d); r := Resolve(tref[r])
    END;
    RETURN d
  END ArrayDepth;

PROCEDURE SubBounds (t: TypeIndex; VAR lo, hi: INTEGER): BOOLEAN;
  VAR r: TypeIndex;
  BEGIN
    lo := 0; hi := -1;
    r := Resolve(t);
    IF (r = InvalidType) OR (tform[r] # FSub)
       OR (tref[r] # InvalidType) THEN
      RETURN FALSE
    END;
    lo := tlo[r]; hi := thi[r];
    RETURN TRUE
  END SubBounds;

PROCEDURE SetBase (t: TypeIndex): TypeIndex;
  VAR r: TypeIndex;
  BEGIN
    r := Resolve(t);
    IF (r = InvalidType) OR (tform[r] # FSet) THEN
      RETURN InvalidType
    END;
    RETURN tref[r]
  END SetBase;

PROCEDURE SetSpan (t: TypeIndex; VAR lo, n: INTEGER): BOOLEAN;
(* Base span for mask sizing; FALSE when unsuitable. Internal. *)
  VAR b, r: TypeIndex;
    blo, bhi: INTEGER;
  BEGIN
    lo := 0; n := 0;
    b := SetBase(t);
    IF b = InvalidType THEN RETURN FALSE END;
    r := Resolve(b);
    IF r = InvalidType THEN RETURN FALSE END;
    IF tform[r] = FBool THEN lo := 0; n := 2; RETURN TRUE END;
    IF tform[r] = FChar THEN lo := 0; n := 256; RETURN TRUE END;
    IF tform[r] = FEnum THEN
      IF tenum[r] = 0 THEN RETURN FALSE END;
      lo := 0; n := VAL(INTEGER, tenum[r]); RETURN TRUE
    END;
    IF (tform[r] = FSub) AND (tref[r] = InvalidType)
 AND SubBounds(b, blo, bhi) AND (bhi >= blo)
 AND (bhi - blo < 65536) THEN
      lo := blo; n := bhi - blo + 1; RETURN TRUE
    END;
    RETURN FALSE
  END SetSpan;

PROCEDURE SetWords (t: TypeIndex): CARDINAL;
  VAR lo, n: INTEGER;
  BEGIN
    IF NOT SetSpan(t, lo, n) THEN RETURN 0 END;
    RETURN VAL(CARDINAL, (n + 31) DIV 32)
  END SetWords;

PROCEDURE SetBaseLo (t: TypeIndex): INTEGER;
  VAR lo, n: INTEGER;
  BEGIN
    IF NOT SetSpan(t, lo, n) THEN RETURN 0 END;
    RETURN lo
  END SetBaseLo;

PROCEDURE SetCount (t: TypeIndex): CARDINAL;
  VAR lo, n: INTEGER;
  BEGIN
    IF NOT SetSpan(t, lo, n) THEN RETURN 0 END;
    RETURN VAL(CARDINAL, n)
  END SetCount;

PROCEDURE TypeBounds (t: TypeIndex; VAR lo, hi: INTEGER): BOOLEAN;
(* The ordinal bounds of a type, for MIN/MAX: subrange/array bounds,
   CHAR/UCHAR, BOOLEAN, enumeration, or a set's base span. *)
  VAR r: TypeIndex;
    c: INTEGER;
  BEGIN
    lo := 0; hi := -1;
    r := Resolve(t);
    IF r = InvalidType THEN RETURN FALSE END;
    IF tform[r] = FSub THEN RETURN SubBounds(r, lo, hi) END;
    IF tform[r] = FArray THEN lo := alo[r]; hi := ahi[r]; RETURN TRUE END;
    c := ClassOf(r);
    IF c = ClChar THEN lo := 0; hi := 255; RETURN TRUE END;
    IF c = ClUChar THEN lo := 0; hi := 1114111; RETURN TRUE END;
    IF c = ClBool THEN lo := 0; hi := 1; RETURN TRUE END;
    IF c = ClEnum THEN
      lo := 0;
      IF tenum[r] = 0 THEN hi := -1
      ELSE hi := VAL(INTEGER, tenum[r]) - 1
      END;
      RETURN TRUE
    END;
    IF c = ClSet THEN
      lo := SetBaseLo(r);
      IF SetCount(r) = 0 THEN hi := lo - 1
      ELSE hi := lo + VAL(INTEGER, SetCount(r)) - 1
      END;
      RETURN TRUE
    END;
    IF c = ClInt THEN
      lo := -2147483648; hi := 2147483647; RETURN TRUE
    END;
    RETURN FALSE
  END TypeBounds;

PROCEDURE PtrBase (t: TypeIndex): TypeIndex;
  VAR r: TypeIndex;
  BEGIN
    r := Resolve(t);
    IF (r = InvalidType) OR (tform[r] # FPtr) THEN
      RETURN InvalidType
    END;
    RETURN tref[r]
  END PtrBase;

(* ---------------- procedure types (step 8.5) ---------------- *)

PROCEDURE NewProcType (res: TypeIndex): TypeIndex;
  VAR t: TypeIndex;
  BEGIN
    t := NewDesc(FProc, res);
    IF t = InvalidType THEN RETURN t END;
    procstart[t] := nProcP;
    procn[t] := 0;
    RETURN t
  END NewProcType;

PROCEDURE ProcTypeAdd (t: TypeIndex; isVar: BOOLEAN; pt: TypeIndex);
  VAR r: TypeIndex;
  BEGIN
    r := Resolve(t);
    IF (r = InvalidType) OR (tform[r] # FProc) THEN RETURN END;
    IF nProcP < MaxPP THEN
      procp[nProcP] := pt;
      procvis[nProcP] := isVar;
      INC(nProcP); INC(procn[r])
    END
  END ProcTypeAdd;

PROCEDURE SetProcTypeRes (t: TypeIndex; res: TypeIndex);
  VAR r: TypeIndex;
  BEGIN
    r := Resolve(t);
    IF (r # InvalidType) AND (tform[r] = FProc) THEN tref[r] := res END
  END SetProcTypeRes;

PROCEDURE ProcTypeNPar (t: TypeIndex): CARDINAL;
  VAR r: TypeIndex;
  BEGIN
    r := Resolve(t);
    IF (r = InvalidType) OR (tform[r] # FProc) THEN RETURN 0 END;
    RETURN procn[r]
  END ProcTypeNPar;

PROCEDURE ProcTypeParamType (t: TypeIndex; i: CARDINAL): TypeIndex;
  VAR r: TypeIndex;
  BEGIN
    r := Resolve(t);
    IF (r = InvalidType) OR (tform[r] # FProc) OR (i >= procn[r]) THEN
      RETURN InvalidType
    END;
    RETURN procp[procstart[r] + i]
  END ProcTypeParamType;

PROCEDURE ProcTypeParamIsVar (t: TypeIndex; i: CARDINAL): BOOLEAN;
  VAR r: TypeIndex;
  BEGIN
    r := Resolve(t);
    IF (r = InvalidType) OR (tform[r] # FProc) OR (i >= procn[r]) THEN
      RETURN FALSE
    END;
    RETURN procvis[procstart[r] + i]
  END ProcTypeParamIsVar;

PROCEDURE ProcTypeRes (t: TypeIndex): TypeIndex;
  VAR r: TypeIndex;
  BEGIN
    r := Resolve(t);
    IF (r = InvalidType) OR (tform[r] # FProc) THEN
      RETURN InvalidType
    END;
    RETURN tref[r]
  END ProcTypeRes;

PROCEDURE ProcTypeOf (name: ARRAY OF CHAR): TypeIndex;
  VAR node, p: SymPtr;
    t: TypeIndex;
    k: CARDINAL;
  BEGIN
    node := Find(name);
    IF node = NIL THEN RETURN InvalidType END;
    IF node^.kind # KindProc THEN RETURN InvalidType END;
    t := NewDesc(FProc, node^.rslt);
    IF t = InvalidType THEN RETURN t END;
    procstart[t] := nProcP;
    k := 0;
    p := node^.plink;
    WHILE (p # NIL) AND (nProcP < MaxPP) DO
      procp[nProcP] := p^.typ;
      procvis[nProcP] := p^.isVar;
      INC(nProcP); INC(k);
      p := p^.plink
    END;
    procn[t] := k;
    RETURN t
  END ProcTypeOf;

PROCEDURE ElemBytes (t: TypeIndex): CARDINAL;
(* element size of array descriptor t (bytes) *)
  VAR cls: INTEGER;
  BEGIN
    cls := ClassOf(ArrayElem(t));
    IF cls = ClChar THEN RETURN 1 END;
    IF cls = ClReal THEN RETURN 8 END;
    IF (cls = ClArray) OR (cls = ClPtr) OR (cls = ClRecord)
       OR (cls = ClClass) OR (cls = ClProc) THEN
      RETURN 8
    END;
    RETURN 4
  END ElemBytes;

PROCEDURE IsCharArray (t: TypeIndex): BOOLEAN;
  BEGIN RETURN ClassOf(ArrayElem(t)) = ClChar END IsCharArray;

PROCEDURE ArrObjSize (t: TypeIndex): CARDINAL;
(* full inline size of a fixed array: header (count) + packed elements
   (+1 terminator byte for CHAR arrays) *)
  VAR n: CARDINAL;
  BEGIN
    n := ArrayLen(t) * ElemBytes(t);
    IF IsCharArray(t) THEN n := n + 1 END;
    RETURN 8 + n
  END ArrObjSize;

PROCEDURE TypeSizeD (t: TypeIndex; depth: CARDINAL): CARDINAL;
(* Inline footprint in bytes: scalars 4/8, sets words*4, pointers,
   open and fixed arrays 8 (descriptor address — array objects live
   separately); records sum members. Depth guards cycles (not 223). *)
  VAR r: TypeIndex;
    f: FieldPtr;
    tagF: FieldPtr;
    n, plain, high: CARDINAL;
  BEGIN
    IF depth > ResDepth THEN RETURN 0 END;
    r := Resolve(t);
    IF r = InvalidType THEN RETURN 0 END;
    CASE tform[r] OF
      FInt, FBool, FChar, FUChar : RETURN 4
    | FLong : RETURN 8
    | FReal : RETURN 8
    | FEnum, FSub : RETURN 4
    | FSet : RETURN SetWords(t) * 4
    | FPtr, FOpenArr, FArray, FProc, FUStr : RETURN 8
    | FRecord, FClass :
        n := 0;
        IF (tform[r] = FClass) AND (tparent[r] # InvalidType) THEN
          (* single inheritance: parent fields (and its vptr) come first *)
          n := TypeSizeD(tparent[r], depth + 1)
        END;
        IF (tform[r] = FClass) AND (tvptr[r] >= 0)
           AND (tvptr[r] = VAL(INTEGER, n)) THEN
          (* this class introduces its vptr here *)
          n := n + 8
        END;
        IF tvtag[r] AND (ttag[r] # NIL) THEN
          (* variant record: plain fields (declared before the tag) pack
             normally; the tag and every variant field overlay in one
             slot, so the record is plainSize + max(tag, variants). *)
          plain := 0; high := 0;
          f := fields;
          WHILE f # NIL DO
            IF f^.owner = r THEN
              IF f^.ord < ttag[r]^.ord THEN
                (* a plain field, packed before the tag *)
                IF ClassOf(f^.typ) = ClArray THEN
                  plain := plain + ArrObjSize(f^.typ)
                ELSE
                  plain := plain + TypeSizeD(f^.typ, depth + 1)
                END
              ELSIF f = ttag[r] THEN
                (* the tag itself: its own slot *)
                IF ClassOf(f^.typ) = ClArray THEN
                  plain := plain + ArrObjSize(f^.typ)
                ELSE
                  plain := plain + TypeSizeD(f^.typ, depth + 1)
                END
              ELSE
                (* a variant field: overlay in the region after the tag *)
                IF ClassOf(f^.typ) = ClArray THEN
                  IF ArrObjSize(f^.typ) > high THEN
                    high := ArrObjSize(f^.typ)
                  END
                ELSE
                  IF TypeSizeD(f^.typ, depth + 1) > high THEN
                    high := TypeSizeD(f^.typ, depth + 1)
                  END
                END
              END
            END;
            f := f^.next
          END;
          RETURN n + plain + high       (* n = parent size, if any *)
        END;
        f := fields;
        WHILE f # NIL DO
          IF f^.owner = r THEN
            IF ClassOf(f^.typ) = ClArray THEN
              n := n + ArrObjSize(f^.typ)  (* inline array field *)
            ELSE
              n := n + TypeSizeD(f^.typ, depth + 1)
            END
          END;
          f := f^.next
        END;
        RETURN n
    | FAlias :
        RETURN TypeSizeD(tref[r], depth + 1)
    ELSE RETURN 0
    END
  END TypeSizeD;

PROCEDURE TypeSize (t: TypeIndex): CARDINAL;
  BEGIN
    RETURN TypeSizeD(t, 0)
  END TypeSize;

PROCEDURE FieldSize (t: TypeIndex): CARDINAL;
(* inline footprint of a record field: fixed arrays are inline objects *)
  BEGIN
    IF ClassOf(t) = ClArray THEN RETURN ArrObjSize(t) END;
    RETURN TypeSizeD(t, 0)
  END FieldSize;

PROCEDURE ObjectSize (t: TypeIndex): CARDINAL;
(* full allocation footprint: arrays 8 + count*elem, else TypeSize.
   Used by SYSTEM.SIZE/TSIZE. *)
  VAR r: TypeIndex;
  BEGIN
    r := Resolve(t);
    IF (r # InvalidType) AND ((tform[r] = FArray)
       OR (tform[r] = FOpenArr)) THEN
      RETURN 8 + ArrayLen(t) * ElemBytes(t)
    END;
    RETURN TypeSize(t)
  END ObjectSize;

PROCEDURE BuildVTable (ct: TypeIndex);
(* Assigns ct its virtual-method slots: the parent's are inherited
   first (a same-named virtual method overrides in place), then ct's
   own new virtual methods append.  Each method node records its slot
   in vslot.  Idempotent. *)
  VAR r, p: TypeIndex;
    s: ScopePtr;
    k: CARDINAL;

  PROCEDURE AddMeth (node: SymPtr);
  (* override an inherited slot or append a new one *)
    VAR found: BOOLEAN; j: CARDINAL;
    BEGIN
      IF (node^.kind # KindProc) OR NOT node^.virt THEN RETURN END;
      found := FALSE; j := 0;
      WHILE (j < nVirt[r]) AND NOT found DO
        IF Equal(vtName[vtBase[r] + j], node^.name) THEN
          vtUid[vtBase[r] + j] := node^.uid;
          node^.vslot := VAL(INTEGER, j);
          found := TRUE
        END;
        INC(j)
      END;
      IF NOT found AND (vtTop < MaxVt) THEN
        Assign(vtName[vtTop], node^.name);
        vtUid[vtTop] := node^.uid;
        node^.vslot := VAL(INTEGER, nVirt[r]);
        INC(vtTop); INC(nVirt[r])
      END
    END AddMeth;

  PROCEDURE Walk (node: SymPtr);
    BEGIN
      IF node = NIL THEN RETURN END;
      Walk(node^.left);
      AddMeth(node);
      Walk(node^.right)
    END Walk;

  BEGIN
    r := Resolve(ct);
    IF (r = InvalidType) OR (tform[r] # FClass) THEN RETURN END;
    IF vtBuilt[r] THEN RETURN END;   (* already built *)
    s := tscope[r];
    IF s = NIL THEN RETURN END;
    vtBase[r] := vtTop;
    nVirt[r] := 0;
    (* inherit the parent's slots *)
    p := ParentOf(r);
    IF p # InvalidType THEN
      IF NOT vtBuilt[p] THEN BuildVTable(p) END;
      k := 0;
      WHILE (k < nVirt[p]) AND (vtTop < MaxVt) DO
        Assign(vtName[vtTop], vtName[vtBase[p] + k]);
        vtUid[vtTop] := vtUid[vtBase[p] + k];
        INC(vtTop); INC(nVirt[r]);
        INC(k)
      END
    END;
    (* ct's own virtual methods: override or append *)
    Walk(s^.root);
    (* vptr field offset: inherited from a parent that already has one,
       else introduced after the parent's fields (or at 0) *)
    IF (p # InvalidType) AND (nVirt[p] > 0) THEN
      tvptr[r] := tvptr[p]
    ELSIF nVirt[r] > 0 THEN
      IF p # InvalidType THEN tvptr[r] := VAL(INTEGER, TypeSizeD(p, 0))
      ELSE tvptr[r] := 0
      END
    ELSE tvptr[r] := -1
    END;
    IF (nVirt[r] > 0) AND (nVtl < MaxTypes) THEN
      vtl[nVtl] := r; INC(nVtl)
    END;
    vtBuilt[r] := TRUE
  END BuildVTable;

PROCEDURE ComputeOffsets (r: TypeIndex);
(* Declaration-order offsets over the (prepend-built, hence reverse)
   field chain, plus declaration ranks. Array fields count 8
   (pointer-sized in records, matching the locked layout).
   A record with a variant part lays every field from the first tag
   slot on at that slot's offset (all variant fields overlap), and
   the record's size is the largest such field. *)
  VAR f: FieldPtr;
    tagF: FieldPtr;          (* the variant CASE selector field *)
    total, high, tagSize, varOff, baseOff: INTEGER;
    cnt, ord: CARDINAL;
    off, p: INTEGER;
  BEGIN
    (* a class with a parent lays its own fields after the parent's *)
    baseOff := 0;
    IF (tform[r] = FClass) AND (tparent[r] # InvalidType) THEN
      p := Resolve(tparent[r]);
      IF p # InvalidType THEN
        IF NOT vtBuilt[p] THEN BuildVTable(p) END;
        IF NOT tdone[p] THEN ComputeOffsets(p) END;
        baseOff := VAL(INTEGER, TypeSizeD(p, 0))
      END
    END;
    (* a class that introduces (rather than inherits) a vptr reserves
       8 bytes for it after the parent's fields *)
    IF (tform[r] = FClass) AND (tvptr[r] >= 0)
       AND (tvptr[r] = baseOff) THEN
      baseOff := baseOff + 8
    END;
    IF NOT tvtag[r] THEN
      (* plain record/class: declaration-ordered, tightly packed *)
      total := baseOff; cnt := 0;
      f := fields;
      WHILE f # NIL DO
        IF f^.owner = r THEN
          total := total + VAL(INTEGER, FieldSize(f^.typ));
          INC(cnt)
        END;
        f := f^.next
      END;
      off := total; ord := cnt;
      f := fields;
      WHILE f # NIL DO
        IF f^.owner = r THEN
          off := off - VAL(INTEGER, FieldSize(f^.typ));
          DEC(ord);
          f^.off := off;
          f^.ord := ord
        END;
        f := f^.next
      END;
      tdone[r] := TRUE;
      RETURN
    END;
    (* variant record.  Fields declared before the CASE tag pack
       normally; the tag starts the overlay region and every variant
       field (declared after the tag) overlays at the tag's slot.
       Ranks are reverse-declaration (0 = last declared), so the tag
       has rank = number-of-fields-after-it, and plain fields have
       larger ranks. *)
    tagF := ttag[r];
    IF tagF = NIL THEN
      (* no tag recorded (malformed); fall back to plain layout *)
      tvtag[r] := FALSE;
      ComputeOffsets(r);
      RETURN
    END;
    cnt := 0;
    f := fields;
    WHILE f # NIL DO
      IF f^.owner = r THEN INC(cnt) END;
      f := f^.next
    END;
    ord := cnt;
    f := fields;
    WHILE f # NIL DO
      IF f^.owner = r THEN DEC(ord); f^.ord := ord END;
      f := f^.next
    END;
    (* plain fields: pack in declaration order up to the tag *)
    total := 0;
    f := fields;
    WHILE f # NIL DO
      IF (f^.owner = r) AND (f^.ord < tagF^.ord) THEN
        total := total + VAL(INTEGER, FieldSize(f^.typ))
      END;
      f := f^.next
    END;
    off := total;
    f := fields;
    WHILE f # NIL DO
      IF (f^.owner = r) AND (f^.ord < tagF^.ord) THEN
        off := off - VAL(INTEGER, FieldSize(f^.typ));
        f^.off := off
      END;
      f := f^.next
    END;
    (* the tag occupies its own slot after the plain fields; every
       variant field overlays in the region after the tag *)
    tagF^.off := total;
    varOff := total + VAL(INTEGER, FieldSize(tagF^.typ));
    f := fields;
    WHILE f # NIL DO
      IF (f^.owner = r) AND (f^.ord > tagF^.ord) THEN
        f^.off := varOff
      END;
      f := f^.next
    END;
    tdone[r] := TRUE
  END ComputeOffsets;

PROCEDURE LayoutClass (t: TypeIndex);
(* Computes a class's vtable and field offsets (and thus its size). *)
  VAR r: TypeIndex;
  BEGIN
    r := Resolve(t);
    IF (r # InvalidType) AND (tform[r] = FClass) THEN
      IF NOT vtBuilt[r] THEN BuildVTable(r) END;
      IF NOT tdone[r] THEN ComputeOffsets(r) END
    END
  END LayoutClass;

PROCEDURE LayoutRecord (t: TypeIndex);
(* Computes a record's field offsets / size now (idempotent). *)
  VAR r: TypeIndex;
  BEGIN
    r := Resolve(t);
    IF (r # InvalidType) AND (tform[r] = FRecord)
       AND NOT tdone[r] THEN
      ComputeOffsets(r)
    END
  END LayoutRecord;

PROCEDURE FieldOffset (rec: TypeIndex; name: ARRAY OF CHAR): INTEGER;
  VAR r: TypeIndex;
    f: FieldPtr;
  BEGIN
    r := Resolve(rec);
    IF (r = InvalidType) OR ((tform[r] # FRecord)
 AND (tform[r] # FClass)) THEN
      RETURN -1
    END;
    IF NOT tdone[r] THEN ComputeOffsets(r) END;
    f := FindField(r, name);
    IF f = NIL THEN RETURN -1 END;
    RETURN f^.off
  END FieldOffset;

PROCEDURE FieldCount (rec: TypeIndex): CARDINAL;
  VAR r: TypeIndex;
    f: FieldPtr;
    n: CARDINAL;
  BEGIN
    n := 0;
    r := Resolve(rec);
    IF (r = InvalidType) OR ((tform[r] # FRecord)
 AND (tform[r] # FClass)) THEN
      RETURN 0
    END;
    f := fields;
    WHILE f # NIL DO
      IF f^.owner = r THEN INC(n) END;
      f := f^.next
    END;
    RETURN n
  END FieldCount;

PROCEDURE FieldName (rec: TypeIndex; i: CARDINAL; VAR name: Name);
(* i-th field in DECLARATION order (chain is reverse; ord ranks it). *)
  VAR r: TypeIndex;
    f: FieldPtr;
  BEGIN
    name[0] := CHR(0);
    r := Resolve(rec);
    IF (r = InvalidType) OR ((tform[r] # FRecord)
 AND (tform[r] # FClass)) THEN
      RETURN
    END;
    IF NOT tdone[r] THEN ComputeOffsets(r) END;
    f := fields;
    WHILE f # NIL DO
      IF (f^.owner = r) AND (f^.ord = i) THEN
        Assign(name, f^.name); RETURN
      END;
      f := f^.next
    END
  END FieldName;

PROCEDURE EnterFieldsOf (rec: TypeIndex);
(* Enters rec's own fields as KindField into the current scope. *)
  VAR f: FieldPtr;
  BEGIN
    f := fields;
    WHILE f # NIL DO
      IF f^.owner = rec THEN
        IF Enter(f^.name, KindField) THEN
          SetSymType(f^.name, f^.typ)
        END
      END;
      f := f^.next
    END
  END EnterFieldsOf;

PROCEDURE PushRecord (t: TypeIndex): BOOLEAN;
(* Pushes a scope with t's fields (and, for a class, its ancestors'
   fields); caller must PopScope afterwards.  Classes share the field
   machinery (methods stay in the class scope itself). *)
  VAR r, p: TypeIndex;
    guard: CARDINAL;
  BEGIN
    r := Resolve(t);
    IF (r < 0) OR ((tform[r] # FRecord) AND (tform[r] # FClass)) THEN
      RETURN FALSE
    END;
    PushScope;
    curScope^.ofRec := r;
    EnterFieldsOf(r);
    IF tform[r] = FClass THEN
      guard := 0;
      p := ParentOf(r);
      WHILE (p # InvalidType) AND (guard < ResDepth) DO
        EnterFieldsOf(p);
        p := ParentOf(p);
        INC(guard)
      END
    END;
    RETURN TRUE
  END PushRecord;

(* ---------------- classes ---------------- *)

PROCEDURE ClassMethodNode (t: TypeIndex; name: ARRAY OF CHAR): SymPtr;
(* The method symbol named name in class t or an ancestor, or NIL. *)
  VAR r: TypeIndex;
    s: ScopePtr;
    node: SymPtr;
    guard: CARDINAL;
  BEGIN
    r := Resolve(t);
    guard := 0;
    WHILE (r # InvalidType) AND (tform[r] = FClass) AND (guard < ResDepth) DO
      s := tscope[r];
      IF s # NIL THEN
        node := TreeFind(s^.root, name);
        IF (node # NIL) AND (node^.kind = KindProc) THEN RETURN node END
      END;
      r := ParentOf(r);
      INC(guard)
    END;
    RETURN NIL
  END ClassMethodNode;

PROCEDURE MethodExists (t: TypeIndex; name: ARRAY OF CHAR): BOOLEAN;
(* TRUE when the class (or an ancestor) declares name as a method. *)
  BEGIN
    RETURN ClassMethodNode(t, name) # NIL
  END MethodExists;


PROCEDURE ResumeMethod (ct: TypeIndex; name: ARRAY OF CHAR): BOOLEAN;
(* Resumes a class's declared method for its CLASS IMPLEMENTATION
   body: pushes the existing symbol (reusing its uid so calls bind),
   clearing the formal chain for the body's own heading to rebuild. *)
  VAR node: SymPtr;
  BEGIN
    node := ClassMethodNode(ct, name);
    IF node = NIL THEN RETURN FALSE END;
    node^.plink := NIL;
    node^.hasBody := TRUE;
    curProc := node;
    curPTail := NIL;
    PushProc(node);
    PushScope;
    RETURN TRUE
  END ResumeMethod;

PROCEDURE ClassMethodUid (t: TypeIndex; name: ARRAY OF CHAR): CARDINAL;
  VAR n: SymPtr;
  BEGIN
    n := ClassMethodNode(t, name);
    IF n = NIL THEN RETURN 0 END;
    RETURN n^.uid
  END ClassMethodUid;

PROCEDURE ClassMethodNPar (t: TypeIndex; name: ARRAY OF CHAR): CARDINAL;
(* Number of user formals (excludes the hidden THIS). *)
  VAR n: SymPtr;
    p: SymPtr;
    k: CARDINAL;
  BEGIN
    n := ClassMethodNode(t, name);
    IF n = NIL THEN RETURN 0 END;
    k := 0;
    p := n^.plink;
    WHILE p # NIL DO INC(k); p := p^.plink END;
    IF k > 0 THEN DEC(k) END;   (* drop THIS *)
    RETURN k
  END ClassMethodNPar;

PROCEDURE ClassMethodParamType (t: TypeIndex; name: ARRAY OF CHAR;
                                i: CARDINAL): TypeIndex;
(* Type of the i-th USER formal (index 0 skips the hidden THIS). *)
  VAR n, p: SymPtr;
    k: CARDINAL;
  BEGIN
    n := ClassMethodNode(t, name);
    IF n = NIL THEN RETURN InvalidType END;
    p := n^.plink;
    IF p # NIL THEN p := p^.plink END;   (* skip THIS *)
    k := 0;
    WHILE (p # NIL) AND (k < i) DO p := p^.plink; INC(k) END;
    IF p = NIL THEN RETURN InvalidType END;
    RETURN p^.typ
  END ClassMethodParamType;

PROCEDURE ClassMethodParamIsVar (t: TypeIndex; name: ARRAY OF CHAR;
                                 i: CARDINAL): BOOLEAN;
  VAR n, p: SymPtr;
    k: CARDINAL;
  BEGIN
    n := ClassMethodNode(t, name);
    IF n = NIL THEN RETURN FALSE END;
    p := n^.plink;
    IF p # NIL THEN p := p^.plink END;   (* skip THIS *)
    k := 0;
    WHILE (p # NIL) AND (k < i) DO p := p^.plink; INC(k) END;
    IF p = NIL THEN RETURN FALSE END;
    RETURN p^.isVar
  END ClassMethodParamIsVar;

PROCEDURE ClassMethodRes (t: TypeIndex; name: ARRAY OF CHAR): TypeIndex;
  VAR n: SymPtr;
  BEGIN
    n := ClassMethodNode(t, name);
    IF n = NIL THEN RETURN InvalidType END;
    RETURN n^.rslt
  END ClassMethodRes;


PROCEDURE PushImplClass (ct: TypeIndex);
  BEGIN
    IF nImpl <= HIGH(implStk) THEN
      implStk[nImpl] := ct; INC(nImpl)
    END
  END PushImplClass;

PROCEDURE PopImplClass;
  BEGIN IF nImpl > 0 THEN DEC(nImpl) END
  END PopImplClass;

PROCEDURE CurImplClass (): TypeIndex;
(* The class whose CLASS IMPLEMENTATION body is innermost open, or
   InvalidType.  Bare method names inside a body resolve against it. *)
  BEGIN
    IF nImpl = 0 THEN RETURN InvalidType END;
    RETURN implStk[nImpl - 1]
  END CurImplClass;

PROCEDURE VtClassCount (): CARDINAL;
  BEGIN RETURN nVtl END VtClassCount;

PROCEDURE VtClassAt (k: CARDINAL): TypeIndex;
  BEGIN
    IF k >= nVtl THEN RETURN InvalidType END;
    RETURN vtl[k]
  END VtClassAt;

PROCEDURE IsSubclass (sub, sup: TypeIndex): BOOLEAN;
(* TRUE when sub is sup or inherits (transitively) from sup. *)
  VAR r: TypeIndex;
    guard: CARDINAL;
  BEGIN
    r := Resolve(sub);
    sup := Resolve(sup);
    guard := 0;
    WHILE (r # InvalidType) AND (guard < ResDepth) DO
      IF r = sup THEN RETURN TRUE END;
      r := ParentOf(r);
      INC(guard)
    END;
    RETURN FALSE
  END IsSubclass;

PROCEDURE VptrOffset (ct: TypeIndex): INTEGER;
  VAR r: TypeIndex;
  BEGIN
    r := Resolve(ct);
    IF (r = InvalidType) OR (tform[r] # FClass) THEN RETURN -1 END;
    IF NOT vtBuilt[r] THEN BuildVTable(r) END;
    RETURN tvptr[r]
  END VptrOffset;

PROCEDURE HasVTable (ct: TypeIndex): BOOLEAN;
(* TRUE when ct has (or inherits) any virtual method. *)
  VAR r: TypeIndex;
  BEGIN
    r := Resolve(ct);
    IF (r = InvalidType) OR (tform[r] # FClass) THEN RETURN FALSE END;
    IF NOT vtBuilt[r] THEN BuildVTable(r) END;
    RETURN nVirt[r] > 0
  END HasVTable;

PROCEDURE VirtSlot (ct: TypeIndex; name: ARRAY OF CHAR): INTEGER;
(* Vtable slot of ct's method name, or -1 when it is not virtual. *)
  VAR r: TypeIndex;
    node: SymPtr;
  BEGIN
    node := ClassMethodNode(ct, name);
    IF (node = NIL) OR NOT node^.virt THEN RETURN -1 END;
    r := Resolve(ct);
    IF NOT vtBuilt[r] THEN BuildVTable(r) END;
    RETURN node^.vslot
  END VirtSlot;

PROCEDURE VtCount (ct: TypeIndex): CARDINAL;
  VAR r: TypeIndex;
  BEGIN
    r := Resolve(ct);
    IF (r = InvalidType) OR (tform[r] # FClass) THEN RETURN 0 END;
    IF NOT vtBuilt[r] THEN BuildVTable(r) END;
    RETURN nVirt[r]
  END VtCount;

PROCEDURE VtName (ct: TypeIndex; k: CARDINAL; VAR name: Name): BOOLEAN;
  VAR r: TypeIndex;
  BEGIN
    name[0] := CHR(0);
    r := Resolve(ct);
    IF (r = InvalidType) OR (k >= nVirt[r]) THEN RETURN FALSE END;
    Assign(name, vtName[vtBase[r] + k]);
    RETURN TRUE
  END VtName;

PROCEDURE VtHasBody (ct: TypeIndex; k: CARDINAL): BOOLEAN;
(* TRUE when slot k's method has an emitted body (else the vtable
   entry is a null pointer). *)
  VAR r: TypeIndex;
    node: SymPtr;
  BEGIN
    r := Resolve(ct);
    IF (r = InvalidType) OR (k >= nVirt[r]) THEN RETURN FALSE END;
    node := ClassMethodNode(r, vtName[vtBase[r] + k]);
    IF node = NIL THEN RETURN FALSE END;
    RETURN node^.hasBody
  END VtHasBody;

PROCEDURE VtUid (ct: TypeIndex; k: CARDINAL): CARDINAL;
  VAR r: TypeIndex;
  BEGIN
    r := Resolve(ct);
    IF (r = InvalidType) OR (k >= nVirt[r]) THEN RETURN 0 END;
    RETURN vtUid[vtBase[r] + k]
  END VtUid;


PROCEDURE PushClassMembers (t: TypeIndex): BOOLEAN;
(* Pushes a scope with t's fields and its ancestors' fields
   (inheritance) as KindField, for method bodies in CLASS
   IMPLEMENTATION.  Method NAMES are deliberately not copied; bodies
   re-enter them fresh via ResumeMethod (copying would collide). *)
  VAR r, p: TypeIndex;
    s: ScopePtr;
    guard: CARDINAL;
  BEGIN
    r := Resolve(t);
    IF (r = InvalidType) OR (tform[r] # FClass) THEN RETURN FALSE END;
    s := tscope[r];
    IF s = NIL THEN RETURN FALSE END;
    PushScope;
    curScope^.ofRec := r;
    EnterFieldsOf(r);
    (* ancestors' fields, nearest first *)
    guard := 0;
    p := ParentOf(r);
    WHILE (p # InvalidType) AND (guard < ResDepth) DO
      EnterFieldsOf(p);
      p := ParentOf(p);
      INC(guard)
    END;
    RETURN TRUE
  END PushClassMembers;

PROCEDURE MarkVirtual;
  BEGIN
    IF curProc # NIL THEN curProc^.virt := TRUE END
  END MarkVirtual;

(* ---------------- procedures ---------------- *)


PROCEDURE EnterProc (name: ARRAY OF CHAR): BOOLEAN;
  VAR node: SymPtr;
  BEGIN
    node := RawEnter(name, KindProc);
    IF node = NIL THEN curProc := NIL; RETURN FALSE END;
    node^.rslt := InvalidType;
    node^.plink := NIL;
    node^.isVar := FALSE;
    node^.fwd := FALSE;
    node^.virt := FALSE;
    node^.ext := FALSE;
    node^.fsnap := FALSE;
    node^.link[0] := CHR(0);
    node^.uid := nextUid; INC(nextUid);
    IF node^.uid <= HIGH(uidBase) THEN Assign(uidBase[node^.uid], name) END;
    node^.fdep := nProc;
    node^.vslot := -1;
    node^.hasBody := FALSE;
    curProc := node;
    curPTail := NIL;
    PushProc(node);
    PushScope;
    RETURN TRUE
  END EnterProc;

PROCEDURE DeclareCProc (name: ARRAY OF CHAR): BOOLEAN;
(* Enter name in the current scope as an external C procedure with a
   permissive (varargs, no-result) signature.  Used for intrinsic
   `FROM libc IMPORT ...`; not pushed as the current proc. *)
  VAR node: SymPtr;
  BEGIN
    node := RawEnter(name, KindProc);
    IF node = NIL THEN RETURN FALSE END;
    node^.rslt := InvalidType;
    node^.plink := NIL;
    node^.isVar := FALSE;
    node^.fwd := FALSE;
    node^.virt := FALSE;
    node^.ext := TRUE;
    node^.varargs := TRUE;
    node^.fsnap := FALSE;
    Assign(node^.link, name);
    node^.uid := nextUid; INC(nextUid);
    IF node^.uid <= HIGH(uidBase) THEN Assign(uidBase[node^.uid], name) END;
    node^.fdep := nProc;
    node^.vslot := -1;
    node^.hasBody := TRUE;
    RETURN TRUE
  END DeclareCProc;

PROCEDURE Varargs (name: ARRAY OF CHAR): BOOLEAN;
(* TRUE for a C-varargs procedure (its calls skip arity/type checks). *)
  VAR node: SymPtr;
  BEGIN
    node := Find(name);
    IF node = NIL THEN RETURN FALSE END;
    RETURN node^.varargs
  END Varargs;

PROCEDURE ResumeProc (name: ARRAY OF CHAR): BOOLEAN;
(* Resumes a DEFINITION procedure heading for its IMPLEMENTATION
   body.  The definition's signature (result type, formals in order,
   VAR-ness) is snapshotted before the implementation re-enters its
   own formals; SetProcRes/FixPending then compare (strict 231). *)
  VAR node, f: SymPtr;
    i, n: CARDINAL;
  BEGIN
    IF curUnit # UnitImpl THEN RETURN FALSE END;
    node := TreeFind(curScope^.root, name);
    IF node = NIL THEN RETURN FALSE END;
    IF node^.kind # KindProc THEN RETURN FALSE END;
    (* snapshot the definition signature *)
    node^.snapRes := node^.rslt;
    node^.nSnap := 0;
    n := 0;
    f := node^.plink;
    WHILE (f # NIL) AND (n <= HighSnap) DO
      snapT[n] := f^.typ;
      snapV[n] := f^.isVar;
      INC(n);
      f := f^.plink
    END;
    FOR i := 0 TO HighSnap DO
      IF i < n THEN
        node^.snapT[i] := snapT[i];
        node^.snapV[i] := snapV[i]
      END
    END;
    node^.nSnap := n;
    node^.fsnap := TRUE;
    node^.plink := NIL;   (* implementation re-enters formals *)
    curProc := node;
    curPTail := NIL;
    PushProc(node);
    PushScope;
    RETURN TRUE
  END ResumeProc;

PROCEDURE ReenterProc (name: ARRAY OF CHAR): BOOLEAN;
  VAR node: SymPtr;
  BEGIN
    node := TreeFind(curScope^.root, name);
    IF node = NIL THEN RETURN FALSE END;
    IF (node^.kind # KindProc) OR NOT node^.fwd THEN
      RETURN FALSE
    END;
    node^.fwd := FALSE;
    node^.plink := NIL;  (* fresh signature; step 4 compares old vs new *)
    curProc := node;
    curPTail := NIL;
    PushProc(node);
    PushScope;
    RETURN TRUE
  END ReenterProc;

PROCEDURE EnterParam (name: ARRAY OF CHAR; isVar: BOOLEAN): BOOLEAN;
  VAR node: SymPtr;
  BEGIN
    node := RawEnter(name, KindParam);
    IF node = NIL THEN RETURN FALSE END;
    node^.isVar := isVar;
    node^.plink := NIL;
    IF (nPend < MaxPend) THEN
      pend[nPend] := node; INC(nPend)
    END;
    IF curProc # NIL THEN
      IF curProc^.plink = NIL THEN curProc^.plink := node
      ELSE curPTail^.plink := node
      END;
      curPTail := node
    END;
    RETURN TRUE
  END EnterParam;

PROCEDURE EnterThisParam (cls: TypeIndex): BOOLEAN;
(* Enters the hidden first parameter THIS (a VAR param of the class
   type) for a method heading.  Field access inside the body binds
   THIS as the WITH base.  THIS is not left pending (it is emitted
   explicitly by the heading, before any user formals). *)
  VAR ok: BOOLEAN;
  BEGIN
    ok := EnterParam("THIS", TRUE);
    nPend := 0;
    RETURN ok
  END EnterThisParam;

PROCEDURE SetProcRes (t: TypeIndex) : BOOLEAN;
(* Sets the current procedure's result type.  If the heading resumed
   a DEFINITION (ResumeProc), this is the strict-231 checkpoint: the
   implementation's result type, formal count, formal types and
   VAR-ness are compared against the snapshot; the outcome is
   returned (TRUE = match). *)
  VAR f, node: SymPtr;
    i, n: CARDINAL;
    isV: BOOLEAN;
  BEGIN
    IF curProc # NIL THEN curProc^.rslt := t END;
    node := curProc;
    IF (node = NIL) OR NOT node^.fsnap THEN RETURN TRUE END;
    IF NOT FormalOk(t, node^.snapRes) THEN RETURN FALSE END;
    (* count the implementation heading's formals *)
    n := 0;
    f := node^.plink;
    WHILE (f # NIL) AND (n <= HighSnap) DO INC(n); f := f^.plink END;
    IF n # node^.nSnap THEN RETURN FALSE END;
    f := node^.plink;
    i := 0;
    WHILE f # NIL DO
      IF i > HighSnap THEN RETURN FALSE END;
      isV := f^.isVar;
      IF isV # node^.snapV[i] THEN RETURN FALSE END;
      IF isV THEN
        IF NOT VarParamOk(f^.typ, node^.snapT[i]) THEN RETURN FALSE END
      ELSE
        IF NOT FormalOk(f^.typ, node^.snapT[i]) THEN RETURN FALSE END
      END;
      f := f^.plink;
      INC(i)
    END;
    RETURN TRUE
  END SetProcRes;

PROCEDURE ProcRes (name: ARRAY OF CHAR): TypeIndex;
  VAR node: SymPtr;
  BEGIN
    node := Find(name);
    IF node = NIL THEN RETURN InvalidType END;
    IF node^.kind # KindProc THEN RETURN InvalidType END;
    RETURN node^.rslt
  END ProcRes;

PROCEDURE MarkFwd;
  BEGIN
    IF curProc # NIL THEN curProc^.fwd := TRUE END
  END MarkFwd;

PROCEDURE MarkExternal (link: ARRAY OF CHAR);
(* Marks the current procedure EXTERNAL; link '' means "use the
   procedure's own name" (must be a valid C symbol). *)
  BEGIN
    IF curProc = NIL THEN RETURN END;
    curProc^.ext := TRUE;
    IF link[0] = CHR(0) THEN Assign(curProc^.link, curProc^.name)
    ELSE Assign(curProc^.link, link)
    END
  END MarkExternal;

PROCEDURE ProcLink (name: ARRAY OF CHAR; VAR link: Name): BOOLEAN;
  VAR node: SymPtr;
  BEGIN
    node := Find(name);
    IF node = NIL THEN RETURN FALSE END;
    IF NOT node^.ext THEN RETURN FALSE END;
    Assign(link, node^.link);
    RETURN TRUE
  END ProcLink;

PROCEDURE CloseProc;
  BEGIN
    IF nProc > 0 THEN DEC(nProc) END;
    PopScope
  END CloseProc;

PROCEDURE InProc (): BOOLEAN;
  BEGIN
    RETURN nProc > 0
  END InProc;

PROCEDURE CurRes (): TypeIndex;
  BEGIN
    IF nProc = 0 THEN RETURN InvalidType END;
    RETURN procStk[nProc - 1]^.rslt
  END CurRes;

PROCEDURE ProcDepthOf (name: ARRAY OF CHAR): CARDINAL;
  VAR node: SymPtr;
  BEGIN
    node := Find(name);
    IF node = NIL THEN RETURN 0 END;
    IF node^.kind # KindProc THEN RETURN 0 END;
    RETURN node^.fdep
  END ProcDepthOf;

PROCEDURE ProcUid (name: ARRAY OF CHAR): CARDINAL;
  VAR node: SymPtr;
  BEGIN
    node := Find(name);
    IF node = NIL THEN RETURN 0 END;
    IF node^.kind # KindProc THEN RETURN 0 END;
    RETURN node^.uid
  END ProcUid;

PROCEDURE NthParam (node: SymPtr; i: CARDINAL): SymPtr;
  BEGIN
    node := node^.plink;
    WHILE (i > 0) AND (node # NIL) DO
      node := node^.plink; DEC(i)
    END;
    RETURN node
  END NthParam;

PROCEDURE ProcNPar (name: ARRAY OF CHAR): CARDINAL;
  VAR node, p: SymPtr;
    n: CARDINAL;
  BEGIN
    node := Find(name);
    IF node = NIL THEN RETURN 0 END;
    IF node^.kind # KindProc THEN RETURN 0 END;
    n := 0; p := node^.plink;
    WHILE p # NIL DO INC(n); p := p^.plink END;
    RETURN n
  END ProcNPar;

PROCEDURE ParamType (name: ARRAY OF CHAR; i: CARDINAL): TypeIndex;
  VAR node, p: SymPtr;
  BEGIN
    node := Find(name);
    IF node = NIL THEN RETURN InvalidType END;
    IF node^.kind # KindProc THEN RETURN InvalidType END;
    p := NthParam(node, i);
    IF p = NIL THEN RETURN InvalidType END;
    RETURN p^.typ
  END ParamType;

PROCEDURE ParamIsVar (name: ARRAY OF CHAR; i: CARDINAL): BOOLEAN;
  VAR node, p: SymPtr;
  BEGIN
    node := Find(name);
    IF node = NIL THEN RETURN FALSE END;
    IF node^.kind # KindProc THEN RETURN FALSE END;
    p := NthParam(node, i);
    IF p = NIL THEN RETURN FALSE END;
    RETURN p^.isVar
  END ParamIsVar;


(* ---------------- modules / separate compilation (step 4.3) ---------------- *)

PROCEDURE EnterIn (s: ScopePtr; name: ARRAY OF CHAR;
                    kind: INTEGER): BOOLEAN;
  VAR node: SymPtr;
  BEGIN
    NEW(node);
    Assign(node^.name, name);
    Assign(node^.sym, name);
    node^.mod[0] := CHR(0);
    node^.kind := kind;
    node^.typ := InvalidType;
    node^.scope := s;
    node^.left := NIL;
    node^.right := NIL;
    node^.rslt := InvalidType;
    node^.plink := NIL;
    node^.isVar := FALSE;
    node^.fwd := FALSE;
    node^.virt := FALSE;
    node^.ext := FALSE;
    node^.link[0] := CHR(0);
    node^.fdep := 0;
    node^.uid := 0;
    node^.val[0] := CHR(0);
    IF NOT TreeInsert(s, node) THEN RETURN FALSE END;
    RETURN TRUE
  END EnterIn;

PROCEDURE FindMod (name: ARRAY OF CHAR): INTEGER;
  VAR i : CARDINAL;
  BEGIN
    i := 0;
    WHILE i < nMods DO
      IF Equal(modNames[i], name) THEN RETURN VAL(INTEGER, i) END;
      INC(i)
    END;
    RETURN -1
  END FindMod;

PROCEDURE NewMod (name: ARRAY OF CHAR; kind: INTEGER): BOOLEAN;
  VAR idx : CARDINAL;
    s : ScopePtr;
  BEGIN
    IF nMods >= MaxMods THEN RETURN FALSE END;
    IF FindMod(name) # -1 THEN RETURN FALSE END;
    idx := nMods;
    Assign(modNames[idx], name);
    s := NewScope(globScope, 1);
    modScopes[idx] := s;
    modKind[idx] := kind;
    modImpl[idx] := FALSE;
    INC(nMods);
    (* the module name lives in the global scope *)
    IF NOT EnterIn(globScope, name, KindModule) THEN
      DEC(nMods); RETURN FALSE
    END;
    curMod := VAL(INTEGER, idx);
    curUnit := kind;
    curScope := s;
    RETURN TRUE
  END NewMod;

PROCEDURE BeginDef (name: ARRAY OF CHAR): BOOLEAN;
  BEGIN
    RETURN NewMod(name, UnitDef)
  END BeginDef;

PROCEDURE BeginImpl (name: ARRAY OF CHAR): BOOLEAN;
  VAR idx : INTEGER;
  BEGIN
    idx := FindMod(name);
    IF idx = -1 THEN RETURN FALSE END;
    IF (modKind[idx] # UnitDef) OR modImpl[idx] THEN RETURN FALSE END;
    modImpl[idx] := TRUE;
    curMod := idx;
    curUnit := UnitImpl;
    curScope := modScopes[idx];
    RETURN TRUE
  END BeginImpl;

PROCEDURE Reenter (name: ARRAY OF CHAR; kind: INTEGER): BOOLEAN;
(* Re-enters an already-registered module's scope for an instantiation
   re-parse (the refinement registered the instance name; the re-parsed
   generic body must be filled into that same module). *)
  VAR idx : INTEGER;
  BEGIN
    idx := FindMod(name);
    IF idx = -1 THEN RETURN FALSE END;
    curMod := idx;
    curUnit := kind;
    curScope := modScopes[idx];
    RETURN TRUE
  END Reenter;

PROCEDURE BeginProg (name: ARRAY OF CHAR): BOOLEAN;
  VAR ok : BOOLEAN;
  BEGIN
    ok := NewMod(name, UnitProg);
    IF ok THEN haveProg := TRUE END;
    RETURN ok
  END BeginProg;

PROCEDURE HaveProgram (): BOOLEAN;
  BEGIN
    RETURN haveProg
  END HaveProgram;

PROCEDURE EndUnit;
  BEGIN
    curScope := globScope;
    curMod := -1;
    curUnit := -1
  END EndUnit;

PROCEDURE EnterLowerScope (name: ARRAY OF CHAR): BOOLEAN;
(* Make a unit's module scope current while Lower re-emits it.  Without
   this, Lower runs in globScope and MaterializeGlobals copies the
   unit's types there — which leaks them across units (and across
   generic instantiations of the same generic). *)
  VAR idx: INTEGER;
  BEGIN
    idx := FindMod(name);
    IF idx = -1 THEN RETURN FALSE END;
    curMod := idx; curScope := modScopes[idx];
    RETURN TRUE
  END EnterLowerScope;

PROCEDURE LeaveLowerScope;
  BEGIN
    curScope := globScope; curMod := -1
  END LeaveLowerScope;

PROCEDURE ModKnown (name: ARRAY OF CHAR): BOOLEAN;
  BEGIN
    RETURN FindMod(name) # -1
  END ModKnown;

PROCEDURE OpaqueBase (name: ARRAY OF CHAR): TypeIndex;
  VAR node: SymPtr;
    r : TypeIndex;
  BEGIN
    node := Find(name);
    IF node = NIL THEN RETURN InvalidType END;
    IF node^.kind # KindType THEN RETURN InvalidType END;
    r := node^.typ;
    IF (r < 0) OR (r >= VAL(INTEGER, nTypes)) THEN
      RETURN InvalidType
    END;
    IF (tform[r] = FAlias) AND (tref[r] = InvalidType) THEN RETURN r END;
    RETURN InvalidType
  END OpaqueBase;

PROCEDURE BeginTypeBlock;
  BEGIN
    INC(typeBlockDepth)
  END BeginTypeBlock;

PROCEDURE EndTypeBlock;
  BEGIN
    IF typeBlockDepth > 0 THEN DEC(typeBlockDepth) END
  END EndTypeBlock;

PROCEDURE IsUnresolved (t: TypeIndex): BOOLEAN;
  VAR r: TypeIndex;
  BEGIN
    IF (t < 0) OR (t >= VAL(INTEGER, nTypes)) THEN RETURN FALSE END;
    r := t;
    RETURN (tform[r] = FAlias) AND (tref[r] = InvalidType)
  END IsUnresolved;

PROCEDURE ForwardType (name: ARRAY OF CHAR): TypeIndex;
(* Registers an undeclared type name as an opaque placeholder that a
   later TYPE declaration completes.  Active inside a TYPE block, and
   at module declaration level (so a global may reference a type
   declared further down). *)
  VAR node: SymPtr;
    t: TypeIndex;
  BEGIN
    IF (typeBlockDepth = 0) AND (nProc > 0) THEN
      RETURN InvalidType
    END;
    node := Find(name);
    IF node # NIL THEN
      IF node^.kind = KindType THEN RETURN node^.typ END;
      RETURN InvalidType
    END;
    IF NOT Enter(name, KindType) THEN RETURN InvalidType END;
    t := NewAlias();
    SetSymType(name, t);
    IF (typeBlockDepth = 0) AND (pfwdN <= HIGH(pfwdName)) THEN
      Assign(pfwdName[pfwdN], name);
      pfwdT[pfwdN] := t;
      INC(pfwdN)
    END;
    RETURN t
  END ForwardType;

PROCEDURE FwdPending (): CARDINAL;
  BEGIN RETURN pfwdN END FwdPending;

PROCEDURE FwdInfo (i: CARDINAL; VAR name: Name; VAR unresolved: BOOLEAN);
  BEGIN
    name[0] := CHR(0);
    unresolved := FALSE;
    IF i < pfwdN THEN
      Assign(name, pfwdName[i]);
      unresolved := Resolve(pfwdT[i]) = InvalidType
    END
  END FwdInfo;

PROCEDURE FwdClear;
  BEGIN pfwdN := 0 END FwdClear;

PROCEDURE QualNode (mod, name: ARRAY OF CHAR): SymPtr;
  VAR i : INTEGER;
  BEGIN
    i := FindMod(mod);
    IF i = -1 THEN RETURN NIL END;
    RETURN TreeFind(modScopes[i]^.root, name)
  END QualNode;

PROCEDURE QualType (mod, name: ARRAY OF CHAR): TypeIndex;
  VAR n : SymPtr;
  BEGIN
    n := QualNode(mod, name);
    IF n = NIL THEN RETURN InvalidType END;
    RETURN n^.typ
  END QualType;

PROCEDURE QualNthParam (n: SymPtr; i: CARDINAL): SymPtr;
  BEGIN
    n := n^.plink;
    WHILE (i > 0) AND (n # NIL) DO
      n := n^.plink; DEC(i)
    END;
    RETURN n
  END QualNthParam;

PROCEDURE ExportUp (name: ARRAY OF CHAR);
  VAR src, node: SymPtr;
    parent: ScopePtr;
  BEGIN
    IF curScope = NIL THEN RETURN END;
    src := TreeFind(curScope^.root, name);
    IF src = NIL THEN RETURN END;
    parent := curScope^.parent;
    IF parent = NIL THEN RETURN END;
    IF TreeFind(parent^.root, name) # NIL THEN RETURN END;
    NEW(node);
    node^ := src^;
    node^.left := NIL;
    node^.right := NIL;
    node^.scope := parent;
    IF NOT TreeInsert(parent, node) THEN
      (* duplicate at this level: ignore *)
    END
  END ExportUp;

PROCEDURE Materialize (mod, name: ARRAY OF CHAR): BOOLEAN;
(* FROM-import: clones mod's export into the current scope under
   its plain name. *)
  VAR src, node : SymPtr;
  BEGIN
    src := QualNode(mod, name);
    IF src = NIL THEN RETURN FALSE END;
    (* already visible (repeat import): nothing to do *)
    IF TreeFind(curScope^.root, name) # NIL THEN RETURN TRUE END;
    NEW(node);
    node^ := src^;
    node^.left := NIL;
    node^.right := NIL;
    node^.scope := curScope;
    IF NOT TreeInsert(curScope, node) THEN RETURN FALSE END;
    RETURN TRUE
  END Materialize;

PROCEDURE MaterializeReplace (mod, name: ARRAY OF CHAR): BOOLEAN;
(* Like Materialize, but when `name` is already visible it is updated in
   place to the given module's symbol.  Lower re-emits one unit at a time
   and every unit has its own `scopeTop`/`EOL`/..., so the current unit's
   global must win GlobalRef; the plain Materialize keeps the first one. *)
  VAR src, node, l, r : SymPtr; sc : ScopePtr;
  BEGIN
    src := QualNode(mod, name);
    IF src = NIL THEN RETURN FALSE END;
    node := TreeFind(curScope^.root, name);
    IF node # NIL THEN
      l := node^.left; r := node^.right; sc := node^.scope;
      node^ := src^;
      node^.left := l; node^.right := r; node^.scope := sc;
      RETURN TRUE
    END;
    NEW(node);
    node^ := src^;
    node^.left := NIL;
    node^.right := NIL;
    node^.scope := curScope;
    IF NOT TreeInsert(curScope, node) THEN RETURN FALSE END;
    RETURN TRUE
  END MaterializeReplace;

PROCEDURE BuildAlias (mod, name: ARRAY OF CHAR; VAR alias: Name);
(* alias := "<mod>$<name>" (a key no identifier can collide with). *)
  VAR i, j : CARDINAL;
  BEGIN
    i := 0;
    WHILE (i < HIGH(alias)) AND (mod[i] # CHR(0)) DO
      alias[i] := mod[i]; INC(i)
    END;
    IF i < HIGH(alias) THEN alias[i] := "$"; INC(i) END;
    j := 0;
    WHILE (i < HIGH(alias)) AND (name[j] # CHR(0)) DO
      alias[i] := name[j]; INC(i); INC(j)
    END;
    IF i <= HIGH(alias) THEN alias[i] := CHR(0) END
  END BuildAlias;

PROCEDURE MaterializeAlias (mod, name: ARRAY OF CHAR;
                             VAR alias: Name): BOOLEAN;
(* Qualified access: clones mod's export under a per-module alias
   key so same-named exports of different modules never collide.
   The node keeps sym = name and mod = defining module, so QBE
   symbols (data and calls) resolve correctly. *)
  VAR src, node : SymPtr;
  BEGIN
    src := QualNode(mod, name);
    IF src = NIL THEN RETURN FALSE END;
    BuildAlias(mod, name, alias);
    IF TreeFind(curScope^.root, alias) = NIL THEN
      NEW(node);
      node^ := src^;
      Assign(node^.name, alias);   (* BST key *)
      Assign(node^.sym, name);     (* real symbol name *)
      node^.left := NIL;
      node^.right := NIL;
      node^.scope := curScope;
      IF NOT TreeInsert(curScope, node) THEN RETURN FALSE END
    END;
    RETURN TRUE
  END MaterializeAlias;

PROCEDURE SymMod (name: ARRAY OF CHAR; VAR m: Name): BOOLEAN;
(* The defining module of the visible entry ("" for a local). *)
  VAR node: SymPtr;
  BEGIN
    m[0] := CHR(0);
    node := Find(name);
    IF node = NIL THEN RETURN FALSE END;
    Assign(m, node^.mod);
    RETURN TRUE
  END SymMod;

PROCEDURE AliasProc (formalName: ARRAY OF CHAR; mod, actualName: ARRAY OF CHAR): BOOLEAN;
(* Generic procedure formal: clone the actual procedure's symbol
   (uid/mod/params/result) under formalName in the current scope, so a
   call through the formal resolves to the actual. *)
  VAR src, node: SymPtr;
  BEGIN
    src := QualNode(mod, actualName);
    IF src = NIL THEN
      src := Find(actualName)   (* same-module actual *)
    END;
    IF src = NIL THEN RETURN FALSE END;
    IF TreeFind(curScope^.root, formalName) # NIL THEN RETURN TRUE END;
    NEW(node);
    node^ := src^;
    Assign(node^.name, formalName);
    node^.left := NIL;
    node^.right := NIL;
    node^.scope := curScope;
    IF NOT TreeInsert(curScope, node) THEN RETURN FALSE END;
    RETURN TRUE
  END AliasProc;

PROCEDURE QualProcInfo (mod, name: ARRAY OF CHAR; VAR uid, depth: CARDINAL;
                        VAR res: TypeIndex; VAR ext: BOOLEAN): BOOLEAN;
(* Proc facts of a qualified (module-qualified) procedure name. *)
  VAR n: SymPtr;
  BEGIN
    n := QualNode(mod, name);
    IF n = NIL THEN RETURN FALSE END;
    uid := n^.uid; depth := n^.fdep; res := n^.rslt; ext := n^.ext;
    RETURN n^.kind = KindProc
  END QualProcInfo;

PROCEDURE ProcBaseByUid (uid: CARDINAL; VAR base: Name): BOOLEAN;
(* Base (mangling) name of a procedure by its uid.  Lets a proc alias or
   a call target whose scope is gone still mangle correctly. *)
  BEGIN
    base[0] := CHR(0);
    IF (uid > HIGH(uidBase)) OR (uidBase[uid][0] = CHR(0)) THEN RETURN FALSE END;
    Assign(base, uidBase[uid]);
    RETURN TRUE
  END ProcBaseByUid;

PROCEDURE SymBase (name: ARRAY OF CHAR; VAR base: Name): BOOLEAN;
(* Base symbol name of the visible entry (differs from `name` for
   qualified aliases). *)
  VAR node: SymPtr;
  BEGIN
    node := Find(name);
    IF node = NIL THEN RETURN FALSE END;
    Assign(base, node^.sym);
    RETURN TRUE
  END SymBase;

PROCEDURE GlobalRef (name: ARRAY OF CHAR; VAR g: Name): BOOLEAN;
(* QBE global-symbol name for a module-level entry: "<mod>_<sym>".
   FALSE when name is not a module-level symbol. *)
  VAR node: SymPtr;
    i, j : CARDINAL;
  BEGIN
    node := Find(name);
    IF node = NIL THEN RETURN FALSE END;
    IF node^.mod[0] = CHR(0) THEN RETURN FALSE END;
    i := 0;
    WHILE (i < HIGH(g)) AND (node^.mod[i] # CHR(0)) DO
      g[i] := node^.mod[i]; INC(i)
    END;
    IF i < HIGH(g) THEN g[i] := "_"; INC(i) END;
    j := 0;
    WHILE (i < HIGH(g)) AND (node^.sym[j] # CHR(0)) DO
      g[i] := node^.sym[j]; INC(i); INC(j)
    END;
    IF i <= HIGH(g) THEN g[i] := CHR(0) END;
    RETURN TRUE
  END GlobalRef;

PROCEDURE DeferReset;
(* Fresh deferral table per unit (the parser's span table is per-parse;
   the driver-equivalent reset lives in the M2 action). *)
  BEGIN
    nDefer := 0
  END DeferReset;

PROCEDURE DeferBody (): CARDINAL;
(* Records the current procedure's own scope for a skipped body.  Call
   at skip time, when curScope is the proc scope (heading parsed,
   params entered, body not yet parsed).  Returns the deferral index,
   or 65535 when there is no current procedure or the table is full. *)
  BEGIN
    IF curProc = NIL THEN RETURN 65535 END;
    IF nDefer > HIGH(deferProc) THEN RETURN 65535 END;
    deferProc[nDefer] := curProc;
    deferScope[nDefer] := curScope;
    INC(nDefer);
    RETURN nDefer - 1
  END DeferBody;

PROCEDURE ReenterDeferred (idx: CARDINAL): BOOLEAN;
(* Restores a deferred body scope for the re-parse pass: the saved proc
   scope becomes current again (params visible; locals are entered once
   here) and the proc stack is re-armed for InProc/CurRes.  The
   Block-end CloseProc pops back to the enclosing scope. *)
  BEGIN
    IF idx >= nDefer THEN RETURN FALSE END;
    IF deferProc[idx] = NIL THEN RETURN FALSE END;
    curProc := deferProc[idx];
    curScope := deferScope[idx];
    PushProc(curProc);
    RETURN TRUE
  END ReenterDeferred;

PROCEDURE ParamName (name: ARRAY OF CHAR; i: CARDINAL;
                     VAR pname: Name): BOOLEAN;
(* The i-th formal's name, for the re-parse pass QbeGen replay
   (sibling of ProcNPar/ParamType/ParamIsVar). *)
  VAR node, p: SymPtr; k: CARDINAL;
  BEGIN
    pname[0] := CHR(0);
    node := Find(name);
    IF node = NIL THEN RETURN FALSE END;
    IF node^.kind # KindProc THEN RETURN FALSE END;
    p := node^.plink; k := 0;
    WHILE (p # NIL) AND (k < i) DO p := p^.plink; INC(k) END;
    IF p = NIL THEN RETURN FALSE END;
    Assign(pname, p^.name);
    RETURN TRUE
  END ParamName;

PROCEDURE ImportFrom (mod, name: ARRAY OF CHAR): BOOLEAN;
  VAR n: SymPtr;
  BEGIN
    IF NOT Materialize(mod, name) THEN RETURN FALSE END;
    (* a type is imported together with its enumeration literals *)
    n := QualNode(mod, name);
    IF n # NIL THEN IF EnterEnumLits(n^.typ) > 0 THEN END END;
    RETURN TRUE
  END ImportFrom;

(* ---------------- predicates (unchanged) ---------------- *)

PROCEDURE BaseSpanOk (b: TypeIndex): BOOLEAN;
(* TRUE for set-suitable bases: bool, char, subranges ≤ 256 wide. *)
  VAR r: TypeIndex;
    lo, hi: INTEGER;
  BEGIN
    r := Resolve(b);
    IF r = InvalidType THEN RETURN TRUE END;
    IF tform[r] = FBool THEN RETURN TRUE END;
    IF tform[r] = FChar THEN RETURN TRUE END;
    IF (tform[r] = FEnum) AND (tenum[r] >= 1) AND (tenum[r] <= 256) THEN
      RETURN TRUE   (* a set base over an enumeration *)
    END;
    IF (tform[r] = FSub) AND (tref[r] = InvalidType)
 AND SubBounds(b, lo, hi) AND (hi >= lo) AND (hi - lo < 256) THEN
      RETURN TRUE
    END;
    RETURN FALSE
  END BaseSpanOk;

PROCEDURE SetBasesOk (a, b: TypeIndex): BOOLEAN;
(* base compatibility for two SET types: same, or both suitable
   (masks compare over min words + zero-check extras) *)
  BEGIN
    IF SameType(a, b) THEN RETURN TRUE END;
    RETURN BaseSpanOk(a) AND BaseSpanOk(b)
  END SetBasesOk;

PROCEDURE ParamTypesOk (x, y: TypeIndex): BOOLEAN;
(* Procedure-type formal compatibility: identical, or an open array
   matching an open/fixed 1-D array of the same element type (open
   arrays are distinct descriptors, so index equality is too strict). *)
  BEGIN
    IF SameType(x, y) THEN RETURN TRUE END;
    IF (x = InvalidType) OR (y = InvalidType) THEN RETURN TRUE END;
    IF IsOpenArray(x) AND (ClassOf(y) = ClArray) AND (ArrayDepth(y) = 1) THEN
      RETURN SameType(ArrayElem(x), ArrayElem(y))
    END;
    IF IsOpenArray(y) AND (ClassOf(x) = ClArray) AND (ArrayDepth(x) = 1) THEN
      RETURN SameType(ArrayElem(x), ArrayElem(y))
    END;
    RETURN FALSE
  END ParamTypesOk;

PROCEDURE ProcTypesOk (a, b: TypeIndex): BOOLEAN;
(* Structural compatibility of two procedure types: same result and
   same parameter types / VAR flags. *)
  VAR i, n: CARDINAL;
  BEGIN
    IF (tform[a] # FProc) OR (tform[b] # FProc) THEN RETURN FALSE END;
    IF NOT SameType(tref[a], tref[b]) THEN RETURN FALSE END;
    n := procn[a];
    IF n # procn[b] THEN RETURN FALSE END;
    i := 0;
    WHILE i < n DO
      IF procvis[procstart[a] + i] # procvis[procstart[b] + i] THEN
        RETURN FALSE
      END;
      IF NOT ParamTypesOk(procp[procstart[a] + i],
                          procp[procstart[b] + i]) THEN
        RETURN FALSE
      END;
      INC(i)
    END;
    RETURN TRUE
  END ProcTypesOk;

PROCEDURE Assignable (src, dst: TypeIndex): BOOLEAN;
  VAR rs, rd: TypeIndex;
  BEGIN
    IF (src = InvalidType) OR (dst = InvalidType) THEN RETURN TRUE END;
    rs := Resolve(src); rd := Resolve(dst);
    IF rs = rd THEN RETURN TRUE END;
    IF (rs = InvalidType) OR (rd = InvalidType) THEN RETURN TRUE END;
    IF (tform[rs] = FSet) AND (tform[rd] = FSet) THEN
      RETURN SetBasesOk(tref[rs], tref[rd])
    END;
    IF (tform[rs] = FProc) AND (tform[rd] = FProc) THEN
      RETURN ProcTypesOk(rs, rd)
    END;
    IF (ClassOf(src) = ClArray) AND (ClassOf(dst) = ClArray) THEN
      (* a fixed 1-D array is compatible with an open formal of the
         same element type (value or VAR) *)
      IF IsOpenArray(dst) AND (ArrayDepth(src) = 1) THEN
        RETURN SameType(ArrayElem(src), ArrayElem(dst))
      END;
      RETURN SameType(src, dst)
    END;
    IF (ClassOf(src) = ClStr) AND (ClassOf(dst) = ClArray) THEN
      RETURN (ArrayDepth(dst) = 1)
 AND (ClassOf(ArrayElem(dst)) = ClChar)
    END;
    IF (ClassOf(src) = ClUStr) AND (ClassOf(dst) = ClArray) THEN
      (* a U"..." literal assigns/ passes to a 1-D ARRAY OF UCHAR by
         content copy (count-clamped, UCHAR-0 terminated). *)
      RETURN (ArrayDepth(dst) = 1)
 AND (ClassOf(ArrayElem(dst)) = ClUChar)
    END;
    IF ClassOf(src) = ClNil THEN
      RETURN ClassOf(dst) = ClPtr
    END;
    (* ADDRESS assigns to/from any pointer (check before the subclass
       test, which returns early) *)
    IF (Resolve(src) = dAddr) AND (ClassOf(dst) = ClPtr) THEN
      RETURN TRUE
    END;
    IF (Resolve(dst) = dAddr) AND (ClassOf(src) = ClPtr) THEN
      RETURN TRUE
    END;
    (* POINTER TO Derived assigns to POINTER TO Base (subtyping) *)
    IF (ClassOf(src) = ClPtr) AND (ClassOf(dst) = ClPtr) THEN
      RETURN IsSubclass(PtrBase(src), PtrBase(dst))
    END;
    (* a procedure value is a code address: it assigns to/from a
       pointer (PROC is mapped onto ADDRESS) *)
    IF (ClassOf(src) = ClProc) AND (ClassOf(dst) = ClPtr) THEN
      RETURN TRUE
    END;
    IF (ClassOf(src) = ClPtr) AND (ClassOf(dst) = ClProc) THEN
      RETURN TRUE
    END;
    IF (ClassOf(src) = ClInt) AND (ClassOf(dst) = ClInt) THEN
      RETURN TRUE
    END;
    IF (ClassOf(src) = ClInt) AND (ClassOf(dst) = ClLong) THEN
      RETURN TRUE
    END;
    IF (ClassOf(src) = ClInt) AND (ClassOf(dst) = ClReal) THEN
      RETURN TRUE
    END;
    RETURN FALSE
  END Assignable;

PROCEDURE ArithCheck (l, r: TypeIndex; divmod: BOOLEAN;
                      VAR res: TypeIndex): BOOLEAN;
  BEGIN
    res := InvalidType;
    IF (Resolve(l) = InvalidType) OR (Resolve(r) = InvalidType) THEN RETURN TRUE END;
    IF (IsLongFamily(l) AND IsLongFamily(r))
       OR (IsLongFamily(l) AND IsIntFamily(r))
       OR (IsIntFamily(l) AND IsLongFamily(r)) THEN
      res := dLong; RETURN TRUE
    END;
    IF IsIntFamily(l) AND IsIntFamily(r) THEN
      res := dInt; RETURN TRUE
    END;
    IF NOT divmod AND (ClassOf(l) = ClReal) AND (ClassOf(r) = ClReal) THEN
      res := dReal; RETURN TRUE
    END;
    RETURN FALSE
  END ArithCheck;

PROCEDURE BoolCheck (t: TypeIndex): BOOLEAN;
  BEGIN
    IF Resolve(t) = InvalidType THEN RETURN TRUE END;
    RETURN ClassOf(t) = ClBool
  END BoolCheck;

PROCEDURE IsStrType (t: TypeIndex): BOOLEAN;
(* A string literal, or a 1-D ARRAY OF CHAR. *)
  VAR c: TypeIndex;
  BEGIN
    c := Resolve(t);
    IF c = InvalidType THEN RETURN FALSE END;
    IF ClassOf(c) = ClStr THEN RETURN TRUE END;
    IF (ClassOf(c) = ClArray) AND (ArrayDepth(c) = 1) THEN
      RETURN ClassOf(ArrayElem(c)) = ClChar
    END;
    RETURN FALSE
  END IsStrType;

PROCEDURE UStrCompat (l, r: TypeIndex): BOOLEAN;
(* Both operands are UString literals (ClUStr): `+` concatenates. *)
  BEGIN
    RETURN (l # InvalidType) AND (r # InvalidType)
      AND (ClassOf(l) = ClUStr) AND (ClassOf(r) = ClUStr)
  END UStrCompat;

PROCEDURE IsUCharArray (t: TypeIndex): BOOLEAN;
(* A 1-D ARRAY OF UCHAR: a destination for U"..." content copy. *)
  VAR c: TypeIndex;
  BEGIN
    c := Resolve(t);
    IF c = InvalidType THEN RETURN FALSE END;
    IF (ClassOf(c) = ClArray) AND (ArrayDepth(c) = 1) THEN
      RETURN ClassOf(ArrayElem(c)) = ClUChar
    END;
    RETURN FALSE
  END IsUCharArray;

PROCEDURE StrCompat (l, r: TypeIndex): BOOLEAN;
(* Both operands are string-compatible (content equality via the
   shim); used for `=`/`#` only. *)
  BEGIN
    RETURN IsStrType(l) AND IsStrType(r)
  END StrCompat;

PROCEDURE EqCheck (l, r: TypeIndex): BOOLEAN;
  VAR rl, rr: TypeIndex;
  BEGIN
    IF (Resolve(l) = InvalidType) OR (Resolve(r) = InvalidType) THEN RETURN TRUE END;
    IF ClassOf(l) = ClNil THEN
      RETURN (ClassOf(r) = ClNil) OR (ClassOf(r) = ClPtr)
    END;
    IF ClassOf(r) = ClNil THEN
      RETURN (ClassOf(l) = ClNil) OR (ClassOf(l) = ClPtr)
    END;
    (* gm2 ext: any two set types compare =/# (word-wise equality);
       a set CASE selector uses this too. *)
    IF (ClassOf(l) = ClSet) AND (ClassOf(r) = ClSet) THEN RETURN TRUE END;
    IF SameType(l, r) THEN
      (* Whole-array, string, record and class equality are not
         built-in (213); compare member-wise instead. *)
      IF (ClassOf(l) = ClArray) OR (ClassOf(l) = ClStr)
         OR (ClassOf(l) = ClRecord) OR (ClassOf(l) = ClClass) THEN
        IF StrCompat(l, r) THEN RETURN TRUE END;   (* string content *)
        RETURN FALSE
      END;
      RETURN TRUE
    END;
    IF StrCompat(l, r) THEN RETURN TRUE END;
    IF IsIntFamily(l) AND IsIntFamily(r) THEN RETURN TRUE END;
    IF (ClassOf(l) = ClLong) AND (ClassOf(r) = ClLong) THEN
      RETURN TRUE
    END;
    IF (ClassOf(l) = ClLong) AND IsIntFamily(r) THEN RETURN TRUE END;
    IF IsIntFamily(l) AND (ClassOf(r) = ClLong) THEN RETURN TRUE END;
    IF (ClassOf(l) = ClReal) AND (ClassOf(r) = ClReal) THEN
      RETURN TRUE
    END;
    IF (ClassOf(l) = ClChar) AND (ClassOf(r) = ClChar) THEN
      RETURN TRUE
    END;
    IF (ClassOf(l) = ClUChar) AND (ClassOf(r) = ClUChar) THEN
      RETURN TRUE
    END;
    IF (ClassOf(l) = ClBool) AND (ClassOf(r) = ClBool) THEN
      RETURN TRUE
    END;
    rl := Resolve(l); rr := Resolve(r);
    IF (rl = InvalidType) OR (rr = InvalidType) THEN RETURN TRUE END;
    IF (tform[rl] = FSet) AND (tform[rr] = FSet) THEN
      RETURN SetBasesOk(tref[rl], tref[rr])
    END;
    RETURN FALSE
  END EqCheck;

PROCEDURE OrdCheck (l, r: TypeIndex): BOOLEAN;
  BEGIN
    IF (Resolve(l) = InvalidType) OR (Resolve(r) = InvalidType) THEN RETURN TRUE END;
    IF IsIntFamily(l) AND IsIntFamily(r) THEN RETURN TRUE END;
    IF (ClassOf(l) = ClLong) AND (ClassOf(r) = ClLong) THEN
      RETURN TRUE
    END;
    IF (ClassOf(l) = ClLong) AND IsIntFamily(r) THEN RETURN TRUE END;
    IF IsIntFamily(l) AND (ClassOf(r) = ClLong) THEN RETURN TRUE END;
    IF (ClassOf(l) = ClReal) AND (ClassOf(r) = ClReal) THEN
      RETURN TRUE
    END;
    IF (ClassOf(l) = ClChar) AND (ClassOf(r) = ClChar) THEN
      RETURN TRUE
    END;
    IF (ClassOf(l) = ClUChar) AND (ClassOf(r) = ClUChar) THEN
      RETURN TRUE
    END;
    IF (ClassOf(l) = ClEnum) AND SameType(l, r) THEN RETURN TRUE END;
    RETURN FALSE
  END OrdCheck;

PROCEDURE SetElemClassOk (c: INTEGER): BOOLEAN;
(* TRUE for an element class acceptable in a set constructor. *)
  BEGIN
    RETURN (c = ClInt) OR (c = ClChar) OR (c = ClBool)
        OR (c = ClEnum) OR (c = ClUChar)
  END SetElemClassOk;

PROCEDURE InCheck (l, set: TypeIndex): BOOLEAN;
  VAR rs, b: TypeIndex;
  BEGIN
    IF (Resolve(l) = InvalidType) OR (Resolve(set) = InvalidType) THEN RETURN TRUE END;
    rs := Resolve(set);
    IF (rs = InvalidType) OR (tform[rs] # FSet) THEN RETURN FALSE END;
    b := tref[rs];
    IF SameType(l, b) THEN RETURN TRUE END;
    IF IsIntFamily(l) AND IsIntFamily(b) THEN RETURN TRUE END;
    IF (ClassOf(l) = ClChar) AND (ClassOf(b) = ClChar) THEN
      RETURN TRUE
    END;
    (* lenient: small int/char/bool/enum tested against suitable sets;
       the span trap decides out-of-range at runtime *)
    IF ((ClassOf(l) = ClInt) OR (ClassOf(l) = ClChar)
        OR (ClassOf(l) = ClBool) OR (ClassOf(l) = ClEnum))
       AND (SetWords(set) > 0) THEN
      RETURN TRUE
    END;
    RETURN FALSE
  END InCheck;

PROCEDURE RelCheck (l, r: TypeIndex; op: INTEGER): BOOLEAN;
  BEGIN
    IF (Resolve(l) = InvalidType) OR (Resolve(r) = InvalidType) THEN RETURN TRUE END;
    IF op = OpIn THEN RETURN InCheck(l, r) END;
    IF (op = OpEq) OR (op = OpNeq1) OR (op = OpNeq2) THEN
      RETURN EqCheck(l, r)
    END;
    RETURN OrdCheck(l, r)
  END RelCheck;

(* ---------------- init ---------------- *)

PROCEDURE Predef (name: ARRAY OF CHAR; kind: INTEGER; t: TypeIndex);
  BEGIN
    IF Enter(name, kind) THEN SetSymType(name, t) END
  END Predef;

PROCEDURE AddFormal (pr: SymPtr; t: TypeIndex; isVar: BOOLEAN);
(* Appends a formal-position node to procedure pr's plink chain.
   These formals are not in any scope: they exist only to give the
   external builtin a signature the caller checks against. *)
  VAR p, q: SymPtr;
  BEGIN
    IF pr = NIL THEN RETURN END;
    NEW(p);
    p^.name[0] := CHR(0);
    p^.sym[0] := CHR(0);
    p^.mod[0] := CHR(0);
    p^.kind := KindParam;
    p^.typ := t;
    p^.scope := NIL;
    p^.left := NIL; p^.right := NIL;
    p^.rslt := InvalidType;
    p^.plink := NIL;
    p^.isVar := isVar;
    p^.fwd := FALSE; p^.virt := FALSE;
    p^.fdep := 0;
    p^.snapRes := InvalidType;
    p^.nSnap := 0;
    p^.fsnap := FALSE;
    p^.vslot := -1;
    p^.hasBody := FALSE;
    p^.ext := FALSE; p^.varargs := FALSE;
    p^.link[0] := CHR(0);
    p^.uid := 0;
    p^.val[0] := CHR(0);
    IF pr^.plink = NIL THEN
      pr^.plink := p
    ELSE
      q := pr^.plink;
      WHILE q^.plink # NIL DO q := q^.plink END;
      q^.plink := p
    END
  END AddFormal;

PROCEDURE PredefCProc (name, cname: ARRAY OF CHAR; res: TypeIndex): SymPtr;
(* Defines an external C procedure in the global scope with an
   explicit (not varargs) signature; formals are added with AddFormal. *)
  VAR node: SymPtr;
  BEGIN
    node := RawEnter(name, KindProc);
    IF node = NIL THEN RETURN NIL END;
    node^.rslt := res;
    node^.plink := NIL;
    node^.isVar := FALSE;
    node^.fwd := FALSE;
    node^.virt := FALSE;
    node^.ext := TRUE;
    node^.varargs := FALSE;
    node^.fsnap := FALSE;
    Assign(node^.link, cname);
    node^.uid := nextUid; INC(nextUid);
    node^.fdep := 0;
    node^.vslot := -1;
    node^.hasBody := TRUE;
    RETURN node
  END PredefCProc;

PROCEDURE Init;
  VAR pr: SymPtr;
  BEGIN
    scopeList := NIL; scopeTail := NIL;
    fields := NIL; nFields := 0;
    nPend := 0; nPendF := 0;
    nTypes := 0; nProc := 0; nBounds := 0; nextUid := 0;
    vtTop := 0; nVtl := 0; nImpl := 0;
    curProc := NIL; curPTail := NIL;
    nMods := 0; curMod := -1; curUnit := -1; haveProg := FALSE;
    curScope := NewScope(NIL, 0);
    globScope := curScope;
    dInt := NewDesc(FInt, InvalidType);
    dCard := NewDesc(FInt, InvalidType);
    dReal := NewDesc(FReal, InvalidType);
    dChar := NewDesc(FChar, InvalidType);
    dBool := NewDesc(FBool, InvalidType);
    dNil := NewDesc(FNil, InvalidType);
    dAddr := NewDesc(FPtr, InvalidType);   (* ADDRESS: pointer-sized *)
    dLong := NewDesc(FLong, InvalidType);  (* LONGINT/LONGCARD: 64-bit *)
    dUChar := NewDesc(FUChar, InvalidType);
    dBitset := NewSet(NewSubR(0, 15));     (* BITSET *)
    dProc := NewProcType(InvalidType);     (* PROC: no params, no result *)
    Predef("INTEGER", KindPredef, dInt);
    Predef("CARDINAL", KindPredef, dCard);
    Predef("SHORTINT", KindPredef, dInt);
    Predef("LONGINT", KindPredef, dLong);
    Predef("SHORTCARD", KindPredef, dCard);
    Predef("REAL", KindPredef, dReal);
    Predef("LONGREAL", KindPredef, dReal);
    Predef("CHAR", KindPredef, dChar);
    Predef("BOOLEAN", KindPredef, dBool);
    Predef("TRUE", KindConst, dBool);
    Predef("FALSE", KindConst, dBool);
    Predef("ADDRESS", KindPredef, dAddr);
    Predef("UCHAR", KindPredef, dUChar);
    Predef("BITSET", KindPredef, dBitset);
    (* SYSTEM storage types (PIM/gm2): mapped onto V3's integer family
       (BYTE/WORD -> the 32-bit ordinal, LONGWORD -> LONGINT, the
       address forms -> ADDRESS) so `FROM SYSTEM IMPORT BYTE;` and
       `ARRAY OF BYTE` resolve. *)
    Predef("BYTE", KindPredef, dCard);
    Predef("SBYTE", KindPredef, dInt);
    Predef("WORD", KindPredef, dCard);
    Predef("SWORD", KindPredef, dInt);
    Predef("LONGWORD", KindPredef, dLong);
    Predef("SHORTADDR", KindPredef, dAddr);
    Predef("LONGADDR", KindPredef, dAddr);
    Predef("PROC", KindPredef, dAddr);
    Predef("LOC", KindPredef, dAddr);
    (* gm2 sized/scalar names (mapped onto V3's families) *)
    Predef("LONGCARD", KindPredef, dLong);
    Predef("SHORTREAL", KindPredef, dReal);
    Predef("REAL32", KindPredef, dReal);
    Predef("REAL64", KindPredef, dReal);
    Predef("INTEGER8", KindPredef, dInt);
    Predef("INTEGER16", KindPredef, dInt);
    Predef("INTEGER32", KindPredef, dInt);
    Predef("INTEGER64", KindPredef, dLong);
    Predef("CARDINAL8", KindPredef, dCard);
    Predef("CARDINAL16", KindPredef, dCard);
    Predef("CARDINAL32", KindPredef, dCard);
    Predef("CARDINAL64", KindPredef, dLong);
    (* PIM/SYSTEM coroutines: PROCESS is pointer-sized; the three
       builtins bind to C helpers in the runtime shim.  Signatures:
         NEWPROCESS(P: PROC; A: ADDRESS; n: CARDINAL; VAR c: PROCESS);
         TRANSFER(VAR a, b: PROCESS);
         IOTRANSFER(VAR a, b: PROCESS; interruptNo: CARDINAL). *)
    Predef("PROCESS", KindPredef, dAddr);
    pr := PredefCProc("NEWPROCESS", "m2_newprocess", InvalidType);
    AddFormal(pr, dProc, FALSE);
    AddFormal(pr, dAddr, FALSE);
    AddFormal(pr, dCard, FALSE);
    AddFormal(pr, dAddr, TRUE);
    pr := PredefCProc("TRANSFER", "m2_transfer", InvalidType);
    AddFormal(pr, dAddr, TRUE);
    AddFormal(pr, dAddr, TRUE);
    pr := PredefCProc("IOTRANSFER", "m2_iotransfer", InvalidType);
    AddFormal(pr, dAddr, TRUE);
    AddFormal(pr, dAddr, TRUE);
    AddFormal(pr, dCard, FALSE);
    Predef("NIL", KindConst, dNil)
  END Init;

(* ---------------- listing ---------------- *)

PROCEDURE WriteKind (kind: INTEGER);
  BEGIN
    CASE kind OF
      KindConst  : FileIO.WriteString(FileIO.StdOut, "CONST")
    | KindType   : FileIO.WriteString(FileIO.StdOut, "TYPE")
    | KindVar    : FileIO.WriteString(FileIO.StdOut, "VAR")
    | KindImport : FileIO.WriteString(FileIO.StdOut, "IMPORT")
    | KindModule : FileIO.WriteString(FileIO.StdOut, "MODULE")
    | KindPredef : FileIO.WriteString(FileIO.StdOut, "PREDEF")
    | KindField  : FileIO.WriteString(FileIO.StdOut, "FIELD")
    | KindProc   : FileIO.WriteString(FileIO.StdOut, "PROC")
    | KindParam  : FileIO.WriteString(FileIO.StdOut, "PARAM")
    ELSE FileIO.WriteString(FileIO.StdOut, "???")
    END
  END WriteKind;

PROCEDURE WriteNode (node: SymPtr);
  BEGIN
    IF node = NIL THEN RETURN END;
    WriteNode(node^.left);
    FileIO.WriteString(FileIO.StdOut, "  ");
    FileIO.WriteString(FileIO.StdOut, node^.name);
    FileIO.WriteString(FileIO.StdOut, " : ");
    WriteKind(node^.kind);
    FileIO.WriteString(FileIO.StdOut, " #");
    FileIO.WriteInt(FileIO.StdOut, node^.typ, 1);
    FileIO.WriteLn(FileIO.StdOut);
    WriteNode(node^.right)
  END WriteNode;

PROCEDURE PrintTable;
  VAR s: ScopePtr;
  BEGIN
    FileIO.WriteLn(FileIO.StdOut);
    FileIO.WriteString(FileIO.StdOut, "--- Symbol table ---");
    FileIO.WriteLn(FileIO.StdOut);
    s := scopeList;
    WHILE s # NIL DO
      WriteNode(s^.root);
      s := s^.link
    END
  END PrintTable;

BEGIN
  Init
END SymTab.