[ivy]<Satterthwaite>Mimosa>Pass3V.mesa!3

Pass3V.Mesa
Copyright © 1985 by Xerox Corporation. All rights reserved.
Satterthwaite, June 11, 1986 12:52:38 pm PDT
Russ Atkinson (RRA) March 6, 1985 10:44:46 pm PST
DIRECTORY
A3 USING [CanonicalType, LongPath, MarkedType, OperandType, TargetType, TypeForTree],
Alloc USING [Notifier],
ComData USING [idBOOL, ownSymbols, seAnon, textIndex, typeAtomRecord],
Copier USING [CopyUnion],
Log USING [Error, ErrorHti, ErrorSei, ErrorTree, Warning],
P3 USING [Attr, NarrowOp, NPUse, phraseNP, BaseTree, EnterType, Exp, FindSe, FirstId, ForceType, OpenPointer, PopCtx, PushCtx, PushHtCtx, PushRecordCtx, RAttr, Rhs, RPop, RPush, Scope, SealRefStack, SearchCtxList, SetType, TopCtx, UnsealRefStack, UpdateTreeAttr, UType, VoidExp],
P3S USING [ImplicitInfo, implicit, implicitRecord, safety],
SourceMap USING [Loc],
Symbols USING [Base, HTIndex, Type, ISEIndex, CSEIndex, RecordSEIndex, CTXIndex, HTNull, nullType, ISENull, CSENull, CTXNull, typeANY, typeTYPE, seType, ctxType],
SymbolOps USING [DecodeTreeIndex, DecodeType, FromType, NextSe, NormalType, RCType, ReferentType, ToType, TypeForm, TypeLink, TypeRoot, UnderType],
Tree USING [Base, Index, Link, Map, Null, Scan, treeType],
TreeOps USING [GetHash, GetNode, GetTag, ListHead, ListTail, OpName, PopTree, PushTree, PushNode, PushSe, ScanList, SetAttr, ToLoc, UpdateList],
Types USING [Equivalent];
Pass3V: PROGRAM
IMPORTS A3, Copier, Log, P3, P3S, SymbolOps, TreeOps, Types, dataPtr: ComData
EXPORTS P3 = {
OPEN SymbolOps, A3, P3, 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];
RETURN [WITH seb[rType] SELECT FROM
record =>
IF hints.variant
THEN ConsType[TypeForSe[UnionField[LOOPHOLE[rType, RecordSEIndex]]]]
ELSE typeANY,
ENDCASE => typeANY]};
SelectVariantType: PUBLIC PROC [type: Type, tag: HTIndex] RETURNS [sei: ISEIndex] = {
matched: BOOL;
vType: CSEIndex = VariantUnionType[type];
WITH seb[vType] SELECT FROM
union => [matched, sei] ← SearchCtxList[tag, caseCtx];
ENDCASE => matched ← FALSE;
IF ~matched THEN sei ← ISENull;
RETURN};
SequenceField: PUBLIC PROC [rSei: RecordSEIndex] RETURNS [ISEIndex] = {
sei: ISEIndex = UnionField[rSei];
RETURN [IF TypeForm[seb[sei].idType] = sequence THEN sei ELSE ISENull]};
auxiliary procedures (for avoiding UnderType when potentially 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 ← NextSe[sei];
IF next = ISENull THEN RETURN [sei];
ENDLOOP
ELSE {-- defined in another module, UnderType is safe
repeated: BOOL ← FALSE;
DO
sei ← root ← ctxb[ctx].seList;
DO
IF sei = ISENull THEN EXIT;
SELECT TypeForm[seb[sei].idType] FROM
union, sequence => RETURN [sei];
ENDCASE;
IF (sei ← NextSe[sei]) = root THEN EXIT;
ENDLOOP;
IF repeated THEN EXIT;
Copier.CopyUnion[seb[rSei].fieldCtx]; repeated ← TRUE;
ENDLOOP};
RETURN [dataPtr.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]};
RETURN};
TypeForSe: PROC [sei: ISEIndex] RETURNS [type: Type] = INLINE {
node: Tree.Index;
t: Tree.Link;
IF seb[sei].mark3 THEN RETURN [seb[sei].idType];
node ← 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 => ToType[tb[index].info],
ENDCASE => typeANY;
RETURN};
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[DecodeType[se.idInfo]]]
ELSE {
node: Tree.Index = 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: Type] = {
WITH t SELECT GetTag[t] FROM
hash => type ← ResolveId[index, ctx];
symbol => type ← index;
subtree => {
node: Tree.Index = index;
type ← IF ToType[tb[node].info] # nullType
THEN ToType[tb[node].info]
ELSE
SELECT tb[node].name FROM
discrimTC =>
WITH tb[node].son[2] SELECT GetTag[tb[node].son[2]] FROM
hash => SelectVariantType[ResolveTreeType[tb[node].son[1], ctx], index],
ENDCASE => ERROR,
ENDCASE => ERROR};
ENDCASE => ERROR;
RETURN};
type discrimination
DiscriminatedType: PUBLIC PROC [baseType: CSEIndex, t: Tree.Link]
RETURNS [type: CSEIndex] = {
IF t = Tree.Null THEN type ← P3S.implicitRecord
ELSE
WITH t SELECT GetTag[t] FROM
subtree => {
node: Tree.Index = index;
temp: Tree.Link;
SELECT tb[node].name FROM
union => {
type ← WITH tb[node].son[1] SELECT GetTag[tb[node].son[1]] FROM
symbol => UnderType[index],
ENDCASE => ERROR;
WITH seb[type] SELECT FROM
record =>
IF hints.variant AND tb[node].son[2] # Tree.Null
AND (temp←ListTail[tb[node].son[2]]) # Tree.Null THEN
type ← DiscriminatedType[type, temp];
ENDCASE => ERROR};
dollar => type ← UnderType[OperandType[tb[node].son[1]]];
dot => {
subType: CSEIndex = NormalType[OperandType[tb[node].son[1]]];
type ← WITH seb[subType] SELECT FROM ref => UnderType[refType], ENDCASE => ERROR};
assignx => type ← DiscriminatedType[baseType, tb[node].son[2]];
ENDCASE => type ← baseType};
ENDCASE => type ← baseType;
RETURN};
discrimination operations
Narrowing: PUBLIC PROC [type, target: Type] RETURNS [op: NarrowOp←[]] = {
typeL: CSEIndex ← UnderType[target];
typeR: CSEIndex ← UnderType[type];
nextL, nextR: Type;
IF ~Types.Equivalent[[dataPtr.ownSymbols, typeL], [dataPtr.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 # dataPtr.typeAtomRecord THEN op.unImpl ← TRUE;
EXIT};
ENDCASE => {
op.rtTest ← TRUE;
IF ~Discriminated[typeL] THEN EXIT;
nextL ← typeL; nextR ← TypeRoot[typeL]}};
record =>
WITH tL: seb[typeL] SELECT FROM
record => {
IF Types.Equivalent[[dataPtr.ownSymbols, typeL], [dataPtr.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 TypeForm[tL.typeIn] = any OR TypeForm[tL.typeOut] = any THEN
op.error ← TRUE;-- for now
IF TypeForm[tR.typeIn] = any THEN
op.rtTest ← TRUE
ELSE IF ~Types.Equivalent[
[dataPtr.ownSymbols, tL.typeIn],
[dataPtr.ownSymbols, tR.typeIn]] THEN op.error ← TRUE;
IF TypeForm[tR.typeOut] = any THEN
op.rtTest ← TRUE
ELSE IF ~Types.Equivalent[
[dataPtr.ownSymbols, tL.typeOut],
[dataPtr.ownSymbols, tR.typeOut]] THEN op.error ← TRUE;
EXIT};
ENDCASE => op.error ← TRUE;
long =>
WITH tL: seb[typeL] SELECT FROM
long => {nextL ← tL.rangeType; nextR ← tR.rangeType};
ENDCASE => op.error ← TRUE;
ENDCASE => {
IF Types.Equivalent[[dataPtr.ownSymbols, typeL], [dataPtr.ownSymbols, typeR]]
THEN EXIT;
op.error ← TRUE};
IF op.error THEN EXIT;
typeL ← UnderType[nextL]; typeR ← UnderType[nextR];
ENDLOOP;
RETURN};
Discriminated: PROC [type: CSEIndex] RETURNS [BOOL] = INLINE {
RETURN [TypeLink[type] # nullType]}; -- check that at tag exists?
binding of variant records
Discrimination: PUBLIC PROC [node: Tree.Index, selection: Tree.Map] = {
OPEN tb[node];
copy: BOOL = (OpName[ListHead[son[3]]] = ditem);
type, subType: CSEIndex;
vCtx: CTXIndex;
base, discBase: Tree.Link;
attr: Attr;
entryNP: NPUse ← none;
unreachable: BOOL ← FALSE;
BindError: PROC = {
IF son[2] # Tree.Null THEN son[2] ← VoidExp[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 = dataPtr.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;
dataPtr.textIndex ← ToLoc[tb[declNode].info];
IF unreachable THEN {Log.Warning[unreachable]; unreachable ← FALSE};
Scope[subNode, Item];
declType ← UnderType[TypeForTree[tb[declNode].son[2]]];
op ← Narrowing[subType, declType];
SELECT TRUE FROM
~copy => Log.Error[discrimForm];
op.error => Log.ErrorSei[typeClash, FirstId[declNode]];
op.computed => Log.ErrorTree[missingBinding, base];
op.unImpl => Log.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;
dataPtr.textIndex ← ToLoc[tb[subNode].info];
IF copy THEN {Log.Error[discrimForm]; 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 ← 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};
dataPtr.textIndex ← saveIndex};
saveImplicit: P3S.ImplicitInfo = P3S.implicit;
idNode: Tree.Index = GetNode[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 ← RAttr[]; RPop[];
UnsealRefStack[];
subType ← UnderType[CanonicalType[type]];
IF subType # type THEN tb[idNode].son[2] ← ForceType[tb[idNode].son[2], subType];
type ← NormalType[subType];
P3S.implicit ← [tree: base, type: subType, attr: attr];
IF (attr3 ← copy) THEN {
P3S.implicit.attr.noAssign ← P3S.implicit.attr.noXfer ← TRUE;
SELECT TypeForm[type] FROM
ref => {
attr2 ← (TypeForm[ReferentType[type]] = any);
indirect ← TRUE};
transfer => {attr2 ← TRUE; indirect ← FALSE};
ENDCASE => {attr2 ← FALSE; indirect ← FALSE};
IF baseId # HTNull THEN Log.Error[discrimForm]}
ELSE {
long: BOOL;
WITH t: seb[type] SELECT FROM
ref => {
indirect ← TRUE;
[base, type] ← OpenPointer[base, subType];
subType ← UnderType[OperandType[base]];
long ← seb[subType].typeTag = long};
ENDCASE => {indirect ← FALSE; long ← LongPath[base]};
IF P3S.safety = checked AND RCType[type] # none THEN
Log.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 son[2] = Tree.Null THEN {
IF ~u.controlled THEN Log.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]; son[2] ← PopTree[]}
ELSE {
IF u.controlled THEN Log.ErrorTree[spuriousBinding, son[2]];
PushCommonCtx[];
son[2] ← Rhs[son[2], TargetType[tagType]];
entryNP ← phraseNP; RPop[];
PopCtx[]}};
ENDCASE => {Log.Error[noAccess]; BindError[]}}
ELSE {Log.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 => {
Log.ErrorTree[noVariants, tb[idNode].son[2]]; BindError[];
discBase ← Tree.Null}};
attr1 ← indirect;
ScanList[son[3], BindItem];
PushCommonCtx[]; phraseNP ← entryNP; son[4] ← selection[son[4]]; PopCtx[];
RPush[CSENull, attr];
P3S.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;
uType: CSEIndex;
found: BOOL;
[found, iType] ← SearchCtxList[index, vCtx];
IF found THEN {
uType ← UnderType[iType];
tb[subNode].son[2] ← [symbol[index: iType]];
SELECT vType FROM
uType => NULL;
typeANY => vType ← uType;
ENDCASE => mixed ← TRUE}
ELSE IF vCtx # CTXNull THEN Log.ErrorHti[unknownVariant, index];
tb[subNode].info ← FromType[dataPtr.idBOOL];
tb[subNode].attr1 ← tb[subNode].attr2 ← FALSE;
v ← t};
ENDCASE => {
v ← Rhs[t, dataPtr.idBOOL]; RPop[];
Log.ErrorTree[nonVariantLabel, t]};
ENDCASE => {
v ← Rhs[t, dataPtr.idBOOL]; RPop[];
Log.ErrorTree[nonVariantLabel, t]}};
ENDCASE => ERROR;
RETURN};
vType ← typeANY; val ← UpdateList[t, TestItem];
IF mixed THEN vType ← typeANY;
RETURN};
}.