Repository : ssh://darcs.haskell.org//srv/darcs/packages/base On branch : master
http://hackage.haskell.org/trac/ghc/changeset/e3c360d4c1b47b8eb099ea5ffdd800af43eeec3f >--------------------------------------------------------------- commit e3c360d4c1b47b8eb099ea5ffdd800af43eeec3f Author: Ian Lynagh <[email protected]> Date: Sun Jul 31 20:41:25 2011 +0100 Fix the behaviour of scaleFloat; part of #3898 Patch from Daniel Fischer. >--------------------------------------------------------------- GHC/Float.lhs | 21 +++++++++++++++++---- cbits/primFloat.c | 22 +++++++++++++++++++++- 2 files changed, 38 insertions(+), 5 deletions(-) diff --git a/GHC/Float.lhs b/GHC/Float.lhs index 5100a88..f86ed6b 100644 --- a/GHC/Float.lhs +++ b/GHC/Float.lhs @@ -143,7 +143,10 @@ class (RealFrac a, Floating a) => RealFloat a where significand x = encodeFloat m (negate (floatDigits x)) where (m,_) = decodeFloat x - scaleFloat k x = encodeFloat m (n + clamp b k) + scaleFloat 0 x = x + scaleFloat k x + | isFix = x + | otherwise = encodeFloat m (n + clamp b k) where (m,n) = decodeFloat x (l,h) = floatRange x d = floatDigits x @@ -156,6 +159,7 @@ class (RealFrac a, Floating a) => RealFloat a where -- for smaller than l - d. -- Add a little extra to keep clear -- from the boundary cases. + isFix = x == 0 || isNaN x || isInfinite x atan2 y x | x > 0 = atan (y/x) @@ -313,9 +317,13 @@ instance RealFloat Float where significand x = case decodeFloat x of (m,_) -> encodeFloat m (negate (floatDigits x)) - scaleFloat k x = case decodeFloat x of + scaleFloat 0 x = x + scaleFloat k x + | isFix = x + | otherwise = case decodeFloat x of (m,n) -> encodeFloat m (n + clamp bf k) where bf = FLT_MAX_EXP - (FLT_MIN_EXP) + 4*FLT_MANT_DIG + isFix = x == 0 || isFloatFinite x == 0 isNaN x = 0 /= isFloatNaN x isInfinite x = 0 /= isFloatInfinite x @@ -464,9 +472,13 @@ instance RealFloat Double where significand x = case decodeFloat x of (m,_) -> encodeFloat m (negate (floatDigits x)) - scaleFloat k x = case decodeFloat x of + scaleFloat 0 x = x + scaleFloat k x + | isFix = x + | otherwise = case decodeFloat x of (m,n) -> encodeFloat m (n + clamp bd k) where bd = DBL_MAX_EXP - (DBL_MIN_EXP) + 4*DBL_MANT_DIG + isFix = x == 0 || isDoubleFinite x == 0 isNaN x = 0 /= isDoubleNaN x isInfinite x = 0 /= isDoubleInfinite x @@ -1046,12 +1058,13 @@ foreign import ccall unsafe "isFloatNaN" isFloatNaN :: Float -> Int foreign import ccall unsafe "isFloatInfinite" isFloatInfinite :: Float -> Int foreign import ccall unsafe "isFloatDenormalized" isFloatDenormalized :: Float -> Int foreign import ccall unsafe "isFloatNegativeZero" isFloatNegativeZero :: Float -> Int - +foreign import ccall unsafe "isFloatFinite" isFloatFinite :: Float -> Int foreign import ccall unsafe "isDoubleNaN" isDoubleNaN :: Double -> Int foreign import ccall unsafe "isDoubleInfinite" isDoubleInfinite :: Double -> Int foreign import ccall unsafe "isDoubleDenormalized" isDoubleDenormalized :: Double -> Int foreign import ccall unsafe "isDoubleNegativeZero" isDoubleNegativeZero :: Double -> Int +foreign import ccall unsafe "isDoubleFinite" isDoubleFinite :: Double -> Int \end{code} %********************************************************* diff --git a/cbits/primFloat.c b/cbits/primFloat.c index a8f4803..0e9f9b3 100644 --- a/cbits/primFloat.c +++ b/cbits/primFloat.c @@ -112,6 +112,16 @@ union stg_ieee754_dbl #ifdef IEEE_FLOATING_POINT HsInt +isDoubleFinite(HsDouble d) +{ + union stg_ieee754_dbl u; + + u.d = d; + + return u.ieee.exponent != 2047; +} + +HsInt isDoubleNaN(HsDouble d) { union stg_ieee754_dbl u; @@ -190,6 +200,14 @@ isDoubleNegativeZero(HsDouble d) HsInt +isFloatFinite(HsFloat f) +{ + union stg_ieee754_flt u; + u.f = f; + return u.ieee.exponent != 255; +} + +HsInt isFloatNaN(HsFloat f) { union stg_ieee754_flt u; @@ -426,11 +444,13 @@ rintDouble(HsDouble d) #else /* ! IEEE_FLOATING_POINT */ -/* Dummy definitions of predicates - they all return false */ +/* Dummy definitions of predicates - they all return "normal" values */ +HsInt isDoubleFinite(d) HsDouble d; { return 1;} HsInt isDoubleNaN(d) HsDouble d; { return 0; } HsInt isDoubleInfinite(d) HsDouble d; { return 0; } HsInt isDoubleDenormalized(d) HsDouble d; { return 0; } HsInt isDoubleNegativeZero(d) HsDouble d; { return 0; } +HsInt isFloatFinite(f) HsFloat f; { return 1; } HsInt isFloatNaN(f) HsFloat f; { return 0; } HsInt isFloatInfinite(f) HsFloat f; { return 0; } HsInt isFloatDenormalized(f) HsFloat f; { return 0; } _______________________________________________ Cvs-libraries mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-libraries
