-- file Pass3V.Mesa
-- last modified by Satterthwaite, November 8, 1979  3:02 PM

DIRECTORY
  ComData: FROM "comdata" USING [idANY, seAnon, textIndex, typeBOOLEAN],
  Copier: FROM "copier" USING [CopyUnion],
  Log: FROM "log" USING [Error, ErrorHti, ErrorTree],
  P3: FROM "p3"
    USING [
      Attr, NPUse,
      phraseNP,
      BaseTree, Exp, FindSe, LongPath, OpenPointer, OperandType,
      PopCtx, PushCtx, PushHtCtx, PushRecordCtx,
      RAttr, Rhs, RPop, RPush, RType, SealRefStack, SearchCtxList, TargetType,
      TopCtx, UnsealRefStack, UpdateTreeAttr, VoidExp],
  Pass3: FROM "pass3" USING [implicitRecord, implicitTree, implicitType],
  Symbols: FROM "symbols"
    USING [seType, ctxType,
      HTIndex, SEIndex, ISEIndex, CSEIndex, RecordSEIndex, CTXIndex,
      HTNull, SENull, ISENull, CSENull, CTXNull, typeANY, typeTYPE],
  SymbolOps: FROM "symbolops" USING [NextSe, NormalType, TypeForm, UnderType],
  Table: FROM "table" USING [Base, Notifier, AddNotify, DropNotify],
  Tree: FROM "tree" USING [Index, Link, Map, Null, Scan, treeType],
  TreeOps: FROM "treeops"
    USING [
      ListTail, PopTree, PushTree, PushNode,
      ScanList, SetAttr, SetInfo, UpdateList];

Pass3V: PROGRAM
    IMPORTS
	Copier, Log, P3, SymbolOps, Table, TreeOps, 
	dataPtr: ComData, passPtr: Pass3
    EXPORTS P3 = 
  BEGIN
  OPEN SymbolOps, P3, Symbols, TreeOps;

-- tables defining the current symbol table

  tb: Table.Base;		-- tree base
  seb: Table.Base;		-- se table
  ctxb: Table.Base;		-- context table

  VRNotify: Table.Notifier =
    BEGIN  -- called whenever the main symbol table is repacked
    tb _ base[Tree.treeType];  seb _ base[seType];  ctxb _ base[ctxType];
    END;

  entryDepth: CARDINAL _ 0;

  VREnter: PROCEDURE =
    BEGIN
    IF entryDepth = 0 THEN Table.AddNotify[VRNotify];
    entryDepth _ entryDepth + 1;
    END;

  VRExit: PROCEDURE =
    BEGIN
    IF (entryDepth _ entryDepth-1) = 0 THEN Table.DropNotify[VRNotify];
    END;


-- finding union and discriminated types
-- N. B. the following two entries cannot assume well-formed type links

  VariantUnionType: PUBLIC PROCEDURE [type: SEIndex] RETURNS [vType: CSEIndex] =
    BEGIN
    rType: CSEIndex;
    VREnter[];
    rType _ ConsType[type];
    vType _ WITH seb[rType] SELECT FROM
      record =>
	IF hints.variant
	  THEN ConsType[TypeForSe[UnionField[LOOPHOLE[rType, RecordSEIndex]]]]
	  ELSE typeANY,
      ENDCASE => typeANY;
    VRExit[];
    RETURN
    END;


  SelectVariantType: PUBLIC PROCEDURE [type: SEIndex, tag: HTIndex] RETURNS [sei: ISEIndex] =
    BEGIN
    matched: BOOLEAN;
    vType: CSEIndex = VariantUnionType[type];
    VREnter[];
    WITH seb[vType] SELECT FROM
      union =>   [matched, sei] _ SearchCtxList[tag, caseCtx];
      ENDCASE => matched _ FALSE;
    IF ~matched
      THEN
	BEGIN
        IF type # typeANY THEN Log.ErrorHti[unknownVariant, tag];
	sei _ dataPtr.idANY;
	END;
    VRExit[];
    RETURN
    END;


 -- auxiliary procedures (for avoiding UnderType when potentially unsafe)

  UnionField: PROCEDURE [rSei: RecordSEIndex] RETURNS [ISEIndex] = INLINE
    BEGIN
    sei, root, next: ISEIndex;
    ctx: CTXIndex = seb[rSei].fieldCtx;
    repeated: BOOLEAN;
    IF ctxb[ctx].ctxType = simple
      THEN
	FOR sei _ ctxb[ctx].seList, next UNTIL sei = ISENull
	  DO
	  next _ NextSe[sei];
	  IF next = ISENull THEN RETURN [sei];
	  ENDLOOP
      ELSE
	BEGIN	-- defined elsewhere, UnderType is safe
	repeated _ FALSE;
	  DO
	  sei _ root _ ctxb[ctx].seList;
	    DO
	    IF sei = ISENull THEN EXIT;
	    IF TypeForm[seb[sei].idType] = union THEN RETURN [sei];
	    IF (sei _ NextSe[sei]) = root THEN EXIT;
	    ENDLOOP;
	  IF repeated THEN EXIT;
	  Copier.CopyUnion[seb[rSei].fieldCtx];  repeated _ TRUE;
	  ENDLOOP;
	END;
    RETURN [dataPtr.seAnon]
    END;

  ResolveId: PROCEDURE [hti: HTIndex, ctx: CTXIndex] RETURNS [sei: ISEIndex] =
    BEGIN
    currentCtx: CTXIndex = TopCtx[];
    IF ctx = currentCtx
      THEN  sei _ FindSe[hti].symbol
      ELSE
	BEGIN PopCtx[]; sei _ ResolveId[hti, ctx]; PushCtx[currentCtx] END;
    RETURN
    END;

  TypeForSe: PROCEDURE [sei: ISEIndex] RETURNS [type: SEIndex] = INLINE
    BEGIN
    node: Tree.Index;
    t: Tree.Link;
    IF seb[sei].mark3 THEN RETURN [seb[sei].idType];
    node _ seb[sei].idValue;
    IF tb[node].name # decl THEN RETURN [typeTYPE];
    t _ tb[node].son[2];
    type _ WITH t SELECT FROM
      hash => ResolveId[index, seb[sei].idCtx],
      symbol => index,
      subtree => tb[index].info,
      ENDCASE => typeANY;
    RETURN
    END;

  ConsType: PROCEDURE [type: SEIndex] RETURNS [CSEIndex] =
    BEGIN
    sei, next: SEIndex;
    node: Tree.Index;
    FOR sei _ type, next
      DO
      WITH seb[sei] SELECT FROM
	id =>
	  IF mark3
	    THEN
	      BEGIN
	      IF idType # typeTYPE THEN RETURN [typeANY];
	      next _ idInfo;
	      END
	    ELSE
	      BEGIN  node _ idValue;
	      IF tb[node].name # typedecl THEN RETURN [typeANY];
	      next _ ResolveTreeType[tb[node].son[2], idCtx];
	      END;
	cons => RETURN [LOOPHOLE[sei, CSEIndex]];
	ENDCASE;
      ENDLOOP;
    END;

  ResolveTreeType: PROCEDURE [t: Tree.Link, ctx: CTXIndex] RETURNS [type: SEIndex] =
    BEGIN
    node: Tree.Index;
    WITH t SELECT FROM
      hash =>    type _ ResolveId[index, ctx];
      symbol =>  type _ index;
      subtree =>
	BEGIN  node _ index;
	IF tb[node].info # SENull
	  THEN  type _ tb[node].info
	  ELSE
	    SELECT tb[node].name FROM
	      discrimTC =>
		WITH tb[node].son[2] SELECT FROM
		  hash =>
		    type _ SelectVariantType[
		      ResolveTreeType[tb[node].son[1], ctx],
		      index];
		  ENDCASE =>  ERROR;
	      ENDCASE => ERROR;
	END;
      ENDCASE => ERROR;
    RETURN
    END;


 -- type discrimination

  DiscriminatedType: PUBLIC PROCEDURE [baseType: CSEIndex, t: Tree.Link] RETURNS [type: CSEIndex] =
    BEGIN
    node: Tree.Index;
    temp: Tree.Link;
    subType: CSEIndex;
    VREnter[];
    IF t = Tree.Null
      THEN  type _ passPtr.implicitRecord
      ELSE
	WITH t SELECT FROM
	  subtree =>
	    BEGIN  node _ index;
	    SELECT tb[node].name FROM
	      union =>
		BEGIN
		type _ WITH tb[node].son[1] SELECT FROM
		  symbol => UnderType[index],
		  ENDCASE =>  ERROR;
		WITH seb[type] SELECT FROM
		  record =>
		    IF hints.variant AND tb[node].son[2] # Tree.Null(1800)
		       AND (temp_ListTail[tb[node].son[2]]) # Tree.Null
		      THEN  type _ DiscriminatedType[type, temp];
		  ENDCASE =>  ERROR;
		END;
	      dollar =>  type _ OperandType[tb[node].son[1]];
	      dot =>
		BEGIN
		subType _ NormalType[OperandType[tb[node].son[1]]];
		type _ WITH seb[subType] SELECT FROM
		  pointer =>  UnderType[refType],
		  ENDCASE =>  ERROR;
		END;
	      assignx => type _ DiscriminatedType[baseType, tb[node].son[2]];
	      ENDCASE => type _ baseType;
	    END;
	  ENDCASE => type _ baseType;
    VRExit[];  RETURN
    END;


-- binding of variant records

  Discrimination: PUBLIC PROCEDURE [node: Tree.Index, selection: Tree.Map] =
    BEGIN  OPEN tb[node];
    idNode: Tree.Index;
    type, subType, uType, tagType: CSEIndex;
    vCtx: CTXIndex;
    base, discBase: Tree.Link;
    indirect, long: BOOLEAN;
    baseId: HTIndex;
    attr: Attr;
    entryNP: NPUse;
    saveType: CSEIndex = passPtr.implicitType;
    saveTree: Tree.Link = passPtr.implicitTree;

    BindError: PROCEDURE =
      BEGIN
      IF son[2] # Tree.Null THEN son[2] _ VoidExp[son[2]];
      vCtx _ CTXNull;  tagType _ typeANY;
      END;

    PushCommonCtx: PROCEDURE =
      BEGIN
      SELECT TRUE FROM
	(seb[type].typeTag # record) =>  PushCtx[CTXNull];
	(baseId = HTNull) =>  PushRecordCtx[LOOPHOLE[type], base, indirect];
	ENDCASE =>  PushHtCtx[baseId, base, indirect];
      END;

    BindItem: Tree.Scan =
      BEGIN
      subNode: Tree.Index;
      vType: CSEIndex;
      saveIndex: CARDINAL = dataPtr.textIndex;
      WITH t SELECT FROM
	subtree =>
	  BEGIN  subNode _ index;
	  dataPtr.textIndex _ tb[subNode].info;
	  [tb[subNode].son[1], vType] _ BindTest[tb[subNode].son[1], vCtx];
	  IF vType = typeANY
	    THEN PushCommonCtx[]
	    ELSE
	      BEGIN
	      WITH discBase SELECT FROM
		subtree => tb[index].info _ vType;
		ENDCASE => ERROR;
	      IF baseId = HTNull
		THEN  PushRecordCtx[LOOPHOLE[vType], discBase, FALSE]
		ELSE  PushHtCtx[baseId, discBase, FALSE];
	      END;
	  phraseNP _ entryNP;
	  tb[subNode].son[2] _ selection[tb[subNode].son[2]];
	  PopCtx[];
	  tb[subNode].attr1 _ TRUE;
	  END;
	ENDCASE =>  ERROR;
      dataPtr.textIndex _ saveIndex;
      END;

    VREnter[];
    idNode _ WITH son[1] SELECT FROM subtree => index, ENDCASE => ERROR;
    SealRefStack[];
    base _ tb[idNode].son[2] _ Exp[tb[idNode].son[2], typeANY];
    subType _ RType[];  attr _ RAttr[];  RPop[];
    UnsealRefStack[];
    type _ NormalType[subType];
    IF (indirect _ seb[type].typeTag = pointer)
      THEN
	BEGIN
	[base, type] _ OpenPointer[base, subType];
	subType _ OperandType[base];  long _ seb[subType].typeTag = long;
	END
      ELSE  long _ LongPath[base];
    baseId _ WITH tb[idNode].son[1] SELECT FROM hash=> index, ENDCASE=> ERROR;
    entryNP _ none;
    WITH seb[type] SELECT FROM
      record =>
	BEGIN
	tb[idNode].son[2] _ base _ BaseTree[base, subType];
	IF hints.variant
	  THEN
	    BEGIN  uType _ VariantUnionType[type];
	    WITH seb[uType] SELECT FROM
	      union =>
		BEGIN
		vCtx _ caseCtx;
		tagType _ UnderType[seb[tagSei].idType];
		IF son[2] = Tree.Null
		  THEN
		    BEGIN
		    IF ~controlled THEN Log.Error[missingBinding];
		    [] _ UpdateTreeAttr[base];  entryNP _ phraseNP;
		    PushTree[base];
		    PushTree[Tree.Link[symbol[index: tagSei]]];
		    PushNode[IF indirect THEN dot ELSE dollar, 2];
		    SetInfo[tagType]; SetAttr[2, long]; son[2] _ PopTree[];
		    END
		  ELSE
		    BEGIN
		    IF controlled THEN Log.ErrorTree[spuriousBinding, son[2]];
		    PushCommonCtx[];
		    son[2] _ Rhs[son[2], TargetType[tagType]];
		    entryNP _ phraseNP;  RPop[];
		    PopCtx[];
		    END;
		END;
	      ENDCASE =>  BEGIN  Log.Error[noAccess];  BindError[]  END;
	    END
	  ELSE
	    BEGIN
	    Log.ErrorTree[noVariants, tb[idNode].son[2]];  BindError[];
	    END;
	PushTree[base];
	IF indirect
	  THEN  BEGIN PushNode[uparrow, 1]; SetAttr[2, long] END
	  ELSE  PushNode[cast, 1];
	discBase _ PopTree[];
	END;
      ENDCASE =>
	BEGIN
	Log.ErrorTree[noVariants, tb[idNode].son[2]];  BindError[];
	discBase _ Tree.Null;
	END;
    ScanList[son[3], BindItem];
    PushCommonCtx[]; phraseNP _ entryNP; son[4] _ selection[son[4]]; PopCtx[];
    RPush[CSENull, attr];
    passPtr.implicitType _ saveType;  passPtr.implicitTree _ saveTree;
    VRExit[];
    END;


  BindTest: PROCEDURE [t: Tree.Link, vCtx: CTXIndex] RETURNS [val: Tree.Link, vType: CSEIndex] =
    BEGIN
    mixed: BOOLEAN;

    TestItem: Tree.Map =
      BEGIN
      subNode: Tree.Index;
      iType: ISEIndex;
      uType: CSEIndex;
      found: BOOLEAN;
      WITH t SELECT FROM
	subtree =>
	  BEGIN  subNode _ index;
	  SELECT tb[subNode].name FROM
	    relE =>
	      WITH tb[subNode].son[2] SELECT FROM
		hash =>
		  BEGIN
		  [found, iType] _ SearchCtxList[index, vCtx];
		  IF found
		    THEN
		      BEGIN  uType _ UnderType[iType];
		      tb[subNode].son[2] _ Tree.Link[symbol[index: iType]];
		      SELECT vType FROM
			uType => NULL;
			typeANY => vType _ uType;
			ENDCASE => mixed _ TRUE;
		      END
		    ELSE
		      IF vCtx # CTXNull
			THEN Log.ErrorHti[unknownVariant, index];
		  tb[subNode].info _ dataPtr.typeBOOLEAN;
		  tb[subNode].attr1 _ tb[subNode].attr2 _ FALSE;
		  v _ t;
		  END;
		ENDCASE =>
		  BEGIN
		  v _ Rhs[t, dataPtr.typeBOOLEAN];  RPop[];
		  Log.ErrorTree[nonVariantLabel, t];
		  END;
	    ENDCASE =>
	      BEGIN
	      v _ Rhs[t, dataPtr.typeBOOLEAN];  RPop[];
	      Log.ErrorTree[nonVariantLabel, t];
	      END;
	  END;
	ENDCASE =>  ERROR;
      RETURN
      END;

    vType _ typeANY;  mixed _ FALSE;
    val _ UpdateList[t, TestItem];
    IF mixed THEN vType _ typeANY;
    RETURN
    END;

  END.