M2compiler-V3/compiler/src/SymTab.mod

IMPLEMENTATION MODULE SymTab;

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

CONST
  MaxTypes  = 256;
  MaxPend   = 64;
  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;

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 *)
  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 *)
  END;
  FieldNode = RECORD
    name  : Name;
    typ   : TypeIndex;
    owner : TypeIndex;
    next  : FieldPtr;   (* next field of the same owner *)
  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;
  nTypes : CARDINAL;
  curProc : SymPtr;   (* heading being declared *)
  curPTail : SymPtr;  (* positional param chain tail *)
  dInt, dCard, dReal, dChar, dBool : TypeIndex;

(* ---------------- 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;
    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 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 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;
    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 NewArray (elem: TypeIndex): TypeIndex;
  BEGIN
    RETURN NewDesc(FArray, elem)
  END NewArray;

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 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
    | FRecord : RETURN ClRecord
    | FSet : RETURN ClSet
    | FPtr : RETURN ClPtr
    | FStr : RETURN ClStr
    | 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) THEN
      RETURN InvalidType
    END;
    RETURN tref[r]
  END ArrayElem;

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 PushRecord (t: TypeIndex): BOOLEAN;
(* Pushes a scope with t's fields; caller must PopScope afterwards. *)
  VAR r: TypeIndex;
    f: FieldPtr;
  BEGIN
    r := Resolve(t);
    IF (r < 0) OR (tform[r] # FRecord) THEN RETURN FALSE END;
    PushScope;
    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;

(* ---------------- 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;
    curProc := node;
    curPTail := NIL;
    PushScope;
    RETURN TRUE
  END EnterProc;

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

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

PROCEDURE SetBasesOk (a, b: TypeIndex): BOOLEAN;
(* base compatibility for two SET types *)
  BEGIN
    IF SameType(a, b) THEN RETURN TRUE END;
    IF IsIntFamily(a) & IsIntFamily(b) THEN RETURN TRUE END;
    IF (ClassOf(a) = ClChar) & (ClassOf(b) = ClChar) THEN
      RETURN TRUE
    END;
    RETURN FALSE
  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) = ClInt) & (ClassOf(dst) = ClInt) THEN
      RETURN TRUE
    END;
    IF (ClassOf(src) = ClInt) & (ClassOf(dst) = ClReal) THEN
      RETURN TRUE
    END;
    IF (ClassOf(src) = ClStr) & (ClassOf(dst) = ClArray) 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 SameType(l, r) 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) = ClBool) & (ClassOf(r) = ClBool) THEN
      RETURN TRUE
    END;
    IF (ClassOf(l) = ClStr) & (ClassOf(r) = ClStr) 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;
    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;
    curProc := NIL; curPTail := NIL;
    curScope := NewScope(NIL, 0);
    dInt := NewDesc(FInt, InvalidType);
    dCard := NewDesc(FInt, InvalidType);
    dReal := NewDesc(FReal, InvalidType);
    dChar := NewDesc(FChar, InvalidType);
    dBool := NewDesc(FBool, InvalidType);
    Predef("INTEGER", KindPredef, dInt);
    Predef("CARDINAL", KindPredef, dCard);
    Predef("SHORTINT", KindPredef, dInt);
    Predef("LONGINT", KindPredef, dInt);
    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, InvalidType)
  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.