Selection:
PROGRAM
IMPORTS MPtr: ComData, CPtr: Code, CodeDefs, P5U, P5, SymbolOps, TreeOps
EXPORTS CodeDefs, P5 = BEGIN OPEN IntCodeDefs, CodeDefs;
imported definitions
SEIndex: TYPE = Symbols.SEIndex;
ISEIndex: TYPE = Symbols.ISEIndex;
ISENull: ISEIndex = Symbols.ISENull;
CSEIndex: TYPE = Symbols.CSEIndex;
BTIndex: TYPE = Symbols.BTIndex;
BitCount: TYPE = Symbols.BitCount;
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;
CaseStmtExp:
PUBLIC
PROC [rootNode: Tree.Index, isExp:
BOOL]
RETURNS [l: Node] =
BEGIN -- generate code for CASE statment and expression
saveCaseCV: Node = CPtr.caseCV;
saveExtracting: BOOL = CPtr.xtracting;
cvTemp: Var;
cvr: Node;
bits: BitCount;
cl: CodeList ← P5U.NewCodeList[];
armHead, armTail: CaseList ← NIL;
t3: Tree.Link ← tb[rootNode].son[3];
CaseArm: Tree.Scan = {
node: Tree.Index ← TreeOps.GetNode[t]; -- t is an item
tests: NodeList ← P5.ExpList[tb[node].son[1]].head;
t2: Tree.Link ← tb[node].son[2];
body: Node ← IF isExp THEN P5.Exp[t2] ELSE P5.StatementTree[t2];
arm: CaseList ← z.NEW[CaseListRep ← [tests: tests, body: body, rest: NIL]];
IF armTail = NIL THEN armHead ← arm ELSE armTail.rest ← arm;
armTail ← arm};
CPtr.xtracting ← FALSE;
cvr ← P5.Exp[tb[rootNode].son[1]];
cvTemp ← P5U.CreateTemp[cvr.bits].var;
P5U.Declare[cl, cvTemp, cvr];
CPtr.caseCV ← cvTemp;
TreeOps.ScanList[tb[rootNode].son[2], CaseArm];
IF t3 # Tree.Null
THEN {
ec: Node ← IF isExp THEN P5.Exp[t3] ELSE P5.StatementTree[t3];
other: CaseList ← z.NEW[CaseListRep ← [tests: NIL, body: ec, rest: NIL]];
IF armHead = NIL THEN armHead ← other ELSE armTail.rest ← other};
CPtr.caseCV ← saveCaseCV;
CPtr.xtracting ← saveExtracting;
IF armHead = NIL OR armHead.body = NIL THEN bits ← 0 ELSE bits ← armHead.body.bits;
l ← z.NEW[cond NodeRep ← [bits: bits, details: cond[armHead]]];
RETURN
END;
BindStmtExp:
PUBLIC
PROC [rootNode: Tree.Index, isExp:
BOOL]
RETURNS [l: Node] =
BEGIN -- discrimination with copying
saveExtracting: BOOL = CPtr.xtracting;
saveCaseCV: CaseCVState = CPtr.caseCV;
typeTemp: BOOL ← FALSE;
typeLex: se Lexeme ← 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.qPUSH];
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.qPOP]; 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 ← P5L.VarForLex[P5.Exp[tb[node].son[2]]]
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 [Node ←
NIL] =
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: Label] =
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 [l: Node] =
BEGIN
oper: Node;
IF tb[node].attr2 THEN oper ← P5U.CedarOpNode[referentType]
ELSE {
type: CSEIndex ← P5U.OperandType[tb[node].son[1]];
SELECT SymbolOps.XferMode[type]
FROM
proc => oper ← NIL; -- P5U.CedarOpNode[procType];
signal, error => oper ← NIL; -- P5U.CedarOpNode[signalType];
ENDCASE};
l ← P5U.ApplyOp[oper: oper, args: P5U.MakeNodeList[P5.Exp[tb[node].son[1]]], bits: WordSize];
END;
END.