core/inference/inference-tests.factor

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