1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
|
{-# Language BlockArguments #-}
module Main(main) where
import Test.Tasty (TestTree, defaultMain, testGroup)
import Test.Tasty.HUnit ((@=?), assertFailure, testCase)
import LibBF
main :: IO ()
main =
defaultMain $
testGroup "LibBF tests"
[ testGroup "bfToString"
[ testCase "NaN" $
"NaN" @=? bfToString 16 (showFree Nothing) bfNaN
]
, testGroup "bfFromString"
[ testCase "Underflow" $
let (_, status) =
bfFromString 10 (expBits 3 <> precBits 2 <> rnd ToZero) "0.001" in
True @=? statusUnderflow status
, testCase "Overflow" $
let (_, status) =
bfFromString 10 (expBits 3 <> precBits 2 <> rnd ToZero) "1.0e200" in
True @=? statusOverflow status
]
, testGroup "bfAdd"
[ dblTestCase "+" (+) (bfAdd (float64 NearEven)) 1 2
]
, testGroup "bfDiv"
[ dblTestCase "/" (/) (bfDiv (float64 NearEven)) 1 0
]
, testGroup "IEEE 754 compare"
[ testGroup "Comparisons with NaN should always return False"
[ testCase "NaN > 0" $ False @=? bfNaN > bfPosZero
, testCase "0 > NaN" $ False @=? bfPosZero > bfNaN
, testCase "NaN >= 0" $ False @=? bfNaN >= bfPosZero
, testCase "0 >= NaN" $ False @=? bfPosZero >= bfNaN
, testCase "NaN < 0" $ False @=? bfNaN < bfPosZero
, testCase "0 < NaN" $ False @=? bfPosZero < bfNaN
, testCase "NaN <= 0" $ False @=? bfNaN <= bfPosZero
, testCase "0 <= NaN" $ False @=? bfPosZero <= bfNaN
]
]
]
statusUnderflow :: Status -> Bool
statusUnderflow Underflow = True
statusUnderflow _ = False
statusOverflow :: Status -> Bool
statusOverflow Overflow = True
statusOverflow _ = False
-- Check that a binary operation over BigFloats returns the same result as the
-- corresponding operation over doubles.
dblTestCase ::
String ->
(Double -> Double -> Double) ->
(BigFloat -> BigFloat -> (BigFloat, Status)) ->
Double -> Double -> TestTree
dblTestCase op opD opBF x y =
testCase (unwords [show x, op, show y]) $
case z1 of
Left err -> assertFailure ("status: " ++ err)
Right actual -> expected @=? actual
where
expected = opD x y
z1 = case opBF (bfFromDouble x) (bfFromDouble y) of
(res,_) ->
case bfToDouble NearEven res of
(res1,Ok) -> Right res1
(_, s) -> Left ("result: " ++ show s)
|
