M2compiler-V1/SymTab.mod

IMPLEMENTATION MODULE SymTab;

IMPORT FileIO;

CONST
  MaxTypes  = 256;
  MaxFields = 512;
  MaxPend   = 64;
  MaxMarks  = 16;
  ResDepth  = 64;
  MaxProcs  = 64;
  MaxParams = 256;
  MaxPDepth = 16;
  NoSlot    = -1000;

  (* 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
  Symbol = RECORD
    name : Name;
    kind : INTEGER;
    typ  : TypeIndex;
    lev  : CARDINAL;
    slot : INTEGER;    (* frame slot (params >= 3, locals negative) *)
    pdep : CARDINAL;   (* proc depth at declaration *)
    pnum : INTEGER;    (* proc number (0 = not a procedure) *)
  END;
  Field = RECORD
    name  : Name;
    typ   : TypeIndex;
    owner : TypeIndex;
    next  : INTEGER;  (* index of next field of same owner, -1 = end *)
    off   : INTEGER;  (* slot offset within record, -1 = not yet fixed *)
  END;
  ProcRec = RECORD
    ret     : TypeIndex;  (* InvalidType = proper procedure *)
    fret    : TypeIndex;  (* forward heading return type *)
    fwd     : BOOLEAN;    (* body still pending *)
    everFwd : BOOLEAN;    (* had a forward heading *)
    fHead   : INTEGER;    (* forward param list *)
    fTail   : INTEGER;
    dHead   : INTEGER;    (* define param list *)
    dTail   : INTEGER;
  END;
  ParamRec = RECORD
    typ   : TypeIndex;
    isVar : BOOLEAN;
    next  : INTEGER;
  END;

VAR
  syms : ARRAY [0 .. MaxSyms - 1] OF Symbol;
  nSyms : CARDINAL;
  curLev : CARDINAL;
  marks : ARRAY [0 .. MaxMarks - 1] OF CARDINAL;
  mtop : CARDINAL;
  pend : ARRAY [0 .. MaxPend - 1] OF CARDINAL;
  nPend : CARDINAL;
  pendF : ARRAY [0 .. MaxPend - 1] OF CARDINAL;
  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;
  tNext : ARRAY [0 .. MaxTypes - 1] OF CARDINAL;
  tOpen : ARRAY [0 .. MaxTypes - 1] OF BOOLEAN;
  nTypes : CARDINAL;
  fields : ARRAY [0 .. MaxFields - 1] OF Field;
  nFields : CARDINAL;
  dInt, dCard, dReal, dChar, dBool : TypeIndex;
  procs : ARRAY [1 .. MaxProcs] OF ProcRec;
  nProcs : CARDINAL;
  params : ARRAY [0 .. MaxParams - 1] OF ParamRec;
  nParams : CARDINAL;
  pdep : CARDINAL;
  curProc : INTEGER;
  procSt : ARRAY [0 .. MaxPDepth] OF INTEGER;
  locCnt : ARRAY [0 .. MaxPDepth] OF CARDINAL;
  parCnt : ARRAY [0 .. MaxPDepth] OF CARDINAL;
  retSt : ARRAY [0 .. MaxPDepth] OF 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 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;

(* ---------------- symbols and scopes ---------------- *)

PROCEDURE Find (name: ARRAY OF CHAR): INTEGER;
(* innermost visible index or -1 *)
  VAR i : CARDINAL;
  BEGIN
    i := nSyms;
    WHILE i > 0 DO
      DEC(i);
      IF Equal(syms[i].name, name) THEN RETURN VAL(INTEGER, i) END
    END;
    RETURN -1
  END Find;

PROCEDURE RawEnter (name: ARRAY OF CHAR; kind: INTEGER): INTEGER;
(* index or -1 when full *)
  BEGIN
    IF nSyms >= MaxSyms THEN RETURN -1 END;
    Assign(syms[nSyms].name, name);
    syms[nSyms].kind := kind;
    syms[nSyms].typ := InvalidType;
    syms[nSyms].lev := curLev;
    syms[nSyms].slot := NoSlot;
    syms[nSyms].pdep := pdep;
    syms[nSyms].pnum := 0;
    IF (kind = KindVar) & (pdep > 0) THEN
      syms[nSyms].slot := -(1 + VAL(INTEGER, locCnt[pdep]));
      INC(locCnt[pdep])
    END;
    INC(nSyms);
    RETURN VAL(INTEGER, nSyms - 1)
  END RawEnter;

PROCEDURE DupInLevel (name: ARRAY OF CHAR): BOOLEAN;
  VAR i : CARDINAL;
  BEGIN
    i := nSyms;
    WHILE (i > 0) & (syms[i - 1].lev = curLev) DO
      DEC(i);
      IF Equal(syms[i].name, name) THEN RETURN TRUE END
    END;
    RETURN FALSE
  END DupInLevel;

PROCEDURE Enter (name: ARRAY OF CHAR; kind: INTEGER): BOOLEAN;
  BEGIN
    IF DupInLevel(name) THEN RETURN FALSE END;
    RETURN RawEnter(name, kind) # -1
  END Enter;

PROCEDURE EnterPending (name: ARRAY OF CHAR; kind: INTEGER): BOOLEAN;
  VAR idx : INTEGER;
  BEGIN
    IF DupInLevel(name) THEN RETURN FALSE END;
    idx := RawEnter(name, kind);
    IF (idx # -1) & (nPend < MaxPend) THEN
      pend[nPend] := VAL(CARDINAL, idx); INC(nPend)
    END;
    RETURN idx # -1
  END EnterPending;

PROCEDURE SlotsDepth (t: TypeIndex; d: CARDINAL): CARDINAL;
(* Size in slots (words); 0 = unsized/needs error, 1 = scalar/placeholder.
   Records use precomputed tNext; arrays use len*elem. Incomplete
   aliases return 1 to suppress cascades. *)
  VAR r : TypeIndex;
    n : CARDINAL;
    e, len : CARDINAL;
    lo, hi, span : INTEGER;
  BEGIN
    IF d > ResDepth THEN RETURN 0 END;
    IF t = InvalidType THEN RETURN 1 END;
    IF (t < 0) OR (t >= VAL(INTEGER, nTypes)) THEN RETURN 1 END;
    r := t; n := 0;
    WHILE (n < ResDepth) & (r >= 0) & (r < VAL(INTEGER, nTypes))
          & (tform[r] = FAlias) DO
      r := tref[r]; INC(n);
      IF r = InvalidType THEN RETURN 1 END
    END;
    IF (r < 0) OR (r >= VAL(INTEGER, nTypes)) THEN RETURN 1 END;
    CASE tform[r] OF
      FInt, FReal, FChar, FBool, FEnum, FSub, FSet, FPtr, FStr :
        RETURN 1
    | FArray :
        lo := tLo[r]; hi := tHi[r];
        IF hi < lo THEN RETURN 0 END;
        span := hi - lo + 1;
        IF span <= 0 THEN RETURN 0 END;
        len := VAL(CARDINAL, span);
        e := SlotsDepth(tref[r], d + 1);
        IF e = 0 THEN RETURN 0 END;
        IF (len > 1024) OR (e > 1024) THEN RETURN 0 END;
        IF len * e > 1024 THEN RETURN 0 END;
        IF len * e = 0 THEN RETURN 0 END;
        RETURN len * e
    | FRecord :
        RETURN tNext[r]
    ELSE RETURN 1
    END
  END SlotsDepth;

PROCEDURE FixPending (t: TypeIndex);
  VAR i, k : CARDINAL;
    s : CARDINAL;
    L0 : CARDINAL;
    isLoc : BOOLEAN;
  BEGIN
    s := SlotsDepth(t, 0);
    IF s = 0 THEN s := 1 END;
    isLoc := FALSE;
    IF nPend > 0 THEN
      k := 0;
      WHILE k < nPend DO
        IF syms[pend[k]].pdep > 0 THEN isLoc := TRUE END;
        INC(k)
      END
    END;
    IF isLoc THEN
      L0 := 0;
      IF locCnt[pdep] >= nPend THEN
        L0 := locCnt[pdep] - nPend
      END;
      i := 0;
      WHILE i < nPend DO
        syms[pend[i]].typ := t;
        syms[pend[i]].slot := -(VAL(INTEGER, L0) + VAL(INTEGER, s)
                                 * (VAL(INTEGER, i) + 1));
        INC(i)
      END;
      locCnt[pdep] := L0 + nPend * s
    ELSE
      i := 0;
      WHILE i < nPend DO
        syms[pend[i]].typ := t; INC(i)
      END
    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, syms[pend[i]].name)
    ELSE n[0] := 0C
    END
  END PendName;

PROCEDURE FindField (rec: TypeIndex; name: ARRAY OF CHAR): INTEGER;
  VAR i : INTEGER;
  BEGIN
    IF (rec < 0) OR (rec >= VAL(INTEGER, nTypes)) THEN RETURN -1 END;
    IF tform[rec] # FRecord THEN RETURN -1 END;
    i := tref[rec];
    WHILE i # -1 DO
      IF Equal(fields[i].name, name) THEN RETURN i END;
      i := fields[i].next
    END;
    RETURN -1
  END FindField;

PROCEDURE FieldPending (rec: TypeIndex; name: ARRAY OF CHAR): BOOLEAN;
  BEGIN
    IF FindField(rec, name) # -1 THEN RETURN FALSE END;
    IF nFields >= MaxFields THEN RETURN FALSE END;
    Assign(fields[nFields].name, name);
    fields[nFields].typ := InvalidType;
    fields[nFields].owner := rec;
    fields[nFields].next := tref[rec];
    fields[nFields].off := -1;
    tref[rec] := VAL(INTEGER, nFields);
    IF nPendF < MaxPend THEN
      pendF[nPendF] := nFields; INC(nPendF)
    END;
    INC(nFields);
    RETURN TRUE
  END FieldPending;

PROCEDURE FixPendingF (rec: TypeIndex; t: TypeIndex);
  VAR i, j : CARDINAL;
    s : CARDINAL;
    rr : TypeIndex;
  BEGIN
    s := SlotsDepth(t, 0);
    IF s = 0 THEN s := 1 END;
    rr := rec;
    IF (rr >= 0) & (rr < VAL(INTEGER, nTypes)) & (tform[rr] = FAlias) THEN
      rr := tref[rr]
    END;
    i := 0;
    WHILE i < nPendF DO
      IF fields[pendF[i]].owner = rec THEN
        fields[pendF[i]].typ := t;
        IF (rr >= 0) & (rr < VAL(INTEGER, nTypes))
           & (tform[rr] = FRecord) THEN
          fields[pendF[i]].off := VAL(INTEGER, tNext[rr]);
          tNext[rr] := tNext[rr] + s
        ELSE
          fields[pendF[i]].off := 0
        END;
        (* 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) # -1
  END Lookup;

PROCEDURE SymType (name: ARRAY OF CHAR): TypeIndex;
  VAR idx : INTEGER;
  BEGIN
    idx := Find(name);
    IF idx = -1 THEN RETURN InvalidType END;
    RETURN syms[idx].typ
  END SymType;

PROCEDURE SetSymType (name: ARRAY OF CHAR; t: TypeIndex);
  VAR idx : INTEGER;
  BEGIN
    idx := Find(name);
    IF idx # -1 THEN syms[idx].typ := t END
  END SetSymType;

PROCEDURE SymKind (name: ARRAY OF CHAR): INTEGER;
  VAR idx : INTEGER;
  BEGIN
    idx := Find(name);
    IF idx = -1 THEN RETURN -1 END;
    RETURN syms[idx].kind
  END SymKind;

PROCEDURE PushScope;
  BEGIN
    IF mtop < MaxMarks THEN marks[mtop] := nSyms; INC(mtop) END;
    INC(curLev)
  END PushScope;

PROCEDURE PopScope;
  BEGIN
    IF mtop > 0 THEN DEC(mtop); nSyms := marks[mtop] END;
    IF curLev > 0 THEN DEC(curLev) END
  END PopScope;

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

PROCEDURE NewDesc (form: INTEGER; ref: TypeIndex): TypeIndex;
  BEGIN
    IF nTypes >= MaxTypes THEN RETURN InvalidType END;
    tform[nTypes] := form;
    tref[nTypes] := ref;
    tLo[nTypes] := 0;
    tHi[nTypes] := -1;
    tNext[nTypes] := 0;
    tOpen[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 NewSubB (base: TypeIndex; lo, hi: INTEGER): TypeIndex;
  VAR t : TypeIndex;
  BEGIN
    t := NewDesc(FSub, base);
    IF t # InvalidType THEN
      tLo[t] := lo; tHi[t] := hi
    END;
    RETURN t
  END NewSubB;

PROCEDURE NewEnum (): TypeIndex;
  VAR t : TypeIndex;
  BEGIN
    t := NewDesc(FEnum, InvalidType);
    IF t # InvalidType THEN
      tLo[t] := 0; tHi[t] := -1
    END;
    RETURN t
  END NewEnum;

PROCEDURE EnumAdd (t: TypeIndex);
  VAR r : TypeIndex;
  BEGIN
    r := t;
    IF (r >= 0) & (r < VAL(INTEGER, nTypes)) & (tform[r] = FAlias) THEN
      r := tref[r]
    END;
    IF (r < 0) OR (r >= VAL(INTEGER, nTypes)) THEN RETURN END;
    IF tform[r] # FEnum THEN RETURN END;
    tHi[r] := tHi[r] + 1
  END EnumAdd;

PROCEDURE NewArray (elem: TypeIndex): TypeIndex;
  BEGIN
    RETURN NewDesc(FArray, elem)
  END NewArray;

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

PROCEDURE NewOpen (elem: TypeIndex): TypeIndex;
  VAR t : TypeIndex;
  BEGIN
    t := NewDesc(FArray, elem);
    IF t # InvalidType THEN
      tLo[t] := 0; tHi[t] := -1; tOpen[t] := TRUE
    END;
    RETURN t
  END NewOpen;

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

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 : RETURN ClassOf(tref[r])
    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) # -1
  END FieldExists;

PROCEDURE FieldType (rec: TypeIndex; name: ARRAY OF CHAR): TypeIndex;
  VAR i : INTEGER;
  BEGIN
    i := FindField(Resolve(rec), name);
    IF i = -1 THEN RETURN InvalidType END;
    RETURN fields[i].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 TypeSlots (t: TypeIndex): CARDINAL;
  BEGIN
    RETURN SlotsDepth(t, 0)
  END TypeSlots;

PROCEDURE OrdBounds (t: TypeIndex; VAR lo, hi: INTEGER): BOOLEAN;
(* Bounds for ordinal types; FALSE if unsized/invalid (no cascade if Invalid). *)
  VAR r : TypeIndex;
  BEGIN
    IF t = InvalidType THEN lo := 0; hi := 0; RETURN TRUE END;
    r := Resolve(t);
    IF r = InvalidType THEN lo := 0; hi := 0; RETURN TRUE END;
    CASE tform[r] OF
      FInt : lo := 0; hi := -1; RETURN FALSE
    | FChar : lo := 0; hi := 255; RETURN TRUE
    | FBool : lo := 0; hi := 1; RETURN TRUE
    | FEnum :
        IF tHi[r] < tLo[r] THEN lo := 0; hi := -1; RETURN FALSE END;
        lo := tLo[r]; hi := tHi[r]; RETURN TRUE
    | FSub :
        IF tHi[r] < tLo[r] THEN
          IF tref[r] = InvalidType THEN lo := 0; hi := 0; RETURN TRUE END;
          lo := 0; hi := -1; RETURN FALSE
        END;
        lo := tLo[r]; hi := tHi[r]; RETURN TRUE
    ELSE lo := 0; hi := -1; RETURN FALSE
    END
  END OrdBounds;

PROCEDURE TypeLo (t: TypeIndex): INTEGER;
  VAR lo, hi: INTEGER;
  BEGIN
    IF OrdBounds(t, lo, hi) THEN RETURN lo END;
    RETURN 0
  END TypeLo;

PROCEDURE TypeHi (t: TypeIndex): INTEGER;
  VAR lo, hi: INTEGER;
  BEGIN
    IF OrdBounds(t, lo, hi) THEN RETURN hi END;
    RETURN -1
  END TypeHi;

PROCEDURE TypeLen (t: TypeIndex): CARDINAL;
  VAR lo, hi: INTEGER;
    span: INTEGER;
  BEGIN
    IF t = InvalidType THEN RETURN 1 END;
    IF OrdBounds(t, lo, hi) THEN
      IF hi < lo THEN RETURN 0 END;
      span := hi - lo + 1;
      IF span <= 0 THEN RETURN 0 END;
      RETURN VAL(CARDINAL, span)
    END;
    RETURN 0
  END TypeLen;

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

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

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

PROCEDURE FieldOffset (rec: TypeIndex; name: ARRAY OF CHAR): INTEGER;
  VAR i: INTEGER;
  BEGIN
    i := FindField(Resolve(rec), name);
    IF i = -1 THEN RETURN -1 END;
    RETURN fields[i].off
  END FieldOffset;

PROCEDURE PushRecord (t: TypeIndex): BOOLEAN;
(* Pushes a scope with t's fields; caller must PopScope afterwards. *)
  VAR r, i : INTEGER;
  BEGIN
    r := Resolve(t);
    IF (r < 0) OR (tform[r] # FRecord) THEN RETURN FALSE END;
    PushScope;
    i := tref[r];
    WHILE i # -1 DO
      IF Enter(fields[i].name, KindField) THEN
        SetSymType(fields[i].name, fields[i].typ)
      END;
      i := fields[i].next
    END;
    RETURN TRUE
  END PushRecord;

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

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 (tform[rs] = FPtr) & (tform[rd] = FPtr) THEN
      RETURN SameType(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;

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

PROCEDURE NewParamRec (typ: TypeIndex; isVar: BOOLEAN): INTEGER;
  BEGIN
    IF nParams >= MaxParams THEN RETURN -1 END;
    params[nParams].typ := typ;
    params[nParams].isVar := isVar;
    params[nParams].next := -1;
    INC(nParams);
    RETURN VAL(INTEGER, nParams - 1)
  END NewParamRec;

PROCEDURE AppParam (p: INTEGER; fwd: BOOLEAN);
(* Appends param record p to the current proc's forward/define list. *)
  VAR tail : INTEGER;
  BEGIN
    IF (curProc < 1) OR (curProc > VAL(INTEGER, nProcs)) THEN RETURN END;
    IF fwd THEN
      IF procs[curProc].fHead = -1 THEN procs[curProc].fHead := p
      ELSE
        tail := procs[curProc].fHead;
        WHILE params[tail].next # -1 DO tail := params[tail].next END;
        params[tail].next := p
      END;
      procs[curProc].fTail := p
    ELSE
      IF procs[curProc].dHead = -1 THEN procs[curProc].dHead := p
      ELSE
        tail := procs[curProc].dHead;
        WHILE params[tail].next # -1 DO tail := params[tail].next END;
        params[tail].next := p
      END;
      procs[curProc].dTail := p
    END
  END AppParam;

PROCEDURE EnterProc (name: ARRAY OF CHAR): BOOLEAN;
  VAR idx : INTEGER;
  BEGIN
    IF DupInLevel(name) THEN RETURN FALSE END;
    IF nProcs >= MaxProcs THEN RETURN FALSE END;
    idx := RawEnter(name, KindProc);
    IF idx = -1 THEN RETURN FALSE END;
    INC(nProcs);
    syms[idx].pnum := VAL(INTEGER, nProcs);
    procs[nProcs].ret := InvalidType;
    procs[nProcs].fret := InvalidType;
    procs[nProcs].fwd := FALSE;
    procs[nProcs].everFwd := FALSE;
    procs[nProcs].fHead := -1;
    procs[nProcs].fTail := -1;
    procs[nProcs].dHead := -1;
    procs[nProcs].dTail := -1;
    curProc := VAL(INTEGER, nProcs);
    RETURN TRUE
  END EnterProc;

PROCEDURE IsForward (name: ARRAY OF CHAR): BOOLEAN;
  VAR idx : INTEGER;
  BEGIN
    idx := Find(name);
    IF idx = -1 THEN RETURN FALSE END;
    IF syms[idx].kind # KindProc THEN RETURN FALSE END;
    IF syms[idx].pnum < 1 THEN RETURN FALSE END;
    RETURN procs[syms[idx].pnum].fwd
  END IsForward;

PROCEDURE ReuseProc (name: ARRAY OF CHAR);
  VAR idx : INTEGER;
  BEGIN
    idx := Find(name);
    IF idx = -1 THEN RETURN END;
    curProc := syms[idx].pnum;
    IF (curProc >= 1) & (curProc <= VAL(INTEGER, nProcs)) THEN
      procs[curProc].fwd := FALSE;
      procs[curProc].dHead := -1;
      procs[curProc].dTail := -1
    END
  END ReuseProc;

PROCEDURE OpenProcScope;
  BEGIN
    IF pdep < MaxPDepth THEN INC(pdep) END;
    PushScope;
    locCnt[pdep] := 0;
    parCnt[pdep] := 0;
    procSt[pdep] := curProc;
    retSt[pdep] := InvalidType
  END OpenProcScope;

PROCEDURE CloseProc;
  BEGIN
    PopScope;
    IF pdep > 0 THEN DEC(pdep) END;
    curProc := procSt[pdep]
  END CloseProc;

PROCEDURE EnterParam (name: ARRAY OF CHAR; isVar: BOOLEAN;
                      t: TypeIndex): BOOLEAN;
  VAR idx, pi : INTEGER;
  BEGIN
    IF DupInLevel(name) THEN RETURN FALSE END;
    IF isVar THEN idx := RawEnter(name, KindVarPar)
    ELSE idx := RawEnter(name, KindParam)
    END;
    IF idx = -1 THEN RETURN FALSE END;
    SetSymType(name, t);
    syms[idx].slot := 3 + VAL(INTEGER, parCnt[pdep]);
    IF IsOpen(t) THEN
      INC(parCnt[pdep], 2)
    ELSE
      INC(parCnt[pdep])
    END;
    pi := NewParamRec(t, isVar);
    IF pi # -1 THEN AppParam(pi, FALSE) END;
    RETURN TRUE
  END EnterParam;

PROCEDURE SetProcRet (t: TypeIndex): BOOLEAN;
  BEGIN
    IF (curProc < 1) OR (curProc > VAL(INTEGER, nProcs)) THEN
      RETURN TRUE
    END;
    IF procs[curProc].everFwd
       & ~SameType(t, procs[curProc].fret) THEN
      RETURN FALSE
    END;
    procs[curProc].ret := t;
    IF pdep > 0 THEN retSt[pdep] := t END;
    RETURN TRUE
  END SetProcRet;

PROCEDURE VerifyProc (): BOOLEAN;
  VAR fi, di : INTEGER;
  BEGIN
    IF (curProc < 1) OR (curProc > VAL(INTEGER, nProcs)) THEN
      RETURN TRUE
    END;
    IF ~procs[curProc].everFwd THEN RETURN TRUE END;
    fi := procs[curProc].fHead; di := procs[curProc].dHead;
    WHILE (fi # -1) & (di # -1) DO
      IF (params[fi].isVar # params[di].isVar)
         OR ~SameType(params[fi].typ, params[di].typ) THEN
        RETURN FALSE
      END;
      fi := params[fi].next; di := params[di].next
    END;
    RETURN (fi = -1) & (di = -1)
  END VerifyProc;

PROCEDURE SetForward;
  BEGIN
    IF (curProc < 1) OR (curProc > VAL(INTEGER, nProcs)) THEN RETURN END;
    procs[curProc].fwd := TRUE;
    procs[curProc].everFwd := TRUE;
    procs[curProc].fret := procs[curProc].ret;
    procs[curProc].fHead := procs[curProc].dHead;
    procs[curProc].fTail := procs[curProc].dTail;
    procs[curProc].dHead := -1;
    procs[curProc].dTail := -1
  END SetForward;

PROCEDURE AnyForward (): BOOLEAN;
  VAR i : CARDINAL;
  BEGIN
    i := 1;
    WHILE i <= nProcs DO
      IF procs[i].fwd THEN RETURN TRUE END;
      INC(i)
    END;
    RETURN FALSE
  END AnyForward;

PROCEDURE ProcNum (name: ARRAY OF CHAR): INTEGER;
  VAR idx : INTEGER;
  BEGIN
    idx := Find(name);
    IF idx = -1 THEN RETURN -1 END;
    IF syms[idx].kind # KindProc THEN RETURN -1 END;
    RETURN syms[idx].pnum
  END ProcNum;

PROCEDURE SigHead (name: ARRAY OF CHAR): INTEGER;
(* Param list head: define list if present, else forward list. *)
  VAR n : INTEGER;
  BEGIN
    n := ProcNum(name);
    IF n < 1 THEN RETURN -1 END;
    IF procs[n].dHead # -1 THEN RETURN procs[n].dHead END;
    RETURN procs[n].fHead
  END SigHead;

PROCEDURE ProcRet (name: ARRAY OF CHAR): TypeIndex;
  VAR n : INTEGER;
  BEGIN
    n := ProcNum(name);
    IF n < 1 THEN RETURN InvalidType END;
    RETURN procs[n].ret
  END ProcRet;

PROCEDURE ProcNPar (name: ARRAY OF CHAR): CARDINAL;
  VAR h : INTEGER;
    c : CARDINAL;
  BEGIN
    h := SigHead(name); c := 0;
    WHILE h # -1 DO INC(c); h := params[h].next END;
    RETURN c
  END ProcNPar;

PROCEDURE ParamType (name: ARRAY OF CHAR; i: CARDINAL): TypeIndex;
  VAR h : INTEGER;
  BEGIN
    h := SigHead(name);
    WHILE (h # -1) & (i > 0) DO h := params[h].next; DEC(i) END;
    IF h = -1 THEN RETURN InvalidType END;
    RETURN params[h].typ
  END ParamType;

PROCEDURE ParamIsVar (name: ARRAY OF CHAR; i: CARDINAL): BOOLEAN;
  VAR h : INTEGER;
  BEGIN
    h := SigHead(name);
    WHILE (h # -1) & (i > 0) DO h := params[h].next; DEC(i) END;
    IF h = -1 THEN RETURN FALSE END;
    RETURN params[h].isVar
  END ParamIsVar;

PROCEDURE SymSlot (name: ARRAY OF CHAR): INTEGER;
  VAR idx : INTEGER;
  BEGIN
    idx := Find(name);
    IF idx = -1 THEN RETURN NoSlot END;
    RETURN syms[idx].slot
  END SymSlot;

PROCEDURE SymDepth (name: ARRAY OF CHAR): INTEGER;
  VAR idx : INTEGER;
  BEGIN
    idx := Find(name);
    IF idx = -1 THEN RETURN 0 END;
    RETURN VAL(INTEGER, syms[idx].pdep)
  END SymDepth;

PROCEDURE CurDepth (): INTEGER;
  BEGIN
    RETURN VAL(INTEGER, pdep)
  END CurDepth;

PROCEDURE CurProc (): INTEGER;
  BEGIN
    RETURN curProc
  END CurProc;

PROCEDURE CurNPar (): CARDINAL;
  BEGIN
    RETURN parCnt[pdep]
  END CurNPar;

PROCEDURE CurRet (): TypeIndex;
  BEGIN
    IF pdep = 0 THEN RETURN InvalidType END;
    RETURN retSt[pdep]
  END CurRet;

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

PROCEDURE InFunction (): BOOLEAN;
  BEGIN
    RETURN (pdep > 0) & (retSt[pdep] # InvalidType)
  END InFunction;

PROCEDURE ProcNLocals (): CARDINAL;
  BEGIN
    IF pdep = 0 THEN RETURN 0 END;
    RETURN locCnt[pdep]
  END ProcNLocals;

(* ---------------- 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
    nSyms := 0; curLev := 0; mtop := 0;
    nPend := 0; nPendF := 0;
    nTypes := 0; nFields := 0;
    nProcs := 0; nParams := 0;
    pdep := 0; curProc := 0;
    procSt[0] := 0; locCnt[0] := 0; parCnt[0] := 0;
    retSt[0] := InvalidType;
    dInt := NewDesc(FInt, InvalidType);
    dCard := NewDesc(FInt, InvalidType);
    dReal := NewDesc(FReal, InvalidType);
    dChar := NewDesc(FChar, InvalidType);
    dBool := NewDesc(FBool, InvalidType);
    tLo[dChar] := 0; tHi[dChar] := 255;
    tLo[dBool] := 0; tHi[dBool] := 1;
    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")
    ELSE FileIO.WriteString(FileIO.StdOut, "???")
    END
  END WriteKind;

PROCEDURE PrintTable;
  VAR i : CARDINAL;
  BEGIN
    FileIO.WriteLn(FileIO.StdOut);
    FileIO.WriteString(FileIO.StdOut, "--- Symbol table ---");
    FileIO.WriteLn(FileIO.StdOut);
    i := 0;
    WHILE i < nSyms DO
      FileIO.WriteString(FileIO.StdOut, "  ");
      FileIO.WriteString(FileIO.StdOut, syms[i].name);
      FileIO.WriteString(FileIO.StdOut, " : ");
      WriteKind(syms[i].kind);
      FileIO.WriteString(FileIO.StdOut, " #");
      FileIO.WriteInt(FileIO.StdOut, syms[i].typ, 1);
      FileIO.WriteLn(FileIO.StdOut);
      INC(i)
    END
  END PrintTable;

BEGIN
  Init
END SymTab.