Pass3D.mesa
Copyright © 1985 by Xerox Corporation. All rights reserved.
Satterthwaite, June 18, 1986 12:21:40 pm PDT
Donahue, 10-Dec-81 10:22:58
DIRECTORY
A3: TYPE USING [AssignableType, ComponentType, Default, DefaultInit, IndexType, OrderedType, TargetType, TypeForTree, Voidable, VoidItem],
Alloc: TYPE USING [Notifier],
ComData: TYPE USING [idANY, idCARDINAL, idINTEGER, interface, mainCtx, moduleCtx, seAnon, textIndex, typeStringBody],
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],
PrincOpsUtils: TYPE USING [BITOR],
SourceMap: TYPE USING [Loc],
Symbols: TYPE USING [Base, SERecord, Name, Type, ISEIndex, CSEIndex, RecordSEIndex, RefSEIndex, CTXIndex, CBTIndex, nullType, ISENull, CSENull, CTXNull, codeANY, codeINT, lG, lZ, typeANY, typeTYPE, seType, ctxType, mdType, bodyType],
SymbolOps: TYPE USING [ArgCtx, CopyXferType, CtxLevel, DecodeCard, DecodeTreeIndex, DecodeType, EncodeCard, EncodeType, EnterExtension, EqTypes, FromType, LinkMode, MakeNonCtxSe, NormalType, RCType, ReferentType, ToBti, ToType, TypeForm, TypeLink, UnderType, XferMode],
Tree: TYPE USING [Base, Index, Link, Map, Null, nullIndex, Scan, treeType],
TreeOps: TYPE USING [FreeTree, GetHash, GetNode, GetSe, GetTag, IdentityMap, ListHead, ListLength, NthSon, OpName, ScanList, ToLoc, UpdateList];
Pass3D: PROGRAM
IMPORTS A3, Log, P3, PrincOpsUtils, 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 GetTag[t] 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: Type;
saveIndex: SourceMap.Loc = dataPtr.textIndex;
IF tb[node].attr3 = P3.mark THEN RETURN; -- already processed
tb[node].attr3 ← P3.mark;
dataPtr.textIndex ← ToLoc[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: SourceMap.Loc = dataPtr.textIndex;
IF tb[node].attr2 = P3.mark THEN RETURN; -- already processed
tb[node].attr2 ← P3.mark;
dataPtr.textIndex ← ToLoc[tb[node].info];
TypeAttr[typeExp: tb[node].son[2], varOK: varOK];
SELECT tb[node].name FROM
typedecl => NULL;
decl => {
type: Type = TypeForTree[tb[node].son[2]];
IF ~ComponentType[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: SourceMap.Loc = dataPtr.textIndex;
IF tb[node].attr2 = P3.mark THEN RETURN; -- already processed
tb[node].attr2 ← P3.mark;
dataPtr.textIndex ← ToLoc[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: Type;
constFlag, extFlag: BOOL;
ctx: CTXIndex = TopCtx[];
TypeAttr[typeExp: tb[node].son[2], varOK: InterfaceContext[ctx]];
type ← TypeForTree[tb[node].son[2]];
IF ~ComponentType[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[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: Type, ids: Tree.Link] RETURNS[v: Tree.Link] = {
subType: Type = TargetType[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: Type] RETURNS[v: Tree.Link, extended: BOOL] = {
v ← t; extended ← FALSE; phraseNP ← none;
SELECT OpName[t] FROM
body => {
defer processing of bodies (see Body)
subType: CSEIndex = UnderType[type];
expNode: Tree.Index = GetNode[t];
bti: CBTIndex = LOOPHOLE[ToBti[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[type, 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[inlineChecked];
tb[expNode].son[1] ← UpdateList[tb[expNode].son[1], CodeBody];
RPush[type, fullAttr]; extended ← TRUE;
CheckBodyType[UnderType[type], expNode]};
apply => {
expNode: Tree.Index = GetNode[t];
IF tb[expNode].son[1] = Tree.Null
AND EqTypes[ReferentType[type], dataPtr.typeStringBody]
AND ListLength[tb[expNode].son[2]] = 1 THEN
tb[expNode].name ← stringinit;
v ← Rhs[t, TargetType[type]]};
signalinit => RPush[type, voidAttr];
void => {v ← FreeTree[t]; RPush[type, voidAttr]};
ENDCASE => v ← Rhs[t, TargetType[type]];
RETURN};
RecordField: PROC[ctx: CTXIndex] RETURNS[BOOL] = INLINE {
RETURN[ctx = CTXNull OR (CtxLevel[ctx] = lZ AND ctx # dataPtr.moduleCtx)]};
GlobalContext: PROC[ctx: CTXIndex] RETURNS[BOOL] = INLINE {
RETURN[~dataPtr.interface AND CtxLevel[ctx] = 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: Type] = {
first: BOOL ← TRUE;
UpdateSe: Tree.Scan = {
sei: ISEIndex = ItemId[t];
seb[sei].idType ← typeTYPE; seb[sei].idInfo ← EncodeType[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: Type, 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: DecodeTreeIndex[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: DecodeTreeIndex[seb[sei].idValue]]]]
ELSE DeclBInit[[subtree[index: DecodeTreeIndex[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 = DecodeTreeIndex[seb[sei].idValue];
RETURN[node = Tree.nullIndex OR tb[node].name = typedecl]}
};
TypeSymbol: PROC[sei: ISEIndex] RETURNS[val: Tree.Link] = {
entryIndex: SourceMap.Loc = dataPtr.textIndex;
circular: BOOL ← FALSE;
IF ~seb[sei].mark3 THEN {
ENABLE
LogTypeLoop => {
saveIndex: SourceMap.Loc = dataPtr.textIndex;
dataPtr.textIndex ← entryIndex;
Log.ErrorSei[circularType, sei]; circular ← TRUE;
dataPtr.textIndex ← saveIndex};
declNode: Tree.Index = DecodeTreeIndex[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: Type;
tb[node].son[1] ← TypeExp[tb[node].son[1]];
tb[node].info ← FromType[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.idINTEGER]; attr ← RAttr[]; RPop[]};
(TypeForm[VariantUnionType[rType]] = $union) => {
TypeDiscrim[rType, node]; phraseNP ← none; attr ← fullAttr};
ENDCASE => {
Log.ErrorTree[noApplication, 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 GetTag[t] 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: Type, node: Tree.Index] = TypeDiscrim;
for now, should do other possible cluster items
TypeDiscrim: PROC[rType: Type, node: Tree.Index] = {
t2: Tree.Link = tb[node].son[2];
WITH h: t2 SELECT GetTag[t2] FROM
hash => {
iSei: ISEIndex = SelectVariantType[rType, h.index];
IF iSei # ISENull THEN {
tb[node].info ← FromType[iSei]; tb[node].son[2] ← [symbol[index: iSei]];
tb[node].name ← discrimTC}
ELSE {
IF rType # typeANY THEN Log.ErrorTree[unknownVariant, t2];
tb[node].info ← FromType[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 GetTag[typeExp] FROM
hash => {
sei: ISEIndex = FindSe[index].symbol;
IF sei # ISENull 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: Type;
tb[node].son[1] ← TypeLink[tb[node].son[1]];
tb[node].info ← FromType[rType ← TypeForTree[tb[node].son[1]]];
SELECT TypeForm[VariantUnionType[rType]] FROM
$union => TypeDiscrim[rType, node];
$sequence => Log.ErrorTree[unimplemented, typeExp];
ENDCASE => Log.ErrorTree[noApplication, tb[node].son[1]]
};
dot => {
id: Name = GetHash[tb[node].son[2]];
nDerefs: CARDINAL ← 0;
found: BOOL;
next: Type;
ctx: CTXIndex ← CTXNull;
tb[node].son[1] ← ClusterExp[tb[node].son[1]];
FOR type: Type ← RType[], next DO
sei: CSEIndex = UnderType[type];
WITH t: seb[sei] SELECT FROM
mode => GOTO type;
definition, transfer => {
ctx ← InterfaceCtx[sei, 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[id, ctx];
IF ~found THEN {iSei ← dataPtr.idANY; Log.ErrorHti[unknownField, id]};
tb[node].name ← cdot;
tb[node].info ← FromType[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 ← FromType[TypeForTree[tb[node].son[2]]]};
linkTC => tb[node].info ← FromType[SIGNAL FindLinkType[]];
implicitTC => NULL;
frameTC => {
tb[node].son[1] ← Exp[tb[node].son[1], typeANY]; RPop[];
tb[node].info ← FromType[MakeFrameRecord[tb[node].son[1]]]};
ENDCASE => {
OPEN tb[node];
type: CSEIndex = LOOPHOLE[ToType[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 = ISENull 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 GetTag[typeExp] FROM
symbol =>
IF ~indirect THEN {
sei: ISEIndex = index;
IF seb[sei].mark3 AND ~seb[sei].mark4 THEN {
declNode: Tree.Index = DecodeTreeIndex[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 = LOOPHOLE[ToType[info]];
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]];
IF ~IndexType[t.indexType] THEN {
t.indexType ← typeANY; Log.Error[nonOrderedType]}
ELSE IF TypeForm[t.indexType] = $long THEN Log.Error[indexType];
TypeAttr[son[2], indirect];
IF ~ComponentType[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 ← UnderType[TargetType[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;
IF ~IndexType[seb[t.tagSei].idType] THEN Log.ErrorSei[nonTagType, t.tagSei]
ELSE IF TypeForm[seb[t.tagSei].idType] = $long THEN Log.Error[indexType];
TypeAttr[son[2], indirect];
IF ~ComponentType[t.componentType] THEN
Log.ErrorTree[typeLength, son[2]]
};
relative => {
subType, vType: CSEIndex;
TypeAttr[son[1], TRUE];
IF TypeForm[NormalType[t.baseType]] # $ref THEN Log.Error[relative];
TypeAttr[son[2]];
vType ← UnderType[t.offsetType]; subType ← NormalType[vType];
SELECT TypeForm[subType] FROM
$ref, $arraydesc => NULL;
ENDCASE => {Log.Error[relative]; subType ← typeANY};
IF TypeForm[t.baseType] = $long OR TypeForm[vType] = $long THEN
t.resultType ← MakeLongType[subType, vType]
ELSE t.resultType ← subType};
zone => NULL;
opaque =>
IF son[1] # Tree.Null THEN {
son[1] ← Rhs[son[1], dataPtr.idINTEGER];
IF ~RAttr[].const THEN Log.ErrorTree[nonConstant, son[1]];
RPop[]
};
subrange => {
target: Type;
subNode: Tree.Index = GetNode[son[2]];
TypeAttr[son[1], indirect]; target ← t.rangeType;
SELECT TRUE FROM
(TypeForm[target] = $ref) => target ← dataPtr.idINTEGER;
OrderedType[target] => {
subType: CSEIndex = UnderType[target];
WITH s: seb[subType] SELECT FROM
long => target ← t.rangeType ← s.rangeType;
real => Log.Error[subrangeNesting];
ENDCASE;
target ← TargetType[target]};
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 => {
subType: CSEIndex;
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: Type] 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[PrincOpsUtils.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: Type = 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[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 # CSENull 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.idINTEGER]; RPop[]; RETURN};
AssignedEnumeration: PROC[t: Tree.Link] RETURNS[assigned: BOOL] = {
AssignElement: Tree.Scan = {
WITH t SELECT GetTag[t] 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 GetTag[t] 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: Type] = {
FOR sei: Type ← link, SymbolOps.TypeLink[sei] UNTIL sei = nullType 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 ← EncodeCard[TagValue[seb[sei].hash, tagType]]};
VariantItem: Tree.Scan = {
node: Tree.Index = GetNode[t];
saveIndex: SourceMap.Loc = dataPtr.textIndex;
dataPtr.textIndex ← ToLoc[tb[node].info];
ScanList[tb[node].son[1], DefineTag];
DeclBDefault[t];
dataPtr.textIndex ← saveIndex};
ScanList[t, VariantItem]};
TagValue: PROC[tag: Name, tagType: CSEIndex] RETURNS[CARD] = {
matched: BOOL;
sei: ISEIndex;
WITH t: seb[tagType] SELECT FROM
enumerated => {
[matched, sei] ← SearchCtxList[tag, t.valueCtx];
IF matched THEN RETURN[DecodeCard[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: Type = DecodeType[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, hint: Type] RETURNS[type: Type] = {
subType: CSEIndex = UnderType[rType];
protoType: CSEIndex = UnderType[hint];
WITH p: seb[protoType] SELECT FROM
long =>
IF EqTypes[TargetType[p.rangeType], TargetType[subType]] THEN RETURN[hint];
ENDCASE;
WITH t: seb[subType] SELECT FROM
relative => {
oType: Type = MakeLongType[t.offsetType, 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, hint: Type, readOnly, counted, var: BOOL]
RETURNS[type: RefSEIndex] = {
protoType: CSEIndex = UnderType[hint];
WITH p: seb[protoType] SELECT FROM
ref =>
IF ~p.ordered
AND p.readOnly = readOnly AND p.counted = counted AND p.var = var
AND EqTypes[p.refType, cType] THEN RETURN[LOOPHOLE[protoType]];
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};
}.