Pass3V.mesa
Copyright Ó 1985, 1986, 1987, 1988, 1991 by Xerox Corporation. All rights reserved.
Satterthwaite, June 11, 1986 12:52:38 pm PDT
Russ Atkinson (RRA) July 11, 1990 9:22:07 pm PDT
DIRECTORY
Alloc USING [Notifier],
MimData USING [idBOOL, ownSymbols, seAnon, textIndex, typeAtomRecord],
MimosaCopier USING [CopyUnion],
MimosaLog USING [Error, ErrorHti, ErrorSei, ErrorTree, Warning],
MimP3 USING [Attr, BaseTree, EnterType, Exp, FindSe, FirstId, ForceType, NarrowOp, NPUse, OpenPointer, phraseNP, PopCtx, PushCtx, PushHtCtx, PushRecordCtx, RAttrPop, Rhs, RPop, RPush, Scope, SealRefStack, SearchCtxList, SetType, TopCtx, UnsealRefStack, UpdateTreeAttr, UType, VoidExp],
MimP3S USING [implicit, ImplicitInfo, implicitRecord, safety],
Pass3Attributes USING [CanonicalType, LongPath, LongType, MarkedType, OperandType, TargetType, TypeForTree],
SourceMap USING [Loc],
SymbolOps USING [DecodeTreeIndex, DecodeType, FromType, NextSe, NormalType, own, RCType, ReferentType, ToType, TypeForm, TypeLink, TypeRoot, UnderType],
Symbols USING [Base, CSEIndex, CSENull, CTXIndex, CTXNull, ctxType, HTIndex, HTNull, ISEIndex, ISENull, nullType, RecordSEIndex, seType, Type, typeANY, typeTYPE],
Tree USING [Base, Index, Link, Map, NodePtr, Null, Scan, treeType],
TreeOps USING [GetHash, GetNode, GetTag, ListHead, ListTail, OpName, PopTree, PushNode, PushSe, PushTree, ScanList, SetAttr, ToLoc, UpdateList],
Types USING [Equivalent];
Pass3V: PROGRAM
IMPORTS MimData, MimosaCopier, MimosaLog, MimP3, MimP3S, Pass3Attributes, SymbolOps, TreeOps, Types
EXPORTS MimP3 = {
OPEN MimP3, Pass3Attributes, Symbols, TreeOps;
tables defining the current symbol table
tb: Tree.Base;  -- tree base
seb: Symbols.Base;  -- se table
ctxb: Symbols.Base;  -- context table
VRNotify: PUBLIC Alloc.Notifier = {
called whenever the main symbol table is repacked
tb ¬ base[Tree.treeType];
seb ¬ base[seType];
ctxb ¬ base[ctxType];
};
finding union and discriminated types
N. B. the following two entries cannot assume well-formed type links
VariantUnionType: PUBLIC PROC [type: Type] RETURNS [CSEIndex] = {
rType: CSEIndex = ConsType[type];
WITH se: seb[rType] SELECT FROM
record => IF se.hints.variant THEN
RETURN [ConsType[TypeForSe[UnionField[LOOPHOLE[rType, RecordSEIndex]]]]];
ENDCASE;
RETURN [typeANY];
};
TypeForSe: PROC [sei: ISEIndex] RETURNS [type: Type] = INLINE {
node: Tree.Index;
t: Tree.Link;
IF seb[sei].mark3 THEN RETURN [seb[sei].idType];
node ¬ SymbolOps.DecodeTreeIndex[seb[sei].idValue];
IF tb[node].name # decl THEN RETURN [typeTYPE];
t ¬ tb[node].son[2];
type ¬ WITH t SELECT GetTag[t] FROM
hash => ResolveId[index, seb[sei].idCtx],
symbol => index,
subtree => SymbolOps.ToType[tb[index].info],
ENDCASE => typeANY;
};
SelectVariantType: PUBLIC PROC [type: Type, tag: HTIndex] RETURNS [sei: ISEIndex] = {
vType: CSEIndex = VariantUnionType[type];
WITH seb[vType] SELECT FROM
union => {
matched: BOOL;
[matched, sei] ¬ SearchCtxList[tag, caseCtx];
IF ~matched THEN sei ¬ ISENull;
};
ENDCASE => sei ¬ ISENull;
};
SequenceField: PUBLIC PROC [rSei: RecordSEIndex] RETURNS [ISEIndex] = {
sei: ISEIndex = UnionField[rSei];
IF SymbolOps.TypeForm[SymbolOps.own, seb[sei].idType] = sequence THEN RETURN [sei];
RETURN [ISENull];
};
auxiliary procedures (to avoid SymbolOps.UnderType when unsafe)
UnionField: PROC [rSei: RecordSEIndex] RETURNS [ISEIndex] = {
sei, root, next: ISEIndex;
ctx: CTXIndex = seb[rSei].fieldCtx;
IF ctxb[ctx].ctxType = simple
THEN
FOR sei ¬ ctxb[ctx].seList, next UNTIL sei = ISENull DO
next ¬ SymbolOps.NextSe[SymbolOps.own, sei];
IF next = ISENull THEN RETURN [sei];
ENDLOOP
ELSE {
defined in another module, SymbolOps.UnderType is safe
repeated: BOOL ¬ FALSE;
DO
sei ¬ root ¬ ctxb[ctx].seList;
DO
IF sei = ISENull THEN EXIT;
SELECT SymbolOps.TypeForm[SymbolOps.own, seb[sei].idType] FROM
union, sequence => RETURN [sei];
ENDCASE;
IF (sei ¬ SymbolOps.NextSe[SymbolOps.own, sei]) = root THEN EXIT;
ENDLOOP;
IF repeated THEN EXIT;
MimosaCopier.CopyUnion[rSei];
repeated ¬ TRUE;
ENDLOOP;
};
RETURN [MimData.seAnon];
};
ResolveId: PROC [hti: HTIndex, ctx: CTXIndex] RETURNS [sei: ISEIndex] = {
currentCtx: CTXIndex = TopCtx[];
IF ctx = currentCtx
THEN sei ¬ FindSe[hti].symbol
ELSE {PopCtx[]; sei ¬ ResolveId[hti, ctx]; PushCtx[currentCtx]};
};
ConsType: PROC [type: Type] RETURNS [CSEIndex] = {
WITH se: seb[type] SELECT FROM
id =>
IF se.mark3 THEN
RETURN [
IF se.idType # typeTYPE
THEN typeANY
ELSE ConsType[SymbolOps.DecodeType[se.idInfo]]]
ELSE {
node: Tree.Index = SymbolOps.DecodeTreeIndex[se.idValue];
RETURN [IF tb[node].name # typedecl
THEN typeANY
ELSE ConsType[ResolveTreeType[tb[node].son[2], se.idCtx]]];
};
cons => RETURN [LOOPHOLE[type, CSEIndex]];
ENDCASE => ERROR;
};
ResolveTreeType: PROC [t: Tree.Link, ctx: CTXIndex] RETURNS [Type] = {
DO
WITH e: t SELECT GetTag[t] FROM
hash => RETURN [ResolveId[e.index, ctx]];
symbol => RETURN [e.index];
subtree => {
node: Tree.Index = e.index;
tp: Tree.NodePtr = @tb[e.index];
dst: Type ¬ SymbolOps.ToType[tp.info];
IF dst # nullType THEN RETURN [dst];
SELECT tp.name FROM
optionTC => {t ¬ tp.son[1]; LOOP};
discrimTC => {
son2: Tree.Link = tp.son[2];
WITH s2: son2 SELECT GetTag[son2] FROM
hash => RETURN [SelectVariantType[
ResolveTreeType[tp.son[1], ctx], s2.index]];
ENDCASE;
};
ENDCASE;
};
ENDCASE;
ERROR;
ENDLOOP;
};
type discrimination
DiscriminatedType: PUBLIC PROC
[baseType: CSEIndex, t: Tree.Link] RETURNS [type: CSEIndex] = {
type ¬ MimP3S.implicitRecord;
IF t # Tree.Null THEN
WITH t SELECT GetTag[t] FROM
subtree => {
node: Tree.Index = index;
SELECT tb[node].name FROM
union => {
son1: Tree.Link = tb[node].son[1];
WITH son1 SELECT GetTag[son1] FROM
symbol => type ¬ SymbolOps.UnderType[SymbolOps.own, index];
ENDCASE => ERROR;
WITH seb[type] SELECT FROM
record =>
IF hints.variant THEN {
son2: Tree.Link = tb[node].son[2];
IF son2 # Tree.Null THEN {
temp: Tree.Link ¬ ListTail[son2];
IF temp # Tree.Null THEN type ¬ DiscriminatedType[type, temp];
};
};
ENDCASE => ERROR;
};
dollar =>
type ¬ SymbolOps.UnderType[SymbolOps.own, OperandType[tb[node].son[1]]];
dot => {
subType: CSEIndex = SymbolOps.NormalType[SymbolOps.own, OperandType[tb[node].son[1]]];
WITH seb[subType] SELECT FROM
ref => type ¬ SymbolOps.UnderType[SymbolOps.own, refType];
ENDCASE => ERROR;
};
assignx => type ¬ DiscriminatedType[baseType, tb[node].son[2]];
ENDCASE => type ¬ baseType;
};
ENDCASE => type ¬ baseType;
};
discrimination operations
Narrowing: PUBLIC PROC [type, target: Type] RETURNS [op: NarrowOp¬[]] = {
typeL: CSEIndex ¬ SymbolOps.UnderType[SymbolOps.own, target];
typeR: CSEIndex ¬ SymbolOps.UnderType[SymbolOps.own, type];
nextL, nextR: Type;
IF ~Types.Equivalent[[MimData.ownSymbols, typeL], [MimData.ownSymbols, typeR]] THEN
DO
WITH tR: seb[typeR] SELECT FROM
any => {
IF ~op.indirect THEN op.error ¬ TRUE;
WITH tL: seb[typeL] SELECT FROM
any => EXIT;
opaque => {
op.rtTest ¬ TRUE;
IF typeL # MimData.typeAtomRecord THEN op.unImpl ¬ TRUE;
EXIT};
ENDCASE => {
op.rtTest ¬ TRUE;
IF ~Discriminated[typeL] THEN EXIT;
nextR ¬ SymbolOps.TypeRoot[SymbolOps.own, nextL ¬ typeL];
};
};
record =>
WITH tL: seb[typeL] SELECT FROM
record => {
IF Types.Equivalent[
[MimData.ownSymbols, typeL], [MimData.ownSymbols, typeR]]
THEN EXIT;
WITH vL: tL SELECT FROM
linked => {
uType: CSEIndex = VariantUnionType[vL.linkType];
WITH u: seb[uType] SELECT FROM
union =>
IF u.controlled THEN op.tagTest ¬ TRUE ELSE op.computed ¬ TRUE;
ENDCASE => op.error ¬ TRUE;
nextL ¬ vL.linkType; nextR ¬ typeR};
ENDCASE => op.error ¬ TRUE};
ENDCASE => op.error ¬ TRUE;
ref =>
WITH tL: seb[typeL] SELECT FROM
ref => {
IF op.indirect OR
(tL.counted # tR.counted) OR (tR.readOnly AND ~tL.readOnly)
THEN op.error ¬ TRUE;
op.indirect ¬ TRUE;
nextL ¬ tL.refType;
nextR ¬ tR.refType;
};
ENDCASE => op.error ¬ TRUE;
transfer =>
WITH tL: seb[typeL] SELECT FROM
transfer => {
IF op.indirect OR tL.mode # tR.mode OR tL.safe # tR.safe THEN
op.error ¬ TRUE;
SELECT tL.mode FROM
proc, signal, error => NULL;
ENDCASE => op.error ¬ TRUE;
IF SymbolOps.TypeForm[SymbolOps.own, tL.typeIn] = any OR SymbolOps.TypeForm[SymbolOps.own, tL.typeOut] = any THEN
op.error ¬ TRUE; -- for now
SELECT TRUE FROM
SymbolOps.TypeForm[SymbolOps.own, tR.typeIn] = any =>
op.rtTest ¬ TRUE;
~Types.Equivalent[
[MimData.ownSymbols, tL.typeIn],
[MimData.ownSymbols, tR.typeIn]] => op.error ¬ TRUE;
ENDCASE;
SELECT TRUE FROM
SymbolOps.TypeForm[SymbolOps.own, tR.typeOut] = any =>
op.rtTest ¬ TRUE;
~Types.Equivalent[
[MimData.ownSymbols, tL.typeOut],
[MimData.ownSymbols, tR.typeOut]] => op.error ¬ TRUE;
ENDCASE;
EXIT;
};
ENDCASE => op.error ¬ TRUE;
ENDCASE => {
IF Types.Equivalent[
[MimData.ownSymbols, typeL], [MimData.ownSymbols, typeR]]
THEN EXIT;
op.error ¬ TRUE;
};
IF op.error THEN EXIT;
typeL ¬ SymbolOps.UnderType[SymbolOps.own, nextL];
typeR ¬ SymbolOps.UnderType[SymbolOps.own, nextR];
ENDLOOP;
};
Discriminated: PROC [type: CSEIndex] RETURNS [BOOL] = INLINE {
RETURN [SymbolOps.TypeLink[SymbolOps.own, type] # nullType];
check that at tag exists?
};
binding of variant records
Discrimination: PUBLIC PROC [node: Tree.Index, selection: Tree.Map] = {
copy: BOOL = (OpName[ListHead[tb[node].son[3]]] = ditem);
type, subType: CSEIndex;
vCtx: CTXIndex;
base, discBase: Tree.Link;
attr: Attr;
entryNP: NPUse ¬ none;
unreachable: BOOL ¬ FALSE;
BindError: PROC = {
IF tb[node].son[2] # Tree.Null THEN tb[node].son[2] ¬ VoidExp[tb[node].son[2]];
vCtx ¬ CTXNull;
};
PushCommonCtx: PROC = {
SELECT TRUE FROM
copy OR (seb[type].typeTag # record) => PushCtx[CTXNull];
(baseId = HTNull) => PushRecordCtx[LOOPHOLE[type], base, indirect];
ENDCASE => PushHtCtx[baseId, base, indirect];
};
BindItem: Tree.Scan = {
subNode: Tree.Index = GetNode[t];
saveIndex: SourceMap.Loc = MimData.textIndex;
IF tb[subNode].name = ditem
THEN {
declNode: Tree.Index = GetNode[tb[subNode].son[1]];
declType: CSEIndex;
Item: Tree.Map = {phraseNP ¬ entryNP; v ¬ selection[t]};
op: NarrowOp;
MimData.textIndex ¬ ToLoc[tb[declNode].info];
IF unreachable THEN {MimosaLog.Warning[unreachable]; unreachable ¬ FALSE};
Scope[subNode, Item];
declType ¬ SymbolOps.UnderType[SymbolOps.own, TypeForTree[tb[declNode].son[2]]];
op ¬ Narrowing[subType, declType];
SELECT TRUE FROM
~copy => MimosaLog.Error[discrimForm];
op.error => MimosaLog.ErrorSei[typeClash, FirstId[declNode]];
op.computed => MimosaLog.ErrorTree[missingBinding, base];
op.unImpl => MimosaLog.Warning[opaqueTest];
~(op.rtTest OR op.tagTest) => unreachable ¬ TRUE;
ENDCASE;
tb[subNode].attr1 ¬ op.indirect;
IF (tb[subNode].attr2 ¬ op.rtTest) THEN EnterType[MarkedType[declType]];
tb[subNode].attr3 ¬ op.tagTest;
}
ELSE {
vType: CSEIndex;
MimData.textIndex ¬ ToLoc[tb[subNode].info];
IF copy THEN {MimosaLog.Error[discrimForm]; tb[node].attr3 ¬ FALSE};
[tb[subNode].son[1], vType] ¬ BindTest[tb[subNode].son[1], vCtx];
IF vType = typeANY
THEN PushCommonCtx[]
ELSE {
WITH discBase SELECT GetTag[discBase] FROM
subtree => tb[index].info ¬ SymbolOps.FromType[vType];
ENDCASE => ERROR;
IF baseId = HTNull
THEN PushRecordCtx[LOOPHOLE[vType], discBase, FALSE]
ELSE PushHtCtx[baseId, discBase, FALSE];
};
phraseNP ¬ entryNP;
tb[subNode].son[2] ¬ selection[tb[subNode].son[2]];
PopCtx[];
tb[subNode].attr1 ¬ TRUE;
};
MimData.textIndex ¬ saveIndex;
};
saveImplicit: MimP3S.ImplicitInfo = MimP3S.implicit;
idNode: Tree.Index = GetNode[tb[node].son[1]];
baseId: HTIndex = GetHash[tb[idNode].son[1]];
indirect: BOOL;
SealRefStack[];
base ¬ tb[idNode].son[2] ¬ Exp[tb[idNode].son[2], typeANY];
type ¬ UType[];
attr ¬ RAttrPop[];
UnsealRefStack[];
subType ¬ SymbolOps.UnderType[SymbolOps.own, CanonicalType[type]];
IF subType # type THEN tb[idNode].son[2] ¬ ForceType[tb[idNode].son[2], subType];
type ¬ SymbolOps.NormalType[SymbolOps.own, subType];
MimP3S.implicit ¬ [tree: base, type: subType, attr: attr];
IF (tb[node].attr3 ¬ copy)
THEN {
MimP3S.implicit.attr.noAssign ¬ MimP3S.implicit.attr.noXfer ¬ TRUE;
SELECT SymbolOps.TypeForm[SymbolOps.own, type] FROM
ref => {
tb[node].attr2 ¬ (SymbolOps.TypeForm[SymbolOps.own, SymbolOps.ReferentType[SymbolOps.own, type]] = any);
indirect ¬ TRUE;
};
transfer => {
tb[node].attr2 ¬ TRUE;
indirect ¬ FALSE;
MimosaLog.Error[unimplemented];
Some day we might allow discrimnation based on procedure types, but not in the near future.
};
ENDCASE => {tb[node].attr2 ¬ FALSE; indirect ¬ FALSE};
IF baseId # HTNull THEN MimosaLog.Error[discrimForm];
}
ELSE {
long: BOOL;
WITH t: seb[type] SELECT FROM
ref => {
indirect ¬ TRUE;
[base, type] ¬ OpenPointer[base, subType];
subType ¬ SymbolOps.UnderType[SymbolOps.own, OperandType[base]];
long ¬ LongType[type];
};
ENDCASE => {indirect ¬ FALSE; long ¬ LongPath[base]};
IF MimP3S.safety = checked
AND SymbolOps.RCType[SymbolOps.own, type] # none THEN
MimosaLog.ErrorTree[unsafeSelection, base];
WITH seb[type] SELECT FROM
record => {
tb[idNode].son[2] ¬ base ¬ BaseTree[base, subType];
IF hints.variant
THEN {
uType: CSEIndex = VariantUnionType[type];
WITH u: seb[uType] SELECT FROM
union => {
tagType: Type = seb[u.tagSei].idType;
vCtx ¬ u.caseCtx;
IF tb[node].son[2] = Tree.Null
THEN {
IF ~u.controlled THEN
MimosaLog.ErrorTree[missingBinding, base];
[] ¬ UpdateTreeAttr[base];
entryNP ¬ phraseNP;
PushTree[base];
PushSe[u.tagSei];
PushNode[IF indirect THEN dot ELSE dollar, 2];
SetType[tagType];
SetAttr[2, long];
tb[node].son[2] ¬ PopTree[];
}
ELSE {
IF u.controlled THEN
MimosaLog.ErrorTree[spuriousBinding, tb[node].son[2]];
PushCommonCtx[];
tb[node].son[2] ¬ Rhs[tb[node].son[2], TargetType[tagType]];
entryNP ¬ phraseNP;
RPop[];
PopCtx[];
};
};
ENDCASE => {MimosaLog.Error[noAccess]; BindError[]}}
ELSE {MimosaLog.ErrorTree[noVariants, tb[idNode].son[2]]; BindError[]};
PushTree[base];
IF indirect
THEN {PushNode[uparrow, 1]; SetAttr[2, long]}
ELSE PushNode[cast, 1];
discBase ¬ PopTree[];
};
ENDCASE => {
MimosaLog.ErrorTree[noVariants, tb[idNode].son[2]];
BindError[];
discBase ¬ Tree.Null;
};
};
tb[node].attr1 ¬ indirect;
ScanList[tb[node].son[3], BindItem];
PushCommonCtx[];
phraseNP ¬ entryNP;
tb[node].son[4] ¬ selection[tb[node].son[4]]; PopCtx[];
RPush[CSENull, attr];
MimP3S.implicit ¬ saveImplicit;
};
BindTest: PROC [t: Tree.Link, vCtx: CTXIndex]
RETURNS [val: Tree.Link, vType: CSEIndex] = {
mixed: BOOL ¬ FALSE;
TestItem: Tree.Map = {
WITH t SELECT GetTag[t] FROM
subtree => {
subNode: Tree.Index = index;
SELECT tb[subNode].name FROM
relE =>
WITH tb[subNode].son[2] SELECT GetTag[tb[subNode].son[2]] FROM
hash => {
iType: ISEIndex;
found: BOOL;
[found, iType] ¬ SearchCtxList[index, vCtx];
SELECT TRUE FROM
found => {
uType: CSEIndex = SymbolOps.UnderType[SymbolOps.own, iType];
tb[subNode].son[2] ¬ [symbol[index: iType]];
SELECT vType FROM
uType => NULL;
typeANY => vType ¬ uType;
ENDCASE => mixed ¬ TRUE;
};
vCtx # CTXNull => MimosaLog.ErrorHti[unknownVariant, index];
ENDCASE;
tb[subNode].info ¬ SymbolOps.FromType[MimData.idBOOL];
tb[subNode].attr1 ¬ tb[subNode].attr2 ¬ FALSE;
v ¬ t;
};
ENDCASE => {
v ¬ Rhs[t, MimData.idBOOL]; RPop[];
MimosaLog.ErrorTree[nonVariantLabel, t];
};
ENDCASE => {
v ¬ Rhs[t, MimData.idBOOL]; RPop[];
MimosaLog.ErrorTree[nonVariantLabel, t];
};
};
ENDCASE => ERROR;
};
vType ¬ typeANY;
val ¬ UpdateList[t, TestItem];
IF mixed THEN vType ¬ typeANY;
};
}.