Fixing unit tests for syntax change
parent
70192ce0d5
commit
723bfab030
|
@ -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 ] [
|
||||
|
|
|
@ -4,7 +4,7 @@ prettyprint ;
|
|||
|
||||
[ 0 ] [ 123 <byte-vector> length ] unit-test
|
||||
|
||||
: do-it
|
||||
: do-it ( seq -- seq )
|
||||
123 [ over push ] each ;
|
||||
|
||||
[ t ] [
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 }
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
[ ] [
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
[ "" ] [
|
||||
[
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 )
|
||||
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 }
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 + ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 }
|
||||
|
|
|
@ -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 ( ? ? -- )
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 )
|
||||
{
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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 ] [
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
IN: io.tests
|
||||
USE: math
|
||||
: foo 2 2 + ;
|
||||
: foo ( -- x ) 2 2 + ;
|
||||
FORGET: foo
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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" }
|
||||
[
|
||||
|
|
|
@ -1,3 +1,3 @@
|
|||
IN: vocabs.loader.test.d
|
||||
|
||||
: foo iterate-next ;
|
||||
: foo ( -- ) iterate-next ;
|
|
@ -7,7 +7,7 @@ IN: advice.tests
|
|||
[
|
||||
[ ad-do-it ] must-fail
|
||||
|
||||
: foo "foo" ;
|
||||
: foo ( -- str ) "foo" ;
|
||||
\ foo make-advised
|
||||
|
||||
{ "bar" "foo" } [
|
||||
|
|
|
@ -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>> ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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" }
|
||||
} ;
|
||||
}
|
||||
|
||||
[
|
||||
{
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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 } } ]
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue