-- Selection.mesa
-- last modified by Satterthwaite, January 11, 1983 4:57 pm
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, zone],
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, 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 {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: LONG POINTER TO 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: LONG POINTER TO 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];
SELECT SymbolOps.WordsForType[type] FROM
1 => PushTree[P5U.MakeTreeLiteral[0]];
2 =>
BEGIN
zeros: ARRAY [0..2) OF WORD ← [0, 0];
PushTree[P5U.MakeLongTreeLiteral[DESCRIPTOR[zeros], type]];
END;
ENDCASE => ERROR;
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.