-- 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.