-- file Pass3Xc.Mesa
-- last modified by Satterthwaite, November 16, 1979  10:23 AM

DIRECTORY
  ComData: FROM "comdata" USING [idCARDINAL, typeINTEGER],
  InlineDefs: FROM "inlinedefs" USING [BITAND],
  Log: FROM "log" USING [ErrorN, ErrorNode, ErrorTree],
  P3: FROM "p3"
    USING [
      Attr, NPUse, MergeNP,
      phraseNP,
      --And,-- CanonicalType, Exp, LongPath, MakeLongType,
      MakePointerType, OperandLhs, OperandType, RAttr, Rhs,
      RPop, RPush, RType, TargetType, TypeExp, TypeForTree, VoidExp],
  Symbols: FROM "symbols"
    USING [seType,
      SERecord, SEIndex, ISEIndex, CSEIndex, RecordSEIndex, CTXIndex,
      SENull, ISENull, typeANY],
  SymbolOps: FROM "symbolops"
    USING [
      FirstCtxSe, MakeNonCtxSe, NextSe, NormalType, TypeForm, UnderType],
  Table: FROM "table" USING [Base, Notifier, AddNotify, DropNotify],
  Tree: FROM "tree" USING [Index, Link, Null, treeType],
  TreeOps: FROM "treeops"
    USING [
      GetNode, IdentityMap, ListLength, MakeList,
      PushTree, PushNode, SetAttr, SetInfo, UpdateList];

Pass3Xc: PROGRAM
    IMPORTS
      InlineDefs, Log, P3, SymbolOps, Table, TreeOps,
      dataPtr: ComData
    EXPORTS P3 =
  BEGIN
  OPEN SymbolOps, TreeOps, P3;

  And: PROCEDURE [Attr, Attr] RETURNS [Attr] = LOOPHOLE[InlineDefs.BITAND];

 -- pervasive definitions from Symbols

  SEIndex: TYPE = Symbols.SEIndex;
  ISEIndex: TYPE = Symbols.ISEIndex;
  CSEIndex: TYPE = Symbols.CSEIndex;
  RecordSEIndex: TYPE = Symbols.RecordSEIndex;
  SENull: SEIndex = Symbols.SENull;
  ISENull: ISEIndex = Symbols.ISENull;
  typeANY: CSEIndex = Symbols.typeANY;

  CTXIndex: TYPE = Symbols.CTXIndex;


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

  ExpCNotify: Table.Notifier =
    BEGIN  -- called by allocator whenever table area is repacked
    seb _ base[Symbols.seType];  tb _ base[Tree.treeType];
    END;


 -- operations on enumerated types

  Span: PUBLIC PROCEDURE [type: CSEIndex] RETURNS [first, last: ISEIndex] =
    BEGIN
    Table.AddNotify[ExpCNotify];
    [first, last] _ EnumeratedSpan[type];
    Table.DropNotify[ExpCNotify];  RETURN
    END;

  EnumeratedSpan: PROCEDURE [type: CSEIndex] RETURNS [first, last: ISEIndex] =
    BEGIN
    subType: CSEIndex = TargetType[type];
    vCtx: CTXIndex = WITH seb[subType] SELECT FROM
			enumerated => valueCtx,
			ENDCASE => ERROR;
    WITH t:seb[type] SELECT FROM
      enumerated =>
	BEGIN first _ FirstCtxSe[vCtx]; last _ LastCtxSe[vCtx] END;
      subrange =>
	BEGIN
	IF t.mark4
	  THEN
	    BEGIN
	    first _ FindElement[vCtx, t.origin];
	    last _ FindElement[vCtx, t.origin + t.range];
	    END
	  ELSE
	    BEGIN
	    node: Tree.Index = LOOPHOLE[t.range];
	    subNode: Tree.Index = GetNode[tb[node].son[2]];
	    first _ EnumeratedValue[tb[subNode].son[1], vCtx];
	    last _ EnumeratedValue[tb[subNode].son[2], vCtx];
	    SELECT tb[subNode].name FROM
	      intOO, intOC =>  first _ NextSe[first];
	      ENDCASE;
	    SELECT tb[subNode].name FROM
	      intOO, intCO =>  last _ PrevSe[last];
	      ENDCASE;
	    END;
	END;
      ENDCASE =>  first _ last _ ISENull;
    RETURN
    END;

  EnumeratedValue: PROCEDURE [t: Tree.Link, vCtx: CTXIndex] RETURNS [ISEIndex] =
    BEGIN
    WITH t SELECT FROM
      symbol =>
	BEGIN
	sei: ISEIndex = index;
	RETURN [SELECT TRUE FROM
	  ~seb[sei].constant => ISENull,
	  (seb[sei].idCtx = vCtx) => sei,
	  seb[sei].mark4 => FindElement[vCtx, seb[sei].idValue],
	  ENDCASE => EnumeratedValue[InitTree[sei], vCtx]]
	END;
      subtree =>
	BEGIN
	node: Tree.Index = index;
	RETURN [SELECT tb[node].name FROM
	  first =>
	    EnumeratedSpan[UnderType[TypeForTree[tb[node].son[1]]]].first,
	  last =>
	    EnumeratedSpan[UnderType[TypeForTree[tb[node].son[1]]]].last,
	  ENDCASE => ISENull]
	END;
      ENDCASE => RETURN [ISENull]
    END;

  FindElement: PROCEDURE [vCtx: CTXIndex, value: CARDINAL] RETURNS [ISEIndex] =
    BEGIN
    sei: ISEIndex;
    FOR sei _ FirstCtxSe[vCtx], NextSe[sei] UNTIL sei = ISENull
      DO
      IF seb[sei].idValue = value THEN RETURN [sei];
      ENDLOOP;
    RETURN [ISENull]
    END;

  LastCtxSe: PROCEDURE [ctx: CTXIndex] RETURNS [last: ISEIndex] =
    BEGIN
    sei: ISEIndex;
    last _ ISENull;
    FOR sei _ FirstCtxSe[ctx], NextSe[sei] UNTIL sei = ISENull
      DO last _ sei ENDLOOP;
    RETURN
    END;

  PrevSe: PROCEDURE [sei: ISEIndex] RETURNS [prev: ISEIndex] =
    BEGIN
    next: ISEIndex;
    prev _ ISENull;
    IF sei # ISENull
      THEN
	BEGIN
	next _ FirstCtxSe[seb[sei].idCtx];
	UNTIL next = sei OR next = ISENull
	  DO  prev _ next;  next _ NextSe[next]  ENDLOOP;
	END;
    RETURN
    END;
   
  InitTree: PROCEDURE [sei: ISEIndex] RETURNS [Tree.Link] = INLINE
    BEGIN RETURN [tb[LOOPHOLE[seb[sei].idValue, Tree.Index]].son[3]] END;

 -- operations on addresses

  Addr: PUBLIC PROCEDURE [node: Tree.Index, target: CSEIndex] =
    BEGIN  OPEN tb[node];
    type: CSEIndex;
    attr: Attr;
    Table.AddNotify[ExpCNotify];
    son[1] _ Exp[son[1], typeANY];
    IF ~OperandLhs[son[1]] THEN Log.ErrorTree[nonAddressable, son[1]];
    type _ MakePointerType[RType[], NormalType[target]];
    IF (attr2 _ LongPath[son[1]]) THEN type _ MakeLongType[type, target];
    attr _ RAttr[];  RPop[];  RPush[type, attr];
    Table.DropNotify[ExpCNotify];  RETURN
    END;


  DescOp: PUBLIC PROCEDURE [node: Tree.Index, target: CSEIndex] =
    BEGIN
    Table.AddNotify[ExpCNotify];
    SELECT tb[node].name FROM
      base => Base[node, target];
      length => Length[node];
      arraydesc => Desc[node, target];
      ENDCASE => ERROR;
    Table.DropNotify[ExpCNotify];  RETURN
    END;


  StripRelative: PROCEDURE [rType: CSEIndex] RETURNS [type: CSEIndex, bType: SEIndex] =
    BEGIN
    WITH seb[rType] SELECT FROM
      relative =>  BEGIN type _ UnderType[offsetType]; bType _ baseType END;
      ENDCASE =>   BEGIN type _ rType; bType _ SENull END;
    RETURN
    END;

  MakeRelativeType: PROCEDURE [type: CSEIndex, bType: SEIndex, hint: CSEIndex]
      RETURNS [CSEIndex] =
    BEGIN
    rType, tType: CSEIndex;
    WITH seb[hint] SELECT FROM
      relative =>
	IF offsetType = type AND UnderType[baseType] = UnderType[bType]
	  THEN  RETURN [hint];
      ENDCASE;
    tType _ IF TypeForm[bType] = long OR TypeForm[type] = long
		THEN  MakeLongType[NormalType[type], type]
		ELSE  type;
    rType _ MakeNonCtxSe[SIZE[relative cons Symbols.SERecord]];
    seb[rType].typeInfo _ relative[
		baseType: bType,
		offsetType: type,
		resultType: tType];
    seb[rType].mark3 _ seb[rType].mark4 _ TRUE;
    RETURN [rType]
    END;


  Base: PROCEDURE [node: Tree.Index, target: CSEIndex] =
    BEGIN  OPEN tb[node];
    type, aType, nType, subTarget: CSEIndex;
    bType: SEIndex;
    attr: Attr;
    long: BOOLEAN;
    IF ListLength[son[1]] = 1
      THEN
	BEGIN
	son[1] _ Exp[son[1], typeANY];
	[aType, bType] _ StripRelative[CanonicalType[RType[]]];
	attr _ RAttr[];  RPop[];
	nType _ NormalType[aType];  [subTarget, ] _ StripRelative[target];
	WITH seb[nType] SELECT FROM
	  array =>
	    BEGIN  name _ addr;
	    IF ~OperandLhs[son[1]] THEN Log.ErrorTree[nonAddressable, son[1]];
	    long _ LongPath[son[1]];
	    END;
	  arraydesc =>
	    BEGIN
	    long _ seb[aType].typeTag = long;
	    nType _ UnderType[describedType];
	    END;
	  ENDCASE =>
	    IF nType # typeANY THEN Log.ErrorTree[typeClash, son[1]];
	END
      ELSE
	BEGIN
	Log.ErrorN[listLong, ListLength[son[1]]-1];
	son[1] _ UpdateList[son[1], VoidExp];  long _ FALSE;
	END;
    type _ MakePointerType[nType, NormalType[subTarget]];
    IF (attr2 _ long) THEN type _ MakeLongType[type, subTarget];
    IF bType # SENull THEN type _ MakeRelativeType[type, bType, target];
    attr.const _ FALSE;  RPush[type, attr];  RETURN
    END;

 Length: PROCEDURE [node: Tree.Index] =
    BEGIN  OPEN tb[node];
    type: CSEIndex;
    attr: Attr;
    IF ListLength[son[1]] = 1
      THEN
	BEGIN
	son[1] _ Exp[son[1], typeANY];
	type _ RType[];  attr _ RAttr[];  RPop[];
	type _ IF seb[type].mark3
	       THEN NormalType[StripRelative[CanonicalType[type]].type]
	       ELSE typeANY;
	WITH seb[type] SELECT FROM
	  array =>  attr.const _ TRUE;
	  arraydesc =>  attr.const _ FALSE;
	  ENDCASE =>
	    BEGIN  attr.const _ TRUE;
	    IF type # typeANY THEN Log.ErrorTree[typeClash, son[1]];
	    END;
	END
      ELSE
	BEGIN  attr.const _ TRUE;
	Log.ErrorN[listLong, ListLength[son[1]]-1];
	son[1] _ UpdateList[son[1], VoidExp];
	END;
    RPush[dataPtr.typeINTEGER, attr];  RETURN
    END;

  Desc: PROCEDURE [node: Tree.Index, target: CSEIndex] =
    BEGIN  OPEN tb[node];
    type, subType: CSEIndex;
    attr: Attr;
    saveNP: NPUse;
    aType, bType, cType: SEIndex;
    fixed, long: BOOLEAN;
    subNode: Tree.Index;
    subTarget: CSEIndex = StripRelative[target].type;
    nTarget: CSEIndex = NormalType[subTarget];
    aType _ bType _ SENull;
    SELECT ListLength[son[1]] FROM
      1 =>
	BEGIN
	son[1] _ Exp[son[1], typeANY];
	IF ~OperandLhs[son[1]] THEN Log.ErrorTree[nonAddressable, son[1]];
	long _ LongPath[son[1]];
	subType _ CanonicalType[RType[]];  attr _ RAttr[];  RPop[];
	IF seb[subType].typeTag = array
	  THEN  BEGIN  aType _ OperandType[son[1]];  fixed _ TRUE  END
	  ELSE
	    BEGIN  fixed _ FALSE;
	    IF subType # typeANY THEN Log.ErrorTree[typeClash, son[1]];
	    END;
	PushTree[son[1]];
	PushNode[addr, 1];
	SetInfo[MakePointerType[subType, typeANY]];  SetAttr[2, long];
	PushTree[IdentityMap[son[1]]];
	PushNode[length, 1];  SetInfo[dataPtr.typeINTEGER];
	PushTree[Tree.Null];
	son[1] _ MakeList[3];
	END;
      3 =>
	BEGIN  subNode _ GetNode[son[1]];
	tb[subNode].son[1] _ Exp[tb[subNode].son[1], typeANY];
	[subType,bType] _ StripRelative[CanonicalType[RType[]]];
	attr _ RAttr[];  RPop[];  saveNP _ phraseNP;
	SELECT seb[NormalType[subType]].typeTag FROM
	  basic, pointer => NULL;
	  ENDCASE => Log.ErrorTree[typeClash, tb[subNode].son[1]];
	long _ seb[subType].typeTag = long;
	tb[subNode].son[2] _ Rhs[tb[subNode].son[2], dataPtr.typeINTEGER];
	attr _ And[RAttr[], attr];  RPop[];
	phraseNP _ MergeNP[saveNP][phraseNP];
	IF (fixed _ tb[subNode].son[3] # Tree.Null)
	  THEN
	    BEGIN
	    tb[subNode].son[3] _ TypeExp[tb[subNode].son[3]];
	    cType _ TypeForTree[tb[subNode].son[3]];
	    END;
	END;
      ENDCASE;
    IF aType = SENull
      THEN
	BEGIN
	WITH seb[nTarget] SELECT FROM
	  arraydesc =>
	    BEGIN  subType _ UnderType[describedType];
	    WITH t: seb[subType] SELECT FROM
	      array =>
		IF ~fixed OR UnderType[t.componentType] = UnderType[cType]
		  THEN  BEGIN  aType _ describedType;  GO TO old  END;
	      ENDCASE;
	    END;
	  ENDCASE;
	GO TO new;
	EXITS
	  old => NULL;
	  new =>
	    BEGIN
	    subType _ MakeNonCtxSe[SIZE[array cons Symbols.SERecord]];
	    seb[subType].typeInfo _ array[
		oldPacked: FALSE,
		lengthUsed: FALSE,
		comparable: FALSE,
		indexType: dataPtr.idCARDINAL,
		componentType: IF fixed THEN cType ELSE typeANY];
	    seb[subType].mark3 _ seb[subType].mark4 _ TRUE;
	    aType _ subType;
	    END;
	END;
    -- make type description
      BEGIN
      WITH t: seb[nTarget] SELECT FROM
  	arraydesc =>
  	  IF UnderType[t.describedType] = UnderType[aType] THEN GO TO old;
	ENDCASE =>
	  IF ~fixed AND target = typeANY THEN Log.ErrorNode[noTarget, node];
      GO TO new;
      EXITS
	old =>  type _ nTarget;
	new =>
	  BEGIN
	  type _ MakeNonCtxSe[SIZE[arraydesc cons Symbols.SERecord]];
	  seb[type].typeInfo _ arraydesc[readOnly:FALSE, describedType:aType];
	  seb[type].mark3 _ seb[type].mark4 _ TRUE;
	  END;
      END;
    IF (attr2 _ long) THEN type _ MakeLongType[type, subTarget];
    IF bType # SENull THEN type _ MakeRelativeType[type, bType, target];
    attr.const _ FALSE;  RPush[type, attr];  RETURN
    END;

  END.
(1800)