-USING: tools.test kernel ;
+USING: tools.test kernel accessors ;
IN: calendar.format.macros
[ 2 ] [ { [ 2 ] } attempt-all-quots ] unit-test
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test combinators.smart math kernel ;
+USING: tools.test combinators.smart math kernel accessors ;
IN: combinators.smart.tests
: test-bi ( -- 9 11 )
{ HEX: fc411800 } [ 1 2 3 FCMPU ] test-assembler
{ HEX: fc411840 } [ 1 2 3 FCMPO ] test-assembler
{ HEX: 3c601234 HEX: 60635678 } [ HEX: 12345678 3 LOAD ] test-assembler
-
-"cpu.ppc.assembler" words [ must-infer ] each
USING: debugger kernel continuations tools.test ;\r
\r
[ ] [ [ drop ] [ error. ] recover ] unit-test\r
+\r
+[ f ] [ { } vm-error? ] unit-test\r
+[ f ] [ { "A" "B" } vm-error? ] unit-test
\ No newline at end of file
TUPLE: blahblah quux ;
-[ "an int" ] [ [ { "int" } $instance ] with-string-writer ] unit-test
+[ "int" ] [ [ { "int" } $instance ] with-string-writer ] unit-test
[ ] [ \ quux>> print-topic ] unit-test
[ ] [ \ >>quux print-topic ] unit-test
: comparison-test ( -- ? )
random-interval random-interval random-comparison
- [ [ [ random-element ] bi@ ] dip first execute ] 3keep
- second execute dup incomparable eq? [ 2drop t ] [ = ] if ;
+ [ [ [ random-element ] bi@ ] dip first execute( a b -- ? ) ] 3keep
+ second execute( a b -- ? ) dup incomparable eq? [ 2drop t ] [ = ] if ;
[ t ] [ 40000 iota [ drop comparison-test ] all? ] unit-test
"x[i][j].y" primary
] unit-test
-'ebnf' compile must-infer
-
{ V{ V{ "a" "b" } "c" } } [
"abc" [EBNF a="a" "b" foo=(a "c") EBNF]
] unit-test
[ ] [ enable-compiler ] unit-test
[ [ ] ] [ "" epsilon [ drop [ [ ] ] call ] action parse ] unit-test
-
-[ [ ] ] [ "" epsilon [ drop [ [ ] ] ] action [ call ] action parse ] unit-test
\ No newline at end of file
: regexp-parses ( string -- )
[ [ ] ] dip '[ _ parse-regexp drop ] unit-test ;
-: regexp-fails ( string -- regexp )
+: regexp-fails ( string -- )
'[ _ parse-regexp ] must-fail ;
{
USING: math kernel sequences io.files io.pathnames
tools.crossref tools.test parser namespaces source-files generic
-definitions ;
+definitions words accessors compiler.units ;
IN: tools.crossref.tests
GENERIC: foo ( a b -- c )
<PRIVATE
+SYMBOL: visited
+
GENERIC# quot-uses 1 ( obj assoc -- )
M: object quot-uses 2drop ;
M: word quot-uses over crossref? [ conjoin ] [ 2drop ] if ;
-: seq-uses ( seq assoc -- ) [ quot-uses ] curry each ;
+: (seq-uses) ( seq assoc -- )
+ [ quot-uses ] curry each ;
+
+: seq-uses ( seq assoc -- )
+ over visited get memq? [ 2drop ] [
+ over visited get push
+ (seq-uses)
+ ] if ;
+
+: assoc-uses ( assoc' assoc -- )
+ over visited get memq? [ 2drop ] [
+ over visited get push
+ [ >alist ] dip (seq-uses)
+ ] if ;
M: array quot-uses seq-uses ;
-M: hashtable quot-uses [ >alist ] dip seq-uses ;
+M: hashtable quot-uses assoc-uses ;
M: callable quot-uses seq-uses ;
M: wrapper quot-uses [ wrapped>> ] dip quot-uses ;
M: callable uses ( quot -- assoc )
- H{ } clone [ quot-uses ] keep keys ;
+ V{ } clone visited [
+ H{ } clone [ quot-uses ] keep keys
+ ] with-variable ;
M: word uses def>> uses ;
M: link uses { $subsection $link $see-also } article-links ;
-M: pathname uses string>> source-file top-level-form>> uses ;
+M: pathname uses string>> source-file top-level-form>> [ uses ] [ { } ] if* ;
GENERIC: crossref-def ( defspec -- )
[ 1 ] [ \ foobar counter>> ] unit-test
-: fooblah ( -- ) { } [ ] like call ;
+: fooblah ( -- ) { } [ ] like call( -- ) ;
: foobaz ( -- ) fooblah fooblah ;
[ concat [ quot call [ "" like ] map ] curry ] bi unit-test
] each ;
-: grapheme-test ( tests quot -- )
+: grapheme-test ( tests -- )
[
[ 1quotation ]
[ concat [ >graphemes [ "" like ] map ] curry ] bi unit-test
: test-two ( str1 str2 -- )\r
[ +lt+ ] -rot [ string<=> ] 2curry unit-test ;\r
\r
-: test-equality ( str1 str2 -- )\r
+: test-equality ( str1 str2 -- ? ? ? ? )\r
{ primary= secondary= tertiary= quaternary= }\r
- [ execute ] with with each ;\r
+ [ execute( a b -- ? ) ] with with map\r
+ first4 ;\r
\r
[ f f f f ] [ "hello" "hi" test-equality ] unit-test\r
[ t f f f ] [ "hello" "h\u0000e9llo" test-equality ] unit-test\r
locals math quotations assocs combinators unicode.normalize.private ;
IN: unicode.normalize.tests
-{ nfc nfkc nfd nfkd } [ must-infer ] each
-
[ "ab\u000323\u000302cd" ] [ "ab\u000302" "\u000323cd" string-append ] unit-test
[ "ab\u00064b\u000347\u00034e\u00034d\u000346" ] [ "ab\u000346\u000347\u00064b\u00034e\u00034d" dup reorder ] unit-test
[ [ 1 ] 2dip set-alien-unsigned-4 ] [ drop ] 2bi ;
: (callbacks>vtbl) ( callbacks -- vtbl )
- [ execute ] void*-array{ } map-as malloc-byte-array ;
+ [ execute( -- callback ) ] void*-array{ } map-as malloc-byte-array ;
: (callbacks>vtbls) ( callbacks -- vtbls )
[ (callbacks>vtbl) ] map ;
gc
] unit-test
-[ f ] [ { } kernel-error? ] unit-test
-[ f ] [ { "A" "B" } kernel-error? ] unit-test
-
! ! See how well callstack overflow is handled
! [ clear drop ] must-fail
!
! : callstack-overflow callstack-overflow f ;
! [ callstack-overflow ] must-fail
-: don't-compile-me ( n -- ) { } [ ] each ;
-
-: foo ( -- ) callstack "c" set 3 don't-compile-me ;
+: don't-compile-me ( -- ) ;
+: foo ( -- ) callstack "c" set don't-compile-me ;
: bar ( -- a b ) 1 foo 2 ;
-[ 1 3 2 ] [ bar ] unit-test
+<< { don't-compile-me foo bar } [ t "no-compile" set-word-prop ] each >>
+
+[ 1 2 ] [ bar ] unit-test
[ t ] [ \ bar def>> "c" get innermost-frame-quot = ] unit-test
USING: arrays byte-arrays kernel kernel.private math memory
namespaces sequences tools.test math.private quotations
continuations prettyprint io.streams.string debugger assocs
-sequences.private accessors locals.backend grouping ;
+sequences.private accessors locals.backend grouping words ;
IN: kernel.tests
[ 0 ] [ f size ] unit-test
: overflow-d ( -- ) 3 overflow-d ;
-[ overflow-d ] [ { "kernel-error" 12 f f } = ] must-fail-with
-
-[ ] [ :c ] unit-test
-
: (overflow-d-alt) ( -- n ) 3 ;
: overflow-d-alt ( -- ) (overflow-d-alt) overflow-d-alt ;
+: overflow-r ( -- ) 3 load-local overflow-r ;
+
+<<
+{ overflow-d (overflow-d-alt) overflow-d-alt overflow-r }
+[ t "no-compile" set-word-prop ] each
+>>
+
+[ overflow-d ] [ { "kernel-error" 12 f f } = ] must-fail-with
+
+[ ] [ :c ] unit-test
+
[ 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 ] [ { "kernel-error" 14 f f } = ] must-fail-with
[ ] [ :c ] unit-test
[ ] [ :c ] unit-test
! Doesn't compile; important
-: foo ( a -- b ) 5 + 0 [ ] each ;
+: foo ( a -- b ) ;
+
+<< \ foo t "no-compile" set-word-prop >>
[ drop foo ] must-fail
[ ] [ :c ] unit-test
[ pick ] dip swap [ pick ] dip swap
< [ [ 1+ ] 3dip (loop) ] [ 2drop 2drop ] if ; inline recursive
-: loop ( obj obj -- )
+: loop ( obj -- )
H{ } values swap [ dup length swap ] dip 0 -roll (loop) ;
[ loop ] must-fail
! Discovered on Windows
-: total-failure-1 ( -- ) "" [ ] map unimplemented ;
+: total-failure-1 ( -- a ) "" [ ] map unimplemented ;
[ total-failure-1 ] must-fail
sequences strings io.files io.pathnames definitions
continuations sorting classes.tuple compiler.units debugger
vocabs vocabs.loader accessors eval combinators lexer
-vocabs.parser words.symbol multiline source-files.errors ;
+vocabs.parser words.symbol multiline source-files.errors
+tools.crossref ;
IN: parser.tests
[
: %pop-output-line ( -- string ) irc> stream>> out>> lines>> pop ;
: read-matching-message ( chat quot: ( msg -- ? ) -- irc-message )
- [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ;
+ [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ; inline
: spawning-irc ( quot: ( -- ) -- )
[ spawn-client ] dip [ (terminate-irc) ] compose with-irc ; inline