M2compiler-V3/compiler/src/SymTab.mod

IMPLEMENTATION MODULE SymTab;

IMPORT FileIO;
FROM Storage IMPORT ALLOCATE;
FROM SYSTEM IMPORT TSIZE;

CONST
  MaxTypes  = 256;
  MaxPend   = 64;
  MaxMods   = 32;
  ResDepth  = 64;

  (* 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;

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 *)
    uid   : CARDINAL;   (* KindProc: unique id for name mangling *)
  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;
  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 *)
  procStk : ARRAY [0 .. 15] OF SymPtr;
  nProc : CARDINAL;
  nextUid : CARDINAL;
  dInt, dCard, dReal, dChar, dBool, dNil : TypeIndex;
  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;

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

PROCEDURE Assign (VAR dest: ARRAY OF CHAR; src: ARRAY OF CHAR);
  VAR i : CARDINAL;
  BEGIN
    i := 0;
    WHILE (i < HIGH(dest)) & (src[i] # 0C) DO
      dest[i] := src[i]; INC(i)
    END;
    dest[i] := 0C
  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] = 0C 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] = 0C 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)) & (s[i] # 0C) 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] = 0C) THEN RETURN FALSE END;
    WHILE (i < HIGH(q)) & (q[i] # 0C) 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
    ALLOCATE(s, TSIZE(ScopeNode));
    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 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
    ALLOCATE(node, TSIZE(SymNode));
    Assign(node^.name, name);
    node^.kind := kind;
    node^.typ := InvalidType;
    node^.scope := curScope;
    node^.left := NIL;
    node^.right := NIL;
    IF ~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) & (nPend < MaxPend) THEN
      pend[nPend] := node; INC(nPend)
    END;
    RETURN node # NIL
  END EnterPending;

PROCEDURE FixPending (t: TypeIndex);
  VAR i: CARDINAL;
  BEGIN
    i := 0;
    WHILE i < nPend DO
      pend[i]^.typ := t; INC(i)
    END;
    nPend := 0
  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] := 0C
    END
  END PendName;

PROCEDURE FindField (rec: TypeIndex; name: ARRAY OF CHAR): FieldPtr;
  VAR f: FieldPtr;
  BEGIN
    IF (rec < 0) OR (rec >= VAL(INTEGER, nTypes)) THEN RETURN NIL END;
    IF (tform[rec] # FRecord) & (tform[rec] # FClass) THEN RETURN NIL END;
    f := fields;
    WHILE f # NIL DO
      IF (f^.owner = rec) & Equal(f^.name, name) THEN RETURN f END;
      f := f^.next
    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;
    ALLOCATE(f, TSIZE(FieldNode));
    Assign(f^.name, name);
    f^.typ := InvalidType;
    f^.owner := rec;
    f^.next := fields;
    fields := f;
    IF (rec >= 0) & (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 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;
    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 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 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) & (t < VAL(INTEGER, nTypes)) & (tform[t] = FClass) THEN
      tparent[t] := p
    END
  END SetParent;

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) & (t < VAL(INTEGER, nTypes)) & (tform[t] = FAlias) THEN
      tref[t] := base
    END
  END SetTarget;

PROCEDURE Resolve (t: TypeIndex): TypeIndex;
  VAR n: CARDINAL;
  BEGIN
    n := 0;
    WHILE (n < ResDepth) & (t >= 0) & (t < VAL(INTEGER, nTypes))
          & (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 IntType (): TypeIndex;
  BEGIN RETURN dInt END IntType;
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
    | 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
    | 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 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)
       & (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) & ((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) & (tref[r] = InvalidType)
       & SubBounds(b, blo, bhi) & (bhi >= blo)
       & (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 ~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 ~SetSpan(t, lo, n) THEN RETURN 0 END;
    RETURN lo
  END SetBaseLo;

PROCEDURE SetCount (t: TypeIndex): CARDINAL;
  VAR lo, n: INTEGER;
  BEGIN
    IF ~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 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;
    n: 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 : RETURN 4
    | FReal : RETURN 8
    | FEnum, FSub : RETURN 4
    | FSet : RETURN SetWords(t) * 4
    | FPtr, FOpenArr, FArray : RETURN 8
    | FRecord, FClass :
        n := 0;
        f := fields;
        WHILE f # NIL DO
          IF f^.owner = r THEN
            n := n + TypeSizeD(f^.typ, depth + 1)
          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 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). *)
  VAR f: FieldPtr;
    total: INTEGER;
    cnt, ord: CARDINAL;
    off: INTEGER;
  BEGIN
    total := 0; cnt := 0;
    f := fields;
    WHILE f # NIL DO
      IF f^.owner = r THEN
        total := total + VAL(INTEGER, TypeSize(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, TypeSize(f^.typ));
        DEC(ord);
        f^.off := off;
        f^.ord := ord
      END;
      f := f^.next
    END;
    tdone[r] := TRUE
  END ComputeOffsets;

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)
       & (tform[r] # FClass)) THEN
      RETURN -1
    END;
    IF ~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) OR (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)
       & (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] := 0C;
    r := Resolve(rec);
    IF (r = InvalidType) OR ((tform[r] # FRecord)
       & (tform[r] # FClass)) THEN
      RETURN
    END;
    IF ~tdone[r] THEN ComputeOffsets(r) END;
    f := fields;
    WHILE f # NIL DO
      IF (f^.owner = r) & (f^.ord = i) THEN
        Assign(name, f^.name); RETURN
      END;
      f := f^.next
    END
  END FieldName;

PROCEDURE PushRecord (t: TypeIndex): BOOLEAN;
(* Pushes a scope with t's fields; caller must PopScope afterwards.
   Classes share the field machinery (methods stay in the class
   scope itself). *)
  VAR r: TypeIndex;
    f: FieldPtr;
  BEGIN
    r := Resolve(t);
    IF (r < 0) OR ((tform[r] # FRecord) & (tform[r] # FClass)) THEN
      RETURN FALSE
    END;
    PushScope;
    curScope^.ofRec := r;
    f := fields;
    WHILE f # NIL DO
      IF f^.owner = r THEN
        IF Enter(f^.name, KindField) THEN
          SetSymType(f^.name, f^.typ)
        END
      END;
      f := f^.next
    END;
    RETURN TRUE
  END PushRecord;

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

PROCEDURE MethodExists (t: TypeIndex; name: ARRAY OF CHAR): BOOLEAN;
  VAR r: TypeIndex;
    s: ScopePtr;
    node: SymPtr;
  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;
    node := TreeFind(s^.root, name);
    RETURN (node # NIL) & (node^.kind = KindProc)
  END MethodExists;

PROCEDURE PushClassMembers (t: TypeIndex): BOOLEAN;
(* Pushes a scope with t's fields (KindField) for method bodies in
   CLASS IMPLEMENTATION. Method NAMES are deliberately not copied:
   bodies re-enter them fresh via EnterProc (copying would collide
   as duplicates); sibling-method visibility waits for step 4 calls,
   when unknown names there honestly report 201. *)
  VAR r: TypeIndex;
    s: ScopePtr;
    f: FieldPtr;
  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;
    f := fields;
    WHILE f # NIL DO
      IF f^.owner = r THEN
        IF Enter(f^.name, KindField) THEN
          SetSymType(f^.name, f^.typ)
        END
      END;
      f := f^.next
    END;
    RETURN TRUE
  END PushClassMembers;

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

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

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

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^.uid := nextUid; INC(nextUid);
    node^.fdep := nProc;
    curProc := node;
    curPTail := NIL;
    PushProc(node);
    PushScope;
    RETURN TRUE
  END EnterProc;

PROCEDURE ResumeProc (name: ARRAY OF CHAR): BOOLEAN;
  VAR node: SymPtr;
  BEGIN
    IF curUnit # UnitImpl THEN RETURN FALSE END;
    node := TreeFind(curScope^.root, name);
    IF (node = NIL) OR (node^.kind # KindProc) THEN RETURN FALSE END;
    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) OR (node^.kind # KindProc) OR ~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 SetProcRes (t: TypeIndex);
  BEGIN
    IF curProc # NIL THEN curProc^.rslt := t END
  END SetProcRes;

PROCEDURE ProcRes (name: ARRAY OF CHAR): TypeIndex;
  VAR node: SymPtr;
  BEGIN
    node := Find(name);
    IF (node = NIL) OR (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 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) OR (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) OR (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) & (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) OR (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) OR (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) OR (node^.kind # KindProc) THEN RETURN FALSE END;
    p := NthParam(node, i);
    IF p = NIL THEN RETURN FALSE END;
    RETURN p^.isVar
  END ParamIsVar;

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;
    IF IsOpenArray(formal)
       & (ClassOf(actual) = ClArray) & (ArrayDepth(actual) = 1) THEN
      fa := ArrayElem(actual); fe := ArrayElem(formal);
      IF SameType(fa, fe) THEN RETURN TRUE END
    END;
    IF IsOpenArray(formal) & (ClassOf(actual) = ClStr) THEN
      fe := ArrayElem(formal);
      IF ClassOf(fe) = ClChar THEN RETURN TRUE END
    END;
    RETURN FALSE
  END VarParamOk;

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

PROCEDURE EnterIn (s: ScopePtr; name: ARRAY OF CHAR;
                    kind: INTEGER): BOOLEAN;
  VAR node: SymPtr;
  BEGIN
    ALLOCATE(node, TSIZE(SymNode));
    Assign(node^.name, name);
    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^.fdep := 0;
    node^.uid := 0;
    IF ~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 ~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] := 0C
    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) & (modKind[i] # UnitProg)
  END ModDefined;

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

PROCEDURE OpaqueBase (name: ARRAY OF CHAR): TypeIndex;
  VAR node: SymPtr;
    r : TypeIndex;
  BEGIN
    node := Find(name);
    IF (node = NIL) OR (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) & (tref[r] = InvalidType) THEN RETURN r END;
    RETURN InvalidType
  END OpaqueBase;

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) OR (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) & (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) OR (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) OR (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) OR (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) OR (n^.kind # KindProc) THEN
      RETURN InvalidType
    END;
    RETURN n^.rslt
  END QualProcRes;

PROCEDURE Materialize (mod, name: ARRAY OF CHAR): BOOLEAN;
(* Clones mod's export into the current scope (qualified-access
   flattening and FROM-import share this). *)
  VAR src, node : SymPtr;
  BEGIN
    src := QualNode(mod, name);
    IF src = NIL THEN RETURN FALSE END;
    (* already visible (repeat L.x): nothing to do *)
    IF TreeFind(curScope^.root, name) # NIL THEN RETURN TRUE END;
    ALLOCATE(node, TSIZE(SymNode));
    node^ := src^;
    node^.left := NIL;
    node^.right := NIL;
    node^.scope := curScope;
    IF ~TreeInsert(curScope, node) THEN RETURN FALSE END;
    RETURN TRUE
  END Materialize;

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) & (tref[r] = InvalidType)
       & SubBounds(b, lo, hi) & (hi >= lo) & (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) & BaseSpanOk(b)
  END SetBasesOk;

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) & (tform[rd] = FSet) THEN
      RETURN SetBasesOk(tref[rs], tref[rd])
    END;
    IF (ClassOf(src) = ClArray) & (ClassOf(dst) = ClArray) THEN
      RETURN SameType(src, dst)
    END;
    IF (ClassOf(src) = ClStr) & (ClassOf(dst) = ClArray) THEN
      RETURN (ArrayDepth(dst) = 1)
             & (ClassOf(ArrayElem(dst)) = ClChar)
    END;
    IF ClassOf(src) = ClNil THEN
      RETURN ClassOf(dst) = ClPtr
    END;
    IF (ClassOf(src) = ClInt) & (ClassOf(dst) = ClInt) THEN
      RETURN TRUE
    END;
    IF (ClassOf(src) = ClInt) & (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 IsIntFamily(l) & IsIntFamily(r) THEN
      res := dInt; RETURN TRUE
    END;
    IF ~divmod & (ClassOf(l) = ClReal) & (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 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 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
        RETURN FALSE
      END;
      RETURN TRUE
    END;
    IF IsIntFamily(l) & IsIntFamily(r) THEN RETURN TRUE END;
    IF (ClassOf(l) = ClReal) & (ClassOf(r) = ClReal) THEN
      RETURN TRUE
    END;
    IF (ClassOf(l) = ClChar) & (ClassOf(r) = ClChar) THEN
      RETURN TRUE
    END;
    IF (ClassOf(l) = ClBool) & (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) & (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) & IsIntFamily(r) THEN RETURN TRUE END;
    IF (ClassOf(l) = ClReal) & (ClassOf(r) = ClReal) THEN
      RETURN TRUE
    END;
    IF (ClassOf(l) = ClChar) & (ClassOf(r) = ClChar) THEN
      RETURN TRUE
    END;
    IF (ClassOf(l) = ClEnum) & 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) & IsIntFamily(b) THEN RETURN TRUE END;
    IF (ClassOf(l) = ClChar) & (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)) & (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) & 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;
    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);
    Predef("INTEGER", KindPredef, dInt);
    Predef("CARDINAL", KindPredef, dCard);
    Predef("SHORTINT", KindPredef, dInt);
    Predef("LONGINT", KindPredef, dInt);
    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("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.