(* SymbolTable.mod provides access to the symbol table. Copyright (C) 2001-2025 Free Software Foundation, Inc. Contributed by Gaius Mulley . This file is part of GNU Modula-2. GNU Modula-2 is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3, or (at your option) any later version. GNU Modula-2 is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with GNU Modula-2; see the file COPYING3. If not see . *) IMPLEMENTATION MODULE SymbolTable ; FROM SYSTEM IMPORT ADDRESS, ADR ; FROM Storage IMPORT ALLOCATE, DEALLOCATE ; FROM M2Debug IMPORT Assert ; FROM libc IMPORT printf ; FROM ASCII IMPORT nul ; IMPORT Indexing ; FROM Indexing IMPORT InitIndex, InBounds, LowIndice, HighIndice, PutIndice, GetIndice, InitIndexTuned ; FROM Sets IMPORT Set, InitSet, IncludeElementIntoSet, IsElementInSet ; FROM gcctypes IMPORT location_t ; FROM M2Options IMPORT Pedantic, ExtendedOpaque, GetDebugFunctionLineNumbers, ScaffoldDynamic, DebugBuiltins ; FROM M2LexBuf IMPORT UnknownTokenNo, TokenToLineNo, FindFileNameFromToken, TokenToLocation, MakeVirtual2Tok ; FROM M2ALU IMPORT InitValue, PtrToValue, PushCard, PopInto, PushString, PushFrom, PushChar, PushInt, IsSolved, IsValueConst ; FROM M2Error IMPORT Error, NewError, ChainError, InternalError, ErrorFormat0, ErrorFormat1, ErrorFormat2, WriteFormat0, WriteFormat1, WriteFormat2, ErrorString, ErrorAbort0, FlushErrors, ErrorScope, GetCurrentErrorScope ; FROM M2MetaError IMPORT MetaError1, MetaError2, MetaError3, MetaErrors1, MetaErrorT0, MetaErrorString1, MetaErrorStringT0, MetaErrorStringT1, MetaErrorT1, MetaErrorT2 ; FROM M2LexBuf IMPORT GetTokenNo ; FROM FormatStrings IMPORT Sprintf1 ; FROM M2Printf IMPORT printf0, printf1, printf2, printf3, printf4 ; FROM DynamicStrings IMPORT String, string, InitString, InitStringCharStar, Mark, KillString, Length, ConCat, Index, char ; FROM Lists IMPORT List, InitList, GetItemFromList, PutItemIntoList, IsItemInList, IncludeItemIntoList, NoOfItemsInList, RemoveItemFromList, ForeachItemInListDo ; FROM NameKey IMPORT Name, MakeKey, makekey, NulName, WriteKey, LengthKey, GetKey, KeyToCharStar ; FROM SymbolKey IMPORT NulKey, SymbolTree, IsSymbol, InitTree, GetSymKey, PutSymKey, DelSymKey, IsEmptyTree, DoesTreeContainAny, ForeachNodeDo, ForeachNodeConditionDo, NoOfNodes ; FROM M2Base IMPORT MixTypes, MixTypesDecl, InitBase, Char, Integer, LongReal, Cardinal, LongInt, LongCard, ZType, RType ; FROM M2System IMPORT Address ; FROM m2expr IMPORT OverflowZType ; FROM gcctypes IMPORT tree ; FROM m2linemap IMPORT BuiltinsLocation ; FROM StrLib IMPORT StrEqual ; FROM m2builtins IMPORT BuiltinExists ; FROM M2Comp IMPORT CompilingDefinitionModule, CompilingImplementationModule ; FROM FormatStrings IMPORT HandleEscape ; FROM M2Scaffold IMPORT DeclareArgEnvParams ; FROM M2SymInit IMPORT InitDesc, InitSymInit, GetInitialized, ConfigSymInit, SetInitialized, SetFieldInitialized, GetFieldInitialized, PrintSymInit ; IMPORT Indexing ; CONST DebugUnknowns = FALSE ; (* Debug unknown symbols. *) DebugUnknownToken = FALSE ; (* If enabled it will generate a warning every time a symbol is created with an unknown location. *) (* The Unbounded is a pseudo type used within the compiler to implement dynamic parameter arrays. It is implmented as a record structure which has the following fields: RECORD _m2_contents: POINTER TO type ; _m2_high : CARDINAL ; END ; *) UnboundedAddressName = "_m2_contents" ; UnboundedHighName = "_m2_high_%d" ; BreakSym = 203 ; TYPE ProcAnyBoolean = PROCEDURE (CARDINAL, ProcedureKind) : BOOLEAN ; ProcAnyCardinal = PROCEDURE (CARDINAL, ProcedureKind) : CARDINAL ; ConstLitPoolEntry = POINTER TO RECORD sym : CARDINAL ; tok : CARDINAL ; constName: Name ; constType: CARDINAL ; next : ConstLitPoolEntry ; END ; LRLists = ARRAY [RightValue..LeftValue] OF List ; LRInitDesc = ARRAY [RightValue..LeftValue] OF InitDesc ; TypeOfSymbol = (RecordSym, VarientSym, DummySym, VarSym, EnumerationSym, SubrangeSym, ArraySym, ConstStringSym, ConstVarSym, ConstLitSym, VarParamSym, ParamSym, PointerSym, UndefinedSym, TypeSym, RecordFieldSym, VarientFieldSym, EnumerationFieldSym, DefImpSym, ModuleSym, SetSym, ProcedureSym, ProcTypeSym, SubscriptSym, UnboundedSym, GnuAsmSym, InterfaceSym, ObjectSym, PartialUnboundedSym, TupleSym, OAFamilySym, ImportSym, ImportStatementSym, EquivSym, ErrorSym) ; Where = RECORD DefDeclared, FirstUsed, ModDeclared: CARDINAL ; END ; VarDecl = RECORD FullTok, VarTok, TypeTok: CARDINAL ; (* Variable and type token *) END ; (* locations. *) PackedInfo = RECORD IsPacked : BOOLEAN ; (* is this type packed? *) PackedEquiv : CARDINAL ; (* the equivalent packed type *) END ; PtrToAsmConstraint = POINTER TO RECORD tokpos: CARDINAL ; name : Name ; str : CARDINAL ; (* regnames or constraints *) obj : CARDINAL ; (* list of M2 syms *) END ; ModuleCtor = RECORD ctor: CARDINAL ; (* Procedure which will become a ctor. *) init: CARDINAL ; (* Module initialization block proc. *) fini: CARDINAL ; (* Module Finalization block proc. *) dep : CARDINAL ; (* Module dependency proc. *) END ; (* Each import list has a import statement symbol. *) SymImportStatement = RECORD listNo : CARDINAL ; (* The import list no. *) ListOfImports: List ; (* Vector of SymImports. *) at : Where ; (* The FROM or IMPORT token. *) END ; SymImport = RECORD module : CARDINAL ; (* The module imported. *) listNo : CARDINAL ; (* The import list no. *) qualified: BOOLEAN ; (* Is the complete module imported? *) at : Where ; (* token corresponding to the *) (* module name in the import. *) END ; SymEquiv = RECORD packedInfo: PackedInfo ; nonPacked : CARDINAL ; END ; SymOAFamily = RECORD MaxDimensions: CARDINAL ; SimpleType : CARDINAL ; Dimensions : Indexing.Index ; END ; SymTuple = RECORD At : Where ; nTuple: CARDINAL ; list : Indexing.Index ; END ; SymError = RECORD name : Name ; Scope : CARDINAL ; (* Scope of declaration. *) At : Where ; (* Where was sym declared/used *) END ; SymObject = RECORD name : Name ; At : Where ; (* Where was sym declared/used *) END ; SymUndefined = RECORD name : Name ; (* Index into name array, name *) (* of record. *) oafamily : CARDINAL ; (* The oafamily for this sym *) errorScope: ErrorScope ; (* Title scope used if an *) (* error is emitted. *) At : Where ; (* Where was sym declared/used *) END ; SymGnuAsm = RECORD String : CARDINAL ; (* (ConstString) the assembly *) (* instruction. *) At : Where ; (* Where was sym declared/used *) Inputs, Outputs, Trashed : CARDINAL ; (* The interface symbols. *) Volatile : BOOLEAN ; (* Declared as ASM VOLATILE ? *) Simple : BOOLEAN ; (* is a simple kind? *) END ; SymInterface = RECORD Parameters: Indexing.Index ; (* regnames or constraints *) (* list of M2 syms. *) At : Where ; (* Where was sym declared/used *) END ; SymVarient = RECORD Size : PtrToValue ; (* Size at runtime of symbol. *) ListOfSons : List ; (* ListOfSons contains a list *) (* of SymRecordField and *) (* SymVarients *) (* declared by the source *) (* file. *) DeclPacked : BOOLEAN ; (* Is this varient packed? *) DeclResolved: BOOLEAN ; (* has we resolved packed? *) Parent : CARDINAL ; (* Points to the parent symbol *) Varient : CARDINAL ; (* Index into symbol table to *) (* determine the associated *) (* varient symbol. *) tag : CARDINAL ; (* The tag of the varient *) (* this can either be a type *) (* or a varient field. *) Scope : CARDINAL ; (* Scope of declaration. *) At : Where ; (* Where was sym declared/used *) END ; SymRecord = RECORD name : Name ; (* Index into name array, name *) (* of record. *) LocalSymbols : SymbolTree ; (* Contains all record fields. *) Size : PtrToValue ; (* Size at runtime of symbol. *) ListOfSons : List ; (* ListOfSons contains a list *) (* of SymRecordField and *) (* SymVarients *) (* declared by the source *) (* file. *) Align : CARDINAL ; (* The alignment of this type. *) DefaultAlign : CARDINAL ; (* The default field alignment *) DeclPacked : BOOLEAN ; (* Is this record packed? *) DeclResolved : BOOLEAN ; (* has we resolved packed? *) oafamily : CARDINAL ; (* The oafamily for this sym. *) Parent : CARDINAL ; (* Points to the parent symbol *) Scope : CARDINAL ; (* Scope of declaration. *) At : Where ; (* Where was sym declared/used *) END ; SymSubrange = RECORD name : Name ; (* Index into name array, name *) (* of subrange. *) Low : CARDINAL ; (* Index to symbol for lower *) High : CARDINAL ; (* Index to symbol for higher *) Size : PtrToValue ; (* Size of subrange type. *) Type : CARDINAL ; (* Index to type symbol for *) (* the type of subrange. *) Align : CARDINAL ; (* Alignment for this type. *) ConstLitTree: SymbolTree ; (* constants of this type. *) packedInfo : PackedInfo ; (* the equivalent packed type *) oafamily : CARDINAL ; (* The oafamily for this sym *) Scope : CARDINAL ; (* Scope of declaration. *) At : Where ; (* Where was sym declared/used *) END ; SymEnumeration = RECORD name : Name ; (* Index into name array, name *) (* of enumeration. *) NoOfElements: CARDINAL ; (* No elements in enumeration *) LocalSymbols: SymbolTree ; (* Contains all enumeration *) (* fields (alphabetical). *) ListOfFields: List ; (* Ordered as declared. *) Size : PtrToValue ; (* Size at runtime of symbol. *) packedInfo : PackedInfo ; (* the equivalent packed type *) oafamily : CARDINAL ; (* The oafamily for this sym *) Scope : CARDINAL ; (* Scope of declaration. *) At : Where ; (* Where was sym declared/used *) END ; SymArray = RECORD name : Name ; (* Index into name array, name *) (* of array. *) Subscript : CARDINAL ; (* the subscript for this *) (* array. *) Size : PtrToValue ; (* Size at runtime of symbol. *) Offset : PtrToValue ; (* Offset at runtime of symbol *) Type : CARDINAL ; (* Type of the Array. *) Align : CARDINAL ; (* Alignment for this type. *) Large : BOOLEAN ; (* is this a large array? *) oafamily : CARDINAL ; (* The oafamily for this sym *) Scope : CARDINAL ; (* Scope of declaration. *) At : Where ; (* Where was sym declared/used *) END ; SymSubscript = RECORD Type : CARDINAL ; (* Index to a subrange symbol. *) Size : PtrToValue ; (* Size of this indice in*Size *) Offset : PtrToValue ; (* Offset at runtime of symbol *) (* Pseudo ie: Offset+Size*i *) (* 1..n. The array offset is *) (* the real memory offset. *) (* This offset allows the a[i] *) (* to be calculated without *) (* the need to perform *) (* subtractions when a[4..10] *) (* needs to be indexed. *) At : Where ; (* Where was sym declared/used *) END ; SymUnbounded = RECORD Type : CARDINAL ; (* Index to Simple type symbol *) Size : PtrToValue ;(* Max No of words ever *) (* passed to this type. *) RecordType : CARDINAL ; (* Record type used to *) (* implement the unbounded. *) Dimensions : CARDINAL ; (* No of dimensions this open array uses. *) Scope : CARDINAL ; (* Scope of declaration. *) At : Where ; (* Where was sym declared/used *) END ; SymPartialUnbounded = RECORD Type: CARDINAL ; (* Index to Simple type symbol *) NDim: CARDINAL ; (* dimensions associated *) END ; ProcedureDeclaration = RECORD ListOfParam : List ; (* Contains a list of all the *) (* parameters in this procedure. *) Defined : BOOLEAN ; (* Has the procedure been *) (* declared yet? *) ParamDefined : BOOLEAN ; (* Have the parameters been *) (* defined yet? *) HasVarArgs : BOOLEAN ; (* Does this procedure use ... ? *) HasOptArg : BOOLEAN ; (* Does this procedure use [ ] ? *) IsNoReturn : BOOLEAN ; (* Attribute noreturn ? *) ReturnOptional: BOOLEAN ; (* Is the return value optional? *) ReturnTypeTok, ProcedureTok : CARDINAL ; (* Token pos of procedure name. *) END ; SymProcedure = RECORD name : Name ; (* Index into name array, name *) (* of procedure. *) Decl : ARRAY ProcedureKind OF ProcedureDeclaration ; OptArgInit : CARDINAL ; (* The optarg initial value. *) IsExtern : BOOLEAN ; (* Make this procedure extern. *) IsPublic : BOOLEAN ; (* Make this procedure visible. *) IsCtor : BOOLEAN ; (* Is this procedure a ctor? *) IsMonoName : BOOLEAN ; (* Ignores module name prefix. *) BuildProcType : BOOLEAN ; (* Are we building the *) (* associated proctype? *) Unresolved : SymbolTree ; (* All symbols currently *) (* unresolved in this procedure. *) ScopeQuad : CARDINAL ; (* Index into quads for scope *) StartQuad : CARDINAL ; (* Index into quads for start *) (* of procedure. *) EndQuad : CARDINAL ; (* Index into quads for end of *) (* procedure. *) Reachable : BOOLEAN ; (* Defines if procedure will *) (* ever be called by the main *) (* Module. *) SavePriority : BOOLEAN ; (* Does procedure need to save *) (* and restore interrupts? *) ReturnType : CARDINAL ; (* Return type for function. *) ProcedureType : CARDINAL ; (* Proc type for this procedure. *) IsBuiltin : BOOLEAN ; (* Was it declared __BUILTIN__ ? *) BuiltinName : Name ; (* name of equivalent builtin *) IsInline : BOOLEAN ; (* Was it declared __INLINE__ ? *) LocalSymbols: SymbolTree ; (* Contains all symbols declared *) (* within this procedure. *) EnumerationScopeList: List ; (* Enumeration scope list which *) (* contains a list of all *) (* enumerations which are *) (* visable within this scope. *) ListOfVars : List ; (* List of variables in this *) (* scope. *) ListOfProcs : List ; (* List of all procedures *) (* declared within this *) (* procedure. *) NamedObjects : SymbolTree ; (* Names of all items declared. *) Size : PtrToValue ; (* Activation record size. *) TotalParamSize: PtrToValue ; (* size of all parameters. *) ExceptionFinally, ExceptionBlock: BOOLEAN ; (* does it have an exception? *) Scope : CARDINAL ; (* Scope of declaration. *) errorScope : ErrorScope ; (* The title scope. *) ListOfModules : List ; (* List of all inner modules. *) Begin, End : CARDINAL ; (* Tokens marking the BEGIN END *) At : Where ; (* Where was sym declared/used *) END ; SymProcType = RECORD name : Name ; (* Index into name array, name *) (* of procedure. *) ListOfParam : List ; (* Contains a list of all the *) (* parameters in this procedure. *) HasVarArgs : BOOLEAN ; (* Does this proc type use ... ? *) HasOptArg : BOOLEAN ; (* Does this procedure use [ ] ? *) OptArgInit : CARDINAL ; (* The optarg initial value. *) ReturnType : CARDINAL ; (* Return type for function. *) ReturnOptional: BOOLEAN ; (* Is the return value optional? *) ReturnTypeTok : CARDINAL ; (* Token of return type. *) Scope : CARDINAL ; (* Scope of declaration. *) Size : PtrToValue ; (* Runtime size of symbol. *) TotalParamSize: PtrToValue ; (* size of all parameters. *) oafamily : CARDINAL ; (* The oafamily for this sym *) At : Where ; (* Where was sym declared/used *) END ; SymParam = RECORD name : Name ; (* Index into name array, name *) (* of param. *) Type : CARDINAL ; (* Index to the type of param. *) IsUnbounded : BOOLEAN ; (* Is it an ARRAY OF Type? *) ShadowVar : CARDINAL ; (* The local variable used to *) (* shadow this parameter. *) At : Where ; (* Where was sym declared/used *) END ; SymVarParam = RECORD name : Name ; (* Index into name array, name *) (* of param. *) Type : CARDINAL ;(* Index to the type of param. *) IsUnbounded : BOOLEAN ; (* Is it an ARRAY OF Type? *) HeapVar : CARDINAL ;(* The pointer value on heap. *) (* Only used by static *) (* analysis. *) ShadowVar : CARDINAL ;(* The local variable used to *) (* shadow this parameter. *) At : Where ; (* Where was sym declared/used *) END ; ConstStringVariant = (m2str, cstr, m2nulstr, cnulstr) ; SymConstString = RECORD name : Name ; (* Index into name array, name *) (* of const. *) Contents : Name ; (* Contents of the string. *) Length : CARDINAL ; (* StrLen (Contents) *) StringVariant : ConstStringVariant ; Known : BOOLEAN ; (* Is Contents known? *) Scope : CARDINAL ; (* Scope of declaration. *) At : Where ; (* Where was sym declared/used *) END ; SymConstLit = RECORD name : Name ; (* Index into name array, name *) (* of const. *) Value : PtrToValue ; (* Value of the constant. *) Type : CARDINAL ; (* TYPE of constant, char etc *) IsSet : BOOLEAN ; (* is the constant a set? *) IsConstructor: BOOLEAN ; (* is it a constructor? *) IsInternal : BOOLEAN ; (* Generated internally? *) FromType : CARDINAL ; (* type is determined FromType *) RangeError : BOOLEAN ; (* Have we reported an error? *) UnresFromType: BOOLEAN ; (* is Type unresolved? *) Scope : CARDINAL ; (* Scope of declaration. *) At : Where ; (* Where was sym declared/used *) END ; SymConstVar = RECORD name : Name ; (* Index into name array, name *) (* of const. *) Value : PtrToValue ; (* Value of the constant *) Type : CARDINAL ; (* TYPE of constant, char etc *) IsConditional, (* Is it the result of a *) (* boolean conditional? *) IsSet : BOOLEAN ; (* is the constant a set? *) IsConstructor: BOOLEAN ; (* is the constant a set? *) FromType : CARDINAL ; (* type is determined FromType *) UnresFromType: BOOLEAN ; (* is Type resolved? *) IsTemp : BOOLEAN ; (* is it a temporary? *) Scope : CARDINAL ; (* Scope of declaration. *) At : Where ; (* Where was sym declared/used *) END ; SymVar = RECORD name : Name ; (* Index into name array, name *) (* of const. *) Type : CARDINAL ; (* Index to a type symbol. *) BackType : CARDINAL ; (* specific back end symbol. *) Size : PtrToValue ; (* Runtime size of symbol. *) Offset : PtrToValue ; (* Offset at runtime of symbol *) AddrMode : ModeOfAddr ; (* Type of Addressing mode. *) Scope : CARDINAL ; (* Scope of declaration. *) AtAddress : BOOLEAN ; (* Is declared at address? *) Address : CARDINAL ; (* Address at which declared *) IsComponentRef: BOOLEAN ; (* Is temporary referencing a *) (* record field? *) list : Indexing.Index ; (* the record and fields *) IsConditional, IsTemp : BOOLEAN ; (* Is variable a temporary? *) IsParam : BOOLEAN ; (* Is variable a parameter? *) IsPointerCheck: BOOLEAN ; (* Is variable used to *) (* dereference a pointer? *) IsWritten : BOOLEAN ; (* Is variable written to? *) IsSSA : BOOLEAN ; (* Is variable a SSA? *) IsConst : BOOLEAN ; (* Is variable read/only? *) ArrayRef : BOOLEAN ; (* Is variable used to point *) (* to an array? *) Heap : BOOLEAN ; (* Is var on the heap? *) InitState : LRInitDesc ; (* Initialization state. *) Declared : VarDecl ; (* Var and type tokens. *) At : Where ; (* Where was sym declared/used *) ReadUsageList, (* list of var read quads *) WriteUsageList: LRLists ; (* list of var write quads *) END ; SymType = RECORD name : Name ; (* Index into name array, name *) (* of type. *) Type : CARDINAL ; (* Index to a type symbol. *) IsHidden : BOOLEAN ; (* Was it declared as hidden? *) ConstLitTree: SymbolTree ; (* constants of this type. *) Size : PtrToValue ; (* Runtime size of symbol. *) packedInfo : PackedInfo ; (* the equivalent packed type *) oafamily : CARDINAL ; (* The oafamily for this sym *) Align : CARDINAL ; (* The alignment of this type *) Scope : CARDINAL ; (* Scope of declaration. *) At : Where ; (* Where was sym declared/used *) END ; SymPointer = RECORD name : Name ; (* Index into name array, name *) (* of pointer. *) Type : CARDINAL ; (* Index to a type symbol. *) Size : PtrToValue ; (* Runtime size of symbol. *) Align : CARDINAL ; (* The alignment of this type *) ConstLitTree: SymbolTree ; (* constants of this type. *) oafamily : CARDINAL ; (* The oafamily for this sym *) Scope : CARDINAL ; (* Scope of declaration. *) At : Where ; (* Where was sym declared/used *) END ; SymRecordField = RECORD name : Name ; (* Index into name array, name *) (* of record field. *) Type : CARDINAL ; (* Index to a type symbol. *) Tag : BOOLEAN ; (* is the record field really *) (* a varient tag? *) Size : PtrToValue ; (* Runtime size of symbol. *) Offset : PtrToValue ; (* Offset at runtime of symbol *) Parent : CARDINAL ; (* Index into symbol table to *) (* determine the parent symbol *) (* for this record field. Used *) (* for BackPatching. *) Varient : CARDINAL ; (* Index into symbol table to *) (* determine the associated *) (* varient symbol. *) Align : CARDINAL ; (* The alignment of this type *) Used : BOOLEAN ; (* pragma usused unsets this. *) DeclPacked: BOOLEAN ; (* Is this declared packed? *) DeclResolved: BOOLEAN ; (* has we resolved packed? *) Scope : CARDINAL ; (* Scope of declaration. *) At : Where ; (* Where was sym declared/used *) END ; SymVarientField = RECORD name : Name ; (* Index into name array, name *) (* of varient field (internal) *) Size : PtrToValue ; (* Runtime size of symbol. *) Offset : PtrToValue ; (* Offset at runtime of symbol *) Parent : CARDINAL ; (* Index into symbol table to *) (* determine the parent symbol *) (* for this record field. Used *) (* for BackPatching. *) Varient : CARDINAL ; (* Index into symbol table to *) (* determine the associated *) (* varient symbol. *) ListOfSons: List ; (* Contains a list of the *) (* RecordField symbols and *) (* SymVarients *) DeclPacked: BOOLEAN ; (* Is this varient field *) (* packed? *) DeclResolved: BOOLEAN ; (* is it resolved? *) Scope : CARDINAL ; (* Scope of declaration. *) At : Where ; (* Where was sym declared/used *) END ; SymEnumerationField = RECORD name : Name ; (* Index into name array, name *) (* of enumeration field. *) Value : PtrToValue ; (* Enumeration field value. *) Type : CARDINAL ; (* Index to the enumeration. *) Scope : CARDINAL ; (* Scope of declaration. *) At : Where ; (* Where was sym declared/used *) END ; SymSet = RECORD name : Name ; (* Index into name array, name *) (* of set. *) Type : CARDINAL ; (* Index to a type symbol. *) (* (subrange or enumeration). *) packedInfo: PackedInfo ; (* the equivalent packed type *) ispacked : BOOLEAN ; Size : PtrToValue ; (* Runtime size of symbol. *) oafamily : CARDINAL ; (* The oafamily for this sym *) Scope : CARDINAL ; (* Scope of declaration. *) At : Where ; (* Where was sym declared/used *) END ; SymDefImp = RECORD name : Name ; (* Index into name array, name *) (* of record field. *) libname : Name ; (* Library (dialect) with module *) ctors : ModuleCtor ; (* All the ctor functions. *) DefListOfDep, ModListOfDep : List ; (* Vector of SymDependency. *) ExportQualifiedTree: SymbolTree ; (* Holds all the export *) (* Qualified identifiers. *) (* This tree may be *) (* deleted at the end of Pass 1. *) ExportUnQualifiedTree: SymbolTree ; (* Holds all the export *) (* UnQualified identifiers. *) (* This tree may be *) (* deleted at the end of Pass 1. *) ExportRequest : SymbolTree ; (* Contains all identifiers that *) (* have been requested by other *) (* modules before this module *) (* declared its export list. *) (* This tree should be empty at *) (* the end of the compilation. *) (* Each time a symbol is *) (* exported it is removed from *) (* this list. *) IncludeList : List ; (* Contains all included symbols *) (* which are included by *) (* IMPORT modulename ; *) (* modulename.Symbol *) DefIncludeList: List ; (* Contains all included symbols *) (* which are included by *) (* IMPORT modulename ; *) (* in the definition module only *) ImportTree : SymbolTree ; (* Contains all IMPORTed *) (* identifiers. *) ExportUndeclared: SymbolTree ; (* ExportUndeclared contains all *) (* the identifiers which were *) (* exported but have not yet *) (* been declared. *) NeedToBeImplemented: SymbolTree ; (* NeedToBeImplemented contains *) (* the identifiers which have *) (* been exported and declared *) (* but have not yet been *) (* implemented. *) LocalSymbols : SymbolTree ; (* The LocalSymbols hold all the *) (* variables declared local to *) (* the block. It contains the *) (* IMPORT r ; *) (* FROM _ IMPORT x, y, x ; *) (* and also *) (* MODULE WeAreHere ; *) (* x y z visible by localsym *) (* MODULE Inner ; *) (* EXPORT x, y, z ; *) (* END Inner ; *) (* END WeAreHere. *) EnumerationScopeList: List ; (* Enumeration scope list which *) (* contains a list of all *) (* enumerations which are *) (* visible within this scope. *) NamedObjects : SymbolTree ; (* Names of all items declared. *) NamedImports : SymbolTree ; (* Names of items imported. *) WhereImported : SymbolTree ; (* Sym to TokenNo where import *) (* occurs. Error message use. *) Priority : CARDINAL ; (* Priority of the module. This *) (* is an index to a constant. *) Unresolved : SymbolTree ; (* All symbols currently *) (* unresolved in this module. *) StartQuad : CARDINAL ; (* Signify the initialization *) (* code. *) EndQuad : CARDINAL ; (* EndQuad should point to a *) (* goto quad. *) StartFinishQuad: CARDINAL ; (* Signify the finalization *) (* code. *) EndFinishQuad : CARDINAL ; (* should point to a finish *) FinallyFunction: tree ; (* The GCC function for finally *) ExceptionFinally, ExceptionBlock: BOOLEAN ; (* does it have an exception? *) ContainsHiddenType: BOOLEAN ;(* True if this module *) (* implements a hidden type. *) ContainsBuiltin: BOOLEAN ; (* Does the module define a *) (* builtin procedure? *) ForC : BOOLEAN ; (* Is it a definition for "C" *) NeedExportList: BOOLEAN ; (* Must user supply export list? *) ModLink, (* Is the Def/Mod module parsed *) DefLink : BOOLEAN ; (* for linkage only? *) Builtin : BOOLEAN ; (* Is the module builtin? *) ListOfVars : List ; (* List of variables in this *) (* scope. *) ListOfProcs : List ; (* List of all procedures *) (* declared within this module. *) ListOfModules : List ; (* List of all inner modules. *) errorScope : ErrorScope ; (* The title scope. *) At : Where ; (* Where was sym declared/used *) END ; SymModule = RECORD name : Name ; (* Index into name array, name *) (* of record field. *) libname : Name ; (* Library (dialect) with module *) ctors : ModuleCtor ; (* All the ctor functions. *) ModListOfDep : List ; (* Vector of SymDependency. *) LocalSymbols : SymbolTree ; (* The LocalSymbols hold all the *) (* variables declared local to *) (* the block. It contains the *) (* IMPORT r ; *) (* FROM _ IMPORT x, y, x ; *) (* and also *) (* MODULE WeAreHere ; *) (* x y z visible by localsym *) (* MODULE Inner ; *) (* EXPORT x, y, z ; *) (* END Inner ; *) (* END WeAreHere. *) ExportTree : SymbolTree ; (* Holds all the exported *) (* identifiers. *) (* This tree may be *) (* deleted at the end of Pass 1. *) IncludeList : List ; (* Contains all included symbols *) (* which are included by *) (* IMPORT modulename ; *) (* modulename.Symbol *) ImportTree : SymbolTree ; (* Contains all IMPORTed *) (* identifiers. *) ExportUndeclared: SymbolTree ; (* ExportUndeclared contains all *) (* the identifiers which were *) (* exported but have not yet *) (* been declared. *) EnumerationScopeList: List ; (* Enumeration scope list which *) (* contains a list of all *) (* enumerations which are *) (* visable within this scope. *) NamedObjects : SymbolTree ; (* Names of all items declared. *) NamedImports : SymbolTree ; (* Names of items imported. *) WhereImported : SymbolTree ; (* Sym to TokenNo where import *) (* occurs. Error message use. *) Scope : CARDINAL ; (* Scope of declaration. *) Priority : CARDINAL ; (* Priority of the module. This *) (* is an index to a constant. *) Unresolved : SymbolTree ; (* All symbols currently *) (* unresolved in this module. *) StartQuad : CARDINAL ; (* Signify the initialization *) (* code. *) EndQuad : CARDINAL ; (* EndQuad should point to a *) (* goto quad. *) StartFinishQuad: CARDINAL ; (* Signify the finalization *) (* code. *) EndFinishQuad : CARDINAL ; (* should point to a finish *) FinallyFunction: tree ; (* The GCC function for finally *) ExceptionFinally, ExceptionBlock: BOOLEAN ; (* does it have an exception? *) ModLink : BOOLEAN ; (* Is the module parsed for *) (* linkage only? *) Builtin : BOOLEAN ; (* Is the module builtin? *) ListOfVars : List ; (* List of variables in this *) (* scope. *) ListOfProcs : List ; (* List of all procedures *) (* declared within this module. *) ListOfModules : List ; (* List of all inner modules. *) errorScope : ErrorScope ; (* The title scope. *) At : Where ; (* Where was sym declared/used *) END ; SymDummy = RECORD NextFree : CARDINAL ; (* Link to the next free symbol. *) END ; Symbol = RECORD CASE SymbolType : TypeOfSymbol OF (* Determines the type of symbol *) OAFamilySym : OAFamily : SymOAFamily | ObjectSym : Object : SymObject | EquivSym : Equiv : SymEquiv | RecordSym : Record : SymRecord | VarientSym : Varient : SymVarient | VarSym : Var : SymVar | EnumerationSym : Enumeration : SymEnumeration | SubrangeSym : Subrange : SymSubrange | SubscriptSym : Subscript : SymSubscript | ArraySym : Array : SymArray | UnboundedSym : Unbounded : SymUnbounded | PartialUnboundedSym : PartialUnbounded : SymPartialUnbounded | ConstVarSym : ConstVar : SymConstVar | ConstLitSym : ConstLit : SymConstLit | ConstStringSym : ConstString : SymConstString | VarParamSym : VarParam : SymVarParam | ParamSym : Param : SymParam | ErrorSym : Error : SymError | UndefinedSym : Undefined : SymUndefined | TypeSym : Type : SymType | PointerSym : Pointer : SymPointer | RecordFieldSym : RecordField : SymRecordField | VarientFieldSym : VarientField : SymVarientField | EnumerationFieldSym : EnumerationField : SymEnumerationField | DefImpSym : DefImp : SymDefImp | ModuleSym : Module : SymModule | SetSym : Set : SymSet | ProcedureSym : Procedure : SymProcedure | ProcTypeSym : ProcType : SymProcType | ImportStatementSym : ImportStatement : SymImportStatement | ImportSym : Import : SymImport | GnuAsmSym : GnuAsm : SymGnuAsm | InterfaceSym : Interface : SymInterface | TupleSym : Tuple : SymTuple | DummySym : Dummy : SymDummy END END ; CallFrame = RECORD Main : CARDINAL ; (* Main scope for insertions *) Search: CARDINAL ; (* Search scope for symbol searches *) Start : CARDINAL ; (* ScopePtr value before StartScope *) (* was called. *) END ; PtrToSymbol = POINTER TO Symbol ; PtrToCallFrame = POINTER TO CallFrame ; CheckProcedure = PROCEDURE (CARDINAL) ; VAR Symbols : Indexing.Index ; (* ARRAY [1..MaxSymbols] OF Symbol. *) ScopeCallFrame: Indexing.Index ; (* ARRAY [1..MaxScopes] OF CallFrame. *) FreeSymbol : CARDINAL ; (* The next free symbol indice. *) DefModuleTree : SymbolTree ; ModuleTree : SymbolTree ; (* Tree of all modules ever used. *) CurrentModule : CARDINAL ; (* Index into symbols determining the *) (* current module being compiled. *) (* This maybe an inner module. *) MainModule : CARDINAL ; (* Index into symbols determining the *) (* module the user requested to *) (* compile. *) FileModule : CARDINAL ; (* Index into symbols determining *) (* which module (file) is being *) (* compiled. (Maybe an import def) *) ScopePtr : CARDINAL ; (* An index to the ScopeCallFrame. *) (* ScopePtr determines the top of the *) (* ScopeCallFrame. *) BaseScopePtr : CARDINAL ; (* An index to the ScopeCallFrame of *) (* the top of BaseModule. BaseModule *) (* is always left at the bottom of *) (* stack since it is used so *) (* frequently. When the BaseModule *) (* needs to be searched the ScopePtr *) (* is temporarily altered to *) (* BaseScopePtr and GetScopeSym is *) (* called. *) BaseModule : CARDINAL ; (* Index to the symbol table of the *) (* Base pseudo modeule declaration. *) TemporaryNo : CARDINAL ; (* The next temporary number. *) CurrentError : Error ; (* Current error chain. *) AddressTypes : List ; (* A list of type symbols which must *) (* be declared as ADDRESS or pointer *) UnresolvedConstructorType: List ; (* all constructors whose type *) (* is not yet known. *) AnonymousName : CARDINAL ; (* anonymous type name unique id *) ReportedUnknowns : Set ; (* set of symbols already reported as *) (* unknowns to the user. *) ConstLitPoolTree : SymbolTree ; (* Pool of constants to ensure *) (* constants are reused between *) (* passes and reduce duplicate *) (* errors. *) ConstLitArray : Indexing.Index ; (* CheckAnonymous - checks to see whether the name is NulName and if so it creates a unique anonymous name. *) PROCEDURE CheckAnonymous (name: Name) : Name ; BEGIN IF name = NulName THEN INC (AnonymousName) ; name := makekey (string (Mark (Sprintf1 (Mark (InitString ('__anon%d')), AnonymousName)))) END ; RETURN name END CheckAnonymous ; (* IsNameAnonymous - returns TRUE if the symbol, sym, has an anonymous name or no name. *) PROCEDURE IsNameAnonymous (sym: CARDINAL) : BOOLEAN ; VAR a: ARRAY [0..5] OF CHAR ; n: Name ; BEGIN n := GetSymName(sym) ; IF n=NulName THEN RETURN( TRUE ) ELSE GetKey(n, a) ; RETURN( StrEqual(a, '__anon') ) END END IsNameAnonymous ; (* InitWhereDeclared - sets the Declared and FirstUsed fields of record, at. *) PROCEDURE InitWhereDeclaredTok (tok: CARDINAL; VAR at: Where) ; BEGIN WITH at DO IF CompilingDefinitionModule () THEN DefDeclared := tok ; ModDeclared := UnknownTokenNo ELSE DefDeclared := UnknownTokenNo ; ModDeclared := tok END ; FirstUsed := tok (* we assign this field to something legal *) END END InitWhereDeclaredTok ; (* InitWhereDeclared - sets the Declared and FirstUsed fields of record, at. *) PROCEDURE InitWhereDeclared (VAR at: Where) ; BEGIN InitWhereDeclaredTok (GetTokenNo (), at) END InitWhereDeclared ; (* InitWhereFirstUsed - sets the FirstUsed field of record, at. *) PROCEDURE InitWhereFirstUsed (VAR at: Where) ; BEGIN InitWhereFirstUsedTok (GetTokenNo (), at) END InitWhereFirstUsed ; (* InitWhereFirstUsedTok - sets the FirstUsed field of record, at. *) PROCEDURE InitWhereFirstUsedTok (tok: CARDINAL; VAR at: Where) ; BEGIN WITH at DO FirstUsed := tok END END InitWhereFirstUsedTok ; (* FinalSymbol - returns the highest number symbol used. *) PROCEDURE FinalSymbol () : CARDINAL ; BEGIN RETURN( FreeSymbol-1 ) END FinalSymbol ; (* stop - a debugger convenience hook. *) PROCEDURE stop ; END stop ; (* NewSym - Sets Sym to a new symbol index. *) PROCEDURE NewSym (VAR sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN sym := FreeSymbol ; NEW(pSym) ; WITH pSym^ DO SymbolType := DummySym END ; PutIndice(Symbols, sym, pSym) ; IF sym = BreakSym THEN stop END ; INC(FreeSymbol) END NewSym ; (* GetPsym - returns the pointer to, sym. *) PROCEDURE GetPsym (sym: CARDINAL) : PtrToSymbol ; VAR pSym: PtrToSymbol ; BEGIN IF InBounds(Symbols, sym) THEN pSym := GetIndice(Symbols, sym) ; RETURN( pSym ) ELSE InternalError ('symbol out of bounds') END END GetPsym ; (* GetPcall - returns the pointer to the CallFrame. *) PROCEDURE GetPcall (call: CARDINAL) : PtrToCallFrame ; VAR pCall: PtrToCallFrame ; BEGIN IF InBounds(ScopeCallFrame, call) THEN pCall := GetIndice(ScopeCallFrame, call) ; RETURN( pCall ) ELSE InternalError ('symbol out of bounds') END END GetPcall ; (* MakeImport - create and return an import symbol. moduleSym is the symbol being imported. isqualified is FALSE if it were IMPORT modulename and TRUE for the qualified FROM modulename IMPORT etc. listno is the import list count for this module. tok should match this modulename position. *) PROCEDURE MakeImport (tok: CARDINAL; moduleSym: CARDINAL; listno: CARDINAL; isqualified: BOOLEAN) : CARDINAL ; VAR importSym: CARDINAL ; pSym : PtrToSymbol ; BEGIN NewSym (importSym) ; pSym := GetPsym (importSym) ; WITH pSym^ DO SymbolType := ImportSym ; WITH Import DO module := moduleSym ; listNo := listno ; qualified := isqualified ; InitWhereDeclaredTok (tok, at) END END ; RETURN importSym END MakeImport ; (* MakeImportStatement - return a dependent symbol which represents an import statement or a qualified import statement. The tok should either match the FROM token or the IMPORT token. listno is the import list count for the module. *) PROCEDURE MakeImportStatement (tok: CARDINAL; listno: CARDINAL) : CARDINAL ; VAR dependentSym: CARDINAL ; pSym : PtrToSymbol ; BEGIN NewSym (dependentSym) ; pSym := GetPsym (dependentSym) ; WITH pSym^ DO SymbolType := ImportStatementSym ; WITH ImportStatement DO listNo := listno ; InitList (ListOfImports) ; InitWhereDeclaredTok (tok, at) END END ; RETURN dependentSym END MakeImportStatement ; (* AppendModuleImportStatement - appends the ImportStatement symbol onto the module import list. For example: FROM x IMPORT y, z ; ^^^^ also: IMPORT p, q, r; ^^^^^^ will result in a new ImportStatement symbol added to the current module import list. The statement symbol is expected to be created by MakeImportStatement using the token positions outlined above. *) PROCEDURE AppendModuleImportStatement (module, statement: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN IF IsDefImp (module) THEN pSym := GetPsym (module) ; IF CompilingDefinitionModule () THEN IncludeItemIntoList (pSym^.DefImp.DefListOfDep, statement) ELSE IncludeItemIntoList (pSym^.DefImp.ModListOfDep, statement) END ELSIF IsModule (module) THEN pSym := GetPsym (module) ; IncludeItemIntoList (pSym^.Module.ModListOfDep, statement) ELSE InternalError ('expecting DefImp or Module symbol') END END AppendModuleImportStatement ; (* AppendModuleOnImportStatement - appends the import symbol onto the dependent list (chain). For example each: FROM x IMPORT y, z ; ^ x are added to the dependent list. also: IMPORT p, q, r; ^ ^ ^ will result in p, q and r added to to the dependent list. The import symbol is created by MakeImport and the token is expected to match the module name position outlined above. *) PROCEDURE AppendModuleOnImportStatement (module, import: CARDINAL) ; VAR l : List ; lastImportStatement: CARDINAL ; BEGIN Assert (IsImport (import)) ; IF CompilingDefinitionModule () THEN l := GetModuleDefImportStatementList (module) ELSE l := GetModuleModImportStatementList (module) END ; Assert (l # NIL) ; Assert (NoOfItemsInList (l) > 0) ; (* There should always be one on the list. *) lastImportStatement := GetItemFromList (l, NoOfItemsInList (l)) ; Assert (IsImportStatement (lastImportStatement)) ; l := GetImportStatementList (lastImportStatement) ; IncludeItemIntoList (l, import) END AppendModuleOnImportStatement ; (* IsImport - returns TRUE if sym is an import symbol. *) PROCEDURE IsImport (sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (sym) ; RETURN pSym^.SymbolType=ImportSym END IsImport ; (* IsImportStatement - returns TRUE if sym is a dependent symbol. *) PROCEDURE IsImportStatement (sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (sym) ; RETURN pSym^.SymbolType=ImportStatementSym END IsImportStatement ; (* GetImportModule - returns the module associated with the import symbol. *) PROCEDURE GetImportModule (sym: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN Assert (IsImport (sym)) ; pSym := GetPsym (sym) ; RETURN pSym^.Import.module END GetImportModule ; (* GetImportDeclared - returns the token associated with the import symbol. *) PROCEDURE GetImportDeclared (sym: CARDINAL) : CARDINAL ; VAR tok : CARDINAL ; BEGIN Assert (IsImport (sym)) ; tok := GetDeclaredDefinition (sym) ; IF tok = UnknownTokenNo THEN RETURN GetDeclaredModule (sym) END ; RETURN tok END GetImportDeclared ; (* GetImportStatementList - returns the list of imports for this dependent. Each import symbol corresponds to a module. *) PROCEDURE GetImportStatementList (sym: CARDINAL) : List ; VAR pSym: PtrToSymbol ; BEGIN Assert (IsImportStatement (sym)) ; pSym := GetPsym (sym) ; RETURN pSym^.ImportStatement.ListOfImports END GetImportStatementList ; (* GetModuleDefImportStatementList - returns the list of dependents associated with the definition module. *) PROCEDURE GetModuleDefImportStatementList (sym: CARDINAL) : List ; VAR pSym: PtrToSymbol ; BEGIN Assert (IsModule (sym) OR IsDefImp (sym)) ; IF IsDefImp (sym) THEN pSym := GetPsym (sym) ; RETURN pSym^.DefImp.DefListOfDep END ; RETURN NIL END GetModuleDefImportStatementList ; (* GetModuleModImportStatementList - returns the list of dependents associated with the implementation or program module. *) PROCEDURE GetModuleModImportStatementList (sym: CARDINAL) : List ; VAR pSym: PtrToSymbol ; BEGIN Assert (IsModule (sym) OR IsDefImp (sym)) ; pSym := GetPsym (sym) ; IF IsDefImp (sym) THEN RETURN pSym^.DefImp.ModListOfDep ELSE RETURN pSym^.Module.ModListOfDep END END GetModuleModImportStatementList ; (* DebugProcedureLineNumber - *) PROCEDURE DebugProcedureLineNumber (sym: CARDINAL) ; VAR begin, end: CARDINAL ; n : Name ; f : String ; l : CARDINAL ; BEGIN GetProcedureBeginEnd (sym, begin, end) ; n := GetSymName(sym) ; IF begin#0 THEN f := FindFileNameFromToken (begin, 0) ; l := TokenToLineNo(begin, 0) ; printf3 ('%s:%d:%a:begin\n', f, l, n) END ; IF end#0 THEN f := FindFileNameFromToken (end, 0) ; l := TokenToLineNo(end, 0) ; printf3 ('%s:%d:%a:end\n', f, l, n) END END DebugProcedureLineNumber ; (* DebugLineNumbers - internal debugging, emit all procedure names in this module together with the line numbers for the corresponding begin/end tokens. *) PROCEDURE DebugLineNumbers (sym: CARDINAL) ; BEGIN IF GetDebugFunctionLineNumbers () THEN printf0 ('\n') ; ForeachProcedureDo(sym, DebugProcedureLineNumber) ; printf0 ('\n') END END DebugLineNumbers ; (* IsPartialUnbounded - returns TRUE if, sym, is a partially unbounded symbol. *) PROCEDURE IsPartialUnbounded (sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN IF sym>0 THEN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF PartialUnboundedSym: RETURN( TRUE ) ELSE RETURN( FALSE ) END END ELSE RETURN( FALSE ) END END IsPartialUnbounded ; (* PutPartialUnbounded - *) PROCEDURE PutPartialUnbounded (sym: CARDINAL; type: CARDINAL; ndim: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(sym) ; IF IsDummy(sym) THEN pSym^.SymbolType := PartialUnboundedSym END ; WITH pSym^ DO CASE SymbolType OF PartialUnboundedSym: PartialUnbounded.Type := type ; PartialUnbounded.NDim := ndim ELSE InternalError ('not expecting this type') END END END PutPartialUnbounded ; (* AlreadyDeclaredError - generate an error message, a, and two areas of code showing the places where the symbols were declared. *) PROCEDURE AlreadyDeclaredError (s: String; name: Name; OtherOccurance: CARDINAL) ; VAR e: Error ; BEGIN IF (OtherOccurance=0) OR (OtherOccurance=GetTokenNo()) THEN e := NewError(GetTokenNo()) ; ErrorString(e, s) ELSE e := NewError(GetTokenNo()) ; ErrorString(e, s) ; e := ChainError(OtherOccurance, e) ; ErrorFormat1(e, 'and symbol (%a) is also declared here', name) END END AlreadyDeclaredError ; (* AlreadyImportedError - generate an error message, a, and two areas of code showing the places where the symbols was imported and also declared. *) (* PROCEDURE AlreadyImportedError (s: String; name: Name; OtherOccurance: CARDINAL) ; VAR e: Error ; BEGIN IF (OtherOccurance=0) OR (OtherOccurance=GetTokenNo()) THEN e := NewError(GetTokenNo()) ; ErrorString(e, s) ELSE e := NewError(GetTokenNo()) ; ErrorString(e, s) ; e := ChainError(OtherOccurance, e) ; ErrorFormat1(e, 'and symbol (%a) was also seen here', name) END END AlreadyImportedError ; *) (* MakeError - creates an error node, which can be used in MetaError messages. It will be removed from ExportUndeclared and Unknown trees. *) PROCEDURE MakeError (tok: CARDINAL; name: Name) : CARDINAL ; VAR pSym: PtrToSymbol ; Sym : CARDINAL ; BEGIN (* if Sym is present on the unknown tree then remove it *) Sym := FetchUnknownSym (name) ; IF Sym=NulSym THEN NewSym(Sym) ELSE (* remove symbol from this tree as we have already generated a meaningful error message *) RemoveExportUndeclared(GetCurrentModuleScope(), Sym) END ; pSym := GetPsym(Sym) ; WITH pSym^ DO SymbolType := ErrorSym ; Error.name := name ; Error.Scope := GetCurrentScope () ; InitWhereDeclaredTok(tok, Error.At) ; InitWhereFirstUsedTok(tok, Error.At) END ; RETURN( Sym ) END MakeError ; (* MakeErrorS - creates an error node from a string, which can be used in MetaError messages. It will be removed from ExportUndeclared and Unknown trees. *) PROCEDURE MakeErrorS (tok: CARDINAL; name: String) : CARDINAL ; BEGIN RETURN MakeError (tok, makekey (string (name))) END MakeErrorS ; (* IsError - returns TRUE if the symbol is an error symbol. *) PROCEDURE IsError (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN AssertInRange(Sym) ; pSym := GetPsym(Sym) ; RETURN( pSym^.SymbolType=ErrorSym ) END IsError ; (* MakeObject - creates an object node. *) PROCEDURE MakeObject (name: Name) : CARDINAL ; VAR pSym: PtrToSymbol ; Sym : CARDINAL ; BEGIN NewSym(Sym) ; pSym := GetPsym(Sym) ; WITH pSym^ DO SymbolType := ObjectSym ; Object.name := name ; InitWhereDeclared(Object.At) ; InitWhereFirstUsed(Object.At) END ; RETURN( Sym ) END MakeObject ; (* IsTuple - returns TRUE if the symbol is a tuple symbol. *) PROCEDURE IsTuple (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN AssertInRange(Sym) ; pSym := GetPsym(Sym) ; RETURN( pSym^.SymbolType=TupleSym ) END IsTuple ; (* IsObject - returns TRUE if the symbol is an object symbol. *) PROCEDURE IsObject (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN AssertInRange(Sym) ; pSym := GetPsym(Sym) ; RETURN( pSym^.SymbolType=ObjectSym ) END IsObject ; (* DeclareSym - returns a symbol which was either in the unknown tree or a New symbol, since name is about to be declared. *) PROCEDURE DeclareSym (tok: CARDINAL; name: Name) : CARDINAL ; VAR Sym: CARDINAL ; BEGIN IF name = NulName THEN NewSym (Sym) ELSIF IsAlreadyDeclaredSym (name) THEN Sym := GetSym (name) ; IF IsImported (GetCurrentModuleScope (), Sym) THEN MetaErrorT1 (GetWhereImported(Sym), 'symbol {%1Rad} is already present in this scope, check both definition and implementation modules, use a different name or remove the import', Sym) ; MetaErrorT1 (tok, 'symbol {%1Cad} also declared in this module', Sym) ; IF Sym # GetVisibleSym (name) THEN MetaErrorT1 (tok, 'symbol {%1CMad} also declared in this module', GetVisibleSym (name)) END ELSE MetaErrorT1 (tok, 'symbol {%1RMad} is already declared in this scope, use a different name or remove the declaration', Sym) ; MetaErrorT1 (tok, 'symbol {%1Cad} also declared in this module', Sym) ; IF Sym # GetVisibleSym(name) THEN MetaErrorT1(tok, 'symbol {%1CMad} also declared in this module', GetVisibleSym (name)) END END ; Sym := MakeError (tok, name) ELSE Sym := FetchUnknownSym (name) ; IF Sym=NulSym THEN NewSym (Sym) END ; CheckForExportedDeclaration (Sym) END ; RETURN Sym END DeclareSym ; (* Init - Initializes the data structures and variables in this module. Initialize the trees. *) PROCEDURE Init ; VAR pCall: PtrToCallFrame ; BEGIN AnonymousName := 0 ; CurrentError := NIL ; InitTree (ConstLitPoolTree) ; InitTree (DefModuleTree) ; InitTree (ModuleTree) ; Symbols := InitIndexTuned (1, 1024*1024 DIV 16, 16) ; ConstLitArray := InitIndex (1) ; FreeSymbol := 1 ; ScopePtr := 1 ; ScopeCallFrame := InitIndex(1) ; NEW(pCall) ; WITH pCall^ DO Main := NulSym ; Search := NulSym END ; PutIndice(ScopeCallFrame, ScopePtr, pCall) ; CurrentModule := NulSym ; MainModule := NulSym ; FileModule := NulSym ; TemporaryNo := 0 ; (* InitList(FreeFVarientList) ; (* Lists used to maintain GC of field *) InitList(UsedFVarientList) ; (* varients. *) *) InitList(UnresolvedConstructorType) ; InitBase(BuiltinsLocation(), BaseModule) ; StartScope(BaseModule) ; (* BaseModule scope placed at the bottom of the stack *) BaseScopePtr := ScopePtr ; (* BaseScopePtr points to the top of the BaseModule scope *) InitList(AddressTypes) ; ReportedUnknowns := InitSet(1) END Init ; (* FromModuleGetSym - attempts to find a symbol of name, n, in the module, mod, scope. An unknown symbol is created at token position tok if necessary. *) PROCEDURE FromModuleGetSym (tok: CARDINAL; n: Name; mod: CARDINAL) : CARDINAL ; VAR n1 : Name ; sym : CARDINAL ; OldScopePtr: CARDINAL ; BEGIN OldScopePtr := ScopePtr ; StartScope (mod) ; sym := RequestSym (tok, n) ; EndScope ; IF sym=NulSym THEN (* --fixme-- can sym ever be NulSym? *) n1 := GetSymName(mod) ; WriteFormat2('cannot find procedure %a in module, %a', n, n1) END ; ScopePtr := OldScopePtr ; RETURN( sym ) END FromModuleGetSym ; (* AddSymToUnknown - *) PROCEDURE AddSymToUnknown (scope: CARDINAL; name: Name; Sym: CARDINAL) ; VAR pSym: PtrToSymbol ; n : Name ; BEGIN IF DebugUnknowns THEN n := GetSymName(scope) ; printf3('adding unknown %a (%d) to scope %a\n', name, Sym, n) END ; (* Add symbol to unknown tree *) pSym := GetPsym(scope) ; WITH pSym^ DO CASE SymbolType OF DefImpSym : PutSymKey(DefImp.Unresolved, name, Sym) | ModuleSym : PutSymKey(Module.Unresolved, name, Sym) | ProcedureSym: PutSymKey(Procedure.Unresolved, name, Sym) ELSE InternalError ('expecting DefImp, Module or Procedure symbol') END END END AddSymToUnknown ; (* AddSymToUnknownTree - adds a symbol with name, name, and Sym to the unknown tree. *) PROCEDURE AddSymToUnknownTree (ScopeId: INTEGER; name: Name; Sym: CARDINAL) ; VAR pCall : PtrToCallFrame ; ScopeSym: CARDINAL ; BEGIN IF ScopeId>0 THEN (* choose to place the unknown symbol in the first module scope outside the current scope *) REPEAT pCall := GetPcall(ScopeId) ; ScopeSym := pCall^.Main ; IF (ScopeSym>0) AND (IsDefImp(ScopeSym) OR IsModule(ScopeSym)) THEN AddSymToUnknown(ScopeSym, name, Sym) ; RETURN END ; DEC(ScopeId) UNTIL ScopeId=0 END ; AddSymToUnknown(CurrentModule, name, Sym) END AddSymToUnknownTree ; (* SubSymFromUnknownTree - removes a symbol with name, name, from the unknown tree. *) PROCEDURE SubSymFromUnknownTree (name: Name) ; VAR pCall : PtrToCallFrame ; ScopeSym, ScopeId : CARDINAL ; BEGIN IF ScopePtr>0 THEN ScopeId := ScopePtr ; REPEAT pCall := GetPcall(ScopeId) ; ScopeSym := pCall^.Search ; IF IsModule(ScopeSym) OR IsDefImp(ScopeSym) OR IsProcedure(ScopeSym) THEN IF RemoveFromUnresolvedTree(ScopeSym, name) THEN RETURN END END ; DEC(ScopeId) ; UNTIL (ScopeId>0) AND (IsModule(ScopeSym) OR IsDefImp(ScopeSym)) END ; IF RemoveFromUnresolvedTree(CurrentModule, name) THEN END END SubSymFromUnknownTree ; (* GetSymFromUnknownTree - returns a symbol with name, name, from the unknown tree. If no symbol with name is found then NulSym is returned. *) PROCEDURE GetSymFromUnknownTree (name: Name) : CARDINAL ; VAR pCall : PtrToCallFrame ; ScopeSym, ScopeId , Sym : CARDINAL ; BEGIN IF ScopePtr>0 THEN ScopeId := ScopePtr ; REPEAT pCall := GetPcall(ScopeId) ; ScopeSym := pCall^.Search ; IF IsModule(ScopeSym) OR IsDefImp(ScopeSym) OR IsProcedure(ScopeSym) THEN Sym := ExamineUnresolvedTree(ScopeSym, name) ; IF Sym#NulSym THEN RETURN( Sym ) END END ; DEC(ScopeId) ; UNTIL (ScopeId>0) AND (IsModule(ScopeSym) OR IsDefImp(ScopeSym)) END ; (* Get symbol from unknown tree *) RETURN( ExamineUnresolvedTree(CurrentModule, name) ) END GetSymFromUnknownTree ; (* ExamineUnresolvedTree - returns a symbol with name, name, from the unresolved tree of module, ModSym. If no symbol with name is found then NulSym is returned. *) PROCEDURE ExamineUnresolvedTree (ScopeSym: CARDINAL; name: Name) : CARDINAL ; VAR pSym: PtrToSymbol ; Sym : CARDINAL ; BEGIN (* Get symbol from unknown tree *) pSym := GetPsym(ScopeSym) ; WITH pSym^ DO CASE SymbolType OF DefImpSym : Sym := GetSymKey(DefImp.Unresolved, name) | ModuleSym : Sym := GetSymKey(Module.Unresolved, name) | ProcedureSym: Sym := GetSymKey(Procedure.Unresolved, name) ELSE InternalError ('expecting DefImp, Module or Procedure symbol') END END ; RETURN( Sym ) END ExamineUnresolvedTree ; (* TryMoveUndeclaredSymToInnerModule - attempts to move a symbol of name, name, which is currently undefined in the outer scope to the inner scope. If successful then the symbol is returned otherwise NulSym is returned. *) PROCEDURE TryMoveUndeclaredSymToInnerModule (OuterScope, InnerScope: CARDINAL; name: Name) : CARDINAL ; VAR pSym: PtrToSymbol ; sym : CARDINAL ; BEGIN (* assume this should not be called if OuterScope was a procedure as this case is handled by the caller (P1SymBuild) *) Assert(IsModule(OuterScope) OR IsDefImp(OuterScope)) ; sym := GetExportUndeclared(OuterScope, name) ; IF sym#NulSym THEN Assert(IsUnknown(sym)) ; RemoveExportUndeclared(OuterScope, sym) ; AddSymToModuleScope(OuterScope, sym) ; AddVarToScopeList(OuterScope, sym) ; pSym := GetPsym(OuterScope) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: IF GetSymKey(DefImp.Unresolved, name)=sym THEN DelSymKey(DefImp.Unresolved, name) END | ModuleSym: IF GetSymKey(Module.Unresolved, name)=sym THEN DelSymKey(Module.Unresolved, name) END ELSE InternalError ('expecting DefImp, Module symbol') END END ; AddSymToUnknown(InnerScope, name, sym) ; PutExportUndeclared(InnerScope, sym) END ; RETURN( sym ) END TryMoveUndeclaredSymToInnerModule ; (* RemoveFromUnresolvedTree - removes a symbol with name, name, from the unresolved tree of symbol, ScopeSym. *) PROCEDURE RemoveFromUnresolvedTree (ScopeSym: CARDINAL; name: Name) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN (* Get symbol from unknown tree *) pSym := GetPsym(ScopeSym) ; WITH pSym^ DO CASE SymbolType OF DefImpSym : IF GetSymKey(DefImp.Unresolved, name)#NulKey THEN DelSymKey(DefImp.Unresolved, name) ; RETURN( TRUE ) END | ModuleSym : IF GetSymKey(Module.Unresolved, name)#NulKey THEN DelSymKey(Module.Unresolved, name) ; RETURN( TRUE ) END | ProcedureSym: IF GetSymKey(Procedure.Unresolved, name)#NulKey THEN DelSymKey(Procedure.Unresolved, name) ; RETURN( TRUE ) END ELSE InternalError ('expecting DefImp, Module or Procedure symbol') END END ; RETURN( FALSE ) END RemoveFromUnresolvedTree ; (* FetchUnknownSym - returns a symbol from the unknown tree if one is available. It also updates the unknown tree. *) PROCEDURE FetchUnknownSym (name: Name) : CARDINAL ; VAR Sym: CARDINAL ; BEGIN Sym := GetSymFromUnknownTree(name) ; IF Sym#NulSym THEN SubSymFromUnknownTree(name) END ; RETURN( Sym ) END FetchUnknownSym ; (* TransparentScope - returns true is the scope symbol Sym is allowed to look to an outer level for a symbol. ie is the symbol allowed to look to the parent scope for a symbol. *) PROCEDURE TransparentScope (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO RETURN( (SymbolType#DefImpSym) AND (SymbolType#ModuleSym) ) END END TransparentScope ; (* AddSymToModuleScope - adds a symbol, Sym, to the scope of the module ModSym. *) PROCEDURE AddSymToModuleScope (ModSym: CARDINAL; Sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(ModSym) ; WITH pSym^ DO CASE SymbolType OF DefImpSym : IF GetSymKey(DefImp.LocalSymbols, GetSymName(Sym))=NulKey THEN PutSymKey(DefImp.LocalSymbols, GetSymName(Sym), Sym) ELSE MetaError1 ('{%kIMPORT} name clash with symbol {%1Ead} symbol already declared ', Sym) END | ModuleSym : IF GetSymKey(Module.LocalSymbols, GetSymName(Sym))=NulKey THEN PutSymKey(Module.LocalSymbols, GetSymName(Sym), Sym) ELSE MetaError1 ('{%kIMPORT} name clash with symbol {%1Ead} symbol already declared ', Sym) END | ProcedureSym: IF GetSymKey(Procedure.LocalSymbols, GetSymName(Sym))=NulKey THEN PutSymKey(Procedure.LocalSymbols, GetSymName(Sym), Sym) ELSE MetaError1 ('{%kIMPORT} name clash with symbol {%1Ead} symbol already declared ', Sym) END ELSE InternalError ('expecting Module or DefImp symbol') END END END AddSymToModuleScope ; (* GetCurrentModuleScope - returns the module symbol which forms the current (possibly inner most) module. *) PROCEDURE GetCurrentModuleScope () : CARDINAL ; VAR pCall: PtrToCallFrame ; i : CARDINAL ; BEGIN i := ScopePtr ; pCall := GetPcall(i) ; WHILE (NOT IsModule(pCall^.Search)) AND (NOT IsDefImp(pCall^.Search)) DO Assert(i>0) ; DEC(i) ; pCall := GetPcall(i) END ; RETURN( pCall^.Search ) END GetCurrentModuleScope ; (* GetLastModuleScope - returns the last module scope encountered, the module scope before the Current Module Scope. *) PROCEDURE GetLastModuleScope () : CARDINAL ; VAR pCall: PtrToCallFrame ; i : CARDINAL ; BEGIN i := ScopePtr ; pCall := GetPcall(i) ; WHILE (NOT IsModule(pCall^.Search)) AND (NOT IsDefImp(pCall^.Search)) DO Assert(i>0) ; DEC(i) ; pCall := GetPcall(i) END ; (* Found module at position, i. *) DEC(i) ; (* Move to an outer level module scope *) pCall := GetPcall(i) ; WHILE (NOT IsModule(pCall^.Search)) AND (NOT IsDefImp(pCall^.Search)) DO Assert(i>0) ; DEC(i) ; pCall := GetPcall(i) END ; (* Found module at position, i. *) RETURN( pCall^.Search ) END GetLastModuleScope ; (* GetLastModuleOrProcedureScope - returns the last module or procedure scope encountered, the scope before the current module scope. *) PROCEDURE GetLastModuleOrProcedureScope () : CARDINAL ; VAR pCall: PtrToCallFrame ; i : CARDINAL ; BEGIN (* find current inner module *) i := ScopePtr ; pCall := GetPcall(i) ; WHILE (NOT IsModule(pCall^.Search)) AND (NOT IsDefImp(pCall^.Search)) DO Assert(i>0) ; DEC(i) ; pCall := GetPcall(i) END ; (* found module at position, i. *) DEC(i) ; (* Move to an outer level module or procedure scope *) pCall := GetPcall(i) ; WHILE (NOT IsModule(pCall^.Search)) AND (NOT IsDefImp(pCall^.Search)) AND (NOT IsProcedure(pCall^.Search)) DO Assert(i>0) ; DEC(i) ; pCall := GetPcall(i) END ; (* Found module at position, i. *) RETURN( pCall^.Search ) END GetLastModuleOrProcedureScope ; (* AddSymToScope - adds a symbol Sym with name name to the current scope symbol tree. *) PROCEDURE AddSymToScope (Sym: CARDINAL; name: Name) ; VAR pSym : PtrToSymbol ; pCall : PtrToCallFrame ; ScopeId: CARDINAL ; BEGIN pCall := GetPcall(ScopePtr) ; ScopeId := pCall^.Main ; (* WriteString('Adding ') ; WriteKey(name) ; WriteString(' :') ; WriteCard(Sym, 4) ; WriteString(' to scope: ') ; WriteKey(GetSymName(ScopeId)) ; WriteLn ; *) pSym := GetPsym(ScopeId) ; WITH pSym^ DO CASE SymbolType OF DefImpSym : IF name#NulName THEN PutSymKey(DefImp.LocalSymbols, name, Sym) END ; IF IsEnumeration(Sym) THEN CheckEnumerationInList(DefImp.EnumerationScopeList, Sym) END | ModuleSym : IF name#NulName THEN PutSymKey(Module.LocalSymbols, name, Sym) END ; IF IsEnumeration(Sym) THEN CheckEnumerationInList(Module.EnumerationScopeList, Sym) END | ProcedureSym: IF name#NulName THEN PutSymKey(Procedure.LocalSymbols, name, Sym) END ; IF IsEnumeration(Sym) THEN CheckEnumerationInList(Procedure.EnumerationScopeList, Sym) END ELSE InternalError ('should never get here') END END END AddSymToScope ; (* GetCurrentScope - returns the symbol who is responsible for the current scope. Note that it ignore pseudo scopes. *) PROCEDURE GetCurrentScope () : CARDINAL ; VAR pCall: PtrToCallFrame ; BEGIN pCall := GetPcall(ScopePtr) ; RETURN( pCall^.Main ) END GetCurrentScope ; (* StartScope - starts a block scope at Sym. Transparent determines whether the search for a symbol will look at the previous ScopeCallFrame if Sym does not contain the symbol that GetSym is searching. WITH statements are partially implemented by calling StartScope. Therefore we must retain the old Main from the previous ScopePtr when a record is added to the scope stack. (Main contains the symbol where all identifiers should be added.) *) PROCEDURE StartScope (Sym: CARDINAL) ; VAR oCall, pCall: PtrToCallFrame ; BEGIN Sym := SkipType(Sym) ; (* WriteString('New scope is: ') ; WriteKey(GetSymName(Sym)) ; WriteLn ; *) INC(ScopePtr) ; IF InBounds(ScopeCallFrame, ScopePtr) THEN pCall := GetPcall(ScopePtr) ELSE NEW(pCall) ; PutIndice(ScopeCallFrame, ScopePtr, pCall) END ; WITH pCall^ DO Start := ScopePtr-1 ; (* Previous ScopePtr value before StartScope *) Search := Sym ; (* If Sym is a record then maintain the old Main scope for adding *) (* new symbols to ie temporary variables. *) IF IsRecord(Sym) THEN oCall := GetPcall(ScopePtr-1) ; Main := oCall^.Main ELSE Main := Sym ; PlaceMajorScopesEnumerationListOntoStack(Sym) END END (* ; DisplayScopes *) END StartScope ; (* PlaceMajorScopesEnumerationListOntoStack - places the DefImp, Module and Procedure symbols enumeration list onto the scope stack. *) PROCEDURE PlaceMajorScopesEnumerationListOntoStack (Sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF DefImpSym : PlaceEnumerationListOntoScope(DefImp.EnumerationScopeList) | ModuleSym : PlaceEnumerationListOntoScope(Module.EnumerationScopeList) | ProcedureSym: PlaceEnumerationListOntoScope(Procedure.EnumerationScopeList) ELSE InternalError ('expecting - DefImp, Module or Procedure symbol') END END END PlaceMajorScopesEnumerationListOntoStack ; (* PlaceEnumerationListOntoScope - places an enumeration list, l, onto the scope stack. This list will automatically removed via one call to EndScope which matches the StartScope by which this procedure is invoked. *) PROCEDURE PlaceEnumerationListOntoScope (l: List) ; VAR i, n: CARDINAL ; BEGIN n := NoOfItemsInList(l) ; i := 1 ; WHILE i<=n DO PseudoScope(GetItemFromList(l, i)) ; INC(i) END END PlaceEnumerationListOntoScope ; (* EndScope - ends a block scope started by StartScope. The current head of the symbol scope reverts back to the symbol which was the Head of the symbol scope before the last StartScope was called. *) PROCEDURE EndScope ; VAR pCall: PtrToCallFrame ; BEGIN (* ; WriteString('EndScope - ending scope: ') ; pCall := GetPcall(ScopePtr) ; ; WriteKey(GetSymName(pCall^.Search)) ; WriteLn ; *) pCall := GetPcall(ScopePtr) ; ScopePtr := pCall^.Start (* ; DisplayScopes *) END EndScope ; (* PseudoScope - starts a pseudo scope at Sym. We always connect parent up to the last scope, to determine the transparancy of a scope we call TransparentScope. A Pseudo scope has no end block, but is terminated when the next EndScope is used. The function of the pseudo scope is to provide an automatic mechanism to solve enumeration types. A declared enumeration type is a Pseudo scope and identifiers used with the name of an enumeration type field will find the enumeration symbol by the scoping algorithm. *) PROCEDURE PseudoScope (Sym: CARDINAL) ; VAR oCall, pCall: PtrToCallFrame ; BEGIN IF IsEnumeration(Sym) THEN INC(ScopePtr) ; IF InBounds(ScopeCallFrame, ScopePtr) THEN pCall := GetPcall(ScopePtr) ELSE NEW(pCall) ; PutIndice(ScopeCallFrame, ScopePtr, pCall) END ; WITH pCall^ DO oCall := GetPcall(ScopePtr-1) ; Main := oCall^.Main ; Start := oCall^.Start ; Search := Sym END ELSE InternalError ('expecting EnumerationSym') END END PseudoScope ; (* IsDeclaredIn - returns TRUE if a symbol was declared in, scope. *) PROCEDURE IsDeclaredIn (scope, sym: CARDINAL) : BOOLEAN ; VAR s: CARDINAL ; BEGIN s := GetScope(sym) ; WHILE s#scope DO IF (s=NulSym) OR IsProcedure(s) OR IsModule(s) OR IsDefImp(s) THEN RETURN( FALSE ) ELSE s := GetScope(s) END END ; RETURN( TRUE ) END IsDeclaredIn ; (* SetFirstUsed - assigns the FirstUsed field in at to tok providing it has not already been set. *) PROCEDURE SetFirstUsed (tok: CARDINAL; VAR at: Where) ; BEGIN IF at.FirstUsed = UnknownTokenNo THEN at.FirstUsed := tok END END SetFirstUsed ; (* PutFirstUsed - sets tok to the first used providing it has not already been set. It also includes the read and write quad into the usage list providing the quad numbers are not 0. *) PROCEDURE PutFirstUsed (object: CARDINAL; tok: CARDINAL; read, write: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN IF IsVar (object) THEN pSym := GetPsym (object) ; SetFirstUsed (tok, pSym^.Var.At) ; IF read # 0 THEN PutReadQuad (object, GetMode (object), read) END ; IF write # 0 THEN PutWriteQuad (object, GetMode (object), write) END END END PutFirstUsed ; (* MakeGnuAsm - create a GnuAsm symbol. *) PROCEDURE MakeGnuAsm () : CARDINAL ; VAR pSym: PtrToSymbol ; Sym : CARDINAL ; BEGIN NewSym(Sym) ; pSym := GetPsym (Sym) ; WITH pSym^ DO SymbolType := GnuAsmSym ; WITH GnuAsm DO String := NulSym ; InitWhereDeclared (At) ; Inputs := NulSym ; Outputs := NulSym ; Trashed := NulSym ; Volatile := FALSE ; Simple := FALSE END END ; RETURN( Sym ) END MakeGnuAsm ; (* PutGnuAsm - places the instruction textual name into the GnuAsm symbol. *) PROCEDURE PutGnuAsm (sym: CARDINAL; string: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN Assert (IsConstString (string)) ; pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF GnuAsmSym: GnuAsm.String := string ELSE InternalError ('expecting PutGnuAsm symbol') END END END PutGnuAsm ; (* GetGnuAsm - returns the string symbol, representing the instruction textual of the GnuAsm symbol. It will return a ConstString. *) PROCEDURE GetGnuAsm (sym: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF GnuAsmSym: RETURN GnuAsm.String ELSE InternalError ('expecting GnuAsm symbol') END END END GetGnuAsm ; (* PutGnuAsmOutput - places the interface object, out, into GnuAsm symbol, sym. *) PROCEDURE PutGnuAsmOutput (sym: CARDINAL; out: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF GnuAsmSym: GnuAsm.Outputs := out ELSE InternalError ('expecting PutGnuAsm symbol') END END END PutGnuAsmOutput ; (* PutGnuAsmInput - places the interface object, in, into GnuAsm symbol, sym. *) PROCEDURE PutGnuAsmInput (sym: CARDINAL; in: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF GnuAsmSym: GnuAsm.Inputs := in ELSE InternalError ('expecting PutGnuAsm symbol') END END END PutGnuAsmInput ; (* PutGnuAsmTrash - places the interface object, trash, into GnuAsm symbol, sym. *) PROCEDURE PutGnuAsmTrash (sym: CARDINAL; trash: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF GnuAsmSym: GnuAsm.Trashed := trash ELSE InternalError ('expecting PutGnuAsm symbol') END END END PutGnuAsmTrash ; (* GetGnuAsmInput - returns the input list of registers. *) PROCEDURE GetGnuAsmInput (sym: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF GnuAsmSym: RETURN GnuAsm.Inputs ELSE InternalError ('expecting PutGnuAsm symbol') END END END GetGnuAsmInput ; (* GetGnuAsmOutput - returns the output list of registers. *) PROCEDURE GetGnuAsmOutput (sym: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF GnuAsmSym: RETURN GnuAsm.Outputs ELSE InternalError ('expecting PutGnuAsm symbol') END END END GetGnuAsmOutput ; (* GetGnuAsmTrash - returns the list of trashed registers. *) PROCEDURE GetGnuAsmTrash (sym: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF GnuAsmSym: RETURN GnuAsm.Trashed ELSE InternalError ('expecting PutGnuAsm symbol') END END END GetGnuAsmTrash ; (* PutGnuAsmVolatile - defines a GnuAsm symbol as VOLATILE. *) PROCEDURE PutGnuAsmVolatile (Sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (Sym) ; WITH pSym^ DO CASE SymbolType OF GnuAsmSym: GnuAsm.Volatile := TRUE ELSE InternalError ('expecting GnuAsm symbol') END END END PutGnuAsmVolatile ; (* PutGnuAsmSimple - defines a GnuAsm symbol as a simple kind. *) PROCEDURE PutGnuAsmSimple (Sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (Sym) ; WITH pSym^ DO CASE SymbolType OF GnuAsmSym: GnuAsm.Simple := TRUE ELSE InternalError ('expecting GnuAsm symbol') END END END PutGnuAsmSimple ; (* MakeRegInterface - creates and returns a register interface symbol. *) PROCEDURE MakeRegInterface () : CARDINAL ; VAR pSym: PtrToSymbol ; Sym : CARDINAL ; BEGIN NewSym (Sym) ; pSym := GetPsym (Sym) ; WITH pSym^ DO SymbolType := InterfaceSym ; WITH Interface DO Parameters := InitIndex (1) ; InitWhereDeclared (At) END END ; RETURN( Sym ) END MakeRegInterface ; (* PutRegInterface - places a, name, string, and, object, into the interface array, sym, at position, i. The string symbol will either be a register name or a constraint. The object is an optional Modula-2 variable or constant symbol. read and write are the quadruple numbers representing any read or write operation. *) PROCEDURE PutRegInterface (tok: CARDINAL; sym: CARDINAL; i: CARDINAL; n: Name; string, object: CARDINAL; read, write: CARDINAL) ; VAR pSym : PtrToSymbol ; p : PtrToAsmConstraint ; BEGIN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF InterfaceSym: IF Indexing.InBounds(Interface.Parameters, i) THEN p := Indexing.GetIndice(Interface.Parameters, i) ELSIF i=Indexing.HighIndice(Interface.Parameters)+1 THEN NEW(p) ; Indexing.PutIndice(Interface.Parameters, i, p) ELSE InternalError ('expecting to add parameters sequentially') END ; WITH p^ DO tokpos := tok ; name := n ; str := string ; obj := object END ; PutFirstUsed (object, tok, read, write) ELSE InternalError ('expecting Interface symbol') END END END PutRegInterface ; (* GetRegInterface - gets a, name, string, and, object, from the interface array, sym, from position, i. *) PROCEDURE GetRegInterface (sym: CARDINAL; i: CARDINAL; VAR tok: CARDINAL; VAR n: Name; VAR string, object: CARDINAL) ; VAR pSym: PtrToSymbol ; p : PtrToAsmConstraint ; BEGIN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF InterfaceSym: IF Indexing.InBounds(Interface.Parameters, i) THEN p := Indexing.GetIndice(Interface.Parameters, i) ; WITH p^ DO tok := tokpos ; n := name ; string := str ; object := obj END ELSE tok := UnknownTokenNo ; n := NulName ; string := NulSym ; object := NulSym END ELSE InternalError ('expecting Interface symbol') END END END GetRegInterface ; (* GetSubrange - returns HighSym and LowSym - two constants which make up the subrange. *) PROCEDURE GetSubrange (Sym: CARDINAL; VAR HighSym, LowSym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF SubrangeSym: HighSym := Subrange.High ; LowSym := Subrange.Low ELSE InternalError ('expecting Subrange symbol') END END END GetSubrange ; (* PutSubrange - places LowSym and HighSym as two symbols which provide the limits of the range. *) PROCEDURE PutSubrange (Sym: CARDINAL; LowSym, HighSym: CARDINAL; TypeSymbol: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF SubrangeSym: Subrange.Low := LowSym ; (* Index to symbol for lower *) Subrange.High := HighSym ; (* Index to symbol for higher *) Subrange.Type := TypeSymbol ; (* Index to type symbol for *) (* the type of subrange. *) ELSE InternalError ('expecting Subrange symbol') END END END PutSubrange ; (* SetCurrentModule - Used to set the CurrentModule to a symbol, Sym. This Sym must represent the module name of the file currently being compiled. *) PROCEDURE SetCurrentModule (Sym: CARDINAL) ; BEGIN CurrentModule := Sym END SetCurrentModule ; (* GetCurrentModule - returns the current module Sym that is being compiled. *) PROCEDURE GetCurrentModule () : CARDINAL ; BEGIN RETURN( CurrentModule ) END GetCurrentModule ; (* SetMainModule - Used to set the MainModule to a symbol, Sym. This Sym must represent the main module which was envoked by the user to be compiled. *) PROCEDURE SetMainModule (Sym: CARDINAL) ; BEGIN MainModule := Sym END SetMainModule ; (* GetMainModule - returns the main module symbol that was requested by the user to be compiled. *) PROCEDURE GetMainModule () : CARDINAL ; BEGIN RETURN( MainModule ) END GetMainModule ; (* SetFileModule - Used to set the FileModule to a symbol, Sym. This Sym must represent the current program module file which is being parsed. *) PROCEDURE SetFileModule (Sym: CARDINAL) ; BEGIN FileModule := Sym END SetFileModule ; (* GetFileModule - returns the FileModule symbol that was requested by the user to be compiled. *) PROCEDURE GetFileModule () : CARDINAL ; BEGIN RETURN( FileModule ) END GetFileModule ; (* GetBaseModule - returns the base module symbol that contains Modula-2 base types, procedures and functions. *) PROCEDURE GetBaseModule () : CARDINAL ; BEGIN RETURN( BaseModule ) END GetBaseModule ; (* GetSym - searches the current scope (and previous scopes if the scope tranparent allows) for a symbol with name. *) PROCEDURE GetSym (name: Name) : CARDINAL ; VAR Sym : CARDINAL ; OldScopePtr: CARDINAL ; BEGIN Sym := GetScopeSym(name, TRUE) ; IF Sym=NulSym THEN (* Check default base types for symbol *) OldScopePtr := ScopePtr ; (* Save ScopePtr *) ScopePtr := BaseScopePtr ; (* Alter ScopePtr to point to top of BaseModule *) Sym := GetScopeSym(name, FALSE) ; (* Search BaseModule for name *) ScopePtr := OldScopePtr (* Restored ScopePtr *) END ; RETURN( Sym ) END GetSym ; (* CanLookThroughScope - by default this procedure returns TRUE. It only returns FALSE if, throughProcedure, is FALSE and the ScopeSym is a procedure. *) PROCEDURE CanLookThroughScope (ScopeSym: CARDINAL; throughProcedure: BOOLEAN) : BOOLEAN ; BEGIN IF IsProcedure(ScopeSym) THEN RETURN( throughProcedure ) ELSE RETURN( TRUE ) END END CanLookThroughScope ; (* GetScopeSym - searches the current scope and below, providing that the scopes are transparent, for a symbol with name, name. It only passes over procedure scopes if, throughProcedure, is TRUE. *) PROCEDURE GetScopeSym (name: Name; throughProcedure: BOOLEAN) : CARDINAL ; VAR pCall : PtrToCallFrame ; ScopeSym, ScopeId , Sym : CARDINAL ; BEGIN (* DisplayScopes ; *) ScopeId := ScopePtr ; pCall := GetPcall(ScopeId) ; ScopeSym := pCall^.Search ; (* WriteString(' scope: ') ; WriteKey(GetSymName(ScopeSym)) ; *) Sym := CheckScopeForSym(ScopeSym, name) ; WHILE (ScopeId>0) AND (Sym=NulSym) AND TransparentScope(ScopeSym) AND CanLookThroughScope(ScopeSym, throughProcedure) DO DEC(ScopeId) ; pCall := GetPcall(ScopeId) ; ScopeSym := pCall^.Search ; Sym := CheckScopeForSym(ScopeSym, name) ; (* WriteString(' scope: ') ; WriteKey(GetSymName(ScopeSym)) *) END ; (* IF Sym#NulSym THEN WriteKey(GetSymName(Sym)) END ; WriteLn ; *) RETURN( Sym ) END GetScopeSym ; (* CheckScopeForSym - checks the scope, ScopeSym, for an identifier of name, name. CheckScopeForSym checks for the symbol by the GetLocalSym and also ExamineUnresolvedTree. *) PROCEDURE CheckScopeForSym (ScopeSym: CARDINAL; name: Name) : CARDINAL ; VAR Sym: CARDINAL ; BEGIN Sym := GetLocalSym(ScopeSym, name) ; IF (Sym=NulSym) AND (IsModule(ScopeSym) OR IsDefImp(ScopeSym) OR IsProcedure(ScopeSym)) THEN Sym := ExamineUnresolvedTree(ScopeSym, name) END ; RETURN( Sym ) END CheckScopeForSym ; (* DisplayScopes - displays the scopes that will be searched to find a requested symbol. *) (* PROCEDURE DisplayScopes ; VAR pCall: PtrToCallFrame ; n : Name ; i : CARDINAL ; Sym : CARDINAL ; BEGIN i := ScopePtr ; printf0('Displaying scopes\n') ; WHILE i>=1 DO pCall := GetPcall(i) ; Sym := pCall^.Search ; printf1('Symbol %4d', Sym) ; IF Sym#NulSym THEN n := GetSymName(Sym) ; printf1(' : name %a is ', n) ; IF NOT TransparentScope(Sym) THEN printf0('not') END ; printf0(' transparent\n') END ; DEC(i) END ; printf0('\n') END DisplayScopes ; *) (* GetModuleScopeId - returns the scope index to the next module starting at index, Id. Id will either point to a null scope (NulSym) or alternatively point to a Module or DefImp symbol. *) PROCEDURE GetModuleScopeId (Id: CARDINAL) : CARDINAL ; VAR pCall: PtrToCallFrame ; s : CARDINAL ; BEGIN pCall := GetPcall(Id) ; s := pCall^.Search ; WHILE (Id>0) AND (s#NulSym) AND ((NOT IsModule(s)) AND (NOT IsDefImp(s))) DO DEC(Id) ; pCall := GetPcall(Id) ; s := pCall^.Search ; END ; RETURN( Id ) END GetModuleScopeId ; (* GetVisibleSym - *) PROCEDURE GetVisibleSym (name: Name) : CARDINAL ; VAR pCall: PtrToCallFrame ; Sym, i : CARDINAL ; BEGIN i := ScopePtr ; WHILE i>=1 DO pCall := GetPcall(i) ; WITH pCall^ DO IF Search=Main THEN RETURN( GetLocalSym(Main, name) ) ELSE IF IsEnumeration(Search) THEN Sym := GetLocalSym(Search, name) ; IF Sym#NulSym THEN RETURN( Sym ) END END END END ; DEC(i) END ; RETURN( NulSym ) END GetVisibleSym ; (* IsAlreadyDeclaredSym - returns true if Sym has already been declared in the current main scope. *) PROCEDURE IsAlreadyDeclaredSym (name: Name) : BOOLEAN ; VAR pCall: PtrToCallFrame ; i : CARDINAL ; BEGIN i := ScopePtr ; WHILE i>=1 DO pCall := GetPcall(i) ; WITH pCall^ DO IF Search=Main THEN RETURN( GetLocalSym(Main, name)#NulSym ) ELSE IF IsEnumeration(Search) AND (GetLocalSym(Search, name)#NulSym) THEN RETURN( TRUE ) END END END ; DEC(i) END ; RETURN( FALSE ) END IsAlreadyDeclaredSym ; (* IsImplicityExported - returns TRUE if, Sym, is implicitly exported from module, ModSym. ModSym must be a defimp symbol. *) PROCEDURE IsImplicityExported (ModSym, Sym: CARDINAL) : BOOLEAN ; VAR type: CARDINAL ; pSym: PtrToSymbol ; BEGIN IF IsDefImp(ModSym) AND IsFieldEnumeration(Sym) THEN pSym := GetPsym(ModSym) ; type := SkipType(GetType(Sym)) ; RETURN( IsItemInList(pSym^.DefImp.EnumerationScopeList, type) ) END ; RETURN( FALSE ) END IsImplicityExported ; (* MakeProcedureCtorExtern - creates an extern ctor procedure *) PROCEDURE MakeProcedureCtorExtern (tokenno: CARDINAL; libname, modulename: Name) : CARDINAL ; VAR ctor: CARDINAL ; BEGIN ctor := MakeProcedure (tokenno, GenName (libname, '_M2_', modulename, '_ctor')) ; PutExtern (ctor, TRUE) ; RETURN ctor END MakeProcedureCtorExtern ; (* GenName - returns a new name consisting of pre, name, post concatenation. *) PROCEDURE GenName (libname: Name; pre: ARRAY OF CHAR; name: Name; post: ARRAY OF CHAR) : Name ; VAR str : String ; result: Name ; BEGIN str := InitStringCharStar (KeyToCharStar (libname)) ; str := ConCat (str, Mark (InitString (pre))) ; str := ConCat (str, Mark (InitStringCharStar (KeyToCharStar (name)))) ; str := ConCat (str, InitString (post)) ; result := makekey (string (str)) ; str := KillString (str) ; RETURN result END GenName ; (* InitCtor - initialize the ModuleCtor fields to NulSym. *) PROCEDURE InitCtor (VAR ctor: ModuleCtor) ; BEGIN ctor.ctor := NulSym ; ctor.dep := NulSym ; ctor.init := NulSym ; ctor.fini := NulSym END InitCtor ; (* MakeModuleCtor - for a defimp or module symbol create all the ctor related procedures. *) PROCEDURE MakeModuleCtor (moduleTok, beginTok, finallyTok: CARDINAL; moduleSym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN Assert (IsDefImp (moduleSym) OR IsModule (moduleSym)) ; pSym := GetPsym (moduleSym) ; IF IsDefImp (moduleSym) THEN InitCtorFields (moduleTok, beginTok, finallyTok, moduleSym, pSym^.DefImp.ctors, GetSymName (moduleSym), FALSE, TRUE) ELSE InitCtorFields (moduleTok, beginTok, finallyTok, moduleSym, pSym^.Module.ctors, GetSymName (moduleSym), IsInnerModule (moduleSym), TRUE) END END MakeModuleCtor ; (* InitCtorFields - initialize the ModuleCtor fields. An inner module has no ctor procedure. *) PROCEDURE InitCtorFields (moduleTok, beginTok, finallyTok: CARDINAL; moduleSym: CARDINAL; VAR ctor: ModuleCtor; name: Name; inner, pub: BOOLEAN) ; BEGIN IF ScaffoldDynamic AND (NOT inner) THEN (* The ctor procedure must be public. *) ctor.ctor := MakeProcedure (moduleTok, GenName (GetLibName (moduleSym), "_M2_", name, "_ctor")) ; PutCtor (ctor.ctor, TRUE) ; Assert (pub) ; PutPublic (ctor.ctor, pub) ; PutExtern (ctor.ctor, NOT pub) ; PutMonoName (ctor.ctor, TRUE) ; (* The dep procedure is local to the module. *) ctor.dep := MakeProcedure (moduleTok, GenName (GetLibName (moduleSym), "_M2_", name, "_dep")) ; PutMonoName (ctor.dep, TRUE) ELSE ctor.ctor := NulSym ; ctor.dep := NulSym END ; (* The init/fini procedures must be public. *) ctor.init := MakeProcedure (beginTok, GenName (GetLibName (moduleSym), "_M2_", name, "_init")) ; PutPublic (ctor.init, pub) ; PutExtern (ctor.init, NOT pub) ; PutMonoName (ctor.init, NOT inner) ; DeclareArgEnvParams (beginTok, ctor.init) ; ctor.fini := MakeProcedure (finallyTok, GenName (GetLibName (moduleSym), "_M2_", name, "_fini")) ; PutPublic (ctor.fini, pub) ; PutExtern (ctor.fini, NOT pub) ; PutMonoName (ctor.fini, NOT inner) ; DeclareArgEnvParams (beginTok, ctor.fini) END InitCtorFields ; (* GetModuleCtors - mod can be a DefImp or Module symbol. ctor, init and fini are assigned for this module. An inner module ctor value will be NulSym. *) PROCEDURE GetModuleCtors (mod: CARDINAL; VAR ctor, init, fini, dep: CARDINAL) ; VAR pSym : PtrToSymbol ; BEGIN pSym := GetPsym (mod) ; WITH pSym^ DO CASE SymbolType OF ModuleSym: ctor := Module.ctors.ctor ; init := Module.ctors.init ; fini := Module.ctors.fini ; dep := Module.ctors.dep | DefImpSym: ctor := DefImp.ctors.ctor ; init := DefImp.ctors.init ; fini := DefImp.ctors.fini ; dep := DefImp.ctors.dep ELSE InternalError ('expecting Module or DefImp symbol') END END END GetModuleCtors ; (* CheckTok - checks to see that tok is at a known location. If not it uses GetTokenNo as a fall back. *) PROCEDURE CheckTok (tok: CARDINAL; name: ARRAY OF CHAR) : CARDINAL ; VAR s: String ; BEGIN IF tok = UnknownTokenNo THEN tok := GetTokenNo () ; IF DebugUnknownToken THEN s := InitString (name) ; s := ConCat (s, InitString (' symbol {%W} has been created with an unknown token location')) ; MetaErrorStringT0 (GetTokenNo (), s) END END ; RETURN tok END CheckTok ; (* MakeModule - creates a module sym with ModuleName. It returns the symbol index. *) PROCEDURE MakeModule (tok: CARDINAL; ModuleName: Name) : CARDINAL ; VAR pSym : PtrToSymbol ; pCall: PtrToCallFrame ; Sym : CARDINAL ; BEGIN (* tok := CheckTok (tok, 'module') ; *) (* Make a new symbol since we are at the outer scope level. DeclareSym examines the current scope level for any symbols that have the correct name, but are yet undefined. Therefore we must not call DeclareSym but create a symbol directly. *) NewSym(Sym) ; pSym := GetPsym(Sym) ; WITH pSym^ DO SymbolType := ModuleSym ; WITH Module DO name := ModuleName ; (* Index into name array, name *) (* of record field. *) libname := NulName ; (* Library association. *) InitCtor (ctors) ; (* Init all ctor functions. *) InitList(ModListOfDep) ; (* Vector of SymDependency. *) InitTree(LocalSymbols) ; (* The LocalSymbols hold all the *) (* variables declared local to *) (* the block. It contains the *) (* FROM _ IMPORT x, y, x ; *) (* IMPORT A ; *) (* and also *) (* MODULE WeAreHere ; *) (* x y z visiable by localsym *) (* MODULE Inner ; *) (* EXPORT x, y, z ; *) (* END Inner ; *) (* END WeAreHere. *) InitTree(ExportTree) ; (* Holds all the exported *) (* identifiers. *) (* This tree may be *) (* deleted at the end of Pass 1. *) InitTree(ImportTree) ; (* Contains all IMPORTed *) (* identifiers. *) InitList(IncludeList) ; (* Contains all included symbols *) (* which are included by *) (* IMPORT modulename ; *) (* modulename.Symbol *) InitTree(ExportUndeclared) ; (* ExportUndeclared contains all *) (* the identifiers which were *) (* exported but have not yet *) (* been declared. *) InitList(EnumerationScopeList) ; (* Enumeration scope list which *) (* contains a list of all *) (* enumerations which are *) (* visable within this scope. *) (* Outer Module. *) InitTree(NamedObjects) ; (* Names of all items declared. *) InitTree(NamedImports) ; (* Names of items imported. *) InitTree(WhereImported) ; (* Sym to TokenNo where import *) (* occurs. Error message use. *) Priority := NulSym ; (* Priority of the module. This *) (* is an index to a constant. *) InitTree(Unresolved) ; (* All symbols currently *) (* unresolved in this module. *) StartQuad := 0 ; (* Signify the initialization *) (* code. *) EndQuad := 0 ; (* EndQuad should point to a *) (* goto quad. *) StartFinishQuad := 0 ; (* Signify the finalization *) (* code. *) EndFinishQuad := 0 ; (* should point to a finish *) FinallyFunction := NIL ; (* The GCC function for finally *) ExceptionFinally := FALSE ; (* does it have an exception? *) ExceptionBlock := FALSE ; (* does it have an exception? *) ModLink := GetLink () ; (* Is this parsed for linkage? *) Builtin := FALSE ; (* Is the module builtin? *) InitList(ListOfVars) ; (* List of variables in this *) (* scope. *) InitList(ListOfProcs) ; (* List of all procedures *) (* declared within this module. *) InitList(ListOfModules) ; (* List of all inner modules. *) InitWhereDeclaredTok(tok, At) ; (* Where symbol declared. *) InitWhereFirstUsedTok(tok, At) ; (* Where symbol first used. *) pCall := GetPcall(ScopePtr) ; IF pCall^.Main=GetBaseModule() THEN Scope := NulSym ELSE Scope := pCall^.Main END ; errorScope := GetCurrentErrorScope () ; (* Title error scope. *) END END ; PutSymKey(ModuleTree, ModuleName, Sym) ; RETURN Sym END MakeModule ; (* PutModLink - assigns link to module sym. *) PROCEDURE PutModLink (sym: CARDINAL; link: BOOLEAN) ; VAR pSym: PtrToSymbol ; BEGIN IF IsModule (sym) THEN pSym := GetPsym (sym) ; pSym^.Module.ModLink := link ELSIF IsDefImp (sym) THEN pSym := GetPsym (sym) ; pSym^.DefImp.ModLink := link ELSE InternalError ('expecting a DefImp or Module symbol') END END PutModLink ; (* IsModLink - returns the ModLink value associated with the module symbol. *) PROCEDURE IsModLink (sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN IF IsModule (sym) THEN pSym := GetPsym (sym) ; RETURN pSym^.Module.ModLink ELSIF IsDefImp (sym) THEN pSym := GetPsym (sym) ; RETURN pSym^.DefImp.ModLink ELSE InternalError ('expecting a DefImp or Module symbol') END END IsModLink ; (* PutDefLink - assigns link to the definition module sym. *) PROCEDURE PutDefLink (sym: CARDINAL; link: BOOLEAN) ; VAR pSym: PtrToSymbol ; BEGIN IF IsDefImp (sym) THEN pSym := GetPsym (sym) ; pSym^.DefImp.DefLink := link ELSE InternalError ('expecting a DefImp symbol') END END PutDefLink ; (* IsDefLink - returns the DefLink value associated with the definition module symbol. *) PROCEDURE IsDefLink (sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN IF IsDefImp (sym) THEN pSym := GetPsym (sym) ; RETURN pSym^.DefImp.DefLink ELSE InternalError ('expecting a DefImp symbol') END END IsDefLink ; (* GetLink - returns TRUE if the current module is only used for linkage. *) PROCEDURE GetLink () : BOOLEAN ; VAR OuterModule: CARDINAL ; BEGIN OuterModule := GetCurrentModule () ; IF OuterModule # NulSym THEN IF CompilingDefinitionModule () THEN RETURN IsDefLink (OuterModule) ELSE RETURN IsModLink (OuterModule) END END ; (* Default is that the module is for compiling. *) RETURN FALSE END GetLink ; (* IsModuleBuiltin - returns TRUE if the module is a builtin module. (For example _BaseTypes). *) PROCEDURE IsModuleBuiltin (sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN IF IsDefImp (sym) THEN pSym := GetPsym (sym) ; RETURN pSym^.DefImp.Builtin ELSIF IsModule (sym) THEN pSym := GetPsym (sym) ; RETURN pSym^.Module.Builtin END ; RETURN FALSE END IsModuleBuiltin ; (* PutModuleBuiltin - sets the Builtin flag to value. Currently the procedure expects sym to be a DefImp module only. *) PROCEDURE PutModuleBuiltin (sym: CARDINAL; value: BOOLEAN) ; VAR pSym: PtrToSymbol ; BEGIN IF IsDefImp (sym) THEN pSym := GetPsym (sym) ; pSym^.DefImp.Builtin := value ELSIF IsModule (sym) THEN pSym := GetPsym (sym) ; pSym^.Module.Builtin := value ELSE InternalError ('expecting Module or DefImp symbol') END END PutModuleBuiltin ; (* AddModuleToParent - adds symbol, Sym, to module, Parent. *) PROCEDURE AddModuleToParent (Sym: CARDINAL; Parent: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Parent) ; WITH pSym^ DO CASE SymbolType OF DefImpSym : PutItemIntoList(DefImp.ListOfModules, Sym) | ModuleSym : PutItemIntoList(Module.ListOfModules, Sym) | ProcedureSym: PutItemIntoList(Procedure.ListOfModules, Sym) ELSE InternalError ('expecting DefImp or Module symbol') END END END AddModuleToParent ; (* MakeInnerModule - creates an inner module sym with ModuleName. It returns the symbol index. *) PROCEDURE MakeInnerModule (tok: CARDINAL; ModuleName: Name) : CARDINAL ; VAR pSym: PtrToSymbol ; Sym : CARDINAL ; BEGIN Sym := DeclareSym (tok, ModuleName) ; IF NOT IsError(Sym) THEN pSym := GetPsym(Sym) ; WITH pSym^ DO SymbolType := ModuleSym ; WITH Module DO name := ModuleName ; (* Index into name array, name *) (* of record field. *) libname := NulName ; (* Library association. *) InitCtor (ctors) ; (* Init all ctor functions. *) InitTree(LocalSymbols) ; (* The LocalSymbols hold all the *) (* variables declared local to *) (* the block. It contains the *) (* FROM _ IMPORT x, y, x ; *) (* IMPORT A ; *) (* and also *) (* MODULE WeAreHere ; *) (* x y z visiable by localsym *) (* MODULE Inner ; *) (* EXPORT x, y, z ; *) (* END Inner ; *) (* END WeAreHere. *) InitTree(ExportTree) ; (* Holds all the exported *) (* identifiers. *) (* This tree may be *) (* deleted at the end of Pass 1. *) InitTree(ImportTree) ; (* Contains all IMPORTed *) (* identifiers. *) InitList(IncludeList) ; (* Contains all included symbols *) (* which are included by *) (* IMPORT modulename ; *) (* modulename.Symbol *) InitTree(ExportUndeclared) ; (* ExportUndeclared contains all *) (* the identifiers which were *) (* exported but have not yet *) (* been declared. *) InitList(EnumerationScopeList) ;(* Enumeration scope list which *) (* contains a list of all *) (* enumerations which are *) (* visable within this scope. *) InitTree(NamedObjects) ; (* Names of all items declared. *) InitTree(NamedImports) ; (* Names of items imported. *) InitTree(WhereImported) ; (* Sym to TokenNo where import *) (* occurs. Error message use. *) Priority := NulSym ; (* Priority of the module. This *) (* is an index to a constant. *) InitTree(Unresolved) ; (* All symbols currently *) (* unresolved in this module. *) StartQuad := 0 ; (* Signify the initialization *) (* code. *) EndQuad := 0 ; (* EndQuad should point to a *) (* goto quad. *) StartFinishQuad := 0 ; (* Signify the finalization *) (* code. *) EndFinishQuad := 0 ; (* should point to a finish *) FinallyFunction := NIL ; (* The GCC function for finally *) ExceptionFinally := FALSE ; (* does it have an exception? *) ExceptionBlock := FALSE ; (* does it have an exception? *) ModLink := GetLink () ; (* Is this parsed for linkage? *) InitList(ListOfVars) ; (* List of variables in this *) (* scope. *) InitList(ListOfProcs) ; (* List of all procedures *) (* declared within this module. *) InitList(ListOfModules) ; (* List of all inner modules. *) InitWhereDeclaredTok(tok, At) ; (* Where symbol declared. *) InitWhereFirstUsedTok(tok, At) ; (* Where symbol first used. *) IF GetCurrentScope()=GetBaseModule() THEN Scope := NulSym ELSE Scope := GetCurrentScope() ; AddModuleToParent(Sym, Scope) END ; errorScope := GetCurrentErrorScope () ; (* Title error scope. *) END ; END ; AddSymToScope(Sym, ModuleName) END ; RETURN Sym END MakeInnerModule ; (* MakeDefImp - creates a definition and implementation module sym with name DefImpName. It returns the symbol index. *) PROCEDURE MakeDefImp (tok: CARDINAL; DefImpName: Name) : CARDINAL ; VAR pSym: PtrToSymbol ; Sym : CARDINAL ; BEGIN (* Make a new symbol since we are at the outer scope level. *) (* We cannot use DeclareSym as it examines the current scope *) (* for any symbols which have the correct name, but are yet *) (* undefined. *) (* tok := CheckTok (tok, 'defimp') ; *) NewSym(Sym) ; pSym := GetPsym(Sym) ; WITH pSym^ DO SymbolType := DefImpSym ; WITH DefImp DO name := DefImpName ; (* Index into name array, name *) (* of record field. *) libname := NulName ; (* Library association. *) InitCtor (ctors) ; (* Init all ctor functions. *) InitList(DefListOfDep) ; (* Vector of SymDependency. *) InitList(ModListOfDep) ; (* Vector of SymDependency. *) InitTree(ExportQualifiedTree) ; (* Holds all the EXPORT *) (* QUALIFIED identifiers. *) (* This tree may be *) (* deleted at the end of Pass 1. *) InitTree(ExportUnQualifiedTree) ; (* Holds all the EXPORT *) (* UNQUALIFIED identifiers. *) (* This tree may be *) (* deleted at the end of Pass 1. *) InitTree(ExportRequest) ; (* Contains all identifiers that *) (* have been requested by other *) (* modules before this module *) (* declared its export list. *) (* This tree should be empty at *) (* the end of the compilation. *) (* Each time a symbol is *) (* exported it is removed from *) (* this list. *) InitTree(ImportTree) ; (* Contains all IMPORTed *) (* identifiers. *) InitList(IncludeList) ; (* Contains all included symbols *) (* which are included by *) (* IMPORT modulename ; *) (* modulename.Symbol *) InitList(DefIncludeList) ; (* Contains all included symbols *) (* which are included by *) (* IMPORT modulename ; *) (* in the definition module only *) InitTree(ExportUndeclared) ; (* ExportUndeclared contains all *) (* the identifiers which were *) (* exported but have not yet *) (* been declared. *) InitTree(NeedToBeImplemented) ; (* NeedToBeImplemented contains *) (* the identifiers which have *) (* been exported and declared *) (* but have not yet been *) (* implemented. *) InitTree(LocalSymbols) ; (* The LocalSymbols hold all the *) (* variables declared local to *) (* the block. It contains the *) (* IMPORT r ; *) (* FROM _ IMPORT x, y, x ; *) (* and also *) (* MODULE WeAreHere ; *) (* x y z visiable by localsym *) (* MODULE Inner ; *) (* EXPORT x, y, z ; *) (* END Inner ; *) (* END WeAreHere. *) InitList(EnumerationScopeList) ; (* Enumeration scope list which *) (* contains a list of all *) (* enumerations which are *) (* visable within this scope. *) InitTree(NamedObjects) ; (* names of all items declared. *) InitTree(NamedImports) ; (* Names of items imported. *) InitTree(WhereImported) ; (* Sym to TokenNo where import *) (* occurs. Error message use. *) Priority := NulSym ; (* Priority of the module. This *) (* is an index to a constant. *) InitTree(Unresolved) ; (* All symbols currently *) (* unresolved in this module. *) StartQuad := 0 ; (* Signify the initialization *) (* code. *) EndQuad := 0 ; (* EndQuad should point to a *) (* goto quad. *) StartFinishQuad := 0 ; (* Signify the finalization *) (* code. *) EndFinishQuad := 0 ; (* should point to a finish *) FinallyFunction := NIL ; (* The GCC function for finally *) ExceptionFinally := FALSE ; (* does it have an exception? *) ExceptionBlock := FALSE ; (* does it have an exception? *) ContainsHiddenType := FALSE ;(* True if this module *) (* implements a hidden type. *) ContainsBuiltin := FALSE ; (* Does module define a builtin *) (* procedure? *) ForC := FALSE ; (* Is it a definition for "C" *) NeedExportList := FALSE ; (* Must user supply export list? *) DefLink := GetLink () ; (* Is the def/mod file only *) ModLink := GetLink () ; (* parsed for linkage? *) Builtin := FALSE ; (* Is the module builtin? *) InitList(ListOfVars) ; (* List of variables in this *) (* scope. *) InitList(ListOfProcs) ; (* List of all procedures *) (* declared within this module. *) InitList(ListOfModules) ; (* List of all inner modules. *) InitWhereDeclaredTok(tok, At) ; (* Where symbol declared. *) InitWhereFirstUsedTok(tok, At) ; (* Where symbol first used. *) errorScope := GetCurrentErrorScope () ; (* Title error scope. *) END END ; PutSymKey(ModuleTree, DefImpName, Sym) ; RETURN Sym END MakeDefImp ; (* PutLibName - places libname into defimp or module sym. *) PROCEDURE PutLibName (sym: CARDINAL; libname: Name) ; VAR pSym: PtrToSymbol ; BEGIN Assert (IsModule (sym) OR IsDefImp (sym)) ; pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: DefImp.libname := libname | ModuleSym: Module.libname := libname ELSE InternalError ('expecting DefImp or Module symbol') END END END PutLibName ; (* GetLibName - returns libname associated with a defimp or module sym. *) PROCEDURE GetLibName (sym: CARDINAL) : Name ; VAR pSym: PtrToSymbol ; BEGIN Assert (IsModule (sym) OR IsDefImp (sym)) ; pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: RETURN DefImp.libname | ModuleSym: RETURN Module.libname ELSE InternalError ('expecting DefImp or Module symbol') END END END GetLibName ; (* PutProcedureExternPublic - if procedure is not NulSym set extern and public booleans. *) PROCEDURE PutProcedureExternPublic (procedure: CARDINAL; extern, pub: BOOLEAN) ; BEGIN IF procedure # NulSym THEN PutExtern (procedure, extern) ; PutPublic (procedure, pub) END END PutProcedureExternPublic ; (* PutCtorExtern - *) PROCEDURE PutCtorExtern (tok: CARDINAL; sym: CARDINAL; VAR ctor: ModuleCtor; extern: BOOLEAN) ; BEGIN (* If the ctor does not exist then make it extern/ (~extern) public. *) IF ctor.ctor = NulSym THEN ctor.ctor := MakeProcedure (tok, GenName (GetLibName (sym), "_M2_", GetSymName (sym), "_ctor")) ; PutMonoName (ctor.ctor, TRUE) END ; PutProcedureExternPublic (ctor.ctor, extern, NOT extern) ; PutCtor (ctor.ctor, TRUE) ; (* If the ctor does not exist then make it extern/ (~extern) public. *) IF ctor.dep = NulSym THEN ctor.dep := MakeProcedure (tok, GenName (GetLibName (sym), "_M2_", GetSymName (sym), "_dep")) ; PutMonoName (ctor.dep, TRUE) END ; PutProcedureExternPublic (ctor.dep, extern, NOT extern) ; (* If init/fini do not exist then create them. *) IF ctor.init = NulSym THEN ctor.init := MakeProcedure (tok, GenName (GetLibName (sym), "_M2_", GetSymName (sym), "_init")) ; DeclareArgEnvParams (tok, ctor.init) ; PutMonoName (ctor.init, NOT IsInnerModule (sym)) END ; PutProcedureExternPublic (ctor.init, extern, NOT extern) ; IF ctor.fini = NulSym THEN ctor.fini := MakeProcedure (tok, GenName (GetLibName (sym), "_M2_", GetSymName (sym), "_fini")) ; DeclareArgEnvParams (tok, ctor.fini) ; PutMonoName (ctor.fini, NOT IsInnerModule (sym)) END ; PutProcedureExternPublic (ctor.fini, extern, NOT extern) END PutCtorExtern ; (* PutModuleCtorExtern - for every ctor related procedure in module sym. Make it external. It will create any missing init/fini procedures but not any missing dep/ctor procedures. *) PROCEDURE PutModuleCtorExtern (tok: CARDINAL; sym: CARDINAL; external: BOOLEAN) ; VAR pSym: PtrToSymbol ; BEGIN Assert (IsModule (sym) OR IsDefImp (sym)) ; pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: PutCtorExtern (tok, sym, DefImp.ctors, external) | ModuleSym: PutCtorExtern (tok, sym, Module.ctors, external) ELSE InternalError ('expecting DefImp or Module symbol') END END END PutModuleCtorExtern ; (* InitProcedureDeclaration - initialize all the ProcedureDeclaration fields. *) PROCEDURE InitProcedureDeclaration (VAR decl: ProcedureDeclaration) ; BEGIN WITH decl DO Defined := FALSE ; (* Has the procedure been *) (* declared yet? *) ParamDefined := FALSE ; (* Have the parameters been *) (* defined yet? *) HasVarArgs := FALSE ; (* Does the procedure use ... ? *) HasOptArg := FALSE ; (* Does this procedure use [ ] ? *) IsNoReturn := FALSE ; (* Declared attribute noreturn ? *) ReturnOptional := FALSE ; (* Is the return value optional? *) ProcedureTok := UnknownTokenNo END END InitProcedureDeclaration ; (* MakeProcedure - creates a procedure sym with name. It returns the symbol index. *) PROCEDURE MakeProcedure (tok: CARDINAL; ProcedureName: Name) : CARDINAL ; VAR pSym: PtrToSymbol ; Sym : CARDINAL ; kind: ProcedureKind ; BEGIN tok := CheckTok (tok, 'procedure') ; Sym := DeclareSym(tok, ProcedureName) ; IF Sym = BreakSym THEN stop END ; IF NOT IsError(Sym) THEN pSym := GetPsym(Sym) ; WITH pSym^ DO SymbolType := ProcedureSym ; WITH Procedure DO name := ProcedureName ; FOR kind := MIN (ProcedureKind) TO MAX (ProcedureKind) DO InitProcedureDeclaration (Decl[kind]) ; InitList (Decl[kind].ListOfParam) END ; OptArgInit := NulSym ; (* The optional arg default *) (* value. *) IsExtern := FALSE ; (* Make this procedure external. *) IsPublic := FALSE ; (* Make this procedure visible. *) IsCtor := FALSE ; (* Is this procedure a ctor? *) IsMonoName := FALSE ; (* Overrides module name prefix. *) BuildProcType := TRUE ; (* Are we building the *) (* proctype associated with sym? *) Scope := GetCurrentScope() ; (* Scope of procedure. *) InitTree(Unresolved) ; (* All symbols currently *) (* unresolved in this procedure. *) ScopeQuad := 0 ; (* Index into list of quads, *) StartQuad := 0 ; (* defining the scope, start and *) EndQuad := 0 ; (* end of the procedure. *) Reachable := FALSE ; (* Procedure not known to be *) (* reachable. *) SavePriority := FALSE ; (* Does procedure need to save *) (* and restore interrupts? *) ReturnType := NulSym ; (* Not a function yet! *) (* The ProcType equivalent. *) ProcedureType := MakeProcType (tok, NulName) ; InitTree(LocalSymbols) ; InitList(EnumerationScopeList) ; (* Enumeration scope list which *) (* contains a list of all *) (* enumerations which are *) (* visable within this scope. *) InitTree(NamedObjects) ; (* Names of all items declared. *) InitList(ListOfVars) ; (* List of variables in this *) (* scope. *) InitList(ListOfProcs) ; (* List of all procedures *) (* declared within this *) (* procedure. *) InitList(ListOfModules) ; (* List of all inner modules. *) ExceptionFinally := FALSE ; (* does it have an exception? *) ExceptionBlock := FALSE ; (* does it have an exception? *) IsBuiltin := FALSE ; (* Was it declared __BUILTIN__ ? *) BuiltinName := NulName ; (* name of equivalent builtin *) IsInline := FALSE ; (* Was is declared __INLINE__ ? *) Size := InitValue() ; (* Activation record size. *) TotalParamSize := InitValue() ; (* size of all parameters. *) Begin := 0 ; (* token number for BEGIN *) End := 0 ; (* token number for END *) InitWhereDeclaredTok(tok, At) ; (* Where the symbol was declared. *) errorScope := GetCurrentErrorScope () ; (* Title error scope. *) END END ; (* Now add this procedure to the symbol table of the current scope *) AddSymToScope(Sym, ProcedureName) ; AddProcedureToList(GetCurrentScope(), Sym) END ; RETURN Sym END MakeProcedure ; (* PutProcedureNoReturn - places value into the no return attribute field of procedure sym. *) PROCEDURE PutProcedureNoReturn (Sym: CARDINAL; kind: ProcedureKind; value: BOOLEAN) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (Sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: Procedure.Decl[kind].IsNoReturn := value ELSE InternalError ('expecting ProcedureSym symbol') END END END PutProcedureNoReturn ; (* IsProcedureNoReturn - returns TRUE if this procedure never returns. *) PROCEDURE IsProcedureNoReturn (Sym: CARDINAL; kind: ProcedureKind) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (Sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: RETURN Procedure.Decl[kind].IsNoReturn ELSE InternalError ('expecting ProcedureSym symbol') END END END IsProcedureNoReturn ; (* PutMonoName - changes the IsMonoName boolean inside the procedure. *) PROCEDURE PutMonoName (sym: CARDINAL; value: BOOLEAN) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: Procedure.IsMonoName := value ELSE InternalError ('expecting ProcedureSym symbol') END END END PutMonoName ; (* IsMonoName - returns the public boolean associated with a procedure. *) PROCEDURE IsMonoName (sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: RETURN Procedure.IsMonoName ELSE InternalError ('expecting ProcedureSym symbol') END END END IsMonoName ; (* PutExtern - changes the extern boolean inside the procedure. *) PROCEDURE PutExtern (sym: CARDINAL; value: BOOLEAN) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: Procedure.IsExtern := value ELSE InternalError ('expecting ProcedureSym symbol') END END END PutExtern ; (* IsExtern - returns the public boolean associated with a procedure. *) PROCEDURE IsExtern (sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: RETURN Procedure.IsExtern ELSE InternalError ('expecting ProcedureSym symbol') END END END IsExtern ; (* PutPublic - changes the public boolean inside the procedure. *) PROCEDURE PutPublic (sym: CARDINAL; value: BOOLEAN) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym : Procedure.IsPublic := value ELSE InternalError ('expecting ProcedureSym symbol') END END END PutPublic ; (* IsPublic - returns the public boolean associated with a procedure. *) PROCEDURE IsPublic (sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym : RETURN Procedure.IsPublic ELSE InternalError ('expecting ProcedureSym symbol') END END END IsPublic ; (* PutCtor - changes the ctor boolean inside the procedure. *) PROCEDURE PutCtor (sym: CARDINAL; value: BOOLEAN) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym : Procedure.IsCtor := value ELSE InternalError ('expecting ProcedureSym symbol') END END END PutCtor ; (* IsCtor - returns the ctor boolean associated with a procedure. *) PROCEDURE IsCtor (sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym : RETURN Procedure.IsCtor ELSE InternalError ('expecting ProcedureSym symbol') END END END IsCtor ; (* AddProcedureToList - adds a procedure, Proc, to the list of procedures in module, Mod. *) PROCEDURE AddProcedureToList (Mod, Proc: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Mod) ; WITH pSym^ DO CASE SymbolType OF DefImpSym : PutItemIntoList(DefImp.ListOfProcs, Proc) | ModuleSym : PutItemIntoList(Module.ListOfProcs, Proc) | ProcedureSym: PutItemIntoList(Procedure.ListOfProcs, Proc) ELSE InternalError ('expecting ModuleSym, DefImpSym or ProcedureSym symbol') END END END AddProcedureToList ; (* AddVarToScopeList - adds symbol, sym, to, scope. *) PROCEDURE AddVarToScopeList (scope, sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(scope) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: PutItemIntoList(Procedure.ListOfVars, sym) | ModuleSym : PutItemIntoList(Module.ListOfVars, sym) | DefImpSym : PutItemIntoList(DefImp.ListOfVars, sym) ELSE InternalError ('expecting Procedure or Module symbol') END END END AddVarToScopeList ; (* AddVarToList - add a variable symbol to the list of variables maintained by the inner most scope. (Procedure or Module). *) PROCEDURE AddVarToList (Sym: CARDINAL) ; VAR pCall: PtrToCallFrame ; BEGIN pCall := GetPcall(ScopePtr) ; AddVarToScopeList(pCall^.Main, Sym) END AddVarToList ; (* InitVarDecl - initialize the variable and type token location positions. *) PROCEDURE InitVarDecl (VAR decl: VarDecl; vartok: CARDINAL) ; BEGIN decl.FullTok := UnknownTokenNo ; decl.VarTok := vartok ; decl.TypeTok := UnknownTokenNo END InitVarDecl ; (* doPutVarDeclTypeTok - places typetok into decl.TypeTok. sym must be a variable. *) PROCEDURE doPutVarDeclTypeTok (sym: CARDINAL; typetok: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN Assert (IsVar (sym)) ; pSym := GetPsym (sym) ; WITH pSym^.Var DO Declared.TypeTok := typetok END END doPutVarDeclTypeTok ; (* PutVarDeclTypeTok - assigns the TypeTok field to typetok. sym can be a variable or parameter. *) PROCEDURE PutVarDeclTypeTok (sym: CARDINAL; typetok: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN IF IsParameter (sym) THEN pSym := GetPsym (sym) ; IF IsParameterVar (sym) THEN PutVarDeclTypeTok (pSym^.VarParam.ShadowVar, typetok) ELSE PutVarDeclTypeTok (pSym^.Param.ShadowVar, typetok) END ELSIF IsVar (sym) THEN doPutVarDeclTypeTok (sym, typetok) END END PutVarDeclTypeTok ; (* doPutVarDeclTok - places vartok into decl.VarTok. sym must be a variable. *) PROCEDURE doPutVarDeclTok (sym: CARDINAL; vartok: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN Assert (IsVar (sym)) ; pSym := GetPsym (sym) ; WITH pSym^.Var DO Declared.VarTok := vartok END END doPutVarDeclTok ; (* PutVarDeclTok - assigns the VarTok field to typetok. sym can be a variable or parameter. *) PROCEDURE PutVarDeclTok (sym: CARDINAL; vartok: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN IF IsParameter (sym) THEN pSym := GetPsym (sym) ; IF IsParameterVar (sym) THEN PutVarDeclTok (pSym^.VarParam.ShadowVar, vartok) ELSE PutVarDeclTok (pSym^.Param.ShadowVar, vartok) END ELSIF IsVar (sym) THEN doPutVarDeclTok (sym, vartok) END END PutVarDeclTok ; (* doGetVarDeclTok - return decl.VarTok for a variable. *) PROCEDURE doGetVarDeclTok (sym: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (sym) ; Assert (IsVar (sym)) ; WITH pSym^.Var DO RETURN Declared.VarTok END END doGetVarDeclTok ; (* GetVarDeclTok - returns the TypeTok field associate with variable sym. *) PROCEDURE GetVarDeclTok (sym: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN IF IsParameter (sym) THEN pSym := GetPsym (sym) ; IF IsParameterVar (sym) THEN RETURN GetVarDeclTok (pSym^.VarParam.ShadowVar) ELSE RETURN GetVarDeclTok (pSym^.Param.ShadowVar) END ELSIF IsVar (sym) THEN RETURN doGetVarDeclTok (sym) ELSE RETURN UnknownTokenNo END END GetVarDeclTok ; (* doGetVarDeclTypeTok - return decl.TypeTok for a variable. *) PROCEDURE doGetVarDeclTypeTok (sym: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (sym) ; Assert (IsVar (sym)) ; WITH pSym^.Var DO RETURN Declared.TypeTok END END doGetVarDeclTypeTok ; (* GetVarDeclTypeTok - returns the TypeTok field associate with variable sym. *) PROCEDURE GetVarDeclTypeTok (sym: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN IF IsParameter (sym) THEN pSym := GetPsym (sym) ; IF IsParameterVar (sym) THEN RETURN GetVarDeclTypeTok (pSym^.VarParam.ShadowVar) ELSE RETURN GetVarDeclTypeTok (pSym^.Param.ShadowVar) END ELSIF IsVar (sym) THEN RETURN doGetVarDeclTypeTok (sym) ELSE RETURN UnknownTokenNo END END GetVarDeclTypeTok ; (* doGetVarDeclFullTok - return the full declaration of var: type. *) PROCEDURE doGetVarDeclFullTok (sym: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (sym) ; Assert (IsVar (sym)) ; WITH pSym^.Var DO IF Declared.FullTok = UnknownTokenNo THEN IF Declared.TypeTok = UnknownTokenNo THEN RETURN Declared.VarTok ELSE Declared.FullTok := MakeVirtual2Tok (Declared.VarTok, Declared.TypeTok) END END ; RETURN Declared.FullTok END END doGetVarDeclFullTok ; (* GetVarDeclFullTok - returns the full virtual token containing var: type. *) PROCEDURE GetVarDeclFullTok (sym: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (sym) ; IF IsParameter (sym) THEN IF IsParameterVar (sym) THEN RETURN GetVarDeclFullTok (pSym^.VarParam.ShadowVar) ELSE RETURN GetVarDeclFullTok (pSym^.Param.ShadowVar) END ELSIF IsVar (sym) THEN RETURN doGetVarDeclFullTok (sym) ELSE RETURN UnknownTokenNo END END GetVarDeclFullTok ; (* MakeVar - creates a variable sym with VarName. It returns the symbol index. *) PROCEDURE MakeVar (tok: CARDINAL; VarName: Name) : CARDINAL ; VAR pSym: PtrToSymbol ; Sym : CARDINAL ; BEGIN Sym := DeclareSym (tok, VarName) ; IF NOT IsError(Sym) THEN pSym := GetPsym(Sym) ; WITH pSym^ DO SymbolType := VarSym ; WITH Var DO name := VarName ; Type := NulSym ; BackType := NulSym ; Size := InitValue() ; Offset := InitValue() ; AddrMode := RightValue ; Scope := GetCurrentScope() ; (* Procedure or Module? *) AtAddress := FALSE ; Address := NulSym ; (* Address at which declared. *) IsConditional := FALSE ; IsTemp := FALSE ; IsComponentRef := FALSE ; IsParam := FALSE ; IsPointerCheck := FALSE ; IsWritten := FALSE ; IsSSA := FALSE ; IsConst := FALSE ; ArrayRef := FALSE ; Heap := FALSE ; InitVarDecl (Declared, tok) ; InitWhereDeclaredTok(tok, At) ; InitWhereFirstUsedTok(tok, At) ; (* Where symbol first used. *) InitList(ReadUsageList[RightValue]) ; InitList(WriteUsageList[RightValue]) ; InitList(ReadUsageList[LeftValue]) ; InitList(WriteUsageList[LeftValue]) ; InitState[LeftValue] := InitSymInit () ; InitState[RightValue] := InitSymInit () END END ; (* Add Var to Procedure or Module variable list. *) AddVarToList(Sym) ; (* Now add this Var to the symbol table of the current scope. *) AddSymToScope(Sym, VarName) END ; RETURN Sym END MakeVar ; (* PutVarConditional - assign IsConditional to value. *) PROCEDURE PutVarConditional (sym: CARDINAL; value: BOOLEAN) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF VarSym : Var.IsConditional := value | ConstVarSym: ConstVar.IsConditional := value ELSE InternalError ('expecting Var') END END END PutVarConditional ; (* IsVarConditional - return TRUE if the symbol is a var symbol containing the result of a boolean conditional. *) PROCEDURE IsVarConditional (sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF VarSym : RETURN Var.IsConditional | ConstVarSym: RETURN ConstVar.IsConditional ELSE RETURN FALSE END END ; RETURN FALSE END IsVarConditional ; (* PutExceptionBlock - sets a BOOLEAN in block module/procedure/defimp, sym, indicating that this block as an EXCEPT statement sequence. *) PROCEDURE PutExceptionBlock (sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: Procedure.ExceptionBlock := TRUE | ModuleSym : Module.ExceptionBlock := TRUE | DefImpSym : DefImp.ExceptionBlock := TRUE ELSE InternalError ('expecting Procedure') END END END PutExceptionBlock ; (* HasExceptionBlock - returns a BOOLEAN determining whether module/procedure/defimp, sym, has an EXCEPT statement sequence. *) PROCEDURE HasExceptionBlock (sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: RETURN( Procedure.ExceptionBlock ) | ModuleSym : RETURN( Module.ExceptionBlock ) | DefImpSym : RETURN( DefImp.ExceptionBlock ) ELSE InternalError ('expecting Procedure') END END END HasExceptionBlock ; (* PutExceptionFinally - sets a BOOLEAN in block module/defimp, sym, indicating that this FINALLY block as an EXCEPT statement sequence. *) PROCEDURE PutExceptionFinally (sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: Procedure.ExceptionFinally := TRUE | ModuleSym : Module.ExceptionFinally := TRUE | DefImpSym : DefImp.ExceptionFinally := TRUE ELSE InternalError ('expecting DefImp or Module symbol') END END END PutExceptionFinally ; (* HasExceptionFinally - returns a BOOLEAN determining whether module/defimp, sym, has an EXCEPT statement sequence. *) PROCEDURE HasExceptionFinally (sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: RETURN( Procedure.ExceptionFinally ) | ModuleSym : RETURN( Module.ExceptionFinally ) | DefImpSym : RETURN( DefImp.ExceptionFinally ) ELSE InternalError ('expecting DefImp or Module symbol') END END END HasExceptionFinally ; (* FillInRecordFields - given a new symbol, sym, make it a record symbol and initialize its fields. *) PROCEDURE FillInRecordFields (tok: CARDINAL; sym: CARDINAL; RecordName: Name; scope: CARDINAL; oaf: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN IF NOT IsError(sym) THEN pSym := GetPsym (sym) ; WITH pSym^ DO SymbolType := RecordSym ; WITH Record DO name := RecordName ; InitTree (LocalSymbols) ; Size := InitValue () ; InitList (ListOfSons) ; (* List of RecordFieldSym and VarientSym *) oafamily := oaf ; Parent := NulSym ; Align := NulSym ; DefaultAlign := NulSym ; DeclPacked := FALSE ; DeclResolved := FALSE ; Scope := scope ; InitWhereDeclaredTok (tok, At) END END END END FillInRecordFields ; (* HandleHiddenOrDeclare - *) PROCEDURE HandleHiddenOrDeclare (tok: CARDINAL; name: Name; VAR oaf: CARDINAL) : CARDINAL ; VAR sym: CARDINAL ; BEGIN sym := CheckForHiddenType (name) ; IF sym=NulSym THEN sym := DeclareSym (tok, name) ; IF NOT IsError (sym) THEN (* Now add this type to the symbol table of the current scope *) AddSymToScope (sym, name) END END ; oaf := GetOAFamily (sym) ; RETURN sym END HandleHiddenOrDeclare ; (* MakeRecord - makes a Record symbol with name RecordName. *) PROCEDURE MakeRecord (tok: CARDINAL; RecordName: Name) : CARDINAL ; VAR oaf, sym: CARDINAL ; BEGIN tok := CheckTok (tok, 'record') ; sym := HandleHiddenOrDeclare (tok, RecordName, oaf) ; FillInRecordFields (tok, sym, RecordName, GetCurrentScope (), oaf) ; ForeachOAFamily (oaf, doFillInOAFamily) ; RETURN sym END MakeRecord ; (* MakeVarient - creates a new symbol, a varient symbol for record or varient field symbol, RecOrVarFieldSym. *) PROCEDURE MakeVarient (tok: CARDINAL; RecOrVarFieldSym: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; Sym : CARDINAL ; BEGIN tok := CheckTok (tok, 'varient') ; NewSym (Sym) ; pSym := GetPsym(Sym) ; WITH pSym^ DO SymbolType := VarientSym ; WITH Varient DO Size := InitValue() ; Parent := RecOrVarFieldSym ; (* GetRecord(RecOrVarFieldSym) ; *) IF IsRecord(RecOrVarFieldSym) THEN Varient := NulSym ELSE Varient := RecOrVarFieldSym END ; tag := NulSym ; DeclPacked := FALSE ; Scope := GetCurrentScope() ; InitList(ListOfSons) ; InitWhereDeclaredTok(tok, At) END END ; (* Now add Sym to the record RecSym field list *) pSym := GetPsym(RecOrVarFieldSym) ; WITH pSym^ DO CASE SymbolType OF RecordSym : PutItemIntoList(Record.ListOfSons, Sym) | VarientFieldSym: PutItemIntoList(VarientField.ListOfSons, Sym) ELSE InternalError ('expecting Record or VarientField symbol') END END ; RETURN Sym END MakeVarient ; (* GetRecord - fetches the record symbol from the parent of Sym. Sym maybe a varient symbol in which case its parent is searched etc. *) PROCEDURE GetRecord (Sym: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (Sym) ; WITH pSym^ DO CASE SymbolType OF RecordSym : RETURN Sym | VarientSym : RETURN GetRecord(Varient.Parent) | VarientFieldSym: RETURN GetRecord(VarientField.Parent) ELSE InternalError ('expecting Record or Varient symbol') END END END GetRecord ; (* PutDeclaredPacked - sets the Packed field of the record or record field symbol. *) PROCEDURE PutDeclaredPacked (sym: CARDINAL; b: BOOLEAN) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF RecordSym : Record.DeclPacked := b ; Record.DeclResolved := TRUE | RecordFieldSym : RecordField.DeclPacked := b ; RecordField.DeclResolved := TRUE | VarientFieldSym: VarientField.DeclPacked := b ; VarientField.DeclResolved := TRUE | VarientSym : Varient.DeclPacked := b ; Varient.DeclResolved := TRUE ELSE InternalError ('expecting a record or field record symbol') END END END PutDeclaredPacked ; (* IsDeclaredPacked - was the record symbol or record field, sym, declared as packed? *) PROCEDURE IsDeclaredPacked (sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF RecordSym : RETURN Record.DeclPacked | RecordFieldSym : RETURN RecordField.DeclPacked | VarientFieldSym: RETURN VarientField.DeclPacked | VarientSym : RETURN Varient.DeclPacked ELSE InternalError ('expecting a record or a record field symbol') END END END IsDeclaredPacked ; (* IsDeclaredPackedResolved - do we know if the record symbol or record field, sym, declared as packed or not packed? *) PROCEDURE IsDeclaredPackedResolved (sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF RecordSym : RETURN Record.DeclResolved | RecordFieldSym : RETURN RecordField.DeclResolved | VarientFieldSym: RETURN VarientField.DeclResolved | VarientSym : RETURN Varient.DeclResolved ELSE InternalError ('expecting a record or a record field symbol') END END END IsDeclaredPackedResolved ; (* MakeEnumeration - places a new symbol in the current scope, the symbol is an enumeration symbol. The symbol index is returned. *) PROCEDURE MakeEnumeration (tok: CARDINAL; EnumerationName: Name) : CARDINAL ; VAR pSym : PtrToSymbol ; sym, oaf: CARDINAL ; BEGIN tok := CheckTok (tok, 'enumeration') ; sym := CheckForHiddenType (EnumerationName) ; IF sym=NulSym THEN sym := DeclareSym (tok, EnumerationName) ; oaf := GetOAFamily (sym) ; IF NOT IsError (sym) THEN pSym := GetPsym (sym) ; pSym^.SymbolType := EnumerationSym ; (* To satisfy AddSymToScope *) (* Now add this type to the symbol table of the current scope *) AddSymToScope (sym, EnumerationName) END ELSE oaf := GetOAFamily (sym) END ; IF NOT IsError (sym) THEN pSym := GetPsym (sym) ; WITH pSym^ DO SymbolType := EnumerationSym ; WITH Enumeration DO name := EnumerationName ; (* Name of enumeration. *) NoOfElements := 0 ; (* No of elements in the *) (* enumeration type. *) Size := InitValue () ; (* Size at runtime of sym *) InitTree (LocalSymbols) ; (* Enumeration fields. *) InitList (ListOfFields) ; (* Ordered as declared. *) InitPacked (packedInfo) ; (* not packed and no *) (* equivalent (yet). *) oafamily := oaf ; (* The open array family *) Scope := GetCurrentScope () ; (* Which scope created it *) InitWhereDeclaredTok (tok, At) (* Declared here *) END END ; CheckIfEnumerationExported (sym, ScopePtr) END ; ForeachOAFamily (oaf, doFillInOAFamily) ; RETURN sym END MakeEnumeration ; (* MakeType - makes a type symbol with name TypeName. *) PROCEDURE MakeType (tok: CARDINAL; TypeName: Name) : CARDINAL ; VAR pSym : PtrToSymbol ; sym, oaf: CARDINAL ; BEGIN sym := HandleHiddenOrDeclare (tok, TypeName, oaf) ; IF NOT IsError(sym) THEN pSym := GetPsym(sym) ; WITH pSym^ DO SymbolType := TypeSym ; WITH Type DO name := TypeName ; (* Index into name array, name *) (* of type. *) Type := NulSym ; (* Index to a type symbol. *) IsHidden := FALSE ; (* Was it declared as hidden? *) InitTree(ConstLitTree) ; (* constants of this type. *) Size := InitValue() ; (* Runtime size of symbol. *) Align := NulSym ; (* Alignment of this type. *) InitPacked(packedInfo) ; (* not packed and no *) (* equivalent yet. *) oafamily := oaf ; (* The open array family. *) Scope := GetCurrentScope() ; (* Which scope created it *) InitWhereDeclaredTok(tok, At) (* Declared here *) END END END ; ForeachOAFamily(oaf, doFillInOAFamily) ; RETURN sym END MakeType ; (* MakeHiddenType - makes a type symbol that is hidden from the definition module. This symbol is placed into the UnImplemented list of the definition/implementation module. The type will be filled in when the implementation module is reached. *) PROCEDURE MakeHiddenType (tok: CARDINAL; TypeName: Name) : CARDINAL ; VAR pSym: PtrToSymbol ; Sym : CARDINAL ; BEGIN tok := CheckTok (tok, 'hidden') ; Sym := DeclareSym (tok, TypeName) ; IF NOT IsError(Sym) THEN pSym := GetPsym(Sym) ; WITH pSym^ DO SymbolType := TypeSym ; WITH Type DO name := TypeName ; (* Index into name array, name *) (* of type. *) IsHidden := GetMainModule()#GetCurrentScope() ; IF ExtendedOpaque OR (NOT IsHidden) THEN Type := NulSym (* will be filled in later *) ELSE Type := Address END ; Align := NulSym ; (* Alignment of this type. *) Scope := GetCurrentScope() ; (* Which scope created it *) oafamily := NulSym ; IF NOT ExtendedOpaque THEN IncludeItemIntoList(AddressTypes, Sym) END ; Size := InitValue() ; (* Runtime size of symbol. *) InitWhereDeclaredTok(tok, At) (* Declared here *) END END ; PutExportUnImplemented (tok, Sym) ; IF ExtendedOpaque OR (GetMainModule()=GetCurrentScope()) THEN PutHiddenTypeDeclared END ; (* Now add this type to the symbol table of the current scope *) AddSymToScope(Sym, TypeName) END ; RETURN Sym END MakeHiddenType ; (* GetConstFromTypeTree - return a constant symbol from the tree owned by constType. NulSym is returned if the symbol is unknown. *) (* PROCEDURE GetConstFromTypeTree (constName: Name; constType: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN IF constType=NulSym THEN RETURN GetSymKey(ConstLitTree, constName) ELSE pSym := GetPsym(constType) ; Assert(IsType(constType) OR IsSubrange(constType) OR IsPointer(constType)) ; WITH pSym^ DO CASE SymbolType OF TypeSym : RETURN GetSymKey (Type.ConstLitTree, constName) | SubrangeSym: RETURN GetSymKey (Subrange.ConstLitTree, constName) | PointerSym : RETURN GetSymKey (Pointer.ConstLitTree, constName) ELSE InternalError ('expecting Type symbol') END END END END GetConstFromTypeTree ; *) (* PutConstIntoTypeTree - places, constSym, into the tree of constants owned by, constType. constName is the name of constSym. *) (* PROCEDURE PutConstIntoTypeTree (constName: Name; constType: CARDINAL; constSym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN IF constType=NulSym THEN PutSymKey(ConstLitTree, constName, constSym) ELSE pSym := GetPsym(constType) ; Assert(IsType(constType) OR IsSubrange(constType) OR IsPointer(constType)) ; WITH pSym^ DO CASE SymbolType OF TypeSym : PutSymKey (Type.ConstLitTree, constName, constSym) | SubrangeSym: PutSymKey (Subrange.ConstLitTree, constName, constSym) | PointerSym : PutSymKey (Pointer.ConstLitTree, constName, constSym) ELSE InternalError ('expecting Type symbol') END END END END PutConstIntoTypeTree ; *) (* MakeConstant - create a constant cardinal and return the symbol. *) PROCEDURE MakeConstant (tok: CARDINAL; value: CARDINAL) : CARDINAL ; VAR str: String ; sym: CARDINAL ; BEGIN tok := CheckTok (tok, 'constant') ; str := Sprintf1 (Mark (InitString ("%d")), value) ; sym := MakeConstLit (tok, makekey (string (str)), Cardinal) ; str := KillString (str) ; RETURN sym END MakeConstant ; (* CreateConstLit - *) PROCEDURE CreateConstLit (tok: CARDINAL; constName: Name; constType: CARDINAL) : CARDINAL ; VAR pSym : PtrToSymbol ; Sym : CARDINAL ; overflow : BOOLEAN ; BEGIN overflow := FALSE ; IF constType=NulSym THEN constType := GetConstLitType (tok, constName, overflow, TRUE) END ; NewSym (Sym) ; pSym := GetPsym (Sym) ; WITH pSym^ DO SymbolType := ConstLitSym ; CASE SymbolType OF ConstLitSym : ConstLit.name := constName ; ConstLit.Value := InitValue () ; PushString (tok, constName, NOT overflow) ; PopInto (ConstLit.Value) ; ConstLit.Type := constType ; ConstLit.IsSet := FALSE ; ConstLit.IsInternal := FALSE ; (* Is it a default BY constant expression? *) ConstLit.IsConstructor := FALSE ; ConstLit.FromType := NulSym ; (* type is determined FromType *) ConstLit.RangeError := overflow ; ConstLit.UnresFromType := FALSE ; (* is Type resolved? *) ConstLit.Scope := GetCurrentScope () ; InitWhereDeclaredTok (tok, ConstLit.At) ; InitWhereFirstUsedTok (tok, ConstLit.At) ELSE InternalError ('expecting ConstLit symbol') END END ; RETURN Sym END CreateConstLit ; (* LookupConstLitPoolEntry - return a ConstLit symbol from the constant pool which matches tok, constName and constType. *) PROCEDURE LookupConstLitPoolEntry (tok: CARDINAL; constName: Name; constType: CARDINAL) : CARDINAL ; VAR pe : ConstLitPoolEntry ; rootIndex: CARDINAL ; BEGIN rootIndex := GetSymKey (ConstLitPoolTree, constName) ; IF rootIndex # 0 THEN pe := Indexing.GetIndice (ConstLitArray, rootIndex) ; WHILE pe # NIL DO IF (pe^.tok = tok) AND (pe^.constName = constName) AND (pe^.constType = constType) THEN RETURN pe^.sym END ; pe := pe^.next END END ; RETURN NulSym END LookupConstLitPoolEntry ; (* AddConstLitPoolEntry - adds sym to the constlit pool. *) PROCEDURE AddConstLitPoolEntry (sym: CARDINAL; tok: CARDINAL; constName: Name; constType: CARDINAL) ; VAR pe, old : ConstLitPoolEntry ; rootIndex, high: CARDINAL ; BEGIN rootIndex := GetSymKey (ConstLitPoolTree, constName) ; IF rootIndex = NulKey THEN high := Indexing.HighIndice (ConstLitArray) ; NEW (pe) ; IF pe = NIL THEN InternalError ('out of memory') ELSE pe^.sym := sym ; pe^.tok := tok ; pe^.constName := constName ; pe^.constType := constType ; pe^.next := NIL ; PutSymKey (ConstLitPoolTree, constName, high+1) ; Indexing.PutIndice (ConstLitArray, high+1, pe) END ELSE NEW (pe) ; IF pe = NIL THEN InternalError ('out of memory') ELSE old := Indexing.GetIndice (ConstLitArray, rootIndex) ; pe^.sym := sym ; pe^.tok := tok ; pe^.constName := constName ; pe^.constType := constType ; pe^.next := old ; Indexing.PutIndice (ConstLitArray, rootIndex, pe) END END END AddConstLitPoolEntry ; (* MakeConstLit - returns a constant literal of type, constType, with a constName, at location, tok. *) PROCEDURE MakeConstLit (tok: CARDINAL; constName: Name; constType: CARDINAL) : CARDINAL ; VAR sym: CARDINAL ; BEGIN tok := CheckTok (tok, 'constlit') ; sym := LookupConstLitPoolEntry (tok, constName, constType) ; IF sym = NulSym THEN sym := CreateConstLit (tok, constName, constType) ; AddConstLitPoolEntry (sym, tok, constName, constType) END ; RETURN sym END MakeConstLit ; (* MakeConstVar - makes a ConstVar type with name ConstVarName. *) PROCEDURE MakeConstVar (tok: CARDINAL; ConstVarName: Name) : CARDINAL ; VAR pSym: PtrToSymbol ; Sym : CARDINAL ; temp: BOOLEAN ; BEGIN temp := (ConstVarName = NulName) ; ConstVarName := CheckAnonymous (ConstVarName) ; Sym := DeclareSym (tok, ConstVarName) ; IF NOT IsError(Sym) THEN pSym := GetPsym(Sym) ; WITH pSym^ DO SymbolType := ConstVarSym ; WITH ConstVar DO name := ConstVarName ; Value := InitValue() ; Type := NulSym ; IsSet := FALSE ; IsConditional := FALSE ; IsConstructor := FALSE ; FromType := NulSym ; (* type is determined FromType *) UnresFromType := FALSE ; (* is Type resolved? *) IsTemp := temp ; Scope := GetCurrentScope () ; InitWhereDeclaredTok (tok, At) END END ; (* Now add this constant to the symbol table of the current scope *) AddSymToScope(Sym, ConstVarName) END ; RETURN( Sym ) END MakeConstVar ; (* InitConstString - initialize the constant string. *) PROCEDURE InitConstString (tok: CARDINAL; sym: CARDINAL; name, contents: Name; kind: ConstStringVariant; escape, known: BOOLEAN) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (sym) ; WITH pSym^ DO SymbolType := ConstStringSym ; CASE SymbolType OF ConstStringSym: ConstString.name := name ; ConstString.StringVariant := kind ; ConstString.Scope := GetCurrentScope() ; InitWhereDeclaredTok (tok, ConstString.At) ; PutConstStringKnown (tok, sym, contents, escape, known) ELSE InternalError ('expecting ConstStringSym') END END END InitConstString ; (* IsConstStringNulTerminated - returns TRUE if the constant string, sym, should be created with a nul terminator. *) PROCEDURE IsConstStringNulTerminated (sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF ConstStringSym: RETURN ((ConstString.StringVariant = m2nulstr) OR (ConstString.StringVariant = cnulstr)) ELSE InternalError ('expecting ConstStringSym') END END END IsConstStringNulTerminated ; (* MakeConstStringCnul - creates a constant string nul terminated string suitable for C. If known is TRUE then name is assigned to the contents and the escape sequences will be converted into characters. *) PROCEDURE MakeConstStringCnul (tok: CARDINAL; name: Name; known: BOOLEAN) : CARDINAL ; VAR newstr: CARDINAL ; BEGIN tok := CheckTok (tok, 'conststringcnul') ; NewSym (newstr) ; InitConstString (tok, newstr, name, name, cnulstr, TRUE, known) ; RETURN newstr END MakeConstStringCnul ; (* MakeConstStringM2nul - creates a constant string nul terminated string suitable for M2. If known is TRUE then name is assigned to the contents however the escape sequences are not converted into characters. *) PROCEDURE MakeConstStringM2nul (tok: CARDINAL; name: Name; known: BOOLEAN) : CARDINAL ; VAR newstr: CARDINAL ; BEGIN NewSym (newstr) ; InitConstString (tok, newstr, name, name, m2nulstr, FALSE, known) ; RETURN newstr END MakeConstStringM2nul ; (* MakeConstString - create a string constant in the symboltable. *) PROCEDURE MakeConstString (tok: CARDINAL; ConstName: Name) : CARDINAL ; VAR newstr: CARDINAL ; BEGIN NewSym (newstr) ; InitConstString (tok, newstr, ConstName, ConstName, m2nulstr, FALSE, TRUE) ; RETURN newstr END MakeConstString ; (* PutConstStringKnown - if sym is a constvar then convert it into a conststring. If known is FALSE then contents is ignored and NulName is stored. If escape is TRUE then the contents will have any escape sequences converted into single characters. *) PROCEDURE PutConstStringKnown (tok: CARDINAL; sym: CARDINAL; contents: Name; escape, known: BOOLEAN) ; VAR pSym: PtrToSymbol ; s : String ; BEGIN pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF ConstStringSym: IF known THEN IF escape THEN s := HandleEscape (InitStringCharStar (KeyToCharStar (contents))) ; contents := makekey (string (s)) ; s := KillString (s) END ; ConstString.Length := LengthKey (contents) ; ConstString.Contents := contents ELSE ConstString.Length := 0 ; ConstString.Contents := NulName END ; ConstString.Known := known ; InitWhereDeclaredTok (tok, ConstString.At) ; InitWhereFirstUsedTok (tok, ConstString.At) | ConstVarSym : (* Change a ConstVar to a ConstString copy name and alter symboltype. *) InitConstString (tok, sym, ConstVar.name, contents, m2str, escape, known) ELSE InternalError ('expecting ConstString symbol') END END END PutConstStringKnown ; (* CopyConstString - copies string contents from expr to des and retain the kind of string. *) PROCEDURE CopyConstString (tok: CARDINAL; des, expr: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN Assert (IsConstStringKnown (expr)) ; pSym := GetPsym (des) ; WITH pSym^ DO CASE SymbolType OF ConstStringSym: InitConstString (tok, des, ConstString.name, GetString (expr), GetConstStringKind (expr), FALSE, TRUE) | ConstVarSym : (* Change a ConstVar to a ConstString copy name and alter symboltype. *) InitConstString (tok, des, ConstVar.name, GetString (expr), GetConstStringKind (expr), FALSE, TRUE) ELSE InternalError ('expecting ConstString symbol') END END END CopyConstString ; (* IsConstStringKnown - returns TRUE if sym is a const string and the contents are known. *) PROCEDURE IsConstStringKnown (sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF ConstStringSym: RETURN ConstString.Known ELSE RETURN FALSE END END END IsConstStringKnown ; (* IsConstStringM2 - returns whether this conststring is a Modula-2 string. *) PROCEDURE IsConstStringM2 (sym: CARDINAL) : BOOLEAN ; BEGIN RETURN GetConstStringKind (sym) = m2str END IsConstStringM2 ; (* IsConstStringC - returns whether this conststring is a C style string which will have any escape translated. *) PROCEDURE IsConstStringC (sym: CARDINAL) : BOOLEAN ; BEGIN RETURN GetConstStringKind (sym) = cstr END IsConstStringC ; (* IsConstStringM2nul - returns whether this conststring is a Modula-2 string which contains a nul terminator. *) PROCEDURE IsConstStringM2nul (sym: CARDINAL) : BOOLEAN ; BEGIN RETURN GetConstStringKind (sym) = m2nulstr END IsConstStringM2nul ; (* IsConstStringCnul - returns whether this conststring is a C style string which will have any escape translated and also contains a nul terminator. *) PROCEDURE IsConstStringCnul (sym: CARDINAL) : BOOLEAN ; BEGIN RETURN GetConstStringKind (sym) = cnulstr END IsConstStringCnul ; (* GetConstStringKind - return the StringVariant field associated with sym. *) PROCEDURE GetConstStringKind (sym: CARDINAL) : ConstStringVariant ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF ConstStringSym: RETURN ConstString.StringVariant ELSE InternalError ('expecting ConstString symbol') END END END GetConstStringKind ; (* GetString - returns the contents of the string symbol sym, note that this is not the same as GetName (unless it was a literal). *) PROCEDURE GetString (Sym: CARDINAL) : Name ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (Sym) ; WITH pSym^ DO CASE SymbolType OF ConstStringSym: IF ConstString.Known THEN RETURN ConstString.Contents ELSE InternalError ('const string contents are unknown') END ELSE InternalError ('expecting ConstString symbol') END END END GetString ; (* GetStringLength - returns the length of the string symbol Sym. *) PROCEDURE GetStringLength (tok: CARDINAL; sym: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF ConstStringSym: IF ConstString.Known THEN RETURN ConstString.Length ELSE MetaErrorT0 (tok, 'const string contents are unknown') ; RETURN 0 END ELSE InternalError ('expecting ConstString symbol') END END END GetStringLength ; (* PutVariableAtAddress - determines that a variable, sym, is declared at a specific address. *) PROCEDURE PutVariableAtAddress (sym: CARDINAL; address: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN Assert(sym#NulSym) ; pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF VarSym: Var.AtAddress := TRUE ; Var.Address := address ELSE InternalError ('expecting a variable symbol') END END END PutVariableAtAddress ; (* GetVariableAtAddress - returns the address at which variable, sym, is declared. *) PROCEDURE GetVariableAtAddress (sym: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN Assert(sym#NulSym) ; pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF VarSym: RETURN( Var.Address ) ELSE InternalError ('expecting a variable symbol') END END END GetVariableAtAddress ; (* IsVariableAtAddress - returns TRUE if a variable, sym, was declared at a specific address. *) PROCEDURE IsVariableAtAddress (sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN Assert(sym#NulSym) ; pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF VarSym: RETURN( Var.AtAddress ) ELSE InternalError ('expecting a variable symbol') END END END IsVariableAtAddress ; (* PutVariableSSA - assigns value to the SSA field within variable sym. *) PROCEDURE PutVariableSSA (sym: CARDINAL; value: BOOLEAN) ; VAR pSym: PtrToSymbol ; BEGIN Assert (sym#NulSym) ; pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF VarSym: Var.IsSSA := value ELSE InternalError ('expecting a variable symbol') END END END PutVariableSSA ; (* IsVariableSSA - returns TRUE if variable is known to be a SSA. *) PROCEDURE IsVariableSSA (sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN Assert (sym#NulSym) ; pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF VarSym: RETURN Var.IsSSA ELSE InternalError ('expecting a variable symbol') END END END IsVariableSSA ; (* PutPriority - places a interrupt, priority, value into module, module. *) PROCEDURE PutPriority (module: CARDINAL; priority: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN Assert(module#NulSym) ; pSym := GetPsym(module) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: DefImp.Priority := priority | ModuleSym: Module.Priority := priority ELSE InternalError ('expecting DefImp or Module symbol') END END END PutPriority ; (* GetPriority - returns the interrupt priority which was assigned to module, module. *) PROCEDURE GetPriority (module: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN Assert(module#NulSym) ; pSym := GetPsym(module) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: RETURN( DefImp.Priority ) | ModuleSym: RETURN( Module.Priority ) ELSE InternalError ('expecting DefImp or Module symbol') END END END GetPriority ; (* PutNeedSavePriority - set a boolean flag indicating that this procedure needs to save and restore interrupts. *) PROCEDURE PutNeedSavePriority (sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: Procedure.SavePriority := TRUE ELSE InternalError ('expecting procedure symbol') END END END PutNeedSavePriority ; (* GetNeedSavePriority - returns the boolean flag indicating whether this procedure needs to save and restore interrupts. *) PROCEDURE GetNeedSavePriority (sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: RETURN( Procedure.SavePriority ) ELSE InternalError ('expecting procedure symbol') END END END GetNeedSavePriority ; (* GetProcedureBuiltin - returns the builtin name for the equivalent procedure, Sym. *) PROCEDURE GetProcedureBuiltin (Sym: CARDINAL) : Name ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: RETURN( Procedure.BuiltinName ) ELSE InternalError ('expecting procedure symbol') END END END GetProcedureBuiltin ; (* PutProcedureBuiltin - assigns the builtin name for the equivalent procedure, Sym. *) PROCEDURE PutProcedureBuiltin (Sym: CARDINAL; name: Name) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym : Procedure.BuiltinName := name ; Procedure.IsBuiltin := TRUE ; (* we use the same extra pass method as hidden types for builtins *) PutHiddenTypeDeclared ELSE InternalError ('expecting procedure symbol') END END END PutProcedureBuiltin ; (* IsProcedureBuiltin - returns TRUE if this procedure has a builtin equivalent. *) PROCEDURE IsProcedureBuiltin (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym : RETURN( Procedure.IsBuiltin ) ELSE InternalError ('expecting procedure symbol') END END END IsProcedureBuiltin ; (* CanUseBuiltin - returns TRUE if the procedure, Sym, can be inlined via a builtin function. *) PROCEDURE CanUseBuiltin (Sym: CARDINAL) : BOOLEAN ; BEGIN RETURN( (NOT DebugBuiltins) AND (BuiltinExists (KeyToCharStar (GetProcedureBuiltin (Sym))) OR BuiltinExists (KeyToCharStar (GetSymName (Sym)))) ) END CanUseBuiltin ; (* IsProcedureBuiltinAvailable - return TRUE if procedure is available as a builtin for the target architecture. *) PROCEDURE IsProcedureBuiltinAvailable (procedure: CARDINAL) : BOOLEAN ; BEGIN RETURN IsProcedureBuiltin (procedure) AND CanUseBuiltin (procedure) END IsProcedureBuiltinAvailable ; (* PutProcedureInline - determines that procedure, Sym, has been requested to be inlined. *) PROCEDURE PutProcedureInline (Sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym : Procedure.IsInline := TRUE ; ELSE InternalError ('expecting procedure symbol') END END END PutProcedureInline ; (* IsProcedureBuiltin - returns TRUE if this procedure was declared as inlined. *) PROCEDURE IsProcedureInline (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym : RETURN( Procedure.IsInline ) ELSE InternalError ('expecting procedure symbol') END END END IsProcedureInline ; (* PutConstSet - informs the const var symbol, sym, that it is or will contain a set value. *) PROCEDURE PutConstSet (Sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ConstVarSym: ConstVar.IsSet := TRUE | ConstLitSym: ConstLit.IsSet := TRUE ELSE InternalError ('expecting ConstVar symbol') END END END PutConstSet ; (* IsConstSet - returns TRUE if the constant is declared as a set. *) PROCEDURE IsConstSet (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ConstVarSym: RETURN( ConstVar.IsSet ) | ConstLitSym: RETURN( ConstLit.IsSet ) ELSE RETURN( FALSE ) END END END IsConstSet ; (* PutConstructor - informs the const var symbol, sym, that it is or will contain a constructor (record, set or array) value. *) PROCEDURE PutConstructor (Sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ConstVarSym: ConstVar.IsConstructor := TRUE | ConstLitSym: ConstLit.IsConstructor := TRUE ELSE InternalError ('expecting ConstVar or ConstLit symbol') END END END PutConstructor ; (* IsConstructor - returns TRUE if the constant is declared as a constant set, array or record. *) PROCEDURE IsConstructor (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ConstVarSym: RETURN( ConstVar.IsConstructor ) | ConstLitSym: RETURN( ConstLit.IsConstructor ) ELSE RETURN( FALSE ) END END END IsConstructor ; (* PutConstructorFrom - sets the from type field in constructor, Sym, to, from. *) PROCEDURE PutConstructorFrom (Sym: CARDINAL; from: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ConstVarSym: ConstVar.FromType := from ; ConstVar.UnresFromType := TRUE | ConstLitSym: ConstLit.FromType := from ; ConstLit.UnresFromType := TRUE ELSE InternalError ('expecting ConstVar or ConstLit symbol') END END ; IncludeItemIntoList(UnresolvedConstructorType, Sym) END PutConstructorFrom ; (* InitPacked - initialise packedInfo to FALSE and NulSym. *) PROCEDURE InitPacked (VAR packedInfo: PackedInfo) ; BEGIN WITH packedInfo DO IsPacked := FALSE ; PackedEquiv := NulSym END END InitPacked ; (* doEquivalent - create a packed equivalent symbol for, sym, and return the new symbol. It sets both fields in packedInfo to FALSE and the new symbol. *) PROCEDURE doEquivalent (VAR packedInfo: PackedInfo; sym: CARDINAL) : CARDINAL ; VAR nSym: CARDINAL ; pSym: PtrToSymbol ; BEGIN NewSym(nSym) ; pSym := GetPsym(nSym) ; WITH pSym^ DO SymbolType := EquivSym ; WITH Equiv DO nonPacked := sym ; packedInfo.IsPacked := TRUE ; packedInfo.PackedEquiv := NulSym END END ; packedInfo.IsPacked := FALSE ; packedInfo.PackedEquiv := nSym ; RETURN( nSym ) END doEquivalent ; (* MakeEquivalent - return the equivalent packed symbol for, sym. *) PROCEDURE MakeEquivalent (sym: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF EnumerationSym: RETURN( doEquivalent(Enumeration.packedInfo, sym) ) | SubrangeSym : RETURN( doEquivalent(Subrange.packedInfo, sym) ) | TypeSym : RETURN( doEquivalent(Type.packedInfo, sym) ) | SetSym : RETURN( doEquivalent(Set.packedInfo, sym) ) ELSE InternalError ('expecting type, subrange or enumerated type symbol') END END END MakeEquivalent ; (* GetEquivalent - *) PROCEDURE GetEquivalent (VAR packedInfo: PackedInfo; sym: CARDINAL) : CARDINAL ; BEGIN WITH packedInfo DO IF IsPacked THEN RETURN( sym ) ELSIF PackedEquiv=NulSym THEN PackedEquiv := MakeEquivalent(sym) END ; RETURN( PackedEquiv ) END END GetEquivalent ; (* GetPackedEquivalent - returns the packed equivalent of type, sym. sym must be a type, subrange or enumerated type. *) PROCEDURE GetPackedEquivalent (sym: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF EnumerationSym: RETURN( GetEquivalent(Enumeration.packedInfo, sym) ) | SubrangeSym : RETURN( GetEquivalent(Subrange.packedInfo, sym) ) | TypeSym : RETURN( GetEquivalent(Type.packedInfo, sym) ) | SetSym : RETURN( GetEquivalent(Set.packedInfo, sym) ) ELSE InternalError ('expecting type, subrange or enumerated type symbol') END END END GetPackedEquivalent ; (* GetNonPackedEquivalent - returns the equivalent non packed symbol associated with, sym. *) PROCEDURE GetNonPackedEquivalent (sym: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF EquivSym: RETURN( Equiv.nonPacked ) ELSE InternalError ('expecting equivalent symbol') END END END GetNonPackedEquivalent ; (* IsEquivalent - returns TRUE if, sym, is an equivalent symbol. *) PROCEDURE IsEquivalent (sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF EquivSym: RETURN( TRUE ) ELSE RETURN( FALSE ) END END END IsEquivalent ; (* MakeSubrange - makes a new symbol into a subrange type with name SubrangeName. *) PROCEDURE MakeSubrange (tok: CARDINAL; SubrangeName: Name) : CARDINAL ; VAR pSym : PtrToSymbol ; sym, oaf: CARDINAL ; BEGIN tok := CheckTok (tok, 'subrange') ; sym := HandleHiddenOrDeclare (tok, SubrangeName, oaf) ; IF NOT IsError(sym) THEN pSym := GetPsym(sym) ; WITH pSym^ DO SymbolType := SubrangeSym ; WITH Subrange DO name := SubrangeName ; Low := NulSym ; (* Index to a symbol determining *) (* the lower bound of subrange. *) (* Points to a constant - *) (* possibly created by *) (* ConstExpression. *) High := NulSym ; (* Index to a symbol determining *) (* the lower bound of subrange. *) (* Points to a constant - *) (* possibly created by *) (* ConstExpression. *) Type := NulSym ; (* Index to a type. Determines *) (* the type of subrange. *) Align := NulSym ; (* The alignment of this type. *) InitPacked(packedInfo) ; (* not packed and no equivalent *) InitTree(ConstLitTree) ; (* constants of this type. *) Size := InitValue() ; (* Size determines the type size *) oafamily := oaf ; (* The unbounded sym for this *) Scope := GetCurrentScope() ; (* Which scope created it *) InitWhereDeclaredTok(tok, At) (* Declared here *) END END END ; ForeachOAFamily(oaf, doFillInOAFamily) ; RETURN sym END MakeSubrange ; (* MakeArray - makes an Array symbol with name ArrayName. *) PROCEDURE MakeArray (tok: CARDINAL; ArrayName: Name) : CARDINAL ; VAR pSym : PtrToSymbol ; sym, oaf: CARDINAL ; BEGIN sym := HandleHiddenOrDeclare (tok, ArrayName, oaf) ; IF NOT IsError(sym) THEN pSym := GetPsym(sym) ; WITH pSym^ DO SymbolType := ArraySym ; WITH Array DO name := ArrayName ; Subscript := NulSym ; (* Contains the array subscripts. *) Size := InitValue() ; (* Size of array. *) Offset := InitValue() ; (* Offset of array. *) Type := NulSym ; (* The Array Type. ARRAY OF Type. *) Large := FALSE ; (* is this array large? *) Align := NulSym ; (* The alignment of this type. *) oafamily := oaf ; (* The unbounded for this array *) Scope := GetCurrentScope() ; (* Which scope created it *) InitWhereDeclaredTok(tok, At) (* Declared here *) END END END ; ForeachOAFamily(oaf, doFillInOAFamily) ; RETURN( sym ) END MakeArray ; (* PutArrayLarge - indicates that this is a large array in which case the interface to gcc maps this array from 0..high-low, using an integer indice. *) PROCEDURE PutArrayLarge (array: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN IF NOT IsError(array) THEN Assert(IsArray(array)) ; pSym := GetPsym(array) ; WITH pSym^.Array DO Large := TRUE END END END PutArrayLarge ; (* IsArrayLarge - returns TRUE if we need to treat this as a large array. *) PROCEDURE IsArrayLarge (array: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN Assert(IsArray(array)) ; pSym := GetPsym(array) ; RETURN( pSym^.Array.Large ) END IsArrayLarge ; (* GetModule - Returns the Module symbol for the module with name, name. *) PROCEDURE GetModule (name: Name) : CARDINAL ; BEGIN RETURN( GetSymKey(ModuleTree, name) ) END GetModule ; (* GetLowestType - Returns the lowest type in the type chain of symbol Sym. If NulSym is returned then we assume type unknown or you have reqested the type of a base type. *) PROCEDURE GetLowestType (Sym: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; type: CARDINAL ; BEGIN Assert(Sym#NulSym) ; pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF VarSym : type := Var.Type | ConstLitSym : type := ConstLit.Type | ConstVarSym : type := ConstVar.Type | ConstStringSym : type := NulSym | (* No type for a string *) TypeSym : type := Type.Type | RecordFieldSym : type := RecordField.Type | RecordSym : type := NulSym | (* No type for a record *) EnumerationFieldSym : type := EnumerationField.Type | EnumerationSym : type := NulSym | (* No type for enumeration *) PointerSym : type := Sym | (* we don't go to Pointer.Type *) ProcedureSym : type := Procedure.ReturnType | ProcTypeSym : type := ProcType.ReturnType | ParamSym : type := Param.Type | VarParamSym : type := VarParam.Type | SubrangeSym : type := Subrange.Type | ArraySym : type := Array.Type | SubscriptSym : type := Subscript.Type | SetSym : type := Sym | (* Stop at the set type. *) UnboundedSym : type := Unbounded.Type | UndefinedSym : type := NulSym | DummySym : type := NulSym ELSE InternalError ('not implemented yet') END END ; pSym := GetPsym(Sym) ; IF (pSym^.SymbolType=TypeSym) AND (type=NulSym) THEN type := Sym (* Base Type *) ELSIF (type#NulSym) AND IsType(type) AND (GetAlignment(type)=NulSym) THEN type := GetLowestType(type) (* Type def *) END ; RETURN( type ) END GetLowestType ; (* doGetType - subsiduary helper procedure function of GetDType, GetSType and GetLType. *) PROCEDURE doGetType (sym: CARDINAL; skipEquiv, skipAlign, skipHidden, skipBase: BOOLEAN) : CARDINAL ; VAR pSym: PtrToSymbol ; type: CARDINAL ; BEGIN type := NulSym ; Assert (sym # NulSym) ; pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF OAFamilySym : type := OAFamily.SimpleType | VarSym : type := GetTypeOfVar(sym) | ConstLitSym : type := ConstLit.Type | ConstVarSym : type := ConstVar.Type | ConstStringSym : IF ConstString.Length=1 THEN type := Char ELSE type := NulSym (* No type for a string *) END | TypeSym : type := Type.Type | RecordFieldSym : type := RecordField.Type | RecordSym : type := NulSym | (* No type for a record *) VarientSym : type := NulSym | (* No type for a record *) EnumerationFieldSym : type := EnumerationField.Type | EnumerationSym : type := NulSym | (* No type for enumeration *) PointerSym : type := Pointer.Type | ProcedureSym : type := Procedure.ReturnType | ProcTypeSym : type := ProcType.ReturnType | ParamSym : type := Param.Type | VarParamSym : type := VarParam.Type | SubrangeSym : type := Subrange.Type | ArraySym : type := Array.Type | SubscriptSym : type := Subscript.Type | SetSym : type := Set.Type | UnboundedSym : type := Unbounded.Type | UndefinedSym : type := NulSym | PartialUnboundedSym : type := PartialUnbounded.Type | ObjectSym : type := NulSym ELSE InternalError ('not implemented yet') END END ; IF (type=NulSym) AND IsType(sym) AND (NOT skipBase) THEN RETURN sym (* sym is a base type *) ELSIF type#NulSym THEN IF IsType(type) AND skipEquiv THEN IF (NOT IsHiddenType(type)) OR skipHidden THEN IF (GetAlignment(type)=NulSym) OR skipAlign THEN RETURN doGetType (type, skipEquiv, skipAlign, skipHidden, skipBase) END END END END ; RETURN type END doGetType ; (* GetLType - get lowest type. It returns the lowest type of symbol, sym. It skips over type equivalences. It will not skip over base types. *) PROCEDURE GetLType (sym: CARDINAL) : CARDINAL ; BEGIN (* Assert (doGetType (sym, TRUE, TRUE, TRUE, FALSE) = GetLowestType (sym)) ; *) RETURN doGetType (sym, TRUE, TRUE, TRUE, FALSE) END GetLType ; (* GetSType - get source type. It returns the type closest to the object. It does not skip over type equivalences. It will skip over base types. *) PROCEDURE GetSType (sym: CARDINAL) : CARDINAL ; BEGIN Assert (doGetType (sym, FALSE, FALSE, FALSE, TRUE) = GetType (sym)) ; RETURN doGetType (sym, FALSE, FALSE, FALSE, TRUE) END GetSType ; (* GetDType - get gcc declared type. It returns the type of the object which is declared to GCC. It does skip over type equivalences but only if they do not contain a user alignment. It does not skip over hidden types. It does not skip over base types. *) PROCEDURE GetDType (sym: CARDINAL) : CARDINAL ; BEGIN (* Assert (doGetType (sym, TRUE, FALSE, FALSE, FALSE) = SkipType(GetType(sym))) ; *) RETURN doGetType (sym, TRUE, FALSE, FALSE, FALSE) END GetDType ; (* GetTypeOfVar - returns the type of symbol, var. *) PROCEDURE GetTypeOfVar (var: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; high: CARDINAL ; BEGIN pSym := GetPsym(var) ; WITH pSym^ DO CASE SymbolType OF VarSym: IF Var.IsTemp AND Var.IsComponentRef THEN high := Indexing.HighIndice(Var.list) ; RETURN( GetType(GetFromIndex(Var.list, high)) ) ELSE RETURN( Var.Type ) END ELSE InternalError ('expecting a var symbol') END END END GetTypeOfVar ; (* GetType - Returns the symbol that is the TYPE symbol to Sym. If zero is returned then we assume type unknown. *) PROCEDURE GetType (Sym: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; type: CARDINAL ; BEGIN Assert(Sym#NulSym) ; pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF OAFamilySym : type := OAFamily.SimpleType | VarSym : type := GetTypeOfVar(Sym) | ConstLitSym : type := ConstLit.Type | ConstVarSym : type := ConstVar.Type | ConstStringSym : IF ConstString.Length=1 THEN type := Char ELSE type := NulSym (* No type for a string *) END | TypeSym : type := Type.Type | RecordFieldSym : type := RecordField.Type | RecordSym : type := NulSym | (* No type for a record *) VarientSym : type := NulSym | (* No type for a record *) EnumerationFieldSym : type := EnumerationField.Type | EnumerationSym : type := NulSym | (* No type for enumeration *) PointerSym : type := Pointer.Type | ProcedureSym : type := Procedure.ReturnType | ProcTypeSym : type := ProcType.ReturnType | ParamSym : type := Param.Type | VarParamSym : type := VarParam.Type | SubrangeSym : type := Subrange.Type | ArraySym : type := Array.Type | SubscriptSym : type := Subscript.Type | SetSym : type := Set.Type | UnboundedSym : type := Unbounded.Type | UndefinedSym : type := NulSym | PartialUnboundedSym : type := PartialUnbounded.Type | ObjectSym : type := NulSym ELSE InternalError ('not implemented yet') END END ; RETURN( type ) END GetType ; (* SkipType - if sym is a TYPE foo = bar then call SkipType(bar) else return sym it does not skip over hidden types. *) PROCEDURE SkipType (Sym: CARDINAL) : CARDINAL ; BEGIN IF (Sym#NulSym) AND IsType(Sym) AND (NOT IsHiddenType(Sym)) AND (GetType(Sym)#NulSym) THEN RETURN( SkipType(GetType(Sym)) ) ELSE RETURN( Sym ) END END SkipType ; (* SkipTypeAndSubrange - if sym is a TYPE foo = bar OR sym is declared as a subrange of bar then call SkipTypeAndSubrange(bar) else return sym it does not skip over hidden types. *) PROCEDURE SkipTypeAndSubrange (Sym: CARDINAL) : CARDINAL ; BEGIN IF (Sym#NulSym) AND (IsType(Sym) OR IsSubrange(Sym)) AND (NOT IsHiddenType(Sym)) AND (GetType(Sym)#NulSym) THEN RETURN( SkipTypeAndSubrange(GetType(Sym)) ) ELSE RETURN( Sym ) END END SkipTypeAndSubrange ; (* IsHiddenType - returns TRUE if, Sym, is a Type and is also declared as a hidden type. *) PROCEDURE IsHiddenType (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF TypeSym: RETURN( Type.IsHidden ) ELSE RETURN( FALSE ) END END END IsHiddenType ; (* GetConstLitType - returns the type of the constant of, name. All floating point constants have type LONGREAL. Character constants are type CHAR. Integer values are INTEGER, LONGINT or LONGCARD depending upon their value. *) PROCEDURE GetConstLitType (tok: CARDINAL; name: Name; VAR overflow: BOOLEAN; issueError: BOOLEAN) : CARDINAL ; VAR loc: location_t ; s : String ; BEGIN s := InitStringCharStar (KeyToCharStar (name)) ; IF char (s, -1) = 'C' THEN s := KillString (s) ; RETURN Char ELSE IF Index (s, '.', 0) # -1 (* found a '.' in our constant *) THEN s := KillString (s) ; RETURN RType END ; loc := TokenToLocation (tok) ; CASE char (s, -1) OF 'H': overflow := OverflowZType (loc, string (s), 16, issueError) | 'B': overflow := OverflowZType (loc, string (s), 8, issueError) | 'A': overflow := OverflowZType (loc, string (s), 2, issueError) ELSE overflow := OverflowZType (loc, string (s), 10, issueError) END ; s := KillString (s) ; RETURN ZType END END GetConstLitType ; (* GetTypeMode - return the type of sym, it returns Address is the symbol is a LValue. *) PROCEDURE GetTypeMode (sym: CARDINAL) : CARDINAL ; BEGIN IF GetMode (sym) = LeftValue THEN RETURN( Address ) ELSE RETURN( GetType (sym) ) END END GetTypeMode ; (* GetLocalSym - only searches the scope Sym for a symbol with name and returns the index to the symbol. *) PROCEDURE GetLocalSym (Sym: CARDINAL; name: Name) : CARDINAL ; VAR pSym : PtrToSymbol ; LocalSym: CARDINAL ; BEGIN (* WriteString('Attempting to retrieve symbol from ') ; WriteKey(GetSymName(Sym)) ; WriteString(' local symbol table') ; WriteLn ; *) pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF EnumerationSym : LocalSym := GetSymKey(Enumeration.LocalSymbols, name) | RecordSym : LocalSym := GetSymKey(Record.LocalSymbols, name) | ProcedureSym : LocalSym := GetSymKey(Procedure.LocalSymbols, name) | ModuleSym : LocalSym := GetSymKey(Module.LocalSymbols, name) | DefImpSym : LocalSym := GetSymKey(DefImp.LocalSymbols, name) ELSE InternalError ('symbol does not have a LocalSymbols field') END END ; RETURN( LocalSym ) END GetLocalSym ; (* GetNthFromComponent - *) PROCEDURE GetNthFromComponent (Sym: CARDINAL; n: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF VarSym: IF IsComponent(Sym) THEN IF InBounds(Var.list, n) THEN RETURN( GetFromIndex(Var.list, n) ) ELSE RETURN( NulSym ) END ELSE InternalError ('cannot GetNth from this symbol') END ELSE InternalError ('cannot GetNth from this symbol') END END END GetNthFromComponent ; (* GetNth - returns the n th symbol in the list associated with the scope of Sym. Sym may be a Module, DefImp, Procedure, Record or Enumeration symbol. *) PROCEDURE GetNth (Sym: CARDINAL; n: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; i : CARDINAL ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF RecordSym : i := GetItemFromList (Record.ListOfSons, n) | VarientSym : i := GetItemFromList (Varient.ListOfSons, n) | VarientFieldSym : i := GetItemFromList (VarientField.ListOfSons, n) | ProcedureSym : i := GetItemFromList (Procedure.ListOfVars, n) | DefImpSym : i := GetItemFromList (DefImp.ListOfVars, n) | ModuleSym : i := GetItemFromList (Module.ListOfVars, n) | TupleSym : i := GetFromIndex (Tuple.list, n) | VarSym : i := GetNthFromComponent (Sym, n) | EnumerationSym : i := GetItemFromList (Enumeration.ListOfFields, n) ELSE InternalError ('cannot GetNth from this symbol') END END ; RETURN( i ) END GetNth ; (* GetNthParam - returns the n th parameter of a procedure Sym. *) PROCEDURE GetNthParam (Sym: CARDINAL; kind: ProcedureKind; ParamNo: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; i : CARDINAL ; BEGIN IF ParamNo=0 THEN (* The return type of the function *) i := GetType(Sym) ELSE pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: i := GetItemFromList (Procedure.Decl[kind].ListOfParam, ParamNo) | ProcTypeSym : i := GetItemFromList (ProcType.ListOfParam, ParamNo) ELSE InternalError ('expecting ProcedureSym or ProcTypeSym') END END END ; RETURN( i ) END GetNthParam ; (* GetNthParamAny - returns the nth parameter from the order proper procedure, forward declaration or definition module procedure. *) PROCEDURE GetNthParamAny (sym: CARDINAL; ParamNo: CARDINAL) : CARDINAL ; VAR kind: ProcedureKind ; BEGIN FOR kind := MIN (ProcedureKind) TO MAX (ProcedureKind) DO IF GetProcedureParametersDefined (sym, kind) THEN RETURN GetNthParam (sym, kind, ParamNo) END END ; InternalError ('no procedure kind exists') END GetNthParamAny ; (* The Following procedures fill in the symbol table with the symbol entities. *) (* PutVar - gives the VarSym symbol Sym a type Type. *) PROCEDURE PutVar (Sym: CARDINAL; VarType: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF VarSym : Var.Type := VarType ; ConfigSymInit (Var.InitState[LeftValue], Sym) ; ConfigSymInit (Var.InitState[RightValue], Sym) | ConstVarSym: ConstVar.Type := VarType ELSE InternalError ('expecting VarSym or ConstVarSym') END END END PutVar ; (* PutVarTok - gives the VarSym symbol Sym a type Type at typetok. *) PROCEDURE PutVarTok (Sym: CARDINAL; VarType: CARDINAL; typetok: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF VarSym : Var.Type := VarType ; Var.Declared.TypeTok := typetok ; ConfigSymInit (Var.InitState[LeftValue], Sym) ; ConfigSymInit (Var.InitState[RightValue], Sym) | ConstVarSym: ConstVar.Type := VarType ELSE InternalError ('expecting VarSym or ConstVarSym') END END END PutVarTok ; (* PutLeftValueFrontBackType - gives the variable symbol a front and backend type. The variable must be a LeftValue. *) PROCEDURE PutLeftValueFrontBackType (Sym: CARDINAL; FrontType, BackType: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN Assert(GetMode(Sym)=LeftValue) ; pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF VarSym : Var.Type := FrontType ; Var.BackType := BackType ; PushSize(Address) ; PopInto(Var.Size) ELSE InternalError ('expecting VarSym') END END END PutLeftValueFrontBackType ; (* GetVarBackEndType - returns the back end type if specified. *) PROCEDURE GetVarBackEndType (Sym: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN Assert(Sym#NulSym) ; pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF VarSym: RETURN( Var.BackType ) ELSE RETURN( NulSym ) END END END GetVarBackEndType ; (* PutVarPointerCheck - marks variable, sym, as requiring (or not depending upon the, value), a NIL pointer check when this symbol is dereferenced. *) PROCEDURE PutVarPointerCheck (sym: CARDINAL; value: BOOLEAN) ; VAR pSym: PtrToSymbol ; BEGIN IF IsVar(sym) THEN pSym := GetPsym(sym) ; WITH pSym^.Var DO IsPointerCheck := value END END END PutVarPointerCheck ; (* GetVarPointerCheck - returns TRUE if this symbol is a variable and has been marked as needing a pointer via NIL check. *) PROCEDURE GetVarPointerCheck (sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN IF IsVar(sym) THEN pSym := GetPsym(sym) ; WITH pSym^.Var DO RETURN( IsPointerCheck ) END END ; RETURN FALSE END GetVarPointerCheck ; (* PutVarWritten - marks variable, sym, as being written to (or not depending upon the, value). *) PROCEDURE PutVarWritten (sym: CARDINAL; value: BOOLEAN) ; VAR pSym: PtrToSymbol ; BEGIN IF IsVar(sym) THEN pSym := GetPsym(sym) ; WITH pSym^.Var DO IsWritten := value END END END PutVarWritten ; (* GetVarWritten - returns TRUE if this symbol is a variable and has been marked as being written. *) PROCEDURE GetVarWritten (sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF VarSym: RETURN( Var.IsWritten ) ELSE InternalError ('expecting VarSym') END END END GetVarWritten ; (* PutVarConst - sets the IsConst field to value indicating the variable is read only. *) PROCEDURE PutVarConst (sym: CARDINAL; value: BOOLEAN) ; VAR pSym: PtrToSymbol ; BEGIN IF IsVar (sym) THEN pSym := GetPsym (sym) ; pSym^.Var.IsConst := value END END PutVarConst ; (* IsVarConst - returns the IsConst field indicating the variable is read only. *) PROCEDURE IsVarConst (sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF VarSym: RETURN( Var.IsConst ) ELSE InternalError ('expecting VarSym') END END END IsVarConst ; (* PutConst - gives the constant symbol Sym a type ConstType. *) PROCEDURE PutConst (Sym: CARDINAL; ConstType: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ConstVarSym: ConstVar.Type := ConstType ELSE InternalError ('expecting ConstVarSym') END END END PutConst ; (* PutConstLitInternal - marks the sym as being an internal constant. Currently this is used when generating a default BY constant expression during a FOR loop. A constant marked as internal will always pass an expression type check. *) PROCEDURE PutConstLitInternal (sym: CARDINAL; value: BOOLEAN) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF ConstLitSym: ConstLit.IsInternal := value ELSE InternalError ('expecting ConstLitSym') END END END PutConstLitInternal ; (* IsConstLitInternal - returns the value of the IsInternal field within a constant expression. *) PROCEDURE IsConstLitInternal (sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF ConstLitSym: RETURN ConstLit.IsInternal ELSE InternalError ('expecting ConstLitSym') END END END IsConstLitInternal ; (* PutVarArrayRef - assigns ArrayRef field with value. *) PROCEDURE PutVarArrayRef (sym: CARDINAL; value: BOOLEAN) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF VarSym: Var.ArrayRef := value ELSE InternalError ('expecting VarSym') END END END PutVarArrayRef ; (* IsVarArrayRef - returns ArrayRef field value. *) PROCEDURE IsVarArrayRef (sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF VarSym: RETURN (Var.ArrayRef) ELSE InternalError ('expecting VarSym') END END END IsVarArrayRef ; (* PutVarHeap - assigns ArrayRef field with value. *) PROCEDURE PutVarHeap (sym: CARDINAL; value: BOOLEAN) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF VarSym: Var.Heap := value ELSE InternalError ('expecting VarSym') END END END PutVarHeap ; (* IsVarHeap - returns ArrayRef field value. *) PROCEDURE IsVarHeap (sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF VarSym: RETURN (Var.Heap) ELSE InternalError ('expecting VarSym') END END END IsVarHeap ; (* PutFieldRecord - places a field, FieldName and FieldType into a record, Sym. VarSym is a optional varient symbol which can be returned by a call to GetVarient(fieldsymbol). The created field is returned. *) PROCEDURE PutFieldRecord (Sym: CARDINAL; FieldName: Name; FieldType: CARDINAL; VarSym: CARDINAL) : CARDINAL ; VAR oSym, pSym : PtrToSymbol ; esym, ParSym, SonSym: CARDINAL ; BEGIN NewSym(SonSym) ; (* Cannot be used before declared since use occurs *) (* in pass 3 and it will be declared in pass 2. *) (* Fill in the SonSym and connect it to its brothers (if any) and *) (* ensure that it is connected its parent. *) pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF RecordSym : WITH Record DO PutItemIntoList(ListOfSons, SonSym) ; Assert(IsItemInList(Record.ListOfSons, SonSym)) ; (* n := NoOfItemsInList(ListOfSons) ; printf3('record %d no of fields in ListOfSons = %d, field %d\n', Sym, n, SonSym) ; *) (* Ensure that the Field is in the Parents Local Symbols *) IF FieldName#NulName THEN IF GetSymKey(LocalSymbols, FieldName)=NulKey THEN PutSymKey(LocalSymbols, FieldName, SonSym) ELSE esym := GetSymKey(LocalSymbols, FieldName) ; MetaErrors1('field record {%1Dad} has already been declared', 'field record duplicate', esym) END END END ; CheckRecordConsistency(Sym) | VarientFieldSym : WITH VarientField DO PutItemIntoList(ListOfSons, SonSym) ; ParSym := GetRecord(Parent) END ; oSym := GetPsym(ParSym) ; Assert(oSym^.SymbolType=RecordSym) ; IF FieldName#NulName THEN oSym := GetPsym(ParSym) ; PutSymKey(oSym^.Record.LocalSymbols, FieldName, SonSym) END ELSE InternalError ('expecting Record symbol') END END ; (* Fill in SonSym *) oSym := GetPsym(SonSym) ; WITH oSym^ DO SymbolType := RecordFieldSym ; WITH RecordField DO Type := FieldType ; name := FieldName ; Tag := FALSE ; Parent := Sym ; Varient := VarSym ; Align := NulSym ; Used := TRUE ; DeclPacked := FALSE ; (* not known as packed (yet). *) DeclResolved := FALSE ; Scope := GetScope(Sym) ; Size := InitValue() ; Offset := InitValue() ; InitWhereDeclared(At) END END ; RETURN( SonSym ) END PutFieldRecord ; (* MakeFieldVarient - returns a FieldVarient symbol which has been assigned to the Varient symbol, Sym. *) PROCEDURE MakeFieldVarient (n: Name; Sym: CARDINAL) : CARDINAL ; VAR pSym : PtrToSymbol ; SonSym: CARDINAL ; BEGIN NewSym(SonSym) ; (* IF NoOfItemsInList(FreeFVarientList)=0 THEN NewSym(SonSym) ELSE SonSym := GetItemFromList(FreeFVarientList, 1) ; RemoveItemFromList(FreeFVarientList, SonSym) END ; *) (* Fill in Sym *) pSym := GetPsym(SonSym) ; WITH pSym^ DO SymbolType := VarientFieldSym ; WITH VarientField DO name := n ; InitList(ListOfSons) ; Parent := GetRecord(Sym) ; Varient := NulSym ; Size := InitValue() ; Offset := InitValue() ; DeclPacked := FALSE ; DeclResolved := FALSE ; Scope := GetCurrentScope() ; InitWhereDeclared(At) END END ; RETURN( SonSym ) END MakeFieldVarient ; (* PutFieldVarient - places the field varient, Field, as a brother to, the varient symbol, sym, and also tells Field that its varient parent is Sym. *) PROCEDURE PutFieldVarient (Field, Sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN Assert(IsVarient(Sym)) ; Assert(IsFieldVarient(Field)) ; pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF VarientSym : IncludeItemIntoList(Varient.ListOfSons, Field) ELSE InternalError ('expecting Varient symbol') END END ; pSym := GetPsym(Field) ; WITH pSym^ DO CASE SymbolType OF VarientFieldSym : VarientField.Varient := Sym ELSE InternalError ('expecting VarientField symbol') END END ; (* PutItemIntoList(UsedFVarientList, Field) *) END PutFieldVarient ; (* GetVarient - returns the varient symbol associated with the record or varient field symbol, Field. *) PROCEDURE GetVarient (Field: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Field) ; WITH pSym^ DO CASE SymbolType OF VarientFieldSym : RETURN( VarientField.Varient ) | RecordFieldSym : RETURN( RecordField.Varient ) | VarientSym : RETURN( Varient.Varient ) ELSE RETURN( NulSym ) END END END GetVarient ; (* EnsureOrder - providing that both symbols, a, and, b, exist in list, l. Ensure that, b, is placed after a. *) PROCEDURE EnsureOrder (l: List; a, b: CARDINAL) ; VAR n: CARDINAL ; BEGIN n := NoOfItemsInList(l) ; IF IsItemInList(l, a) AND IsItemInList(l, b) THEN RemoveItemFromList(l, b) ; IncludeItemIntoList(l, b) END ; Assert(n=NoOfItemsInList(l)) END EnsureOrder ; VAR recordConsist: CARDINAL ; (* is used by CheckRecordConsistency and friends. *) (* DumpSons - *) PROCEDURE DumpSons (sym: CARDINAL) ; VAR pSym : PtrToSymbol ; f, n, i: CARDINAL ; BEGIN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF RecordSym: n := NoOfItemsInList(Record.ListOfSons) ; i := 1 ; WHILE i<=n DO f := GetItemFromList(Record.ListOfSons, i) ; printf3('record %d field %d is %d\n', sym, i, f) ; INC(i) END ELSE InternalError ('expecting record symbol') END END END DumpSons ; (* CheckListOfSons - checks to see that sym, is present in, recordConsist, ListOfSons. *) PROCEDURE CheckListOfSons (sym: WORD) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(recordConsist) ; WITH pSym^ DO CASE SymbolType OF RecordSym: IF NOT IsItemInList(Record.ListOfSons, sym) THEN DumpSons(recordConsist) ; MetaError1('internal error: expecting {%1ad} to exist in record ListOfSons', sym) END ELSE InternalError ('expecting record symbol') END END END CheckListOfSons ; (* CheckRecordConsistency - *) PROCEDURE CheckRecordConsistency (sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN RETURN ; pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF RecordSym: recordConsist := sym ; WITH Record DO ForeachNodeDo(LocalSymbols, CheckListOfSons) END | ELSE InternalError ('record symbol expected') END END END CheckRecordConsistency ; (* IsEmptyFieldVarient - returns TRUE if the field variant has no fields. This will occur then the compiler constructs 'else end' variants. *) PROCEDURE IsEmptyFieldVarient (sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF VarientFieldSym: RETURN( NoOfItemsInList(VarientField.ListOfSons)=0 ) ELSE InternalError ('varient field symbol expected') END END END IsEmptyFieldVarient ; (* IsRecordFieldAVarientTag - returns TRUE if record field, sym, is a varient tag. *) PROCEDURE IsRecordFieldAVarientTag (sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN IF IsRecordField(sym) THEN pSym := GetPsym(sym) ; RETURN( pSym^.RecordField.Tag ) ELSE InternalError ('record field symbol expected') END END IsRecordFieldAVarientTag ; (* PutVarientTag - places, Tag, into varient, Sym. *) PROCEDURE PutVarientTag (Sym, Tag: CARDINAL) ; VAR pSym : PtrToSymbol ; parent: CARDINAL ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF VarientSym: Varient.tag := Tag ELSE InternalError ('varient symbol expected') END END ; (* now ensure that if Tag is a RecordField then it must be placed before the varient symbol in its parent ListOfSons. This allows M2GCCDeclare to declare record fields in order and preserve the order of fields. Otherwise it will add the tag field after the C union. *) IF IsRecordField(Tag) THEN pSym := GetPsym(Tag) ; pSym^.RecordField.Tag := TRUE ; parent := GetParent(Sym) ; pSym := GetPsym(parent) ; WITH pSym^ DO CASE SymbolType OF ErrorSym: | VarientSym : EnsureOrder(Varient.ListOfSons, Tag, Sym) | VarientFieldSym: EnsureOrder(VarientField.ListOfSons, Tag, Sym) | RecordSym : EnsureOrder(Record.ListOfSons, Tag, Sym) ; CheckRecordConsistency(parent) ELSE InternalError ('not expecting this symbol type') END END END END PutVarientTag ; (* GetVarientTag - returns the varient tag from, Sym. *) PROCEDURE GetVarientTag (Sym: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF VarientSym: RETURN( Varient.tag ) ELSE InternalError ('varient symbol expected') END END END GetVarientTag ; (* IsFieldVarient - returns true if the symbol, Sym, is a varient field. *) PROCEDURE IsFieldVarient (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; RETURN( pSym^.SymbolType=VarientFieldSym ) END IsFieldVarient ; (* IsFieldEnumeration - returns true if the symbol, Sym, is an enumeration field. *) PROCEDURE IsFieldEnumeration (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; RETURN( pSym^.SymbolType=EnumerationFieldSym ) END IsFieldEnumeration ; (* IsVarient - returns true if the symbol, Sym, is a varient symbol. *) PROCEDURE IsVarient (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; RETURN( pSym^.SymbolType=VarientSym ) END IsVarient ; (* PutUnused - sets, sym, as unused. This is a gm2 pragma. *) PROCEDURE PutUnused (sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF RecordFieldSym: RecordField.Used := FALSE ELSE MetaError1("cannot use pragma 'unused' on symbol {%1ad}", sym) END END END PutUnused ; (* IsUnused - returns TRUE if the symbol was declared as unused with a gm2 pragma. *) PROCEDURE IsUnused (sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF RecordFieldSym: RETURN( NOT RecordField.Used ) ELSE InternalError ('expecting a record field symbol') END END END IsUnused ; (* PutFieldEnumeration - places a field into the enumeration type Sym. The field has a name FieldName and a value FieldVal. *) PROCEDURE PutFieldEnumeration (tok: CARDINAL; Sym: CARDINAL; FieldName: Name) ; VAR oSym, pSym : PtrToSymbol ; s : String ; Field: CARDINAL ; BEGIN Field := CheckForHiddenType(FieldName) ; IF Field=NulSym THEN Field := DeclareSym (tok, FieldName) END ; IF NOT IsError(Field) THEN pSym := GetPsym(Field) ; WITH pSym^ DO SymbolType := EnumerationFieldSym ; WITH EnumerationField DO name := FieldName ; (* Index into name array, name *) (* of type. *) oSym := GetPsym(Sym) ; PushCard(oSym^.Enumeration.NoOfElements) ; Value := InitValue() ; PopInto(Value) ; Type := Sym ; Scope := GetCurrentScope() ; InitWhereDeclaredTok (tok, At) (* Declared here *) END END ; pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF EnumerationSym: WITH Enumeration DO INC(NoOfElements) ; IF GetSymKey(LocalSymbols, FieldName)#NulSym THEN s := Mark(InitStringCharStar(KeyToCharStar(FieldName))) ; AlreadyDeclaredError(Sprintf1(Mark(InitString('enumeration field (%s) is already declared elsewhere, use a different name or remove the declaration')), s), FieldName, GetDeclaredMod(GetSymKey(LocalSymbols, FieldName))) ELSE PutSymKey(LocalSymbols, FieldName, Field) ; IncludeItemIntoList (ListOfFields, Field) END END ELSE InternalError ('expecting Sym=Enumeration') END END END END PutFieldEnumeration ; (* PutType - gives a type symbol Sym type TypeSymbol. *) PROCEDURE PutType (Sym: CARDINAL; TypeSymbol: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN IF TypeSymbol=Sym THEN InternalError ('not expecting a type to be declared as itself') END ; pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym: | TypeSym : Type.Type := TypeSymbol ELSE InternalError ('expecting a Type symbol') END END END PutType ; (* IsDefImp - returns true is the Sym is a DefImp symbol. Definition/Implementation module symbol. *) PROCEDURE IsDefImp (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; RETURN( pSym^.SymbolType=DefImpSym ) END IsDefImp ; (* IsModule - returns true is the Sym is a Module symbol. Program module symbol. *) PROCEDURE IsModule (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; RETURN( pSym^.SymbolType=ModuleSym ) END IsModule ; (* IsInnerModule - returns true if the symbol, Sym, is an inner module. *) PROCEDURE IsInnerModule (Sym: CARDINAL) : BOOLEAN ; BEGIN IF IsModule(Sym) THEN RETURN( GetScope(Sym)#NulSym ) ELSE RETURN( FALSE ) END END IsInnerModule ; (* GetSymName - returns the symbol name. *) PROCEDURE GetSymName (Sym: CARDINAL) : Name ; VAR pSym: PtrToSymbol ; n : Name ; BEGIN IF Sym=NulSym THEN n := NulKey ELSE pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym : n := Error.name | ObjectSym : n := Object.name | DefImpSym : n := DefImp.name | ModuleSym : n := Module.name | TypeSym : n := Type.name | VarSym : n := Var.name | ConstLitSym : n := ConstLit.name | ConstVarSym : n := ConstVar.name | ConstStringSym : n := ConstString.name | EnumerationSym : n := Enumeration.name | EnumerationFieldSym : n := EnumerationField.name | UndefinedSym : n := Undefined.name | ProcedureSym : n := Procedure.name | ProcTypeSym : n := ProcType.name | RecordFieldSym : n := RecordField.name | RecordSym : n := Record.name | VarientSym : n := NulName | VarientFieldSym : n := VarientField.name | VarParamSym : n := VarParam.name | ParamSym : n := Param.name | PointerSym : n := Pointer.name | ArraySym : n := Array.name | UnboundedSym : n := NulName | SubrangeSym : n := Subrange.name | SetSym : n := Set.name | SubscriptSym : n := NulName | DummySym : n := NulName | PartialUnboundedSym : n := GetSymName(PartialUnbounded.Type) | TupleSym : n := NulName | GnuAsmSym : n := NulName | InterfaceSym : n := NulName | ImportSym : n := NulName | ImportStatementSym : n := NulName ELSE InternalError ('unexpected symbol type') END END END ; RETURN( n ) END GetSymName ; (* PutConstVarTemporary - indicates that constant, sym, is a temporary. *) PROCEDURE PutConstVarTemporary (sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF ConstVarSym: ConstVar.IsTemp := TRUE ELSE InternalError ('expecting a Var symbol') END END END PutConstVarTemporary ; (* buildTemporary - builds the temporary filling in componentRef, record and sets mode. *) PROCEDURE buildTemporary (tok: CARDINAL; Mode: ModeOfAddr; componentRef: BOOLEAN; record: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; s : String ; Sym : CARDINAL ; BEGIN INC(TemporaryNo) ; (* Make the name *) s := Sprintf1(Mark(InitString('_T%d')), TemporaryNo) ; IF Mode=ImmediateValue THEN Sym := MakeConstVar(tok, makekey(string(s))) ; PutConstVarTemporary(Sym) ELSE Sym := MakeVar(tok, makekey(string(s))) ; pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF VarSym : Var.AddrMode := Mode ; Var.IsComponentRef := componentRef ; Var.IsTemp := TRUE ; (* Variable is a temporary var *) IF componentRef THEN Var.list := Indexing.InitIndex(1) ; PutIntoIndex(Var.list, 1, record) END ; InitWhereDeclaredTok(tok, Var.At) ; (* Declared here *) InitWhereFirstUsedTok(tok, Var.At) ; (* Where symbol first used. *) ELSE InternalError ('expecting a Var symbol') END END END ; s := KillString(s) ; RETURN Sym END buildTemporary ; (* MakeComponentRef - use, sym, to reference, field, sym is returned. *) PROCEDURE MakeComponentRef (sym: CARDINAL; field: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; high: CARDINAL ; BEGIN pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF VarSym: IF NOT Var.IsTemp THEN InternalError ('variable must be a temporary') ELSIF Var.IsComponentRef THEN high := Indexing.HighIndice (Var.list) ; PutIntoIndex (Var.list, high+1, field) ELSE InternalError ('temporary is not a component reference') END ELSE InternalError ('expecting a variable symbol') END END ; RETURN( sym ) END MakeComponentRef ; (* MakeComponentRecord - make a temporary which will be used to reference and field (or sub field) of record. *) PROCEDURE MakeComponentRecord (tok: CARDINAL; Mode: ModeOfAddr; record: CARDINAL) : CARDINAL ; BEGIN RETURN buildTemporary (tok, Mode, TRUE, record) END MakeComponentRecord ; (* IsComponent - returns TRUE if symbol, sym, is a temporary and a component reference. *) PROCEDURE IsComponent (sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF VarSym: RETURN( Var.IsComponentRef ) ELSE RETURN( FALSE ) END END END IsComponent ; (* MakeTemporary - Makes a new temporary variable at the highest real scope. The addressing mode of the temporary is set to NoValue. *) PROCEDURE MakeTemporary (tok: CARDINAL; Mode: ModeOfAddr) : CARDINAL ; BEGIN tok := CheckTok (tok, 'temporary') ; RETURN buildTemporary (tok, Mode, FALSE, NulSym) END MakeTemporary ; (* MakeTemporaryFromExpressions - makes a new temporary variable at the highest real scope. The addressing mode of the temporary is set and the type is determined by expressions, e1 and e2. *) PROCEDURE MakeTemporaryFromExpressions (tok: CARDINAL; e1, e2: CARDINAL; mode: ModeOfAddr) : CARDINAL ; VAR pSym: PtrToSymbol ; s : String ; t, Sym : CARDINAL ; BEGIN INC(TemporaryNo) ; (* Make the name *) s := Sprintf1(Mark(InitString('_T%d')), TemporaryNo) ; IF mode=ImmediateValue THEN Sym := MakeConstVar(tok, makekey(string(s))) ; IF IsConstructor(e1) THEN PutConstructor(Sym) ; PutConstructorFrom(Sym, e1) ELSIF IsConstructor(e2) THEN PutConstructor(Sym) ; PutConstructorFrom(Sym, e2) ELSE PutVar(Sym, MixTypes(GetType(e1), GetType(e2), tok)) END ; PutConstVarTemporary(Sym) ELSE Sym := MakeVar(tok, makekey(string(s))) ; pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF VarSym : Var.AddrMode := mode ; Var.IsComponentRef := FALSE ; Var.IsTemp := TRUE ; (* Variable is a temporary var *) InitWhereDeclaredTok(tok, Var.At) (* Declared here *) ELSE InternalError ('expecting a Var symbol') END END ; t := MixTypesDecl (e1, e2, GetType(e1), GetType(e2), tok) ; IF t#NulSym THEN Assert(NOT IsConstructor(t)) ; PutVar(Sym, t) END END ; s := KillString(s) ; RETURN( Sym ) END MakeTemporaryFromExpressions ; (* MakeTemporaryFromExpression - makes a new temporary variable at the highest real scope. The addressing mode of the temporary is set and the type is determined by expressions, e. *) PROCEDURE MakeTemporaryFromExpression (tok: CARDINAL; e: CARDINAL; mode: ModeOfAddr) : CARDINAL ; BEGIN RETURN MakeTemporaryFromExpressions (tok, e, e, mode) END MakeTemporaryFromExpression ; (* PutMode - Puts the addressing mode, SymMode, into symbol Sym. The mode may only be altered if the mode is None. *) PROCEDURE PutMode (Sym: CARDINAL; SymMode: ModeOfAddr) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym: | VarSym : Var.AddrMode := SymMode ELSE InternalError ('Expecting VarSym') END END END PutMode ; (* GetMode - Returns the addressing mode of a symbol. *) PROCEDURE GetMode (Sym: CARDINAL) : ModeOfAddr ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym : ErrorAbort0('') | VarSym : RETURN( Var.AddrMode ) | ConstLitSym : RETURN( ImmediateValue ) | ConstVarSym : RETURN( ImmediateValue ) | ConstStringSym : RETURN( ImmediateValue ) | EnumerationFieldSym: RETURN( ImmediateValue ) | ProcedureSym : RETURN( ImmediateValue ) | RecordFieldSym : RETURN( ImmediateValue ) | VarientFieldSym : RETURN( ImmediateValue ) | TypeSym : RETURN( NoValue ) | ArraySym : RETURN( NoValue ) | SubrangeSym : RETURN( NoValue ) | EnumerationSym : RETURN( NoValue ) | RecordSym : RETURN( NoValue ) | PointerSym : RETURN( NoValue ) | SetSym : RETURN( NoValue ) | ProcTypeSym : RETURN( NoValue ) | UnboundedSym : RETURN( NoValue ) | UndefinedSym : RETURN( NoValue ) ELSE InternalError ('not expecting this type') END END END GetMode ; (* RenameSym - renames a symbol, Sym, with SymName. It also checks the unknown tree for a symbol with this new name. Must only be renamed in the same scope of being declared. *) PROCEDURE RenameSym (Sym: CARDINAL; SymName: Name) ; VAR pSym: PtrToSymbol ; BEGIN IF GetSymName(Sym)=NulName THEN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym : ErrorAbort0('') | TypeSym : Type.name := SymName | VarSym : Var.name := SymName | ConstLitSym : ConstLit.name := SymName | ConstVarSym : ConstVar.name := SymName | UndefinedSym : Undefined.name := SymName | RecordSym : Record.name := SymName | PointerSym : Pointer.name := SymName ELSE InternalError ('not implemented yet') END END ; AddSymToScope(Sym, SymName) ELSE InternalError ('old name of symbol must be nul') END END RenameSym ; (* IsUnknown - returns true is the symbol Sym is unknown. *) PROCEDURE IsUnknown (Sym: WORD) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN AssertInRange (Sym) ; pSym := GetPsym(Sym) ; RETURN pSym^.SymbolType=UndefinedSym END IsUnknown ; (* AssertInRange - determines whether the Sym is a legal symbol. *) PROCEDURE AssertInRange (Sym: CARDINAL) ; BEGIN IF (Sym<1) OR (Sym>FinalSymbol()) THEN InternalError ('illegal symbol') END END AssertInRange ; (* CheckForHiddenType - scans the NeedToBeImplemented tree providing that we are currently compiling an implementation module. If a symbol is found with TypeName then its Sym is returned. Otherwise NulSym is returned. CheckForHiddenType is called before any type is created, therefore the compiler allows hidden types to be implemented using any type. *) PROCEDURE CheckForHiddenType (TypeName: Name) : CARDINAL ; VAR pSym: PtrToSymbol ; Sym : CARDINAL ; BEGIN Sym := NulSym ; IF CompilingImplementationModule() AND IsDefImp(CurrentModule) AND IsHiddenTypeDeclared(CurrentModule) AND (TypeName#NulName) THEN (* Check to see whether we are declaring a HiddenType. *) pSym := GetPsym(CurrentModule) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: Sym := GetSymKey(DefImp.NeedToBeImplemented, TypeName) ELSE InternalError ('expecting a DefImp symbol') END END END ; RETURN( Sym ) END CheckForHiddenType ; (* IsReallyPointer - returns TRUE is sym is a pointer, address or a type declared as a pointer or address. *) PROCEDURE IsReallyPointer (Sym: CARDINAL) : BOOLEAN ; BEGIN IF IsVar (Sym) THEN Sym := GetType (Sym) END ; Sym := SkipType (Sym) ; RETURN IsPointer (Sym) OR (Sym = Address) OR IsHiddenReallyPointer (Sym) END IsReallyPointer ; (* IsHiddenReallyPointer - returns TRUE is sym is a pointer, address or a type declared as a pointer or address. *) PROCEDURE IsHiddenReallyPointer (Sym: CARDINAL) : BOOLEAN ; BEGIN IF IsVar (Sym) THEN Sym := GetType (Sym) END ; WHILE (Sym # NulSym) AND IsType (Sym) DO Sym := SkipType (GetType (Sym)) END ; RETURN (Sym # NulSym) AND (IsPointer (Sym) OR (Sym = Address)) END IsHiddenReallyPointer ; (* CheckHiddenTypeAreAddress - checks to see that any hidden types which we have declared are actually of type ADDRESS or map onto a POINTER type. *) PROCEDURE CheckHiddenTypeAreAddress ; VAR name: Name ; e : Error ; sym, i, n: CARDINAL ; BEGIN i := 1 ; n := NoOfItemsInList(AddressTypes) ; WHILE i<=n DO sym := GetItemFromList(AddressTypes, i) ; IF NOT IsHiddenReallyPointer(sym) THEN name := GetSymName(sym) ; e := NewError(GetDeclaredDef(sym)) ; ErrorFormat1(e, 'opaque type (%a) should be equivalent to a POINTER or an ADDRESS', name) ; e := NewError(GetDeclaredMod(sym)) ; ErrorFormat0(e, 'if you really need a non POINTER type use the -fextended-opaque switch') END ; INC(i) END END CheckHiddenTypeAreAddress ; (* GetLastMainScopeId - returns the, id, containing the last main scope. *) (* PROCEDURE GetLastMainScopeId (id: CARDINAL) : CARDINAL ; VAR pCall: PtrToCallFrame ; sym : CARDINAL ; BEGIN IF id>0 THEN pCall := GetPcall(id) ; sym := pCall^.Main ; WHILE id>1 DO DEC(id) ; pCall := GetPcall(id) ; IF sym#pCall^.Main THEN RETURN( id ) END END END ; RETURN( 0 ) END GetLastMainScopeId ; *) (* GetDeclareSym - searches for a symbol with a name SymName in the current and previous scopes. If the symbol is found then it is returned else an unknown symbol is returned. This procedure assumes that SymName is being declared at this point and therefore it does not examine the base scope (for pervasive identifiers). *) PROCEDURE GetDeclareSym (tok: CARDINAL; SymName: Name) : CARDINAL ; VAR Sym: CARDINAL ; BEGIN Sym := GetScopeSym (SymName, FALSE) ; (* must not be allowed to fetch a symbol through a procedure scope *) IF Sym=NulSym THEN Sym := GetSymFromUnknownTree (SymName) ; IF Sym=NulSym THEN (* Make unknown *) NewSym (Sym) ; FillInUnknownFields (tok, Sym, SymName) ; (* Add to unknown tree *) AddSymToUnknownTree (ScopePtr, SymName, Sym) (* ; WriteKey(SymName) ; WriteString(' unknown demanded') ; WriteLn *) END END ; RETURN Sym END GetDeclareSym ; (* RequestSym - searches for a symbol with a name SymName in the current and previous scopes. If the symbol is found then it is returned else an unknown symbol is returned create at token position, tok. This procedure does search the base scope (for pervasive identifiers). *) PROCEDURE RequestSym (tok: CARDINAL; SymName: Name) : CARDINAL ; VAR Sym: CARDINAL ; BEGIN (* WriteString('RequestSym for: ') ; WriteKey(SymName) ; WriteLn ; *) Sym := GetSym (SymName) ; IF Sym=NulSym THEN Sym := GetSymFromUnknownTree (SymName) ; IF Sym=NulSym THEN (* Make unknown *) NewSym (Sym) ; FillInUnknownFields (tok, Sym, SymName) ; (* Add to unknown tree *) AddSymToUnknownTree (ScopePtr, SymName, Sym) (* ; WriteKey(SymName) ; WriteString(' unknown demanded') ; WriteLn *) END END ; RETURN( Sym ) END RequestSym ; (* PutImported - places a symbol, Sym, into the current main scope. *) PROCEDURE PutImported (Sym: CARDINAL) ; VAR pSym : PtrToSymbol ; ModSym: CARDINAL ; n : Name ; BEGIN (* We have currently imported Sym, now place it into the current module. *) ModSym := GetCurrentModuleScope() ; Assert(IsDefImp(ModSym) OR IsModule(ModSym)) ; pSym := GetPsym(ModSym) ; WITH pSym^ DO CASE SymbolType OF ModuleSym: IF GetSymKey(Module.ImportTree, GetSymName(Sym))=Sym THEN IF Pedantic THEN n := GetSymName(Sym) ; WriteFormat1('symbol (%a) has already been imported', n) END ELSIF GetSymKey(Module.ImportTree, GetSymName(Sym))=NulKey THEN IF GetSymKey(Module.WhereImported, Sym)=NulKey THEN PutSymKey(Module.WhereImported, Sym, GetTokenNo()) END ; PutSymKey(Module.ImportTree, GetSymName(Sym), Sym) ; AddSymToModuleScope(ModSym, Sym) ELSE n := GetSymName(Sym) ; WriteFormat1('name clash when trying to import (%a)', n) END | DefImpSym: IF GetSymKey(DefImp.ImportTree, GetSymName(Sym))=Sym THEN IF Pedantic THEN n := GetSymName(Sym) ; WriteFormat1('symbol (%a) has already been imported', n) END ELSIF GetSymKey(DefImp.ImportTree, GetSymName(Sym))=NulKey THEN IF GetSymKey(DefImp.WhereImported, Sym)=NulKey THEN PutSymKey(DefImp.WhereImported, Sym, GetTokenNo()) END ; PutSymKey(DefImp.ImportTree, GetSymName(Sym), Sym) ; AddSymToModuleScope(ModSym, Sym) ELSE n := GetSymName(Sym) ; WriteFormat1('name clash when trying to import (%a)', n) END ELSE InternalError ('expecting a Module or DefImp symbol') END END END PutImported ; (* PutIncluded - places a symbol, Sym, into the included list of the current module. Symbols that are placed in this list are indirectly declared by: IMPORT modulename ; modulename.identifier *) PROCEDURE PutIncluded (Sym: CARDINAL) ; VAR pSym : PtrToSymbol ; ModSym: CARDINAL ; n1, n2: Name ; BEGIN (* We have referenced Sym, via modulename.Sym now place it into the current module include list. *) ModSym := GetCurrentModuleScope() ; Assert(IsDefImp(ModSym) OR IsModule(ModSym)) ; IF DebugUnknowns THEN n1 := GetSymName(Sym) ; n2 := GetSymName(ModSym) ; printf2('including %a into scope %a\n', n1, n2) END ; pSym := GetPsym(ModSym) ; WITH pSym^ DO CASE SymbolType OF ModuleSym: IncludeItemIntoList(Module.IncludeList, Sym) | DefImpSym: IncludeItemIntoList(DefImp.IncludeList, Sym) ELSE InternalError ('expecting a Module or DefImp symbol') END END END PutIncluded ; (* PutExported - places a symbol, Sym into the next level out module. Sym is also placed in the ExportTree of the current inner module. *) PROCEDURE PutExported (Sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN (* WriteString('PutExported') ; WriteLn ; *) AddSymToModuleScope(GetLastModuleOrProcedureScope(), Sym) ; pSym := GetPsym(GetCurrentModuleScope()) ; WITH pSym^ DO CASE SymbolType OF ModuleSym: PutSymKey(Module.ExportTree, GetSymName(Sym), Sym) ; IF IsUnknown(Sym) THEN PutExportUndeclared(GetCurrentModuleScope(), Sym) END (* ; WriteKey(Module.name) ; WriteString(' exports ') ; ; WriteKey(GetSymName(Sym)) ; WriteLn ; *) ELSE InternalError ('expecting a Module symbol') END END END PutExported ; (* PutExportQualified - places a symbol with the name, SymName, into the export tree of the Definition module being compiled. The symbol with name has been EXPORT QUALIFIED by the definition module and therefore any reference to this symbol in the code generation phase will be in the form _Module_Name. *) PROCEDURE PutExportQualified (tokenno: CARDINAL; SymName: Name) ; VAR pSym : PtrToSymbol ; n : Name ; Sym, ModSym: CARDINAL ; BEGIN ModSym := GetCurrentModule () ; Assert (IsDefImp (ModSym)) ; Assert (CompilingDefinitionModule () OR (GetSymName(ModSym) = MakeKey ('SYSTEM'))) ; (* printf2('module %a exporting %a\n', GetSymName(ModSym), SymName) ; *) (* WriteString('1st MODULE ') ; WriteKey(GetSymName(ModSym)) ; WriteString(' identifier ') ; WriteKey(SymName) ; WriteLn ; *) pSym := GetPsym (ModSym) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: WITH DefImp DO IF (GetSymKey (ExportQualifiedTree, SymName) # NulKey) AND (GetSymKey (ExportRequest, SymName) = NulKey) THEN n := GetSymName(ModSym) ; WriteFormat2('identifier (%a) has already been exported from MODULE %a', SymName, n) ELSIF GetSymKey(ExportRequest, SymName)#NulKey THEN Sym := GetSymKey(ExportRequest, SymName) ; DelSymKey(ExportRequest, SymName) ; PutSymKey(ExportQualifiedTree, SymName, Sym) ; PutExportUndeclared (ModSym, Sym) ELSE Sym := GetDeclareSym(tokenno, SymName) ; PutSymKey(ExportQualifiedTree, SymName, Sym) ; PutExportUndeclared (ModSym, Sym) END END ELSE InternalError ('expecting a DefImp symbol') END END END PutExportQualified ; (* PutExportUnQualified - places a symbol with the name, SymName, into the export tree of the Definition module being compiled. The symbol with Name has been EXPORT UNQUALIFIED by the definition module and therefore any reference to this symbol in the code generation phase will be in the form _Name. *) PROCEDURE PutExportUnQualified (tokenno: CARDINAL; SymName: Name) ; VAR pSym : PtrToSymbol ; n : Name ; Sym, ModSym: CARDINAL ; BEGIN ModSym := GetCurrentModule() ; Assert(IsDefImp(ModSym)) ; Assert(CompilingDefinitionModule() OR (GetSymName(ModSym)=MakeKey('SYSTEM'))) ; pSym := GetPsym(ModSym) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: WITH DefImp DO IF (GetSymKey(ExportUnQualifiedTree, SymName)#NulKey) AND (GetSymKey(ExportRequest, SymName)=NulKey) THEN n := GetSymName(ModSym) ; WriteFormat2('identifier (%a) has already been exported from MODULE %a', SymName, n) ELSIF GetSymKey(ExportRequest, SymName)#NulKey THEN Sym := GetSymKey(ExportRequest, SymName) ; DelSymKey(ExportRequest, SymName) ; PutSymKey(ExportUnQualifiedTree, SymName, Sym) ; PutExportUndeclared(ModSym, Sym) ELSE Sym := GetDeclareSym(tokenno, SymName) ; PutSymKey(ExportUnQualifiedTree, SymName, Sym) ; PutExportUndeclared(ModSym, Sym) END END ELSE InternalError ('expecting a DefImp symbol') END END END PutExportUnQualified ; (* GetExported - returns the symbol which has a name SymName, and is exported from the definition module ModSym. *) PROCEDURE GetExported (tokenno: CARDINAL; ModSym: CARDINAL; SymName: Name) : CARDINAL ; VAR pSym: PtrToSymbol ; Sym : CARDINAL ; BEGIN pSym := GetPsym(ModSym) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: Sym := RequestFromDefinition (tokenno, ModSym, SymName) | ModuleSym: Sym := RequestFromModule (tokenno, ModSym, SymName) ELSE InternalError ('expecting a DefImp symbol') END END ; RETURN( Sym ) END GetExported ; (* RequestFromModule - returns a symbol from module ModSym with name, SymName. *) PROCEDURE RequestFromModule (tok: CARDINAL; ModSym: CARDINAL; SymName: Name) : CARDINAL ; VAR pSym: PtrToSymbol ; Sym : CARDINAL ; BEGIN pSym := GetPsym(ModSym) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: WITH DefImp DO Sym := GetSymKey (LocalSymbols, SymName) ; IF Sym=NulSym THEN Sym := FetchUnknownFromDefImp (tok, ModSym, SymName) END END | ModuleSym: WITH Module DO Sym := GetSymKey (LocalSymbols, SymName) ; IF Sym=NulSym THEN Sym := FetchUnknownFromModule (tok, ModSym, SymName) END END ELSE InternalError ('expecting a DefImp or Module symbol') END END ; RETURN( Sym ) END RequestFromModule ; (* RequestFromDefinition - returns a symbol from module ModSym with name, SymName. *) PROCEDURE RequestFromDefinition (tok: CARDINAL; ModSym: CARDINAL; SymName: Name) : CARDINAL ; VAR pSym : PtrToSymbol ; Sym : CARDINAL ; OldScopePtr: CARDINAL ; BEGIN pSym := GetPsym(ModSym) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: WITH DefImp DO Sym := GetSymKey (ExportQualifiedTree, SymName) ; IF Sym=NulSym THEN Sym := GetSymKey (ExportUnQualifiedTree, SymName) ; IF Sym=NulSym THEN Sym := GetSymKey (ExportRequest, SymName) ; IF Sym=NulSym THEN OldScopePtr := ScopePtr ; StartScope (ModSym) ; Sym := GetScopeSym (SymName, TRUE) ; EndScope ; Assert (OldScopePtr=ScopePtr) ; IF Sym=NulSym THEN Sym := FetchUnknownFromDefImp (tok, ModSym, SymName) ELSE IF IsFieldEnumeration (Sym) THEN IF IsExported (ModSym, GetType (Sym)) THEN RETURN( Sym ) END END END ; PutSymKey (ExportRequest, SymName, Sym) END END END END ELSE InternalError ('expecting a DefImp symbol') END END ; RETURN( Sym ) END RequestFromDefinition ; (* PutIncludedByDefinition - places a module symbol, Sym, into the included list of the current definition module. *) PROCEDURE PutIncludedByDefinition (Sym: CARDINAL) ; VAR pSym : PtrToSymbol ; ModSym: CARDINAL ; BEGIN ModSym := GetCurrentModuleScope() ; Assert(IsDefImp(ModSym)) ; Assert(IsDefImp(Sym)) ; pSym := GetPsym(ModSym) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: IncludeItemIntoList(DefImp.DefIncludeList, Sym) ELSE InternalError ('expecting a DefImp symbol') END END END PutIncludedByDefinition ; (* IsIncludedByDefinition - returns TRUE if definition module symbol, Sym, was included by ModSym's definition module. *) PROCEDURE IsIncludedByDefinition (ModSym, Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN Assert(IsDefImp(ModSym)) ; Assert(IsDefImp(Sym)) ; pSym := GetPsym(ModSym) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: RETURN( IsItemInList(DefImp.DefIncludeList, Sym) ) ELSE InternalError ('expecting a DefImp symbol') END END END IsIncludedByDefinition ; (* GetWhereImported - returns the token number where this symbol was imported into the current module. *) PROCEDURE GetWhereImported (Sym: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(GetCurrentModuleScope()) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: RETURN( GetSymKey(DefImp.WhereImported, Sym) ) | ModuleSym: RETURN( GetSymKey(Module.WhereImported, Sym) ) ELSE InternalError ('expecting DefImp or Module symbol') END END END GetWhereImported ; (* DisplayName - displays the name. *) PROCEDURE DisplayName (sym: WORD) ; BEGIN printf1(' %a', sym) END DisplayName ; (* DisplaySymbol - displays the name of a symbol *) PROCEDURE DisplaySymbol (sym: WORD) ; VAR s: String ; BEGIN s := Mark(InitStringCharStar(KeyToCharStar(GetSymName(sym)))) ; printf2(' %s (%d)', s, sym) END DisplaySymbol ; (* DisplayTrees - displays the SymbolTrees for Module symbol, ModSym. *) PROCEDURE DisplayTrees (ModSym: CARDINAL) ; VAR pSym: PtrToSymbol ; n : Name ; BEGIN n := GetSymName(ModSym) ; printf1('Symbol trees for module/procedure: %a\n', n) ; pSym := GetPsym(ModSym) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: WITH DefImp DO n := GetSymName(ModSym) ; printf1('%a UndefinedTree', n) ; ForeachNodeDo(Unresolved, DisplaySymbol) ; printf0('\n') ; printf1('%a Local symbols', n) ; ForeachNodeDo(LocalSymbols, DisplaySymbol) ; printf0('\n') ; printf1('%a ExportRequest', n) ; ForeachNodeDo(ExportRequest, DisplaySymbol) ; printf0('\n') ; printf1('%a ExportQualified', n) ; ForeachNodeDo(ExportQualifiedTree, DisplaySymbol) ; printf0('\n') ; printf1('%a ExportUnQualified', n) ; ForeachNodeDo(ExportUnQualifiedTree, DisplaySymbol) ; printf0('\n') ; printf1('%a ExportUndeclared', n) ; ForeachNodeDo(ExportUndeclared, DisplaySymbol) ; printf0('\n') ; printf1('%a DeclaredObjects', n) ; ForeachNodeDo(NamedObjects, DisplaySymbol) ; printf0('\n') ; printf1('%a ImportedObjects', n) ; ForeachNodeDo(NamedImports, DisplayName) ; printf0('\n') END | ModuleSym: WITH Module DO n := GetSymName(ModSym) ; printf1('%a UndefinedTree', n) ; ForeachNodeDo(Unresolved, DisplaySymbol) ; printf0('\n') ; printf1('%a Local symbols', n) ; ForeachNodeDo(LocalSymbols, DisplaySymbol) ; printf0('\n') ; printf1('%a ImportTree', n) ; ForeachNodeDo(ImportTree, DisplaySymbol) ; printf0('\n') ; printf1('%a ExportTree', n) ; ForeachNodeDo(ExportTree, DisplaySymbol) ; printf0('\n') ; printf1('%a ExportUndeclared', n) ; ForeachNodeDo(ExportUndeclared, DisplaySymbol) ; printf0('\n') ; printf1('%a DeclaredObjects', n) ; ForeachNodeDo(NamedObjects, DisplaySymbol) ; printf0('\n') ; printf1('%a ImportedObjects', n) ; ForeachNodeDo(NamedImports, DisplayName) ; printf0('\n') END | ProcedureSym: WITH Procedure DO n := GetSymName(ModSym) ; printf1('%a UndefinedTree', n) ; ForeachNodeDo(Unresolved, DisplaySymbol) ; printf0('\n') ; printf1('%a Local symbols', n) ; ForeachNodeDo(LocalSymbols, DisplaySymbol) ; printf0('\n') ; printf1('%a DeclaredObjects', n) ; ForeachNodeDo(NamedObjects, DisplayName) ; printf0('\n') END ELSE InternalError ('expecting DefImp symbol') END END END DisplayTrees ; (* FetchUnknownFromModule - returns an Unknown symbol from module, ModSym. *) PROCEDURE FetchUnknownFromModule (tok: CARDINAL; ModSym: CARDINAL; SymName: Name) : CARDINAL ; VAR pSym: PtrToSymbol ; Sym : CARDINAL ; BEGIN pSym := GetPsym (ModSym) ; WITH pSym^ DO CASE SymbolType OF ModuleSym: WITH Module DO Sym := GetSymKey (Unresolved, SymName) ; IF Sym=NulSym THEN NewSym (Sym) ; FillInUnknownFields (tok, Sym, SymName) ; PutSymKey (Unresolved, SymName, Sym) END END ELSE InternalError ('expecting a Module symbol') END END ; RETURN( Sym ) END FetchUnknownFromModule ; (* FetchUnknownFromDefImp - returns an Unknown symbol from module, ModSym. *) PROCEDURE FetchUnknownFromDefImp (tok: CARDINAL; ModSym: CARDINAL; SymName: Name) : CARDINAL ; VAR pSym: PtrToSymbol ; Sym : CARDINAL ; BEGIN pSym := GetPsym (ModSym) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: WITH DefImp DO Sym := GetSymKey (Unresolved , SymName) ; IF Sym=NulSym THEN NewSym(Sym) ; FillInUnknownFields (tok, Sym, SymName) ; PutSymKey (Unresolved, SymName, Sym) END END ELSE InternalError ('expecting a DefImp symbol') END END ; RETURN( Sym ) END FetchUnknownFromDefImp ; PROCEDURE FetchUnknownFrom (tok: CARDINAL; scope: CARDINAL; SymName: Name) : CARDINAL ; VAR pSym: PtrToSymbol ; Sym : CARDINAL ; BEGIN pSym := GetPsym(scope) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: WITH DefImp DO Sym := GetSymKey(Unresolved, SymName) ; IF Sym=NulSym THEN NewSym(Sym) ; FillInUnknownFields (tok, Sym, SymName) ; PutSymKey(Unresolved, SymName, Sym) END END | ModuleSym: WITH Module DO Sym := GetSymKey(Unresolved, SymName) ; IF Sym=NulSym THEN NewSym(Sym) ; FillInUnknownFields (tok, Sym, SymName) ; PutSymKey(Unresolved, SymName, Sym) END END | ProcedureSym: WITH Procedure DO Sym := GetSymKey(Unresolved, SymName) ; IF Sym=NulSym THEN NewSym(Sym) ; FillInUnknownFields (tok, Sym, SymName) ; PutSymKey(Unresolved, SymName, Sym) END END ELSE InternalError ('expecting a DefImp or Module or Procedure symbol') END END ; RETURN( Sym ) END FetchUnknownFrom ; (* GetFromOuterModule - returns a symbol with name, SymName, which comes from outside the current module. *) PROCEDURE GetFromOuterModule (tokenno: CARDINAL; SymName: Name) : CARDINAL ; VAR pCall : PtrToCallFrame ; ScopeId : CARDINAL ; Sym, ScopeSym: CARDINAL ; BEGIN ScopeId := ScopePtr ; pCall := GetPcall(ScopeId) ; WHILE (NOT IsModule(pCall^.Search)) AND (NOT IsDefImp(pCall^.Search)) DO Assert (ScopeId>0) ; DEC (ScopeId) ; pCall := GetPcall (ScopeId) END ; DEC (ScopeId) ; (* we are now below the current module *) WHILE ScopeId>0 DO pCall := GetPcall(ScopeId) ; ScopeSym := pCall^.Search ; IF ScopeSym#NulSym THEN Sym := GetLocalSym(ScopeSym, SymName) ; IF Sym=NulSym THEN IF IsModule(ScopeSym) OR IsProcedure(ScopeSym) OR IsDefImp(ScopeSym) THEN IF Sym=NulSym THEN Sym := ExamineUnresolvedTree(ScopeSym, SymName) ; IF Sym#NulSym THEN RETURN( Sym ) END END END ELSE RETURN( Sym ) END END ; DEC(ScopeId) ; pCall := GetPcall(ScopeId) END ; (* at this point we force an unknown from the last module scope *) RETURN( RequestFromModule (tokenno, GetLastModuleScope(), SymName) ) END GetFromOuterModule ; (* IsExportUnQualified - returns true if a symbol, Sym, was defined as being EXPORT UNQUALIFIED. *) PROCEDURE IsExportUnQualified (Sym: CARDINAL) : BOOLEAN ; VAR pSym : PtrToSymbol ; OuterModule: CARDINAL ; BEGIN OuterModule := Sym ; REPEAT OuterModule := GetScope(OuterModule) UNTIL GetScope(OuterModule)=NulSym ; pSym := GetPsym(OuterModule) ; WITH pSym^ DO CASE SymbolType OF ModuleSym: RETURN( FALSE ) | DefImpSym: RETURN( GetSymKey( DefImp.ExportUnQualifiedTree, GetSymName(Sym) )=Sym ) ELSE InternalError ('expecting a DefImp or Module symbol') END END END IsExportUnQualified ; (* IsExportQualified - returns true if a symbol, Sym, was defined as being EXPORT QUALIFIED. Sym is expected to be either a procedure or a variable. *) PROCEDURE IsExportQualified (Sym: CARDINAL) : BOOLEAN ; VAR pSym : PtrToSymbol ; OuterModule: CARDINAL ; BEGIN OuterModule := Sym ; REPEAT OuterModule := GetScope(OuterModule) UNTIL GetScope(OuterModule)=NulSym ; pSym := GetPsym(OuterModule) ; WITH pSym^ DO CASE SymbolType OF ModuleSym: RETURN( FALSE ) | DefImpSym: RETURN( GetSymKey(DefImp.ExportQualifiedTree, GetSymName(Sym))=Sym ) ELSE InternalError ('expecting a DefImp or Module symbol') END END END IsExportQualified ; (* ForeachImportedDo - calls a procedure, P, foreach imported symbol in module, ModSym. *) PROCEDURE ForeachImportedDo (ModSym: CARDINAL; P: PerformOperation) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(ModSym) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: WITH DefImp DO ForeachNodeDo( ImportTree, P ) ; ForeachItemInListDo( IncludeList, P ) END | ModuleSym: WITH Module DO ForeachNodeDo( ImportTree, P ) ; ForeachItemInListDo( IncludeList, P ) END ELSE InternalError ('expecting a DefImp or Module symbol') END END END ForeachImportedDo ; (* ForeachExportedDo - calls a procedure, P, foreach imported symbol in module, ModSym. *) PROCEDURE ForeachExportedDo (ModSym: CARDINAL; P: PerformOperation) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(ModSym) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: WITH DefImp DO ForeachNodeDo( ExportQualifiedTree, P ) ; ForeachNodeDo( ExportUnQualifiedTree, P ) END | ModuleSym: WITH Module DO ForeachNodeDo( ExportTree, P ) END ELSE InternalError ('expecting a DefImp or Module symbol') END END END ForeachExportedDo ; (* ForeachLocalSymDo - foreach local symbol in module, Sym, or procedure, Sym, perform the procedure, P. *) PROCEDURE ForeachLocalSymDo (Sym: CARDINAL; P: PerformOperation) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: WITH DefImp DO ForeachNodeDo( LocalSymbols, P ) END | ModuleSym: WITH Module DO ForeachNodeDo( LocalSymbols, P ) END | ProcedureSym: WITH Procedure DO ForeachNodeDo( LocalSymbols, P ) END | RecordSym: WITH Record DO ForeachNodeDo( LocalSymbols, P ) END | EnumerationSym: WITH Enumeration DO ForeachNodeDo( LocalSymbols, P ) END ELSE InternalError ('expecting a DefImp, Module or Procedure symbol') END END END ForeachLocalSymDo ; (* ForeachParamSymDo - foreach parameter symbol in procedure Sym perform the procedure P. Each symbol looked up will be VarParam or Param (not the shadow variable). Every parameter from each KindProcedure is iterated over. *) PROCEDURE ForeachParamSymDo (Sym: CARDINAL; P: PerformOperation) ; VAR kind : ProcedureKind ; param: CARDINAL ; p, i : CARDINAL ; BEGIN IF IsProcedure (Sym) THEN FOR kind := MIN (ProcedureKind) TO MAX (ProcedureKind) DO p := NoOfParam (Sym, kind) ; i := p ; WHILE i>0 DO param := GetNthParam (Sym, kind, i) ; P (param) ; DEC(i) END END END END ForeachParamSymDo ; (* CheckForUnknownInModule - checks for any unknown symbols in the current module. If any unknown symbols are found then an error message is displayed. *) PROCEDURE CheckForUnknownInModule ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(GetCurrentModuleScope()) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: WITH DefImp DO CheckForUnknowns (name, ExportQualifiedTree, 'EXPORT QUALIFIED') ; CheckForUnknowns (name, ExportUnQualifiedTree, 'EXPORT UNQUALIFIED') ; CheckForSymbols (ExportRequest, 'requested by another modules import (symbols have not been exported by the appropriate definition module)') ; CheckForUnknowns (name, Unresolved, 'unresolved') ; CheckForUnknowns (name, LocalSymbols, 'locally used') END | ModuleSym: WITH Module DO CheckForUnknowns (name, Unresolved, 'unresolved') ; CheckForUnknowns (name, ExportUndeclared, 'exported but undeclared') ; CheckForUnknowns (name, ExportTree, 'exported but undeclared') ; CheckForUnknowns (name, LocalSymbols, 'locally used') END ELSE InternalError ('expecting a DefImp or Module symbol') END END END CheckForUnknownInModule ; (* UnknownSymbolError - displays symbol name for symbol, sym. *) PROCEDURE UnknownSymbolError (sym: WORD) ; BEGIN IF IsUnreportedUnknown (sym) THEN IncludeElementIntoSet (ReportedUnknowns, sym) ; MetaErrorStringT1 (GetFirstUsed (sym), InitString ("unknown symbol {%1EUad}"), sym) END END UnknownSymbolError ; (* UnknownReported - if sym is an unknown symbol and has not been reported then include it into the set of reported unknowns. *) PROCEDURE UnknownReported (sym: CARDINAL) ; BEGIN IF IsUnreportedUnknown (sym) THEN IncludeElementIntoSet (ReportedUnknowns, sym) END END UnknownReported ; (* IsUnreportedUnknown - returns TRUE if symbol, sym, has not been reported and is an unknown symbol. *) PROCEDURE IsUnreportedUnknown (sym: CARDINAL) : BOOLEAN ; BEGIN RETURN IsUnknown (sym) AND (NOT IsElementInSet (ReportedUnknowns, sym)) END IsUnreportedUnknown ; VAR ListifySentance : String ; ListifyTotal, ListifyWordCount: CARDINAL ; (* AddListify - *) PROCEDURE AddListify (sym: CARDINAL) ; BEGIN INC (ListifyWordCount) ; (* printf ("AddListify: ListifyWordCount = %d, ListifyTotal = %d\n", ListifyWordCount, ListifyTotal) ; *) IF ListifyWordCount > 1 THEN IF ListifyWordCount = ListifyTotal THEN ListifySentance := ConCat (ListifySentance, Mark (InitString (" and "))) ELSE ListifySentance := ConCat (ListifySentance, Mark (InitString (", "))) END END ; ListifySentance := ConCat (ListifySentance, Mark (InitStringCharStar (KeyToCharStar (GetSymName (sym))))) END AddListify ; (* Listify - convert tree into a string list and return the result. *) PROCEDURE Listify (tree: SymbolTree; isCondition: IsSymbol) : String ; BEGIN ListifyTotal := NoOfNodes (tree, isCondition) ; ListifyWordCount := 0 ; ListifySentance := InitString ('') ; ForeachNodeConditionDo (tree, isCondition, AddListify) ; RETURN ListifySentance END Listify ; (* CheckForUnknowns - checks a binary tree, Tree, to see whether it contains an unknown symbol. All unknown symbols are displayed together with an error message. *) PROCEDURE CheckForUnknowns (name: Name; Tree: SymbolTree; a: ARRAY OF CHAR) ; VAR s: String ; BEGIN IF DoesTreeContainAny(Tree, IsUnreportedUnknown) THEN CurrentError := NewError(GetTokenNo()) ; s := InitString("{%E} the following unknown symbols in module %<") ; s := ConCat(s, Mark(InitStringCharStar(KeyToCharStar(name)))) ; s := ConCat(s, Mark(InitString('%> were '))) ; s := ConCat(s, Mark(InitString(a))) ; s := ConCat (s, Mark (InitString (': '))) ; s := ConCat (s, Mark (Listify (Tree, IsUnreportedUnknown))) ; MetaErrorStringT0(GetTokenNo(), s) ; ForeachNodeDo(Tree, UnknownSymbolError) END END CheckForUnknowns ; (* SymbolError - displays symbol name for symbol, Sym. *) PROCEDURE SymbolError (Sym: WORD) ; VAR e: Error ; n: Name ; BEGIN n := GetSymName(Sym) ; e := ChainError(GetFirstUsed(Sym), CurrentError) ; ErrorFormat1(e, "unknown symbol '%a' found", n) END SymbolError ; (* CheckForSymbols - checks a binary tree, Tree, to see whether it contains any symbol. The tree is expected to be empty, if not then an error has occurred. *) PROCEDURE CheckForSymbols (Tree: SymbolTree; a: ARRAY OF CHAR) ; VAR s: String ; BEGIN IF NOT IsEmptyTree(Tree) THEN s := InitString ("the symbols are unknown at the end of module {%1Ea} when ") ; s := ConCat (s, Mark(InitString(a))) ; MetaErrorString1 (s, MainModule) ; ForeachNodeDo(Tree, SymbolError) END END CheckForSymbols ; (* PutExportUndeclared - places a symbol, Sym, into module, ModSym, ExportUndeclared list provided that Sym is unknown. *) PROCEDURE PutExportUndeclared (ModSym: CARDINAL; Sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN IF IsUnknown (Sym) THEN pSym := GetPsym (ModSym) ; WITH pSym^ DO CASE SymbolType OF ModuleSym: PutSymKey (Module.ExportUndeclared, GetSymName (Sym), Sym) | DefImpSym: PutSymKey (DefImp.ExportUndeclared, GetSymName (Sym), Sym) ELSE InternalError ('expecting a DefImp or Module symbol') END END END END PutExportUndeclared ; (* GetExportUndeclared - returns a symbol which has, name, from module, ModSym, which is in the ExportUndeclared list. *) PROCEDURE GetExportUndeclared (ModSym: CARDINAL; name: Name) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(ModSym) ; WITH pSym^ DO CASE SymbolType OF ModuleSym: RETURN( GetSymKey(Module.ExportUndeclared, name) ) | DefImpSym: RETURN( GetSymKey(DefImp.ExportUndeclared, name) ) ELSE InternalError ('expecting a DefImp or Module symbol') END END END GetExportUndeclared ; (* RemoveExportUndeclared - removes a symbol, Sym, from the module, ModSym, ExportUndeclaredTree. *) PROCEDURE RemoveExportUndeclared (ModSym: CARDINAL; Sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(ModSym) ; WITH pSym^ DO CASE SymbolType OF ModuleSym: IF GetSymKey(Module.ExportUndeclared, GetSymName(Sym))=Sym THEN DelSymKey(Module.ExportUndeclared, GetSymName(Sym)) END | DefImpSym: IF GetSymKey(DefImp.ExportUndeclared, GetSymName(Sym))=Sym THEN DelSymKey(DefImp.ExportUndeclared, GetSymName(Sym)) END ELSE InternalError ('expecting a DefImp or Module symbol') END END END RemoveExportUndeclared ; (* CheckForExportedDeclaration - checks to see whether a definition module is currently being compiled, if so, symbol, Sym, is removed from the ExportUndeclared list. This procedure is called whenever a symbol is declared, thus attempting to reduce the ExportUndeclared list. *) PROCEDURE CheckForExportedDeclaration (Sym: CARDINAL) ; BEGIN IF CompilingDefinitionModule () THEN RemoveExportUndeclared(GetCurrentModule(), Sym) END END CheckForExportedDeclaration ; (* CheckForUndeclaredExports - displays an error and the offending symbols which have been exported but not declared from module, ModSym. *) PROCEDURE CheckForUndeclaredExports (ModSym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN (* WriteString('Inside CheckForUndeclaredExports') ; WriteLn ; *) pSym := GetPsym(ModSym) ; WITH pSym^ DO CASE SymbolType OF ModuleSym: IF NOT IsEmptyTree(Module.ExportUndeclared) THEN MetaError1('undeclared identifier(s) in EXPORT list of {%1ERd} {%1a}', ModSym) ; ForeachNodeDo(Module.ExportUndeclared, UndeclaredSymbolError) END | DefImpSym: IF NOT IsEmptyTree(DefImp.ExportUndeclared) THEN IF DoesNotNeedExportList(ModSym) THEN MetaError1('undeclared identifier(s) in {%1ERd} {%1a}', ModSym) ; ELSE MetaError1('undeclared identifier(s) in export list of {%1ERd} {%1a}', ModSym) ; END ; ForeachNodeDo(DefImp.ExportUndeclared, UndeclaredSymbolError) END ELSE InternalError ('expecting a DefImp or Module symbol') END END END CheckForUndeclaredExports ; (* UndeclaredSymbolError - displays symbol name for symbol, Sym. *) PROCEDURE UndeclaredSymbolError (Sym: WORD) ; BEGIN IF DebugUnknowns THEN printf1('undeclared symbol (%d)\n', Sym) END ; MetaError1('{%1UC} undeclared symbol {%1a}', Sym) END UndeclaredSymbolError ; (* PutExportUnImplemented - places a symbol, Sym, into the currently compiled DefImp module NeedToBeImplemented list. *) PROCEDURE PutExportUnImplemented (tokenno: CARDINAL; Sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (CurrentModule) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: IF GetSymKey (DefImp.NeedToBeImplemented, GetSymName (Sym)) = Sym THEN MetaErrorT2 (tokenno, 'symbol {%1a} is already exported from module {%2a}', Sym, CurrentModule) (* n1 := GetSymName (Sym) ; n2 := GetSymName (CurrentModule) ; WriteFormat2 ('symbol (%a) already exported from module (%a)', n1, n2) *) ELSE PutSymKey (DefImp.NeedToBeImplemented, GetSymName(Sym), Sym) END ELSE InternalError ('expecting a DefImp symbol') END END END PutExportUnImplemented ; (* RemoveExportUnImplemented - removes a symbol, Sym, from the module, ModSym, NeedToBeImplemented list. *) PROCEDURE RemoveExportUnImplemented (ModSym: CARDINAL; Sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(ModSym) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: IF GetSymKey(DefImp.NeedToBeImplemented, GetSymName(Sym))=Sym THEN DelSymKey(DefImp.NeedToBeImplemented, GetSymName(Sym)) END ELSE InternalError ('expecting a DefImp symbol') END END END RemoveExportUnImplemented ; VAR ExportRequestModule: CARDINAL ; (* RemoveFromExportRequest - *) PROCEDURE RemoveFromExportRequest (Sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(ExportRequestModule) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: IF GetSymKey(DefImp.ExportRequest, GetSymName(Sym))=Sym THEN DelSymKey(DefImp.ExportRequest, GetSymName(Sym)) END ELSE InternalError ('expecting a DefImp symbol') END END END RemoveFromExportRequest ; (* RemoveEnumerationFromExportRequest - removes enumeration symbol, sym, (and its fields) from the ExportRequest tree. *) PROCEDURE RemoveEnumerationFromExportRequest (ModSym: CARDINAL; Sym: CARDINAL) ; BEGIN IF IsEnumeration(Sym) THEN ExportRequestModule := ModSym ; RemoveFromExportRequest(Sym) ; ForeachLocalSymDo(Sym, RemoveFromExportRequest) END END RemoveEnumerationFromExportRequest ; (* CheckForExportedImplementation - checks to see whether an implementation module is currently being compiled, if so, symbol, Sym, is removed from the NeedToBeImplemented list. This procedure is called whenever a symbol is declared, thus attempting to reduce the NeedToBeImplemented list. Only needs to be called when a TYPE or PROCEDURE is built since the implementation module can only implement these objects declared in the definition module. It also checks whether a definition module is currently being compiled and, if so, it will ensure that symbol, Sym, is removed from the ExportRequest list. If Sym is an enumerated type it ensures that its fields are also removed. *) PROCEDURE CheckForExportedImplementation (Sym: CARDINAL) ; BEGIN IF CompilingImplementationModule() THEN RemoveExportUnImplemented(GetCurrentModule(), Sym) END ; IF CompilingDefinitionModule() AND IsEnumeration(Sym) THEN RemoveEnumerationFromExportRequest(GetCurrentModule(), Sym) END END CheckForExportedImplementation ; (* CheckForUnImplementedExports - displays an error and the offending symbols which have been exported but not implemented from the current compiled module. *) PROCEDURE CheckForUnImplementedExports ; VAR pSym: PtrToSymbol ; BEGIN (* WriteString('Inside CheckForImplementedExports') ; WriteLn ; *) pSym := GetPsym (CurrentModule) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: IF NOT IsEmptyTree (DefImp.NeedToBeImplemented) THEN CurrentError := NewError (GetTokenNo ()) ; ErrorFormat1 (CurrentError, 'unimplemented identifier(s) in EXPORT list of DEFINITION MODULE %a\nthe implementation module fails to implement the following exported identifier(s)', DefImp.name) ; ForeachNodeDo (DefImp.NeedToBeImplemented, UnImplementedSymbolError) END ELSE InternalError ('expecting a DefImp symbol') END END END CheckForUnImplementedExports ; (* UnImplementedSymbolError - displays symbol name for symbol, Sym. *) PROCEDURE UnImplementedSymbolError (Sym: WORD) ; VAR n: Name ; BEGIN CurrentError := ChainError (GetFirstUsed (Sym), CurrentError) ; IF IsType (Sym) THEN n := GetSymName(Sym) ; ErrorFormat1 (CurrentError, 'hidden type is undeclared (%a)', n) ELSIF IsProcedure (Sym) THEN n := GetSymName(Sym) ; ErrorFormat1 (CurrentError, 'procedure is undeclared (%a)', n) ELSIF IsProcType (Sym) THEN n := GetSymName(Sym) ; ErrorFormat1 (CurrentError, 'procedure type is undeclared (%a)', n) ELSE ErrorFormat0 (CurrentError, 'undeclared symbol') END END UnImplementedSymbolError ; (* PutHiddenTypeDeclared - sets a flag in the current compiled module which indicates that a Hidden Type is declared within the implementation part of the module. This procedure is expected to be called while compiling the associated definition module. *) PROCEDURE PutHiddenTypeDeclared ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(CurrentModule) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: DefImp.ContainsHiddenType := TRUE ELSE InternalError ('expecting a DefImp symbol') END END END PutHiddenTypeDeclared ; (* IsHiddenTypeDeclared - returns true if a Hidden Type was declared in the module, Sym. *) PROCEDURE IsHiddenTypeDeclared (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: RETURN( DefImp.ContainsHiddenType ) ELSE InternalError ('expecting a DefImp symbol') END END END IsHiddenTypeDeclared ; (* PutModuleContainsBuiltin - sets a flag in the current compiled module which indicates that a builtin procedure is being declared. This is only expected to be called when we are parsing the definition module. *) PROCEDURE PutModuleContainsBuiltin ; VAR pSym: PtrToSymbol ; BEGIN PutHiddenTypeDeclared ; pSym := GetPsym(CurrentModule) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: DefImp.ContainsBuiltin := TRUE ELSE InternalError ('expecting a DefImp symbol') END END END PutModuleContainsBuiltin ; (* IsBuiltinInModule - returns true if a module, Sym, has declared a builtin procedure. *) PROCEDURE IsBuiltinInModule (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: RETURN( DefImp.ContainsBuiltin ) ELSE InternalError ('expecting a DefImp symbol') END END END IsBuiltinInModule ; (* PutDefinitionForC - sets a flag in the current compiled module which indicates that this module is a wrapper for a C file. Parameters passes to procedures in this module will adopt the C calling convention. *) PROCEDURE PutDefinitionForC (Sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: DefImp.ForC := TRUE ELSE InternalError ('expecting a DefImp symbol') END END END PutDefinitionForC ; (* IsDefinitionForC - returns true if this definition module was declared as a DEFINITION MODULE FOR "C". *) PROCEDURE IsDefinitionForC (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: RETURN( DefImp.ForC ) ELSE InternalError ('expecting a DefImp symbol') END END END IsDefinitionForC ; (* PutDoesNeedExportList - sets a flag in module, Sym, which indicates that this module requires an explicit EXPORT QUALIFIED or UNQUALIFIED list. PIM-2 *) PROCEDURE PutDoesNeedExportList (Sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: DefImp.NeedExportList := TRUE ELSE InternalError ('expecting a DefImp symbol') END END END PutDoesNeedExportList ; (* PutDoesNotNeedExportList - sets a flag in module, Sym, which indicates that this module does not require an explicit EXPORT QUALIFIED or UNQUALIFIED list. PIM-3|4 *) PROCEDURE PutDoesNotNeedExportList (Sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: DefImp.NeedExportList := FALSE ELSE InternalError ('expecting a DefImp symbol') END END END PutDoesNotNeedExportList ; (* DoesNotNeedExportList - returns TRUE if module, Sym, does not require an explicit EXPORT QUALIFIED list. *) PROCEDURE DoesNotNeedExportList (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: RETURN( NOT DefImp.NeedExportList ) ELSE InternalError ('expecting a DefImp symbol') END END END DoesNotNeedExportList ; (* CheckForEnumerationInCurrentModule - checks to see whether the enumeration type symbol, Sym, has been entered into the current modules scope list. *) PROCEDURE CheckForEnumerationInCurrentModule (Sym: CARDINAL) ; VAR pSym : PtrToSymbol ; ModSym: CARDINAL ; BEGIN IF (SkipType(Sym)#NulSym) AND IsEnumeration(SkipType(Sym)) THEN Sym := SkipType(Sym) END ; IF IsEnumeration(Sym) THEN ModSym := GetCurrentModuleScope() ; pSym := GetPsym(ModSym) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: CheckEnumerationInList(DefImp.EnumerationScopeList, Sym) | ModuleSym: CheckEnumerationInList(Module.EnumerationScopeList, Sym) ELSE InternalError ('expecting a DefImp or Module symbol') END END END END CheckForEnumerationInCurrentModule ; (* CheckEnumerationInList - places symbol, Sym, in the list, l, providing it does not already exist. PseudoScope(Sym) is called if Sym needs to be added to the enumeration list, l. *) PROCEDURE CheckEnumerationInList (l: List; Sym: CARDINAL) ; BEGIN IF NOT IsItemInList(l, Sym) THEN PutItemIntoList(l, Sym) ; PseudoScope(Sym) END END CheckEnumerationInList ; (* CheckIfEnumerationExported - An outer module may use an enumeration that is declared inside an inner module. The usage may occur before definition. The first pass exports a symbol, later the symbol is declared as an emumeration type. At this stage the CheckIfEnumerationExported procedure should be called. This procedure ripples from the current (inner) module to outer module and every time it is exported it must be added to the outer module EnumerationScopeList. *) PROCEDURE CheckIfEnumerationExported (Sym: CARDINAL; ScopeId: CARDINAL) ; VAR pCall : PtrToCallFrame ; InnerModId, OuterModId : CARDINAL ; InnerModSym, OuterModSym: CARDINAL ; BEGIN InnerModId := GetModuleScopeId(ScopeId) ; IF InnerModId>0 THEN OuterModId := GetModuleScopeId(InnerModId-1) ; IF OuterModId>0 THEN pCall := GetPcall(InnerModId) ; InnerModSym := pCall^.Search ; pCall := GetPcall(OuterModId) ; OuterModSym := pCall^.Search ; IF (InnerModSym#NulSym) AND (OuterModSym#NulSym) THEN IF IsExported(InnerModSym, Sym) THEN CheckForEnumerationInOuterModule(Sym, OuterModSym) ; CheckIfEnumerationExported(Sym, OuterModId) END END END END END CheckIfEnumerationExported ; (* CheckForEnumerationInOuterModule - checks to see whether the enumeration type symbol, Sym, has been entered into the outer module, OuterModule, scope list. OuterModule may be internal to the program module. *) PROCEDURE CheckForEnumerationInOuterModule (Sym: CARDINAL; OuterModule: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(OuterModule) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: IncludeItemIntoList(DefImp.EnumerationScopeList, Sym) | ModuleSym: IncludeItemIntoList(Module.EnumerationScopeList, Sym) ELSE InternalError ('expecting a DefImp or Module symbol') END END END CheckForEnumerationInOuterModule ; (* IsExported - returns true if a symbol, Sym, is exported from module, ModSym. If ModSym is a DefImp symbol then its ExportQualified and ExportUnQualified lists are examined. *) PROCEDURE IsExported (ModSym: CARDINAL; Sym: CARDINAL) : BOOLEAN ; VAR pSym : PtrToSymbol ; SymName: Name ; BEGIN SymName := GetSymName(Sym) ; pSym := GetPsym(ModSym) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: WITH DefImp DO RETURN( (GetSymKey(ExportQualifiedTree, SymName)=Sym) OR (GetSymKey(ExportUnQualifiedTree, SymName)=Sym) ) END | ModuleSym: WITH Module DO RETURN( GetSymKey(ExportTree, SymName)=Sym ) END ELSE InternalError ('expecting a DefImp or Module symbol') END END END IsExported ; (* IsImported - returns true if a symbol, Sym, in module, ModSym, was imported. *) PROCEDURE IsImported (ModSym: CARDINAL; Sym: CARDINAL) : BOOLEAN ; VAR pSym : PtrToSymbol ; SymName: Name ; BEGIN SymName := GetSymName(Sym) ; pSym := GetPsym(ModSym) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: WITH DefImp DO RETURN( (GetSymKey(ImportTree, SymName)=Sym) OR IsItemInList(IncludeList, Sym) ) END | ModuleSym: WITH Module DO RETURN( (GetSymKey(ImportTree, SymName)=Sym) OR IsItemInList(IncludeList, Sym) ) END ELSE InternalError ('expecting a DefImp or Module symbol') END END END IsImported ; (* IsType - returns true if the Sym is a type symbol. *) PROCEDURE IsType (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; RETURN( pSym^.SymbolType=TypeSym ) END IsType ; (* IsReturnOptional - returns TRUE if the return value for, sym, is optional. *) PROCEDURE IsReturnOptional (sym: CARDINAL; kind: ProcedureKind) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: RETURN( Procedure.Decl[kind].ReturnOptional ) | ProcTypeSym : RETURN( ProcType.ReturnOptional ) ELSE InternalError ('expecting a Procedure or ProcType symbol') END END END IsReturnOptional ; (* SetReturnOptional - sets the ReturnOptional field in the Procedure:kind or ProcType symboltable entry. *) PROCEDURE SetReturnOptional (sym: CARDINAL; kind: ProcedureKind; isopt: BOOLEAN) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: Procedure.Decl[kind].ReturnOptional := isopt | ProcTypeSym : ProcType.ReturnOptional := isopt ELSE InternalError ('expecting a Procedure or ProcType symbol') END END END SetReturnOptional ; (* IsReturnOptionalAny - returns TRUE if the return value for sym is optional. *) PROCEDURE IsReturnOptionalAny (sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: RETURN IsProcedureAnyBoolean (sym, IsReturnOptional) | ProcTypeSym : RETURN ProcType.ReturnOptional ELSE InternalError ('expecting a Procedure or ProcType symbol') END END END IsReturnOptionalAny ; (* PutFunction - Places a TypeSym as the return type to a procedure Sym. *) PROCEDURE PutFunction (tok: CARDINAL; Sym: CARDINAL; kind: ProcedureKind; TypeSym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym: | ProcedureSym: Procedure.ReturnType := TypeSym ; Procedure.Decl[kind].ReturnTypeTok := tok ; PutFunction (tok, Procedure.ProcedureType, kind, TypeSym) | ProcTypeSym : ProcType.ReturnType := TypeSym ; ProcType.ReturnTypeTok := tok ; ELSE InternalError ('expecting a Procedure or ProcType symbol') END END END PutFunction ; (* PutOptFunction - places a TypeSym as the optional return type to a procedure Sym. *) PROCEDURE PutOptFunction (tok: CARDINAL; Sym: CARDINAL; kind: ProcedureKind; TypeSym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (Sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym: | ProcedureSym: Procedure.ReturnType := TypeSym ; Procedure.Decl[kind].ReturnOptional := TRUE ; Procedure.Decl[kind].ReturnTypeTok := tok ; PutOptFunction (tok, Procedure.ProcedureType, kind, TypeSym) | ProcTypeSym : ProcType.ReturnType := TypeSym ; ProcType.ReturnTypeTok := tok ; ELSE InternalError ('expecting a Procedure or ProcType symbol') END END END PutOptFunction ; (* MakeVariableForParam - *) PROCEDURE MakeVariableForParam (tok : CARDINAL; ParamName: Name; ProcSym : CARDINAL; kind : ProcedureKind; no : CARDINAL; ParmType : CARDINAL; typetok : CARDINAL) : CARDINAL ; VAR pSym : PtrToSymbol ; VariableSym: CARDINAL ; BEGIN tok := CheckTok (tok, 'parameter') ; VariableSym := MakeVar (tok, ParamName) ; pSym := GetPsym (VariableSym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym: RETURN( NulSym ) | VarSym : Var.IsParam := TRUE (* Variable is really a parameter. *) ELSE InternalError ('expecting a Var symbol') END END ; (* Note that the parameter is now treated as a local variable. *) PutVarTok (VariableSym, ParmType, typetok) ; PutDeclared (tok, VariableSym) ; (* Normal VAR parameters have LeftValue, however Unbounded VAR parameters have RightValue. Non VAR parameters always have RightValue. *) IF IsVarParam (ProcSym, kind, no) AND (NOT IsUnboundedParam (ProcSym, kind, no)) THEN PutMode (VariableSym, LeftValue) ELSE PutMode (VariableSym, RightValue) END ; RETURN( VariableSym ) END MakeVariableForParam ; (* PutParam - Places a Non VAR parameter ParamName with type ParamType into procedure Sym:kind. The parameter number is ParamNo. If the procedure Sym already has this parameter then the parameter is checked for consistancy and the consistancy test is returned. *) PROCEDURE PutParam (tok: CARDINAL; Sym: CARDINAL; kind: ProcedureKind; ParamNo: CARDINAL; ParamName: Name; ParamType: CARDINAL; isUnbounded: BOOLEAN; typetok: CARDINAL) : BOOLEAN ; VAR pSym : PtrToSymbol ; ParSym : CARDINAL ; VariableSym: CARDINAL ; BEGIN IF GetProcedureParametersDefined (Sym, kind) THEN (* ParamNo <= NoOfParamAny (Sym) *) InternalError ('why are we trying to put parameters again') ELSE (* Add a new parameter *) NewSym(ParSym) ; pSym := GetPsym(ParSym) ; WITH pSym^ DO SymbolType := ParamSym ; WITH Param DO name := ParamName ; Type := ParamType ; IsUnbounded := isUnbounded ; ShadowVar := NulSym ; InitWhereDeclaredTok(tok, At) END END ; AddParameter (Sym, kind, ParSym) ; (* Only declare a parameter as a local variable if it has not been done before. It might be declared during the definition module, forward declaration or proper procedure. Name mismatches are checked in P2SymBuild.mod. *) IF (ParamName # NulName) AND (GetNth (Sym, ParamNo) = NulSym) THEN VariableSym := MakeVariableForParam (tok, ParamName, Sym, kind, ParamNo, ParamType, typetok) ; IF VariableSym=NulSym THEN RETURN( FALSE ) ELSE pSym := GetPsym(ParSym) ; pSym^.Param.ShadowVar := VariableSym END END ; AddProcedureProcTypeParam (Sym, ParamType, isUnbounded, FALSE) END ; RETURN( TRUE ) END PutParam ; (* PutVarParam - Places a Non VAR parameter ParamName with type ParamType into procedure Sym:kind. The parameter number is ParamNo. If the procedure Sym already has this parameter then the parameter is checked for consistancy and the consistancy test is returned. *) PROCEDURE PutVarParam (tok: CARDINAL; Sym: CARDINAL; kind: ProcedureKind; ParamNo: CARDINAL; ParamName: Name; ParamType: CARDINAL; isUnbounded: BOOLEAN; typetok: CARDINAL) : BOOLEAN ; VAR pSym : PtrToSymbol ; ParSym : CARDINAL ; VariableSym: CARDINAL ; BEGIN IF GetProcedureParametersDefined (Sym, kind) THEN InternalError ('why are we trying to put parameters again') ELSE (* Add a new parameter *) NewSym(ParSym) ; pSym := GetPsym(ParSym) ; WITH pSym^ DO SymbolType := VarParamSym ; WITH VarParam DO name := ParamName ; Type := ParamType ; IsUnbounded := isUnbounded ; ShadowVar := NulSym ; HeapVar := NulSym ; (* Will contain a pointer value. *) InitWhereDeclaredTok(tok, At) END END ; AddParameter (Sym, kind, ParSym) ; (* Only declare a parameter as a local variable if it has not been done before. It might be declared during the definition module, forward declaration or proper procedure. Name mismatches are checked in P2SymBuild.mod. *) IF (ParamName # NulName) AND (GetNth (Sym, ParamNo) = NulSym) THEN VariableSym := MakeVariableForParam (tok, ParamName, Sym, kind, ParamNo, ParamType, typetok) ; IF VariableSym=NulSym THEN RETURN( FALSE ) ELSE pSym := GetPsym(ParSym) ; pSym^.VarParam.ShadowVar := VariableSym END END ; AddProcedureProcTypeParam (Sym, ParamType, isUnbounded, TRUE) END ; RETURN( TRUE ) END PutVarParam ; (* PutParamName - assigns a name to paramater no of procedure ProcSym:kind. *) PROCEDURE PutParamName (tok: CARDINAL; ProcSym: CARDINAL; kind: ProcedureKind; no: CARDINAL; name: Name; ParamType: CARDINAL; typetok: CARDINAL) ; VAR pSym : PtrToSymbol ; ParSym: CARDINAL ; BEGIN pSym := GetPsym(ProcSym) ; ParSym := NulSym ; WITH pSym^ DO CASE SymbolType OF ErrorSym : RETURN | ProcedureSym: ParSym := GetItemFromList(Procedure.Decl[kind].ListOfParam, no) | ProcTypeSym : ParSym := GetItemFromList(ProcType.ListOfParam, no) ELSE InternalError ('expecting a Procedure symbol') END END ; pSym := GetPsym(ParSym) ; WITH pSym^ DO CASE SymbolType OF ParamSym: IF Param.name=NulName THEN Param.name := name ; Param.ShadowVar := MakeVariableForParam(tok, name, ProcSym, kind, no, ParamType, typetok) ELSE InternalError ('name of parameter has already been assigned') END | VarParamSym: IF VarParam.name=NulName THEN VarParam.name := name ; VarParam.ShadowVar := MakeVariableForParam(tok, name, ProcSym, kind, no, ParamType, typetok) ELSE InternalError ('name of parameter has already been assigned') END ELSE InternalError ('expecting a VarParam or Param symbol') END END END PutParamName ; (* AddParameter - adds a parameter ParSym to a procedure Sym. *) PROCEDURE AddParameter (Sym: CARDINAL; kind: ProcedureKind; ParSym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym: | ProcedureSym: PutItemIntoList (Procedure.Decl[kind].ListOfParam, ParSym) | ProcTypeSym : PutItemIntoList (ProcType.ListOfParam, ParSym) ELSE InternalError ('expecting a Procedure or ProcType symbol') END END END AddParameter ; (* AddProcedureProcTypeParam - adds ParamType to the parameter ProcType associated with procedure Sym. *) PROCEDURE AddProcedureProcTypeParam (Sym, ParamType: CARDINAL; isUnbounded, isVarParam: BOOLEAN) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (Sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: IF Procedure.BuildProcType THEN IF isVarParam THEN PutProcTypeVarParam (Procedure.ProcedureType, ParamType, isUnbounded) ELSE PutProcTypeParam (Procedure.ProcedureType, ParamType, isUnbounded) END END ELSE InternalError ('expecting Sym to be a procedure') END END END AddProcedureProcTypeParam ; (* IsVarParam - Returns a conditional depending whether parameter ParamNo is a VAR parameter. *) PROCEDURE IsVarParam (Sym: CARDINAL; kind: ProcedureKind; ParamNo: CARDINAL) : BOOLEAN ; VAR pSym : PtrToSymbol ; IsVar: BOOLEAN ; BEGIN IsVar := FALSE ; pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym : | ProcedureSym: IsVar := IsNthParamVar(Procedure.Decl[kind].ListOfParam, ParamNo) | ProcTypeSym : IsVar := IsNthParamVar(ProcType.ListOfParam, ParamNo) ELSE InternalError ('expecting a Procedure or ProcType symbol') END END ; RETURN( IsVar ) END IsVarParam ; (* IsVarParamAny - Returns a conditional depending whether parameter ParamNo is a VAR parameter. *) PROCEDURE IsVarParamAny (Sym: CARDINAL; ParamNo: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; kind: ProcedureKind ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym : | ProcedureSym: FOR kind := MIN (ProcedureKind) TO MAX (ProcedureKind) DO IF GetProcedureDefined (Sym, kind) THEN RETURN IsNthParamVar (Procedure.Decl[kind].ListOfParam, ParamNo) END END | ProcTypeSym : RETURN IsNthParamVar(ProcType.ListOfParam, ParamNo) ELSE InternalError ('expecting a Procedure or ProcType symbol') END END ; RETURN FALSE END IsVarParamAny ; (* IsNthParamVar - returns true if the n th parameter of the parameter list, List, is a VAR parameter. *) PROCEDURE IsNthParamVar (Head: List; n: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; p : CARDINAL ; BEGIN p := GetItemFromList(Head, n) ; IF p=NulSym THEN InternalError ('parameter does not exist') ELSE pSym := GetPsym(p) ; WITH pSym^ DO CASE SymbolType OF ErrorSym : RETURN( FALSE ) | VarParamSym: RETURN( TRUE ) | ParamSym : RETURN( FALSE ) ELSE InternalError ('expecting Param or VarParam symbol') END END END END IsNthParamVar ; (* NoOfParam - Returns the number of parameters that procedure Sym contains. *) PROCEDURE NoOfParam (Sym: CARDINAL; kind: ProcedureKind) : CARDINAL ; VAR pSym: PtrToSymbol ; n : CARDINAL ; BEGIN AssertInRange(Sym) ; pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym : n := 0 | ProcedureSym: n := NoOfItemsInList(Procedure.Decl[kind].ListOfParam) | ProcTypeSym : n := NoOfItemsInList(ProcType.ListOfParam) ELSE InternalError ('expecting a Procedure or ProcType symbol') END END ; RETURN( n ) END NoOfParam ; (* NoOfParamAny - return the number of parameters for sym. *) PROCEDURE NoOfParamAny (sym: CARDINAL) : CARDINAL ; VAR kind: ProcedureKind ; pSym: PtrToSymbol ; BEGIN AssertInRange (sym) ; pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym : RETURN 0 | ProcedureSym: FOR kind := MIN (ProcedureKind) TO MAX (ProcedureKind) DO IF GetProcedureParametersDefined (sym, kind) THEN RETURN NoOfParam (sym, kind) END END | ProcTypeSym : RETURN NoOfItemsInList(ProcType.ListOfParam) ELSE InternalError ('expecting a Procedure or ProcType symbol') END END ; RETURN 0 END NoOfParamAny ; (* HasVarParameters - returns TRUE if procedure, p, has any VAR parameters. *) PROCEDURE HasVarParameters (p: CARDINAL) : BOOLEAN ; VAR i, n: CARDINAL ; BEGIN n := NoOfParamAny (p) ; i := 1 ; WHILE i <= n DO IF IsParameterVar (GetNthParamAny (p, i)) THEN RETURN TRUE END ; INC(i) END ; RETURN FALSE END HasVarParameters ; (* PutUseVarArgs - tell the symbol table that this procedure, Sym, uses varargs. The procedure _must_ be declared inside a DEFINITION FOR "C" *) PROCEDURE PutUseVarArgs (Sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN AssertInRange(Sym) ; pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym: | (* Currently can only declare var args in a definition module. *) ProcedureSym: Procedure.Decl[DefProcedure].HasVarArgs := TRUE | ProcTypeSym : ProcType.HasVarArgs := TRUE ELSE InternalError ('expecting a Procedure or ProcType symbol') END END END PutUseVarArgs ; (* UsesVarArgs - returns TRUE if procedure, Sym, uses varargs. The procedure _must_ be declared inside a DEFINITION FOR "C" *) PROCEDURE UsesVarArgs (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN AssertInRange(Sym) ; pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym : RETURN( FALSE ) | (* Currently can only declare var args in a definition module. *) ProcedureSym: RETURN( Procedure.Decl[DefProcedure].HasVarArgs ) | ProcTypeSym : RETURN( ProcType.HasVarArgs ) ELSE InternalError ('expecting a Procedure or ProcType symbol') END END END UsesVarArgs ; (* PutUseOptArg - tell the symbol table that this procedure, Sym, uses an optarg. *) PROCEDURE PutUseOptArg (Sym: CARDINAL; kind: ProcedureKind) ; VAR pSym: PtrToSymbol ; BEGIN AssertInRange(Sym) ; pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym: | ProcedureSym: Procedure.Decl[kind].HasOptArg := TRUE | ProcTypeSym : ProcType.HasOptArg := TRUE ELSE InternalError ('expecting a Procedure or ProcType symbol') END END END PutUseOptArg ; (* UsesOptArg - returns TRUE if procedure, Sym, uses varargs. *) PROCEDURE UsesOptArg (Sym: CARDINAL; kind: ProcedureKind) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN AssertInRange(Sym) ; pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym : RETURN FALSE | ProcedureSym: RETURN Procedure.Decl[kind].HasOptArg | ProcTypeSym : RETURN ProcType.HasOptArg ELSE InternalError ('expecting a Procedure or ProcType symbol') END END END UsesOptArg ; (* UsesOptArgAny - returns TRUE if procedure Sym:kind uses an optional argument. *) PROCEDURE UsesOptArgAny (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym : RETURN FALSE | ProcedureSym: RETURN IsProcedureAnyDefaultBoolean (Sym, FALSE, UsesOptArg) | ProcTypeSym : RETURN ProcType.HasOptArg ELSE InternalError ('expecting a Procedure or ProcType symbol') END END END UsesOptArgAny ; (* PutOptArgInit - makes symbol, Sym, the initializer value to procedure, ProcSym. *) PROCEDURE PutOptArgInit (ProcSym: CARDINAL; Sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN AssertInRange(Sym) ; IF NOT IsError(ProcSym) THEN pSym := GetPsym(ProcSym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym : | ProcedureSym: Procedure.OptArgInit := Sym | ProcTypeSym : ProcType.OptArgInit := Sym ELSE InternalError ('expecting a Procedure or ProcType symbol') END END END END PutOptArgInit ; (* GetOptArgInit - returns the initializer value to the optional parameter in procedure, ProcSym. *) PROCEDURE GetOptArgInit (ProcSym: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN IF NOT IsError(ProcSym) THEN pSym := GetPsym(ProcSym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym : | ProcedureSym: RETURN( Procedure.OptArgInit ) | ProcTypeSym : RETURN( ProcType.OptArgInit ) ELSE InternalError ('expecting a Procedure or ProcType symbol') END END END ; RETURN( NulSym ) END GetOptArgInit ; (* MakeParameterHeapVar - create a heap variable if sym is a pointer. *) PROCEDURE MakeParameterHeapVar (tok: CARDINAL; type: CARDINAL; mode: ModeOfAddr) : CARDINAL ; VAR heapvar: CARDINAL ; BEGIN tok := CheckTok (tok, 'parameter heap var') ; heapvar := NulSym ; type := SkipType (type) ; IF IsPointer (type) THEN heapvar := MakeTemporary (tok, mode) ; PutVar (heapvar, type) ; PutVarHeap (heapvar, TRUE) END ; RETURN heapvar END MakeParameterHeapVar ; (* GetParameterHeapVar - return the heap variable associated with the parameter or NulSym. *) PROCEDURE GetParameterHeapVar (ParSym: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (ParSym) ; WITH pSym^ DO CASE SymbolType OF ParamSym : RETURN NulSym | (* Only VarParam has the pointer. *) VarParamSym: RETURN VarParam.HeapVar ELSE InternalError ('expecting Param or VarParam symbol') END END END GetParameterHeapVar ; (* PutParameterHeapVar - creates a heap variable associated with parameter sym. *) PROCEDURE PutParameterHeapVar (sym: CARDINAL) ; VAR pSym : PtrToSymbol ; BEGIN pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF ParamSym : | (* Nothing to do for the non var parameter. *) VarParamSym: VarParam.HeapVar := MakeParameterHeapVar (GetDeclaredMod (sym), VarParam.Type, LeftValue) ELSE InternalError ('Param or VarParam symbol expected') END END END PutParameterHeapVar ; (* PutProcedureParameterHeapVars - creates heap variables for parameter sym. *) PROCEDURE PutProcedureParameterHeapVars (sym: CARDINAL) ; BEGIN Assert (IsProcedure (sym)) ; ForeachParamSymDo (sym, PutParameterHeapVar) END PutProcedureParameterHeapVars ; (* NoOfVariables - returns the number of variables in scope. The scope maybe a procedure, module or defimp scope. *) PROCEDURE NoOfVariables (scope: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN IF IsProcedure (scope) THEN RETURN NoOfLocalVar (scope) ELSIF IsModule (scope) THEN pSym := GetPsym (scope) ; WITH pSym^ DO CASE SymbolType OF ModuleSym: RETURN NoOfItemsInList (Module.ListOfVars) ELSE InternalError ('expecting module symbol') END END ELSIF IsDefImp (scope) THEN pSym := GetPsym (scope) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: RETURN NoOfItemsInList (DefImp.ListOfVars) ELSE InternalError ('expecting defimp symbol') END END ELSE InternalError ('expecting procedure, module or defimp symbol') END END NoOfVariables ; (* NoOfLocalVar - returns the number of local variables that exist in procedure Sym. Parameters are NOT included in the count. *) PROCEDURE NoOfLocalVar (Sym: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; n : CARDINAL ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym : n := 0 | ProcedureSym: n := NoOfItemsInList(Procedure.ListOfVars) ELSE InternalError ('expecting a Procedure symbol') END END ; (* Parameters are actually included in the list of local varaibles, therefore we must subtract the Parameter Number from local variable total. *) RETURN( n - NoOfParamAny (Sym) ) END NoOfLocalVar ; (* IsParameterVar - returns true if parameter symbol Sym was declared as a VAR. *) PROCEDURE IsParameterVar (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ParamSym : RETURN( FALSE ) | VarParamSym: RETURN( TRUE ) ELSE InternalError ('expecting Param or VarParam symbol') END END END IsParameterVar ; (* IsParameterUnbounded - returns TRUE if parameter, Sym, is unbounded. *) PROCEDURE IsParameterUnbounded (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ParamSym : RETURN( Param.IsUnbounded ) | VarParamSym: RETURN( VarParam.IsUnbounded ) ELSE InternalError ('expecting Param or VarParam symbol') END END END IsParameterUnbounded ; (* IsUnboundedParam - Returns a conditional depending whether parameter ParamNo is an unbounded array procedure parameter. *) PROCEDURE IsUnboundedParam (Sym: CARDINAL; kind: ProcedureKind; ParamNo: CARDINAL) : BOOLEAN ; VAR param: CARDINAL ; BEGIN param := GetNthParam (Sym, kind, ParamNo) ; RETURN IsParameterUnbounded (param) END IsUnboundedParam ; (* IsUnboundedParam - Returns a conditional depending whether parameter ParamNo is an unbounded array procedure parameter. *) PROCEDURE IsUnboundedParamAny (Sym: CARDINAL; ParamNo: CARDINAL) : BOOLEAN ; VAR kind: ProcedureKind ; BEGIN FOR kind := MIN (ProcedureKind) TO MAX (ProcedureKind) DO IF GetProcedureParametersDefined (Sym, kind) THEN RETURN IsUnboundedParam (Sym, kind, ParamNo) END END ; InternalError ('no procedure kind exists') END IsUnboundedParamAny ; (* IsParameter - returns true if Sym is a parameter symbol. *) PROCEDURE IsParameter (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ParamSym, VarParamSym: RETURN( TRUE ) ELSE RETURN( FALSE ) END END END IsParameter ; (* GetParameterShadowVar - returns the local variable associated with the parameter symbol, sym. *) PROCEDURE GetParameterShadowVar (sym: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF ParamSym : RETURN( Param.ShadowVar ) | VarParamSym: RETURN( VarParam.ShadowVar ) ELSE InternalError ('expecting a ParamSym or VarParamSym') END END END GetParameterShadowVar ; (* IsProcedure - returns true if Sym is a procedure symbol. *) PROCEDURE IsProcedure (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN AssertInRange(Sym) ; pSym := GetPsym(Sym) ; RETURN( pSym^.SymbolType=ProcedureSym ) END IsProcedure ; (* PutProcedureParametersDefined - the procedure symbol sym:kind parameters have been defined. *) PROCEDURE PutProcedureParametersDefined (sym: CARDINAL; kind: ProcedureKind) ; VAR pSym: PtrToSymbol ; BEGIN AssertInRange (sym) ; pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym : | ProcedureSym: Procedure.Decl[kind].ParamDefined := TRUE ; Procedure.BuildProcType := FALSE | ProcTypeSym : ELSE InternalError ('expecting a Procedure symbol') END END END PutProcedureParametersDefined ; (* GetProcedureParametersDefined - returns true if procedure symbol sym:kind parameters are defined. *) PROCEDURE GetProcedureParametersDefined (sym: CARDINAL; kind: ProcedureKind) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN AssertInRange (sym) ; pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym : RETURN( FALSE ) | ProcedureSym: RETURN( Procedure.Decl[kind].ParamDefined ) | ProcTypeSym : RETURN( TRUE ) ELSE InternalError ('expecting a Procedure symbol') END END END GetProcedureParametersDefined ; (* PutProcedureDefined - the procedure symbol sym:kind is defined. *) PROCEDURE PutProcedureDefined (sym: CARDINAL; kind: ProcedureKind) ; VAR pSym: PtrToSymbol ; BEGIN AssertInRange (sym) ; pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym : | ProcedureSym: Procedure.Decl[kind].Defined := TRUE ELSE InternalError ('expecting a Procedure symbol') END END END PutProcedureDefined ; (* GetProcedureDefined - returns true if procedure symbol sym:kind is defined. *) PROCEDURE GetProcedureDefined (sym: CARDINAL; kind: ProcedureKind) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN AssertInRange (sym) ; pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym : RETURN( FALSE ) | ProcedureSym: RETURN( Procedure.Decl[kind].Defined ) ELSE InternalError ('expecting a Procedure symbol') END END END GetProcedureDefined ; (* IsProcedureAnyBoolean - returns the boolean result from p for any of procedure kind which is defined. *) PROCEDURE IsProcedureAnyBoolean (sym: CARDINAL; p: ProcAnyBoolean) : BOOLEAN ; VAR kind: ProcedureKind ; BEGIN FOR kind := MIN (ProcedureKind) TO MAX (ProcedureKind) DO IF GetProcedureDefined (sym, kind) THEN RETURN p (sym, kind) END END ; InternalError ('no procedure kind exists') END IsProcedureAnyBoolean ; (* IsProcedureAnyDefaultBoolean - returns the boolean result from p for any of procedure kind which is defined. *) PROCEDURE IsProcedureAnyDefaultBoolean (sym: CARDINAL; default: BOOLEAN; p: ProcAnyBoolean) : BOOLEAN ; VAR kind: ProcedureKind ; BEGIN FOR kind := MIN (ProcedureKind) TO MAX (ProcedureKind) DO IF GetProcedureDefined (sym, kind) THEN RETURN p (sym, kind) END END ; RETURN default END IsProcedureAnyDefaultBoolean ; (* IsProcedureAnyNoReturn - return TRUE if any of the defined kinds of procedure sym is declared no return. *) PROCEDURE IsProcedureAnyNoReturn (sym: CARDINAL) : BOOLEAN ; BEGIN RETURN IsProcedureAnyDefaultBoolean (sym, FALSE, IsProcedureNoReturn) END IsProcedureAnyNoReturn ; (* FillInUnknownFields - *) PROCEDURE FillInUnknownFields (tok: CARDINAL; sym: CARDINAL; SymName: Name) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(sym) ; WITH pSym^ DO SymbolType := UndefinedSym ; WITH Undefined DO name := SymName ; oafamily := NulSym ; errorScope := GetCurrentErrorScope () ; InitWhereFirstUsedTok (tok, At) END END END FillInUnknownFields ; (* FillInPointerFields - given a new symbol, sym, make it a pointer symbol and initialize its fields. *) PROCEDURE FillInPointerFields (Sym: CARDINAL; PointerName: Name; scope: CARDINAL; oaf: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN IF NOT IsError(Sym) THEN pSym := GetPsym(Sym) ; WITH pSym^ DO SymbolType := PointerSym ; CASE SymbolType OF PointerSym: Pointer.Type := NulSym ; Pointer.name := PointerName ; Pointer.oafamily := oaf ; (* The unbounded for this *) InitTree(Pointer.ConstLitTree) ; (* constants of this type *) Pointer.Scope := scope ; (* Which scope created it *) Pointer.Size := InitValue() ; Pointer.Align := NulSym ; (* Alignment of this type *) ELSE InternalError ('expecting a Pointer symbol') END END END END FillInPointerFields ; (* MakePointer - returns a pointer symbol with PointerName. *) PROCEDURE MakePointer (tok: CARDINAL; PointerName: Name) : CARDINAL ; VAR oaf, sym: CARDINAL ; BEGIN tok := CheckTok (tok, 'pointer') ; sym := HandleHiddenOrDeclare(tok, PointerName, oaf) ; FillInPointerFields(sym, PointerName, GetCurrentScope(), oaf) ; ForeachOAFamily(oaf, doFillInOAFamily) ; RETURN( sym ) END MakePointer ; (* PutPointer - gives a pointer symbol a type, PointerType. *) PROCEDURE PutPointer (Sym: CARDINAL; PointerType: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym : | PointerSym: Pointer.Type := PointerType ELSE InternalError ('expecting a Pointer symbol') END END END PutPointer ; (* IsPointer - returns true is Sym is a pointer type symbol. *) PROCEDURE IsPointer (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN AssertInRange(Sym) ; pSym := GetPsym(Sym) ; RETURN( pSym^.SymbolType=PointerSym ) END IsPointer ; (* IsRecord - returns true is Sym is a record type symbol. *) PROCEDURE IsRecord (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN AssertInRange(Sym) ; pSym := GetPsym(Sym) ; RETURN( pSym^.SymbolType=RecordSym ) END IsRecord ; (* IsArray - returns true is Sym is an array type symbol. *) PROCEDURE IsArray (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN AssertInRange(Sym) ; pSym := GetPsym(Sym) ; RETURN( pSym^.SymbolType=ArraySym ) END IsArray ; (* IsEnumeration - returns true if Sym is an enumeration symbol. *) PROCEDURE IsEnumeration (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN AssertInRange(Sym) ; pSym := GetPsym(Sym) ; RETURN( pSym^.SymbolType=EnumerationSym ) END IsEnumeration ; (* IsUnbounded - returns true if Sym is an unbounded symbol. *) PROCEDURE IsUnbounded (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN AssertInRange(Sym) ; pSym := GetPsym(Sym) ; RETURN( pSym^.SymbolType=UnboundedSym ) END IsUnbounded ; (* GetVarScope - returns the symbol which is the scope of variable Sym. ie a Module, DefImp or Procedure Symbol. *) PROCEDURE GetVarScope (Sym: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym: RETURN( NulSym ) | VarSym : RETURN( Var.Scope ) ELSE InternalError ('expecting a Var symbol') END END END GetVarScope ; (* NoOfElements - Returns the number of elements in array Sym, or the number of elements in an enumeration Sym or the number of interface symbols in an Interface list. *) PROCEDURE NoOfElements (Sym: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; n : CARDINAL ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym : n := 0 | (* ArraySym , UnboundedSym : n := 1 | (* Standard language limitation *) *) EnumerationSym: n := pSym^.Enumeration.NoOfElements | InterfaceSym : n := HighIndice(Interface.Parameters) ELSE InternalError ('expecting an Array or UnBounded symbol') END END ; RETURN( n ) END NoOfElements ; (* PutArraySubscript - places an index field into the array Sym. The index field is a subscript sym. *) PROCEDURE PutArraySubscript (Sym: CARDINAL; SubscriptSymbol: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym: | ArraySym: Array.Subscript := SubscriptSymbol ELSE InternalError ('expecting an Array symbol') END END END PutArraySubscript ; (* GetArraySubscript - returns the subscript symbol for array, Sym. *) PROCEDURE GetArraySubscript (Sym: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym: RETURN( NulSym ) | ArraySym: RETURN( Array.Subscript ) ELSE InternalError ('expecting an Array symbol') END END END GetArraySubscript ; (* MakeSubscript - makes a subscript Symbol. No name is required. *) PROCEDURE MakeSubscript () : CARDINAL ; VAR pSym: PtrToSymbol ; Sym : CARDINAL ; BEGIN NewSym(Sym) ; pSym := GetPsym(Sym) ; WITH pSym^ DO SymbolType := SubscriptSym ; WITH Subscript DO Type := NulSym ; (* Index to a subrange symbol. *) Size := InitValue() ; (* Size of this indice in*Size *) Offset := InitValue() ; (* Offset at runtime of symbol *) (* Pseudo ie: Offset+Size*i *) (* 1..n. The array offset is *) (* the real memory offset. *) (* This offset allows the a[i] *) (* to be calculated without *) (* the need to perform *) (* subtractions when a[4..10] *) (* needs to be indexed. *) InitWhereDeclared(At) (* Declared here *) END END ; RETURN( Sym ) END MakeSubscript ; (* PutSubscript - gives a subscript symbol a type, SimpleType. *) PROCEDURE PutSubscript (Sym: CARDINAL; SimpleType: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym: | SubscriptSym: Subscript.Type := SimpleType ; ELSE InternalError ('expecting a SubScript symbol') END END END PutSubscript ; (* MakeSet - makes a set Symbol with name, SetName. *) PROCEDURE MakeSet (tok: CARDINAL; SetName: Name) : CARDINAL ; VAR pSym : PtrToSymbol ; oaf, sym: CARDINAL ; BEGIN tok := CheckTok (tok, 'set') ; sym := HandleHiddenOrDeclare(tok, SetName, oaf) ; IF NOT IsError(sym) THEN pSym := GetPsym(sym) ; WITH pSym^ DO SymbolType := SetSym ; WITH Set DO name := SetName ; (* The name of the set. *) Type := NulSym ; (* Index to a subrange symbol. *) Size := InitValue() ; (* Size of this set *) InitPacked(packedInfo) ; (* not packed and no *) (* equivalent (yet). *) ispacked := FALSE ; (* Not yet known to be packed. *) oafamily := oaf ; (* The unbounded sym for this *) Scope := GetCurrentScope() ; (* Which scope created it *) InitWhereDeclaredTok(tok, At) (* Declared here *) END END END ; ForeachOAFamily(oaf, doFillInOAFamily) ; RETURN( sym ) END MakeSet ; (* PutSet - places SimpleType as the type for set, Sym. *) PROCEDURE PutSet (Sym: CARDINAL; SimpleType: CARDINAL; packed: BOOLEAN) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym: | SetSym: WITH Set DO Type := SimpleType ; (* Index to a subrange symbol *) (* or an enumeration type. *) ispacked := packed END ELSE InternalError ('expecting a Set symbol') END END END PutSet ; (* IsSet - returns TRUE if Sym is a set symbol. *) PROCEDURE IsSet (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN AssertInRange(Sym) ; pSym := GetPsym(Sym) ; RETURN( pSym^.SymbolType=SetSym ) END IsSet ; (* IsSetPacked - returns TRUE if Sym is packed. *) PROCEDURE IsSetPacked (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN AssertInRange (Sym) ; pSym := GetPsym (Sym) ; RETURN (pSym^.SymbolType=SetSym) AND pSym^.Set.ispacked END IsSetPacked ; (* ForeachParameterDo - *) PROCEDURE ForeachParameterDo (p: CheckProcedure) ; VAR l, h: CARDINAL ; BEGIN l := LowIndice(Symbols) ; h := HighIndice(Symbols) ; WHILE l<=h DO IF IsParameter(l) THEN p(l) END ; INC(l) END END ForeachParameterDo ; (* CheckUnbounded - checks to see if parameter, Sym, is now an unbounded parameter. *) PROCEDURE CheckUnbounded (Sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN AssertInRange(Sym) ; pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ParamSym : IF IsUnbounded(Param.Type) THEN Param.IsUnbounded := TRUE END | VarParamSym: IF IsUnbounded(VarParam.Type) THEN VarParam.IsUnbounded := TRUE END ELSE HALT END END END CheckUnbounded ; (* IsOAFamily - returns TRUE if, Sym, is an OAFamily symbol. *) PROCEDURE IsOAFamily (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN AssertInRange(Sym) ; pSym := GetPsym(Sym) ; RETURN( pSym^.SymbolType=OAFamilySym ) END IsOAFamily ; (* MakeOAFamily - makes an OAFamily symbol based on SimpleType. It returns the OAFamily symbol. A new symbol is created if one does not already exist for SimpleType. *) PROCEDURE MakeOAFamily (SimpleType: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; sym : CARDINAL ; BEGIN sym := GetOAFamily(SimpleType) ; IF sym=NulSym THEN NewSym(sym) ; pSym := GetPsym(sym) ; WITH pSym^ DO SymbolType := OAFamilySym ; OAFamily.MaxDimensions := 0 ; OAFamily.SimpleType := SimpleType ; OAFamily.Dimensions := Indexing.InitIndex(1) END ; PutOAFamily(SimpleType, sym) END ; RETURN( sym ) END MakeOAFamily ; (* GetOAFamily - returns the oafamily symbol associated with SimpleType. *) PROCEDURE GetOAFamily (SimpleType: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(SimpleType) ; WITH pSym^ DO CASE SymbolType OF ErrorSym : RETURN( NulSym ) | RecordSym : RETURN( Record.oafamily ) | SubrangeSym : RETURN( Subrange.oafamily ) | EnumerationSym: RETURN( Enumeration.oafamily ) | ArraySym : RETURN( Array.oafamily ) | ProcTypeSym : RETURN( ProcType.oafamily ) | TypeSym : RETURN( Type.oafamily ) | PointerSym : RETURN( Pointer.oafamily ) | SetSym : RETURN( Set.oafamily ) | UndefinedSym : RETURN( Undefined.oafamily ) ELSE RETURN( NulSym ) END END END GetOAFamily ; (* PutOAFamily - places the, oaf, into, SimpleType, oafamily field. *) PROCEDURE PutOAFamily (SimpleType: CARDINAL; oaf: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(SimpleType) ; WITH pSym^ DO CASE SymbolType OF ErrorSym : | RecordSym : Record.oafamily := oaf | SubrangeSym : Subrange.oafamily := oaf | EnumerationSym: Enumeration.oafamily := oaf | ArraySym : Array.oafamily := oaf | ProcTypeSym : ProcType.oafamily := oaf | TypeSym : Type.oafamily := oaf | PointerSym : Pointer.oafamily := oaf | SetSym : Set.oafamily := oaf | UndefinedSym : Undefined.oafamily := oaf ELSE InternalError ('not expecting this SimpleType') END END END PutOAFamily ; (* ForeachOAFamily - call, p[oaf, ndim, symbol] for every unbounded symbol, sym, in the oaf. *) PROCEDURE ForeachOAFamily (sym: CARDINAL; p: FamilyOperation) ; VAR pSym: PtrToSymbol ; h, i: CARDINAL ; pc : POINTER TO CARDINAL ; BEGIN IF sym#NulSym THEN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF OAFamilySym: h := Indexing.HighIndice(OAFamily.Dimensions) ; i := 1 ; WHILE i<=h DO pc := Indexing.GetIndice(OAFamily.Dimensions, i) ; IF pc#NIL THEN p(sym, i, pc^) END ; INC(i) END ELSE InternalError ('expecting OAFamily symbol') END END END END ForeachOAFamily ; (* doFillInOAFamily - *) PROCEDURE doFillInOAFamily (oaf: CARDINAL; i: CARDINAL; unbounded: CARDINAL) ; VAR SimpleType: CARDINAL ; BEGIN SimpleType := GetType(oaf) ; IF unbounded#NulSym THEN FillInUnboundedFields(GetTokenNo(), unbounded, SimpleType, i) END END doFillInOAFamily ; (* FillInUnboundedFields - *) PROCEDURE FillInUnboundedFields (tok: CARDINAL; sym: CARDINAL; SimpleType: CARDINAL; ndim: CARDINAL) ; VAR pSym : PtrToSymbol ; Contents: CARDINAL ; i : CARDINAL ; BEGIN IF sym#NulSym THEN pSym := GetPsym(sym) ; WITH pSym^ DO SymbolType := UnboundedSym ; WITH Unbounded DO Type := SimpleType ; (* Index to a simple type. *) Size := InitValue() ; (* Size in bytes for this sym *) Scope := GetScope(SimpleType) ; (* Which scope will create it *) InitWhereDeclaredTok(tok, At) ; (* Declared here *) NewSym(RecordType) ; FillInRecordFields(tok, RecordType, NulName, GetScope(SimpleType), NulSym) ; NewSym(Contents) ; FillInPointerFields(Contents, NulName, GetScope(SimpleType), NulSym) ; PutPointer(Contents, SimpleType) ; (* create the contents field for the unbounded array. *) Assert (PutFieldRecord(RecordType, MakeKey(UnboundedAddressName), Contents, NulSym) # NulSym) ; (* create all the high fields for the unbounded array. *) i := 1 ; WHILE i<=ndim DO Assert (PutFieldRecord(RecordType, makekey(string(Mark(Sprintf1(Mark(InitString(UnboundedHighName)), i)))), Cardinal, NulSym) # NulSym) ; INC(i) END ; Dimensions := ndim END END ; ForeachParameterDo(CheckUnbounded) END END FillInUnboundedFields ; (* MakeUnbounded - makes an unbounded array Symbol. ndim is the number of dimensions required. No name is required. *) PROCEDURE MakeUnbounded (tok: CARDINAL; SimpleType: CARDINAL; ndim: CARDINAL) : CARDINAL ; VAR sym, oaf: CARDINAL ; BEGIN tok := CheckTok (tok, 'unbounded') ; oaf := MakeOAFamily(SimpleType) ; sym := GetUnbounded(oaf, ndim) ; IF sym=NulSym THEN NewSym(sym) ; IF IsUnknown (SimpleType) THEN PutPartialUnbounded(sym, SimpleType, ndim) ELSE FillInUnboundedFields(tok, sym, SimpleType, ndim) END ; PutUnbounded(oaf, sym, ndim) END ; RETURN( sym ) END MakeUnbounded ; (* GetUnbounded - returns the unbounded symbol associated with the OAFamily symbol, oaf, and the number of dimensions, ndim, of the open array. *) PROCEDURE GetUnbounded (oaf: CARDINAL; ndim: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(oaf) ; WITH pSym^ DO CASE SymbolType OF OAFamilySym: WITH OAFamily DO IF ndim>MaxDimensions THEN RETURN( NulSym ) ELSE RETURN( GetFromIndex(Dimensions, ndim) ) END END ELSE InternalError ('expecting OAFamily symbol') END END END GetUnbounded ; (* PutUnbounded - associates the unbounded symbol, open, with SimpleType. *) PROCEDURE PutUnbounded (oaf: CARDINAL; sym: CARDINAL; ndim: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(oaf) ; WITH pSym^ DO CASE SymbolType OF OAFamilySym: WITH OAFamily DO (* need to check to see if we need to add NulSym for all dimensions < ndim which have not been used. *) WHILE MaxDimensions0 THEN FOR i := 1 TO n DO s := GetItemFromList(UnresolvedConstructorType, i) ; e := NewError(GetDeclaredMod(s)) ; ErrorFormat0(e, 'constructor has an unknown type') END ; FlushErrors END END CheckAllConstructorsResolved ; (* ResolveConstructorTypes - to be called at the end of pass three. Its purpose is to fix up all constructors whose types are unknown. *) PROCEDURE ResolveConstructorTypes ; VAR finished: BOOLEAN ; i, n, s : CARDINAL ; BEGIN REPEAT n := NoOfItemsInList(UnresolvedConstructorType) ; finished := TRUE ; i := 1 ; WHILE i<=n DO s := GetItemFromList(UnresolvedConstructorType, i) ; Assert(IsConstructor(s)) ; IF CanResolveConstructor(s) THEN finished := FALSE ; RemoveItemFromList(UnresolvedConstructorType, s) ; i := n END ; INC(i) END UNTIL finished ; CheckAllConstructorsResolved END ResolveConstructorTypes ; (* SanityCheckParameters - *) PROCEDURE SanityCheckParameters (sym: CARDINAL) ; VAR p : CARDINAL ; i, n: CARDINAL ; BEGIN i := 1 ; n := NoOfParamAny (sym) ; WHILE i <= n DO p := GetType (GetParam (sym, i)) ; IF IsConst (p) THEN MetaError3 ('the {%1N} formal parameter in procedure {%2Dad} should have a type rather than a constant {%3Dad}', i, sym, p) END ; INC (i) END END SanityCheckParameters ; (* SanityCheckArray - checks to see that an array has a correct subrange type. *) PROCEDURE SanityCheckArray (sym: CARDINAL) ; VAR type : CARDINAL ; subscript: CARDINAL ; BEGIN IF IsArray(sym) THEN subscript := GetArraySubscript(sym) ; IF subscript#NulSym THEN type := SkipType(GetType(subscript)) ; IF IsAModula2Type(type) THEN (* ok all is good *) ELSE MetaError2('the array {%1Dad} must be declared with a simpletype in the [..] component rather than a {%2d}', sym, type) END END END END SanityCheckArray ; (* ForeachSymbolDo - foreach symbol, call, P(sym). *) PROCEDURE ForeachSymbolDo (P: PerformOperation) ; VAR i, n: CARDINAL ; BEGIN i := Indexing.LowIndice(Symbols) ; n := Indexing.HighIndice(Symbols) ; WHILE i<=n DO P(i) ; INC(i) END END ForeachSymbolDo ; (* SanityCheckProcedure - check to see that procedure parameters do not use constants instead of types in their formal parameter section. *) PROCEDURE SanityCheckProcedure (sym: CARDINAL) ; BEGIN SanityCheckParameters(sym) END SanityCheckProcedure ; (* SanityCheckModule - *) PROCEDURE SanityCheckModule (sym: CARDINAL) ; BEGIN ForeachInnerModuleDo(sym, SanityCheckModule) ; ForeachProcedureDo(sym, SanityCheckProcedure) ; ForeachLocalSymDo(sym, SanityCheckArray) END SanityCheckModule ; (* SanityCheckConstants - must only be called once all constants, types, procedures have been declared. It checks to see that constants are not used as procedure parameter types. *) PROCEDURE SanityCheckConstants ; BEGIN ForeachModuleDo(SanityCheckModule) ; ForeachSymbolDo(SanityCheckArray) END SanityCheckConstants ; (* AddNameTo - adds Name, n, to tree, s. *) PROCEDURE AddNameTo (s: SymbolTree; o: CARDINAL) ; BEGIN IF GetSymKey(s, GetSymName(o))=NulKey THEN PutSymKey(s, GetSymName(o), o) END END AddNameTo ; (* AddNameToScope - adds a Name, n, to the list of objects declared at the current scope. *) PROCEDURE AddNameToScope (n: Name) ; VAR pSym : PtrToSymbol ; scope: CARDINAL ; BEGIN scope := GetCurrentScope() ; pSym := GetPsym(scope) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: AddNameTo(Procedure.NamedObjects, MakeObject(n)) | ModuleSym : AddNameTo(Module.NamedObjects, MakeObject(n)) | DefImpSym : AddNameTo(DefImp.NamedObjects, MakeObject(n)) ELSE InternalError ('expecting - DefImp') END END END AddNameToScope ; (* AddNameToImportList - adds a Name, n, to the import list of the current module. *) PROCEDURE AddNameToImportList (n: Name) ; VAR pSym : PtrToSymbol ; scope: CARDINAL ; BEGIN scope := GetCurrentScope() ; pSym := GetPsym(scope) ; WITH pSym^ DO CASE SymbolType OF ModuleSym: AddNameTo(Module.NamedImports, MakeObject(n)) | DefImpSym: AddNameTo(DefImp.NamedImports, MakeObject(n)) ELSE InternalError ('expecting - DefImp or Module symbol') END END END AddNameToImportList ; VAR ResolveModule: CARDINAL ; (* CollectSymbolFrom - *) PROCEDURE CollectSymbolFrom (tok: CARDINAL; scope: CARDINAL; n: Name) : CARDINAL ; VAR n1 : Name ; sym: CARDINAL ; BEGIN n1 := GetSymName (scope) ; IF DebugUnknowns THEN printf2('declaring %a in %a', n, n1) END ; sym := CheckScopeForSym (scope, n) ; IF sym=NulSym THEN sym := FetchUnknownFrom (tok, scope, n) END ; IF DebugUnknowns THEN printf1(' symbol created (%d)\n', sym) END ; RETURN( sym ) END CollectSymbolFrom ; (* CollectUnknown - *) PROCEDURE CollectUnknown (tok: CARDINAL; sym: CARDINAL; n: Name) : CARDINAL ; VAR pSym: PtrToSymbol ; s : CARDINAL ; BEGIN s := NulSym ; IF IsModule (sym) OR IsDefImp (sym) THEN RETURN( CollectSymbolFrom (tok, sym, n) ) ELSIF IsProcedure(sym) THEN s := CheckScopeForSym (sym, n) ; IF s=NulSym THEN pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: IF GetSymKey (Procedure.NamedObjects, n) # NulKey THEN RETURN( CollectSymbolFrom (tok, sym, n) ) END ELSE InternalError ('expecting - Procedure symbol') END END ; s := CollectUnknown (tok, GetScope (sym), n) END END ; RETURN( s ) END CollectUnknown ; (* ResolveImport - *) PROCEDURE ResolveImport (o: WORD) ; VAR n1, n2: Name ; tok : CARDINAL ; sym : CARDINAL ; BEGIN IF DebugUnknowns THEN n1 := GetSymName(o) ; printf1('attempting to find out where %a was declared\n', n1) ; n1 := GetSymName(ResolveModule) ; n2 := GetSymName(GetScope(ResolveModule)) ; printf2('scope of module %a is %a\n', n1, n2) END ; tok := GetFirstUsed (o) ; sym := CollectUnknown (tok, GetScope(ResolveModule), GetSymName(o)) ; IF sym=NulSym THEN MetaError2('unknown symbol {%1Uad} found in import list of module {%2a}', o, ResolveModule) ELSE AddSymToModuleScope(ResolveModule, sym) END END ResolveImport ; (* ResolveRelativeImport - *) PROCEDURE ResolveRelativeImport (sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN IF IsModule(sym) THEN ResolveModule := sym ; pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF ModuleSym: ForeachNodeDo(Module.NamedImports, ResolveImport) ELSE InternalError ('expecting - Module symbol') END END END ; ForeachProcedureDo(sym, ResolveRelativeImport) ; ForeachInnerModuleDo(sym, ResolveRelativeImport) END ResolveRelativeImport ; (* ResolveImports - it examines the import list of all inner modules and resolves all relative imports. *) PROCEDURE ResolveImports ; VAR scope: CARDINAL ; BEGIN scope := GetCurrentScope() ; IF DebugUnknowns THEN DisplayTrees(scope) END ; ForeachProcedureDo(scope, ResolveRelativeImport) ; ForeachInnerModuleDo(scope, ResolveRelativeImport) END ResolveImports ; (* GetScope - returns the declaration scope of the symbol. *) PROCEDURE GetScope (Sym: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym : RETURN( Error.Scope ) | DefImpSym : RETURN( NulSym ) | ModuleSym : RETURN( Module.Scope ) | VarSym : RETURN( Var.Scope ) | ProcedureSym : RETURN( Procedure.Scope ) | ProcTypeSym : RETURN( ProcType.Scope ) | RecordFieldSym : RETURN( RecordField.Scope ) | VarientSym : RETURN( Varient.Scope ) | VarientFieldSym : RETURN( VarientField.Scope ) | EnumerationSym : RETURN( Enumeration.Scope ) | EnumerationFieldSym: RETURN( EnumerationField.Scope ) | SubrangeSym : RETURN( Subrange.Scope ) | ArraySym : RETURN( Array.Scope ) | TypeSym : RETURN( Type.Scope ) | PointerSym : RETURN( Pointer.Scope ) | RecordSym : RETURN( Record.Scope ) | SetSym : RETURN( Set.Scope ) | UnboundedSym : RETURN( Unbounded.Scope ) | ConstLitSym : RETURN( ConstLit.Scope ) | ConstStringSym : RETURN( ConstString.Scope ) | ConstVarSym : RETURN( ConstVar.Scope ) | ParamSym : IF Param.ShadowVar = NulSym THEN RETURN NulSym ELSE RETURN( GetScope (Param.ShadowVar) ) END | VarParamSym : IF VarParam.ShadowVar = NulSym THEN RETURN NulSym ELSE RETURN( GetScope (VarParam.ShadowVar) ) END | UndefinedSym : RETURN( NulSym ) | PartialUnboundedSym: InternalError ('should not be requesting the scope of a PartialUnbounded symbol') ELSE InternalError ('not implemented yet') END END END GetScope ; (* GetModuleScope - returns the module scope of symbol, sym. If sym was declared within a nested procedure then return the module which defines the procedure. *) PROCEDURE GetModuleScope (sym: CARDINAL) : CARDINAL ; VAR mod: CARDINAL ; BEGIN mod := GetScope(sym) ; WHILE (mod#NulSym) AND (NOT IsDefImp(mod)) AND (NOT IsModule(mod)) DO mod := GetScope(mod) END ; RETURN( mod ) END GetModuleScope ; (* GetProcedureScope - returns the innermost procedure (if any) in which the symbol, sym, resides. A module inside the procedure is skipped over. *) PROCEDURE GetProcedureScope (sym: CARDINAL) : CARDINAL ; BEGIN WHILE (sym#NulSym) AND (NOT IsProcedure(sym)) DO sym := GetScope(sym) END ; IF (sym#NulSym) AND IsProcedure(sym) THEN RETURN( sym ) ELSE RETURN( NulSym ) END END GetProcedureScope ; (* IsModuleWithinProcedure - returns TRUE if module, sym, is inside a procedure. *) PROCEDURE IsModuleWithinProcedure (sym: CARDINAL) : BOOLEAN ; BEGIN RETURN( GetProcedureScope (sym) # NulSym ) END IsModuleWithinProcedure ; (* GetParent - returns the parent of symbol, Sym. *) PROCEDURE GetParent (Sym: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym : ErrorAbort0('') | VarientSym : RETURN( Varient.Parent ) | VarientFieldSym : RETURN( VarientField.Parent ) | RecordFieldSym : RETURN( RecordField.Parent ) | EnumerationFieldSym: RETURN( EnumerationField.Type ) ELSE InternalError ('not implemented yet') END END END GetParent ; (* IsRecordField - returns true if Sym is a record field. *) PROCEDURE IsRecordField (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; RETURN( pSym^.SymbolType=RecordFieldSym ) END IsRecordField ; (* MakeProcType - returns a procedure type symbol with ProcTypeName. *) PROCEDURE MakeProcType (tok: CARDINAL; ProcTypeName: Name) : CARDINAL ; VAR pSym : PtrToSymbol ; oaf, sym: CARDINAL ; BEGIN tok := CheckTok (tok, 'proctype') ; sym := HandleHiddenOrDeclare (tok, ProcTypeName, oaf) ; IF NOT IsError(sym) THEN pSym := GetPsym(sym) ; WITH pSym^ DO SymbolType := ProcTypeSym ; CASE SymbolType OF ProcTypeSym: ProcType.ReturnType := NulSym ; ProcType.name := ProcTypeName ; InitList(ProcType.ListOfParam) ; ProcType.HasVarArgs := FALSE ; (* Does this proc type use ... ? *) ProcType.HasOptArg := FALSE ; (* Does this proc type use [ ] ? *) ProcType.OptArgInit := NulSym ; (* The optarg initial value. *) ProcType.ReturnOptional := FALSE ; (* Is the return value optional? *) ProcType.ReturnTypeTok := UnknownTokenNo ; ProcType.Scope := GetCurrentScope() ; (* scope of procedure. *) ProcType.Size := InitValue() ; ProcType.TotalParamSize := InitValue() ; (* size of all parameters *) ProcType.oafamily := oaf ; (* The oa family for this symbol *) InitWhereDeclaredTok(tok, ProcType.At) (* Declared here *) ELSE InternalError ('expecting ProcType symbol') END END END ; ForeachOAFamily(oaf, doFillInOAFamily) ; RETURN( sym ) END MakeProcType ; (* PutProcTypeParam - Places a Non VAR parameter ParamName with type ParamType into ProcType Sym. *) PROCEDURE PutProcTypeParam (Sym: CARDINAL; ParamType: CARDINAL; isUnbounded: BOOLEAN) ; VAR pSym : PtrToSymbol ; ParSym: CARDINAL ; BEGIN NewSym(ParSym) ; pSym := GetPsym(ParSym) ; WITH pSym^ DO SymbolType := ParamSym ; WITH Param DO name := NulName ; Type := ParamType ; IsUnbounded := isUnbounded ; ShadowVar := NulSym ; InitWhereDeclared(At) END END ; AddParameter (Sym, ProperProcedure, ParSym) END PutProcTypeParam ; (* PutProcTypeVarParam - Places a Non VAR parameter ParamName with type ParamType into ProcType Sym. *) PROCEDURE PutProcTypeVarParam (Sym: CARDINAL; ParamType: CARDINAL; isUnbounded: BOOLEAN) ; VAR pSym : PtrToSymbol ; ParSym: CARDINAL ; BEGIN NewSym(ParSym) ; pSym := GetPsym(ParSym) ; WITH pSym^ DO SymbolType := VarParamSym ; WITH Param DO name := NulName ; Type := ParamType ; IsUnbounded := isUnbounded ; ShadowVar := NulSym ; InitWhereDeclared(At) END END ; AddParameter (Sym, ProperProcedure, ParSym) END PutProcTypeVarParam ; (* GetProcedureProcType - returns the proctype matching procedure sym. *) PROCEDURE GetProcedureProcType (sym: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: RETURN Procedure.ProcedureType ELSE InternalError ('expecting Procedure symbol') END END END GetProcedureProcType ; (* PutProcedureReachable - Sets the procedure, Sym, to be reachable by the main Module. *) PROCEDURE PutProcedureReachable (Sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym: | ProcedureSym: Procedure.Reachable := TRUE ELSE InternalError ('expecting Procedure symbol') END END END PutProcedureReachable ; (* PutModuleStartQuad - Places QuadNumber into the Module symbol, Sym. QuadNumber is the start quad of Module, Sym. *) PROCEDURE PutModuleStartQuad (Sym: CARDINAL; QuadNumber: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ModuleSym: Module.StartQuad := QuadNumber | DefImpSym: DefImp.StartQuad := QuadNumber ELSE InternalError ('expecting a Module or DefImp symbol') END END END PutModuleStartQuad ; (* PutModuleEndQuad - Places QuadNumber into the Module symbol, Sym. QuadNumber is the end quad of Module, Sym. *) PROCEDURE PutModuleEndQuad (Sym: CARDINAL; QuadNumber: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ModuleSym: Module.EndQuad := QuadNumber | DefImpSym: DefImp.EndQuad := QuadNumber ELSE InternalError ('expecting a Module or DefImp symbol') END END END PutModuleEndQuad ; (* PutModuleFinallyStartQuad - Places QuadNumber into the Module symbol, Sym. QuadNumber is the finally start quad of Module, Sym. *) PROCEDURE PutModuleFinallyStartQuad (Sym: CARDINAL; QuadNumber: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ModuleSym: Module.StartFinishQuad := QuadNumber | DefImpSym: DefImp.StartFinishQuad := QuadNumber ELSE InternalError ('expecting a Module or DefImp symbol') END END END PutModuleFinallyStartQuad ; (* PutModuleFinallyEndQuad - Places QuadNumber into the Module symbol, Sym. QuadNumber is the end quad of the finally block in Module, Sym. *) PROCEDURE PutModuleFinallyEndQuad (Sym: CARDINAL; QuadNumber: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ModuleSym: Module.EndFinishQuad := QuadNumber | DefImpSym: DefImp.EndFinishQuad := QuadNumber ELSE InternalError ('expecting a Module or DefImp symbol') END END END PutModuleFinallyEndQuad ; (* GetModuleQuads - Returns, StartInit EndInit StartFinish EndFinish, Quads of a Module, Sym. Start and End represent the initialization code of the Module, Sym. *) PROCEDURE GetModuleQuads (Sym: CARDINAL; VAR StartInit, EndInit, StartFinish, EndFinish: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ModuleSym: WITH Module DO StartInit := StartQuad ; EndInit := EndQuad ; StartFinish := StartFinishQuad ; EndFinish := EndFinishQuad END | DefImpSym: WITH DefImp DO StartInit := StartQuad ; EndInit := EndQuad ; StartFinish := StartFinishQuad ; EndFinish := EndFinishQuad END ELSE InternalError ('expecting a Module or DefImp symbol') END END END GetModuleQuads ; (* PutModuleFinallyFunction - Places Tree, finally, into the Module symbol, Sym. *) PROCEDURE PutModuleFinallyFunction (Sym: CARDINAL; finally: tree) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ModuleSym: Module.FinallyFunction := finally | DefImpSym: DefImp.FinallyFunction := finally ELSE InternalError ('expecting a Module or DefImp symbol') END END END PutModuleFinallyFunction ; (* GetModuleFinallyFunction - returns the finally tree from the Module symbol, Sym. *) PROCEDURE GetModuleFinallyFunction (Sym: CARDINAL) : tree ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ModuleSym: RETURN( Module.FinallyFunction) | DefImpSym: RETURN( DefImp.FinallyFunction) ELSE InternalError ('expecting a Module or DefImp symbol') END END END GetModuleFinallyFunction ; (* PutProcedureScopeQuad - Places QuadNumber into the Procedure symbol, Sym. QuadNumber is the start quad of scope for procedure, Sym. *) PROCEDURE PutProcedureScopeQuad (Sym: CARDINAL; QuadNumber: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: Procedure.ScopeQuad := QuadNumber ELSE InternalError ('expecting a Procedure symbol') END END END PutProcedureScopeQuad ; (* PutProcedureStartQuad - Places QuadNumber into the Procedure symbol, Sym. QuadNumber is the start quad of procedure, Sym. *) PROCEDURE PutProcedureStartQuad (Sym: CARDINAL; QuadNumber: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: Procedure.StartQuad := QuadNumber ELSE InternalError ('expecting a Procedure symbol') END END END PutProcedureStartQuad ; (* PutProcedureEndQuad - Places QuadNumber into the Procedure symbol, Sym. QuadNumber is the end quad of procedure, Sym. *) PROCEDURE PutProcedureEndQuad (Sym: CARDINAL; QuadNumber: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: Procedure.EndQuad := QuadNumber ELSE InternalError ('expecting a Procedure symbol') END END END PutProcedureEndQuad ; (* GetProcedureQuads - Returns, Start and End, Quads of a procedure, Sym. *) PROCEDURE GetProcedureQuads (Sym: CARDINAL; VAR scope, start, end: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: WITH Procedure DO scope := ScopeQuad ; start := StartQuad ; end := EndQuad END ELSE InternalError ('expecting a Procedure symbol') END END END GetProcedureQuads ; (* GetReadQuads - assigns Start and End to the beginning and end of symbol, Sym, read history usage. *) PROCEDURE GetReadQuads (Sym: CARDINAL; m: ModeOfAddr; VAR Start, End: CARDINAL) ; BEGIN GetReadLimitQuads(Sym, m, 0, 0, Start, End) END GetReadQuads ; (* GetWriteQuads - assigns Start and End to the beginning and end of symbol, Sym, usage. *) PROCEDURE GetWriteQuads (Sym: CARDINAL; m: ModeOfAddr; VAR Start, End: CARDINAL) ; BEGIN GetWriteLimitQuads(Sym, m, 0, 0, Start, End) END GetWriteQuads ; (* PutProcedureBegin - assigns begin as the token number matching the procedure BEGIN. *) PROCEDURE PutProcedureBegin (Sym: CARDINAL; begin: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: Procedure.Begin := begin ELSE InternalError ('expecting a Procedure symbol') END END END PutProcedureBegin ; (* PutProcedureEnd - assigns end as the token number matching the procedure END. *) PROCEDURE PutProcedureEnd (Sym: CARDINAL; end: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: Procedure.End := end ELSE InternalError ('expecting a Procedure symbol') END END END PutProcedureEnd ; (* GetProcedureBeginEnd - assigns, begin, end, to the stored token values. *) PROCEDURE GetProcedureBeginEnd (Sym: CARDINAL; VAR begin, end: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: begin := Procedure.Begin ; end := Procedure.End ELSE InternalError ('expecting a Procedure symbol') END END END GetProcedureBeginEnd ; (* Max - *) PROCEDURE Max (a, b: CARDINAL) : CARDINAL ; BEGIN IF a>b THEN RETURN( a ) ELSE RETURN( b ) END END Max ; (* Min - *) PROCEDURE Min (a, b: CARDINAL) : CARDINAL ; BEGIN IF aEnd) AND (j>=StartLimit) AND ((j<=EndLimit) OR (EndLimit=0)) THEN End := j END ; IF ((Start=0) OR (j=StartLimit) AND ((j<=EndLimit) OR (EndLimit=0)) THEN Start := j END ; INC(i) END END DoFindLimits ; (* GetReadLimitQuads - returns Start and End which have been assigned the start and end of when the symbol was read to within: StartLimit..EndLimit. *) PROCEDURE GetReadLimitQuads (Sym: CARDINAL; m: ModeOfAddr; StartLimit, EndLimit: CARDINAL; VAR Start, End: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF VarSym: DoFindLimits(StartLimit, EndLimit, Start, End, Var.ReadUsageList[m]) ELSE InternalError ('expecting a Var symbol') END END END GetReadLimitQuads ; (* GetWriteLimitQuads - returns Start and End which have been assigned the start and end of when the symbol was written to within: StartLimit..EndLimit. *) PROCEDURE GetWriteLimitQuads (Sym: CARDINAL; m: ModeOfAddr; StartLimit, EndLimit: CARDINAL; VAR Start, End: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF VarSym : DoFindLimits(StartLimit, EndLimit, Start, End, Var.WriteUsageList[m]) ELSE InternalError ('expecting a Var symbol') END END END GetWriteLimitQuads ; (* GetNthProcedure - Returns the Nth procedure in Module, Sym. *) PROCEDURE GetNthProcedure (Sym: CARDINAL; n: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF DefImpSym: RETURN( GetItemFromList(DefImp.ListOfProcs, n) ) | ModuleSym: RETURN( GetItemFromList(Module.ListOfProcs, n) ) ELSE InternalError ('expecting a DefImp or Module symbol') END END END GetNthProcedure ; (* GetDeclaredDefinition - returns the token where this symbol was declared in the definition module. *) PROCEDURE GetDeclaredDefinition (Sym: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym : RETURN( Error.At.DefDeclared ) | ObjectSym : RETURN( Object.At.DefDeclared ) | VarientSym : RETURN( Varient.At.DefDeclared ) | RecordSym : RETURN( Record.At.DefDeclared ) | SubrangeSym : RETURN( Subrange.At.DefDeclared ) | EnumerationSym : RETURN( Enumeration.At.DefDeclared ) | ArraySym : RETURN( Array.At.DefDeclared ) | SubscriptSym : RETURN( Subscript.At.DefDeclared ) | UnboundedSym : RETURN( Unbounded.At.DefDeclared ) | ProcedureSym : RETURN( Procedure.At.DefDeclared ) | ProcTypeSym : RETURN( ProcType.At.DefDeclared ) | ParamSym : RETURN( Param.At.DefDeclared ) | VarParamSym : RETURN( VarParam.At.DefDeclared ) | ConstStringSym : RETURN( ConstString.At.DefDeclared ) | ConstLitSym : RETURN( ConstLit.At.DefDeclared ) | ConstVarSym : RETURN( ConstVar.At.DefDeclared ) | VarSym : RETURN( Var.At.DefDeclared ) | TypeSym : RETURN( Type.At.DefDeclared ) | PointerSym : RETURN( Pointer.At.DefDeclared ) | RecordFieldSym : RETURN( RecordField.At.DefDeclared ) | VarientFieldSym : RETURN( VarientField.At.DefDeclared ) | EnumerationFieldSym: RETURN( EnumerationField.At.DefDeclared ) | SetSym : RETURN( Set.At.DefDeclared ) | DefImpSym : RETURN( DefImp.At.DefDeclared ) | ModuleSym : RETURN( Module.At.DefDeclared ) | UndefinedSym : RETURN( GetFirstUsed(Sym) ) | ImportSym : RETURN( Import.at.DefDeclared ) | ImportStatementSym : RETURN( ImportStatement.at.DefDeclared ) | PartialUnboundedSym: RETURN( GetDeclaredDefinition(PartialUnbounded.Type) ) ELSE InternalError ('not expecting this type of symbol') END END END GetDeclaredDefinition ; (* GetDeclaredModule - returns the token where this symbol was declared in an implementation or program module. *) PROCEDURE GetDeclaredModule (Sym: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym : RETURN( Error.At.ModDeclared ) | ObjectSym : RETURN( Object.At.ModDeclared ) | VarientSym : RETURN( Varient.At.ModDeclared ) | RecordSym : RETURN( Record.At.ModDeclared ) | SubrangeSym : RETURN( Subrange.At.ModDeclared ) | EnumerationSym : RETURN( Enumeration.At.ModDeclared ) | ArraySym : RETURN( Array.At.ModDeclared ) | SubscriptSym : RETURN( Subscript.At.ModDeclared ) | UnboundedSym : RETURN( Unbounded.At.ModDeclared ) | ProcedureSym : RETURN( Procedure.At.ModDeclared ) | ProcTypeSym : RETURN( ProcType.At.ModDeclared ) | ParamSym : RETURN( Param.At.ModDeclared ) | VarParamSym : RETURN( VarParam.At.ModDeclared ) | ConstStringSym : RETURN( ConstString.At.ModDeclared ) | ConstLitSym : RETURN( ConstLit.At.ModDeclared ) | ConstVarSym : RETURN( ConstVar.At.ModDeclared ) | VarSym : RETURN( Var.At.ModDeclared ) | TypeSym : RETURN( Type.At.ModDeclared ) | PointerSym : RETURN( Pointer.At.ModDeclared ) | RecordFieldSym : RETURN( RecordField.At.ModDeclared ) | VarientFieldSym : RETURN( VarientField.At.ModDeclared ) | EnumerationFieldSym: RETURN( EnumerationField.At.ModDeclared ) | SetSym : RETURN( Set.At.ModDeclared ) | DefImpSym : RETURN( DefImp.At.ModDeclared ) | ModuleSym : RETURN( Module.At.ModDeclared ) | UndefinedSym : RETURN( GetFirstUsed(Sym) ) | ImportSym : RETURN( Import.at.ModDeclared ) | ImportStatementSym : RETURN( ImportStatement.at.ModDeclared ) | PartialUnboundedSym: RETURN( GetDeclaredModule(PartialUnbounded.Type) ) ELSE InternalError ('not expecting this type of symbol') END END END GetDeclaredModule ; (* PutDeclaredDefinition - associates the current tokenno with the symbols declaration in the definition module. *) PROCEDURE PutDeclaredDefinition (tok: CARDINAL; Sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym : Error.At.DefDeclared := tok | ObjectSym : Object.At.DefDeclared := tok | VarientSym : Varient.At.DefDeclared := tok | RecordSym : Record.At.DefDeclared := tok | SubrangeSym : Subrange.At.DefDeclared := tok | EnumerationSym : Enumeration.At.DefDeclared := tok | ArraySym : Array.At.DefDeclared := tok | SubscriptSym : Subscript.At.DefDeclared := tok | UnboundedSym : Unbounded.At.DefDeclared := tok | ProcedureSym : Procedure.At.DefDeclared := tok | ProcTypeSym : ProcType.At.DefDeclared := tok | ParamSym : Param.At.DefDeclared := tok | VarParamSym : VarParam.At.DefDeclared := tok | ConstStringSym : ConstString.At.DefDeclared := tok | ConstLitSym : ConstLit.At.DefDeclared := tok | ConstVarSym : ConstVar.At.DefDeclared := tok | VarSym : Var.At.DefDeclared := tok | TypeSym : Type.At.DefDeclared := tok | PointerSym : Pointer.At.DefDeclared := tok | RecordFieldSym : RecordField.At.DefDeclared := tok | VarientFieldSym : VarientField.At.DefDeclared := tok | EnumerationFieldSym: EnumerationField.At.DefDeclared := tok | SetSym : Set.At.DefDeclared := tok | DefImpSym : DefImp.At.DefDeclared := tok | ModuleSym : Module.At.DefDeclared := tok | UndefinedSym : | PartialUnboundedSym: PutDeclaredDefinition(tok, PartialUnbounded.Type) ELSE InternalError ('not expecting this type of symbol') END END END PutDeclaredDefinition ; (* PutDeclaredModule - returns the token where this symbol was declared in an implementation or program module. *) PROCEDURE PutDeclaredModule (tok: CARDINAL; Sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym : Error.At.ModDeclared := tok | ObjectSym : Object.At.ModDeclared := tok | VarientSym : Varient.At.ModDeclared := tok | RecordSym : Record.At.ModDeclared := tok | SubrangeSym : Subrange.At.ModDeclared := tok | EnumerationSym : Enumeration.At.ModDeclared := tok | ArraySym : Array.At.ModDeclared := tok | SubscriptSym : Subscript.At.ModDeclared := tok | UnboundedSym : Unbounded.At.ModDeclared := tok | ProcedureSym : Procedure.At.ModDeclared := tok | ProcTypeSym : ProcType.At.ModDeclared := tok | ParamSym : Param.At.ModDeclared := tok | VarParamSym : VarParam.At.ModDeclared := tok | ConstStringSym : ConstString.At.ModDeclared := tok | ConstLitSym : ConstLit.At.ModDeclared := tok | ConstVarSym : ConstVar.At.ModDeclared := tok | VarSym : Var.At.ModDeclared := tok | TypeSym : Type.At.ModDeclared := tok | PointerSym : Pointer.At.ModDeclared := tok | RecordFieldSym : RecordField.At.ModDeclared := tok | VarientFieldSym : VarientField.At.ModDeclared := tok | EnumerationFieldSym: EnumerationField.At.ModDeclared := tok | SetSym : Set.At.ModDeclared := tok | DefImpSym : DefImp.At.ModDeclared := tok | ModuleSym : Module.At.ModDeclared := tok | UndefinedSym : | PartialUnboundedSym: PutDeclaredModule(tok, PartialUnbounded.Type) ELSE InternalError ('not expecting this type of symbol') END END END PutDeclaredModule ; (* PutDeclared - adds an entry to symbol, Sym, indicating that it was declared at, tok. This routine may be called twice, once for definition module partial declaration and once when parsing the implementation module. *) PROCEDURE PutDeclared (tok: CARDINAL; Sym: CARDINAL) ; BEGIN IF CompilingDefinitionModule () THEN PutDeclaredDefinition (tok, Sym) ELSE PutDeclaredModule (tok, Sym) END END PutDeclared ; (* GetDeclaredDef - returns the tokenno where the symbol was declared in the definition module. UnknownTokenNo is returned if no declaration occurred. *) PROCEDURE GetDeclaredDef (Sym: CARDINAL) : CARDINAL ; BEGIN RETURN GetDeclaredDefinition (Sym) END GetDeclaredDef ; (* GetDeclaredMod - returns the tokenno where the symbol was declared. in the program or implementation module. UnknownTokenNo is returned if no declaration occurred. *) PROCEDURE GetDeclaredMod (Sym: CARDINAL) : CARDINAL ; BEGIN RETURN GetDeclaredModule (Sym) END GetDeclaredMod ; (* GetDeclaredFor - returns the token where this forward procedure symbol was declared in the program or implementation module. UnknownTokenNo is returned if no declaration occurred. *) PROCEDURE GetDeclaredFor (Sym: CARDINAL) : CARDINAL ; BEGIN IF IsProcedure (Sym) THEN RETURN GetProcedureDeclaredTok (Sym, ForwardProcedure) ELSE RETURN UnknownTokenNo END END GetDeclaredFor ; (* GetProcedureKind - returns the procedure kind given the declaration tok. The declaration tok must match the ident tok in the procedure name. It is only safe to call this procedure function during pass 2 onwards. *) PROCEDURE GetProcedureKind (sym: CARDINAL; tok: CARDINAL) : ProcedureKind ; VAR kind: ProcedureKind ; pSym: PtrToSymbol ; BEGIN pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: FOR kind := MIN (ProcedureKind) TO MAX (ProcedureKind) DO IF Procedure.Decl[kind].ProcedureTok = tok THEN RETURN kind END END | ProcTypeSym: RETURN ProperProcedure ELSE InternalError ('expecting ProcedureSym symbol') END END ; InternalError ('ProcedureSym kind has not yet been declared') END GetProcedureKind ; (* GetProcedureDeclaredTok - return the token where the declaration of procedure sym:kind occurred. *) PROCEDURE GetProcedureDeclaredTok (sym: CARDINAL; kind: ProcedureKind) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: RETURN Procedure.Decl[kind].ProcedureTok ELSE InternalError ('expecting procedure symbol') END END END GetProcedureDeclaredTok ; (* PutProcedureDeclaredTok - places the tok where the declaration of procedure sym:kind occurred. *) PROCEDURE PutProcedureDeclaredTok (sym: CARDINAL; kind: ProcedureKind; tok: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: Procedure.Decl[kind].ProcedureTok := tok ELSE InternalError ('expecting procedure symbol') END END END PutProcedureDeclaredTok ; (* GetReturnTypeTok - return the token where the return type procedure sym:kind or proctype was defined. *) PROCEDURE GetReturnTypeTok (sym: CARDINAL; kind: ProcedureKind) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: RETURN Procedure.Decl[kind].ReturnTypeTok | ProcTypeSym : RETURN ProcType.ReturnTypeTok ELSE InternalError ('expecting procedure symbol') END END END GetReturnTypeTok ; (* PutReturnTypeTok - places the tok where the return type of procedure sym:kind or proctype was defined. *) PROCEDURE PutReturnTypeTok (sym: CARDINAL; kind: ProcedureKind; tok: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: Procedure.Decl[kind].ReturnTypeTok := tok | ProcTypeSym : ProcType.ReturnTypeTok := tok ELSE InternalError ('expecting procedure symbol') END END END PutReturnTypeTok ; (* GetProcedureKindDesc - return a string describing kind. *) PROCEDURE GetProcedureKindDesc (kind: ProcedureKind) : String ; BEGIN IF kind = ProperProcedure THEN RETURN InitString ('proper procedure') ELSIF kind = ForwardProcedure THEN RETURN InitString ('forward procedure') ELSIF kind = DefProcedure THEN RETURN InitString ('definition procedure') END ; InternalError ('unknown kind value') END GetProcedureKindDesc ; (* GetFirstUsed - returns the token where this symbol was first used. *) PROCEDURE GetFirstUsed (Sym: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (Sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym : RETURN( Error.At.FirstUsed ) | ObjectSym : RETURN( Object.At.FirstUsed ) | UndefinedSym : RETURN( Undefined.At.FirstUsed ) | VarientSym : RETURN( Varient.At.FirstUsed ) | RecordSym : RETURN( Record.At.FirstUsed ) | SubrangeSym : RETURN( Subrange.At.FirstUsed ) | EnumerationSym : RETURN( Enumeration.At.FirstUsed ) | ArraySym : RETURN( Array.At.FirstUsed ) | SubscriptSym : RETURN( Subscript.At.FirstUsed ) | UnboundedSym : RETURN( Unbounded.At.FirstUsed ) | ProcedureSym : RETURN( Procedure.At.FirstUsed ) | ProcTypeSym : RETURN( ProcType.At.FirstUsed ) | ParamSym : RETURN( Param.At.FirstUsed ) | VarParamSym : RETURN( VarParam.At.FirstUsed ) | ConstStringSym : RETURN( ConstString.At.FirstUsed ) | ConstLitSym : RETURN( ConstLit.At.FirstUsed ) | ConstVarSym : RETURN( ConstVar.At.FirstUsed ) | VarSym : RETURN( Var.At.FirstUsed ) | TypeSym : RETURN( Type.At.FirstUsed ) | PointerSym : RETURN( Pointer.At.FirstUsed ) | RecordFieldSym : RETURN( RecordField.At.FirstUsed ) | VarientFieldSym : RETURN( VarientField.At.FirstUsed ) | EnumerationFieldSym: RETURN( EnumerationField.At.FirstUsed ) | SetSym : RETURN( Set.At.FirstUsed ) | DefImpSym : RETURN( DefImp.At.FirstUsed ) | ModuleSym : RETURN( Module.At.FirstUsed ) ELSE InternalError ('not expecting this type of symbol') END END END GetFirstUsed ; (* ForeachProcedureDo - for each procedure in module, Sym, do procedure, P. *) PROCEDURE ForeachProcedureDo (Sym: CARDINAL; P: PerformOperation) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF DefImpSym : ForeachItemInListDo( DefImp.ListOfProcs, P) | ModuleSym : ForeachItemInListDo( Module.ListOfProcs, P) | ProcedureSym: ForeachItemInListDo( Procedure.ListOfProcs, P) ELSE InternalError ('expecting DefImp or Module symbol') END END END ForeachProcedureDo ; (* ForeachInnerModuleDo - for each inner module in module, Sym, do procedure, P. *) PROCEDURE ForeachInnerModuleDo (Sym: CARDINAL; P: PerformOperation) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF DefImpSym : ForeachItemInListDo( DefImp.ListOfModules, P) | ModuleSym : ForeachItemInListDo( Module.ListOfModules, P) | ProcedureSym: ForeachItemInListDo( Procedure.ListOfModules, P) ELSE InternalError ('expecting DefImp or Module symbol') END END END ForeachInnerModuleDo ; (* ForeachModuleDo - for each module do procedure, P. *) PROCEDURE ForeachModuleDo (P: PerformOperation) ; BEGIN ForeachNodeDo (ModuleTree, P) END ForeachModuleDo ; (* ForeachFieldEnumerationDo - for each field in enumeration, Sym, do procedure, P. Each call to P contains an enumeration field, the order is alphabetical. Use ForeachLocalSymDo for declaration order. *) PROCEDURE ForeachFieldEnumerationDo (Sym: CARDINAL; P: PerformOperation) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF EnumerationSym: ForeachNodeDo (Enumeration.LocalSymbols, P) ELSE InternalError ('expecting Enumeration symbol') END END END ForeachFieldEnumerationDo ; (* IsProcedureReachable - Returns true if the procedure, Sym, is reachable from the main Module. *) PROCEDURE IsProcedureReachable (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: RETURN( Procedure.Reachable ) ELSE InternalError ('expecting Procedure symbol') END END END IsProcedureReachable ; (* IsProcType - returns true if Sym is a ProcType Symbol. *) PROCEDURE IsProcType (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; RETURN( pSym^.SymbolType=ProcTypeSym ) END IsProcType ; (* IsVar - returns true if Sym is a Var Symbol. *) PROCEDURE IsVar (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; RETURN( pSym^.SymbolType=VarSym ) END IsVar ; (* DoIsConst - returns TRUE if Sym is defined as a constant or is an enumeration field or string. *) PROCEDURE DoIsConst (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO RETURN( (SymbolType=ConstVarSym) OR (SymbolType=ConstLitSym) OR (SymbolType=ConstStringSym) OR ((SymbolType=VarSym) AND (Var.AddrMode=ImmediateValue)) OR (SymbolType=EnumerationFieldSym) ) END END DoIsConst ; (* IsConst - returns true if Sym contains a constant value. *) PROCEDURE IsConst (Sym: CARDINAL) : BOOLEAN ; BEGIN IF IsConstructor(Sym) THEN RETURN( IsConstructorConstant(Sym) ) ELSE RETURN( DoIsConst(Sym) ) END END IsConst ; (* IsConstString - returns whether sym is a conststring of any variant. *) PROCEDURE IsConstString (sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (sym) ; WITH pSym^ DO RETURN SymbolType = ConstStringSym END END IsConstString ; (* IsConstLit - returns true if Sym is a literal constant. *) PROCEDURE IsConstLit (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO RETURN( SymbolType=ConstLitSym ) END END IsConstLit ; (* IsDummy - returns true if Sym is a Dummy symbol. *) PROCEDURE IsDummy (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; RETURN( pSym^.SymbolType=DummySym ) END IsDummy ; (* IsTemporary - returns true if Sym is a Temporary symbol. *) PROCEDURE IsTemporary (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF VarSym : RETURN( Var.IsTemp ) | ConstVarSym: RETURN( ConstVar.IsTemp ) ELSE RETURN( FALSE ) END END END IsTemporary ; (* IsVarAParam - returns true if Sym is a variable declared as a parameter. *) PROCEDURE IsVarAParam (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF VarSym: RETURN( Var.IsParam ) ELSE RETURN( FALSE ) END END END IsVarAParam ; (* IsSubscript - returns true if Sym is a subscript symbol. *) PROCEDURE IsSubscript (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; RETURN( pSym^.SymbolType=SubscriptSym ) END IsSubscript ; (* IsSubrange - returns true if Sym is a subrange symbol. *) PROCEDURE IsSubrange (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; RETURN( pSym^.SymbolType=SubrangeSym ) END IsSubrange ; (* IsProcedureVariable - returns true if a Sym is a variable and it was declared within a procedure. *) PROCEDURE IsProcedureVariable (Sym: CARDINAL) : BOOLEAN ; BEGIN AssertInRange(Sym) ; RETURN( IsVar(Sym) AND IsProcedure(GetVarScope(Sym)) ) END IsProcedureVariable ; (* IsProcedureNested - returns TRUE if procedure, Sym, was declared as a nested procedure. *) PROCEDURE IsProcedureNested (Sym: CARDINAL) : BOOLEAN ; BEGIN RETURN( IsProcedure(Sym) AND (IsProcedure(GetScope(Sym))) ) END IsProcedureNested ; (* IsAModula2Type - returns true if Sym, is a: IsType, IsPointer, IsRecord, IsEnumeration, IsSubrange, IsArray, IsUnbounded, IsProcType. NOTE that it different from IsType. *) PROCEDURE IsAModula2Type (Sym: CARDINAL) : BOOLEAN ; BEGIN AssertInRange(Sym) ; RETURN( IsType(Sym) OR IsRecord(Sym) OR IsPointer(Sym) OR IsEnumeration(Sym) OR IsSubrange(Sym) OR IsArray(Sym) OR IsUnbounded(Sym) OR IsProcType(Sym) OR IsSet(Sym) ) END IsAModula2Type ; (* IsGnuAsmVolatile - returns TRUE if a GnuAsm symbol was defined as VOLATILE. *) PROCEDURE IsGnuAsmVolatile (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF GnuAsmSym: RETURN( GnuAsm.Volatile ) ELSE InternalError ('expecting GnuAsm symbol') END END END IsGnuAsmVolatile ; (* IsGnuAsmSimple - returns TRUE if a GnuAsm symbol is a simple kind. *) PROCEDURE IsGnuAsmSimple (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF GnuAsmSym: RETURN( GnuAsm.Simple ) ELSE InternalError ('expecting GnuAsm symbol') END END END IsGnuAsmSimple ; (* IsGnuAsm - returns TRUE if Sym is a GnuAsm symbol. *) PROCEDURE IsGnuAsm (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO RETURN( SymbolType=GnuAsmSym ) END END IsGnuAsm ; (* IsRegInterface - returns TRUE if Sym is a RegInterface symbol. *) PROCEDURE IsRegInterface (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(Sym) ; WITH pSym^ DO RETURN( SymbolType=InterfaceSym ) END END IsRegInterface ; (* GetParam - returns the ParamNo parameter from procedure ProcSym *) PROCEDURE GetParam (Sym: CARDINAL; ParamNo: CARDINAL) : CARDINAL ; BEGIN AssertInRange(Sym) ; IF ParamNo=0 THEN (* Parameter Zero is the return argument for the Function *) RETURN(GetType(Sym)) ELSE RETURN (GetNthParamAny (Sym, ParamNo)) END END GetParam ; (* GetFromIndex - return a value from list, i, at position, n. *) PROCEDURE GetFromIndex (i: Indexing.Index; n: CARDINAL) : CARDINAL ; VAR p: POINTER TO CARDINAL ; BEGIN p := Indexing.GetIndice(i, n) ; RETURN( p^ ) END GetFromIndex ; (* PutIntoIndex - places value, v, into list, i, at position, n. *) PROCEDURE PutIntoIndex (VAR i: Indexing.Index; n: CARDINAL; v: CARDINAL) ; VAR p: POINTER TO CARDINAL ; BEGIN NEW(p) ; p^ := v ; Indexing.PutIndice(i, n, p) END PutIntoIndex ; (* Make2Tuple - creates and returns a 2 tuple from, a, and, b. *) PROCEDURE Make2Tuple (a, b: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; Sym : CARDINAL ; BEGIN NewSym(Sym) ; pSym := GetPsym(Sym) ; WITH pSym^ DO SymbolType := TupleSym ; WITH Tuple DO nTuple := 2 ; list := Indexing.InitIndex(1) ; PutIntoIndex(list, 1, a) ; PutIntoIndex(list, 2, b) ; InitWhereDeclared(At) ; InitWhereFirstUsed(At) END END ; RETURN( Sym ) END Make2Tuple ; (* IsSizeSolved - returns true if the size of Sym is solved. *) PROCEDURE IsSizeSolved (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN AssertInRange(Sym) ; pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym : RETURN( IsSolved(Procedure.Size) ) | VarSym : RETURN( IsSolved(Var.Size) ) | TypeSym : RETURN( IsSolved(Type.Size) ) | SetSym : RETURN( IsSolved(Set.Size) ) | RecordSym : RETURN( IsSolved(Record.Size) ) | VarientSym : RETURN( IsSolved(Varient.Size) ) | EnumerationSym : RETURN( IsSolved(Enumeration.Size) ) | PointerSym : RETURN( IsSolved(Pointer.Size) ) | ArraySym : RETURN( IsSolved(Array.Size) ) | RecordFieldSym : RETURN( IsSolved(RecordField.Size) ) | VarientFieldSym : RETURN( IsSolved(VarientField.Size) ) | SubrangeSym : RETURN( IsSolved(Subrange.Size) ) | SubscriptSym : RETURN( IsSolved(Subscript.Size) ) | ProcTypeSym : RETURN( IsSolved(ProcType.Size) ) | UnboundedSym : RETURN( IsSolved(Unbounded.Size) ) ELSE InternalError ('not expecting this kind of symbol') END END END IsSizeSolved ; (* IsOffsetSolved - returns true if the Offset of Sym is solved. *) PROCEDURE IsOffsetSolved (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN AssertInRange(Sym) ; pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF VarSym : RETURN( IsSolved(Var.Offset) ) | RecordFieldSym : RETURN( IsSolved(RecordField.Offset) ) | VarientFieldSym : RETURN( IsSolved(VarientField.Offset) ) ELSE InternalError ('not expecting this kind of symbol') END END END IsOffsetSolved ; (* IsValueSolved - returns true if the value of Sym is solved. *) PROCEDURE IsValueSolved (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN AssertInRange(Sym) ; pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ConstLitSym : RETURN( IsSolved(ConstLit.Value) ) | ConstVarSym : RETURN( IsSolved(ConstVar.Value) ) | EnumerationFieldSym : RETURN( IsSolved(EnumerationField.Value) ) | ConstStringSym : RETURN( TRUE ) ELSE InternalError ('not expecting this kind of symbol') END END END IsValueSolved ; (* IsConstructorConstant - returns TRUE if constructor, Sym, is defined by only constants. *) PROCEDURE IsConstructorConstant (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN IF IsConstructor(Sym) OR IsConstSet(Sym) THEN pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ConstVarSym: RETURN( IsValueConst(ConstVar.Value) ) | ConstLitSym: RETURN( IsValueConst(ConstLit.Value) ) ELSE InternalError ('expecting Constructor') END END ELSE InternalError ('expecting Constructor') END END IsConstructorConstant ; (* IsComposite - returns TRUE if symbol, sym, is a composite type: ie an ARRAY or RECORD. *) PROCEDURE IsComposite (sym: CARDINAL) : BOOLEAN ; BEGIN IF sym=NulSym THEN RETURN( FALSE ) ELSE sym := SkipType(sym) ; RETURN( IsArray(sym) OR IsRecord(sym) ) END END IsComposite ; (* IsSumOfParamSizeSolved - has the sum of parameters been solved yet? *) PROCEDURE IsSumOfParamSizeSolved (Sym: CARDINAL) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN AssertInRange(Sym) ; pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: RETURN( IsSolved(Procedure.TotalParamSize) ) | ProcTypeSym : RETURN( IsSolved(ProcType.TotalParamSize) ) ELSE InternalError ('expecting Procedure or ProcType symbol') END END END IsSumOfParamSizeSolved ; (* PushSize - pushes the size of Sym. *) PROCEDURE PushSize (Sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN AssertInRange(Sym) ; pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym : PushFrom(Procedure.Size) | VarSym : PushFrom(Var.Size) | TypeSym : PushFrom(Type.Size) | SetSym : PushFrom(Set.Size) | VarientSym : PushFrom(Varient.Size) | RecordSym : PushFrom(Record.Size) | EnumerationSym : PushFrom(Enumeration.Size) | PointerSym : PushFrom(Pointer.Size) | ArraySym : PushFrom(Array.Size) | RecordFieldSym : PushFrom(RecordField.Size) | VarientFieldSym : PushFrom(VarientField.Size) | SubrangeSym : PushFrom(Subrange.Size) | SubscriptSym : PushFrom(Subscript.Size) | ProcTypeSym : PushFrom(ProcType.Size) | UnboundedSym : PushFrom(Unbounded.Size) ELSE InternalError ('not expecting this kind of symbol') END END END PushSize ; (* PopSize - pops the ALU stack into Size of Sym. *) PROCEDURE PopSize (Sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN AssertInRange(Sym) ; pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym : PopInto(Procedure.Size) | VarSym : PopInto(Var.Size) | TypeSym : PopInto(Type.Size) | RecordSym : PopInto(Record.Size) | VarientSym : PopInto(Varient.Size) | EnumerationSym : PopInto(Enumeration.Size) | PointerSym : PopInto(Pointer.Size) | ArraySym : PopInto(Array.Size) | RecordFieldSym : PopInto(RecordField.Size) | VarientFieldSym : PopInto(VarientField.Size) | SubrangeSym : PopInto(Subrange.Size) | SubscriptSym : PopInto(Subscript.Size) | ProcTypeSym : PopInto(ProcType.Size) | UnboundedSym : PopInto(Unbounded.Size) | SetSym : PopInto(Set.Size) ELSE InternalError ('not expecting this kind of symbol') END END END PopSize ; (* PushValue - pushes the Value of Sym onto the ALU stack. *) PROCEDURE PushValue (Sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN AssertInRange(Sym) ; pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ConstLitSym : PushFrom(ConstLit.Value) | ConstVarSym : PushFrom(ConstVar.Value) | EnumerationFieldSym : PushFrom(EnumerationField.Value) | ConstStringSym : PushConstString(Sym) ELSE InternalError ('not expecting this kind of symbol') END END END PushValue ; (* PushConstString - pushes the character string onto the ALU stack. It assumes that the character string is only one character long. *) PROCEDURE PushConstString (Sym: CARDINAL) ; VAR pSym: PtrToSymbol ; a : ARRAY [0..10] OF CHAR ; BEGIN AssertInRange (Sym) ; pSym := GetPsym (Sym) ; WITH pSym^ DO CASE SymbolType OF ConstStringSym: WITH ConstString DO IF Length = 0 THEN PushChar (nul) ELSIF Length = 1 THEN GetKey (Contents, a) ; PushChar (a[0]) ELSE WriteFormat0 ('ConstString must be length 0 or 1') END END ELSE InternalError ('expecting ConstString symbol') END END END PushConstString ; (* PushVarSize - pushes the size of a variable, Sym. The runtime size of Sym will depend upon its addressing mode, RightValue has size PushSize(GetType(Sym)) and LeftValue has size PushSize(Address) since it points to a variable. *) PROCEDURE PushVarSize (Sym: CARDINAL) ; BEGIN AssertInRange(Sym) ; Assert(IsVar(Sym)) ; IF GetMode(Sym)=LeftValue THEN PushSize(Address) ELSE Assert(GetMode(Sym)=RightValue) ; PushSize(GetType(Sym)) END END PushVarSize ; (* PopValue - pops the ALU stack into Value of Sym. *) PROCEDURE PopValue (Sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN AssertInRange(Sym) ; pSym := GetPsym(Sym) ; WITH pSym^ DO CASE SymbolType OF ConstLitSym : PopInto(ConstLit.Value) | ConstVarSym : PopInto(ConstVar.Value) | EnumerationFieldSym : InternalError ('cannot pop into an enumeration field') ELSE InternalError ('symbol type not expected') END END END PopValue ; (* PutAlignment - assigns the alignment constant associated with, type, with, align. *) PROCEDURE PutAlignment (type: CARDINAL; align: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(type) ; WITH pSym^ DO CASE SymbolType OF RecordSym : Record.Align := align | RecordFieldSym: RecordField.Align := align | TypeSym : Type.Align := align | ArraySym : Array.Align := align | PointerSym : Pointer.Align := align | SubrangeSym : Subrange.Align := align ELSE InternalError ('expecting record, field, pointer, type, subrange or an array symbol') END END END PutAlignment ; (* GetAlignment - returns the alignment constant associated with, type. *) PROCEDURE GetAlignment (type: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(type) ; WITH pSym^ DO CASE SymbolType OF RecordSym : RETURN( Record.Align ) | RecordFieldSym : RETURN( RecordField.Align ) | TypeSym : RETURN( Type.Align ) | ArraySym : RETURN( Array.Align ) | PointerSym : RETURN( Pointer.Align ) | VarientFieldSym: RETURN( GetAlignment(VarientField.Parent) ) | VarientSym : RETURN( GetAlignment(Varient.Parent) ) | SubrangeSym : RETURN( Subrange.Align ) ELSE InternalError ('expecting record, field, pointer, type, subrange or an array symbol') END END END GetAlignment ; (* PutDefaultRecordFieldAlignment - assigns, align, as the default alignment to record, sym. *) PROCEDURE PutDefaultRecordFieldAlignment (sym: CARDINAL; align: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF RecordSym: Record.DefaultAlign := align ELSE InternalError ('expecting record symbol') END END END PutDefaultRecordFieldAlignment ; (* GetDefaultRecordFieldAlignment - assigns, align, as the default alignment to record, sym. *) PROCEDURE GetDefaultRecordFieldAlignment (sym: CARDINAL) : CARDINAL ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym(sym) ; WITH pSym^ DO CASE SymbolType OF RecordSym : RETURN( Record.DefaultAlign ) | VarientFieldSym: RETURN( GetDefaultRecordFieldAlignment(GetParent(sym)) ) | VarientSym : RETURN( GetDefaultRecordFieldAlignment(GetParent(sym)) ) ELSE InternalError ('expecting record symbol') END END END GetDefaultRecordFieldAlignment ; (* VarCheckReadInit - returns TRUE if sym has been initialized. *) PROCEDURE VarCheckReadInit (sym: CARDINAL; mode: ModeOfAddr) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN IF IsVar (sym) THEN pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF VarSym: RETURN GetInitialized (Var.InitState[mode]) ELSE END END END ; RETURN FALSE END VarCheckReadInit ; (* VarInitState - initializes the init state for variable sym. *) PROCEDURE VarInitState (sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN IF IsVar (sym) THEN pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF VarSym: ConfigSymInit (Var.InitState[LeftValue], sym) ; ConfigSymInit (Var.InitState[RightValue], sym) ELSE END END END END VarInitState ; (* PutVarInitialized - set sym as initialized. *) PROCEDURE PutVarInitialized (sym: CARDINAL; mode: ModeOfAddr) ; VAR pSym: PtrToSymbol ; BEGIN IF IsVar (sym) THEN pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF VarSym: WITH Var DO SetInitialized (InitState[mode]) END ELSE END END END END PutVarInitialized ; (* PutVarFieldInitialized - records that field has been initialized with variable sym. TRUE is returned if the field is detected and changed to initialized. *) PROCEDURE PutVarFieldInitialized (sym: CARDINAL; mode: ModeOfAddr; fieldlist: List) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN IF IsVar (sym) THEN pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF VarSym: WITH Var DO RETURN SetFieldInitialized (InitState[mode], fieldlist) END ELSE END END END ; RETURN FALSE END PutVarFieldInitialized ; (* GetVarFieldInitialized - return TRUE if fieldlist has been initialized within variable sym. *) PROCEDURE GetVarFieldInitialized (sym: CARDINAL; mode: ModeOfAddr; fieldlist: List) : BOOLEAN ; VAR pSym: PtrToSymbol ; BEGIN IF IsVar (sym) THEN pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF VarSym: WITH Var DO RETURN GetFieldInitialized (InitState[mode], fieldlist) END ELSE END END END ; RETURN FALSE END GetVarFieldInitialized ; (* PrintInitialized - display variable sym initialization state. *) PROCEDURE PrintInitialized (sym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN IF IsVar (sym) THEN pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF VarSym: printf0 ("LeftMode init: ") ; PrintSymInit (Var.InitState[LeftValue]) ; printf0 ("RightMode init: ") ; PrintSymInit (Var.InitState[RightValue]) ELSE END END END END PrintInitialized ; (* DumpSymbols - display all symbol numbers and their type. *) (* PROCEDURE DumpSymbols ; VAR pSym: PtrToSymbol ; sym : CARDINAL ; BEGIN sym := 1 ; WHILE sym <= FinalSymbol () DO pSym := GetPsym(sym) ; printf ("%d ", sym) ; WITH pSym^ DO CASE SymbolType OF RecordSym: printf ("RecordSym") | VarientSym: printf ("VarientSym") | DummySym: printf ("DummySym") | VarSym: printf ("VarSym") | EnumerationSym: printf ("EnumerationSym") | SubrangeSym: printf ("SubrangeSym") | ArraySym: printf ("ArraySym") | ConstStringSym: printf ("ConstStringSym") | ConstVarSym: printf ("ConstVarSym") | ConstLitSym: printf ("ConstLitSym") | VarParamSym: printf ("VarParamSym") | ParamSym: printf ("ParamSym") | PointerSym: printf ("PointerSym") | UndefinedSym: printf ("UndefinedSym") | TypeSym: printf ("TypeSym") | RecordFieldSym: printf ("RecordFieldSym") | VarientFieldSym: printf ("VarientFieldSym") | EnumerationFieldSym: printf ("EnumerationFieldSym") | DefImpSym: printf ("DefImpSym") | ModuleSym: printf ("ModuleSym") | SetSym: printf ("SetSym") | ProcedureSym: printf ("ProcedureSym") | ProcTypeSym: printf ("ProcTypeSym") | SubscriptSym: printf ("SubscriptSym") | UnboundedSym: printf ("UnboundedSym") | GnuAsmSym: printf ("GnuAsmSym") | InterfaceSym: printf ("InterfaceSym") | ObjectSym: printf ("ObjectSym") | PartialUnboundedSym: printf ("PartialUnboundedSym") | TupleSym: printf ("TupleSym") | OAFamilySym: printf ("OAFamilySym") | EquivSym: printf ("EquivSym") | ErrorSym: printf ("ErrorSym") END END ; printf ("\n") ; INC (sym) END END DumpSymbols ; *) (* GetErrorScope - returns the error scope for a symbol. The error scope is the title scope which is used to announce the symbol in the GCC error message. *) PROCEDURE GetErrorScope (sym: CARDINAL) : ErrorScope ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (sym) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: RETURN Procedure.errorScope | ModuleSym : RETURN Module.errorScope | DefImpSym : RETURN DefImp.errorScope | UndefinedSym: RETURN Undefined.errorScope ELSE InternalError ('expecting procedure, module or defimp symbol') END END END GetErrorScope ; (* PutErrorScope - sets the error scope for a symbol. The error scope is the title scope which is used to announce the symbol in the GCC error message. *) (* PROCEDURE PutErrorScope (sym: CARDINAL; errorScope: ErrorScope) ; VAR pSym: PtrToSymbol ; BEGIN pSym := GetPsym (type) ; WITH pSym^ DO CASE SymbolType OF ProcedureSym: Procedure.errorScope := errorScope | ModuleSym : Module.errorScope := errorScope | DefImpSym : DefImp.errorScope := errorScope ELSE InternalError ('expecting procedure, module or defimp symbol') END END END PutErrorScope ; *) (* IsLegal - returns TRUE if, sym, is a legal symbol. *) PROCEDURE IsLegal (sym: CARDINAL) : BOOLEAN ; BEGIN RETURN sym < FreeSymbol END IsLegal ; BEGIN Init END SymbolTable.