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