IMPLEMENTATION MODULE SymTab; IMPORT FileIO; FROM Storage IMPORT ALLOCATE; (* gm2 needs this for NEW substitution *) CONST MaxTypes = 4096; MaxVt = 1024; (* total virtual-method slots across all classes *) MaxPend = 256; MaxMods = 64; ResDepth = 64; MaxPP = 1024; (* total procedure-type parameter slots *) (* descriptor forms *) FNone = 0; FAlias = 1; FSub = 2; FEnum = 3; FArray = 4; FRecord = 5; FSet = 6; FPtr = 7; FStr = 8; FInt = 9; FReal = 10; FChar = 11; FBool = 12; FClass = 13; FOpenArr = 14; FNil = 15; FLong = 16; FProc = 17; FUChar = 18; FUStr = 19; (* signatures compared by the strict 231 check are bounded to this many formals (self-hosting uses far fewer). *) MaxSnap = 16; HighSnap = MaxSnap - 1; TYPE SymPtr = POINTER TO SymNode; ScopePtr = POINTER TO ScopeNode; FieldPtr = POINTER TO FieldNode; SymNode = RECORD name : Name; kind : INTEGER; typ : TypeIndex; scope : ScopePtr; (* owning scope *) left : SymPtr; (* BST links within the owning scope *) right : SymPtr; rslt : TypeIndex; (* KindProc result type, InvalidType = none *) plink : SymPtr; (* next formal, positional chain *) isVar : BOOLEAN; (* KindParam: VAR formal *) fwd : BOOLEAN; (* KindProc: FORWARD body pending *) virt : BOOLEAN; (* KindProc: VIRTUAL method *) fdep : CARDINAL; (* KindProc: lexical function-nesting depth *) snapRes : TypeIndex; (* KindProc: DEFINITION result (ResumeProc) *) snapT : ARRAY [0 .. MaxSnap - 1] OF TypeIndex; (* DEF formal types *) snapV : ARRAY [0 .. MaxSnap - 1] OF BOOLEAN; (* DEF formal VARs *) nSnap : CARDINAL; (* KindProc: number of snapshot formals *) fsnap : BOOLEAN; (* KindProc: signature snapshotted, compare *) vslot : INTEGER; (* KindProc VIRTUAL: vtable slot (-1 = none) *) hasBody : BOOLEAN; (* KindProc: a body was resumed/emitted *) ext : BOOLEAN; (* KindProc: EXTERNAL (no body emitted) *) link : Name; (* KindProc: external link (C) name *) varargs : BOOLEAN; (* KindProc: C varargs (FROM libc IMPORT) *) sym : Name; (* base symbol name (differs from name for qualified aliases) *) mod : Name; (* defining module (for QBE global names) *) uid : CARDINAL; (* KindProc: unique id for name mangling *) val : Name; (* KindConst: literal value text, "" if none *) END; ScopeNode = RECORD parent : ScopePtr; (* scope tree link *) root : SymPtr; (* BST root of this scope's symbols *) level : CARDINAL; link : ScopePtr; (* creation-order chain for PrintTable *) ofRec : TypeIndex; (* record/class whose members live here *) END; FieldNode = RECORD name : Name; typ : TypeIndex; owner : TypeIndex; next : FieldPtr; (* next field of the same owner *) off : INTEGER; (* declaration-order byte offset *) ord : CARDINAL; (* declaration rank (chain is reverse) *) END; VAR curScope : ScopePtr; scopeList : ScopePtr; (* all scopes, creation order *) scopeTail : ScopePtr; fields : FieldPtr; (* all record fields, newest first *) nFields : CARDINAL; pend : ARRAY [0 .. MaxPend - 1] OF SymPtr; nPend : CARDINAL; pendF : ARRAY [0 .. MaxPend - 1] OF FieldPtr; nPendF : CARDINAL; tform : ARRAY [0 .. MaxTypes - 1] OF INTEGER; tref : ARRAY [0 .. MaxTypes - 1] OF TypeIndex; tlo : ARRAY [0 .. MaxTypes - 1] OF INTEGER; thi : ARRAY [0 .. MaxTypes - 1] OF INTEGER; tenum : ARRAY [0 .. MaxTypes - 1] OF CARDINAL; (* enum literal count *) (* module-level forward type references awaiting completion *) pfwdN : CARDINAL; pfwdName : ARRAY [0 .. 255] OF Name; pfwdT : ARRAY [0 .. 255] OF TypeIndex; (* forward module-level variable references from procedure bodies *) nFwdVar : CARDINAL; fwdVarName : ARRAY [0 .. 255] OF Name; fwdVarKind : ARRAY [0 .. 255] OF INTEGER; (* KindVar / KindProc *) fwdVarT : ARRAY [0 .. 255] OF TypeIndex; (* placeholder type index *) tparent : ARRAY [0 .. MaxTypes - 1] OF TypeIndex; tscope : ARRAY [0 .. MaxTypes - 1] OF ScopePtr; tdone : ARRAY [0 .. MaxTypes - 1] OF BOOLEAN; (* per-class vtables: each class owns a slice of the shared pool *) vtBase : ARRAY [0 .. MaxTypes - 1] OF CARDINAL; nVirt : ARRAY [0 .. MaxTypes - 1] OF CARDINAL; vtName : ARRAY [0 .. MaxVt - 1] OF Name; (* virtual method name *) vtUid : ARRAY [0 .. MaxVt - 1] OF CARDINAL; (* its uid *) vtTop : CARDINAL; vtBuilt : ARRAY [0 .. MaxTypes - 1] OF BOOLEAN; tvptr : ARRAY [0 .. MaxTypes - 1] OF INTEGER; (* vptr field offset, -1 none *) vtl : ARRAY [0 .. MaxTypes - 1] OF TypeIndex; (* classes with a vtable *) nVtl : CARDINAL; (* class whose CLASS IMPLEMENTATION body is currently open (nested impls stack); bare method names resolve against it *) implStk : ARRAY [0 .. 15] OF TypeIndex; nImpl : CARDINAL; tvtag : ARRAY [0 .. MaxTypes - 1] OF BOOLEAN; (* record has variants *) ttag : ARRAY [0 .. MaxTypes - 1] OF FieldPtr; (* variant CASE selector *) alo : ARRAY [0 .. MaxTypes - 1] OF INTEGER; ahi : ARRAY [0 .. MaxTypes - 1] OF INTEGER; blo : ARRAY [0 .. 7] OF INTEGER; bhi : ARRAY [0 .. 7] OF INTEGER; nBounds : CARDINAL; nTypes : CARDINAL; curProc : SymPtr; (* heading being declared *) curPTail : SymPtr; (* positional param chain tail *) snapT : ARRAY [0 .. 15] OF TypeIndex; (* signature snapshot scratch *) snapV : ARRAY [0 .. 15] OF BOOLEAN; procStk : ARRAY [0 .. 15] OF SymPtr; nProc : CARDINAL; nextUid : CARDINAL; dInt, dCard, dReal, dChar, dBool, dNil, dAddr, dLong : TypeIndex; dUChar : TypeIndex; (* UCHAR: 32-bit codepoint *) dBitset : TypeIndex; (* BITSET = SET OF [0..15] *) dProc : TypeIndex; (* PROC: parameterless procedure type *) globScope : ScopePtr; (* the global scope (module names live here) *) curMod : INTEGER; (* current registry slot, -1 between units *) curUnit : INTEGER; (* UnitProg/Def/Impl, -1 between units *) nMods : CARDINAL; modNames : ARRAY [0 .. MaxMods - 1] OF Name; modScopes : ARRAY [0 .. MaxMods - 1] OF ScopePtr; modKind : ARRAY [0 .. MaxMods - 1] OF INTEGER; modImpl : ARRAY [0 .. MaxMods - 1] OF BOOLEAN; haveProg : BOOLEAN; typeBlockDepth : CARDINAL; (* > 0 inside a TYPE block *) procp : ARRAY [0 .. MaxPP - 1] OF TypeIndex; (* proc-type params *) procvis : ARRAY [0 .. MaxPP - 1] OF BOOLEAN; (* VAR flags *) procstart : ARRAY [0 .. MaxTypes - 1] OF CARDINAL; procn : ARRAY [0 .. MaxTypes - 1] OF CARDINAL; nProcP : CARDINAL; (* ---------------- strings ---------------- *) PROCEDURE Assign (VAR dest: ARRAY OF CHAR; src: ARRAY OF CHAR); VAR i : CARDINAL; BEGIN i := 0; WHILE (i < HIGH(dest)) AND (src[i] # CHR(0)) DO dest[i] := src[i]; INC(i) END; dest[i] := CHR(0) END Assign; PROCEDURE Equal (a, b: ARRAY OF CHAR): BOOLEAN; VAR i : CARDINAL; BEGIN i := 0; LOOP IF a[i] # b[i] THEN RETURN FALSE END; IF a[i] = CHR(0) THEN RETURN TRUE END; INC(i) END END Equal; PROCEDURE Less (a, b: ARRAY OF CHAR): BOOLEAN; (* Lexicographic order on NUL-terminated strings (BST key order). *) VAR i : CARDINAL; BEGIN i := 0; LOOP IF a[i] # b[i] THEN RETURN ORD(a[i]) < ORD(b[i]) END; IF a[i] = CHR(0) THEN RETURN FALSE END; INC(i) END END Less; PROCEDURE StrLen (s: ARRAY OF CHAR): CARDINAL; VAR i : CARDINAL; BEGIN i := 0; WHILE (i < HIGH(s)) AND (s[i] # CHR(0)) DO INC(i) END; RETURN i END StrLen; PROCEDURE ConstInt (q: ARRAY OF CHAR; VAR v: INTEGER): BOOLEAN; VAR i, d: CARDINAL; neg: BOOLEAN; BEGIN v := 0; i := 0; neg := FALSE; IF q[0] = "-" THEN neg := TRUE; i := 1 END; IF (i >= HIGH(q)) OR (q[i] = CHR(0)) THEN RETURN FALSE END; WHILE (i < HIGH(q)) AND (q[i] # CHR(0)) DO d := ORD(q[i]); IF (d < ORD("0")) OR (d > ORD("9")) THEN RETURN FALSE END; v := v * 10 + VAL(INTEGER, d - ORD("0")); INC(i) END; IF neg THEN v := -v END; RETURN TRUE END ConstInt; (* ---------------- scope tree + per-scope BST ---------------- *) PROCEDURE NewScope (parent: ScopePtr; level: CARDINAL): ScopePtr; (* Heap-allocates a scope and appends it to the creation chain. *) VAR s: ScopePtr; BEGIN NEW(s); s^.parent := parent; s^.root := NIL; s^.level := level; s^.link := NIL; s^.ofRec := InvalidType; IF scopeList = NIL THEN scopeList := s ELSE scopeTail^.link := s END; scopeTail := s; RETURN s END NewScope; PROCEDURE TreeFind (root: SymPtr; name: ARRAY OF CHAR): SymPtr; (* BST search within one scope; NIL if absent. *) BEGIN WHILE root # NIL DO IF Equal(root^.name, name) THEN RETURN root END; IF Less(name, root^.name) THEN root := root^.left ELSE root := root^.right END END; RETURN NIL END TreeFind; PROCEDURE TreeInsert (s: ScopePtr; node: SymPtr): BOOLEAN; (* BST insert of node into scope s; FALSE on duplicate. *) VAR cur, parent: SymPtr; goLeft: BOOLEAN; BEGIN cur := s^.root; parent := NIL; goLeft := FALSE; WHILE cur # NIL DO IF Equal(cur^.name, node^.name) THEN RETURN FALSE END; parent := cur; IF Less(node^.name, cur^.name) THEN cur := cur^.left; goLeft := TRUE ELSE cur := cur^.right; goLeft := FALSE END END; node^.left := NIL; node^.right := NIL; node^.scope := s; IF parent = NIL THEN s^.root := node ELSIF goLeft THEN parent^.left := node ELSE parent^.right := node END; RETURN TRUE END TreeInsert; PROCEDURE Find (name: ARRAY OF CHAR): SymPtr; (* Innermost visible node or NIL; walks the scope chain up. *) VAR s: ScopePtr; r: SymPtr; BEGIN s := curScope; WHILE s # NIL DO r := TreeFind(s^.root, name); IF r # NIL THEN RETURN r END; s := s^.parent END; RETURN NIL END Find; PROCEDURE SetNodeMod (node: SymPtr); (* Records the defining module for global-symbol naming. *) BEGIN IF curMod >= 0 THEN Assign(node^.mod, modNames[curMod]) ELSE node^.mod[0] := CHR(0) END END SetNodeMod; PROCEDURE RawEnter (name: ARRAY OF CHAR; kind: INTEGER): SymPtr; (* Heap-allocates a symbol and links it into the current scope's BST; NIL on duplicate (node released to nobody: dropped). *) VAR node: SymPtr; BEGIN NEW(node); Assign(node^.name, name); Assign(node^.sym, name); SetNodeMod(node); node^.kind := kind; node^.typ := InvalidType; node^.scope := curScope; node^.left := NIL; node^.right := NIL; node^.val[0] := CHR(0); node^.fsnap := FALSE; (* no DEFINITION signature snapshotted *) node^.ext := FALSE; node^.varargs := FALSE; IF NOT TreeInsert(curScope, node) THEN RETURN NIL END; RETURN node END RawEnter; PROCEDURE Enter (name: ARRAY OF CHAR; kind: INTEGER): BOOLEAN; BEGIN RETURN RawEnter(name, kind) # NIL END Enter; PROCEDURE ReenterModGlobal (name: ARRAY OF CHAR; kind: INTEGER; modName: ARRAY OF CHAR): BOOLEAN; VAR node: SymPtr; BEGIN node := RawEnter(name, kind); IF node = NIL THEN RETURN FALSE END; Assign(node^.mod, modName); RETURN TRUE END ReenterModGlobal; PROCEDURE EnterPending (name: ARRAY OF CHAR; kind: INTEGER): BOOLEAN; VAR node: SymPtr; BEGIN node := RawEnter(name, kind); IF (node # NIL) AND (nPend < MaxPend) THEN pend[nPend] := node; INC(nPend) END; RETURN node # NIL END EnterPending; PROCEDURE VarParamOk (actual, formal: TypeIndex): BOOLEAN; (* Addressable-designator compatibility for VAR formals: same type, or fixed array into open array with same element type, or string literal into open CHAR array. *) VAR fa, fe: TypeIndex; BEGIN IF (actual = InvalidType) OR (formal = InvalidType) THEN RETURN TRUE END; IF SameType(actual, formal) THEN RETURN TRUE END; (* ADDRESS is interchangeable with any pointer for VAR params (ADDRESS is a predefined alias, so ClassOf is enough here) *) IF (formal = dAddr) AND (ClassOf(actual) = ClPtr) THEN RETURN TRUE END; IF (actual = dAddr) AND (ClassOf(formal) = ClPtr) THEN RETURN TRUE END; IF IsOpenArray(formal) AND (ClassOf(actual) = ClArray) AND (ArrayDepth(actual) = 1) THEN fa := ArrayElem(actual); fe := ArrayElem(formal); IF SameType(fa, fe) THEN RETURN TRUE END END; IF IsOpenArray(formal) AND (ClassOf(actual) = ClStr) THEN fe := ArrayElem(formal); IF ClassOf(fe) = ClChar THEN RETURN TRUE END END; IF IsOpenArray(formal) AND (ClassOf(actual) = ClUStr) THEN fe := ArrayElem(formal); IF ClassOf(fe) = ClUChar THEN RETURN TRUE END END; RETURN FALSE END VarParamOk; PROCEDURE FormalOk (a, b: TypeIndex): BOOLEAN; (* Value-formal equivalence for the strict 231 check: the same type, or both integer-family (one family per the scalar model), or two string-compatible types. *) BEGIN IF (a = InvalidType) OR (b = InvalidType) THEN (* an unresolved type is not honest evidence; treat as ok so a single root 221/201 is not multiplied by 231 *) RETURN TRUE END; IF SameType(a, b) THEN RETURN TRUE END; IF IsIntFamily(a) AND IsIntFamily(b) THEN RETURN TRUE END; (* Open-array formals are structurally compatible when their element types match: each `ARRAY OF T` declaration allocates a fresh descriptor, so a DEFINITION/IMPLEMENTATION pair never shares the type index and SameType would otherwise reject it. *) IF IsOpenArray(a) AND IsOpenArray(b) THEN RETURN SameType(ArrayElem(a), ArrayElem(b)) END; RETURN StrCompat(a, b) END FormalOk; PROCEDURE FixPending (t: TypeIndex) : BOOLEAN; (* Assigns type t to all pending entries, clears the buffer, and returns TRUE. When the current procedure heading resumed a DEFINITION (snapshot present), this is where a formal's type is known, so the just-typed formals are compared against the snapshot: FALSE = a strict-231 mismatch. *) VAR i, base, k, n: CARDINAL; f: SymPtr; isV, ok: BOOLEAN; BEGIN n := nPend; (* formals typed by this call *) i := 0; WHILE i < nPend DO pend[i]^.typ := t; INC(i) END; nPend := 0; IF (curProc = NIL) OR (curProc^.nSnap = 0) THEN RETURN TRUE END; (* number of formals already in the chain *) base := 0; f := curProc^.plink; WHILE f # NIL DO INC(base); f := f^.plink END; IF base > curProc^.nSnap THEN RETURN FALSE END; (* the just-typed formals are chain indexes base-n .. base-1 *) FOR k := 0 TO n - 1 DO IF base >= n THEN (* walk to index base-n+k *) f := curProc^.plink; i := 0; WHILE (i < base - n + k) AND (f # NIL) DO f := f^.plink; INC(i) END; IF f # NIL THEN isV := f^.isVar; IF isV THEN ok := VarParamOk(f^.typ, curProc^.snapT[base - n + k]) ELSE ok := FormalOk(f^.typ, curProc^.snapT[base - n + k]) END; IF (isV # curProc^.snapV[base - n + k]) OR NOT ok THEN RETURN FALSE END END END END; RETURN TRUE END FixPending; PROCEDURE PendCount (): CARDINAL; BEGIN RETURN nPend END PendCount; PROCEDURE PendName (i: CARDINAL; VAR n: Name); BEGIN IF i < nPend THEN Assign(n, pend[i]^.name) ELSE n[0] := CHR(0) END END PendName; PROCEDURE Resolve (t: TypeIndex): TypeIndex; VAR n: CARDINAL; BEGIN n := 0; WHILE (n < ResDepth) AND (t >= 0) AND (t < VAL(INTEGER, nTypes)) AND (tform[t] = FAlias) DO t := tref[t]; INC(n) END; IF (t < 0) OR (t >= VAL(INTEGER, nTypes)) THEN RETURN InvalidType END; RETURN t END Resolve; PROCEDURE ParentOf (t: TypeIndex): TypeIndex; (* The single parent class of t, or InvalidType. *) VAR r: TypeIndex; BEGIN r := Resolve(t); IF (r >= 0) AND (r < VAL(INTEGER, nTypes)) AND (tform[r] = FClass) THEN RETURN tparent[r] END; RETURN InvalidType END ParentOf; PROCEDURE PushProc (node: SymPtr); BEGIN IF nProc <= HIGH(procStk) THEN procStk[nProc] := node; INC(nProc) END END PushProc; PROCEDURE OwnField (rec: TypeIndex; name: ARRAY OF CHAR): FieldPtr; (* A field declared directly in rec (no parent walk). *) VAR f: FieldPtr; BEGIN IF (rec < 0) OR (rec >= VAL(INTEGER, nTypes)) THEN RETURN NIL END; IF (tform[rec] # FRecord) AND (tform[rec] # FClass) THEN RETURN NIL END; f := fields; WHILE f # NIL DO IF (f^.owner = rec) AND Equal(f^.name, name) THEN RETURN f END; f := f^.next END; RETURN NIL END OwnField; PROCEDURE FindField (rec: TypeIndex; name: ARRAY OF CHAR): FieldPtr; (* Looks in rec, then up the single-inheritance chain. *) VAR f: FieldPtr; r, p: TypeIndex; guard: CARDINAL; BEGIN f := OwnField(rec, name); IF f # NIL THEN RETURN f END; r := Resolve(rec); IF (r = InvalidType) OR (tform[r] # FClass) THEN RETURN NIL END; guard := 0; p := ParentOf(r); WHILE (p # InvalidType) AND (guard < ResDepth) DO f := OwnField(p, name); IF f # NIL THEN RETURN f END; r := p; p := ParentOf(r); INC(guard) END; RETURN NIL END FindField; PROCEDURE FieldPending (rec: TypeIndex; name: ARRAY OF CHAR): BOOLEAN; VAR f: FieldPtr; BEGIN IF FindField(rec, name) # NIL THEN RETURN FALSE END; NEW(f); Assign(f^.name, name); f^.typ := InvalidType; f^.owner := rec; f^.next := fields; fields := f; IF (rec >= 0) AND (rec < VAL(INTEGER, nTypes)) THEN tdone[rec] := FALSE END; IF nPendF < MaxPend THEN pendF[nPendF] := f; INC(nPendF) END; INC(nFields); RETURN TRUE END FieldPending; PROCEDURE FixPendingF (rec: TypeIndex; t: TypeIndex); VAR i, j: CARDINAL; BEGIN i := 0; WHILE i < nPendF DO IF pendF[i]^.owner = rec THEN pendF[i]^.typ := t; (* remove by swap with last *) j := nPendF - 1; pendF[i] := pendF[j]; DEC(nPendF) ELSE INC(i) END END END FixPendingF; PROCEDURE Lookup (name: ARRAY OF CHAR): BOOLEAN; BEGIN RETURN Find(name) # NIL END Lookup; PROCEDURE SymType (name: ARRAY OF CHAR): TypeIndex; VAR node: SymPtr; BEGIN node := Find(name); IF node = NIL THEN RETURN InvalidType END; RETURN node^.typ END SymType; PROCEDURE SetSymType (name: ARRAY OF CHAR; t: TypeIndex); VAR node: SymPtr; BEGIN node := Find(name); IF node # NIL THEN node^.typ := t END END SetSymType; PROCEDURE SymKind (name: ARRAY OF CHAR): INTEGER; VAR node: SymPtr; BEGIN node := Find(name); IF node = NIL THEN RETURN -1 END; RETURN node^.kind END SymKind; PROCEDURE SetSymVal (name: ARRAY OF CHAR; v: ARRAY OF CHAR); VAR node: SymPtr; BEGIN node := Find(name); IF node # NIL THEN Assign(node^.val, v) END END SetSymVal; PROCEDURE GetSymVal (name: ARRAY OF CHAR; VAR v: ARRAY OF CHAR): BOOLEAN; VAR node: SymPtr; BEGIN node := Find(name); IF node = NIL THEN v[0] := CHR(0); RETURN FALSE END; IF node^.val[0] = CHR(0) THEN v[0] := CHR(0); RETURN FALSE END; Assign(v, node^.val); RETURN TRUE END GetSymVal; PROCEDURE PushScope; BEGIN curScope := NewScope(curScope, curScope^.level + 1) END PushScope; PROCEDURE PopScope; BEGIN (* Nodes stay allocated but become unreachable via the chain. *) IF curScope^.parent # NIL THEN curScope := curScope^.parent END END PopScope; (* ---------------- type descriptors (unchanged) ---------------- *) PROCEDURE NewDesc (form: INTEGER; ref: TypeIndex): TypeIndex; BEGIN IF nTypes >= MaxTypes THEN RETURN InvalidType END; tform[nTypes] := form; tref[nTypes] := ref; tdone[nTypes] := FALSE; tvtag[nTypes] := FALSE; vtBase[nTypes] := 0; nVirt[nTypes] := 0; vtBuilt[nTypes] := FALSE; tvptr[nTypes] := -1; ttag[nTypes] := NIL; INC(nTypes); RETURN VAL(INTEGER, nTypes - 1) END NewDesc; PROCEDURE NewAlias (): TypeIndex; BEGIN RETURN NewDesc(FAlias, InvalidType) END NewAlias; PROCEDURE 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 SetEnumCount (t: TypeIndex; n: CARDINAL); VAR r: TypeIndex; BEGIN r := Resolve(t); IF (r # InvalidType) AND (tform[r] = FEnum) THEN tenum[r] := n END END SetEnumCount; PROCEDURE EnumCount (t: TypeIndex): CARDINAL; VAR r: TypeIndex; BEGIN r := Resolve(t); IF (r = InvalidType) OR (tform[r] # FEnum) THEN RETURN 0 END; RETURN tenum[r] END EnumCount; PROCEDURE NewArrayB (elem: TypeIndex; lo, hi: INTEGER): TypeIndex; VAR t: TypeIndex; BEGIN t := NewDesc(FArray, elem); IF t # InvalidType THEN alo[t] := lo; ahi[t] := hi END; RETURN t END NewArrayB; PROCEDURE NewOpenArray (elem: TypeIndex): TypeIndex; BEGIN RETURN NewDesc(FOpenArr, elem) END NewOpenArray; PROCEDURE BoundBegin; BEGIN nBounds := 0 END BoundBegin; PROCEDURE BoundAdd (lo, hi: INTEGER): BOOLEAN; BEGIN IF nBounds > HIGH(blo) THEN RETURN FALSE END; blo[nBounds] := lo; bhi[nBounds] := hi; INC(nBounds); RETURN TRUE END BoundAdd; PROCEDURE BoundCount (): CARDINAL; BEGIN RETURN nBounds END BoundCount; PROCEDURE BoundLo (i: CARDINAL): INTEGER; BEGIN IF i < nBounds THEN RETURN blo[i] ELSE RETURN 0 END END BoundLo; PROCEDURE BoundHi (i: CARDINAL): INTEGER; BEGIN IF i < nBounds THEN RETURN bhi[i] ELSE RETURN -1 END END BoundHi; PROCEDURE NewRecord (): TypeIndex; BEGIN RETURN NewDesc(FRecord, -1) END NewRecord; PROCEDURE NewSet (base: TypeIndex): TypeIndex; BEGIN RETURN NewDesc(FSet, base) END NewSet; PROCEDURE NewPtr (base: TypeIndex): TypeIndex; BEGIN RETURN NewDesc(FPtr, base) END NewPtr; PROCEDURE NewStr (): TypeIndex; BEGIN RETURN NewDesc(FStr, InvalidType) END NewStr; PROCEDURE NewUStr (): TypeIndex; BEGIN RETURN NewDesc(FUStr, InvalidType) END NewUStr; PROCEDURE NewClass (): TypeIndex; VAR t: TypeIndex; BEGIN t := NewDesc(FClass, InvalidType); IF t # InvalidType THEN tparent[t] := InvalidType; tscope[t] := NIL END; RETURN t END NewClass; PROCEDURE SetParent (t, p: TypeIndex); BEGIN IF (t >= 0) AND (t < VAL(INTEGER, nTypes)) AND (tform[t] = FClass) THEN tparent[t] := p END END SetParent; PROCEDURE IsOrdinal (t: TypeIndex): BOOLEAN; (* An ordinal type: integer family, CHAR, UCHAR, BOOLEAN or an enumeration (drives CASE/variant selectors). *) VAR c: INTEGER; BEGIN IF Resolve(t) = InvalidType THEN RETURN FALSE END; c := ClassOf(t); RETURN (c = ClInt) OR (c = ClChar) OR (c = ClUChar) OR (c = ClBool) OR (c = ClEnum) END IsOrdinal; PROCEDURE ResetFields (rec: TypeIndex); (* Starts a fresh variant branch: drops any still-pending fields of rec (their identifiers saw no ":" yet) and clears its layout so the next branch overlays from the tag slot. Field names already committed in an earlier branch stay in the record's scope. *) VAR i: CARDINAL; r: TypeIndex; BEGIN r := Resolve(rec); i := 0; WHILE i < nPendF DO IF pendF[i]^.owner = r THEN nPendF := nPendF - 1; pendF[i] := pendF[nPendF] ELSE INC(i) END END; IF (r >= 0) AND (r < VAL(INTEGER, nTypes)) THEN tdone[r] := FALSE END END ResetFields; PROCEDURE SetVariantTag (rec: TypeIndex; name: ARRAY OF CHAR); (* Records the variant CASE selector field of rec (by name); called just after the tag's type is fixed, before the variant branches. *) VAR r: TypeIndex; BEGIN r := Resolve(rec); IF (r >= 0) AND (r < VAL(INTEGER, nTypes)) THEN ttag[r] := FindField(r, name) END END SetVariantTag; PROCEDURE MarkVariant (rec: TypeIndex); (* Records that this record has a variant part (its fields overlap from the tag slot on, so whole-record comparison is 236). *) VAR r: TypeIndex; BEGIN r := Resolve(rec); IF (r >= 0) AND (r < VAL(INTEGER, nTypes)) THEN tvtag[r] := TRUE END END MarkVariant; PROCEDURE IsVariant (rec: TypeIndex): BOOLEAN; VAR r: TypeIndex; BEGIN r := Resolve(rec); IF (r >= 0) AND (r < VAL(INTEGER, nTypes)) THEN RETURN tvtag[r] END; RETURN FALSE END IsVariant; PROCEDURE PushClassScope (t: TypeIndex); VAR r: TypeIndex; BEGIN r := Resolve(t); IF (r = InvalidType) OR (tform[r] # FClass) THEN RETURN END; PushScope; tscope[r] := curScope END PushClassScope; PROCEDURE SetTarget (t, base: TypeIndex); BEGIN IF (t >= 0) AND (t < VAL(INTEGER, nTypes)) AND (tform[t] = FAlias) THEN tref[t] := base END END SetTarget; PROCEDURE IntType (): TypeIndex; BEGIN RETURN dInt END IntType; PROCEDURE UCharType (): TypeIndex; BEGIN RETURN dUChar END UCharType; PROCEDURE AddrType (): TypeIndex; BEGIN RETURN dAddr END AddrType; PROCEDURE LongType (): TypeIndex; BEGIN RETURN dLong END LongType; PROCEDURE RealType (): TypeIndex; BEGIN RETURN dReal END RealType; PROCEDURE CharType (): TypeIndex; BEGIN RETURN dChar END CharType; PROCEDURE BoolType (): TypeIndex; BEGIN RETURN dBool END BoolType; PROCEDURE ClassOf (t: TypeIndex): INTEGER; VAR r: TypeIndex; BEGIN r := Resolve(t); IF r = InvalidType THEN (* an opaque/undeclared alias (e.g. gm2's String) is pointer-like *) IF (t >= 0) AND (t < VAL(INTEGER, nTypes)) AND (tform[t] = FAlias) THEN RETURN ClPtr END; RETURN ClInvalid END; CASE tform[r] OF FInt : RETURN ClInt | FLong : RETURN ClLong | FReal : RETURN ClReal | FChar : RETURN ClChar | FBool : RETURN ClBool | FEnum : RETURN ClEnum | FArray : RETURN ClArray | FOpenArr : RETURN ClArray | FRecord : RETURN ClRecord | FSet : RETURN ClSet | FPtr : RETURN ClPtr | FStr : RETURN ClStr | FClass : RETURN ClClass | FProc : RETURN ClProc | FUChar : RETURN ClUChar | FUStr : RETURN ClUStr | FNil : RETURN ClNil | FSub : IF tref[r] = InvalidType THEN RETURN ClInt ELSE RETURN ClassOf(tref[r]) END ELSE RETURN ClInvalid END END ClassOf; PROCEDURE IsIntFamily (t: TypeIndex): BOOLEAN; BEGIN RETURN ClassOf(t) = ClInt END IsIntFamily; PROCEDURE IsLongFamily (t: TypeIndex): BOOLEAN; BEGIN RETURN ClassOf(t) = ClLong END IsLongFamily; PROCEDURE SameType (a, b: TypeIndex): BOOLEAN; BEGIN IF (a = InvalidType) OR (b = InvalidType) THEN RETURN TRUE END; RETURN Resolve(a) = Resolve(b) END SameType; PROCEDURE FieldExists (rec: TypeIndex; name: ARRAY OF CHAR): BOOLEAN; BEGIN RETURN FindField(Resolve(rec), name) # NIL END FieldExists; PROCEDURE FieldType (rec: TypeIndex; name: ARRAY OF CHAR): TypeIndex; VAR f: FieldPtr; BEGIN f := FindField(Resolve(rec), name); IF f = NIL THEN RETURN InvalidType END; RETURN f^.typ END FieldType; PROCEDURE ArrayElem (t: TypeIndex): TypeIndex; VAR r: TypeIndex; BEGIN r := Resolve(t); IF (r = InvalidType) OR ((tform[r] # FArray) AND (tform[r] # FOpenArr)) THEN RETURN InvalidType END; RETURN tref[r] END ArrayElem; PROCEDURE IsOpenArray (t: TypeIndex): BOOLEAN; VAR r: TypeIndex; BEGIN r := Resolve(t); IF r = InvalidType THEN RETURN FALSE END; RETURN tform[r] = FOpenArr END IsOpenArray; PROCEDURE ArrayLo (t: TypeIndex): INTEGER; VAR r: TypeIndex; BEGIN r := Resolve(t); IF (r = InvalidType) OR (tform[r] # FArray) THEN RETURN 0 END; RETURN alo[r] END ArrayLo; PROCEDURE ArrayHi (t: TypeIndex): INTEGER; VAR r: TypeIndex; BEGIN r := Resolve(t); IF (r = InvalidType) OR (tform[r] # FArray) THEN RETURN 0 END; RETURN ahi[r] END ArrayHi; PROCEDURE ArrayLen (t: TypeIndex): CARDINAL; VAR r: TypeIndex; lo, hi: INTEGER; BEGIN r := Resolve(t); IF (r = InvalidType) OR (tform[r] # FArray) THEN RETURN 0 END; lo := alo[r]; hi := ahi[r]; IF hi < lo THEN RETURN 0 END; RETURN VAL(CARDINAL, hi - lo + 1) END ArrayLen; PROCEDURE ArrayDepth (t: TypeIndex): CARDINAL; VAR r: TypeIndex; d: CARDINAL; BEGIN d := 0; r := Resolve(t); WHILE (r # InvalidType) AND ((tform[r] = FArray) OR (tform[r] = FOpenArr)) DO INC(d); r := Resolve(tref[r]) END; RETURN d END ArrayDepth; PROCEDURE SubBounds (t: TypeIndex; VAR lo, hi: INTEGER): BOOLEAN; VAR r: TypeIndex; BEGIN lo := 0; hi := -1; r := Resolve(t); IF (r = InvalidType) OR (tform[r] # FSub) OR (tref[r] # InvalidType) THEN RETURN FALSE END; lo := tlo[r]; hi := thi[r]; RETURN TRUE END SubBounds; PROCEDURE SetBase (t: TypeIndex): TypeIndex; VAR r: TypeIndex; BEGIN r := Resolve(t); IF (r = InvalidType) OR (tform[r] # FSet) THEN RETURN InvalidType END; RETURN tref[r] END SetBase; PROCEDURE SetSpan (t: TypeIndex; VAR lo, n: INTEGER): BOOLEAN; (* Base span for mask sizing; FALSE when unsuitable. Internal. *) VAR b, r: TypeIndex; blo, bhi: INTEGER; BEGIN lo := 0; n := 0; b := SetBase(t); IF b = InvalidType THEN RETURN FALSE END; r := Resolve(b); IF r = InvalidType THEN RETURN FALSE END; IF tform[r] = FBool THEN lo := 0; n := 2; RETURN TRUE END; IF tform[r] = FChar THEN lo := 0; n := 256; RETURN TRUE END; IF tform[r] = FEnum THEN IF tenum[r] = 0 THEN RETURN FALSE END; lo := 0; n := VAL(INTEGER, tenum[r]); RETURN TRUE END; IF (tform[r] = FSub) AND (tref[r] = InvalidType) AND SubBounds(b, blo, bhi) AND (bhi >= blo) AND (bhi - blo < 65536) THEN lo := blo; n := bhi - blo + 1; RETURN TRUE END; RETURN FALSE END SetSpan; PROCEDURE SetWords (t: TypeIndex): CARDINAL; VAR lo, n: INTEGER; BEGIN IF NOT SetSpan(t, lo, n) THEN RETURN 0 END; RETURN VAL(CARDINAL, (n + 31) DIV 32) END SetWords; PROCEDURE SetBaseLo (t: TypeIndex): INTEGER; VAR lo, n: INTEGER; BEGIN IF NOT SetSpan(t, lo, n) THEN RETURN 0 END; RETURN lo END SetBaseLo; PROCEDURE SetCount (t: TypeIndex): CARDINAL; VAR lo, n: INTEGER; BEGIN IF NOT SetSpan(t, lo, n) THEN RETURN 0 END; RETURN VAL(CARDINAL, n) END SetCount; PROCEDURE TypeBounds (t: TypeIndex; VAR lo, hi: INTEGER): BOOLEAN; (* The ordinal bounds of a type, for MIN/MAX: subrange/array bounds, CHAR/UCHAR, BOOLEAN, enumeration, or a set's base span. *) VAR r: TypeIndex; c: INTEGER; BEGIN lo := 0; hi := -1; r := Resolve(t); IF r = InvalidType THEN RETURN FALSE END; IF tform[r] = FSub THEN RETURN SubBounds(r, lo, hi) END; IF tform[r] = FArray THEN lo := alo[r]; hi := ahi[r]; RETURN TRUE END; c := ClassOf(r); IF c = ClChar THEN lo := 0; hi := 255; RETURN TRUE END; IF c = ClUChar THEN lo := 0; hi := 1114111; RETURN TRUE END; IF c = ClBool THEN lo := 0; hi := 1; RETURN TRUE END; IF c = ClEnum THEN lo := 0; IF tenum[r] = 0 THEN hi := -1 ELSE hi := VAL(INTEGER, tenum[r]) - 1 END; RETURN TRUE END; IF c = ClSet THEN lo := SetBaseLo(r); IF SetCount(r) = 0 THEN hi := lo - 1 ELSE hi := lo + VAL(INTEGER, SetCount(r)) - 1 END; RETURN TRUE END; IF c = ClInt THEN lo := -2147483648; hi := 2147483647; RETURN TRUE END; RETURN FALSE END TypeBounds; PROCEDURE PtrBase (t: TypeIndex): TypeIndex; VAR r: TypeIndex; BEGIN r := Resolve(t); IF (r = InvalidType) OR (tform[r] # FPtr) THEN RETURN InvalidType END; RETURN tref[r] END PtrBase; (* ---------------- procedure types (step 8.5) ---------------- *) PROCEDURE NewProcType (res: TypeIndex): TypeIndex; VAR t: TypeIndex; BEGIN t := NewDesc(FProc, res); IF t = InvalidType THEN RETURN t END; procstart[t] := nProcP; procn[t] := 0; RETURN t END NewProcType; PROCEDURE ProcTypeAdd (t: TypeIndex; isVar: BOOLEAN; pt: TypeIndex); VAR r: TypeIndex; BEGIN r := Resolve(t); IF (r = InvalidType) OR (tform[r] # FProc) THEN RETURN END; IF nProcP < MaxPP THEN procp[nProcP] := pt; procvis[nProcP] := isVar; INC(nProcP); INC(procn[r]) END END ProcTypeAdd; PROCEDURE SetProcTypeRes (t: TypeIndex; res: TypeIndex); VAR r: TypeIndex; BEGIN r := Resolve(t); IF (r # InvalidType) AND (tform[r] = FProc) THEN tref[r] := res END END SetProcTypeRes; PROCEDURE ProcTypeNPar (t: TypeIndex): CARDINAL; VAR r: TypeIndex; BEGIN r := Resolve(t); IF (r = InvalidType) OR (tform[r] # FProc) THEN RETURN 0 END; RETURN procn[r] END ProcTypeNPar; PROCEDURE ProcTypeParamType (t: TypeIndex; i: CARDINAL): TypeIndex; VAR r: TypeIndex; BEGIN r := Resolve(t); IF (r = InvalidType) OR (tform[r] # FProc) OR (i >= procn[r]) THEN RETURN InvalidType END; RETURN procp[procstart[r] + i] END ProcTypeParamType; PROCEDURE ProcTypeParamIsVar (t: TypeIndex; i: CARDINAL): BOOLEAN; VAR r: TypeIndex; BEGIN r := Resolve(t); IF (r = InvalidType) OR (tform[r] # FProc) OR (i >= procn[r]) THEN RETURN FALSE END; RETURN procvis[procstart[r] + i] END ProcTypeParamIsVar; PROCEDURE ProcTypeRes (t: TypeIndex): TypeIndex; VAR r: TypeIndex; BEGIN r := Resolve(t); IF (r = InvalidType) OR (tform[r] # FProc) THEN RETURN InvalidType END; RETURN tref[r] END ProcTypeRes; PROCEDURE ProcTypeOf (name: ARRAY OF CHAR): TypeIndex; VAR node, p: SymPtr; t: TypeIndex; k: CARDINAL; BEGIN node := Find(name); IF node = NIL THEN RETURN InvalidType END; IF node^.kind # KindProc THEN RETURN InvalidType END; t := NewDesc(FProc, node^.rslt); IF t = InvalidType THEN RETURN t END; procstart[t] := nProcP; k := 0; p := node^.plink; WHILE (p # NIL) AND (nProcP < MaxPP) DO procp[nProcP] := p^.typ; procvis[nProcP] := p^.isVar; INC(nProcP); INC(k); p := p^.plink END; procn[t] := k; RETURN t END ProcTypeOf; PROCEDURE ElemBytes (t: TypeIndex): CARDINAL; (* element size of array descriptor t (bytes) *) VAR cls: INTEGER; BEGIN cls := ClassOf(ArrayElem(t)); IF cls = ClChar THEN RETURN 1 END; IF cls = ClReal THEN RETURN 8 END; IF (cls = ClArray) OR (cls = ClPtr) OR (cls = ClRecord) OR (cls = ClClass) OR (cls = ClProc) THEN RETURN 8 END; RETURN 4 END ElemBytes; PROCEDURE IsCharArray (t: TypeIndex): BOOLEAN; BEGIN RETURN ClassOf(ArrayElem(t)) = ClChar END IsCharArray; PROCEDURE ArrObjSize (t: TypeIndex): CARDINAL; (* full inline size of a fixed array: header (count) + packed elements (+1 terminator byte for CHAR arrays) *) VAR n: CARDINAL; BEGIN n := ArrayLen(t) * ElemBytes(t); IF IsCharArray(t) THEN n := n + 1 END; RETURN 8 + n END ArrObjSize; PROCEDURE TypeSizeD (t: TypeIndex; depth: CARDINAL): CARDINAL; (* Inline footprint in bytes: scalars 4/8, sets words*4, pointers, open and fixed arrays 8 (descriptor address — array objects live separately); records sum members. Depth guards cycles (not 223). *) VAR r: TypeIndex; f: FieldPtr; tagF: FieldPtr; n, plain, high: CARDINAL; BEGIN IF depth > ResDepth THEN RETURN 0 END; r := Resolve(t); IF r = InvalidType THEN RETURN 0 END; CASE tform[r] OF FInt, FBool, FChar, FUChar : RETURN 4 | FLong : RETURN 8 | FReal : RETURN 8 | FEnum, FSub : RETURN 4 | FSet : RETURN SetWords(t) * 4 | FPtr, FOpenArr, FArray, FProc, FUStr : RETURN 8 | FRecord, FClass : n := 0; IF (tform[r] = FClass) AND (tparent[r] # InvalidType) THEN (* single inheritance: parent fields (and its vptr) come first *) n := TypeSizeD(tparent[r], depth + 1) END; IF (tform[r] = FClass) AND (tvptr[r] >= 0) AND (tvptr[r] = VAL(INTEGER, n)) THEN (* this class introduces its vptr here *) n := n + 8 END; IF tvtag[r] AND (ttag[r] # NIL) THEN (* variant record: plain fields (declared before the tag) pack normally; the tag and every variant field overlay in one slot, so the record is plainSize + max(tag, variants). *) plain := 0; high := 0; f := fields; WHILE f # NIL DO IF f^.owner = r THEN IF f^.ord < ttag[r]^.ord THEN (* a plain field, packed before the tag *) IF ClassOf(f^.typ) = ClArray THEN plain := plain + ArrObjSize(f^.typ) ELSE plain := plain + TypeSizeD(f^.typ, depth + 1) END ELSIF f = ttag[r] THEN (* the tag itself: its own slot *) IF ClassOf(f^.typ) = ClArray THEN plain := plain + ArrObjSize(f^.typ) ELSE plain := plain + TypeSizeD(f^.typ, depth + 1) END ELSE (* a variant field: overlay in the region after the tag *) IF ClassOf(f^.typ) = ClArray THEN IF ArrObjSize(f^.typ) > high THEN high := ArrObjSize(f^.typ) END ELSE IF TypeSizeD(f^.typ, depth + 1) > high THEN high := TypeSizeD(f^.typ, depth + 1) END END END END; f := f^.next END; RETURN n + plain + high (* n = parent size, if any *) END; f := fields; WHILE f # NIL DO IF f^.owner = r THEN IF ClassOf(f^.typ) = ClArray THEN n := n + ArrObjSize(f^.typ) (* inline array field *) ELSE n := n + TypeSizeD(f^.typ, depth + 1) END END; f := f^.next END; RETURN n | FAlias : RETURN TypeSizeD(tref[r], depth + 1) ELSE RETURN 0 END END TypeSizeD; PROCEDURE TypeSize (t: TypeIndex): CARDINAL; BEGIN RETURN TypeSizeD(t, 0) END TypeSize; PROCEDURE FieldSize (t: TypeIndex): CARDINAL; (* inline footprint of a record field: fixed arrays are inline objects *) BEGIN IF ClassOf(t) = ClArray THEN RETURN ArrObjSize(t) END; RETURN TypeSizeD(t, 0) END FieldSize; PROCEDURE ObjectSize (t: TypeIndex): CARDINAL; (* full allocation footprint: arrays 8 + count*elem, else TypeSize. Used by SYSTEM.SIZE/TSIZE. *) VAR r: TypeIndex; BEGIN r := Resolve(t); IF (r # InvalidType) AND ((tform[r] = FArray) OR (tform[r] = FOpenArr)) THEN RETURN 8 + ArrayLen(t) * ElemBytes(t) END; RETURN TypeSize(t) END ObjectSize; PROCEDURE BuildVTable (ct: TypeIndex); (* Assigns ct its virtual-method slots: the parent's are inherited first (a same-named virtual method overrides in place), then ct's own new virtual methods append. Each method node records its slot in vslot. Idempotent. *) VAR r, p: TypeIndex; s: ScopePtr; k: CARDINAL; PROCEDURE AddMeth (node: SymPtr); (* override an inherited slot or append a new one *) VAR found: BOOLEAN; j: CARDINAL; BEGIN IF (node^.kind # KindProc) OR NOT node^.virt THEN RETURN END; found := FALSE; j := 0; WHILE (j < nVirt[r]) AND NOT found DO IF Equal(vtName[vtBase[r] + j], node^.name) THEN vtUid[vtBase[r] + j] := node^.uid; node^.vslot := VAL(INTEGER, j); found := TRUE END; INC(j) END; IF NOT found AND (vtTop < MaxVt) THEN Assign(vtName[vtTop], node^.name); vtUid[vtTop] := node^.uid; node^.vslot := VAL(INTEGER, nVirt[r]); INC(vtTop); INC(nVirt[r]) END END AddMeth; PROCEDURE Walk (node: SymPtr); BEGIN IF node = NIL THEN RETURN END; Walk(node^.left); AddMeth(node); Walk(node^.right) END Walk; BEGIN r := Resolve(ct); IF (r = InvalidType) OR (tform[r] # FClass) THEN RETURN END; IF vtBuilt[r] THEN RETURN END; (* already built *) s := tscope[r]; IF s = NIL THEN RETURN END; vtBase[r] := vtTop; nVirt[r] := 0; (* inherit the parent's slots *) p := ParentOf(r); IF p # InvalidType THEN IF NOT vtBuilt[p] THEN BuildVTable(p) END; k := 0; WHILE (k < nVirt[p]) AND (vtTop < MaxVt) DO Assign(vtName[vtTop], vtName[vtBase[p] + k]); vtUid[vtTop] := vtUid[vtBase[p] + k]; INC(vtTop); INC(nVirt[r]); INC(k) END END; (* ct's own virtual methods: override or append *) Walk(s^.root); (* vptr field offset: inherited from a parent that already has one, else introduced after the parent's fields (or at 0) *) IF (p # InvalidType) AND (nVirt[p] > 0) THEN tvptr[r] := tvptr[p] ELSIF nVirt[r] > 0 THEN IF p # InvalidType THEN tvptr[r] := VAL(INTEGER, TypeSizeD(p, 0)) ELSE tvptr[r] := 0 END ELSE tvptr[r] := -1 END; IF (nVirt[r] > 0) AND (nVtl < MaxTypes) THEN vtl[nVtl] := r; INC(nVtl) END; vtBuilt[r] := TRUE END BuildVTable; PROCEDURE ComputeOffsets (r: TypeIndex); (* Declaration-order offsets over the (prepend-built, hence reverse) field chain, plus declaration ranks. Array fields count 8 (pointer-sized in records, matching the locked layout). A record with a variant part lays every field from the first tag slot on at that slot's offset (all variant fields overlap), and the record's size is the largest such field. *) VAR f: FieldPtr; tagF: FieldPtr; (* the variant CASE selector field *) total, high, tagSize, varOff, baseOff: INTEGER; cnt, ord: CARDINAL; off, p: INTEGER; BEGIN (* a class with a parent lays its own fields after the parent's *) baseOff := 0; IF (tform[r] = FClass) AND (tparent[r] # InvalidType) THEN p := Resolve(tparent[r]); IF p # InvalidType THEN IF NOT vtBuilt[p] THEN BuildVTable(p) END; IF NOT tdone[p] THEN ComputeOffsets(p) END; baseOff := VAL(INTEGER, TypeSizeD(p, 0)) END END; (* a class that introduces (rather than inherits) a vptr reserves 8 bytes for it after the parent's fields *) IF (tform[r] = FClass) AND (tvptr[r] >= 0) AND (tvptr[r] = baseOff) THEN baseOff := baseOff + 8 END; IF NOT tvtag[r] THEN (* plain record/class: declaration-ordered, tightly packed *) total := baseOff; cnt := 0; f := fields; WHILE f # NIL DO IF f^.owner = r THEN total := total + VAL(INTEGER, FieldSize(f^.typ)); INC(cnt) END; f := f^.next END; off := total; ord := cnt; f := fields; WHILE f # NIL DO IF f^.owner = r THEN off := off - VAL(INTEGER, FieldSize(f^.typ)); DEC(ord); f^.off := off; f^.ord := ord END; f := f^.next END; tdone[r] := TRUE; RETURN END; (* variant record. Fields declared before the CASE tag pack normally; the tag starts the overlay region and every variant field (declared after the tag) overlays at the tag's slot. Ranks are reverse-declaration (0 = last declared), so the tag has rank = number-of-fields-after-it, and plain fields have larger ranks. *) tagF := ttag[r]; IF tagF = NIL THEN (* no tag recorded (malformed); fall back to plain layout *) tvtag[r] := FALSE; ComputeOffsets(r); RETURN END; cnt := 0; f := fields; WHILE f # NIL DO IF f^.owner = r THEN INC(cnt) END; f := f^.next END; ord := cnt; f := fields; WHILE f # NIL DO IF f^.owner = r THEN DEC(ord); f^.ord := ord END; f := f^.next END; (* plain fields: pack in declaration order up to the tag *) total := 0; f := fields; WHILE f # NIL DO IF (f^.owner = r) AND (f^.ord < tagF^.ord) THEN total := total + VAL(INTEGER, FieldSize(f^.typ)) END; f := f^.next END; off := total; f := fields; WHILE f # NIL DO IF (f^.owner = r) AND (f^.ord < tagF^.ord) THEN off := off - VAL(INTEGER, FieldSize(f^.typ)); f^.off := off END; f := f^.next END; (* the tag occupies its own slot after the plain fields; every variant field overlays in the region after the tag *) tagF^.off := total; varOff := total + VAL(INTEGER, FieldSize(tagF^.typ)); f := fields; WHILE f # NIL DO IF (f^.owner = r) AND (f^.ord > tagF^.ord) THEN f^.off := varOff END; f := f^.next END; tdone[r] := TRUE END ComputeOffsets; PROCEDURE LayoutClass (t: TypeIndex); (* Computes a class's vtable and field offsets (and thus its size). *) VAR r: TypeIndex; BEGIN r := Resolve(t); IF (r # InvalidType) AND (tform[r] = FClass) THEN IF NOT vtBuilt[r] THEN BuildVTable(r) END; IF NOT tdone[r] THEN ComputeOffsets(r) END END END LayoutClass; PROCEDURE LayoutRecord (t: TypeIndex); (* Computes a record's field offsets / size now (idempotent). *) VAR r: TypeIndex; BEGIN r := Resolve(t); IF (r # InvalidType) AND (tform[r] = FRecord) AND NOT tdone[r] THEN ComputeOffsets(r) END END LayoutRecord; PROCEDURE FieldOffset (rec: TypeIndex; name: ARRAY OF CHAR): INTEGER; VAR r: TypeIndex; f: FieldPtr; BEGIN r := Resolve(rec); IF (r = InvalidType) OR ((tform[r] # FRecord) AND (tform[r] # FClass)) THEN RETURN -1 END; IF NOT tdone[r] THEN ComputeOffsets(r) END; f := FindField(r, name); IF f = NIL THEN RETURN -1 END; RETURN f^.off END FieldOffset; PROCEDURE FieldOwner (name: ARRAY OF CHAR): TypeIndex; VAR node: SymPtr; BEGIN node := Find(name); IF node = NIL THEN RETURN InvalidType END; IF node^.kind # KindField THEN RETURN InvalidType END; IF node^.scope = NIL THEN RETURN InvalidType END; RETURN node^.scope^.ofRec END FieldOwner; PROCEDURE FieldCount (rec: TypeIndex): CARDINAL; VAR r: TypeIndex; f: FieldPtr; n: CARDINAL; BEGIN n := 0; r := Resolve(rec); IF (r = InvalidType) OR ((tform[r] # FRecord) AND (tform[r] # FClass)) THEN RETURN 0 END; f := fields; WHILE f # NIL DO IF f^.owner = r THEN INC(n) END; f := f^.next END; RETURN n END FieldCount; PROCEDURE FieldName (rec: TypeIndex; i: CARDINAL; VAR name: Name); (* i-th field in DECLARATION order (chain is reverse; ord ranks it). *) VAR r: TypeIndex; f: FieldPtr; BEGIN name[0] := CHR(0); r := Resolve(rec); IF (r = InvalidType) OR ((tform[r] # FRecord) AND (tform[r] # FClass)) THEN RETURN END; IF NOT tdone[r] THEN ComputeOffsets(r) END; f := fields; WHILE f # NIL DO IF (f^.owner = r) AND (f^.ord = i) THEN Assign(name, f^.name); RETURN END; f := f^.next END END FieldName; PROCEDURE EnterFieldsOf (rec: TypeIndex); (* Enters rec's own fields as KindField into the current scope. *) VAR f: FieldPtr; BEGIN f := fields; WHILE f # NIL DO IF f^.owner = rec THEN IF Enter(f^.name, KindField) THEN SetSymType(f^.name, f^.typ) END END; f := f^.next END END EnterFieldsOf; PROCEDURE PushRecord (t: TypeIndex): BOOLEAN; (* Pushes a scope with t's fields (and, for a class, its ancestors' fields); caller must PopScope afterwards. Classes share the field machinery (methods stay in the class scope itself). *) VAR r, p: TypeIndex; guard: CARDINAL; BEGIN r := Resolve(t); IF (r < 0) OR ((tform[r] # FRecord) AND (tform[r] # FClass)) THEN RETURN FALSE END; PushScope; curScope^.ofRec := r; EnterFieldsOf(r); IF tform[r] = FClass THEN guard := 0; p := ParentOf(r); WHILE (p # InvalidType) AND (guard < ResDepth) DO EnterFieldsOf(p); p := ParentOf(p); INC(guard) END END; RETURN TRUE END PushRecord; (* ---------------- classes ---------------- *) PROCEDURE ClassMethodNode (t: TypeIndex; name: ARRAY OF CHAR): SymPtr; (* The method symbol named name in class t or an ancestor, or NIL. *) VAR r: TypeIndex; s: ScopePtr; node: SymPtr; guard: CARDINAL; BEGIN r := Resolve(t); guard := 0; WHILE (r # InvalidType) AND (tform[r] = FClass) AND (guard < ResDepth) DO s := tscope[r]; IF s # NIL THEN node := TreeFind(s^.root, name); IF (node # NIL) AND (node^.kind = KindProc) THEN RETURN node END END; r := ParentOf(r); INC(guard) END; RETURN NIL END ClassMethodNode; PROCEDURE MethodExists (t: TypeIndex; name: ARRAY OF CHAR): BOOLEAN; (* TRUE when the class (or an ancestor) declares name as a method. *) BEGIN RETURN ClassMethodNode(t, name) # NIL END MethodExists; PROCEDURE ResumeMethod (ct: TypeIndex; name: ARRAY OF CHAR): BOOLEAN; (* Resumes a class's declared method for its CLASS IMPLEMENTATION body: pushes the existing symbol (reusing its uid so calls bind), clearing the formal chain for the body's own heading to rebuild. *) VAR node: SymPtr; BEGIN node := ClassMethodNode(ct, name); IF node = NIL THEN RETURN FALSE END; node^.plink := NIL; node^.hasBody := TRUE; curProc := node; curPTail := NIL; PushProc(node); PushScope; RETURN TRUE END ResumeMethod; PROCEDURE MethUid (): CARDINAL; (* uid of the procedure currently being headed (0 when none): set by ResumeMethod, whose node lives in a detached class scope that ProcUid/Find cannot reach. *) BEGIN IF curProc = NIL THEN RETURN 0 END; RETURN curProc^.uid END MethUid; PROCEDURE ClassMethodUid (t: TypeIndex; name: ARRAY OF CHAR): CARDINAL; VAR n: SymPtr; BEGIN n := ClassMethodNode(t, name); IF n = NIL THEN RETURN 0 END; RETURN n^.uid END ClassMethodUid; PROCEDURE ClassMethodNPar (t: TypeIndex; name: ARRAY OF CHAR): CARDINAL; (* Number of user formals (excludes the hidden THIS). *) VAR n: SymPtr; p: SymPtr; k: CARDINAL; BEGIN n := ClassMethodNode(t, name); IF n = NIL THEN RETURN 0 END; k := 0; p := n^.plink; WHILE p # NIL DO INC(k); p := p^.plink END; IF k > 0 THEN DEC(k) END; (* drop THIS *) RETURN k END ClassMethodNPar; PROCEDURE ClassMethodParamType (t: TypeIndex; name: ARRAY OF CHAR; i: CARDINAL): TypeIndex; (* Type of the i-th USER formal (index 0 skips the hidden THIS). *) VAR n, p: SymPtr; k: CARDINAL; BEGIN n := ClassMethodNode(t, name); IF n = NIL THEN RETURN InvalidType END; p := n^.plink; IF p # NIL THEN p := p^.plink END; (* skip THIS *) k := 0; WHILE (p # NIL) AND (k < i) DO p := p^.plink; INC(k) END; IF p = NIL THEN RETURN InvalidType END; RETURN p^.typ END ClassMethodParamType; PROCEDURE ClassMethodParamIsVar (t: TypeIndex; name: ARRAY OF CHAR; i: CARDINAL): BOOLEAN; VAR n, p: SymPtr; k: CARDINAL; BEGIN n := ClassMethodNode(t, name); IF n = NIL THEN RETURN FALSE END; p := n^.plink; IF p # NIL THEN p := p^.plink END; (* skip THIS *) k := 0; WHILE (p # NIL) AND (k < i) DO p := p^.plink; INC(k) END; IF p = NIL THEN RETURN FALSE END; RETURN p^.isVar END ClassMethodParamIsVar; PROCEDURE ClassMethodRes (t: TypeIndex; name: ARRAY OF CHAR): TypeIndex; VAR n: SymPtr; BEGIN n := ClassMethodNode(t, name); IF n = NIL THEN RETURN InvalidType END; RETURN n^.rslt END ClassMethodRes; PROCEDURE PushImplClass (ct: TypeIndex); BEGIN IF nImpl <= HIGH(implStk) THEN implStk[nImpl] := ct; INC(nImpl) END END PushImplClass; PROCEDURE PopImplClass; BEGIN IF nImpl > 0 THEN DEC(nImpl) END END PopImplClass; PROCEDURE CurImplClass (): TypeIndex; (* The class whose CLASS IMPLEMENTATION body is innermost open, or InvalidType. Bare method names inside a body resolve against it. *) BEGIN IF nImpl = 0 THEN RETURN InvalidType END; RETURN implStk[nImpl - 1] END CurImplClass; PROCEDURE VtClassCount (): CARDINAL; BEGIN RETURN nVtl END VtClassCount; PROCEDURE VtClassAt (k: CARDINAL): TypeIndex; BEGIN IF k >= nVtl THEN RETURN InvalidType END; RETURN vtl[k] END VtClassAt; PROCEDURE IsSubclass (sub, sup: TypeIndex): BOOLEAN; (* TRUE when sub is sup or inherits (transitively) from sup. *) VAR r: TypeIndex; guard: CARDINAL; BEGIN r := Resolve(sub); sup := Resolve(sup); guard := 0; WHILE (r # InvalidType) AND (guard < ResDepth) DO IF r = sup THEN RETURN TRUE END; r := ParentOf(r); INC(guard) END; RETURN FALSE END IsSubclass; PROCEDURE VptrOffset (ct: TypeIndex): INTEGER; VAR r: TypeIndex; BEGIN r := Resolve(ct); IF (r = InvalidType) OR (tform[r] # FClass) THEN RETURN -1 END; IF NOT vtBuilt[r] THEN BuildVTable(r) END; RETURN tvptr[r] END VptrOffset; PROCEDURE HasVTable (ct: TypeIndex): BOOLEAN; (* TRUE when ct has (or inherits) any virtual method. *) VAR r: TypeIndex; BEGIN r := Resolve(ct); IF (r = InvalidType) OR (tform[r] # FClass) THEN RETURN FALSE END; IF NOT vtBuilt[r] THEN BuildVTable(r) END; RETURN nVirt[r] > 0 END HasVTable; PROCEDURE VirtSlot (ct: TypeIndex; name: ARRAY OF CHAR): INTEGER; (* Vtable slot of ct's method name, or -1 when it is not virtual. *) VAR r: TypeIndex; node: SymPtr; BEGIN node := ClassMethodNode(ct, name); IF (node = NIL) OR NOT node^.virt THEN RETURN -1 END; r := Resolve(ct); IF NOT vtBuilt[r] THEN BuildVTable(r) END; RETURN node^.vslot END VirtSlot; PROCEDURE VtCount (ct: TypeIndex): CARDINAL; VAR r: TypeIndex; BEGIN r := Resolve(ct); IF (r = InvalidType) OR (tform[r] # FClass) THEN RETURN 0 END; IF NOT vtBuilt[r] THEN BuildVTable(r) END; RETURN nVirt[r] END VtCount; PROCEDURE VtName (ct: TypeIndex; k: CARDINAL; VAR name: Name): BOOLEAN; VAR r: TypeIndex; BEGIN name[0] := CHR(0); r := Resolve(ct); IF (r = InvalidType) OR (k >= nVirt[r]) THEN RETURN FALSE END; Assign(name, vtName[vtBase[r] + k]); RETURN TRUE END VtName; PROCEDURE VtHasBody (ct: TypeIndex; k: CARDINAL): BOOLEAN; (* TRUE when slot k's method has an emitted body (else the vtable entry is a null pointer). *) VAR r: TypeIndex; node: SymPtr; BEGIN r := Resolve(ct); IF (r = InvalidType) OR (k >= nVirt[r]) THEN RETURN FALSE END; node := ClassMethodNode(r, vtName[vtBase[r] + k]); IF node = NIL THEN RETURN FALSE END; RETURN node^.hasBody END VtHasBody; PROCEDURE VtUid (ct: TypeIndex; k: CARDINAL): CARDINAL; VAR r: TypeIndex; BEGIN r := Resolve(ct); IF (r = InvalidType) OR (k >= nVirt[r]) THEN RETURN 0 END; RETURN vtUid[vtBase[r] + k] END VtUid; PROCEDURE PushClassMembers (t: TypeIndex): BOOLEAN; (* Pushes a scope with t's fields and its ancestors' fields (inheritance) as KindField, for method bodies in CLASS IMPLEMENTATION. Method NAMES are deliberately not copied; bodies re-enter them fresh via ResumeMethod (copying would collide). *) VAR r, p: TypeIndex; s: ScopePtr; guard: CARDINAL; BEGIN r := Resolve(t); IF (r = InvalidType) OR (tform[r] # FClass) THEN RETURN FALSE END; s := tscope[r]; IF s = NIL THEN RETURN FALSE END; PushScope; curScope^.ofRec := r; EnterFieldsOf(r); (* ancestors' fields, nearest first *) guard := 0; p := ParentOf(r); WHILE (p # InvalidType) AND (guard < ResDepth) DO EnterFieldsOf(p); p := ParentOf(p); INC(guard) END; RETURN TRUE END PushClassMembers; PROCEDURE MarkVirtual; BEGIN IF curProc # NIL THEN curProc^.virt := TRUE END END MarkVirtual; (* ---------------- procedures ---------------- *) PROCEDURE EnterProc (name: ARRAY OF CHAR): BOOLEAN; VAR node: SymPtr; BEGIN node := RawEnter(name, KindProc); IF node = NIL THEN curProc := NIL; RETURN FALSE END; node^.rslt := InvalidType; node^.plink := NIL; node^.isVar := FALSE; node^.fwd := FALSE; node^.virt := FALSE; node^.ext := FALSE; node^.fsnap := FALSE; node^.link[0] := CHR(0); node^.uid := nextUid; INC(nextUid); node^.fdep := nProc; node^.vslot := -1; node^.hasBody := FALSE; curProc := node; curPTail := NIL; PushProc(node); PushScope; RETURN TRUE END EnterProc; PROCEDURE DeclareCProc (name: ARRAY OF CHAR): BOOLEAN; (* Enter name in the current scope as an external C procedure with a permissive (varargs, no-result) signature. Used for intrinsic `FROM libc IMPORT ...`; not pushed as the current proc. *) VAR node: SymPtr; BEGIN node := RawEnter(name, KindProc); IF node = NIL THEN RETURN FALSE END; node^.rslt := InvalidType; node^.plink := NIL; node^.isVar := FALSE; node^.fwd := FALSE; node^.virt := FALSE; node^.ext := TRUE; node^.varargs := TRUE; node^.fsnap := FALSE; Assign(node^.link, name); node^.uid := nextUid; INC(nextUid); node^.fdep := nProc; node^.vslot := -1; node^.hasBody := TRUE; RETURN TRUE END DeclareCProc; PROCEDURE Varargs (name: ARRAY OF CHAR): BOOLEAN; (* TRUE for a C-varargs procedure (its calls skip arity/type checks). *) VAR node: SymPtr; BEGIN node := Find(name); IF node = NIL THEN RETURN FALSE END; RETURN node^.varargs END Varargs; PROCEDURE ResumeProc (name: ARRAY OF CHAR): BOOLEAN; (* Resumes a DEFINITION procedure heading for its IMPLEMENTATION body. The definition's signature (result type, formals in order, VAR-ness) is snapshotted before the implementation re-enters its own formals; SetProcRes/FixPending then compare (strict 231). *) VAR node, f: SymPtr; i, n: CARDINAL; BEGIN IF curUnit # UnitImpl THEN RETURN FALSE END; node := TreeFind(curScope^.root, name); IF node = NIL THEN RETURN FALSE END; IF node^.kind # KindProc THEN RETURN FALSE END; (* snapshot the definition signature *) node^.snapRes := node^.rslt; node^.nSnap := 0; n := 0; f := node^.plink; WHILE (f # NIL) AND (n <= HighSnap) DO snapT[n] := f^.typ; snapV[n] := f^.isVar; INC(n); f := f^.plink END; FOR i := 0 TO HighSnap DO IF i < n THEN node^.snapT[i] := snapT[i]; node^.snapV[i] := snapV[i] END END; node^.nSnap := n; node^.fsnap := TRUE; node^.plink := NIL; (* implementation re-enters formals *) curProc := node; curPTail := NIL; PushProc(node); PushScope; RETURN TRUE END ResumeProc; PROCEDURE ReenterProc (name: ARRAY OF CHAR): BOOLEAN; VAR node: SymPtr; BEGIN node := TreeFind(curScope^.root, name); IF node = NIL THEN RETURN FALSE END; IF (node^.kind # KindProc) OR NOT node^.fwd THEN RETURN FALSE END; node^.fwd := FALSE; node^.plink := NIL; (* fresh signature; step 4 compares old vs new *) curProc := node; curPTail := NIL; PushProc(node); PushScope; RETURN TRUE END ReenterProc; PROCEDURE EnterParam (name: ARRAY OF CHAR; isVar: BOOLEAN): BOOLEAN; VAR node: SymPtr; BEGIN node := RawEnter(name, KindParam); IF node = NIL THEN RETURN FALSE END; node^.isVar := isVar; node^.plink := NIL; IF (nPend < MaxPend) THEN pend[nPend] := node; INC(nPend) END; IF curProc # NIL THEN IF curProc^.plink = NIL THEN curProc^.plink := node ELSE curPTail^.plink := node END; curPTail := node END; RETURN TRUE END EnterParam; PROCEDURE EnterThisParam (cls: TypeIndex): BOOLEAN; (* Enters the hidden first parameter THIS (a VAR param of the class type) for a method heading. Field access inside the body binds THIS as the WITH base. THIS is not left pending (it is emitted explicitly by the heading, before any user formals). *) VAR ok: BOOLEAN; BEGIN ok := EnterParam("THIS", TRUE); nPend := 0; RETURN ok END EnterThisParam; PROCEDURE SetProcRes (t: TypeIndex) : BOOLEAN; (* Sets the current procedure's result type. If the heading resumed a DEFINITION (ResumeProc), this is the strict-231 checkpoint: the implementation's result type, formal count, formal types and VAR-ness are compared against the snapshot; the outcome is returned (TRUE = match). *) VAR f, node: SymPtr; i, n: CARDINAL; isV: BOOLEAN; BEGIN IF curProc # NIL THEN curProc^.rslt := t END; node := curProc; IF (node = NIL) OR NOT node^.fsnap THEN RETURN TRUE END; IF NOT FormalOk(t, node^.snapRes) THEN RETURN FALSE END; (* count the implementation heading's formals *) n := 0; f := node^.plink; WHILE (f # NIL) AND (n <= HighSnap) DO INC(n); f := f^.plink END; IF n # node^.nSnap THEN RETURN FALSE END; f := node^.plink; i := 0; WHILE f # NIL DO IF i > HighSnap THEN RETURN FALSE END; isV := f^.isVar; IF isV # node^.snapV[i] THEN RETURN FALSE END; IF isV THEN IF NOT VarParamOk(f^.typ, node^.snapT[i]) THEN RETURN FALSE END ELSE IF NOT FormalOk(f^.typ, node^.snapT[i]) THEN RETURN FALSE END END; f := f^.plink; INC(i) END; RETURN TRUE END SetProcRes; PROCEDURE ProcRes (name: ARRAY OF CHAR): TypeIndex; VAR node: SymPtr; BEGIN node := Find(name); IF node = NIL THEN RETURN InvalidType END; IF node^.kind # KindProc THEN RETURN InvalidType END; RETURN node^.rslt END ProcRes; PROCEDURE MarkFwd; BEGIN IF curProc # NIL THEN curProc^.fwd := TRUE END END MarkFwd; PROCEDURE MarkExternal (link: ARRAY OF CHAR); (* Marks the current procedure EXTERNAL; link '' means "use the procedure's own name" (must be a valid C symbol). *) BEGIN IF curProc = NIL THEN RETURN END; curProc^.ext := TRUE; IF link[0] = CHR(0) THEN Assign(curProc^.link, curProc^.name) ELSE Assign(curProc^.link, link) END END MarkExternal; PROCEDURE IsExternal (name: ARRAY OF CHAR): BOOLEAN; VAR node: SymPtr; BEGIN node := Find(name); IF node = NIL THEN RETURN FALSE END; RETURN node^.ext END IsExternal; PROCEDURE ProcLink (name: ARRAY OF CHAR; VAR link: Name): BOOLEAN; VAR node: SymPtr; BEGIN node := Find(name); IF node = NIL THEN RETURN FALSE END; IF NOT node^.ext THEN RETURN FALSE END; Assign(link, node^.link); RETURN TRUE END ProcLink; PROCEDURE CloseProc; BEGIN IF nProc > 0 THEN DEC(nProc) END; PopScope END CloseProc; PROCEDURE InProc (): BOOLEAN; BEGIN RETURN nProc > 0 END InProc; PROCEDURE CurRes (): TypeIndex; BEGIN IF nProc = 0 THEN RETURN InvalidType END; RETURN procStk[nProc - 1]^.rslt END CurRes; PROCEDURE ProcDepthOf (name: ARRAY OF CHAR): CARDINAL; VAR node: SymPtr; BEGIN node := Find(name); IF node = NIL THEN RETURN 0 END; IF node^.kind # KindProc THEN RETURN 0 END; RETURN node^.fdep END ProcDepthOf; PROCEDURE ProcUid (name: ARRAY OF CHAR): CARDINAL; VAR node: SymPtr; BEGIN node := Find(name); IF node = NIL THEN RETURN 0 END; IF node^.kind # KindProc THEN RETURN 0 END; RETURN node^.uid END ProcUid; PROCEDURE NthParam (node: SymPtr; i: CARDINAL): SymPtr; BEGIN node := node^.plink; WHILE (i > 0) AND (node # NIL) DO node := node^.plink; DEC(i) END; RETURN node END NthParam; PROCEDURE ProcNPar (name: ARRAY OF CHAR): CARDINAL; VAR node, p: SymPtr; n: CARDINAL; BEGIN node := Find(name); IF node = NIL THEN RETURN 0 END; IF node^.kind # KindProc THEN RETURN 0 END; n := 0; p := node^.plink; WHILE p # NIL DO INC(n); p := p^.plink END; RETURN n END ProcNPar; PROCEDURE ParamType (name: ARRAY OF CHAR; i: CARDINAL): TypeIndex; VAR node, p: SymPtr; BEGIN node := Find(name); IF node = NIL THEN RETURN InvalidType END; IF node^.kind # KindProc THEN RETURN InvalidType END; p := NthParam(node, i); IF p = NIL THEN RETURN InvalidType END; RETURN p^.typ END ParamType; PROCEDURE ParamIsVar (name: ARRAY OF CHAR; i: CARDINAL): BOOLEAN; VAR node, p: SymPtr; BEGIN node := Find(name); IF node = NIL THEN RETURN FALSE END; IF node^.kind # KindProc THEN RETURN FALSE END; p := NthParam(node, i); IF p = NIL THEN RETURN FALSE END; RETURN p^.isVar END ParamIsVar; (* ---------------- modules / separate compilation (step 4.3) ---------------- *) PROCEDURE EnterIn (s: ScopePtr; name: ARRAY OF CHAR; kind: INTEGER): BOOLEAN; VAR node: SymPtr; BEGIN NEW(node); Assign(node^.name, name); Assign(node^.sym, name); node^.mod[0] := CHR(0); node^.kind := kind; node^.typ := InvalidType; node^.scope := s; node^.left := NIL; node^.right := NIL; node^.rslt := InvalidType; node^.plink := NIL; node^.isVar := FALSE; node^.fwd := FALSE; node^.virt := FALSE; node^.ext := FALSE; node^.link[0] := CHR(0); node^.fdep := 0; node^.uid := 0; node^.val[0] := CHR(0); IF NOT TreeInsert(s, node) THEN RETURN FALSE END; RETURN TRUE END EnterIn; PROCEDURE FindMod (name: ARRAY OF CHAR): INTEGER; VAR i : CARDINAL; BEGIN i := 0; WHILE i < nMods DO IF Equal(modNames[i], name) THEN RETURN VAL(INTEGER, i) END; INC(i) END; RETURN -1 END FindMod; PROCEDURE NewMod (name: ARRAY OF CHAR; kind: INTEGER): BOOLEAN; VAR idx : CARDINAL; s : ScopePtr; BEGIN IF nMods >= MaxMods THEN RETURN FALSE END; IF FindMod(name) # -1 THEN RETURN FALSE END; idx := nMods; Assign(modNames[idx], name); s := NewScope(globScope, 1); modScopes[idx] := s; modKind[idx] := kind; modImpl[idx] := FALSE; INC(nMods); (* the module name lives in the global scope *) IF NOT EnterIn(globScope, name, KindModule) THEN DEC(nMods); RETURN FALSE END; curMod := VAL(INTEGER, idx); curUnit := kind; curScope := s; RETURN TRUE END NewMod; PROCEDURE BeginDef (name: ARRAY OF CHAR): BOOLEAN; BEGIN RETURN NewMod(name, UnitDef) END BeginDef; PROCEDURE BeginImpl (name: ARRAY OF CHAR): BOOLEAN; VAR idx : INTEGER; BEGIN idx := FindMod(name); IF idx = -1 THEN RETURN FALSE END; IF (modKind[idx] # UnitDef) OR modImpl[idx] THEN RETURN FALSE END; modImpl[idx] := TRUE; curMod := idx; curUnit := UnitImpl; curScope := modScopes[idx]; RETURN TRUE END BeginImpl; PROCEDURE BeginProg (name: ARRAY OF CHAR): BOOLEAN; VAR ok : BOOLEAN; BEGIN ok := NewMod(name, UnitProg); IF ok THEN haveProg := TRUE END; RETURN ok END BeginProg; PROCEDURE HaveProgram (): BOOLEAN; BEGIN RETURN haveProg END HaveProgram; PROCEDURE EndUnit; BEGIN curScope := globScope; curMod := -1; curUnit := -1 END EndUnit; PROCEDURE ModKnown (name: ARRAY OF CHAR): BOOLEAN; BEGIN RETURN FindMod(name) # -1 END ModKnown; PROCEDURE OpaqueBase (name: ARRAY OF CHAR): TypeIndex; VAR node: SymPtr; r : TypeIndex; BEGIN node := Find(name); IF node = NIL THEN RETURN InvalidType END; IF node^.kind # KindType THEN RETURN InvalidType END; r := node^.typ; IF (r < 0) OR (r >= VAL(INTEGER, nTypes)) THEN RETURN InvalidType END; IF (tform[r] = FAlias) AND (tref[r] = InvalidType) THEN RETURN r END; RETURN InvalidType END OpaqueBase; PROCEDURE BeginTypeBlock; BEGIN INC(typeBlockDepth) END BeginTypeBlock; PROCEDURE EndTypeBlock; BEGIN IF typeBlockDepth > 0 THEN DEC(typeBlockDepth) END END EndTypeBlock; PROCEDURE IsUnresolved (t: TypeIndex): BOOLEAN; VAR r: TypeIndex; BEGIN IF (t < 0) OR (t >= VAL(INTEGER, nTypes)) THEN RETURN FALSE END; r := t; RETURN (tform[r] = FAlias) AND (tref[r] = InvalidType) END IsUnresolved; PROCEDURE ForwardType (name: ARRAY OF CHAR): TypeIndex; (* Registers an undeclared type name as an opaque placeholder that a later TYPE declaration completes. Active inside a TYPE block, and at module declaration level (so a global may reference a type declared further down). *) VAR node: SymPtr; t: TypeIndex; BEGIN IF (typeBlockDepth = 0) AND (nProc > 0) THEN RETURN InvalidType END; node := Find(name); IF node # NIL THEN IF node^.kind = KindType THEN RETURN node^.typ END; RETURN InvalidType END; IF NOT Enter(name, KindType) THEN RETURN InvalidType END; t := NewAlias(); SetSymType(name, t); IF (typeBlockDepth = 0) AND (pfwdN <= HIGH(pfwdName)) THEN Assign(pfwdName[pfwdN], name); pfwdT[pfwdN] := t; INC(pfwdN) END; RETURN t END ForwardType; PROCEDURE FwdPending (): CARDINAL; BEGIN RETURN pfwdN END FwdPending; PROCEDURE FwdInfo (i: CARDINAL; VAR name: Name; VAR unresolved: BOOLEAN); BEGIN name[0] := CHR(0); unresolved := FALSE; IF i < pfwdN THEN Assign(name, pfwdName[i]); unresolved := Resolve(pfwdT[i]) = InvalidType END END FwdInfo; PROCEDURE FwdClear; BEGIN pfwdN := 0 END FwdClear; 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 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 QualNthParam (n: SymPtr; i: CARDINAL): SymPtr; BEGIN n := n^.plink; WHILE (i > 0) AND (n # NIL) DO n := n^.plink; DEC(i) END; RETURN n END QualNthParam; PROCEDURE ExportUp (name: ARRAY OF CHAR); VAR src, node: SymPtr; parent: ScopePtr; BEGIN IF curScope = NIL THEN RETURN END; src := TreeFind(curScope^.root, name); IF src = NIL THEN RETURN END; parent := curScope^.parent; IF parent = NIL THEN RETURN END; IF TreeFind(parent^.root, name) # NIL THEN RETURN END; NEW(node); node^ := src^; node^.left := NIL; node^.right := NIL; node^.scope := parent; IF NOT TreeInsert(parent, node) THEN (* duplicate at this level: ignore *) END END ExportUp; PROCEDURE Materialize (mod, name: ARRAY OF CHAR): BOOLEAN; (* FROM-import: clones mod's export into the current scope under its plain name. *) VAR src, node : SymPtr; BEGIN src := QualNode(mod, name); IF src = NIL THEN RETURN FALSE END; (* already visible (repeat import): nothing to do *) IF TreeFind(curScope^.root, name) # NIL THEN RETURN TRUE END; NEW(node); node^ := src^; node^.left := NIL; node^.right := NIL; node^.scope := curScope; IF NOT TreeInsert(curScope, node) THEN RETURN FALSE END; RETURN TRUE END Materialize; PROCEDURE MaterializeReplace (mod, name: ARRAY OF CHAR): BOOLEAN; (* Like Materialize, but when `name` is already visible it is updated in place to the given module's symbol. Lower re-emits one unit at a time and every unit has its own `scopeTop`/`EOL`/..., so the current unit's global must win GlobalRef; the plain Materialize keeps the first one. *) VAR src, node, l, r : SymPtr; sc : ScopePtr; BEGIN src := QualNode(mod, name); IF src = NIL THEN RETURN FALSE END; node := TreeFind(curScope^.root, name); IF node # NIL THEN l := node^.left; r := node^.right; sc := node^.scope; node^ := src^; node^.left := l; node^.right := r; node^.scope := sc; RETURN TRUE END; NEW(node); node^ := src^; node^.left := NIL; node^.right := NIL; node^.scope := curScope; IF NOT TreeInsert(curScope, node) THEN RETURN FALSE END; RETURN TRUE END MaterializeReplace; PROCEDURE BuildAlias (mod, name: ARRAY OF CHAR; VAR alias: Name); (* alias := "$" (a key no identifier can collide with). *) VAR i, j : CARDINAL; BEGIN i := 0; WHILE (i < HIGH(alias)) AND (mod[i] # CHR(0)) DO alias[i] := mod[i]; INC(i) END; IF i < HIGH(alias) THEN alias[i] := "$"; INC(i) END; j := 0; WHILE (i < HIGH(alias)) AND (name[j] # CHR(0)) DO alias[i] := name[j]; INC(i); INC(j) END; IF i <= HIGH(alias) THEN alias[i] := CHR(0) END END BuildAlias; PROCEDURE MaterializeAlias (mod, name: ARRAY OF CHAR; VAR alias: Name): BOOLEAN; (* Qualified access: clones mod's export under a per-module alias key so same-named exports of different modules never collide. The node keeps sym = name and mod = defining module, so QBE symbols (data and calls) resolve correctly. *) VAR src, node : SymPtr; BEGIN src := QualNode(mod, name); IF src = NIL THEN RETURN FALSE END; BuildAlias(mod, name, alias); IF TreeFind(curScope^.root, alias) = NIL THEN NEW(node); node^ := src^; Assign(node^.name, alias); (* BST key *) Assign(node^.sym, name); (* real symbol name *) node^.left := NIL; node^.right := NIL; node^.scope := curScope; IF NOT TreeInsert(curScope, node) THEN RETURN FALSE END END; RETURN TRUE END MaterializeAlias; PROCEDURE SymBase (name: ARRAY OF CHAR; VAR base: Name): BOOLEAN; (* Base symbol name of the visible entry (differs from `name` for qualified aliases). *) VAR node: SymPtr; BEGIN node := Find(name); IF node = NIL THEN RETURN FALSE END; Assign(base, node^.sym); RETURN TRUE END SymBase; PROCEDURE GlobalRef (name: ARRAY OF CHAR; VAR g: Name): BOOLEAN; (* QBE global-symbol name for a module-level entry: "_". FALSE when name is not a module-level symbol. *) VAR node: SymPtr; i, j : CARDINAL; BEGIN node := Find(name); IF node = NIL THEN RETURN FALSE END; IF node^.mod[0] = CHR(0) THEN RETURN FALSE END; i := 0; WHILE (i < HIGH(g)) AND (node^.mod[i] # CHR(0)) DO g[i] := node^.mod[i]; INC(i) END; IF i < HIGH(g) THEN g[i] := "_"; INC(i) END; j := 0; WHILE (i < HIGH(g)) AND (node^.sym[j] # CHR(0)) DO g[i] := node^.sym[j]; INC(i); INC(j) END; IF i <= HIGH(g) THEN g[i] := CHR(0) END; RETURN TRUE END GlobalRef; (* ---- forward module-level variables ---- Inside a procedure body a not-yet-declared identifier may be a module-level variable declared further down (gm2 tolerates this). SymTab records the reference and reports it (FwdVarFix) once the module's declarations are complete; an identifier never declared still yields a 201. *) PROCEDURE IsFwdVar (t: TypeIndex): BOOLEAN; (* TRUE when t is a forward-variable placeholder (its real type is not yet known, so type checks must be lenient). *) VAR k: CARDINAL; BEGIN k := 0; WHILE k < nFwdVar DO IF fwdVarT[k] = t THEN RETURN TRUE END; INC(k) END; RETURN FALSE END IsFwdVar; PROCEDURE FwdVarName (id: INTEGER; VAR name: Name); (* The identifier behind a forward reference id (1-based). *) BEGIN name[0] := CHR(0); IF (id >= 1) AND (id <= VAL(INTEGER, nFwdVar)) THEN Assign(name, fwdVarName[id - 1]) END END FwdVarName; PROCEDURE FwdVarRef (name: ARRAY OF CHAR; kind: INTEGER; VAR id: INTEGER; VAR t: TypeIndex): BOOLEAN; (* Records (or finds) a forward reference to a module-level name used inside a procedure body before its declaration. Returns FALSE when the buffer is full. *) VAR k: CARDINAL; BEGIN k := 0; WHILE k < nFwdVar DO IF Equal(fwdVarName[k], name) THEN id := VAL(INTEGER, k) + 1; t := fwdVarT[k]; RETURN TRUE END; INC(k) END; IF nFwdVar > HIGH(fwdVarName) THEN id := 0; t := InvalidType; RETURN FALSE END; Assign(fwdVarName[nFwdVar], name); fwdVarKind[nFwdVar] := kind; t := NewAlias(); fwdVarT[nFwdVar] := t; id := VAL(INTEGER, nFwdVar) + 1; INC(nFwdVar); RETURN TRUE END FwdVarRef; PROCEDURE FwdVarType (id: INTEGER): TypeIndex; BEGIN IF (id >= 1) AND (id <= VAL(INTEGER, nFwdVar)) THEN RETURN fwdVarT[id - 1] END; RETURN InvalidType END FwdVarType; PROCEDURE FwdVarResolve (id: INTEGER): BOOLEAN; (* Resolves forward reference id against the module's declarations. TRUE when the name now exists; sets the recorded placeholder's target so ClassOf/Assignable see the real type. *) VAR node: SymPtr; BEGIN IF (id < 1) OR (id > VAL(INTEGER, nFwdVar)) THEN RETURN TRUE END; node := Find(fwdVarName[id - 1]); IF node = NIL THEN RETURN FALSE END; IF fwdVarKind[id - 1] = KindProc THEN IF node^.kind # KindProc THEN RETURN FALSE END ELSE IF (node^.kind # KindVar) AND (node^.kind # KindParam) THEN RETURN FALSE END END; fwdVarT[id - 1] := node^.typ; RETURN TRUE END FwdVarResolve; PROCEDURE FwdVarName1 (id: INTEGER; VAR name: Name); BEGIN FwdVarName(id, name) END FwdVarName1; PROCEDURE ImportFrom (mod, name: ARRAY OF CHAR): BOOLEAN; BEGIN RETURN Materialize(mod, name) END ImportFrom; (* ---------------- predicates (unchanged) ---------------- *) PROCEDURE BaseSpanOk (b: TypeIndex): BOOLEAN; (* TRUE for set-suitable bases: bool, char, subranges ≤ 256 wide. *) VAR r: TypeIndex; lo, hi: INTEGER; BEGIN r := Resolve(b); IF r = InvalidType THEN RETURN TRUE END; IF tform[r] = FBool THEN RETURN TRUE END; IF tform[r] = FChar THEN RETURN TRUE END; IF (tform[r] = FSub) AND (tref[r] = InvalidType) AND SubBounds(b, lo, hi) AND (hi >= lo) AND (hi - lo < 256) THEN RETURN TRUE END; RETURN FALSE END BaseSpanOk; PROCEDURE SetBasesOk (a, b: TypeIndex): BOOLEAN; (* base compatibility for two SET types: same, or both suitable (masks compare over min words + zero-check extras) *) BEGIN IF SameType(a, b) THEN RETURN TRUE END; RETURN BaseSpanOk(a) AND BaseSpanOk(b) END SetBasesOk; PROCEDURE ParamTypesOk (x, y: TypeIndex): BOOLEAN; (* Procedure-type formal compatibility: identical, or an open array matching an open/fixed 1-D array of the same element type (open arrays are distinct descriptors, so index equality is too strict). *) BEGIN IF SameType(x, y) THEN RETURN TRUE END; IF (x = InvalidType) OR (y = InvalidType) THEN RETURN TRUE END; IF IsOpenArray(x) AND (ClassOf(y) = ClArray) AND (ArrayDepth(y) = 1) THEN RETURN SameType(ArrayElem(x), ArrayElem(y)) END; IF IsOpenArray(y) AND (ClassOf(x) = ClArray) AND (ArrayDepth(x) = 1) THEN RETURN SameType(ArrayElem(x), ArrayElem(y)) END; RETURN FALSE END ParamTypesOk; PROCEDURE ProcTypesOk (a, b: TypeIndex): BOOLEAN; (* Structural compatibility of two procedure types: same result and same parameter types / VAR flags. *) VAR i, n: CARDINAL; BEGIN IF (tform[a] # FProc) OR (tform[b] # FProc) THEN RETURN FALSE END; IF NOT SameType(tref[a], tref[b]) THEN RETURN FALSE END; n := procn[a]; IF n # procn[b] THEN RETURN FALSE END; i := 0; WHILE i < n DO IF procvis[procstart[a] + i] # procvis[procstart[b] + i] THEN RETURN FALSE END; IF NOT ParamTypesOk(procp[procstart[a] + i], procp[procstart[b] + i]) THEN RETURN FALSE END; INC(i) END; RETURN TRUE END ProcTypesOk; PROCEDURE Assignable (src, dst: TypeIndex): BOOLEAN; VAR rs, rd: TypeIndex; BEGIN IF (src = InvalidType) OR (dst = InvalidType) THEN RETURN TRUE END; IF IsFwdVar(src) OR IsFwdVar(dst) THEN RETURN TRUE END; rs := Resolve(src); rd := Resolve(dst); IF rs = rd THEN RETURN TRUE END; IF (rs = InvalidType) OR (rd = InvalidType) THEN RETURN TRUE END; IF (tform[rs] = FSet) AND (tform[rd] = FSet) THEN RETURN SetBasesOk(tref[rs], tref[rd]) END; IF (tform[rs] = FProc) AND (tform[rd] = FProc) THEN RETURN ProcTypesOk(rs, rd) END; IF (ClassOf(src) = ClArray) AND (ClassOf(dst) = ClArray) THEN (* a fixed 1-D array is compatible with an open formal of the same element type (value or VAR) *) IF IsOpenArray(dst) AND (ArrayDepth(src) = 1) THEN RETURN SameType(ArrayElem(src), ArrayElem(dst)) END; RETURN SameType(src, dst) END; IF (ClassOf(src) = ClStr) AND (ClassOf(dst) = ClArray) THEN RETURN (ArrayDepth(dst) = 1) AND (ClassOf(ArrayElem(dst)) = ClChar) END; IF (ClassOf(src) = ClUStr) AND (ClassOf(dst) = ClArray) THEN (* a U"..." literal assigns/ passes to a 1-D ARRAY OF UCHAR by content copy (count-clamped, UCHAR-0 terminated). *) RETURN (ArrayDepth(dst) = 1) AND (ClassOf(ArrayElem(dst)) = ClUChar) END; IF ClassOf(src) = ClNil THEN RETURN ClassOf(dst) = ClPtr END; (* ADDRESS assigns to/from any pointer (check before the subclass test, which returns early) *) IF (Resolve(src) = dAddr) AND (ClassOf(dst) = ClPtr) THEN RETURN TRUE END; IF (Resolve(dst) = dAddr) AND (ClassOf(src) = ClPtr) THEN RETURN TRUE END; (* POINTER TO Derived assigns to POINTER TO Base (subtyping) *) IF (ClassOf(src) = ClPtr) AND (ClassOf(dst) = ClPtr) THEN RETURN IsSubclass(PtrBase(src), PtrBase(dst)) END; IF (ClassOf(src) = ClInt) AND (ClassOf(dst) = ClInt) THEN RETURN TRUE END; IF (ClassOf(src) = ClInt) AND (ClassOf(dst) = ClLong) THEN RETURN TRUE END; IF (ClassOf(src) = ClInt) AND (ClassOf(dst) = ClReal) THEN RETURN TRUE END; RETURN FALSE END Assignable; PROCEDURE ArithCheck (l, r: TypeIndex; divmod: BOOLEAN; VAR res: TypeIndex): BOOLEAN; BEGIN res := InvalidType; IF (l = InvalidType) OR (r = InvalidType) THEN RETURN TRUE END; IF IsFwdVar(l) OR IsFwdVar(r) THEN res := dInt; RETURN TRUE END; IF (IsLongFamily(l) AND IsLongFamily(r)) OR (IsLongFamily(l) AND IsIntFamily(r)) OR (IsIntFamily(l) AND IsLongFamily(r)) THEN res := dLong; RETURN TRUE END; IF IsIntFamily(l) AND IsIntFamily(r) THEN res := dInt; RETURN TRUE END; IF NOT divmod AND (ClassOf(l) = ClReal) AND (ClassOf(r) = ClReal) THEN res := dReal; RETURN TRUE END; RETURN FALSE END ArithCheck; PROCEDURE BoolCheck (t: TypeIndex): BOOLEAN; BEGIN IF t = InvalidType THEN RETURN TRUE END; RETURN ClassOf(t) = ClBool END BoolCheck; PROCEDURE IsStrType (t: TypeIndex): BOOLEAN; (* A string literal, or a 1-D ARRAY OF CHAR. *) VAR c: TypeIndex; BEGIN c := Resolve(t); IF c = InvalidType THEN RETURN FALSE END; IF ClassOf(c) = ClStr THEN RETURN TRUE END; IF (ClassOf(c) = ClArray) AND (ArrayDepth(c) = 1) THEN RETURN ClassOf(ArrayElem(c)) = ClChar END; RETURN FALSE END IsStrType; PROCEDURE UStrCompat (l, r: TypeIndex): BOOLEAN; (* Both operands are UString literals (ClUStr): `+` concatenates. *) BEGIN RETURN (l # InvalidType) AND (r # InvalidType) AND (ClassOf(l) = ClUStr) AND (ClassOf(r) = ClUStr) END UStrCompat; PROCEDURE IsUCharArray (t: TypeIndex): BOOLEAN; (* A 1-D ARRAY OF UCHAR: a destination for U"..." content copy. *) VAR c: TypeIndex; BEGIN c := Resolve(t); IF c = InvalidType THEN RETURN FALSE END; IF (ClassOf(c) = ClArray) AND (ArrayDepth(c) = 1) THEN RETURN ClassOf(ArrayElem(c)) = ClUChar END; RETURN FALSE END IsUCharArray; PROCEDURE StrCompat (l, r: TypeIndex): BOOLEAN; (* Both operands are string-compatible (content equality via the shim); used for `=`/`#` only. *) BEGIN RETURN IsStrType(l) AND IsStrType(r) END StrCompat; PROCEDURE EqCheck (l, r: TypeIndex): BOOLEAN; VAR rl, rr: TypeIndex; BEGIN IF IsFwdVar(l) OR IsFwdVar(r) THEN RETURN TRUE END; IF (l = InvalidType) OR (r = InvalidType) THEN RETURN TRUE END; IF ClassOf(l) = ClNil THEN RETURN (ClassOf(r) = ClNil) OR (ClassOf(r) = ClPtr) END; IF ClassOf(r) = ClNil THEN RETURN (ClassOf(l) = ClNil) OR (ClassOf(l) = ClPtr) END; IF SameType(l, r) THEN (* Whole-array, string, record and class equality are not built-in (213); compare member-wise instead. *) IF (ClassOf(l) = ClArray) OR (ClassOf(l) = ClStr) OR (ClassOf(l) = ClRecord) OR (ClassOf(l) = ClClass) THEN IF StrCompat(l, r) THEN RETURN TRUE END; (* string content *) RETURN FALSE END; RETURN TRUE END; IF StrCompat(l, r) THEN RETURN TRUE END; IF IsIntFamily(l) AND IsIntFamily(r) THEN RETURN TRUE END; IF (ClassOf(l) = ClLong) AND (ClassOf(r) = ClLong) THEN RETURN TRUE END; IF (ClassOf(l) = ClLong) AND IsIntFamily(r) THEN RETURN TRUE END; IF IsIntFamily(l) AND (ClassOf(r) = ClLong) THEN RETURN TRUE END; IF (ClassOf(l) = ClReal) AND (ClassOf(r) = ClReal) THEN RETURN TRUE END; IF (ClassOf(l) = ClChar) AND (ClassOf(r) = ClChar) THEN RETURN TRUE END; IF (ClassOf(l) = ClUChar) AND (ClassOf(r) = ClUChar) THEN RETURN TRUE END; IF (ClassOf(l) = ClBool) AND (ClassOf(r) = ClBool) THEN RETURN TRUE END; rl := Resolve(l); rr := Resolve(r); IF (rl = InvalidType) OR (rr = InvalidType) THEN RETURN TRUE END; IF (tform[rl] = FSet) AND (tform[rr] = FSet) THEN RETURN SetBasesOk(tref[rl], tref[rr]) END; RETURN FALSE END EqCheck; PROCEDURE OrdCheck (l, r: TypeIndex): BOOLEAN; BEGIN IF IsFwdVar(l) OR IsFwdVar(r) THEN RETURN TRUE END; IF (l = InvalidType) OR (r = InvalidType) THEN RETURN TRUE END; IF IsIntFamily(l) AND IsIntFamily(r) THEN RETURN TRUE END; IF (ClassOf(l) = ClLong) AND (ClassOf(r) = ClLong) THEN RETURN TRUE END; IF (ClassOf(l) = ClLong) AND IsIntFamily(r) THEN RETURN TRUE END; IF IsIntFamily(l) AND (ClassOf(r) = ClLong) THEN RETURN TRUE END; IF (ClassOf(l) = ClReal) AND (ClassOf(r) = ClReal) THEN RETURN TRUE END; IF (ClassOf(l) = ClChar) AND (ClassOf(r) = ClChar) THEN RETURN TRUE END; IF (ClassOf(l) = ClUChar) AND (ClassOf(r) = ClUChar) THEN RETURN TRUE END; IF (ClassOf(l) = ClEnum) AND SameType(l, r) THEN RETURN TRUE END; RETURN FALSE END OrdCheck; PROCEDURE SetElemClassOk (c: INTEGER): BOOLEAN; (* TRUE for an element class acceptable in a set constructor. *) BEGIN RETURN (c = ClInt) OR (c = ClChar) OR (c = ClBool) OR (c = ClEnum) OR (c = ClUChar) END SetElemClassOk; PROCEDURE InCheck (l, set: TypeIndex): BOOLEAN; VAR rs, b: TypeIndex; BEGIN IF (l = InvalidType) OR (set = InvalidType) THEN RETURN TRUE END; rs := Resolve(set); IF (rs = InvalidType) OR (tform[rs] # FSet) THEN RETURN FALSE END; b := tref[rs]; IF SameType(l, b) THEN RETURN TRUE END; IF IsIntFamily(l) AND IsIntFamily(b) THEN RETURN TRUE END; IF (ClassOf(l) = ClChar) AND (ClassOf(b) = ClChar) THEN RETURN TRUE END; (* lenient: small int/char/bool/enum 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) OR (ClassOf(l) = ClEnum)) AND (SetWords(set) > 0) THEN RETURN TRUE END; RETURN FALSE END InCheck; PROCEDURE RelCheck (l, r: TypeIndex; op: INTEGER): BOOLEAN; BEGIN IF (l = InvalidType) OR (r = InvalidType) THEN RETURN TRUE END; IF op = OpIn THEN RETURN InCheck(l, r) END; IF (op = OpEq) OR (op = OpNeq1) OR (op = OpNeq2) THEN RETURN EqCheck(l, r) END; RETURN OrdCheck(l, r) END RelCheck; (* ---------------- init ---------------- *) PROCEDURE Predef (name: ARRAY OF CHAR; kind: INTEGER; t: TypeIndex); BEGIN IF Enter(name, kind) THEN SetSymType(name, t) END END Predef; PROCEDURE AddFormal (pr: SymPtr; t: TypeIndex; isVar: BOOLEAN); (* Appends a formal-position node to procedure pr's plink chain. These formals are not in any scope: they exist only to give the external builtin a signature the caller checks against. *) VAR p, q: SymPtr; BEGIN IF pr = NIL THEN RETURN END; NEW(p); p^.name[0] := CHR(0); p^.sym[0] := CHR(0); p^.mod[0] := CHR(0); p^.kind := KindParam; p^.typ := t; p^.scope := NIL; p^.left := NIL; p^.right := NIL; p^.rslt := InvalidType; p^.plink := NIL; p^.isVar := isVar; p^.fwd := FALSE; p^.virt := FALSE; p^.fdep := 0; p^.snapRes := InvalidType; p^.nSnap := 0; p^.fsnap := FALSE; p^.vslot := -1; p^.hasBody := FALSE; p^.ext := FALSE; p^.varargs := FALSE; p^.link[0] := CHR(0); p^.uid := 0; p^.val[0] := CHR(0); IF pr^.plink = NIL THEN pr^.plink := p ELSE q := pr^.plink; WHILE q^.plink # NIL DO q := q^.plink END; q^.plink := p END END AddFormal; PROCEDURE PredefCProc (name, cname: ARRAY OF CHAR; res: TypeIndex): SymPtr; (* Defines an external C procedure in the global scope with an explicit (not varargs) signature; formals are added with AddFormal. *) VAR node: SymPtr; BEGIN node := RawEnter(name, KindProc); IF node = NIL THEN RETURN NIL END; node^.rslt := res; node^.plink := NIL; node^.isVar := FALSE; node^.fwd := FALSE; node^.virt := FALSE; node^.ext := TRUE; node^.varargs := FALSE; node^.fsnap := FALSE; Assign(node^.link, cname); node^.uid := nextUid; INC(nextUid); node^.fdep := 0; node^.vslot := -1; node^.hasBody := TRUE; RETURN node END PredefCProc; PROCEDURE Init; VAR pr: SymPtr; BEGIN scopeList := NIL; scopeTail := NIL; fields := NIL; nFields := 0; nPend := 0; nPendF := 0; nTypes := 0; nProc := 0; nBounds := 0; nextUid := 0; vtTop := 0; nVtl := 0; nImpl := 0; curProc := NIL; curPTail := NIL; nMods := 0; curMod := -1; curUnit := -1; haveProg := FALSE; curScope := NewScope(NIL, 0); globScope := curScope; dInt := NewDesc(FInt, InvalidType); dCard := NewDesc(FInt, InvalidType); dReal := NewDesc(FReal, InvalidType); dChar := NewDesc(FChar, InvalidType); dBool := NewDesc(FBool, InvalidType); dNil := NewDesc(FNil, InvalidType); dAddr := NewDesc(FPtr, InvalidType); (* ADDRESS: pointer-sized *) dLong := NewDesc(FLong, InvalidType); (* LONGINT/LONGCARD: 64-bit *) dUChar := NewDesc(FUChar, InvalidType); dBitset := NewSet(NewSubR(0, 15)); (* BITSET *) dProc := NewProcType(InvalidType); (* PROC: no params, no result *) Predef("INTEGER", KindPredef, dInt); Predef("CARDINAL", KindPredef, dCard); Predef("SHORTINT", KindPredef, dInt); Predef("LONGINT", KindPredef, dLong); Predef("SHORTCARD", KindPredef, dCard); Predef("REAL", KindPredef, dReal); Predef("LONGREAL", KindPredef, dReal); Predef("CHAR", KindPredef, dChar); Predef("BOOLEAN", KindPredef, dBool); Predef("TRUE", KindConst, dBool); Predef("FALSE", KindConst, dBool); Predef("ADDRESS", KindPredef, dAddr); Predef("UCHAR", KindPredef, dUChar); Predef("BITSET", KindPredef, dBitset); (* SYSTEM storage types (PIM/gm2): mapped onto V3's integer family (BYTE/WORD -> the 32-bit ordinal, LONGWORD -> LONGINT, the address forms -> ADDRESS) so `FROM SYSTEM IMPORT BYTE;` and `ARRAY OF BYTE` resolve. *) Predef("BYTE", KindPredef, dCard); Predef("SBYTE", KindPredef, dInt); Predef("WORD", KindPredef, dCard); Predef("SWORD", KindPredef, dInt); Predef("LONGWORD", KindPredef, dLong); Predef("SHORTADDR", KindPredef, dAddr); Predef("LONGADDR", KindPredef, dAddr); Predef("PROC", KindPredef, dAddr); Predef("LOC", KindPredef, dAddr); (* gm2 sized/scalar names (mapped onto V3's families) *) Predef("LONGCARD", KindPredef, dLong); Predef("SHORTREAL", KindPredef, dReal); Predef("INTEGER8", KindPredef, dInt); Predef("INTEGER16", KindPredef, dInt); Predef("INTEGER32", KindPredef, dInt); Predef("INTEGER64", KindPredef, dLong); Predef("CARDINAL8", KindPredef, dCard); Predef("CARDINAL16", KindPredef, dCard); Predef("CARDINAL32", KindPredef, dCard); Predef("CARDINAL64", KindPredef, dLong); (* PIM/SYSTEM coroutines: PROCESS is pointer-sized; the three builtins bind to C helpers in the runtime shim. Signatures: NEWPROCESS(P: PROC; A: ADDRESS; n: CARDINAL; VAR c: PROCESS); TRANSFER(VAR a, b: PROCESS); IOTRANSFER(VAR a, b: PROCESS; interruptNo: CARDINAL). *) Predef("PROCESS", KindPredef, dAddr); pr := PredefCProc("NEWPROCESS", "m2_newprocess", InvalidType); AddFormal(pr, dProc, FALSE); AddFormal(pr, dAddr, FALSE); AddFormal(pr, dCard, FALSE); AddFormal(pr, dAddr, TRUE); pr := PredefCProc("TRANSFER", "m2_transfer", InvalidType); AddFormal(pr, dAddr, TRUE); AddFormal(pr, dAddr, TRUE); pr := PredefCProc("IOTRANSFER", "m2_iotransfer", InvalidType); AddFormal(pr, dAddr, TRUE); AddFormal(pr, dAddr, TRUE); AddFormal(pr, dCard, FALSE); 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.