steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Some cleanups and more tests

cvs
Doug Coleman 2006-01-28 21:02:54 +00:00
parent 8569427c4e
commit 586dd2a8a7
2 changed files with 92 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

122
contrib/random-tester/random-tester.factor
View File

@ -182,8 +182,24 @@ IN: random-tester
SYMBOL: last-quot SYMBOL: last-quot
: interp-compile-check ( quot -- ) SYMBOL: first-arg
: runtime-check
[ last-quot set ] keep
[ call ] keep
call
! 2dup swap unparse write " " write unparse print
= [ last-quot get . "problem in runtime" throw ] unless ;
: runtime-check-1
[ last-quot set first-arg set ] 2keep
[ call ] 2keep
call
2dup swap unparse write " " write unparse print
= [ "problem in runtime" throw ] unless ;
: interp-runtime-check ( quot -- )
dup . dup .
! 0 [ tan tan ] compile-1 drop
[ last-quot set ] keep [ last-quot set ] keep
[ call ] keep compile-1 [ call ] keep compile-1
2dup swap unparse write " " write unparse print 2dup swap unparse write " " write unparse print
@ -191,12 +207,18 @@ SYMBOL: last-quot
: interp-compile-check-1 ( x quot -- ) : interp-compile-check-1 ( x quot -- )
.s flush .s flush
! dup . flush
[ last-quot set ] keep [ last-quot set ] keep
[ call ] 2keep compile-1 [ call ] 2keep compile-1
2dup swap unparse write " " write unparse print 2dup swap unparse write " " write unparse print
= [ "problem in math" throw ] unless ; = [ "problem in math" throw ] unless ;
: interp-compile-check-2 ( x quot -- )
.s flush
[ last-quot set ] keep
[ call ] 3keep compile-1
2dup swap unparse write " " write unparse print
= [ "problem in math" throw ] unless ;
: interp-compile-check* ( quot -- ) : interp-compile-check* ( quot -- )
dup . dup .
>r 100 200 300 400 r> [ call 4array ] keep >r 100 200 300 400 r> [ call 4array ] keep
@ -235,11 +257,13 @@ SYMBOL: last-quot
: random-float>x-quot ( -- ) random-float float>x nth-rand unit cons ; : random-float>x-quot ( -- ) random-float float>x nth-rand unit cons ;
: random-complex>x-quot ( -- ) random-complex complex>x nth-rand unit cons ; : random-complex>x-quot ( -- ) random-complex complex>x nth-rand unit cons ;
: test-integer>x ( -- ) random-integer>x-quot interp-compile-check ; : test-integer>x ( -- ) random-integer>x-quot interp-runtime-check ;
: test-ratio>x ( -- ) random-ratio>x-quot interp-compile-check ; : test-ratio>x ( -- ) random-ratio>x-quot interp-runtime-check ;
: test-float>x ( -- ) random-float>x-quot interp-compile-check ; : test-float>x ( -- ) random-float>x-quot interp-runtime-check ;
: test-complex>x ( -- ) random-complex>x-quot interp-compile-check ; : test-complex>x ( -- ) random-complex>x-quot interp-runtime-check ;
: test-integer>x-runtime ( -- ) random-integer>x-quot runtime-check ;
: test-integer>x-1-runtime ( -- ) random-integer>x-quot runtime-check ;
: test-integer>x-1 ( -- ) : test-integer>x-1 ( -- )
random-integer integer>x nth-rand unit interp-compile-check-1 ; random-integer integer>x nth-rand unit interp-compile-check-1 ;
@ -256,27 +280,43 @@ SYMBOL: last-quot
random-ratio ratio>x-throw nth-rand unit cons interp-compile-check-catch ; random-ratio ratio>x-throw nth-rand unit cons interp-compile-check-catch ;
: test-update-xt ( -- ) : test-update-xt ( -- )
random-integer random-integer 2integer>x nth-rand f cons cons cons update-xt-check ; random-integer random-integer 2integer>x nth-rand unit swons swons update-xt-check ;
! 2-arg tests ! 2-arg tests
: test-2integer>x ( -- ) : test-2integer>x ( -- )
random-integer random-integer 2integer>x nth-rand f cons cons cons interp-compile-check ; random-integer random-integer 2integer>x nth-rand unit swons swons interp-runtime-check ;
: test-2ratio>x ( -- ) : test-2ratio>x ( -- )
random-ratio random-ratio 2ratio>x nth-rand f cons cons cons interp-compile-check ; random-ratio random-ratio 2ratio>x nth-rand unit swons swons interp-runtime-check ;
: test-2float>x ( -- ) : test-2float>x ( -- )
random-float random-float 2float>x nth-rand f cons cons cons interp-compile-check ; random-float random-float 2float>x nth-rand unit swons swons interp-runtime-check ;
: test-2complex>x ( -- ) : test-2complex>x ( -- )
random-complex random-complex 2complex>x nth-rand f cons cons cons interp-compile-check ; random-complex random-complex 2complex>x nth-rand unit swons swons interp-runtime-check ;
: test-2random>x ( -- ) : test-2random>x ( -- )
random-number random-number math-2 nth-rand f cons cons cons interp-compile-check ; random-number random-number math-2 nth-rand unit swons swons interp-runtime-check ;
: test-2integer>x-2 ( -- )
random-integer random-integer 2integer>x nth-rand unit interp-compile-check-2 ;
: test-2ratio>x-2 ( -- )
random-ratio random-ratio 2ratio>x nth-rand unit interp-compile-check-2 ;
: test-2float>x-2 ( -- )
random-float random-float 2float>x nth-rand unit interp-compile-check-2 ;
: test-2complex>x-2 ( -- )
random-complex random-complex 2complex>x nth-rand unit interp-compile-check-2 ;
! : test-2integer>x-1 ( -- )
! random-integer random-integer-quotation-1 interp-compile-check-1 ;
: test-2integer>x-1 ( -- )
random-integer random-integer-quotation-1 interp-compile-check-1 ;
: test-2integer>x-throws ( -- ) : test-2integer>x-throws ( -- )
[ [
@ -301,10 +341,12 @@ SYMBOL: last-quot
! test-ratio>x ! test-ratio>x
! test-float>x ! test-float>x
! test-complex>x ! test-complex>x
test-integer>x-1
test-ratio>x-1 ! test-integer>x-1
test-float>x-1 ! test-ratio>x-1
test-complex>x-1 ! test-float>x-1
! test-complex>x-1
! test-integer>x-throws ! test-integer>x-throws
! test-ratio>x-throws ! test-ratio>x-throws
@ -313,7 +355,11 @@ SYMBOL: last-quot
! test-2ratio>x ! test-2ratio>x
! test-2float>x ! test-2float>x
! test-2complex>x ! test-2complex>x
test-2integer>x-1 test-2integer>x-2
test-2ratio>x-2
test-2float>x-2
test-2complex>x-2
! ! test-2integer>x-1
! test-2integer>x-throws ! test-2integer>x-throws
! test-^-shift ! test-^-shift
! test-^-ratio ! test-^-ratio
@ -335,48 +381,48 @@ SYMBOL: last-quot
: logic-3 ( -- seq ) { between? } ; : logic-3 ( -- seq ) { between? } ;
: complex-logic-2 ( -- seq ) { number= = eq? and or } ; : complex-logic-2 ( -- seq ) { number= = eq? and or } ;
: logic-0-test ( -- ) logic-0 nth-rand unit interp-compile-check ; : logic-0-test ( -- ) logic-0 nth-rand unit interp-runtime-check ;
: integer-logic-1-test ( -- ) : integer-logic-1-test ( -- )
[ [
random-integer , logic-1 nth-rand , random-integer , logic-1 nth-rand ,
] [ ] make interp-compile-check ; ] [ ] make interp-runtime-check ;
: ratio-logic-1-test ( -- ) : ratio-logic-1-test ( -- )
[ [
random-ratio , logic-1 nth-rand , random-ratio , logic-1 nth-rand ,
] [ ] make interp-compile-check ; ] [ ] make interp-runtime-check ;
: float-logic-1-test ( -- ) : float-logic-1-test ( -- )
[ [
random-float , logic-1 nth-rand , random-float , logic-1 nth-rand ,
] [ ] make interp-compile-check ; ] [ ] make interp-runtime-check ;
: complex-logic-1-test ( -- ) : complex-logic-1-test ( -- )
[ [
random-complex , logic-1 nth-rand , random-complex , logic-1 nth-rand ,
] [ ] make interp-compile-check ; ] [ ] make interp-runtime-check ;
: integer-logic-2-test ( -- ) : integer-logic-2-test ( -- )
[ [
random-integer , random-integer , logic-2 nth-rand , random-integer , random-integer , logic-2 nth-rand ,
] [ ] make interp-compile-check ; ] [ ] make interp-runtime-check ;
: ratio-logic-2-test ( -- ) : ratio-logic-2-test ( -- )
[ [
random-ratio , random-ratio , logic-2 nth-rand , random-ratio , random-ratio , logic-2 nth-rand ,
] [ ] make interp-compile-check ; ] [ ] make interp-runtime-check ;
: float-logic-2-test ( -- ) : float-logic-2-test ( -- )
[ [
random-float , random-float , logic-2 nth-rand , random-float , random-float , logic-2 nth-rand ,
] [ ] make interp-compile-check ; ] [ ] make interp-runtime-check ;
: complex-logic-2-test ( -- ) : complex-logic-2-test ( -- )
[ [
random-complex , random-complex , complex-logic-2 nth-rand , random-complex , random-complex , complex-logic-2 nth-rand ,
] [ ] make interp-compile-check ; ] [ ] make interp-runtime-check ;
: string-to-math-test ( -- ) : string-to-math-test ( -- )
@ -385,19 +431,33 @@ SYMBOL: last-quot
[ random-integer , \ number>string , ] [ random-integer , \ number>string , ]
[ random-integer , \ number>string , \ string>number , ] [ random-integer , \ number>string , \ string>number , ]
} do-one } do-one
] [ ] make interp-compile-check ; ] [ ] make interp-runtime-check ;
: test-float?-when : test-float?-when
[ [
random-number , \ dup , \ float? , float>x nth-rand unit , \ when , random-number , \ dup , \ float? , float>x nth-rand unit , \ when ,
] [ ] make interp-compile-check ; ] [ ] make interp-runtime-check ;
: test-integer?-when-1
random-float [
\ dup , \ float? , float>x nth-rand unit , \ when ,
] [ ] make interp-compile-check-1 ;
: test-ratio?-when-1
random-ratio [
\ dup , \ ratio? , ratio>x nth-rand unit , \ when ,
] [ ] make interp-compile-check-1 ;
: test-float?-when-1 : test-float?-when-1
random-float [ random-float [
\ dup , \ float? , float>x nth-rand unit , \ when , \ dup , \ float? , float>x nth-rand unit , \ when ,
] [ ] make interp-compile-check-1 ; ] [ ] make interp-compile-check-1 ;
: test-complex?-when-1
random-complex [
\ dup , \ complex? , complex>x nth-rand unit , \ when ,
] [ ] make interp-compile-check-1 ;
: stack-identity-0 : stack-identity-0
H{ H{
@ -481,7 +541,7 @@ SYMBOL: last-quot
! when-quot % ! when-quot %
] [ ] make ; ] [ ] make ;
: test-if ( -- ) nested-ifs interp-compile-check ; : test-if ( -- ) nested-ifs interp-runtime-check ;
: random-test ( -- ) : random-test ( -- )
{ {

2
contrib/random-tester/random.factor
View File

@ -34,7 +34,7 @@ SYMBOL: special-integers
{ } make \ special-integers set { } make \ special-integers set
: special-integers ( -- seq ) \ special-integers get ; : special-integers ( -- seq ) \ special-integers get ;
SYMBOL: special-floats SYMBOL: special-floats
[ { 0.0 } % e , pi , 1./0. , -1./0. , 0./0. , epsilon , epsilon neg , ] [ { 0.0 -0.0 } % e , pi , 1./0. , -1./0. , 0./0. , epsilon , epsilon neg , ]
{ } make \ special-floats set { } make \ special-floats set
: special-floats ( -- seq ) \ special-floats get ; : special-floats ( -- seq ) \ special-floats get ;
SYMBOL: special-complexes SYMBOL: special-complexes