Fixing unit tests for syntax change

db4
Slava Pestov 2009-03-23 00:34:02 -05:00
parent 70192ce0d5
commit 723bfab030
56 changed files with 196 additions and 196 deletions

View File

@ -3,7 +3,7 @@ USING: tools.test bit-vectors vectors sequences kernel math ;
[ 0 ] [ 123 <bit-vector> length ] unit-test
: do-it
: do-it ( seq -- )
1234 swap [ [ even? ] dip push ] curry each ;
[ t ] [

View File

@ -4,7 +4,7 @@ prettyprint ;
[ 0 ] [ 123 <byte-vector> length ] unit-test
: do-it
: do-it ( seq -- seq )
123 [ over push ] each ;
[ t ] [

View File

@ -148,7 +148,7 @@ IN: calendar.tests
[ t ] [ 123456789000000 [ micros>timestamp timestamp>micros ] keep = ] unit-test
[ t ] [ 123456789123456000 [ micros>timestamp timestamp>micros ] keep = ] unit-test
: checktime+ now dup clone [ rot time+ drop ] keep = ;
: checktime+ ( duration -- ? ) now dup clone [ rot time+ drop ] keep = ;
[ t ] [ 5 seconds checktime+ ] unit-test

View File

@ -13,7 +13,7 @@ CLASS: {
[ gc "x" set 2drop ]
} ;
: test-foo
: test-foo ( -- )
Foo -> alloc -> init
dup 1.0 2.0 101.0 102.0 <CGRect> -> foo:
-> release ;

View File

@ -285,7 +285,7 @@ paste "PASTE"
[ test-cascade ] test-postgresql
[ test-restrict ] test-postgresql
: test-repeated-insert
: test-repeated-insert ( -- )
[ ] [ person ensure-table ] unit-test
[ ] [ person1 get insert-tuple ] unit-test
[ person1 get insert-tuple ] must-fail ;
@ -458,7 +458,7 @@ TUPLE: bignum-test id m n o ;
swap >>n
swap >>m ;
: test-bignum
: test-bignum ( -- )
bignum-test "BIGNUM_TEST"
{
{ "id" "ID" +db-assigned-id+ }
@ -478,7 +478,7 @@ TUPLE: bignum-test id m n o ;
TUPLE: secret n message ;
C: <secret> secret
: test-random-id
: test-random-id ( -- )
secret "SECRET"
{
{ "n" "ID" +random-id+ system-random-generator }

View File

@ -41,13 +41,13 @@ M: hello bing hello-test ;
[ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ; inline\n" ] [ [ baz see ] with-string-writer ] unit-test
GENERIC: one
GENERIC: one ( a -- b )
M: integer one ;
GENERIC: two
GENERIC: two ( a -- b )
M: integer two ;
GENERIC: three
GENERIC: three ( a -- b )
M: integer three ;
GENERIC: four
GENERIC: four ( a -- b )
M: integer four ;
PROTOCOL: alpha one two ;

View File

@ -34,7 +34,7 @@ sequences eval accessors ;
{ "a" "b" "c" } swap map
] unit-test
: funny-dip '[ [ @ ] dip ] call ; inline
: funny-dip ( obj quot -- ) '[ [ @ ] dip ] call ; inline
[ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test

View File

@ -7,7 +7,7 @@ IN: furnace.actions.tests
[ "a" param "b" param [ string>number ] bi@ + ] >>display
"action-1" set
: lf>crlf "\n" split "\r\n" join ;
: lf>crlf ( string -- string' ) "\n" split "\r\n" join ;
STRING: action-request-test-1
GET http://foo/bar?a=12&b=13 HTTP/1.1

View File

@ -4,7 +4,7 @@ http.server furnace furnace.utilities tools.test kernel
namespaces accessors io.streams.string urls xml.writer ;
TUPLE: funny-dispatcher < dispatcher ;
: <funny-dispatcher> funny-dispatcher new-dispatcher ;
: <funny-dispatcher> ( -- dispatcher ) funny-dispatcher new-dispatcher ;
TUPLE: base-path-check-responder ;

View File

@ -6,7 +6,7 @@ io.streams.string io.files io.files.temp io.directories
splitting destructors sequences db db.tuples db.sqlite
continuations urls math.parser furnace furnace.utilities ;
: with-session
: with-session ( session quot -- )
[
[ [ save-session-after ] [ session set ] bi ] dip call
] with-destructors ; inline
@ -22,7 +22,7 @@ M: foo call-responder*
"x" [ 1+ ] schange
"x" sget number>string "text/html" <content> ;
: url-responder-mock-test
: url-responder-mock-test ( -- )
[
<request>
"GET" >>method
@ -34,7 +34,7 @@ M: foo call-responder*
[ write-response-body drop ] with-string-writer
] with-destructors ;
: sessions-mock-test
: sessions-mock-test ( -- )
[
<request>
"GET" >>method
@ -45,7 +45,7 @@ M: foo call-responder*
[ write-response-body drop ] with-string-writer
] with-destructors ;
: <exiting-action>
: <exiting-action> ( -- action )
<action>
[ [ ] "text/plain" <content> exit-with ] >>display ;

View File

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

View File

@ -4,7 +4,7 @@ definitions assocs sequences kernel namespaces parser arrays
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
[ $subsection ] [
@ -23,7 +23,7 @@ io.streams.string continuations debugger compiler.units eval ;
] 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
[ ] [

View File

@ -7,7 +7,7 @@ IN: help.definitions.tests
[
[ 4 ] [
"IN: help.definitions.tests USING: help.syntax ; : hello ; HELP: hello \"test\" ; ARTICLE: \"hello\" \"world\" ; ARTICLE: \"hello2\" \"world\" ;" <string-reader> "foo"
"IN: help.definitions.tests USING: help.syntax ; : hello ( -- ) ; HELP: hello \"test\" ; ARTICLE: \"hello\" \"world\" ; ARTICLE: \"hello2\" \"world\" ;" <string-reader> "foo"
parse-stream drop
"foo" source-file definitions>> first assoc-size
@ -20,7 +20,7 @@ IN: help.definitions.tests
] unit-test
[ 2 ] [
"IN: help.definitions.tests USING: help.syntax ; : hello ; ARTICLE: \"hello\" \"world\" ;" <string-reader> "foo"
"IN: help.definitions.tests USING: help.syntax ; : hello ( -- ) ; ARTICLE: \"hello\" \"world\" ;" <string-reader> "foo"
parse-stream drop
"foo" source-file definitions>> first assoc-size
@ -32,7 +32,7 @@ IN: help.definitions.tests
"hello" "help.definitions.tests" lookup "help" word-prop
] 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

View File

@ -11,7 +11,7 @@ TUPLE: blahblah quux ;
[ ] [ \ >>quux print-topic ] unit-test
[ ] [ \ blahblah? print-topic ] unit-test
: fooey "fooey" throw ;
: fooey ( -- * ) "fooey" throw ;
[ ] [ \ fooey print-topic ] unit-test

View File

@ -5,7 +5,7 @@ splitting unicode.categories furnace accessors
html.templates.chloe.compiler ;
IN: html.templates.chloe.tests
: run-template
: run-template ( quot -- string )
with-string-writer [ "\r\n\t" member? not ] filter
"?>" split1 nip ; inline
@ -37,7 +37,7 @@ IN: html.templates.chloe.tests
] run-template
] unit-test
: test4-aux? t ;
: test4-aux? ( -- ? ) t ;
[ "True" ] [
[
@ -45,7 +45,7 @@ IN: html.templates.chloe.tests
] run-template
] unit-test
: test5-aux? f ;
: test5-aux? ( -- ? ) f ;
[ "" ] [
[

View File

@ -13,7 +13,7 @@ IN: http.tests
[ "application/octet-stream" binary ] [ "application/octet-stream" parse-content-type ] unit-test
: lf>crlf "\n" split "\r\n" join ;
: lf>crlf ( string -- string' ) "\n" split "\r\n" join ;
STRING: read-request-test-1
POST /bar HTTP/1.1
@ -180,14 +180,14 @@ accessors namespaces threads
http.server.responses http.server.redirection furnace.redirection
http.server.dispatchers db.tuples ;
: add-quit-action
: add-quit-action ( responder -- responder )
<action>
[ stop-this-server "Goodbye" "text/html" <content> ] >>display
"quit" add-responder ;
: test-db-file "test.db" temp-file ;
: test-db-file ( -- path ) "test.db" temp-file ;
: test-db test-db-file <sqlite-db> ;
: test-db ( -- db ) test-db-file <sqlite-db> ;
[ test-db-file delete-file ] ignore-errors
@ -268,7 +268,7 @@ test-db [
test-httpd
] unit-test
: 404? [ download-failed? ] [ response>> code>> 404 = ] bi and ;
: 404? ( response -- ? ) [ download-failed? ] [ response>> code>> 404 = ] bi and ;
! This should give a 404 not an infinite redirect loop
[ "http://localhost/d/blah" add-port http-get nip ] [ 404? ] must-fail-with

View File

@ -5,7 +5,7 @@ io.streams.duplex destructors make io.launcher ;
IN: io.backend.unix.tests
! Unix domain stream sockets
: socket-server "unix-domain-socket-test" temp-file ;
: socket-server ( -- path ) "unix-domain-socket-test" temp-file ;
[
[ socket-server delete-file ] ignore-errors
@ -33,8 +33,8 @@ yield
] { } make
] unit-test
: datagram-server "unix-domain-datagram-test" temp-file ;
: datagram-client "unix-domain-datagram-test-2" temp-file ;
: datagram-server ( -- path ) "unix-domain-datagram-test" temp-file ;
: datagram-client ( -- path ) "unix-domain-datagram-test-2" temp-file ;
! Unix domain datagram sockets
[ datagram-server delete-file ] ignore-errors
@ -104,7 +104,7 @@ datagram-client <local> <datagram>
[ ] [ "d" get dispose ] unit-test
! Test error behavior
: another-datagram "unix-domain-datagram-test-3" temp-file ;
: another-datagram ( -- path ) "unix-domain-datagram-test-3" temp-file ;
[ another-datagram delete-file ] ignore-errors

View File

@ -2,7 +2,7 @@ USING: accessors alien.c-types kernel
io.encodings.utf16 io.streams.byte-array tools.test ;
IN: io.encodings.utf16n
: correct-endian
: correct-endian ( obj -- ? )
code>> little-endian? [ utf16le = ] [ utf16be = ] if ;
[ t ] [ B{ } utf16n <byte-reader> correct-endian ] unit-test

View File

@ -5,13 +5,13 @@ IN: io.streams.duplex.tests
! Test duplex stream close behavior
TUPLE: closing-stream < disposable ;
: <closing-stream> closing-stream new ;
: <closing-stream> ( -- stream ) closing-stream new ;
M: closing-stream dispose* drop ;
TUPLE: unclosable-stream ;
: <unclosable-stream> unclosable-stream new ;
: <unclosable-stream> ( -- stream ) unclosable-stream new ;
M: unclosable-stream dispose
"Can't close me!" throw ;

View File

@ -50,7 +50,7 @@ SYNTAX: hello "Hi" print ;
[
[ ] [
"IN: listener.tests : hello\n\"world\" ;" parse-interactive
"IN: listener.tests : hello ( -- )\n\"world\" ;" parse-interactive
drop
] unit-test
] with-file-vocabs

View File

@ -192,14 +192,14 @@ M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ;
DEFER: xyzzy
[ ] [
"IN: locals.tests USE: math GENERIC: xyzzy M: integer xyzzy ;"
"IN: locals.tests USE: math GENERIC: xyzzy ( a -- b ) M: integer xyzzy ;"
<string-reader> "lambda-generic-test" parse-stream drop
] unit-test
[ 10 ] [ 10 xyzzy ] unit-test
[ ] [
"IN: locals.tests USE: math USE: locals GENERIC: xyzzy M:: integer xyzzy ( n -- ) 5 ;"
"IN: locals.tests USE: math USE: locals GENERIC: xyzzy ( a -- b ) M:: integer xyzzy ( n -- x ) 5 ;"
<string-reader> "lambda-generic-test" parse-stream drop
] unit-test
@ -245,7 +245,7 @@ M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ;
[ 5 ] [ 1 next-method-test ] unit-test
: no-with-locals-test { 1 2 3 } [| x | x 3 + ] map ;
: no-with-locals-test ( -- seq ) { 1 2 3 } [| x | x 3 + ] map ;
[ { 4 5 6 } ] [ no-with-locals-test ] unit-test
@ -259,7 +259,7 @@ M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ;
:: a-word-with-locals ( a b -- ) ;
: 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
@ -268,7 +268,7 @@ M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ;
new-definition =
] unit-test
: method-definition "USING: locals locals.tests sequences ;\nM:: sequence method-with-locals ( a -- y ) a reverse ;\n" ;
CONSTANT: method-definition "USING: locals locals.tests sequences ;\nM:: sequence method-with-locals ( a -- y ) a reverse ;\n"
GENERIC: method-with-locals ( x -- y )

View File

@ -2,16 +2,22 @@ IN: macros.tests
USING: tools.test macros math kernel arrays
vectors io.streams.string prettyprint parser eval see ;
MACRO: see-test ( a b -- c ) + ;
MACRO: see-test ( a b -- quot ) + ;
[ "USING: macros math ;\nIN: macros.tests\nMACRO: see-test ( a b -- c ) + ;\n" ]
[ t ] [ \ see-test macro? ] unit-test
[ "USING: macros math ;\nIN: macros.tests\nMACRO: see-test ( a b -- quot ) + ;\n" ]
[ [ \ see-test see ] with-string-writer ]
unit-test
[ t ] [ \ see-test macro? ] unit-test
[ t ] [
"USING: math ;\nIN: macros.tests\n: see-test ( a b -- c ) - ;\n" dup eval
[ \ see-test see ] with-string-writer =
] 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

View File

@ -7,14 +7,14 @@ IN: macros
<PRIVATE
: real-macro-effect ( effect -- effect' )
in>> 1 <effect> ;
in>> { "quot" } <effect> ;
PRIVATE>
: define-macro ( word definition effect -- )
real-macro-effect
[ drop "macro" set-word-prop ]
[ [ memoize-quot [ call ] append ] keep define-declared ]
[ drop "macro" set-word-prop ]
3bi ;
SYNTAX: MACRO: (:) define-macro ;

View File

@ -4,7 +4,7 @@ IN: models.tests
TUPLE: model-tester hit? ;
: <model-tester> model-tester new ;
: <model-tester> ( -- model-tester ) model-tester new ;
M: model-tester model-changed nip t >>hit? drop ;

View File

@ -3,7 +3,7 @@ USING: arrays generic kernel math models namespaces sequences assocs
tools.test models.range ;
! Test <range>
: setup-range 0 0 0 255 <range> ;
: setup-range ( -- range ) 0 0 0 255 <range> ;
! clamp-value should not go past range ends
[ 0 ] [ -10 setup-range clamp-value ] unit-test

View File

@ -1,9 +1,9 @@
USING: persistent.heaps tools.test ;
IN: persistent.heaps.tests
: test-input
CONSTANT: test-input
{ { "hello" 3 } { "goodbye" 2 } { "whatever" 5 }
{ "foo" 1 } { "bar" -1 } { "baz" -7 } { "bing" 0 } } ;
{ "foo" 1 } { "bar" -1 } { "baz" -7 } { "bing" 0 } }
[
{ { "baz" -7 } { "bar" -1 } { "bing" 0 } { "foo" 1 }

View File

@ -63,7 +63,7 @@ unit-test
[ "USING: math ;\nIN: prettyprint.tests\n: bar ( x -- y ) 2 + ;\n" ]
[ [ \ bar see ] with-string-writer ] unit-test
: blah
: blah ( a a a a a a a a a a a a a a a a a a a a -- )
drop
drop
drop
@ -102,7 +102,7 @@ unit-test
] keep =
] with-scope ;
GENERIC: method-layout
GENERIC: method-layout ( a -- b )
M: complex method-layout
"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
@ -135,7 +135,7 @@ M: object method-layout ;
[ \ method-layout see-methods ] with-string-writer "\n" split
] unit-test
: soft-break-test
: soft-break-test ( -- str )
{
"USING: kernel math sequences strings ;"
"IN: prettyprint.tests"
@ -152,7 +152,7 @@ M: object method-layout ;
DEFER: parse-error-file
: another-soft-break-test
: another-soft-break-test ( -- str )
{
"USING: make sequences ;"
"IN: prettyprint.tests"
@ -166,7 +166,7 @@ DEFER: parse-error-file
check-see
] unit-test
: string-layout
: string-layout ( -- str )
{
"USING: accessors debugger io kernel ;"
"IN: prettyprint.tests"
@ -187,7 +187,7 @@ DEFER: parse-error-file
\ send soft "break-after" set-word-prop
: final-soft-break-test
: final-soft-break-test ( -- str )
{
"USING: kernel sequences ;"
"IN: prettyprint.tests"
@ -202,7 +202,7 @@ DEFER: parse-error-file
"final-soft-break-layout" final-soft-break-test check-see
] unit-test
: narrow-test
: narrow-test ( -- str )
{
"USING: arrays combinators continuations kernel sequences ;"
"IN: prettyprint.tests"
@ -218,7 +218,7 @@ DEFER: parse-error-file
"narrow-layout" narrow-test check-see
] unit-test
: another-narrow-test
: another-narrow-test ( -- str )
{
"IN: prettyprint.tests"
": another-narrow-layout ( -- obj )"
@ -326,7 +326,7 @@ INTERSECTION: intersection-see-test sequence number ;
TUPLE: started-out-hustlin' ;
GENERIC: ended-up-ballin'
GENERIC: ended-up-ballin' ( a -- b )
M: started-out-hustlin' ended-up-ballin' ; inline

View File

@ -7,7 +7,7 @@ sequences math prettyprint parser classes math.constants
io.encodings.binary random assocs serialize.private ;
IN: serialize.tests
: test-serialize-cell
: test-serialize-cell ( a -- ? )
2^ random dup
binary [ serialize-cell ] with-byte-writer
binary [ deserialize-cell ] with-byte-reader = ;
@ -27,7 +27,7 @@ TUPLE: serialize-test a b ;
C: <serialize-test> serialize-test
: objects
CONSTANT: objects
{
f
t
@ -52,7 +52,7 @@ C: <serialize-test> serialize-test
<< 1 [ 2 ] curry parsed >>
{ { "a" "bc" } { "de" "fg" } }
H{ { "a" "bc" } { "de" "fg" } }
} ;
}
: check-serialize-1 ( obj -- ? )
"=====" print

View File

@ -2,7 +2,7 @@ USING: tools.test tools.annotations tools.time math parser eval
io.streams.string kernel strings ;
IN: tools.annotations.tests
: foo ;
: foo ( -- ) ;
\ foo watch
[ ] [ foo ] unit-test

View File

@ -3,7 +3,7 @@ tools.crossref tools.test parser namespaces source-files generic
definitions ;
IN: tools.crossref.tests
GENERIC: foo
GENERIC: foo ( a b -- c )
M: integer foo + ;

View File

@ -36,7 +36,7 @@ IN: tools.walker.tests
[ 2 2 fixnum+ ] test-walker
] unit-test
: foo 2 2 fixnum+ ;
: foo ( -- x ) 2 2 fixnum+ ;
[ { 8 } ] [
[ foo 4 fixnum+ ] test-walker

View File

@ -5,9 +5,9 @@ IN: ui.gadgets.buttons.tests
TUPLE: foo-gadget ;
: com-foo-a ;
: com-foo-a ( -- ) ;
: com-foo-b ;
: com-foo-b ( -- ) ;
\ foo-gadget "toolbar" f {
{ f com-foo-a }

View File

@ -119,14 +119,14 @@ M: mock-gadget ungraft*
[ { f f } ] [ "g" get graft-state>> ] unit-test
] with-variable
: add-some-children
: add-some-children ( gadget -- gadget )
3 [
<mock-gadget> over <model> >>model
"g" get over add-gadget drop
swap 1+ number>string set
] each ;
: status-flags
: status-flags ( -- seq )
{ "g" "1" "2" "3" } [ get graft-state>> ] map prune ;
: notify-combo ( ? ? -- )

View File

@ -5,7 +5,7 @@ help.stylesheet splitting tools.test.ui models math summary
inspector accessors help.topics see ;
IN: ui.gadgets.panes.tests
: #children "pane" get children>> length ;
: #children ( -- n ) "pane" get children>> length ;
[ ] [ <pane> "pane" set ] unit-test

View File

@ -3,7 +3,7 @@ USING: ui.operations ui.commands prettyprint kernel namespaces
tools.test ui.gadgets ui.gadgets.editors parser io
io.streams.string math help help.markup accessors ;
: my-pprint pprint ;
: my-pprint ( obj -- ) pprint ;
[ drop t ] \ my-pprint [ ] f operation boa "op" set

View File

@ -68,7 +68,7 @@ IN: ui.tools.listener.tests
[ ] [ <interactor> <pane> <pane-stream> >>output "interactor" set ] unit-test
: text "Hello world.\nThis is a test." ;
CONSTANT: text "Hello world.\nThis is a test."
[ ] [ text "interactor" get set-editor-string ] unit-test

View File

@ -2,7 +2,7 @@ IN: urls.tests
USING: urls urls.private tools.test
arrays kernel assocs present accessors ;
: urls
CONSTANT: urls
{
{
T{ url
@ -80,7 +80,7 @@ arrays kernel assocs present accessors ;
}
"ftp://slava:secret@ftp.kernel.org/"
}
} ;
}
urls [
[ 1array ] [ [ >url ] curry ] bi* unit-test

View File

@ -13,7 +13,7 @@ GENERIC: zammo ( obj -- str )
SINGLETON: word-and-singleton
: word-and-singleton 3 ;
: word-and-singleton ( -- x ) 3 ;
[ t ] [ \ word-and-singleton word-and-singleton? ] unit-test
[ 3 ] [ word-and-singleton ] unit-test

View File

@ -288,7 +288,7 @@ CONSTANT: case-const-2 2
} case
] unit-test
: do-not-call "do not call" throw ;
: do-not-call ( -- * ) "do not call" throw ;
: test-case-6 ( obj -- value )
{

View File

@ -3,7 +3,7 @@ continuations debugger parser memory arrays words
kernel.private accessors eval ;
IN: continuations.tests
: (callcc1-test)
: (callcc1-test) ( -- )
[ 1- dup ] dip ?push
over 0 = [ "test-cc" get continue-with ] when
(callcc1-test) ;
@ -59,10 +59,10 @@ IN: continuations.tests
! : callstack-overflow callstack-overflow f ;
! [ callstack-overflow ] must-fail
: don't-compile-me { } [ ] each ;
: don't-compile-me ( -- ) { } [ ] each ;
: foo callstack "c" set 3 don't-compile-me ;
: bar 1 foo 2 ;
: foo ( -- ) callstack "c" set 3 don't-compile-me ;
: bar ( -- a b ) 1 foo 2 ;
[ 1 3 2 ] [ bar ] unit-test

View File

@ -21,7 +21,7 @@ T{ dispose-dummy } "b" set
TUPLE: dummy-obj destroyed? ;
: <dummy-obj> dummy-obj new ;
: <dummy-obj> ( -- obj ) dummy-obj new ;
TUPLE: dummy-destructor obj ;
@ -30,10 +30,10 @@ C: <dummy-destructor> dummy-destructor
M: dummy-destructor dispose ( obj -- )
obj>> t >>destroyed? drop ;
: destroy-always
: destroy-always ( obj -- )
<dummy-destructor> &dispose drop ;
: destroy-later
: destroy-later ( obj -- )
<dummy-destructor> |dispose drop ;
[ t ] [

View File

@ -1,4 +1,4 @@
IN: io.tests
USE: math
: foo 2 2 + ;
: foo ( -- x ) 2 2 + ;
FORGET: foo

View File

@ -21,21 +21,21 @@ IN: kernel.tests
[ ] [ :c ] unit-test
: overflow-d 3 overflow-d ;
: overflow-d ( -- ) 3 overflow-d ;
[ overflow-d ] [ { "kernel-error" 12 f f } = ] must-fail-with
[ ] [ :c ] unit-test
: (overflow-d-alt) 3 ;
: (overflow-d-alt) ( -- ) 3 ;
: overflow-d-alt (overflow-d-alt) overflow-d-alt ;
: overflow-d-alt ( -- ) (overflow-d-alt) overflow-d-alt ;
[ overflow-d-alt ] [ { "kernel-error" 12 f f } = ] must-fail-with
[ ] [ [ :c ] with-string-writer drop ] unit-test
: overflow-r 3 load-local overflow-r ;
: overflow-r ( -- ) 3 load-local overflow-r ;
[ overflow-r ] [ { "kernel-error" 14 f f } = ] must-fail-with
@ -99,7 +99,7 @@ IN: kernel.tests
[ ] [ :c ] unit-test
! Doesn't compile; important
: foo 5 + 0 [ ] each ;
: foo ( a -- b ) 5 + 0 [ ] each ;
[ drop foo ] must-fail
[ ] [ :c ] unit-test
@ -115,7 +115,7 @@ IN: kernel.tests
[ loop ] must-fail
! Discovered on Windows
: total-failure-1 "" [ ] map unimplemented ;
: total-failure-1 ( -- ) "" [ ] map unimplemented ;
[ total-failure-1 ] must-fail

View File

@ -27,7 +27,7 @@ IN: parser.tests
[ "hello world" ]
[
"IN: parser.tests : hello \"hello world\" ;"
"IN: parser.tests : hello ( -- str ) \"hello world\" ;"
eval "USE: parser.tests hello" eval
] unit-test
@ -78,12 +78,8 @@ IN: parser.tests
[ T{ effect f { "a" "b" } { "d" } f } ]
[ \ effect-parsing-test "declared-effect" word-prop ] unit-test
[ ] [ "IN: parser.tests : effect-parsing-test ;" eval ] unit-test
[ f ] [ \ effect-parsing-test "declared-effect" word-prop ] unit-test
! Funny bug
[ 2 ] [ "IN: parser.tests : \0. 2 ; \0." eval ] unit-test
[ 2 ] [ "IN: parser.tests : \0. ( -- x ) 2 ; \0." eval ] unit-test
[ "IN: parser.tests : missing-- ( a b ) ;" eval ] must-fail
@ -110,7 +106,7 @@ IN: parser.tests
[ ] [ "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 ] [
"USE: parser.tests \\ foo" eval
@ -120,7 +116,7 @@ IN: parser.tests
! Test smudging
[ 1 ] [
"IN: parser.tests : smudge-me ;" <string-reader> "foo"
"IN: parser.tests : smudge-me ( -- ) ;" <string-reader> "foo"
parse-stream drop
"foo" source-file definitions>> first assoc-size
@ -129,7 +125,7 @@ IN: parser.tests
[ t ] [ "smudge-me" "parser.tests" lookup >boolean ] unit-test
[ ] [
"IN: parser.tests : smudge-me-more ;" <string-reader> "foo"
"IN: parser.tests : smudge-me-more ( -- ) ;" <string-reader> "foo"
parse-stream drop
] unit-test
@ -137,7 +133,7 @@ IN: parser.tests
[ f ] [ "smudge-me" "parser.tests" lookup >boolean ] unit-test
[ 3 ] [
"IN: parser.tests USING: math strings ; GENERIC: smudge-me M: integer smudge-me ; M: string smudge-me ;" <string-reader> "foo"
"IN: parser.tests USING: math strings ; GENERIC: smudge-me ( a -- b ) M: integer smudge-me ; M: string smudge-me ;" <string-reader> "foo"
parse-stream drop
"foo" source-file definitions>> first assoc-size
@ -151,7 +147,7 @@ IN: parser.tests
] unit-test
[ 2 ] [
"IN: parser.tests USING: math strings ; GENERIC: smudge-me M: integer smudge-me ;" <string-reader> "foo"
"IN: parser.tests USING: math strings ; GENERIC: smudge-me ( a -- b ) M: integer smudge-me ;" <string-reader> "foo"
parse-stream drop
"foo" source-file definitions>> first assoc-size
@ -190,7 +186,7 @@ IN: parser.tests
[ ] [
"a" source-files get delete-at
2 [
"IN: parser.tests DEFER: x : y x ; : x y ;"
"IN: parser.tests DEFER: x : y ( -- ) x ; : x ( -- ) y ;"
<string-reader> "a" parse-stream drop
] times
] unit-test
@ -198,7 +194,7 @@ IN: parser.tests
"a" source-files get delete-at
[
"IN: parser.tests : x ; : y 3 throw ; this is an error"
"IN: parser.tests : x ( -- ) ; : y ( -- * ) 3 throw ; this is an error"
<string-reader> "a" parse-stream
] [ source-file-error? ] must-fail-with
@ -207,7 +203,7 @@ IN: parser.tests
] unit-test
[ f ] [
"IN: parser.tests : x ;"
"IN: parser.tests : x ( -- ) ;"
<string-reader> "a" parse-stream drop
"y" "parser.tests" lookup
@ -215,18 +211,18 @@ IN: parser.tests
! Test new forward definition logic
[ ] [
"IN: axx : axx ;"
"IN: axx : axx ( -- ) ;"
<string-reader> "axx" parse-stream drop
] unit-test
[ ] [
"USE: axx IN: bxx : bxx ; : cxx axx bxx ;"
"USE: axx IN: bxx : bxx ( -- ) ; : cxx ( -- ) axx bxx ;"
<string-reader> "bxx" parse-stream drop
] unit-test
! So we move the bxx word to axx...
[ ] [
"IN: axx : axx ; : bxx ;"
"IN: axx : axx ( -- ) ; : bxx ( -- ) ;"
<string-reader> "axx" parse-stream drop
] unit-test
@ -234,7 +230,7 @@ IN: parser.tests
! And reload the file that uses it...
[ ] [
"USE: axx IN: bxx : cxx axx bxx ;"
"USE: axx IN: bxx ( -- ) : cxx ( -- ) axx bxx ;"
<string-reader> "bxx" parse-stream drop
] unit-test
@ -243,17 +239,17 @@ IN: parser.tests
! Turning a generic into a non-generic could cause all
! kinds of funnyness
[ ] [
"IN: ayy USE: kernel GENERIC: ayy M: object ayy ;"
"IN: ayy USE: kernel GENERIC: ayy ( a -- b ) M: object ayy ;"
<string-reader> "ayy" parse-stream drop
] unit-test
[ ] [
"IN: ayy USE: kernel : ayy ;"
"IN: ayy USE: kernel : ayy ( -- ) ;"
<string-reader> "ayy" parse-stream drop
] unit-test
[ ] [
"IN: azz TUPLE: my-class ; GENERIC: a-generic"
"IN: azz TUPLE: my-class ; GENERIC: a-generic ( a -- b )"
<string-reader> "azz" parse-stream drop
] unit-test
@ -263,7 +259,7 @@ IN: parser.tests
] unit-test
[ ] [
"IN: azz GENERIC: a-generic"
"IN: azz GENERIC: a-generic ( a -- b )"
<string-reader> "azz" parse-stream drop
] unit-test
@ -273,12 +269,12 @@ IN: parser.tests
] unit-test
[ ] [
"IN: parser.tests : <bogus-error> ; : bogus <bogus-error> ;"
"IN: parser.tests : <bogus-error> ( -- ) ; : bogus ( -- ) <bogus-error> ;"
<string-reader> "bogus-error" parse-stream drop
] 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 ( -- ) <bogus-error> ;"
<string-reader> "bogus-error" parse-stream drop
] unit-test
@ -298,7 +294,7 @@ IN: parser.tests
] unit-test
[
"IN: parser.tests TUPLE: another-pred-test ; GENERIC: another-pred-test?"
"IN: parser.tests TUPLE: another-pred-test ; GENERIC: another-pred-test? ( a -- b )"
<string-reader> "removing-the-predicate" parse-stream
] [ error>> error>> error>> redefine-error? ] must-fail-with
@ -313,7 +309,7 @@ IN: parser.tests
] unit-test
[
"IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;"
"IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ( -- ) ;"
<string-reader> "redefining-a-class-3" parse-stream drop
] [ error>> error>> error>> redefine-error? ] must-fail-with
@ -338,7 +334,7 @@ IN: parser.tests
] [ error>> error>> error>> no-word-error? ] must-fail-with
[
"IN: parser.tests : foo ; TUPLE: foo ;"
"IN: parser.tests : foo ( -- ) ; TUPLE: foo ;"
<string-reader> "redefining-a-class-4" parse-stream drop
] [ error>> error>> error>> redefine-error? ] must-fail-with
@ -369,7 +365,7 @@ IN: parser.tests
2 [
[ ] [
"IN: parser.tests TUPLE: foo ; GENERIC: foo"
"IN: parser.tests TUPLE: foo ; GENERIC: foo ( a -- b )"
<string-reader> "redefining-a-class-5" parse-stream drop
] unit-test
@ -381,14 +377,14 @@ IN: parser.tests
[ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
[ ] [
"IN: parser.tests TUPLE: foo ; GENERIC: foo"
"IN: parser.tests TUPLE: foo ; GENERIC: foo ( a -- b )"
<string-reader> "redefining-a-class-5" parse-stream drop
] unit-test
[ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
[ ] [
"IN: parser.tests TUPLE: foo ; GENERIC: foo"
"IN: parser.tests TUPLE: foo ; GENERIC: foo ( a -- b )"
<string-reader> "redefining-a-class-7" parse-stream drop
] unit-test
@ -438,7 +434,7 @@ IN: parser.tests
{
"IN: parser.tests"
"USING: math arrays ;"
"GENERIC: change-combination"
"GENERIC: change-combination ( a -- b )"
"M: integer change-combination 1 ;"
"M: array change-combination 2 ;"
} "\n" join <string-reader> "change-combination-test" parse-stream drop
@ -448,7 +444,7 @@ IN: parser.tests
{
"IN: parser.tests"
"USING: math arrays ;"
"GENERIC# change-combination 1"
"GENERIC# change-combination 1 ( a -- b )"
"M: integer change-combination 1 ;"
"M: array change-combination 2 ;"
} "\n" join <string-reader> "change-combination-test" parse-stream drop
@ -467,7 +463,7 @@ IN: parser.tests
] 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 ( -- ) 1 ; : staging-problem-test-2 ( -- ) staging-problem-test-1 ;"
<string-reader> "staging-problem-test" parse-stream
] unit-test
@ -476,7 +472,7 @@ IN: parser.tests
[ 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 ( -- ) 1 ; >> : staging-problem-test-2 ( -- ) staging-problem-test-1 ;"
<string-reader> "staging-problem-test" parse-stream
] unit-test
@ -495,7 +491,7 @@ IN: parser.tests
! Bogus error message
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
[ ] [ f lexer set f file set "Hello world" note. ] unit-test
@ -510,7 +506,7 @@ SYMBOLS: a b c ;
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
[ f ] [ \ blah generic? ] unit-test
@ -523,13 +519,13 @@ DEFER: blah1
must-fail-with
IN: qualified.tests.foo
: x 1 ;
: y 5 ;
: x ( -- a ) 1 ;
: y ( -- a ) 5 ;
IN: qualified.tests.bar
: x 2 ;
: y 4 ;
: x ( -- a ) 2 ;
: y ( -- a ) 4 ;
IN: qualified.tests.baz
: x 3 ;
: x ( -- a ) 3 ;
QUALIFIED: qualified.tests.foo
QUALIFIED: qualified.tests.bar

View File

@ -132,7 +132,7 @@ IN: vocabs.loader.tests
"vocabs.loader.test.d" vocab source-loaded?>>
] unit-test
: forget-junk
: forget-junk ( -- )
[
{ "2" "a" "b" "d" "e" "f" }
[

View File

@ -1,3 +1,3 @@
IN: vocabs.loader.test.d
: foo iterate-next ;
: foo ( -- ) iterate-next ;

View File

@ -7,7 +7,7 @@ IN: advice.tests
[
[ ad-do-it ] must-fail
: foo "foo" ;
: foo ( -- str ) "foo" ;
\ foo make-advised
{ "bar" "foo" } [

View File

@ -1,44 +1,45 @@
USING: words kernel sequences locals locals.parser
locals.definitions accessors parser namespaces continuations
summary definitions generalizations arrays ;
IN: descriptive
ERROR: descriptive-error args underlying word ;
M: descriptive-error summary
word>> "The " swap name>> " word encountered an error."
3append ;
<PRIVATE
: rethrower ( word inputs -- quot )
[ length ] keep [ [ narray ] dip swap 2array flip ] 2curry
[ 2 ndip descriptive-error ] 2curry ;
: [descriptive] ( word def -- newdef )
swap dup "declared-effect" word-prop in>> rethrower
[ recover ] 2curry ;
PRIVATE>
: define-descriptive ( word def effect -- )
[ drop "descriptive-definition" set-word-prop ]
[ [ dupd [descriptive] ] dip define-declared ]
3bi ;
SYNTAX: DESCRIPTIVE: (:) define-descriptive ;
PREDICATE: descriptive < word
"descriptive-definition" word-prop ;
M: descriptive definer drop \ DESCRIPTIVE: \ ; ;
M: descriptive definition
"descriptive-definition" word-prop ;
SYNTAX: DESCRIPTIVE:: (::) define-descriptive ;
INTERSECTION: descriptive-lambda descriptive lambda-word ;
M: descriptive-lambda definer drop \ DESCRIPTIVE:: \ ; ;
M: descriptive-lambda definition
"lambda" word-prop body>> ;
USING: words kernel sequences locals locals.parser
locals.definitions accessors parser namespaces continuations
summary definitions generalizations arrays ;
IN: descriptive
ERROR: descriptive-error args underlying word ;
M: descriptive-error summary
word>> "The " swap name>> " word encountered an error."
3append ;
<PRIVATE
: rethrower ( word inputs -- quot )
[ length ] keep [ [ narray ] dip swap 2array flip ] 2curry
[ 2 ndip descriptive-error ] 2curry ;
: [descriptive] ( word def effect -- newdef )
swapd in>> rethrower [ recover ] 2curry ;
PRIVATE>
: define-descriptive ( word def effect -- )
[ drop "descriptive-definition" set-word-prop ]
[ [ [ dup ] 2dip [descriptive] ] keep define-declared ]
3bi ;
SYNTAX: DESCRIPTIVE: (:) define-descriptive ;
PREDICATE: descriptive < word
"descriptive-definition" word-prop ;
M: descriptive definer drop \ DESCRIPTIVE: \ ; ;
M: descriptive definition
"descriptive-definition" word-prop ;
SYNTAX: DESCRIPTIVE:: (::) define-descriptive ;
INTERSECTION: descriptive-lambda descriptive lambda-word ;
M: descriptive-lambda definer drop \ DESCRIPTIVE:: \ ; ;
M: descriptive-lambda definition
"lambda" word-prop body>> ;

View File

@ -31,8 +31,6 @@ IN: infix.tests
[ f ] [ 2 \ gcd check-word ] unit-test ! multiple return values
[ f ] [ 1 \ drop check-word ] unit-test ! no return value
[ f ] [ 1 \ lcm check-word ] unit-test ! takes 2 args
: no-stack-effect-declared + ;
[ 0 \ no-stack-effect-declared check-word ] must-fail
: qux ( -- x ) 2 ;
[ t ] [ 0 \ qux check-word ] unit-test

View File

@ -9,6 +9,6 @@ IN: lint.tests
: lint2 ( n -- n' ) 1 + ; ! 1+
[ { [ 1 + ] } ] [ \ lint2 lint ] unit-test
: lint3 dup -rot ; ! tuck
: lint3 ( a b -- b a b ) dup -rot ; ! tuck
[ { { lint3 { [ dup -rot ] } } } ] [ \ lint3 lint-word ] unit-test

View File

@ -2,8 +2,7 @@ USING: kernel math math.functions tools.test math.analysis
math.constants ;
IN: math.analysis.tests
: eps
.00000001 ;
CONSTANT: eps .00000001
[ t ] [ -9000000000000000000000000000000000000000000 gamma 1/0. = ] unit-test
[ t ] [ -1.5 gamma 2.363271801207344 eps ~ ] unit-test

View File

@ -4,11 +4,11 @@ kernel strings ;
[ { POSTPONE: f integer } ] [ { f integer } canonicalize-specializer-0 ] unit-test
: setup-canon-test
: setup-canon-test ( -- )
0 args set
V{ } clone hooks set ;
: canon-test-1
: canon-test-1 ( -- seq )
{ integer { cpu x86 } sequence } canonicalize-specializer-1 ;
[ { { -2 integer } { -1 sequence } { cpu x86 } } ] [
@ -36,12 +36,12 @@ kernel strings ;
] with-scope
] unit-test
: example-1
CONSTANT: example-1
{
{ { { cpu x86 } { os linux } } "a" }
{ { { cpu ppc } } "b" }
{ { string { os windows } } "c" }
} ;
}
[
{

View File

@ -1,7 +1,7 @@
IN: multi-methods.tests
USING: math strings sequences tools.test ;
GENERIC: legacy-test
GENERIC: legacy-test ( a -- b )
M: integer legacy-test sq ;
M: string legacy-test " hey" append ;

View File

@ -3,7 +3,7 @@ USING: kernel accessors assocs
sequences sequences.n-based tools.test ;
IN: sequences.n-based.tests
: months
: months ( -- assoc )
V{
"January"
"February"

View File

@ -106,7 +106,7 @@ STRING: test-svg-string
</svg>
;
: test-svg-path
: test-svg-path ( -- obj )
test-svg-string string>xml body>> children-tags first ;
[ { T{ moveto f { -1.0 -1.0 } f } T{ lineto f { 2.0 2.0 } t } } ]

View File

@ -15,7 +15,7 @@ IN: units.tests
[ t ] [ 1 m 2 m 3 m 3array d-product 6 m^3 = ] unit-test
[ t ] [ 3 m d-recip 1/3 { } { m } <dimensioned> = ] unit-test
: km/L km 1 L d/ ;
: mpg miles 1 gallons d/ ;
: km/L ( n -- d ) km 1 L d/ ;
: mpg ( n -- d ) miles 1 gallons d/ ;
[ t ] [ 100 10 / km/L [ mpg ] undo 23 1 ~ ] unit-test