<<>> <> <> <> <> <> <> <<>> DIRECTORY DRealSupport, FloatingPointCommon USING [Error, NumberType]; DRealSupportImpl: CEDAR PROGRAM IMPORTS FloatingPointCommon EXPORTS DRealSupport = BEGIN OPEN DRealSupport; NumberType: TYPE = FloatingPointCommon.NumberType; simpleClassification: BOOL = NumberType.LAST.ORD = 6 AND NumberType.zero.ORD = 0 AND NumberType.subnormal.ORD = 1 AND NumberType.normal.ORD = 2 AND NumberType.infinity.ORD = 3 AND NumberType.quiet.ORD = 4 AND NumberType.signaling.ORD = 5 AND NumberType.other.ORD = 6; <> Classify: PUBLIC PROC [d: DREAL] RETURNS [NumberType] = TRUSTED { w: WORD = DRealClassifyI[@d]; IF simpleClassification THEN <> RETURN [VAL[w]] ELSE SELECT w FROM 0 => RETURN [zero]; 1 => RETURN [subnormal]; 2 => RETURN [normal]; 3 => RETURN [infinity]; 4 => RETURN [quiet]; 5 => RETURN [signaling]; ENDCASE => RETURN [other]; }; Example: PUBLIC PROC [c: NumberType, min: BOOL ¬ FALSE] RETURNS [DREAL] = TRUSTED { d: DREAL ¬ 0.0; SELECT c FROM subnormal => IF min THEN { help: UNSAFE PROC [p: PDREAL] = UNCHECKED MACHINE CODE { "+#define ex_subnormal_min(x) (DRealPtr(x)=min_subnormal())\n"; ".ex_subnormal_min" }; help[@d]; } ELSE { help: UNSAFE PROC [p: PDREAL] = UNCHECKED MACHINE CODE { "+#define ex_subnormal_max(x) (DRealPtr(x)=max_subnormal())\n"; ".ex_subnormal_max" }; help[@d]; }; normal => IF min THEN { help: UNSAFE PROC [p: PDREAL] = UNCHECKED MACHINE CODE { "+#define ex_normal_min(x) (DRealPtr(x)=min_normal())\n"; ".ex_normal_min" }; help[@d]; } ELSE { help: UNSAFE PROC [p: PDREAL] = UNCHECKED MACHINE CODE { "+#define ex_normal_max(x) (DRealPtr(x)=max_normal())\n"; ".ex_normal_max" }; help[@d]; }; infinity => { help: UNSAFE PROC [p: PDREAL] = UNCHECKED MACHINE CODE { "+#define ex_infinity(x) (DRealPtr(x)=infinity())\n"; ".ex_infinity" }; help[@d]; }; quiet => { help: UNSAFE PROC [p: PDREAL] = UNCHECKED MACHINE CODE { "+#define ex_quiet(x) (DRealPtr(x)=quiet_nan(0))\n"; ".ex_quiet" }; help[@d]; }; signaling => { help: UNSAFE PROC [p: PDREAL] = UNCHECKED MACHINE CODE { "+#define ex_signaling(x) (DRealPtr(x)=signaling_nan(0))\n"; ".ex_signaling" }; help[@d]; }; ENDCASE; RETURN [d]; }; DRealToReal: PUBLIC PROC [d: DREAL] RETURNS [REAL] = TRUSTED { RETURN [FloatDRealI[@d]]; }; <<>> IntToDReal: PUBLIC PROC [i: INT] RETURNS [ret: DREAL] = TRUSTED { DFloatInt[@ret, i]; }; <<>> CardToDReal: PUBLIC PROC [c: CARD] RETURNS [ret: DREAL] = TRUSTED { DFloatCard[@ret, c]; }; <<>> RealToDReal: PUBLIC PROC [r: REAL] RETURNS [ret: DREAL] = TRUSTED { DFloatReal[@ret, r]; }; <<>> Fix: PUBLIC PROC [x: DREAL] RETURNS [INT] = { <<... rounds toward zero (error if outside the INT range)>> last: INT = INT.LAST; first: INT = INT.FIRST; ret: INT ¬ 0; frac: DREAL ¬ 0.0; IF x < first THEN ERROR FloatingPointCommon.Error[other]; IF x >= CARD[last]+1 THEN ERROR FloatingPointCommon.Error[other]; [ret, frac] ¬ Modf[x]; IF x < 0.0 THEN IF frac # 0.0 THEN ret ¬ ret - 1; RETURN [ret]; }; <<>> Round: PUBLIC PROC [x: DREAL] RETURNS [INT] = { <<... rounds toward nearest (error if outside the INT range)>> last: INT = INT.LAST; first: INT = INT.FIRST; ret: INT ¬ 0; frac: DREAL ¬ 0.0; IF x <= first THEN { IF (x+0.5) >= first THEN RETURN [first]; ERROR FloatingPointCommon.Error[other]; }; IF x >= last THEN { IF (x-0.5) <= last THEN RETURN [last]; ERROR FloatingPointCommon.Error[other]; }; [ret, frac] ¬ Modf[x]; SELECT TRUE FROM frac < 0.5 => ret ¬ ret - 1; frac = 0.5 => IF (ret MOD 2) # 0 THEN ret ¬ ret + 1; ENDCASE => ret ¬ ret + 1; RETURN [ret]; }; Modf: PROC [x: DREAL] RETURNS [int: INT, frac: DREAL] = TRUSTED { DRealModfI: UNSAFE PROC [x: PDREAL, frac: PDREAL, ip: POINTER TO DINT] = UNCHECKED MACHINE CODE { "+extern void XR_DRealModfI (x, frac, ip) W2 *x, *frac; double *ip; {\n"; " double d = DRealPtr(x);\n"; " d = modf(d, ip);\n"; " DRealPtr(frac) = d;\n"; " }\n"; ".XR_DRealModfI"; }; di: DINT; DRealModfI[@x, @frac, @di]; int ¬ di; }; <<>> FScale: PUBLIC PROC [a: DREAL, scale: INTEGER] RETURNS [DREAL] = { SELECT scale FROM -2 => RETURN [a*0.25]; -1 => RETURN [a*0.5]; 0 => RETURN [a]; 1 => RETURN [a*2.0]; 2 => RETURN [a*4.0]; ENDCASE => { half: INTEGER = scale/2; rem: INTEGER = scale-half; RETURN [FScale[1.0, half]*FScale[a, rem]]; }; }; <<>> Neg: PUBLIC PROC [d: DREAL] RETURNS [ret: DREAL] = TRUSTED { DRealNegI[@ret, @d]; }; <<>> Abs: PUBLIC PROC [d: DREAL] RETURNS [ret: DREAL] = TRUSTED { DRealAbsI[@ret, @d]; }; <<>> Add: PUBLIC PROC [x, y: DREAL] RETURNS [ret: DREAL] = TRUSTED { DRealAddI[@ret, @x, @y]; }; <<>> Sub: PUBLIC PROC [x, y: DREAL] RETURNS [ret: DREAL] = TRUSTED { DRealSubI[@ret, @x, @y]; }; <<>> Mul: PUBLIC PROC [x, y: DREAL] RETURNS [ret: DREAL] = TRUSTED { DRealMulI[@ret, @x, @y]; }; <<>> Div: PUBLIC PROC [x, y: DREAL] RETURNS [ret: DREAL] = TRUSTED { DRealDivI[@ret, @x, @y]; }; <<>> Gt: PUBLIC PROC [x, y: DREAL] RETURNS [BOOL] = TRUSTED { RETURN [DRealGtI[@x, @y]]; }; <<>> Ge: PUBLIC PROC [x, y: DREAL] RETURNS [BOOL] = TRUSTED { RETURN [DRealGeI[@x, @y]]; }; <<>> Lt: PUBLIC PROC [x, y: DREAL] RETURNS [BOOL] = TRUSTED { RETURN [DRealLtI[@x, @y]]; }; <<>> Le: PUBLIC PROC [x, y: DREAL] RETURNS [BOOL] = TRUSTED { RETURN [DRealLeI[@x, @y]]; }; <<>> Eq: PUBLIC PROC [x, y: DREAL] RETURNS [BOOL] = TRUSTED { RETURN [DRealEqI[@x, @y]]; }; <<>> Ne: PUBLIC PROC [x, y: DREAL] RETURNS [BOOL] = TRUSTED { RETURN [DRealNeI[@x, @y]]; }; <<>> Min: PUBLIC PROC [x, y: DREAL] RETURNS [ret: DREAL] = TRUSTED { DRealMinI[@ret, @x, @y]; }; <<>> Max: PUBLIC PROC [x, y: DREAL] RETURNS [ret: DREAL] = TRUSTED { DRealMaxI[@ret, @x, @y]; }; <<>> Pwr: PUBLIC PROC [x, y: DREAL] RETURNS [ret: DREAL] = TRUSTED { DRealPwrI[@ret, @x, @y]; }; <<>> Floor: PUBLIC PROC [x: DREAL] RETURNS [ret: DREAL] = TRUSTED { DRealFloorI[@ret, @x]; }; <<>> Ceiling: PUBLIC PROC [x: DREAL] RETURNS [ret: DREAL] = TRUSTED { DRealCeilingI[@ret, @x]; }; <> PREAL: TYPE = POINTER TO REAL; PDREAL: TYPE = POINTER TO DREAL; DRealClassifyI: UNSAFE PROC [x: PDREAL] RETURNS [NAT] = UNCHECKED MACHINE CODE { "+extern word XR_DRealClassifyI (x) W2 *x; {\n"; " double d = DRealPtr(x);\n"; " word w = fp_class(d);\n"; " switch (w) {\n"; " case fp_zero: return (0);\n"; " case fp_subnormal: return (1);\n"; " case fp_normal: return (2);\n"; " case fp_infinity: return (3);\n"; " case fp_quiet: return (4);\n"; " case fp_signaling: return (5);\n"; " };\n"; " return (6);\n"; " }\n"; ".XR_DRealClassifyI"; }; <<>> FloatDFloatI: UNSAFE PROC [x: PDREAL] RETURNS [REAL] = UNCHECKED MACHINE CODE { <> "+extern word XR_FloatDFloatI (x) W2 *x; {\n"; " float f = DRealPtr(x);\n"; " return (*((ptr) &f));\n"; " }\n"; ".XR_FloatDFloatI"; }; <<>> FloatDRealI: UNSAFE PROC [x: PDREAL] RETURNS [REAL] = UNCHECKED MACHINE CODE { "+extern word XR_FloatDRealI (x) W2 *x; {\n"; " float f = DRealPtr(x);\n"; " return (*((ptr) &f));\n"; " }\n"; ".XR_FloatDRealI"; }; <<>> DFloatInt: UNSAFE PROC [ret: PDREAL, x: INT] = UNCHECKED MACHINE CODE { "+extern void XR_DFloatInt (ret, x) W2 *ret; word x; {\n"; " DRealPtr(ret) = ((int) x);\n"; " }\n"; ".XR_FloatInt"; }; <<>> DFloatCard: UNSAFE PROC [ret: PDREAL, x: CARD] = UNCHECKED MACHINE CODE { "+extern void XR_DFloatCard (ret, x) W2 *ret; word x; {\n"; " DRealPtr(ret) = ((unsigned) x);\n"; " }\n"; ".XR_DFloatCard"; }; <<>> DFloatReal: UNSAFE PROC [ret: PDREAL, x: REAL] = UNCHECKED MACHINE CODE { "+extern void XR_DFloatReal (ret, x) W2 *ret; word x; {\n"; " float f = *((float *) &x);\n"; " DRealPtr(ret) = f;\n"; " }\n"; ".XR_DFloatReal"; }; <<>> DRealNegI: UNSAFE PROC [ret, x: PDREAL] = UNCHECKED MACHINE CODE { "+extern void XR_DRealNegI (ret, x) W2 *ret, *x; {\n"; " DRealPtr(ret) = - DRealPtr(x);\n"; " }\n"; ".XR_DRealNegI"; }; <<>> DRealAbsI: UNSAFE PROC [ret, x: PDREAL] = UNCHECKED MACHINE CODE { "+extern void XR_DRealAbsI (ret, x) W2 *ret, *x; {\n"; " DRealPtr(ret) = fabs(DRealPtr(x));\n"; " }\n"; ".XR_DRealAbsI"; }; <<>> DRealAddI: UNSAFE PROC [ret, x, y: PDREAL] = UNCHECKED MACHINE CODE { "+extern void XR_DRealAddI (ret, x, y) W2 *ret, *x, *y; {\n"; " DRealPtr(ret) = DRealPtr(x) + DRealPtr(y);\n"; " }\n"; ".XR_DRealAddI"; }; <<>> DRealSubI: UNSAFE PROC [ret, x, y: PDREAL] = UNCHECKED MACHINE CODE { "+extern void XR_DRealSubI (ret, x, y) W2 *ret, *x, *y; {\n"; " DRealPtr(ret) = DRealPtr(x) - DRealPtr(y);\n"; " }\n"; ".XR_DRealSubI"; }; <<>> DRealMulI: UNSAFE PROC [ret, x, y: PDREAL] = UNCHECKED MACHINE CODE { "+extern void XR_DRealMulI (ret, x, y) W2 *ret, *x, *y; {\n"; " DRealPtr(ret) = DRealPtr(x) * DRealPtr(y);\n"; " }\n"; ".XR_DRealMulI"; }; <<>> DRealDivI: UNSAFE PROC [ret, x, y: PDREAL] = UNCHECKED MACHINE CODE { "+extern void XR_DRealDivI (ret, x, y) W2 *ret, *x, *y; {\n"; " DRealPtr(ret) = DRealPtr(x) / DRealPtr(y);\n"; " }\n"; ".XR_DRealDivI"; }; <<>> DRealGtI: UNSAFE PROC [x, y: PDREAL] RETURNS [BOOL] = UNCHECKED MACHINE CODE { "+extern word XR_DRealGtI (x, y) W2 *x, *y; {\n"; " if ( DRealPtr(x) > DRealPtr(y) ) {return (1);};\n"; " return (0);\n"; " }\n"; ".XR_DRealGtI"; }; <<>> DRealGeI: UNSAFE PROC [x, y: PDREAL] RETURNS [BOOL] = UNCHECKED MACHINE CODE { "+extern word XR_DRealGeI (x, y) W2 *x, *y; {\n"; " if ( DRealPtr(x) >= DRealPtr(y) ) {return (1);};\n"; " return (0);\n"; " }\n"; ".XR_DRealGeI"; }; <<>> DRealLtI: UNSAFE PROC [x, y: PDREAL] RETURNS [BOOL] = UNCHECKED MACHINE CODE { "+extern word XR_DRealLtI (x, y) W2 *x, *y; {\n"; " if ( DRealPtr(x) < DRealPtr(y) ) {return (1);};\n"; " return (0);\n"; " }\n"; ".XR_DRealLtI"; }; <<>> DRealLeI: UNSAFE PROC [x, y: PDREAL] RETURNS [BOOL] = UNCHECKED MACHINE CODE { "+extern word XR_DRealLeI (x, y) W2 *x, *y; {\n"; " if ( DRealPtr(x) <= DRealPtr(y) ) {return (1);};\n"; " return (0);\n"; " }\n"; ".XR_DRealLeI"; }; <<>> DRealEqI: UNSAFE PROC [x, y: PDREAL] RETURNS [BOOL] = UNCHECKED MACHINE CODE { "+extern word XR_DRealEqI (x, y) W2 *x, *y; {\n"; " if ( DRealPtr(x) == DRealPtr(y) ) {return (1);};\n"; " return (0);\n"; " }\n"; ".XR_DRealEqI"; }; <<>> DRealNeI: UNSAFE PROC [x, y: PDREAL] RETURNS [BOOL] = UNCHECKED MACHINE CODE { "+extern word XR_DRealNeI (x, y) W2 *x, *y; {\n"; " if ( DRealPtr(x) != DRealPtr(y) ) {return (1);};\n"; " return (0);\n"; " }\n"; ".XR_DRealNeI"; }; <<>> DRealMinI: UNSAFE PROC [ret, x, y: PDREAL] = UNCHECKED MACHINE CODE { "+extern void XR_DRealMinI (ret, x, y) W2 *ret, *x, *y; {\n"; " if ( DRealPtr(x) <= DRealPtr(y) ) {*ret = *x; return;};\n"; " *ret = *y;\n"; " }\n"; ".XR_DRealMinI"; }; <<>> DRealMaxI: UNSAFE PROC [ret, x, y: PDREAL] = UNCHECKED MACHINE CODE { "+extern void XR_DRealMaxI (ret, x, y) W2 *ret, *x, *y; {\n"; " if ( DRealPtr(x) >= DRealPtr(y) ) {*ret = *x; return;};\n"; " *ret = *y;\n"; " }\n"; ".XR_DRealMaxI"; }; <<>> DRealPwrI: UNSAFE PROC [ret, x, y: PDREAL] = UNCHECKED MACHINE CODE { "+extern void XR_DRealPwrI (ret, x, y) W2 *ret, *x, *y; {\n"; " DRealPtr(ret) = pow(DRealPtr(x), DRealPtr(y));\n"; " }\n"; ".XR_DRealPwrI"; }; <<>> DRealFloorI: UNSAFE PROC [ret, x: PDREAL] = UNCHECKED MACHINE CODE { "+extern void XR_DRealFloorI (ret, x) W2 *ret, *x; {\n"; " DRealPtr(ret) = floor(DRealPtr(x));\n"; " }\n"; ".XR_DRealFloorI"; }; <<>> DRealCeilingI: UNSAFE PROC [ret, x: PDREAL] = UNCHECKED MACHINE CODE { "+extern void XR_DRealCeilingI (ret, x) W2 *ret, *x; {\n"; " DRealPtr(ret) = ceil(DRealPtr(x));\n"; " }\n"; ".XR_DRealCeilingI"; }; <<>> <> DefInclude: PROC = TRUSTED MACHINE CODE { "*"; "#include \n"; "." }; DefDRealPtr: PROC = TRUSTED MACHINE CODE { "+#define DRealPtr(x) (*((double *) (x)))\n." }; DefInclude[]; DefDRealPtr[]; TRUSTED { dummy: DREAL ¬ 1.0; dummyPtr: PDREAL ¬ @dummy; [] ¬ FloatDFloatI[dummyPtr]}; -- need a use of FloatDFloatI to get the code included END.