basis/math/floats/env/env-tests.factor

   1 USING: kernel math math.floats.env math.floats.env.private
   2 math.functions math.libm sequences tools.test locals
   3 compiler.units kernel.private fry compiler math.private words ;
   4 IN: math.floats.env.tests
   5
   6 : set-default-fp-env ( -- )
   7     { } { } +round-nearest+ +denormal-keep+ set-fp-env ;
   8
   9 ! In case the tests screw up the FP env because of bugs in math.floats.env
  10 set-default-fp-env
  11
  12 : test-fp-exception ( exception inputs quot -- quot' )
  13     '[ _ [ @ @ ] collect-fp-exceptions nip member? ] ;
  14
  15 : test-fp-exception-compiled ( exception inputs quot -- quot' )
  16     '[ _ @ [ _ collect-fp-exceptions ] compile-call nip member? ] ;
  17
  18 [ t ] +fp-zero-divide+ [ 1.0 0.0 ] [ /f ] test-fp-exception unit-test
  19 [ t ] +fp-inexact+ [ 1.0 3.0 ] [ /f ] test-fp-exception unit-test
  20 [ t ] +fp-overflow+ [ 1.0e250 1.0e100 ] [ * ] test-fp-exception unit-test
  21 [ t ] +fp-underflow+ [ 1.0e-250 1.0e-100 ] [ * ] test-fp-exception unit-test
  22 [ t ] +fp-overflow+ [ 2.0 100,000.0 ] [ fpow ] test-fp-exception unit-test
  23 [ t ] +fp-underflow+ [ 2.0 -100,000.0 ] [ fpow ] test-fp-exception unit-test
  24 [ t ] +fp-invalid-operation+ [ 0.0 0.0 ] [ /f ] test-fp-exception unit-test
  25 [ t ] +fp-invalid-operation+ [ -1.0 ] [ fsqrt ] test-fp-exception unit-test
  26
  27 [ t ] +fp-zero-divide+ [ 1.0 0.0 ] [ /f ] test-fp-exception-compiled unit-test
  28 [ t ] +fp-inexact+ [ 1.0 3.0 ] [ /f ] test-fp-exception-compiled unit-test
  29 [ t ] +fp-overflow+ [ 1.0e250 1.0e100 ] [ * ] test-fp-exception-compiled unit-test
  30 [ t ] +fp-underflow+ [ 1.0e-250 1.0e-100 ] [ * ] test-fp-exception-compiled unit-test
  31 [ t ] +fp-overflow+ [ 2.0 100,000.0 ] [ fpow ] test-fp-exception-compiled unit-test
  32 [ t ] +fp-underflow+ [ 2.0 -100,000.0 ] [ fpow ] test-fp-exception-compiled unit-test
  33 [ t ] +fp-invalid-operation+ [ 0.0 0.0 ] [ /f ] test-fp-exception-compiled unit-test
  34 [ t ] +fp-invalid-operation+ [ -1.0 ] [ fsqrt ] test-fp-exception-compiled unit-test
  35
  36 [
  37     HEX: 3fd5,5555,5555,5555
  38     HEX: 3fc9,9999,9999,999a
  39     HEX: bfc9,9999,9999,999a
  40     HEX: bfd5,5555,5555,5555
  41 ] [
  42     +round-nearest+ [
  43          1.0 3.0 /f double>bits
  44          1.0 5.0 /f double>bits
  45         -1.0 5.0 /f double>bits
  46         -1.0 3.0 /f double>bits
  47     ] with-rounding-mode
  48 ] unit-test
  49
  50 [
  51     HEX: 3fd5,5555,5555,5555
  52     HEX: 3fc9,9999,9999,9999
  53     HEX: bfc9,9999,9999,999a
  54     HEX: bfd5,5555,5555,5556
  55 ] [
  56     +round-down+ [
  57          1.0 3.0 /f double>bits
  58          1.0 5.0 /f double>bits
  59         -1.0 5.0 /f double>bits
  60         -1.0 3.0 /f double>bits
  61     ] with-rounding-mode
  62 ] unit-test
  63
  64 [
  65     HEX: 3fd5,5555,5555,5556
  66     HEX: 3fc9,9999,9999,999a
  67     HEX: bfc9,9999,9999,9999
  68     HEX: bfd5,5555,5555,5555
  69 ] [
  70     +round-up+ [
  71          1.0 3.0 /f double>bits
  72          1.0 5.0 /f double>bits
  73         -1.0 5.0 /f double>bits
  74         -1.0 3.0 /f double>bits
  75     ] with-rounding-mode
  76 ] unit-test
  77
  78 [
  79     HEX: 3fd5,5555,5555,5555
  80     HEX: 3fc9,9999,9999,9999
  81     HEX: bfc9,9999,9999,9999
  82     HEX: bfd5,5555,5555,5555
  83 ] [
  84     +round-zero+ [
  85          1.0 3.0 /f double>bits
  86          1.0 5.0 /f double>bits
  87         -1.0 5.0 /f double>bits
  88         -1.0 3.0 /f double>bits
  89     ] with-rounding-mode
  90 ] unit-test
  91
  92 ! ensure rounding mode is restored to +round-nearest+
  93 [
  94     HEX: 3fd5,5555,5555,5555
  95     HEX: 3fc9,9999,9999,999a
  96     HEX: bfc9,9999,9999,999a
  97     HEX: bfd5,5555,5555,5555
  98 ] [
  99      1.0 3.0 /f double>bits
 100      1.0 5.0 /f double>bits
 101     -1.0 5.0 /f double>bits
 102     -1.0 3.0 /f double>bits
 103 ] unit-test
 104
 105 : test-traps ( traps inputs quot -- quot' )
 106     append '[ _ _ with-fp-traps ] ;
 107
 108 : test-traps-compiled ( traps inputs quot -- quot' )
 109     swapd '[ _ [ _ _ with-fp-traps ] compile-call ] ;
 110
 111 { +fp-zero-divide+ }       [ 1.0 0.0 ] [ /f ] test-traps must-fail
 112 { +fp-inexact+ }           [ 1.0 3.0 ] [ /f ] test-traps must-fail
 113 { +fp-invalid-operation+ } [ -1.0 ] [ fsqrt ] test-traps must-fail
 114 { +fp-overflow+ }          [ 2.0 ] [ 100,000.0 ^ ] test-traps must-fail
 115 { +fp-underflow+ }         [ 2.0 ] [ -100,000.0 ^ ] test-traps must-fail
 116
 117 { +fp-zero-divide+ }       [ 1.0 0.0 ] [ /f ] test-traps-compiled must-fail
 118 { +fp-inexact+ }           [ 1.0 3.0 ] [ /f ] test-traps-compiled must-fail
 119 { +fp-invalid-operation+ } [ -1.0 ] [ fsqrt ] test-traps-compiled must-fail
 120 { +fp-overflow+ }          [ 2.0 ] [ 100,000.0 ^ ] test-traps-compiled must-fail
 121 { +fp-underflow+ }         [ 2.0 ] [ -100,000.0 ^ ] test-traps-compiled must-fail
 122
 123 ! Ensure ordered comparisons raise traps
 124 :: test-comparison-quot ( word -- quot )
 125     [
 126         { float float } declare
 127         { +fp-invalid-operation+ } [ word execute ] with-fp-traps
 128     ] ;
 129
 130 : test-comparison ( inputs word -- quot )
 131     test-comparison-quot append ;
 132
 133 : test-comparison-compiled ( inputs word -- quot )
 134     test-comparison-quot '[ @ _ compile-call ] ;
 135
 136 \ float< "intrinsic" word-prop [
 137     [ 0/0. -15.0 ] \ < test-comparison must-fail
 138     [ 0/0. -15.0 ] \ < test-comparison-compiled must-fail
 139     [ -15.0 0/0. ] \ < test-comparison must-fail
 140     [ -15.0 0/0. ] \ < test-comparison-compiled must-fail
 141     [ 0/0. -15.0 ] \ <= test-comparison must-fail
 142     [ 0/0. -15.0 ] \ <= test-comparison-compiled must-fail
 143     [ -15.0 0/0. ] \ <= test-comparison must-fail
 144     [ -15.0 0/0. ] \ <= test-comparison-compiled must-fail
 145     [ 0/0. -15.0 ] \ > test-comparison must-fail
 146     [ 0/0. -15.0 ] \ > test-comparison-compiled must-fail
 147     [ -15.0 0/0. ] \ > test-comparison must-fail
 148     [ -15.0 0/0. ] \ > test-comparison-compiled must-fail
 149     [ 0/0. -15.0 ] \ >= test-comparison must-fail
 150     [ 0/0. -15.0 ] \ >= test-comparison-compiled must-fail
 151     [ -15.0 0/0. ] \ >= test-comparison must-fail
 152     [ -15.0 0/0. ] \ >= test-comparison-compiled must-fail
 153
 154     [ f ] [ 0/0. -15.0 ] \ u< test-comparison unit-test
 155     [ f ] [ 0/0. -15.0 ] \ u< test-comparison-compiled unit-test
 156     [ f ] [ -15.0 0/0. ] \ u< test-comparison unit-test
 157     [ f ] [ -15.0 0/0. ] \ u< test-comparison-compiled unit-test
 158     [ f ] [ 0/0. -15.0 ] \ u<= test-comparison unit-test
 159     [ f ] [ 0/0. -15.0 ] \ u<= test-comparison-compiled unit-test
 160     [ f ] [ -15.0 0/0. ] \ u<= test-comparison unit-test
 161     [ f ] [ -15.0 0/0. ] \ u<= test-comparison-compiled unit-test
 162     [ f ] [ 0/0. -15.0 ] \ u> test-comparison unit-test
 163     [ f ] [ 0/0. -15.0 ] \ u> test-comparison-compiled unit-test
 164     [ f ] [ -15.0 0/0. ] \ u> test-comparison unit-test
 165     [ f ] [ -15.0 0/0. ] \ u> test-comparison-compiled unit-test
 166     [ f ] [ 0/0. -15.0 ] \ u>= test-comparison unit-test
 167     [ f ] [ 0/0. -15.0 ] \ u>= test-comparison-compiled unit-test
 168     [ f ] [ -15.0 0/0. ] \ u>= test-comparison unit-test
 169     [ f ] [ -15.0 0/0. ] \ u>= test-comparison-compiled unit-test
 170 ] when
 171
 172 ! Ensure traps get cleared
 173 [ 1/0. ] [ 1.0 0.0 /f ] unit-test
 174
 175 ! Ensure state is back to normal
 176 [ +round-nearest+ ] [ rounding-mode ] unit-test
 177 [ +denormal-keep+ ] [ denormal-mode ] unit-test
 178 [ { } ] [ fp-traps ] unit-test
 179
 180 ! In case the tests screw up the FP env because of bugs in math.floats.env
 181 set-default-fp-env
 182