[ resume ] curry instant later drop\r
] "test" suspend drop\r
] unit-test\r
-\r
-\ alarm-thread-loop must-infer\r
USING: alien alien.syntax alien.c-types kernel tools.test
sequences system libc alien.strings io.encodings.utf8 ;
-\ expand-constants must-infer
-
CONSTANT: xyz 123
[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
[ { 33 52 17 40 12 51 33 43 18 33 23 } base64> ]
[ malformed-base64? ] must-fail-with
-
-\ >base64 must-infer
-\ base64> must-infer
IN: binary-search.tests
USING: binary-search math.order vectors kernel tools.test ;
-\ sorted-member? must-infer
-
[ f ] [ 3 { } [ <=> ] with search drop ] unit-test
[ 0 ] [ 3 { 3 } [ <=> ] with search drop ] unit-test
[ 1 ] [ 2 { 1 2 3 } [ <=> ] with search drop ] unit-test
USING: bootstrap.image bootstrap.image.private tools.test
kernel math ;
-\ ' must-infer
-\ write-image must-infer
-
[ f ] [ { 1 2 3 } [ 1 2 3 ] eql? ] unit-test
[ t ] [ [ 1 2 3 ] [ 1 2 3 ] eql? ] unit-test
continuations system math.order threads ;
IN: calendar.tests
-\ time+ must-infer
-\ time* must-infer
-\ time- must-infer
-
[ f ] [ 2004 12 32 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2004 2 30 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2003 2 29 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
: compiled-test-1 ( -- n )
{ [ 1 throw ] [ 2 ] } attempt-all-quots ;
-\ compiled-test-1 must-infer
+\ compiled-test-1 def>> must-infer
[ 2 ] [ compiled-test-1 ] unit-test
: nested-smart-combo-test ( -- array )
[ [ 1 2 ] output>array [ 3 4 ] output>array ] output>array ;
-\ nested-smart-combo-test must-infer
+\ nested-smart-combo-test def>> must-infer
[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test
compiler.cfg.builder compiler.cfg.debugger arrays locals byte-arrays
kernel.private math ;
-\ build-cfg must-infer
-
! Just ensure that various CFGs build correctly.
: unit-test-cfg ( quot -- ) '[ _ test-cfg drop ] [ ] swap unit-test ;
USING: compiler.cfg.linear-scan.assignment tools.test ;
IN: compiler.cfg.linear-scan.assignment.tests
-\ assign-registers must-infer
+
IN: compiler.cfg.linearization.tests
USING: compiler.cfg.linearization tools.test ;
-\ build-mr must-infer
+
+++ /dev/null
-IN: compiler.tests
-USING: words kernel stack-checker alien.strings tools.test
-compiler.units ;
-
-[ ] [ [ \ if redefined ] with-compilation-unit [ string>alien ] infer. ] unit-test
: lift-loop-tail-test-2 ( -- a b c )
10 [ ] lift-loop-tail-test-1 1 2 3 ;
-\ lift-loop-tail-test-2 must-infer
+\ lift-loop-tail-test-2 def>> must-infer
[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test
: member-test ( obj -- ? ) { + - * / /i } member? ;
-\ member-test must-infer
+\ member-test def>> must-infer
[ ] [ \ member-test build-tree-from-word optimize-tree drop ] unit-test
[ t ] [ \ + member-test ] unit-test
[ f ] [ \ append member-test ] unit-test
dup "a" get { array-capacity } declare >=
[ dup "b" get { array-capacity } declare >= [ 3 ] [ 4 ] if ] [ 5 ] if ;
-\ interval-inference-bug must-infer
+[ t ] [ \ interval-inference-bug optimized>> ] unit-test
[ ] [ 1 "a" set 2 "b" set ] unit-test
[ 2 3 ] [ 2 interval-inference-bug ] unit-test
fixnum string [ \ method-redefine-generic-2 method forget ] bi@
] with-compilation-unit
] unit-test
-
-! Test ripple-up behavior
-: hey ( -- ) ;
-: there ( -- ) hey ;
-
-[ t ] [ \ hey optimized>> ] unit-test
-[ t ] [ \ there optimized>> ] unit-test
-[ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval( -- ) ] unit-test
-[ f ] [ \ hey optimized>> ] unit-test
-[ f ] [ \ there optimized>> ] unit-test
-[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval( -- ) ] unit-test
-[ t ] [ \ there optimized>> ] unit-test
-
-: good ( -- ) ;
-: bad ( -- ) good ;
-: ugly ( -- ) bad ;
-
-[ t ] [ \ good optimized>> ] unit-test
-[ t ] [ \ bad optimized>> ] unit-test
-[ t ] [ \ ugly optimized>> ] unit-test
-
-[ f ] [ \ good compiled-usage assoc-empty? ] unit-test
-
-[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval( -- ) ] unit-test
-
-[ f ] [ \ good optimized>> ] unit-test
-[ f ] [ \ bad optimized>> ] unit-test
-[ f ] [ \ ugly optimized>> ] unit-test
-
-[ t ] [ \ good compiled-usage assoc-empty? ] unit-test
-
-[ ] [ "IN: compiler.tests : good ( -- ) ;" eval( -- ) ] unit-test
-
-[ t ] [ \ good optimized>> ] unit-test
-[ t ] [ \ bad optimized>> ] unit-test
-[ t ] [ \ ugly optimized>> ] unit-test
-
-[ f ] [ \ good compiled-usage assoc-empty? ] unit-test
[ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- )" eval( -- ) ] unit-test
[ ] [ "IN: compiler.tests.redefine16 USING: strings math arrays prettyprint ; M: string blah 1 + 3array . ;" eval( -- ) ] unit-test
-[ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- x )" eval( -- ) ] unit-test
-[ "blah" "compiler.tests.redefine16" lookup 1quotation infer ] must-fail
+[ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- x )" eval( -- ) ] unit-test
\ No newline at end of file
arrays memory vocabs parser eval ;
IN: compiler.tests
-\ (compile) must-infer
-
! Test empty word
[ ] [ [ ] compile-call ] unit-test
IN: compiler.tree.builder.tests
USING: compiler.tree.builder tools.test sequences kernel
-compiler.tree ;
-
-\ build-tree must-infer
-\ build-tree-with must-infer
-\ build-tree-from-word must-infer
+compiler.tree stack-checker stack-checker.errors ;
: inline-recursive ( -- ) inline-recursive ; inline recursive
[ t ] [ \ inline-recursive build-tree-from-word [ #recursive? ] any? ] unit-test
+
+: bad-recursion-1 ( a -- b )
+ dup [ drop bad-recursion-1 5 ] [ ] if ;
+
+[ \ bad-recursion-1 build-tree-from-word ] [ inference-error? ] must-fail-with
+
+FORGET: bad-recursion-1
+
+: bad-recursion-2 ( obj -- obj )
+ dup [ dup first swap second bad-recursion-2 ] [ ] if ;
+
+[ \ bad-recursion-2 build-tree-from-word ] [ inference-error? ] must-fail-with
+
+FORGET: bad-recursion-2
+
+: bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ;
+
+[ \ bad-bin build-tree-from-word ] [ inference-error? ] must-fail-with
+
+FORGET: bad-bin
IN: compiler.tree.checker.tests
USING: compiler.tree.checker tools.test ;
-\ check-nodes must-infer
+
sequences.private arrays classes kernel.private ;
IN: compiler.tree.dead-code.tests
-\ remove-dead-code must-infer
-
: count-live-values ( quot -- n )
build-tree
analyze-recursive
IN: compiler.tree.debugger.tests
USING: compiler.tree.debugger tools.test sorting sequences io math.order ;
-\ optimized. must-infer
-\ optimizer-report. must-infer
-
[ [ <=> ] sort ] optimized.
[ <reversed> [ print ] each ] optimizer-report.
\ No newline at end of file
binary-search compiler.tree.checker ;
IN: compiler.tree.def-use.tests
-\ compute-def-use must-infer
-
[ t ] [
[ 1 2 3 ] build-tree compute-def-use drop
def-use get {
compiler.tree.checker
kernel.private ;
-\ escape-analysis must-infer
-
GENERIC: count-unboxed-allocations* ( m node -- n )
: (count-unboxed-allocations) ( m node -- n )
compiler.tree compiler.tree.checker
sequences accessors tools.test kernel math ;
-\ count-introductions must-infer
-\ normalize must-infer
-
[ 3 ] [ [ 3drop 1 2 3 ] build-tree count-introductions ] unit-test
[ 4 ] [ [ 3drop 1 2 3 3drop drop ] build-tree count-introductions ] unit-test
USING: compiler.tree.optimizer tools.test ;
IN: compiler.tree.optimizer.tests
-\ optimize-tree must-infer
+
math.intervals ;
IN: compiler.tree.propagation.tests
-\ propagate must-infer
-
[ V{ } ] [ [ ] final-classes ] unit-test
[ V{ fixnum } ] [ [ 1 ] final-classes ] unit-test
[ { f t t t } ] [ t { f f t t } (tail-calls) ] unit-test
[ { f f f t } ] [ t { f f t f } (tail-calls) ] unit-test
-\ analyze-recursive must-infer
-
: label-is-loop? ( nodes word -- ? )
[
{
} 2&&
] curry contains-node? ;
-\ label-is-loop? must-infer
-
: label-is-not-loop? ( nodes word -- ? )
[
{
} 2&&
] curry contains-node? ;
-\ label-is-not-loop? must-infer
-
: loop-test-1 ( a -- )
dup [ 1+ loop-test-1 ] [ drop ] if ; inline recursive
math.private sorting math.order binary-search sequences.private
slots.private ;
-\ unbox-tuples must-infer
-
: test-unboxing ( quot -- )
build-tree
analyze-recursive
USING: db.pools tools.test continuations io.files io.files.temp
io.directories namespaces accessors kernel math destructors ;
-\ <db-pool> must-infer
-
{ 1 0 } [ [ ] with-db-pool ] must-infer-as
{ 1 0 } [ [ ] with-pooled-db ] must-infer-as
[ test-string-encoding ] test-sqlite
[ test-string-encoding ] test-postgresql
-! Don't comment these out. These words must infer
-\ bind-tuple must-infer
-\ insert-tuple must-infer
-\ update-tuple must-infer
-\ delete-tuples must-infer
-\ select-tuple must-infer
-\ define-persistent must-infer
-\ ensure-table must-infer
-\ create-table must-infer
-\ drop-table must-infer
-
: test-queries ( -- )
[ ] [ exam ensure-table ] unit-test
[ ] [ 1000 [ random-exam insert-tuple ] times ] unit-test
>>
-\ sqsq must-infer
-
[ 16 ] [ 2 sqsq ] unit-test
<<
USING: furnace.auth tools.test ;
IN: furnace.auth.tests
-\ logged-in-username must-infer
-\ <protected> must-infer
-\ new-realm must-infer
IN: furnace.auth.features.edit-profile.tests
USING: tools.test furnace.auth.features.edit-profile ;
-\ allow-edit-profile must-infer
+
IN: furnace.auth.features.recover-password
USING: tools.test furnace.auth.features.recover-password ;
-\ allow-password-recovery must-infer
+
IN: furnace.auth.features.registration.tests
USING: tools.test furnace.auth.features.registration ;
-\ allow-registration must-infer
+
IN: furnace.auth.login.tests\r
USING: tools.test furnace.auth.login ;\r
\r
-\ <login-realm> must-infer\r
+\r
IN: furnace.db.tests
USING: tools.test furnace.db ;
-\ <db-persistence> must-infer
+
[ "a string, a fixnum, or an integer" ]
[ [ { $or string fixnum integer } print-element ] with-string-writer ] unit-test
-\ print-element must-infer
-\ print-topic must-infer
\ No newline at end of file
namespaces assocs source-files eval ;
IN: help.topics.tests
-\ article-name must-infer
-\ article-title must-infer
-\ article-content must-infer
-\ article-parent must-infer
-
! Test help cross-referencing
[ ] [ "Test B" { "Hello world." } <article> { "test" "b" } add-article ] unit-test
html.components html.forms namespaces
xml.writer ;
-\ render must-infer
-
[ ] [ begin-form ] unit-test
[ ] [ 3 "hi" set-value ] unit-test
USING: http.client http.client.private http tools.test
namespaces urls ;
-\ download must-infer
-
[ "localhost" f ] [ "localhost" parse-host ] unit-test
[ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test
assocs arrays classes words urls ;
IN: http.server.dispatchers.tests
-\ find-responder must-infer
-
TUPLE: mock-responder path ;
C: <mock-responder> mock-responder
USING: http http.server.redirection urls accessors
namespaces tools.test present kernel ;
-\ relative-to-request must-infer
-
[
<request>
<url>
[ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test
-\ make-http-error must-infer
-
[ "text/plain; charset=UTF-8" ] [
<response>
"text/plain" >>content-type
sequences io.files.temp ;
IN: io.files.info.tests
-\ file-info must-infer
-\ link-info must-infer
-
[ t ] [
temp-directory [ "hi41" "test41" utf8 set-file-contents ] with-directory
temp-directory "test41" append-path utf8 file-contents "hi41" =
IN: io.launcher.tests
USING: tools.test io.launcher ;
-\ <process-stream> must-infer
-\ <process-reader> must-infer
-\ <process-writer> must-infer
io.pathnames io.files.temp io.directories.hierarchy ;
IN: io.monitors.recursive.tests
-\ pump-thread must-infer
-
SINGLETON: mock-io-backend
TUPLE: counter i ;
IN: io.monitors.windows.nt.tests\r
USING: io.monitors.windows.nt tools.test ;\r
\r
-\ fill-queue-thread must-infer\r
+\r
concurrency.promises byte-arrays locals calendar io.timeouts
io.sockets.secure.unix.debug ;
-\ <secure-config> must-infer
{ 1 0 } [ [ ] with-secure-context ] must-infer-as
[ ] [ <promise> "port" set ] unit-test
IN: io.styles.tests
USING: io.styles tools.test ;
-
-\ stream-format must-infer
-\ stream-write-table must-infer
-\ make-span-stream must-infer
-\ make-block-stream must-infer
-\ make-cell-stream must-infer
\ No newline at end of file
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test lcs ;
-\ lcs must-infer
-\ diff must-infer
-\ levenshtein must-infer
-
[ 3 ] [ "sitting" "kitten" levenshtein ] unit-test
[ 3 ] [ "kitten" "sitting" levenshtein ] unit-test
[ 1 ] [ "freshpak" "freshpack" levenshtein ] unit-test
IN: locals.backend.tests
-USING: tools.test locals.backend kernel arrays ;
+USING: tools.test locals.backend kernel arrays accessors ;
: get-local-test-1 ( -- x ) 3 1 load-locals 0 get-local 1 drop-locals ;
-\ get-local-test-1 must-infer
+\ get-local-test-1 def>> must-infer
[ 3 ] [ get-local-test-1 ] unit-test
: get-local-test-2 ( -- x ) 3 4 2 load-locals -1 get-local 2 drop-locals ;
-\ get-local-test-2 must-infer
+\ get-local-test-2 def>> must-infer
[ 3 ] [ get-local-test-2 ] unit-test
[ { 1 2 } ] [ 2 let-test-4 ] unit-test
-:: let-test-5 ( a -- b )
- a [let | a [ ] b [ ] | a b 2array ] ;
+:: let-test-5 ( a b -- b )
+ a b [let | a [ ] b [ ] | a b 2array ] ;
[ { 2 1 } ] [ 1 2 let-test-5 ] unit-test
SYMBOL: a
:: use-test ( a b c -- a b c )
- USE: kernel ;
+ USE: kernel
+ a b c ;
[ t ] [ a symbol? ] unit-test
[ ] [ \ lambda-generic see ] unit-test
-:: unparse-test-1 ( a -- ) [let | a! [ ] | ] ;
+:: unparse-test-1 ( a -- ) [let | a! [ 3 ] | ] ;
-[ "[let | a! [ ] | ]" ] [
+[ "[let | a! [ 3 ] | ]" ] [
\ unparse-test-1 "lambda" word-prop body>> first unparse
] unit-test
{ [ a b > ] [ 5 ] }
} cond ;
-\ cond-test must-infer
+\ cond-test def>> must-infer
[ 3 ] [ 1 2 cond-test ] unit-test
[ 4 ] [ 2 2 cond-test ] unit-test
:: 0&&-test ( a -- ? )
{ [ a integer? ] [ a even? ] [ a 10 > ] } 0&& ;
-\ 0&&-test must-infer
+\ 0&&-test def>> must-infer
[ f ] [ 1.5 0&&-test ] unit-test
[ f ] [ 3 0&&-test ] unit-test
:: &&-test ( a -- ? )
{ [ a integer? ] [ a even? ] [ a 10 > ] } && ;
-\ &&-test must-infer
+\ &&-test def>> must-infer
[ f ] [ 1.5 &&-test ] unit-test
[ f ] [ 3 &&-test ] unit-test
]
] ;
-\ let-and-cond-test-1 must-infer
+\ let-and-cond-test-1 def>> must-infer
[ 20 ] [ let-and-cond-test-1 ] unit-test
]
] ;
-\ let-and-cond-test-2 must-infer
+\ let-and-cond-test-2 def>> must-infer
[ { 10 20 } ] [ let-and-cond-test-2 ] unit-test
{ 5 [ a a ^ ] }
} case ;
-\ big-case-test must-infer
+\ big-case-test def>> must-infer
[ 9 ] [ 3 big-case-test ] unit-test
[| x | x 12 + { "howdy" } nth ]
} case ;
-\ littledan-case-problem-1 must-infer
+\ littledan-case-problem-1 def>> must-infer
[ "howdy" ] [ -12 \ littledan-case-problem-1 def>> call ] unit-test
[ "howdy" ] [ -12 littledan-case-problem-1 ] unit-test
[| x | x a - { "howdy" } nth ]
} case ;
-\ littledan-case-problem-2 must-infer
+\ littledan-case-problem-2 def>> must-infer
[ "howdy" ] [ -12 \ littledan-case-problem-2 def>> call ] unit-test
[ "howdy" ] [ -12 littledan-case-problem-2 ] unit-test
[| x | x a - { "howdy" } nth ]
} cond ;
-\ littledan-cond-problem-1 must-infer
+\ littledan-cond-problem-1 def>> must-infer
[ f ] [ -12 \ littledan-cond-problem-1 def>> call ] unit-test
[ 4 ] [ 12 \ littledan-cond-problem-1 def>> call ] unit-test
: littledan-case-problem-4 ( a -- b )
[ 1 + ] littledan-case-problem-3 ;
-\ littledan-case-problem-4 must-infer
+\ littledan-case-problem-4 def>> must-infer
*/
GENERIC: lambda-method-forget-test ( a -- b )
-M:: integer lambda-method-forget-test ( a -- b ) ;
+M:: integer lambda-method-forget-test ( a -- b ) a ;
[ ] [ [ M\ integer lambda-method-forget-test forget ] with-compilation-unit ] unit-test
:: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline
: funny-macro-test ( n -- ? ) [ odd? ] (funny-macro-test) ;
-\ funny-macro-test must-infer
+\ funny-macro-test def>> must-infer
[ t ] [ 3 funny-macro-test ] unit-test
[ f ] [ 2 funny-macro-test ] unit-test
:: FAILdog-1 ( -- b ) { [| c | c ] } ;
-\ FAILdog-1 must-infer
+\ FAILdog-1 def>> must-infer
:: FAILdog-2 ( a -- b ) a { [| c | c ] } cond ;
-\ FAILdog-2 must-infer
+\ FAILdog-2 def>> must-infer
[ 3 ] [ 3 [| a | \ a ] call ] unit-test
{ [ is-integer? ] [ is-even? ] [ >10? ] } &&
] ;
-\ wlet-&&-test must-infer
+\ wlet-&&-test def>> must-infer
[ f ] [ 1.5 wlet-&&-test ] unit-test
[ f ] [ 3 wlet-&&-test ] unit-test
[ f ] [ 8 wlet-&&-test ] unit-test
: fry-locals-test-1 ( -- n )
[let | | 6 '[ [let | A [ 4 ] | A _ + ] ] call ] ;
-\ fry-locals-test-1 must-infer
+\ fry-locals-test-1 def>> must-infer
[ 10 ] [ fry-locals-test-1 ] unit-test
:: fry-locals-test-2 ( -- n )
[let | | 6 '[ [let | A [ 4 ] | A _ + ] ] call ] ;
-\ fry-locals-test-2 must-infer
+\ fry-locals-test-2 def>> must-infer
[ 10 ] [ fry-locals-test-2 ] unit-test
[ 1 ] [ 3 4 [| | '[ [ _ swap - ] call ] call ] call ] unit-test
[ 3 ] [ foo ] unit-test
[ 3 ] [ { a b } flags ] unit-test
-\ foo must-infer
+\ foo def>> must-infer
[ 1 ] [ { 1 } flags ] unit-test
"tester" get
"model-c" get value>>
] unit-test
-
-\ model-changed must-infer
-\ set-model must-infer
peg peg.private peg.parsers accessors words math accessors ;
IN: peg.tests
-\ parse must-infer
-
[ ] [ reset-pegs ] unit-test
[
"abc 123 def 456" 'integer' [ 2 * number>string ] action replace
] unit-test
-\ search must-infer
-\ replace must-infer
persistent.sequences sequences kernel arrays random namespaces
vectors math math.order ;
-\ new-nth must-infer
-\ ppush must-infer
-\ ppop must-infer
-
[ 0 ] [ PV{ } length ] unit-test
[ 1 ] [ 3 PV{ } ppush length ] unit-test
eval strings multiline accessors ;
IN: regexp-tests
-\ <regexp> must-infer
-\ compile-regexp must-infer
-\ matches? must-infer
-
[ f ] [ "b" "a*" <regexp> matches? ] unit-test
[ t ] [ "" "a*" <regexp> matches? ] unit-test
[ t ] [ "a" "a*" <regexp> matches? ] unit-test
concurrency.promises system ;
IN: smtp.tests
-\ send-email must-infer
-
{ 0 0 } [ [ ] with-smtp-connection ] must-infer-as
[ "hello\nworld" validate-address ] must-fail
system compiler.units ;
IN: stack-checker.tests
-\ infer. must-infer
+[ 1234 infer ] must-fail
{ 0 2 } [ 2 "Hello" ] must-infer-as
{ 1 2 } [ dup ] must-infer-as
{ 1 1 } [ simple-recursion-2 ] must-infer-as
-: bad-recursion-2 ( obj -- obj )
- dup [ dup first swap second bad-recursion-2 ] [ ] if ;
-
-[ [ bad-recursion-2 ] infer ] must-fail
-
: funny-recursion ( obj -- obj )
dup [ funny-recursion 1 ] [ 2 ] if drop ;
over string? [ 2array throw ] unless
] must-infer-as
-! Regression
-
-! This order of branches works
-DEFER: do-crap
-: more-crap ( obj -- ) dup [ drop ] [ dup do-crap call ] if ;
-: do-crap ( obj -- ) dup [ more-crap ] [ do-crap ] if ;
-[ [ do-crap ] infer ] must-fail
-
-! This one does not
-DEFER: do-crap*
-: more-crap* ( obj -- ) dup [ drop ] [ dup do-crap* call ] if ;
-: do-crap* ( obj -- ) dup [ do-crap* ] [ more-crap* ] if ;
-[ [ do-crap* ] infer ] must-fail
-
! Regression
: too-deep ( a b -- c )
dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline recursive
{ 2 1 } [ too-deep ] must-infer-as
-! Error reporting is wrong
-MATH: xyz ( a b -- c )
-M: fixnum xyz 2array ;
-M: float xyz
- [ 3 ] bi@ swapd [ 2array swap ] dip 2array swap ;
-
-[ [ xyz ] infer ] [ inference-error? ] must-fail-with
-
-! Doug Coleman discovered this one while working on the
-! calendar library
-DEFER: A
-DEFER: B
-DEFER: C
-
-: A ( a -- )
- dup {
- [ drop ]
- [ A ]
- [ \ A no-method ]
- [ dup C A ]
- } dispatch ;
-
-: B ( b -- )
- dup {
- [ C ]
- [ B ]
- [ \ B no-method ]
- [ dup B B ]
- } dispatch ;
-
-: C ( c -- )
- dup {
- [ A ]
- [ C ]
- [ \ C no-method ]
- [ dup B C ]
- } dispatch ;
-
-{ 1 0 } [ A ] must-infer-as
-{ 1 0 } [ B ] must-infer-as
-{ 1 0 } [ C ] must-infer-as
-
-! I found this bug by thinking hard about the previous one
-DEFER: Y
-: X ( a b -- c d ) dup [ swap Y ] [ ] if ;
-: Y ( a b -- c d ) X ;
-
-{ 2 2 } [ X ] must-infer-as
-{ 2 2 } [ Y ] must-infer-as
-
-! This one comes from UI code
-DEFER: #1
-: #2 ( a b: ( -- ) -- ) dup [ call ] [ 2drop ] if ; inline
-: #3 ( a -- ) [ #1 ] #2 ;
-: #4 ( a -- ) dup [ drop ] [ dup #4 dup #3 call ] if ;
-: #1 ( a -- ) dup [ dup #4 dup #3 ] [ ] if drop ;
-
-[ \ #4 def>> infer ] must-fail
-[ [ #1 ] infer ] must-fail
-
-! Similar
-DEFER: bar
-: foo ( a b -- c d ) dup [ 2drop f f bar ] [ ] if ;
-: bar ( a b -- ) [ 2 2 + ] t foo drop call drop ;
-
-[ [ foo ] infer ] must-fail
-
-[ 1234 infer ] must-fail
-
! This used to hang
[ [ [ dup call ] dup call ] infer ]
[ inference-error? ] must-fail-with
[ [ [ [ drop 3 ] swap call ] dup call ] infer ]
[ inference-error? ] must-fail-with
-! This form should not have a stack effect
-
-: bad-recursion-1 ( a -- b )
- dup [ drop bad-recursion-1 5 ] [ ] if ;
-
-[ [ bad-recursion-1 ] infer ] must-fail
-
-: bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ;
-[ [ bad-bin ] infer ] must-fail
-
[ [ 1 drop-locals ] infer ] [ inference-error? ] must-fail-with
! Regression
[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] must-fail
-! Test number protocol
-\ bitor must-infer
-\ bitand must-infer
-\ bitxor must-infer
-\ mod must-infer
-\ /i must-infer
-\ /f must-infer
-\ /mod must-infer
-\ + must-infer
-\ - must-infer
-\ * must-infer
-\ / must-infer
-\ < must-infer
-\ <= must-infer
-\ > must-infer
-\ >= must-infer
-\ number= must-infer
-
-! Test object protocol
-\ = must-infer
-\ clone must-infer
-\ hashcode* must-infer
-
-! Test sequence protocol
-\ length must-infer
-\ nth must-infer
-\ set-length must-infer
-\ set-nth must-infer
-\ new must-infer
-\ new-resizable must-infer
-\ like must-infer
-\ lengthen must-infer
-
-! Test assoc protocol
-\ at* must-infer
-\ set-at must-infer
-\ new-assoc must-infer
-\ delete-at must-infer
-\ clear-assoc must-infer
-\ assoc-size must-infer
-\ assoc-like must-infer
-\ assoc-clone-like must-infer
-\ >alist must-infer
{ 1 3 } [ [ 2drop f ] assoc-find ] must-infer-as
-! Test some random library words
-\ 1quotation must-infer
-\ string>number must-infer
-\ get must-infer
-
-\ push must-infer
-\ append must-infer
-\ peek must-infer
-
-\ reverse must-infer
-\ member? must-infer
-\ remove must-infer
-\ natural-sort must-infer
-
-\ forget must-infer
-\ define-class must-infer
-\ define-tuple-class must-infer
-\ define-union-class must-infer
-\ define-predicate-class must-infer
-\ instance? must-infer
-\ next-method-quot must-infer
-
! Test words with continuations
{ 0 0 } [ [ drop ] callcc0 ] must-infer-as
{ 0 1 } [ [ 4 swap continue-with ] callcc1 ] must-infer-as
{ 2 1 } [ [ + ] [ ] [ ] cleanup ] must-infer-as
{ 2 1 } [ [ + ] [ 3drop 0 ] recover ] must-infer-as
-\ dispose must-infer
-
-! Test stream protocol
-\ set-timeout must-infer
-\ stream-read must-infer
-\ stream-read1 must-infer
-\ stream-readln must-infer
-\ stream-read-until must-infer
-\ stream-write must-infer
-\ stream-write1 must-infer
-\ stream-nl must-infer
-\ stream-flush must-infer
-
-! Test stream utilities
-\ lines must-infer
-\ contents must-infer
-
-! Test prettyprinting
-\ . must-infer
-\ short. must-infer
-\ unparse must-infer
-
-\ describe must-infer
-\ error. must-infer
-
-! Test odds and ends
-\ io-thread must-infer
-
-! Incorrect stack declarations on inline recursive words should
-! be caught
-: fooxxx ( a b -- c ) over [ foo ] when ; inline
-: barxxx ( a b -- c ) fooxxx ;
-
-[ [ barxxx ] infer ] must-fail
-
! A typo
{ 1 0 } [ { [ ] } dispatch ] must-infer-as
{ 1 1 } [ [ deferred-word ] [ 3 ] if ] must-infer-as
-
DEFER: an-inline-word
: normal-word-3 ( -- )
] unit-test
! Regression
-: missing->r-check ( a -- ) 1 load-locals ;
-
-[ [ missing->r-check ] infer ] must-fail
+[ [ 1 load-locals ] infer ] must-fail
! Corner case
[ [ [ f dup ] [ dup ] produce ] infer ] must-fail
[ [ [ f dup ] [ ] while ] infer ] must-fail
: erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline recursive
-
[ [ erg's-inference-bug ] infer ] must-fail
-
-: inference-invalidation-a ( -- ) ;
-: inference-invalidation-b ( quot -- ) [ inference-invalidation-a ] dip call ; inline
-: inference-invalidation-c ( a b -- c ) [ + ] inference-invalidation-b ; inline
-
-[ 7 ] [ 4 3 inference-invalidation-c ] unit-test
-
-{ 2 1 } [ [ + ] inference-invalidation-b ] must-infer-as
-
-[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- a b ) 1 2 ;" eval( -- ) ] unit-test
-
-[ 3 ] [ inference-invalidation-c ] unit-test
-
-{ 0 1 } [ inference-invalidation-c ] must-infer-as
-
-GENERIC: inference-invalidation-d ( obj -- )
-
-M: object inference-invalidation-d inference-invalidation-c 2drop ;
-
-\ inference-invalidation-d must-infer
-
-[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- ) ;" eval( -- ) ] unit-test
-
-[ [ inference-invalidation-d ] infer ] must-fail
+FORGET: erg's-inference-bug
: bad-recursion-3 ( -- ) dup [ [ bad-recursion-3 ] dip ] when ; inline recursive
[ [ bad-recursion-3 ] infer ] must-fail
+FORGET: bad-recursion-3
: bad-recursion-4 ( -- ) 4 [ dup call roll ] times ; inline recursive
[ [ [ ] [ 1 2 3 ] over dup bad-recursion-4 ] infer ] must-fail
[ [ unbalanced-retain-usage ] infer ] [ inference-error? ] must-fail-with
+FORGET: unbalanced-retain-usage
+
DEFER: eee'
: ddd' ( ? -- ) [ f eee' ] when ; inline recursive
: eee' ( ? -- ) [ swap [ ] ] dip ddd' call ; inline recursive
: compose-n-quot ( word n -- quot' ) <repetition> >quotation ;
: compose-n ( quot n -- ) compose-n-quot call ;
+
+<<
\ compose-n [ compose-n-quot ] 2 define-transform
+\ compose-n t "no-compile" set-word-prop
+>>
+
: compose-n-test ( a b c -- x ) 2 \ + compose-n ;
[ 6 ] [ 1 2 3 compose-n-test ] unit-test
calendar urls xml.writer ;
IN: syndication.tests
-\ download-feed must-infer
-\ feed>xml must-infer
-
: load-news-file ( filename -- feed )
#! Load an news syndication file and process it, returning
#! it as an feed tuple.
USING: tools.test tools.memory ;
IN: tools.memory.tests
-\ room. must-infer
[ ] [ room. ] unit-test
-
-\ heap-stats. must-infer
[ ] [ heap-stats. ] unit-test
{ $notes "This word is used to test error handling code, ensuring that errors thrown by code contain the relevant debugging information." } ;
HELP: must-infer
-{ $values { "word/quot" "a quotation or a word" } }
-{ $description "Ensures that the quotation or word has a static stack effect without running it." }
+{ $values { "quot" quotation } }
+{ $description "Ensures that the quotation has a static stack effect without running it." }
{ $notes "This word is used to test that code will compile with the optimizing compiler for optimum performance. See " { $link "compiler" } "." } ;
HELP: must-infer-as
IN: tools.test.tests
USING: tools.test tools.test.private namespaces kernel sequences ;
-\ test-all must-infer
-
: fake-unit-test ( quot -- )
[
"fake" file set
:: (must-infer-as) ( effect quot -- error ? )
[ quot infer short-effect effect assert= f f ] [ t ] recover ;
-:: (must-infer) ( word/quot -- error ? )
- word/quot dup word? [ '[ _ execute ] ] when :> quot
+:: (must-infer) ( quot -- error ? )
[ quot infer drop f f ] [ t ] recover ;
TUPLE: did-not-fail ;
IN: ui.event-loop.tests
USING: ui.event-loop tools.test ;
-
-\ event-loop must-infer
IN: ui.gadgets.books.tests
USING: tools.test ui.gadgets.books ;
-
-\ <book> must-infer
} <radio-buttons> "religion" set
] unit-test
-\ <radio-buttons> must-infer
-
-\ <checkbox> must-infer
-
[ 0 ] [
"religion" get gadget-child value>>
] unit-test
] with-grafted-gadget
] unit-test
-\ <editor> must-infer
-
"hello" <model> <model-field> "field" set
"field" get [
{ { f f } { f t } { t f } { t t } } [ notify-combo ] assoc-each
] with-string-writer print
-
-\ <gadget> must-infer
-\ unparent must-infer
-\ add-gadget must-infer
-\ add-gadgets must-infer
-\ clear-gadget must-infer
-
-\ relayout must-infer
-\ relayout-1 must-infer
-\ pref-dim must-infer
-
-\ graft* must-infer
-\ ungraft* must-infer
\ No newline at end of file
model>> dependencies>> [ range-max value>> ] map
{ 0 0 } =
] unit-test
-
-\ <scroller> must-infer
IN: ui.gestures.tests
USING: tools.test ui.gestures ;
-
-\ handle-gesture must-infer
-\ send-queued-gesture must-infer
\ No newline at end of file
[ ] [
[ { $operations \ + } print-element ] with-string-writer drop
] unit-test
-
-\ object-operations must-infer
\ No newline at end of file
IN: ui.render.tests
USING: ui.render tools.test ;
-
-\ draw-gadget must-infer
\ No newline at end of file
IN: ui.tools.browser.tests
USING: tools.test ui.gadgets.debug ui.tools.browser math ;
-\ <browser-gadget> must-infer
[ ] [ \ + <browser-gadget> [ ] with-grafted-gadget ] unit-test
IN: ui.tools.inspector.tests
USING: tools.test ui.tools.inspector math models ;
-\ <inspector-gadget> must-infer
-
[ ] [ \ + <model> <inspector-gadget> com-edit-slot ] unit-test
\ No newline at end of file
calendar concurrency.promises io ui.tools.common ;
IN: ui.tools.listener.tests
-\ <interactor> must-infer
-
[
[ ] [ <interactor> <pane> <pane-stream> >>output "interactor" set ] unit-test
USING: ui.tools.profiler tools.test ;
-\ profiler-window must-infer
+
USING: ui.tools.walker tools.test ;
IN: ui.tools.walker.tests
-\ <walker-gadget> must-infer
IN: ui.tests
USING: ui ui.private tools.test ;
-
-\ open-window must-infer
-\ update-ui must-infer
\ No newline at end of file
unicode.case.private ;
IN: unicode.case.tests
-\ >upper must-infer
-\ >lower must-infer
-\ >title must-infer
-
[ "Hello How Are You? I'm Good" ] [ "hEllo how ARE yOU? I'm good" >title ] unit-test
[ "FUSS" ] [ "Fu\u0000DF" >upper ] unit-test
[ "\u0003C3a\u0003C2 \u0003C3\u0003C2 \u0003C3a\u0003C2" ] [ "\u0003A3A\u0003A3 \u0003A3\u0003A3 \u0003A3A\u0003A3" >lower ] unit-test
[ ] [ all-groups drop ] unit-test
-\ all-groups must-infer
-
[ t ] [ real-group-name string? ] unit-test
[ t ] [ effective-group-name string? ] unit-test
USING: tools.test unix.users kernel strings math ;
IN: unix.users.tests
-
[ ] [ all-users drop ] unit-test
-\ all-users must-infer
-
[ t ] [ real-user-name string? ] unit-test
[ t ] [ effective-user-name string? ] unit-test
[ "aaa bb\ncccc\nddddd" ] [ "aaa bb cccc ddddd" 6 wrap-string ] unit-test
[ "aaa bb\nccccccc\nddddddd" ] [ "aaa bb ccccccc ddddddd" 6 wrap-string ] unit-test
-\ wrap-string must-infer
-
[ "a b c d e f\ng h" ] [ "a b c d e f g h" 11 wrap-string ] unit-test
} 35 35 wrap-words [ { } like ] map
] unit-test
-\ wrap-words must-infer
calc-arith
] unit-test
-\ calc-arith must-infer
-
XML-NS: foo http://blah.com
[ T{ name { main "bling" } { url "http://blah.com" } } ] [ "bling" foo ] unit-test
[ "<x>3</x>" ] [ 3 [XML <x><-></x> XML] xml>string ] unit-test
[ "<x></x>" ] [ f [XML <x><-></x> XML] xml>string ] unit-test
-\ <XML must-infer
[ [XML <-> XML] ] must-infer
[ [XML <foo><-></foo> <bar val=<->/> XML] ] must-infer
sequences.deep accessors io.streams.string ;
! This is insufficient
-\ read-xml must-infer
[ [ drop ] each-element ] must-infer
-\ string>xml must-infer
SYMBOL: xml-file
[ ] [
io.encodings.utf8 io.files accessors io.directories math math.parser ;
IN: xml.writer.tests
-\ write-xml must-infer
-\ xml>string must-infer
-\ pprint-xml must-infer
! Add a test for pprint-xml with sensitive-tags
[ "foo" ] [ T{ name { main "foo" } } name>string ] unit-test
tools.test multiline splitting memoize
kernel io.streams.string xml.writer ;
-\ htmlize-file must-infer
-
[ ] [ \ (load-mode) reset-memoized ] unit-test
[ ] [
IN: checksums.tests
USING: checksums tools.test ;
-\ checksum-bytes must-infer
-\ checksum-stream must-infer
-\ checksum-lines must-infer
-\ checksum-file must-infer
classes.tuple accessors ;\r
IN: classes.algebra.tests\r
\r
-\ class< must-infer\r
-\ class-and must-infer\r
-\ class-or must-infer\r
-\ flatten-class must-infer\r
-\ flatten-builtin-class must-infer\r
-\r
: class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;\r
\r
: class-or* ( cls1 cls2 cls3 -- ? ) [ class-or ] dip class= ;\r
: foo ( a b -- c ) declared-types boa ;
-\ foo must-infer
+\ foo def>> must-infer
[ T{ declared-types f 0 "hi" } ] [ 0.0 "hi" foo ] unit-test
{ [ dup 2 mod 1 = ] [ drop "odd" ] }
} cond ;
-\ cond-test-1 must-infer
+\ cond-test-1 def>> must-infer
[ "even" ] [ 2 cond-test-1 ] unit-test
[ "odd" ] [ 3 cond-test-1 ] unit-test
[ drop "something else" ]
} cond ;
-\ cond-test-2 must-infer
+\ cond-test-2 def>> must-infer
[ "true" ] [ t cond-test-2 ] unit-test
[ "false" ] [ f cond-test-2 ] unit-test
{ [ dup f = ] [ drop "false" ] }
} cond ;
-\ cond-test-3 must-infer
+\ cond-test-3 def>> must-infer
[ "something else" ] [ t cond-test-3 ] unit-test
[ "something else" ] [ f cond-test-3 ] unit-test
{
} cond ;
-\ cond-test-4 must-infer
+\ cond-test-4 def>> must-infer
[ cond-test-4 ] [ class \ no-cond = ] must-fail-with
{ 4 [ "four" ] }
} case ;
-\ case-test-1 must-infer
+\ case-test-1 def>> must-infer
[ "two" ] [ 2 case-test-1 ] unit-test
[ sq ]
} case ;
-\ case-test-2 must-infer
+\ case-test-2 def>> must-infer
[ 25 ] [ 5 case-test-2 ] unit-test
[ sq ]
} case ;
-\ case-test-3 must-infer
+\ case-test-3 def>> must-infer
[ "an array" ] [ { 1 2 3 } case-test-3 ] unit-test
[ drop "demasiado" ]
} case ;
-\ case-test-4 must-infer
+\ case-test-4 def>> must-infer
[ "uno" ] [ 1 case-test-4 ] unit-test
[ "dos" ] [ 2 case-test-4 ] unit-test
[ drop "demasiado" print ]
} case ;
-\ case-test-5 must-infer
+\ case-test-5 def>> must-infer
[ ] [ 1 case-test-5 ] unit-test
{ 3 [ "three" ] }
} case ;
-\ test-case-6 must-infer
+\ test-case-6 def>> must-infer
[ "three" ] [ 3 test-case-6 ] unit-test
[ "do-not-call" ] [ \ do-not-call test-case-6 ] unit-test
{ \ ] [ "KFC" ] }
} case ;
-\ test-case-7 must-infer
+\ test-case-7 def>> must-infer
[ "plus" ] [ \ + test-case-7 ] unit-test
[ { 4 } ] [ { 2 2 } [ + ] with-datastack ] unit-test
-\ with-datastack must-infer
+[ with-datastack ] must-infer
make math sequences system threads tools.test generic.standard ;
IN: io.files.tests
-\ exists? must-infer
-\ (exists?) must-infer
-
[ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test
[ ] [ "append-test" temp-file ascii <file-appender> dispose ] unit-test
vocabs.parser words.symbol multiline source-files.errors ;
IN: parser.tests
-\ run-file must-infer
-
[
[ 1 [ 2 [ 3 ] 4 ] 5 ]
[ "1\n[\n2\n[\n3\n]\n4\n]\n5" eval( -- a b c ) ]
IN: contributors.tests
USING: contributors tools.test ;
-\ contributors must-infer
[ ] [ contributors ] unit-test
USING: infix.ast infix.parser infix.tokenizer tools.test ;
IN: infix.parser.tests
-\ parse-infix must-infer
-\ build-infix-ast must-infer
-
[ T{ ast-number { value 1 } } ] [ "1" build-infix-ast ] unit-test
[ T{ ast-negation f T{ ast-number { value 1 } } } ]
[ "-1" build-infix-ast ] unit-test
USING: infix.ast infix.tokenizer tools.test ;
IN: infix.tokenizer.tests
-\ tokenize-infix must-infer
[ V{ T{ ast-number f 1 } } ] [ "1" tokenize-infix ] unit-test
[ V{ T{ ast-number f 1.02 } CHAR: * T{ ast-number f 3 } } ] [ "1.02*3" tokenize-infix ] unit-test
[ V{ T{ ast-number f 3 } CHAR: / CHAR: ( T{ ast-number f 3 } CHAR: + T{ ast-number f 4 } CHAR: ) } ]
USING: tools.test mason.cleanup ;
IN: mason.cleanup.tests
-
-\ cleanup must-infer
IN: mason.release.upload.tests
USING: mason.release.upload tools.test ;
-\ upload must-infer
USING: multi-methods tools.test math sequences namespaces system
kernel strings words compiler.units quotations ;
-\ GENERIC: must-infer
-\ create-method-in must-infer
-
DEFER: fake
\ fake H{ } clone "multi-methods" set-word-prop
USING: kernel tools.test peg.javascript peg.javascript.ast accessors ;
IN: peg.javascript.tests
-\ parse-javascript must-infer
-
{ T{ ast-begin f V{ T{ ast-number f 123 } } } } [
"123;" parse-javascript
] unit-test
\ No newline at end of file
accessors multiline sequences math peg.ebnf ;
IN: peg.javascript.parser.tests
-\ javascript must-infer
-
{
T{
ast-begin
USING: kernel tools.test peg peg.javascript.ast peg.javascript.tokenizer accessors ;
IN: peg.javascript.tokenizer.tests
-\ tokenize-javascript must-infer
-
{
V{
T{ ast-number f 123 }
projects / factor.git / commitdiff