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 IN: stack-checker.tests
14 { 0 2 } [ 2 "Hello" ] must-infer-as
15 { 1 2 } [ dup ] must-infer-as
17 { 1 2 } [ [ dup ] call ] must-infer-as
18 [ [ call ] infer ] must-fail
20 { 2 4 } [ 2dup ] must-infer-as
22 { 1 0 } [ [ ] [ ] if ] must-infer-as
23 [ [ if ] infer ] must-fail
24 [ [ [ ] if ] infer ] must-fail
25 [ [ [ 2 ] [ ] if ] infer ] must-fail
26 { 4 3 } [ [ rot ] [ -rot ] if ] must-infer-as
30 [ swap 3 ] [ nip 5 5 ] if
36 { 1 1 } [ dup [ ] when ] must-infer-as
37 { 1 1 } [ dup [ dup fixnum* ] when ] must-infer-as
38 { 2 1 } [ [ dup fixnum* ] when ] must-infer-as
40 { 1 0 } [ [ drop ] when* ] must-infer-as
41 { 1 1 } [ [ { { [ ] } } ] unless* ] must-infer-as
44 [ [ 2 2 fixnum+ ] dup [ ] when call ] must-infer-as
47 [ [ [ 2 2 fixnum+ ] ] [ [ 2 2 fixnum* ] ] if call ] infer
50 ! Test inference of termination of control flow
51 : termination-test-1 ( -- * ) "foo" throw ;
53 : termination-test-2 ( ? -- x ) [ termination-test-1 ] [ 3 ] if ;
55 { 1 1 } [ termination-test-2 ] must-infer-as
57 : simple-recursion-1 ( obj -- obj )
58 dup [ simple-recursion-1 ] [ ] if ;
60 { 1 1 } [ simple-recursion-1 ] must-infer-as
62 : simple-recursion-2 ( obj -- obj )
63 dup [ ] [ simple-recursion-2 ] if ;
65 { 1 1 } [ simple-recursion-2 ] must-infer-as
67 : bad-recursion-2 ( obj -- obj )
68 dup [ dup first swap second bad-recursion-2 ] [ ] if ;
70 [ [ bad-recursion-2 ] infer ] must-fail
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 [ swap slip ] 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
200 ! This order of branches works
202 : more-crap ( obj -- ) dup [ drop ] [ dup do-crap call ] if ;
203 : do-crap ( obj -- ) dup [ more-crap ] [ do-crap ] if ;
204 [ [ do-crap ] infer ] must-fail
208 : more-crap* ( obj -- ) dup [ drop ] [ dup do-crap* call ] if ;
209 : do-crap* ( obj -- ) dup [ do-crap* ] [ more-crap* ] if ;
210 [ [ do-crap* ] infer ] must-fail
213 : too-deep ( a b -- c )
214 dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline recursive
215 { 2 1 } [ too-deep ] must-infer-as
217 ! Error reporting is wrong
218 MATH: xyz ( a b -- c )
219 M: fixnum xyz 2array ;
221 [ 3 ] bi@ swapd [ 2array swap ] dip 2array swap ;
223 [ [ xyz ] infer ] [ inference-error? ] must-fail-with
225 ! Doug Coleman discovered this one while working on the
255 { 1 0 } [ A ] must-infer-as
256 { 1 0 } [ B ] must-infer-as
257 { 1 0 } [ C ] must-infer-as
259 ! I found this bug by thinking hard about the previous one
261 : X ( a b -- c d ) dup [ swap Y ] [ ] if ;
262 : Y ( a b -- c d ) X ;
264 { 2 2 } [ X ] must-infer-as
265 { 2 2 } [ Y ] must-infer-as
267 ! This one comes from UI code
269 : #2 ( a b: ( -- ) -- ) dup [ call ] [ 2drop ] if ; inline
270 : #3 ( a -- ) [ #1 ] #2 ;
271 : #4 ( a -- ) dup [ drop ] [ dup #4 dup #3 call ] if ;
272 : #1 ( a -- ) dup [ dup #4 dup #3 ] [ ] if drop ;
274 [ \ #4 def>> infer ] must-fail
275 [ [ #1 ] infer ] must-fail
279 : foo ( a b -- c d ) dup [ 2drop f f bar ] [ ] if ;
280 : bar ( a b -- ) [ 2 2 + ] t foo drop call drop ;
282 [ [ foo ] infer ] must-fail
284 [ 1234 infer ] must-fail
287 [ [ [ dup call ] dup call ] infer ]
288 [ inference-error? ] must-fail-with
290 : m dup call ; inline
292 [ [ [ m ] m ] infer ] [ inference-error? ] must-fail-with
294 : m' dup curry call ; inline
296 [ [ [ m' ] m' ] infer ] [ inference-error? ] must-fail-with
298 : m'' [ dup curry ] ; inline
300 : m''' m'' call call ; inline
302 [ [ [ m''' ] m''' ] infer ] [ inference-error? ] must-fail-with
304 : m-if t over if ; inline
306 [ [ [ m-if ] m-if ] infer ] [ inference-error? ] must-fail-with
308 ! This doesn't hang but it's also an example of the
310 [ [ [ [ drop 3 ] swap call ] dup call ] infer ]
311 [ inference-error? ] must-fail-with
313 ! This form should not have a stack effect
315 : bad-recursion-1 ( a -- b )
316 dup [ drop bad-recursion-1 5 ] [ ] if ;
318 [ [ bad-recursion-1 ] infer ] must-fail
320 : bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ;
321 [ [ bad-bin ] infer ] must-fail
323 [ [ 1 drop-locals ] infer ] [ inference-error? ] must-fail-with
326 [ [ cleave ] infer ] [ inference-error? ] must-fail-with
328 ! Test some curry stuff
329 { 1 1 } [ 3 [ ] curry 4 [ ] curry if ] must-infer-as
331 { 2 1 } [ [ ] curry 4 [ ] curry if ] must-infer-as
333 [ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] must-fail
335 ! Test number protocol
353 ! Test object protocol
356 \ hashcode* must-infer
358 ! Test sequence protocol
361 \ set-length must-infer
364 \ new-resizable must-infer
366 \ lengthen must-infer
368 ! Test assoc protocol
371 \ new-assoc must-infer
372 \ delete-at must-infer
373 \ clear-assoc must-infer
374 \ assoc-size must-infer
375 \ assoc-like must-infer
376 \ assoc-clone-like must-infer
378 { 1 3 } [ [ 2drop f ] assoc-find ] must-infer-as
380 ! Test some random library words
381 \ 1quotation must-infer
382 \ string>number must-infer
392 \ natural-sort must-infer
395 \ define-class must-infer
396 \ define-tuple-class must-infer
397 \ define-union-class must-infer
398 \ define-predicate-class must-infer
399 \ instance? must-infer
400 \ next-method-quot must-infer
402 ! Test words with continuations
403 { 0 0 } [ [ drop ] callcc0 ] must-infer-as
404 { 0 1 } [ [ 4 swap continue-with ] callcc1 ] must-infer-as
405 { 2 1 } [ [ + ] [ ] [ ] cleanup ] must-infer-as
406 { 2 1 } [ [ + ] [ 3drop 0 ] recover ] must-infer-as
410 ! Test stream protocol
411 \ set-timeout must-infer
412 \ stream-read must-infer
413 \ stream-read1 must-infer
414 \ stream-readln must-infer
415 \ stream-read-until must-infer
416 \ stream-write must-infer
417 \ stream-write1 must-infer
418 \ stream-nl must-infer
419 \ stream-format must-infer
420 \ stream-write-table must-infer
421 \ stream-flush must-infer
422 \ make-span-stream must-infer
423 \ make-block-stream must-infer
424 \ make-cell-stream must-infer
426 ! Test stream utilities
428 \ contents must-infer
430 ! Test prettyprinting
435 \ describe must-infer
439 \ io-thread must-infer
441 ! Incorrect stack declarations on inline recursive words should
443 : fooxxx ( a b -- c ) over [ foo ] when ; inline
444 : barxxx ( a b -- c ) fooxxx ;
446 [ [ barxxx ] infer ] must-fail
449 { 1 0 } [ { [ ] } dispatch ] must-infer-as
451 DEFER: inline-recursive-2
452 : inline-recursive-1 ( -- ) inline-recursive-2 ;
453 : inline-recursive-2 ( -- ) inline-recursive-1 ;
455 { 0 0 } [ inline-recursive-1 ] must-infer-as
459 HOOK: my-hook my-var ( -- x )
461 M: integer my-hook "an integer" ;
462 M: string my-hook "a string" ;
464 { 0 1 } [ my-hook ] must-infer-as
468 { 1 1 } [ [ deferred-word ] [ 3 ] if ] must-infer-as
471 DEFER: an-inline-word
473 : normal-word-3 ( -- )
474 3 [ [ 2 + ] curry ] an-inline-word call drop ;
476 : normal-word-2 ( -- )
479 : normal-word ( x -- x )
480 dup [ normal-word-2 ] when ;
482 : an-inline-word ( obj quot -- )
483 [ normal-word ] dip call ; inline
485 { 1 1 } [ [ 3 * ] an-inline-word ] must-infer-as
487 { 0 1 } [ [ 2 ] [ 2 ] [ + ] compose compose call ] must-infer-as
489 ERROR: custom-error ;
491 [ T{ effect f 0 0 t } ] [
492 [ custom-error ] infer
495 : funny-throw throw ; inline
497 [ T{ effect f 0 0 t } ] [
498 [ 3 funny-throw ] infer
501 [ T{ effect f 0 0 t } ] [
502 [ custom-error inference-error ] infer
505 [ T{ effect f 1 2 t } ] [
506 [ dup [ 3 throw ] dip ] infer
509 ! This was a false trigger of the undecidable quotation
511 { 2 1 } [ find-last-sep ] must-infer-as
514 : missing->r-check 1 load-locals ;
516 [ [ missing->r-check ] infer ] must-fail
519 [ [ [ f dup ] [ dup ] [ ] produce ] infer ] must-fail
521 [ [ [ f dup ] [ ] [ ] while ] infer ] must-fail
523 : erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline
525 [ [ erg's-inference-bug ] infer ] must-fail
527 : inference-invalidation-a ( -- ) ;
528 : inference-invalidation-b ( quot -- ) [ inference-invalidation-a ] dip call ; inline
529 : inference-invalidation-c ( a b -- c ) [ + ] inference-invalidation-b ; inline
531 [ 7 ] [ 4 3 inference-invalidation-c ] unit-test
533 { 2 1 } [ [ + ] inference-invalidation-b ] must-infer-as
535 [ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- a b ) 1 2 ;" eval ] unit-test
537 [ 3 ] [ inference-invalidation-c ] unit-test
539 { 0 1 } [ inference-invalidation-c ] must-infer-as
541 GENERIC: inference-invalidation-d ( obj -- )
543 M: object inference-invalidation-d inference-invalidation-c 2drop ;
545 \ inference-invalidation-d must-infer
547 [ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- ) ;" eval ] unit-test
549 [ [ inference-invalidation-d ] infer ] must-fail
551 : bad-recursion-3 ( -- ) dup [ [ bad-recursion-3 ] dip ] when ; inline
552 [ [ bad-recursion-3 ] infer ] must-fail
554 : bad-recursion-4 ( -- ) 4 [ dup call roll ] times ; inline
555 [ [ [ ] [ 1 2 3 ] over dup bad-recursion-4 ] infer ] must-fail
557 : bad-recursion-5 ( obj quot: ( -- ) -- ) dup call swap bad-recursion-5 ; inline recursive
558 [ [ f [ ] bad-recursion-5 ] infer ] must-fail
560 : bad-recursion-6 ( quot: ( -- ) -- )
561 dup bad-recursion-6 call ; inline recursive
562 [ [ [ drop f ] bad-recursion-6 ] infer ] must-fail
564 { 3 0 } [ [ 2drop "A" throw ] [ ] if 2drop ] must-infer-as
565 { 2 0 } [ drop f f [ 2drop "A" throw ] [ ] if 2drop ] must-infer-as
567 : unbalanced-retain-usage ( a b -- )
568 dup 10 < [ 2drop 5 1 + unbalanced-retain-usage ] [ 2drop ] if ;
571 [ [ unbalanced-retain-usage ] infer ] [ inference-error? ] must-fail-with
574 : ddd' ( ? -- ) [ f eee' ] when ; inline recursive
575 : eee' ( ? -- ) [ swap [ ] ] dip ddd' call ; inline recursive
577 [ [ eee' ] infer ] [ inference-error? ] must-fail-with
579 : bogus-error ( x -- )
580 dup "A" throw [ bogus-error ] [ drop ] if ; inline recursive
582 [ bogus-error ] must-infer
584 [ [ clear ] infer. ] [ inference-error? ] must-fail-with