-- file Pass3D.Mesa
-- last modified by Satterthwaite, December 20, 1979 11:08 AM
DIRECTORY
ComData: FROM "comdata"
USING [
definitionsOnly, idANY, idCARDINAL, mainCtx, moduleCtx, seAnon,
textIndex, typeINTEGER, typeSTRING],
Log: FROM "log" USING [Error, ErrorHti, ErrorSei, ErrorTree],
P3: FROM "p3"
USING [
CircuitCheck, CircuitSignal, Mark, NPUse, SequenceNP,
pathNP, phraseNP,
CheckDisjoint, ClearRefStack, CompleteRecord, Exp, FindSe, Interval,
MakeFrameRecord, PopCtx, PushCtx, RAttr, RecordLhs, RecordMention,
Rhs, RPop, RType, SealRefStack, SearchCtxList, SelectVariantType,
TopCtx, UnsealRefStack, UpdateTreeAttr, VariantUnionType],
Symbols: FROM "symbols"
USING [seType, ctxType, mdType,
SERecord,
HTIndex, SEIndex, ISEIndex, CSEIndex, RecordSEIndex, CTXIndex,
SENull, CTXNull, codeANY, codeINTEGER, lG, lZ, typeANY, typeTYPE],
SymbolOps: FROM "symbolops"
USING [
CtxEntries, EnterExtension, FindExtension, LinkMode, MakeNonCtxSe,
NormalType, TypeForm, UnderType, XferMode],
Table: FROM "table" USING [Base, Notifier],
Tree: FROM "tree" USING [Index, Link, Map, Null, NullIndex, Scan, treeType],
TreeOps: FROM "treeops"
USING [
FreeTree, GetNode, IdentityMap, ListHead, ListLength,
ScanList, TestTree, UpdateList];
Pass3D: PROGRAM
IMPORTS
Log, P3, SymbolOps, TreeOps,
dataPtr: ComData
EXPORTS P3 =
BEGIN
OPEN TreeOps, SymbolOps, Symbols, P3;
tb: Table.Base; -- tree base address (local copy)
seb: Table.Base; -- se table base address (local copy)
ctxb: Table.Base; -- context table base address (local copy)
mdb: Table.Base; -- module table base address (local copy)
DeclNotify: PUBLIC Table.Notifier =
BEGIN -- called by allocator whenever table area is repacked
tb ← base[Tree.treeType];
seb ← base[seType]; ctxb ← base[ctxType]; mdb ← base[mdType];
END;
-- signals for type loop detection
CheckTypeLoop: PUBLIC CircuitCheck = CODE;
LogTypeLoop: CircuitSignal = CODE;
-- declaration processing
DeclList: PUBLIC Tree.Scan =
BEGIN
ScanList[t, DeclItemA]; ScanList[t, DeclItemBI];
END;
DeclItemA: Tree.Scan =
BEGIN
node: Tree.Index = GetNode[t];
type: SEIndex;
saveIndex: CARDINAL = dataPtr.textIndex;
IF tb[node].attr3 = P3.Mark THEN RETURN; -- already processed
tb[node].attr3 ← P3.Mark;
dataPtr.textIndex ← tb[node].info;
tb[node].son[2] ← TypeLink[tb[node].son[2]
! CheckTypeLoop => IF loopNode=node THEN RESUME [TRUE];
LogTypeLoop => IF loopNode=node THEN RESUME];
type ← TypeForTree[tb[node].son[2]];
IF tb[node].name = typedecl
THEN DefineTypeSe[tb[node].son[1], type]
ELSE DefineSeType[tb[node].son[1], type, tb[node].attr1];
ClearRefStack[];
dataPtr.textIndex ← saveIndex;
END;
DeclItemB: Tree.Scan =
BEGIN
node: Tree.Index = GetNode[t];
type: SEIndex;
ExpInit: PROCEDURE [t: Tree.Link] RETURNS [val: Tree.Link] =
BEGIN
val ← Rhs[t, TargetType[UnderType[type]]]; RPop[];
pathNP ← SequenceNP[pathNP][phraseNP];
RETURN
END;
saveIndex: CARDINAL = dataPtr.textIndex;
IF tb[node].attr2 = P3.Mark THEN RETURN; -- already processed
tb[node].attr2 ← P3.Mark;
dataPtr.textIndex ← tb[node].info;
TypeAttr[tb[node].son[2]];
SELECT tb[node].name FROM
typedecl => NULL;
ENDCASE =>
BEGIN
type ← TypeForTree[tb[node].son[2]];
IF tb[node].son[3] # Tree.Null
THEN
BEGIN
ScanList[tb[node].son[1], RecordDeclInit];
tb[node].son[3] ← UpdateList[tb[node].son[3], ExpInit];
IF VoidItem[tb[node].son[3]] AND ~Voidable[type]
THEN Log.ErrorTree[defaultForm, ListHead[tb[node].son[1]]];
END;
DefineSeValue[tb[node].son[1], FALSE, FALSE];
END;
ClearRefStack[];
dataPtr.textIndex ← saveIndex;
END;
DeclItemBI: Tree.Scan =
BEGIN
node: Tree.Index = GetNode[t];
expNode: Tree.Index;
type: SEIndex;
eqFlag, constFlag, extFlag: BOOLEAN;
ExpInit: PROCEDURE [t: Tree.Link] RETURNS [val: Tree.Link] =
BEGIN
val ← Rhs[t, TargetType[UnderType[type]]];
constFlag ← eqFlag AND RAttr[].const; RPop[];
pathNP ← SequenceNP[pathNP][phraseNP];
RETURN
END;
saveIndex: CARDINAL = dataPtr.textIndex;
IF tb[node].attr2 = P3.Mark THEN RETURN; -- already processed
tb[node].attr2 ← P3.Mark;
dataPtr.textIndex ← tb[node].info;
TypeAttr[tb[node].son[2]]; type ← TypeForTree[tb[node].son[2]];
SELECT tb[node].name FROM
typedecl =>
BEGIN
IF tb[node].son[3] # Tree.Null
THEN
BEGIN
tb[node].son[3] ← UpdateList[tb[node].son[3], ExpInit];
IF VoidItem[tb[node].son[3]] AND ~Voidable[type]
THEN Log.ErrorTree[defaultForm, ListHead[tb[node].son[1]]];
END;
IF tb[node].son[3] # Tree.Null THEN ProcessDefaults[t, TRUE];
END;
ENDCASE =>
BEGIN
extFlag ← FALSE; eqFlag ← tb[node].attr1;
IF tb[node].son[3] = Tree.Null
THEN
BEGIN
v: Tree.Link = DefaultInit[type];
IF v # Tree.Null
THEN
BEGIN
tb[node].son[3] ← v; [] ← UpdateTreeAttr[v];
pathNP ← SequenceNP[pathNP][phraseNP];
END;
constFlag ← FALSE;
END
ELSE
BEGIN
ScanList[tb[node].son[1], RecordDeclInit];
WITH tb[node].son[3] SELECT FROM
subtree =>
BEGIN expNode ← index;
SELECT tb[expNode].name FROM
body =>
BEGIN -- defer processing of bodies (see Body)
constFlag ← FALSE;
SELECT XferMode[type] FROM
procedure, program => NULL;
ENDCASE =>
IF TypeForm[type] = definition
THEN constFlag ← TRUE
ELSE Log.Error[bodyType];
extFlag ← eqFlag AND tb[expNode].attr3; -- inline
END;
inline =>
BEGIN
IF XferMode[type] # procedure OR ~eqFlag
THEN Log.Error[inlineType];
tb[expNode].son[1] ←
UpdateList[tb[expNode].son[1], InlineOp];
constFlag ← eqFlag;
END;
apply =>
IF tb[expNode].son[1] # Tree.Null
OR UnderType[type] # dataPtr.typeSTRING
OR ListLength[tb[expNode].son[2]] # 1
THEN tb[node].son[3] ← ExpInit[tb[node].son[3]]
ELSE
BEGIN tb[expNode].name ← stringinit;
tb[expNode].info ← dataPtr.typeSTRING;
tb[expNode].son[2] ← Rhs[
tb[expNode].son[2], dataPtr.typeINTEGER];
IF ~RAttr[].const
THEN Log.ErrorTree[nonConstant, tb[expNode].son[2]];
RPop[]; constFlag ← FALSE;
pathNP ← SequenceNP[pathNP][phraseNP];
END;
signalinit => constFlag ← FALSE;
void =>
BEGIN
IF ~Voidable[type] THEN
Log.ErrorTree[defaultForm, ListHead[tb[node].son[1]]];
tb[node].son[3] ← FreeTree[tb[node].son[3]];
constFlag ← FALSE;
END;
ENDCASE => tb[node].son[3] ← ExpInit[tb[node].son[3]];
END;
ENDCASE => tb[node].son[3] ← ExpInit[tb[node].son[3]];
END;
DefineSeValue[tb[node].son[1], constFlag, extFlag];
END;
ClearRefStack[];
dataPtr.textIndex ← saveIndex;
END;
RecordDeclInit: Tree.Scan =
BEGIN
sei: ISEIndex;
WITH t SELECT FROM
symbol => BEGIN sei ← index; RecordMention[sei]; RecordLhs[sei] END;
ENDCASE => ERROR;
END;
InlineOp: Tree.Map =
BEGIN
EvalConst: Tree.Map =
BEGIN
v ← Rhs[t, dataPtr.typeINTEGER];
IF ~RAttr[].const THEN Log.ErrorTree[nonConstant, v];
RPop[]; RETURN
END;
RETURN [UpdateList[t, EvalConst]]
END;
InterfaceSe: PROCEDURE [sei: ISEIndex] RETURNS [BOOLEAN] = INLINE
BEGIN
RETURN [dataPtr.definitionsOnly AND ctxb[seb[sei].idCtx].level = lG]
END;
DefineSeType: PROCEDURE [t: Tree.Link, type: SEIndex, fixed: BOOLEAN] =
BEGIN
UpdateSe: Tree.Scan =
BEGIN
sei: ISEIndex;
WITH t SELECT FROM
symbol =>
BEGIN sei ← index;
seb[sei].idType ← type; seb[sei].constant ← FALSE;
IF InterfaceSe[sei]
THEN seb[sei].immutable ← seb[sei].immutable OR fixed
ELSE
BEGIN
IF seb[sei].immutable THEN Log.ErrorSei[attrClash, sei];
seb[sei].immutable ← fixed
END;
seb[sei].mark3 ← TRUE;
END;
ENDCASE => ERROR;
END;
ScanList[t, UpdateSe];
END;
DefineSeValue: PROCEDURE [t: Tree.Link, const, ext: BOOLEAN] =
BEGIN
UpdateSe: Tree.Scan =
BEGIN
sei: ISEIndex;
WITH t SELECT FROM
symbol =>
BEGIN sei ← index;
seb[sei].constant ← const; seb[sei].extended ← ext;
IF InterfaceSe[sei] AND LinkMode[sei] = val
THEN seb[sei].immutable ← TRUE;
END;
ENDCASE => ERROR;
END;
ScanList[t, UpdateSe];
END;
DefineTypeSe: PROCEDURE [t: Tree.Link, info: SEIndex] =
BEGIN
first: BOOLEAN ← TRUE;
UpdateSe: Tree.Scan =
BEGIN
sei: ISEIndex;
WITH t SELECT FROM
symbol =>
BEGIN sei ← index;
seb[sei].idType ← typeTYPE; seb[sei].idInfo ← info;
seb[sei].immutable ← seb[sei].constant ← TRUE;
IF first THEN BEGIN info ← sei; first ← FALSE END;
seb[sei].mark3 ← TRUE;
END;
ENDCASE => ERROR;
END;
ScanList[t, UpdateSe]; RETURN
END;
ProcessDefaults: PROCEDURE [t: Tree.Link, valid: BOOLEAN] =
BEGIN
ProcessDefault: Tree.Scan =
BEGIN
copy: BOOLEAN;
node: Tree.Index = GetNode[t];
DefineDefault: Tree.Scan =
BEGIN
WITH t SELECT FROM
symbol =>
EnterExtension[index, default,
IF copy THEN IdentityMap[tb[node].son[3]] ELSE tb[node].son[3]];
ENDCASE => ERROR;
copy ← TRUE;
END;
IF tb[node].son[3] # Tree.Null THEN
BEGIN
IF ~valid
THEN Log.ErrorTree[default, ListHead[tb[node].son[1]]];
IF TestTree[tb[node].son[3], stringinit]
THEN Log.ErrorTree[defaultForm, ListHead[tb[node].son[1]]];
copy ← FALSE;
ScanList[tb[node].son[1], DefineDefault]; tb[node].son[3] ← Tree.Null;
END;
END;
ScanList[t, ProcessDefault];
END;
-- default merging
DefaultInit: PUBLIC PROCEDURE [type: SEIndex] RETURNS [v: Tree.Link] =
BEGIN
s, next: SEIndex;
v ← Tree.Null;
FOR s ← type, next
DO
WITH seb[s] SELECT FROM
id =>
BEGIN
sei: ISEIndex = LOOPHOLE[s];
CopyNonVoid: Tree.Scan =
BEGIN
IF ~TestTree[t, void] AND v = Tree.Null THEN v ← IdentityMap[t];
END;
IF seb[sei].extended THEN
BEGIN ScanList[FindExtension[sei].tree, CopyNonVoid]; EXIT END;
next ← seb[sei].idInfo;
END;
ENDCASE => EXIT;
ENDLOOP;
RETURN
END;
VoidItem: PUBLIC PROCEDURE [t: Tree.Link] RETURNS [void: BOOLEAN] =
BEGIN
TestVoid: Tree.Scan = BEGIN IF TestTree[t, void] THEN void ← TRUE END;
void ← FALSE; ScanList[t, TestVoid]; RETURN
END;
Voidable: PUBLIC PROCEDURE [type: SEIndex] RETURNS [BOOLEAN] =
BEGIN
s, next: SEIndex;
FOR s ← type, next
DO
WITH seb[s] SELECT FROM
id =>
BEGIN
sei: ISEIndex = LOOPHOLE[s];
IF seb[sei].extended
THEN RETURN [VoidItem[FindExtension[sei].tree]];
next ← seb[sei].idInfo;
END;
ENDCASE => RETURN [TRUE];
ENDLOOP;
END;
ResolveType: PUBLIC PROCEDURE [sei: ISEIndex] =
BEGIN
currentCtx: CTXIndex = TopCtx[];
IF seb[sei].idCtx # currentCtx
THEN BEGIN PopCtx[]; ResolveType[sei]; PushCtx[currentCtx] END
ELSE
BEGIN
SealRefStack[];
DeclItemA[[subtree[index: seb[sei].idValue]]];
UnsealRefStack[];
END;
END;
ResolveValue: PUBLIC PROCEDURE [sei: ISEIndex] =
BEGIN
currentCtx: CTXIndex = TopCtx[];
IF seb[sei].idCtx # currentCtx
THEN BEGIN PopCtx[]; ResolveValue[sei]; PushCtx[currentCtx] END
ELSE
BEGIN
SealRefStack[];
IF currentCtx = CTXNull OR
(ctxb[currentCtx].level = lZ AND currentCtx # dataPtr.moduleCtx)
THEN DeclItemB[[subtree[index: seb[sei].idValue]]]
ELSE DeclItemBI[[subtree[index: seb[sei].idValue]]];
UnsealRefStack[];
END;
END;
CheckTypeId: PROCEDURE [sei: ISEIndex] RETURNS [BOOLEAN] =
BEGIN
node: Tree.Index;
IF seb[sei].mark3 THEN RETURN [seb[sei].idType = typeTYPE];
node ← seb[sei].idValue;
RETURN [node = Tree.NullIndex OR tb[node].name = typedecl]
END;
TypeSymbol: PROCEDURE [sei: ISEIndex] RETURNS [val: Tree.Link] =
BEGIN
declNode: Tree.Index;
saveIndex: CARDINAL;
entryIndex: CARDINAL = dataPtr.textIndex;
circular: BOOLEAN;
circular ← FALSE;
IF ~seb[sei].mark3
THEN
BEGIN
ENABLE
LogTypeLoop =>
BEGIN saveIndex ← dataPtr.textIndex;
dataPtr.textIndex ← entryIndex;
Log.ErrorSei[circularType, sei];
circular ← TRUE;
dataPtr.textIndex ← saveIndex;
END;
declNode ← seb[sei].idValue;
IF tb[declNode].attr3 # P3.Mark
THEN ResolveType[sei]
ELSE
IF SIGNAL CheckTypeLoop[declNode]
THEN SIGNAL LogTypeLoop[declNode];
END;
IF CheckTypeId[sei] AND ~circular
THEN val ← Tree.Link[symbol[index: sei]]
ELSE
BEGIN
IF ~circular AND sei # dataPtr.seAnon
THEN Log.ErrorSei[nonTypeId, sei];
val ← Tree.Link[symbol[index: dataPtr.idANY]];
END;
RETURN
END;
PushArgCtx: PROCEDURE [sei: RecordSEIndex] =
BEGIN
IF sei # SENull THEN PushCtx[seb[sei].fieldCtx];
END;
PopArgCtx: PROCEDURE [sei: RecordSEIndex] =
BEGIN
IF sei # SENull THEN PopCtx[];
END;
TypeExp: PUBLIC PROCEDURE [typeExp: Tree.Link] RETURNS [val: Tree.Link] =
BEGIN
val ← TypeLink[typeExp]; TypeAttr[val]; RETURN
END;
TypeForTree: PUBLIC PROCEDURE [t: Tree.Link] RETURNS [SEIndex] =
-- N.B. assumes t evaluated by TypeLink or Exp
BEGIN
RETURN [WITH t SELECT FROM
symbol => index,
subtree =>
SELECT tb[index].name FROM
cdot => TypeForTree[tb[index].son[2]],
ENDCASE => tb[index].info,
ENDCASE => typeANY]
END;
TypeLink: PROCEDURE [typeExp: Tree.Link] RETURNS [val: Tree.Link] =
BEGIN
WITH typeExp SELECT FROM
hash => val ← TypeSymbol[FindSe[index].symbol];
symbol => val ← TypeSymbol[index];
subtree =>
BEGIN
node: Tree.Index = index;
iSei: ISEIndex;
SELECT tb[node].name FROM
discrimTC =>
BEGIN OPEN tb[node];
son[1] ← TypeLink[son[1]];
iSei ← WITH son[2] SELECT FROM
hash => SelectVariantType[TypeForTree[son[1]], index],
ENDCASE => ERROR;
info ← iSei; son[2] ← Tree.Link[symbol[index: iSei]];
END;
dot =>
BEGIN OPEN tb[node];
found: BOOLEAN;
nDerefs: CARDINAL;
sei: SEIndex;
subType: CSEIndex;
ctx: CTXIndex;
son[1] ← Exp[son[1], typeANY];
WITH son[2] SELECT FROM
hash =>
BEGIN
nDerefs ← 0;
FOR subType ← RType[], UnderType[sei]
DO
WITH t: seb[subType] SELECT FROM
definition => BEGIN ctx ← t.defCtx; GO TO search END;
record => BEGIN ctx ← t.fieldCtx; GO TO search END;
pointer =>
BEGIN
IF (nDerefs ← nDerefs+1) > 255 THEN GO TO fail;
t.dereferenced ← TRUE; sei ← t.refType;
END;
long => sei ← t.rangeType;
subrange => sei ← t.rangeType;
ENDCASE => GO TO fail;
REPEAT
fail => found ← FALSE;
search => [found, iSei] ← SearchCtxList[index, ctx];
ENDLOOP;
IF ~found
THEN
BEGIN
iSei ← dataPtr.idANY; Log.ErrorHti[unknownField, index];
END;
name ← cdot; info ← iSei; son[2] ← TypeSymbol[iSei];
END;
ENDCASE => ERROR;
RPop[];
END;
frameTC =>
BEGIN OPEN tb[node];
son[1] ← Exp[son[1], typeANY]; RPop[];
info ← MakeFrameRecord[son[1]];
END;
ENDCASE =>
BEGIN OPEN tb[node];
type: CSEIndex = info;
WITH t: seb[type] SELECT FROM
enumerated => NULL;
record =>
BEGIN
PushCtx[t.fieldCtx]; ScanList[son[1], DeclItemA]; PopCtx[];
END;
pointer =>
BEGIN
son[1] ← TypeLink[son[1] ! CheckTypeLoop => RESUME [FALSE]];
t.refType ← TypeForTree[son[1]];
END;
array =>
BEGIN
IF son[1] = Tree.Null
THEN t.indexType ← dataPtr.idCARDINAL
ELSE
BEGIN
son[1] ← TypeLink[son[1]];
t.indexType ← TypeForTree[son[1]];
END;
son[2] ← TypeLink[son[2]];
t.componentType ← TypeForTree[son[2]];
END;
arraydesc =>
BEGIN
son[1] ← TypeLink[son[1] ! CheckTypeLoop => RESUME [FALSE]];
t.describedType ← TypeForTree[son[1]];
END;
transfer =>
BEGIN
ENABLE CheckTypeLoop => RESUME [FALSE];
IF t.inRecord # SENull AND t.outRecord # SENull
THEN CheckDisjoint[
seb[t.inRecord].fieldCtx, seb[t.outRecord].fieldCtx];
PushArgCtx[t.inRecord]; ScanList[son[1], DeclItemA];
PushArgCtx[t.outRecord]; ScanList[son[2], DeclItemA];
PopArgCtx[t.outRecord]; PopArgCtx[t.inRecord];
END;
definition => t.defCtx ← dataPtr.mainCtx;
union =>
BEGIN
DeclItemA[son[1]]; ScanList[son[2], DeclItemA];
END;
relative =>
BEGIN
son[1] ← TypeLink[son[1] ! CheckTypeLoop => RESUME [FALSE]];
t.baseType ← TypeForTree[son[1]];
son[2] ← TypeLink[son[2]];
t.resultType ← t.offsetType ← TypeForTree[son[2]];
END;
subrange =>
BEGIN
t.range ← LOOPHOLE[node]; -- to allow symbolic evaluation
son[1] ← TypeLink[son[1]]; t.rangeType ← TypeForTree[son[1]];
END;
long =>
BEGIN
son[1] ← TypeLink[son[1]]; t.rangeType ← TypeForTree[son[1]];
END;
ENDCASE => ERROR;
seb[type].mark3 ← TRUE;
END;
val ← typeExp;
END;
ENDCASE => ERROR;
RETURN
END;
TypeAttr: PROCEDURE [typeExp: Tree.Link] =
BEGIN
WITH typeExp SELECT FROM
symbol =>
BEGIN
sei: ISEIndex = index;
declNode: Tree.Index;
IF ~seb[sei].mark4
THEN
BEGIN
declNode ← seb[sei].idValue;
IF seb[sei].mark3 AND tb[declNode].attr2 # P3.Mark
THEN ResolveValue[sei];
END;
END;
subtree =>
BEGIN
node: Tree.Index = index;
SELECT tb[node].name FROM
discrimTC, cdot, frameTC => NULL;
ENDCASE =>
BEGIN OPEN tb[node];
type: CSEIndex = info;
subType: CSEIndex;
WITH t: seb[type] SELECT FROM
enumerated => NULL;
record =>
BEGIN
saveNP: NPUse = pathNP;
PushCtx[t.fieldCtx]; pathNP ← none;
ScanList[son[1], DeclItemB]; ProcessDefaults[son[1], TRUE];
PopCtx[]; pathNP ← saveNP;
END;
pointer => TypeAttr[son[1]];
array =>
BEGIN
IF son[1] # Tree.Null THEN TypeAttr[son[1]];
SELECT TRUE FROM
~OrderedType[t.indexType] =>
BEGIN t.indexType←typeANY; Log.Error[nonOrderedType] END;
(TypeForm[t.indexType]=long) => Log.Error[subrangeNesting];
ENDCASE;
TypeAttr[son[2]];
END;
arraydesc =>
BEGIN
TypeAttr[son[1]];
IF TypeForm[t.describedType] # array
THEN Log.Error[descriptor];
END;
transfer =>
BEGIN
saveNP: NPUse = pathNP;
PushArgCtx[t.inRecord];
ScanList[son[1], DeclItemB]; ProcessDefaults[son[1], TRUE];
PushArgCtx[t.outRecord];
ScanList[son[2], DeclItemB]; ProcessDefaults[son[2], FALSE];
PopArgCtx[t.outRecord]; PopArgCtx[t.inRecord];
pathNP ← saveNP;
END;
definition => NULL;
union =>
BEGIN
tagType: CSEIndex;
DeclItemB[son[1]];
seb[t.tagSei].immutable ← TRUE;
tagType ← TargetType[UnderType[seb[t.tagSei].idType]];
IF seb[tagType].typeTag # enumerated
THEN
BEGIN
Log.ErrorSei[nonTagType, t.tagSei]; tagType ← typeANY;
END;
VariantList[son[2], tagType];
END;
relative =>
BEGIN
vType: CSEIndex;
TypeAttr[son[1]];
IF seb[NormalType[UnderType[t.baseType]]].typeTag # pointer
THEN Log.Error[relative];
TypeAttr[son[2]];
vType ← UnderType[t.offsetType]; subType ← NormalType[vType];
SELECT seb[subType].typeTag FROM
pointer, arraydesc => NULL;
ENDCASE =>
BEGIN Log.Error[relative]; subType ← typeANY END;
IF seb[UnderType[t.baseType]].typeTag = long
OR seb[vType].typeTag = long
THEN subType ← MakeLongType[subType, vType];
t.resultType ← subType;
END;
subrange =>
BEGIN
TypeAttr[son[1]]; subType ← UnderType[t.rangeType];
SELECT TRUE FROM
(TypeForm[subType] = pointer) =>
BEGIN
Interval[son[2], dataPtr.typeINTEGER, TRUE]; RPop[];
END;
OrderedType[subType] =>
BEGIN
IF TypeForm[subType] = long
THEN Log.Error[subrangeNesting];
Interval[son[2], subType, TRUE]; RPop[];
END;
ENDCASE =>
BEGIN Log.Error[nonOrderedType];
Interval[son[2], typeANY, TRUE]; RPop[];
END;
END;
long =>
BEGIN
TypeAttr[son[1]]; subType ← UnderType[t.rangeType];
WITH s: seb[subType] SELECT FROM
basic =>
SELECT s.code FROM
codeINTEGER, codeANY => NULL;
ENDCASE => Log.Error[long];
pointer, arraydesc => NULL;
subrange =>
IF t.rangeType # dataPtr.idCARDINAL THEN Log.Error[long];
ENDCASE => Log.Error[long];
END;
ENDCASE => ERROR;
END;
END;
ENDCASE => ERROR;
END;
VariantList: PROCEDURE [t: Tree.Link, tagType: CSEIndex] =
BEGIN
DefineTag: Tree.Scan =
BEGIN
sei: ISEIndex;
WITH t SELECT FROM
symbol =>
BEGIN sei ← index;
seb[sei].idValue ← TagValue[seb[sei].hash, tagType];
END;
ENDCASE => ERROR;
END;
VariantItem: Tree.Scan =
BEGIN
node: Tree.Index = GetNode[t];
saveIndex: CARDINAL = dataPtr.textIndex;
dataPtr.textIndex ← tb[node].info;
ScanList[tb[node].son[1], DefineTag];
DeclItemB[t];
dataPtr.textIndex ← saveIndex;
END;
ScanList[t, VariantItem];
END;
TagValue: PROCEDURE [tag: HTIndex, tagType: CSEIndex] RETURNS [CARDINAL] =
BEGIN
matched: BOOLEAN;
sei: ISEIndex;
WITH seb[tagType] SELECT FROM
enumerated =>
BEGIN
[matched, sei] ← SearchCtxList[tag, valueCtx];
IF matched THEN RETURN [seb[sei].idValue];
END;
ENDCASE;
Log.ErrorHti[unknownTag, tag]; RETURN [0]
END;
-- type mappings and predicates
Bundling: PUBLIC PROCEDURE [type: CSEIndex] RETURNS [nLevels: CARDINAL] =
BEGIN
next: CSEIndex;
ctx: CTXIndex;
nLevels ← 0;
DO
IF type = SENull THEN EXIT;
WITH seb[type] SELECT FROM
record =>
BEGIN
IF ~hints.unifield THEN EXIT;
ctx ← fieldCtx;
WITH ctxb[ctx] SELECT FROM
included =>
BEGIN
IF hints.privateFields AND ~mdb[module].shared THEN EXIT;
IF ~complete THEN CompleteRecord[LOOPHOLE[type, RecordSEIndex]];
IF ~complete THEN EXIT;
END;
ENDCASE;
IF CtxEntries[fieldCtx] # 1 OR hints.variant THEN EXIT;
nLevels ← nLevels + 1;
next ← Unbundle[LOOPHOLE[type, RecordSEIndex]];
END;
ENDCASE => EXIT;
type ← next;
ENDLOOP;
RETURN
END;
Unbundle: PUBLIC PROCEDURE [record: RecordSEIndex] RETURNS [CSEIndex] =
BEGIN OPEN seb[record];
RETURN [UnderType[seb[ctxb[fieldCtx].seList].idType]]
END;
TargetType: PUBLIC PROCEDURE [type: CSEIndex] RETURNS [target: CSEIndex] =
BEGIN
next: CSEIndex;
FOR target ← type, next
DO
WITH seb[target] SELECT FROM
subrange => next ← UnderType[rangeType];
ENDCASE => EXIT;
ENDLOOP;
RETURN [target]
END;
CanonicalType: PUBLIC PROCEDURE [sType: CSEIndex] RETURNS [type: CSEIndex] =
BEGIN
next: CSEIndex;
FOR type ← sType, next
DO
WITH seb[type] SELECT FROM
subrange => next ← UnderType[rangeType];
record =>
IF Bundling[type] # 0
THEN next ← Unbundle[LOOPHOLE[type, RecordSEIndex]]
ELSE RETURN;
ENDCASE => RETURN
ENDLOOP;
END;
IdentifiedType: PUBLIC PROCEDURE [type: CSEIndex] RETURNS [BOOLEAN] =
BEGIN
WITH seb[type] SELECT FROM
mode, definition, nil => RETURN [FALSE];
record =>
BEGIN
IF hints.variant AND ~hints.comparable
THEN [] ← VariantUnionType[type]; -- force copying now
RETURN [TRUE]
END;
ENDCASE => RETURN [TRUE]
END;
OrderedType: PUBLIC PROCEDURE [type: SEIndex] RETURNS [BOOLEAN] =
BEGIN
sei: CSEIndex;
DO
sei ← UnderType[type];
WITH seb[sei] SELECT FROM
basic => RETURN [ordered];
enumerated => RETURN [ordered];
pointer => RETURN [ordered];
relative => type ← offsetType;
subrange => type ← rangeType;
long, real => type ← rangeType;
ENDCASE => RETURN [FALSE];
ENDLOOP;
END;
MakeLongType: PUBLIC PROCEDURE [rType: SEIndex, hint: CSEIndex] RETURNS [type: CSEIndex] =
BEGIN
WITH seb[hint] SELECT FROM
long =>
IF TargetType[UnderType[rangeType]] = TargetType[UnderType[rType]]
THEN RETURN [hint];
ENDCASE;
type ← MakeNonCtxSe[SIZE[long cons SERecord]];
seb[type] ← SERecord[mark3: TRUE, mark4: TRUE,
body: cons[long[rangeType: rType]]];
RETURN
END;
MakePointerType: PUBLIC PROCEDURE [cType: SEIndex, hint: CSEIndex, readOnly: BOOLEAN]
RETURNS [type: CSEIndex] =
BEGIN
WITH t: seb[hint] SELECT FROM
pointer =>
IF ~t.ordered AND t.readOnly = readOnly
AND UnderType[t.refType] = UnderType[cType]
THEN RETURN [hint];
ENDCASE;
type ← MakeNonCtxSe[SIZE[pointer cons SERecord]];
seb[type] ← SERecord[mark3: TRUE, mark4: TRUE,
body: cons[pointer[
ordered: FALSE,
readOnly: readOnly,
basing: FALSE,
dereferenced: FALSE,
refType: cType]]];
RETURN
END;
END.