import PrelBase
import PrelGHC
+import PrelEnum
+import PrelShow
import PrelNum
-import {-# SOURCE #-} PrelErr ( error )
+import PrelErr ( error )
import PrelList
import PrelMaybe
import Maybe ( fromMaybe )
signum x | x == 0.0 = 0
| x > 0.0 = 1
| otherwise = negate 1
+
+ {-# INLINE fromInteger #-}
fromInteger n = encodeFloat n 0
+ -- It's important that encodeFloat inlines here, and that
+ -- fromInteger in turn inlines,
+ -- so that if fromInteger is applied to an (S# i) the right thing happens
+
+ {-# INLINE fromInt #-}
fromInt i = int2Float i
instance Real Float where
floor x = case properFraction x of
(n,r) -> if r < 0.0 then n - 1 else n
+foreign import ccall "__encodeFloat" unsafe
+ encodeFloat# :: Int# -> ByteArray# -> Int -> Float
+foreign import ccall "__int_encodeFloat" unsafe
+ int_encodeFloat# :: Int# -> Int -> Float
+
+
+foreign import ccall "isFloatNaN" unsafe isFloatNaN :: Float -> Int
+foreign import ccall "isFloatInfinite" unsafe isFloatInfinite :: Float -> Int
+foreign import ccall "isFloatDenormalized" unsafe isFloatDenormalized :: Float -> Int
+foreign import ccall "isFloatNegativeZero" unsafe isFloatNegativeZero :: Float -> Int
+
instance RealFloat Float where
floatRadix _ = FLT_RADIX -- from float.h
floatDigits _ = FLT_MANT_DIG -- ditto
decodeFloat (F# f#)
= case decodeFloat# f# of
- (# exp#, a#, s#, d# #) -> (J# a# s# d#, I# exp#)
+ (# exp#, s#, d# #) -> (J# s# d#, I# exp#)
- encodeFloat (J# a# s# d#) (I# e#)
- = case encodeFloat# a# s# d# e# of { flt# -> F# flt# }
+ encodeFloat (S# i) j = int_encodeFloat# i j
+ encodeFloat (J# s# d#) e = encodeFloat# s# d# e
exponent x = case decodeFloat x of
(m,n) -> if m == 0 then 0 else n + floatDigits x
scaleFloat k x = case decodeFloat x of
(m,n) -> encodeFloat m (n+k)
- isNaN x =
- (0::Int) /= unsafePerformIO (_ccall_ isFloatNaN x) {- a _pure_function! -}
- isInfinite x =
- (0::Int) /= unsafePerformIO (_ccall_ isFloatInfinite x) {- ditto! -}
- isDenormalized x =
- (0::Int) /= unsafePerformIO (_ccall_ isFloatDenormalized x) -- ..
- isNegativeZero x =
- (0::Int) /= unsafePerformIO (_ccall_ isFloatNegativeZero x) -- ...
- isIEEE _ = True
+ isNaN x = 0 /= isFloatNaN x
+ isInfinite x = 0 /= isFloatInfinite x
+ isDenormalized x = 0 /= isFloatDenormalized x
+ isNegativeZero x = 0 /= isFloatNegativeZero x
+ isIEEE _ = True
\end{code}
%*********************************************************
signum x | x == 0.0 = 0
| x > 0.0 = 1
| otherwise = negate 1
+
+ {-# INLINE fromInteger #-}
+ -- See comments with Num Float
fromInteger n = encodeFloat n 0
fromInt (I# n#) = case (int2Double# n#) of { d# -> D# d# }
{-# SPECIALIZE ceiling :: Double -> Integer #-}
{-# SPECIALIZE floor :: Double -> Integer #-}
-#if defined(__UNBOXED_INSTANCES__)
- {-# SPECIALIZE properFraction :: Double -> (Int#, Double) #-}
- {-# SPECIALIZE truncate :: Double -> Int# #-}
- {-# SPECIALIZE round :: Double -> Int# #-}
- {-# SPECIALIZE ceiling :: Double -> Int# #-}
- {-# SPECIALIZE floor :: Double -> Int# #-}
-#endif
-
properFraction x
= case (decodeFloat x) of { (m,n) ->
let b = floatRadix x in
floor x = case properFraction x of
(n,r) -> if r < 0.0 then n - 1 else n
+foreign import ccall "__encodeDouble" unsafe
+ encodeDouble# :: Int# -> ByteArray# -> Int -> Double
+foreign import ccall "__int_encodeDouble" unsafe
+ int_encodeDouble# :: Int# -> Int -> Double
+
+foreign import ccall "isDoubleNaN" unsafe isDoubleNaN :: Double -> Int
+foreign import ccall "isDoubleInfinite" unsafe isDoubleInfinite :: Double -> Int
+foreign import ccall "isDoubleDenormalized" unsafe isDoubleDenormalized :: Double -> Int
+foreign import ccall "isDoubleNegativeZero" unsafe isDoubleNegativeZero :: Double -> Int
+
instance RealFloat Double where
floatRadix _ = FLT_RADIX -- from float.h
floatDigits _ = DBL_MANT_DIG -- ditto
decodeFloat (D# x#)
= case decodeDouble# x# of
- (# exp#, a#, s#, d# #) -> (J# a# s# d#, I# exp#)
+ (# exp#, s#, d# #) -> (J# s# d#, I# exp#)
- encodeFloat (J# a# s# d#) (I# e#)
- = case encodeDouble# a# s# d# e# of { dbl# -> D# dbl# }
+ encodeFloat (S# i) j = int_encodeDouble# i j
+ encodeFloat (J# s# d#) e = encodeDouble# s# d# e
exponent x = case decodeFloat x of
(m,n) -> if m == 0 then 0 else n + floatDigits x
scaleFloat k x = case decodeFloat x of
(m,n) -> encodeFloat m (n+k)
- isNaN x =
- (0::Int) /= unsafePerformIO (_ccall_ isDoubleNaN x) {- a _pure_function! -}
- isInfinite x =
- (0::Int) /= unsafePerformIO (_ccall_ isDoubleInfinite x) {- ditto -}
- isDenormalized x =
- (0::Int) /= unsafePerformIO (_ccall_ isDoubleDenormalized x) -- ..
- isNegativeZero x =
- (0::Int) /= unsafePerformIO (_ccall_ isDoubleNegativeZero x) -- ...
- isIEEE _ = True
+
+ isNaN x = 0 /= isDoubleNaN x
+ isInfinite x = 0 /= isDoubleInfinite x
+ isDenormalized x = 0 /= isDoubleDenormalized x
+ isNegativeZero x = 0 /= isDoubleNegativeZero x
+ isIEEE _ = True
instance Show Double where
showsPrec x = showSigned showFloat x
%*********************************************************
\begin{code}
-{- SPECIALIZE fromIntegral ::
+{-# SPECIALIZE fromIntegral ::
Int -> Rational,
Integer -> Rational,
Int -> Int,
fromIntegral :: (Integral a, Num b) => a -> b
fromIntegral = fromInteger . toInteger
-{- SPECIALIZE realToFrac ::
+{-# SPECIALIZE realToFrac ::
Double -> Rational,
Rational -> Double,
Float -> Rational,
toEnum = fromIntegral
fromEnum = fromInteger . truncate -- may overflow
enumFrom = numericEnumFrom
+ enumFromTo = numericEnumFromTo
enumFromThen = numericEnumFromThen
enumFromThenTo = numericEnumFromThenTo
toEnum = fromIntegral
fromEnum = fromInteger . truncate -- may overflow
enumFrom = numericEnumFrom
+ enumFromTo = numericEnumFromTo
enumFromThen = numericEnumFromThen
enumFromThenTo = numericEnumFromThenTo
-numericEnumFrom :: (Real a) => a -> [a]
-numericEnumFromThen :: (Real a) => a -> a -> [a]
-numericEnumFromThenTo :: (Real a) => a -> a -> a -> [a]
+numericEnumFrom :: (Fractional a) => a -> [a]
numericEnumFrom = iterate (+1)
+
+numericEnumFromThen :: (Fractional a) => a -> a -> [a]
numericEnumFromThen n m = iterate (+(m-n)) n
-numericEnumFromThenTo n m p = takeWhile (if m >= n then (<= p) else (>= p))
- (numericEnumFromThen n m)
+
+numericEnumFromTo :: (Ord a, Fractional a) => a -> a -> [a]
+numericEnumFromTo n m = takeWhile (<= m + 1/2) (numericEnumFrom n)
+
+numericEnumFromThenTo :: (Ord a, Fractional a) => a -> a -> a -> [a]
+numericEnumFromThenTo e1 e2 e3 = takeWhile pred (numericEnumFromThen e1 e2)
+ where
+ mid = (e2 - e1) / 2
+ pred | e2 > e1 = (<= e3 + mid)
+ | otherwise = (>= e3 + mid)
+
\end{code}
@approxRational@, applied to two real fractional numbers x and epsilon,
instance (Integral a) => Enum (Ratio a) where
succ x = x + 1
pred x = x - 1
- enumFrom = iterate ((+)1)
- enumFromThen n m = iterate ((+)(m-n)) n
+
toEnum n = fromIntegral n :% 1
fromEnum = fromInteger . truncate
+ enumFrom = bounded_iterator True (1)
+ enumFromThen n m = bounded_iterator (diff >= 0) diff n
+ where diff = m - n
+
+
+bounded_iterator :: (Ord a, Num a) => Bool -> a -> a -> [a]
+bounded_iterator inc step v
+ | inc && v > new_v = [v] -- oflow
+ | not inc && v < new_v = [v] -- uflow
+ | otherwise = v : bounded_iterator inc step new_v
+ where
+ new_v = v + step
+
ratio_prec :: Int
ratio_prec = 7
s@(h:t) = show ((round (r * 10^n))::Integer)
e = e0+1
- takeN (I# n#) ls rs = takeUInt n# ls rs
+#ifdef USE_REPORT_PRELUDE
+ takeN n ls rs = take n ls ++ rs
+#else
+ takeN (I# n#) ls rs = takeUInt_append n# ls rs
+#endif
drop0 :: String -> String -> String
drop0 [] rs = rs
Lennart's code follows, and it works...
\begin{pseudocode}
-{-# SPECIALISE fromRat ::
- Rational -> Double,
- Rational -> Float #-}
fromRat :: (RealFloat a) => Rational -> a
fromRat x = x'
where x' = f e
Now, here's Lennart's code.
\begin{code}
+{-# SPECIALISE fromRat ::
+ Rational -> Double,
+ Rational -> Float #-}
fromRat :: (RealFloat a) => Rational -> a
fromRat x
| x == 0 = encodeFloat 0 0 -- Handle exceptional cases
-- These are the format types. This type is not exported.
-data FFFormat = FFExponent | FFFixed | FFGeneric --no need: deriving (Eq, Ord, Show)
+data FFFormat = FFExponent | FFFixed | FFGeneric
formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
formatRealFloat fmt decs x
| isNaN x = "NaN"
- | isInfinite x && x < 0 = if x < 0 then "-Infinity" else "Infinity"
+ | isInfinite x = if x < 0 then "-Infinity" else "Infinity"
| x < 0 || isNegativeZero x = '-':doFmt fmt (floatToDigits (toInteger base) (-x))
| otherwise = doFmt fmt (floatToDigits (toInteger base) x)
where
Nothing ->
let e' = if e==0 then 0 else e-1 in
(case ds of
- [d] -> d : ".0e" ++ show e'
+ [d] -> d : ".0e"
(d:ds') -> d : '.' : ds' ++ "e") ++ show e'
Just dec ->
let dec' = max dec 1 in
projects / ghc-hetmet.git / blobdiff