basis/stack-checker/stack-checker-tests.factor

   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
  12
  13 [ 1234 infer ] must-fail
  14
  15 { 0 2 } [ 2 "Hello" ] must-infer-as
  16 { 1 2 } [ dup ] must-infer-as
  17
  18 { 1 2 } [ [ dup ] call ] must-infer-as
  19 [ [ call ] infer ] must-fail
  20
  21 { 2 4 } [ 2dup ] must-infer-as
  22
  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
  28
  29 { 4 3 } [
  30     [
  31         [ swap 3 ] [ nip 5 5 ] if
  32     ] [
  33         -rot
  34     ] if
  35 ] must-infer-as
  36
  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
  40
  41 { 1 0 } [ [ drop ] when* ] must-infer-as
  42 { 1 1 } [ [ { { [ ] } } ] unless* ] must-infer-as
  43
  44 { 0 1 }
  45 [ [ 2 2 fixnum+ ] dup [ ] when call ] must-infer-as
  46
  47 [
  48     [ [ [ 2 2 fixnum+ ] ] [ [ 2 2 fixnum* ] ] if call ] infer
  49 ] must-fail
  50
  51 ! Test inference of termination of control flow
  52 : termination-test-1 ( -- * ) "foo" throw ;
  53
  54 : termination-test-2 ( ? -- x ) [ termination-test-1 ] [ 3 ] if ;
  55
  56 { 1 1 } [ termination-test-2 ] must-infer-as
  57
  58 : simple-recursion-1 ( obj -- obj )
  59     dup [ simple-recursion-1 ] [ ] if ;
  60
  61 { 1 1 } [ simple-recursion-1 ] must-infer-as
  62
  63 : simple-recursion-2 ( obj -- obj )
  64     dup [ ] [ simple-recursion-2 ] if ;
  65
  66 { 1 1 } [ simple-recursion-2 ] must-infer-as
  67
  68 : funny-recursion ( obj -- obj )
  69     dup [ funny-recursion 1 ] [ 2 ] if drop ;
  70
  71 { 1 1 } [ funny-recursion ] must-infer-as
  72
  73 ! Simple combinators
  74 { 1 2 } [ [ first ] keep second ] must-infer-as
  75
  76 ! Mutual recursion
  77 DEFER: foe
  78
  79 : fie ( element obj -- ? )
  80     dup array? [ foe ] [ eq? ] if ;
  81
  82 : foe ( element tree -- ? )
  83     dup [
  84         2dup first fie [
  85             nip
  86         ] [
  87             second dup array? [
  88                 foe
  89             ] [
  90                 fie
  91             ] if
  92         ] if
  93     ] [
  94         2drop f
  95     ] if ;
  96
  97 { 2 1 } [ fie ] must-infer-as
  98 { 2 1 } [ foe ] must-infer-as
  99
 100 : nested-when ( -- )
 101     t [
 102         t [
 103             5 drop
 104         ] when
 105     ] when ;
 106
 107 { 0 0 } [ nested-when ] must-infer-as
 108
 109 : nested-when* ( obj -- )
 110     [
 111         [
 112             drop
 113         ] when*
 114     ] when* ;
 115
 116 { 1 0 } [ nested-when* ] must-infer-as
 117
 118 SYMBOL: sym-test
 119
 120 { 0 1 } [ sym-test ] must-infer-as
 121
 122 : terminator-branch ( a -- b )
 123     dup [
 124         length
 125     ] [
 126         "foo" throw
 127     ] if ;
 128
 129 { 1 1 } [ terminator-branch ] must-infer-as
 130
 131 : recursive-terminator ( obj -- )
 132     dup [
 133         recursive-terminator
 134     ] [
 135         "Hi" throw
 136     ] if ;
 137
 138 { 1 0 } [ recursive-terminator ] must-infer-as
 139
 140 GENERIC: potential-hang ( obj -- obj )
 141 M: fixnum potential-hang dup [ potential-hang ] when ;
 142
 143 [ ] [ [ 5 potential-hang ] infer drop ] unit-test
 144
 145 TUPLE: funny-cons car cdr ;
 146 GENERIC: iterate ( obj -- )
 147 M: funny-cons iterate cdr>> iterate ;
 148 M: f iterate drop ;
 149 M: real iterate drop ;
 150
 151 { 1 0 } [ iterate ] must-infer-as
 152
 153 ! Regression
 154 : cat ( obj -- * ) dup [ throw ] [ throw ] if ;
 155 : dog ( a b c -- ) dup [ cat ] [ 3drop ] if ;
 156 { 3 0 } [ dog ] must-infer-as
 157
 158 ! Regression
 159 DEFER: monkey
 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
 163
 164 ! Regression -- same as above but we infer the second word first
 165 DEFER: blah2
 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
 169
 170 ! Regression
 171 DEFER: blah4
 172 : blah3 ( a b c -- )
 173     dup [ blah3 ] [ dup [ blah4 ] [ blah3 ] if ] if ;
 174 : blah4 ( a b c -- )
 175     dup [ blah4 ] [ dup [ 3drop ] [ blah3 ] if ] if ;
 176 { 3 0 } [ blah4 ] must-infer-as
 177
 178 ! Regression
 179 : bad-combinator ( obj quot: ( -- ) -- )
 180     over [
 181         2drop
 182     ] [
 183         [ dip ] keep swap bad-combinator
 184     ] if ; inline recursive
 185
 186 [ [ [ 1 ] [ ] bad-combinator ] infer ] must-fail
 187
 188 ! Regression
 189 { 2 2 } [
 190     dup string? [ 2array throw ] unless
 191     over string? [ 2array throw ] unless
 192 ] must-infer-as
 193
 194 ! Regression
 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
 198
 199 ! This used to hang
 200 [ [ [ dup call ] dup call ] infer ]
 201 [ inference-error? ] must-fail-with
 202
 203 : m ( q -- ) dup call ; inline
 204
 205 [ [ [ m ] m ] infer ] [ inference-error? ] must-fail-with
 206
 207 : m' ( quot -- ) dup curry call ; inline
 208
 209 [ [ [ m' ] m' ] infer ] [ inference-error? ] must-fail-with
 210
 211 : m'' ( -- q ) [ dup curry ] ; inline
 212
 213 : m''' ( -- ) m'' call call ; inline
 214
 215 [ [ [ m''' ] m''' ] infer ] [ inference-error? ] must-fail-with
 216
 217 : m-if ( a b c -- ) t over if ; inline
 218
 219 [ [ [ m-if ] m-if ] infer ] [ inference-error? ] must-fail-with
 220
 221 ! This doesn't hang but it's also an example of the
 222 ! undedicable case
 223 [ [ [ [ drop 3 ] swap call ] dup call ] infer ]
 224 [ inference-error? ] must-fail-with
 225
 226 [ [ 1 drop-locals ] infer ] [ inference-error? ] must-fail-with
 227
 228 ! Regression
 229 [ [ cleave ] infer ] [ inference-error? ] must-fail-with
 230
 231 ! Test some curry stuff
 232 { 1 1 } [ 3 [ ] curry 4 [ ] curry if ] must-infer-as
 233
 234 { 2 1 } [ [ ] curry 4 [ ] curry if ] must-infer-as
 235
 236 [ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] must-fail
 237
 238 { 1 3 } [ [ 2drop f ] assoc-find ] must-infer-as
 239
 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
 245
 246 ! A typo
 247 { 1 0 } [ { [ ] } dispatch ] must-infer-as
 248
 249 DEFER: inline-recursive-2
 250 : inline-recursive-1 ( -- ) inline-recursive-2 ;
 251 : inline-recursive-2 ( -- ) inline-recursive-1 ;
 252
 253 { 0 0 } [ inline-recursive-1 ] must-infer-as
 254
 255 ! Hooks
 256 SYMBOL: my-var
 257 HOOK: my-hook my-var ( -- x )
 258
 259 M: integer my-hook "an integer" ;
 260 M: string my-hook "a string" ;
 261
 262 { 0 1 } [ my-hook ] must-infer-as
 263
 264 DEFER: deferred-word
 265
 266 { 1 1 } [ [ deferred-word ] [ 3 ] if ] must-infer-as
 267
 268 DEFER: an-inline-word
 269
 270 : normal-word-3 ( -- )
 271     3 [ [ 2 + ] curry ] an-inline-word call drop ;
 272
 273 : normal-word-2 ( -- )
 274     normal-word-3 ;
 275
 276 : normal-word ( x -- x )
 277     dup [ normal-word-2 ] when ;
 278
 279 : an-inline-word ( obj quot -- )
 280     [ normal-word ] dip call ; inline
 281
 282 { 1 1 } [ [ 3 * ] an-inline-word ] must-infer-as
 283
 284 { 0 1 } [ [ 2 ] [ 2 ] [ + ] compose compose call ] must-infer-as
 285
 286 ERROR: custom-error ;
 287
 288 [ T{ effect f 0 0 t } ] [
 289     [ custom-error ] infer
 290 ] unit-test
 291
 292 : funny-throw ( a -- * ) throw ; inline
 293
 294 [ T{ effect f 0 0 t } ] [
 295     [ 3 funny-throw ] infer
 296 ] unit-test
 297
 298 [ T{ effect f 0 0 t } ] [
 299     [ custom-error inference-error ] infer
 300 ] unit-test
 301
 302 [ T{ effect f 1 2 t } ] [
 303     [ dup [ 3 throw ] dip ] infer
 304 ] unit-test
 305
 306 ! Regression
 307 [ [ 1 load-locals ] infer ] must-fail
 308
 309 ! Corner case
 310 [ [ [ f dup ] [ dup ] produce ] infer ] must-fail
 311
 312 [ [ [ f dup ] [ ] while ] infer ] must-fail
 313
 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
 317
 318 : bad-recursion-3 ( -- ) dup [ [ bad-recursion-3 ] dip ] when ; inline recursive
 319 [ [ bad-recursion-3 ] infer ] must-fail
 320 FORGET: bad-recursion-3
 321
 322 : bad-recursion-4 ( -- ) 4 [ dup call roll ] times ; inline recursive
 323 [ [ [ ] [ 1 2 3 ] over dup bad-recursion-4 ] infer ] must-fail
 324
 325 : bad-recursion-5 ( obj quot: ( -- ) -- ) dup call swap bad-recursion-5 ; inline recursive
 326 [ [ f [ ] bad-recursion-5 ] infer ] must-fail
 327
 328 : bad-recursion-6 ( quot: ( -- ) -- )
 329     dup bad-recursion-6 call ; inline recursive
 330 [ [ [ drop f ] bad-recursion-6 ] infer ] must-fail
 331
 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
 334
 335 : unbalanced-retain-usage ( a b -- )
 336     dup 10 < [ 2drop 5 1 + unbalanced-retain-usage ] [ 2drop ] if ;
 337     inline recursive
 338
 339 [ [ unbalanced-retain-usage ] infer ] [ inference-error? ] must-fail-with
 340
 341 FORGET: unbalanced-retain-usage
 342
 343 DEFER: eee'
 344 : ddd' ( ? -- ) [ f eee' ] when ; inline recursive
 345 : eee' ( ? -- ) [ swap [ ] ] dip ddd' call ; inline recursive
 346
 347 [ [ eee' ] infer ] [ inference-error? ] must-fail-with
 348
 349 : bogus-error ( x -- )
 350     dup "A" throw [ bogus-error ] [ drop ] if ; inline recursive
 351
 352 [ bogus-error ] must-infer
 353
 354 [ [ clear ] infer. ] [ inference-error? ] must-fail-with
 355
 356 : debugging-curry-folding ( quot -- )
 357     [ debugging-curry-folding ] curry call ; inline recursive
 358
 359 [ [ ] debugging-curry-folding ] must-infer
 360
 361 [ [ exit ] [ 1 2 3 ] if ] must-infer
 362
 363 ! Stack effects are required now but FORGET: clears them...
 364 : forget-test ( -- ) ;
 365
 366 [ forget-test ] must-infer
 367 [ ] [ [ \ forget-test forget ] with-compilation-unit ] unit-test
 368 [ forget-test ] must-infer
 369
 370 [ [ cond ] infer ] must-fail
 371 [ [ bi ] infer ] must-fail
 372 [ at ] must-infer
 373
 374 [ [ [ "OOPS" throw ] dip ] [ drop ] if ] must-infer