
<<Selection.mesa>>
<<last modified by Satterthwaite, March 26, 1986 3:37:53 pm PST>>

DIRECTORY
Alloc: TYPE USING [Notifier],
Code: TYPE USING [caseCVState, codeptr, mwCaseCV, xtracting],
CodeDefs: TYPE USING [
Base, CaseCVState, CCIndex, CCItem, codeType, JumpCCNull, LabelCCIndex, LabelCCNull,
Lexeme, NullLex, OtherCCIndex, OpWordCount, VarIndex, VarNull],
ComData: TYPE USING [typeBOOL],
FOpCodes: TYPE USING [qDIS, qGCRT, qLP, qREC],
P5: TYPE USING [
All, CallCatch, Construct, EnterBlock, ExitBlock, Exp, FlowTree, GenAnonLex, 
LogHeapFree, PurgePendTempList, PushLex, PushRhs, ReleaseTempLex, RowCons,
SAssign, StatementTree, SysCallN, VariantConstruct],
P5L: TYPE USING [
ComponentForLex, CopyLex, CopyToTemp, EasilyLoadable, FieldOfVarOnly, LoadVar,
NormalizeExp, NormalLex, OVarItem, ReleaseLex, ReleaseVarItem, ReusableCopies,
TOSLex, VarForLex],
P5S: TYPE USING [Assign],
P5U: TYPE USING [
CCellAlloc, EnumerateCaseArms, FreeChunk, InsertLabel, LabelAlloc, MakeLongTreeLiteral,
MakeTreeLiteral, MarkedType, NilTree, OperandType, Out0, OutJump, PushLitVal,
ReferentType, TreeLiteral, TreeLiteralValue, TypeForTree, VariantTag, WordsForOperand],
RTSD: TYPE USING [
sCheckForNarrowRefFault, sGetCanonicalProcType, sGetCanonicalSignalType,
sRaiseNarrowFault],
Stack: TYPE USING [Decr, DeleteToMark, Dump, Incr, Mark, Off, On, ResetToMark],
SymbolOps: TYPE USING [
RCType, TypeLink, UnderType, VariantField, WordsForType, XferMode],
Symbols: TYPE USING [Base, BTIndex, CSEIndex, ISEIndex, ISENull, SEIndex, seType],
SymLiteralOps: TYPE USING [TypeRef],
Tree: TYPE USING [Base, Index, Link, Map, NodeName, Null, Scan, treeType],
TreeOps: TYPE USING [
FreeTree, GetNode, GetSe, ListLength, MarkShared, OpName, PopTree,
PushNode, PushSe, PushTree, ScanList, SetAttr, SetInfo, UpdateList];

Selection: PROGRAM
IMPORTS MPtr: ComData, CPtr: Code, P5U, P5L, P5, P5S, 
Stack, SymbolOps, SymLiteralOps, TreeOps 
EXPORTS CodeDefs, P5 =
BEGIN
OPEN CodeDefs;


<<imported definitions>>

SEIndex: TYPE = Symbols.SEIndex;
ISEIndex: TYPE = Symbols.ISEIndex;
ISENull: ISEIndex = Symbols.ISENull;
CSEIndex: TYPE = Symbols.CSEIndex;
BTIndex: TYPE = Symbols.BTIndex;


tb: Tree.Base;        -- tree base (local copy)
seb: Symbols.Base;        -- semantic entry base (local copy)
cb: CodeDefs.Base;        -- code base (local copy)

SelectionNotify: PUBLIC Alloc.Notifier =
BEGIN  -- called by allocator whenever table area is repacked
seb _ base[Symbols.seType];
tb _ base[Tree.treeType];
cb _ base[codeType];
END;


CaseDriver: PROC [
node: Tree.Index,
isExp: BOOL,
item: PROC [
node: Tree.Index, isExp: BOOL, tempSei: ISEIndex, failLabel: LabelCCIndex]
RETURNS [VarIndex, ISEIndex],
endCaseLabel: LabelCCIndex _ LabelCCNull]
RETURNS [lex: Lexeme] =
BEGIN
caseEndLabel: LabelCCIndex = P5U.LabelAlloc[];
caseLPEndLabel: LabelCCIndex = P5U.LabelAlloc[];
nWords: CARDINAL =
IF isExp THEN OpWordCount[SymbolOps.WordsForType[tb[node].info]] ELSE 0;
longExpValue: BOOL;
valTsei: ISEIndex _ ISENull;

allConst: BOOL;
CheckConst: Tree.Scan = {allConst _ allConst AND P5U.TreeLiteral[t]};

CaseItem: Tree.Map =
BEGIN
failLabel: LabelCCIndex = P5U.LabelAlloc[];
long: BOOL _ FALSE;
r: VarIndex;
[r, valTsei] _ item[TreeOps.GetNode[t], isExp, valTsei, failLabel];
IF isExp THEN
BEGIN
[long: long, tsei: valTsei] _ P5L.NormalizeExp[r, valTsei, allConst];
Stack.ResetToMark[];
END;
P5U.OutJump[Jump, IF long THEN caseLPEndLabel ELSE caseEndLabel];
P5U.InsertLabel[failLabel];
RETURN [TreeOps.FreeTree[t]]
END;

IF isExp THEN {allConst _ TRUE;  P5U.EnumerateCaseArms[node, CheckConst]}
ELSE P5.PurgePendTempList[];

BEGIN
ENABLE P5.LogHeapFree => {RESUME [FALSE, NullLex]};
tb[node].son[2] _ TreeOps.FreeTree[TreeOps.UpdateList[tb[node].son[2], CaseItem]];
IF CPtr.caseCVState = singleLoaded THEN P5U.Out0[FOpCodes.qDIS];
IF endCaseLabel # LabelCCNull THEN P5U.InsertLabel[endCaseLabel];
IF isExp THEN
BEGIN
r: VarIndex;
long: BOOL;
[r, valTsei] _ CaseValue[tb[node].son[3], valTsei];
long _ P5L.NormalizeExp[r, valTsei, allConst].long;
P5U.OutJump[Jump, IF long THEN caseLPEndLabel ELSE caseEndLabel];
Stack.DeleteToMark[];
END
ELSE tb[node].son[3] _ P5.StatementTree[tb[node].son[3]];
END;

P5U.InsertLabel[caseEndLabel];
longExpValue _ cb[caseLPEndLabel].jumplist # JumpCCNull;
IF longExpValue THEN
{Stack.Off[]; P5U.Out0[FOpCodes.qLP]; Stack.On[]}; -- unreached if all arms long
P5U.InsertLabel[caseLPEndLabel];
IF valTsei # ISENull THEN P5.ReleaseTempLex[[se[valTsei]]];
IF isExp THEN
BEGIN
Stack.Incr[SELECT TRUE FROM
nWords <= 2 => nWords,
longExpValue => 2,
ENDCASE => 1];
lex _ P5L.NormalLex[nWords, longExpValue, allConst];
END
ELSE lex _ NullLex;
RETURN
END;

CaseValue: PROC [t: Tree.Link, oTsei: ISEIndex] RETURNS [r: VarIndex, tsei: ISEIndex] =
BEGIN
SetupTemp: PROC = {
IF tsei = ISENull THEN tsei _ P5.GenAnonLex[P5U.WordsForOperand[t]].lexsei};
tsei _ oTsei;
SELECT TreeOps.OpName[t] FROM
construct => {
SetupTemp[];
[] _ P5.Construct[[symbol[tsei]], TreeOps.GetNode[t], [init: TRUE]];
r _ P5L.VarForLex[[se[tsei]]]};
union => {
SetupTemp[];
P5.VariantConstruct[[symbol[tsei]], t, [init: TRUE]];
r _ P5L.VarForLex[[se[tsei]]]};
rowcons => {
SetupTemp[];
[] _ P5.RowCons[[symbol[tsei]], TreeOps.GetNode[t], [init: TRUE]];
r _ P5L.VarForLex[[se[tsei]]]};
all => {
SetupTemp[];
[] _ P5.All[[symbol[tsei]], TreeOps.GetNode[t], [init: TRUE]];
r _ P5L.VarForLex[[se[tsei]]]};
<<mergecons => ...>>
ENDCASE => r _ P5L.VarForLex[P5.Exp[t]];
END;


CaseStmtExp: PUBLIC PROC [rootNode: Tree.Index, isExp: BOOL] RETURNS [lex: Lexeme] =
BEGIN -- generate code for CASE statment and expression
cvSize: CARDINAL = P5U.WordsForOperand[tb[rootNode].son[1]];
saveMwCaseCV: Lexeme = CPtr.mwCaseCV;
saveExtracting: BOOL = CPtr.xtracting;
saveCaseCVState: CaseCVState = CPtr.caseCVState;
cvTlex: Lexeme.se _ NullLex;
cvr: VarIndex;
CPtr.xtracting _ FALSE;
IF isExp THEN Stack.Mark[];
cvr _ P5L.VarForLex[P5.Exp[tb[rootNode].son[1]
! P5.LogHeapFree => {RESUME [FALSE, NullLex]}]];
IF cvSize = 1 THEN {P5L.LoadVar[cvr]; CPtr.caseCVState _ singleLoaded}
ELSE
BEGIN
cvTlex _ P5.GenAnonLex[cvSize];
CPtr.mwCaseCV _ [bdo[P5L.OVarItem[P5L.CopyToTemp[cvr, cvTlex.lexsei].var]]];
CPtr.caseCVState _ multi;
END;
lex _ CaseDriver[rootNode, isExp, CaseItem];
IF cvTlex # NullLex THEN {P5.ReleaseTempLex[cvTlex]; P5L.ReleaseLex[CPtr.mwCaseCV]};
CPtr.mwCaseCV _ saveMwCaseCV;
CPtr.caseCVState _ saveCaseCVState;
CPtr.xtracting _ saveExtracting;
tb[rootNode].son[1] _ TreeOps.FreeTree[tb[rootNode].son[1]];
tb[rootNode].son[2] _ TreeOps.FreeTree[tb[rootNode].son[2]];
tb[rootNode].son[3] _ TreeOps.FreeTree[tb[rootNode].son[3]];
IF tb[rootNode].nSons > 3 THEN TreeOps.MarkShared[tb[rootNode].son[4], FALSE];
RETURN
END;

CaseItem: PROC [node: Tree.Index, isExp: BOOL, tempSei: ISEIndex, failLabel: LabelCCIndex]
RETURNS [r: VarIndex, tSei: ISEIndex] =
BEGIN -- generate code for a CASE item
IF tb[node].name = caseswitch THEN [r, tSei] _ Branch[node, isExp, tempSei, failLabel]
ELSE
BEGIN
tSei _ tempSei;
CaseTest[tb[node].son[1], failLabel];
IF isExp THEN [r, tempSei] _ CaseValue[tb[node].son[2], tempSei]
ELSE {
P5.PurgePendTempList[];
tb[node].son[2] _ P5.StatementTree[tb[node].son[2]]; r _ VarNull};
END;
RETURN
END;


CaseTest: PUBLIC PROC [t: Tree.Link, failLabel: LabelCCIndex] =
BEGIN
n: CARDINAL = TreeOps.ListLength[t];
IF n = 1 THEN P5.FlowTree[t, FALSE, failLabel]
ELSE
BEGIN
lastSon: CARDINAL = n-1;
thisSon: CARDINAL _ 0;
itemLabel: LabelCCIndex = P5U.LabelAlloc[];

Test: PROC [t: Tree.Link] =
BEGIN
IF thisSon # lastSon THEN {P5.FlowTree[t, TRUE, itemLabel]; thisSon _ thisSon+1}
ELSE {P5.FlowTree[t, FALSE, failLabel]; P5U.InsertLabel[itemLabel]};
END;

TreeOps.ScanList[t, Test];
END;
END;


BranchTable: TYPE = RECORD [SEQUENCE length: NAT OF LabelCCIndex];

NewBranches: PROC [
t: Tree.Link,
itemLabel, failLabel: LabelCCIndex,
bt: REF BranchTable]
RETURNS [new: BOOL] =
BEGIN -- sees if any new branches need to be added to branch table

AddEntry: PROC [t: Tree.Link] =
BEGIN
i: CARDINAL = P5U.TreeLiteralValue[t];
IF bt[i] = failLabel THEN {bt[i] _ itemLabel; new _ TRUE};
END;

new _ FALSE;  TreeOps.ScanList[t, AddEntry];
RETURN
END;

Branch: PROC [node: Tree.Index, isExp: BOOL, tempSei: ISEIndex, failLabel: LabelCCIndex]
RETURNS [r: VarIndex, tSei: ISEIndex] =
BEGIN -- generate code for case switch if range is densely packed
nWords, range, i: CARDINAL;
btcp, saveCodePtr: CCIndex;
valLabel, valLPLabel: LabelCCIndex;
bt: REF BranchTable;
first: BOOL _ TRUE;
allConst: BOOL;
longExp: BOOL;

LookForConst: Tree.Scan =
BEGIN -- t is a casetest node
WITH t SELECT FROM
subtree => allConst _ allConst AND P5U.TreeLiteral[tb[index].son[2]];
ENDCASE => ERROR;
END;

CaseItem: Tree.Map =
BEGIN
itemLabel: LabelCCIndex;
WITH t SELECT FROM
subtree =>
BEGIN -- is an item
bNode: Tree.Index = index;
long: BOOL _ FALSE;
itemLabel _ P5U.LabelAlloc[];
IF NewBranches[tb[bNode].son[1], itemLabel, failLabel, bt] THEN
BEGIN
P5U.InsertLabel[itemLabel];
IF isExp THEN
BEGIN
tr: VarIndex;
IF first THEN first _ FALSE ELSE Stack.ResetToMark[];
[tr, tSei] _ CaseValue[tb[bNode].son[2], tSei];
[nwords: nWords, long: long, tsei: tSei] _ P5L.NormalizeExp[tr, tSei, allConst];
END
ELSE tb[bNode].son[2] _ P5.StatementTree[tb[bNode].son[2]];
P5U.OutJump[Jump, IF long THEN valLPLabel ELSE valLabel];
END
ELSE P5U.FreeChunk[itemLabel, CCItem.label.SIZE];
END;
ENDCASE;
RETURN [TreeOps.FreeTree[t]]
END;

tSei _ tempSei;
IF isExp THEN {allConst _ TRUE; TreeOps.ScanList[tb[node].son[3], LookForConst]};
range _ P5U.TreeLiteralValue[tb[node].son[2]];
valLabel _ P5U.LabelAlloc[];
valLPLabel _ P5U.LabelAlloc[];
P5.PushRhs[tb[node].son[1]];
P5U.PushLitVal[range];
Stack.Decr[2];
P5U.CCellAlloc[other];
cb[LOOPHOLE[CPtr.codeptr, OtherCCIndex]].obody _ 
table[btab: , tableSize: range, taboffset: ];
btcp _ CPtr.codeptr;
P5U.OutJump[JumpCA, failLabel];
bt _ --(MPtr.zone).--NEW[BranchTable[range]];
FOR i IN [0..range) DO bt[i] _ failLabel ENDLOOP;
tb[node].son[3] _ TreeOps.FreeTree[TreeOps.UpdateList[tb[node].son[3], CaseItem]];
saveCodePtr _ CPtr.codeptr;
CPtr.codeptr _ btcp;
FOR i IN [0..range) DO P5U.OutJump[JumpC, bt[i]] ENDLOOP;
CPtr.codeptr _ saveCodePtr;
P5U.InsertLabel[valLabel];
longExp _ cb[valLPLabel].jumplist # JumpCCNull;
IF longExp THEN P5U.Out0[FOpCodes.qLP];
P5U.InsertLabel[valLPLabel];
--(MPtr.zone).--FREE[@bt];
IF isExp THEN RETURN [P5L.VarForLex[P5L.NormalLex[nWords, longExp, allConst]], tSei]
ELSE RETURN [VarNull, tSei];
END;


BindStmtExp: PUBLIC PROC [rootNode: Tree.Index, isExp: BOOL] RETURNS [lex: Lexeme] =
BEGIN -- discrimination with copying
saveMwCaseCV: Lexeme = CPtr.mwCaseCV;
saveExtracting: BOOL = CPtr.xtracting;
saveCaseCVState: CaseCVState = CPtr.caseCVState;
typeTemp: BOOL _ FALSE;
typeLex: Lexeme.se _ NullLex;
pushableTag: BOOL _ FALSE;
nItems: CARDINAL _ 0;
sourceType: CSEIndex = P5U.OperandType[tb[rootNode].son[1]];

BindItem: PROC [node: Tree.Index, isExp: BOOL, tempSei: ISEIndex, failLabel: LabelCCIndex]
RETURNS [r: VarIndex, tSei: ISEIndex] =
BEGIN
bti: BTIndex = tb[node].info;
subNode: Tree.Index = TreeOps.GetNode[tb[node].son[1]];
type: SEIndex = seb[TreeOps.GetSe[tb[subNode].son[1]]].idType;
indirect: BOOL = tb[node].attr1;
subType: SEIndex;
nItems _ nItems + 1;
tSei _ tempSei;
P5.EnterBlock[bti];
IF tb[rootNode].attr2 THEN
BEGIN
subType _ P5U.MarkedType[type];
IF tb[node].attr3    -- will destroy type code
AND typeLex = NullLex AND nItems < TreeOps.ListLength[tb[rootNode].son[2]] THEN
BEGIN
typeLex _ P5.GenAnonLex[1];
IF CPtr.caseCVState # singleLoaded THEN P5U.Out0[FOpCodes.qREC];
P5.SAssign[typeLex.lexsei];
CPtr.caseCVState _ single;
END;
IF tb[node].attr2 THEN
BEGIN
t: Tree.Link;
IF typeTemp THEN {PushCopy[typeLex]; CPtr.caseCVState _ singleLoaded};
TreeOps.PushTree[Tree.Null];
TreeOps.PushTree[SymLiteralOps.TypeRef[subType]];
TreeOps.PushNode[relE, 2];  TreeOps.SetInfo[MPtr.typeBOOL];  t _ TreeOps.PopTree[];
P5.FlowTree[t, FALSE, failLabel];  t _ TreeOps.FreeTree[t];
END
ELSE IF CPtr.caseCVState = singleLoaded THEN
BEGIN P5U.Out0[FOpCodes.qDIS]; CPtr.caseCVState _ single END;
pushableTag _ FALSE;
IF tb[node].attr3 THEN typeTemp _ TRUE;
END
ELSE subType _ IF indirect THEN P5U.ReferentType[sourceType] ELSE sourceType;
BEGIN
saveCVState: CaseCVState = CPtr.caseCVState;
CPtr.caseCVState _ multi;    -- the value being discriminated
IF tb[node].attr3 THEN
pushableTag _ TestTag[
type: subType,
target: IF indirect THEN P5U.ReferentType[type] ELSE type,
failLabel: failLabel,
indirect: indirect,
long: indirect AND SymbolOps.WordsForType[sourceType] # 1,
onStack: pushableTag];
P5S.Assign[subNode];
CPtr.caseCVState _ saveCVState;
END;
IF isExp THEN [r, tSei] _ CaseValue[tb[node].son[2], tSei]
ELSE {tb[node].son[2] _ P5.StatementTree[tb[node].son[2]];  r _ VarNull};
P5.ExitBlock[bti];
RETURN
END;

endCaseLabel: LabelCCIndex _ LabelCCNull;
CPtr.xtracting _ FALSE;
Stack.Dump[];
IF isExp THEN Stack.Mark[];
CPtr.mwCaseCV _ SelectArg[tb[rootNode].son[1], tb[rootNode].attr1];
SELECT TRUE FROM
tb[rootNode].attr2 =>
BEGIN
IF tb[rootNode].attr1 THEN
BEGIN
PushCopy[CPtr.mwCaseCV];  P5U.Out0[FOpCodes.qGCRT];
END
ELSE
BEGIN
Stack.Dump[]; Stack.Mark[];
PushCopy[CPtr.mwCaseCV];
P5.SysCallN[GetTypeEntry[sourceType], 1];
END;
CPtr.caseCVState _ singleLoaded;
END;
tb[rootNode].attr1 =>
BEGIN
t: Tree.Link _ NilPredicate[sourceType];
endCaseLabel _ P5U.LabelAlloc[];
CPtr.caseCVState _ multi;
P5.FlowTree[t, TRUE, endCaseLabel];  t _ TreeOps.FreeTree[t];
END;
ENDCASE;
lex _ CaseDriver[rootNode, isExp, BindItem, endCaseLabel];
IF typeLex # NullLex THEN P5.ReleaseTempLex[typeLex];
P5L.ReleaseLex[CPtr.mwCaseCV];
CPtr.mwCaseCV _ saveMwCaseCV;  CPtr.caseCVState _ saveCaseCVState;
CPtr.xtracting _ saveExtracting;
RETURN
END;


SelectArg: PROC [t: Tree.Link, indirect: BOOL] RETURNS [Lexeme] =
BEGIN
l: Lexeme;
r: VarIndex;
l _ P5.Exp[t ! P5.LogHeapFree => {RESUME [FALSE, NullLex]}];
IF indirect THEN r _ P5L.OVarItem[P5L.EasilyLoadable[P5L.ComponentForLex[l], load]]
ELSE
BEGIN
r1: VarIndex;
[first: r1, next: r] _ P5L.ReusableCopies[P5L.VarForLex[l], load, FALSE, TRUE];
P5L.ReleaseVarItem[r1];
END;
RETURN [[bdo[r]]]
END;

PushCopy: PROC [l: Lexeme] = {P5.PushLex[P5L.CopyLex[l]]};


TestTag: PROC [
type, target: SEIndex, failLabel: LabelCCIndex, indirect, long, onStack: BOOL]
RETURNS [pushable: BOOL] =
BEGIN  OPEN SymbolOps;
link: SEIndex = TypeLink[target];
subLink: CSEIndex = SymbolOps.UnderType[link];
uType: CSEIndex = SymbolOps.UnderType[seb[SymbolOps.VariantField[subLink]].idType];
IF SymbolOps.UnderType[type] # subLink THEN        -- discriminate to the link type
BEGIN
[] _ TestTag[type, link, failLabel, indirect, long, onStack];
onStack _ pushable _ FALSE;
END
ELSE pushable _ TRUE;        -- should force non-commutativity
WITH u: seb[uType] SELECT FROM
union =>
BEGIN OPEN TreeOps;
saveCVState: CaseCVState = CPtr.caseCVState;
tagSei: ISEIndex = u.tagSei;
t: Tree.Link;
PushTree[Tree.Null];
IF onStack THEN CPtr.caseCVState _ single
ELSE    -- CPtr.caseCVState = multi
BEGIN
IF indirect THEN {PushNode[uparrow, 1]; SetAttr[1, FALSE]; SetAttr[2, long]}
ELSE PushNode[cast, 1];
SetInfo[subLink];
PushSe[tagSei];  PushNode[dollar, 2];
SetInfo[SymbolOps.UnderType[seb[tagSei].idType]];  SetAttr[2, long];
END;
PushTree[P5U.MakeTreeLiteral[P5U.VariantTag[target, u.caseCtx]]];
PushNode[relE, 2];  SetInfo[MPtr.typeBOOL];
t _ PopTree[];  P5.FlowTree[t, FALSE, failLabel];  t _ FreeTree[t];
CPtr.caseCVState _ saveCVState;
END;
ENDCASE => ERROR;
RETURN
END;


TagPredicate: PROC [type, target: SEIndex, indirect, long: BOOL] RETURNS [Tree.Link] =
BEGIN OPEN SymbolOps, TreeOps;
link: SEIndex = TypeLink[target];
subLink: CSEIndex = SymbolOps.UnderType[link];
uType: CSEIndex = SymbolOps.UnderType[seb[SymbolOps.VariantField[subLink]].idType];
WITH u: seb[uType] SELECT FROM
union =>
BEGIN
tagSei: ISEIndex = u.tagSei;
PushTree[Tree.Null];
IF indirect THEN {PushNode[uparrow, 1]; SetAttr[1, FALSE]; SetAttr[2, long]}
ELSE PushNode[cast, 1];
SetInfo[subLink];
PushSe[tagSei];  PushNode[dollar, 2];
SetInfo[SymbolOps.UnderType[seb[tagSei].idType]];  SetAttr[2, long];
PushTree[P5U.MakeTreeLiteral[P5U.VariantTag[target, u.caseCtx]]];
PushNode[relE, 2];  SetInfo[MPtr.typeBOOL];
END;
ENDCASE => ERROR;
IF SymbolOps.UnderType[type] # subLink THEN        -- discriminate to the link type
BEGIN
PushTree[TagPredicate[type, link, indirect, long]];  PushNode[and, -2];
END;
RETURN [PopTree[]]
END;

TypePredicate: PROC [
source: CSEIndex, dest: SEIndex, node: Tree.Index] RETURNS [t: Tree.Link_Tree.Null] =
BEGIN OPEN TreeOps;    -- attrs, son[1] as in narrow, istype
indirect: BOOL = tb[node].attr1;
long: BOOL = indirect AND SymbolOps.WordsForType[source] = 2;
type: SEIndex;
IF tb[node].attr2 THEN
BEGIN
type _ P5U.MarkedType[dest];
PushTree[Tree.Null];
IF ~indirect THEN {PushNode[cast, 1]; SetInfo[source]};
PushNode[gcrt, 1];  SetAttr[2, indirect];
PushTree[SymLiteralOps.TypeRef[type]];
PushNode[relE, 2];  SetInfo[MPtr.typeBOOL];
t _ PopTree[];
END
ELSE type _ IF indirect THEN P5U.ReferentType[source] ELSE source;
IF tb[node].attr3 THEN
BEGIN
<<add NIL test here if not attr2?>>
PushTree[
TagPredicate[type, IF indirect THEN P5U.ReferentType[dest] ELSE dest, indirect, long]];
IF t # Tree.Null THEN {PushTree[t]; PushNode[and, -2]};
t _ PopTree[];
END;
RETURN
END;

NilPredicate: PROC [type: CSEIndex] RETURNS [Tree.Link] =
BEGIN OPEN TreeOps;
PushTree[Tree.Null];
PushTree[P5U.NilTree[type]];
PushNode[relE, 2];  SetInfo[MPtr.typeBOOL];
RETURN [PopTree[]]
END;

OrTest: PROC [t1, t2: Tree.Link] RETURNS [Tree.Link] =
BEGIN OPEN TreeOps;
PushTree[t1];  PushTree[t2];  PushNode[or, 2];  SetInfo[MPtr.typeBOOL];
RETURN [PopTree[]]
END;


NarrowExp: PUBLIC PROC [node: Tree.Index] RETURNS [l: Lexeme] =
BEGIN
saveMwCaseCV: Lexeme = CPtr.mwCaseCV;
saveExtracting: BOOL = CPtr.xtracting;
saveCaseCVState: CaseCVState = CPtr.caseCVState;
eLabel: LabelCCIndex = P5U.LabelAlloc[];
indirect: BOOL = tb[node].attr1;
sourceType: CSEIndex = P5U.OperandType[tb[node].son[1]];
targetType: SEIndex =
IF tb[node].son[2] # Tree.Null THEN P5U.TypeForTree[tb[node].son[2]] ELSE tb[node].info;
nWords: CARDINAL = SymbolOps.WordsForType[sourceType];
counted: BOOL = indirect AND (SymbolOps.RCType[sourceType] = simple);
t: Tree.Link;
CPtr.xtracting _ FALSE;
Stack.Dump[];  Stack.Mark[];
t _ TypePredicate[sourceType, targetType, node];
IF indirect # tb[node].attr2 THEN t _ OrTest[NilPredicate[sourceType], t];
CPtr.mwCaseCV _ SelectArg[tb[node].son[1], indirect];  CPtr.caseCVState _ multi;
IF indirect THEN PushCopy[CPtr.mwCaseCV];
P5.FlowTree[t, TRUE, eLabel];  t _ TreeOps.FreeTree[t];
IF indirect THEN
BEGIN
IF counted THEN
BEGIN
t _ SymLiteralOps.TypeRef[P5U.ReferentType[targetType], FALSE];
P5.PushRhs[t];  t _ TreeOps.FreeTree[t];
P5.SysCallN[RTSD.sCheckForNarrowRefFault, nWords];
END
ELSE P5.SysCallN[RTSD.sRaiseNarrowFault, nWords];
P5L.ReleaseLex[CPtr.mwCaseCV];
l _ P5L.TOSLex[nWords];
END
ELSE
BEGIN
len: CARDINAL = SymbolOps.WordsForType[SymbolOps.UnderType[targetType]];
P5.SysCallN[RTSD.sRaiseNarrowFault, 0];
IF len = nWords THEN l _ CPtr.mwCaseCV
ELSE    -- simulate a chop
BEGIN
r: VarIndex = P5L.VarForLex[CPtr.mwCaseCV];
P5L.FieldOfVarOnly[r: r, wSize: len];
l _ [bdo[r]];
END;
END;
CPtr.mwCaseCV _ saveMwCaseCV;  CPtr.caseCVState _ saveCaseCVState;
CPtr.xtracting _ saveExtracting;
P5.CallCatch[IF tb[node].nSons > 2 THEN tb[node].son[3] ELSE Tree.Null];
P5U.InsertLabel[eLabel];
RETURN
END;


TypeRel: PUBLIC PROC [node: Tree.Index, tf: BOOL, label: LabelCCIndex]  =
BEGIN
saveMwCaseCV: Lexeme = CPtr.mwCaseCV;
saveExtracting: BOOL = CPtr.xtracting;
saveCaseCVState: CaseCVState = CPtr.caseCVState;
sourceType: CSEIndex = P5U.OperandType[tb[node].son[1]];
t: Tree.Link;
CPtr.xtracting _ FALSE;
Stack.Dump[];
t _ TypePredicate[sourceType, P5U.TypeForTree[tb[node].son[2]], node];
IF tb[node].attr1 OR tb[node].attr2 THEN
t _ OrTest[NilPredicate[sourceType], t];
CPtr.mwCaseCV _ SelectArg[tb[node].son[1], tb[node].attr1];  CPtr.caseCVState _ multi;
P5.FlowTree[t, tf, label];  t _ TreeOps.FreeTree[t];
P5L.ReleaseLex[CPtr.mwCaseCV];
CPtr.mwCaseCV _ saveMwCaseCV;  CPtr.caseCVState _ saveCaseCVState;
CPtr.xtracting _ saveExtracting;
END;

GetCanonicalType: PUBLIC PROC [node: Tree.Index] RETURNS [Lexeme] =
BEGIN
IF tb[node].attr2 THEN
BEGIN
P5.PushRhs[tb[node].son[1]];  P5U.Out0[FOpCodes.qGCRT];
END
ELSE
BEGIN
Stack.Dump[]; Stack.Mark[];
P5.PushRhs[tb[node].son[1]];
P5.SysCallN[GetTypeEntry[P5U.OperandType[tb[node].son[1]]], 1];
END;
RETURN [P5L.TOSLex[1]]
END;

GetTypeEntry: PROC [type: CSEIndex] RETURNS [CARDINAL] =
BEGIN
RETURN [SELECT SymbolOps.XferMode[type] FROM
proc => RTSD.sGetCanonicalProcType,
signal, error => RTSD.sGetCanonicalSignalType,
ENDCASE => 0]
END;

END.

