ghc/tests/programs/north_lias/Main.lhs

   1 This version includes checks to see if `extended precision' is
   2 used in expressions, but does not determine the characteristics.
   3
   4
   5 > module Main (main) where
   6
   7 > import Bits
   8 > import LIAS
   9
  10 > version = "@(#)TestLIAS.lhs   1.2 dated 92/07/31 at 08:53:52"
  11 > int_name = "Int"
  12 > flp_name = "Float"
  13 > int_val :: Int
  14 > int_val = 1
  15 > flp_val :: Float
  16 > flp_val = 1
  17
  18 > maxInt, minInt :: Int
  19 > maxInt = maxBound
  20 > minInt = minBound
  21
  22 > main  =  (initial_checks flp_parms . main_identities flp_parms .
  23 >           notification_checks flp_parms) (return ())
  24 >          where
  25 >          flp_parms  =  makeFloatParms flp_val
  26
  27 Data type for representing parameters of a RealFloat.
  28 AN element has the form
  29 (MkFloatParms r p emin emax denorm fmax fmin fminN epsilon)
  30
  31 > data (RealFloat a) =>
  32 >      FloatParms a = MkFloatParms Integer Int Int Int Bool a a a a
  33
  34 > makeFloatParms :: (RealFloat a) => a -> FloatParms a
  35 > makeFloatParms x
  36 >     =  MkFloatParms (floatRadix x) (floatDigits x) (emin x) (emax x)
  37 >                     (denorm x) (fmax x) (fmin x) (fminN x) (epsilon x)
  38
  39 > initial_checks :: (RealFloat a) => FloatParms a -> Cont -> Cont
  40 > initial_checks (MkFloatParms r p eemin eemax ddenorm ffmax ffmin ffminN eps)
  41 >     =   -- text is output here to form the basis of a report.
  42 >        new_line .
  43 >        showits "LIAS Model Implementation " . showits version . new_line .
  44 >        new_line .
  45 >        showits "Test results" .  new_line .
  46 >        showits "Computer: " .  new_line .
  47 >        showits "Compiler: " .   new_line .
  48 >        showits "Options used: " . new_line .
  49 >        showits "Program modifications (with reasons): " . new_line .
  50 >        showits "Date tested: " . new_line .
  51 >        showits "Tested by: " . new_line .
  52 >        new_line .
  53 >        showits "Integer type (int) name " . showits int_name . new_line .
  54 >        showits "Floating point type (flp) name " . showits flp_name .
  55 >        new_line . new_line .
  56 >        showits "Parameter values" . new_line .
  57 >        showits "        minint,         maxint" .
  58 >        new_line .
  59 >        showits (pad 15 (show minInt)) . showits (pad 15 (show maxInt)) .
  60 >        new_line .
  61 >        showits " r,  p,    emin,   emax, denorm" .
  62 >        new_line .
  63 >        showits (pad 3 (show r)) .
  64 >        showits (pad 4 (show p)) .
  65 >        showits (pad 8 (show eemin)) . showits (pad 8 (show eemax)) .
  66 >        (if ddenorm then
  67 >           showits "  true"
  68 >        else
  69 >           showits "  false") .
  70 >        new_line .
  71 >        showits "fmax    " . showit ffmax . new_line .
  72 >        showits "fmin    " . showit ffmin . new_line .
  73 >        showits "fminn   " . showit ffminN . new_line .
  74 >        showits "epsilon " . showit eps . new_line .
  75 >        (if (r `mod` 2 /= 0) || (r < 0) then
  76 >           showits "floatRadix value is not positive even integer" .
  77 >           new_line
  78 >        else id) .
  79 >        (if fromIntegral (p -1) * log (fromInteger r)
  80 >            < log 1.0e6 then
  81 >           --  the accuracy of the log function used here is not critical
  82 >           showits "precision less than six decimal floatDigits" .
  83 >           new_line
  84 >        else id) .
  85 >        (if (eemin -1) >= -2*(fromInteger r -1) then
  86 >           showits "Exponent minimum too large" .
  87 >           new_line
  88 >        else id) .
  89 >        (if eemax <= 2*(fromInteger r -1) then
  90 >           showits "Exponent maximum not large enough" .
  91 >           new_line
  92 >        else id) .
  93 >        (if (-2 > eemin -1+eemax) ||
  94 >           (eemin -1+eemax > 2) then
  95 >           showits "Exponent range not roughly symmetric" .
  96 >           new_line
  97 >        else id) .
  98 >        new_line
  99
 100 > equal_int :: (Integral a) => (a, a, Int) -> Cont -> Cont
 101 > equal_int (i,j, test_number)
 102 >     | i /= j  =  showits "Integer operation check number " .
 103 >                  showit test_number . showits " fails with " .
 104 >                  showit i . showits " ". showit j . new_line
 105 >     | True    =  id
 106
 107 > equal_flp :: (RealFloat a) => (a, a, Int) -> Cont -> Cont
 108 > equal_flp (x, y, test_number)
 109 >     | x /= y  =  showits "Floating point operation check number " .
 110 >                  showit test_number . showits " fails" . new_line .
 111 >                  showit x . showits " " . showit y . new_line
 112 >     | True    =  id
 113
 114 > test_true :: (Bool, Int) -> Cont -> Cont
 115 > test_true (b, test_number)
 116 >     | not b  =  showits "Predicate number " . showit test_number .
 117 >                 showits " fails " .  showit b . new_line
 118 >     | True    =  id
 119
 120 > -- This procedure checks that sqrt(y*y) = y when y*y is exact
 121 > check_exact_squares :: (RealFloat a) => FloatParms a -> Cont -> Cont
 122 > check_exact_squares (MkFloatParms r p eemin eemax ddenorm
 123 >                                   ffmax ffmin ffminN eps)
 124 >     =  foldr (.) id (map foo list)
 125 >        where
 126 >        list  =  takeWhile in_range (iterate mul 10)
 127 >        mul y  =  fromInteger (truncate (1.2 * y)) :: Float
 128 >        in_range y  =  exponent y < p `div` 2
 129 >        foo y  =  if y /= sqrt (fromInteger (truncate (y * y)))
 130 >                  then showits "Square root not exact for a square" .
 131 >                       showit y . new_line
 132 >                  else id
 133
 134 > flp :: (Integral a, RealFloat b) => a -> b
 135 > flp  =  fromIntegral
 136
 137 > int_part :: (RealFloat a) => a -> a
 138 > int_part x  =  flp (truncate x)
 139
 140 > main_identities :: (RealFloat a) => FloatParms a -> Cont -> Cont
 141 > main_identities flp_parms@(MkFloatParms r p eemin eemax ddenorm
 142 >                                         ffmax ffmin ffminN eps)
 143 >     =  equal_int(-(-maxInt), maxInt, 1) .
 144 >        equal_int(2+2, 2*2, 2) .
 145 >        equal_int(minInt `rem` (-1), 0, 3) .
 146 >        equal_flp(1.0+1.0, 2.0, 4) .
 147 >        equal_flp(ffmax-1.0, ffmax, 5) .
 148 >        equal_flp(ffmax/2.0+ffmax/2.0, ffmax, 6) .
 149 >        equal_flp(ffmax/ffmax, 1.0, 7) .
 150 >        equal_flp((ffmax/flp(r))*flp(r), ffmax, 8) .
 151 >        equal_flp(ffmin/ffmin, 1.0, 9) .
 152 >        equal_flp(-(-1.1), 1.1, 10) .
 153 >        equal_flp(abs(-ffmax), ffmax, 11) .
 154 >        equal_flp(abs(-ffminN), ffminN, 12) .
 155 >        equal_flp(signf(-ffmin), -1.0, 13) .
 156 >        equal_flp(signf(0.0), 1.0, 14) .
 157 >        equal_flp(signf(ffmin), 1.0, 15) .
 158 >        -- NDN Tests 16-25 changed as they were incorrect
 159 >        equal_int(exponent 1.0, 1, 16) .
 160 >        equal_int(exponent 1.6, 1, 17) .
 161 >        equal_int(exponent(flp(r)), 2, 18) .
 162 >        equal_int(exponent(ffmax), eemax, 19) .
 163 >        equal_int(exponent(ffminN), eemin, 20) .
 164 >        (if ddenorm then
 165 >           equal_int(exponent(ffmin), eemin-p+1, 21)
 166 >        else id) .
 167 >        equal_flp(significand(0.9), 0.9, 22) .
 168 >        equal_flp(significand(1.0), scaleFloat (-1) 1, 23) .
 169 >        -- NDN This fails on hbc. I'm not sure  if the test is correct.
 170 >        equal_flp(significand(ffmax), predf(1), 24) .
 171 >        -- equal_flp(significand(-ffmin), -1.0, 25) .
 172 >        equal_flp(scaleFloat 1 1.1, 1.1*flp(r), 26) .
 173 >        equal_flp(scaleFloat (-11) (scaleFloat 11 1.7), 1.7, 27) .
 174 >        equal_flp(succf(1.0), 1.0+eps, 28) .
 175 >        -- NDN Test 29 changed as it was incorrect
 176 >        equal_flp(succf(significand(ffmax)), 1.0, 29) .
 177 >        equal_flp(succf(-ffmin), 0.0, 30) .
 178 >        equal_flp(succf(0.0), ffmin, 31) .
 179 >        equal_flp(predf(succf(ffmin)), ffmin, 32) .
 180 >        test_true(predf(flp(r)) < flp(r), 33) .
 181 >        test_true(predf 1.1 < 1.1, 34) .
 182 >        equal_flp(predf(succf 1.2), 1.2, 35) .
 183 >        equal_flp(ulpf(1.0), eps, 36) .
 184 >        equal_flp(flp(r)*ulpf(predf 1.0), eps, 37) .
 185 >        equal_flp(succf(predf(ffmax)), ffmax, 38) .
 186 >        equal_flp(truncf (1.0 + 3.0*eps) p, 1.0 + 3.0*eps, 39) .
 187 >        equal_flp(truncf (1.0 + 3.0*eps) (p-1), 1.0 + 2.0*eps, 40) .
 188 >        equal_flp(truncf (1.0 + 3.0*eps) (p-2), 1.0, 41) .
 189 >        equal_flp(roundf (1.0 + 3.0*eps) p, 1.0 + 3.0*eps, 42) .
 190 >        equal_flp(roundf (1.0 + 3.0*eps) (p-1), 1.0 + 4.0*eps, 43) .
 191 >        equal_flp(roundf (1.0 + 3.0*eps) (p-2), 1.0 + 4.0*eps, 44) .
 192 >        equal_flp(int_part 1.0, 1.0, 45) .
 193 >        equal_flp(int_part(succf 1.0), 1.0, 46) .
 194 >        equal_flp(int_part(predf 2.0), 1.0, 47) .
 195 >        equal_flp(int_part(-ffmin), 0.0, 48) .
 196 >        equal_flp(int_part(ffmin), 0.0, 49) .
 197 >        equal_flp(fractpart(ffmax), 0.0, 50) .
 198 >        equal_flp(fractpart(ffmin), ffmin, 51) .
 199 >        equal_flp(fractpart(succf 1.0), eps, 52) .
 200 >        equal_flp(fractpart(flp(r)), 0.0, 53) .
 201 >        equal_flp(fractpart(-ffmin), -ffmin, 54) .
 202 >        test_true(ffmin > 0.0, 55) .
 203 >        test_true(-ffmax < -ffmin, 56) .
 204 >        check_exact_squares flp_parms .
 205 >        -- equal_int(int(predf 3.5), 3, 57) .
 206 >        -- equal_int(int(succf 3.5), 4, 58) .
 207 >        -- equal_int(int(predf -3.5), -4, 59) .
 208 >        -- equal_flp(flp(int(-5.0)), -5.0, 60) .
 209 >        -- equal_flp(flp(int(-5.6)), -6.0, 61) .
 210 >        -- equal_flp(scaleFloat (eemax+1) (ffminN),
 211 >        --        flp(r) ^^ integer(eemax+eemin), 62) .
 212 >        -- equal_flp(scaleFloat(ffmax, eemin-2),
 213 >        --        significand(ffmax) *
 214 >        --          flp(r) ^^ integer(eemax+eemin-3), 63) .
 215 >        -- check_conversions .
 216 >        id
 217
 218 > notification_checks :: (RealFloat a) => FloatParms a -> Cont -> Cont
 219 > notification_checks (MkFloatParms r p eemin eemax ddenorm
 220 >                                   ffmax ffmin ffminN eps)
 221 >     =  showits "Test  condition tested notify  result(ce/ne/other/no)" .
 222 >        new_line .
 223 >        let my_maxint = maxInt in
 224 >            showits " 1   addi overflow pos  overf " .
 225 >            showit (my_maxint + 1) .
 226 >            new_line .
 227 >            showits " 2   addi overflow neg  overf " .
 228 >            (let tempi1 = -minInt ; tempi2 = -1 in
 229 >            showit (tempi1 + tempi2)) .
 230 >            new_line .
 231 >            showits " 3   subi overflow neg  overf " .
 232 >            showit (minInt - 1) .
 233 >            new_line .
 234 >            showits " 4   subi overflow pos  overf " .
 235 >            (let tempi1 = maxInt ; tempi2 = -1 in
 236 >            showit (tempi1 - tempi2)) .
 237 >            new_line .
 238 >            showits " 5   muli overflow pos  overf " .
 239 >            (let tempi1 = my_maxint `div` 2 + 1 ; tempi2 = 2 in
 240 >            showit (tempi1 * tempi2)) .
 241 >            new_line .
 242 >            showits " 6   muli overflow neg  overf " .
 243 >            (let tempi1 = -2 ; tempi2 = my_maxint `div` 2 + 2 in
 244 >            showit (tempi1 * tempi2)) .
 245 >            new_line .
 246 >            showits " 7   int divide by zero zerod " .
 247 >            (let tempi1 = 1 ; tempi2 = my_maxint - maxInt in
 248 >            showit (tempi1 `div` tempi2)) .
 249 >            new_line .
 250 >            showits " 8   int divide by zero zerod " .
 251 >            showit (1 `div` (my_maxint-maxInt)) .
 252 >            new_line .
 253 >            showits " 9   remi divide by 0   zerod " .
 254 >            showit (1 `rem` (my_maxint - maxInt)) .
 255 >            new_line .
 256 >            showits "10   modi divide by 0   zerod " .
 257 >            (let tempi1 = 1 ; tempi2 = my_maxint - maxInt in
 258 >            showit (tempi1 `mod` tempi2)) .
 259 >            new_line .
 260 >            showits "11  divide by zero      zerod " .
 261 >            showit (1 `div` (my_maxint-maxInt)) .
 262 >            new_line .
 263 >            showits "12  divide by zero      zerod " .
 264 >            showit (1 `div` (my_maxint-maxInt)) .
 265 >            new_line .
 266 >            -- showits "13   addf overflow      overf " .
 267 >            -- showit (ffmax + flp(r) ** integer(eemax-p+1)) .
 268 >            -- new_line .
 269 >            -- showits "14   subf overflow      overf " .
 270 >            -- showit (-ffmax - flp(r) ** integer(eemax-p+1)) .
 271 >            -- new_line .
 272 >            showits "15   mulf overflow      overf " .
 273 >            showit (ffmax * 1.001) .
 274 >            new_line .
 275 >            showits "16   divf overflow      overf " .
 276 >            showit (ffmax / 0.7) .
 277 >            new_line .
 278 >            showits "17   divf by zero       zerod " .
 279 >            (let tempf1 = flp(my_maxint-maxInt) in
 280 >            showit (1.0 / tempf1)) .
 281 >            new_line .
 282 >            showits "18   sqrt of tiny neg   undef " .
 283 >            showit (sqrt(-ffmin)) .
 284 >            new_line .
 285 >            showits "19   exponentf(zero)    undef " .
 286 >            (let tempf1 = flp(my_maxint-maxInt) in
 287 >            showit (exponent(tempf1))) .
 288 >            new_line .
 289 >            showits "20   succf of fmax      overf " .
 290 >            showit (succf(ffmax)) .
 291 >            new_line .
 292 >            showits "21   predf of -fmax     overf " .
 293 >            showit (predf(-ffmax)) .
 294 >            new_line .
 295 >            showits "22   ulpf(zero)         undef " .
 296 >            showit (ulpf(0.0)) .
 297 >            new_line .
 298 >            showits "23   roundf to 0 p undef " .
 299 >            showit (roundf 1.0 0) .
 300 >            new_line .
 301 >            showits "24   roundf  overflow   overf " .
 302 >            showit (roundf ffmax 2) .
 303 >            -- new_line .
 304 >            -- showits "25   trunc  overflow    overf " .
 305 >            -- (if flp(maxInt) < max_mantissa then
 306 >            --    showit (int(flp(maxInt)+1.0))
 307 >            -- else
 308 >            --    showit (int(succf(flp(maxInt))))) .
 309 >            -- new_line .
 310 >            -- showits "26   round overflow     overf " .
 311 >            -- (if flp(maxInt) < max_mantissa then
 312 >            --    showit (int(flp(minInt)-1.0))
 313 >            -- else
 314 >            --    showit (int(predf(flp(minInt)))))
 315 >            id
 316