-! FP traps cause a kernel panic on OpenBSD 4.5 i386
-os openbsd eq? cpu x86.32 eq? and [
-
- : fp-trap-error? ( error -- ? )
- 2 head { "kernel-error" 17 } = ;
-
- : test-traps ( traps inputs quot -- quot' fail-quot )
- append '[ _ _ with-fp-traps ] [ fp-trap-error? ] ;
-
- : test-traps-compiled ( traps inputs quot -- quot' fail-quot )
- swapd '[ @ [ _ _ with-fp-traps ] compile-call ] [ fp-trap-error? ] ;
-
- { +fp-zero-divide+ } [ 1.0 0.0 ] [ /f ] test-traps must-fail-with
- { +fp-inexact+ } [ 1.0 3.0 ] [ /f ] test-traps must-fail-with
- { +fp-invalid-operation+ } [ -1.0 ] [ fsqrt ] test-traps must-fail-with
- { +fp-overflow+ } [ 2.0 ] [ 100,000.0 ^ ] test-traps must-fail-with
- { +fp-underflow+ +fp-inexact+ } [ 2.0 ] [ -100,000.0 ^ ] test-traps must-fail-with
-
- { +fp-zero-divide+ } [ 1.0 0.0 ] [ /f ] test-traps-compiled must-fail-with
- { +fp-inexact+ } [ 1.0 3.0 ] [ /f ] test-traps-compiled must-fail-with
- { +fp-invalid-operation+ } [ -1.0 ] [ fsqrt ] test-traps-compiled must-fail-with
- { +fp-overflow+ } [ 2.0 ] [ 100,000.0 ^ ] test-traps-compiled must-fail-with
- { +fp-underflow+ +fp-inexact+ } [ 2.0 ] [ -100,000.0 ^ ] test-traps-compiled must-fail-with
-
- ! Ensure ordered comparisons raise traps
- :: test-comparison-quot ( word -- quot )
- [
- { float float } declare
- { +fp-invalid-operation+ } [ word execute ] with-fp-traps
- ] ;
-
- : test-comparison ( inputs word -- quot fail-quot )
- test-comparison-quot append [ fp-trap-error? ] ;
-
- : test-comparison-compiled ( inputs word -- quot fail-quot )
- test-comparison-quot '[ @ _ compile-call ] [ fp-trap-error? ] ;
-
- \ float< "intrinsic" word-prop [
- [ 0/0. -15.0 ] \ < test-comparison must-fail-with
- [ 0/0. -15.0 ] \ < test-comparison-compiled must-fail-with
- [ -15.0 0/0. ] \ < test-comparison must-fail-with
- [ -15.0 0/0. ] \ < test-comparison-compiled must-fail-with
- [ 0/0. -15.0 ] \ <= test-comparison must-fail-with
- [ 0/0. -15.0 ] \ <= test-comparison-compiled must-fail-with
- [ -15.0 0/0. ] \ <= test-comparison must-fail-with
- [ -15.0 0/0. ] \ <= test-comparison-compiled must-fail-with
- [ 0/0. -15.0 ] \ > test-comparison must-fail-with
- [ 0/0. -15.0 ] \ > test-comparison-compiled must-fail-with
- [ -15.0 0/0. ] \ > test-comparison must-fail-with
- [ -15.0 0/0. ] \ > test-comparison-compiled must-fail-with
- [ 0/0. -15.0 ] \ >= test-comparison must-fail-with
- [ 0/0. -15.0 ] \ >= test-comparison-compiled must-fail-with
- [ -15.0 0/0. ] \ >= test-comparison must-fail-with
- [ -15.0 0/0. ] \ >= test-comparison-compiled must-fail-with
-
- [ f ] [ 0/0. -15.0 ] \ u< test-comparison drop unit-test
- [ f ] [ 0/0. -15.0 ] \ u< test-comparison-compiled drop unit-test
- [ f ] [ -15.0 0/0. ] \ u< test-comparison drop unit-test
- [ f ] [ -15.0 0/0. ] \ u< test-comparison-compiled drop unit-test
- [ f ] [ 0/0. -15.0 ] \ u<= test-comparison drop unit-test
- [ f ] [ 0/0. -15.0 ] \ u<= test-comparison-compiled drop unit-test
- [ f ] [ -15.0 0/0. ] \ u<= test-comparison drop unit-test
- [ f ] [ -15.0 0/0. ] \ u<= test-comparison-compiled drop unit-test
- [ f ] [ 0/0. -15.0 ] \ u> test-comparison drop unit-test
- [ f ] [ 0/0. -15.0 ] \ u> test-comparison-compiled drop unit-test
- [ f ] [ -15.0 0/0. ] \ u> test-comparison drop unit-test
- [ f ] [ -15.0 0/0. ] \ u> test-comparison-compiled drop unit-test
- [ f ] [ 0/0. -15.0 ] \ u>= test-comparison drop unit-test
- [ f ] [ 0/0. -15.0 ] \ u>= test-comparison-compiled drop unit-test
- [ f ] [ -15.0 0/0. ] \ u>= test-comparison drop unit-test
- [ f ] [ -15.0 0/0. ] \ u>= test-comparison-compiled drop unit-test
- ] when
-
-] unless
+: fp-trap-error? ( error -- ? )
+ 2 head { "kernel-error" 17 } = ;
+
+: test-traps ( traps inputs quot -- quot' fail-quot )
+ append '[ _ _ with-fp-traps ] [ fp-trap-error? ] ;
+
+: test-traps-compiled ( traps inputs quot -- quot' fail-quot )
+ swapd '[ @ [ _ _ with-fp-traps ] compile-call ] [ fp-trap-error? ] ;
+
+{ +fp-zero-divide+ } [ 1.0 0.0 ] [ /f ] test-traps must-fail-with
+{ +fp-inexact+ } [ 1.0 3.0 ] [ /f ] test-traps must-fail-with
+{ +fp-invalid-operation+ } [ -1.0 ] [ fsqrt ] test-traps must-fail-with
+{ +fp-overflow+ } [ 2.0 ] [ 100,000.0 ^ ] test-traps must-fail-with
+{ +fp-underflow+ +fp-inexact+ } [ 2.0 ] [ -100,000.0 ^ ] test-traps must-fail-with
+
+{ +fp-zero-divide+ } [ 1.0 0.0 ] [ /f ] test-traps-compiled must-fail-with
+{ +fp-inexact+ } [ 1.0 3.0 ] [ /f ] test-traps-compiled must-fail-with
+{ +fp-invalid-operation+ } [ -1.0 ] [ fsqrt ] test-traps-compiled must-fail-with
+{ +fp-overflow+ } [ 2.0 ] [ 100,000.0 ^ ] test-traps-compiled must-fail-with
+{ +fp-underflow+ +fp-inexact+ } [ 2.0 ] [ -100,000.0 ^ ] test-traps-compiled must-fail-with
+
+! Ensure ordered comparisons raise traps
+:: test-comparison-quot ( word -- quot )
+ [
+ { float float } declare
+ { +fp-invalid-operation+ } [ word execute ] with-fp-traps
+ ] ;
+
+: test-comparison ( inputs word -- quot fail-quot )
+ test-comparison-quot append [ fp-trap-error? ] ;
+
+: test-comparison-compiled ( inputs word -- quot fail-quot )
+ test-comparison-quot '[ @ _ compile-call ] [ fp-trap-error? ] ;
+
+\ float< "intrinsic" word-prop [
+ [ 0/0. -15.0 ] \ < test-comparison must-fail-with
+ [ 0/0. -15.0 ] \ < test-comparison-compiled must-fail-with
+ [ -15.0 0/0. ] \ < test-comparison must-fail-with
+ [ -15.0 0/0. ] \ < test-comparison-compiled must-fail-with
+ [ 0/0. -15.0 ] \ <= test-comparison must-fail-with
+ [ 0/0. -15.0 ] \ <= test-comparison-compiled must-fail-with
+ [ -15.0 0/0. ] \ <= test-comparison must-fail-with
+ [ -15.0 0/0. ] \ <= test-comparison-compiled must-fail-with
+ [ 0/0. -15.0 ] \ > test-comparison must-fail-with
+ [ 0/0. -15.0 ] \ > test-comparison-compiled must-fail-with
+ [ -15.0 0/0. ] \ > test-comparison must-fail-with
+ [ -15.0 0/0. ] \ > test-comparison-compiled must-fail-with
+ [ 0/0. -15.0 ] \ >= test-comparison must-fail-with
+ [ 0/0. -15.0 ] \ >= test-comparison-compiled must-fail-with
+ [ -15.0 0/0. ] \ >= test-comparison must-fail-with
+ [ -15.0 0/0. ] \ >= test-comparison-compiled must-fail-with
+
+ [ f ] [ 0/0. -15.0 ] \ u< test-comparison drop unit-test
+ [ f ] [ 0/0. -15.0 ] \ u< test-comparison-compiled drop unit-test
+ [ f ] [ -15.0 0/0. ] \ u< test-comparison drop unit-test
+ [ f ] [ -15.0 0/0. ] \ u< test-comparison-compiled drop unit-test
+ [ f ] [ 0/0. -15.0 ] \ u<= test-comparison drop unit-test
+ [ f ] [ 0/0. -15.0 ] \ u<= test-comparison-compiled drop unit-test
+ [ f ] [ -15.0 0/0. ] \ u<= test-comparison drop unit-test
+ [ f ] [ -15.0 0/0. ] \ u<= test-comparison-compiled drop unit-test
+ [ f ] [ 0/0. -15.0 ] \ u> test-comparison drop unit-test
+ [ f ] [ 0/0. -15.0 ] \ u> test-comparison-compiled drop unit-test
+ [ f ] [ -15.0 0/0. ] \ u> test-comparison drop unit-test
+ [ f ] [ -15.0 0/0. ] \ u> test-comparison-compiled drop unit-test
+ [ f ] [ 0/0. -15.0 ] \ u>= test-comparison drop unit-test
+ [ f ] [ 0/0. -15.0 ] \ u>= test-comparison-compiled drop unit-test
+ [ f ] [ -15.0 0/0. ] \ u>= test-comparison drop unit-test
+ [ f ] [ -15.0 0/0. ] \ u>= test-comparison-compiled drop unit-test
+] when