-- Selection.mesa
-- last modified by Satterthwaite, January 7, 1983 10:54 am

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, OpWordCount, OtherCCIndex, VarComponent, VarIndex, VarNull],
  ComData: TYPE USING [typeBOOL, zone],
  FOpCodes: TYPE USING [qGCRT, qLP, qPOP, qPUSH],
  P5: TYPE USING [
    CallCatch, EnterBlock, ExitBlock, Exp, FlowTree, GenAnonLex, LogHeapFree,
    PurgePendTempList, PushLex, PushRhs, ReleaseTempLex, SAssign, StatementTree, SysCallN],
  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, 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.qPOP];
      IF endCaseLabel # LabelCCNull THEN P5U.InsertLabel[endCaseLabel];
      IF isExp THEN
	BEGIN
	r: VarIndex = P5L.VarForLex[P5.Exp[tb[node].son[3]]];
	long: BOOL = 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;


  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: se Lexeme ← 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 ← P5L.VarForLex[P5.Exp[tb[node].son[2]]]
      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: CARDINAL 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 ← P5L.VarForLex[P5.Exp[tb[bNode].son[2]]];
	      [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: , tablecodebytes: 3, 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: 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];
    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.