<> <> <> <> <<>> <> <<>> DIRECTORY BigCardinals USING [BigFromSmall, BigSubtract, FirstOneBit], BigIntegers USING [Abs, BigINT, RopeFromBig, Sgn], IO USING [PutFR, rope], SaffronATDef USING [ExpNode], SaffronBaseDef USING [ChangeType, CompilerStateNode, ContextTreeNode, FieldListNode, LocalContextNode, MakeTrash, RetrieveIntegerValue, RopeFromValue, Static, Type, ValueNode], SaffronContextPrivateTypes USING [AtomTGN, ElementTGNBody, IntegerElementType, NamedTGN, RealTGN, TypeGraphNodeNodeBody], SaffronErrorHandling USING [Error, InternalError]; SaffronTypeConformanceImpl: CEDAR PROGRAM IMPORTS BigCardinals, BigIntegers, IO, SaffronBaseDef, SaffronErrorHandling EXPORTS SaffronATDef, SaffronBaseDef ~ BEGIN OPEN BD: SaffronBaseDef, PT: SaffronContextPrivateTypes; <> BigINT: TYPE ~ BigIntegers.BigINT; TypeGraphNodeNode: TYPE ~ REF TypeGraphNodeNodeBody; TypeGraphNodeNodeBody: PUBLIC TYPE ~ PT.TypeGraphNodeNodeBody; <> < REAL, for instance)?>> <<>> CompileAndTypeCheckExpression: PUBLIC PROC[exp: SaffronATDef.ExpNode, ct: BD.ContextTreeNode, cs: BD.CompilerStateNode, targetType: TypeGraphNodeNode] RETURNS[BD.ValueNode, BD.ContextTreeNode] ~ BEGIN i: BD.ValueNode; iType: TypeGraphNodeNode; ctr: BD.ContextTreeNode; conform: BOOLEAN; conversionProc: ConversionProc; <> <> <> <> [i, ctr] _ exp.procs.CompileExpression[exp, ct, cs, targetType]; iType _ BD.Type[i]; <> <> <> <> [conform, conversionProc] _ Conform[iType, targetType]; IF NOT conform THEN { SIGNAL SaffronErrorHandling.Error[0, IO.PutFR["%g has incorrect type (expected %g).", IO.rope[BD.RopeFromValue[i]], IO.rope[""]]]; RETURN[BD.MakeTrash[targetType], ctr]; }; i _ conversionProc[i, targetType]; IF TRUE THEN i _ RangeCheck[i, targetType]; -- should test range-check flag in cs RETURN[i, ctr]; END; EvaluateAndTypeCheckExpression: PUBLIC PROC[exp: SaffronATDef.ExpNode, lc: BD.LocalContextNode, fl: BD.FieldListNode, cs: BD.CompilerStateNode, targetType: TypeGraphNodeNode] RETURNS[BD.ValueNode] ~ BEGIN <> i: BD.ValueNode; iType: TypeGraphNodeNode; conform: BOOLEAN; conversionProc: ConversionProc; <> <> <> <> i _ exp.procs.EvaluateExpression[exp, lc, fl, cs, targetType]; iType _ BD.Type[i]; <> <> <> <> [conform, conversionProc] _ Conform[iType, targetType]; IF NOT conform THEN { SIGNAL SaffronErrorHandling.Error[0, IO.PutFR["%g has incorrect type (expected %g).", IO.rope[BD.RopeFromValue[i]], IO.rope[""]]]; RETURN[BD.MakeTrash[targetType]]; }; i _ conversionProc[i, targetType]; IF TRUE THEN i _ RangeCheck[i, targetType]; -- should test range-check flag in cs RETURN[i]; END; <> DemandNumber: PUBLIC PROC[i: BD.ValueNode] RETURNS[BD.ValueNode] ~ BEGIN type: TypeGraphNodeNode _ BD.Type[i]; WHILE ISTYPE[type.body, PT.NamedTGN] DO type _ NARROW[type.body, PT.NamedTGN].type; ENDLOOP; -- ugghh <> IF ISTYPE[type.body, REF integer base PT.ElementTGNBody] OR ISTYPE[type.body, REF integer base PT.ElementTGNBody] THEN RETURN[i] ELSE { SIGNAL SaffronErrorHandling.Error[0, IO.PutFR["%g has incorrect type (expected a number).", IO.rope[BD.RopeFromValue[i]]]]; RETURN[BD.MakeTrash[NIL]]; }; END; ConformsToInteger: PUBLIC PROC[i: TypeGraphNodeNode] RETURNS[BOOLEAN] ~ BEGIN RETURN[TRUE]; END; DemandBoolean: PUBLIC PROC[i: BD.ValueNode] RETURNS[BD.ValueNode] ~ BEGIN type: TypeGraphNodeNode _ BD.Type[i]; WHILE ISTYPE[type.body, PT.NamedTGN] DO type _ NARROW[type.body, PT.NamedTGN].type; ENDLOOP; -- ugghh <> IF ISTYPE[type.body, REF boolean base PT.ElementTGNBody] THEN RETURN[i] ELSE { SIGNAL SaffronErrorHandling.Error[0, IO.PutFR["%g has incorrect type (expected a boolean value).", IO.rope[BD.RopeFromValue[i]]]]; RETURN[BD.MakeTrash[NIL]]; }; END; <> <> <<(Mesa manual, section 2.4.7): "If two types are completely interchangeable, they are said to be equivalent. A value having a given type is acceptable in any context requiring a value of any other type equivalent to it; there is no operational difference between two equivalent types.">> <> <> Equivalent: PROC [t1, t2: TypeGraphNodeNode] RETURNS [BOOLEAN] ~ BEGIN <> WHILE ISTYPE[t1.body, PT.NamedTGN] DO t1 _ NARROW[t1.body, PT.NamedTGN].type; ENDLOOP; WHILE ISTYPE[t2.body, PT.NamedTGN] DO t2 _ NARROW[t2.body, PT.NamedTGN].type; ENDLOOP; <> RETURN [ WITH t1.body SELECT FROM u: PT.AtomTGN => EquivalentAtomBaseType[u, t2], u: REF boolean base PT.ElementTGNBody => EquivalentBooleanBaseType[u, t2], u: REF integer base PT.ElementTGNBody => EquivalentIntegerBaseType[u, t2], < EquivalentSpecial[u, t2],>> < EquivalentSubrange[u, t2], >> < EquivalentRecord[u, t2], >> < EquivalentPointer[u, t2], >> < EquivalentRef[u, t2], >> < EquivalentVar[u, t2], >> < EquivalentRelative[u, t2], >> < EquivalentReferent[u, t2], >> < EquivalentList[u, t2], >> < EquivalentEnum[u, t2], >> < EquivalentVariantPart[u, t2], >> < EquivalentSequence[u, t2], >> < EquivalentArray[u, t2], >> < EquivalentDescriptor[u, t2], >> < EquivalentTransfer[u, t2], >> < EquivalentZone[u, t2], >> < EquivalentLong[u, t2], >> < EquivalentInterface[u, t2], >> < EquivalentLink[u, t2], >> < EquivalentFrame[u, t2], >> < EquivalentSpecianated[u, t2], >> < EquivalentOpaque[u, t2], >> ENDCASE => ERROR SaffronErrorHandling.InternalError["Unrecognized type passed as first argument to SaffronTypeConformanceImpl.Equivalent"] ]; END; <> EquivalentAtomBaseType: PROC [u: PT.AtomTGN, t2: TypeGraphNodeNode] RETURNS [BOOLEAN] ~ BEGIN RETURN[ISTYPE[t2.body, PT.AtomTGN]]; END; EquivalentBooleanBaseType: PROC [u: REF boolean base PT.ElementTGNBody, t2: TypeGraphNodeNode] RETURNS [BOOLEAN] ~ BEGIN RETURN[ISTYPE[t2.body, REF boolean base PT.ElementTGNBody]]; END; EquivalentIntegerBaseType: PROC [u: REF integer base PT.ElementTGNBody, t2: TypeGraphNodeNode] RETURNS [BOOLEAN] ~ BEGIN IF ISTYPE[t2.body, REF integer base PT.ElementTGNBody] THEN { u2: REF integer base PT.ElementTGNBody _ NARROW[t2.body]; RETURN[(u.body.signed = u2.body.signed) AND (u.body.nBits = u2.body.nBits) AND (u.body.nUnusedBits = u2.body.nUnusedBits)]; } ELSE RETURN[FALSE]; END; <<>> <> <> <<(Mesa manual, section 3.5.3): "The relationship of free conformace...is defined so that it can be computed recursively. Loosely speaking, one type freely conforms to another if a value of the first can always be used as a value of the second without any computation or run-time check of validity. ">> < t1 freely conforms to t2, and t2 freely conforms to t1 . It implies conformace: t1 freely conforms to t2 => t1 conforms to t2.>> <> FreelyConform: PROC [t1, t2: TypeGraphNodeNode] RETURNS [BOOLEAN] ~ BEGIN <> WHILE ISTYPE[t1.body, PT.NamedTGN] DO t1 _ NARROW[t1.body, PT.NamedTGN].type; ENDLOOP; WHILE ISTYPE[t2.body, PT.NamedTGN] DO t2 _ NARROW[t2.body, PT.NamedTGN].type; ENDLOOP; <> IF Equivalent[t1, t2] THEN RETURN[TRUE]; RETURN [ WITH t1.body SELECT FROM u: PT.AtomTGN => FALSE, u: REF boolean base PT.ElementTGNBody => FALSE, u: REF integer base PT.ElementTGNBody => FALSE, < FreelyConformSpecial[u, t2],>> < FreelyConformSubrange[u, t2], >> < FreelyConformRecord[u, t2], >> < FreelyConformPointer[u, t2], >> < FreelyConformRef[u, t2], >> < FreelyConformVar[u, t2], >> < FreelyConformRelative[u, t2], >> < FreelyConformReferent[u, t2], >> < FreelyConformList[u, t2], >> < FreelyConformEnum[u, t2], >> < FreelyConformVariantPart[u, t2], >> < FreelyConformSequence[u, t2], >> < FreelyConformArray[u, t2], >> < FreelyConformDescriptor[u, t2], >> < FreelyConformTransfer[u, t2], >> < FreelyConformZone[u, t2], >> < FreelyConformLong[u, t2], >> < FreelyConformInterface[u, t2], >> < FreelyConformLink[u, t2], >> < FreelyConformFrame[u, t2], >> < FreelyConformSpecianated[u, t2], >> < FreelyConformOpaque[u, t2], >> ENDCASE => ERROR SaffronErrorHandling.InternalError["Unrecognized type passed as first argument to SaffronTypeConformanceImpl.FreelyConform"] ]; END; <> <> <> <<(Mesa manual, section 2.4.7): "One type is said to conform to another if any value of the first type can be assigned to a variable of the second type...In more interesting cases, an automatic application of a conversion function may be required prior to the assignment.">> < t1 and t2 freely conform; t1 freely conforms to t2 => t1 conforms to t2.>> <> <<(1) A boolean value which indicates whether or not the two types conform. >> <<(2) A procedure which takes two arguments. The first argument, i, must be an instance of type t1; the second must be type type t2. (no upward funargs, mutter, grumble, grumble) This procedure returns a new instance whose type freely conforms with t2 and whose value is the (possibly converted) value of i. The conversions which might be performed are listed in section 3.5.1 of the Mesa manual.>> <> <> ConversionProc: TYPE = PROC[instance: BD.ValueNode, type: TypeGraphNodeNode] RETURNS[BD.ValueNode]; IdentityConversion: ConversionProc = {RETURN[instance]}; MeaninglessConversion: ConversionProc = { ERROR SaffronErrorHandling.InternalError["You shouldn't have called this proc."] }; Conform: PROC [t1, t2: TypeGraphNodeNode] RETURNS [conform: BOOLEAN, conversionProc: ConversionProc] ~ BEGIN <> WHILE ISTYPE[t1.body, PT.NamedTGN] DO t1 _ NARROW[t1.body, PT.NamedTGN].type; ENDLOOP; WHILE ISTYPE[t2.body, PT.NamedTGN] DO t2 _ NARROW[t2.body, PT.NamedTGN].type; ENDLOOP; <> IF FreelyConform[t1, t2] THEN RETURN[TRUE, IdentityConversion]; <> [conform, conversionProc] _ WITH t1.body SELECT FROM u: PT.AtomTGN => NoConform[], u: REF boolean base PT.ElementTGNBody => NoConform[], u: REF integer base PT.ElementTGNBody => ConformIntegerBaseType[u, t2], < ConformSpecial[u, t2],>> < ConformSubrange[u, t2], >> < ConformRecord[u, t2], >> < ConformPointer[u, t2], >> < ConformRef[u, t2], >> < ConformVar[u, t2], >> < ConformRelative[u, t2], >> < ConformReferent[u, t2], >> < ConformList[u, t2], >> < ConformEnum[u, t2], >> < ConformVariantPart[u, t2], >> < ConformSequence[u, t2], >> < ConformArray[u, t2], >> < ConformDescriptor[u, t2], >> < ConformTransfer[u, t2], >> < ConformZone[u, t2], >> < ConformLong[u, t2], >> < ConformInterface[u, t2], >> < ConformLink[u, t2], >> < ConformFrame[u, t2], >> < ConformSpecianated[u, t2], >> < ConformOpaque[u, t2], >> ENDCASE => ERROR SaffronErrorHandling.InternalError["Unrecognized type passed as first argument to SaffronTypeConformanceImpl.Conform"] ; END; <> NoConform: PROC RETURNS [BOOLEAN, ConversionProc] ~ BEGIN RETURN[FALSE, MeaninglessConversion]; END; ConformIntegerBaseType: PROC [u: REF integer base PT.ElementTGNBody, t2: TypeGraphNodeNode] RETURNS [BOOLEAN, ConversionProc] ~ BEGIN conform: BOOLEAN _ ISTYPE[t2.body, REF integer base PT.ElementTGNBody] OR ISTYPE[t2.body, PT.RealTGN]; RETURN[conform, IF conform THEN IntegerConvert ELSE MeaninglessConversion]; END; IntegerConvert: ConversionProc ~ BEGIN RETURN[BD.ChangeType[instance, type]]; END; ConformRealBaseType: PROC [u: PT.RealTGN, t2: TypeGraphNodeNode] RETURNS [BOOLEAN, ConversionProc] ~ BEGIN RETURN[ ISTYPE[t2.body, PT.RealTGN], IdentityConversion ]; END; <> <> <> <> RangeCheck: PROC [i: BD.ValueNode, targetType: TypeGraphNodeNode] RETURNS [BD.ValueNode] ~ BEGIN t1: TypeGraphNodeNode _ BD.Type[i]; t2: TypeGraphNodeNode _ targetType; <> IF NOT FreelyConform[t1, t2] THEN ERROR SaffronErrorHandling.InternalError["Arguments to SaffronTypeRangeCheckanceImpl.RangeCheck do not freely conform."]; <> WHILE ISTYPE[t1.body, PT.NamedTGN] DO t1 _ NARROW[t1.body, PT.NamedTGN].type; ENDLOOP; WHILE ISTYPE[t2.body, PT.NamedTGN] DO t2 _ NARROW[t2.body, PT.NamedTGN].type; ENDLOOP; <> RETURN [ WITH t2.body SELECT FROM u: PT.AtomTGN => i, u: REF boolean base PT.ElementTGNBody => i, u: REF integer base PT.ElementTGNBody => RangeCheckIntegerBaseType[i, t2], < RangeCheckSpecial[u, t2],>> < RangeCheckSubrange[u, t2], >> < RangeCheckRecord[u, t2], >> < RangeCheckPointer[u, t2], >> < RangeCheckRef[u, t2], >> < RangeCheckVar[u, t2], >> < RangeCheckRelative[u, t2], >> < RangeCheckReferent[u, t2], >> < RangeCheckList[u, t2], >> < RangeCheckEnum[u, t2], >> < RangeCheckVariantPart[u, t2], >> < RangeCheckSequence[u, t2], >> < RangeCheckArray[u, t2], >> < RangeCheckDescriptor[u, t2], >> < RangeCheckTransfer[u, t2], >> < RangeCheckZone[u, t2], >> < RangeCheckLong[u, t2], >> < RangeCheckInterface[u, t2], >> < RangeCheckLink[u, t2], >> < RangeCheckFrame[u, t2], >> < RangeCheckSpecianated[u, t2], >> < RangeCheckOpaque[u, t2], >> ENDCASE => ERROR SaffronErrorHandling.InternalError["Unrecognized type passed as first argument to SaffronTypeRangeCheckanceImpl.RangeCheck"] ]; END; <> RangeCheckIntegerBaseType: PROC [i: BD.ValueNode, targetType: TypeGraphNodeNode] RETURNS [BD.ValueNode] ~ BEGIN IF BD.Static[i] THEN BEGIN value: BigINT _ BD.RetrieveIntegerValue[i]; IF CanCastIntegerValue[value, targetType] THEN RETURN[i] ELSE { SIGNAL SaffronErrorHandling.Error[0, IO.PutFR[ "Integer value %g out of range of type %g", IO.rope[BigIntegers.RopeFromBig[value]], IO.rope[""]]]; RETURN[BD.MakeTrash[targetType]]; }; END ELSE BEGIN <> RETURN[i]; END; END; CanCastIntegerValue: PUBLIC PROC [value: BigINT, type: TypeGraphNodeNode] RETURNS [BOOLEAN] ~ BEGIN baseType: PT.IntegerElementType; WHILE ISTYPE[type.body, PT.NamedTGN] DO -- bletch! do I have to do this everywhere? type _ NARROW[type.body, PT.NamedTGN].type; ENDLOOP; baseType _ NARROW[type.body, REF integer base PT.ElementTGNBody].body; IF baseType.signed THEN { nValueBits: INT _ BigCardinals.FirstOneBit[BigCardinals.BigSubtract[ BigIntegers.Abs[value], BigCardinals.BigFromSmall[IF BigIntegers.Sgn[value] = minus THEN 1 ELSE 0]]] + 1; IF (nValueBits + 1) > baseType.nBits THEN RETURN[FALSE]; } ELSE { nValueBits: INT _ BigCardinals.FirstOneBit[BigIntegers.Abs[value]] + 1; IF BigIntegers.Sgn[value] = minus THEN RETURN[FALSE]; IF nValueBits > baseType.nBits THEN RETURN[FALSE]; }; RETURN[TRUE]; END; END.