-- file TypePack.mesa
-- last modified by Satterthwaite, February 17, 1983 4:51 pm

DIRECTORY
  Strings: TYPE USING [SubStringDescriptor, EqualSubStrings],
  SymbolTable: TYPE USING [Base],
  Symbols: TYPE USING [
    Name, SEIndex, ISEIndex, CSEIndex, RecordSEIndex, CTXIndex, MDIndex,
    nullName, MDNull, OwnMdi, ISENull, RecordSENull, StandardContext,
    typeANY, typeTYPE],
  Types: TYPE USING [Handle];

TypePack: PROGRAM IMPORTS Strings EXPORTS Types = {
  OPEN Symbols;

 -- internal utilities

  NameHandle: TYPE = RECORD [
    stb: SymbolTable.Base,
    name: Name];

  EqualIds: PROC [id1, id2: NameHandle] RETURNS [BOOL] = {
    OPEN b1: id1.stb, b2: id2.stb;
    ss1, ss2: Strings.SubStringDescriptor;
    IF id1 = id2 THEN RETURN [TRUE];
    b1.SubStringForName[@ss1, id1.name];  b2.SubStringForName[@ss2, id2.name];
    RETURN [Strings.EqualSubStrings[@ss1, @ss2]]};


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

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

  OpaqueValue: PROC [type: Types.Handle, base: SymbolTable.Base]
      RETURNS [val: Types.Handle] = {
    OPEN b1: type.stb;
    val ← type;		-- the default
    WITH t1: b1.seb[type.sei] SELECT FROM
      opaque => {
	mdi1: MDIndex = WITH c1: b1.ctxb[b1.seb[t1.id].idCtx] SELECT FROM
			  included => c1.module,
			  imported => b1.ctxb[c1.includeLink].module,
			  ENDCASE => OwnMdi;
	mdi2: MDIndex = base.FindMdi[b1.mdb[mdi1].stamp];
	IF mdi2 # MDNull AND base.mdb[mdi2].exported THEN {
	  ss: Strings.SubStringDescriptor;
	  sei2: ISEIndex;
	  b1.SubStringForName[@ss, b1.seb[t1.id].hash];
	  sei2 ← base.SearchContext[base.FindString[@ss], base.mainCtx];
	  IF sei2 # ISENull
	   AND base.seb[sei2].idType = typeTYPE AND base.seb[sei2].public THEN
	    val ← [base, base.UnderType[sei2]]}};
      ENDCASE;
    RETURN};


 -- type relations

  Equivalent: PUBLIC PROC [type1, type2: Types.Handle] RETURNS [BOOL] = {
    RETURN [type1 = type2 OR EqualTypes[type1, type2
	! Resolved => {RESUME [FALSE]}; Matched => {RESUME [FALSE]}] ]};

  Matched: SIGNAL [m1, m2: Types.Handle] RETURNS [BOOL] = CODE;

  EqualTypes: PROC [type1, type2: Types.Handle] RETURNS [BOOL] = {
    OPEN b1: type1.stb, b2: type2.stb;
    IF type1 = type2 OR type1.sei = typeANY OR type2.sei = typeANY THEN RETURN [TRUE];
    IF (b1.seb[type1.sei].typeTag = opaque) # (b2.seb[type2.sei].typeTag = opaque)
      THEN {type1 ← OpaqueValue[type1, type2.stb]; type2 ← OpaqueValue[type2, type1.stb]};
    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 =>
	    IF ~t1.unpainted THEN
	      ~t2.unpainted AND  EqContexts[[type1.stb, t1.valueCtx], [type2.stb, t2.valueCtx]]
	    ELSE
	      t2.unpainted AND MatchConstants[[type1.stb, t1.valueCtx], [type2.stb, t2.valueCtx]],
	  ENDCASE => FALSE,
      record =>
	WITH t2: b2.seb[type2.sei] SELECT FROM
	  record =>
	    IF t1.painted THEN
	      t2.painted AND EqContexts[[type1.stb, t1.fieldCtx], [type2.stb, t2.fieldCtx]]
	    ELSE
	      ~t2.painted AND t1.argument = t2.argument AND (
		(SIGNAL Matched[type1, type2])
		  OR
		MatchFields[
		  [type1.stb, LOOPHOLE[type1.sei]], [type2.stb, LOOPHOLE[type2.sei]]
		    ! Matched => {IF m1 = type1 AND m2 = type2 THEN RESUME [TRUE]}]),
	  ENDCASE => FALSE,
      ref =>
	WITH t2: b2.seb[type2.sei] SELECT FROM
	  ref =>
	    (t1.counted = t2.counted) AND (t1.var = t2.var)
	     AND (t1.readOnly = t2.readOnly) AND (t1.ordered = t2.ordered)
	     AND Equal[[type1.stb, t1.refType], [type2.stb, t2.refType]],
	  ENDCASE => FALSE,
      array =>
	WITH t2: b2.seb[type2.sei] SELECT FROM
	  array =>
	    t1.packed = t2.packed 
	     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 (t1.safe = t2.safe)
	     AND EqualTypes[[type2.stb, t2.typeIn], [type1.stb, t1.typeIn]]
	     AND EqualTypes[[type1.stb, t1.typeOut], [type2.stb, t2.typeOut]],
	  ENDCASE => FALSE,
      union =>
	WITH t2: b2.seb[type2.sei] SELECT FROM
	  union => EqContexts[[type1.stb, t1.caseCtx], [type2.stb, t2.caseCtx]],
	  ENDCASE => FALSE,
      sequence =>
	WITH t2: b2.seb[type2.sei] SELECT FROM
	  sequence =>
	    t1.packed = t2.packed AND t1.controlled = t2.controlled 
	     AND Equal[[type1.stb, t1.componentType], [type2.stb, t2.componentType]]
	     AND MatchTags[[type1.stb, t1.tagSei], [type2.stb, t2.tagSei]],
	  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,
      opaque =>
	WITH t2: b2.seb[type2.sei] SELECT FROM
	  opaque =>
	    EqContexts[[type1.stb, b1.seb[t1.id].idCtx], [type2.stb, b2.seb[t2.id].idCtx]] 
	     AND
	    EqualIds[[type1.stb, b1.seb[t1.id].hash], [type2.stb, b2.seb[t2.id].hash]],
	  ENDCASE => FALSE,
      zone =>
	WITH t2: b2.seb[type2.sei] SELECT FROM
	  zone => (t1.mds = t2.mds AND t1.counted = t2.counted),
	  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,
      any =>
	WITH t2: b2.seb[type2.sei] SELECT FROM any => TRUE, ENDCASE => FALSE,
      nil => type1.sei = type2.sei,
      ENDCASE => FALSE]};

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

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

  Equal: PROC [type1, type2: SEHandle] RETURNS [BOOL] = {
    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]]]) ]};


  Assignable: PUBLIC PROC [typeL, typeR: Types.Handle] RETURNS [BOOL] = {
    OPEN bL: typeL.stb, bR: typeR.stb;
    ENABLE {Resolved => {RESUME [FALSE]}; Matched => {RESUME [FALSE]}};
    IF typeL = typeR OR typeL.sei = typeANY OR typeR.sei = typeANY THEN
      RETURN [TRUE];
    RETURN [
      FreeAssignable[typeL, typeR, val]
       OR
      (SELECT typeL.stb.TypeForm[typeL.sei] FROM
	record, opaque => ConformingVariant[typeL, typeR]
	ENDCASE => FreeAssignable[FullRangeType[typeL], FullRangeType[typeR], val])]};


  Mode: TYPE = {val, ref};

  FreeAssignable: PROC [typeL, typeR: Types.Handle, mode: Mode] RETURNS [BOOL] = {
    OPEN bL: typeL.stb, bR: typeR.stb;
    IF typeL = typeR OR typeL.sei = typeANY OR typeR.sei = typeANY THEN
      RETURN [TRUE];
    IF (bL.seb[typeL.sei].typeTag = opaque) # (bR.seb[typeR.sei].typeTag = opaque)
      THEN {
	typeL ← OpaqueValue[typeL, typeR.stb]; typeR ← OpaqueValue[typeR, typeL.stb]};
    RETURN [WITH tR: bR.seb[typeR.sei] SELECT FROM
      record =>
	WITH tL: bL.seb[typeL.sei] SELECT FROM
	  record =>
	    IF (tL.painted OR tR.painted) THEN Equivalent[typeL, typeR]
	    ELSE
	      tL.argument = tR.argument AND (
		(SIGNAL Matched[typeL, typeR])
		  OR
		CheckFields[
		  [typeL.stb, LOOPHOLE[typeL.sei]], [typeR.stb, LOOPHOLE[typeR.sei]], mode
		    ! Matched => {IF m1 = typeL AND m2 = typeR THEN RESUME [TRUE]}]),
	  ENDCASE => FALSE,
      ref =>
	WITH tL: bL.seb[typeL.sei] SELECT FROM
	  ref =>
	    (tL.counted = tR.counted) AND (tL.var = tR.var) AND
	     (~tL.ordered OR tR.ordered) AND
	     (~tR.readOnly OR tL.readOnly) AND
	     (SELECT bL.TypeForm[tL.refType] FROM
		record, opaque =>
		  ConformingVariant[	-- assumes immutability
			    [typeL.stb, bL.UnderType[tL.refType]], 
			    [typeR.stb, bR.UnderType[tR.refType]]]
		    OR
		  (tL.readOnly
		    AND Conformable[[typeL.stb, tL.refType], [typeR.stb, tR.refType], ref]),
		any => TRUE,
		ENDCASE =>
		  IF ~tL.readOnly THEN
		    Equivalent[
			    [typeL.stb, bL.UnderType[tL.refType]], 
			    [typeR.stb, bR.UnderType[tR.refType]]]
		  ELSE Conformable[[typeL.stb, tL.refType], [typeR.stb, tR.refType], ref])
	  ENDCASE => FALSE,
      array =>
	WITH tL: bL.seb[typeL.sei] SELECT FROM
	  array =>
	    tL.packed = tR.packed 
	     AND Equivalent[
		[typeL.stb, bL.UnderType[tL.indexType]], 
		[typeR.stb, bR.UnderType[tR.indexType]]]
	     AND (
	      IF tL.packed THEN
		Equivalent[
			[typeL.stb, bL.UnderType[tL.componentType]], 
			[typeR.stb, bR.UnderType[tR.componentType]]]
	      ELSE Conformable[
		  [typeL.stb, tL.componentType], [typeR.stb, tR.componentType], mode])
	  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 (~tL.safe OR tR.safe)
	     AND (FreeAssignable[[typeR.stb, tR.typeIn], [typeL.stb, tL.typeIn], mode]
	           OR bL.TypeForm[tL.typeIn] = any)
	     AND (FreeAssignable[[typeL.stb, tL.typeOut], [typeR.stb, tR.typeOut], mode]
	           OR bL.TypeForm[tL.typeOut] = any),
	  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], mode]
	 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]]],
		mode],
	  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]]};

  Conformable: PROC [type1, type2: SEHandle, mode: Mode] RETURNS [BOOL] = {
    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]) ]};

  ConformingVariant: PROC [typeL, typeR: Types.Handle]
      RETURNS [BOOL] = {
    OPEN bL: typeL.stb, bR: typeR.stb;
    RETURN [
      Equivalent[typeL, typeR]
	OR
      (WITH tR: bR.seb[typeR.sei] SELECT FROM
	record =>
	  WITH tV: tR SELECT FROM
	    linked => ConformingVariant[typeL, [typeR.stb, bR.UnderType[tV.linkType]]],
	    ENDCASE => FALSE,
	ENDCASE => FALSE)]};


-- auxiliary predicates

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

  MatchFields: PROC [rec1, rec2: RecordHandle] RETURNS [BOOL] = {
    OPEN b1: rec1.stb, b2: rec2.stb;
    sei1, sei2: ISEIndex;
    IF rec1.sei = RecordSENull OR rec2.sei = RecordSENull
      THEN RETURN [rec1.sei = rec2.sei];
    IF EqContexts[[rec1.stb, b1.seb[rec1.sei].fieldCtx], [rec2.stb, b2.seb[rec2.sei].fieldCtx]]
      THEN RETURN [TRUE];
    sei1 ← b1.FirstCtxSe[b1.seb[rec1.sei].fieldCtx];
    sei2 ← b2.FirstCtxSe[b2.seb[rec2.sei].fieldCtx];
    UNTIL sei1 = ISENull OR sei2 = ISENull DO
      IF ~(Equal[[rec1.stb, b1.seb[sei1].idType], [rec2.stb, b2.seb[sei2].idType]] AND
	    EqualIds[[rec1.stb, b1.seb[sei1].hash], [rec2.stb, b2.seb[sei2].hash]])
	THEN RETURN [FALSE];
      sei1 ← b1.NextSe[sei1];  sei2 ← b2.NextSe[sei2];
      ENDLOOP;
    RETURN [sei1 = sei2]};

  CheckFields: PROC [rec1, rec2: RecordHandle, mode: Mode] RETURNS [BOOL] = {
    OPEN b1: rec1.stb, b2: rec2.stb;
    sei1, sei2: ISEIndex;
    checkIds: BOOL;
    IF rec1.sei = RecordSENull OR rec2.sei = RecordSENull
      THEN RETURN [rec1.sei = rec2.sei];
    IF EqContexts[[rec1.stb, b1.seb[rec1.sei].fieldCtx], [rec2.stb, b2.seb[rec2.sei].fieldCtx]]
      THEN RETURN [TRUE];
    checkIds ← ~(b1.seb[rec1.sei].hints.unifield OR b2.seb[rec2.sei].hints.unifield);
    sei1 ← b1.FirstCtxSe[b1.seb[rec1.sei].fieldCtx];
    sei2 ← b2.FirstCtxSe[b2.seb[rec2.sei].fieldCtx];
    UNTIL sei1 = ISENull OR sei2 = ISENull DO
      IF ~Conformable[[rec1.stb, b1.seb[sei1].idType], [rec2.stb, b2.seb[sei2].idType], mode]
       OR (checkIds AND
	    b1.seb[sei1].hash # nullName AND b2.seb[sei2].hash # nullName AND
	    ~EqualIds[[rec1.stb, b1.seb[sei1].hash], [rec2.stb, b2.seb[sei2].hash]])
	THEN RETURN [FALSE];
      sei1 ← b1.NextSe[sei1];  sei2 ← b2.NextSe[sei2];
      ENDLOOP;
    RETURN [sei1 = sei2]};

  MatchConstants: PROC [context1, context2: CTXHandle] RETURNS [BOOL] = {
    OPEN b1: context1.stb, b2: context2.stb;
    sei1, sei2: ISEIndex;
    IF EqContexts[context1, context2] THEN RETURN [TRUE];
    sei1 ← b1.FirstCtxSe[context1.ctx];
    sei2 ← b2.FirstCtxSe[context2.ctx];
    UNTIL sei1 = ISENull OR sei2 = ISENull DO
      IF ~EqualIds[[context1.stb, b1.seb[sei1].hash], [context2.stb, b2.seb[sei2].hash]]
      	THEN RETURN [FALSE];
      sei1 ← b1.NextSe[sei1];  sei2 ← b2.NextSe[sei2];
      ENDLOOP;
    RETURN [sei1 = sei2]};

  ISEHandle: TYPE = RECORD [
    stb: SymbolTable.Base,
    sei: ISEIndex];
    
  MatchTags: PROC [tag1, tag2: ISEHandle] RETURNS [BOOL] = {
    OPEN b1: tag1.stb, b2: tag2.stb;
    RETURN [
     EqualIds[[tag1.stb, b1.seb[tag1.sei].hash], [tag2.stb, b2.seb[tag2.sei].hash]] AND
     Equal[[tag1.stb, b1.seb[tag1.sei].idType], [tag2.stb, b2.seb[tag2.sei].idType]]]};


  Covering: PROC [typeL, typeR: Types.Handle] RETURNS [BOOL] = {
    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.packed = tR.packed
	     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]]};

  FullRangeType: PROC [type: Types.Handle] RETURNS [Types.Handle] = {
    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]]};

  }.