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