-- file TypePack.Mesa
-- last modified by Satterthwaite, October 30, 1979  3:19 PM

DIRECTORY
  StringDefs: FROM "stringdefs" USING [SubStringDescriptor, EqualSubStrings],
  SymbolTable: FROM "symboltable" USING [Base],
  Symbols: FROM "symbols" USING [
    HTIndex, SEIndex, ISEIndex, CSEIndex, RecordSEIndex, CTXIndex, MDIndex,
    HTNull, OwnMdi, SENull, StandardContext, typeANY],
  Types: FROM "types" USING [Handle];

TypePack: PROGRAM IMPORTS StringDefs EXPORTS Types =
  BEGIN
  OPEN Symbols;

 -- internal utilities

  HTHandle: TYPE = RECORD[
    stb: SymbolTable.Base,
    hti: HTIndex];

  EqualIds: PROCEDURE [id1, id2: HTHandle] RETURNS [BOOLEAN] =
    BEGIN
    OPEN b1: id1.stb, b2: id2.stb;
    ss1, ss2: StringDefs.SubStringDescriptor;
    IF id1 = id2 THEN RETURN [TRUE];
    b1.SubStringForHash[@ss1, id1.hti];  b2.SubStringForHash[@ss2, id2.hti];
    RETURN [StringDefs.EqualSubStrings[@ss1, @ss2]]
    END;


  CTXHandle: TYPE = RECORD[
    stb: SymbolTable.Base,
    ctx: CTXIndex];

  EqContexts: PROCEDURE [context1, context2: CTXHandle] RETURNS [BOOLEAN] =
    BEGIN
    OPEN b1: context1.stb, b2: context2.stb;
    ctx1, ctx2: CTXIndex;
    mdi1, mdi2: MDIndex;
    IF context1 = context2 THEN RETURN [TRUE];
    IF context1.stb = context2.stb THEN RETURN [FALSE];
    IF context1.ctx IN StandardContext
      THEN RETURN [context1.ctx = context2.ctx];	-- predefined types
    WITH c1: b1.ctxb[context1.ctx] SELECT FROM
      simple =>  BEGIN  mdi1 _ OwnMdi;  ctx1 _ context1.ctx  END;
      included =>  BEGIN  mdi1 _ c1.module;  ctx1 _ c1.map  END;
      ENDCASE => ERROR;
    WITH c2: b2.ctxb[context2.ctx] SELECT FROM
      simple =>  BEGIN  mdi2 _ OwnMdi;  ctx2 _ context2.ctx  END;
      included =>  BEGIN  mdi2 _ c2.module;  ctx2 _ c2.map  END;
      ENDCASE => ERROR;
    RETURN [ctx1 = ctx2 AND b1.mdb[mdi1].stamp = b2.mdb[mdi2].stamp]
    END;


 -- type relations

  Equivalent: PUBLIC PROCEDURE [type1, type2: Types.Handle] RETURNS [BOOLEAN] =
    BEGIN
    RETURN [type1 = type2 OR
	EqualTypes[type1, type2 ! Resolved => RESUME [FALSE]] ]
    END;

  EqualTypes: PROCEDURE [type1, type2: Types.Handle] RETURNS [BOOLEAN] =
    BEGIN
    OPEN b1: type1.stb, b2: type2.stb;
    IF type1 = type2 OR type1.sei = typeANY OR type2.sei = typeANY
      THEN RETURN [TRUE];
    RETURN [WITH t1: b1.seb[type1.sei] SELECT FROM
      basic =>
	WITH t2: b2.seb[type2.sei] SELECT FROM
	  basic => t1.code = t2.code,
	  ENDCASE => FALSE,
      enumerated =>
	WITH t2: b2.seb[type2.sei] SELECT FROM
	  enumerated =>
	    EqContexts[[type1.stb, t1.valueCtx], [type2.stb, t2.valueCtx]],
	  ENDCASE => FALSE,
      record =>
	WITH t2: b2.seb[type2.sei] SELECT FROM
	  record =>
	    EqContexts[[type1.stb, t1.fieldCtx], [type2.stb, t2.fieldCtx]],
	  ENDCASE => FALSE,
      pointer =>
	WITH t2: b2.seb[type2.sei] SELECT FROM
	  pointer =>
	    (t1.ordered = t2.ordered) AND (t1.readOnly = t2.readOnly)
	     AND Equal[[type1.stb, t1.refType], [type2.stb, t2.refType]],
	  ENDCASE => FALSE,
      array =>
	WITH t2: b2.seb[type2.sei] SELECT FROM
	  array =>
	    t1.oldPacked = t2.oldPacked 
	     AND Equal[
		[type1.stb, t1.componentType], 
		[type2.stb, t2.componentType]]
	     AND Equal[
		[type1.stb, t1.indexType], 
		[type2.stb, t2.indexType]],
	  ENDCASE => FALSE,
      arraydesc =>
	WITH t2: b2.seb[type2.sei] SELECT FROM
	  arraydesc =>
	    t1.readOnly = t2.readOnly
	     AND Equal[
		[type1.stb, t1.describedType], 
		[type2.stb, t2.describedType]],
	  ENDCASE => FALSE,
      transfer =>
	WITH t2: b2.seb[type2.sei] SELECT FROM
	  transfer =>
	    t1.mode = t2.mode
	     AND CheckArgs[
		[type2.stb, t2.inRecord], [type1.stb, t1.inRecord], TRUE]
	     AND CheckArgs[
		[type1.stb, t1.outRecord], [type2.stb, t2.outRecord], TRUE],
	  ENDCASE => FALSE,
      union =>
	WITH t2: b2.seb[type2.sei] SELECT FROM
	  union =>
	    EqContexts[[type1.stb, t1.caseCtx], [type2.stb, t2.caseCtx]],
	  ENDCASE => FALSE,
      relative =>
	WITH t2: b2.seb[type2.sei] SELECT FROM
	  relative =>
	    Equal[[type1.stb, t1.baseType], [type2.stb, t2.baseType]] 
	     AND
	    Equal[[type1.stb, t1.offsetType], [type2.stb, t2.offsetType]],
	  ENDCASE => FALSE,
      subrange =>
	WITH t2: b2.seb[type2.sei] SELECT FROM
	  subrange =>
	    Equal[[type1.stb, t1.rangeType], [type2.stb, t2.rangeType]]
	      AND 
	       (~t1.filled OR ~t2.filled
		OR (t1.origin = t2.origin AND t1.empty = t2.empty
		    AND (t1.empty OR t1.range = t2.range))),
	  ENDCASE => FALSE,
      long =>
	WITH t2: b2.seb[type2.sei] SELECT FROM
	  long => Equal[[type1.stb, t1.rangeType], [type2.stb, t2.rangeType]],
	  ENDCASE => FALSE,
      real =>
	WITH t2: b2.seb[type2.sei] SELECT FROM
	  real => TRUE,
	  ENDCASE => FALSE,
      nil =>  type1.sei = type2.sei,
      ENDCASE => FALSE]
    END;

  SEHandle: TYPE = RECORD[
    stb: SymbolTable.Base,
    sei: SEIndex];

  Resolved: SIGNAL [se1, se2: SEHandle] RETURNS [BOOLEAN] = CODE;

  Equal: PROCEDURE [type1, type2: SEHandle] RETURNS [BOOLEAN] =
    BEGIN
    OPEN b1: type1.stb, b2: type2.stb;
    RETURN [
      type1 = type2
	OR
      (IF b1.seb[type1.sei].seTag = id AND b2.seb[type2.sei].seTag = id
	  THEN
	    ((SIGNAL Resolved[type1, type2])
		OR
	     EqualTypes[ [type1.stb, b1.UnderType[type1.sei]],
			 [type2.stb, b2.UnderType[type2.sei]]
	       ! Resolved =>
		  IF se1 = type1 AND se2 = type2 THEN RESUME [TRUE]])
	  ELSE
      EqualTypes[ [type1.stb, b1.UnderType[type1.sei]],
		  [type2.stb, b2.UnderType[type2.sei]]]) ]
    END;


  Assignable: PUBLIC PROCEDURE [typeL, typeR: Types.Handle] RETURNS [BOOLEAN] =
    BEGIN
    OPEN bL: typeL.stb, bR: typeR.stb;
    ENABLE Resolved => RESUME [FALSE];
    IF typeL = typeR OR typeL.sei = typeANY OR typeR.sei = typeANY
      THEN RETURN [TRUE];
    RETURN [
      FreeAssignable[
	  typeL,
	  typeR,
	  IF bR.seb[typeR.sei].typeTag = record THEN ref ELSE val]
       OR FreeAssignable[FullRangeType[typeL], FullRangeType[typeR], val]]
    END;


  Mode: TYPE = {val, ref};

  FreeAssignable: PROCEDURE [typeL, typeR: Types.Handle, mode: Mode] RETURNS [BOOLEAN] =
    BEGIN
    OPEN bL: typeL.stb, bR: typeR.stb;
    IF typeL = typeR OR typeL.sei = typeANY OR typeR.sei = typeANY
      THEN RETURN [TRUE];
    RETURN [WITH tR: bR.seb[typeR.sei] SELECT FROM
      record =>
	WITH tL: bL.seb[typeL.sei] SELECT FROM
	  record =>
	    EqContexts[[typeL.stb, tL.fieldCtx], [typeR.stb, tR.fieldCtx]]
	     OR
	    ((mode = ref --OR tL.length = tR.length--) AND
	      (WITH tR SELECT FROM
		linked => Conformable[
				[typeL.stb, typeL.sei],
				[typeR.stb, linkType],
				mode],
		ENDCASE => FALSE)),
	  ENDCASE => FALSE,
      pointer =>
	WITH tL: bL.seb[typeL.sei] SELECT FROM
	  pointer =>
	    (~tL.ordered OR tR.ordered) AND
	     (IF tL.readOnly OR bL.TypeForm[tL.refType] = record
		THEN Conformable[
		    [typeL.stb, tL.refType], [typeR.stb, tR.refType], ref]
		ELSE ~tR.readOnly AND Equivalent[
		    [typeL.stb, bL.UnderType[tL.refType]], 
		    [typeR.stb, bR.UnderType[tR.refType]]]),
	  ENDCASE => FALSE,
      array =>
	WITH tL: bL.seb[typeL.sei] SELECT FROM
	  array =>
	    tL.oldPacked = tR.oldPacked 
	     AND Conformable[
		[typeL.stb, tL.componentType], 
		[typeR.stb, tR.componentType],
		val]
	     AND Equivalent[
		[typeL.stb, bL.UnderType[tL.indexType]], 
		[typeR.stb, bR.UnderType[tR.indexType]]],
	  ENDCASE => FALSE,
      arraydesc =>
	WITH tL: bL.seb[typeL.sei] SELECT FROM
	  arraydesc =>
	    (tL.readOnly OR ~tR.readOnly)
	     AND Covering[
		[typeL.stb, bL.UnderType[tL.describedType]], 
		[typeR.stb, bR.UnderType[tR.describedType]]],
	  ENDCASE => FALSE,
      transfer =>
	WITH tL: bL.seb[typeL.sei] SELECT FROM
	  transfer =>
	    (tL.mode = tR.mode OR (tL.mode = error AND tR.mode = signal))
	     AND CheckArgs[
		[typeR.stb, tR.inRecord], [typeL.stb, tL.inRecord], FALSE]
	     AND CheckArgs[
		[typeL.stb, tL.outRecord], [typeR.stb, tR.outRecord], FALSE],
	  ENDCASE => FALSE,
      relative =>
	WITH tL: bL.seb[typeL.sei] SELECT FROM
	  relative =>
	    Equivalent[
		[typeL.stb, bL.UnderType[tL.baseType]], 
		[typeR.stb, bR.UnderType[tR.baseType]]]
	     AND FreeAssignable[
		FullRangeType[[typeL.stb, bL.UnderType[tL.offsetType]]], 
		FullRangeType[[typeR.stb, bR.UnderType[tR.offsetType]]],
		mode],
	  ENDCASE => FALSE,
      subrange =>
	FreeAssignable[FullRangeType[typeL], FullRangeType[typeR], val]
	 AND
	  (WITH tL: bL.seb[typeL.sei] SELECT FROM
	    subrange =>
	      ~tL.filled OR ~tR.filled
		OR (tL.origin = tR.origin
		    AND (tR.empty OR (~tL.empty AND tL.range >= tR.range))),
	    ENDCASE => (~tR.filled OR tR.origin = 0)),
      long =>
	WITH tL: bL.seb[typeL.sei] SELECT FROM
	  long =>
	    FreeAssignable[
		FullRangeType[[typeL.stb, bL.UnderType[tL.rangeType]]], 
		FullRangeType[[typeR.stb, bR.UnderType[tR.rangeType]]],
		val],
	  real =>  bR.UnderType[tR.rangeType] = typeANY,
	  ENDCASE => FALSE,
      real =>
	WITH tL: bL.seb[typeL.sei] SELECT FROM
	  real => TRUE,
	  long => bL.UnderType[tL.rangeType] = typeANY,
	  ENDCASE => FALSE,
      ENDCASE => Equivalent[typeL, typeR]]
    END;

  Conformable: PROCEDURE [type1, type2: SEHandle, mode: Mode] RETURNS [BOOLEAN] =
    BEGIN
    OPEN b1: type1.stb, b2: type2.stb;
    RETURN [
      type1 = type2
	OR
      (IF b1.seb[type1.sei].seTag = id AND b2.seb[type2.sei].seTag = id
	  THEN
	    ((SIGNAL Resolved[type1, type2])
		OR
	     FreeAssignable[ [type1.stb, b1.UnderType[type1.sei]],
			     [type2.stb, b2.UnderType[type2.sei]],
			     mode
	       ! Resolved =>
		  IF se1 = type1 AND se2 = type2 THEN RESUME [TRUE]])
	  ELSE
      FreeAssignable[ [type1.stb, b1.UnderType[type1.sei]],
		      [type2.stb, b2.UnderType[type2.sei]],
		      mode]) ]
    END;


-- auxiliary predicates

  ArgHandle: TYPE = RECORD[
    stb: SymbolTable.Base,
    sei: RecordSEIndex];

  CheckArgs: PROCEDURE [arg1, arg2: ArgHandle, strict: BOOLEAN] RETURNS [BOOLEAN] =
    BEGIN
    OPEN b1: arg1.stb, b2: arg2.stb;
    sei1, sei2: ISEIndex;
    checkIds: BOOLEAN;
    IF arg1.sei = SENull OR arg2.sei = SENull
      THEN RETURN [arg1.sei = arg2.sei];
    checkIds _ strict OR
	~(b1.seb[arg1.sei].hints.unifield OR b2.seb[arg2.sei].hints.unifield);
    sei1 _ b1.FirstCtxSe[b1.seb[arg1.sei].fieldCtx];
    sei2 _ b2.FirstCtxSe[b2.seb[arg2.sei].fieldCtx];
    UNTIL sei1 = SENull OR sei2 = SENull
      DO
      IF ~(IF strict
	    THEN Equal[
		[arg1.stb, b1.seb[sei1].idType],
		[arg2.stb, b2.seb[sei2].idType]]
	    ELSE Conformable[
		[arg1.stb, b1.seb[sei1].idType],
		[arg2.stb, b2.seb[sei2].idType],
		val])
       OR (checkIds
	    AND b1.seb[sei1].hash # HTNull
	    AND b2.seb[sei2].hash # HTNull
	    AND ~EqualIds[
		[arg1.stb, b1.seb[sei1].hash],
		[arg2.stb, b2.seb[sei2].hash]])
	THEN RETURN [FALSE];
      sei1 _ b1.NextSe[sei1];  sei2 _ b2.NextSe[sei2];
      ENDLOOP;
    RETURN [sei1 = sei2]
    END;


  Covering: PROCEDURE [typeL, typeR: Types.Handle] RETURNS [BOOLEAN] =
    BEGIN
    OPEN bL: typeL.stb, bR: typeR.stb;
    IF typeL = typeR THEN RETURN [TRUE];
    RETURN [WITH tL: bL.seb[typeL.sei] SELECT FROM
      array =>
	WITH tR: bR.seb[typeR.sei] SELECT FROM
	  array =>
	    tL.oldPacked = tR.oldPacked
	     AND Equivalent[
		[typeL.stb, bL.UnderType[tL.componentType]], 
		[typeR.stb, bR.UnderType[tR.componentType]]]
	     AND Conformable[
		[typeL.stb, tL.indexType], [typeR.stb, tR.indexType], val],
	  ENDCASE => FALSE,
      ENDCASE => Equivalent[typeL, typeR]]
    END;

  FullRangeType: PROCEDURE [type: Types.Handle] RETURNS [Types.Handle] =
    BEGIN
    OPEN b: type.stb;
    sei, next: CSEIndex;
    FOR sei _ type.sei, next
      DO
      WITH b.seb[sei] SELECT FROM
	subrange =>  next _ b.UnderType[rangeType];
	ENDCASE =>  EXIT; 
      ENDLOOP;
    RETURN [[type.stb, sei]]
    END;

  END.
(1800)\7520v13V35v13V