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

Merge branch 'master' of git://factorcode.org/git/factor into clean-linux-x86-32

db4
Maxim Savchenko 2009-04-17 15:57:03 -04:00
parent 9a0879ac7e 364ea217ef
commit 573be9c08e
77 changed files with 295 additions and 291 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
basis/compiler/tests/folding.factor
View File

@ -12,7 +12,7 @@ IN: compiler.tests
IN: compiler.tests.folding IN: compiler.tests.folding
GENERIC: foldable-generic ( a -- b ) foldable GENERIC: foldable-generic ( a -- b ) foldable
M: integer foldable-generic f <array> ; M: integer foldable-generic f <array> ;
"> eval "> (( -- )) eval
] unit-test ] unit-test
[ ] [ [ ] [
@ -20,7 +20,7 @@ IN: compiler.tests
USING: math arrays ; USING: math arrays ;
IN: compiler.tests.folding IN: compiler.tests.folding
: fold-test ( -- x ) 10 foldable-generic ; : fold-test ( -- x ) 10 foldable-generic ;
"> eval "> (( -- )) eval
] unit-test ] unit-test
[ t ] [ [ t ] [

12
basis/compiler/tests/redefine1.factor
View File

@ -11,7 +11,7 @@ M: integer method-redefine-generic-1 3 + ;
[ 6 ] [ method-redefine-test-1 ] unit-test [ 6 ] [ method-redefine-test-1 ] unit-test
[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-generic-1 4 + ;" eval ] unit-test [ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-generic-1 4 + ;" (( -- )) eval ] unit-test
[ 7 ] [ method-redefine-test-1 ] unit-test [ 7 ] [ method-redefine-test-1 ] unit-test
@ -27,7 +27,7 @@ M: integer method-redefine-generic-2 3 + ;
[ 6 ] [ method-redefine-test-2 ] unit-test [ 6 ] [ method-redefine-test-2 ] unit-test
[ ] [ "IN: compiler.tests USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval ] unit-test [ ] [ "IN: compiler.tests USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" (( -- )) eval ] unit-test
[ 7 ] [ method-redefine-test-2 ] unit-test [ 7 ] [ method-redefine-test-2 ] unit-test
@ -43,10 +43,10 @@ M: integer method-redefine-generic-2 3 + ;
[ t ] [ \ hey optimized>> ] unit-test [ t ] [ \ hey optimized>> ] unit-test
[ t ] [ \ there optimized>> ] unit-test [ t ] [ \ there optimized>> ] unit-test
[ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval ] unit-test [ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" (( -- )) eval ] unit-test
[ f ] [ \ hey optimized>> ] unit-test [ f ] [ \ hey optimized>> ] unit-test
[ f ] [ \ there optimized>> ] unit-test [ f ] [ \ there optimized>> ] unit-test
[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval ] unit-test [ ] [ "IN: compiler.tests : hey ( -- ) ;" (( -- )) eval ] unit-test
[ t ] [ \ there optimized>> ] unit-test [ t ] [ \ there optimized>> ] unit-test
: good ( -- ) ; : good ( -- ) ;
@ -59,7 +59,7 @@ M: integer method-redefine-generic-2 3 + ;
[ f ] [ \ good compiled-usage assoc-empty? ] unit-test [ f ] [ \ good compiled-usage assoc-empty? ] unit-test
[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval ] unit-test [ ] [ "IN: compiler.tests : good ( -- ) 3 ;" (( -- )) eval ] unit-test
[ f ] [ \ good optimized>> ] unit-test [ f ] [ \ good optimized>> ] unit-test
[ f ] [ \ bad optimized>> ] unit-test [ f ] [ \ bad optimized>> ] unit-test
@ -67,7 +67,7 @@ M: integer method-redefine-generic-2 3 + ;
[ t ] [ \ good compiled-usage assoc-empty? ] unit-test [ t ] [ \ good compiled-usage assoc-empty? ] unit-test
[ ] [ "IN: compiler.tests : good ( -- ) ;" eval ] unit-test [ ] [ "IN: compiler.tests : good ( -- ) ;" (( -- )) eval ] unit-test
[ t ] [ \ good optimized>> ] unit-test [ t ] [ \ good optimized>> ] unit-test
[ t ] [ \ bad optimized>> ] unit-test [ t ] [ \ bad optimized>> ] unit-test

4
basis/compiler/tests/redefine10.factor
View File

@ -13,7 +13,7 @@ IN: compiler.tests
MIXIN: my-mixin MIXIN: my-mixin
INSTANCE: fixnum my-mixin INSTANCE: fixnum my-mixin
: my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ; : my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ;
"> eval "> (( -- )) eval
] unit-test ] unit-test
[ ] [ [ ] [
@ -21,7 +21,7 @@ IN: compiler.tests
USE: math USE: math
IN: compiler.tests.redefine10 IN: compiler.tests.redefine10
INSTANCE: float my-mixin INSTANCE: float my-mixin
"> eval "> (( -- )) eval
] unit-test ] unit-test
[ 2.0 ] [ [ 2.0 ] [

2
basis/compiler/tests/redefine11.factor
View File

@ -17,7 +17,7 @@ IN: compiler.tests
M: my-mixin my-generic drop 0 ; M: my-mixin my-generic drop 0 ;
M: object my-generic drop 1 ; M: object my-generic drop 1 ;
: my-inline ( -- b ) { } my-generic ; : my-inline ( -- b ) { } my-generic ;
"> eval "> (( -- )) eval
] unit-test ] unit-test
[ ] [ [ ] [

2
basis/compiler/tests/redefine12.factor
View File

@ -15,6 +15,6 @@ M: object g drop t ;
TUPLE: jeah ; TUPLE: jeah ;
[ ] [ "USE: kernel IN: compiler.tests.redefine12 M: jeah g drop f ;" eval ] unit-test [ ] [ "USE: kernel IN: compiler.tests.redefine12 M: jeah g drop f ;" (( -- )) eval ] unit-test
[ f ] [ T{ jeah } h ] unit-test [ f ] [ T{ jeah } h ] unit-test

2
basis/compiler/tests/redefine2.factor
View File

@ -5,7 +5,7 @@ arrays words assocs eval words.symbol ;
DEFER: redefine2-test DEFER: redefine2-test
[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval ] unit-test [ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" (( -- )) eval ] unit-test
[ t ] [ \ redefine2-test symbol? ] unit-test [ t ] [ \ redefine2-test symbol? ] unit-test

2
basis/compiler/tests/redefine3.factor
View File

@ -18,7 +18,7 @@ M: empty-mixin sheeple drop "wake up" ;
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test [ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test [ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ ] [ "IN: compiler.tests USE: arrays INSTANCE: array empty-mixin" eval ] unit-test [ ] [ "IN: compiler.tests USE: arrays INSTANCE: array empty-mixin" (( -- )) eval ] unit-test
[ "wake up" ] [ sheeple-test ] unit-test [ "wake up" ] [ sheeple-test ] unit-test
[ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test [ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test

2
basis/compiler/tests/redefine4.factor
View File

@ -7,6 +7,6 @@ USING: io.streams.string kernel tools.test eval ;
[ "" ] [ [ declaration-test ] with-string-writer ] unit-test [ "" ] [ [ declaration-test ] with-string-writer ] unit-test
[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval ] unit-test [ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" (( -- )) eval ] unit-test
[ "X" ] [ [ declaration-test ] with-string-writer ] unit-test [ "X" ] [ [ declaration-test ] with-string-writer ] unit-test

4
basis/compiler/tests/redefine5.factor
View File

@ -14,7 +14,7 @@ IN: compiler.tests
GENERIC: my-generic ( a -- b ) GENERIC: my-generic ( a -- b )
M: object my-generic [ <=> ] sort ; M: object my-generic [ <=> ] sort ;
: my-inline ( a -- b ) my-generic ; : my-inline ( a -- b ) my-generic ;
"> eval "> (( -- )) eval
] unit-test ] unit-test
[ ] [ [ ] [
@ -23,7 +23,7 @@ IN: compiler.tests
IN: compiler.tests.redefine5 IN: compiler.tests.redefine5
TUPLE: my-tuple ; TUPLE: my-tuple ;
M: my-tuple my-generic drop 0 ; M: my-tuple my-generic drop 0 ;
"> eval "> (( -- )) eval
] unit-test ] unit-test
[ 0 ] [ [ 0 ] [

4
basis/compiler/tests/redefine6.factor
View File

@ -14,7 +14,7 @@ IN: compiler.tests
MIXIN: my-mixin MIXIN: my-mixin
M: my-mixin my-generic drop 0 ; M: my-mixin my-generic drop 0 ;
: my-inline ( a -- b ) { my-mixin } declare my-generic ; : my-inline ( a -- b ) { my-mixin } declare my-generic ;
"> eval "> (( -- )) eval
] unit-test ] unit-test
[ ] [ [ ] [
@ -24,7 +24,7 @@ IN: compiler.tests
TUPLE: my-tuple ; TUPLE: my-tuple ;
M: my-tuple my-generic drop 1 ; M: my-tuple my-generic drop 1 ;
INSTANCE: my-tuple my-mixin INSTANCE: my-tuple my-mixin
"> eval "> (( -- )) eval
] unit-test ] unit-test
[ 1 ] [ [ 1 ] [

4
basis/compiler/tests/redefine7.factor
View File

@ -13,7 +13,7 @@ IN: compiler.tests
MIXIN: my-mixin MIXIN: my-mixin
INSTANCE: fixnum my-mixin INSTANCE: fixnum my-mixin
: my-inline ( a -- b ) dup my-mixin? [ 1 + ] when ; : my-inline ( a -- b ) dup my-mixin? [ 1 + ] when ;
"> eval "> (( -- )) eval
] unit-test ] unit-test
[ ] [ [ ] [
@ -21,7 +21,7 @@ IN: compiler.tests
USE: math USE: math
IN: compiler.tests.redefine7 IN: compiler.tests.redefine7
INSTANCE: float my-mixin INSTANCE: float my-mixin
"> eval "> (( -- )) eval
] unit-test ] unit-test
[ 2.0 ] [ [ 2.0 ] [

4
basis/compiler/tests/redefine8.factor
View File

@ -16,7 +16,7 @@ IN: compiler.tests
! We add the bogus quotation here to hinder inlining ! We add the bogus quotation here to hinder inlining
! since otherwise we cannot trigger this bug. ! since otherwise we cannot trigger this bug.
M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ; M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
"> eval "> (( -- )) eval
] unit-test ] unit-test
[ ] [ [ ] [
@ -24,7 +24,7 @@ IN: compiler.tests
USE: math USE: math
IN: compiler.tests.redefine8 IN: compiler.tests.redefine8
INSTANCE: float my-mixin INSTANCE: float my-mixin
"> eval "> (( -- )) eval
] unit-test ] unit-test
[ 2.0 ] [ [ 2.0 ] [

4
basis/compiler/tests/redefine9.factor
View File

@ -16,7 +16,7 @@ IN: compiler.tests
! We add the bogus quotation here to hinder inlining ! We add the bogus quotation here to hinder inlining
! since otherwise we cannot trigger this bug. ! since otherwise we cannot trigger this bug.
M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ; M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
"> eval "> (( -- )) eval
] unit-test ] unit-test
[ ] [ [ ] [
@ -25,7 +25,7 @@ IN: compiler.tests
IN: compiler.tests.redefine9 IN: compiler.tests.redefine9
TUPLE: my-tuple ; TUPLE: my-tuple ;
INSTANCE: my-tuple my-mixin INSTANCE: my-tuple my-mixin
"> eval "> (( -- )) eval
] unit-test ] unit-test
[ [

2
basis/compiler/tests/simple.factor
View File

@ -237,6 +237,6 @@ M: f single-combination-test-2 single-combination-test-4 ;
10 [ 10 [
[ "compiler.tests.foo" forget-vocab ] with-compilation-unit [ "compiler.tests.foo" forget-vocab ] with-compilation-unit
[ t ] [ [ t ] [
"USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" eval "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" (( -- obj )) eval
] unit-test ] unit-test
] times ] times

2
basis/compiler/tree/cleanup/cleanup-tests.factor
View File

@ -197,7 +197,7 @@ M: fixnum annotate-entry-test-1 drop ;
[ dup annotate-entry-test-1 1+ ] dip (annotate-entry-test-2) [ dup annotate-entry-test-1 1+ ] dip (annotate-entry-test-2)
] if ; inline recursive ] if ; inline recursive
: annotate-entry-test-2 ( from to -- ) 0 -rot (annotate-entry-test-2) ; inline : annotate-entry-test-2 ( from to -- obj ) 0 -rot (annotate-entry-test-2) ; inline
[ f ] [ [ f ] [
[ { bignum } declare annotate-entry-test-2 ] [ { bignum } declare annotate-entry-test-2 ]

12
basis/compiler/tree/normalization/normalization-tests.factor
View File

@ -17,7 +17,7 @@ sequences accessors tools.test kernel math ;
[ 2 ] [ [ 3 [ drop ] [ 2drop 3 ] if ] build-tree count-introductions ] unit-test [ 2 ] [ [ 3 [ drop ] [ 2drop 3 ] if ] build-tree count-introductions ] unit-test
: foo ( -- ) swap ; inline recursive : foo ( a b -- b a ) swap ; inline recursive
: recursive-inputs ( nodes -- n ) : recursive-inputs ( nodes -- n )
[ #recursive? ] find nip child>> first in-d>> length ; [ #recursive? ] find nip child>> first in-d>> length ;
@ -34,18 +34,18 @@ sequences accessors tools.test kernel math ;
[ ] [ [ [ 1 ] [ 2 ] if + * ] test-normalization ] unit-test [ ] [ [ [ 1 ] [ 2 ] if + * ] test-normalization ] unit-test
DEFER: bbb DEFER: bbb
: aaa ( x -- ) dup [ dup [ bbb ] dip aaa ] [ drop ] if ; inline recursive : aaa ( obj x -- obj ) dup [ dup [ bbb ] dip aaa ] [ drop ] if ; inline recursive
: bbb ( x -- ) [ drop 0 ] dip aaa ; inline recursive : bbb ( obj x -- obj ) [ drop 0 ] dip aaa ; inline recursive
[ ] [ [ bbb ] test-normalization ] unit-test [ ] [ [ bbb ] test-normalization ] unit-test
: ccc ( -- ) ccc drop 1 ; inline recursive : ccc ( obj -- 1 ) ccc drop 1 ; inline recursive
[ ] [ [ ccc ] test-normalization ] unit-test [ ] [ [ ccc ] test-normalization ] unit-test
DEFER: eee DEFER: eee
: ddd ( -- ) eee ; inline recursive : ddd ( a b -- a b ) eee ; inline recursive
: eee ( -- ) swap ddd ; inline recursive : eee ( a b -- a b ) swap ddd ; inline recursive
[ ] [ [ eee ] test-normalization ] unit-test [ ] [ [ eee ] test-normalization ] unit-test

2
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -680,7 +680,7 @@ TUPLE: littledan-2 { from read-only } { to read-only } ;
: (littledan-3-test) ( x -- ) : (littledan-3-test) ( x -- )
length 1+ f <array> (littledan-3-test) ; inline recursive length 1+ f <array> (littledan-3-test) ; inline recursive
: littledan-3-test ( x -- ) : littledan-3-test ( -- )
0 f <array> (littledan-3-test) ; inline 0 f <array> (littledan-3-test) ; inline
[ ] [ [ littledan-3-test ] final-classes drop ] unit-test [ ] [ [ littledan-3-test ] final-classes drop ] unit-test

2
basis/compiler/tree/recursive/recursive-tests.factor
View File

@ -57,7 +57,7 @@ compiler.tree.combinators ;
\ (each-integer) label-is-loop? \ (each-integer) label-is-loop?
] unit-test ] unit-test
: loop-test-2 ( a -- ) : loop-test-2 ( a b -- a' )
dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline recursive dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline recursive
[ t ] [ [ t ] [

2
basis/concurrency/exchangers/exchangers-tests.factor
View File

@ -3,7 +3,7 @@ USING: sequences tools.test concurrency.exchangers
concurrency.count-downs concurrency.promises locals kernel concurrency.count-downs concurrency.promises locals kernel
threads ; threads ;
:: exchanger-test ( -- ) :: exchanger-test ( -- string )
[let | [let |
ex [ <exchanger> ] ex [ <exchanger> ]
c [ 2 <count-down> ] c [ 2 <count-down> ]

2
basis/concurrency/flags/flags-tests.factor
View File

@ -11,7 +11,7 @@ kernel threads locals accessors calendar ;
[ f ] [ flag-test-1 ] unit-test [ f ] [ flag-test-1 ] unit-test
:: flag-test-2 ( -- ) :: flag-test-2 ( -- ? )
[let | f [ <flag> ] | [let | f [ <flag> ] |
[ 1 seconds sleep f raise-flag ] "Flag test" spawn drop [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop
f lower-flag f lower-flag

10
basis/delegate/delegate-tests.factor
View File

@ -35,7 +35,7 @@ M: hello bing hello-test ;
[ 3 ] [ 1 0 <hello> 2 whoa ] unit-test [ 3 ] [ 1 0 <hello> 2 whoa ] unit-test
[ 3 ] [ 1 0 <hello> f <goodbye> 2 whoa ] unit-test [ 3 ] [ 1 0 <hello> f <goodbye> 2 whoa ] unit-test
[ ] [ 3 [ "USING: accessors delegate ; IN: delegate.tests CONSULT: baz goodbye these>> ;" eval ] times ] unit-test [ ] [ 3 [ "USING: accessors delegate ; IN: delegate.tests CONSULT: baz goodbye these>> ;" (( -- )) eval ] times ] unit-test
[ H{ { goodbye T{ consultation f baz goodbye [ these>> ] } } } ] [ baz protocol-consult ] unit-test [ H{ { goodbye T{ consultation f baz goodbye [ these>> ] } } } ] [ baz protocol-consult ] unit-test
[ H{ } ] [ bee protocol-consult ] unit-test [ H{ } ] [ bee protocol-consult ] unit-test
@ -63,22 +63,22 @@ CONSULT: beta hey value>> 1- ;
[ 0 ] [ 1 <hey> three ] unit-test [ 0 ] [ 1 <hey> three ] unit-test
[ { hey } ] [ alpha protocol-users ] unit-test [ { hey } ] [ alpha protocol-users ] unit-test
[ { hey } ] [ beta protocol-users ] unit-test [ { hey } ] [ beta protocol-users ] unit-test
[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: alpha one ;" eval ] unit-test [ ] [ "USE: delegate IN: delegate.tests PROTOCOL: alpha one ;" (( -- )) eval ] unit-test
[ f ] [ hey \ two method ] unit-test [ f ] [ hey \ two method ] unit-test
[ f ] [ hey \ four method ] unit-test [ f ] [ hey \ four method ] unit-test
[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: beta two three four ;" eval ] unit-test [ ] [ "USE: delegate IN: delegate.tests PROTOCOL: beta two three four ;" (( -- )) eval ] unit-test
[ { hey } ] [ alpha protocol-users ] unit-test [ { hey } ] [ alpha protocol-users ] unit-test
[ { hey } ] [ beta protocol-users ] unit-test [ { hey } ] [ beta protocol-users ] unit-test
[ 2 ] [ 1 <hey> one ] unit-test [ 2 ] [ 1 <hey> one ] unit-test
[ 0 ] [ 1 <hey> two ] unit-test [ 0 ] [ 1 <hey> two ] unit-test
[ 0 ] [ 1 <hey> three ] unit-test [ 0 ] [ 1 <hey> three ] unit-test
[ 0 ] [ 1 <hey> four ] unit-test [ 0 ] [ 1 <hey> four ] unit-test
[ ] [ "USING: math accessors delegate ; IN: delegate.tests CONSULT: beta hey value>> 2 - ;" eval ] unit-test [ ] [ "USING: math accessors delegate ; IN: delegate.tests CONSULT: beta hey value>> 2 - ;" (( -- )) eval ] unit-test
[ 2 ] [ 1 <hey> one ] unit-test [ 2 ] [ 1 <hey> one ] unit-test
[ -1 ] [ 1 <hey> two ] unit-test [ -1 ] [ 1 <hey> two ] unit-test
[ -1 ] [ 1 <hey> three ] unit-test [ -1 ] [ 1 <hey> three ] unit-test
[ -1 ] [ 1 <hey> four ] unit-test [ -1 ] [ 1 <hey> four ] unit-test
[ ] [ "IN: delegate.tests FORGET: alpha" eval ] unit-test [ ] [ "IN: delegate.tests FORGET: alpha" (( -- )) eval ] unit-test
[ f ] [ hey \ one method ] unit-test [ f ] [ hey \ one method ] unit-test
TUPLE: slot-protocol-test-1 a b ; TUPLE: slot-protocol-test-1 a b ;

2
basis/fry/fry-tests.factor
View File

@ -56,7 +56,7 @@ sequences eval accessors ;
3 '[ [ [ _ 1array ] call 1array ] call 1array ] call 3 '[ [ [ _ 1array ] call 1array ] call 1array ] call
] unit-test ] unit-test
[ "USING: fry locals.backend ; f '[ load-local _ ]" eval ] [ "USING: fry locals.backend ; f '[ load-local _ ]" (( -- quot )) eval ]
[ error>> >r/r>-in-fry-error? ] must-fail-with [ error>> >r/r>-in-fry-error? ] must-fail-with
[ { { "a" 1 } { "b" 2 } { "c" 3 } { "d" 4 } } ] [ [ { { "a" 1 } { "b" 2 } { "c" 3 } { "d" 4 } } ] [

4
basis/furnace/sessions/sessions-tests.factor
View File

@ -22,7 +22,7 @@ M: foo call-responder*
"x" [ 1+ ] schange "x" [ 1+ ] schange
"x" sget number>string "text/html" <content> ; "x" sget number>string "text/html" <content> ;
: url-responder-mock-test ( -- ) : url-responder-mock-test ( -- string )
[ [
<request> <request>
"GET" >>method "GET" >>method
@ -34,7 +34,7 @@ M: foo call-responder*
[ write-response-body drop ] with-string-writer [ write-response-body drop ] with-string-writer
] with-destructors ; ] with-destructors ;
: sessions-mock-test ( -- ) : sessions-mock-test ( -- string )
[ [
<request> <request>
"GET" >>method "GET" >>method

2
basis/hash2/hash2-tests.factor
View File

@ -4,7 +4,7 @@ IN: hash2.tests
[ t ] [ 1 2 { 1 2 } 2= ] unit-test [ t ] [ 1 2 { 1 2 } 2= ] unit-test
[ f ] [ 1 3 { 1 2 } 2= ] unit-test [ f ] [ 1 3 { 1 2 } 2= ] unit-test
: sample-hash ( -- ) : sample-hash ( -- hash )
5 <hash2> 5 <hash2>
dup 2 3 "foo" roll set-hash2 dup 2 3 "foo" roll set-hash2
dup 4 2 "bar" roll set-hash2 dup 4 2 "bar" roll set-hash2

2
basis/heaps/heaps-tests.factor
View File

@ -54,7 +54,7 @@ IN: heaps.tests
: sort-entries ( entries -- entries' ) : sort-entries ( entries -- entries' )
[ [ key>> ] compare ] sort ; [ [ key>> ] compare ] sort ;
: delete-test ( n -- ? ) : delete-test ( n -- obj1 obj2 )
[ [
random-alist random-alist
<min-heap> [ heap-push-all ] keep <min-heap> [ heap-push-all ] keep

4
basis/help/crossref/crossref-tests.factor
View File

@ -4,7 +4,7 @@ definitions assocs sequences kernel namespaces parser arrays
io.streams.string continuations debugger compiler.units eval ; io.streams.string continuations debugger compiler.units eval ;
[ ] [ [ ] [
"IN: help.crossref.tests USING: help.syntax help.markup ; : foo ( -- ) ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval "IN: help.crossref.tests USING: help.syntax help.markup ; : foo ( -- ) ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" (( -- )) eval
] unit-test ] unit-test
[ $subsection ] [ [ $subsection ] [
@ -23,7 +23,7 @@ io.streams.string continuations debugger compiler.units eval ;
] unit-test ] unit-test
[ ] [ [ ] [
"IN: help.crossref.tests USING: help.syntax help.markup ; : bar ( -- ) ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" eval "IN: help.crossref.tests USING: help.syntax help.markup ; : bar ( -- ) ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" (( -- )) eval
] unit-test ] unit-test
[ ] [ [ ] [

2
basis/help/definitions/definitions-tests.factor
View File

@ -32,7 +32,7 @@ IN: help.definitions.tests
"hello" "help.definitions.tests" lookup "help" word-prop "hello" "help.definitions.tests" lookup "help" word-prop
] unit-test ] unit-test
[ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ( -- ) ; HELP: xxx ;" eval ] unit-test [ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ( -- ) ; HELP: xxx ;" (( -- )) eval ] unit-test
[ ] [ "xxx" "help.definitions.tests" lookup print-topic ] unit-test [ ] [ "xxx" "help.definitions.tests" lookup print-topic ] unit-test

4
basis/help/syntax/syntax-tests.factor
View File

@ -4,12 +4,12 @@ IN: help.syntax.tests
[ [
[ "foobar" ] [ [ "foobar" ] [
"IN: help.syntax.tests USE: help.syntax ABOUT: \"foobar\"" eval "IN: help.syntax.tests USE: help.syntax ABOUT: \"foobar\"" (( -- )) eval
"help.syntax.tests" vocab vocab-help "help.syntax.tests" vocab vocab-help
] unit-test ] unit-test
[ { "foobar" } ] [ [ { "foobar" } ] [
"IN: help.syntax.tests USE: help.syntax ABOUT: { \"foobar\" }" eval "IN: help.syntax.tests USE: help.syntax ABOUT: { \"foobar\" }" (( -- )) eval
"help.syntax.tests" vocab vocab-help "help.syntax.tests" vocab vocab-help
] unit-test ] unit-test

2
basis/help/topics/topics-tests.factor
View File

@ -29,7 +29,7 @@ SYMBOL: foo
} "\n" join } "\n" join
[ [
"testfile" source-file file set "testfile" source-file file set
eval (( -- )) eval
] with-scope ] with-scope
] unit-test ] unit-test

4
basis/listener/listener-tests.factor
View File

@ -25,7 +25,7 @@ SYNTAX: hello "Hi" print ;
"\\ + 1 2 3 4" parse-interactive "\\ + 1 2 3 4" parse-interactive
"cont" get continue-with "cont" get continue-with
] ignore-errors ] ignore-errors
"USE: debugger :1" eval "USE: debugger :1" (( -- quot )) eval
] callcc1 ] callcc1
] unit-test ] unit-test
] with-file-vocabs ] with-file-vocabs
@ -50,7 +50,7 @@ SYNTAX: hello "Hi" print ;
[ [
[ ] [ [ ] [
"IN: listener.tests : hello ( -- )\n\"world\" ;" parse-interactive "IN: listener.tests : hello ( -- string )\n\"world\" ;" parse-interactive
drop drop
] unit-test ] unit-test
] with-file-vocabs ] with-file-vocabs

26
basis/locals/locals-tests.factor
View File

@ -261,7 +261,7 @@ M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ;
CONSTANT: new-definition "USING: math ;\nIN: locals.tests\n: a-word-with-locals ( -- x ) 2 3 + ;\n" CONSTANT: new-definition "USING: math ;\nIN: locals.tests\n: a-word-with-locals ( -- x ) 2 3 + ;\n"
[ ] [ new-definition eval ] unit-test [ ] [ new-definition (( -- )) eval ] unit-test
[ t ] [ [ t ] [
[ \ a-word-with-locals see ] with-string-writer [ \ a-word-with-locals see ] with-string-writer
@ -461,7 +461,7 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
[ [
"USING: locals fry math ; 1 '[ [let | A [ 10 ] | A _ + ] ]" "USING: locals fry math ; 1 '[ [let | A [ 10 ] | A _ + ] ]"
eval call (( -- )) eval call
] [ error>> >r/r>-in-fry-error? ] must-fail-with ] [ error>> >r/r>-in-fry-error? ] must-fail-with
:: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline :: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline
@ -473,10 +473,10 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
[ f ] [ 2 funny-macro-test ] unit-test [ f ] [ 2 funny-macro-test ] unit-test
! Some odd parser corner cases ! Some odd parser corner cases
[ "USE: locals [let" eval ] [ error>> unexpected-eof? ] must-fail-with [ "USE: locals [let" (( -- )) eval ] [ error>> unexpected-eof? ] must-fail-with
[ "USE: locals [let |" eval ] [ error>> unexpected-eof? ] must-fail-with [ "USE: locals [let |" (( -- )) eval ] [ error>> unexpected-eof? ] must-fail-with
[ "USE: locals [let | a" eval ] [ error>> unexpected-eof? ] must-fail-with [ "USE: locals [let | a" (( -- )) eval ] [ error>> unexpected-eof? ] must-fail-with
[ "USE: locals [|" eval ] [ error>> unexpected-eof? ] must-fail-with [ "USE: locals [|" (( -- )) eval ] [ error>> unexpected-eof? ] must-fail-with
[ 25 ] [ 5 [| a | { [ a sq ] } cond ] call ] unit-test [ 25 ] [ 5 [| a | { [ a sq ] } cond ] call ] unit-test
[ 25 ] [ 5 [| | { [| a | a sq ] } ] call first call ] unit-test [ 25 ] [ 5 [| | { [| a | a sq ] } ] call first call ] unit-test
@ -491,19 +491,19 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
[ 3 ] [ 3 [| a | \ a ] call ] unit-test [ 3 ] [ 3 [| a | \ a ] call ] unit-test
[ "USE: locals [| | { [let | a [ 0 ] | a ] } ]" eval ] must-fail [ "USE: locals [| | { [let | a [ 0 ] | a ] } ]" (( -- )) eval ] must-fail
[ "USE: locals [| | { [wlet | a [ 0 ] | a ] } ]" eval ] must-fail [ "USE: locals [| | { [wlet | a [ 0 ] | a ] } ]" (( -- )) eval ] must-fail
[ "USE: locals [| | { [let* | a [ 0 ] | a ] } ]" eval ] must-fail [ "USE: locals [| | { [let* | a [ 0 ] | a ] } ]" (( -- )) eval ] must-fail
[ "USE: locals [| | [let | a! [ 0 ] | { a! } ] ]" eval ] must-fail [ "USE: locals [| | [let | a! [ 0 ] | { a! } ] ]" (( -- )) eval ] must-fail
[ "USE: locals [| | [wlet | a [ 0 ] | { a } ] ]" eval ] must-fail [ "USE: locals [| | [wlet | a [ 0 ] | { a } ] ]" (( -- )) eval ] must-fail
[ "USE: locals [| | { :> a } ]" eval ] must-fail [ "USE: locals [| | { :> a } ]" (( -- )) eval ] must-fail
[ "USE: locals 3 :> a" eval ] must-fail [ "USE: locals 3 :> a" (( -- )) eval ] must-fail
[ 3 ] [ 3 [| | :> a a ] call ] unit-test [ 3 ] [ 3 [| | :> a a ] call ] unit-test

4
basis/macros/macros-tests.factor
View File

@ -13,11 +13,11 @@ unit-test
[ t ] [ \ see-test macro? ] unit-test [ t ] [ \ see-test macro? ] unit-test
[ t ] [ [ t ] [
"USING: math ;\nIN: macros.tests\n: see-test ( a b -- c ) - ;\n" dup eval "USING: math ;\nIN: macros.tests\n: see-test ( a b -- c ) - ;\n" dup (( -- )) eval
[ \ see-test see ] with-string-writer = [ \ see-test see ] with-string-writer =
] unit-test ] unit-test
[ f ] [ \ see-test macro? ] unit-test [ f ] [ \ see-test macro? ] unit-test
[ ] [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" eval ] unit-test [ ] [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" (( -- )) eval ] unit-test

18
basis/math/intervals/intervals-tests.factor
View File

@ -255,11 +255,11 @@ IN: math.intervals.tests
0 pick interval-contains? over first \ recip eq? and [ 0 pick interval-contains? over first \ recip eq? and [
2drop t 2drop t
] [ ] [
[ [ random-element ] dip first execute ] 2keep [ [ random-element ] dip first execute( a -- b ) ] 2keep
second execute interval-contains? second execute( a -- b ) interval-contains?
] if ; ] if ;
[ t ] [ 80000 [ drop unary-test ] all? ] unit-test [ t ] [ 80000 iota [ drop unary-test ] all? ] unit-test
: random-binary-op ( -- pair ) : random-binary-op ( -- pair )
{ {
@ -286,11 +286,11 @@ IN: math.intervals.tests
0 pick interval-contains? over first { / /i mod rem } member? and [ 0 pick interval-contains? over first { / /i mod rem } member? and [
3drop t 3drop t
] [ ] [
[ [ [ random-element ] bi@ ] dip first execute ] 3keep [ [ [ random-element ] bi@ ] dip first execute( a b -- c ) ] 3keep
second execute interval-contains? second execute( a b -- c ) interval-contains?
] if ; ] if ;
[ t ] [ 80000 [ drop binary-test ] all? ] unit-test [ t ] [ 80000 iota [ drop binary-test ] all? ] unit-test
: random-comparison ( -- pair ) : random-comparison ( -- pair )
{ {
@ -305,7 +305,7 @@ IN: math.intervals.tests
[ [ [ random-element ] bi@ ] dip first execute ] 3keep [ [ [ random-element ] bi@ ] dip first execute ] 3keep
second execute dup incomparable eq? [ 2drop t ] [ = ] if ; second execute dup incomparable eq? [ 2drop t ] [ = ] if ;
[ t ] [ 40000 [ drop comparison-test ] all? ] unit-test [ t ] [ 40000 iota [ drop comparison-test ] all? ] unit-test
[ t ] [ -10 10 [a,b] 0 100 [a,b] assume> 0 10 (a,b] = ] unit-test [ t ] [ -10 10 [a,b] 0 100 [a,b] assume> 0 10 (a,b] = ] unit-test
@ -322,7 +322,7 @@ IN: math.intervals.tests
[ t ] [ -10 10 [a,b] interval-abs 0 10 [a,b] = ] unit-test [ t ] [ -10 10 [a,b] interval-abs 0 10 [a,b] = ] unit-test
! Test that commutative interval ops really are ! Test that commutative interval ops really are
: random-interval-or-empty ( -- ) : random-interval-or-empty ( -- obj )
10 random 0 = [ empty-interval ] [ random-interval ] if ; 10 random 0 = [ empty-interval ] [ random-interval ] if ;
: random-commutative-op ( -- op ) : random-commutative-op ( -- op )
@ -333,7 +333,7 @@ IN: math.intervals.tests
} random ; } random ;
[ t ] [ [ t ] [
80000 [ 80000 iota [
drop drop
random-interval-or-empty random-interval-or-empty random-interval-or-empty random-interval-or-empty
random-commutative-op random-commutative-op

4
basis/memoize/memoize-tests.factor
View File

@ -9,7 +9,7 @@ MEMO: fib ( m -- n )
[ 89 ] [ 10 fib ] unit-test [ 89 ] [ 10 fib ] unit-test
[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1+ ] 4 ndip ;" eval ] must-fail [ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1+ ] 4 ndip ;" (( -- )) eval ] must-fail
MEMO: see-test ( a -- b ) reverse ; MEMO: see-test ( a -- b ) reverse ;
@ -17,7 +17,7 @@ MEMO: see-test ( a -- b ) reverse ;
[ [ \ see-test see ] with-string-writer ] [ [ \ see-test see ] with-string-writer ]
unit-test unit-test
[ ] [ "IN: memoize.tests : fib ( -- ) ;" eval ] unit-test [ ] [ "IN: memoize.tests : fib ( -- ) ;" (( -- )) eval ] unit-test
[ "IN: memoize.tests\n: fib ( -- ) ;\n" ] [ [ \ fib see ] with-string-writer ] unit-test [ "IN: memoize.tests\n: fib ( -- ) ;\n" ] [ [ \ fib see ] with-string-writer ] unit-test

2
basis/mirrors/mirrors-tests.factor
View File

@ -56,6 +56,6 @@ TUPLE: color
! Test reshaping with a mirror ! Test reshaping with a mirror
1 2 3 color boa <mirror> "mirror" set 1 2 3 color boa <mirror> "mirror" set
[ ] [ "IN: mirrors.tests USE: math TUPLE: color { green integer } { red integer } { blue integer } ;" eval ] unit-test [ ] [ "IN: mirrors.tests USE: math TUPLE: color { green integer } { red integer } { blue integer } ;" (( -- )) eval ] unit-test
[ 1 ] [ "red" "mirror" get at ] unit-test [ 1 ] [ "red" "mirror" get at ] unit-test

10
basis/peg/ebnf/ebnf-tests.factor
View File

@ -444,12 +444,12 @@ foo=<foreign any-char> 'd'
"ad" parser4 "ad" parser4
] unit-test ] unit-test
{ t } [ { } [
"USING: kernel peg.ebnf ; \"a\\n\" [EBNF foo='a' '\n' => [[ drop \"\n\" ]] EBNF]" eval drop t "USING: kernel peg.ebnf ; \"a\\n\" [EBNF foo='a' '\n' => [[ drop \"\n\" ]] EBNF] drop" (( -- )) eval
] unit-test ] unit-test
[ [
"USING: peg.ebnf ; <EBNF foo='a' foo='b' EBNF>" eval drop "USING: peg.ebnf ; <EBNF foo='a' foo='b' EBNF>" (( -- )) eval drop
] must-fail ] must-fail
{ t } [ { t } [
@ -521,12 +521,12 @@ Tok = Spaces (Number | Special )
"\\" [EBNF foo="\\" EBNF] "\\" [EBNF foo="\\" EBNF]
] unit-test ] unit-test
[ "USE: peg.ebnf [EBNF EBNF]" eval ] must-fail [ "USE: peg.ebnf [EBNF EBNF]" (( -- )) eval ] must-fail
[ <" USE: peg.ebnf [EBNF [ <" USE: peg.ebnf [EBNF
lol = a lol = a
lol = b lol = b
EBNF] "> eval EBNF] "> (( -- )) eval
] [ ] [
error>> [ redefined-rule? ] [ name>> "lol" = ] bi and error>> [ redefined-rule? ] [ name>> "lol" = ] bi and
] must-fail-with ] must-fail-with

6
basis/persistent/hashtables/hashtables-tests.factor
View File

@ -83,7 +83,7 @@ M: hash-0-b hashcode* 2drop 0 ;
: random-string ( -- str ) : random-string ( -- str )
1000000 random ; ! [ CHAR: a CHAR: z [a,b] random ] "" replicate-as ; 1000000 random ; ! [ CHAR: a CHAR: z [a,b] random ] "" replicate-as ;
: random-assocs ( -- hash phash ) : random-assocs ( n -- hash phash )
[ random-string ] replicate [ random-string ] replicate
[ H{ } clone [ '[ swap _ set-at ] each-index ] keep ] [ H{ } clone [ '[ swap _ set-at ] each-index ] keep ]
[ PH{ } clone swap [ spin new-at ] each-index ] [ PH{ } clone swap [ spin new-at ] each-index ]
@ -92,7 +92,7 @@ M: hash-0-b hashcode* 2drop 0 ;
: ok? ( assoc1 assoc2 -- ? ) : ok? ( assoc1 assoc2 -- ? )
[ assoc= ] [ [ assoc-size ] bi@ = ] 2bi and ; [ assoc= ] [ [ assoc-size ] bi@ = ] 2bi and ;
: test-persistent-hashtables-1 ( n -- ) : test-persistent-hashtables-1 ( n -- ? )
random-assocs ok? ; random-assocs ok? ;
[ t ] [ 10 test-persistent-hashtables-1 ] unit-test [ t ] [ 10 test-persistent-hashtables-1 ] unit-test
@ -106,7 +106,7 @@ M: hash-0-b hashcode* 2drop 0 ;
[ t ] [ 10000 test-persistent-hashtables-1 ] unit-test [ t ] [ 10000 test-persistent-hashtables-1 ] unit-test
[ t ] [ 50000 test-persistent-hashtables-1 ] unit-test [ t ] [ 50000 test-persistent-hashtables-1 ] unit-test
: test-persistent-hashtables-2 ( n -- ) : test-persistent-hashtables-2 ( n -- ? )
random-assocs random-assocs
dup keys [ dup keys [
[ nip over delete-at ] [ swap pluck-at nip ] 3bi [ nip over delete-at ] [ swap pluck-at nip ] 3bi

24
basis/prettyprint/prettyprint-tests.factor
View File

@ -90,7 +90,7 @@ unit-test
[ \ blah see ] with-string-writer "\n" ?tail drop 6 tail* [ \ blah see ] with-string-writer "\n" ?tail drop 6 tail*
] unit-test ] unit-test
: check-see ( expect name -- ) : check-see ( expect name -- ? )
[ [
use [ clone ] change use [ clone ] change
@ -105,6 +105,7 @@ unit-test
GENERIC: method-layout ( a -- b ) GENERIC: method-layout ( a -- b )
M: complex method-layout M: complex method-layout
drop
"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
; ;
@ -116,8 +117,9 @@ M: object method-layout ;
[ [
{ {
"USING: math prettyprint.tests ;" "USING: kernel math prettyprint.tests ;"
"M: complex method-layout" "M: complex method-layout"
" drop"
" \"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\"" " \"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\""
" ;" " ;"
"" ""
@ -180,15 +182,15 @@ DEFER: parse-error-file
"string-layout-test" string-layout check-see "string-layout-test" string-layout check-see
] unit-test ] unit-test
: narrow-test ( -- str ) : narrow-test ( -- array )
{ {
"USING: arrays combinators continuations kernel sequences ;" "USING: arrays combinators continuations kernel sequences ;"
"IN: prettyprint.tests" "IN: prettyprint.tests"
": narrow-layout ( obj -- )" ": narrow-layout ( obj1 obj2 -- obj3 )"
" {" " {"
" { [ dup continuation? ] [ append ] }" " { [ dup continuation? ] [ append ] }"
" { [ dup not ] [ drop reverse ] }" " { [ dup not ] [ drop reverse ] }"
" { [ dup pair? ] [ delete ] }" " { [ dup pair? ] [ [ delete ] keep ] }"
" } cond ;" " } cond ;"
} ; } ;
@ -196,7 +198,7 @@ DEFER: parse-error-file
"narrow-layout" narrow-test check-see "narrow-layout" narrow-test check-see
] unit-test ] unit-test
: another-narrow-test ( -- str ) : another-narrow-test ( -- array )
{ {
"IN: prettyprint.tests" "IN: prettyprint.tests"
": another-narrow-layout ( -- obj )" ": another-narrow-layout ( -- obj )"
@ -252,18 +254,14 @@ M: class-see-layout class-see-layout ;
! Regression ! Regression
[ t ] [ [ t ] [
"IN: prettyprint.tests\nGENERIC: generic-decl-test ( a -- b ) flushable\n" "IN: prettyprint.tests\nGENERIC: generic-decl-test ( a -- b ) flushable\n"
dup eval dup (( -- )) eval
"generic-decl-test" "prettyprint.tests" lookup "generic-decl-test" "prettyprint.tests" lookup
[ see ] with-string-writer = [ see ] with-string-writer =
] unit-test ] unit-test
[ [ + ] ] [ [ [ + ] ] [ [ \ + (step-into-execute) ] (remove-breakpoints) ] unit-test
[ \ + (step-into-execute) ] (remove-breakpoints)
] unit-test
[ [ (step-into-execute) ] ] [ [ [ (step-into-execute) ] ] [ [ (step-into-execute) ] (remove-breakpoints) ] unit-test
[ (step-into-execute) ] (remove-breakpoints)
] unit-test
[ [ 2 2 + . ] ] [ [ [ 2 2 + . ] ] [
[ 2 2 \ + (step-into-execute) . ] (remove-breakpoints) [ 2 2 \ + (step-into-execute) . ] (remove-breakpoints)

2
basis/random/mersenne-twister/mersenne-twister-tests.factor
View File

@ -11,7 +11,7 @@ IN: random.mersenne-twister.tests
100 [ 100 random ] replicate ; 100 [ 100 random ] replicate ;
: test-rng ( seed quot -- ) : test-rng ( seed quot -- )
[ <mersenne-twister> ] dip with-random ; [ <mersenne-twister> ] dip with-random ; inline
[ f ] [ 1234 [ randoms randoms = ] test-rng ] unit-test [ f ] [ 1234 [ randoms randoms = ] test-rng ] unit-test

2
basis/regexp/parser/parser-tests.factor
View File

@ -4,7 +4,7 @@ IN: regexp.parser.tests
: regexp-parses ( string -- ) : regexp-parses ( string -- )
[ [ ] ] dip '[ _ parse-regexp drop ] unit-test ; [ [ ] ] dip '[ _ parse-regexp drop ] unit-test ;
: regexp-fails ( string -- ) : regexp-fails ( string -- regexp )
'[ _ parse-regexp ] must-fail ; '[ _ parse-regexp ] must-fail ;
{ {

6
basis/regexp/regexp-tests.factor
View File

@ -262,11 +262,11 @@ IN: regexp-tests
! Comment inside a regular expression ! Comment inside a regular expression
[ t ] [ "ac" "a(?#boo)c" <regexp> matches? ] unit-test [ t ] [ "ac" "a(?#boo)c" <regexp> matches? ] unit-test
[ ] [ "USING: regexp kernel ; R' -{3}[+]{1,6}(?:!!)?\\s' drop" eval ] unit-test [ ] [ "USING: regexp kernel ; R' -{3}[+]{1,6}(?:!!)?\\s' drop" (( -- )) eval ] unit-test
[ ] [ "USING: regexp kernel ; R' (ftp|http|https)://(\\w+:?\\w*@)?(\\S+)(:[0-9]+)?(/|/([\\w#!:.?+=&%@!\\-/]))?' drop" eval ] unit-test [ ] [ "USING: regexp kernel ; R' (ftp|http|https)://(\\w+:?\\w*@)?(\\S+)(:[0-9]+)?(/|/([\\w#!:.?+=&%@!\\-/]))?' drop" (( -- )) eval ] unit-test
[ ] [ "USING: regexp kernel ; R' \\*[^\s*][^*]*\\*' drop" eval ] unit-test [ ] [ "USING: regexp kernel ; R' \\*[^\s*][^*]*\\*' drop" (( -- )) eval ] unit-test
[ "ab" ] [ "ab" "(a|ab)(bc)?" <regexp> first-match >string ] unit-test [ "ab" ] [ "ab" "(a|ab)(bc)?" <regexp> first-match >string ] unit-test
[ "abc" ] [ "abc" "(a|ab)(bc)?" <regexp> first-match >string ] unit-test [ "abc" ] [ "abc" "(a|ab)(bc)?" <regexp> first-match >string ] unit-test

4
basis/stack-checker/stack-checker-tests.factor
View File

@ -524,7 +524,7 @@ ERROR: custom-error ;
{ 2 1 } [ [ + ] inference-invalidation-b ] must-infer-as { 2 1 } [ [ + ] inference-invalidation-b ] must-infer-as
[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- a b ) 1 2 ;" eval ] unit-test [ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- a b ) 1 2 ;" (( -- )) eval ] unit-test
[ 3 ] [ inference-invalidation-c ] unit-test [ 3 ] [ inference-invalidation-c ] unit-test
@ -536,7 +536,7 @@ M: object inference-invalidation-d inference-invalidation-c 2drop ;
\ inference-invalidation-d must-infer \ inference-invalidation-d must-infer
[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- ) ;" eval ] unit-test [ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- ) ;" (( -- )) eval ] unit-test
[ [ inference-invalidation-d ] infer ] must-fail [ [ inference-invalidation-d ] infer ] must-fail

2
basis/threads/threads-tests.factor
View File

@ -31,7 +31,7 @@ yield
[ [ 3 throw ] "A" suspend ] [ 3 = ] must-fail-with [ [ 3 throw ] "A" suspend ] [ 3 = ] must-fail-with
:: spawn-namespace-test ( -- ) :: spawn-namespace-test ( -- ? )
[let | p [ <promise> ] g [ gensym ] | [let | p [ <promise> ] g [ gensym ] |
[ [
g "x" set g "x" set

4
basis/tools/annotations/annotations-tests.factor
View File

@ -18,7 +18,7 @@ M: integer some-generic 1+ ;
[ 4 ] [ 3 some-generic ] unit-test [ 4 ] [ 3 some-generic ] unit-test
[ ] [ "IN: tools.annotations.tests USE: math M: integer some-generic 1- ;" eval ] unit-test [ ] [ "IN: tools.annotations.tests USE: math M: integer some-generic 1- ;" (( -- )) eval ] unit-test
[ 2 ] [ 3 some-generic ] unit-test [ 2 ] [ 3 some-generic ] unit-test
@ -33,7 +33,7 @@ M: object another-generic ;
\ another-generic watch \ another-generic watch
[ ] [ "IN: tools.annotations.tests GENERIC: another-generic ( a -- b )" eval ] unit-test [ ] [ "IN: tools.annotations.tests GENERIC: another-generic ( a -- b )" (( -- )) eval ] unit-test
[ ] [ \ another-generic reset ] unit-test [ ] [ \ another-generic reset ] unit-test

6
basis/tools/deploy/shaker/shaker.factor
View File

@ -374,9 +374,9 @@ SYMBOL: deploy-vocab
[:c] [:c]
[print-error] [print-error]
'[ '[
[ _ execute ] [ [ _ execute( obj -- ) ] [
_ execute nl _ execute( obj -- ) nl
_ execute _ execute( obj -- )
] recover ] recover
] % ] %
] if ] if

6
core/classes/classes-tests.factor
View File

@ -29,10 +29,10 @@ M: method-forget-class method-forget-test ;
] unit-test ] unit-test
! Minor leak ! Minor leak
[ ] [ "IN: classes.tests TUPLE: forget-me ;" eval ] unit-test [ ] [ "IN: classes.tests TUPLE: forget-me ;" (( -- )) eval ] unit-test
[ ] [ f \ word set-global ] unit-test [ ] [ f \ word set-global ] unit-test
[ ] [ "IN: classes.tests USE: kernel USE: classes.algebra forget-me tuple class<= drop" eval ] unit-test [ ] [ "IN: classes.tests USE: kernel USE: classes.algebra forget-me tuple class<= drop" (( -- )) eval ] unit-test
[ ] [ "IN: classes.tests FORGET: forget-me" eval ] unit-test [ ] [ "IN: classes.tests FORGET: forget-me" (( -- )) eval ] unit-test
[ 0 ] [ [ 0 ] [
[ word? ] instances [ word? ] instances
[ [ name>> "forget-me" = ] [ vocabulary>> "classes.tests" = ] bi and ] count [ [ name>> "forget-me" = ] [ vocabulary>> "classes.tests" = ] bi and ] count

2
core/classes/mixin/mixin-tests.factor
View File

@ -42,7 +42,7 @@ INSTANCE: integer mx1
[ t ] [ mx1 integer class<= ] unit-test [ t ] [ mx1 integer class<= ] unit-test
[ t ] [ mx1 number class<= ] unit-test [ t ] [ mx1 number class<= ] unit-test
"IN: classes.mixin.tests USE: arrays INSTANCE: array mx1" eval "IN: classes.mixin.tests USE: arrays INSTANCE: array mx1" (( -- )) eval
[ t ] [ array mx1 class<= ] unit-test [ t ] [ array mx1 class<= ] unit-test
[ f ] [ mx1 number class<= ] unit-test [ f ] [ mx1 number class<= ] unit-test

22
core/classes/tuple/parser/parser-tests.factor
View File

@ -50,20 +50,20 @@ TUPLE: test-8 { b integer read-only } ;
DEFER: foo DEFER: foo
[ "IN: classes.tuple.parser.tests TUPLE: foo < test-1 < ;" eval ] [ "IN: classes.tuple.parser.tests TUPLE: foo < test-1 < ;" (( -- )) eval ]
[ error>> invalid-slot-name? ] [ error>> invalid-slot-name? ]
must-fail-with must-fail-with
[ "IN: classes.tuple.parser.tests TUPLE: foo :" eval ] [ "IN: classes.tuple.parser.tests TUPLE: foo :" (( -- )) eval ]
[ error>> invalid-slot-name? ] [ error>> invalid-slot-name? ]
must-fail-with must-fail-with
[ "IN: classes.tuple.parser.tests TUPLE: foo" eval ] [ "IN: classes.tuple.parser.tests TUPLE: foo" (( -- )) eval ]
[ error>> unexpected-eof? ] [ error>> unexpected-eof? ]
must-fail-with must-fail-with
2 [ 2 [
[ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { slot dll } ;" eval ] [ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { slot dll } ;" (( -- )) eval ]
[ error>> no-initial-value? ] [ error>> no-initial-value? ]
must-fail-with must-fail-with
@ -71,14 +71,14 @@ must-fail-with
] times ] times
2 [ 2 [
[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo { slot array initial: 5 } ;" eval ] [ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo { slot array initial: 5 } ;" (( -- )) eval ]
[ error>> bad-initial-value? ] [ error>> bad-initial-value? ]
must-fail-with must-fail-with
[ f ] [ \ foo tuple-class? ] unit-test [ f ] [ \ foo tuple-class? ] unit-test
] times ] times
[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo slot { slot array } ;" eval ] [ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo slot { slot array } ;" (( -- )) eval ]
[ error>> duplicate-slot-names? ] [ error>> duplicate-slot-names? ]
must-fail-with must-fail-with
@ -107,7 +107,7 @@ TUPLE: parsing-corner-case x ;
" f" " f"
" 3" " 3"
"}" "}"
} "\n" join eval } "\n" join (( -- tuple )) eval
] unit-test ] unit-test
[ T{ parsing-corner-case f 3 } ] [ [ T{ parsing-corner-case f 3 } ] [
@ -116,7 +116,7 @@ TUPLE: parsing-corner-case x ;
"T{ parsing-corner-case" "T{ parsing-corner-case"
" { x 3 }" " { x 3 }"
"}" "}"
} "\n" join eval } "\n" join (( -- tuple )) eval
] unit-test ] unit-test
[ T{ parsing-corner-case f 3 } ] [ [ T{ parsing-corner-case f 3 } ] [
@ -125,7 +125,7 @@ TUPLE: parsing-corner-case x ;
"T{ parsing-corner-case {" "T{ parsing-corner-case {"
" x 3 }" " x 3 }"
"}" "}"
} "\n" join eval } "\n" join (( -- tuple )) eval
] unit-test ] unit-test
@ -133,12 +133,12 @@ TUPLE: parsing-corner-case x ;
{ {
"USE: classes.tuple.parser.tests T{ parsing-corner-case" "USE: classes.tuple.parser.tests T{ parsing-corner-case"
" { x 3 }" " { x 3 }"
} "\n" join eval } "\n" join (( -- tuple )) eval
] [ error>> unexpected-eof? ] must-fail-with ] [ error>> unexpected-eof? ] must-fail-with
[ [
{ {
"USE: classes.tuple.parser.tests T{ parsing-corner-case {" "USE: classes.tuple.parser.tests T{ parsing-corner-case {"
" x 3 }" " x 3 }"
} "\n" join eval } "\n" join (( -- tuple )) eval
] [ error>> unexpected-eof? ] must-fail-with ] [ error>> unexpected-eof? ] must-fail-with

86
core/classes/tuple/tuple-tests.factor
View File

@ -27,7 +27,7 @@ C: <redefinition-test> redefinition-test
[ t ] [ "redefinition-test" get redefinition-test? ] unit-test [ t ] [ "redefinition-test" get redefinition-test? ] unit-test
"IN: classes.tuple.tests TUPLE: redefinition-test ;" eval "IN: classes.tuple.tests TUPLE: redefinition-test ;" (( -- )) eval
[ t ] [ "redefinition-test" get redefinition-test? ] unit-test [ t ] [ "redefinition-test" get redefinition-test? ] unit-test
@ -39,7 +39,7 @@ C: <point> point
[ ] [ 100 200 <point> "p" set ] unit-test [ ] [ 100 200 <point> "p" set ] unit-test
! Use eval to sequence parsing explicitly ! Use eval to sequence parsing explicitly
[ ] [ "IN: classes.tuple.tests TUPLE: point x y z ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: point x y z ;" (( -- )) eval ] unit-test
[ 100 ] [ "p" get x>> ] unit-test [ 100 ] [ "p" get x>> ] unit-test
[ 200 ] [ "p" get y>> ] unit-test [ 200 ] [ "p" get y>> ] unit-test
@ -51,7 +51,7 @@ C: <point> point
[ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test [ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: point z y ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: point z y ;" (( -- )) eval ] unit-test
[ 2 ] [ "p" get tuple-size ] unit-test [ 2 ] [ "p" get tuple-size ] unit-test
@ -89,7 +89,7 @@ C: <empty> empty
[ t length ] [ object>> t eq? ] must-fail-with [ t length ] [ object>> t eq? ] must-fail-with
[ "<constructor-test>" ] [ "<constructor-test>" ]
[ "IN: classes.tuple.test TUPLE: constructor-test ; C: <constructor-test> constructor-test" eval word name>> ] unit-test [ "IN: classes.tuple.test TUPLE: constructor-test ; C: <constructor-test> constructor-test" (( -- )) eval word name>> ] unit-test
TUPLE: size-test a b c d ; TUPLE: size-test a b c d ;
@ -102,7 +102,7 @@ GENERIC: <yo-momma> ( a -- b )
TUPLE: yo-momma ; TUPLE: yo-momma ;
[ ] [ "IN: classes.tuple.tests C: <yo-momma> yo-momma" eval ] unit-test [ ] [ "IN: classes.tuple.tests C: <yo-momma> yo-momma" (( -- )) eval ] unit-test
[ f ] [ \ <yo-momma> generic? ] unit-test [ f ] [ \ <yo-momma> generic? ] unit-test
@ -204,7 +204,7 @@ C: <erg's-reshape-problem> erg's-reshape-problem
: cons-test-1 ( -- tuple ) \ erg's-reshape-problem new ; : cons-test-1 ( -- tuple ) \ erg's-reshape-problem new ;
: cons-test-2 ( a b c d -- tuple ) \ erg's-reshape-problem boa ; : cons-test-2 ( a b c d -- tuple ) \ erg's-reshape-problem boa ;
[ ] [ "IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" (( -- )) eval ] unit-test
[ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test [ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test
@ -281,13 +281,13 @@ test-server-slot-values
] unit-test ] unit-test
[ [
"IN: classes.tuple.tests TUPLE: bad-superclass < word ;" eval "IN: classes.tuple.tests TUPLE: bad-superclass < word ;" (( -- )) eval
] must-fail ] must-fail
! Dynamically changing inheritance hierarchy ! Dynamically changing inheritance hierarchy
TUPLE: electronic-device ; TUPLE: electronic-device ;
[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ;" (( -- )) eval ] unit-test
[ f ] [ electronic-device laptop class<= ] unit-test [ f ] [ electronic-device laptop class<= ] unit-test
[ t ] [ server electronic-device class<= ] unit-test [ t ] [ server electronic-device class<= ] unit-test
@ -303,17 +303,17 @@ TUPLE: electronic-device ;
[ f ] [ "server" get laptop? ] unit-test [ f ] [ "server" get laptop? ] unit-test
[ t ] [ "server" get server? ] unit-test [ t ] [ "server" get server? ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ;" (( -- )) eval ] unit-test
[ f ] [ "laptop" get electronic-device? ] unit-test [ f ] [ "laptop" get electronic-device? ] unit-test
[ t ] [ "laptop" get computer? ] unit-test [ t ] [ "laptop" get computer? ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ;" (( -- )) eval ] unit-test
test-laptop-slot-values test-laptop-slot-values
test-server-slot-values test-server-slot-values
[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ;" (( -- )) eval ] unit-test
test-laptop-slot-values test-laptop-slot-values
test-server-slot-values test-server-slot-values
@ -326,7 +326,7 @@ TUPLE: make-me-some-accessors voltage grounded? ;
[ ] [ "laptop" get 220 >>voltage drop ] unit-test [ ] [ "laptop" get 220 >>voltage drop ] unit-test
[ ] [ "server" get 110 >>voltage drop ] unit-test [ ] [ "server" get 110 >>voltage drop ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ;" (( -- )) eval ] unit-test
test-laptop-slot-values test-laptop-slot-values
test-server-slot-values test-server-slot-values
@ -334,7 +334,7 @@ test-server-slot-values
[ 220 ] [ "laptop" get voltage>> ] unit-test [ 220 ] [ "laptop" get voltage>> ] unit-test
[ 110 ] [ "server" get voltage>> ] unit-test [ 110 ] [ "server" get voltage>> ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ;" (( -- )) eval ] unit-test
test-laptop-slot-values test-laptop-slot-values
test-server-slot-values test-server-slot-values
@ -343,7 +343,7 @@ test-server-slot-values
[ 110 ] [ "server" get voltage>> ] unit-test [ 110 ] [ "server" get voltage>> ] unit-test
! Reshaping superclass and subclass simultaneously ! Reshaping superclass and subclass simultaneously
[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ;" (( -- )) eval ] unit-test
test-laptop-slot-values test-laptop-slot-values
test-server-slot-values test-server-slot-values
@ -364,11 +364,11 @@ C: <test2> test2
test-a/b test-a/b
[ ] [ "IN: classes.tuple.tests TUPLE: test1 a x ; TUPLE: test2 < test1 b y ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: test1 a x ; TUPLE: test2 < test1 b y ;" (( -- )) eval ] unit-test
test-a/b test-a/b
[ ] [ "IN: classes.tuple.tests TUPLE: test1 a ; TUPLE: test2 < test1 b ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: test1 a ; TUPLE: test2 < test1 b ;" (( -- )) eval ] unit-test
test-a/b test-a/b
@ -393,19 +393,19 @@ T{ move-up-2 f "a" "b" "c" } "move-up" set
test-move-up test-move-up
[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a b c ; TUPLE: move-up-2 < move-up-1 ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a b c ; TUPLE: move-up-2 < move-up-1 ;" (( -- )) eval ] unit-test
test-move-up test-move-up
[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a c ; TUPLE: move-up-2 < move-up-1 b ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a c ; TUPLE: move-up-2 < move-up-1 b ;" (( -- )) eval ] unit-test
test-move-up test-move-up
[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 c ; TUPLE: move-up-2 < move-up-1 b a ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 c ; TUPLE: move-up-2 < move-up-1 b a ;" (( -- )) eval ] unit-test
test-move-up test-move-up
[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 ; TUPLE: move-up-2 < move-up-1 a b c ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 ; TUPLE: move-up-2 < move-up-1 a b c ;" (( -- )) eval ] unit-test
! Constructors must be recompiled when changing superclass ! Constructors must be recompiled when changing superclass
TUPLE: constructor-update-1 xxx ; TUPLE: constructor-update-1 xxx ;
@ -416,7 +416,7 @@ C: <constructor-update-2> constructor-update-2
{ 3 1 } [ <constructor-update-2> ] must-infer-as { 3 1 } [ <constructor-update-2> ] must-infer-as
[ ] [ "IN: classes.tuple.tests TUPLE: constructor-update-1 xxx ttt www ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: constructor-update-1 xxx ttt www ;" (( -- )) eval ] unit-test
{ 5 1 } [ <constructor-update-2> ] must-infer-as { 5 1 } [ <constructor-update-2> ] must-infer-as
@ -431,7 +431,7 @@ UNION: redefinition-problem' redefinition-problem integer ;
TUPLE: redefinition-problem-2 ; TUPLE: redefinition-problem-2 ;
"IN: classes.tuple.tests TUPLE: redefinition-problem < redefinition-problem-2 ;" eval "IN: classes.tuple.tests TUPLE: redefinition-problem < redefinition-problem-2 ;" (( -- )) eval
[ t ] [ 3 redefinition-problem'? ] unit-test [ t ] [ 3 redefinition-problem'? ] unit-test
@ -472,7 +472,7 @@ USE: vocabs
] with-compilation-unit ] with-compilation-unit
] unit-test ] unit-test
[ "USE: words T{ word }" eval ] [ "USE: words T{ word }" (( -- )) eval ]
[ error>> T{ no-method f word new } = ] [ error>> T{ no-method f word new } = ]
must-fail-with must-fail-with
@ -485,7 +485,7 @@ must-fail-with
[ t ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test [ t ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test
: accessor-exists? ( class name -- ? ) : accessor-exists? ( name -- ? )
[ "forget-accessors-test" "classes.tuple.tests" lookup ] dip [ "forget-accessors-test" "classes.tuple.tests" lookup ] dip
">>" append "accessors" lookup method >boolean ; ">>" append "accessors" lookup method >boolean ;
@ -520,13 +520,13 @@ TUPLE: another-forget-accessors-test ;
[ f ] [ [ f ] [
t parser-notes? [ t parser-notes? [
[ [
"IN: classes.tuple.tests TUPLE: shadow-1 a b ; TUPLE: shadow-2 < shadow-1 a b ;" eval "IN: classes.tuple.tests TUPLE: shadow-1 a b ; TUPLE: shadow-2 < shadow-1 a b ;" (( -- )) eval
] with-string-writer empty? ] with-string-writer empty?
] with-variable ] with-variable
] unit-test ] unit-test
! Missing error check ! Missing error check
[ "IN: classes.tuple.tests USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail [ "IN: classes.tuple.tests USE: words TUPLE: wrong-superclass < word ;" (( -- )) eval ] must-fail
! Class forget messyness ! Class forget messyness
TUPLE: subclass-forget-test ; TUPLE: subclass-forget-test ;
@ -535,7 +535,7 @@ TUPLE: subclass-forget-test-1 < subclass-forget-test ;
TUPLE: subclass-forget-test-2 < subclass-forget-test ; TUPLE: subclass-forget-test-2 < subclass-forget-test ;
TUPLE: subclass-forget-test-3 < subclass-forget-test-2 ; TUPLE: subclass-forget-test-3 < subclass-forget-test-2 ;
[ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval ] unit-test [ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" (( -- )) eval ] unit-test
[ { subclass-forget-test-2 } ] [ { subclass-forget-test-2 } ]
[ subclass-forget-test-2 class-usages ] [ subclass-forget-test-2 class-usages ]
@ -549,7 +549,7 @@ unit-test
[ f ] [ subclass-forget-test-2 tuple-class? ] unit-test [ f ] [ subclass-forget-test-2 tuple-class? ] unit-test
[ subclass-forget-test-3 new ] must-fail [ subclass-forget-test-3 new ] must-fail
[ "IN: classes.tuple.tests TUPLE: subclass-forget-test-4 < subclass-forget-test-2 ;" eval ] must-fail [ "IN: classes.tuple.tests TUPLE: subclass-forget-test-4 < subclass-forget-test-2 ;" (( -- )) eval ] must-fail
! More ! More
DEFER: subclass-reset-test DEFER: subclass-reset-test
@ -562,11 +562,11 @@ GENERIC: break-me ( obj -- )
[ ] [ [ M\ integer break-me forget ] with-compilation-unit ] unit-test [ ] [ [ M\ integer break-me forget ] with-compilation-unit ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test ;" <string-reader> "subclass-reset-test" parse-stream drop ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test ;" <string-reader> "subclass-reset-test" parse-stream drop ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-1 < subclass-reset-test ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-1 < subclass-reset-test ;" (( -- )) eval ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-2 < subclass-reset-test ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-2 < subclass-reset-test ;" (( -- )) eval ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-3 < subclass-reset-test-2 ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-3 < subclass-reset-test-2 ;" (( -- )) eval ] unit-test
[ ] [ "IN: classes.tuple.tests USE: kernel M: subclass-reset-test-1 break-me drop ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests USE: kernel M: subclass-reset-test-1 break-me drop ;" (( -- )) eval ] unit-test
[ ] [ "IN: classes.tuple.tests : subclass-reset-test ( -- ) ;" <string-reader> "subclass-reset-test" parse-stream drop ] unit-test [ ] [ "IN: classes.tuple.tests : subclass-reset-test ( -- ) ;" <string-reader> "subclass-reset-test" parse-stream drop ] unit-test
@ -576,7 +576,7 @@ GENERIC: break-me ( obj -- )
[ t ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test [ t ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test
[ ] [ "IN: classes.tuple.tests USE: math USE: kernel M: integer break-me drop ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests USE: math USE: kernel M: integer break-me drop ;" (( -- )) eval ] unit-test
[ f ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test [ f ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test
@ -632,7 +632,7 @@ TUPLE: reshape-test x ;
T{ reshape-test f "hi" } "tuple" set T{ reshape-test f "hi" } "tuple" set
[ ] [ "IN: classes.tuple.tests TUPLE: reshape-test { x read-only } ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: reshape-test { x read-only } ;" (( -- )) eval ] unit-test
[ f ] [ \ reshape-test \ (>>x) method ] unit-test [ f ] [ \ reshape-test \ (>>x) method ] unit-test
@ -640,11 +640,11 @@ T{ reshape-test f "hi" } "tuple" set
[ "hi" ] [ "tuple" get x>> ] unit-test [ "hi" ] [ "tuple" get x>> ] unit-test
[ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x integer read-only } ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x integer read-only } ;" (( -- )) eval ] unit-test
[ 0 ] [ "tuple" get x>> ] unit-test [ 0 ] [ "tuple" get x>> ] unit-test
[ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x fixnum initial: 4 read-only } ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x fixnum initial: 4 read-only } ;" (( -- )) eval ] unit-test
[ 0 ] [ "tuple" get x>> ] unit-test [ 0 ] [ "tuple" get x>> ] unit-test
@ -660,20 +660,20 @@ ERROR: error-class-test a b c ;
[ "( a b c -- * )" ] [ \ error-class-test stack-effect effect>string ] unit-test [ "( a b c -- * )" ] [ \ error-class-test stack-effect effect>string ] unit-test
[ f ] [ \ error-class-test "inline" word-prop ] unit-test [ f ] [ \ error-class-test "inline" word-prop ] unit-test
[ "IN: classes.tuple.tests ERROR: error-x ; : error-x 3 ;" eval ] [ "IN: classes.tuple.tests ERROR: error-x ; : error-x 3 ;" (( -- )) eval ]
[ error>> error>> redefine-error? ] must-fail-with [ error>> error>> redefine-error? ] must-fail-with
DEFER: error-y DEFER: error-y
[ ] [ [ \ error-y dup class? [ forget-class ] [ drop ] if ] with-compilation-unit ] unit-test [ ] [ [ \ error-y dup class? [ forget-class ] [ drop ] if ] with-compilation-unit ] unit-test
[ ] [ "IN: classes.tuple.tests GENERIC: error-y ( a -- b )" eval ] unit-test [ ] [ "IN: classes.tuple.tests GENERIC: error-y ( a -- b )" (( -- )) eval ] unit-test
[ f ] [ \ error-y tuple-class? ] unit-test [ f ] [ \ error-y tuple-class? ] unit-test
[ t ] [ \ error-y generic? ] unit-test [ t ] [ \ error-y generic? ] unit-test
[ ] [ "IN: classes.tuple.tests ERROR: error-y ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests ERROR: error-y ;" (( -- )) eval ] unit-test
[ t ] [ \ error-y tuple-class? ] unit-test [ t ] [ \ error-y tuple-class? ] unit-test
@ -694,7 +694,7 @@ DEFER: error-y
] unit-test ] unit-test
[ ] [ [ ] [
"IN: sequences TUPLE: reversed { seq read-only } ;" eval "IN: sequences TUPLE: reversed { seq read-only } ;" (( -- )) eval
] unit-test ] unit-test
TUPLE: bogus-hashcode-1 x ; TUPLE: bogus-hashcode-1 x ;
@ -735,14 +735,14 @@ SLOT: kex
DEFER: redefine-tuple-twice DEFER: redefine-tuple-twice
[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" (( -- )) eval ] unit-test
[ t ] [ \ redefine-tuple-twice symbol? ] unit-test [ t ] [ \ redefine-tuple-twice symbol? ] unit-test
[ ] [ "IN: classes.tuple.tests DEFER: redefine-tuple-twice" eval ] unit-test [ ] [ "IN: classes.tuple.tests DEFER: redefine-tuple-twice" (( -- )) eval ] unit-test
[ t ] [ \ redefine-tuple-twice deferred? ] unit-test [ t ] [ \ redefine-tuple-twice deferred? ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" (( -- )) eval ] unit-test
[ t ] [ \ redefine-tuple-twice symbol? ] unit-test [ t ] [ \ redefine-tuple-twice symbol? ] unit-test

6
core/classes/union/union-tests.factor
View File

@ -26,13 +26,13 @@ M: union-1 generic-update-test drop "union-1" ;
[ t ] [ union-1 number class<= ] unit-test [ t ] [ union-1 number class<= ] unit-test
[ "union-1" ] [ 1.0 generic-update-test ] unit-test [ "union-1" ] [ 1.0 generic-update-test ] unit-test
"IN: classes.union.tests USE: math USE: arrays UNION: union-1 rational array ;" eval "IN: classes.union.tests USE: math USE: arrays UNION: union-1 rational array ;" (( -- )) eval
[ t ] [ bignum union-1 class<= ] unit-test [ t ] [ bignum union-1 class<= ] unit-test
[ f ] [ union-1 number class<= ] unit-test [ f ] [ union-1 number class<= ] unit-test
[ "union-1" ] [ { 1.0 } generic-update-test ] unit-test [ "union-1" ] [ { 1.0 } generic-update-test ] unit-test
"IN: classes.union.tests USE: math PREDICATE: union-1 < integer even? ;" eval "IN: classes.union.tests USE: math PREDICATE: union-1 < integer even? ;" (( -- )) eval
[ f ] [ union-1 union-class? ] unit-test [ f ] [ union-1 union-class? ] unit-test
[ t ] [ union-1 predicate-class? ] unit-test [ t ] [ union-1 predicate-class? ] unit-test
@ -58,7 +58,7 @@ UNION: redefine-bug-2 redefine-bug-1 quotation ;
[ t ] [ fixnum redefine-bug-2 class<= ] unit-test [ t ] [ fixnum redefine-bug-2 class<= ] unit-test
[ t ] [ quotation redefine-bug-2 class<= ] unit-test [ t ] [ quotation redefine-bug-2 class<= ] unit-test
[ ] [ "IN: classes.union.tests USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test [ ] [ "IN: classes.union.tests USE: math UNION: redefine-bug-1 bignum ;" (( -- )) eval ] unit-test
[ t ] [ bignum redefine-bug-1 class<= ] unit-test [ t ] [ bignum redefine-bug-1 class<= ] unit-test
[ f ] [ fixnum redefine-bug-2 class<= ] unit-test [ f ] [ fixnum redefine-bug-2 class<= ] unit-test

2
core/combinators/combinators-tests.factor
View File

@ -357,7 +357,7 @@ DEFER: corner-case-1
[ 4 ] [ 2 2 [ + ] curry 1array case ] unit-test [ 4 ] [ 2 2 [ + ] curry 1array case ] unit-test
: test-case-8 ( n -- ) : test-case-8 ( n -- string )
{ {
{ 1 [ "foo" ] } { 1 [ "foo" ] }
} case ; } case ;

2
core/compiler/units/units-tests.factor
View File

@ -56,6 +56,6 @@ observer add-definition-observer
DEFER: nesting-test DEFER: nesting-test
[ ] [ "IN: compiler.units.tests << : nesting-test ( -- ) ; >>" eval ] unit-test [ ] [ "IN: compiler.units.tests << : nesting-test ( -- ) ; >>" (( -- )) eval ] unit-test
observer remove-definition-observer observer remove-definition-observer

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

@ -3,7 +3,7 @@ continuations debugger parser memory arrays words
kernel.private accessors eval ; kernel.private accessors eval ;
IN: continuations.tests IN: continuations.tests
: (callcc1-test) ( -- ) : (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) ;
@ -59,7 +59,7 @@ IN: continuations.tests
! : callstack-overflow callstack-overflow f ; ! : callstack-overflow callstack-overflow f ;
! [ callstack-overflow ] must-fail ! [ callstack-overflow ] must-fail
: don't-compile-me ( -- ) { } [ ] each ; : don't-compile-me ( n -- ) { } [ ] each ;
: foo ( -- ) callstack "c" set 3 don't-compile-me ; : foo ( -- ) callstack "c" set 3 don't-compile-me ;
: bar ( -- a b ) 1 foo 2 ; : bar ( -- a b ) 1 foo 2 ;

18
core/generic/generic-tests.factor
View File

@ -65,11 +65,11 @@ M: number union-containment drop 2 ;
[ 2 ] [ 1.0 union-containment ] unit-test [ 2 ] [ 1.0 union-containment ] unit-test
! Testing recovery from bad method definitions ! Testing recovery from bad method definitions
"IN: generic.tests GENERIC: unhappy ( x -- x )" eval "IN: generic.tests GENERIC: unhappy ( x -- x )" (( -- )) eval
[ [
"IN: generic.tests M: dictionary unhappy ;" eval "IN: generic.tests M: dictionary unhappy ;" (( -- )) eval
] must-fail ] must-fail
[ ] [ "IN: generic.tests GENERIC: unhappy ( x -- x )" eval ] unit-test [ ] [ "IN: generic.tests GENERIC: unhappy ( x -- x )" (( -- )) eval ] unit-test
GENERIC# complex-combination 1 ( a b -- c ) GENERIC# complex-combination 1 ( a b -- c )
M: string complex-combination drop ; M: string complex-combination drop ;
@ -177,7 +177,7 @@ M: f generic-forget-test-3 ;
[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test [ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
[ ] [ "IN: generic.tests M: f generic-forget-test-3 ;" eval ] unit-test [ ] [ "IN: generic.tests M: f generic-forget-test-3 ;" (( -- )) eval ] unit-test
[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test [ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
@ -193,7 +193,7 @@ M: integer a-generic a-word ;
[ t ] [ "m" get \ a-word usage memq? ] unit-test [ t ] [ "m" get \ a-word usage memq? ] unit-test
[ ] [ "IN: generic.tests : a-generic ( -- ) ;" eval ] unit-test [ ] [ "IN: generic.tests : a-generic ( -- ) ;" (( -- )) eval ] unit-test
[ f ] [ "m" get \ a-word usage memq? ] unit-test [ f ] [ "m" get \ a-word usage memq? ] unit-test
@ -207,25 +207,25 @@ M: integer a-generic a-word ;
M: boii jeah ; M: boii jeah ;
GENERIC: jeah* ( a -- b ) GENERIC: jeah* ( a -- b )
M: boii jeah* jeah ; M: boii jeah* jeah ;
"> eval "> (( -- )) eval
<" <"
IN: compiler.tests IN: compiler.tests
FORGET: boii FORGET: boii
"> eval "> (( -- )) eval
<" <"
IN: compiler.tests IN: compiler.tests
TUPLE: boii ; TUPLE: boii ;
M: boii jeah ; M: boii jeah ;
"> eval "> (( -- )) eval
] unit-test ] unit-test
! call-next-method cache test ! call-next-method cache test
GENERIC: c-n-m-cache ( a -- b ) GENERIC: c-n-m-cache ( a -- b )
! Force it to be unoptimized ! Force it to be unoptimized
M: fixnum c-n-m-cache { } [ ] like call call-next-method ; M: fixnum c-n-m-cache { } [ ] like call( -- ) call-next-method ;
M: integer c-n-m-cache 1 + ; M: integer c-n-m-cache 1 + ;
M: number c-n-m-cache ; M: number c-n-m-cache ;

2
core/generic/standard/standard-tests.factor
View File

@ -66,7 +66,7 @@ M: circle area radius>> sq pi * ;
GENERIC: perimiter ( shape -- n ) GENERIC: perimiter ( shape -- n )
: rectangle-perimiter ( n -- n ) + 2 * ; : rectangle-perimiter ( l w -- n ) + 2 * ;
M: rectangle perimiter M: rectangle perimiter
[ width>> ] [ height>> ] bi [ width>> ] [ height>> ] bi

4
core/kernel/kernel-tests.factor
View File

@ -27,7 +27,7 @@ IN: kernel.tests
[ ] [ :c ] unit-test [ ] [ :c ] unit-test
: (overflow-d-alt) ( -- ) 3 ; : (overflow-d-alt) ( -- n ) 3 ;
: overflow-d-alt ( -- ) (overflow-d-alt) overflow-d-alt ; : overflow-d-alt ( -- ) (overflow-d-alt) overflow-d-alt ;
@ -107,7 +107,7 @@ IN: kernel.tests
! Regression ! Regression
: (loop) ( a b c d -- ) : (loop) ( a b c d -- )
[ pick ] dip swap [ pick ] dip swap [ pick ] dip swap [ pick ] dip swap
< [ [ 1+ ] 3dip (loop) ] [ 2drop 2drop ] if ; inline < [ [ 1+ ] 3dip (loop) ] [ 2drop 2drop ] if ; inline recursive
: loop ( obj obj -- ) : loop ( obj obj -- )
H{ } values swap [ dup length swap ] dip 0 -roll (loop) ; H{ } values swap [ dup length swap ] dip 0 -roll (loop) ;

2
core/memory/memory-tests.factor
View File

@ -15,7 +15,7 @@ IN: memory.tests
[ [ ] instances ] must-infer [ [ ] instances ] must-infer
! Code GC wasn't kicking in when needed ! Code GC wasn't kicking in when needed
: leak-step ( -- ) 800000 f <array> 1quotation call drop ; : leak-step ( -- ) 800000 f <array> 1quotation call( -- obj ) drop ;
: leak-loop ( -- ) 100 [ leak-step ] times ; : leak-loop ( -- ) 100 [ leak-step ] times ;

94
core/parser/parser-tests.factor
View File

@ -10,43 +10,43 @@ IN: parser.tests
[ [
[ 1 [ 2 [ 3 ] 4 ] 5 ] [ 1 [ 2 [ 3 ] 4 ] 5 ]
[ "1\n[\n2\n[\n3\n]\n4\n]\n5" eval ] [ "1\n[\n2\n[\n3\n]\n4\n]\n5" (( -- a b c )) eval ]
unit-test unit-test
[ t t f f ] [ t t f f ]
[ "t t f f" eval ] [ "t t f f" (( -- ? ? ? ? )) eval ]
unit-test unit-test
[ "hello world" ] [ "hello world" ]
[ "\"hello world\"" eval ] [ "\"hello world\"" (( -- string )) eval ]
unit-test unit-test
[ "\n\r\t\\" ] [ "\n\r\t\\" ]
[ "\"\\n\\r\\t\\\\\"" eval ] [ "\"\\n\\r\\t\\\\\"" (( -- string )) eval ]
unit-test unit-test
[ "hello world" ] [ "hello world" ]
[ [
"IN: parser.tests : hello ( -- str ) \"hello world\" ;" "IN: parser.tests : hello ( -- str ) \"hello world\" ;"
eval "USE: parser.tests hello" eval (( -- )) eval "USE: parser.tests hello" (( -- string )) eval
] unit-test ] unit-test
[ ] [ ]
[ "! This is a comment, people." eval ] [ "! This is a comment, people." (( -- )) eval ]
unit-test unit-test
! Test escapes ! Test escapes
[ " " ] [ " " ]
[ "\"\\u000020\"" eval ] [ "\"\\u000020\"" (( -- string )) eval ]
unit-test unit-test
[ "'" ] [ "'" ]
[ "\"\\u000027\"" eval ] [ "\"\\u000027\"" (( -- string )) eval ]
unit-test unit-test
! Test EOL comments in multiline strings. ! Test EOL comments in multiline strings.
[ "Hello" ] [ "#! This calls until-eol.\n\"Hello\"" eval ] unit-test [ "Hello" ] [ "#! This calls until-eol.\n\"Hello\"" (( -- string )) eval ] unit-test
[ word ] [ \ f class ] unit-test [ word ] [ \ f class ] unit-test
@ -68,7 +68,7 @@ IN: parser.tests
[ \ baz "declared-effect" word-prop terminated?>> ] [ \ baz "declared-effect" word-prop terminated?>> ]
unit-test unit-test
[ ] [ "IN: parser.tests USE: math : effect-parsing-test ( a b -- d ) - ;" eval ] unit-test [ ] [ "IN: parser.tests USE: math : effect-parsing-test ( a b -- d ) - ;" (( -- )) eval ] unit-test
[ t ] [ [ t ] [
"effect-parsing-test" "parser.tests" lookup "effect-parsing-test" "parser.tests" lookup
@ -79,14 +79,14 @@ IN: parser.tests
[ \ effect-parsing-test "declared-effect" word-prop ] unit-test [ \ effect-parsing-test "declared-effect" word-prop ] unit-test
! Funny bug ! Funny bug
[ 2 ] [ "IN: parser.tests : \0. ( -- x ) 2 ; \0." eval ] unit-test [ 2 ] [ "IN: parser.tests : \0. ( -- x ) 2 ; \0." (( -- n )) eval ] unit-test
[ "IN: parser.tests : missing-- ( a b ) ;" eval ] must-fail [ "IN: parser.tests : missing-- ( a b ) ;" (( -- )) eval ] must-fail
! These should throw errors ! These should throw errors
[ "HEX: zzz" eval ] must-fail [ "HEX: zzz" (( -- obj )) eval ] must-fail
[ "OCT: 999" eval ] must-fail [ "OCT: 999" (( -- obj )) eval ] must-fail
[ "BIN: --0" eval ] must-fail [ "BIN: --0" (( -- obj )) eval ] must-fail
! Another funny bug ! Another funny bug
[ t ] [ [ t ] [
@ -102,14 +102,14 @@ IN: parser.tests
] unit-test ] unit-test
DEFER: foo DEFER: foo
"IN: parser.tests USING: math prettyprint ; SYNTAX: foo 2 2 + . ;" eval "IN: parser.tests USING: math prettyprint ; SYNTAX: foo 2 2 + . ;" (( -- )) eval
[ ] [ "USE: parser.tests foo" eval ] unit-test [ ] [ "USE: parser.tests foo" (( -- )) eval ] unit-test
"IN: parser.tests USING: math prettyprint ; : foo ( -- ) 2 2 + . ;" eval "IN: parser.tests USING: math prettyprint ; : foo ( -- ) 2 2 + . ;" (( -- )) eval
[ t ] [ [ t ] [
"USE: parser.tests \\ foo" eval "USE: parser.tests \\ foo" (( -- word )) eval
"foo" "parser.tests" lookup eq? "foo" "parser.tests" lookup eq?
] unit-test ] unit-test
@ -269,12 +269,12 @@ IN: parser.tests
] unit-test ] unit-test
[ ] [ [ ] [
"IN: parser.tests : <bogus-error> ( -- ) ; : bogus ( -- ) <bogus-error> ;" "IN: parser.tests : <bogus-error> ( -- ) ; : bogus ( -- error ) <bogus-error> ;"
<string-reader> "bogus-error" parse-stream drop <string-reader> "bogus-error" parse-stream drop
] unit-test ] unit-test
[ ] [ [ ] [
"IN: parser.tests TUPLE: bogus-error ; C: <bogus-error> bogus-error : bogus ( -- ) <bogus-error> ;" "IN: parser.tests TUPLE: bogus-error ; C: <bogus-error> bogus-error : bogus ( -- error ) <bogus-error> ;"
<string-reader> "bogus-error" parse-stream drop <string-reader> "bogus-error" parse-stream drop
] unit-test ] unit-test
@ -339,16 +339,16 @@ IN: parser.tests
] [ error>> error>> error>> redefine-error? ] must-fail-with ] [ error>> error>> error>> redefine-error? ] must-fail-with
[ ] [ [ ] [
"IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval "IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" (( -- )) eval
] unit-test ] unit-test
[ [
"IN: parser.tests : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" eval "IN: parser.tests : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" (( -- )) eval
] must-fail ] must-fail
] with-file-vocabs ] with-file-vocabs
[ ] [ [ ] [
"IN: parser.tests USE: kernel PREDICATE: foo < object ( x -- y ) ;" eval "IN: parser.tests USE: kernel PREDICATE: foo < object ( x -- y ) ;" (( -- )) eval
] unit-test ] unit-test
[ t ] [ [ t ] [
@ -422,31 +422,31 @@ IN: parser.tests
] unit-test ] unit-test
[ [
"USE: this-better-not-exist" eval "USE: this-better-not-exist" (( -- )) eval
] must-fail ] must-fail
[ ": foo ;" eval ] [ error>> error>> no-current-vocab? ] must-fail-with [ ": foo ;" (( -- )) eval ] [ error>> error>> no-current-vocab? ] must-fail-with
[ 92 ] [ "CHAR: \\" eval ] unit-test [ 92 ] [ "CHAR: \\" (( -- n )) eval ] unit-test
[ 92 ] [ "CHAR: \\\\" eval ] unit-test [ 92 ] [ "CHAR: \\\\" (( -- n )) eval ] unit-test
[ ] [ [ ] [
{ {
"IN: parser.tests" "IN: parser.tests"
"USING: math arrays ;" "USING: math arrays kernel ;"
"GENERIC: change-combination ( a -- b )" "GENERIC: change-combination ( obj a -- b )"
"M: integer change-combination 1 ;" "M: integer change-combination 2drop 1 ;"
"M: array change-combination 2 ;" "M: array change-combination 2drop 2 ;"
} "\n" join <string-reader> "change-combination-test" parse-stream drop } "\n" join <string-reader> "change-combination-test" parse-stream drop
] unit-test ] unit-test
[ ] [ [ ] [
{ {
"IN: parser.tests" "IN: parser.tests"
"USING: math arrays ;" "USING: math arrays kernel ;"
"GENERIC# change-combination 1 ( a -- b )" "GENERIC# change-combination 1 ( obj a -- b )"
"M: integer change-combination 1 ;" "M: integer change-combination 2drop 1 ;"
"M: array change-combination 2 ;" "M: array change-combination 2drop 2 ;"
} "\n" join <string-reader> "change-combination-test" parse-stream drop } "\n" join <string-reader> "change-combination-test" parse-stream drop
] unit-test ] unit-test
@ -463,7 +463,7 @@ IN: parser.tests
] unit-test ] unit-test
[ [ ] ] [ [ [ ] ] [
"IN: parser.tests : staging-problem-test-1 ( -- ) 1 ; : staging-problem-test-2 ( -- ) staging-problem-test-1 ;" "IN: parser.tests : staging-problem-test-1 ( -- a ) 1 ; : staging-problem-test-2 ( -- a ) staging-problem-test-1 ;"
<string-reader> "staging-problem-test" parse-stream <string-reader> "staging-problem-test" parse-stream
] unit-test ] unit-test
@ -472,7 +472,7 @@ IN: parser.tests
[ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test [ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test
[ [ ] ] [ [ [ ] ] [
"IN: parser.tests << : staging-problem-test-1 ( -- ) 1 ; >> : staging-problem-test-2 ( -- ) staging-problem-test-1 ;" "IN: parser.tests << : staging-problem-test-1 ( -- a ) 1 ; >> : staging-problem-test-2 ( -- a ) staging-problem-test-1 ;"
<string-reader> "staging-problem-test" parse-stream <string-reader> "staging-problem-test" parse-stream
] unit-test ] unit-test
@ -480,10 +480,10 @@ IN: parser.tests
[ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test [ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test
[ "DEFER: blahy" eval ] [ error>> error>> no-current-vocab? ] must-fail-with [ "DEFER: blahy" (( -- )) eval ] [ error>> error>> no-current-vocab? ] must-fail-with
[ [
"IN: parser.tests SYNTAX: blahy ; FORGET: blahy" eval "IN: parser.tests SYNTAX: blahy ; FORGET: blahy" (( -- )) eval
] [ ] [
error>> staging-violation? error>> staging-violation?
] must-fail-with ] must-fail-with
@ -491,12 +491,12 @@ IN: parser.tests
! Bogus error message ! Bogus error message
DEFER: blahy DEFER: blahy
[ "IN: parser.tests USE: kernel TUPLE: blahy < tuple ; : blahy ( -- ) ; TUPLE: blahy < tuple ; : blahy ( -- ) ;" eval ] [ "IN: parser.tests USE: kernel TUPLE: blahy < tuple ; : blahy ( -- ) ; TUPLE: blahy < tuple ; : blahy ( -- ) ;" (( -- )) eval ]
[ error>> error>> def>> \ blahy eq? ] must-fail-with [ error>> error>> def>> \ blahy eq? ] must-fail-with
[ ] [ f lexer set f file set "Hello world" note. ] unit-test [ ] [ f lexer set f file set "Hello world" note. ] unit-test
[ "CHAR: \\u9999999999999" eval ] must-fail [ "CHAR: \\u9999999999999" (( -- n )) eval ] must-fail
SYMBOLS: a b c ; SYMBOLS: a b c ;
@ -506,15 +506,15 @@ SYMBOLS: a b c ;
DEFER: blah DEFER: blah
[ ] [ "IN: parser.tests GENERIC: blah ( -- )" eval ] unit-test [ ] [ "IN: parser.tests GENERIC: blah ( -- )" (( -- )) eval ] unit-test
[ ] [ "IN: parser.tests SYMBOLS: blah ;" eval ] unit-test [ ] [ "IN: parser.tests SYMBOLS: blah ;" (( -- )) eval ] unit-test
[ f ] [ \ blah generic? ] unit-test [ f ] [ \ blah generic? ] unit-test
[ t ] [ \ blah symbol? ] unit-test [ t ] [ \ blah symbol? ] unit-test
DEFER: blah1 DEFER: blah1
[ "IN: parser.tests SINGLETONS: blah1 blah1 blah1 ;" eval ] [ "IN: parser.tests SINGLETONS: blah1 blah1 blah1 ;" (( -- )) eval ]
[ error>> error>> def>> \ blah1 eq? ] [ error>> error>> def>> \ blah1 eq? ]
must-fail-with must-fail-with
@ -545,10 +545,10 @@ EXCLUDE: qualified.tests.bar => x ;
[ 3 ] [ x ] unit-test [ 3 ] [ x ] unit-test
[ 4 ] [ y ] unit-test [ 4 ] [ y ] unit-test
[ "IN: qualified.tests FROM: qualified.tests => doesnotexist ;" eval ] [ "IN: qualified.tests FROM: qualified.tests => doesnotexist ;" (( -- )) eval ]
[ error>> no-word-error? ] must-fail-with [ error>> no-word-error? ] must-fail-with
[ "IN: qualified.tests RENAME: doesnotexist qualified.tests => blahx" eval ] [ "IN: qualified.tests RENAME: doesnotexist qualified.tests => blahx" (( -- )) eval ]
[ error>> no-word-error? ] must-fail-with [ error>> no-word-error? ] must-fail-with
! Two similar bugs ! Two similar bugs

4
core/slots/slots-tests.factor
View File

@ -25,12 +25,12 @@ TUPLE: hello length ;
[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test [ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test
! See if declarations are cleared on redefinition ! See if declarations are cleared on redefinition
[ ] [ "IN: slots.tests TUPLE: r/w-test { foo read-only } ;" eval ] unit-test [ ] [ "IN: slots.tests TUPLE: r/w-test { foo read-only } ;" (( -- )) eval ] unit-test
[ t ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test [ t ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test
[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test [ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test
[ ] [ "IN: slots.tests TUPLE: r/w-test foo ;" eval ] unit-test [ ] [ "IN: slots.tests TUPLE: r/w-test foo ;" (( -- )) eval ] unit-test
[ f ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test [ f ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test
[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test [ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test

2
core/vocabs/loader/loader-tests.factor
View File

@ -143,7 +143,7 @@ IN: vocabs.loader.tests
forget-junk forget-junk
[ { } ] [ [ { } ] [
"IN: xabbabbja" eval "xabbabbja" vocab-files "IN: xabbabbja" (( -- )) eval "xabbabbja" vocab-files
] unit-test ] unit-test
[ "xabbabbja" forget-vocab ] with-compilation-unit [ "xabbabbja" forget-vocab ] with-compilation-unit

2
core/words/alias/alias-tests.factor
View File

@ -2,5 +2,5 @@ USING: math eval tools.test effects ;
IN: words.alias.tests IN: words.alias.tests
ALIAS: foo + ALIAS: foo +
[ ] [ "IN: words.alias.tests CONSTANT: foo 5" eval ] unit-test [ ] [ "IN: words.alias.tests CONSTANT: foo 5" (( -- )) eval ] unit-test
[ (( -- value )) ] [ \ foo stack-effect ] unit-test [ (( -- value )) ] [ \ foo stack-effect ] unit-test

24
core/words/words-tests.factor
View File

@ -6,7 +6,7 @@ IN: words.tests
[ 4 ] [ [ 4 ] [
[ [
"poo" "words.tests" create [ 2 2 + ] define "poo" "words.tests" create [ 2 2 + ] (( -- n )) define-declared
] with-compilation-unit ] with-compilation-unit
"poo" "words.tests" lookup execute "poo" "words.tests" lookup execute
] unit-test ] unit-test
@ -51,7 +51,7 @@ SYMBOL: a-symbol
! See if redefining a generic as a colon def clears some ! See if redefining a generic as a colon def clears some
! word props. ! word props.
GENERIC: testing ( a -- b ) GENERIC: testing ( a -- b )
"IN: words.tests : testing ( -- ) ;" eval "IN: words.tests : testing ( -- ) ;" (( -- )) eval
[ f ] [ \ testing generic? ] unit-test [ f ] [ \ testing generic? ] unit-test
@ -88,7 +88,7 @@ DEFER: calls-a-gensym
[ [
\ calls-a-gensym \ calls-a-gensym
gensym dup "x" set 1quotation gensym dup "x" set 1quotation
define (( x -- x )) define-declared
] with-compilation-unit ] with-compilation-unit
] unit-test ] unit-test
@ -116,10 +116,10 @@ DEFER: x
[ ] [ "no-loc" "words.tests" create drop ] unit-test [ ] [ "no-loc" "words.tests" create drop ] unit-test
[ f ] [ "no-loc" "words.tests" lookup where ] unit-test [ f ] [ "no-loc" "words.tests" lookup where ] unit-test
[ ] [ "IN: words.tests : no-loc-2 ( -- ) ;" eval ] unit-test [ ] [ "IN: words.tests : no-loc-2 ( -- ) ;" (( -- )) eval ] unit-test
[ f ] [ "no-loc-2" "words.tests" lookup where ] unit-test [ f ] [ "no-loc-2" "words.tests" lookup where ] unit-test
[ ] [ "IN: words.tests : test-last ( -- ) ;" eval ] unit-test [ ] [ "IN: words.tests : test-last ( -- ) ;" (( -- )) eval ] unit-test
[ "test-last" ] [ word name>> ] unit-test [ "test-last" ] [ word name>> ] unit-test
! regression ! regression
@ -146,15 +146,15 @@ SYMBOL: quot-uses-b
[ forget ] with-compilation-unit [ forget ] with-compilation-unit
] when* ] when*
[ "IN: words.tests : undef-test ( -- ) ; << undef-test >>" eval ] [ "IN: words.tests : undef-test ( -- ) ; << undef-test >>" (( -- )) eval ]
[ error>> undefined? ] must-fail-with [ error>> undefined? ] must-fail-with
[ ] [ [ ] [
"IN: words.tests GENERIC: symbol-generic ( -- )" eval "IN: words.tests GENERIC: symbol-generic ( -- )" (( -- )) eval
] unit-test ] unit-test
[ ] [ [ ] [
"IN: words.tests SYMBOL: symbol-generic" eval "IN: words.tests SYMBOL: symbol-generic" (( -- )) eval
] unit-test ] unit-test
[ t ] [ "symbol-generic" "words.tests" lookup symbol? ] unit-test [ t ] [ "symbol-generic" "words.tests" lookup symbol? ] unit-test
@ -174,14 +174,14 @@ SYMBOL: quot-uses-b
[ f ] [ "symbol-generic" "words.tests" lookup generic? ] unit-test [ f ] [ "symbol-generic" "words.tests" lookup generic? ] unit-test
! Regressions ! Regressions
[ ] [ "IN: words.tests : decl-forget-test ( -- ) ; foldable" eval ] unit-test [ ] [ "IN: words.tests : decl-forget-test ( -- ) ; foldable" (( -- )) eval ] unit-test
[ t ] [ "decl-forget-test" "words.tests" lookup "foldable" word-prop ] unit-test [ t ] [ "decl-forget-test" "words.tests" lookup "foldable" word-prop ] unit-test
[ ] [ "IN: words.tests : decl-forget-test ( -- ) ;" eval ] unit-test [ ] [ "IN: words.tests : decl-forget-test ( -- ) ;" (( -- )) eval ] unit-test
[ f ] [ "decl-forget-test" "words.tests" lookup "foldable" word-prop ] unit-test [ f ] [ "decl-forget-test" "words.tests" lookup "foldable" word-prop ] unit-test
[ ] [ "IN: words.tests : decl-forget-test ( -- ) ; flushable" eval ] unit-test [ ] [ "IN: words.tests : decl-forget-test ( -- ) ; flushable" (( -- )) eval ] unit-test
[ t ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test [ t ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test
[ ] [ "IN: words.tests : decl-forget-test ( -- ) ;" eval ] unit-test [ ] [ "IN: words.tests : decl-forget-test ( -- ) ;" (( -- )) eval ] unit-test
[ f ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test [ f ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test
[ { } ] [ { } ]

2
extra/4DNav/file-chooser/file-chooser.factor
View File

@ -111,7 +111,7 @@ file-chooser H{
: line-selected-action ( file-chooser -- ) : line-selected-action ( file-chooser -- )
dup list>> list-value dup list>> list-value
dup directory? dup directory?
[ fc-change-directory ] [ fc-load-file ] if ; [ fc-change-directory ] [ fc-load-file ] if ; inline
: present-dir-element ( element -- string ) : present-dir-element ( element -- string )
[ name>> ] [ directory? ] bi [ "-> " prepend ] when ; [ name>> ] [ directory? ] bi [ "-> " prepend ] when ;

10
extra/advice/advice.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2008 James Cash ! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences fry words assocs linked-assocs tools.annotations USING: kernel sequences fry words assocs linked-assocs tools.annotations
coroutines lexer parser quotations arrays namespaces continuations ; coroutines lexer parser quotations arrays namespaces continuations
summary ;
IN: advice IN: advice
SYMBOLS: before after around advised in-advice? ; SYMBOLS: before after around advised in-advice? ;
@ -45,8 +46,13 @@ PRIVATE>
: remove-advice ( name word loc -- ) : remove-advice ( name word loc -- )
word-prop delete-at ; word-prop delete-at ;
ERROR: ad-do-it-error ;
M: ad-do-it-error summary
drop "ad-do-it should only be called inside 'around' advice" ;
: ad-do-it ( input -- result ) : ad-do-it ( input -- result )
in-advice? get [ "ad-do-it should only be called inside 'around' advice" throw ] unless coyield ; in-advice? get [ ad-do-it-error ] unless coyield ;
: make-advised ( word -- ) : make-advised ( word -- )
[ dup '[ [ _ ] dip over dup '[ _ call-before _ _ call-around _ call-after ] ] annotate ] [ dup '[ [ _ ] dip over dup '[ _ call-before _ _ call-around _ call-after ] ] annotate ]

5
extra/coroutines/coroutines.factor
View File

@ -19,9 +19,10 @@ TUPLE: coroutine resumecc exitcc originalcc ;
: coresume ( v co -- result ) : coresume ( v co -- result )
[ [
>>exitcc >>exitcc
resumecc>> call resumecc>> call( -- )
#! At this point, the coroutine quotation must have terminated #! At this point, the coroutine quotation must have terminated
#! normally (without calling coyield, coreset, or coterminate). This shouldn't happen. #! normally (without calling coyield, coreset, or coterminate).
#! This shouldn't happen.
f over f over
] callcc1 2nip ; ] callcc1 2nip ;

2
extra/lint/lint-tests.factor
View File

@ -2,7 +2,7 @@ USING: io lint kernel math tools.test ;
IN: lint.tests IN: lint.tests
! Don't write code like this ! Don't write code like this
: lint1 ( -- ) [ "hi" print ] [ ] if ; ! when : lint1 ( obj -- ) [ "hi" print ] [ ] if ; ! when
[ { { lint1 { [ [ ] if ] } } } ] [ \ lint1 lint-word ] unit-test [ { { lint1 { [ [ ] if ] } } } ] [ \ lint1 lint-word ] unit-test

8
extra/math/numerical-integration/numerical-integration.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel sequences namespaces make math math.ranges USING: kernel math math.ranges math.vectors namespaces
math.vectors vectors ; sequences ;
IN: math.numerical-integration IN: math.numerical-integration
SYMBOL: num-steps SYMBOL: num-steps
@ -15,7 +15,7 @@ SYMBOL: num-steps
length 2 / 2 - { 2 4 } <repetition> concat length 2 / 2 - { 2 4 } <repetition> concat
{ 1 4 } { 1 } surround ; { 1 4 } { 1 } surround ;
: integrate-simpson ( from to f -- x ) : integrate-simpson ( from to quot -- x )
[ setup-simpson-range dup ] dip [ setup-simpson-range dup ] dip
map dup generate-simpson-weights map dup generate-simpson-weights
v. swap [ third ] keep first - 6 / * ; v. swap [ third ] keep first - 6 / * ; inline

2
extra/partial-continuations/partial-continuations-tests.factor
View File

@ -7,7 +7,7 @@ SYMBOL: sum
: range ( r from to -- n ) : range ( r from to -- n )
over - 1 + rot [ over - 1 + rot [
-rot [ over + pick call drop ] each 2drop f -rot [ over + pick call drop ] each 2drop f
] bshift 2nip ; ] bshift 2nip ; inline
[ 55 ] [ [ 55 ] [
0 sum set 0 sum set

0
extra/graph-theory/authors.txt → unmaintained/graph-theory/authors.txt
View File

0
extra/graph-theory/graph-theory-docs.factor → unmaintained/graph-theory/graph-theory-docs.factor
View File

9
extra/graph-theory/graph-theory.factor → unmaintained/graph-theory/graph-theory.factor
View File

@ -1,8 +1,7 @@
! Copyright (C) 2008 William Schlieper <schlieper@unc.edu> ! Copyright (C) 2008 William Schlieper <schlieper@unc.edu>
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel combinators fry continuations sequences arrays
USING: kernel combinators fry continuations sequences arrays vectors assocs hashtables heaps namespaces ; vectors assocs hashtables heaps namespaces ;
IN: graph-theory IN: graph-theory
MIXIN: graph MIXIN: graph
@ -35,7 +34,7 @@ M: graph num-vertices
vertices length ; vertices length ;
M: graph num-edges M: graph num-edges
[ vertices ] [ '[ _ adjlist length ] map sum ] bi ; [ vertices ] [ '[ _ adjlist length ] sigma ] bi ;
M: graph adjlist M: graph adjlist
[ vertices ] [ swapd '[ _ swap _ adj? ] filter ] bi ; [ vertices ] [ swapd '[ _ swap _ adj? ] filter ] bi ;
@ -88,5 +87,5 @@ PRIVATE>
: topological-sort ( graph -- seq/f ) : topological-sort ( graph -- seq/f )
dup dag? dup dag?
[ V{ } swap [ drop ] [ prefix ] [ ] full-depth-first drop ] [ V{ } clone swap [ drop ] [ prefix ] [ ] full-depth-first drop ]
[ drop f ] if ; [ drop f ] if ;

0
extra/graph-theory/reversals/reversals.factor → unmaintained/graph-theory/reversals/reversals.factor
View File

0
extra/graph-theory/sparse/sparse.factor → unmaintained/graph-theory/sparse/sparse.factor
View File

0
extra/graph-theory/summary.txt → unmaintained/graph-theory/summary.txt
View File

0
extra/graph-theory/tags.txt → unmaintained/graph-theory/tags.txt
View File