-- file Pass3T.mesa
-- last modified by Satterthwaite, June 28, 1982 1:38 pm

DIRECTORY
  Alloc: TYPE USING [Notifier],
  ComData: TYPE USING [ownSymbols, typeAtomRecord],
  P3: TYPE USING [
    Attr, DefaultForm, LhsMode, NarrowOp, NPUse, phraseNP, VoidAttr,
    CompleteRecord, CopyTree, Initialization, RPush, UpdateTreeAttr,
    VariantUnionType],
  Symbols: TYPE USING [
    Base, SERecord, SEIndex, ISEIndex, CSEIndex, RecordSEIndex, RefSEIndex, CTXIndex,
    SENull, ISENull, lZ, typeANY, seType, ctxType, mdType],
  SymbolOps: TYPE USING [
    CtxEntries, FindExtension, MakeNonCtxSe, NormalType, TypeForm, TypeLink,
    TypeRoot, UnderType, VisibleCtxEntries],
  Tree: TYPE USING [Base, Link, Null, Scan, treeType],
  TreeOps: TYPE USING [
    PushSe, PopTree, PushNode, PushProperList, PushTree, OpName, ScanList],
  Types: TYPE USING [Equivalent];

Pass3T: PROGRAM
    IMPORTS P3, SymbolOps, TreeOps, Types, dataPtr: ComData
    EXPORTS P3 = {
  OPEN TreeOps, SymbolOps, Symbols, P3;

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

  TypeNotify: PUBLIC Alloc.Notifier = {
    -- called by allocator whenever table area is repacked
    tb _ base[Tree.treeType];
    seb _ base[seType];  ctxb _ base[ctxType];  mdb _ base[mdType]};


 -- type mappings

  CanonicalType: PUBLIC PROC [type: CSEIndex] RETURNS [CSEIndex] = {
    RETURN [WITH t: seb[type] SELECT FROM
      subrange => CanonicalType[UnderType[t.rangeType]],
      record =>
	IF Bundling[type] # 0
	  THEN CanonicalType[Unbundle[LOOPHOLE[type, RecordSEIndex]]]
	  ELSE type,
      ENDCASE => type]};

  TargetType: PUBLIC PROC [type: CSEIndex] RETURNS [target: CSEIndex] = {
    RETURN [WITH t: seb[type] SELECT FROM
      subrange => TargetType[UnderType[t.rangeType]],
      ENDCASE => type]};

  Unbundle: PUBLIC PROC [record: RecordSEIndex] RETURNS [CSEIndex] = {
    RETURN [UnderType[seb[ctxb[seb[record].fieldCtx].seList].idType]]};


 -- type predicates

  AccessMode: PUBLIC PROC [type: CSEIndex] RETURNS [LhsMode] = {
    nType: CSEIndex = NormalType[type];
    RETURN [WITH t: seb[nType] SELECT FROM
      ref => SELECT TRUE FROM
		t.readOnly => none,
		t.counted => counted,
		ENDCASE => uncounted,
      arraydesc => IF t.readOnly THEN none ELSE uncounted,
      relative => AccessMode[UnderType[t.offsetType]],
      ENDCASE => none]};

  AssignableType: PUBLIC PROC [type: CSEIndex, safe: BOOL] RETURNS [BOOL] = {
    RETURN [WITH t: seb[type] SELECT FROM
      mode, definition, any, nil, sequence => FALSE,
      record => t.hints.assignable AND (~safe OR ~t.hints.variant),
      array => AssignableType[UnderType[t.componentType], safe],
      transfer => t.mode # port, 
      opaque => t.lengthKnown,
      ENDCASE => TRUE]};

  Bundling: PUBLIC PROC [type: CSEIndex] RETURNS [nLevels: CARDINAL] = {
    next: CSEIndex;
    ctx: CTXIndex;
    nLevels _ 0;
    DO
      IF type = SENull THEN EXIT;
      WITH t: seb[type] SELECT FROM
	record => {
	  IF ~t.hints.unifield THEN EXIT;
	  ctx _ t.fieldCtx;
	  WITH c: ctxb[ctx] SELECT FROM
	    included => {
	      IF t.hints.privateFields AND ~mdb[c.module].shared THEN EXIT;
	      IF ~c.complete THEN CompleteRecord[LOOPHOLE[type, RecordSEIndex]];
	      IF ~c.complete THEN EXIT};
	    ENDCASE;
	  IF CtxEntries[ctx] # 1 OR t.hints.variant THEN EXIT;
	  nLevels _ nLevels + 1;
	  next _ Unbundle[LOOPHOLE[type, RecordSEIndex]]};
	ENDCASE => EXIT;
      type _ next;
      ENDLOOP;
    RETURN};

  IdentifiedType: PUBLIC PROC [type: CSEIndex] RETURNS [BOOL] = {
    RETURN [WITH t: seb[type] SELECT FROM
      mode, definition, any, nil, union, sequence => FALSE,
      record => 
	IF t.hints.variant AND ~t.hints.comparable THEN
	  SELECT seb[VariantUnionType[type]].typeTag FROM	-- force copying now
	    sequence => FALSE,
	    ENDCASE => TRUE
	ELSE TRUE,
      opaque => t.lengthKnown,
      ENDCASE => TRUE]};

  IndexType: PUBLIC PROC [type: SEIndex] RETURNS [BOOL] = {
    sei: CSEIndex = UnderType[type];
    RETURN [WITH t: seb[sei] SELECT FROM
      basic => t.ordered,
      enumerated => t.ordered,
      subrange => IndexType[t.rangeType],
      long =>  IndexType[t.rangeType],
      ENDCASE => FALSE]};

  NewableType: PUBLIC PROC [type: SEIndex] RETURNS [BOOL] = {
    sei: CSEIndex = UnderType[type];
    RETURN [WITH t: seb[sei] SELECT FROM
      mode, any, nil => FALSE,
      opaque => t.lengthKnown,
      ENDCASE => TRUE]};

  NullableType: PUBLIC PROC [type: SEIndex] RETURNS [BOOL] = {
    sei: CSEIndex = NormalType[UnderType[type]];
    RETURN [WITH t: seb[sei] SELECT FROM
      ref, transfer, arraydesc, zone => TRUE,
      ENDCASE => FALSE]};

  OrderedType: PUBLIC PROC [type: SEIndex] RETURNS [BOOL] = {
    sei: CSEIndex = UnderType[type];
    RETURN [WITH t: seb[sei] SELECT FROM
      basic => t.ordered,
      enumerated => t.ordered,
      ref => t.ordered,
      relative => OrderedType[t.offsetType],
      subrange => OrderedType[t.rangeType],
      long, real => OrderedType[t.rangeType],
      ENDCASE => FALSE]};

  DiscrimId: PROC [sei: ISEIndex] RETURNS [BOOL] = INLINE {
    RETURN [ctxb[seb[sei].idCtx].level = lZ AND TypeLink[sei] # SENull]};


 -- defaults

  Default: PUBLIC PROC [type: SEIndex] RETURNS [form: DefaultForm] = {
    next: SEIndex;
    form _ none;
    FOR s: SEIndex _ type, next DO
      WITH se: seb[s] SELECT FROM
	id => {
	  sei: ISEIndex = LOOPHOLE[s];

	  TestOption: Tree.Scan = {
	    IF OpName[t] = void THEN {IF form = none THEN form _ void}
	    ELSE form _ nonVoid};

	  IF seb[sei].extended THEN {ScanList[FindExtension[sei].tree, TestOption]; EXIT};
	  next _ seb[sei].idInfo};
	cons =>
	  WITH t: se SELECT FROM
	    ref => {IF t.counted THEN form _ nonVoid; EXIT};
	    array => next _ t.componentType;
	    record => {IF t.hints.default THEN form _ nonVoid; EXIT};
	    transfer => {form _ nonVoid; EXIT};
	    long => next _ t.rangeType;
	    zone => {IF t.counted THEN form _ nonVoid; EXIT};
	    ENDCASE => EXIT;
	ENDCASE => ERROR;
      ENDLOOP;
    RETURN};

  DefaultInit: PUBLIC PROC [type: SEIndex] RETURNS [v: Tree.Link] = {
    next: SEIndex;
    subType: CSEIndex _ UnderType[type];
    recordTail: Tree.Link _ Tree.Null;
    tagId: ISEIndex _ ISENull;
    v _ Tree.Null;
    FOR s: SEIndex _ type, next DO
      WITH se: seb[s] SELECT FROM
	id => {
	  sei: ISEIndex = LOOPHOLE[s];

	  CopyNonVoid: Tree.Scan = {
	    IF OpName[t] # void AND v = Tree.Null THEN v _ CopyTree[t]};

	  SELECT TRUE FROM
	    (seb[sei].extended AND recordTail = Tree.Null) => {
	      ScanList[FindExtension[sei].tree, CopyNonVoid]; GO TO copy};
	    (DiscrimId[sei] AND tagId = ISENull) => tagId _ sei;
	    ENDCASE;
	  next _ seb[sei].idInfo};
	cons =>
	  WITH t: se SELECT FROM
	    ref =>
	      IF t.counted THEN {PushTree[Tree.Null]; PushNode[nil, 1]; GO TO eval}
	      ELSE GO TO none;
	    array =>
	      IF Default[t.componentType] = nonVoid THEN {
	        PushTree[Tree.Null]; PushNode[all, 1]; GO TO eval}
	      ELSE GO TO none;
	    record =>
	      IF t.hints.default OR recordTail # Tree.Null THEN {
		n: CARDINAL;
		CompleteRecord[LOOPHOLE[s]];
		n _ VisibleCtxEntries[t.fieldCtx];
		FOR i: CARDINAL IN [1..n] DO
		  PushTree[IF i # n THEN Tree.Null ELSE recordTail] ENDLOOP;
		PushProperList[n];  recordTail _ Tree.Null;
		IF tagId = ISENull THEN {PushTree[Tree.Null]; PushNode[apply, -2]; GO TO eval}
		ELSE {
		  PushSe[tagId];  tagId _ ISENull;
		  PushNode[apply,-2];   recordTail _ PopTree[];
		  next _ TypeLink[s];  subType _ UnderType[next]}}
	      ELSE GO TO none;
	    transfer => {
	      PushTree[Tree.Null]; PushNode[nil, 1]; GO TO eval};
	    zone =>
	      IF t.counted THEN {PushTree[Tree.Null]; PushNode[nil, 1]; GO TO eval}
	      ELSE GO TO none;
	    long => next _ t.rangeType;
	    ENDCASE => GO TO none;
	ENDCASE => ERROR;
      REPEAT
	none => {v _ Tree.Null; phraseNP _ none; RPush[subType, VoidAttr]};
	copy => RPush[subType, IF v=Tree.Null THEN VoidAttr ELSE UpdateTreeAttr[v]];
	eval => v _ Initialization[TargetType[subType], PopTree[]];
      ENDLOOP;
    RETURN};


  Voidable: PUBLIC PROC [type: SEIndex] RETURNS [BOOL] = {
    next: SEIndex;
    FOR s: SEIndex _ type, next DO
      WITH se: seb[s] SELECT FROM
	id => {
	  sei: ISEIndex = LOOPHOLE[s];
	  IF seb[sei].extended THEN RETURN [VoidItem[FindExtension[sei].tree]];
	  next _ seb[sei].idInfo};
	cons =>
	  WITH t: se SELECT FROM
	    ref => RETURN [~t.counted];
	    array => next _ t.componentType;
	    record => RETURN [t.hints.voidable];
	    union => RETURN [t.hints.voidable];
	    long => next _ t.rangeType;
	    zone => RETURN [~t.counted];
	    ENDCASE => RETURN [TRUE];
	ENDCASE => ERROR;
      ENDLOOP};

  VoidItem: PUBLIC PROC [t: Tree.Link] RETURNS [void: BOOL] = {
    TestVoid: Tree.Scan = {IF OpName[t] = void THEN void _ TRUE};
    void _ FALSE;  ScanList[t, TestVoid];  RETURN};


 -- discrimination operations
 
  Narrowing: PUBLIC PROC [type, target: CSEIndex] RETURNS [op: NarrowOp _ []] = {
    typeL: CSEIndex _ target;
    typeR: CSEIndex _ type;
    nextL, nextR: SEIndex;
    IF ~Types.Equivalent[[dataPtr.ownSymbols, type], [dataPtr.ownSymbols, target]] THEN
     DO
      WITH tR: seb[typeR] SELECT FROM
	any =>
	  WITH tL: seb[typeL] SELECT FROM
	    any => EXIT;
	    opaque => {
	      op.rtTest _ TRUE;
	      IF typeL # dataPtr.typeAtomRecord THEN op.unImpl _ TRUE;
	      EXIT};
	    ENDCASE => {
	      op.rtTest _ TRUE;
	      IF ~Discriminated[typeL] THEN EXIT;
	      nextL _ typeL;  nextR _ TypeRoot[typeL]};
	record =>
	  WITH tL: seb[typeL] SELECT FROM
	    record => {
	      IF Types.Equivalent[[dataPtr.ownSymbols, typeL], [dataPtr.ownSymbols, typeR]]
	        THEN EXIT;
	      WITH vL: tL SELECT FROM
	        linked => {
		  uType: CSEIndex = VariantUnionType[vL.linkType];
		  WITH u: seb[uType] SELECT FROM
		    union => IF u.controlled THEN op.tagTest _ TRUE ELSE op.computed _ TRUE;
		    ENDCASE => op.error _ TRUE;
		  nextL _ vL.linkType;  nextR _ typeR};
		ENDCASE => op.error _ TRUE};
	    ENDCASE => op.error _ TRUE;
	ref =>
	  WITH tL: seb[typeL] SELECT FROM
	    ref => {
	      IF op.indirect OR (tL.counted # tR.counted) OR (tR.readOnly AND ~tL.readOnly)
	        THEN op.error _ TRUE;
	      op.indirect _ TRUE;
	      nextL _ tL.refType;  nextR _ tR.refType};
	    ENDCASE => op.error _ TRUE;
	transfer =>
	  WITH tL: seb[typeL] SELECT FROM
	    transfer => {
	      IF op.indirect OR tL.mode # tR.mode OR tL.safe # tR.safe THEN
	        op.error _ TRUE;
	      SELECT tL.mode FROM
		proc, signal, error => NULL;
		ENDCASE => op.error _ TRUE;
	      IF TypeForm[tL.typeIn] = any OR TypeForm[tL.typeOut] = any THEN
	        op.error _ TRUE;	-- for now
	      IF TypeForm[tR.typeIn] = any THEN
	        op.rtTest _ TRUE
	      ELSE IF ~Types.Equivalent[
	          [dataPtr.ownSymbols, tL.typeIn],
		  [dataPtr.ownSymbols, tR.typeIn]] THEN op.error _ TRUE;
	      IF TypeForm[tR.typeOut] = any THEN
	        op.rtTest _ TRUE
	      ELSE IF ~Types.Equivalent[
	          [dataPtr.ownSymbols, tL.typeOut],
		  [dataPtr.ownSymbols, tR.typeOut]] THEN op.error _ TRUE;
	      EXIT};
	    ENDCASE => op.error _ TRUE;
	long =>
	  WITH tL: seb[typeL] SELECT FROM
	    long => {nextL _ tL.rangeType; nextR _ tR.rangeType};
	    ENDCASE => op.error _ TRUE;
	ENDCASE => {
	  IF Types.Equivalent[[dataPtr.ownSymbols, typeL], [dataPtr.ownSymbols, typeR]]
	    THEN EXIT;
	  op.error _ TRUE};
      IF op.error THEN EXIT;
      typeL _ UnderType[nextL];  typeR _ UnderType[nextR];
      ENDLOOP;
    RETURN};
    
  Discriminated: PROC [type: CSEIndex] RETURNS [BOOL] = INLINE {
    RETURN [TypeLink[type] # SENull]};  -- check that at tag exists?
    
  MarkedType: PUBLIC PROC [type: CSEIndex] RETURNS [CSEIndex] = {
    subType: CSEIndex = NormalType[type];
    RETURN [WITH t: seb[subType] SELECT FROM
      ref => UnderType[TypeRoot[t.refType]],
      transfer => subType,
      ENDCASE => typeANY]};
    
 -- type construction

  MakeLongType: PUBLIC PROC [rType: SEIndex, hint: CSEIndex]
      RETURNS [type: CSEIndex] = {
    subType: CSEIndex = UnderType[rType];
    WITH t: seb[hint] SELECT FROM
      long => IF TargetType[UnderType[t.rangeType]] = TargetType[subType] THEN RETURN [hint];
      ENDCASE;
    WITH t: seb[subType] SELECT FROM
      relative => {
	oType: CSEIndex = MakeLongType[UnderType[t.offsetType], UnderType[t.resultType]];
	type _ MakeNonCtxSe[SIZE[relative cons SERecord]];
	seb[type] _ [mark3: TRUE, mark4: TRUE,
	    body: cons[relative[
		baseType: t.baseType, offsetType: oType, resultType: oType]]]};
      ENDCASE => {
	type _ MakeNonCtxSe[SIZE[long cons SERecord]];
	seb[type] _ [mark3: TRUE, mark4: TRUE, body: cons[long[rangeType: rType]]]};
    RETURN};

  MakeRefType: PUBLIC PROC [
        cType: SEIndex, hint: CSEIndex, readOnly, counted, var: BOOL]
      RETURNS [type: RefSEIndex] = {
    WITH t: seb[hint] SELECT FROM
      ref =>
	IF ~t.ordered
	 AND t.readOnly = readOnly AND t.counted = counted AND t.var = var
	 AND UnderType[t.refType] = UnderType[cType] THEN RETURN [LOOPHOLE[hint]];
      ENDCASE;
    type _ LOOPHOLE[MakeNonCtxSe[SIZE[ref cons SERecord]]];
    seb[type] _ [mark3: TRUE, mark4: TRUE,
	body: cons[ref[
	    counted: counted,
	    var: var,
	    readOnly: readOnly, ordered: FALSE, list: FALSE, basing: FALSE,
	    refType: cType]]];
    RETURN};

  }.