1 USING: accessors arrays generic stack-checker
2 stack-checker.backend stack-checker.errors kernel classes
3 kernel.private math math.parser math.private namespaces
4 namespaces.private parser sequences strings vectors words
5 quotations effects tools.test continuations generic.standard
6 sorting assocs definitions prettyprint io inspector
7 classes.tuple classes.union classes.predicate debugger
8 threads.private io.streams.string io.timeouts io.thread
9 sequences.private destructors combinators eval locals.backend
10 system compiler.units shuffle vocabs combinators.smart ;
11 IN: stack-checker.tests
13 [ 1234 infer ] must-fail
15 { 0 2 } [ 2 "Hello" ] must-infer-as
16 { 1 2 } [ dup ] must-infer-as
18 { 1 2 } [ [ dup ] call ] must-infer-as
19 [ [ call ] infer ] [ T{ unknown-macro-input f call } = ] must-fail-with
20 [ [ curry call ] infer ] [ T{ unknown-macro-input f call } = ] must-fail-with
21 [ [ { } >quotation call ] infer ] [ T{ bad-macro-input f call } = ] must-fail-with
22 [ [ append curry call ] infer ] [ T{ bad-macro-input f call } = ] must-fail-with
24 { 2 4 } [ 2dup ] must-infer-as
26 { 1 0 } [ [ ] [ ] if ] must-infer-as
27 [ [ if ] infer ] [ T{ unknown-macro-input f if } = ] must-fail-with
28 [ [ { } >quotation { } >quotation if ] infer ] [ T{ bad-macro-input f if } = ] must-fail-with
29 [ [ [ ] if ] infer ] [ T{ unknown-macro-input f if } = ] must-fail-with
30 [ [ [ 2 ] [ ] if ] infer ] [ unbalanced-branches-error? ] must-fail-with
31 { 4 3 } [ [ rot ] [ -rot ] if ] must-infer-as
35 [ swap 3 ] [ nip 5 5 ] if
41 { 1 1 } [ dup [ ] when ] must-infer-as
42 { 1 1 } [ dup [ dup fixnum* ] when ] must-infer-as
43 { 2 1 } [ [ dup fixnum* ] when ] must-infer-as
45 { 1 0 } [ [ drop ] when* ] must-infer-as
46 { 1 1 } [ [ { { [ ] } } ] unless* ] must-infer-as
49 [ [ 2 2 fixnum+ ] dup [ ] when call ] must-infer-as
52 [ [ [ 2 2 fixnum+ ] ] [ [ 2 2 fixnum* ] ] if call ] infer
53 ] [ T{ bad-macro-input f call } = ] must-fail-with
55 ! Test inference of termination of control flow
56 : termination-test-1 ( -- * ) "foo" throw ;
58 : termination-test-2 ( ? -- x ) [ termination-test-1 ] [ 3 ] if ;
60 { 1 1 } [ termination-test-2 ] must-infer-as
62 : simple-recursion-1 ( obj -- obj )
63 dup [ simple-recursion-1 ] [ ] if ;
65 { 1 1 } [ simple-recursion-1 ] must-infer-as
67 : simple-recursion-2 ( obj -- obj )
68 dup [ ] [ simple-recursion-2 ] if ;
70 { 1 1 } [ simple-recursion-2 ] must-infer-as
72 : funny-recursion ( obj -- obj )
73 dup [ funny-recursion 1 ] [ 2 ] if drop ;
75 { 1 1 } [ funny-recursion ] must-infer-as
78 { 1 2 } [ [ first ] keep second ] must-infer-as
83 : fie ( element obj -- ? )
84 dup array? [ foe ] [ eq? ] if ;
86 : foe ( element tree -- ? )
101 { 2 1 } [ fie ] must-infer-as
102 { 2 1 } [ foe ] must-infer-as
111 { 0 0 } [ nested-when ] must-infer-as
113 : nested-when* ( obj -- )
120 { 1 0 } [ nested-when* ] must-infer-as
124 { 0 1 } [ sym-test ] must-infer-as
126 : terminator-branch ( a -- b )
133 { 1 1 } [ terminator-branch ] must-infer-as
135 : recursive-terminator ( obj -- )
142 { 1 0 } [ recursive-terminator ] must-infer-as
144 GENERIC: potential-hang ( obj -- obj )
145 M: fixnum potential-hang dup [ potential-hang ] when ;
147 { } [ [ 5 potential-hang ] infer drop ] unit-test
149 TUPLE: funny-cons car cdr ;
150 GENERIC: iterate ( obj -- )
151 M: funny-cons iterate cdr>> iterate ;
153 M: real iterate drop ;
155 { 1 0 } [ iterate ] must-infer-as
158 : cat ( obj -- * ) dup [ throw ] [ throw ] if ;
159 : dog ( a b c -- ) dup [ cat ] [ 3drop ] if ;
160 { 3 0 } [ dog ] must-infer-as
164 : friend ( a b c -- ) dup [ friend ] [ monkey ] if ;
165 : monkey ( a b c -- ) dup [ 3drop ] [ friend ] if ;
166 { 3 0 } [ friend ] must-infer-as
168 ! Regression -- same as above but we infer the second word first
170 : blah ( a b c -- ) dup [ blah ] [ blah2 ] if ;
171 : blah2 ( a b c -- ) dup [ blah ] [ 3drop ] if ;
172 { 3 0 } [ blah2 ] must-infer-as
177 dup [ blah3 ] [ dup [ blah4 ] [ blah3 ] if ] if ;
179 dup [ blah4 ] [ dup [ 3drop ] [ blah3 ] if ] if ;
180 { 3 0 } [ blah4 ] must-infer-as
183 : bad-combinator ( obj quot: ( -- ) -- )
187 [ dip ] keep swap bad-combinator
188 ] if ; inline recursive
190 [ [ [ 1 ] [ ] bad-combinator ] infer ] must-fail
194 dup string? [ 2array throw ] unless
195 over string? [ 2array throw ] unless
199 : too-deep ( a b -- c )
200 dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline recursive
201 { 2 1 } [ too-deep ] must-infer-as
204 [ [ [ dup call ] dup call ] infer ]
205 [ recursive-quotation-error? ] must-fail-with
207 : m ( q -- ) dup call ; inline
209 [ [ [ m ] m ] infer ] [ recursive-quotation-error? ] must-fail-with
211 : m' ( quot -- ) dup curry call ; inline
213 [ [ [ m' ] m' ] infer ] [ recursive-quotation-error? ] must-fail-with
215 : m'' ( -- q ) [ dup curry ] ; inline
217 : m''' ( -- ) m'' call call ; inline
219 [ [ [ m''' ] m''' ] infer ] [ recursive-quotation-error? ] must-fail-with
221 : m-if ( a b c -- ) t over when ; inline
223 [ [ [ m-if ] m-if ] infer ] [ recursive-quotation-error? ] must-fail-with
225 ! This doesn't hang but it's also an example of the
227 [ [ [ [ drop 3 ] swap call ] dup call ] infer ]
228 [ recursive-quotation-error? ] must-fail-with
230 [ [ 1 drop-locals ] infer ] [ too-many-r>? ] must-fail-with
233 [ [ cleave ] infer ] [ T{ unknown-macro-input f cleave } = ] must-fail-with
235 ! Test some curry stuff
236 { 1 1 } [ 3 [ ] curry 4 [ ] curry if ] must-infer-as
237 { 3 1 } [ [ ] curry [ [ ] curry ] dip if ] must-infer-as
239 { 2 1 } [ [ ] curry 4 [ ] curry if ] must-infer-as
241 [ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] [ unbalanced-branches-error? ] must-fail-with
242 [ [ [ ] curry [ [ ] 2curry ] dip if ] infer ] [ unbalanced-branches-error? ] must-fail-with
244 { 1 3 } [ [ 2drop f ] assoc-find ] must-infer-as
246 ! Test words with continuations
247 { 0 0 } [ [ drop ] callcc0 ] must-infer-as
248 { 0 1 } [ [ 4 swap continue-with ] callcc1 ] must-infer-as
249 { 2 1 } [ [ + ] [ ] finally ] must-infer-as
250 { 2 1 } [ [ + ] [ 3drop 0 ] recover ] must-infer-as
253 { 1 0 } [ { [ ] } dispatch ] must-infer-as
255 ! Make sure the error is correct
257 [ { [ drop ] [ dup ] } dispatch ] infer
258 ] [ word>> \ dispatch eq? ] must-fail-with
260 DEFER: inline-recursive-2
261 : inline-recursive-1 ( -- ) inline-recursive-2 ;
262 : inline-recursive-2 ( -- ) inline-recursive-1 ;
264 { 0 0 } [ inline-recursive-1 ] must-infer-as
268 HOOK: my-hook my-var ( -- x )
270 M: integer my-hook "an integer" ;
271 M: string my-hook "a string" ;
273 { 0 1 } [ my-hook ] must-infer-as
277 { 1 1 } [ [ deferred-word ] [ 3 ] if ] must-infer-as
279 DEFER: an-inline-word
281 : normal-word-3 ( -- )
282 3 [ [ 2 + ] curry ] an-inline-word call drop ;
284 : normal-word-2 ( -- )
287 : normal-word ( x -- x )
288 dup [ normal-word-2 ] when ;
290 : an-inline-word ( obj quot -- )
291 [ normal-word ] dip call ; inline
293 { 1 1 } [ [ 3 * ] an-inline-word ] must-infer-as
295 { 0 1 } [ [ 2 ] [ 2 ] [ + ] compose compose call ] must-infer-as
297 ERROR: custom-error ;
299 { T{ effect f { } { } t } } [
300 [ custom-error ] infer
303 : funny-throw ( a -- * ) throw ; inline
305 { T{ effect f { } { } t } } [
306 [ 3 funny-throw ] infer
309 { T{ effect f { } { } t } } [
310 [ custom-error inference-error ] infer
313 { T{ effect f { "x" } { "x" "x" } t } } [
314 [ dup [ 3 throw ] dip ] infer
318 [ [ 1 load-locals ] infer ] [ too-many->r? ] must-fail-with
321 [ [ [ f dup ] [ dup ] produce ] infer ] must-fail
323 [ [ [ f dup ] [ ] while ] infer ] must-fail
325 : erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline recursive
326 [ [ erg's-inference-bug ] infer ] must-fail
327 FORGET: erg's-inference-bug
329 : bad-recursion-3 ( -- ) dup [ [ bad-recursion-3 ] dip ] when ; inline recursive
330 [ [ bad-recursion-3 ] infer ] must-fail
331 FORGET: bad-recursion-3
333 : bad-recursion-4 ( -- ) 4 [ dup call [ rot ] dip swap ] times ; inline recursive
334 [ [ [ ] [ 1 2 3 ] over dup bad-recursion-4 ] infer ] must-fail
336 : bad-recursion-5 ( obj quot: ( -- ) -- ) dup call swap bad-recursion-5 ; inline recursive
337 [ [ f [ ] bad-recursion-5 ] infer ] must-fail
339 : bad-recursion-6 ( quot: ( -- ) -- )
340 dup bad-recursion-6 call ; inline recursive
341 [ [ [ drop f ] bad-recursion-6 ] infer ] must-fail
343 { } [ [ \ bad-recursion-6 forget ] with-compilation-unit ] unit-test
345 { 3 0 } [ [ 2drop "A" throw ] [ ] if 2drop ] must-infer-as
346 { 2 0 } [ drop f f [ 2drop "A" throw ] [ ] if 2drop ] must-infer-as
348 : unbalanced-retain-usage ( a b -- )
350 [ 2drop 5 1 + unbalanced-retain-usage ]
351 [ 2drop ] if ; inline recursive
353 [ [ unbalanced-retain-usage ] infer ] [ inference-error? ] must-fail-with
355 FORGET: unbalanced-retain-usage
358 : ddd' ( ? -- ) [ f eee' ] when ; inline recursive
359 : eee' ( ? -- ) [ swap [ ] ] dip ddd' call ; inline recursive
361 [ [ eee' ] infer ] [ inference-error? ] must-fail-with
363 { } [ [ \ ddd' forget ] with-compilation-unit ] unit-test
364 { } [ [ \ eee' forget ] with-compilation-unit ] unit-test
366 : bogus-error ( x -- )
367 dup "A" throw [ bogus-error ] [ drop ] if ; inline recursive
369 [ bogus-error ] must-infer
371 [ [ clear ] infer. ] [ inference-error? ] must-fail-with
373 : debugging-curry-folding ( quot -- )
374 [ debugging-curry-folding ] curry call ; inline recursive
376 [ [ ] debugging-curry-folding ] must-infer
378 [ [ exit ] [ 1 2 3 ] if ] must-infer
380 ! Stack effects are required now but FORGET: clears them...
381 : forget-test ( -- ) ;
383 [ forget-test ] must-infer
384 { } [ [ \ forget-test forget ] with-compilation-unit ] unit-test
385 [ forget-test ] must-infer
387 [ [ cond ] infer ] [ T{ unknown-macro-input f cond } = ] must-fail-with
388 [ [ call ] infer ] [ T{ unknown-macro-input f call } = ] must-fail-with
389 [ [ dip ] infer ] [ T{ unknown-macro-input f call } = ] must-fail-with
391 [ [ each ] infer ] [ T{ unknown-macro-input f each } = ] must-fail-with
392 [ [ if* ] infer ] [ T{ unknown-macro-input f if* } = ] must-fail-with
393 [ [ [ "derp" ] if* ] infer ] [ T{ unknown-macro-input f if* } = ] must-fail-with
395 [ [ [ "OOPS" throw ] dip ] [ drop ] if ] must-infer
397 ! Found during code review
398 [ [ [ drop [ ] ] when call ] infer ] must-fail
399 [ swap [ [ drop [ ] ] when call ] infer ] must-fail
401 { 3 1 } [ call( a b -- c ) ] must-infer-as
402 { 3 1 } [ execute( a b -- c ) ] must-infer-as
404 [ [ call-effect ] infer ] [ T{ unknown-macro-input f call-effect } = ] must-fail-with
405 [ [ execute-effect ] infer ] [ T{ unknown-macro-input f execute-effect } = ] must-fail-with
407 [ \ set-datastack def>> infer ] [ T{ do-not-compile f do-primitive } = ] must-fail-with
408 { } [ [ \ set-datastack def>> infer ] try ] unit-test
410 ! Make sure all primitives are covered
412 all-words [ primitive? ] filter
413 [ "default-output-classes" word-prop ] reject
414 [ "special" word-prop ] reject
415 [ "shuffle" word-prop ] reject
418 { 1 0 } [ [ drop ] each ] must-infer-as
419 { 2 1 } [ [ append ] each ] must-infer-as
420 { 1 1 } [ [ ] map ] must-infer-as
421 { 1 1 } [ [ reverse ] map ] must-infer-as
422 { 2 2 } [ [ append dup ] map ] must-infer-as
423 { 2 2 } [ [ swap nth suffix dup ] map-index ] must-infer-as
425 { 4 1 } [ [ 2drop ] [ 2nip ] if ] must-infer-as
426 { 3 3 } [ [ dup ] [ over ] if ] must-infer-as
427 { 1 1 } [ [ 1 ] [ 0 ] if ] must-infer-as
428 { 2 2 } [ [ t ] [ 1 + f ] if ] must-infer-as
430 { 1 0 } [ [ write ] [ "(f)" write ] if* ] must-infer-as
431 { 1 1 } [ [ ] [ f ] if* ] must-infer-as
432 { 2 1 } [ [ nip ] [ drop f ] if* ] must-infer-as
433 { 2 1 } [ [ nip ] [ ] if* ] must-infer-as
434 { 3 2 } [ [ 3append f ] [ ] if* ] must-infer-as
435 { 1 0 } [ [ drop ] [ ] if* ] must-infer-as
437 { 1 1 } [ [ 1 + ] [ "oops" throw ] if* ] must-infer-as
439 : strict-each ( seq quot: ( x -- ) -- )
441 : strict-map ( seq quot: ( x -- x' ) -- seq' )
443 : strict-2map ( xs ys quot: ( x y -- z ) -- zs )
446 { 1 0 } [ [ drop ] strict-each ] must-infer-as
447 { 1 1 } [ [ 1 + ] strict-map ] must-infer-as
448 { 1 1 } [ [ ] strict-map ] must-infer-as
449 { 2 1 } [ [ + ] strict-2map ] must-infer-as
450 { 2 1 } [ [ drop ] strict-2map ] must-infer-as
451 [ [ [ append ] strict-each ] infer ] [ unbalanced-branches-error? ] must-fail-with
452 [ [ [ 1 + ] strict-2map ] infer ] [ unbalanced-branches-error? ] must-fail-with
454 ! ensure that polymorphic checking works on recursive combinators
455 : (recursive-reduce) ( identity i seq quot: ( prev elt -- next ) n -- result )
457 [ [ [ nth-unsafe ] dip call ] 3keep [ 1 + ] 2dip ] dip
459 ] [ 4drop ] if ; inline recursive
460 : recursive-reduce ( seq i quot: ( prev elt -- next ) -- result )
461 swapd [ 0 ] 2dip over length (recursive-reduce) ; inline
462 { 24995000 } [ 10000 <iota> 0 [ dup even? [ + ] [ drop ] if ] recursive-reduce ] unit-test
463 { 3 1 } [ [ member? [ 1 + ] when ] curry recursive-reduce ] must-infer-as
465 [ [ [ write write ] each ] infer ] [ unbalanced-branches-error? ] must-fail-with
467 [ [ [ ] each ] infer ] [ unbalanced-branches-error? ] must-fail-with
468 [ [ [ dup ] map ] infer ] [ unbalanced-branches-error? ] must-fail-with
469 [ [ [ drop ] map ] infer ] [ unbalanced-branches-error? ] must-fail-with
470 [ [ [ 1 + ] map-index ] infer ] [ unbalanced-branches-error? ] must-fail-with
472 [ [ [ dup ] [ ] if ] infer ] [ unbalanced-branches-error? ] must-fail-with
473 [ [ [ 2dup ] [ over ] if ] infer ] [ unbalanced-branches-error? ] must-fail-with
474 [ [ [ drop ] [ ] if ] infer ] [ unbalanced-branches-error? ] must-fail-with
476 [ [ [ ] [ ] if* ] infer ] [ unbalanced-branches-error? ] must-fail-with
477 [ [ [ dup ] [ ] if* ] infer ] [ unbalanced-branches-error? ] must-fail-with
478 [ [ [ drop ] [ drop ] if* ] infer ] [ unbalanced-branches-error? ] must-fail-with
479 [ [ [ ] [ drop ] if* ] infer ] [ unbalanced-branches-error? ] must-fail-with
480 [ [ [ ] [ 2dup ] if* ] infer ] [ unbalanced-branches-error? ] must-fail-with
482 ! M\ declared-effect infer-call* didn't properly unify branches
483 { 1 0 } [ [ 1 [ drop ] [ drop ] if ] each ] must-infer-as
485 ! Make sure alien-callback effects are checked properly
486 USING: alien.c-types alien ;
488 [ void { } cdecl [ ] alien-callback ] must-infer
490 [ [ void { } cdecl [ f [ drop ] unless ] alien-callback ] infer ] [ unbalanced-branches-error? ] must-fail-with
492 [ [ void { } cdecl [ drop ] alien-callback ] infer ] [ effect-error? ] must-fail-with
494 [ [ int { } cdecl [ ] alien-callback ] infer ] [ effect-error? ] must-fail-with
496 [ int { } cdecl [ 5 ] alien-callback ] must-infer
498 [ int { int } cdecl [ ] alien-callback ] must-infer
500 [ int { int } cdecl [ 1 + ] alien-callback ] must-infer
502 [ void { int } cdecl [ . ] alien-callback ] must-infer
504 : recursive-callback-1 ( -- x )
505 void { } cdecl [ recursive-callback-1 drop ] alien-callback ;
507 \ recursive-callback-1 def>> must-infer
509 : recursive-callback-2 ( -- x )
510 void { } cdecl [ recursive-callback-2 drop ] alien-callback ; inline recursive
512 [ recursive-callback-2 ] must-infer
514 ! test one-sided row polymorphism
516 : poly-output ( x a: ( x -- ..a ) -- ..a ) call ; inline
518 [ [ ] poly-output ] must-infer
519 [ [ f f f ] poly-output ] must-infer
521 : poly-input ( ..a a: ( ..a -- x ) -- x ) call ; inline
523 [ [ ] poly-input ] must-infer
524 [ [ drop drop drop ] poly-input ] must-infer
526 : poly-output-input ( x a: ( x -- ..a ) b: ( ..a -- y ) -- y ) [ call ] bi@ ; inline
528 [ [ ] [ ] poly-output-input ] must-infer
529 [ [ f f f ] [ drop drop drop ] poly-output-input ] must-infer
530 [ [ [ f f ] [ drop drop drop ] poly-output-input ] infer ] [ unbalanced-branches-error? ] must-fail-with
531 [ [ [ f f f ] [ drop drop ] poly-output-input ] infer ] [ unbalanced-branches-error? ] must-fail-with
533 : poly-input-output ( ..a a: ( ..a -- x ) b: ( x -- ..b ) -- ..b ) [ call ] bi@ ; inline
535 [ [ ] [ ] poly-input-output ] must-infer
536 [ [ drop drop drop ] [ f f f ] poly-input-output ] must-infer
537 [ [ drop drop ] [ f f f ] poly-input-output ] must-infer
538 [ [ drop drop drop ] [ f f ] poly-input-output ] must-infer
540 ! Check that 'inputs' and 'outputs' work at compile-time
542 : inputs-test0 ( -- n )
545 : inputs-test1 ( x -- n )
548 { 1 } [ inputs-test0 ] unit-test
549 { 1 } [ 10 inputs-test1 ] unit-test