[add floating point reading and writing routines to the libraries
John Meacham <john@repetae.net>**20070523020315] hunk ./lib/base/Data/Ratio.hs 7
+import Prelude.Float(doubleToRational)
hunk ./lib/base/Jhc/Float.hs 129
-doubleToRational :: Double -> Rational
-doubleToRational = _
hunk ./lib/base/Jhc/Num.hs 72
-    fromDouble x = fromRational (doubleToRational x)
+    --fromDouble x = fromRational (doubleToRational x)
hunk ./lib/base/Jhc/Num.hs 83
---  "realToFrac/fromRational"   realToFrac = fromRational
---  "realToFrac/toDouble"       realToFrac = toDouble
---  "realToFrac/fromDouble"     realToFrac = fromDouble
+  "realToFrac/fromRational"   realToFrac = fromRational
+  "realToFrac/toDouble"       realToFrac = toDouble
+  "realToFrac/fromDouble"     realToFrac = fromDouble
hunk ./lib/base/Numeric.hs 19
+fromRat :: (RealFloat a) => Rational -> a
+fromRat = error "fromRat not implemented yet"
+
hunk ./lib/base/Numeric.hs 336
-readFloat = error "readFloat"
-{-
hunk ./lib/base/Numeric.hs 355
--}
hunk ./lib/base/Prelude/Float.hs 3
-module Prelude.Float() where
+module Prelude.Float(readDouble,doubleToDigits,doubleToRational) where
hunk ./lib/base/Prelude/Float.hs 11
+import Data.Word
hunk ./lib/base/Prelude/Float.hs 16
+import Numeric
hunk ./lib/base/Prelude/Float.hs 204
-    toRational x	=  (m:%1)*(b:%1)^^n
-			   where (m,n) = decodeFloat x
-				 b     = floatRadix  x
+    toRational x = doubleToRational x
hunk ./lib/base/Prelude/Float.hs 327
+
+
+readDouble :: ReadS Double
+readDouble r    = [((fromInteger n * (10^^(k-d))),t) | (n,d,s) <- readFix r,(k,t)   <- readExp s] ++
+                 [ (0/0, t) | ("NaN",t)      <- lex r] ++
+                 [ (1/0, t) | ("Infinity",t) <- lex r]
+               where
+                 readFix r = [(read (take 15 $ ds++ds'), length ds', t)
+                             | (ds,d) <- lexDigits r,
+                               (ds',t) <- lexFrac d ]
+
+                 lexFrac ('.':ds) = lexDigits ds
+                 lexFrac s        = [("",s)]
+
+                 readExp (e:s) | e `elem` "eE" = readExp' s
+                 readExp s                     = [(0,s)]
+
+                 readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
+                 readExp' ('+':s) = readDec s
+                 readExp' s       = readDec s
+
+
+doubleToDigits :: Integer -> Double -> ([Int], Int)
+doubleToDigits n d | n `seq` d `seq` d == 0 = ([], 0)
+doubleToDigits base' x =
+    let (f0', e0) = decodeFloat x
+        base, f0 :: WordMax
+        base = fromInteger base'
+        f0 = fromIntegral f0'
+        (minExp0, _) = floatRange x
+        p = floatDigits x
+        b :: WordMax
+        b = fromInteger $ floatRadix x
+        minExp = minExp0 - p            -- the real minimum exponent
+
+        -- Haskell requires that f be adjusted so denormalized numbers
+        -- will have an impossibly low exponent.  Adjust for this.
+        f :: WordMax
+        e :: Int
+        (f, e) = let n = minExp - e0
+                 in  if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)
+
+        (r, s, mUp, mDn) =
+           if e >= 0 then
+               let be = b^e in
+               if f == b^(p-1) then
+                   (f*be*b*2, 2*b, be*b, b)
+               else
+                   (f*be*2, 2, be, be)
+           else
+               if e > minExp && f == b^(p-1) then
+                   (f*b*2, b^(-e+1)*2, b, 1)
+               else
+                   (f*2, b^(-e)*2, 1, 1)
+        k =
+            let k0 =
+                    if b==2 && base==10 then
+                        -- logBase 10 2 is slightly bigger than 3/10 so
+                        -- the following will err on the low side.  Ignoring
+                        -- the fraction will make it err even more.
+                        -- Haskell promises that p-1 <= logBase b f < p.
+                        (p - 1 + e0) * 3 `div` 10
+                    else
+                        ceiling ((log ((fromIntegral (f+1))::Double) +
+                                 fromIntegral e * log (fromIntegral b)) /
+                                  log (fromIntegral base))
+                fixup n =
+                    if n >= 0 then
+                        if r + mUp <= expt base n * s then n else fixup (n+1)
+                    else
+                        if expt base (-n) * (r + mUp) <= s then n
+                                                           else fixup (n+1)
+            in  fixup (k0::Int)
+
+        gen ds rn sN mUpN mDnN | rn `seq` sN `seq` mUpN `seq` mDnN `seq` True =
+            let (dn, rn') = (rn * base) `divMod` sN
+                mUpN' = mUpN * base
+                mDnN' = mDnN * base
+            in  case (rn' < mDnN', rn' + mUpN' > sN) of
+                (True,  False) -> toInt dn : ds
+                (False, True)  -> toInt (dn+1) : ds
+                (True,  True)  -> if rn' * 2 < sN then toInt dn : ds else toInt (dn+1) : ds
+                (False, False) -> gen (toInt dn:ds) rn' sN mUpN' mDnN'
+        rds,rrds :: [Int]
+        rrds = reverse rds
+        rds =
+            if k >= 0 then
+                gen [] r (s * expt base k) mUp mDn
+            else
+                let bk = expt base (-k)
+                in  gen [] (r * bk) s (mUp * bk) (mDn * bk)
+        expt :: WordMax -> Int -> WordMax
+        expt base n = base^n
+    in  k `seq` f `seq` e `seq` b `seq` rrds `seq` (rrds, k)
+
+
+doubleToRational :: Double -> Rational
+doubleToRational x  =  (m:%1)*(b:%1)^^n where
+    (m,n) = decodeFloat x
+    b     = floatRadix  x
+
+
hunk ./lib/base/Prelude/Text.hs 13
+import Prelude.Float
hunk ./lib/base/Prelude/Text.hs 125
-    readsPrec p         = readSigned readFloat
+    readsPrec p s        = [ (doubleToFloat x,y) | (x,y) <- readSigned readDouble s]
hunk ./lib/base/Prelude/Text.hs 131
-    readsPrec p         = readSigned readFloat
+    readsPrec p         = readSigned readDouble
hunk ./lib/base/Prelude.hs 131
+
+{-# SPECIALIZE (^) :: Int -> Int -> Int #-}
+{-# SPECIALIZE (^) :: Integer -> Int -> Integer #-}
+{-# SPECIALIZE (^) :: Double -> Int -> Double #-}