basis/compiler/tree/propagation/propagation-tests.factor

   1 USING: accessors alien alien.accessors alien.c-types alien.data arrays
   2 assocs byte-arrays classes classes.algebra classes.struct
   3 classes.tuple.private combinators.short-circuit compiler.test
   4 compiler.tree compiler.tree.builder compiler.tree.debugger
   5 compiler.tree.optimizer compiler.tree.propagation.info effects fry
   6 generic.single hashtables kernel kernel.private layouts literals
   7 locals math math.floats.private math.functions math.integers.private
   8 math.intervals math.libm math.order math.private quotations sequences
   9 sequences.private sets slots.private sorting specialized-arrays
  10 strings strings.private system tools.test vectors vocabs words ;
  11 FROM: math => float ;
  12 SPECIALIZED-ARRAY: double
  13 SPECIALIZED-ARRAY: void*
  14 IN: compiler.tree.propagation.tests
  15
  16 ! Arrays
  17 { V{ array } } [
  18     [ 10 f <array> ] final-classes
  19 ] unit-test
  20
  21 { V{ array } } [
  22     [ { array } declare ] final-classes
  23 ] unit-test
  24
  25 { V{ array } } [
  26     [ 10 f <array> swap [ ] [ ] if ] final-classes
  27 ] unit-test
  28
  29 {
  30     T{ value-info-state
  31        { class integer }
  32        { interval $[ array-capacity-interval ] }
  33     }
  34 } [
  35     [ dup "foo" <array> drop ] final-info first
  36 ] unit-test
  37
  38 ! Byte arrays
  39 { V{ 3 } } [
  40     [ 3 <byte-array> length ] final-literals
  41 ] unit-test
  42
  43 { t } [
  44     [ dup <byte-array> drop ] final-info first
  45     integer-array-capacity <class-info> =
  46 ] unit-test
  47
  48 { t } [
  49     [ dupd resize-byte-array drop ] final-info first
  50     integer-array-capacity <class-info> =
  51 ] unit-test
  52
  53 ! Strings
  54 { V{ 3 } } [
  55     [ 3 f <string> length ] final-literals
  56 ] unit-test
  57
  58 { V{ t } } [
  59     [ { string } declare string? ] final-classes
  60 ] unit-test
  61
  62 { V{ string } } [
  63     [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
  64 ] unit-test
  65
  66 {
  67     V{ $[
  68         integer-array-capacity <class-info>
  69         integer <class-info>
  70     ] }
  71 } [
  72     [ 2dup <string> drop ] final-info
  73 ] unit-test
  74
  75 { { } } [
  76     all-words [
  77         "input-classes" word-prop [ class? ] all? not
  78     ] filter
  79 ] unit-test
  80
  81 ! The value interval should be limited for these.
  82 { t t } [
  83     [ fixnum>bignum ] final-info first interval>> fixnum-interval =
  84     [ fixnum>float ] final-info first interval>> fixnum-interval =
  85 ] unit-test
  86
  87 { V{ } } [ [ ] final-classes ] unit-test
  88
  89 { V{ fixnum } } [ [ 1 ] final-classes ] unit-test
  90
  91 { V{ fixnum } } [ [ 1 [ ] dip ] final-classes ] unit-test
  92
  93 { V{ fixnum object } } [ [ 1 swap ] final-classes ] unit-test
  94
  95 { V{ fixnum } } [ [ dup fixnum? [ ] [ drop 3 ] if ] final-classes ] unit-test
  96
  97 { V{ 69 } } [ [ [ 69 ] [ 69 ] if ] final-literals ] unit-test
  98
  99 { V{ integer } } [ [ bitnot ] final-classes ] unit-test
 100
 101 { V{ fixnum } } [ [ { fixnum } declare bitnot ] final-classes ] unit-test
 102
 103 ! Test type propagation for math ops
 104 : cleanup-math-class ( obj -- class )
 105     { null fixnum bignum integer ratio rational float real complex number }
 106     [ class= ] with find nip ;
 107
 108 : final-math-class ( quot -- class )
 109     final-classes first cleanup-math-class ;
 110
 111 { number } [ [ + ] final-math-class ] unit-test
 112
 113 { bignum } [ [ { fixnum bignum } declare + ] final-math-class ] unit-test
 114
 115 { integer } [ [ { fixnum integer } declare + ] final-math-class ] unit-test
 116
 117 { bignum } [ [ { integer bignum } declare + ] final-math-class ] unit-test
 118
 119 { integer } [ [ { fixnum fixnum } declare + ] final-math-class ] unit-test
 120
 121 { float } [ [ { float integer } declare + ] final-math-class ] unit-test
 122
 123 { float } [ [ { real float } declare + ] final-math-class ] unit-test
 124
 125 { float } [ [ { float real } declare + ] final-math-class ] unit-test
 126
 127 { rational } [ [ { ratio ratio } declare + ] final-math-class ] unit-test
 128
 129 { rational } [ [ { rational ratio } declare + ] final-math-class ] unit-test
 130
 131 { number } [ [ { complex complex } declare + ] final-math-class ] unit-test
 132
 133 { float } [ [ /f ] final-math-class ] unit-test
 134
 135 { float } [ [ { real real } declare /f ] final-math-class ] unit-test
 136
 137 { integer } [ [ /i ] final-math-class ] unit-test
 138
 139 { integer } [ [ { integer float } declare /i ] final-math-class ] unit-test
 140
 141 { integer } [ [ { float float } declare /i ] final-math-class ] unit-test
 142
 143 { integer } [ [ { integer } declare bitnot ] final-math-class ] unit-test
 144
 145 { null } [ [ { null null } declare + ] final-math-class ] unit-test
 146
 147 { null } [ [ { null fixnum } declare + ] final-math-class ] unit-test
 148
 149 { float } [ [ { float fixnum } declare + ] final-math-class ] unit-test
 150
 151 { bignum } [ [ { bignum bignum } declare bitxor ] final-math-class ] unit-test
 152
 153 { bignum } [ [ { integer } declare 123 >bignum bitand ] final-math-class ] unit-test
 154
 155 { float } [ [ { float float } declare mod ] final-math-class ] unit-test
 156
 157 { V{ integer float } } [ [ { float float } declare [ /i ] keep ] final-classes ] unit-test
 158
 159 { V{ fixnum } } [ [ 255 bitand ] final-classes ] unit-test
 160
 161 { V{ fixnum } } [
 162     [ [ 255 bitand ] [ 65535 bitand ] bi + ] final-classes
 163 ] unit-test
 164
 165 { V{ fixnum } } [
 166     [
 167         { fixnum } declare [ 255 bitand ] [ 65535 bitand ] bi +
 168     ] final-classes
 169 ] unit-test
 170
 171 { V{ integer } } [
 172     [ { fixnum } declare [ 255 bitand ] keep + ] final-classes
 173 ] unit-test
 174
 175 { V{ integer } } [
 176     [ { fixnum } declare 615949 * ] final-classes
 177 ] unit-test
 178
 179 { V{ fixnum } } [
 180     [ 255 bitand >fixnum 3 bitor ] final-classes
 181 ] unit-test
 182
 183 { V{ 0 } } [
 184     [ >fixnum 1 mod ] final-literals
 185 ] unit-test
 186
 187 { V{ 69 } } [
 188     [ >fixnum swap [ 1 mod 69 + ] [ drop 69 ] if ] final-literals
 189 ] unit-test
 190
 191 { V{ fixnum } } [
 192     [ >fixnum dup 10 > [ 1 - ] when ] final-classes
 193 ] unit-test
 194
 195 { V{ integer } } [ [ >fixnum 2 * ] final-classes ] unit-test
 196
 197 { V{ integer } } [
 198     [ >fixnum dup 10 < drop 2 * ] final-classes
 199 ] unit-test
 200
 201 { V{ integer } } [
 202     [ >fixnum dup 10 < [ 2 * ] when ] final-classes
 203 ] unit-test
 204
 205 { V{ integer } } [
 206     [ >fixnum dup 10 < [ 2 * ] [ 2 * ] if ] final-classes
 207 ] unit-test
 208
 209 { V{ fixnum } } [
 210     [ >fixnum dup 10 < [ dup -10 > [ 2 * ] when ] when ] final-classes
 211 ] unit-test
 212
 213 { V{ f } } [
 214     [ dup 10 < [ dup 8 > [ drop 9 ] unless ] [ drop 9 ] if ] final-literals
 215 ] unit-test
 216
 217 { V{ 9 } } [
 218     [
 219         123 bitand
 220         dup 10 < [ dup 8 > [ drop 9 ] unless ] [ drop 9 ] if
 221     ] final-literals
 222 ] unit-test
 223
 224 { V{ t } } [ [ 40 mod 40 < ] final-literals ] unit-test
 225
 226 { V{ f } } [ [ 40 mod 0 >= ] final-literals ] unit-test
 227
 228 { V{ t } } [ [ 40 rem 0 >= ] final-literals ] unit-test
 229
 230 { V{ t } } [ [ abs 40 mod 0 >= ] final-literals ] unit-test
 231
 232 { t } [ [ abs ] final-info first interval>> [0,inf] = ] unit-test
 233
 234 { t } [ [ absq ] final-info first interval>> [0,inf] = ] unit-test
 235
 236 { t } [ [ { fixnum } declare abs ] final-info first interval>> [0,inf] interval-subset? ] unit-test
 237
 238 { t } [ [ { fixnum } declare absq ] final-info first interval>> [0,inf] interval-subset? ] unit-test
 239
 240 { V{ integer } } [ [ { fixnum } declare abs ] final-classes ] unit-test
 241
 242 { V{ integer } } [ [ { fixnum } declare absq ] final-classes ] unit-test
 243
 244 { t } [ [ { bignum } declare abs ] final-info first interval>> [0,inf] interval-subset? ] unit-test
 245
 246 { t } [ [ { bignum } declare absq ] final-info first interval>> [0,inf] interval-subset? ] unit-test
 247
 248 { t } [ [ { float } declare abs ] final-info first interval>> [0,inf] = ] unit-test
 249
 250 { t } [ [ { float } declare absq ] final-info first interval>> [0,inf] = ] unit-test
 251
 252 { t } [ [ { complex } declare abs ] final-info first interval>> [0,inf] = ] unit-test
 253
 254 { t } [ [ { complex } declare absq ] final-info first interval>> [0,inf] = ] unit-test
 255
 256 { t } [ [ { float float } declare rect> C{ 0.0 0.0 } + absq ] final-info first interval>> [0,inf] = ] unit-test
 257
 258 { V{ float } } [ [ { float float } declare rect> C{ 0.0 0.0 } + absq ] final-classes ] unit-test
 259
 260 { t } [ [ [ - absq ] [ + ] 2map-reduce ] final-info first interval>> [0,inf] = ] unit-test
 261
 262 { t } [ [ { double-array double-array } declare [ - absq ] [ + ] 2map-reduce ] final-info first interval>> [0,inf] = ] unit-test
 263
 264 { V{ string } } [
 265     [ dup string? not [ "Oops" throw ] [ ] if ] final-classes
 266 ] unit-test
 267
 268 { V{ string } } [
 269     [ dup string? not not >boolean [ ] [ "Oops" throw ] if ] final-classes
 270 ] unit-test
 271
 272 { f } [ [ t xor ] final-classes first null-class? ] unit-test
 273
 274 { t } [ [ t or ] final-classes first true-class? ] unit-test
 275
 276 { t } [ [ t swap or ] final-classes first true-class? ] unit-test
 277
 278 { t } [ [ f and ] final-classes first false-class? ] unit-test
 279
 280 { t } [ [ f swap and ] final-classes first false-class? ] unit-test
 281
 282 { t } [ [ dup not or ] final-classes first true-class? ] unit-test
 283
 284 { t } [ [ dup not swap or ] final-classes first true-class? ] unit-test
 285
 286 { t } [ [ dup not and ] final-classes first false-class? ] unit-test
 287
 288 { t } [ [ dup not swap and ] final-classes first false-class? ] unit-test
 289
 290 { t } [ [ over [ drop f ] when [ "A" throw ] unless ] final-classes first false-class? ] unit-test
 291
 292 { V{ fixnum } } [
 293     [
 294         [ { fixnum } declare ] [ drop f ] if
 295         dup [ dup 13 eq? [ t ] [ f ] if ] [ t ] if
 296         [ "Oops" throw ] when
 297     ] final-classes
 298 ] unit-test
 299
 300 { V{ fixnum } } [
 301     [
 302         >fixnum
 303         dup [ 10 < ] [ -10 > ] bi and not [ 2 * ] unless
 304     ] final-classes
 305 ] unit-test
 306
 307 { } [
 308     [
 309         dup dup dup [ 100 < ] [ drop f ] if dup
 310         [ 2drop f ] [ 2drop f ] if
 311         [ ] [ dup [ ] [ ] if ] if
 312     ] final-info drop
 313 ] unit-test
 314
 315 { V{ fixnum } } [
 316     [ { fixnum } declare (clone) ] final-classes
 317 ] unit-test
 318
 319 { V{ vector } } [
 320     [ vector new ] final-classes
 321 ] unit-test
 322
 323 { V{ fixnum } } [
 324     [
 325         { fixnum byte-array } declare
 326         [ nth-unsafe ] 2keep [ nth-unsafe ] 2keep nth-unsafe
 327         [ [ 298 * ] dip 100 * - ] dip 208 * - 128 + -8 shift
 328         0 255 clamp
 329     ] final-classes
 330 ] unit-test
 331
 332 { V{ fixnum } } [
 333     [ 0 dup 10 > [ 2 * ] when ] final-classes
 334 ] unit-test
 335
 336 { V{ f } } [
 337     [ [ 0.0 ] [ -0.0 ] if ] final-literals
 338 ] unit-test
 339
 340 { V{ 1.5 } } [
 341     [ /f 1.5 1.5 clamp ] final-literals
 342 ] unit-test
 343
 344 { V{ 1.5 } } [
 345     [
 346         /f
 347         dup 1.5 <= [ dup 1.5 >= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if
 348     ] final-literals
 349 ] unit-test
 350
 351 { V{ 1.5 } } [
 352     [
 353         /f
 354         dup 1.5 u<= [ dup 1.5 u>= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if
 355     ] final-literals
 356 ] unit-test
 357
 358 { V{ 1.5 } } [
 359     [
 360         /f
 361         dup 1.5 <= [ dup 10 >= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if
 362     ] final-literals
 363 ] unit-test
 364
 365 { V{ 1.5 } } [
 366     [
 367         /f
 368         dup 1.5 u<= [ dup 10 u>= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if
 369     ] final-literals
 370 ] unit-test
 371
 372 { V{ f } } [
 373     [
 374         /f
 375         dup 0.0 <= [ dup 0.0 >= [ drop 0.0 ] unless ] [ drop 0.0 ] if
 376     ] final-literals
 377 ] unit-test
 378
 379 { V{ f } } [
 380     [
 381         /f
 382         dup 0.0 u<= [ dup 0.0 u>= [ drop 0.0 ] unless ] [ drop 0.0 ] if
 383     ] final-literals
 384 ] unit-test
 385
 386 { V{ fixnum } } [
 387     [ 0 dup 10 > [ 100 * ] when ] final-classes
 388 ] unit-test
 389
 390 { V{ fixnum } } [
 391     [ 0 dup 10 > [ drop "foo" ] when ] final-classes
 392 ] unit-test
 393
 394 { V{ fixnum } } [
 395     [ 0 dup 10 u> [ 100 * ] when ] final-classes
 396 ] unit-test
 397
 398 { V{ fixnum } } [
 399     [ 0 dup 10 u> [ drop "foo" ] when ] final-classes
 400 ] unit-test
 401
 402 { V{ fixnum } } [
 403     [ { fixnum } declare 3 3 - + ] final-classes
 404 ] unit-test
 405
 406 { V{ t } } [
 407     [ dup 10 < [ 3 * 30 < ] [ drop t ] if ] final-literals
 408 ] unit-test
 409
 410 { V{ t } } [
 411     [ dup 10 u< [ 3 * 30 u< ] [ drop t ] if ] final-literals
 412 ] unit-test
 413
 414 { V{ "d" } } [
 415     [
 416         3 {
 417             [ "a" ]
 418             [ "b" ]
 419             [ "c" ]
 420             [ "d" ]
 421             [ "e" ]
 422             [ "f" ]
 423             [ "g" ]
 424             [ "h" ]
 425         } dispatch
 426     ] final-literals
 427 ] unit-test
 428
 429 { V{ "hi" } } [
 430     [ [ "hi" ] [ 123 3 throw ] if ] final-literals
 431 ] unit-test
 432
 433 { V{ fixnum } } [
 434     [ >fixnum dup 100 < [ 1 + ] [ "Oops" throw ] if ] final-classes
 435 ] unit-test
 436
 437 { V{ fixnum } } [
 438     [ >fixnum dup 100 u< [ 1 + ] [ "Oops" throw ] if ] final-classes
 439 ] unit-test
 440
 441 { V{ -1 } } [
 442     [ 0 dup 100 < not [ 1 + ] [ 1 - ] if ] final-literals
 443 ] unit-test
 444
 445 { V{ -1 } } [
 446     [ 0 dup 100 u< not [ 1 + ] [ 1 - ] if ] final-literals
 447 ] unit-test
 448
 449 { V{ 2 } } [
 450     [ [ 1 ] [ 1 ] if 1 + ] final-literals
 451 ] unit-test
 452
 453 { V{ object } } [
 454     [ 0 * 10 < ] final-classes
 455 ] unit-test
 456
 457 { V{ object } } [
 458     [ 0 * 10 u< ] final-classes
 459 ] unit-test
 460
 461 { V{ 27 } } [
 462     [
 463         123 bitand dup 10 < over 8 > and [ 3 * ] [ "B" throw ] if
 464     ] final-literals
 465 ] unit-test
 466
 467 { V{ 27 } } [
 468     [
 469         123 bitand dup 10 u< over 8 u> and [ 3 * ] [ "B" throw ] if
 470     ] final-literals
 471 ] unit-test
 472
 473 { V{ string string } } [
 474     [
 475         2dup [ dup string? [ "Oops" throw ] unless ] bi@ 2drop
 476     ] final-classes
 477 ] unit-test
 478
 479 { V{ fixnum } } [
 480     [ { fixnum fixnum } declare 7 bitand neg shift ] final-classes
 481 ] unit-test
 482
 483 { V{ fixnum } } [
 484     [ { fixnum fixnum } declare 7 bitand neg >bignum shift ] final-classes
 485 ] unit-test
 486
 487 { V{ fixnum } } [
 488     [ { fixnum } declare 1 swap 7 bitand shift ] final-classes
 489 ] unit-test
 490
 491 { V{ fixnum } } [
 492     [ { fixnum } declare 1 swap 7 bitand >bignum shift ] final-classes
 493 ] unit-test
 494
 495 32bit? [
 496     [ V{ integer } ] [
 497         [ { fixnum } declare 1 swap 31 bitand shift ]
 498         final-classes
 499     ] unit-test
 500 ] when
 501
 502 ! Array length propagation
 503 { V{ t } } [ [ 10 f <array> length 10 = ] final-literals ] unit-test
 504
 505 { V{ t } } [ [ [ 10 f <array> length ] [ 10 <byte-array> length ] if 10 = ] final-literals ] unit-test
 506
 507 { V{ t } } [ [ [ 1 f <array> ] [ 2 f <array> ] if length 3 < ] final-literals ] unit-test
 508
 509 { V{ 10 } } [
 510     [ { fixnum } declare dup 10 eq? [ "A" throw ] unless ] final-literals
 511 ] unit-test
 512
 513 { V{ 3 } } [ [ [ { 1 2 3 } ] [ { 4 5 6 } ] if length ] final-literals ] unit-test
 514
 515 { V{ 3 } } [ [ [ B{ 1 2 3 } ] [ B{ 4 5 6 } ] if length ] final-literals ] unit-test
 516
 517 { V{ 3 } } [ [ [ "yay" ] [ "hah" ] if length ] final-literals ] unit-test
 518
 519
 520
 521 ! Slot propagation
 522 TUPLE: prop-test-tuple { x integer } ;
 523
 524 { V{ integer } } [ [ { prop-test-tuple } declare x>> ] final-classes ] unit-test
 525
 526 TUPLE: fold-boa-test-tuple { x read-only } { y read-only } { z read-only } ;
 527
 528 { V{ T{ fold-boa-test-tuple f 1 2 3 } } }
 529 [ [ 1 2 3 fold-boa-test-tuple boa ] final-literals ]
 530 unit-test
 531
 532 TUPLE: don't-fold-boa-test-tuple < identity-tuple ;
 533
 534 { V{ f } }
 535 [ [ don't-fold-boa-test-tuple boa ] final-literals ]
 536 unit-test
 537
 538 TUPLE: immutable-prop-test-tuple { x sequence read-only } ;
 539
 540 { V{ T{ immutable-prop-test-tuple f "hey" } } } [
 541     [ "hey" immutable-prop-test-tuple boa ] final-literals
 542 ] unit-test
 543
 544 { V{ { 1 2 } } } [
 545     [ { 1 2 } immutable-prop-test-tuple boa x>> ] final-literals
 546 ] unit-test
 547
 548 { V{ array } } [
 549     [ { array } declare immutable-prop-test-tuple boa x>> ] final-classes
 550 ] unit-test
 551
 552 { V{ complex } } [
 553     [ complex boa ] final-classes
 554 ] unit-test
 555
 556 { V{ complex } } [
 557     [ { float float } declare dup 0.0 <= [ "Oops" throw ] [ rect> ] if ] final-classes
 558 ] unit-test
 559
 560 { V{ float float } } [
 561     [
 562         { float float } declare
 563         dup 0.0 <= [ "Oops" throw ] when rect>
 564         [ real>> ] [ imaginary>> ] bi
 565     ] final-classes
 566 ] unit-test
 567
 568 { V{ complex } } [
 569     [
 570         { float float object } declare
 571         [ "Oops" throw ] [ complex boa ] if
 572     ] final-classes
 573 ] unit-test
 574
 575 { } [ [ dup 3 slot swap 4 slot dup 3 slot swap 4 slot ] final-info drop ] unit-test
 576
 577 { V{ number } } [ [ [ "Oops" throw ] [ 2 + ] if ] final-classes ] unit-test
 578 { V{ number } } [ [ [ 2 + ] [ "Oops" throw ] if ] final-classes ] unit-test
 579
 580 { V{ POSTPONE: f } } [
 581     [ dup 1.0 <= [ drop f ] [ 0 number= ] if ] final-classes
 582 ] unit-test
 583
 584 ! Don't fold this
 585 TUPLE: mutable-tuple-test { x sequence } ;
 586
 587 { V{ sequence } } [
 588     [ "hey" mutable-tuple-test boa x>> ] final-classes
 589 ] unit-test
 590
 591 { V{ sequence } } [
 592     [ T{ mutable-tuple-test f "hey" } x>> ] final-classes
 593 ] unit-test
 594
 595 { V{ array } } [
 596     [ T{ mutable-tuple-test f "hey" } layout-of ] final-classes
 597 ] unit-test
 598
 599 ! Mixed mutable and immutable slots
 600 TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
 601
 602 { V{ integer array } } [
 603     [
 604         3 { 2 1 } mixed-mutable-immutable boa [ x>> ] [ y>> ] bi
 605     ] final-classes
 606 ] unit-test
 607
 608 { V{ array integer } } [
 609     [
 610         3 { 2 1 } mixed-mutable-immutable boa [ y>> ] [ x>> ] bi
 611     ] final-classes
 612 ] unit-test
 613
 614 { V{ integer array } } [
 615     [
 616         [ 2drop T{ mixed-mutable-immutable f 3 { } } ]
 617         [ { array } declare mixed-mutable-immutable boa ] if
 618         [ x>> ] [ y>> ] bi
 619     ] final-classes
 620 ] unit-test
 621
 622 { V{ f { } } } [
 623     [
 624         T{ mixed-mutable-immutable f 3 { } }
 625         [ x>> ] [ y>> ] bi
 626     ] final-literals
 627 ] unit-test
 628
 629 ! Recursive propagation
 630 : recursive-test-1 ( a -- b ) recursive-test-1 ; inline recursive
 631
 632 { V{ null } } [ [ recursive-test-1 ] final-classes ] unit-test
 633
 634 : recursive-test-2 ( a -- b ) dup 10 < [ recursive-test-2 ] when ; inline recursive
 635
 636 { V{ real } } [ [ recursive-test-2 ] final-classes ] unit-test
 637
 638 : recursive-test-3 ( a -- b ) dup 10 < drop ; inline recursive
 639
 640 { V{ real } } [ [ recursive-test-3 ] final-classes ] unit-test
 641
 642 { V{ real } } [ [ [ dup 10 < ] [ ] while ] final-classes ] unit-test
 643
 644 { V{ float } } [
 645     [ { float } declare 10 [ 2.3 * ] times ] final-classes
 646 ] unit-test
 647
 648 { V{ fixnum } } [
 649     [ 0 10 [ nip ] each-integer ] final-classes
 650 ] unit-test
 651
 652 { V{ t } } [
 653     [ t 10 [ nip 0 >= ] each-integer ] final-literals
 654 ] unit-test
 655
 656 : recursive-test-4 ( i n -- )
 657     2dup < [ [ 1 + ] dip recursive-test-4 ] [ 2drop ] if ; inline recursive
 658
 659 { } [ [ recursive-test-4 ] final-info drop ] unit-test
 660
 661 : recursive-test-5 ( a -- b )
 662     dup 1 <= [ drop 1 ] [ dup 1 - recursive-test-5 * ] if ; inline recursive
 663
 664 { V{ integer } } [ [ { integer } declare recursive-test-5 ] final-classes ] unit-test
 665
 666 : recursive-test-6 ( a -- b )
 667     dup 1 <= [ drop 1 ] [ dup 1 - recursive-test-6 swap 2 - recursive-test-6 + ] if ; inline recursive
 668
 669 { V{ integer } } [ [ { fixnum } declare recursive-test-6 ] final-classes ] unit-test
 670
 671 : recursive-test-7 ( a -- b )
 672     dup 10 < [ 1 + recursive-test-7 ] when ; inline recursive
 673
 674 { V{ fixnum } } [ [ 0 recursive-test-7 ] final-classes ] unit-test
 675
 676 { V{ fixnum } } [ [ 1 10 [ dup 10 < [ 2 * ] when ] times ] final-classes ] unit-test
 677
 678 { V{ integer } } [ [ 0 2 100 ^ [ nip ] each-integer ] final-classes ] unit-test
 679
 680 { } [ [ [ ] [ ] compose curry call ] final-info drop ] unit-test
 681
 682 { V{ } } [
 683     [ [ drop ] [ drop ] compose curry (each-integer) ] final-classes
 684 ] unit-test
 685
 686 GENERIC: iterate ( obj -- next-obj ? )
 687 M: fixnum iterate f ; inline
 688 M: array iterate first t ; inline
 689
 690 : dead-loop ( obj -- final-obj )
 691     iterate [ dead-loop ] when ; inline recursive
 692
 693 { V{ fixnum } } [ [ { fixnum } declare dead-loop ] final-classes ] unit-test
 694
 695 : hang-1 ( m -- x )
 696     dup 0 number= [ hang-1 ] unless ; inline recursive
 697
 698 { } [ [ 3 hang-1 ] final-info drop ] unit-test
 699
 700 : hang-2 ( m n -- x )
 701     over 0 number= [
 702         nip
 703     ] [
 704         dup [
 705             drop 1 hang-2
 706         ] [
 707             dupd hang-2 hang-2
 708         ] if
 709     ] if ; inline recursive
 710
 711 { } [ [ 3 over hang-2 ] final-info drop ] unit-test
 712
 713 { } [
 714     [
 715         dup fixnum? [ 3 over hang-2 ] [ 3 over hang-2 ] if
 716     ] final-info drop
 717 ] unit-test
 718
 719 { V{ t } } [
 720     [ { hashtable } declare hashtable instance? ] final-classes
 721 ] unit-test
 722
 723 { V{ POSTPONE: f } } [
 724     [ { vector } declare hashtable instance? ] final-classes
 725 ] unit-test
 726
 727 { V{ object } } [
 728     [ { assoc } declare hashtable instance? ] final-classes
 729 ] unit-test
 730
 731 { V{ POSTPONE: f } } [
 732     [ 3 string? ] final-classes
 733 ] unit-test
 734
 735 { V{ fixnum } } [
 736     [ { fixnum } declare [ ] curry obj>> ] final-classes
 737 ] unit-test
 738
 739 { V{ f } } [
 740     [ 10 eq? [ drop 3 ] unless ] final-literals
 741 ] unit-test
 742
 743 GENERIC: bad-generic ( a -- b )
 744 M: fixnum bad-generic 1 fixnum+fast ; inline
 745 : bad-behavior ( -- b ) 4 bad-generic ; inline recursive
 746
 747 { V{ fixnum } } [ [ bad-behavior ] final-classes ] unit-test
 748
 749 { V{ number } } [
 750     [
 751         0 10 [ bad-generic dup 123 bitand drop bad-generic 1 + ] times
 752     ] final-classes
 753 ] unit-test
 754
 755 GENERIC: infinite-loop ( a -- b )
 756 M: integer infinite-loop infinite-loop ;
 757
 758 { } [ [ { integer } declare infinite-loop ] final-classes drop ] unit-test
 759
 760 { V{ tuple } } [ [ tuple-layout <tuple> ] final-classes ] unit-test
 761
 762 { } [ [ instance? ] final-classes drop ] unit-test
 763
 764 { f } [ [ V{ } clone ] final-info first literal?>> ] unit-test
 765
 766 : fold-throw-test ( a -- b ) "A" throw ; foldable
 767
 768 { } [ [ 0 fold-throw-test ] final-info drop ] unit-test
 769
 770 : too-deep ( a b -- c )
 771     dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline recursive
 772
 773 { } [ [ too-deep ] final-info drop ] unit-test
 774
 775 { } [ [ reversed boa slice boa nth-unsafe * ] final-info drop ] unit-test
 776
 777 MIXIN: empty-mixin
 778
 779 { } [ [ { empty-mixin } declare empty-mixin? ] final-info drop ] unit-test
 780
 781 { V{ fixnum } } [ [ [ bignum-shift drop ] keep ] final-classes ] unit-test
 782
 783 { V{ float } } [
 784     [
 785         [ { float float } declare complex boa ]
 786         [ 2drop C{ 0.0 0.0 } ]
 787         if real-part
 788     ] final-classes
 789 ] unit-test
 790
 791 { V{ POSTPONE: f } } [
 792     [ { float } declare 0 eq? ] final-classes
 793 ] unit-test
 794
 795 {
 796     { fixnum integer integer fixnum }
 797 } [
 798     {
 799         { integer fixnum }
 800         ! These two are tricky. Possibly, they will always be
 801         ! fixnums. But that requires a better interval-mod.
 802         { fixnum integer }
 803         { fixnum bignum }
 804         { bignum fixnum }
 805     } [ '[ _ declare mod ] final-classes first ] map
 806 ] unit-test
 807
 808 ! Due to downpromotion, we lose the type here.
 809 { V{ integer } } [
 810     [ { bignum bignum } declare bignum-mod ] final-classes
 811 ] unit-test
 812
 813 ! And here
 814 { V{ bignum integer } } [
 815     [ { bignum bignum } declare /mod ] final-classes
 816 ] unit-test
 817
 818 ! So this code gets worse than it was.
 819 {
 820     [
 821         bignum-mod 20 over tag 0 eq?
 822         [ fixnum+ ] [ fixnum>bignum bignum+ ] if
 823     ]
 824 } [
 825     [ { bignum bignum } declare bignum-mod 20 + ]
 826     build-tree optimize-tree nodes>quot
 827 ] unit-test
 828
 829 { V{ fixnum } } [
 830     [ fixnum-mod ] final-classes
 831 ] unit-test
 832
 833 { V{ integer } } [
 834     [ { fixnum integer } declare bitand ] final-classes
 835 ] unit-test
 836
 837 { V{ double-array } } [ [| | double-array{ } ] final-classes ] unit-test
 838
 839 { V{ t } } [ [ macosx unix? ] final-literals ] unit-test
 840
 841 { V{ array } } [ [ [ <=> ] sort [ <=> ] sort ] final-classes ] unit-test
 842
 843 { V{ float } } [ [ fsqrt ] final-classes ] unit-test
 844
 845 { V{ t } } [ [ { fixnum } declare 10 mod >float -20 > ] final-literals ] unit-test
 846
 847 { T{ interval f { 0 t } { 127 t } } } [
 848     [ { integer } declare 127 bitand ] final-info first interval>>
 849 ] unit-test
 850
 851 { V{ t } } [
 852     [ [ 123 bitand ] [ drop f ] if dup [ 0 >= ] [ not ] if ] final-literals
 853 ] unit-test
 854
 855 { V{ bignum } } [
 856     [ { bignum } declare dup 1 - bitxor ] final-classes
 857 ] unit-test
 858
 859 { V{ bignum integer } } [
 860     [ { bignum integer } declare [ shift ] keep ] final-classes
 861 ] unit-test
 862
 863 { V{ fixnum } } [ [ >fixnum 15 bitand 1 swap shift ] final-classes ] unit-test
 864
 865 { V{ fixnum } } [ [ 15 bitand 1 swap shift ] final-classes ] unit-test
 866
 867 { V{ fixnum } } [
 868     [ { fixnum } declare log2 ] final-classes
 869 ] unit-test
 870
 871 { V{ t } } [
 872     [ { fixnum } declare log2 0 >= ] final-classes
 873 ] unit-test
 874
 875 { V{ POSTPONE: f } } [
 876     [ { word object } declare equal? ] final-classes
 877 ] unit-test
 878
 879 { t } [ [ dup t xor or ] final-classes first true-class? ] unit-test
 880
 881 { t } [ [ dup t xor swap or ] final-classes first true-class? ] unit-test
 882
 883 { t } [ [ dup t xor and ] final-classes first false-class? ] unit-test
 884
 885 { t } [ [ dup t xor swap and ] final-classes first false-class? ] unit-test
 886
 887 ! generalize-counter-interval wasn't being called in all the right places.
 888 ! bug found by littledan
 889
 890 TUPLE: littledan-1 { a read-only } ;
 891
 892 : (littledan-1-test) ( a -- ) a>> 1 + littledan-1 boa (littledan-1-test) ; inline recursive
 893
 894 : littledan-1-test ( -- ) 0 littledan-1 boa (littledan-1-test) ; inline
 895
 896 { } [ [ littledan-1-test ] final-classes drop ] unit-test
 897
 898 TUPLE: littledan-2 { from read-only } { to read-only } ;
 899
 900 : (littledan-2-test) ( x -- i elt )
 901     [ from>> ] [ to>> ] bi + dup littledan-2 boa (littledan-2-test) ; inline recursive
 902
 903 : littledan-2-test ( x -- i elt )
 904     [ 0 ] dip { array-capacity } declare littledan-2 boa (littledan-2-test) ; inline
 905
 906 { } [ [ littledan-2-test ] final-classes drop ] unit-test
 907
 908 : (littledan-3-test) ( x -- )
 909     length 1 + f <array> (littledan-3-test) ; inline recursive
 910
 911 : littledan-3-test ( -- )
 912     0 f <array> (littledan-3-test) ; inline
 913
 914 { } [ [ littledan-3-test ] final-classes drop ] unit-test
 915
 916 { V{ 0 } } [ [ { } length ] final-literals ] unit-test
 917
 918 { V{ 1 } } [ [ { } length 1 + f <array> length ] final-literals ] unit-test
 919
 920 ! generalize-counter is not tight enough
 921 { V{ fixnum } } [ [ 0 10 [ 1 + >fixnum ] times ] final-classes ] unit-test
 922
 923 { V{ fixnum } } [ [ 0 10 [ 1 + >fixnum ] times 0 + ] final-classes ] unit-test
 924
 925 ! Coercions need to update intervals
 926 { V{ f } } [ [ 1 2 ? 100 shift >fixnum 1 = ] final-literals ] unit-test
 927
 928 { V{ t } } [ [ >fixnum 1 + >fixnum most-positive-fixnum <= ] final-literals ] unit-test
 929
 930 { V{ t } } [ [ >fixnum 1 + >fixnum most-negative-fixnum >= ] final-literals ] unit-test
 931
 932 { V{ f } } [ [ >fixnum 1 + >fixnum most-negative-fixnum > ] final-literals ] unit-test
 933
 934 ! Mutable tuples with circularity should not cause problems
 935 TUPLE: circle me ;
 936
 937 { } [ circle new dup >>me 1quotation final-info drop ] unit-test
 938
 939 ! Joe found an oversight
 940 { V{ integer } } [ [ >integer ] final-classes ] unit-test
 941
 942 TUPLE: foo bar ;
 943
 944 { t } [ [ foo new ] { new } inlined? ] unit-test
 945
 946 GENERIC: whatever ( x -- y )
 947 M: number whatever drop foo ; inline
 948
 949 { t } [ [ 1 whatever new ] { new } inlined? ] unit-test
 950
 951 : that-thing ( -- class ) foo ;
 952
 953 { f } [ [ that-thing new ] { new } inlined? ] unit-test
 954
 955 GENERIC: whatever2 ( x -- y )
 956 M: number whatever2 drop H{ { 1 1 } { 2 2 } { 3 3 } { 4 4 } { 5 6 } } ; inline
 957 M: f whatever2 ; inline
 958
 959 { t } [ [ 1 whatever2 at ] { at* hashcode* } inlined? ] unit-test
 960 { f } [ [ whatever2 at ] { at* hashcode* } inlined? ] unit-test
 961
 962 SYMBOL: not-an-assoc
 963
 964 { f } [ [ not-an-assoc at ] { at* } inlined? ] unit-test
 965
 966 { t } [ [ { 1 2 3 } member? ] { member? } inlined? ] unit-test
 967 { f } [ [ { 1 2 3 } swap member? ] { member? } inlined? ] unit-test
 968
 969 { t } [ [ { 1 2 3 } member-eq? ] { member-eq? } inlined? ] unit-test
 970 { f } [ [ { 1 2 3 } swap member-eq? ] { member-eq? } inlined? ] unit-test
 971
 972 { t } [ [ V{ } clone ] { clone (clone) } inlined? ] unit-test
 973 { f } [ [ { } clone ] { clone (clone) } inlined? ] unit-test
 974
 975 { f } [ [ instance? ] { instance? } inlined? ] unit-test
 976 { f } [ [ 5 instance? ] { instance? } inlined? ] unit-test
 977 { t } [ [ array instance? ] { instance? } inlined? ] unit-test
 978
 979 { t } [ [ ( a b c -- c b a ) shuffle ] { shuffle } inlined? ] unit-test
 980 { f } [ [ { 1 2 3 } swap shuffle ] { shuffle } inlined? ] unit-test
 981
 982 ! Type function for 'clone' had a subtle issue
 983 TUPLE: tuple-with-read-only-slot { x read-only } ;
 984
 985 M: tuple-with-read-only-slot clone
 986     x>> clone tuple-with-read-only-slot boa ; inline
 987
 988 { V{ object } } [
 989     [ { 1 2 3 } dup tuple-with-read-only-slot boa clone x>> eq? ] final-classes
 990 ] unit-test
 991
 992 ! alien-cell outputs a alien or f
 993 { t } [
 994     [ { byte-array fixnum } declare alien-cell dup [ "OOPS" throw ] unless ] final-classes
 995     first alien class=
 996 ] unit-test
 997
 998 ! Don't crash if bad literal inputs are passed to unsafe words
 999 { f } [ [ { } 1 fixnum+fast ] final-info first literal?>> ] unit-test
1000
1001 ! Converting /i to shift
1002 { t } [ [ >fixnum dup 0 >= [ 16 /i ] when ] { /i fixnum/i fixnum/i-fast } inlined? ] unit-test
1003 { f } [ [ >fixnum dup 0 >= [ 16 /i ] when ] { fixnum-shift-fast } inlined? ] unit-test
1004 { f } [ [ >float dup 0 >= [ 16 /i ] when ] { /i float/f } inlined? ] unit-test
1005
1006 ! We want this to inline
1007 { t } [ [ void* <c-direct-array> ] { <c-direct-array> } inlined? ] unit-test
1008 { V{ void*-array } } [ [ void* <c-direct-array> ] final-classes ] unit-test
1009
1010 ! bitand identities
1011 { t } [ [ alien-unsigned-1 255 bitand ] { bitand fixnum-bitand } inlined? ] unit-test
1012 { t } [ [ alien-unsigned-1 255 swap bitand ] { bitand fixnum-bitand } inlined? ] unit-test
1013
1014 { t } [ [ { fixnum } declare 256 rem -256 bitand ] { fixnum-bitand } inlined? ] unit-test
1015 { t } [ [ { fixnum } declare 250 rem -256 bitand ] { fixnum-bitand } inlined? ] unit-test
1016 { f } [ [ { fixnum } declare 257 rem -256 bitand ] { fixnum-bitand } inlined? ] unit-test
1017
1018 { V{ fixnum } } [ [ >bignum 10 mod 2^ ] final-classes ] unit-test
1019 { V{ bignum } } [ [ >bignum 10 bitand ] final-classes ] unit-test
1020 { V{ bignum } } [ [ >bignum 10 >bignum bitand ] final-classes ] unit-test
1021 { V{ fixnum } } [ [ >bignum 10 mod ] final-classes ] unit-test
1022 { V{ bignum } } [ [ { fixnum } declare -1 >bignum bitand ] final-classes ] unit-test
1023 { V{ bignum } } [ [ { fixnum } declare -1 >bignum swap bitand ] final-classes ] unit-test
1024
1025 ! Could be bignum not integer but who cares
1026 { V{ integer } } [ [ 10 >bignum bitand ] final-classes ] unit-test
1027 { V{ bignum } } [ [ { fixnum } declare 10 >bignum bitand ] final-classes ] unit-test
1028 { V{ bignum } } [ [ { integer } declare 10 >bignum bitand ] final-classes ] unit-test
1029
1030 { t } [ [ { fixnum fixnum } declare min ] { min } inlined? ] unit-test
1031 { f } [ [ { fixnum fixnum } declare min ] { fixnum-min } inlined? ] unit-test
1032
1033 { t } [ [ { float float } declare min ] { min } inlined? ] unit-test
1034 { f } [ [ { float float } declare min ] { float-min } inlined? ] unit-test
1035
1036 { t } [ [ { fixnum fixnum } declare max ] { max } inlined? ] unit-test
1037 { f } [ [ { fixnum fixnum } declare max ] { fixnum-max } inlined? ] unit-test
1038
1039 { t } [ [ { float float } declare max ] { max } inlined? ] unit-test
1040 { f } [ [ { float float } declare max ] { float-max } inlined? ] unit-test
1041
1042 ! Propagation should not call equal?, hashcode, etc on literals in user code
1043 { V{ } } [ [ 4 <reversed> [ 2drop ] with each ] final-info ] unit-test
1044
1045 ! Reduction
1046 { 1 } [ [ 4 <reversed> [ nth-unsafe ] [ ] unless ] final-info length ] unit-test
1047
1048 ! Optimization on bit?
1049 { t } [ [ 3 bit? ] { bit? } inlined? ] unit-test
1050 { f } [ [ 500 bit? ] { bit? } inlined? ] unit-test
1051
1052 { t } [ [ { 1 } intersect ] { intersect } inlined? ] unit-test
1053 { f } [ [ { 1 } swap intersect ] { intersect } inlined? ] unit-test ! We could do this
1054
1055 { t } [ [ { 1 } intersects? ] { intersects? } inlined? ] unit-test
1056 { f } [ [ { 1 } swap intersects? ] { intersects? } inlined? ] unit-test ! We could do this
1057
1058 { t } [ [ { 1 } diff ] { diff } inlined? ] unit-test
1059 { f } [ [ { 1 } swap diff ] { diff } inlined? ] unit-test ! We could do this
1060
1061 ! Output range for string-nth now that string-nth is a library word and
1062 ! not a primitive
1063 { t } [
1064     [ string-nth ] final-info first interval>> 0 23 2^ 1 - [a,b] =
1065 ] unit-test
1066
1067 ! Non-zero displacement for <displaced-alien> restricts the output type
1068 { t } [
1069     [ { byte-array } declare <displaced-alien> ] final-classes
1070     first byte-array alien class-or class=
1071 ] unit-test
1072
1073 { V{ alien } } [
1074     [ { alien } declare <displaced-alien> ] final-classes
1075 ] unit-test
1076
1077 { t } [
1078     [ { POSTPONE: f } declare <displaced-alien> ] final-classes
1079     first \ f alien class-or class=
1080 ] unit-test
1081
1082 { V{ alien } } [
1083     [ { byte-array } declare [ 10 bitand 2 + ] dip <displaced-alien> ] final-classes
1084 ] unit-test
1085
1086 ! 'tag' should have a declared output interval
1087 { V{ t } } [
1088     [ tag 0 15 between? ] final-literals
1089 ] unit-test
1090
1091 { t } [
1092     [ maybe{ integer } instance? ] { instance? } inlined?
1093 ] unit-test
1094
1095 TUPLE: inline-please a ;
1096 { t } [
1097     [ maybe{ inline-please } instance? ] { instance? } inlined?
1098 ] unit-test
1099
1100 GENERIC: derp ( obj -- obj' )
1101
1102 M: integer derp 5 + ;
1103 M: f derp drop t ;
1104
1105 { t }
1106 [
1107     [ dup maybe{ integer } instance? [ derp ] when ] { instance? } inlined?
1108 ] unit-test
1109
1110 ! Type-check ratios with bitand operators
1111
1112 : bitand-ratio0 ( x -- y )
1113     1 bitand zero? ;
1114
1115 : bitand-ratio1 ( x -- y )
1116     1 swap bitand zero? ;
1117
1118 [ 2+1/2 bitand-ratio0 ] [ no-method? ] must-fail-with
1119 [ 2+1/2 bitand-ratio1 ] [ no-method? ] must-fail-with
1120
1121 : shift-test0 ( x -- y )
1122     4.3 shift ;
1123
1124 [ 1 shift-test0 ] [ no-method? ] must-fail-with
1125
1126 ! Test for the #1370 bug
1127 STRUCT: bar { s bar* } ;
1128
1129 { t } [
1130     [ bar <struct> [ s>> ] follow ] build-tree optimize-tree
1131     [ #recursive? ] find nip
1132     child>> [ { [ #call? ] [ word>> \ alien-cell = ] } 1&& ] find nip
1133     >boolean
1134 ] unit-test