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

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