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

   1 USING: kernel math math.floats.env math.floats.env.private
   2 math.functions math.libm literals sequences tools.test locals
   3 compiler.units kernel.private fry compiler.test math.private
   4 words system memory kernel.private ;
   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 { t } +fp-underflow+ [ 2.0 -100,000.0 ] [ fpow ] test-fp-exception unit-test
  35 { t } +fp-underflow+ [ 2.0 -100,000.0 ] [ fpow ] test-fp-exception-compiled unit-test
  36
  37 { t } +fp-invalid-operation+ [ 0.0 0.0 ] [ /f ] test-fp-exception-compiled unit-test
  38 { t } +fp-invalid-operation+ [ -1.0 ] [ fsqrt ] test-fp-exception-compiled unit-test
  39
  40 {
  41     0x3fd5,5555,5555,5555
  42     0x3fc9,9999,9999,999a
  43     0xbfc9,9999,9999,999a
  44     0xbfd5,5555,5555,5555
  45 } [
  46     +round-nearest+ [
  47          1.0 3.0 /f double>bits
  48          1.0 5.0 /f double>bits
  49         -1.0 5.0 /f double>bits
  50         -1.0 3.0 /f double>bits
  51     ] with-rounding-mode
  52 ] unit-test
  53
  54 {
  55     0x3fd5,5555,5555,5555
  56     0x3fc9,9999,9999,9999
  57     0xbfc9,9999,9999,999a
  58     0xbfd5,5555,5555,5556
  59 } [
  60     +round-down+ [
  61          1.0 3.0 /f double>bits
  62          1.0 5.0 /f double>bits
  63         -1.0 5.0 /f double>bits
  64         -1.0 3.0 /f double>bits
  65     ] with-rounding-mode
  66 ] unit-test
  67
  68 {
  69     0x3fd5,5555,5555,5556
  70     0x3fc9,9999,9999,999a
  71     0xbfc9,9999,9999,9999
  72     0xbfd5,5555,5555,5555
  73 } [
  74     +round-up+ [
  75          1.0 3.0 /f double>bits
  76          1.0 5.0 /f double>bits
  77         -1.0 5.0 /f double>bits
  78         -1.0 3.0 /f double>bits
  79     ] with-rounding-mode
  80 ] unit-test
  81
  82 {
  83     0x3fd5,5555,5555,5555
  84     0x3fc9,9999,9999,9999
  85     0xbfc9,9999,9999,9999
  86     0xbfd5,5555,5555,5555
  87 } [
  88     +round-zero+ [
  89          1.0 3.0 /f double>bits
  90          1.0 5.0 /f double>bits
  91         -1.0 5.0 /f double>bits
  92         -1.0 3.0 /f double>bits
  93     ] with-rounding-mode
  94 ] unit-test
  95
  96 ! ensure rounding mode is restored to +round-nearest+
  97 {
  98     0x3fd5,5555,5555,5555
  99     0x3fc9,9999,9999,999a
 100     0xbfc9,9999,9999,999a
 101     0xbfd5,5555,5555,5555
 102 } [
 103      1.0 3.0 /f double>bits
 104      1.0 5.0 /f double>bits
 105     -1.0 5.0 /f double>bits
 106     -1.0 3.0 /f double>bits
 107 ] unit-test
 108
 109 : fp-trap-error? ( error -- ? )
 110     2 head ${ KERNEL-ERROR ERROR-FP-TRAP } = ;
 111
 112 : test-traps ( traps inputs quot -- quot' fail-quot )
 113     append '[ _ _ with-fp-traps ] [ fp-trap-error? ] ;
 114
 115 : test-traps-compiled ( traps inputs quot -- quot' fail-quot )
 116     swapd '[ @ [ _ _ with-fp-traps ] compile-call ] [ fp-trap-error? ] ;
 117
 118 { +fp-zero-divide+ } [ 1.0 0.0 ] [ /f ] test-traps must-fail-with
 119 { +fp-inexact+ } [ 1.0 3.0 ] [ /f ] test-traps must-fail-with
 120 { +fp-invalid-operation+ } [ -1.0 ] [ fsqrt ] test-traps must-fail-with
 121 { +fp-overflow+ } [ 2.0 ] [ 100,000.0 ^ ] test-traps must-fail-with
 122 { +fp-underflow+ +fp-inexact+ } [ 2.0 ] [ -100,000.0 ^ ] test-traps must-fail-with
 123
 124 { +fp-zero-divide+ } [ 1.0 0.0 ] [ /f ] test-traps-compiled must-fail-with
 125 { +fp-inexact+ } [ 1.0 3.0 ] [ /f ] test-traps-compiled must-fail-with
 126 { +fp-invalid-operation+ } [ -1.0 ] [ fsqrt ] test-traps-compiled must-fail-with
 127 { +fp-overflow+ } [ 2.0 ] [ 100,000.0 ^ ] test-traps-compiled must-fail-with
 128 { +fp-underflow+ +fp-inexact+ } [ 2.0 ] [ -100,000.0 ^ ] test-traps-compiled must-fail-with
 129
 130 ! Ensure ordered comparisons raise traps
 131 :: test-comparison-quot ( word -- quot )
 132     [
 133         { float float } declare
 134         { +fp-invalid-operation+ } [ word execute ] with-fp-traps
 135     ] ;
 136
 137 : test-comparison ( inputs word -- quot fail-quot )
 138     test-comparison-quot append [ fp-trap-error? ] ;
 139
 140 : test-comparison-compiled ( inputs word -- quot fail-quot )
 141     test-comparison-quot '[ @ _ compile-call ] [ fp-trap-error? ] ;
 142
 143 \ float< "intrinsic" word-prop [
 144     [ 0/0. -15.0 ] \ < test-comparison must-fail-with
 145     [ 0/0. -15.0 ] \ < test-comparison-compiled must-fail-with
 146     [ -15.0 0/0. ] \ < test-comparison must-fail-with
 147     [ -15.0 0/0. ] \ < test-comparison-compiled must-fail-with
 148     [ 0/0. -15.0 ] \ <= test-comparison must-fail-with
 149     [ 0/0. -15.0 ] \ <= test-comparison-compiled must-fail-with
 150     [ -15.0 0/0. ] \ <= test-comparison must-fail-with
 151     [ -15.0 0/0. ] \ <= test-comparison-compiled must-fail-with
 152     [ 0/0. -15.0 ] \ > test-comparison must-fail-with
 153     [ 0/0. -15.0 ] \ > test-comparison-compiled must-fail-with
 154     [ -15.0 0/0. ] \ > test-comparison must-fail-with
 155     [ -15.0 0/0. ] \ > test-comparison-compiled must-fail-with
 156     [ 0/0. -15.0 ] \ >= test-comparison must-fail-with
 157     [ 0/0. -15.0 ] \ >= test-comparison-compiled must-fail-with
 158     [ -15.0 0/0. ] \ >= test-comparison must-fail-with
 159     [ -15.0 0/0. ] \ >= test-comparison-compiled must-fail-with
 160
 161     [ f ] [ 0/0. -15.0 ] \ u< test-comparison drop unit-test
 162     [ f ] [ 0/0. -15.0 ] \ u< test-comparison-compiled drop unit-test
 163     [ f ] [ -15.0 0/0. ] \ u< test-comparison drop unit-test
 164     [ f ] [ -15.0 0/0. ] \ u< test-comparison-compiled drop unit-test
 165     [ f ] [ 0/0. -15.0 ] \ u<= test-comparison drop unit-test
 166     [ f ] [ 0/0. -15.0 ] \ u<= test-comparison-compiled drop unit-test
 167     [ f ] [ -15.0 0/0. ] \ u<= test-comparison drop unit-test
 168     [ f ] [ -15.0 0/0. ] \ u<= test-comparison-compiled drop unit-test
 169     [ f ] [ 0/0. -15.0 ] \ u> test-comparison drop unit-test
 170     [ f ] [ 0/0. -15.0 ] \ u> test-comparison-compiled drop unit-test
 171     [ f ] [ -15.0 0/0. ] \ u> test-comparison drop unit-test
 172     [ f ] [ -15.0 0/0. ] \ u> test-comparison-compiled drop unit-test
 173     [ f ] [ 0/0. -15.0 ] \ u>= test-comparison drop unit-test
 174     [ f ] [ 0/0. -15.0 ] \ u>= test-comparison-compiled drop unit-test
 175     [ f ] [ -15.0 0/0. ] \ u>= test-comparison drop unit-test
 176     [ f ] [ -15.0 0/0. ] \ u>= test-comparison-compiled drop unit-test
 177 ] when
 178
 179 ! Ensure traps get cleared
 180 { 1/0. } [ 1.0 0.0 /f ] unit-test
 181
 182 ! Ensure state is back to normal
 183 { +round-nearest+ } [ rounding-mode ] unit-test
 184 { +denormal-keep+ } [ denormal-mode ] unit-test
 185 { { } } [ fp-traps ] unit-test
 186
 187 { } [
 188     all-fp-exceptions [ compact-gc ] with-fp-traps
 189 ] unit-test
 190
 191 ! In case the tests screw up the FP env because of bugs in math.floats.env
 192 set-default-fp-env