<<>> <> <> <> <> <> <<>> DIRECTORY RealSupport USING [FScale, CardToReal], RuntimeError USING [BoundsFault, ZeroDivisor], DRealSupport USING [FScale, CardToDReal]; <<>> DSupportImpl: CEDAR PROGRAM IMPORTS RealSupport, RuntimeError, DRealSupport = BEGIN <> <> <> <<>> ExternalNames: PROC [] = TRUSTED MACHINE CODE { "^ExternalNames\n"; <<--test feature>> "D64SetTestMode XR_D64SetTestMode\n"; <<--integer conversions>> "DCardCard XR_DCardCard\n"; "DCardInt XR_DCardInt\n"; "DCardDInt XR_DCardDIntI\n"; "DIntInt XR_DIntInt\n"; "DIntCard XR_DIntCard\n"; "DIntDCard XR_DIntDCardI\n"; "CardDInt XR_CardDIntI\n"; "CardDCard XR_CardDCardI\n"; "IntDInt XR_IntDIntI\n"; "IntDCard XR_IntDCardI\n"; <<--DCARD operations>> "DCardAdd XR_DCardAddI\n"; "DCardSub XR_DCardSubI\n"; "DCardMul XR_DCardMulI\n"; "DCardDiv XR_DCardDivI\n"; "DCardMod XR_DCardModI\n"; "DCardPwr XR_DCardPwrI\n"; "DCardMin XR_DCardMinI\n"; "DCardMax XR_DCardMaxI\n"; "DCardGt XR_DCardGtI\n"; "DCardGe XR_DCardGeI\n"; "DEq XR_DEqI\n"; <<--DINT operations>> "DIntNeg XR_DIntNegI\n"; "DIntAdd XR_DIntAddI\n"; "DIntSub XR_DIntSubI\n"; "DIntMul XR_DIntMulI\n"; "DIntDiv XR_DIntDivI\n"; "DIntMod XR_DIntModI\n"; "DIntPwr XR_DIntPwrI\n"; "DIntMin XR_DIntMinI\n"; "DIntMax XR_DIntMaxI\n"; "DIntGt XR_DIntGtI\n"; "DIntGe XR_DIntGeI\n"; "DIntAbs XR_DIntAbsI\n"; <<--Floating point and D conversions>> "DFloatDInt XR_DFloatDIntI\n"; "DFloatDCard XR_DFloatDCardI\n"; "FloatDInt XR_FloatDIntI\n"; "FloatDCard XR_FloatDCardI\n"; }; DPointer: TYPE = POINTER TO DNumber; DNumber: TYPE = MACHINE DEPENDENT RECORD [ SELECT OVERLAID * FROM c64 => [c64: CARD64], i64 => [i64: INT64], r64 => [r64: REAL64], c32 => [ch32, cl32: CARD32], i32 => [ih32, il32: INT32], c16 => [d3, d2, d1, d0: CARD16], < [bit0: [0..1], nhr: NAT31, bit32: [0..1], nlr: NAT31],>> < [nhl: NAT31, bit31: [0..1], nll: NAT31, bit63: [0..1]],>> ENDCASE ]; arithmeticError64: SIGNAL = CODE; overFlowTests64: BOOL ¬ FALSE; --set TRUE for debugging package; FALSE for normal usage conversiontests64: BOOL = TRUE; ConversionError: PROC [] = { IF conversiontests64 THEN ERROR RuntimeError.BoundsFault; }; Overflow: PROC [] = { IF overFlowTests64 THEN SIGNAL arithmeticError64; }; D64SetTestMode: UNSAFE PROC [c: CARD] = TRUSTED { <<--This procedure is private between this module and its test code.>> <<--Other applications must not use this; if the feature is required and approved>> <<--it would be put in a definition module, made work on a per process basis>> <<--and set and removed in a region protected with an enable scope >> overFlowTests64 ¬ c#0 }; DCardCard: UNSAFE PROC [res: DPointer, c: CARD32] = TRUSTED { res.cl32 ¬ c; res.ch32 ¬ 0; }; DCardInt: UNSAFE PROC [res: DPointer, i: INT32] = TRUSTED { IF i<0 THEN ConversionError[]; res.il32 ¬ i; res.ch32 ¬ 0; }; DCardDInt: UNSAFE PROC [res, dint: DPointer] = TRUSTED { IF dint.ih32<0 THEN ConversionError[]; res­ ¬ dint­; }; DIntCard: UNSAFE PROC [res: DPointer, c: CARD32] = TRUSTED { res.ch32 ¬ 0; res.cl32 ¬ c; }; DIntInt: UNSAFE PROC [res: DPointer, i: INT32] = TRUSTED { IF i>=0 THEN res.ih32 ¬ 0 ELSE res.ih32 ¬ -1; res.il32 ¬ i; }; DIntDCard: UNSAFE PROC [res, dcard: DPointer] = TRUSTED { IF dcard.ih32<0 THEN ConversionError[]; res­ ¬ dcard­; }; CardDInt: UNSAFE PROC [dint: DPointer] RETURNS [CARD32] = TRUSTED { IF dint.ch32#0 THEN ConversionError[]; RETURN [dint.cl32]; }; CardDCard: UNSAFE PROC [dcard: DPointer] RETURNS [CARD32] = TRUSTED { IF dcard.ch32#0 THEN ConversionError[]; RETURN [dcard.cl32]; }; IntDInt: UNSAFE PROC [dint: DPointer] RETURNS [INT32] = TRUSTED { SELECT dint.ch32 FROM 0 => IF dint.il32<0 THEN ConversionError[]; LAST[CARD] => IF dint.il32>=0 THEN ConversionError[]; ENDCASE => ConversionError[]; RETURN [dint.il32]; }; IntDCard: UNSAFE PROC [dcard: DPointer] RETURNS [INT32] = TRUSTED { IF dcard.ch32#0 OR dcard.il32<0 THEN ConversionError[]; RETURN [dcard.il32]; }; DCardAdd: UNSAFE PROC [res, a, b: DPointer] = TRUSTED { over: CARD32 ¬ IF (LAST[CARD32]-a.cl32)> <> r0 ¬ a.d0*b.d0; <<-->> <> p1a ¬ a.d1*b.d0; p1b ¬ a.d0*b.d1; carry3 ¬ IF LAST[CARD32]-p1a> <> p2a ¬ a.d2*b.d0; p2b ¬ a.d1*b.d1; p2c ¬ a.d0*b.d2; IF LAST[CARD32]-p2a> <> p3a ¬ a.d3*b.d0 + carry3; --can't overflow p3b ¬ a.d2*b.d1; p3c ¬ a.d1*b.d2; p3d ¬ a.d0*b.d3; IF p3a>unit OR p3b>unit OR p3c>unit OR p3d>unit THEN Overflow[]; r3 ¬ p3a + p3b + p3c + p3d; <<-->> <> <<-->> <> <<-->> <> -- <<--res.d0>> res.d0 ¬ r0 MOD unit; r0 ¬ r0/unit; -- <<--res.d1>> carry3 ¬ IF LAST[CARD32]-r1> IF LAST[CARD32]-r2> IF r3>unit THEN Overflow[]; r3 ¬ r3 + r2 + carry3; --can't overflow anymore res.d3 ¬ r3 MOD unit; <<--res.d4..6>> IF r3>=unit OR (a.d3>0 AND (b.d1+b.d2+b.d3>0)) OR (b.d3>0 AND (a.d1+a.d2>0)) OR (a.d2>0 AND b.d2>0) THEN Overflow[]; }; Div2: PROC [a: DPointer] RETURNS [res: DNumber] = TRUSTED { res.cl32 ¬ (a.ch32 MOD 2) * 20000000000B + a.cl32 / 2; res.ch32 ¬ a.ch32 / 2; }; Mul2: PROC [a: DPointer] RETURNS [res: DNumber] = TRUSTED INLINE { res.c64 ¬ a.c64 + a.c64 }; DCardDiv: UNSAFE PROC [res, a, b: DPointer] = TRUSTED { IF a.c64 res­ ¬ Div2[a]; 1 => res­ ¬ a­; 0 => SIGNAL RuntimeError.ZeroDivisor; ENDCASE => ERROR; } ELSE { result: DNumber ¬ [c64[0]]; d: DNumber ¬ b­; count: NAT ¬ 1; rest: DNumber ¬ Div2[a]; WHILE d.c64<=rest.c64 DO d ¬ Mul2[@d]; count ¬ count + 1 ENDLOOP; rest ¬ a­; FOR i: NAT IN [0..count) DO result ¬ Mul2[@result]; IF rest.c64>=d.c64 THEN {rest.c64 ¬ rest.c64 - d.c64; result.c64 ¬ result.c64 + 1}; d ¬ Div2[@d]; ENDLOOP; res­ ¬ result; }; }; DCardMod: UNSAFE PROC [res, a, b: DPointer] = TRUSTED { res.c64 ¬ a.c64 - (a.c64 / b.c64) * b.c64; }; DCardPwr: UNSAFE PROC [res, a, b: DPointer] = TRUSTED { MixedPwr: UNSAFE PROC [x: CARD64, y: CARD32] RETURNS [CARD64] = TRUSTED { SELECT y FROM 0 => RETURN [1]; 1 => RETURN [x]; ENDCASE => IF y MOD 2 # 0 THEN RETURN [x * MixedPwr[x*x, y / 2]] ELSE RETURN [MixedPwr[x*x, y / 2]]; }; IF b.ch32>0 THEN { IF a.ch32>0 THEN Overflow[] ELSE SELECT a.cl32 FROM 0 => res.c64 ¬ 0; 1 => res.c64 ¬ a.c64; ENDCASE => Overflow[]; RETURN; }; res.c64 ¬ MixedPwr[a.c64, b.cl32] }; DCardGt: UNSAFE PROC [a, b: DPointer] RETURNS [BOOL] = TRUSTED { SELECT TRUE FROM a.ch32>b.ch32 => RETURN [TRUE]; a.ch32 RETURN [FALSE]; ENDCASE => RETURN [a.cl32>b.cl32] }; DCardGe: UNSAFE PROC [a, b: DPointer] RETURNS [BOOL] = TRUSTED { SELECT TRUE FROM a.ch32>b.ch32 => RETURN [TRUE]; a.ch32 RETURN [FALSE]; ENDCASE => RETURN [a.cl32>=b.cl32] }; DEq: UNSAFE PROC [a, b: DPointer] RETURNS [BOOL] = TRUSTED { RETURN [a.cl32=b.cl32 AND a.ch32=b.ch32] }; DCardMin: UNSAFE PROC [res, a, b: DPointer] = TRUSTED { IF DCardGt[a, b] THEN res­ ¬ b­ ELSE res­ ¬ a­ }; DCardMax: UNSAFE PROC [res, a, b: DPointer] = TRUSTED { IF DCardGt[a, b] THEN res­ ¬ a­ ELSE res­ ¬ b­ }; XDIntNeg: UNSAFE PROC [res, a: DPointer] = TRUSTED { n1: DNumber ¬ [c32[LAST[CARD32], LAST[CARD32]]]; p1: DNumber ¬ [c32[0, 1]]; t: DNumber; DIntSub[@t, @n1, a]; DIntSub[res, @t, @p1]; }; Neg64: UNSAFE PROC [res, n: DPointer] = TRUSTED { <> res.cl32 ¬ LAST[CARD32] - n.cl32; res.ch32 ¬ LAST[CARD32] - n.ch32; IF res.cl32=LAST[CARD32] THEN {res.ch32 ¬ res.ch32 + 1; res.cl32 ¬ 0} ELSE res.cl32 ¬ res.cl32 + 1 }; IsDFirstNeg: PROC [a: DPointer] RETURNS [BOOL ] = TRUSTED INLINE { RETURN [a.cl32=0 AND a.ih32=FIRST[INT32]] }; DIntNeg: UNSAFE PROC [res, a: DPointer] = TRUSTED { IF IsDFirstNeg[a] THEN Overflow[]; Neg64[res, a]; }; DIntAdd: UNSAFE PROC [res, a, b: DPointer] = TRUSTED { over: CARD32 ¬ IF (LAST[CARD32]-a.cl32)=0 AND b.ih32>=0) OR (LOOPHOLE[h, INT32]>=0 AND a.ih32<0 AND b.ih32<0) THEN Overflow[]; res.cl32 ¬ a.cl32 + b.cl32; res.ch32 ¬ h; }; DIntSub: UNSAFE PROC [res, a, b: DPointer] = TRUSTED { over: CARD32 ¬ IF a.cl32=0 AND b.ih32>=0) OR (a.ih32>=0 AND LOOPHOLE[h, INT32]<0 AND b.ih32<0) THEN Overflow[]; res.cl32 ¬ a.cl32 - b.cl32; res.ch32 ¬ h; }; DIntMul: UNSAFE PROC [res, a, b: DPointer] = TRUSTED { x, y: DNumber; invert: BOOL ¬ FALSE; IF a.ih32>=0 THEN x ¬ a­ ELSE {Neg64[@x, a]; invert ¬ NOT invert}; IF b.ih32>=0 THEN y ¬ b­ ELSE {Neg64[@y, b]; invert ¬ NOT invert}; x.c64 ¬ x.c64*y.c64; IF x.ih32<0 THEN Overflow[]; IF invert THEN Neg64[res, @x] ELSE res­ ¬ x; }; DIntDiv: UNSAFE PROC [res, a, b: DPointer] = TRUSTED { x, y: DNumber; invert: BOOL ¬ FALSE; IF a.ih32>=0 THEN x ¬ a­ ELSE {Neg64[@x, a]; invert ¬ NOT invert}; IF b.ih32>=0 THEN y ¬ b­ ELSE {Neg64[@y, b]; invert ¬ NOT invert}; x.c64 ¬ x.c64 / y.c64; IF x.ih32<0 THEN Overflow[]; IF invert THEN Neg64[res, @x] ELSE res­ ¬ x; }; DIntMod: UNSAFE PROC [res, a, b: DPointer] = TRUSTED { <<--will signal RuntimeError.ZeroDivisor if necessary without explicit test here because it is mapped to CARD64 MOD>> IF b.ih32>=0 THEN { IF a.ih32>=0 THEN { res.c64 ¬ a.c64 MOD b.c64 } ELSE { m: DNumber; Neg64[@m, a]; m.c64 ¬ m.c64 MOD b.c64; IF m.ch32=0 AND m.cl32=0 THEN res­ ¬ m ELSE res.c64 ¬ b.c64 - m.c64 } } ELSE { bb, m: DNumber; Neg64[@bb, b]; IF a.ih32>=0 THEN { m.c64 ¬ a.c64 MOD bb.c64; IF m.ch32=0 AND m.cl32=0 THEN res­ ¬ m ELSE res.c64 ¬ m.c64 - bb.c64 } ELSE { Neg64[@m, a]; m.c64 ¬ m.c64 MOD bb.c64; Neg64[res, @m] } } }; DIntPwr: UNSAFE PROC [res, a, b: DPointer] = TRUSTED { x: DNumber; IF b.ih32<0 THEN Overflow[]; IF a.ih32>=0 THEN { x.c64 ¬ a.c64 ** b.c64; IF x.ih32<0 THEN Overflow[] } ELSE { Neg64[@x, a]; x.c64 ¬ x.c64 ** b.c64; IF x.ih32<0 THEN Overflow[]; IF b.cl32 MOD 2 # 0 THEN Neg64[@x, @x]; }; res­ ¬ x; }; DIntGt: UNSAFE PROC [a, b: DPointer] RETURNS [BOOL] = TRUSTED { SELECT TRUE FROM a.ih32>b.ih32 => RETURN [TRUE]; a.ih32 RETURN [FALSE]; a.ih32<0 => RETURN [a.cl32 RETURN [a.cl32>b.cl32] }; DIntGe: UNSAFE PROC [a, b: DPointer] RETURNS [BOOL] = TRUSTED { SELECT TRUE FROM a.ih32>b.ih32 => RETURN [TRUE]; a.ih32 RETURN [FALSE]; a.ih32<0 => RETURN [a.cl32<=b.cl32]; ENDCASE => RETURN [a.cl32>=b.cl32] }; DIntAbs: UNSAFE PROC [res, a: DPointer] = TRUSTED { <<--the result is CARD64...>> IF a.ih32>=0 THEN res­ ¬ a­ ELSE Neg64[res, a] --no crash on FIRST[INT64] }; DIntMin: UNSAFE PROC [res, a, b: DPointer] = TRUSTED { IF DIntGt[a, b] THEN res­ ¬ b­ ELSE res­ ¬ a­ }; DIntMax: UNSAFE PROC [res, a, b: DPointer] = TRUSTED { IF DIntGt[a, b] THEN res­ ¬ a­ ELSE res­ ¬ b­ }; DFloatDCard: UNSAFE PROC [res, a: DPointer] = TRUSTED { res.r64 ¬ DRealSupport.FScale[DRealSupport.CardToDReal[a.ch32], 32] + DRealSupport.CardToDReal[a.cl32] }; DFloatDInt: UNSAFE PROC [res: DPointer, a: DPointer] = TRUSTED { IF a.ih32>=0 THEN res.r64 ¬ a.c64 ELSE { aa: DNumber; Neg64[@aa, a]; aa.r64 ¬ aa.c64; res.r64 ¬ -aa.r64 } }; FloatDCard: UNSAFE PROC [dcard: DPointer] RETURNS [REAL] = TRUSTED { RETURN [RealSupport.FScale[RealSupport.CardToReal[dcard.ch32], 32] + RealSupport.CardToReal[dcard.cl32]] }; FloatDInt: UNSAFE PROC [dint: DPointer] RETURNS [r: REAL] = TRUSTED { IF dint.ih32>=0 THEN r ¬ dint.c64 ELSE { aa: DNumber; Neg64[@aa, dint]; r ¬ aa.c64; r ¬ -r } }; ExternalNames[]; END.