random-tester changes

contrib/random-tester/random-tester.factor

@@ -1,4 +1,4 @@
-USING: kernel math math-internals sequences namespaces errors
+USING: kernel math math-internals memory sequences namespaces errors
 hashtables words  arrays parser compiler syntax io
 inspector prettyprint optimizer inference ;
 IN: random-tester
@@ -14,7 +14,7 @@ IN: random-tester
         1+ 1- >bignum >digit >fixnum abs absq arg 
         bitnot bits>double bits>float ceiling cis conjugate cos cosec cosech
         cosh cot coth denominator double>bits exp float>bits floor imaginary
-        log neg next-power-of-2 numerator quadrant real sec
+        log neg numerator quadrant real sec ! next-power-of-2
         sech sgn sin sinh sq sqrt tan tanh truncate 
     } ;
 
@@ -57,7 +57,7 @@ IN: random-tester
         1+ 1- >bignum >digit >fixnum abs absq arg 
         ceiling cis conjugate cos cosec cosech
         cosh cot coth double>bits exp float>bits floor imaginary
-        log neg next-power-of-2 quadrant real sec
+        log neg quadrant real sec ! next-power-of-2
         sech sgn sin sinh sq sqrt tan tanh truncate
     } ;
 
@@ -139,7 +139,7 @@ SYMBOL: second-arg
     [ last-quot set ] keep
     [ call ] keep
     call
-    ! 2dup swap unparse write " " write unparse print
+    ! 2dup swap unparse write " " write unparse print flush
     = [ last-quot get . "problem in runtime" throw ] unless ;
 
 : 1-runtime-check ( quot -- )
@@ -149,16 +149,16 @@ SYMBOL: second-arg
     [ last-quot set first-arg set ] 2keep
     [ call ] 2keep
     call
-    2dup swap unparse write " " write unparse print
+    2dup swap unparse write " " write unparse print flush
     = [ "problem in runtime" throw ] unless ;
 
 : 1-interpreted-vs-compiled-check ( x quot -- ) 
     #! Checks the runtime output vs the compiler output
     #! quot: ( x -- y )
-    2dup swap unparse write " " write .
+    2dup swap unparse write " " write . flush
     [ last-quot set first-arg set ] 2keep
     [ call ] 2keep compile-1
-    2dup swap unparse write " " write unparse print
+    2dup swap unparse write " " write unparse print flush
     = [ "problem in math1" throw ] unless ;
 
 : 2-interpreted-vs-compiled-check ( x y quot -- )
@@ -167,7 +167,7 @@ SYMBOL: second-arg
     .s flush
     [ last-quot set first-arg set second-arg set ] 3keep
     [ call ] 3keep compile-1
-    2dup swap unparse write " " write unparse print
+    2dup swap unparse write " " write unparse print flush
     = [ "problem in math2" throw ] unless ;
 
 : 0-interpreted-vs-compiled-check-catch ( quot -- )
@@ -276,8 +276,8 @@ SYMBOL: second-arg
     ] [ ] make 0-runtime-check ;
 
 : test-1-integer?-when
-    random-float [
+    random-integer [
-        \ dup , \ float? , 1-float>x nth-rand unit , \ when ,
+        \ dup , \ integer? , 1-integer>x nth-rand unit , \ when ,
     ] [ ] make 1-interpreted-vs-compiled-check ;
 
 : test-1-ratio?-when
@@ -295,6 +295,20 @@ SYMBOL: second-arg
         \ dup , \ complex? , 1-complex>x nth-rand unit , \ when ,
     ] [ ] make 1-interpreted-vs-compiled-check ;
 
+
+: many-word-test ( -- )
+    #! defines words a1000 down to a0, which does a trivial addition
+    "random-tester-scratchpad" vocabularies get remove-hash
+    "random-tester-scratchpad" [ ensure-vocab ] keep use+
+    "a0" "random-tester-scratchpad" create [ 1 1 + ] define-compound
+    100 [
+        [ 1+ "a" swap unparse append "random-tester-scratchpad" create ] keep
+        "a" swap unparse append [ parse ] catch [ 0 :res ] when define-compound
+    ] each ;
+
+: compile-loop ( -- )
+    10 [ many-word-test "a100" parse first compile ] times ;
+
 : random-test
     {
         test-1-integer>x
@@ -312,5 +326,6 @@ SYMBOL: second-arg
         test-1-ratio?-when
         test-1-float?-when
         test-1-complex?-when
+        full-gc
     } nth-rand execute ;
 

contrib/random-tester/random.factor

@@ -4,7 +4,7 @@ inference ;
 IN: random-tester
 
 ! Tweak me
-: max-length 7 ; inline
+: max-length 15 ; inline
 : max-value 1000000000 ; inline
 
 : 10% ( -- bool ) 10 random-int 8 > ;
@@ -30,11 +30,11 @@ IN: random-tester
 
 SYMBOL: special-integers
 [ { -1 0 1 } % most-negative-fixnum , most-positive-fixnum , first-bignum , ] 
-{ } make \ special-integers set
+{ } make \ special-integers set-global
 : special-integers ( -- seq ) \ special-integers get ;
 SYMBOL: special-floats
 [ { 0.0 -0.0 } % e , pi , 1./0. , -1./0. , 0./0. , epsilon , epsilon neg , ]
-{ } make \ special-floats set
+{ } make \ special-floats set-global
 : special-floats ( -- seq ) \ special-floats get ;
 SYMBOL: special-complexes
 [ 
@@ -43,7 +43,7 @@ SYMBOL: special-complexes
     0 pi rect> , 0 pi neg rect> , pi neg 0 rect> , pi pi rect> ,
     pi pi neg rect> , pi neg pi rect> , pi neg pi neg rect> ,
     e neg e neg rect> , e e rect> ,
-] { } make \ special-complexes set
+] { } make \ special-complexes set-global
 : special-complexes ( -- seq ) \ special-complexes get ;
 
 : random-fixnum ( -- fixnum )
@@ -52,12 +52,12 @@ SYMBOL: special-complexes
 : random-bignum ( -- bignum )
      400 random-bits first-bignum + coin-flip [ neg ] when ;
     
-: random-integer
+: random-integer ( -- n )
     coin-flip [
-            random-fixnum
+        random-fixnum
-        ] [
+    ] [
-            coin-flip [ random-bignum ] [ special-integers nth-rand ] if
+        coin-flip [ random-bignum ] [ special-integers nth-rand ] if
-        ] if ;
+    ] if ;
 
 : random-positive-integer ( -- int )
     random-integer dup 0 < [