-- file Pass3D.mesa
-- last modified by Satterthwaite, May 6, 1983 9:17 am
-- last modified by Donahue, 10-Dec-81 10:22:58
DIRECTORY
A3: TYPE USING [
AssignableType, Default, DefaultInit, IndexType, NewableType, OrderedType,
TargetType, TypeForTree, Voidable, VoidItem],
Alloc: TYPE USING [Notifier],
ComData: TYPE USING [
idANY, idCARDINAL, interface, mainCtx, moduleCtx, seAnon, textIndex,
typeINT, typeStringBody],
Inline: TYPE USING [BITOR],
Log: TYPE USING [Error, ErrorHti, ErrorSei, ErrorTree],
P3: TYPE USING [
Attr, NPUse, SequenceNP, fullAttr, voidAttr,
mark, pathNP, phraseNP,
CheckDisjoint, ClearRefStack, CopyTree, EnterComposite, Exp, FindSe,
InterfaceCtx, MakeFrameRecord, PopCtx, PushCtx, RAttr, RecordLhs,
RecordMention, Rhs, RPop, RPush, RType, SafetyAttr, SealRefStack,
SearchCtxList, SelectVariantType, TopCtx, UnsealRefStack, VariantUnionType,
VoidExp],
Symbols: TYPE USING [
Base, SERecord, HTIndex, SEIndex, ISEIndex, CSEIndex,
RecordSEIndex, RefSEIndex, CTXIndex, CBTIndex,
SENull, ISENull, CTXNull, codeANY, codeINT, lG, lZ, typeANY, typeTYPE,
seType, ctxType, mdType, bodyType],
SymbolOps: TYPE USING [
ArgCtx, CopyXferType, EnterExtension, LinkMode, MakeNonCtxSe, NormalType,
RCType, ReferentType, TypeForm, TypeLink, UnderType, XferMode],
Tree: TYPE USING [Base, Index, Link, Map, Null, NullIndex, Scan, treeType],
TreeOps: TYPE USING [
FreeTree, GetHash, GetNode, GetSe, IdentityMap, ListHead, ListLength,
NthSon, OpName, ScanList, UpdateList];
Pass3D: PROGRAM
IMPORTS
A3, Inline, Log, P3, SymbolOps, TreeOps,
dataPtr: ComData
EXPORTS P3 = {
OPEN TreeOps, SymbolOps, Symbols, A3, P3;
tb: Tree.Base; -- tree base address (local copy)
seb: Symbols.Base; -- se table base address (local copy)
ctxb: Symbols.Base; -- context table base address (local copy)
mdb: Symbols.Base; -- module table base address (local copy)
bb: Symbols.Base; -- body table base address (local copy)
DeclNotify: PUBLIC Alloc.Notifier = {
-- called by allocator whenever table area is repacked
tb ← base[Tree.treeType];
seb ← base[seType]; ctxb ← base[ctxType]; mdb ← base[mdType];
bb ← base[bodyType]};
-- signals for type loop detection
CheckTypeLoop: SIGNAL [loopNode: Tree.Index] RETURNS [BOOL] = CODE;
LogTypeLoop: SIGNAL [loopNode: Tree.Index] = CODE;
-- declaration processing
ItemId: PUBLIC PROC [t: Tree.Link] RETURNS [ISEIndex] = {
RETURN [WITH t SELECT FROM
symbol => index,
subtree => ItemId[tb[index].son[1]],
ENDCASE => ERROR]};
FirstId: PUBLIC PROC [node: Tree.Index] RETURNS [ISEIndex] = {
RETURN [ItemId[ListHead[tb[node].son[1]]]]};
DeclList: PUBLIC Tree.Scan = {ScanList[t, DeclA]; ScanList[t, DeclBInit]};
DeclA: Tree.Scan = {
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]];
SELECT tb[node].name FROM
typedecl => DefineTypeSe[tb[node].son[1], type];
decl => DefineSeType[tb[node].son[1], type, tb[node].attr1];
ENDCASE => ERROR;
ClearRefStack[];
dataPtr.textIndex ← saveIndex};
DeclBField: Tree.Scan = {DeclBDefault[t, FALSE]};
DeclBVarField: Tree.Scan = {DeclBDefault[t, TRUE]};
DeclBDefault: PROC [t: Tree.Link, varOK: BOOL←FALSE] = {
node: Tree.Index = GetNode[t];
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[typeExp: tb[node].son[2], varOK: varOK];
SELECT tb[node].name FROM
typedecl => NULL;
decl => {
type: SEIndex = TypeForTree[tb[node].son[2]];
IF ~NewableType[type] THEN Log.ErrorTree[typeLength, tb[node].son[2]];
IF tb[node].son[3] # Tree.Null THEN {
ScanList[tb[node].son[1], RecordDeclInit];
tb[node].son[3] ← DefaultExp[t:tb[node].son[3], type:type, ids:tb[node].son[1]]};
DefineSeValue[tb[node].son[1], FALSE]};
ENDCASE => ERROR;
ClearRefStack[];
dataPtr.textIndex ← saveIndex};
DeclBInit: Tree.Scan = {
node: Tree.Index = GetNode[t];
saveIndex: CARDINAL = dataPtr.textIndex;
IF tb[node].attr2 = P3.mark THEN RETURN; -- already processed
tb[node].attr2 ← P3.mark;
dataPtr.textIndex ← tb[node].info;
[] ← CheckPositions[tb[node].son[1], FieldAttrs[]];
SELECT tb[node].name FROM
typedecl => {
TypeAttr[tb[node].son[2]];
IF tb[node].son[3] # Tree.Null THEN {
tb[node].son[3] ← DefaultExp[
t:tb[node].son[3], type:TypeForTree[tb[node].son[2]], ids:tb[node].son[1]];
[] ← ProcessDefault[node]}};
decl => {
type: SEIndex;
constFlag, extFlag: BOOL;
ctx: CTXIndex = TopCtx[];
TypeAttr[typeExp: tb[node].son[2], varOK: InterfaceContext[ctx]];
type ← TypeForTree[tb[node].son[2]];
IF ~NewableType[type] THEN Log.ErrorTree[typeLength, tb[node].son[2]];
IF tb[node].son[3] = Tree.Null THEN {
IF ~InterfaceContext[ctx] AND ~tb[node].attr1 THEN {
tb[node].son[3] ← DefaultInit[type];
pathNP ← SequenceNP[pathNP][phraseNP]; RPop[]};
constFlag ← FALSE}
ELSE {
[tb[node].son[3], extFlag] ← InitialExp[tb[node].son[3], type];
IF extFlag AND ~tb[node].attr1 THEN Log.ErrorTree[misusedInline, tb[node].son[3]];
pathNP ← SequenceNP[pathNP][phraseNP];
constFlag ← tb[node].attr1 AND RAttr[].const; RPop[];
IF tb[node].son[3] # Tree.Null THEN ScanList[tb[node].son[1], RecordDeclInit]};
SELECT TRUE FROM
(tb[node].son[3] = Tree.Null) =>
IF ~InterfaceContext[ctx] AND ~Voidable[type] THEN
Log.ErrorSei[missingInit, FirstId[node]];
GlobalContext[ctx] =>
SELECT RCType[UnderType[type]] FROM
composite => EnterComposite[UnderType[type], tb[node].son[3], TRUE];
ENDCASE => NULL;
ENDCASE => NULL;
DefineSeValue[tb[node].son[1], constFlag]};
ENDCASE => ERROR;
ClearRefStack[];
dataPtr.textIndex ← saveIndex};
RecordDeclInit: Tree.Scan = {
sei: ISEIndex = ItemId[t]; RecordMention[sei]; RecordLhs[sei]};
DefaultExp: PROC [t: Tree.Link, type: SEIndex, ids: Tree.Link] RETURNS [v: Tree.Link] = {
subType: CSEIndex = TargetType[UnderType[type]];
ExpInit: PROC [t: Tree.Link] RETURNS [val: Tree.Link] = {
val ← Rhs[t, subType]; RPop[]; RETURN};
v ← UpdateList[t, ExpInit];
IF VoidItem[v] AND ~Voidable[type] THEN Log.ErrorSei[defaultForm, ItemId[ids]];
RETURN};
InitialExp: PUBLIC PROC [t: Tree.Link, type: SEIndex]
RETURNS [v: Tree.Link, extended: BOOL] = {
subType: CSEIndex = UnderType[type];
v ← t; extended ← FALSE; phraseNP ← none;
SELECT OpName[t] FROM
body => {
-- defer processing of bodies (see Body)
expNode: Tree.Index = GetNode[t];
bti: CBTIndex = tb[expNode].info;
attr: Attr ← voidAttr;
SELECT XferMode[type] FROM
proc, program => NULL;
ENDCASE =>
IF TypeForm[type] = definition THEN attr ← fullAttr ELSE Log.Error[bodyType];
bb[bti].ioType ← SELECT seb[type].seTag FROM
cons => subType,
ENDCASE => CopyXferType[subType, IdentityMap];
RPush[subType, attr]; extended ← tb[expNode].attr3; -- inline
CheckBodyType[subType, expNode]};
inline => {
expNode: Tree.Index = GetNode[t];
CodeBody: Tree.Map = {RETURN [UpdateList[t, NumericConst]]};
IF XferMode[type] # proc THEN Log.Error[inlineType];
IF tb[expNode].attr1 THEN Log.Error[attrClash];
tb[expNode].son[1] ← UpdateList[tb[expNode].son[1], CodeBody];
RPush[subType, fullAttr]; extended ← TRUE;
CheckBodyType[subType, expNode]};
apply => {
expNode: Tree.Index = GetNode[t];
IF tb[expNode].son[1] = Tree.Null
AND ReferentType[subType] = dataPtr.typeStringBody
AND ListLength[tb[expNode].son[2]] = 1 THEN
tb[expNode].name ← stringinit;
v ← Rhs[t, TargetType[subType]]};
signalinit => RPush[subType, voidAttr];
void => {v ← FreeTree[t]; RPush[subType, voidAttr]};
ENDCASE => v ← Rhs[t, TargetType[subType]];
RETURN};
RecordField: PROC [ctx: CTXIndex] RETURNS [BOOL] = INLINE {
RETURN [ctx = CTXNull OR (ctxb[ctx].level = lZ AND ctx # dataPtr.moduleCtx)]};
GlobalContext: PROC [ctx: CTXIndex] RETURNS [BOOL] = INLINE {
RETURN [~dataPtr.interface AND ctxb[ctx].level = lG]};
InterfaceContext: PROC [ctx: CTXIndex] RETURNS [BOOL] = INLINE {
RETURN [dataPtr.interface AND ctx = dataPtr.mainCtx]};
InterfaceSe: PROC [sei: ISEIndex] RETURNS [BOOL] = INLINE {
RETURN [InterfaceContext[seb[sei].idCtx]]};
CheckBodyType: PROC [type: CSEIndex, node: Tree.Index] = {
WITH t: seb[type] SELECT FROM
transfer => {
IF TypeForm[t.typeIn] = any OR TypeForm[t.typeOut] = any THEN
Log.Error[bodyType];
IF t.safe AND SafetyAttr[node] = none THEN Log.Error[unsafeBlock]};
ENDCASE};
DefineTypeSe: PROC [t: Tree.Link, info: SEIndex] = {
first: BOOL ← TRUE;
UpdateSe: Tree.Scan = {
sei: ISEIndex = ItemId[t];
seb[sei].idType ← typeTYPE; seb[sei].idInfo ← info;
seb[sei].immutable ← seb[sei].constant ← TRUE;
IF first THEN {info ← sei; first ← FALSE};
seb[sei].mark3 ← TRUE};
ScanList[t, UpdateSe]};
DefineSeType: PROC [t: Tree.Link, type: SEIndex, fixed: BOOL] = {
UpdateSe: Tree.Scan = {
sei: ISEIndex = ItemId[t];
seb[sei].idType ← type; seb[sei].constant ← FALSE;
IF InterfaceSe[sei] THEN seb[sei].immutable ← seb[sei].immutable OR fixed
ELSE seb[sei].immutable ← fixed;
seb[sei].mark3 ← TRUE};
ScanList[t, UpdateSe]};
DefineSeValue: PROC [t: Tree.Link, const: BOOL] = {
UpdateSe: Tree.Scan = {
sei: ISEIndex = ItemId[t];
seb[sei].constant ← const;
IF InterfaceSe[sei] AND LinkMode[sei] = val THEN seb[sei].immutable ← TRUE};
ScanList[t, UpdateSe]};
ProcessDefault: PROC [node: Tree.Index] RETURNS [nonVoid: BOOL] = {
copy: BOOL;
v: Tree.Link = tb[node].son[3];
DefineDefault: Tree.Scan = {
EnterExtension[ItemId[t], default, IF copy THEN CopyTree[v] ELSE v];
copy ← TRUE};
SELECT OpName[v] FROM
stringinit => Log.ErrorSei[defaultForm, FirstId[node]];
lengthen =>
IF OpName[NthSon[v, 1]] = stringinit THEN
Log.ErrorSei[defaultForm, FirstId[node]];
void => nonVoid ← FALSE;
ENDCASE => nonVoid ← TRUE;
copy ← FALSE; ScanList[tb[node].son[1], DefineDefault];
tb[node].son[3] ← Tree.Null};
-- forward reference resolution
ResolveType: PUBLIC PROC [sei: ISEIndex] = {
currentCtx: CTXIndex = TopCtx[];
IF seb[sei].idCtx # currentCtx THEN {PopCtx[]; ResolveType[sei]; PushCtx[currentCtx]}
ELSE {SealRefStack[]; DeclA[[subtree[index: seb[sei].idValue]]]; UnsealRefStack[]}};
ResolveValue: PUBLIC PROC [sei: ISEIndex] = {
currentCtx: CTXIndex = TopCtx[];
IF seb[sei].idCtx # currentCtx THEN {PopCtx[]; ResolveValue[sei]; PushCtx[currentCtx]}
ELSE {
SealRefStack[];
IF RecordField[currentCtx] THEN DeclBDefault[[subtree[index: seb[sei].idValue]]]
ELSE DeclBInit[[subtree[index: seb[sei].idValue]]];
UnsealRefStack[]}};
-- type expressions
CheckTypeId: PROC [sei: ISEIndex] RETURNS [BOOL] = {
SELECT TRUE FROM
(sei = ISENull) => RETURN [FALSE];
seb[sei].mark3 => RETURN [seb[sei].idType = typeTYPE];
ENDCASE => {
node: Tree.Index = seb[sei].idValue;
RETURN [node = Tree.NullIndex OR tb[node].name = typedecl]}};
TypeSymbol: PROC [sei: ISEIndex] RETURNS [val: Tree.Link] = {
entryIndex: CARDINAL = dataPtr.textIndex;
circular: BOOL ← FALSE;
IF ~seb[sei].mark3 THEN {
ENABLE
LogTypeLoop => {
saveIndex: CARDINAL = dataPtr.textIndex;
dataPtr.textIndex ← entryIndex;
Log.ErrorSei[circularType, sei]; circular ← TRUE;
dataPtr.textIndex ← saveIndex};
declNode: Tree.Index = seb[sei].idValue;
IF tb[declNode].attr3 # P3.mark THEN ResolveType[sei]
ELSE IF SIGNAL CheckTypeLoop[declNode] THEN SIGNAL LogTypeLoop[declNode]};
IF CheckTypeId[sei] AND ~circular THEN val ← [symbol[index: sei]]
ELSE {
IF ~circular AND sei # dataPtr.seAnon THEN Log.ErrorSei[nonTypeId, sei];
val ← [symbol[index: dataPtr.idANY]]};
RETURN};
PushArgCtx: PROC [sei: CSEIndex] = {
ctx: CTXIndex = ArgCtx[sei];
IF ctx # CTXNull THEN PushCtx[ctx]};
PopArgCtx: PROC [sei: CSEIndex] = {
IF ArgCtx[sei] # CTXNull THEN PopCtx[]};
TypeExp: PUBLIC PROC [typeExp: Tree.Link] RETURNS [val: Tree.Link] = {
val ← TypeLink[typeExp]; TypeAttr[val]; RETURN};
TypeAppl: PUBLIC PROC [typeExp: Tree.Link] RETURNS [val: Tree.Link] = {
attr: Attr;
IF OpName[typeExp] = apply THEN {
node: Tree.Index = GetNode[typeExp];
rType: SEIndex;
tb[node].son[1] ← TypeExp[tb[node].son[1]];
tb[node].info ← rType ← TypeForTree[tb[node].son[1]];
SELECT TRUE FROM
(UnderType[rType] = dataPtr.typeStringBody),
(TypeForm[VariantUnionType[rType]] = sequence) => {
tb[node].son[2] ← Rhs[tb[node].son[2], dataPtr.typeINT]; attr ← RAttr[]; RPop[]};
(TypeForm[VariantUnionType[rType]] = union) => {
TypeDiscrim[rType, node]; phraseNP ← none; attr ← fullAttr};
ENDCASE => {
Log.ErrorTree[typeClash, tb[node].son[1]];
tb[node].son[2] ← Exp[tb[node].son[2], typeANY]; attr ← RAttr[]; RPop[]};
val ← typeExp}
ELSE {val ← TypeExp[typeExp]; phraseNP ← none; attr ← fullAttr};
RPush[typeTYPE, attr]};
ClusterExp: PROC [t: Tree.Link] RETURNS [val: Tree.Link] = {
WITH t SELECT FROM
hash => {
sei: ISEIndex = FindSe[index].symbol;
IF ~CheckTypeId[sei] THEN -- prevent duplicate error messages
val ← Exp[IF sei = dataPtr.seAnon THEN [symbol[sei]] ELSE t, typeANY]
ELSE {val ← TypeSymbol[sei]; RPush[typeTYPE, fullAttr]}};
symbol => {
sei: ISEIndex = index;
IF ~CheckTypeId[sei] THEN val ← Exp[t, typeANY]
ELSE {val ← TypeSymbol[sei]; RPush[typeTYPE, fullAttr]}};
ENDCASE => {val ← TypeLink[t]; RPush[typeTYPE, fullAttr]};
RETURN};
TypeDot: PROC [rType: SEIndex, node: Tree.Index] = TypeDiscrim;
-- for now, should do other possible cluster items
TypeDiscrim: PROC [rType: SEIndex, node: Tree.Index] = {
t2: Tree.Link = tb[node].son[2];
WITH h: t2 SELECT FROM
hash => {
iSei: ISEIndex = SelectVariantType[rType, h.index];
IF iSei # ISENull THEN {
tb[node].info ← iSei; tb[node].son[2] ← [symbol[index: iSei]];
tb[node].name ← discrimTC}
ELSE {
IF rType # typeANY THEN Log.ErrorTree[unknownVariant, t2];
tb[node].info ← dataPtr.idANY}};
ENDCASE => {
Log.ErrorTree[unknownVariant, t2]; tb[node].son[2] ← VoidExp[t2]}};
FindLinkType: SIGNAL RETURNS [CSEIndex] = CODE; -- to find list link type
TypeLink: PROC [typeExp: Tree.Link] RETURNS [val: Tree.Link] = {
WITH typeExp SELECT FROM
hash => {
sei: ISEIndex = FindSe[index].symbol;
IF sei # SENull THEN val ← TypeSymbol[sei]
ELSE {Log.ErrorHti[nonTypeId, index]; val ← [symbol[dataPtr.idANY]]}};
symbol => val ← TypeSymbol[index];
subtree => {
node: Tree.Index = index;
iSei: ISEIndex;
SELECT tb[node].name FROM
discrimTC => {
tb[node].son[1] ← TypeLink[tb[node].son[1]];
TypeDiscrim[TypeForTree[tb[node].son[1]], node]};
apply => {
rType: SEIndex;
tb[node].son[1] ← TypeLink[tb[node].son[1]];
tb[node].info ← rType ← TypeForTree[tb[node].son[1]];
IF TypeForm[VariantUnionType[rType]] = union THEN TypeDiscrim[rType, node]
ELSE Log.ErrorTree[noApplication, tb[node].son[1]]};
dot => {
hti: HTIndex = GetHash[tb[node].son[2]];
nDerefs: CARDINAL ← 0;
found: BOOL;
next: SEIndex;
ctx: CTXIndex ← CTXNull;
tb[node].son[1] ← ClusterExp[tb[node].son[1]];
FOR subType: CSEIndex ← RType[], UnderType[next] DO
WITH t: seb[subType] SELECT FROM
mode => GOTO type;
definition, transfer => {
ctx ← InterfaceCtx[subType, tb[node].son[1]]; GO TO cluster};
record => {ctx ← t.fieldCtx; GO TO cluster};
ref => {IF (nDerefs ← nDerefs+1) > 63 THEN GO TO cluster; next ← t.refType};
long => next ← t.rangeType;
subrange => next ← t.rangeType;
ENDCASE => GO TO cluster;
REPEAT
type => TypeDot[TypeForTree[tb[node].son[1]], node];
cluster => {
[found, iSei] ← SearchCtxList[hti, ctx];
IF ~found THEN {iSei ← dataPtr.idANY; Log.ErrorHti[unknownField, hti]};
tb[node].name ← cdot;
tb[node].info ← iSei; tb[node].son[2] ← TypeSymbol[iSei]};
ENDLOOP;
RPop[]};
paintTC => {
tb[node].son[1] ← TypeLink[tb[node].son[1]];
tb[node].son[2] ← TypeLink[tb[node].son[2]];
tb[node].info ← TypeForTree[tb[node].son[2]]};
linkTC => tb[node].info ← SIGNAL FindLinkType[];
implicitTC => NULL;
frameTC => {
tb[node].son[1] ← Exp[tb[node].son[1], typeANY]; RPop[];
tb[node].info ← MakeFrameRecord[tb[node].son[1]]};
ENDCASE => {
OPEN tb[node];
type: CSEIndex = info;
WITH t: seb[type] SELECT FROM
enumerated => NULL;
record => {PushCtx[t.fieldCtx]; ScanList[son[1], DeclA]; PopCtx[]};
ref => {
son[1] ← TypeLink[son[1] ! CheckTypeLoop => {RESUME [FALSE]}];
t.refType ← TypeForTree[son[1]]};
array => {
IF son[1] = Tree.Null THEN t.indexType ← dataPtr.idCARDINAL
ELSE {son[1] ← TypeLink[son[1]]; t.indexType ← TypeForTree[son[1]]};
son[2] ← TypeLink[son[2]]; t.componentType ← TypeForTree[son[2]]};
arraydesc => {
son[1] ← TypeLink[son[1] ! CheckTypeLoop => {RESUME [FALSE]}];
t.describedType ← TypeForTree[son[1]]};
transfer => {
ENABLE CheckTypeLoop => {RESUME [FALSE]};
CheckDisjoint[ArgCtx[t.typeIn], ArgCtx[t.typeOut]];
PushArgCtx[t.typeIn];
IF OpName[son[1]] # anyTC THEN ScanList[son[1], DeclA];
PushArgCtx[t.typeOut];
IF OpName[son[2]] # anyTC THEN ScanList[son[2], DeclA];
PopArgCtx[t.typeOut]; PopArgCtx[t.typeIn]};
definition => t.defCtx ← dataPtr.mainCtx;
union => {DeclA[son[1]]; ScanList[son[2], DeclA]};
sequence => {
DeclA[son[1]];
son[2] ← TypeLink[son[2]]; t.componentType ← TypeForTree[son[2]]};
relative => {
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]]};
opaque => IF t.id = SENull OR ~InterfaceSe[t.id] THEN Log.Error[misplacedType];
zone => NULL;
subrange => {
t.range ← LOOPHOLE[node]; -- to allow symbolic evaluation
son[1] ← TypeLink[son[1]]; t.rangeType ← TypeForTree[son[1]]};
long => {
son[1] ← TypeLink[son[1] ! FindLinkType => {RESUME [type]}];
t.rangeType ← TypeForTree[son[1]]};
any => NULL;
ENDCASE => ERROR;
seb[type].mark3 ← TRUE};
val ← typeExp};
ENDCASE => ERROR;
RETURN};
TypeAttr: PROC [typeExp: Tree.Link, indirect, varOK: BOOL ← FALSE] = {
WITH typeExp SELECT FROM
symbol =>
IF ~indirect THEN {
sei: ISEIndex = index;
IF seb[sei].mark3 AND ~seb[sei].mark4 THEN {
declNode: Tree.Index = seb[sei].idValue;
IF tb[declNode].attr2 # P3.mark THEN ResolveValue[sei]}};
subtree => {
node: Tree.Index = index;
SELECT tb[node].name FROM
discrimTC => TypeAttr[tb[node].son[1], indirect];
cdot => TypeAttr[tb[node].son[2], indirect];
paintTC => {
TypeAttr[tb[node].son[1]]; TypeAttr[tb[node].son[2], indirect];
Log.Error[unimplemented]};
implicitTC, linkTC => NULL;
frameTC => NULL;
apply => tb[node].son[2] ← VoidExp[tb[node].son[2]];
dot => NULL;
ENDCASE => {
OPEN tb[node];
type: CSEIndex = info;
subType: CSEIndex;
WITH t: seb[type] SELECT FROM
enumerated =>
IF AssignedEnumeration[son[1]] AND ~t.machineDep THEN Log.Error[machDep];
record => {
saveNP: NPUse = pathNP;
PushCtx[t.fieldCtx]; pathNP ← none;
ScanList[son[1], DeclBField];
WITH s: t SELECT FROM
linked => CheckDisjointPrefix[t.fieldCtx, s.linkType];
notLinked => {
attrs: FieldAttrs = CollectAttrs[
son[1], FieldAttrs[positionValid: t.machineDep]];
UpdateHints[LOOPHOLE[type], attrs];
attr1 ← AssignedPositions[attrs]};
ENDCASE => ERROR;
PopCtx[]; pathNP ← saveNP};
ref => {
IF t.var AND ~varOK THEN Log.Error[var];
TypeAttr[son[1], TRUE]};
array => {
IF son[1] # Tree.Null THEN TypeAttr[son[1]];
SELECT TRUE FROM
~IndexType[t.indexType] => {
t.indexType ← typeANY; Log.Error[nonOrderedType]};
(TypeForm[t.indexType]=long) => Log.Error[subrangeNesting];
ENDCASE;
TypeAttr[son[2], indirect];
IF ~NewableType[t.componentType] THEN Log.ErrorTree[typeLength, son[2]]};
arraydesc => {
TypeAttr[son[1], TRUE];
IF TypeForm[t.describedType] # array THEN Log.Error[descriptor]};
transfer => {
saveNP: NPUse = pathNP;
IF t.mode = error THEN t.safe ← FALSE;
PushArgCtx[t.typeIn];
ArgAttr[t.typeIn, son[1], t.mode = proc OR t.mode = signal];
PushArgCtx[t.typeOut];
ArgAttr[t.typeOut, son[2], FALSE];
PopArgCtx[t.typeOut]; PopArgCtx[t.typeIn];
pathNP ← saveNP};
definition => NULL;
union => {
tagType: CSEIndex;
DeclBDefault[son[1]];
seb[t.tagSei].immutable ← TRUE;
tagType ← TargetType[UnderType[seb[t.tagSei].idType]];
IF seb[tagType].typeTag # enumerated THEN {
Log.ErrorSei[nonTagType, t.tagSei]; tagType ← typeANY};
VariantList[son[2], tagType]};
sequence => {
DeclBDefault[son[1]];
seb[t.tagSei].immutable ← TRUE;
SELECT TRUE FROM
~IndexType[seb[t.tagSei].idType] => Log.ErrorSei[nonTagType, t.tagSei];
(TypeForm[seb[t.tagSei].idType]=long) => Log.Error[unimplemented];
ENDCASE;
TypeAttr[son[2], indirect]};
relative => {
vType: CSEIndex;
TypeAttr[son[1], TRUE];
IF seb[NormalType[UnderType[t.baseType]]].typeTag # ref THEN Log.Error[relative];
TypeAttr[son[2]];
vType ← UnderType[t.offsetType]; subType ← NormalType[vType];
SELECT seb[subType].typeTag FROM
ref, arraydesc => NULL;
ENDCASE => {Log.Error[relative]; subType ← typeANY};
IF seb[UnderType[t.baseType]].typeTag = long OR seb[vType].typeTag = long THEN
subType ← MakeLongType[subType, vType];
t.resultType ← subType};
zone => NULL;
opaque =>
IF son[1] # Tree.Null THEN {
son[1] ← Rhs[son[1], dataPtr.typeINT];
IF ~RAttr[].const THEN Log.ErrorTree[nonConstant, son[1]];
RPop[]};
subrange => {
target: CSEIndex;
subNode: Tree.Index = GetNode[son[2]];
TypeAttr[son[1], indirect]; subType ← UnderType[t.rangeType];
SELECT TRUE FROM
(TypeForm[subType] = ref) => target ← dataPtr.typeINT;
OrderedType[subType] => {
WITH s: seb[subType] SELECT FROM
long => {
t.rangeType ← s.rangeType;
subType ← UnderType[s.rangeType]};
real => Log.Error[subrangeNesting];
ENDCASE;
target ← TargetType[subType]};
ENDCASE => {Log.Error[nonOrderedType]; target ← typeANY};
tb[subNode].son[1] ← EndPoint[tb[subNode].son[1], target];
tb[subNode].son[2] ← EndPoint[tb[subNode].son[2], target]};
long => {
TypeAttr[son[1], indirect, varOK];
subType ← UnderType[t.rangeType];
WITH s: seb[subType] SELECT FROM
basic =>
SELECT s.code FROM
codeINT, codeANY => NULL;
ENDCASE => Log.Error[long];
ref, arraydesc => NULL;
subrange => IF t.rangeType # dataPtr.idCARDINAL THEN Log.Error[long];
ENDCASE => Log.Error[long]};
any => NULL;
ENDCASE => ERROR}};
ENDCASE => ERROR};
EndPoint: PROC [t: Tree.Link, target: CSEIndex] RETURNS [v: Tree.Link] = {
v ← Rhs[t, target];
IF ~RAttr[].const THEN Log.ErrorTree[nonConstant, v];
RPop[]};
-- record attribute collection
FieldAttrs: TYPE = RECORD [
positionValid: BOOL ← FALSE,
noAssign: BOOL ← FALSE,
refField, unVoidable, default: BOOL ← FALSE,
positions: PACKED ARRAY {implicit, explicit} OF BOOL ← [FALSE, FALSE]];
MergeAttrs: PROC [attr1, attr2: FieldAttrs] RETURNS [FieldAttrs] =
LOOPHOLE[Inline.BITOR];
UpdateHints: PROC [rSei: RecordSEIndex, attrs: FieldAttrs] = {
seb[rSei].hints.assignable ← ~attrs.noAssign;
seb[rSei].hints.refField ← attrs.refField;
seb[rSei].hints.voidable ← ~attrs.unVoidable;
seb[rSei].hints.default ← attrs.default};
AssignedPositions: PROC [attrs: FieldAttrs] RETURNS [assigned: BOOL] = {
IF attrs.positionValid THEN {
IF attrs.positions = [TRUE, TRUE] THEN Log.Error[mixedPositions];
assigned ← attrs.positions[explicit]}
ELSE assigned ← FALSE;
RETURN};
CollectAttrs: PROC [t: Tree.Link, attrs: FieldAttrs] RETURNS [FieldAttrs] = {
ProcessField: Tree.Scan = {
node: Tree.Index = GetNode[t];
type: SEIndex = TypeForTree[tb[node].son[2]];
subType: CSEIndex = UnderType[type];
attrs ← CheckPositions[tb[node].son[1], attrs];
IF (IF tb[node].son[3] = Tree.Null
THEN Default[type] = nonVoid
ELSE ProcessDefault[node]) THEN attrs.default ← TRUE;
WITH t: seb[subType] SELECT FROM
union => {
subNode: Tree.Index = GetNode[tb[node].son[2]];
IF t.controlled THEN ProcessField[tb[subNode].son[1]];
attrs ← MergeVariantAttrs[tb[subNode].son[2], attrs];
t.hints.refField ← attrs.refField; t.hints.voidable ← ~attrs.unVoidable;
t.hints.default ← attrs.default;
tb[subNode].attr1 ← attrs.positions[explicit]};
sequence => {
subNode: Tree.Index = GetNode[tb[node].son[2]];
IF t.controlled THEN ProcessField[tb[subNode].son[1]];
IF RCType[UnderType[t.componentType]] # none THEN {
IF ~t.controlled THEN Log.Error[attrClash];
attrs.refField ← --attrs.unVoidable ←-- TRUE};
attrs.noAssign ← TRUE;
tb[subNode].attr1 ← attrs.positions[explicit]};
ENDCASE => {
IF ~attrs.refField AND RCType[subType] # none THEN
attrs.refField ← attrs.unVoidable ← TRUE;
IF ~attrs.unVoidable AND ~Voidable[type] THEN attrs.unVoidable ← TRUE;
IF ~AssignableType[subType, FALSE] THEN attrs.noAssign ← TRUE}};
ScanList[t, ProcessField];
RETURN [attrs]};
ArgAttr: PROC [rSei: CSEIndex, t: Tree.Link, varOK: BOOL] = {
IF rSei # SENull THEN
WITH seb[rSei] SELECT FROM
record => {
ScanList[t, IF varOK THEN DeclBVarField ELSE DeclBField];
UpdateHints[LOOPHOLE[rSei], CollectAttrs[t, FieldAttrs[]]]};
ENDCASE};
-- machine dependent layout
NumericConst: Tree.Map = {v ← Rhs[t, dataPtr.typeINT]; RPop[]; RETURN};
AssignedEnumeration: PROC [t: Tree.Link] RETURNS [assigned: BOOL] = {
AssignElement: Tree.Scan = {
WITH t SELECT FROM
subtree => {
node: Tree.Index = index;
tb[node].son[2] ← NumericConst[tb[node].son[2]]; assigned ← TRUE};
ENDCASE => NULL;
RETURN};
assigned ← FALSE; ScanList[t, AssignElement]; RETURN};
CheckPositions: PROC [t: Tree.Link, attrs: FieldAttrs] RETURNS [FieldAttrs] = {
CheckPosition: Tree.Scan = {
WITH t SELECT FROM
subtree => {
node: Tree.Index = GetNode[tb[index].son[2]];
IF ~attrs.positionValid THEN Log.ErrorSei[position, ItemId[tb[index].son[1]]];
tb[node].son[1] ← NumericConst[tb[node].son[1]];
IF tb[node].son[2] # Tree.Null THEN {
subNode: Tree.Index = GetNode[tb[node].son[2]];
tb[subNode].son[1] ← NumericConst[tb[subNode].son[1]];
tb[subNode].son[2] ← NumericConst[tb[subNode].son[2]]};
attrs.positions[explicit] ← TRUE};
ENDCASE => attrs.positions[implicit] ← TRUE};
ScanList[t, CheckPosition]; RETURN [attrs]};
-- variants
CheckDisjointPrefix: PROC [ctx: CTXIndex, link: SEIndex] = {
FOR sei: SEIndex ← link, SymbolOps.TypeLink[sei] UNTIL sei = SENull DO
type: CSEIndex = UnderType[sei];
WITH t: seb[type] SELECT FROM
record => CheckDisjoint[ctx, t.fieldCtx];
ENDCASE;
ENDLOOP};
VariantList: PROC [t: Tree.Link, tagType: CSEIndex] = {
DefineTag: Tree.Scan = {
sei: ISEIndex = GetSe[t];
seb[sei].idValue ← TagValue[seb[sei].hash, tagType]};
VariantItem: Tree.Scan = {
node: Tree.Index = GetNode[t];
saveIndex: CARDINAL = dataPtr.textIndex;
dataPtr.textIndex ← tb[node].info;
ScanList[tb[node].son[1], DefineTag];
DeclBDefault[t];
dataPtr.textIndex ← saveIndex};
ScanList[t, VariantItem]};
TagValue: PROC [tag: HTIndex, tagType: CSEIndex] RETURNS [CARDINAL] = {
matched: BOOL;
sei: ISEIndex;
WITH seb[tagType] SELECT FROM
enumerated => {
[matched, sei] ← SearchCtxList[tag, valueCtx];
IF matched THEN RETURN [seb[sei].idValue]};
ENDCASE;
Log.ErrorHti[unknownTag, tag]; RETURN [0]};
MergeVariantAttrs: PROC [list: Tree.Link, prefixAttrs: FieldAttrs]
RETURNS [mergedAttrs: FieldAttrs] = {
ProcessVariant: Tree.Scan = {
node: Tree.Index = GetNode[t];
ProcessLabel: Tree.Scan = {
sei: ISEIndex = GetSe[t];
type: SEIndex = seb[sei].idInfo;
WITH v: seb[type] SELECT FROM
cons =>
WITH r: v SELECT FROM
record => {
subNode: Tree.Index = GetNode[tb[node].son[2]];
attrs: FieldAttrs = CollectAttrs[tb[subNode].son[1], prefixAttrs];
UpdateHints[LOOPHOLE[type], attrs];
r.hints.default ← TRUE;
tb[subNode].attr1 ← attrs.positions[explicit];
mergedAttrs ← MergeAttrs[mergedAttrs, attrs]};
ENDCASE;
id => NULL;
ENDCASE};
ScanList[tb[node].son[1], ProcessLabel]};
mergedAttrs ← prefixAttrs;
ScanList[list, ProcessVariant]; mergedAttrs.default ← prefixAttrs.default;
RETURN};
-- type construction
MakeLongType: PUBLIC PROC [rType: SEIndex, hint: CSEIndex] RETURNS [type: CSEIndex] = {
subType: CSEIndex = UnderType[rType];
WITH t: seb[hint] SELECT FROM
long =>
IF TargetType[UnderType[t.rangeType]] = TargetType[subType] THEN RETURN [hint];
ENDCASE;
WITH t: seb[subType] SELECT FROM
relative => {
oType: CSEIndex = MakeLongType[UnderType[t.offsetType], UnderType[t.resultType]];
type ← MakeNonCtxSe[SERecord.cons.relative.SIZE];
seb[type] ← [mark3: TRUE, mark4: TRUE,
body: cons[relative[
baseType: t.baseType, offsetType: oType, resultType: oType]]]};
ENDCASE => {
type ← MakeNonCtxSe[SERecord.cons.long.SIZE];
seb[type] ← [mark3: TRUE, mark4: TRUE, body: cons[long[rangeType: rType]]]};
RETURN};
MakeRefType: PUBLIC PROC [
cType: SEIndex, hint: CSEIndex, readOnly, counted, var: BOOL]
RETURNS [type: RefSEIndex] = {
WITH t: seb[hint] SELECT FROM
ref =>
IF ~t.ordered
AND t.readOnly = readOnly AND t.counted = counted AND t.var = var
AND UnderType[t.refType] = UnderType[cType] THEN RETURN [LOOPHOLE[hint]];
ENDCASE;
type ← LOOPHOLE[MakeNonCtxSe[SERecord.cons.ref.SIZE]];
seb[type] ← [mark3: TRUE, mark4: TRUE,
body: cons[ref[
counted: counted,
var: var,
readOnly: readOnly, ordered: FALSE, list: FALSE, basing: FALSE,
refType: cType]]];
RETURN};
}.