\r
[ 0 ] [ 123 <bit-vector> length ] unit-test\r
\r
-: do-it\r
+: do-it ( seq -- )\r
1234 swap [ [ even? ] dip push ] curry each ;\r
\r
[ t ] [\r
\r
[ 0 ] [ 123 <byte-vector> length ] unit-test\r
\r
-: do-it\r
+: do-it ( seq -- seq )\r
123 [ over push ] each ;\r
\r
[ t ] [\r
[ 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
[ gc "x" set 2drop ]
} ;
-: test-foo
+: test-foo ( -- )
Foo -> alloc -> init
dup 1.0 2.0 101.0 102.0 <CGRect> -> foo:
-> release ;
[ 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 ;
swap >>n
swap >>m ;
-: test-bignum
+: test-bignum ( -- )
bignum-test "BIGNUM_TEST"
{
{ "id" "ID" +db-assigned-id+ }
TUPLE: secret n message ;
C: <secret> secret
-: test-random-id
+: test-random-id ( -- )
secret "SECRET"
{
{ "n" "ID" +random-id+ system-random-generator }
[ "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 ;
{ "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
[ "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
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 ;
splitting destructors sequences db db.tuples db.sqlite\r
continuations urls math.parser furnace furnace.utilities ;\r
\r
-: with-session\r
+: with-session ( session quot -- )\r
[\r
[ [ save-session-after ] [ session set ] bi ] dip call\r
] with-destructors ; inline\r
"x" [ 1+ ] schange\r
"x" sget number>string "text/html" <content> ;\r
\r
-: url-responder-mock-test\r
+: url-responder-mock-test ( -- )\r
[\r
<request>\r
"GET" >>method\r
[ write-response-body drop ] with-string-writer\r
] with-destructors ;\r
\r
-: sessions-mock-test\r
+: sessions-mock-test ( -- )\r
[\r
<request>\r
"GET" >>method\r
[ write-response-body drop ] with-string-writer\r
] with-destructors ;\r
\r
-: <exiting-action>\r
+: <exiting-action> ( -- action )\r
<action>\r
[ [ ] "text/plain" <content> exit-with ] >>display ;\r
\r
[ 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
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 ] [
] 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
[ ] [
[
[ 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
] 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
"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
[ ] [ \ >>quux print-topic ] unit-test
[ ] [ \ blahblah? print-topic ] unit-test
-: fooey "fooey" throw ;
+: fooey ( -- * ) "fooey" throw ;
[ ] [ \ fooey print-topic ] unit-test
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
] run-template
] unit-test
-: test4-aux? t ;
+: test4-aux? ( -- ? ) t ;
[ "True" ] [
[
] run-template
] unit-test
-: test5-aux? f ;
+: test5-aux? ( -- ? ) f ;
[ "" ] [
[
[ "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
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
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
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
] { } 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
[ ] [ "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
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
! 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 ;
[
[ ] [
- "IN: listener.tests : hello\n\"world\" ;" parse-interactive
+ "IN: listener.tests : hello ( -- )\n\"world\" ;" parse-interactive
drop
] unit-test
] with-file-vocabs
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
[ 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
:: 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
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 )
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
<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 ;
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 ;
tools.test models.range ;\r
\r
! Test <range> \r
-: setup-range 0 0 0 255 <range> ;\r
+: setup-range ( -- range ) 0 0 0 255 <range> ;\r
\r
! clamp-value should not go past range ends\r
[ 0 ] [ -10 setup-range clamp-value ] unit-test\r
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 }
[ "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
] keep =
] with-scope ;
-GENERIC: method-layout
+GENERIC: method-layout ( a -- b )
M: complex method-layout
"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
[ \ 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"
DEFER: parse-error-file
-: another-soft-break-test
+: another-soft-break-test ( -- str )
{
"USING: make sequences ;"
"IN: prettyprint.tests"
check-see
] unit-test
-: string-layout
+: string-layout ( -- str )
{
"USING: accessors debugger io kernel ;"
"IN: prettyprint.tests"
\ send soft "break-after" set-word-prop
-: final-soft-break-test
+: final-soft-break-test ( -- str )
{
"USING: kernel sequences ;"
"IN: prettyprint.tests"
"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"
"narrow-layout" narrow-test check-see
] unit-test
-: another-narrow-test
+: another-narrow-test ( -- str )
{
"IN: prettyprint.tests"
": another-narrow-layout ( -- obj )"
TUPLE: started-out-hustlin' ;
-GENERIC: ended-up-ballin'
+GENERIC: ended-up-ballin' ( a -- b )
M: started-out-hustlin' ended-up-ballin' ; inline
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 = ;
C: <serialize-test> serialize-test
-: objects
+CONSTANT: objects
{
f
t
<< 1 [ 2 ] curry parsed >>
{ { "a" "bc" } { "de" "fg" } }
H{ { "a" "bc" } { "de" "fg" } }
- } ;
+ }
: check-serialize-1 ( obj -- ? )
"=====" print
io.streams.string kernel strings ;
IN: tools.annotations.tests
-: foo ;
+: foo ( -- ) ;
\ foo watch
[ ] [ foo ] unit-test
definitions ;
IN: tools.crossref.tests
-GENERIC: foo
+GENERIC: foo ( a b -- c )
M: integer foo + ;
[ 2 2 fixnum+ ] test-walker
] unit-test
-: foo 2 2 fixnum+ ;
+: foo ( -- x ) 2 2 fixnum+ ;
[ { 8 } ] [
[ foo 4 fixnum+ ] test-walker
TUPLE: foo-gadget ;
-: com-foo-a ;
+: com-foo-a ( -- ) ;
-: com-foo-b ;
+: com-foo-b ( -- ) ;
\ foo-gadget "toolbar" f {
{ f com-foo-a }
[ { 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 ( ? ? -- )
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
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
[ ] [ <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
USING: urls urls.private tools.test
arrays kernel assocs present accessors ;
-: urls
+CONSTANT: urls
{
{
T{ url
}
"ftp://slava:secret@ftp.kernel.org/"
}
- } ;
+ }
urls [
[ 1array ] [ [ >url ] curry ] bi* unit-test
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
} case
] unit-test
-: do-not-call "do not call" throw ;
+: do-not-call ( -- * ) "do not call" throw ;
: test-case-6 ( obj -- value )
{
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) ;
! : 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
TUPLE: dummy-obj destroyed? ;
-: <dummy-obj> dummy-obj new ;
+: <dummy-obj> ( -- obj ) dummy-obj new ;
TUPLE: dummy-destructor obj ;
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 ] [
IN: io.tests
USE: math
-: foo 2 2 + ;
+: foo ( -- x ) 2 2 + ;
FORGET: foo
\ No newline at end of file
[ ] [ :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
[ ] [ :c ] unit-test
! Doesn't compile; important
-: foo 5 + 0 [ ] each ;
+: foo ( a -- b ) 5 + 0 [ ] each ;
[ drop foo ] must-fail
[ ] [ :c ] unit-test
[ loop ] must-fail
! Discovered on Windows
-: total-failure-1 "" [ ] map unimplemented ;
+: total-failure-1 ( -- ) "" [ ] map unimplemented ;
[ total-failure-1 ] must-fail
[ "hello world" ]
[
- "IN: parser.tests : hello \"hello world\" ;"
+ "IN: parser.tests : hello ( -- str ) \"hello world\" ;"
eval "USE: parser.tests hello" eval
] unit-test
[ 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
[ ] [ "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
! 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
[ 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
[ 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
] 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
[ ] [
"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
"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
] unit-test
[ f ] [
- "IN: parser.tests : x ;"
+ "IN: parser.tests : x ( -- ) ;"
<string-reader> "a" parse-stream drop
"y" "parser.tests" lookup
! 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
! 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
! 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
] unit-test
[ ] [
- "IN: azz GENERIC: a-generic"
+ "IN: azz GENERIC: a-generic ( a -- b )"
<string-reader> "azz" parse-stream drop
] unit-test
] 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
] 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
] 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
] [ 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
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
[ 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
{
"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
{
"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
] 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
[ 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
! 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
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
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
"vocabs.loader.test.d" vocab source-loaded?>>
] unit-test
-: forget-junk
+: forget-junk ( -- )
[
{ "2" "a" "b" "d" "e" "f" }
[
IN: vocabs.loader.test.d
-: foo iterate-next ;
\ No newline at end of file
+: foo ( -- ) iterate-next ;
\ No newline at end of file
[
[ ad-do-it ] must-fail
- : foo "foo" ;
+ : foo ( -- str ) "foo" ;
\ foo make-advised
{ "bar" "foo" } [
-USING: words kernel sequences locals locals.parser\r
-locals.definitions accessors parser namespaces continuations\r
-summary definitions generalizations arrays ;\r
-IN: descriptive\r
-\r
-ERROR: descriptive-error args underlying word ;\r
-\r
-M: descriptive-error summary\r
- word>> "The " swap name>> " word encountered an error."\r
- 3append ;\r
-\r
-<PRIVATE\r
-: rethrower ( word inputs -- quot )\r
- [ length ] keep [ [ narray ] dip swap 2array flip ] 2curry\r
- [ 2 ndip descriptive-error ] 2curry ;\r
-\r
-: [descriptive] ( word def -- newdef )\r
- swap dup "declared-effect" word-prop in>> rethrower\r
- [ recover ] 2curry ;\r
-PRIVATE>\r
-\r
-: define-descriptive ( word def effect -- )\r
- [ drop "descriptive-definition" set-word-prop ]\r
- [ [ dupd [descriptive] ] dip define-declared ]\r
- 3bi ;\r
-\r
-SYNTAX: DESCRIPTIVE: (:) define-descriptive ;\r
-\r
-PREDICATE: descriptive < word\r
- "descriptive-definition" word-prop ;\r
-\r
-M: descriptive definer drop \ DESCRIPTIVE: \ ; ;\r
-\r
-M: descriptive definition\r
- "descriptive-definition" word-prop ;\r
-\r
-SYNTAX: DESCRIPTIVE:: (::) define-descriptive ;\r
-\r
-INTERSECTION: descriptive-lambda descriptive lambda-word ;\r
-\r
-M: descriptive-lambda definer drop \ DESCRIPTIVE:: \ ; ;\r
-\r
-M: descriptive-lambda definition\r
- "lambda" word-prop body>> ;\r
+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>> ;
[ 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
: 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
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
[ { 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 } } ] [
] with-scope
] unit-test
-: example-1
+CONSTANT: example-1
{
{ { { cpu x86 } { os linux } } "a" }
{ { { cpu ppc } } "b" }
{ { string { os windows } } "c" }
- } ;
+ }
[
{
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 ;
sequences sequences.n-based tools.test ;
IN: sequences.n-based.tests
-: months
+: months ( -- assoc )
V{
"January"
"February"
</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 } } ]
[ 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
projects / factor.git / commitdiff