module Data.Number.ER.Real.Base.MachineDouble
(
initMachineDouble
)
where
import qualified Data.Number.ER.Real.Base as B
import qualified Data.Number.ER.BasicTypes.ExtendedInteger as EI
import Data.Number.ER.Misc
import Foreign.C
type FP_RND_T = CInt
eFE_TONEAREST = 0
eFE_DOWNWARD = 0x400
eFE_UPWARD = 0x800
eFE_TOWARDZERO = 0xc00
foreign import ccall "fenv.h fegetround" fegetround
:: IO FP_RND_T
foreign import ccall "fenv.h fesetround" fesetround
:: FP_RND_T -> IO FP_RND_T
initMachineDouble :: IO ()
initMachineDouble =
do
currentRndMode <- fegetround
case currentRndMode == eFE_UPWARD of
True ->
putStrLn "already rounding upwards"
False ->
do
fesetround eFE_UPWARD
putStrLn "switching to upwards rounding"
instance B.ERRealBase Double
where
typeName _ = "double"
initialiseBaseArithmetic x =
do
putStr $ "Base arithmetic:" ++ B.typeName x ++ "; "
initMachineDouble
defaultGranularity _ = 53
getApproxBinaryLog d
| d < 0 =
error $ "ER.Real.Base.MachineDouble: getApproxBinaryLog: negative argument " ++ show d
| d == 0 = EI.MinusInfinity
| d >= 1 =
fromInteger $ intLogUp 2 $ ceiling d
| d < 1 =
negate $ fromInteger $ intLogUp 2 $ ceiling $ recip d
| otherwise =
error $ "ER.Real.Base.MachineDouble: getApproxBinaryLog: illegal argument " ++ show d
getGranularity _ = 53
setMinGranularity _ = id
setGranularity _ = id
getMaxRounding _ = 0
isERNaN f = isNaN f
erNaN = 0/0
isPlusInfinity f = isInfinite f && f > 0
plusInfinity = 1/0
fromIntegerUp i
| i <= floor nearest = nearest
| otherwise = nearestIncreased
where
nearestCeil = ceiling nearest
nearest = fromInteger i
nearestIncreased = encodeFloat (s+1) e
(s,e) = decodeFloat nearest
fromDouble = fromRational . toRational
toDouble = fromRational . toRational
fromFloat = fromRational . toRational
toFloat = fromRational . toRational
showDiGrCmp _numDigits _showGran _showComponents f = show f