Added some throw/catch action

diff --git a/contrib/random-tester/random-tester.factor b/contrib/random-tester/random-tester.factor
index b31cdc9acef828902ee8d96e485224e6c90235d1..90cac5b3752074ac6a88c91d9f7d92dfe0c85e41 100644 (file)
--- a/contrib/random-tester/random-tester.factor
+++ b/contrib/random-tester/random-tester.factor
@@ -19,6 +19,27 @@ IN: random-tester
     } ;
 ! TODO: take this out eventually
 : math-throw-1
+    {
+        recip log2
+        asec asech acot acoth acosec acosech acos acosh asin asinh atan atanh
+    } ;
+
+: integer>x-throw
+    {
+        recip log2
+        asec asech acot acoth acosec acosech acos acosh asin asinh atan atanh
+    } ;
+: ratio>x-throw
+    {
+        recip
+        asec asech acot acoth acosec acosech acos acosh asin asinh atan atanh
+    } ;
+: float>x-throw
+    {
+        recip
+        asec asech acot acoth acosec acosech acos acosh asin asinh atan atanh
+    } ;
+: complex>x-throw
     {
         recip
         asec asech acot acoth acosec acosech acos acosh asin asinh atan atanh
@@ -93,8 +114,6 @@ IN: random-tester
     } ;
 
 
-
-
 : math-2 ( -- seq )
     { * + - /f max min polar> bitand bitor bitxor align shift } ;
 : math-throw-2 ( -- seq ) { / /i ^ mod rem } ;
@@ -197,6 +216,37 @@ SYMBOL: last
     >r 100 200 300 400 r> compile-1 4array
     = [ "problem found! (compile-check*)" throw ] unless ;
 
+: interp-compile-check-catch ( quot -- )
+    dup .
+    [ last set ] keep
+    [ catch [ "caught: " write dup print-error ] when* ] keep 
+    [ compile-1 ] catch [ nip "caught: " write dup print-error ] when*
+    = [ "problem in math" throw ] unless ;
+
+
+
+: test-integer>x-throws ( -- )
+    [
+        random-integer , integer>x-throw nth-rand ,
+    ] [ ] make interp-compile-check-catch ;
+: test-ratio>x-throws ( -- )
+    [
+        random-ratio , ratio>x-throw nth-rand ,
+    ] [ ] make interp-compile-check-catch ;
+: test-float>x-throws ( -- )
+    [
+        random-float , float>x-throw nth-rand ,
+    ] [ ] make interp-compile-check-catch ;
+: test-complex>x-throws ( -- )
+    [
+        random-complex , complex>x-throw nth-rand ,
+    ] [ ] make interp-compile-check-catch ;
+
+: test-2integer>x-throws ( -- )
+    [
+        random-integer , random-integer , math-throw-2 nth-rand ,
+    ] [ ] make interp-compile-check-catch ;
+
 ! 1-arg tests
 : test-integer>x ( -- )
     random-integer integer>x nth-rand f cons cons interp-compile-check ;