{ History ------- 11/09/85 - change call of FutureBlocklabel in CreateId 08/10/85 - modified to fix dispose error and initialise FormalScope. (agh) 15/10/85 - initialise InputSpelling and OutputSpelling. (agh) 16/10/85 - history tidied. (agh) 18/10/85 - modify MostLikelyOf for better error recovery. (agh) 25/10/85 - initialise FSpace field of IdRecord with DftSpace. (agh) 25/11/85 - Modify WithSchema to pass WordIndex parameter. (agh) 01/12/85 - Add error code to call of RangeCheck. (agh) 04/12/85 - Change spec of WithSchema. (agh) 12/12/85 - Complete initialisation of FileType and NaturalType. (agh) ---------------------------------------------------------------------- 12/02/86 - Remove call of FutureBlockLabel from CreateId and call in EnterProcFunc } { MODULE 10 Semantic Analysis and Semantic Error Recovery Semantic analysis and semantic error recovery are implemented by 'enrichment' of the syntax analyser with semantic interludes. These semantic interludes depend on the following globally-defined data structures and manipulative procedures. } program Support; #include "globals.x" #include "source.pf" #include "interface.pf" #include "lexical.pf" #include "diags.pf" { 10.1 Semantic error reporting. Most semantic errors are reported relative to the current symbol in the program text. This is facilitated by the procedure Semanti- cError. Some errors however, are reported retrospectively, and relate to an earlier point in the program, e.g. a point of declaration. For these a direct call on the procedure Error is used. } procedure SemanticError(Code: Scalar); visible; begin Error(Code, StartOfSymbol) end; { 10.2 Identifier lists. During the construction and analysis of identifier entries, it is sometimes necessary or convenient to hold and process sequential lists of these entries. The following procedures enable such lists to be manipulated, as records of type Idlist. } procedure StartList(var List: IdList); visible; begin List.FirstEntry := nil; List.LastEntry := nil end { startlist }; procedure AppendId(var List: IdList; var Id: IdEntry); visible; var NewEntry: ListEntry; begin new(NewEntry); NewEntry^.Id := Id; NewEntry^.Next := nil; if List.FirstEntry = nil then List.FirstEntry := NewEntry else List.LastEntry^.Next := NewEntry; List.LastEntry := NewEntry end { appendid }; procedure ForAll(List: IdList; procedure Action(Id: IdEntry)); visible; var ThisEntry: ListEntry; begin ThisEntry := List.FirstEntry; while ThisEntry <> nil do begin Action(ThisEntry^.Id); ThisEntry := ThisEntry^.Next end end { forall }; procedure DsposeList(List: IdList); visible; var NextEntry, ThisEntry: ListEntry; begin NextEntry := List.FirstEntry; while NextEntry <> nil do begin ThisEntry := NextEntry; NextEntry := ThisEntry^.Next; dispose(ThisEntry) end end { displist }; { In some contexts, however, a set rather than a list of identifiers is required. The following procedures allow such sets to be mani- pulated as records of the type Idset, using the same underlying representation as that for Idlist. } procedure StartSet(var s: IdSet); visible; begin StartList(s) end; function InSet(s: IdSet; Id: IdEntry): Boolean; visible; var NextOnList: ListEntry; begin InSet := false; NextOnList := s.FirstEntry; while NextOnList <> nil do begin if NextOnList^.Id = Id then InSet := true; NextOnList := NextOnList^.Next end end { inset }; procedure Include(var s: IdSet; Id: IdEntry); visible; begin if not InSet(s, Id) then AppendId(s, Id) end; procedure Exclude(var s: IdSet; Id: IdEntry); visible; var ThisEntry, PreviousEntry: ListEntry; begin PreviousEntry := nil; ThisEntry := s.FirstEntry; while ThisEntry <> nil do if ThisEntry^.Id = Id then begin if PreviousEntry = nil then s.FirstEntry := ThisEntry^.Next else PreviousEntry^.Next := ThisEntry^.Next; if ThisEntry = s.LastEntry then s.LastEntry := PreviousEntry; dispose(ThisEntry); ThisEntry := nil end else begin PreviousEntry := ThisEntry; ThisEntry := ThisEntry^.Next end end { exclude }; procedure DsposeSet(s: IdSet); visible; begin DsposeList(s) end; { 10.3 The semantic table and scope. This holds an entry for each identifier, type or label which may appear in the program being compiled. The table is organised as a stack of sub-tables, one for each identifier scope currently open, the nesting of these scopes being represented by the array Display as follows:- 1. Each display entry points to the identifier, type and label sub-tables for that scope, and indicates whether the scope is one delimited by a block, or by a record type. 2. The global variables ScopeLevel and BlockLevel index the top- most scope and topmost block scope respectively within the display. 3. Display housekeeping is carried out by the procedures Init- Scope, OpenScope, SaveScope, RestoreScope and CloseScope. The distinctive features of the Pascal rules of scope defined by the ISO standard are: R1. The defining occurrence of an identifier must precede all corresponding applied occurrences in its scope, with one exception: a type-identifier may appear in a pointer-type definition before being defined in the same block. For exam- ple: pointer = ^sometype ; . . sometype = domaintype ; is legal. R2. The defining occurrence of an identifier must not be preceded in its scope by an applied occurrence corresponding to a non- local definition of the same identifier. For example const n = 100 ; proc P ; type range = 1..n ; var n : integer ; begin . . end; is illegal. R3. A distinction is made between the scope associated with a formal parameter list and the scope associated with the corresponding procedure or function block. Thus a type- identifier used in declaring a formal parameter may be rede- fined within the procedure or function block without violat- ing rule R2. For example: function f (n : argument) : result ; var argument : integer ; begin . . end ; is legal. Apart from the pointer type problem which is discussed in section 10.4, rule R1 is enforced naturally by one-pass entry and search of the identifier sub-tables. Rule R2 is enforced by a method due to Arthur Sale in which each new scope is assigned a monotonically increasing scope-number when opened. At each identifier occurrence the current scope-number is copied into a LastUse field in the identifier's table entry. A nonlocal identifier may be redefined in a new scope, only if the value of the LastUse field in the nonlocal entry is less than the new scope number. Rule R3 is enforced by an extension of the LastUse mechanism which also accomodates the split scopes created by forward declarations. At the end of a formal parameter list the parameter scope is saved, to be restored at the start of the corresponding procedure or function block with a new scope-number. During restoration the LastUse field of each formal-parameter identifier entry is also updated to the new scope number. Non-local type-identifiers are unaffected by this process and may therefore be redefined in the block without violating R2. In this implementation, the semantic-table has capacity for up to 19 nested scopes. When this is exceeded, an error is reported. } procedure InitScope; visible; begin ScopeLevel := 0; BlockLevel := 0; with Display[0] do begin ScopeNo := 0; NextScopeNo := 1; Locals := nil; Scope := ActualBlock; StartSet(Threatened); TypeChain := nil; LabelChain := nil end end { initscope }; procedure OpenScope(Kind: ScopeKind); visible; begin if ScopeLevel < DispLimit then begin ScopeLevel := ScopeLevel + 1; with Display[ScopeLevel] do begin ScopeNo := NextScopeNo; NextScopeNo := NextScopeNo + 1; Locals := nil; Scope := Kind; if Kind <> RecordScope then begin StartSet(Threatened); TypeChain := nil; LabelChain := nil; if Kind = ActualBlock then BlockLevel := ScopeLevel end else begin FieldsPacked := false; RecordType := nil; ReadOnlyScope := false end end end else SystemError(1) end { openscope }; procedure SaveScope(var Scope: ScopeCopy); visible; begin new(Scope); Scope^ := Display[ScopeLevel]; ScopeLevel := ScopeLevel - 1; BlockLevel := BlockLevel - 1 end { savescope }; procedure ReEnterScope(Scope: ScopeCopy); visible; var NewScopeNo: ScopeNumber; procedure UpdateIdUsage(Id: IdEntry); begin if Id <> nil then with Id^ do begin UpdateIdUsage(LeftLink); LastUse := NewScopeNo; UpdateIdUsage(RightLink) end end { updateidusage }; begin ScopeLevel := ScopeLevel + 1; BlockLevel := BlockLevel + 1; Display[ScopeLevel] := Scope^; NewScopeNo := NextScopeNo; NextScopeNo := NextScopeNo + 1; with Display[ScopeLevel] do begin ScopeNo := NewScopeNo; UpdateIdUsage(Locals) end; dispose(Scope) end { restoscope }; procedure CloseScope; visible; begin if Display[ScopeLevel].Scope = ActualBlock then BlockLevel := BlockLevel - 1; ScopeLevel := ScopeLevel - 1 end { closescope }; { 10.4 The identifier sub-tables. The identifier sub-table for each scope contains an entry for each identifier declared in that scope. Each entry is a record of the variant record type IdRecord. The sub-table is held as a sorted binary tree, records being connected through their fields LeftLink and RightLink. Insertion and lookup of identifiers within the sub-tables is pro- vided by the two procedures NewId and SearchId. When necessary, a particular binary tree may be searched using the procedure Sear- chLocalId. SearchLocalId involves no logic for error reporting or recovery, but recovery from errors involving duplicate, mis-used and unde- clared identifiers is accomodated within NewId and SearchId as follows:- 1. If NewId finds an entry for the identifier already in the current scope, an error is flagged but a second entry is still made (for possible selection by SearchId as below). 2. SearchId is passed a parameter specifying the acceptable classes of entry to be found. If the first entry encountered for the identifier is not of an acceptable class searching continues within the same scope for a possible duplicate entry. If no acceptable duplicate is found in the scope a misuse error is reported and a duplicate entry of acceptable class is created in the same scope. 3. If SearchId fails to find an entry in any scope for the iden- tifier sought, an undeclared error is reported and an entry of acceptable class is created for the identifier, with oth- erwise default attributes, in the current block scope. The forward binding of pointer domains required by scope rule R1 is complicated by the fact that pointer-type definitions can appear within nested record-scopes. For example: rec1 = record f : record n : ^d end ; d : integer end ; d = real ; is illegal since the identifier d is redefined as a field- identifier after an application as a domain-identifier in a nested record-scope. Correct handling of pointer domains is achieved by creating an immediate entry with the special class Domain for each identifier occurring as a domain type in the type definition part, if one does not already exist. This entry will subsequently be changed to class Types if a corresponding type definition is encountered, but in the meantime other usage errors will be detected by applying the Sale algorithm in the usual way. To sup- port this strategy special procedures SearchDomain and BindDomain are provided within this identifier table handling section. Sear- chDomain determines if usage to date of an available type identif- ier implies immediate binding, and precludes further conflicting usage of the identifier (by adjusting LastUse for any entry within the current block). BindDomain carries out a previously delayed binding to a nonlocal type identifier when appropriate. } procedure CreateId(var Entry: IdEntry; ClassNeeded: IdClass); visible; var NewEntry: IdEntry; IdName: Alfa; begin { createid } { create new entry of appropriate class } case ClassNeeded of Domain : new(NewEntry, Domain); Types : new(NewEntry, Types); Consts : new(NewEntry, Consts); PresetVars : new(NewEntry, PresetVars); ReadOnlyVars : new(NewEntry, ReadOnlyVars); Vars : new(NewEntry, Vars); Field : new(NewEntry, Field); Bound : new(NewEntry, Bound); Proc : new(NewEntry, Proc); Func : new(NewEntry, Func) end; { set name, klass, and default attributes } with NewEntry^ do begin CopySpelling(IdName); Name := IdName; IdType := Unknown; LastUse := Display[ScopeLevel].ScopeNo; if ImportingSource then Referenced := true else Referenced := false; Klass := ClassNeeded; case Klass of Domain : Referenced := true; Types : ; Consts : begin Values := DftValue; SuccId := nil end; PresetVars, ReadOnlyVars, Vars : begin VarKind := LocalVar; VarAddress := DftAddress end; Field : begin Offset := DftOffset; Tag := false; NextField := nil end; Bound : begin BdAddress := DftAddress; NextBound := nil end; Proc, Func : begin PfDecKind := Declared; PfKind := Actual; Formals := nil; FSpace := DftSpace; Assignable := false; Assigned := false; BlockKind := LocalBlock; FormalScope := nil; Forwrd := false; Result := DftAddress end end end; Entry := NewEntry end { createid }; procedure EnterId(NewEntry: IdEntry; var Scope: IdEntry); visible; var NewName: Alfa; ThisEntry, LastEntry: IdEntry; LeftTaken: Boolean; begin { enterid } if Scope = nil then Scope := NewEntry else begin NewName := NewEntry^.Name; ThisEntry := Scope; repeat LastEntry := ThisEntry; if ThisEntry^.Name.Head < NewName.Head then begin ThisEntry := ThisEntry^.RightLink; LeftTaken := false end else if ThisEntry^.Name.Head > NewName.Head then begin ThisEntry := ThisEntry^.LeftLink; LeftTaken := true end else if RankedTails(ThisEntry^.Name.Tail, NewName.Tail) then begin ThisEntry := ThisEntry^.RightLink; LeftTaken := false end else { duplicates go to the left } begin ThisEntry := ThisEntry^.LeftLink; LeftTaken := true end until ThisEntry = nil; if LeftTaken then LastEntry^.LeftLink := NewEntry else LastEntry^.RightLink := NewEntry end; NewEntry^.LeftLink := nil; NewEntry^.RightLink := nil end { enterid }; procedure SeekLocalId(Scope: IdEntry; var Entry: IdEntry); visible; label 1; var ThisEntry: IdEntry; begin { seeklocalid } ThisEntry := Scope; while ThisEntry <> nil do if Spelling.Head < ThisEntry^.Name.Head then ThisEntry := ThisEntry^.LeftLink else if Spelling.Head > ThisEntry^.Name.Head then ThisEntry := ThisEntry^.RightLink else if RankedTails(Spelling.Tail, ThisEntry^.Name.Tail) then ThisEntry := ThisEntry^.LeftLink else if RankedTails(ThisEntry^.Name.Tail, Spelling.Tail) then ThisEntry := ThisEntry^.RightLink else goto 1; 1 : Entry := ThisEntry end { seeklocalid }; procedure SearchScopes(Inner, Outer: DispRange; var Entry: IdEntry); visible; label 1; var Index: DispRange; begin for Index := Inner downto Outer do begin SeekLocalId(Display[Index].Locals, Entry); if Entry <> nil then begin LevelFound := Index; goto 1 end end; 1 : end { searchscopes }; procedure SearchGlobals(ClassNeeded: IdClass; var IdFound: IdEntry); visible; begin SearchScopes(BlockLevel, 0, IdFound); if IdFound <> nil then if IdFound^.Klass <> ClassNeeded then IdFound := nil end { SearchGlobals }; procedure BindDomain(Domain: IdEntry); visible; var TypeFound: Boolean; EntryFound: IdEntry; IdName: Alfa; begin RestoreSpelling(Domain^.Name); TypeFound := false; SearchScopes(BlockLevel - 1, 0, EntryFound); if EntryFound <> nil then TypeFound := EntryFound^.Klass = Types; with Domain^ do begin Klass := Types; if TypeFound then IdType := EntryFound^.IdType else SemanticError(101) end; CopySpelling(IdName); Domain^.Name := IdName end { binddomain }; procedure SearchDomain(var Entry: IdEntry); visible; begin SearchScopes(ScopeLevel, 0, Entry); if Entry <> nil then begin if LevelFound < BlockLevel then begin if Entry^.Klass = Types then begin if Entry^.LastUse < Display[BlockLevel].ScopeNo then Entry := nil end else Entry := nil end; if Entry <> nil then Entry^.LastUse := Display[ScopeLevel].ScopeNo end end { searchdomain }; procedure NewId (var Entry: IdEntry; ClassNeeded: IdClass); visible; var NewEntry, LastEntry: IdEntry; DefiningLevel: DispRange; begin { newid } if (ClassNeeded = Field) or (Display[ScopeLevel].Scope = FormalBlock) then DefiningLevel := ScopeLevel else DefiningLevel := BlockLevel; SearchScopes(ScopeLevel, 0, LastEntry); if LastEntry <> nil then if (LevelFound <= DefiningLevel) and (LastEntry^.LastUse >= Display[DefiningLevel].ScopeNo) then SemanticError(102); CreateId(NewEntry, ClassNeeded); if ClassNeeded = Consts then NewEntry^.LastUse := Display[BlockLevel].ScopeNo; EnterId(NewEntry, Display[DefiningLevel].Locals); Entry := NewEntry end { newid }; procedure SearchId (AllowableClasses: SetOfIdClass; var Entry: IdEntry); visible; var EntryFound: IdEntry; Suitable: Boolean; function MostLikelyOf(Classes: SetOfIdClass): IdClass; var LClass: IdClass; begin LClass := FirstChoice; while not (LClass in Classes) do if LClass = Prog then LClass := Types else LClass := succ(LClass); MostLikelyOf := LClass end { mostlikeyof }; begin { searchid } SearchScopes(ScopeLevel, 0, EntryFound); if EntryFound = nil then begin SemanticError(101); CreateId(EntryFound, MostLikelyOf(AllowableClasses)); EnterId(EntryFound, Display[BlockLevel].Locals); LevelFound := BlockLevel end else begin repeat Suitable := (EntryFound^.Klass in AllowableClasses); if not Suitable then SeekLocalId(EntryFound^.LeftLink, EntryFound) until Suitable or (EntryFound = nil); if Suitable then begin if EntryFound^.Klass = Domain then BindDomain(EntryFound); EntryFound^.LastUse := Display[ScopeLevel].ScopeNo end else begin SemanticError(103); CreateId(EntryFound, MostLikelyOf(AllowableClasses)); EnterId(EntryFound, Display[LevelFound].Locals) end end; EntryFound^.Referenced := true; Entry := EntryFound end { searchid }; procedure SetClass(Class: IdClass); visible; begin FirstChoice := Class end; { 10.5 The type sub-tables. All types defined or declared within the program are represented by type entries whose form is determined by the form of the type so represented (i.e. scalars, arrays, etc.). These entries are constructed using a corresponding variant record type TypeRecord. These type entries are accessed only via the identifier table entries for type identifiers, or via the representation of the data objects (variables, constants, functions, expressions) whose type they describe. Thus for example all identifier table entries have a common field IdType which points to an underlying type entry (with an obvious interpretation for all classes of identif- ier other than 'proc'). To enable storage control, the type entries associated with any scope are connected in a linear chain through the pointer field next. New type entries for the current block scope are created via the procedure NewType. } procedure NewType(var Entry: TypEntry; FormNeeded: TypeForm); visible; var NewEntry: TypEntry; procedure ChainAt(Level: DispRange); begin with Display[Level] do begin NewEntry^.Next := TypeChain; TypeChain := NewEntry end end { chainat }; begin { newtype } case FormNeeded of Scalars : new(NewEntry, Scalars); Subranges : new(NewEntry, Subranges); Pointers : new(NewEntry, Pointers); Sets : new(NewEntry, Sets); Arrays : new(NewEntry, Arrays); CAPSchema : new(NewEntry, CAPSchema); Records : new(NewEntry, Records); Files : new(NewEntry, Files); VariantPart : new(NewEntry, VariantPart); Variant : new(NewEntry, Variant) end; with NewEntry^ do begin Form := FormNeeded; Occupying := nil; Representation := DefaultRepresentation; case FormNeeded of Scalars : begin ScalarKind := Declared; FirstConst := nil end; Subranges : begin RangeType := Unknown; Min := ZeroValue; Max := OneValue end; Pointers : DomainType := Unknown; Sets : begin FormOfset := Unpacked; BaseType := Unknown end; Arrays : begin AelType := Unknown; InxType := Unknown; PackedArray := false; StringConstant := false end; CAPSchema : begin PackedSchema := false; ValueSchema := false; FirstIndex := false; Bounded := true; CompType := Unknown; InxSpec := Unknown; LowBound.Fixed := false; LowBound.Address := DftAddress; HighBound.Fixed := false; HighBound.Address := DftAddress end; Records : begin FileFree := true; PackedRecord := false; FieldScope := nil; FixedPart := nil; VarPart := nil end; Files : begin PackedFile := false; TextFile := false; FelType := Unknown end; VariantPart : begin TagType := Unknown; VntFileFree := true; TagField := nil; SelectorField := nil; FirstVariant := nil; DefaultVariant := nil end; Variant : begin VarFileFree := true; SubFixedPart := nil; NextVariant := nil; SubVarPart := nil; VariantValue1 := DftValue; VariantValue2 := DftValue end end end; if FormNeeded = CAPSchema then ChainAt(BlockLevel - 1) else ChainAt(BlockLevel); TSerialise(NewEntry); Entry := NewEntry end { newtype }; { 10.6 The label sub-tables. These are linear lists of entries, one for each label declared in that block scope, each entry being of the record type LabelRecord. The validity of each label at its declaration, siting, and use (by a goto statement) is checked by the procedures NewLabel, DefineLa- bel and CheckLabel . To enforce the label accessibility rules, however, the analyser must also keep track of the depth of state- ment nesting by calling the procedures OpenLabelDepth and CloseLa- belDepth. Through these the current depth of statement nesting is maintained as the variable Depth. When a new depth of nesting is 'opened', Depth is merely incremented by 1. When that depth is closed however, the accessibility of all labels referenced or sited at that level must be reviewed. Specifically, an accessible label sited at that depth becomes inaccessible, and an unsited label referenced at that depth, may only be sited at a lesser depth thereafter. Finally, a transfer of control from an inner- block to an enclosing outer-block requires that the label site is at textual depth 1 of the outer block. The label handling procedures report with the following error codes:- } procedure SeekLabel(FirstLabel: LabelEntry; var Entry: LabelEntry); visible; var Found: Boolean; begin Found := false; Entry := FirstLabel; while (Entry <> nil) and (not Found) do if SameValue(Entry^.LabelValue, Constant.Velue) then Found := true else Entry := Entry^.NextLabel end { searchlabel }; procedure CreateLabel(var Entry: LabelEntry); visible; begin with Display[BlockLevel] do begin new(Entry); with Entry^ do begin LabelValue := Constant.Velue; NextLabel := LabelChain; FutureStatementLabel(LabelledCode); Defined := false; Declaration := StartOfSymbol; MaxDepth := maxint end; LabelChain := Entry end end { createlabel }; procedure NewLabel; visible; var LocalLabel: LabelEntry; begin SeekLabel(Display[BlockLevel].LabelChain, LocalLabel); if LocalLabel <> nil then SemanticError(132) else CreateLabel(LocalLabel) end { newlabel }; procedure SearchAllLabels(var Entry: LabelEntry); visible; label 1; var Level: DispRange; LabelFound: LabelEntry; begin Level := BlockLevel; repeat SeekLabel(Display[Level].LabelChain, LabelFound); if LabelFound <> nil then begin LevelFound := Level; goto 1 end; Level := Level - 1 until Level = 0; { label not found: report an error and create a substitute } SemanticError(130); CreateLabel(LabelFound); LevelFound := BlockLevel; 1 : Entry := LabelFound end { searchalllabels }; procedure InitLabelDepth; visible; begin Depth := 1 end ; procedure OpenLabelDepth; visible; begin Depth := Depth + 1 end; procedure DefineLabel; visible; var Entry: LabelEntry; begin SearchAllLabels(Entry); if LevelFound <> BlockLevel then begin SemanticError(133); CreateLabel(Entry) end; with Entry^ do if Defined then SemanticError(134) else begin if Depth > MaxDepth then SemanticError(135); NextIsStatementLabel(LabelledCode); Defined := true; Accessible := true; DefinedDepth := Depth end end { definelabel }; procedure CheckLabel(var Entry: LabelEntry); visible; begin SearchAllLabels(Entry); with Entry^ do begin if LevelFound <> BlockLevel then MaxDepth := 1 else if Defined then begin if not Accessible then SemanticError(136) end else if MaxDepth > Depth then MaxDepth := Depth end end { checklabel }; procedure CloseLabelDepth; visible; var ThisLabel: LabelEntry; begin ThisLabel := Display[BlockLevel].LabelChain; while ThisLabel <> nil do begin with ThisLabel^ do if Defined then begin if Accessible then Accessible := (DefinedDepth < Depth) end else if MaxDepth = Depth then MaxDepth := Depth - 1; ThisLabel := ThisLabel^.NextLabel end; Depth := Depth - 1 end { closelabeldepth }; { 10.7 Storage recovery at scope closure. On completing analysis of a block, a one-pass compiler can discard and subsequently re-use the storage occupied by all table entries created for that block. The procedure DisposeScope carries out this disposal process. Certain semantic errors, such as unsatisfied label declarations or forward declarations are detected during storage disposal. } procedure CheckScope(BlockId: IdEntry); visible; function Designated(Id: IdEntry): Boolean; begin with Id^ do case Klass of Domain, Types, Consts: Designated := false; PresetVars, ReadOnlyVars, Vars: Designated := VarKind in [ExternalVar, VisibleVar]; Field, Bound: Designated := false; Proc, Func: Designated := BlockKind in [ExternalBlock, VisibleBlock]; Prog: Designated := false end end { Designated }; procedure CheckIds(Id: IdEntry); begin if Id <> nil then with Id^ do begin CheckIds(LeftLink); if not Referenced and (Name.Head <> 'INPUT ') and (Name.Head <> 'OUTPUT ') and not Designated(Id) and (Warnings in Requested) then ReportId(Id, BlockId); if Map in Requested then MapId(Id); CheckIds(RightLink) end end { CheckIds }; procedure CheckFields( ThisType: TypEntry); begin while ThisType <> nil do with ThisType^ do begin if Form = Records then CheckIds(FieldScope); ThisType := Next end end { CheckFields }; begin if (Warnings in Requested) or (Map in Requested) then with Display[ScopeLevel] do if Scope = ActualBlock then begin CheckFields(TypeChain); CheckIds(Locals) end end { CheckScope }; procedure DisposeScope; visible; procedure DisposeFormals(NextFormal: FormalEntry); var ThisFormal: FormalEntry; begin while NextFormal <> nil do begin ThisFormal := NextFormal; with ThisFormal^ do begin if Parm in [ProcParm, FuncParm] then DisposeFormals(ItsFormals); NextFormal := Next end; dispose(ThisFormal) end end { disposeformals }; procedure DisposeIds(Root: IdEntry); begin if Root <> nil then begin with Root^ do begin DisposeIds(LeftLink); DisposeIds(RightLink); if Name.Tail <> nil then DispAlfa(Name) end; case Root^.Klass of Types : dispose(Root, Types); Consts : dispose(Root, Consts); PresetVars : dispose(Root, PresetVars); ReadOnlyVars : dispose(Root, ReadOnlyVars); Vars : dispose(Root, Vars); Field : dispose(Root, Field); Bound : dispose(Root, Bound); Proc, Func : begin with Root^ do if PfKind = Actual then begin if Forwrd then Error(151, Declaration); DisposeFormals(Formals) end; dispose(Root, Proc) end end end end { disposeids }; procedure DisposeTypes(FirstType: TypEntry); var ThisType, NextType: TypEntry; begin NextType := FirstType; while NextType <> nil do begin ThisType := NextType; NextType := ThisType^.Next; case ThisType^.Form of Scalars : dispose(ThisType, Scalars); Subranges : dispose(ThisType, Subranges); Pointers : dispose(ThisType, Pointers); Sets : dispose(ThisType, Sets); Arrays : dispose(ThisType, Arrays); CAPSchema : dispose(ThisType, CAPSchema); Records : begin with ThisType^ do DisposeIds(FieldScope); dispose(ThisType, Records) end; Files : dispose(ThisType, Files); VariantPart : begin with ThisType^ do if SelectorField <> TagField then dispose(SelectorField, Field); dispose(ThisType, VariantPart) end; Variant : dispose(ThisType, Variant) end end end { disposetypes }; procedure DisposeLabels(FirstLabel: LabelEntry); var NextLabel, ThisLabel: LabelEntry; begin NextLabel := FirstLabel; while NextLabel <> nil do begin ThisLabel := NextLabel; if not ThisLabel^.Defined then Error(131, ThisLabel^.Declaration); NextLabel := ThisLabel^.NextLabel; dispose(ThisLabel) end end { disposelabels }; begin { DisposeScope } with Display[ScopeLevel] do begin DsposeSet(Threatened); DisposeIds(Locals); DisposeTypes(TypeChain); DisposeLabels(LabelChain) end end { DisposeScope }; { 10.8 Standard table entries. Predefined identifiers and types supported by Pascal are held within the semantic table as a scope for a pseudo-block enclosing the main program (at display level 0). These entries are created by the procedure InitSemanticTables. The type entries representing the standard types supported by the language ( integer, real, boolean, char and text ) are directly accessible via global pointer variables IntType, RealType, BooleanType, CharType, and TextType as well as via the identifier entries for 'integer', 'real', 'boolean', 'char', and 'text'. } procedure InitSemanticTables; visible; procedure StdTypEntries; var Entry: TypEntry; begin { stdtypentries } new(Unknown, Scalars, Declared); with Unknown^ do begin Representation := DefaultRepresentation; Form := Scalars; ScalarKind := Declared; FirstConst := nil end; new(IntType, Scalars, Predefined); with IntType^ do begin Representation := IntegerRepresentation; Form := Scalars; ScalarKind := Predefined end; new(RealType, Scalars, Predefined); with RealType^ do begin Representation := RealRepresentation; Form := Scalars; ScalarKind := Predefined end; new(CharType, Scalars, Predefined); with CharType^ do begin Representation := CharRepresentation; Form := Scalars; ScalarKind := Predefined end; new(BoolType, Scalars, Declared); with BoolType^ do begin Representation := BooleanRepresentation; Form := Scalars; ScalarKind := Declared end; new(NilType, Pointers); with NilType^ do begin Representation := PtrRepresentation; Form := Pointers; DomainType := Unknown end; new(EmptyType, Sets); with EmptyType^ do begin Form := Sets; FormOfset := Constructed; BaseType := Unknown; Representation := EmptyRepresentation end; new(TextType, Files); with TextType^ do begin Representation := DefaultRepresentation; Form := Files; PackedFile := false; TextFile := true; FelType := CharType end; SetRepresentationFor(TextType); new(NaturalType, Subranges); with NaturalType^ do begin Representation := DefaultRepresentation; Form := Subranges; RangeType := IntType; Min := ZeroValue; Max := MaxintValue end; SetRepresentationFor(NaturalType); new(WordType, Scalars, Predefined); with WordType^ do begin Representation := WordRepresentation; Form := Scalars; ScalarKind := Predefined end; PtrType := NilType end { stdtypentries }; procedure StdIdEntries; var Entry, TrueEntry: IdEntry; procedure EnterProcFunc(PfName: AlfaHead; PfClass: IdClass; Index: StdProcFuncs); var Entry: IdEntry; begin MakeSpelling(PfName); NewId(Entry, PfClass); with Entry^ do begin Klass := PfClass; PfDecKind := Predefined; PfIndex := Index end; FutureBlockLabel(Entry) end { enterprocfunc }; begin { stdidentries } { standard type identifiers } MakeSpelling('INTEGER '); NewId(Entry, Types); Entry^.IdType := IntType; MakeSpelling('REAL '); NewId(Entry, Types); Entry^.IdType := RealType; MakeSpelling('CHAR '); NewId(Entry, Types); Entry^.IdType := CharType; MakeSpelling('BOOLEAN '); NewId(Entry, Types); Entry^.IdType := BoolType; MakeSpelling('TEXT '); NewId(Entry, Types); Entry^.IdType := TextType; { standard constant identifiers } MakeSpelling('MAXINT '); NewId(Entry, Consts); with Entry^ do begin IdType := IntType; Values := MaxintValue end; MakeSpelling('NIL '); NewId(Entry, Consts); with Entry^ do begin IdType := NilType; Values := NilValue end; MakeSpelling('TRUE '); NewId(Entry, Consts); with Entry^ do begin IdType := BoolType; Values := TrueValue; SuccId := nil end; TrueEntry := Entry; MakeSpelling('FALSE '); NewId(Entry, Consts); with Entry^ do begin IdType := BoolType; Values := FalseValue; SuccId := TrueEntry end; BoolType^.FirstConst := Entry; new(DummyVarId, Vars); with DummyVarId^ do begin Klass := Vars; IdType := Unknown; VarKind := LocalVar; VarAddress := DftAddress end; if ICLPascal then begin MakeSpelling('WORD '); NewId(Entry, Types); Entry^.IdType := WordType; MakeSpelling('MAXWORD '); NewId(Entry, Consts); with Entry^ do begin IdType := WordType; Values := MaxWordValue end; MakeSpelling('MAXCHAR '); NewId(Entry, Consts); with Entry^ do begin IdType := CharType; Values := MaxCharValue end; MakeSpelling('MINCHAR '); NewId(Entry, Consts); with Entry^ do begin IdType := CharType; Values := MinCharValue end; MakeSpelling('MAXSET '); NewId(Entry, Consts); with Entry^ do begin IdType := IntType; Values := MaxCharValue end; MakeSpelling('MAXREAL '); NewId(Entry, Consts); with Entry^ do begin IdType := RealType; Values := MaxRealValue end; MakeSpelling('PERQ '); CopySpelling(SystemSpelling); MakeSpelling('stdin '); CopySpelling(InputSpelling); MakeSpelling('stdout '); CopySpelling(OutputSpelling) end; { standard procedure identifiers } EnterProcFunc('PUT ', Proc, Putp); EnterProcFunc('GET ', Proc, Getp); EnterProcFunc('RESET ', Proc, Resetp); EnterProcFunc('REWRITE ', Proc, Rewritep); EnterProcFunc('NEW ', Proc, Newp); EnterProcFunc('DISPOSE ', Proc, Disposep); EnterProcFunc('PACK ', Proc, Packp); EnterProcFunc('UNPACK ', Proc, Unpackp); EnterProcFunc('READ ', Proc, Readp); EnterProcFunc('READLN ', Proc, Readlnp); EnterProcFunc('WRITE ', Proc, Writep); EnterProcFunc('WRITELN ', Proc, Writelnp); EnterProcFunc('PAGE ', Proc, Pagep); { standard function identifiers } EnterProcFunc('ABS ', Func, Absf); EnterProcFunc('SQR ', Func, Sqrf); EnterProcFunc('SIN ', Func, Sinf); EnterProcFunc('COS ', Func, Cosf); EnterProcFunc('EXP ', Func, Expf); EnterProcFunc('LN ', Func, Lnf); EnterProcFunc('SQRT ', Func, Sqrtf); EnterProcFunc('ARCTAN ', Func, Arctanf); EnterProcFunc('TRUNC ', Func, Truncf); EnterProcFunc('ROUND ', Func, Roundf); EnterProcFunc('ORD ', Func, Ordf); EnterProcFunc('CHR ', Func, Chrf); EnterProcFunc('SUCC ', Func, Succf); EnterProcFunc('PRED ', Func, Predf); EnterProcFunc('ODD ', Func, Oddf); EnterProcFunc('EOF ', Func, Eoff); EnterProcFunc('EOLN ', Func, Eolnf); if ICLPascal then begin { ICL procedures } EnterProcFunc('APPEND ', Proc, Appendp); EnterProcFunc('LINES ', Proc, Linesp); EnterProcFunc('CLOSE ', Proc, Closep); EnterProcFunc('DATE ', Proc, Datep); EnterProcFunc('TIME ', Proc, Timep); { ICL functions } EnterProcFunc('WRD ', Func, Wrdf); EnterProcFunc('INT ', Func, Intf); EnterProcFunc('MINVAL ', Func, MinValf); EnterProcFunc('MAXVAL ', Func, MaxValf); EnterProcFunc('SIZEOF ', Func, Sizef); EnterProcFunc('PTR ', Func, Ptrf); EnterProcFunc('WPTR ', Func, Ptrf); EnterProcFunc('CPTR ', Func, CPtrf); EnterProcFunc('ANDW ', Func, AndWf); EnterProcFunc('ORW ', Func, OrWf); EnterProcFunc('NEQW ', Func, NeqWf); EnterProcFunc('NOTW ', Func, NotWf); EnterProcFunc('SHW ', Func, ShWf); EnterProcFunc('ROTW ', Func, RotWf); end end { stdidentries }; begin { initsemantictables } InitScope; StdTypEntries; StdIdEntries; FileStdTypes end { initsemantictables }; { 10.9 Type Analysis. Much of the semantic analysis required by Pascal involves the examination and comparison of types as represented by the corresponding type entry records. The following procedures enable this analysis to be easily expressed within the analyser proper. In all situations where the type of a data object is not deter- mined, it is represented by a pointer value 'unknown', which points to a suitable default type record. The type checking pro- cedures take special action on encountering this value, so that normal type analysis can be expressed within the analyser without preliminary screening for indeterminate types at every point at which they might arise. } procedure StringType(var StringEntry: TypEntry); visible; { This procedure generates a suitable type entry } { for the string currently described by the } { global variable constant. } var IndexType, ArrayType: TypEntry; Length: ValueDetails; begin { stringtype } NewType(IndexType, Subranges); with IndexType^ do begin RangeType := IntType; Length.Kind := OrdValue; Length.IVal := Constant.Length; Evaluate(Length); Min := OneValue; Max := Length.Velue end; SetRepresentationFor(IndexType); NewType(ArrayType, Arrays); with ArrayType^ do begin AelType := CharType; InxType := IndexType; PackedArray := true; StringConstant := true end; SetRepresentationFor(ArrayType); StringEntry := ArrayType end { stringtype }; function String(TheType: TypEntry): Boolean; visible; { This function decides if a type is a string type. } begin { string } String := false; if TheType <> Unknown then with TheType^ do if Form = Arrays then if StringConstant then String := true else if PackedArray and (AelType = CharType) and (InxType <> Unknown) then if InxType^.Form = Subranges then if InxType^.RangeType = IntType then String := SameValue(InxType^.Min, OneValue) and OrderedValues(OneValue, InxType^.Max) end { string }; function CAPString(TheType: TypEntry): Boolean; visible; { This function decides if a type is a conformant } { string type. } begin CAPString := false; if TheType <> Unknown then with TheType^ do if Form = CAPSchema then if PackedSchema and (CompType = CharType) and (InxSpec <> Unknown) then if Bounded then if not HighBound.Fixed then if LowBound.Fixed then CAPString := SameValue(LowBound.Value, OneValue) end { CAPString }; function StringFound: Boolean; visible; { This function decides if the current symbol has } { a string type. } var IdFound: IdEntry; begin StringFound := false; if Symbol = StringConst then StringFound := true else if Symbol = Ident then begin SearchGlobals(Consts, IdFound); if IdFound <> nil then StringFound := String(IdFound^.IdType) end end { StringFound }; function Identical (Type1, Type2: TypEntry): Boolean; visible; { This function decides if two types are identical. } begin Identical := (Type1 = Type2) or (Type1 = Unknown) or (Type2 = Unknown) end { identical }; function Compatible (Type1, Type2: TypEntry): Boolean; visible; { This function decides whether types pointed at by } { type1 and type2 are compatible. } begin { compatible } if Type1 = Type2 then Compatible := true else if (Type1 = Unknown) or (Type2 = Unknown) then Compatible := true else if Type1^.Form = Subranges then Compatible := Compatible(Type1^.RangeType, Type2) else if Type2^.Form = Subranges then Compatible := Compatible(Type1, Type2^.RangeType) else if String(Type1) and String(Type2) then Compatible := SameValue(Type1^.InxType^.Max, Type2^.InxType^.Max) else if (Type1^.Form = Sets) and (Type2^.Form = Sets) then Compatible := Compatible(Type1^.BaseType, Type2^.BaseType) and ((Type1^.FormOfset = Constructed) or (Type2^.FormOfset = Constructed) or (Type1^.FormOfset = Type2^.FormOfset)) else if (Type1^.Form = Pointers) and (Type2^.Form = Pointers) then Compatible := (Type1 = NilType) or (Type2 = NilType) else Compatible := false end { compatible }; function Ordinal (TheType: TypEntry): Boolean; visible; { The function result is true if thetype is an ordinal type. } begin Ordinal := (TheType^.Form <= Subranges) and (TheType <> RealType) end { ordinal }; function EmbeddedFile (TheType: TypEntry): Boolean; visible; { This function checks the given typentry for an } { embedded component-file. } begin with TheType^ do case Form of Scalars, Subranges, Pointers, Sets, VariantPart : EmbeddedFile := false; Arrays : EmbeddedFile := EmbeddedFile(AelType); CAPSchema : EmbeddedFile := EmbeddedFile(CompType); Records : EmbeddedFile := not FileFree; Variant : EmbeddedFile := not VarFileFree; Files : EmbeddedFile := true end end { embeddedfile }; procedure EnsureOrdinal (var TheType: TypEntry); visible; { This procedure checks that a type is ordinal, } { reports an error if it is not, and returns a } { suitable substitute type pointer in this case. } begin if not Ordinal(TheType) then begin SemanticError(110); TheType := Unknown end end { ensureordinal }; procedure EnsureFormIs(FormRequired: TypeForm; var TheType: TypEntry); visible; { This procedure checks that a type has the specified form } { reports an error if it has not, and returns a suitable } { substitute type pointer in this case. } begin if TheType^.Form <> FormRequired then begin if TheType <> Unknown then SemanticError(110 + ord(FormRequired)); NewType(TheType, FormRequired) end end { ensureformis }; procedure EnsureEnumerated (var TheType: TypEntry); visible; { This procedure checks that a type is an enumeration, } { reports an error if it is not, and returns a suitable } { substitute type pointer in this case. } begin EnsureFormIs(Scalars, TheType); if TheType^.ScalarKind <> Declared then begin SemanticError(111); TheType := Unknown end end { EnsureEnumerated }; function Derived(TheType: TypEntry): Boolean; { This function decided whether the type has been derived } { from an unbounded conformant array schema. } begin if TheType^.Form <> CAPSchema then Derived := false else Derived := not TheType^.Bounded end { Derived }; procedure DomainCheck (TheType: TypEntry); visible; { Check the evaluated expression lies within } { closed interval specified by the thetype. } begin if TheType^.Form = Subranges then RangeCheck(TheType^.Min, TheType^.Max, 49) else if TheType^.Form = Sets then if TheType^.BaseType <> Unknown then if TheType^.BaseType^.Form = Subranges then SetCheck(TheType^.BaseType^.Min, TheType^.BaseType^.Max) end { domaincheck }; procedure CheckAssignment (Type1, Type2: TypEntry); visible; { This procedure checks that an expression of type type2 } { is assignment compatible with a type type1, generating } { code to check at runtime, and adjusting the expression } { if necessary. } begin { checkassignment } if Compatible(Type1, Type2) then begin if EmbeddedFile(Type1) or EmbeddedFile(Type2) then SemanticError(150) else if Derived(Type1) or Derived(Type2) then SemanticError(155) else DomainCheck(Type1) end else if (Type1 = RealType) and Compatible(Type2, IntType) then FloatInteger(TopOfStack) else SemanticError(152) end { checkassignment }; procedure Threaten (v: IdEntry); visible; { Unstructured local variables require additional semantic } { analysis to protect for-statement control variables from } { assignment by nested local procedures and re-use by } { nested for-statements. } begin if (v^.VarKind = LocalVar) and Ordinal(v^.IdType) then if LevelFound = BlockLevel then begin if InSet(ControlVars, v) then begin SemanticError(153); Exclude(ControlVars, v) end end else Include(Display[LevelFound].Threatened, v) end { threaten }; procedure GetBounds (OrdinalType: TypEntry; var Lower, Upper: ObjectValue); visible; var LastId, NextId: IdEntry; begin with OrdinalType^ do if Form = Subranges then begin Lower := Min; Upper := Max end else if OrdinalType = CharType then begin Lower := MinCharValue; Upper := MaxCharValue end else if OrdinalType = IntType then begin Lower := MaxintValue; Upper := MaxintValue; NegateValue(Lower) end else if OrdinalType = WordType then begin Lower := ZeroValue; Upper := MaxWordValue end else begin Lower := ZeroValue; NextId := FirstConst; LastId := nil; while NextId <> nil do begin LastId := NextId; NextId := NextId^.SuccId end; if LastId <> nil then Upper := LastId^.Values else Upper := OneValue end end { getbounds }; function IsConformant (TheType: TypEntry): Boolean; visible; { This function decides if the typentry describes } { a conformant array parameter schema. } begin if TheType = nil then IsConformant := false else IsConformant := (TheType^.Form = CAPSchema) end { conformant }; function ElementOf (Structure: TypEntry): TypEntry; visible; begin with Structure^ do if Form = Arrays then ElementOf := AelType else ElementOf := CompType end { elementof }; function IndexOf (Structure: TypEntry): TypEntry; visible; begin with Structure^ do if Form = Arrays then IndexOf := InxType else IndexOf := InxSpec end { indexof }; function PackingOf (Structure: TypEntry): Boolean; visible; begin with Structure^ do if Form = Arrays then PackingOf := PackedArray else PackingOf := PackedSchema end { packingof }; function MultiLevel (Structure: TypEntry): Boolean; visible; var Component: TypEntry; begin Component := ElementOf(Structure); MultiLevel := (Component^.Form = Structure^.Form) end { multilevel }; function LastLevelOf (Structure: TypEntry): TypEntry; visible; begin while MultiLevel(Structure) do Structure := ElementOf(Structure); LastLevelOf := Structure end { lastlevelof }; procedure WithSchema(Schema: TypEntry; procedure Action(Packing, InnerMost: Boolean; LowBound, HighBound: CAPBound; ElemRep: TypeRepresentation)); visible; var Element: TypEntry; LastLevel: Boolean; begin Element := ElementOf(LastLevelOf(Schema)); LastLevel := not MultiLevel(Schema); with Schema^ do Action (PackedSchema, LastLevel, LowBound, HighBound, Element^.Representation) end { withschema }; function TaggedVarPart (ThisVarPart: TypEntry; TagId: IdEntry): TypEntry; visible; { Return the variant-part type-descriptor containing the } { tag-field denoted by tagid. } var WhichTagId: TypEntry; function TaggedSubPart(Variant: TypEntry): TypEntry; var SubPart: TypEntry; begin repeat SubPart := TaggedVarPart(Variant^.SubVarPart, TagId); Variant := Variant^.NextVariant until (SubPart <> nil) or (Variant = nil); TaggedSubPart := SubPart end { taggedsubpart }; begin if ThisVarPart = nil then WhichTagId := nil else begin with ThisVarPart^ do begin if (TagField = TagId) then WhichTagId := ThisVarPart else WhichTagId := TaggedSubPart(FirstVariant); if (WhichTagId = nil) and (DefaultVariant <> nil) then WhichTagId := TaggedSubPart(DefaultVariant) end end; TaggedVarPart := WhichTagId end { taggedvarpart }; function VariantField (VariantPart: TypEntry; FieldId: IdEntry): Boolean; visible; { Returns the value 'true' if fieldid denotes a field of } { the variant-part of a record described by varpart. } begin VariantField := FieldId^.Serial > VariantPart^.Serial end; procedure SeekByValue (VariantPart: TypEntry; var Variant: TypEntry; TheValue: ObjectValue); visible; { This procedure selects a variant from the given variant- } { part according to its corresponding label value or range } var Found: Boolean; begin with VariantPart^ do begin Found := false; Variant := FirstVariant; while (Variant <> nil) and (not Found) do with Variant^ do if InRange(VariantValue1, TheValue, VariantValue2) then Found := true else Variant := NextVariant; if not Found then Variant := DefaultVariant end; end { SeekByValue }; procedure SelectLocal (VariantPart: TypEntry; var Variant: TypEntry; Field: IdEntry); visible; { This procedure selects a local variant from the fixed-part } { of the variant-part. If no variant embracing the nominated } { field can be found, the default variant is returned instead } var Found: Boolean; begin with VariantPart^ do begin Found := false; Variant := FirstVariant; while (Variant <> nil) and (not Found) do if VariantField(Variant, Field) then Found := true else Variant := Variant^.NextVariant; if not Found then Variant := DefaultVariant end end { SelectLocal }; procedure SeekByName (var VariantPart, Variant: TypEntry; Field: Identry); visible; { This procedure returns a pointer to the variant-part } { that contains the declaration of the field-identifier. } { If no variant-part can be found, the value nil is } { returned. } begin SelectLocal(VariantPart, Variant, Field); if Variant <> nil then with Variant^ do if SubVarPart <> nil then if VariantField(SubVarPart, Field) then begin VariantPart := SubVarPart; SeekByName(VariantPart, Variant, Field) end end { SeekByName }; function Congruent (Formals1, Formals2: FormalEntry): Boolean; visible; { This procedure decides if the formal-parameter lists } { referenced by formals1 and formals2 are congruent. } var StillCongruent: Boolean; function EquivalentCAPSchemas(Type1, Type2: TypEntry): Boolean; var Comp1, Comp2: TypEntry; function EquivalentBounds(Type1, Type2: TypEntry): Boolean; begin if Type1^.Bounded and Type2^.Bounded then begin if not Type1^.LowBound.Fixed and not Type1^.HighBound.Fixed and not Type2^.LowBound.Fixed and not Type2^.HighBound.Fixed then EquivalentBounds := true else if Type1^.LowBound.Fixed and Type2^.LowBound.Fixed and SameValue (Type1^.LowBound.Value, Type2^.LowBound.Value) and not Type1^.HighBound.Fixed and not Type2^.HighBound.Fixed then EquivalentBounds := true else if Type1^.HighBound.Fixed and Type2^.HighBound.Fixed and SameValue (Type1^.HighBound.Value, Type2^.HighBound.Value) and not Type1^.LowBound.Fixed and not Type2^.LowBound.Fixed then EquivalentBounds := true else EquivalentBounds := false end else EquivalentBounds := not Type1^.Bounded and not Type2^.Bounded end { EquivalentBounds }; begin if (Type1 = Unknown) or (Type2 = Unknown) then EquivalentCAPSchemas := true else if IsConformant(Type1) and IsConformant(Type2) then begin Comp1 := Type1^.CompType; Comp2 := Type2^.CompType; EquivalentCAPSchemas := Identical(IndexOf(Type1), IndexOf(Type2)) and EquivalentBounds(Type1, Type2) and (PackingOf(Type1) = PackingOf(Type2)) and ((Comp1 = Comp2) or EquivalentCAPSchemas(Comp1, Comp2)) end else EquivalentCAPSchemas := false end { equivalentcapschemas }; begin StillCongruent := true; while StillCongruent and (Formals1 <> nil) and (Formals2 <> nil) do begin if (Formals1^.Parm = Formals2^.Parm) and (Formals1^.Section = Formals2^.Section) then case Formals1^.Parm of ReadOnlyParm, ValueParm, VarParm : StillCongruent := Identical(Formals1^.FormalType, Formals2^.FormalType) or EquivalentCAPSchemas (Formals1^.FormalType, Formals2^.FormalType); ProcParm : StillCongruent := Congruent(Formals1^.ItsFormals, Formals2^.ItsFormals); FuncParm : StillCongruent := Congruent(Formals1^.ItsFormals, Formals2^.ItsFormals) and Identical(Formals1^.FormalType, Formals2^.FormalType); BoundParm : end else StillCongruent := false; Formals1 := Formals1^.Next; Formals2 := Formals2^.Next end; Congruent := StillCongruent and (Formals1 = nil) and (Formals2 = nil) end { congruent }; begin { end of module } end.