2005-03-28 23:45:13 -05:00
|
|
|
IN: temporary
|
2004-07-16 02:26:21 -04:00
|
|
|
USE: kernel
|
|
|
|
USE: lists
|
2004-08-26 22:21:17 -04:00
|
|
|
USE: math
|
2004-07-16 02:26:21 -04:00
|
|
|
USE: namespaces
|
2005-06-19 17:50:35 -04:00
|
|
|
USE: io
|
2004-07-16 02:26:21 -04:00
|
|
|
USE: test
|
|
|
|
|
2005-03-21 15:13:40 -05:00
|
|
|
: (callcc1-test)
|
|
|
|
swap 1 - tuck swons
|
|
|
|
over 0 = [ "test-cc" get call ] when
|
|
|
|
(callcc1-test) ;
|
|
|
|
|
2004-07-16 02:26:21 -04:00
|
|
|
: callcc1-test ( x -- list )
|
|
|
|
[
|
2005-03-21 15:13:40 -05:00
|
|
|
"test-cc" set [ ] (callcc1-test)
|
2004-07-16 02:26:21 -04:00
|
|
|
] callcc1 nip ;
|
|
|
|
|
|
|
|
: callcc-namespace-test ( -- ? )
|
|
|
|
[
|
|
|
|
"test-cc" set
|
|
|
|
5 "x" set
|
2004-08-08 21:24:01 -04:00
|
|
|
[
|
2004-07-16 02:26:21 -04:00
|
|
|
6 "x" set "test-cc" get call
|
2004-08-08 21:24:01 -04:00
|
|
|
] with-scope
|
2004-07-16 02:26:21 -04:00
|
|
|
] callcc0 "x" get 5 = ;
|
|
|
|
|
2005-07-25 17:13:35 -04:00
|
|
|
[ t ] [ 10 callcc1-test 10 >list = ] unit-test
|
2004-08-04 03:12:55 -04:00
|
|
|
[ t ] [ callcc-namespace-test ] unit-test
|
2005-07-24 20:17:51 -04:00
|
|
|
|
|
|
|
: multishot-test ( -- stack )
|
|
|
|
[ dup "cc" set 5 swap call ] callcc1 "cc" get car interp-data ;
|
|
|
|
|
|
|
|
[ 5 { } ] [ multishot-test ] unit-test
|