classes.tuple classes.union classes.predicate debugger
threads.private io.streams.string io.timeouts io.thread
sequences.private destructors combinators eval locals.backend
-system compiler.units shuffle ;
+system compiler.units shuffle vocabs combinators.smart ;
IN: stack-checker.tests
[ 1234 infer ] must-fail
! Test some curry stuff
{ 1 1 } [ 3 [ ] curry 4 [ ] curry if ] must-infer-as
+{ 3 1 } [ [ ] curry [ [ ] curry ] dip if ] must-infer-as
{ 2 1 } [ [ ] curry 4 [ ] curry if ] must-infer-as
[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] [ unbalanced-branches-error? ] must-fail-with
+[ [ [ ] curry [ [ ] 2curry ] dip if ] infer ] [ unbalanced-branches-error? ] must-fail-with
{ 1 3 } [ [ 2drop f ] assoc-find ] must-infer-as
! A typo
{ 1 0 } [ { [ ] } dispatch ] must-infer-as
+! Make sure the error is correct
+[
+ [ { [ drop ] [ dup ] } dispatch ] infer
+] [ word>> \ dispatch eq? ] must-fail-with
+
DEFER: inline-recursive-2
: inline-recursive-1 ( -- ) inline-recursive-2 ;
: inline-recursive-2 ( -- ) inline-recursive-1 ;
ERROR: custom-error ;
-[ T{ effect f 0 0 t } ] [
+[ T{ effect f { } { } t } ] [
[ custom-error ] infer
] unit-test
: funny-throw ( a -- * ) throw ; inline
-[ T{ effect f 0 0 t } ] [
+[ T{ effect f { } { } t } ] [
[ 3 funny-throw ] infer
] unit-test
-[ T{ effect f 0 0 t } ] [
+[ T{ effect f { } { } t } ] [
[ custom-error inference-error ] infer
] unit-test
-[ T{ effect f 1 2 t } ] [
+[ T{ effect f { "x" } { "x" "x" } t } ] [
[ dup [ 3 throw ] dip ] infer
] unit-test
[ forget-test ] must-infer
[ [ cond ] infer ] [ T{ unknown-macro-input f cond } = ] must-fail-with
-[ [ bi ] infer ] [ T{ unknown-macro-input f call } = ] must-fail-with
-[ [ each ] infer ] [ T{ unknown-macro-input f call } = ] must-fail-with
+[ [ call ] infer ] [ T{ unknown-macro-input f call } = ] must-fail-with
+[ [ dip ] infer ] [ T{ unknown-macro-input f call } = ] must-fail-with
+
+[ [ each ] infer ] [ T{ unknown-macro-input f each } = ] must-fail-with
+[ [ if* ] infer ] [ T{ unknown-macro-input f if* } = ] must-fail-with
+[ [ [ "derp" ] if* ] infer ] [ T{ unknown-macro-input f if* } = ] must-fail-with
[ [ [ "OOPS" throw ] dip ] [ drop ] if ] must-infer
[ [ call-effect ] infer ] [ T{ unknown-macro-input f call-effect } = ] must-fail-with
[ [ execute-effect ] infer ] [ T{ unknown-macro-input f execute-effect } = ] must-fail-with
-[ \ set-callstack def>> infer ] [ T{ unknown-primitive-error } = ] must-fail-with
-[ ] [ [ \ set-callstack def>> infer ] try ] unit-test
+[ \ set-datastack def>> infer ] [ T{ do-not-compile f do-primitive } = ] must-fail-with
+[ ] [ [ \ set-datastack def>> infer ] try ] unit-test
+
+! Make sure all primitives are covered
+[ { } ] [
+ all-words [ primitive? ] filter
+ [ "default-output-classes" word-prop ] reject
+ [ "special" word-prop ] reject
+ [ "shuffle" word-prop ] reject
+] unit-test
+
+{ 1 0 } [ [ drop ] each ] must-infer-as
+{ 2 1 } [ [ append ] each ] must-infer-as
+{ 1 1 } [ [ ] map ] must-infer-as
+{ 1 1 } [ [ reverse ] map ] must-infer-as
+{ 2 2 } [ [ append dup ] map ] must-infer-as
+{ 2 2 } [ [ swap nth suffix dup ] map-index ] must-infer-as
+
+{ 4 1 } [ [ 2drop ] [ 2nip ] if ] must-infer-as
+{ 3 3 } [ [ dup ] [ over ] if ] must-infer-as
+{ 1 1 } [ [ 1 ] [ 0 ] if ] must-infer-as
+{ 2 2 } [ [ t ] [ 1 + f ] if ] must-infer-as
+
+{ 1 0 } [ [ write ] [ "(f)" write ] if* ] must-infer-as
+{ 1 1 } [ [ ] [ f ] if* ] must-infer-as
+{ 2 1 } [ [ nip ] [ drop f ] if* ] must-infer-as
+{ 2 1 } [ [ nip ] [ ] if* ] must-infer-as
+{ 3 2 } [ [ 3append f ] [ ] if* ] must-infer-as
+{ 1 0 } [ [ drop ] [ ] if* ] must-infer-as
+
+{ 1 1 } [ [ 1 + ] [ "oops" throw ] if* ] must-infer-as
+
+: strict-each ( seq quot: ( x -- ) -- )
+ each ; inline
+: strict-map ( seq quot: ( x -- x' ) -- seq' )
+ map ; inline
+: strict-2map ( xs ys quot: ( x y -- z ) -- zs )
+ 2map ; inline
+
+{ 1 0 } [ [ drop ] strict-each ] must-infer-as
+{ 1 1 } [ [ 1 + ] strict-map ] must-infer-as
+{ 1 1 } [ [ ] strict-map ] must-infer-as
+{ 2 1 } [ [ + ] strict-2map ] must-infer-as
+{ 2 1 } [ [ drop ] strict-2map ] must-infer-as
+[ [ [ append ] strict-each ] infer ] [ unbalanced-branches-error? ] must-fail-with
+[ [ [ 1 + ] strict-2map ] infer ] [ unbalanced-branches-error? ] must-fail-with
+
+! ensure that polymorphic checking works on recursive combinators
+: (recursive-reduce) ( identity i seq quot: ( prev elt -- next ) n -- result )
+ [ pick ] dip swap over < [
+ [ [ [ nth-unsafe ] dip call ] 3keep [ 1 + ] 2dip ] dip
+ (recursive-reduce)
+ ] [ 4drop ] if ; inline recursive
+: recursive-reduce ( seq i quot: ( prev elt -- next ) -- result )
+ swapd [ 0 ] 2dip over length (recursive-reduce) ; inline
+{ 24995000 } [ 10000 iota 0 [ dup even? [ + ] [ drop ] if ] recursive-reduce ] unit-test
+{ 3 1 } [ [ member? [ 1 + ] when ] curry recursive-reduce ] must-infer-as
+
+[ [ [ write write ] each ] infer ] [ unbalanced-branches-error? ] must-fail-with
+
+[ [ [ ] each ] infer ] [ unbalanced-branches-error? ] must-fail-with
+[ [ [ dup ] map ] infer ] [ unbalanced-branches-error? ] must-fail-with
+[ [ [ drop ] map ] infer ] [ unbalanced-branches-error? ] must-fail-with
+[ [ [ 1 + ] map-index ] infer ] [ unbalanced-branches-error? ] must-fail-with
+
+[ [ [ dup ] [ ] if ] infer ] [ unbalanced-branches-error? ] must-fail-with
+[ [ [ 2dup ] [ over ] if ] infer ] [ unbalanced-branches-error? ] must-fail-with
+[ [ [ drop ] [ ] if ] infer ] [ unbalanced-branches-error? ] must-fail-with
+
+[ [ [ ] [ ] if* ] infer ] [ unbalanced-branches-error? ] must-fail-with
+[ [ [ dup ] [ ] if* ] infer ] [ unbalanced-branches-error? ] must-fail-with
+[ [ [ drop ] [ drop ] if* ] infer ] [ unbalanced-branches-error? ] must-fail-with
+[ [ [ ] [ drop ] if* ] infer ] [ unbalanced-branches-error? ] must-fail-with
+[ [ [ ] [ 2dup ] if* ] infer ] [ unbalanced-branches-error? ] must-fail-with
+
+! M\ declared-effect infer-call* didn't properly unify branches
+{ 1 0 } [ [ 1 [ drop ] [ drop ] if ] each ] must-infer-as
+
+! Make sure alien-callback effects are checked properly
+USING: alien.c-types alien ;
+
+[ void { } cdecl [ ] alien-callback ] must-infer
+
+[ [ void { } cdecl [ f [ drop ] unless ] alien-callback ] infer ] [ unbalanced-branches-error? ] must-fail-with
+
+[ [ void { } cdecl [ drop ] alien-callback ] infer ] [ effect-error? ] must-fail-with
+
+[ [ int { } cdecl [ ] alien-callback ] infer ] [ effect-error? ] must-fail-with
+
+[ int { } cdecl [ 5 ] alien-callback ] must-infer
+
+[ int { int } cdecl [ ] alien-callback ] must-infer
+
+[ int { int } cdecl [ 1 + ] alien-callback ] must-infer
+
+[ void { int } cdecl [ . ] alien-callback ] must-infer
+
+: recursive-callback-1 ( -- x )
+ void { } cdecl [ recursive-callback-1 drop ] alien-callback ;
+
+\ recursive-callback-1 def>> must-infer
+
+: recursive-callback-2 ( -- x )
+ void { } cdecl [ recursive-callback-2 drop ] alien-callback ; inline recursive
+
+[ recursive-callback-2 ] must-infer
+
+! test one-sided row polymorphism
+
+: poly-output ( x a: ( x -- ..a ) -- ..a ) call ; inline
+
+[ [ ] poly-output ] must-infer
+[ [ f f f ] poly-output ] must-infer
+
+: poly-input ( ..a a: ( ..a -- x ) -- x ) call ; inline
+
+[ [ ] poly-input ] must-infer
+[ [ drop drop drop ] poly-input ] must-infer
+
+: poly-output-input ( x a: ( x -- ..a ) b: ( ..a -- y ) -- y ) [ call ] bi@ ; inline
+
+[ [ ] [ ] poly-output-input ] must-infer
+[ [ f f f ] [ drop drop drop ] poly-output-input ] must-infer
+[ [ [ f f ] [ drop drop drop ] poly-output-input ] infer ] [ unbalanced-branches-error? ] must-fail-with
+[ [ [ f f f ] [ drop drop ] poly-output-input ] infer ] [ unbalanced-branches-error? ] must-fail-with
+
+: poly-input-output ( ..a a: ( ..a -- x ) b: ( x -- ..b ) -- ..b ) [ call ] bi@ ; inline
+
+[ [ ] [ ] poly-input-output ] must-infer
+[ [ drop drop drop ] [ f f f ] poly-input-output ] must-infer
+[ [ drop drop ] [ f f f ] poly-input-output ] must-infer
+[ [ drop drop drop ] [ f f ] poly-input-output ] must-infer
+
+! Check that 'inputs' and 'outputs' work at compile-time
+
+: inputs-test0 ( -- n )
+ [ 5 + ] inputs ;
+
+: inputs-test1 ( x -- n )
+ [ + ] curry inputs ;
+
+[ 1 ] [ inputs-test0 ] unit-test
+[ 1 ] [ 10 inputs-test1 ] unit-test
projects / factor.git / blobdiff