Pass3AttributesImpl.mesa
(formerly Attr3A & Attr3B)
Copyright Ó 1985, 1986, 1987, 1989, 1991 by Xerox Corporation. All rights reserved.
Satterthwaite, June 6, 1986 1:51:13 pm PDT
Russ Atkinson (RRA) October 30, 1989 8:44:24 pm PST
DIRECTORY
Alloc USING [Notifier],
LiteralOps USING [IsShort, Value],
Literals USING [LTIndex],
MimData USING [idCARDINAL, idINTEGER, idREAL, idSTRING],
MimosaLog USING [ErrorTree],
MimP3 USING [CompleteRecord, CopyTree, Initialization, phraseNP, RecordLhs, RPush, SetNP, UpdateTreeAttr, VariantUnionType, voidAttr],
MimP3S USING [currentBody, implicit],
Pass3Attributes USING [DefaultForm, LhsMode, LifeTime],
SymbolOps USING [CtxEntries, CtxLevel, DecodeBti, DecodeTreeIndex, DecodeType, FindExtension, NormalType, own, ToBti, ToType, TypeLink, TypeRoot, UnderType, VisibleCtxEntries],
Symbols USING [Base, bodyType, CBTIndex, CBTNull, ContextLevel, CSEIndex, CSENull, CTXIndex, CTXNull, ctxType, ISEIndex, ISENull, lG, lZ, mdType, RecordSEIndex, SENull, SERecord, seType, Type, typeANY],
Target: TYPE MachineParms USING [bitsPerLongWord, bitsPerWord],
Tree USING [Base, Index, Link, Node, Null, nullIndex, Scan, treeType],
TreeOps USING [GetInfo, GetTag, ListLength, NthSon, OpName, PopTree, PushNode, PushProperList, PushSe, PushTree, ScanList];
Pass3AttributesImpl: PROGRAM
IMPORTS LiteralOps, MimData, MimosaLog, MimP3, MimP3S, SymbolOps, TreeOps
EXPORTS Pass3Attributes = {
OPEN Pass3Attributes, Symbols, TreeOps;
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: Base; -- body table base address (local copy)
TypeNotify: PUBLIC Alloc.Notifier = {
called by allocator whenever table area is repacked
tb ¬ base[Tree.treeType];
seb ¬ base[seType];
bb ¬ base[bodyType];
ctxb ¬ base[ctxType];
mdb ¬ base[mdType];
};
type mappings
BaseType: PUBLIC PROC [type: Type] RETURNS [Type] = {
DO
sei: CSEIndex = SymbolOps.UnderType[SymbolOps.own, type];
WITH t: seb[sei] SELECT FROM
subrange => type ¬ t.rangeType;
ENDCASE => RETURN [type];
ENDLOOP;
};
CanonicalType: PUBLIC PROC [type: Type] RETURNS [Type] = {
DO
sei: CSEIndex = SymbolOps.UnderType[SymbolOps.own, type];
WITH t: seb[sei] SELECT FROM
subrange => type ¬ t.rangeType;
record => {
IF Bundling[sei] = 0 THEN RETURN [type];
type ¬ Unbundle[LOOPHOLE[sei, RecordSEIndex]];
};
ENDCASE => RETURN [type];
ENDLOOP;
};
TargetType: PUBLIC PROC [type: Type] RETURNS [target: Type] = {
DO
sei: CSEIndex = SymbolOps.UnderType[SymbolOps.own, type];
WITH t: seb[sei] SELECT FROM
subrange => {
IF seb[sei].mark4 AND NOT t.biased THEN RETURN [type];
A hack to make INT16 work right
type ¬ t.rangeType;
};
ENDCASE => RETURN [type];
ENDLOOP;
};
Unbundle: PUBLIC PROC [record: RecordSEIndex] RETURNS [Type] = {
RETURN [seb[ctxb[seb[record].fieldCtx].seList].idType];
};
type predicates
AssignableType: PUBLIC PROC [type: Type, safe: BOOL] RETURNS [BOOL] = {
DO
sep: LONG POINTER TO Symbols.SERecord.cons = @seb[SymbolOps.UnderType[SymbolOps.own, type]];
WITH t: sep­ SELECT FROM
mode, definition, any, nil, sequence => RETURN [FALSE];
record =>
RETURN [t.hints.assignable
AND (NOT safe OR NOT t.hints.variant OR NOT t.hints.refField)];
union => RETURN [NOT safe OR NOT t.hints.refField];
array => type ¬ t.componentType;
transfer => RETURN [t.mode # port];
opaque => RETURN [t.lengthKnown];
ENDCASE => RETURN [TRUE];
ENDLOOP;
};
Bundling: PUBLIC PROC [type: CSEIndex] RETURNS [nLevels: CARDINAL] = {
next: Type;
ctx: CTXIndex;
nLevels ¬ 0;
DO
IF type = SENull THEN EXIT;
WITH t: seb[type] SELECT FROM
record => {
IF ~t.hints.unifield THEN EXIT;
ctx ¬ t.fieldCtx;
WITH c: ctxb[ctx] SELECT FROM
included => {
IF t.hints.privateFields AND ~mdb[c.module].shared THEN EXIT;
IF ~c.complete THEN MimP3.CompleteRecord[LOOPHOLE[type, RecordSEIndex]];
IF ~c.complete THEN EXIT;
};
ENDCASE;
IF SymbolOps.CtxEntries[SymbolOps.own, ctx] # 1 OR t.hints.variant THEN EXIT;
nLevels ¬ nLevels + 1;
next ¬ Unbundle[LOOPHOLE[type, RecordSEIndex]]};
ENDCASE => EXIT;
type ¬ SymbolOps.UnderType[SymbolOps.own, next];
ENDLOOP;
};
IdentifiedType: PUBLIC PROC [type: Type] RETURNS [BOOL] = {
sei: CSEIndex = SymbolOps.UnderType[SymbolOps.own, type];
WITH t: seb[sei] SELECT FROM
mode, definition, any, nil, union, sequence =>
RETURN [FALSE];
record =>
IF t.hints.variant AND NOT t.hints.comparable THEN
SELECT seb[MimP3.VariantUnionType[sei]].typeTag FROM
force copying now
sequence => RETURN [FALSE];
ENDCASE;
opaque =>
RETURN [t.lengthKnown];
ENDCASE;
RETURN [TRUE];
};
IndexType: PUBLIC PROC [type: Type] RETURNS [BOOL] = {
DO
sep: LONG POINTER TO Symbols.SERecord.cons = @seb[SymbolOps.UnderType[SymbolOps.own, type]];
WITH se: sep­ SELECT FROM
basic => RETURN [se.ordered];
enumerated => RETURN [se.ordered];
subrange => type ¬ se.rangeType;
signed, unsigned => RETURN [TRUE];
ENDCASE => RETURN [FALSE];
ENDLOOP;
};
LongType: PUBLIC PROC [type: Type] RETURNS [BOOL] = {
IF Target.bitsPerWord # Target.bitsPerLongWord THEN DO
sep: LONG POINTER TO Symbols.SERecord.cons = @seb[SymbolOps.UnderType[SymbolOps.own, type]];
WITH se: sep­ SELECT FROM
ref => RETURN [se.length > Target.bitsPerWord];
relative => type ¬ se.offsetType;
arraydesc => RETURN [se.length > 2*Target.bitsPerWord];
zone => RETURN [NOT se.mds];
ENDCASE => RETURN [FALSE];
ENDLOOP;
RETURN [FALSE];
};
NewableType: PUBLIC PROC [type: Type] RETURNS [BOOL] = {
sei: CSEIndex = SymbolOps.UnderType[SymbolOps.own, type];
WITH t: seb[sei] SELECT FROM
mode, any, nil => RETURN [FALSE];
opaque => RETURN [t.lengthKnown];
ENDCASE;
RETURN [TRUE]
};
OrderedType: PUBLIC PROC [type: Type] RETURNS [BOOL] = {
sei: CSEIndex = SymbolOps.UnderType[SymbolOps.own, type];
WITH t: seb[sei] SELECT FROM
basic => RETURN [t.ordered];
enumerated => RETURN [t.ordered];
ref => RETURN [t.ordered];
relative => RETURN [OrderedType[t.offsetType]];
subrange => RETURN [OrderedType[t.rangeType]];
real, signed, unsigned => RETURN [TRUE];
ENDCASE;
RETURN [FALSE];
};
PermanentType: PUBLIC PROC [type: Type] RETURNS [BOOL] = {
sei: CSEIndex = SymbolOps.UnderType[SymbolOps.own, type];
WITH t: seb[sei] SELECT FROM
record => IF SymbolOps.CtxLevel[SymbolOps.own, t.fieldCtx] = lG THEN RETURN [TRUE];
ENDCASE;
RETURN [FALSE];
};
VarType: PUBLIC PROC [type: Type] RETURNS [BOOL] = {
sei: CSEIndex = SymbolOps.NormalType[SymbolOps.own, type];
WITH t: seb[sei] SELECT FROM
ref => RETURN [t.var];
ENDCASE;
RETURN [FALSE];
};
defaults
Default: PUBLIC PROC [type: Type] RETURNS [form: DefaultForm ¬ $none] = {
next: Type;
FOR s: Type ¬ type, next DO
WITH se: seb[s] SELECT FROM
id => {
sei: ISEIndex = LOOPHOLE[s];
TestOption: Tree.Scan = {
IF OpName[t] = $void
THEN {IF form = $none THEN form ¬ $void}
ELSE form ¬ $nonVoid;
};
IF seb[sei].extended THEN {ScanList[SymbolOps.FindExtension[SymbolOps.own, sei].tree, TestOption]; EXIT};
next ¬ SymbolOps.DecodeType[seb[sei].idInfo];
};
cons =>
WITH t: se SELECT FROM
ref => {IF t.counted THEN form ¬ $nonVoid; EXIT};
array => next ¬ t.componentType;
record => {IF t.hints.default THEN form ¬ $nonVoid; EXIT};
transfer => {form ¬ $nonVoid; EXIT};
zone => {IF t.counted THEN form ¬ $nonVoid; EXIT};
ENDCASE => EXIT;
ENDCASE => ERROR;
ENDLOOP;
};
DefaultInit: PUBLIC PROC [type: Type] RETURNS [v: Tree.Link] = {
next: Type;
subType: CSEIndex ¬ SymbolOps.UnderType[SymbolOps.own, type];
recordTail: Tree.Link ¬ Tree.Null;
tagId: ISEIndex ¬ ISENull;
v ¬ Tree.Null;
FOR s: Type ¬ type, next DO
WITH se: seb[s] SELECT FROM
id => {
sei: ISEIndex = LOOPHOLE[s];
CopyNonVoid: Tree.Scan = {
IF OpName[t] # $void AND v = Tree.Null THEN v ¬ MimP3.CopyTree[t];
};
SELECT TRUE FROM
(seb[sei].extended AND recordTail = Tree.Null) => {
ScanList[SymbolOps.FindExtension[SymbolOps.own, sei].tree, CopyNonVoid];
GO TO copy;
};
(DiscrimId[sei] AND tagId = ISENull) => tagId ¬ sei;
ENDCASE;
next ¬ SymbolOps.DecodeType[seb[sei].idInfo];
};
cons =>
WITH t: se SELECT FROM
ref =>
IF t.counted
THEN {PushTree[Tree.Null]; PushNode[nil, 1]; GO TO eval}
ELSE GO TO none;
array =>
IF Default[t.componentType] = nonVoid
THEN {PushTree[Tree.Null]; PushNode[all, 1]; GO TO eval}
ELSE GO TO none;
record =>
IF t.hints.default OR recordTail # Tree.Null THEN {
n: CARDINAL;
MimP3.CompleteRecord[LOOPHOLE[s]];
n ¬ SymbolOps.VisibleCtxEntries[t.fieldCtx];
FOR i: CARDINAL IN [1..n] DO
PushTree[IF i # n THEN Tree.Null ELSE recordTail];
ENDLOOP;
PushProperList[n];
recordTail ¬ Tree.Null;
IF tagId = ISENull
THEN {
PushTree[Tree.Null];
PushNode[apply, -2];
GO TO eval;
}
ELSE {
PushSe[tagId]; tagId ¬ ISENull;
PushNode[apply, -2];
recordTail ¬ PopTree[];
next ¬ SymbolOps.TypeLink[SymbolOps.own, s];
subType ¬ SymbolOps.UnderType[SymbolOps.own, next];
}
}
ELSE GO TO none;
transfer => {
PushTree[Tree.Null];
PushNode[nil, 1];
GO TO eval;
};
zone =>
IF t.counted
THEN {PushTree[Tree.Null]; PushNode[nil, 1]; GO TO eval}
ELSE GO TO none;
ENDCASE => GO TO none;
ENDCASE => ERROR;
REPEAT
none => {
v ¬ Tree.Null;
MimP3.phraseNP ¬ none;
MimP3.RPush[subType, MimP3.voidAttr];
};
copy =>
MimP3.RPush[subType,
IF v=Tree.Null THEN MimP3.voidAttr ELSE MimP3.UpdateTreeAttr[v]];
eval =>
v ¬ MimP3.Initialization[PopTree[], TargetType[subType]];
ENDLOOP;
};
DiscrimId: PROC [sei: ISEIndex] RETURNS [BOOL] = INLINE {
RETURN [SymbolOps.CtxLevel[SymbolOps.own, seb[sei].idCtx] = lZ
AND SymbolOps.TypeLink[SymbolOps.own, sei] # SENull];
};
Voidable: PUBLIC PROC [type: Type] RETURNS [BOOL] = {
next: Type ¬ type;
DO
WITH se: seb[next] SELECT FROM
id => {
sei: ISEIndex = LOOPHOLE[next];
IF seb[sei].extended THEN RETURN [VoidItem[SymbolOps.FindExtension[SymbolOps.own, sei].tree]];
next ¬ SymbolOps.DecodeType[seb[sei].idInfo];
};
cons =>
WITH t: se SELECT FROM
ref => RETURN [~t.counted];
array => next ¬ t.componentType;
record => RETURN [t.hints.voidable];
union => RETURN [t.hints.voidable];
zone => RETURN [~t.counted];
ENDCASE => RETURN [TRUE];
ENDCASE => ERROR;
ENDLOOP;
};
VoidItem: PUBLIC PROC [t: Tree.Link] RETURNS [void: BOOL ¬ FALSE] = {
TestVoid: Tree.Scan = {IF OpName[t] = $void THEN void ¬ TRUE};
ScanList[t, TestVoid];
};
MarkedType: PUBLIC PROC [type: Type] RETURNS [CSEIndex] = {
subType: CSEIndex = SymbolOps.NormalType[SymbolOps.own, type];
WITH t: seb[subType] SELECT FROM
ref => RETURN [SymbolOps.UnderType[SymbolOps.own,
SymbolOps.TypeRoot[SymbolOps.own, t.refType]]];
transfer => RETURN [subType];
ENDCASE => RETURN [typeANY];
};
tree manipulation utilities
TypeForTree: PUBLIC PROC [t: Tree.Link] RETURNS [Type] = {
N.B. assumes t evaluated by MimP3.SymbolOps.TypeLink or MimP3.Exp
WHILE t # Tree.Null DO
WITH t SELECT GetTag[t] FROM
symbol => RETURN [index];
subtree =>
SELECT tb[index].name FROM
cdot, discrimTC => t ¬ tb[index].son[2];
ENDCASE => RETURN [SymbolOps.ToType[tb[index].info]];
ENDCASE => EXIT;
ENDLOOP;
RETURN [typeANY];
};
InterfaceVar: PROC [t: Tree.Link] RETURNS [BOOL] = INLINE {
RETURN [WITH t SELECT GetTag[t] FROM
symbol => (ctxb[seb[index].idCtx].ctxType = imported),
ENDCASE => FALSE]
};
WritableRef: PROC [t: Tree.Link, readonly: BOOL] RETURNS [Pass3Attributes.LhsMode] = {
type: Type ¬ CanonicalType[OperandType[t]];
MimP3.phraseNP ¬ MimP3.SetNP[MimP3.phraseNP];
DO
nType: CSEIndex ¬ SymbolOps.NormalType[SymbolOps.own, type];
WITH t: seb[nType] SELECT FROM
ref => SELECT TRUE FROM
t.readOnly AND NOT readonly => EXIT;
t.counted => RETURN [$counted];
ENDCASE => RETURN [$uncounted];
arraydesc => {
IF readonly OR NOT t.readOnly THEN RETURN [$uncounted];
EXIT;
};
relative => type ¬ t.offsetType;
ENDCASE => EXIT;
ENDLOOP;
RETURN [none];
};
VarLhsMode: ARRAY LhsMode OF LhsMode = [
none: $none, uncounted: $counted, counted: $counted];
OperandLhs: PUBLIC PROC [t: Tree.Link, readonly: BOOL ¬ FALSE] RETURNS [LhsMode] = {
The readonly argument is TRUE iff OperandLhs is being called to get the mode for a readonly address.
DO
WITH e: t SELECT GetTag[t] FROM
symbol => {
sei: ISEIndex = e.index;
ctx: CTXIndex = seb[sei].idCtx;
level: ContextLevel ¬ lZ;
IF ctx # CTXNull THEN {
ctxb[ctx].varUpdated ¬ TRUE;
level ¬ SymbolOps.CtxLevel[SymbolOps.own, ctx];
IF level < MimP3S.currentBody.level THEN
MimP3.phraseNP ¬ MimP3.SetNP[MimP3.phraseNP];
};
MimP3.RecordLhs[sei];
SELECT TRUE FROM
seb[sei].immutable => {};
(level = lG) => RETURN [$counted];
ENDCASE => RETURN [$uncounted];
};
subtree => {
node: Tree.Index = e.index;
IF node # Tree.nullIndex THEN {
SELECT tb[node].name FROM
$dot => {
son2: Tree.Link = tb[node].son[2];
WITH son2 SELECT GetTag[son2] FROM
symbol =>
SELECT TRUE FROM
seb[index].immutable => {};
(SymbolOps.CtxLevel[SymbolOps.own, seb[index].idCtx] = lG) =>
GO TO varLhs1;
ENDCASE => GO TO writable1;
ENDCASE;
};
$uparrow =>
IF InterfaceVar[tb[node].son[1]] THEN GO TO varLhs1 ELSE GO TO writable1;
$dindex => GO TO writable1;
$reloc => GO TO writable2;
$dollar => {
son2: Tree.Link = tb[node].son[2];
WITH son2 SELECT GetTag[son2] FROM
symbol =>
IF ~seb[index].immutable OR readonly THEN GO TO loop1;
ENDCASE;
};
$index, $seqindex, $loophole, $cast, $openx, $pad, $chop => GO TO loop1;
$base, $length => IF tb[node].attr1 THEN GO TO loop1;
$cdot => GO TO loop2;
$apply => IF ListLength[tb[node].son[1]] = 1 THEN RETURN [$uncounted];
ENDCASE;
EXITS
loop1 => {t ¬ tb[node].son[1]; LOOP};
loop2 => {t ¬ tb[node].son[2]; LOOP};
writable1 => RETURN [WritableRef[tb[node].son[1], readonly]];
writable2 => RETURN [WritableRef[tb[node].son[2], readonly]];
varLhs1 => RETURN [VarLhsMode[WritableRef[tb[node].son[1], readonly]]];
};
};
ENDCASE;
RETURN [none];
ENDLOOP;
};
OperandLevel: PUBLIC PROC [t: Tree.Link] RETURNS [level: Pass3Attributes.LifeTime] = {
SELECT OpName[t] FROM
$cdot, $nil => level ¬ $global;
ENDCASE => {
bti: CBTIndex = BodyForTree[t];
level ¬ SELECT TRUE FROM
(bti = CBTNull) => $unknown,
(bb[bti].level <= lG+1) => $global,
ENDCASE => $local;
};
};
OperandEntry: PUBLIC PROC [t: Tree.Link] RETURNS [BOOL] = {
DO
WITH e: t SELECT GetTag[t] FROM
symbol => {
bti: CBTIndex = BodyForTree[t];
RETURN [bti # CBTNull AND bb[bti].entry];
};
subtree =>
SELECT OpName[t] FROM
$dot, $cdot, $assignx => {t ¬ NthSon[t, 2]; LOOP};
$ifx => {
IF OperandInternal[NthSon[t, 2]] THEN RETURN [TRUE];
t ¬ NthSon[t, 3];
LOOP;
};
ENDCASE; -- should check casex, bindx also
ENDCASE;
RETURN [FALSE];
ENDLOOP;
};
OperandInternal: PUBLIC PROC [t: Tree.Link] RETURNS [BOOL] = {
DO
WITH e: t SELECT GetTag[t] FROM
symbol => {
bti: CBTIndex = BodyForTree[t];
RETURN [bti # CBTNull AND bb[bti].internal];
};
subtree =>
SELECT OpName[t] FROM
$dot, $cdot, $assignx => {t ¬ NthSon[t, 2]; LOOP};
$ifx => {
IF OperandInternal[NthSon[t, 2]] THEN RETURN [TRUE];
t ¬ NthSon[t, 3];
LOOP;
};
ENDCASE; -- should check casex, bindx also
ENDCASE;
RETURN [FALSE];
ENDLOOP;
};
OperandType: PUBLIC PROC [t: Tree.Link] RETURNS [Type] = {
IF t = Tree.Null THEN RETURN [MimP3S.implicit.type];
WITH e: t SELECT GetTag[t] FROM
symbol => RETURN [seb[e.index].idType];
subtree => {
tp: LONG POINTER TO Tree.Node = @tb[e.index];
SELECT tp.name FROM
list => {MimosaLog.ErrorTree[typeClash, t]; RETURN [Symbols.typeANY]};
ENDCASE => RETURN [SymbolOps.ToType[tp.info]];
};
literal => {
lti: Literals.LTIndex = e.index;
IF LiteralOps.IsShort[lti] THEN
SELECT LiteralOps.Value[lti].class FROM
unsigned => RETURN [MimData.idCARDINAL];
signed => RETURN [MimData.idINTEGER];
real => RETURN [MimData.idREAL];
ENDCASE;
};
string => RETURN [MimData.idSTRING];
ENDCASE;
RETURN [CSENull];
};
LongPath: PUBLIC PROC [t: Tree.Link] RETURNS [BOOL] = {
WHILE t # Tree.Null DO
WITH e: t SELECT GetTag[t] FROM
subtree => {
tp: LONG POINTER TO Tree.Node = @tb[e.index];
SELECT tp.name FROM
$loophole, $cast, $openx, $pad, $chop =>
t ¬ tp.son[1];
ENDCASE =>
$dot, $uparrow, $dindex, $reloc, $seqindex, $dollar, $index
RETURN [tp.attr2];
};
ENDCASE => EXIT;
ENDLOOP;
RETURN [FALSE];
};
BodyForTree: PUBLIC PROC [t: Tree.Link] RETURNS [CBTIndex] = {
DO
WITH t SELECT GetTag[t] FROM
symbol => {
sei: ISEIndex = index;
SELECT TRUE FROM
seb[sei].mark4 =>
IF seb[sei].constant THEN RETURN [SymbolOps.DecodeBti[seb[sei].idInfo]];
seb[sei].immutable => {
node: Tree.Index ¬ SymbolOps.DecodeTreeIndex[seb[sei].idValue];
IF OpName[tb[node].son[3]] = $body THEN
RETURN [LOOPHOLE[SymbolOps.ToBti[GetInfo[tb[node].son[3]]]]]
};
ENDCASE;
};
subtree => {
node: Tree.Index ¬ index;
SELECT tb[node].name FROM
$cdot, $dot, $dollar => {t ¬ tb[node].son[2]; LOOP};
ENDCASE;
};
ENDCASE;
RETURN [CBTNull];
ENDLOOP;
};
}.