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

add some unit tests for try-find

release
Doug Coleman 2010-01-28 23:12:31 -06:00
parent 4edc37b70c
commit 88e20af800
1 changed files with 120 additions and 108 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

228
core/continuations/continuations-tests.factor
View File

@ -1,108 +1,120 @@
USING: kernel math namespaces io tools.test sequences vectors USING: kernel math namespaces io tools.test sequences vectors
continuations debugger parser memory arrays words continuations debugger parser memory arrays words
kernel.private accessors eval ; kernel.private accessors eval ;
IN: continuations.tests IN: continuations.tests
: (callcc1-test) ( n obj -- n' obj ) : (callcc1-test) ( n obj -- n' obj )
[ 1 - dup ] dip ?push [ 1 - dup ] dip ?push
over 0 = [ "test-cc" get continue-with ] when over 0 = [ "test-cc" get continue-with ] when
(callcc1-test) ; (callcc1-test) ;
: callcc1-test ( x -- list ) : callcc1-test ( x -- list )
[ [
"test-cc" set V{ } clone (callcc1-test) "test-cc" set V{ } clone (callcc1-test)
] callcc1 nip ; ] callcc1 nip ;
: callcc-namespace-test ( -- ? ) : callcc-namespace-test ( -- ? )
[ [
"test-cc" set "test-cc" set
5 "x" set 5 "x" set
[ [
6 "x" set "test-cc" get continue 6 "x" set "test-cc" get continue
] with-scope ] with-scope
] callcc0 "x" get 5 = ; ] callcc0 "x" get 5 = ;
[ t ] [ 10 callcc1-test 10 iota reverse >vector = ] unit-test [ t ] [ 10 callcc1-test 10 iota reverse >vector = ] unit-test
[ t ] [ callcc-namespace-test ] unit-test [ t ] [ callcc-namespace-test ] unit-test
[ 5 throw ] [ 5 = ] must-fail-with [ 5 throw ] [ 5 = ] must-fail-with
[ t ] [ [ t ] [
[ "Hello" throw ] ignore-errors [ "Hello" throw ] ignore-errors
error get-global error get-global
"Hello" = "Hello" =
] unit-test ] unit-test
"!!! The following error is part of the test" print "!!! The following error is part of the test" print
[ ] [ [ 6 [ 12 [ "2 car" ] ] ] print-error ] unit-test [ ] [ [ 6 [ 12 [ "2 car" ] ] ] print-error ] unit-test
"!!! The following error is part of the test" print "!!! The following error is part of the test" print
[ ] [ [ [ "2 car" ] eval ] try ] unit-test [ ] [ [ [ "2 car" ] eval ] try ] unit-test
[ f throw ] must-fail [ f throw ] must-fail
! Weird PowerPC bug. ! Weird PowerPC bug.
[ ] [ [ ] [
[ "4" throw ] ignore-errors [ "4" throw ] ignore-errors
gc gc
gc gc
] unit-test ] unit-test
! ! See how well callstack overflow is handled ! ! See how well callstack overflow is handled
! [ clear drop ] must-fail ! [ clear drop ] must-fail
! !
! : callstack-overflow callstack-overflow f ; ! : callstack-overflow callstack-overflow f ;
! [ callstack-overflow ] must-fail ! [ callstack-overflow ] must-fail
: don't-compile-me ( -- ) ; : don't-compile-me ( -- ) ;
: foo ( -- ) callstack "c" set don't-compile-me ; : foo ( -- ) callstack "c" set don't-compile-me ;
: bar ( -- a b ) 1 foo 2 ; : bar ( -- a b ) 1 foo 2 ;
<< { don't-compile-me foo bar } [ t "no-compile" set-word-prop ] each >> << { don't-compile-me foo bar } [ t "no-compile" set-word-prop ] each >>
[ 1 2 ] [ bar ] unit-test [ 1 2 ] [ bar ] unit-test
[ t ] [ \ bar def>> "c" get innermost-frame-executing = ] unit-test [ t ] [ \ bar def>> "c" get innermost-frame-executing = ] unit-test
[ 1 ] [ "c" get innermost-frame-scan ] unit-test [ 1 ] [ "c" get innermost-frame-scan ] unit-test
SYMBOL: always-counter SYMBOL: always-counter
SYMBOL: error-counter SYMBOL: error-counter
[ [
0 always-counter set 0 always-counter set
0 error-counter set 0 error-counter set
[ ] [ always-counter inc ] [ error-counter inc ] cleanup [ ] [ always-counter inc ] [ error-counter inc ] cleanup
[ 1 ] [ always-counter get ] unit-test [ 1 ] [ always-counter get ] unit-test
[ 0 ] [ error-counter get ] unit-test [ 0 ] [ error-counter get ] unit-test
[ [
[ "a" throw ] [ "a" throw ]
[ always-counter inc ] [ always-counter inc ]
[ error-counter inc ] cleanup [ error-counter inc ] cleanup
] [ "a" = ] must-fail-with ] [ "a" = ] must-fail-with
[ 2 ] [ always-counter get ] unit-test [ 2 ] [ always-counter get ] unit-test
[ 1 ] [ error-counter get ] unit-test [ 1 ] [ error-counter get ] unit-test
[ [
[ ] [ ]
[ always-counter inc "a" throw ] [ always-counter inc "a" throw ]
[ error-counter inc ] cleanup [ error-counter inc ] cleanup
] [ "a" = ] must-fail-with ] [ "a" = ] must-fail-with
[ 3 ] [ always-counter get ] unit-test [ 3 ] [ always-counter get ] unit-test
[ 1 ] [ error-counter get ] unit-test [ 1 ] [ error-counter get ] unit-test
] with-scope ] with-scope
[ ] [ [ return ] with-return ] unit-test [ ] [ [ return ] with-return ] unit-test
[ { } [ ] attempt-all ] [ attempt-all-error? ] must-fail-with [ { } [ ] attempt-all ] [ attempt-all-error? ] must-fail-with
[ { 4 } ] [ { 2 2 } [ + ] with-datastack ] unit-test [ { 4 } ] [ { 2 2 } [ + ] with-datastack ] unit-test
[ with-datastack ] must-infer [ with-datastack ] must-infer
[ { t 1 } ]
[ { 1 1 } [ odd? ] try-find 2array ] unit-test
[ { 9 3 } ]
[ { 3 3 } [ sq ] try-find 2array ] unit-test
[ { f f } ]
[ { 1 1 } [ even? ] try-find 2array ] unit-test
[ { f f } ]
[ { 1 1 } [ "error" throw ] try-find 2array ] unit-test