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.test math.private
   4 words system memory ;
   5 IN: math.floats.env.tests
   6
   7 : set-default-fp-env ( -- )
   8     { } { } +round-nearest+ +denormal-keep+ set-fp-env ;
   9
  10 ! In case the tests screw up the FP env because of bugs in math.floats.env
  11 set-default-fp-env
  12
  13 : test-fp-exception ( exception inputs quot -- quot' )
  14     '[ _ [ @ @ ] collect-fp-exceptions nip member? ] ;
  15
  16 : test-fp-exception-compiled ( exception inputs quot -- quot' )
  17     '[ _ @ [ _ collect-fp-exceptions ] compile-call nip member? ] ;
  18
  19 [ t ] +fp-zero-divide+ [ 1.0 0.0 ] [ /f ] test-fp-exception unit-test
  20 [ t ] +fp-inexact+ [ 1.0 3.0 ] [ /f ] test-fp-exception unit-test
  21 [ t ] +fp-overflow+ [ 1.0e250 1.0e100 ] [ * ] test-fp-exception unit-test
  22 [ t ] +fp-underflow+ [ 1.0e-250 1.0e-100 ] [ * ] test-fp-exception unit-test
  23 [ t ] +fp-overflow+ [ 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-invalid-operation+ [ 2.0 0/0. 1.0e-9 ] [ ~ ] test-fp-exception-compiled unit-test
  33
  34 ! No underflow on Linux with this test, just inexact. Reported as an Ubuntu bug:
  35 ! https://bugs.launchpad.net/ubuntu/+source/glibc/+bug/429113
  36 os linux? cpu x86.64? and [
  37     [ t ] +fp-underflow+ [ 2.0 -100,000.0 ] [ fpow ] test-fp-exception unit-test
  38     [ t ] +fp-underflow+ [ 2.0 -100,000.0 ] [ fpow ] test-fp-exception-compiled unit-test
  39 ] unless
  40
  41 [ t ] +fp-invalid-operation+ [ 0.0 0.0 ] [ /f ] test-fp-exception-compiled unit-test
  42 [ t ] +fp-invalid-operation+ [ -1.0 ] [ fsqrt ] test-fp-exception-compiled unit-test
  43
  44 [
  45     HEX: 3fd5,5555,5555,5555
  46     HEX: 3fc9,9999,9999,999a
  47     HEX: bfc9,9999,9999,999a
  48     HEX: bfd5,5555,5555,5555
  49 ] [
  50     +round-nearest+ [
  51          1.0 3.0 /f double>bits
  52          1.0 5.0 /f double>bits
  53         -1.0 5.0 /f double>bits
  54         -1.0 3.0 /f double>bits
  55     ] with-rounding-mode
  56 ] unit-test
  57
  58 [
  59     HEX: 3fd5,5555,5555,5555
  60     HEX: 3fc9,9999,9999,9999
  61     HEX: bfc9,9999,9999,999a
  62     HEX: bfd5,5555,5555,5556
  63 ] [
  64     +round-down+ [
  65          1.0 3.0 /f double>bits
  66          1.0 5.0 /f double>bits
  67         -1.0 5.0 /f double>bits
  68         -1.0 3.0 /f double>bits
  69     ] with-rounding-mode
  70 ] unit-test
  71
  72 [
  73     HEX: 3fd5,5555,5555,5556
  74     HEX: 3fc9,9999,9999,999a
  75     HEX: bfc9,9999,9999,9999
  76     HEX: bfd5,5555,5555,5555
  77 ] [
  78     +round-up+ [
  79          1.0 3.0 /f double>bits
  80          1.0 5.0 /f double>bits
  81         -1.0 5.0 /f double>bits
  82         -1.0 3.0 /f double>bits
  83     ] with-rounding-mode
  84 ] unit-test
  85
  86 [
  87     HEX: 3fd5,5555,5555,5555
  88     HEX: 3fc9,9999,9999,9999
  89     HEX: bfc9,9999,9999,9999
  90     HEX: bfd5,5555,5555,5555
  91 ] [
  92     +round-zero+ [
  93          1.0 3.0 /f double>bits
  94          1.0 5.0 /f double>bits
  95         -1.0 5.0 /f double>bits
  96         -1.0 3.0 /f double>bits
  97     ] with-rounding-mode
  98 ] unit-test
  99
 100 ! ensure rounding mode is restored to +round-nearest+
 101 [
 102     HEX: 3fd5,5555,5555,5555
 103     HEX: 3fc9,9999,9999,999a
 104     HEX: bfc9,9999,9999,999a
 105     HEX: bfd5,5555,5555,5555
 106 ] [
 107      1.0 3.0 /f double>bits
 108      1.0 5.0 /f double>bits
 109     -1.0 5.0 /f double>bits
 110     -1.0 3.0 /f double>bits
 111 ] unit-test
 112
 113 ! FP traps cause a kernel panic on OpenBSD 4.5 i386
 114 os openbsd eq? cpu x86.32 eq? and [
 115
 116     : fp-trap-error? ( error -- ? )
 117         2 head { "kernel-error" 17 } = ;
 118
 119     : test-traps ( traps inputs quot -- quot' fail-quot )
 120         append '[ _ _ with-fp-traps ] [ fp-trap-error? ] ;
 121
 122     : test-traps-compiled ( traps inputs quot -- quot' fail-quot )
 123         swapd '[ @ [ _ _ with-fp-traps ] compile-call ] [ fp-trap-error? ] ;
 124
 125     { +fp-zero-divide+ } [ 1.0 0.0 ] [ /f ] test-traps must-fail-with
 126     { +fp-inexact+ } [ 1.0 3.0 ] [ /f ] test-traps must-fail-with
 127     { +fp-invalid-operation+ } [ -1.0 ] [ fsqrt ] test-traps must-fail-with
 128     { +fp-overflow+ } [ 2.0 ] [ 100,000.0 ^ ] test-traps must-fail-with
 129     { +fp-underflow+ +fp-inexact+ } [ 2.0 ] [ -100,000.0 ^ ] test-traps must-fail-with
 130
 131     { +fp-zero-divide+ } [ 1.0 0.0 ] [ /f ] test-traps-compiled must-fail-with
 132     { +fp-inexact+ } [ 1.0 3.0 ] [ /f ] test-traps-compiled must-fail-with
 133     { +fp-invalid-operation+ } [ -1.0 ] [ fsqrt ] test-traps-compiled must-fail-with
 134     { +fp-overflow+ } [ 2.0 ] [ 100,000.0 ^ ] test-traps-compiled must-fail-with
 135     { +fp-underflow+ +fp-inexact+ } [ 2.0 ] [ -100,000.0 ^ ] test-traps-compiled must-fail-with
 136
 137     ! Ensure ordered comparisons raise traps
 138     :: test-comparison-quot ( word -- quot )
 139         [
 140             { float float } declare
 141             { +fp-invalid-operation+ } [ word execute ] with-fp-traps
 142         ] ;
 143
 144     : test-comparison ( inputs word -- quot fail-quot )
 145         test-comparison-quot append [ fp-trap-error? ] ;
 146
 147     : test-comparison-compiled ( inputs word -- quot fail-quot )
 148         test-comparison-quot '[ @ _ compile-call ] [ fp-trap-error? ] ;
 149
 150     \ float< "intrinsic" word-prop [
 151         [ 0/0. -15.0 ] \ < test-comparison must-fail-with
 152         [ 0/0. -15.0 ] \ < test-comparison-compiled must-fail-with
 153         [ -15.0 0/0. ] \ < test-comparison must-fail-with
 154         [ -15.0 0/0. ] \ < test-comparison-compiled must-fail-with
 155         [ 0/0. -15.0 ] \ <= test-comparison must-fail-with
 156         [ 0/0. -15.0 ] \ <= test-comparison-compiled must-fail-with
 157         [ -15.0 0/0. ] \ <= test-comparison must-fail-with
 158         [ -15.0 0/0. ] \ <= test-comparison-compiled must-fail-with
 159         [ 0/0. -15.0 ] \ > test-comparison must-fail-with
 160         [ 0/0. -15.0 ] \ > test-comparison-compiled must-fail-with
 161         [ -15.0 0/0. ] \ > test-comparison must-fail-with
 162         [ -15.0 0/0. ] \ > test-comparison-compiled must-fail-with
 163         [ 0/0. -15.0 ] \ >= test-comparison must-fail-with
 164         [ 0/0. -15.0 ] \ >= test-comparison-compiled must-fail-with
 165         [ -15.0 0/0. ] \ >= test-comparison must-fail-with
 166         [ -15.0 0/0. ] \ >= test-comparison-compiled must-fail-with
 167
 168         [ f ] [ 0/0. -15.0 ] \ u< test-comparison drop unit-test
 169         [ f ] [ 0/0. -15.0 ] \ u< test-comparison-compiled drop unit-test
 170         [ f ] [ -15.0 0/0. ] \ u< test-comparison drop unit-test
 171         [ f ] [ -15.0 0/0. ] \ u< test-comparison-compiled drop unit-test
 172         [ f ] [ 0/0. -15.0 ] \ u<= test-comparison drop unit-test
 173         [ f ] [ 0/0. -15.0 ] \ u<= test-comparison-compiled drop unit-test
 174         [ f ] [ -15.0 0/0. ] \ u<= test-comparison drop unit-test
 175         [ f ] [ -15.0 0/0. ] \ u<= test-comparison-compiled drop unit-test
 176         [ f ] [ 0/0. -15.0 ] \ u> test-comparison drop unit-test
 177         [ f ] [ 0/0. -15.0 ] \ u> test-comparison-compiled drop unit-test
 178         [ f ] [ -15.0 0/0. ] \ u> test-comparison drop unit-test
 179         [ f ] [ -15.0 0/0. ] \ u> test-comparison-compiled drop unit-test
 180         [ f ] [ 0/0. -15.0 ] \ u>= test-comparison drop unit-test
 181         [ f ] [ 0/0. -15.0 ] \ u>= test-comparison-compiled drop unit-test
 182         [ f ] [ -15.0 0/0. ] \ u>= test-comparison drop unit-test
 183         [ f ] [ -15.0 0/0. ] \ u>= test-comparison-compiled drop unit-test
 184     ] when
 185
 186 ] unless
 187
 188 ! Ensure traps get cleared
 189 [ 1/0. ] [ 1.0 0.0 /f ] unit-test
 190
 191 ! Ensure state is back to normal
 192 [ +round-nearest+ ] [ rounding-mode ] unit-test
 193 [ +denormal-keep+ ] [ denormal-mode ] unit-test
 194 [ { } ] [ fp-traps ] unit-test
 195
 196 [ ] [
 197     all-fp-exceptions [ compact-gc ] with-fp-traps
 198 ] unit-test
 199
 200 ! In case the tests screw up the FP env because of bugs in math.floats.env
 201 set-default-fp-env