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 ;
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 ] must-fail
21 { 2 4 } [ 2dup ] must-infer-as
23 { 1 0 } [ [ ] [ ] if ] must-infer-as
24 [ [ if ] infer ] must-fail
25 [ [ [ ] if ] infer ] must-fail
26 [ [ [ 2 ] [ ] if ] infer ] must-fail
27 { 4 3 } [ [ rot ] [ -rot ] if ] must-infer-as
31 [ swap 3 ] [ nip 5 5 ] if
37 { 1 1 } [ dup [ ] when ] must-infer-as
38 { 1 1 } [ dup [ dup fixnum* ] when ] must-infer-as
39 { 2 1 } [ [ dup fixnum* ] when ] must-infer-as
41 { 1 0 } [ [ drop ] when* ] must-infer-as
42 { 1 1 } [ [ { { [ ] } } ] unless* ] must-infer-as
45 [ [ 2 2 fixnum+ ] dup [ ] when call ] must-infer-as
48 [ [ [ 2 2 fixnum+ ] ] [ [ 2 2 fixnum* ] ] if call ] infer
51 ! Test inference of termination of control flow
52 : termination-test-1 ( -- * ) "foo" throw ;
54 : termination-test-2 ( ? -- x ) [ termination-test-1 ] [ 3 ] if ;
56 { 1 1 } [ termination-test-2 ] must-infer-as
58 : simple-recursion-1 ( obj -- obj )
59 dup [ simple-recursion-1 ] [ ] if ;
61 { 1 1 } [ simple-recursion-1 ] must-infer-as
63 : simple-recursion-2 ( obj -- obj )
64 dup [ ] [ simple-recursion-2 ] if ;
66 { 1 1 } [ simple-recursion-2 ] must-infer-as
68 : funny-recursion ( obj -- obj )
69 dup [ funny-recursion 1 ] [ 2 ] if drop ;
71 { 1 1 } [ funny-recursion ] must-infer-as
74 { 1 2 } [ [ first ] keep second ] must-infer-as
79 : fie ( element obj -- ? )
80 dup array? [ foe ] [ eq? ] if ;
82 : foe ( element tree -- ? )
97 { 2 1 } [ fie ] must-infer-as
98 { 2 1 } [ foe ] must-infer-as
107 { 0 0 } [ nested-when ] must-infer-as
109 : nested-when* ( obj -- )
116 { 1 0 } [ nested-when* ] must-infer-as
120 { 0 1 } [ sym-test ] must-infer-as
122 : terminator-branch ( a -- b )
129 { 1 1 } [ terminator-branch ] must-infer-as
131 : recursive-terminator ( obj -- )
138 { 1 0 } [ recursive-terminator ] must-infer-as
140 GENERIC: potential-hang ( obj -- obj )
141 M: fixnum potential-hang dup [ potential-hang ] when ;
143 [ ] [ [ 5 potential-hang ] infer drop ] unit-test
145 TUPLE: funny-cons car cdr ;
146 GENERIC: iterate ( obj -- )
147 M: funny-cons iterate cdr>> iterate ;
149 M: real iterate drop ;
151 { 1 0 } [ iterate ] must-infer-as
154 : cat ( obj -- * ) dup [ throw ] [ throw ] if ;
155 : dog ( a b c -- ) dup [ cat ] [ 3drop ] if ;
156 { 3 0 } [ dog ] must-infer-as
160 : friend ( a b c -- ) dup [ friend ] [ monkey ] if ;
161 : monkey ( a b c -- ) dup [ 3drop ] [ friend ] if ;
162 { 3 0 } [ friend ] must-infer-as
164 ! Regression -- same as above but we infer the second word first
166 : blah ( a b c -- ) dup [ blah ] [ blah2 ] if ;
167 : blah2 ( a b c -- ) dup [ blah ] [ 3drop ] if ;
168 { 3 0 } [ blah2 ] must-infer-as
173 dup [ blah3 ] [ dup [ blah4 ] [ blah3 ] if ] if ;
175 dup [ blah4 ] [ dup [ 3drop ] [ blah3 ] if ] if ;
176 { 3 0 } [ blah4 ] must-infer-as
179 : bad-combinator ( obj quot: ( -- ) -- )
183 [ dip ] keep swap bad-combinator
184 ] if ; inline recursive
186 [ [ [ 1 ] [ ] bad-combinator ] infer ] must-fail
190 dup string? [ 2array throw ] unless
191 over string? [ 2array throw ] unless
195 : too-deep ( a b -- c )
196 dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline recursive
197 { 2 1 } [ too-deep ] must-infer-as
200 [ [ [ dup call ] dup call ] infer ]
201 [ inference-error? ] must-fail-with
203 : m ( q -- ) dup call ; inline
205 [ [ [ m ] m ] infer ] [ inference-error? ] must-fail-with
207 : m' ( quot -- ) dup curry call ; inline
209 [ [ [ m' ] m' ] infer ] [ inference-error? ] must-fail-with
211 : m'' ( -- q ) [ dup curry ] ; inline
213 : m''' ( -- ) m'' call call ; inline
215 [ [ [ m''' ] m''' ] infer ] [ inference-error? ] must-fail-with
217 : m-if ( a b c -- ) t over if ; inline
219 [ [ [ m-if ] m-if ] infer ] [ inference-error? ] must-fail-with
221 ! This doesn't hang but it's also an example of the
223 [ [ [ [ drop 3 ] swap call ] dup call ] infer ]
224 [ inference-error? ] must-fail-with
226 [ [ 1 drop-locals ] infer ] [ inference-error? ] must-fail-with
229 [ [ cleave ] infer ] [ inference-error? ] must-fail-with
231 ! Test some curry stuff
232 { 1 1 } [ 3 [ ] curry 4 [ ] curry if ] must-infer-as
234 { 2 1 } [ [ ] curry 4 [ ] curry if ] must-infer-as
236 [ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] must-fail
238 { 1 3 } [ [ 2drop f ] assoc-find ] must-infer-as
240 ! Test words with continuations
241 { 0 0 } [ [ drop ] callcc0 ] must-infer-as
242 { 0 1 } [ [ 4 swap continue-with ] callcc1 ] must-infer-as
243 { 2 1 } [ [ + ] [ ] [ ] cleanup ] must-infer-as
244 { 2 1 } [ [ + ] [ 3drop 0 ] recover ] must-infer-as
247 { 1 0 } [ { [ ] } dispatch ] must-infer-as
249 DEFER: inline-recursive-2
250 : inline-recursive-1 ( -- ) inline-recursive-2 ;
251 : inline-recursive-2 ( -- ) inline-recursive-1 ;
253 { 0 0 } [ inline-recursive-1 ] must-infer-as
257 HOOK: my-hook my-var ( -- x )
259 M: integer my-hook "an integer" ;
260 M: string my-hook "a string" ;
262 { 0 1 } [ my-hook ] must-infer-as
266 { 1 1 } [ [ deferred-word ] [ 3 ] if ] must-infer-as
268 DEFER: an-inline-word
270 : normal-word-3 ( -- )
271 3 [ [ 2 + ] curry ] an-inline-word call drop ;
273 : normal-word-2 ( -- )
276 : normal-word ( x -- x )
277 dup [ normal-word-2 ] when ;
279 : an-inline-word ( obj quot -- )
280 [ normal-word ] dip call ; inline
282 { 1 1 } [ [ 3 * ] an-inline-word ] must-infer-as
284 { 0 1 } [ [ 2 ] [ 2 ] [ + ] compose compose call ] must-infer-as
286 ERROR: custom-error ;
288 [ T{ effect f 0 0 t } ] [
289 [ custom-error ] infer
292 : funny-throw ( a -- * ) throw ; inline
294 [ T{ effect f 0 0 t } ] [
295 [ 3 funny-throw ] infer
298 [ T{ effect f 0 0 t } ] [
299 [ custom-error inference-error ] infer
302 [ T{ effect f 1 2 t } ] [
303 [ dup [ 3 throw ] dip ] infer
307 [ [ 1 load-locals ] infer ] must-fail
310 [ [ [ f dup ] [ dup ] produce ] infer ] must-fail
312 [ [ [ f dup ] [ ] while ] infer ] must-fail
314 : erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline recursive
315 [ [ erg's-inference-bug ] infer ] must-fail
316 FORGET: erg's-inference-bug
318 : bad-recursion-3 ( -- ) dup [ [ bad-recursion-3 ] dip ] when ; inline recursive
319 [ [ bad-recursion-3 ] infer ] must-fail
320 FORGET: bad-recursion-3
322 : bad-recursion-4 ( -- ) 4 [ dup call roll ] times ; inline recursive
323 [ [ [ ] [ 1 2 3 ] over dup bad-recursion-4 ] infer ] must-fail
325 : bad-recursion-5 ( obj quot: ( -- ) -- ) dup call swap bad-recursion-5 ; inline recursive
326 [ [ f [ ] bad-recursion-5 ] infer ] must-fail
328 : bad-recursion-6 ( quot: ( -- ) -- )
329 dup bad-recursion-6 call ; inline recursive
330 [ [ [ drop f ] bad-recursion-6 ] infer ] must-fail
332 { 3 0 } [ [ 2drop "A" throw ] [ ] if 2drop ] must-infer-as
333 { 2 0 } [ drop f f [ 2drop "A" throw ] [ ] if 2drop ] must-infer-as
335 : unbalanced-retain-usage ( a b -- )
336 dup 10 < [ 2drop 5 1 + unbalanced-retain-usage ] [ 2drop ] if ;
339 [ [ unbalanced-retain-usage ] infer ] [ inference-error? ] must-fail-with
341 FORGET: unbalanced-retain-usage
344 : ddd' ( ? -- ) [ f eee' ] when ; inline recursive
345 : eee' ( ? -- ) [ swap [ ] ] dip ddd' call ; inline recursive
347 [ [ eee' ] infer ] [ inference-error? ] must-fail-with
349 : bogus-error ( x -- )
350 dup "A" throw [ bogus-error ] [ drop ] if ; inline recursive
352 [ bogus-error ] must-infer
354 [ [ clear ] infer. ] [ inference-error? ] must-fail-with
356 : debugging-curry-folding ( quot -- )
357 [ debugging-curry-folding ] curry call ; inline recursive
359 [ [ ] debugging-curry-folding ] must-infer
361 [ [ exit ] [ 1 2 3 ] if ] must-infer
363 ! Stack effects are required now but FORGET: clears them...
364 : forget-test ( -- ) ;
366 [ forget-test ] must-infer
367 [ ] [ [ \ forget-test forget ] with-compilation-unit ] unit-test
368 [ forget-test ] must-infer
370 [ [ cond ] infer ] must-fail
371 [ [ bi ] infer ] must-fail
374 [ [ [ "OOPS" throw ] dip ] [ drop ] if ] must-infer
376 ! Found during code review
377 [ [ [ drop [ ] ] when call ] infer ] must-fail
378 [ swap [ [ drop [ ] ] when call ] infer ] must-fail
380 { 3 1 } [ call( a b -- c ) ] must-infer-as
381 { 3 1 } [ execute( a b -- c ) ] must-infer-as
383 [ [ call-effect ] infer ] must-fail
384 [ [ execute-effect ] infer ] must-fail