{
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"
#include "ctlstructs.pf"
#include "objvalues.pf"
#include "datareps.pf"
#include "expeval.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;
if Display[ScopeLevel - 1].Scope = RecordScope
then
ReadOnlyScope := Display[ScopeLevel - 1].ReadOnlyScope
else 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;
CodeOfBody: BlockLabel;
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, Declared);
Func : new(NewEntry, Func, Declared)
end;
{ set name, klass, and default attributes }
with NewEntry^ do
begin
CopySpelling(IdName);
Name := IdName;
IdType := Unknown;
LastUse := Display[ScopeLevel].ScopeNo;
Klass := ClassNeeded;
case Klass of
Domain, 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;
FutureBlockLabel(CodeOfBody);
CodeBody := CodeOfBody;
Assignable := false;
Assigned := false;
BlockKind := LocalBlock;
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
if Classes = [Types]
then LClass := Types else LClass := Consts;
while not (LClass in Classes) do 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;
Entry := EntryFound
end { searchid };
{
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, Declared);
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;
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 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
Form := Files;
PackedFile := false;
TextFile := true;
FelType := CharType
end;
SetRepresentationFor(TextType);
WordType := Unknown;
NaturalType := Unknown;
PtrType := Unknown;
if ICLPascal
then
begin
new(NaturalType, Subranges);
with NaturalType^ do
begin
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
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
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)
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)
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; ClassNeeded: SetOfIdClass);
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. If ICLPascal, fields of a read- }
{ only record variable must not be threatened by }
{ assignment. }
begin
with v^ do
case Klass of
ReadOnlyVars :
if not (ReadOnlyVars in ClassNeeded) then SemanticError(291);
Field :
if not (ReadOnlyVars in ClassNeeded) and
Display[ScopeLevel].ReadOnlyScope
then SemanticError(285);
Vars, PresetVars :
if SimpleVar
then
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;
Func :
end
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;
NegateValue(Lower)
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: Boolean;
LowBound, HighBound:
CAPBound;
PairRep, ElemRep:
TypeRepresentation));
visible;
var Element: TypEntry;
begin
Element := ElementOf(LastLevelOf(Schema));
with Schema^ do
Action
(PackedSchema, LowBound, HighBound, Representation,
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)
then EquivalentBounds := true
else
if Type1^.HighBound.Fixed and Type2^.HighBound.Fixed and
SameValue
(Type1^.HighBound.Value, Type2^.HighBound.Value)
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.