From d85cf7b9ba635f7b9f3aff7dffccb93e2d3da634 Mon Sep 17 00:00:00 2001 From: erg Date: Mon, 24 Jul 2006 16:23:00 +0000 Subject: [PATCH] random-tester changes --- contrib/random-tester/random-tester.factor | 35 +++++++++++++++------- contrib/random-tester/random.factor | 18 +++++------ 2 files changed, 34 insertions(+), 19 deletions(-) diff --git a/contrib/random-tester/random-tester.factor b/contrib/random-tester/random-tester.factor index 333dedb766..240d4db9b7 100644 --- a/contrib/random-tester/random-tester.factor +++ b/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 [ - \ dup , \ float? , 1-float>x nth-rand unit , \ when , + random-integer [ + \ 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 ; diff --git a/contrib/random-tester/random.factor b/contrib/random-tester/random.factor index 91355ce0e7..1ae7259994 100644 --- a/contrib/random-tester/random.factor +++ b/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 - ] [ - coin-flip [ random-bignum ] [ special-integers nth-rand ] if - ] if ; + random-fixnum + ] [ + coin-flip [ random-bignum ] [ special-integers nth-rand ] if + ] if ; : random-positive-integer ( -- int ) random-integer dup 0 < [