CocoR/Test1/SymTab.mod

IMPLEMENTATION MODULE SymTab;

IMPORT FileIO;

CONST
  MaxTypes  = 256;
  MaxFields = 512;
  MaxPend   = 64;
  MaxMarks  = 16;
  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
  Symbol = RECORD
    name : Name;
    kind : INTEGER;
    typ  : TypeIndex;
    lev  : CARDINAL;
  END;
  Field = RECORD
    name  : Name;
    typ   : TypeIndex;
    owner : TypeIndex;
    next  : INTEGER;  (* index of next field of same owner, -1 = end *)
  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;
  nTypes : CARDINAL;
  fields : ARRAY [0 .. MaxFields - 1] OF Field;
  nFields : CARDINAL;
  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 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;
    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 FixPending (t: TypeIndex);
  VAR i : CARDINAL;
  BEGIN
    i := 0;
    WHILE i < nPend DO
      syms[pend[i]].typ := t; INC(i)
    END;
    nPend := 0
  END FixPending;

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];
    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;
  BEGIN
    i := 0;
    WHILE i < nPendF DO
      IF fields[pendF[i]].owner = rec THEN
        fields[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) # -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;
    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 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 : 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 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 (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
    nSyms := 0; curLev := 0; mtop := 0;
    nPend := 0; nPendF := 0;
    nTypes := 0; nFields := 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")
    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.