-- file Pass3Xb.mesa
-- last modified by Satterthwaite, March 9, 1983 3:13 pm
-- last modified by Donahue,  9-Dec-81 15:32:12

DIRECTORY
  A3: TYPE USING [
    Bundling, CanonicalType, IdentifiedType, IndexType, MarkedType, NullableType,
    OperandInline, OrderedType, PermanentType, TargetType, TypeForTree, Unbundle],
  Alloc: TYPE USING [Notifier],
  ComData: TYPE USING [
    idCARDINAL, idTEXT, interface, ownSymbols,
    typeATOM, typeAtomRecord, typeBOOL, typeCHAR, typeINT, typeREAL, typeSTRING],
  LiteralOps: TYPE USING [FindHeapString],
  Log: TYPE USING [Error, ErrorHti, ErrorN, ErrorNode, ErrorSei, ErrorTree, Warning],
  P3: TYPE USING [
    Attr, emptyAttr, fullAttr, voidAttr,
    NarrowOp, NPUse, BoundNP, MergeNP, SequenceNP, TextForm, phraseNP,
    AddrOp, All, And, Apply, Assignment, Case, CatchPhrase, ClearRefStack,
    Discrimination, Dot, EnterType, Extract, Id, MakeLongType, MakeRefType,
    MiscXfer, Narrowing, Range, RecordMention, SealRefStack, SearchCtxList,
    TextRep, TypeAppl, TypeExp, UnsealRefStack],
  P3S: TYPE USING [ImplicitInfo, implicitRecord, safety, self],
  SymLiteralOps: TYPE USING [EnterAtom, EnterText],
  Symbols: TYPE USING [
    Base, HTIndex, SEIndex, ISEIndex, CSEIndex, RecordSEIndex, CSENull,
    RecordSENull, codeANY, codeCHAR, codeINT, typeANY, ctxType, seType],
  SymbolOps: TYPE USING [ConstantId, NormalType, RCType, TypeForm, TypeRoot, UnderType],
  Tree: TYPE USING [Base, Index, Link, Map, Null, NullIndex, treeType],
  TreeOps: TYPE USING [
    FreeNode, GetHash, GetNode, ListLength, PopTree, PushTree, PushNode,
    SetAttr, SetInfo, UpdateList],
  Types: TYPE USING [SymbolTableBase, Assignable, Equivalent];

Pass3Xb: PROGRAM
    IMPORTS
      A3, LiteralOps, Log, P3, P3S, SymLiteralOps, SymbolOps, TreeOps, Types,
      dataPtr: ComData
    EXPORTS P3, P3S = {
  OPEN SymbolOps, Symbols, TreeOps, A3, P3;

  tb: Tree.Base;	-- tree base address (local copy)
  seb: Base;	-- se table base address (local copy)
  ctxb: Base;	-- context table base address (local copy)

  own: Types.SymbolTableBase;
  zone: UNCOUNTED ZONE ← NIL;
  
  ExpBNotify: PUBLIC Alloc.Notifier = {
    -- called by allocator whenever table area is repacked
    seb ← base[seType];  ctxb ← base[ctxType];
    tb ← base[Tree.treeType]};


 -- intermediate result bookkeeping

  OperandDescriptor: TYPE = RECORD[
    type: CSEIndex,		-- type of operand
    attr: Attr];		-- attributes

  RStack: TYPE = RECORD [SEQUENCE length: NAT OF OperandDescriptor];
  rStack: LONG POINTER TO RStack ← NIL;
  rI: INTEGER;			-- index into rStack

  RPush: PUBLIC PROC [type: CSEIndex, attr: Attr] = {
    rI ← rI + 1;
    WHILE rI >= rStack.length DO
      newLength: NAT = rStack.length + 16;
      newStack: LONG POINTER TO RStack = zone.NEW[RStack[newLength]];
      FOR i: INTEGER IN [0 .. rI) DO newStack[i] ← rStack[i] ENDLOOP;
      zone.FREE[@rStack];
      rStack ← newStack;
      ENDLOOP;
    rStack[rI] ← [type:type, attr:attr]};

  RPop: PUBLIC PROC = {IF rI < 0 THEN ERROR; rI ← rI-1};

  RType: PUBLIC PROC RETURNS [CSEIndex] = {RETURN [rStack[rI].type]};

  RAttr: PUBLIC PROC RETURNS [Attr] = {RETURN [rStack[rI].attr]};

  longUnsigned: CSEIndex;	-- a hint for mwconst

  textType: ARRAY TextForm OF CSEIndex;		-- a hint for text literals

  ExpInit: PUBLIC PROC [scratchZone: UNCOUNTED ZONE] = {
    zone ← scratchZone;
    implicit ← [type: typeANY, tree: Tree.Null, attr: emptyAttr];
    P3S.implicitRecord ← RecordSENull;
    own ← dataPtr.ownSymbols;	-- make a parameter?
    longUnsigned ← CSENull;  textType ← ALL[CSENull];
    rStack ← zone.NEW[RStack[32]];
    rI ← -1};
    
  ExpReset: PUBLIC PROC = {
    IF rStack # NIL THEN zone.FREE[@rStack];
    zone ← NIL};


 -- type manipulation

  EqualTypes: PROC [type1, type2: CSEIndex] RETURNS [BOOL] = {
    RETURN [Types.Equivalent[[own, type1], [own, type2]]]};
    
    
  UnresolvedTypes: SIGNAL RETURNS [CSEIndex] = CODE;

  BalanceTypes: PROC [type1, type2: CSEIndex] RETURNS [type: CSEIndex] = {
    n1, n2: CARDINAL;
    SELECT TRUE FROM
      (type1 = type2), (type2 = typeANY) => type ← type1;
      (type1 = typeANY) => type ← type2;
      ENDCASE => {
	n1 ← Bundling[type1];
	n2 ← Bundling[type2];
	WHILE n1 > n2 DO type1 ← Unbundle[LOOPHOLE[type1]]; n1 ← n1-1 ENDLOOP;
	WHILE n2 > n1 DO type2 ← Unbundle[LOOPHOLE[type2]]; n2 ← n2-1 ENDLOOP;
	-- check bundling
	DO
	  type1 ← TargetType[type1];
	  type2 ← TargetType[type2];
	  SELECT TRUE FROM
	    Types.Assignable[[own, type1], [own, type2]] => {type ← type1; EXIT};
	    Types.Assignable[[own, type2], [own, type1]] => {type ← type2; EXIT};
	    ENDCASE;
	  IF n1 = 0 THEN GO TO Fail;
	  n1 ← n1-1;
	  type1 ← Unbundle[LOOPHOLE[type1]];
	  type2 ← Unbundle[LOOPHOLE[type2]];
	  REPEAT
	    Fail => type ← SIGNAL UnresolvedTypes;
	  ENDLOOP};
    RETURN};

  ForceType: PUBLIC PROC [t: Tree.Link, type: CSEIndex] RETURNS [Tree.Link] = {
    PushTree[t];
    IF t = Tree.Null THEN PushNode[cast, 1]
    ELSE WITH t SELECT FROM
      subtree =>
	SELECT tb[index].name FROM
	  construct, union, rowcons => PushNode[cast, 1];
	  openx => PushNode[cast, 1];
	  ENDCASE;
      ENDCASE => PushNode[cast, 1];
    SetInfo[type];  RETURN [PopTree[]]};


 -- operators
 
  UpArrow: PUBLIC PROC [node: Tree.Index] = {
    OPEN tb[node];
    type, nType: CSEIndex;
    attr: Attr;
    son[1] ← Exp[son[1], typeANY];
    type ← RType[];  attr ← RAttr[];  RPop[];  attr.const ← FALSE;
    DO
      nType ← NormalType[type];
      WITH t: seb[nType] SELECT FROM
	ref => {
	  RPush[UnderType[t.refType], attr];
	  attr2 ← seb[type].typeTag = long;
	  IF P3S.safety = checked AND ~(t.counted OR PermanentType[t.refType]) THEN
	    Log.ErrorNode[unsafeOperation, node];
	  EXIT};
	record => {
	  IF Bundling[nType] = 0 THEN GO TO fail;
	  type ← Unbundle[LOOPHOLE[nType, RecordSEIndex]]};
	ENDCASE => GO TO fail;
      REPEAT
	fail => {
	  IF type # typeANY THEN Log.ErrorTree[typeClash, son[1]];
	  RPush[typeANY, attr]};
      ENDLOOP};


 -- arithmetic expression manipulation

  MakeNumeric: PROC [type: CSEIndex] RETURNS [CSEIndex] = {
    RETURN [SELECT seb[type].typeTag FROM
      long => MakeLongType[dataPtr.typeINT, type],
      ENDCASE => dataPtr.typeINT]};

  EvalNumeric: PROC [t: Tree.Link] RETURNS [val: Tree.Link] = {
    val ← GenericRhs[t, dataPtr.typeINT];
    SELECT NormalType[rStack[rI].type] FROM
      dataPtr.typeINT => NULL;
      typeANY => rStack[rI].type ← MakeNumeric[rStack[rI].type];
      ENDCASE => Log.ErrorTree[typeClash, val];
    RETURN};

  ArithOp: PROC [node: Tree.Index] = {
    OPEN tb[node];
    saveNP: NPUse;
    son[1] ← EvalNumeric[son[1]];  saveNP ← phraseNP;
    son[2] ← EvalNumeric[son[2]]; 
    BalanceAttributes[node];
    rStack[rI-1].attr ← And[rStack[rI-1].attr, rStack[rI].attr];
    IF attr1 THEN rStack[rI-1].attr.const ← FALSE;
    RPop[];  phraseNP ← MergeNP[saveNP][phraseNP]};


  ArithType: PROC [type: CSEIndex] RETURNS [CSEIndex] = {
    type ← NormalType[type];
    RETURN [WITH seb[type] SELECT FROM
      relative => NormalType[UnderType[offsetType]],
      ENDCASE => type]};

  Plus: PROC [node: Tree.Index] = {
    OPEN tb[node];
    type: CSEIndex;
    lr: BOOL;
    saveNP: NPUse;
    son[1] ← GenericRhs[son[1], typeANY];  saveNP ← phraseNP;
    type ← ArithType[rStack[rI].type];
    IF seb[type].typeTag = ref OR type = dataPtr.typeCHAR THEN {
      IF RCType[type] # none THEN Log.ErrorTree[typeClash, son[1]];
      lr ← TRUE; son[2] ← EvalNumeric[son[2]]}
    ELSE {
      SELECT type FROM
	dataPtr.typeINT, typeANY => NULL;
	ENDCASE => Log.ErrorTree[typeClash, son[1]];
      son[2] ← GenericRhs[son[2], typeANY];
      lr ← FALSE;  type ← ArithType[rStack[rI].type];
      SELECT TRUE FROM
	type = dataPtr.typeINT, type = dataPtr.typeCHAR => NULL;
	seb[type].typeTag = ref =>
	  IF RCType[type] # none THEN Log.ErrorTree[typeClash, son[2]];
	ENDCASE => {
	  IF type # typeANY THEN Log.ErrorTree[typeClash, son[2]];
	  rStack[rI].type ← MakeNumeric[rStack[rI].type]}};
    IF P3S.safety = checked AND seb[type].typeTag = ref THEN
      Log.ErrorNode[unsafeOperation, node];
    BalanceAttributes[node];
    rStack[rI-1].attr ← And[rStack[rI-1].attr, rStack[rI].attr];
    IF attr1 THEN rStack[rI-1].attr.const ← FALSE;
    IF ~lr THEN rStack[rI-1].type ← rStack[rI].type;
    RPop[];  phraseNP ← MergeNP[saveNP][phraseNP]};

  Minus: PROC [node: Tree.Index] = {
    OPEN tb[node];
    type, lType, rType: CSEIndex;
    lr: BOOL;
    saveNP: NPUse;
    son[1] ← GenericRhs[son[1], typeANY];  saveNP ← phraseNP;
    type ← NormalType[rStack[rI].type]; lType ← ArithType[type];  lr ← TRUE;
    IF seb[lType].typeTag = ref OR lType = dataPtr.typeCHAR THEN {
      IF RCType[lType] # none THEN Log.ErrorTree[typeClash, son[1]];
      son[2] ← GenericRhs[son[2], typeANY];  rType ← ArithType[rStack[rI].type];
      SELECT TRUE FROM
	rType = typeANY => NULL;
	Types.Equivalent[[own, lType], [own, rType]] => lr ← FALSE;
	rType = dataPtr.typeINT => NULL;
	ENDCASE => Log.ErrorTree[typeClash, son[2]]}
    ELSE {
      SELECT type FROM
	dataPtr.typeINT, typeANY => NULL;
	ENDCASE => {Log.ErrorTree[typeClash, son[1]]; rStack[rI].type ← typeANY};
      son[2] ← EvalNumeric[son[2]]};
    IF P3S.safety = checked AND seb[lType].typeTag = ref THEN
      Log.ErrorNode[unsafeOperation, node];
    BalanceAttributes[node];
    rStack[rI-1].attr ← And[rStack[rI-1].attr, rStack[rI].attr];
    IF attr1 THEN rStack[rI-1].attr.const ← FALSE;
    IF ~lr THEN rStack[rI-1].type ←
      IF attr2 THEN MakeLongType[dataPtr.typeINT, rStack[rI].type] ELSE dataPtr.typeINT;
    RPop[];  phraseNP ← MergeNP[saveNP][phraseNP]};

  UnaryOp: PROC [node: Tree.Index] = {
    IF UniOperand[node] THEN {
      tb[node].son[1] ← EvalNumeric[tb[node].son[1]];  SetAttributes[node];
      IF tb[node].attr1 THEN rStack[rI].attr.const ← FALSE}};

  EnumOp: PROC [node: Tree.Index, target: CSEIndex] = {
    IF UniOperand[node] THEN {
      tb[node].son[1] ← GenericRhs[tb[node].son[1], target];  SetAttributes[node];
      IF ~IndexType[RType[]] THEN Log.ErrorTree[typeClash, tb[node].son[1]]}};

  RelOp: PROC [node: Tree.Index, ordered: BOOL] = {
    OPEN tb[node];
    type: CSEIndex;
    attr: Attr;
    saveNP: NPUse;
    implicitOp: BOOL;
    son[1] ← GenericRhs[son[1], typeANY];  saveNP ← phraseNP; 
    type ← NormalType[RType[]];  attr ← RAttr[];
    implicitOp ← (son[1] = Tree.Null);
    son[2] ← GenericRhs[son[2], type];
    type ← BalanceTypes[type, NormalType[RType[]]
      ! UnresolvedTypes => {Log.ErrorTree[typeClash, son[2]]; RESUME [typeANY]}];
    IF (ordered AND ~OrderedType[type]) OR (~ordered AND ~IdentifiedType[type]) THEN
      Log.ErrorNode[relationType, node];
    BalanceAttributes[node];
    attr ← And[attr, RAttr[]];
    IF implicitOp AND son[1] # Tree.Null THEN Log.ErrorTree[typeClash, son[2]];
    SELECT seb[type].typeTag FROM
      basic, enumerated => NULL;
      transfer => {
	IF OperandInline[son[1]] THEN Log.ErrorTree[misusedInline, son[1]];
	IF OperandInline[son[2]] THEN Log.ErrorTree[misusedInline, son[2]];
	attr.const ← FALSE};
      real => attr.const ← FALSE;
      ENDCASE;
    RPop[];  RPop[];
    RPush[dataPtr.typeBOOL, attr];  phraseNP ← MergeNP[saveNP][phraseNP]};

  In: PROC [node: Tree.Index] = {
    OPEN tb[node];
    type: CSEIndex;
    saveNP: NPUse;
    son[1] ← GenericRhs[son[1], typeANY];  saveNP ← phraseNP;
    type ← RType[];
    son[2] ← Range[son[2], CanonicalType[type]];
    [] ← BalanceTypes[NormalType[type], NormalType[RType[]]
      ! UnresolvedTypes => {Log.ErrorTree[typeClash, tb[node].son[1]]; RESUME [typeANY]}];
    BalanceAttributes[node];
    rStack[rI-1].attr ← And[rStack[rI-1].attr, rStack[rI].attr];  RPop[];
    rStack[rI].type ← dataPtr.typeBOOL;
    phraseNP ← MergeNP[saveNP][phraseNP]};

  BoolOp: PROC [node: Tree.Index] = {
    OPEN tb[node];
    attr: Attr;
    saveNP: NPUse;
    SealRefStack[];
    son[1] ← Rhs[son[1], dataPtr.typeBOOL]; attr ← RAttr[]; saveNP ← phraseNP; 
    ClearRefStack[];
    son[2] ← Rhs[son[2], dataPtr.typeBOOL]; 
    UnsealRefStack[];
    attr ← And[attr, RAttr[]];
    RPop[];  RPop[];
    RPush[dataPtr.typeBOOL, attr]; phraseNP ← SequenceNP[saveNP][phraseNP]};


  Interval: PUBLIC PROC [t: Tree.Link, target: CSEIndex, constant: BOOL] = {
    node: Tree.Index = GetNode[t];
    type: CSEIndex;
    attr: Attr;
    saveNP: NPUse;
    target ← TargetType[target];
    tb[node].son[1] ← BalancedRhs[tb[node].son[1], target];  saveNP ← phraseNP;
    type ← rStack[rI].type ← CanonicalType[rStack[rI].type];  attr ← RAttr[];
    IF constant AND ~attr.const THEN Log.ErrorTree[nonConstant, tb[node].son[1]];
    tb[node].son[2] ← BalancedRhs[tb[node].son[2], target];  
    rStack[rI].type ← CanonicalType[rStack[rI].type];
    [] ← BalanceTypes[NormalType[type], NormalType[RType[]]
      ! UnresolvedTypes => {Log.ErrorTree[typeClash, tb[node].son[2]]; RESUME [typeANY]}];
    attr ← And[attr, RAttr[]];
    IF constant AND ~RAttr[].const THEN Log.ErrorTree[nonConstant, tb[node].son[2]];
    BalanceAttributes[node];
    IF tb[node].attr1 THEN attr.const ← FALSE;
    phraseNP ← MergeNP[saveNP][phraseNP];
    RPop[]; rStack[rI].attr ← attr};


  BalancedTarget: PROC [target, type: CSEIndex] RETURNS [CSEIndex] = {
    RETURN [IF target = typeANY
	OR (~EqualTypes[type, target] AND NormalType[type] = target)
      THEN TargetType[type]
      ELSE target]};

  ResolveTypes: PROC [type1, type2, target: CSEIndex, t: Tree.Link]
      RETURNS [type: CSEIndex] = {
    failed: BOOL;
    IF target = typeANY THEN failed ← TRUE
    ELSE {
      ENABLE UnresolvedTypes => {failed ← TRUE; RESUME [typeANY]};
      failed ← FALSE;
      type1 ← BalanceTypes[target, type1];
      type2 ← BalanceTypes[target, type2];
      type ← BalanceTypes[type1, type2]};
    IF failed THEN {Log.ErrorTree[typeClash, t]; type ← typeANY};
    RETURN};

  IfExp: PROC [node: Tree.Index, target: CSEIndex] = {
    OPEN tb[node];
    type: CSEIndex;
    attr: Attr;
    entryNP, saveNP: NPUse;
    SealRefStack[];
    son[1] ← Rhs[son[1], dataPtr.typeBOOL]; 
    attr ← RAttr[];  RPop[];  entryNP ← phraseNP;
    UnsealRefStack[];
    son[2] ← BalancedRhs[son[2], target];
    attr ← And[attr, RAttr[]]; saveNP ← SequenceNP[entryNP][phraseNP];
    type ← RType[];  RPop[];
    target ← BalancedTarget[target, type];
    son[3] ← BalancedRhs[son[3], target];  attr ← And[attr, RAttr[]];
    type ← BalanceTypes[type, RType[]
	! UnresolvedTypes => {RESUME [ResolveTypes[type, RType[], target, son[3]]]}];
    IF seb[type].typeTag = transfer THEN {
      IF OperandInline[son[2]] THEN Log.ErrorTree[misusedInline, son[2]];
      IF OperandInline[son[3]] THEN Log.ErrorTree[misusedInline, son[3]];
      attr.const ← FALSE};
    phraseNP ← BoundNP[saveNP][SequenceNP[entryNP][phraseNP]];
    RPop[];  RPush[type, attr]};

  SelectExp: PROC [
      node: Tree.Index, target: CSEIndex,
      driver: PROC [Tree.Index, Tree.Map], foldable: BOOL] = {
    type: CSEIndex;
    attr: Attr;
    saveNP: NPUse;
    started: BOOL;

    Selection: Tree.Map = {
      subType: CSEIndex;
      entryNP: NPUse = phraseNP;
      v ← BalancedRhs[t, target];
      subType ← BalanceTypes[type, RType[]
	! UnresolvedTypes => {RESUME [ResolveTypes[type, RType[], target, v]]}];
      IF seb[subType].typeTag = transfer AND OperandInline[v] THEN
        Log.ErrorTree[misusedInline, v];
      saveNP ← BoundNP[saveNP][SequenceNP[entryNP][phraseNP]];
      IF subType # typeANY THEN type ← subType;
      IF ~started THEN target ← BalancedTarget[target, type];
      attr ← And[attr, RAttr[]];  RPop[];  started ← TRUE;  RETURN};

    type ← typeANY;  attr ← fullAttr;  started ← FALSE;  saveNP ← none;
    driver[node, Selection];  attr ← And[attr, RAttr[]];  RPop[];
    attr.const ← foldable AND attr.const AND tb[node].attr2;
    RPush[type, attr];  phraseNP ← saveNP};


  MinMax: PROC [node: Tree.Index, target: CSEIndex] = {
    OPEN tb[node];
    attr: Attr;
    saveNP: NPUse;
    started: BOOL;
    type: CSEIndex;
    
    SubMinMax: Tree.Map = {
      subType: CSEIndex;
      v ← BalancedRhs[t, target];
      attr ← And[attr, RAttr[]];  saveNP ← MergeNP[saveNP][phraseNP];
      subType ← CanonicalType[RType[]]; 
      subType ← BalanceTypes[subType, type 
		! UnresolvedTypes => {RESUME[ResolveTypes[subType, type, target, v]]}];
      IF type # subType AND subType # typeANY THEN {
	IF ~OrderedType[subType] THEN Log.ErrorNode[relationType, node];
	type ← subType;
	IF ~started THEN target ← BalancedTarget[target, type]};
      RPop[];  started ← TRUE;  RETURN};

    attr ← fullAttr;  saveNP ← none;  started ← FALSE;  type ← typeANY;
    son[1] ← UpdateList[son[1], SubMinMax];
    SELECT seb[type].typeTag FROM
      long => {attr1 ← FALSE; attr2 ← TRUE};
      real => {attr1 ← TRUE; attr2 ← FALSE; attr.const ← FALSE};
      ENDCASE => attr1 ← attr2 ← FALSE;
    RPush[type, attr];  phraseNP ← saveNP};


  TypeTest: PROC [node: Tree.Index, from, to: CSEIndex] = {
    subType: CSEIndex = CanonicalType[from];
    op: NarrowOp = Narrowing[type: subType, target: to];
    SELECT TRUE FROM
      op.error => Log.ErrorTree[typeClash, tb[node].son[1]];
      op.computed => Log.ErrorTree[missingBinding, tb[node].son[1]];
      op.unImpl => Log.Warning[unimplemented];
      ENDCASE;
    IF subType # from THEN tb[node].son[1] ← ForceType[tb[node].son[1], subType];
    tb[node].attr1 ← op.indirect;
    IF (tb[node].attr2 ← op.rtTest) THEN EnterType[MarkedType[to]];
    tb[node].attr3 ← op.tagTest};
    
    
  EndPoint: PROC [node: Tree.Index] = {
    OPEN tb[node];
    type: CSEIndex;
    son[1] ← TypeExp[son[1]];
    type ← UnderType[TypeForTree[son[1]]];
      BEGIN
      WITH seb[type] SELECT FROM
	basic =>
	  SELECT code FROM
	    codeINT, codeCHAR => NULL;
	    ENDCASE => GO TO fail;
        enumerated => NULL;
	relative => IF TypeForm[offsetType] # subrange THEN GO TO fail;
        subrange => NULL;
	long =>
	  IF NormalType[UnderType[rangeType]] # dataPtr.typeINT THEN GO TO fail;
        ENDCASE => GO TO fail;
      EXITS
	fail => Log.ErrorTree[typeClash, son[1]];
      END;
    RPush[type, fullAttr]};


  Unspec: PROC [type: CSEIndex] RETURNS [BOOL] = {
    RETURN [WITH t: seb[type] SELECT FROM
      basic => t.code = codeANY,
      ENDCASE => FALSE]};
      
  SafeForUnspec: PROC [target: CSEIndex] RETURNS [BOOL] = {
    RETURN [P3S.safety # checked OR RCType[target] = none]};
    
      
  Rhs: PUBLIC PROC [exp: Tree.Link, lhsType: CSEIndex] RETURNS [val: Tree.Link] = {
    rhsType: CSEIndex;
    val ← Exp[exp, lhsType];
    rhsType ← rStack[rI].type;
    SELECT TRUE FROM
      (lhsType = rhsType), Unspec[lhsType] => NULL;
      ENDCASE => {  -- immediate matching is inconclusive
	UNTIL Types.Assignable[[own, lhsType], [own, rhsType]] DO
	  WITH t: seb[rhsType] SELECT FROM
	    subrange => rhsType ← UnderType[t.rangeType];
	    record => {
	      IF Bundling[rhsType] = 0 THEN GO TO nomatch;
	      rhsType ← Unbundle[LOOPHOLE[rhsType, RecordSEIndex]];
	      val ← ForceType[val, IF Unspec[rhsType] THEN typeANY ELSE rhsType]};
	    ref, arraydesc => {
	      SELECT seb[lhsType].typeTag FROM
		long => {
		  IF ~Types.Assignable[[own, NormalType[lhsType]], [own, rhsType]] THEN
		    GO TO nomatch;
		  val ← Lengthen[val, lhsType]};
		ENDCASE => GO TO nomatch;
	      rhsType ← lhsType};
	    basic => {
	      IF Unspec[rhsType] AND SafeForUnspec[lhsType] THEN
		SELECT seb[lhsType].typeTag FROM
		  long => val ← Lengthen[val, MakeLongType[typeANY, lhsType]];
		  ENDCASE
	      ELSE SELECT seb[lhsType].typeTag FROM
		long => {
		  IF ~Types.Assignable[[own, NormalType[lhsType]], [own, rhsType]] THEN
		    GO TO nomatch;
		  val ← Lengthen[val, lhsType]};
		real =>
		  IF rhsType = dataPtr.typeINT THEN {
		    val ← Float[val, rhsType, lhsType]; rStack[rI].attr.const ← FALSE} 
		  ELSE GO TO nomatch;
		ENDCASE => GO TO nomatch;
	      rhsType ← lhsType};
	    long => {
	      subType: CSEIndex = NormalType[rhsType];
	      SELECT seb[lhsType].typeTag FROM
		long =>
		  SELECT TRUE FROM
		    Unspec[NormalType[lhsType]] => lhsType ← rhsType;
		    Unspec[subType] AND SafeForUnspec[lhsType] =>
		      rhsType ← lhsType;
		    ENDCASE => GO TO nomatch;
		real =>
		  IF subType = dataPtr.typeINT THEN {
		    val ← Float[val, rhsType, lhsType];  rStack[rI].attr.const ← FALSE;
		    rhsType ← lhsType} 
		  ELSE GO TO nomatch;
		basic, subrange => {
		  IF ~Types.Assignable[[own, subType], [own, lhsType]] THEN
		    GO TO nomatch;
		  rhsType ← UnderType[t.rangeType]; val ← Shorten[val, rhsType]};
		enumerated =>
		  IF EqualTypes[rhsType, dataPtr.typeATOM] THEN {
		    Log.ErrorTree[missingCoercion, val];  rhsType ← lhsType}
		  ELSE GOTO nomatch;
		ENDCASE => GO TO nomatch};
	    ENDCASE => GO TO nomatch;
	  REPEAT
	    nomatch => {	-- no coercion is possible
	      Log.ErrorTree[typeClash,
		IF exp = Tree.Null THEN implicit.tree ELSE val];
	      rhsType ← lhsType};
	  ENDLOOP;
	rStack[rI].type ← rhsType};
    IF seb[rhsType].typeTag = transfer AND OperandInline[val] THEN
      Log.ErrorTree[misusedInline, val];
    RETURN};


  GenericRhs: PROC [exp: Tree.Link, target: CSEIndex] RETURNS [val: Tree.Link] = {
    type: CSEIndex;
    val ← Exp[exp, target];  type ← rStack[rI].type;
    -- put value in canonical form
    DO
      WITH seb[type] SELECT FROM
	subrange => type ← UnderType[rangeType];
	record => {
	  IF Bundling[type] = 0 THEN EXIT;
	  type ← Unbundle[LOOPHOLE[type, RecordSEIndex]];
	  val ← ForceType[val, type]};
	ENDCASE => EXIT;
      rStack[rI].type ← type;
      ENDLOOP;
    SELECT seb[target].typeTag FROM
      enumerated =>
        IF EqualTypes[type, dataPtr.typeATOM] THEN {
          Log.ErrorTree[missingCoercion, val];  rStack[rI].type ← target};
      ENDCASE;
    RETURN};

  BalancedRhs: PROC [exp: Tree.Link, target: CSEIndex] RETURNS [val: Tree.Link] = {
    type: CSEIndex;
    val ← Exp[exp, target];
    SELECT seb[target].typeTag FROM
      long, real => {
	type ← CanonicalType[rStack[rI].type];
	IF type # typeANY AND seb[target].typeTag # seb[type].typeTag
	 AND EqualTypes[NormalType[target], type] THEN {
	  SELECT seb[target].typeTag FROM
	    long => IF seb[type].typeTag # real THEN val ← Lengthen[val, target];
	    real => {val ← Float[val, type, target]; rStack[rI].attr.const ← FALSE};
	    ENDCASE;
	  rStack[rI].type ← target}};
      enumerated =>
        IF EqualTypes[rStack[rI].type, dataPtr.typeATOM] THEN {
          Log.ErrorTree[missingCoercion, val];  rStack[rI].type ← target};
      ENDCASE;
    RETURN};


  AttrClass: PROC [type: CSEIndex] RETURNS [{short, long, real}] = {
    RETURN [WITH t: seb[type] SELECT FROM
      long => long,
      real => real,
      relative => AttrClass[UnderType[t.offsetType]],
      ENDCASE => short]};

  SetAttributes: PROC [node: Tree.Index] = {
    SELECT AttrClass[rStack[rI].type] FROM
      long => {tb[node].attr1 ← FALSE; tb[node].attr2 ← TRUE};
      real => {tb[node].attr1 ← TRUE; tb[node].attr2 ← FALSE};
      ENDCASE => tb[node].attr1 ← tb[node].attr2 ← FALSE};

  BalanceAttributes: PROC [node: Tree.Index] = {
    lType, rType: CSEIndex;
    lType ← rStack[rI-1].type;  rType ← rStack[rI].type;
    SELECT AttrClass[lType] FROM
      long => {
	SELECT AttrClass[rType] FROM
	  long => {tb[node].attr1 ← FALSE; tb[node].attr2 ← TRUE};
	  real => {
	    rStack[rI-1].type ← rType;
	    tb[node].son[1] ← Float[tb[node].son[1], lType, rType];
	    rStack[rI-1].attr.const ← FALSE;
	    tb[node].attr1 ← TRUE;  tb[node].attr2 ← FALSE};
	  ENDCASE => {
	    rStack[rI].type ← rType ← MakeLongType[rType, lType];
	    tb[node].son[2] ← Lengthen[tb[node].son[2], rType];
	    tb[node].attr1 ← FALSE;  tb[node].attr2 ← TRUE}};
      real => {
	tb[node].attr1 ← TRUE;  tb[node].attr2 ← FALSE;
	SELECT AttrClass[rType] FROM
	  real => NULL;
	  ENDCASE => {
	    rStack[rI].type ← lType;
	    tb[node].son[2] ← Float[tb[node].son[2], rType, lType];
	    rStack[rI].attr.const ← FALSE}};
      ENDCASE =>
	SELECT AttrClass[rType] FROM
	  long => {
	    rStack[rI-1].type ← lType ← MakeLongType[lType, rType];
	    tb[node].son[1] ← Lengthen[tb[node].son[1], lType];
	    tb[node].attr1 ← FALSE;  tb[node].attr2 ← TRUE};
	  real => {
	    rStack[rI-1].type ← rType;
	    tb[node].son[1] ← Float[tb[node].son[1], lType, rType];
	    rStack[rI-1].attr.const ← FALSE;
	    tb[node].attr1 ← TRUE;  tb[node].attr2 ← FALSE};
	  ENDCASE => tb[node].attr1 ← tb[node].attr2 ← FALSE};

  Lengthen: PROC [t: Tree.Link, target: CSEIndex] RETURNS [Tree.Link] = {
    PushTree[t]; PushNode[lengthen, 1]; SetInfo[target]; RETURN [PopTree[]]};

  Shorten: PROC [t: Tree.Link, target: CSEIndex] RETURNS [Tree.Link] = {
    PushTree[t]; PushNode[shorten, 1]; SetInfo[target]; RETURN [PopTree[]]};

  Float: PROC [t: Tree.Link, type, target: CSEIndex] RETURNS [Tree.Link] = {
    PushTree[IF seb[type].typeTag = long
      THEN t
      ELSE Lengthen[t, MakeLongType[type, typeANY]]];
    SELECT NormalType[type] FROM
      dataPtr.typeINT => {PushNode[float, 1]; SetInfo[target]};
      typeANY => NULL;
      ENDCASE => Log.ErrorTree[typeClash, t];
    RETURN [PopTree[]]};


 -- expressions

  implicit: PUBLIC P3S.ImplicitInfo;	-- implied attributes of Tree.Null
  
  Exp: PUBLIC PROC [exp: Tree.Link, target: CSEIndex] RETURNS [val: Tree.Link] = {
    type: CSEIndex;
    phraseNP ← none;
    IF exp = Tree.Null THEN {RPush[implicit.type, implicit.attr]; RETURN [Tree.Null]};
    WITH e: exp SELECT FROM
      symbol => {
	sei: ISEIndex = e.index;
	attr: Attr;
	attr.noXfer ← attr.noAssign ← TRUE;  RecordMention[sei];
	type ← UnderType[seb[sei].idType];
	SELECT ctxb[seb[sei].idCtx].ctxType FROM
	  included =>
	    IF ~(attr.const←ConstantId[sei]) THEN Log.ErrorSei[unimplemented, sei];
	  imported => attr.const ← ConstantId[sei];
	  ENDCASE => attr.const ← seb[sei].constant;
	RPush[type, attr];  val ← exp};
      hash =>
	WITH t: seb[target] SELECT FROM
	  enumerated => {
	    sei: ISEIndex;
	    IF ([sei: sei] ← SearchCtxList[e.index, t.valueCtx]).found THEN {
	      RPush[target, fullAttr];  val ← [symbol[sei]]}
	    ELSE val ← Id[e.index]};
	  ENDCASE => val ← Id[e.index];
      literal => {
	attr: Attr;
	attr.noXfer ← attr.noAssign ← TRUE;
	WITH e.index SELECT FROM
	  string => {
	    [val, type] ← StringRef[exp, target];
	    attr.const ← FALSE;
	    IF dataPtr.interface THEN Log.ErrorTree[unimplemented, exp]};
	  ENDCASE => {type ← dataPtr.typeINT; attr.const ← TRUE; val ← exp};
	RPush[type, attr]};
      subtree => {
	node: Tree.Index ← e.index;
	val ← exp;	-- the default
	SELECT tb[node].name FROM

	  dot => {node ← Dot[node, target]; val ← [subtree[node]]};
	  uparrow => UpArrow[node];

	  apply => {
	    node ← Apply[node, target, FALSE]; val ← [subtree[node]];
	    CheckNonVoid[node, target]};

	  uminus, abs => UnaryOp[node];
	  plus => Plus[node];
	  minus => Minus[node];
	  times, div, mod => ArithOp[node];
	  relE, relN => RelOp[node, FALSE];
	  relL, relGE, relG, relLE => RelOp[node, TRUE];
	  in, notin => In[node];
	  not => tb[node].son[1] ← Rhs[tb[node].son[1], dataPtr.typeBOOL];
	  or, and => BoolOp[node];
	  ifx => IfExp[node, target];
	  casex => SelectExp[node, target, Case, TRUE];
	  bindx => SelectExp[node, target, Discrimination, FALSE];
	  assignx => Assignment[node];
	  extractx => {Extract[node]; CheckNonVoid[node, target]};
	  min, max => MinMax[node, target];
	  pred, succ => EnumOp[node, target];
	  addr, base, length, arraydesc => AddrOp[node, target];
	  all => All[node, target];

	  mwconst =>
	    IF tb[node].attr1 THEN RPush[dataPtr.typeREAL, fullAttr]
	    ELSE {
	      IF longUnsigned = CSENull THEN
	        longUnsigned ← MakeLongType[dataPtr.idCARDINAL, typeANY];
	      RPush[longUnsigned, fullAttr]};

	  void => RPush[target, voidAttr];
	  clit => RPush[dataPtr.typeCHAR, fullAttr];

	  llit => {
	    attr: Attr ← fullAttr;
	    attr.const ← FALSE;  RPush[dataPtr.typeSTRING, attr]};

	  atom => {
	    hti: HTIndex = GetHash[tb[node].son[1]];
	    WITH t: seb[target] SELECT FROM
	      enumerated => {
	        sei: ISEIndex;
	        IF ~([sei: sei]←SearchCtxList[hti, t.valueCtx]).found THEN
	          Log.ErrorHti[unknownId, hti];
	        tb[node].son[1] ← Tree.Null;  FreeNode[node];  node ← Tree.NullIndex;
	        val ← [symbol[index: sei]];  RPush[target, fullAttr]};
	      ENDCASE => {
	        SymLiteralOps.EnterAtom[hti]; EnterType[dataPtr.typeAtomRecord, FALSE];
		RPush[dataPtr.typeATOM, fullAttr]}};

	  nil => {
	    OPEN tb[node];
	    SELECT TRUE FROM
	      (son[1] # Tree.Null) => {
		son[1] ← TypeExp[son[1]];  type ← UnderType[TypeForTree[son[1]]]};
	      (target # typeANY) => type ← target;
	      ENDCASE => type ← MakeRefType[typeANY, typeANY];
	    IF ~NullableType[type] THEN Log.ErrorTree[typeClash, val];
	    RPush[type, fullAttr]};

	  new, signalx, errorx, fork, joinx, create, startx, cons, listcons => {
	    val ← MiscXfer[node, target];
	    node ← GetNode[val];  CheckNonVoid[node, target]};

	  syserrorx => {
	    RPush[CSENull, emptyAttr]; CheckNonVoid[node, target]};

	  lengthen => {
	    OPEN tb[node];
	    subType: CSEIndex;
	    son[1] ← GenericRhs[
		son[1],
		WITH seb[target] SELECT FROM
		  long => TargetType[UnderType[rangeType]],
		  ENDCASE => target];
	    subType ← TargetType[rStack[rI].type];
	    IF subType = dataPtr.typeINT
	     OR seb[subType].typeTag = ref
	     OR seb[subType].typeTag = arraydesc
	     OR subType = typeANY THEN rStack[rI].type ← MakeLongType[subType, target]
	    ELSE {Log.ErrorTree[typeClash, son[1]]; rStack[rI].type ← typeANY}};

	  narrow => {
	    OPEN tb[node];
	    IF son[2] = Tree.Null THEN {
	      IF target = typeANY THEN Log.ErrorNode[noTarget, node];
	      type ← target}
	    ELSE {son[2] ← TypeExp[son[2]]; type ← UnderType[TypeForTree[son[2]]]};
	    son[1] ← Exp[son[1], TargetType[type]];
	    TypeTest[node: node, from: rStack[rI].type, to: type];
	    IF attr3 AND ~attr1 AND son[2] = Tree.Null THEN Log.ErrorNode[noTarget, node];
	    IF RCType[type] = simple THEN {
	      nType: CSEIndex = NormalType[type];
	      WITH t: seb[nType] SELECT FROM
	        ref => EnterType[t.refType, FALSE];
	        ENDCASE => NULL};
	    IF tb[node].nSons > 2 THEN [] ← CatchPhrase[tb[node].son[3]];
	    rStack[rI].type ← type;
	    rStack[rI].attr.const ← rStack[rI].attr.noXfer ← FALSE};

	  istype => {
	    OPEN tb[node];
	    son[1] ← Exp[son[1], typeANY];
	    son[2] ← TypeExp[son[2]]; type ← UnderType[TypeForTree[son[2]]];
	    TypeTest[node: node, from: RType[], to: type];
	    rStack[rI].type ← dataPtr.typeBOOL; rStack[rI].attr.const ← FALSE};

	  safen => tb[node].son[1] ← Exp[tb[node].son[1], target];

	  loophole => {
	    OPEN tb[node];
	    subType: CSEIndex;
	    son[1] ← Exp[son[1], typeANY];  subType ← RType[];
	    IF seb[subType].typeTag = transfer AND OperandInline[son[1]] THEN
	      Log.ErrorTree[misusedInline, son[1]];
	    IF son[2] = Tree.Null THEN {
	      IF target = typeANY THEN Log.ErrorNode[noTarget, node];
	      rStack[rI].type ← target}
	    ELSE {
	      son[2] ← TypeExp[son[2]];
	      rStack[rI].type ← UnderType[TypeForTree[son[2]]]};
	    IF RCType[rStack[rI].type] # none THEN {
	      rStack[rI].attr.const ← FALSE;
	      IF P3S.safety = checked THEN Log.ErrorNode[unsafeOperation, node]}};

	  size => {
	    OPEN tb[node];
	    attr: Attr;
	    son[1] ← TypeAppl[son[1]]; attr ← RAttr[]; RPop[];
	    IF son[2] # Tree.Null THEN {
	      saveNP: NPUse = phraseNP;
	      son[2] ← Rhs[son[2], dataPtr.typeINT];
	      attr ← And[attr, RAttr[]]; RPop[];
	      phraseNP ← MergeNP[saveNP][phraseNP]};
	    RPush[dataPtr.typeINT, attr]};

	  first, last => EndPoint[node];

	  typecode => {
	    tb[node].son[1] ← TypeExp[tb[node].son[1]];
	    EnterType[TypeForTree[tb[node].son[1]], FALSE];
	    RPush[typeANY, fullAttr]};

	  self => {
	    val ← P3S.self.tree;  P3S.self.tree ← Tree.Null;
	    phraseNP ← P3S.self.np;  RPush[P3S.self.type, P3S.self.attr];
	    FreeNode[node];  node ← Tree.NullIndex};

	  val,
	  cast => {
	    tb[node].son[1] ← Exp[tb[node].son[1], target];
	    rStack[rI].type ← target};

	  ord =>
	    IF UniOperand[node] THEN {
	      tb[node].son[1] ← Exp[tb[node].son[1], typeANY];  SetAttributes[node];
	      IF ~IndexType[RType[]] THEN Log.ErrorTree[typeClash, tb[node].son[1]];
	      rStack[rI].type ← MakeNumeric[RType[]]};

--	  val =>
--	    IF UniOperand[node] THEN {
--	      IF ~IndexType[target] THEN Log.ErrorNode[noTarget, node];
--	      tb[node].son[1] ← EvalNumeric[tb[node].son[1]];
--	      rStack[rI].type ← target};
	      
	  stringinit => {
	    tb[node].son[2] ← Rhs[tb[node].son[2], dataPtr.typeINT];
	    IF ~RAttr[].const THEN Log.ErrorTree[nonConstant, tb[node].son[2]];
	    RPop[];  RPush[dataPtr.typeSTRING, voidAttr]};

	  ENDCASE => 
	    IF tb[node].name = item THEN tb[node].son[2] ← Exp[tb[node].son[2], target]
	    ELSE {Log.Error[unimplemented]; RPush[typeANY, emptyAttr]};

	IF node # Tree.NullIndex THEN tb[node].info ← rStack[rI].type};
      ENDCASE;
    RETURN};

    CheckNonVoid: PROC [node: Tree.Index, target: CSEIndex] = {
      IF rStack[rI].type = CSENull THEN
	SELECT tb[node].name FROM
	  error => {tb[node].name ← errorx; rStack[rI].type ← target};
	  errorx, syserrorx => rStack[rI].type ← target;
	  ENDCASE => {Log.ErrorNode[typeClash, node]; rStack[rI].type ← typeANY}};

  VoidExp: PUBLIC PROC [exp: Tree.Link] RETURNS [val: Tree.Link] = {
    val ← Exp[exp, typeANY]; RPop[]; RETURN};

  UniOperand: PROC [node: Tree.Index] RETURNS [valid: BOOL] = {
    l: CARDINAL = ListLength[tb[node].son[1]];
    IF ~(valid ← l=1) THEN {
      IF l > 1 THEN Log.ErrorN[listLong, l-1] ELSE Log.ErrorN[listShort, l+1];
      tb[node].son[1] ← UpdateList[tb[node].son[1], VoidExp];
      RPush[typeANY, emptyAttr]};
    RETURN};


 -- overloaded string literals
 
  StringRef: PROC [t: Tree.Link, target: CSEIndex] RETURNS [v: Tree.Link, type: CSEIndex] = {
    IF RCType[target] = none THEN {type ← dataPtr.typeSTRING; v ← t}
    ELSE {
      nType: CSEIndex = NormalType[target];
      rType: SEIndex = WITH t: seb[nType] SELECT FROM
	  ref => t.refType,
	  ENDCASE => dataPtr.idTEXT;
      form: TextForm = TextRep[rType];
      cType: SEIndex = IF form = text THEN dataPtr.idTEXT ELSE rType;
      type ← textType[form];
      IF type = CSENull THEN {
	type ← MakeLongType[MakeRefType[cType: cType, hint: nType, counted: TRUE], target];
	textType[form] ← type};
      EnterType[TypeRoot[cType], FALSE];
      WITH e: t SELECT FROM
	literal =>
	  WITH e.index SELECT FROM
	    string => {
	      sti ← LiteralOps.FindHeapString[sti, TypeRoot[cType]];
	      SymLiteralOps.EnterText[sti]};
	    ENDCASE;
	ENDCASE;
      PushTree[t];  PushNode[textlit, 1];
      SetAttr[2, TRUE];  SetInfo[type];  v ← PopTree[]};
    RETURN};

  }.