-- file Pass3V.Mesa
-- last modified by Satterthwaite, November 8, 1979 3:02 PM

DIRECTORY
ComData: FROM "comdata" USING [idANY, seAnon, textIndex, typeBOOLEAN],
Copier: FROM "copier" USING [CopyUnion],
Log: FROM "log" USING [Error, ErrorHti, ErrorTree],
P3: FROM "p3"
USING [
Attr, NPUse,
phraseNP,
BaseTree, Exp, FindSe, LongPath, OpenPointer, OperandType,
PopCtx, PushCtx, PushHtCtx, PushRecordCtx,
RAttr, Rhs, RPop, RPush, RType, SealRefStack, SearchCtxList, TargetType,
TopCtx, UnsealRefStack, UpdateTreeAttr, VoidExp],
Pass3: FROM "pass3" USING [implicitRecord, implicitTree, implicitType],
Symbols: FROM "symbols"
USING [seType, ctxType,
HTIndex, SEIndex, ISEIndex, CSEIndex, RecordSEIndex, CTXIndex,
HTNull, SENull, ISENull, CSENull, CTXNull, typeANY, typeTYPE],
SymbolOps: FROM "symbolops" USING [NextSe, NormalType, TypeForm, UnderType],
Table: FROM "table" USING [Base, Notifier, AddNotify, DropNotify],
Tree: FROM "tree" USING [Index, Link, Map, Null, Scan, treeType],
TreeOps: FROM "treeops"
USING [
ListTail, PopTree, PushTree, PushNode,
ScanList, SetAttr, SetInfo, UpdateList];

Pass3V: PROGRAM
IMPORTS
Copier, Log, P3, SymbolOps, Table, TreeOps,
dataPtr: ComData, passPtr: Pass3
EXPORTS P3 =
BEGIN
OPEN SymbolOps, P3, Symbols, TreeOps;

-- tables defining the current symbol table

tb: Table.Base;-- tree base
seb: Table.Base;-- se table
ctxb: Table.Base;-- context table

VRNotify: Table.Notifier =
BEGIN -- called whenever the main symbol table is repacked
tb ← base[Tree.treeType]; seb ← base[seType]; ctxb ← base[ctxType];
END;

entryDepth: CARDINAL ← 0;

VREnter: PROCEDURE =
BEGIN
IF entryDepth = 0 THEN Table.AddNotify[VRNotify];
entryDepth ← entryDepth + 1;
END;

VRExit: PROCEDURE =
BEGIN
IF (entryDepth ← entryDepth-1) = 0 THEN Table.DropNotify[VRNotify];
END;


-- finding union and discriminated types
-- N. B. the following two entries cannot assume well-formed type links

VariantUnionType: PUBLIC PROCEDURE [type: SEIndex] RETURNS [vType: CSEIndex] =
BEGIN
rType: CSEIndex;
VREnter[];
rType ← ConsType[type];
vType ← WITH seb[rType] SELECT FROM
record =>
IF hints.variant
THEN ConsType[TypeForSe[UnionField[LOOPHOLE[rType, RecordSEIndex]]]]
ELSE typeANY,
ENDCASE => typeANY;
VRExit[];
RETURN
END;


SelectVariantType: PUBLIC PROCEDURE [type: SEIndex, tag: HTIndex] RETURNS [sei: ISEIndex] =
BEGIN
matched: BOOLEAN;
vType: CSEIndex = VariantUnionType[type];
VREnter[];
WITH seb[vType] SELECT FROM
union => [matched, sei] ← SearchCtxList[tag, caseCtx];
ENDCASE => matched ← FALSE;
IF ~matched
THEN
BEGIN
IF type # typeANY THEN Log.ErrorHti[unknownVariant, tag];
sei ← dataPtr.idANY;
END;
VRExit[];
RETURN
END;


-- auxiliary procedures (for avoiding UnderType when potentially unsafe)

UnionField: PROCEDURE [rSei: RecordSEIndex] RETURNS [ISEIndex] = INLINE
BEGIN
sei, root, next: ISEIndex;
ctx: CTXIndex = seb[rSei].fieldCtx;
repeated: BOOLEAN;
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
BEGIN-- defined elsewhere, UnderType is safe
repeated ← FALSE;
DO
sei ← root ← ctxb[ctx].seList;
DO
IF sei = ISENull THEN EXIT;
IF TypeForm[seb[sei].idType] = union THEN RETURN [sei];
IF (sei ← NextSe[sei]) = root THEN EXIT;
ENDLOOP;
IF repeated THEN EXIT;
Copier.CopyUnion[seb[rSei].fieldCtx]; repeated ← TRUE;
ENDLOOP;
END;
RETURN [dataPtr.seAnon]
END;

ResolveId: PROCEDURE [hti: HTIndex, ctx: CTXIndex] RETURNS [sei: ISEIndex] =
BEGIN
currentCtx: CTXIndex = TopCtx[];
IF ctx = currentCtx
THEN sei ← FindSe[hti].symbol
ELSE
BEGIN PopCtx[]; sei ← ResolveId[hti, ctx]; PushCtx[currentCtx] END;
RETURN
END;

TypeForSe: PROCEDURE [sei: ISEIndex] RETURNS [type: SEIndex] = INLINE
BEGIN
node: Tree.Index;
t: Tree.Link;
IF seb[sei].mark3 THEN RETURN [seb[sei].idType];
node ← seb[sei].idValue;
IF tb[node].name # decl THEN RETURN [typeTYPE];
t ← tb[node].son[2];
type ← WITH t SELECT FROM
hash => ResolveId[index, seb[sei].idCtx],
symbol => index,
subtree => tb[index].info,
ENDCASE => typeANY;
RETURN
END;

ConsType: PROCEDURE [type: SEIndex] RETURNS [CSEIndex] =
BEGIN
sei, next: SEIndex;
node: Tree.Index;
FOR sei ← type, next
DO
WITH seb[sei] SELECT FROM
id =>
IF mark3
THEN
BEGIN
IF idType # typeTYPE THEN RETURN [typeANY];
next ← idInfo;
END
ELSE
BEGIN node ← idValue;
IF tb[node].name # typedecl THEN RETURN [typeANY];
next ← ResolveTreeType[tb[node].son[2], idCtx];
END;
cons => RETURN [LOOPHOLE[sei, CSEIndex]];
ENDCASE;
ENDLOOP;
END;

ResolveTreeType: PROCEDURE [t: Tree.Link, ctx: CTXIndex] RETURNS [type: SEIndex] =
BEGIN
node: Tree.Index;
WITH t SELECT FROM
hash => type ← ResolveId[index, ctx];
symbol => type ← index;
subtree =>
BEGIN node ← index;
IF tb[node].info # SENull
THEN type ← tb[node].info
ELSE
SELECT tb[node].name FROM
discrimTC =>
WITH tb[node].son[2] SELECT FROM
hash =>
type ← SelectVariantType[
ResolveTreeType[tb[node].son[1], ctx],
index];
ENDCASE => ERROR;
ENDCASE => ERROR;
END;
ENDCASE => ERROR;
RETURN
END;


-- type discrimination

DiscriminatedType: PUBLIC PROCEDURE [baseType: CSEIndex, t: Tree.Link] RETURNS [type: CSEIndex] =
BEGIN
node: Tree.Index;
temp: Tree.Link;
subType: CSEIndex;
VREnter[];
IF t = Tree.Null
THEN type ← passPtr.implicitRecord
ELSE
WITH t SELECT FROM
subtree =>
BEGIN node ← index;
SELECT tb[node].name FROM
union =>
BEGIN
type ← WITH tb[node].son[1] SELECT 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;
END;
dollar => type ← OperandType[tb[node].son[1]];
dot =>
BEGIN
subType ← NormalType[OperandType[tb[node].son[1]]];
type ← WITH seb[subType] SELECT FROM
pointer => UnderType[refType],
ENDCASE => ERROR;
END;
assignx => type ← DiscriminatedType[baseType, tb[node].son[2]];
ENDCASE => type ← baseType;
END;
ENDCASE => type ← baseType;
VRExit[]; RETURN
END;


-- binding of variant records

Discrimination: PUBLIC PROCEDURE [node: Tree.Index, selection: Tree.Map] =
BEGIN OPEN tb[node];
idNode: Tree.Index;
type, subType, uType, tagType: CSEIndex;
vCtx: CTXIndex;
base, discBase: Tree.Link;
indirect, long: BOOLEAN;
baseId: HTIndex;
attr: Attr;
entryNP: NPUse;
saveType: CSEIndex = passPtr.implicitType;
saveTree: Tree.Link = passPtr.implicitTree;

BindError: PROCEDURE =
BEGIN
IF son[2] # Tree.Null THEN son[2] ← VoidExp[son[2]];
vCtx ← CTXNull; tagType ← typeANY;
END;

PushCommonCtx: PROCEDURE =
BEGIN
SELECT TRUE FROM
(seb[type].typeTag # record) => PushCtx[CTXNull];
(baseId = HTNull) => PushRecordCtx[LOOPHOLE[type], base, indirect];
ENDCASE => PushHtCtx[baseId, base, indirect];
END;

BindItem: Tree.Scan =
BEGIN
subNode: Tree.Index;
vType: CSEIndex;
saveIndex: CARDINAL = dataPtr.textIndex;
WITH t SELECT FROM
subtree =>
BEGIN subNode ← index;
dataPtr.textIndex ← tb[subNode].info;
[tb[subNode].son[1], vType] ← BindTest[tb[subNode].son[1], vCtx];
IF vType = typeANY
THEN PushCommonCtx[]
ELSE
BEGIN
WITH discBase SELECT FROM
subtree => tb[index].info ← vType;
ENDCASE => ERROR;
IF baseId = HTNull
THEN PushRecordCtx[LOOPHOLE[vType], discBase, FALSE]
ELSE PushHtCtx[baseId, discBase, FALSE];
END;
phraseNP ← entryNP;
tb[subNode].son[2] ← selection[tb[subNode].son[2]];
PopCtx[];
tb[subNode].attr1 ← TRUE;
END;
ENDCASE => ERROR;
dataPtr.textIndex ← saveIndex;
END;

VREnter[];
idNode ← WITH son[1] SELECT FROM subtree => index, ENDCASE => ERROR;
SealRefStack[];
base ← tb[idNode].son[2] ← Exp[tb[idNode].son[2], typeANY];
subType ← RType[]; attr ← RAttr[]; RPop[];
UnsealRefStack[];
type ← NormalType[subType];
IF (indirect ← seb[type].typeTag = pointer)
THEN
BEGIN
[base, type] ← OpenPointer[base, subType];
subType ← OperandType[base]; long ← seb[subType].typeTag = long;
END
ELSE long ← LongPath[base];
baseId ← WITH tb[idNode].son[1] SELECT FROM hash=> index, ENDCASE=> ERROR;
entryNP ← none;
WITH seb[type] SELECT FROM
record =>
BEGIN
tb[idNode].son[2] ← base ← BaseTree[base, subType];
IF hints.variant
THEN
BEGIN uType ← VariantUnionType[type];
WITH seb[uType] SELECT FROM
union =>
BEGIN
vCtx ← caseCtx;
tagType ← UnderType[seb[tagSei].idType];
IF son[2] = Tree.Null
THEN
BEGIN
IF ~controlled THEN Log.Error[missingBinding];
[] ← UpdateTreeAttr[base]; entryNP ← phraseNP;
PushTree[base];
PushTree[Tree.Link[symbol[index: tagSei]]];
PushNode[IF indirect THEN dot ELSE dollar, 2];
SetInfo[tagType]; SetAttr[2, long]; son[2] ← PopTree[];
END
ELSE
BEGIN
IF controlled THEN Log.ErrorTree[spuriousBinding, son[2]];
PushCommonCtx[];
son[2] ← Rhs[son[2], TargetType[tagType]];
entryNP ← phraseNP; RPop[];
PopCtx[];
END;
END;
ENDCASE => BEGIN Log.Error[noAccess]; BindError[] END;
END
ELSE
BEGIN
Log.ErrorTree[noVariants, tb[idNode].son[2]]; BindError[];
END;
PushTree[base];
IF indirect
THEN BEGIN PushNode[uparrow, 1]; SetAttr[2, long] END
ELSE PushNode[cast, 1];
discBase ← PopTree[];
END;
ENDCASE =>
BEGIN
Log.ErrorTree[noVariants, tb[idNode].son[2]]; BindError[];
discBase ← Tree.Null;
END;
ScanList[son[3], BindItem];
PushCommonCtx[]; phraseNP ← entryNP; son[4] ← selection[son[4]]; PopCtx[];
RPush[CSENull, attr];
passPtr.implicitType ← saveType; passPtr.implicitTree ← saveTree;
VRExit[];
END;


BindTest: PROCEDURE [t: Tree.Link, vCtx: CTXIndex] RETURNS [val: Tree.Link, vType: CSEIndex] =
BEGIN
mixed: BOOLEAN;

TestItem: Tree.Map =
BEGIN
subNode: Tree.Index;
iType: ISEIndex;
uType: CSEIndex;
found: BOOLEAN;
WITH t SELECT FROM
subtree =>
BEGIN subNode ← index;
SELECT tb[subNode].name FROM
relE =>
WITH tb[subNode].son[2] SELECT FROM
hash =>
BEGIN
[found, iType] ← SearchCtxList[index, vCtx];
IF found
THEN
BEGIN uType ← UnderType[iType];
tb[subNode].son[2] ← Tree.Link[symbol[index: iType]];
SELECT vType FROM
uType => NULL;
typeANY => vType ← uType;
ENDCASE => mixed ← TRUE;
END
ELSE
IF vCtx # CTXNull
THEN Log.ErrorHti[unknownVariant, index];
tb[subNode].info ← dataPtr.typeBOOLEAN;
tb[subNode].attr1 ← tb[subNode].attr2 ← FALSE;
v ← t;
END;
ENDCASE =>
BEGIN
v ← Rhs[t, dataPtr.typeBOOLEAN]; RPop[];
Log.ErrorTree[nonVariantLabel, t];
END;
ENDCASE =>
BEGIN
v ← Rhs[t, dataPtr.typeBOOLEAN]; RPop[];
Log.ErrorTree[nonVariantLabel, t];
END;
END;
ENDCASE => ERROR;
RETURN
END;

vType ← typeANY; mixed ← FALSE;
val ← UpdateList[t, TestItem];
IF mixed THEN vType ← typeANY;
RETURN
END;

END.