ghc/tests/codeGen/should_run/cg044.hs

   1 -- !!! Testing IEEE Float and Double extremity predicates.
   2 module Main(main) where
   3
   4 import Char
   5 import ST
   6 import MutableArray
   7
   8 main :: IO ()
   9 main = do
  10  sequence_ (map putStrLn double_tests)
  11  sequence_ (map putStrLn float_tests)
  12   where
  13    double_tests = run_tests double_numbers
  14    float_tests  = run_tests float_numbers
  15
  16    run_tests nums =
  17     map ($nums)
  18         [ denorm
  19         , pos_inf
  20         , neg_inf
  21         , nan
  22         , neg_zero
  23         , pos_zero
  24         ]
  25
  26 -------------
  27 double_numbers :: [Double]
  28 double_numbers =
  29       [ 0
  30       , encodeFloat 0 0     -- 0 using encodeFloat method
  31       , mkDouble (map chr [0,0,0,0,0,0, 0xf0, 0x7f])  -- +inf
  32       , encodeFloat 1 2047  -- +Inf
  33       , encodeFloat 1 2048
  34       , encodeFloat 1  2047               -- signalling NaN
  35       , encodeFloat 0xf000000000000 2047  -- quiet NaN
  36       , 0/(0::Double)
  37         -- misc
  38       , 1.82173691287639817263897126389712638972163e-300
  39       , 1.82173691287639817263897126389712638972163e+300
  40       , 4.9406564558412465e-324  -- smallest possible denorm number
  41                                  -- (as reported by enquire running
  42                                  --  on a i686-pc-linux.)
  43       , 2.2250738585072014e-308
  44       , 0.11
  45       , 0.100
  46       , -3.4
  47         -- smallest
  48       , let (l, _) = floatRange x
  49             x = encodeFloat 1 (l-1)
  50         in x
  51         -- largest
  52       , let (_, u) = floatRange x
  53             d = floatDigits x
  54             x = encodeFloat (floatRadix x ^ d - 1) (u - d)
  55         in x
  56       ]
  57
  58 float_numbers :: [Float]
  59 float_numbers =
  60       [ 0
  61       , encodeFloat 0 0     -- 0 using encodeFloat method
  62       , encodeFloat 1 255  -- +Inf
  63       , encodeFloat 1 256
  64       , encodeFloat 11 255        -- signalling NaN
  65       , encodeFloat 0xf00000 255  -- quiet NaN
  66       , 0/(0::Float)
  67         -- misc
  68       , 1.82173691287639817263897126389712638972163e-300
  69       , 1.82173691287639817263897126389712638972163e+300
  70       , 1.40129846e-45
  71       , 1.17549435e-38
  72       , 2.98023259e-08
  73       , 0.11
  74       , 0.100
  75       , -3.4
  76         -- smallest
  77       , let (l, _) = floatRange x
  78             x = encodeFloat 1 (l-1)
  79         in x
  80         -- largest
  81       , let (_, u) = floatRange x
  82             d = floatDigits x
  83             x = encodeFloat (floatRadix x ^ d - 1) (u - d)
  84         in x
  85       ]
  86
  87 -------------
  88
  89 denorm :: RealFloat a => [a] -> String
  90 denorm numbers =
  91   unlines
  92      ( ""
  93      : "*********************************"
  94      : ("Denormalised numbers: " ++ doubleOrFloat numbers)
  95      : ""
  96      : map showPerform numbers)
  97  where
  98    showPerform = showAndPerform (isDenormalized) "isDenormalised"
  99
 100 pos_inf :: RealFloat a => [a] -> String
 101 pos_inf numbers =
 102   unlines
 103      ( ""
 104      : "*********************************"
 105      : ("Positive Infinity: " ++ doubleOrFloat numbers)
 106      : ""
 107      : map showPerform numbers)
 108  where
 109    showPerform = showAndPerform (isInfinite) "isInfinite"
 110
 111 neg_inf :: RealFloat a => [a] -> String
 112 neg_inf numbers =
 113   unlines
 114      ( ""
 115      : "*********************************"
 116      : ("Negative Infinity: " ++ doubleOrFloat numbers)
 117      : ""
 118      : map showPerform numbers)
 119  where
 120    showPerform = showAndPerform (\ x -> isInfinite x && x < 0) "isNegInfinite"
 121
 122 nan :: RealFloat a => [a] -> String
 123 nan numbers =
 124   unlines
 125      ( ""
 126      : "*********************************"
 127      : ("NaN: " ++ doubleOrFloat numbers)
 128      : ""
 129      : map showPerform numbers)
 130  where
 131    showPerform = showAndPerform (isNaN) "isNaN"
 132
 133 pos_zero :: RealFloat a => [a] -> String
 134 pos_zero numbers =
 135   unlines
 136      ( ""
 137      : "*********************************"
 138      : ("Positive zero: " ++ doubleOrFloat numbers)
 139      : ""
 140      : map showPerform numbers)
 141  where
 142    showPerform = showAndPerform (==0) "isPosZero"
 143
 144 neg_zero :: RealFloat a => [a] -> String
 145 neg_zero numbers =
 146   unlines
 147      ( ""
 148      : "*********************************"
 149      : ("Negative zero: " ++ doubleOrFloat numbers)
 150      : ""
 151      : map showPerform numbers)
 152  where
 153    showPerform = showAndPerform (isNegativeZero) "isNegativeZero"
 154
 155 -- what a hack.
 156 doubleOrFloat :: RealFloat a => [a] -> String
 157 doubleOrFloat ls
 158  | (floatDigits atType) == (floatDigits (0::Double)) = "Double"
 159  | (floatDigits atType) == (floatDigits (0::Float))  = "Float"
 160  | otherwise = "unknown RealFloat type"
 161  where
 162    atType = undefined `asTypeOf` (head ls)
 163
 164 -- make a double from a list of 8 bytes
 165 -- (caller deals with byte ordering.)
 166 mkDouble :: [Char] -> Double
 167 mkDouble ls =
 168  runST ( do
 169    arr <- newCharArray (0,7)
 170    sequence (zipWith (writeCharArray arr) [(0::Int)..] (take 8 ls))
 171    readDoubleArray arr 0
 172  )
 173
 174 showAndPerform :: (Show a, Show b)
 175                => (a -> b)
 176                -> String
 177                -> a
 178                -> String
 179 showAndPerform fun name_fun val =
 180   name_fun ++ ' ':show val ++ " = " ++ show (fun val)
 181