module Text.FShow.RealFloat.Internals
( posToDigits
, i2D
, integerLog2
) where
#include "MachDeps.h"
import GHC.Base
import GHC.Num (quotRemInt)
import GHC.Integer
import Data.Array.Base (unsafeAt)
import Data.Array.IArray
#if __GLASGOW_HASKELL__ >= 702
import GHC.Base
import GHC.Integer.Logarithms
integerLog2 :: Integer -> Int
integerLog2 n = I# (integerLog2# n)
#else
import GHC.Float (integerLogBase)
integerLog2 :: Integer -> Int
integerLog2 = integerLogBase 2
#endif
#if WORD_SIZE_IN_BITS == 32
#define DIGITS 9
#define BASE 1000000000
#else
#define DIGITS 18
#define BASE 1000000000000000000
#endif
i2D :: Int -> Char
i2D (I# i#) = C# (chr# (ord# '0'# +# i#))
posToDigits :: Int
-> Int
-> Integer
-> Int
-> ([Int], Int)
posToDigits showDigs mantExp mant scaleExp@(I# e#) = (integerToDigits decMant, e10)
where
!rex = mantExp + scaleExp
!l0 = (8651*rex) `quot` 28738
!l10 = if rex < 0 then l01 else l0
!decshift@(I# d#) = showDigs l10
!binshift = e# +# d#
!decMant
| d# <# 0# =
(if binshift <# 0#
then shiftRInteger mant (negateInt# binshift)
else shiftLInteger mant binshift) `quot` expt5 (I# (negateInt# d#))
| binshift <# 0# =
shiftRInteger (mant * expt5 decshift) (negateInt# binshift)
| otherwise = shiftLInteger (mant * expt5 decshift) binshift
!e10 = if decMant < expt10 (showDigs+1) then l10 else l10+1
expt5 :: Int -> Integer
expt5 k = if k <= maxEx5 && k >= 0 then unsafeAt expts5 k else 5^k
expt10 :: Int -> Integer
expt10 k = if k <= maxEx10 && k >= 0 then unsafeAt expts10 k else 10^k
maxEx5 :: Int
maxEx5 = 349
maxEx10 :: Int
maxEx10 = 25
expts5 :: Array Int Integer
expts5 = array (0, maxEx5) [(k,5^k) | k <- [0 .. maxEx5]]
expts10 :: Array Int Integer
expts10 = array (0,maxEx10) [(k,10^k) | k <- [0 .. maxEx10]]
integerToDigits :: Integer -> [Int]
integerToDigits nm
| nm < BASE = jhead (fromInteger nm) []
| otherwise = jprinth (jsplitf (BASE*BASE) nm) []
where
jsplitf :: Integer -> Integer -> [Integer]
jsplitf p n
| p > n = [n]
| otherwise = jsplith p (jsplitf (p*p) n)
jsplith :: Integer -> [Integer] -> [Integer]
jsplith p (n:ns) =
case n `quotRemInteger` p of
(# q, r #) ->
if q > 0 then q : r : jsplitb p ns
else r : jsplitb p ns
jsplith _ [] = error "jsplith: []"
jsplitb :: Integer -> [Integer] -> [Integer]
jsplitb _ [] = []
jsplitb p (n:ns) = case n `quotRemInteger` p of
(# q, r #) ->
q : r : jsplitb p ns
jprinth :: [Integer] -> [Int] -> [Int]
jprinth (n:ns) cs =
case n `quotRemInteger` BASE of
(# q', r' #) ->
let q = fromInteger q'
r = fromInteger r'
in if q > 0 then jhead q $ jblock r $ jprintb ns cs
else jhead r $ jprintb ns cs
jprinth [] _ = error "jprinth []"
jprintb :: [Integer] -> [Int] -> [Int]
jprintb [] cs = cs
jprintb (n:ns) cs = case n `quotRemInteger` BASE of
(# q', r' #) ->
let q = fromInteger q'
r = fromInteger r'
in jblock q $ jblock r $ jprintb ns cs
jhead :: Int -> [Int] -> [Int]
jhead n cs
| n < 10 = n:cs
| otherwise = jhead q (r : cs)
where
(q, r) = n `quotRemInt` 10
jblock = jblock' DIGITS
jblock' :: Int -> Int -> [Int] -> [Int]
jblock' d n cs
| d == 1 = n : cs
| otherwise = jblock' (d 1) q (r : cs)
where
(q, r) = n `quotRemInt` 10