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 ;
  11 IN: stack-checker.tests
  12
  13 \ infer. must-infer
  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 : bad-recursion-2 ( obj -- obj )
  69     dup [ dup first swap second bad-recursion-2 ] [ ] if ;
  70
  71 [ [ bad-recursion-2 ] infer ] must-fail
  72
  73 : funny-recursion ( obj -- obj )
  74     dup [ funny-recursion 1 ] [ 2 ] if drop ;
  75
  76 { 1 1 } [ funny-recursion ] must-infer-as
  77
  78 ! Simple combinators
  79 { 1 2 } [ [ first ] keep second ] must-infer-as
  80
  81 ! Mutual recursion
  82 DEFER: foe
  83
  84 : fie ( element obj -- ? )
  85     dup array? [ foe ] [ eq? ] if ;
  86
  87 : foe ( element tree -- ? )
  88     dup [
  89         2dup first fie [
  90             nip
  91         ] [
  92             second dup array? [
  93                 foe
  94             ] [
  95                 fie
  96             ] if
  97         ] if
  98     ] [
  99         2drop f
 100     ] if ;
 101
 102 { 2 1 } [ fie ] must-infer-as
 103 { 2 1 } [ foe ] must-infer-as
 104
 105 : nested-when ( -- )
 106     t [
 107         t [
 108             5 drop
 109         ] when
 110     ] when ;
 111
 112 { 0 0 } [ nested-when ] must-infer-as
 113
 114 : nested-when* ( obj -- )
 115     [
 116         [
 117             drop
 118         ] when*
 119     ] when* ;
 120
 121 { 1 0 } [ nested-when* ] must-infer-as
 122
 123 SYMBOL: sym-test
 124
 125 { 0 1 } [ sym-test ] must-infer-as
 126
 127 : terminator-branch ( a -- b )
 128     dup [
 129         length
 130     ] [
 131         "foo" throw
 132     ] if ;
 133
 134 { 1 1 } [ terminator-branch ] must-infer-as
 135
 136 : recursive-terminator ( obj -- )
 137     dup [
 138         recursive-terminator
 139     ] [
 140         "Hi" throw
 141     ] if ;
 142
 143 { 1 0 } [ recursive-terminator ] must-infer-as
 144
 145 GENERIC: potential-hang ( obj -- obj )
 146 M: fixnum potential-hang dup [ potential-hang ] when ;
 147
 148 [ ] [ [ 5 potential-hang ] infer drop ] unit-test
 149
 150 TUPLE: funny-cons car cdr ;
 151 GENERIC: iterate ( obj -- )
 152 M: funny-cons iterate cdr>> iterate ;
 153 M: f iterate drop ;
 154 M: real iterate drop ;
 155
 156 { 1 0 } [ iterate ] must-infer-as
 157
 158 ! Regression
 159 : cat ( obj -- * ) dup [ throw ] [ throw ] if ;
 160 : dog ( a b c -- ) dup [ cat ] [ 3drop ] if ;
 161 { 3 0 } [ dog ] must-infer-as
 162
 163 ! Regression
 164 DEFER: monkey
 165 : friend ( a b c -- ) dup [ friend ] [ monkey ] if ;
 166 : monkey ( a b c -- ) dup [ 3drop ] [ friend ] if ;
 167 { 3 0 } [ friend ] must-infer-as
 168
 169 ! Regression -- same as above but we infer the second word first
 170 DEFER: blah2
 171 : blah ( a b c -- ) dup [ blah ] [ blah2 ] if ;
 172 : blah2 ( a b c -- ) dup [ blah ] [ 3drop ] if ;
 173 { 3 0 } [ blah2 ] must-infer-as
 174
 175 ! Regression
 176 DEFER: blah4
 177 : blah3 ( a b c -- )
 178     dup [ blah3 ] [ dup [ blah4 ] [ blah3 ] if ] if ;
 179 : blah4 ( a b c -- )
 180     dup [ blah4 ] [ dup [ 3drop ] [ blah3 ] if ] if ;
 181 { 3 0 } [ blah4 ] must-infer-as
 182
 183 ! Regression
 184 : bad-combinator ( obj quot: ( -- ) -- )
 185     over [
 186         2drop
 187     ] [
 188         [ swap slip ] keep swap bad-combinator
 189     ] if ; inline recursive
 190
 191 [ [ [ 1 ] [ ] bad-combinator ] infer ] must-fail
 192
 193 ! Regression
 194 { 2 2 } [
 195     dup string? [ 2array throw ] unless
 196     over string? [ 2array throw ] unless
 197 ] must-infer-as
 198
 199 ! Regression
 200
 201 ! This order of branches works
 202 DEFER: do-crap
 203 : more-crap ( obj -- ) dup [ drop ] [ dup do-crap call ] if ;
 204 : do-crap ( obj -- ) dup [ more-crap ] [ do-crap ] if ;
 205 [ [ do-crap ] infer ] must-fail
 206
 207 ! This one does not
 208 DEFER: do-crap*
 209 : more-crap* ( obj -- ) dup [ drop ] [ dup do-crap* call ] if ;
 210 : do-crap* ( obj -- ) dup [ do-crap* ] [ more-crap* ] if ;
 211 [ [ do-crap* ] infer ] must-fail
 212
 213 ! Regression
 214 : too-deep ( a b -- c )
 215     dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline recursive
 216 { 2 1 } [ too-deep ] must-infer-as
 217
 218 ! Error reporting is wrong
 219 MATH: xyz ( a b -- c )
 220 M: fixnum xyz 2array ;
 221 M: float xyz
 222     [ 3 ] bi@ swapd [ 2array swap ] dip 2array swap ;
 223
 224 [ [ xyz ] infer ] [ inference-error? ] must-fail-with
 225
 226 ! Doug Coleman discovered this one while working on the
 227 ! calendar library
 228 DEFER: A
 229 DEFER: B
 230 DEFER: C
 231
 232 : A ( a -- )
 233     dup {
 234         [ drop ]
 235         [ A ]
 236         [ \ A no-method ]
 237         [ dup C A ]
 238     } dispatch ;
 239
 240 : B ( b -- )
 241     dup {
 242         [ C ]
 243         [ B ]
 244         [ \ B no-method ]
 245         [ dup B B ]
 246     } dispatch ;
 247
 248 : C ( c -- )
 249     dup {
 250         [ A ]
 251         [ C ]
 252         [ \ C no-method ]
 253         [ dup B C ]
 254     } dispatch ;
 255
 256 { 1 0 } [ A ] must-infer-as
 257 { 1 0 } [ B ] must-infer-as
 258 { 1 0 } [ C ] must-infer-as
 259
 260 ! I found this bug by thinking hard about the previous one
 261 DEFER: Y
 262 : X ( a b -- c d ) dup [ swap Y ] [ ] if ;
 263 : Y ( a b -- c d ) X ;
 264
 265 { 2 2 } [ X ] must-infer-as
 266 { 2 2 } [ Y ] must-infer-as
 267
 268 ! This one comes from UI code
 269 DEFER: #1
 270 : #2 ( a b: ( -- ) -- ) dup [ call ] [ 2drop ] if ; inline
 271 : #3 ( a -- ) [ #1 ] #2 ;
 272 : #4 ( a -- ) dup [ drop ] [ dup #4 dup #3 call ] if ;
 273 : #1 ( a -- ) dup [ dup #4 dup #3 ] [ ] if drop ;
 274
 275 [ \ #4 def>> infer ] must-fail
 276 [ [ #1 ] infer ] must-fail
 277
 278 ! Similar
 279 DEFER: bar
 280 : foo ( a b -- c d ) dup [ 2drop f f bar ] [ ] if ;
 281 : bar ( a b -- ) [ 2 2 + ] t foo drop call drop ;
 282
 283 [ [ foo ] infer ] must-fail
 284
 285 [ 1234 infer ] must-fail
 286
 287 ! This used to hang
 288 [ [ [ dup call ] dup call ] infer ]
 289 [ inference-error? ] must-fail-with
 290
 291 : m dup call ; inline
 292
 293 [ [ [ m ] m ] infer ] [ inference-error? ] must-fail-with
 294
 295 : m' dup curry call ; inline
 296
 297 [ [ [ m' ] m' ] infer ] [ inference-error? ] must-fail-with
 298
 299 : m'' [ dup curry ] ; inline
 300
 301 : m''' m'' call call ; inline
 302
 303 [ [ [ m''' ] m''' ] infer ] [ inference-error? ] must-fail-with
 304
 305 : m-if t over if ; inline
 306
 307 [ [ [ m-if ] m-if ] infer ] [ inference-error? ] must-fail-with
 308
 309 ! This doesn't hang but it's also an example of the
 310 ! undedicable case
 311 [ [ [ [ drop 3 ] swap call ] dup call ] infer ]
 312 [ inference-error? ] must-fail-with
 313
 314 ! This form should not have a stack effect
 315
 316 : bad-recursion-1 ( a -- b )
 317     dup [ drop bad-recursion-1 5 ] [ ] if ;
 318
 319 [ [ bad-recursion-1 ] infer ] must-fail
 320
 321 : bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ;
 322 [ [ bad-bin ] infer ] must-fail
 323
 324 [ [ 1 drop-locals ] infer ] [ inference-error? ] must-fail-with
 325
 326 ! Regression
 327 [ [ cleave ] infer ] [ inference-error? ] must-fail-with
 328
 329 ! Test some curry stuff
 330 { 1 1 } [ 3 [ ] curry 4 [ ] curry if ] must-infer-as
 331
 332 { 2 1 } [ [ ] curry 4 [ ] curry if ] must-infer-as
 333
 334 [ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] must-fail
 335
 336 ! Test number protocol
 337 \ bitor must-infer
 338 \ bitand must-infer
 339 \ bitxor must-infer
 340 \ mod must-infer
 341 \ /i must-infer
 342 \ /f must-infer
 343 \ /mod must-infer
 344 \ + must-infer
 345 \ - must-infer
 346 \ * must-infer
 347 \ / must-infer
 348 \ < must-infer
 349 \ <= must-infer
 350 \ > must-infer
 351 \ >= must-infer
 352 \ number= must-infer
 353
 354 ! Test object protocol
 355 \ = must-infer
 356 \ clone must-infer
 357 \ hashcode* must-infer
 358
 359 ! Test sequence protocol
 360 \ length must-infer
 361 \ nth must-infer
 362 \ set-length must-infer
 363 \ set-nth must-infer
 364 \ new must-infer
 365 \ new-resizable must-infer
 366 \ like must-infer
 367 \ lengthen must-infer
 368
 369 ! Test assoc protocol
 370 \ at* must-infer
 371 \ set-at must-infer
 372 \ new-assoc must-infer
 373 \ delete-at must-infer
 374 \ clear-assoc must-infer
 375 \ assoc-size must-infer
 376 \ assoc-like must-infer
 377 \ assoc-clone-like must-infer
 378 \ >alist must-infer
 379 { 1 3 } [ [ 2drop f ] assoc-find ] must-infer-as
 380
 381 ! Test some random library words
 382 \ 1quotation must-infer
 383 \ string>number must-infer
 384 \ get must-infer
 385
 386 \ push must-infer
 387 \ append must-infer
 388 \ peek must-infer
 389
 390 \ reverse must-infer
 391 \ member? must-infer
 392 \ remove must-infer
 393 \ natural-sort must-infer
 394
 395 \ forget must-infer
 396 \ define-class must-infer
 397 \ define-tuple-class must-infer
 398 \ define-union-class must-infer
 399 \ define-predicate-class must-infer
 400 \ instance? must-infer
 401 \ next-method-quot must-infer
 402
 403 ! Test words with continuations
 404 { 0 0 } [ [ drop ] callcc0 ] must-infer-as
 405 { 0 1 } [ [ 4 swap continue-with ] callcc1 ] must-infer-as
 406 { 2 1 } [ [ + ] [ ] [ ] cleanup ] must-infer-as
 407 { 2 1 } [ [ + ] [ 3drop 0 ] recover ] must-infer-as
 408
 409 \ dispose must-infer
 410
 411 ! Test stream protocol
 412 \ set-timeout must-infer
 413 \ stream-read must-infer
 414 \ stream-read1 must-infer
 415 \ stream-readln must-infer
 416 \ stream-read-until must-infer
 417 \ stream-write must-infer
 418 \ stream-write1 must-infer
 419 \ stream-nl must-infer
 420 \ stream-flush must-infer
 421
 422 ! Test stream utilities
 423 \ lines must-infer
 424 \ contents must-infer
 425
 426 ! Test prettyprinting
 427 \ . must-infer
 428 \ short. must-infer
 429 \ unparse must-infer
 430
 431 \ describe must-infer
 432 \ error. must-infer
 433
 434 ! Test odds and ends
 435 \ io-thread must-infer
 436
 437 ! Incorrect stack declarations on inline recursive words should
 438 ! be caught
 439 : fooxxx ( a b -- c ) over [ foo ] when ; inline
 440 : barxxx ( a b -- c ) fooxxx ;
 441
 442 [ [ barxxx ] infer ] must-fail
 443
 444 ! A typo
 445 { 1 0 } [ { [ ] } dispatch ] must-infer-as
 446
 447 DEFER: inline-recursive-2
 448 : inline-recursive-1 ( -- ) inline-recursive-2 ;
 449 : inline-recursive-2 ( -- ) inline-recursive-1 ;
 450
 451 { 0 0 } [ inline-recursive-1 ] must-infer-as
 452
 453 ! Hooks
 454 SYMBOL: my-var
 455 HOOK: my-hook my-var ( -- x )
 456
 457 M: integer my-hook "an integer" ;
 458 M: string my-hook "a string" ;
 459
 460 { 0 1 } [ my-hook ] must-infer-as
 461
 462 DEFER: deferred-word
 463
 464 { 1 1 } [ [ deferred-word ] [ 3 ] if ] must-infer-as
 465
 466
 467 DEFER: an-inline-word
 468
 469 : normal-word-3 ( -- )
 470     3 [ [ 2 + ] curry ] an-inline-word call drop ;
 471
 472 : normal-word-2 ( -- )
 473     normal-word-3 ;
 474
 475 : normal-word ( x -- x )
 476     dup [ normal-word-2 ] when ;
 477
 478 : an-inline-word ( obj quot -- )
 479     [ normal-word ] dip call ; inline
 480
 481 { 1 1 } [ [ 3 * ] an-inline-word ] must-infer-as
 482
 483 { 0 1 } [ [ 2 ] [ 2 ] [ + ] compose compose call ] must-infer-as
 484
 485 ERROR: custom-error ;
 486
 487 [ T{ effect f 0 0 t } ] [
 488     [ custom-error ] infer
 489 ] unit-test
 490
 491 : funny-throw throw ; inline
 492
 493 [ T{ effect f 0 0 t } ] [
 494     [ 3 funny-throw ] infer
 495 ] unit-test
 496
 497 [ T{ effect f 0 0 t } ] [
 498     [ custom-error inference-error ] infer
 499 ] unit-test
 500
 501 [ T{ effect f 1 2 t } ] [
 502     [ dup [ 3 throw ] dip ] infer
 503 ] unit-test
 504
 505 ! This was a false trigger of the undecidable quotation
 506 ! recursion bug
 507 { 2 1 } [ find-last-sep ] must-infer-as
 508
 509 ! Regression
 510 : missing->r-check 1 load-locals ;
 511
 512 [ [ missing->r-check ] infer ] must-fail
 513
 514 ! Corner case
 515 [ [ [ f dup ] [ dup ] [ ] produce ] infer ] must-fail
 516
 517 [ [ [ f dup ] [ ] while ] infer ] must-fail
 518
 519 : erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline
 520
 521 [ [ erg's-inference-bug ] infer ] must-fail
 522
 523 : inference-invalidation-a ( -- ) ;
 524 : inference-invalidation-b ( quot -- ) [ inference-invalidation-a ] dip call ; inline
 525 : inference-invalidation-c ( a b -- c ) [ + ] inference-invalidation-b ; inline
 526
 527 [ 7 ] [ 4 3 inference-invalidation-c ] unit-test
 528
 529 { 2 1 } [ [ + ] inference-invalidation-b ] must-infer-as
 530
 531 [ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- a b ) 1 2 ;" eval ] unit-test
 532
 533 [ 3 ] [ inference-invalidation-c ] unit-test
 534
 535 { 0 1 } [ inference-invalidation-c ] must-infer-as
 536
 537 GENERIC: inference-invalidation-d ( obj -- )
 538
 539 M: object inference-invalidation-d inference-invalidation-c 2drop ;
 540
 541 \ inference-invalidation-d must-infer
 542
 543 [ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- ) ;" eval ] unit-test
 544
 545 [ [ inference-invalidation-d ] infer ] must-fail
 546
 547 : bad-recursion-3 ( -- ) dup [ [ bad-recursion-3 ] dip ] when ; inline
 548 [ [ bad-recursion-3 ] infer ] must-fail
 549
 550 : bad-recursion-4 ( -- ) 4 [ dup call roll ] times ; inline
 551 [ [ [ ] [ 1 2 3 ] over dup bad-recursion-4 ] infer ] must-fail
 552
 553 : bad-recursion-5 ( obj quot: ( -- ) -- ) dup call swap bad-recursion-5 ; inline recursive
 554 [ [ f [ ] bad-recursion-5 ] infer ] must-fail
 555
 556 : bad-recursion-6 ( quot: ( -- ) -- )
 557     dup bad-recursion-6 call ; inline recursive
 558 [ [ [ drop f ] bad-recursion-6 ] infer ] must-fail
 559
 560 { 3 0 } [ [ 2drop "A" throw ] [ ] if 2drop ] must-infer-as
 561 { 2 0 } [ drop f f [ 2drop "A" throw ] [ ] if 2drop ] must-infer-as
 562
 563 : unbalanced-retain-usage ( a b -- )
 564     dup 10 < [ 2drop 5 1 + unbalanced-retain-usage ] [ 2drop ] if ;
 565     inline recursive
 566
 567 [ [ unbalanced-retain-usage ] infer ] [ inference-error? ] must-fail-with
 568
 569 DEFER: eee'
 570 : ddd' ( ? -- ) [ f eee' ] when ; inline recursive
 571 : eee' ( ? -- ) [ swap [ ] ] dip ddd' call ; inline recursive
 572
 573 [ [ eee' ] infer ] [ inference-error? ] must-fail-with
 574
 575 : bogus-error ( x -- )
 576     dup "A" throw [ bogus-error ] [ drop ] if ; inline recursive
 577
 578 [ bogus-error ] must-infer
 579
 580 [ [ clear ] infer. ] [ inference-error? ] must-fail-with
 581
 582 : debugging-curry-folding ( quot -- )
 583     [ debugging-curry-folding ] curry call ; inline recursive
 584
 585 [ [ ] debugging-curry-folding ] must-infer
 586
 587 [ [ exit ] [ 1 2 3 ] if ] must-infer