[rearrange whole floating point stuff in standard libraries, add foof floating point routines that don't go through rational/integer intermediate values
John Meacham <john@repetae.net>**20070516032417] hunk ./Name/Names.hs 163
-class_Floating = toName ClassName ("Prelude","Floating")
-class_RealFrac = toName ClassName ("Prelude","RealFrac")
-class_RealFloat = toName ClassName ("Prelude","RealFloat")
+class_Floating = toName ClassName ("Jhc.Float","Floating")
+class_RealFrac = toName ClassName ("Jhc.Float","RealFrac")
+class_RealFloat = toName ClassName ("Jhc.Float","RealFloat")
hunk ./lib/base/Data/Ratio.hs 8
+import Jhc.Float
hunk ./lib/base/Data/Ratio.hs 14
-numerator (x :% _)      =  x
-denominator (_ :% y)    =  y
hunk ./lib/base/Data/Ratio.hs 17
-numerator, denominator  :: (Integral a) => Ratio a -> a
hunk ./lib/base/Data/Ratio.hs 58
+    fromInt     x       =  fromInt x :% 1
hunk ./lib/base/Data/Ratio.hs 63
+    toDouble  x         = rationalToDouble (toRational x)
+
hunk ./lib/base/Data/Ratio.hs 69
+    fromDouble   x      = fromRational (doubleToRational x)
hunk ./lib/base/Jhc/Float.hs 1
-{-# OPTIONS_JHC -N #-}
+{-# OPTIONS_JHC -N -fffi #-}
hunk ./lib/base/Jhc/Float.hs 4
+import Jhc.IO(error)
+import Jhc.Order
+import Jhc.Int
+import Jhc.Num
+import Jhc.Basics
+
+infixr 8  **
+
hunk ./lib/base/Jhc/Float.hs 16
+foreign import primitive "integralCast" floatToDouble :: Float -> Double
+foreign import primitive "integralCast" doubleToFloat :: Double -> Float
+
+ -- floating point stuff
+
+class  (Fractional a) => Floating a  where
+    pi                  :: a
+    exp, log, sqrt      :: a -> a
+    (**), logBase       :: a -> a -> a
+    sin, cos, tan       :: a -> a
+    asin, acos, atan    :: a -> a
+    sinh, cosh, tanh    :: a -> a
+    asinh, acosh, atanh :: a -> a
+
+        -- Minimal complete definition:
+        --      pi, exp, log, sin, cos, sinh, cosh
+        --      asin, acos, atan
+        --      asinh, acosh, atanh
+    x ** y           =  exp (log x * y)
+    logBase x y      =  log y / log x
+    sqrt x           =  x ** (1 / 2) -- 0.5        -- TODO Doubles
+    tan  x           =  sin  x / cos  x
+    tanh x           =  sinh x / cosh x
+
+
+
+-- TODO Doubles
+class  (Real a, Fractional a) => RealFrac a  where
+    properFraction   :: (Integral b) => a -> (b,a)
+    truncate, round  :: (Integral b) => a -> b
+    ceiling, floor   :: (Integral b) => a -> b
+
+
+
+        -- Minimal complete definition:
+        --      properFraction
+    truncate x       =  m  where (m,_) = properFraction x
+
+    round x          =  let (n,r) = properFraction x
+                            m     = if r < 0 then n - 1 else n + 1
+                          in case signum (abs r - (1 / 2)) of
+                                -1 -> n
+                                0  -> if n `rem` 2 == 0 then n else m
+                                1  -> m
+
+    ceiling x        =  if r > 0 then n + 1 else n
+                        where (n,r) = properFraction x
+
+    floor x          =  if r < 0 then n - 1 else n
+                        where (n,r) = properFraction x
+
+        -- Minimal complete definition:
+        --      properFraction
+
+    properFractionf   :: a -> (a,a)
+    truncatef, roundf :: a -> a
+    ceilingf, floorf  :: a -> a
+
+    truncatef x       =  m  where (m,_) = properFractionf x
+    roundf x          =  fromInteger (round x)
+    ceilingf x        =  if r > 0 then n + 1 else n
+                        where (n,r) = properFractionf x
+    floorf x          =  if r < 0 then n - 1 else n
+                        where (n,r) = properFractionf x
+
+
+-- TODO Doubles
+class  (RealFrac a, Floating a) => RealFloat a  where
+    floatRadix       :: a -> Integer
+    floatDigits      :: a -> Int
+    floatRange       :: a -> (Int,Int)
+    decodeFloat      :: a -> (Integer,Int)
+    encodeFloat      :: Integer -> Int -> a
+    exponent         :: a -> Int
+    significand      :: a -> a
+    scaleFloat       :: Int -> a -> a
+    isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE
+                     :: a -> Bool
+    atan2            :: a -> a -> a
+
+        -- Minimal complete definition:
+        --      All except exponent, significand,
+        --                 scaleFloat, atan2
+    exponent x       =  if m == 0 then 0 else n + floatDigits x
+                        where (m,n) = decodeFloat x
+
+    significand x    =  encodeFloat m (- floatDigits x)
+                        where (m,_) = decodeFloat x
+
+    scaleFloat k x   =  encodeFloat m (n+k)
+                        where (m,n) = decodeFloat x
+
+    atan2 y x
+      | x>0           =  atan (y/x)
+      | x==0 && y>0   =  pi/2
+      | x<0  && y>0   =  pi + atan (y/x)
+      |(x<=0 && y<0)  ||
+       (x<0 && isNegativeZero y) ||
+       (isNegativeZero x && isNegativeZero y)
+                      = -atan2 (-y) x
+      | y==0 && (x<0 || isNegativeZero x)
+                      =  pi    -- must be after the previous test on zero y
+      | x==0 && y==0  =  y     -- must be after the other double zero tests
+      | otherwise     =  x + y -- x or y is a NaN, return a NaN (via +)
+
+    decodeFloatf     :: a -> (a,Int)
+    decodeFloatf x    = case decodeFloat x of
+        (v,exp) -> (fromInteger v,exp)
+
+    encodeFloatf     :: a -> Int -> a
+    encodeFloatf a i = scaleFloat i a
+
+
+doubleToRational :: Double -> Rational
+doubleToRational = _
+
+rationalToDouble :: Rational -> Double
+rationalToDouble (x:%y) = fromInteger x `divideDouble` fromInteger y
+
+foreign import primitive "divide" divideDouble ::  Double -> Double -> Double
hunk ./lib/base/Jhc/Num.hs 9
+import Jhc.Float
hunk ./lib/base/Jhc/Num.hs 11
+infixl 7 :%
hunk ./lib/base/Jhc/Num.hs 18
+numerator, denominator  :: Ratio a -> a
+numerator (x :% _)      =  x
+denominator (_ :% y)    =  y
+
hunk ./lib/base/Jhc/Num.hs 39
+    toDouble         ::  a -> Double
+    toDouble x = rationalToDouble (toRational x)
hunk ./lib/base/Jhc/Num.hs 65
+    fromDouble       :: Double   -> a
hunk ./lib/base/Jhc/Num.hs 72
+    fromDouble x = fromRational (doubleToRational x)
+
hunk ./lib/base/Jhc/Num.hs 75
-fromIntegral     :: (Integral a, Num b) => a -> b
-fromIntegral     =  fromInteger . toInteger
+fromIntegral   :: (Integral a, Num b) => a -> b
+fromIntegral x =  fromInteger (toInteger x)
hunk ./lib/base/Jhc/Num.hs 79
-realToFrac      =  fromRational . toRational
+realToFrac x   =  fromRational (toRational x)
hunk ./lib/base/Jhc/Num.hs 83
-  "realToFrac/fromRational"   realToFrac = fromRational
+--  "realToFrac/fromRational"   realToFrac = fromRational
+--  "realToFrac/toDouble"       realToFrac = toDouble
+--  "realToFrac/fromDouble"     realToFrac = fromDouble
hunk ./lib/base/Jhc/Num.hs 97
+
hunk ./lib/base/Numeric.hs 12
---import Ratio  ( (%), numerator, denominator )
+import Data.Ratio  ( (%), numerator, denominator )
hunk ./lib/base/Numeric.hs 33
-fromRat' :: (RealFloat a) => Rational -> a
-fromRat' x = r
+fromRat' :: (RealFloat a) => Rational ->  a
+fromRat' x = fromRat'' x undefined
+
+fromRat'' :: (RealFloat a) => Rational -> a -> a
+fromRat'' x _x = r
hunk ./lib/base/Numeric.hs 48
-        r = encodeFloat (round x') p'
+        r = encodeFloat (round x') p' `asTypeOf` _x
hunk ./lib/base/Numeric.hs 62
--}
+        -}
hunk ./lib/base/Numeric.hs 333
-readFloat r = error "readFloat"
+readFloat = error "readFloat"
hunk ./lib/base/Numeric.hs 353
+
hunk ./lib/base/Numeric.hs 355
+
hunk ./lib/base/Prelude/Float.hs 5
-import Data.Ratio
+import Jhc.Order
+import Jhc.Basics
+import Jhc.Monad
+import Jhc.IO
+import Jhc.Float
+import Jhc.Num
+import Foreign.Storable
hunk ./lib/base/Prelude/Float.hs 15
-import Jhc.IO
-import Foreign.Storable
hunk ./lib/base/Prelude/Float.hs 20
-instance Fractional @type@ where
-    (/) = divide@type@
-    fromRational x = numerator x / denominator x
+--instance Fractional @type@ where
+--    (/) = divide@type@
+--    fromRational x = numerator x / denominator x
hunk ./lib/base/Prelude/Float.hs 44
+instance RealFrac Float where
+    properFraction x
+      = case (decodeFloat x)      of { (m,n) ->
+    	let  b = floatRadix x     in
+    	if n >= 0 then
+	    (fromInteger m * fromInteger b ^ n, 0.0)
+    	else
+	    case (quotRem m (b^(negate n))) of { (w,r) ->
+	    (fromInteger w, encodeFloat r n)
+	    }
+        }
+
+    truncatef x = c_trunc@x@ x
+    roundf x = c_nearbyint@x@ x
+    ceilingf x = c_ceil@x@ x
+    floorf x = c_floor@x@ x
+
+
hunk ./lib/base/Prelude/Float.hs 78
+foreign import ccall "-lm math.h trunc@x@" c_trunc@x@ :: @type@ -> @type@
+foreign import ccall "-lm math.h ceil@x@" c_ceil@x@ :: @type@ -> @type@
+foreign import ccall "-lm math.h floor@x@" c_floor@x@ :: @type@ -> @type@
+foreign import ccall "-lm math.h nearbyint@x@" c_nearbyint@x@ :: @type@ -> @type@
hunk ./lib/base/Prelude/Float.hs 93
+    fromDouble x = doubleToFloat x
hunk ./lib/base/Prelude/Float.hs 131
+foreign import ccall "-lm math.h truncf" c_truncf :: Float -> Float
+foreign import ccall "-lm math.h ceilf" c_ceilf :: Float -> Float
+foreign import ccall "-lm math.h floorf" c_floorf :: Float -> Float
+foreign import ccall "-lm math.h nearbyintf" c_nearbyintf :: Float -> Float
+
+
hunk ./lib/base/Prelude/Float.hs 147
+    fromDouble x = x
hunk ./lib/base/Prelude/Float.hs 185
+foreign import ccall "-lm math.h trunc" c_trunc :: Double -> Double
+foreign import ccall "-lm math.h ceil" c_ceil :: Double -> Double
+foreign import ccall "-lm math.h floor" c_floor :: Double -> Double
+foreign import ccall "-lm math.h nearbyint" c_nearbyint :: Double -> Double
+
+
hunk ./lib/base/Prelude/Float.hs 196
-    toRational x	=  (m%1)*(b%1)^^n
+    toRational x	=  (m:%1)*(b:%1)^^n
hunk ./lib/base/Prelude/Float.hs 199
+    toDouble x = floatToDouble x
+
hunk ./lib/base/Prelude/Float.hs 202
-    toRational x	=  (m%1)*(b%1)^^n
+    toRational x	=  (m:%1)*(b:%1)^^n
hunk ./lib/base/Prelude/Float.hs 205
+    toDouble x = x
hunk ./lib/base/Prelude/Float.hs 219
+    truncatef x = c_truncf x
+    roundf x = c_nearbyintf x
+    ceilingf x = c_ceilf x
+    floorf x = c_floorf x
+
hunk ./lib/base/Prelude/Float.hs 236
+    truncatef x = c_trunc x
+    roundf x = c_nearbyint x
+    ceilingf x = c_ceil x
+    floorf x = c_floor x
+
hunk ./lib/base/Prelude/Float.hs 247
-    exponent x		= case decodeFloat x of
-			    (m,n) -> if m == 0 then 0 else n + floatDigits x
-
-    significand x	= case decodeFloat x of
-			    (m,_) -> encodeFloat m (negate (floatDigits x))
+    exponent x		= case decodeFloatf x of (_,n) -> n
+    significand x	= case decodeFloatf x of (m,_) -> m
hunk ./lib/base/Prelude/Float.hs 250
-    scaleFloat k x	= case decodeFloat x of
-			    (m,n) -> encodeFloat m (n+k)
hunk ./lib/base/Prelude/Float.hs 255
-    encodeFloat i e = double2float $ c_ldexp (integer2double i) (fromInt e)
+
+    scaleFloat k x = c_ldexpf x (fromInt k)
+    decodeFloatf x = unsafePerformIO $ alloca $ \ptr -> do
+        x' <- c_frexpf x ptr
+        exp <- peek ptr
+        return (x', fromIntegral exp)
+
+    encodeFloat i e = c_ldexpf (fromInteger i) (fromInt e)
hunk ./lib/base/Prelude/Float.hs 264
-        x' <- c_frexp (float2double x) ptr
+        x' <- c_frexp (floatToDouble x) ptr
hunk ./lib/base/Prelude/Float.hs 271
-
hunk ./lib/base/Prelude/Float.hs 273
-foreign import ccall "math.h ldexp" c_ldexp :: Double -> CInt -> Double
hunk ./lib/base/Prelude/Float.hs 276
-foreign import ccall "math.h frexp" c_frexp :: Double -> Ptr CInt -> IO Double
+foreign import ccall "math.h ldexp"  c_ldexp :: Double -> CInt -> Double
+foreign import ccall "math.h ldexpf" c_ldexpf :: Float -> CInt -> Float
+foreign import ccall "math.h frexp"  c_frexp :: Double -> Ptr CInt -> IO Double
+foreign import ccall "math.h frexpf" c_frexpf :: Float -> Ptr CInt -> IO Float
hunk ./lib/base/Prelude/Float.hs 293
-    exponent x		= case decodeFloat x of
-			    (m,n) -> if m == 0 then 0 else n + floatDigits x
-
-    significand x	= case decodeFloat x of
-			    (m,_) -> encodeFloat m (negate (floatDigits x))
+    exponent x		= case decodeFloatf x of (_,n) -> n
+    significand x	= case decodeFloatf x of (m,_) -> m
hunk ./lib/base/Prelude/Float.hs 296
-    --scaleFloat k x	= case decodeFloat x of
-    --    		    (m,n) -> encodeFloat m (n+k)
hunk ./lib/base/Prelude/Float.hs 301
-    encodeFloat i e =  c_ldexp (integer2double i) (fromInt e)
hunk ./lib/base/Prelude/Float.hs 302
+    decodeFloatf x = unsafePerformIO $ alloca $ \ptr -> do
+        x' <- c_frexp x ptr
+        exp <- peek ptr
+        return (x', fromIntegral exp)
+
+    encodeFloat i e =  c_ldexp (integer2double i) (fromInt e)
hunk ./lib/base/Prelude/Float.hs 316
-
hunk ./lib/base/Prelude/Float.hs 325
-foreign import primitive "integralCast" double2float :: Double -> Float
hunk ./lib/base/Prelude/Float.hs 326
-foreign import primitive "integralCast" float2double :: Float -> Double
hunk ./lib/base/Prelude.hs 36
+    Floating(..),
+    RealFrac(properFraction,truncate,round,ceiling,floor),
+    RealFloat(..),
hunk ./lib/base/Prelude.hs 51
-import Prelude.IO
-import Prelude.IOError
-import Prelude.Text
-import Prelude.Float
hunk ./lib/base/Prelude.hs 52
-import qualified Data.Char as Char(isSpace,ord,chr)
+import Jhc.Enum
hunk ./lib/base/Prelude.hs 54
-import Jhc.Tuples
hunk ./lib/base/Prelude.hs 55
-import Jhc.Enum
hunk ./lib/base/Prelude.hs 56
-import Jhc.Order
hunk ./lib/base/Prelude.hs 57
+import Jhc.Order
hunk ./lib/base/Prelude.hs 59
+import Jhc.Tuples
+import Prelude.Float
+import Prelude.IO
+import Prelude.IOError
+import Prelude.Text
+import qualified Data.Char as Char(isSpace,ord,chr)
hunk ./lib/base/Prelude.hs 68
-infixr 8  ^, ^^, **
+--infixr 8  ^, ^^, **
+infixr 8  ^, ^^
hunk ./lib/base/Prelude.hs 83
-class  (Fractional a) => Floating a  where
-    pi                  :: a
-    exp, log, sqrt      :: a -> a
-    (**), logBase       :: a -> a -> a
-    sin, cos, tan       :: a -> a
-    asin, acos, atan    :: a -> a
-    sinh, cosh, tanh    :: a -> a
-    asinh, acosh, atanh :: a -> a
-
-        -- Minimal complete definition:
-        --      pi, exp, log, sin, cos, sinh, cosh
-        --      asin, acos, atan
-        --      asinh, acosh, atanh
-    x ** y           =  exp (log x * y)
-    logBase x y      =  log y / log x
-    sqrt x           =  x ** (1 / 2) -- 0.5        -- TODO Doubles
-    tan  x           =  sin  x / cos  x
-    tanh x           =  sinh x / cosh x
-
-
-
--- TODO Doubles
-class  (Real a, Fractional a) => RealFrac a  where
-    properFraction   :: (Integral b) => a -> (b,a)
-    truncate, round  :: (Integral b) => a -> b
-    ceiling, floor   :: (Integral b) => a -> b
-
-        -- Minimal complete definition:
-        --      properFraction
-    truncate x       =  m  where (m,_) = properFraction x
-
-    round x          =  let (n,r) = properFraction x
-                            m     = if r < 0 then n - 1 else n + 1
-                          in case signum (abs r - 0.5) of
-                                -1 -> n
-                                0  -> if even n then n else m
-                                1  -> m
-
-    ceiling x        =  if r > 0 then n + 1 else n
-                        where (n,r) = properFraction x
-
-    floor x          =  if r < 0 then n - 1 else n
-                        where (n,r) = properFraction x
-
-
--- TODO Doubles
-class  (RealFrac a, Floating a) => RealFloat a  where
-    floatRadix       :: a -> Integer
-    floatDigits      :: a -> Int
-    floatRange       :: a -> (Int,Int)
-    decodeFloat      :: a -> (Integer,Int)
-    encodeFloat      :: Integer -> Int -> a
-    exponent         :: a -> Int
-    significand      :: a -> a
-    scaleFloat       :: Int -> a -> a
-    isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE
-                     :: a -> Bool
-    atan2            :: a -> a -> a
-
-        -- Minimal complete definition:
-        --      All except exponent, significand,
-        --                 scaleFloat, atan2
-    exponent x       =  if m == 0 then 0 else n + floatDigits x
-                        where (m,n) = decodeFloat x
-
-    significand x    =  encodeFloat m (- floatDigits x)
-                        where (m,_) = decodeFloat x
-
-    scaleFloat k x   =  encodeFloat m (n+k)
-                        where (m,n) = decodeFloat x
-
-    atan2 y x
-      | x>0           =  atan (y/x)
-      | x==0 && y>0   =  pi/2
-      | x<0  && y>0   =  pi + atan (y/x)
-      |(x<=0 && y<0)  ||
-       (x<0 && isNegativeZero y) ||
-       (isNegativeZero x && isNegativeZero y)
-                      = -atan2 (-y) x
-      | y==0 && (x<0 || isNegativeZero x)
-                      =  pi    -- must be after the previous test on zero y
-      | x==0 && y==0  =  y     -- must be after the other double zero tests
-      | otherwise     =  x + y -- x or y is a NaN, return a NaN (via +)