Wirth-AT-grammars/TopSpeedV3-grammar/build/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 *)

  (* 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 *)
    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;
  tlo : ARRAY [0 .. MaxTypes - 1] OF INTEGER;
  thi : ARRAY [0 .. MaxTypes - 1] OF INTEGER;
  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] *)
  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 Find (name: ARRAY OF CHAR): SymPtr;
(* Innermost visible node or NIL; walks the scope chain up. *)
  VAR s: ScopePtr;
    r: SymPtr;
  BEGIN
    s := curScope;
    WHILE s # NIL DO
      r := TreeFind(s^.root, name);
      IF r # NIL THEN RETURN r END;
      s := s^.parent
    END;
    RETURN NIL
  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 *)
    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 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;
    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;
    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;
    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 NewSub (base: TypeIndex): TypeIndex;
  BEGIN
    RETURN NewDesc(FSub, base)
  END NewSub;

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 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 NestArray (elem: TypeIndex): TypeIndex;
  VAR i: CARDINAL;
  BEGIN
    i := nBounds;
    WHILE i > 0 DO
      DEC(i);
      elem := NewArrayB(elem, blo[i], bhi[i])
    END;
    RETURN elem
  END NestArray;

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 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 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 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] = FSub) AND (tref[r] = InvalidType)
 AND SubBounds(b, blo, bhi) AND (bhi >= blo)
 AND (bhi - blo < 256) 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 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 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 FieldOwner (name: ARRAY OF CHAR): TypeIndex;
  VAR node: SymPtr;
  BEGIN
    node := Find(name);
    IF node = NIL THEN RETURN InvalidType END;
    IF node^.kind # KindField THEN RETURN InvalidType END;
    IF node^.scope = NIL THEN RETURN InvalidType END;
    RETURN node^.scope^.ofRec
  END FieldOwner;

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 MethUid (): CARDINAL;
(* uid of the procedure currently being headed (0 when none): set by
   ResumeMethod, whose node lives in a detached class scope that
   ProcUid/Find cannot reach. *)
  BEGIN
    IF curProc = NIL THEN RETURN 0 END;
    RETURN curProc^.uid
  END MethUid;

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);
    node^.fdep := nProc;
    node^.vslot := -1;
    node^.hasBody := FALSE;
    curProc := node;
    curPTail := NIL;
    PushProc(node);
    PushScope;
    RETURN TRUE
  END EnterProc;

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 IsExternal (name: ARRAY OF CHAR): BOOLEAN;
  VAR node: SymPtr;
  BEGIN
    node := Find(name);
    IF node = NIL THEN RETURN FALSE END;
    RETURN node^.ext
  END IsExternal;

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 ProcDepth (): CARDINAL;
  BEGIN
    RETURN nProc
  END ProcDepth;

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 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 CurUnit (): INTEGER;
  BEGIN
    RETURN curUnit
  END CurUnit;

PROCEDURE CurModule (VAR name: Name);
  BEGIN
    IF curMod < 0 THEN name[0] := CHR(0)
    ELSE Assign(name, modNames[curMod])
    END
  END CurModule;

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

PROCEDURE ModDefined (name: ARRAY OF CHAR): BOOLEAN;
  VAR i : INTEGER;
  BEGIN
    i := FindMod(name);
    RETURN (i # -1) AND (modKind[i] # UnitProg)
  END ModDefined;

PROCEDURE ModImplemented (name: ARRAY OF CHAR): BOOLEAN;
  VAR i : INTEGER;
  BEGIN
    i := FindMod(name);
    RETURN (i # -1) AND modImpl[i]
  END ModImplemented;

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 ForwardType (name: ARRAY OF CHAR): TypeIndex;
  VAR node: SymPtr;
    t: TypeIndex;
  BEGIN
    IF typeBlockDepth = 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);
    RETURN t
  END ForwardType;

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 QualFind (mod, name: ARRAY OF CHAR): BOOLEAN;
  BEGIN
    RETURN QualNode(mod, name) # NIL
  END QualFind;

PROCEDURE QualKind (mod, name: ARRAY OF CHAR): INTEGER;
  VAR n : SymPtr;
  BEGIN
    n := QualNode(mod, name);
    IF n = NIL THEN RETURN -1 END;
    RETURN n^.kind
  END QualKind;

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 QualProcUid (mod, name: ARRAY OF CHAR): CARDINAL;
  VAR n : SymPtr;
  BEGIN
    n := QualNode(mod, name);
    IF n = NIL THEN RETURN 0 END;
    IF n^.kind # KindProc THEN RETURN 0 END;
    RETURN n^.uid
  END QualProcUid;

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 QualProcNPar (mod, name: ARRAY OF CHAR): CARDINAL;
  VAR n, p : SymPtr;
    c : CARDINAL;
  BEGIN
    n := QualNode(mod, name);
    IF n = NIL THEN RETURN 0 END;
    IF n^.kind # KindProc THEN RETURN 0 END;
    c := 0; p := n^.plink;
    WHILE p # NIL DO INC(c); p := p^.plink END;
    RETURN c
  END QualProcNPar;

PROCEDURE QualParamType (mod, name: ARRAY OF CHAR; i: CARDINAL):
                                                            TypeIndex;
  VAR n, p : SymPtr;
  BEGIN
    n := QualNode(mod, name);
    IF n = NIL THEN RETURN InvalidType END;
    IF n^.kind # KindProc THEN RETURN InvalidType END;
    p := QualNthParam(n, i);
    IF p = NIL THEN RETURN InvalidType END;
    RETURN p^.typ
  END QualParamType;

PROCEDURE QualParamIsVar (mod, name: ARRAY OF CHAR; i: CARDINAL):
                                                             BOOLEAN;
  VAR n, p : SymPtr;
  BEGIN
    n := QualNode(mod, name);
    IF n = NIL THEN RETURN FALSE END;
    IF n^.kind # KindProc THEN RETURN FALSE END;
    p := QualNthParam(n, i);
    IF p = NIL THEN RETURN FALSE END;
    RETURN p^.isVar
  END QualParamIsVar;

PROCEDURE QualProcRes (mod, name: ARRAY OF CHAR): TypeIndex;
  VAR n : SymPtr;
  BEGIN
    n := QualNode(mod, name);
    IF n = NIL THEN RETURN InvalidType END;
    IF n^.kind # KindProc THEN RETURN InvalidType END;
    RETURN n^.rslt
  END QualProcRes;

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 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 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 ImportFrom (mod, name: ARRAY OF CHAR): BOOLEAN;
  BEGIN
    RETURN Materialize(mod, name)
  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] = 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 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 SameType(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;
    (* 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;
    (* ADDRESS assigns to/from any pointer *)
    IF (Resolve(src) = dAddr) AND (ClassOf(dst) = ClPtr) THEN
      RETURN TRUE
    END;
    IF (Resolve(dst) = dAddr) AND (ClassOf(src) = ClPtr) 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 (l = InvalidType) OR (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 UnaryCheck (t: TypeIndex; VAR res: TypeIndex): BOOLEAN;
  BEGIN
    res := InvalidType;
    IF t = InvalidType THEN RETURN TRUE END;
    IF IsLongFamily(t) THEN res := dLong; RETURN TRUE END;
    IF IsIntFamily(t) THEN res := dInt; RETURN TRUE END;
    IF ClassOf(t) = ClReal THEN res := dReal; RETURN TRUE END;
    RETURN FALSE
  END UnaryCheck;

PROCEDURE BoolCheck (t: TypeIndex): BOOLEAN;
  BEGIN
    IF 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 (l = InvalidType) OR (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;
    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 (l = InvalidType) OR (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 InCheck (l, set: TypeIndex): BOOLEAN;
  VAR rs, b: TypeIndex;
  BEGIN
    IF (l = InvalidType) OR (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 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)) AND (SetWords(set) > 0) THEN
      RETURN TRUE
    END;
    RETURN FALSE
  END InCheck;

PROCEDURE RelCheck (l, r: TypeIndex; op: INTEGER): BOOLEAN;
  BEGIN
    IF (l = InvalidType) OR (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;

PROCEDURE SetElemCheck (first, elem: TypeIndex): BOOLEAN;
  BEGIN
    IF (first = InvalidType) OR (elem = InvalidType) THEN
      RETURN TRUE
    END;
    IF SameType(first, elem) THEN RETURN TRUE END;
    IF IsIntFamily(first) AND IsIntFamily(elem) THEN RETURN TRUE END;
    RETURN FALSE
  END SetElemCheck;

PROCEDURE SetFor (elem: TypeIndex): TypeIndex;
  VAR e: TypeIndex;
  BEGIN
    e := Resolve(elem);
    IF e = InvalidType THEN e := dInt END;
    RETURN NewSet(e)
  END SetFor;

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

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

PROCEDURE Init;
  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 *)
    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);
    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.