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
   4 accessors sequences arrays kernel.private vectors
   5 alien.accessors alien.c-types sequences.private
   6 byte-arrays classes.algebra classes.tuple.private
   7 math.functions math.private strings layouts
   8 compiler.tree.propagation.info compiler.tree.def-use
   9 compiler.tree.debugger compiler.tree.checker
  10 slots.private words hashtables classes assocs locals
  11 specialized-arrays.double system sorting math.libm
  12 math.intervals quotations effects ;
  13 IN: compiler.tree.propagation.tests
  14
  15 [ V{ } ] [ [ ] final-classes ] unit-test
  16
  17 [ V{ fixnum } ] [ [ 1 ] final-classes ] unit-test
  18
  19 [ V{ fixnum } ] [ [ 1 [ ] dip ] final-classes ] unit-test
  20
  21 [ V{ fixnum object } ] [ [ 1 swap ] final-classes ] unit-test
  22
  23 [ V{ array } ] [ [ 10 f <array> ] final-classes ] unit-test
  24
  25 [ V{ array } ] [ [ { array } declare ] final-classes ] unit-test
  26
  27 [ V{ array } ] [ [ 10 f <array> swap [ ] [ ] if ] final-classes ] unit-test
  28
  29 [ V{ fixnum } ] [ [ dup fixnum? [ ] [ drop 3 ] if ] final-classes ] unit-test
  30
  31 [ V{ 69 } ] [ [ [ 69 ] [ 69 ] if ] final-literals ] unit-test
  32
  33 [ V{ fixnum } ] [ [ { fixnum } declare bitnot ] final-classes ] unit-test
  34
  35 ! Test type propagation for math ops
  36 : cleanup-math-class ( obj -- class )
  37     { null fixnum bignum integer ratio rational float real complex number }
  38     [ class= ] with find nip ;
  39
  40 : final-math-class ( quot -- class )
  41     final-classes first cleanup-math-class ;
  42
  43 [ number ] [ [ + ] final-math-class ] unit-test
  44
  45 [ bignum ] [ [ { fixnum bignum } declare + ] final-math-class ] unit-test
  46
  47 [ integer ] [ [ { fixnum integer } declare + ] final-math-class ] unit-test
  48
  49 [ bignum ] [ [ { integer bignum } declare + ] final-math-class ] unit-test
  50
  51 [ integer ] [ [ { fixnum fixnum } declare + ] final-math-class ] unit-test
  52
  53 [ float ] [ [ { float integer } declare + ] final-math-class ] unit-test
  54
  55 [ float ] [ [ { real float } declare + ] final-math-class ] unit-test
  56
  57 [ float ] [ [ { float real } declare + ] final-math-class ] unit-test
  58
  59 [ rational ] [ [ { ratio ratio } declare + ] final-math-class ] unit-test
  60
  61 [ rational ] [ [ { rational ratio } declare + ] final-math-class ] unit-test
  62
  63 [ number ] [ [ { complex complex } declare + ] final-math-class ] unit-test
  64
  65 [ float ] [ [ /f ] final-math-class ] unit-test
  66
  67 [ float ] [ [ { real real } declare /f ] final-math-class ] unit-test
  68
  69 [ integer ] [ [ /i ] final-math-class ] unit-test
  70
  71 [ integer ] [ [ { integer float } declare /i ] final-math-class ] unit-test
  72
  73 [ integer ] [ [ { float float } declare /i ] final-math-class ] unit-test
  74
  75 [ integer ] [ [ { integer } declare bitnot ] final-math-class ] unit-test
  76
  77 [ null ] [ [ { null null } declare + ] final-math-class ] unit-test
  78
  79 [ null ] [ [ { null fixnum } declare + ] final-math-class ] unit-test
  80
  81 [ float ] [ [ { float fixnum } declare + ] final-math-class ] unit-test
  82
  83 [ bignum ] [ [ { bignum bignum } declare bitxor ] final-math-class ] unit-test
  84
  85 [ float ] [ [ { float float } declare mod ] final-math-class ] unit-test
  86
  87 [ V{ fixnum } ] [ [ 255 bitand ] final-classes ] unit-test
  88
  89 [ V{ fixnum } ] [
  90     [ [ 255 bitand ] [ 65535 bitand ] bi + ] final-classes
  91 ] unit-test
  92
  93 [ V{ fixnum } ] [
  94     [
  95         { fixnum } declare [ 255 bitand ] [ 65535 bitand ] bi +
  96     ] final-classes
  97 ] unit-test
  98
  99 [ V{ integer } ] [
 100     [ { fixnum } declare [ 255 bitand ] keep + ] final-classes
 101 ] unit-test
 102
 103 [ V{ integer } ] [
 104     [ { fixnum } declare 615949 * ] final-classes
 105 ] unit-test
 106
 107 [ V{ fixnum } ] [
 108     [ 255 bitand >fixnum 3 bitor ] final-classes
 109 ] unit-test
 110
 111 [ V{ 0 } ] [
 112     [ >fixnum 1 mod ] final-literals
 113 ] unit-test
 114
 115 [ V{ 69 } ] [
 116     [ >fixnum swap [ 1 mod 69 + ] [ drop 69 ] if ] final-literals
 117 ] unit-test
 118
 119 [ V{ fixnum } ] [
 120     [ >fixnum dup 10 > [ 1 - ] when ] final-classes
 121 ] unit-test
 122
 123 [ V{ integer } ] [ [ >fixnum 2 * ] final-classes ] unit-test
 124
 125 [ V{ integer } ] [
 126     [ >fixnum dup 10 < drop 2 * ] final-classes
 127 ] unit-test
 128
 129 [ V{ integer } ] [
 130     [ >fixnum dup 10 < [ 2 * ] when ] final-classes
 131 ] unit-test
 132
 133 [ V{ integer } ] [
 134     [ >fixnum dup 10 < [ 2 * ] [ 2 * ] if ] final-classes
 135 ] unit-test
 136
 137 [ V{ fixnum } ] [
 138     [ >fixnum dup 10 < [ dup -10 > [ 2 * ] when ] when ] final-classes
 139 ] unit-test
 140
 141 [ V{ f } ] [
 142     [ dup 10 < [ dup 8 > [ drop 9 ] unless ] [ drop 9 ] if ] final-literals
 143 ] unit-test
 144
 145 [ V{ 9 } ] [
 146     [
 147         123 bitand
 148         dup 10 < [ dup 8 > [ drop 9 ] unless ] [ drop 9 ] if
 149     ] final-literals
 150 ] unit-test
 151
 152 [ V{ t } ] [ [ 40 mod 40 < ] final-literals ] unit-test
 153
 154 [ V{ f } ] [ [ 40 mod 0 >= ] final-literals ] unit-test
 155
 156 [ V{ t } ] [ [ 40 rem 0 >= ] final-literals ] unit-test
 157
 158 [ V{ t } ] [ [ abs 40 mod 0 >= ] final-literals ] unit-test
 159
 160 [ V{ string } ] [
 161     [ dup string? not [ "Oops" throw ] [ ] if ] final-classes
 162 ] unit-test
 163
 164 [ V{ string } ] [
 165     [ dup string? not not >boolean [ ] [ "Oops" throw ] if ] final-classes
 166 ] unit-test
 167
 168 [ f ] [ [ t xor ] final-classes first null-class? ] unit-test
 169
 170 [ t ] [ [ t or ] final-classes first true-class? ] unit-test
 171
 172 [ t ] [ [ t swap or ] final-classes first true-class? ] unit-test
 173
 174 [ t ] [ [ f and ] final-classes first false-class? ] unit-test
 175
 176 [ t ] [ [ f swap and ] final-classes first false-class? ] unit-test
 177
 178 [ t ] [ [ dup not or ] final-classes first true-class? ] unit-test
 179
 180 [ t ] [ [ dup not swap or ] final-classes first true-class? ] unit-test
 181
 182 [ t ] [ [ dup not and ] final-classes first false-class? ] unit-test
 183
 184 [ t ] [ [ dup not swap and ] final-classes first false-class? ] unit-test
 185
 186 [ t ] [ [ over [ drop f ] when [ "A" throw ] unless ] final-classes first false-class? ] unit-test
 187
 188 [ V{ fixnum } ] [
 189     [
 190         >fixnum
 191         dup [ 10 < ] [ -10 > ] bi and not [ 2 * ] unless
 192     ] final-classes
 193 ] unit-test
 194
 195 [ V{ fixnum } ] [
 196     [ { fixnum } declare (clone) ] final-classes
 197 ] unit-test
 198
 199 [ V{ vector } ] [
 200     [ vector new ] final-classes
 201 ] unit-test
 202
 203 [ V{ fixnum } ] [
 204     [
 205         { fixnum byte-array } declare
 206         [ nth-unsafe ] 2keep [ nth-unsafe ] 2keep nth-unsafe
 207         [ [ 298 * ] dip 100 * - ] dip 208 * - 128 + -8 shift
 208         0 255 clamp
 209     ] final-classes
 210 ] unit-test
 211
 212 [ V{ fixnum } ] [
 213     [ 0 dup 10 > [ 2 * ] when ] final-classes
 214 ] unit-test
 215
 216 [ V{ f } ] [
 217     [ [ 0.0 ] [ -0.0 ] if ] final-literals
 218 ] unit-test
 219
 220 [ V{ 1.5 } ] [
 221     [ /f 1.5 1.5 clamp ] final-literals
 222 ] unit-test
 223
 224 [ V{ 1.5 } ] [
 225     [
 226         /f
 227         dup 1.5 <= [ dup 1.5 >= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if
 228     ] final-literals
 229 ] unit-test
 230
 231 [ V{ 1.5 } ] [
 232     [
 233         /f
 234         dup 1.5 <= [ dup 10 >= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if
 235     ] final-literals
 236 ] unit-test
 237
 238 [ V{ f } ] [
 239     [
 240         /f
 241         dup 0.0 <= [ dup 0.0 >= [ drop 0.0 ] unless ] [ drop 0.0 ] if
 242     ] final-literals
 243 ] unit-test
 244
 245 [ V{ fixnum } ] [
 246     [ 0 dup 10 > [ 100 * ] when ] final-classes
 247 ] unit-test
 248
 249 [ V{ fixnum } ] [
 250     [ 0 dup 10 > [ drop "foo" ] when ] final-classes
 251 ] unit-test
 252
 253 [ V{ fixnum } ] [
 254     [ { fixnum } declare 3 3 - + ] final-classes
 255 ] unit-test
 256
 257 [ V{ t } ] [
 258     [ dup 10 < [ 3 * 30 < ] [ drop t ] if ] final-literals
 259 ] unit-test
 260
 261 [ V{ "d" } ] [
 262     [
 263         3 {
 264             [ "a" ]
 265             [ "b" ]
 266             [ "c" ]
 267             [ "d" ]
 268             [ "e" ]
 269             [ "f" ]
 270             [ "g" ]
 271             [ "h" ]
 272         } dispatch
 273     ] final-literals
 274 ] unit-test
 275
 276 [ V{ "hi" } ] [
 277     [ [ "hi" ] [ 123 3 throw ] if ] final-literals
 278 ] unit-test
 279
 280 [ V{ fixnum } ] [
 281     [ >fixnum dup 100 < [ 1 + ] [ "Oops" throw ] if ] final-classes
 282 ] unit-test
 283
 284 [ V{ -1 } ] [
 285     [ 0 dup 100 < not [ 1 + ] [ 1 - ] if ] final-literals
 286 ] unit-test
 287
 288 [ V{ 2 } ] [
 289     [ [ 1 ] [ 1 ] if 1 + ] final-literals
 290 ] unit-test
 291
 292 [ V{ object } ] [
 293     [ 0 * 10 < ] final-classes
 294 ] unit-test
 295
 296 [ V{ 27 } ] [
 297     [
 298         123 bitand dup 10 < over 8 > and [ 3 * ] [ "B" throw ] if
 299     ] final-literals
 300 ] unit-test
 301
 302 [ V{ 27 } ] [
 303     [
 304         dup number? over sequence? and [
 305             dup 10 < over 8 <= not and [ 3 * ] [ "A" throw ] if
 306         ] [ "B" throw ] if
 307     ] final-literals
 308 ] unit-test
 309
 310 [ V{ string string } ] [
 311     [
 312         2dup [ dup string? [ "Oops" throw ] unless ] bi@ 2drop
 313     ] final-classes
 314 ] unit-test
 315
 316 [ V{ fixnum } ] [
 317     [ { fixnum fixnum } declare 7 bitand neg shift ] final-classes
 318 ] unit-test
 319
 320 [ V{ fixnum } ] [
 321     [ { fixnum } declare 1 swap 7 bitand shift ] final-classes
 322 ] unit-test
 323
 324 cell-bits 32 = [
 325     [ V{ integer } ] [
 326         [ { fixnum } declare 1 swap 31 bitand shift ]
 327         final-classes
 328     ] unit-test
 329 ] when
 330
 331 ! Array length propagation
 332 [ V{ t } ] [ [ 10 f <array> length 10 = ] final-literals ] unit-test
 333
 334 [ V{ t } ] [ [ [ 10 f <array> length ] [ 10 <byte-array> length ] if 10 = ] final-literals ] unit-test
 335
 336 [ V{ t } ] [ [ [ 1 f <array> ] [ 2 f <array> ] if length 3 < ] final-literals ] unit-test
 337
 338 [ V{ 10 } ] [
 339     [ { fixnum } declare dup 10 eq? [ "A" throw ] unless ] final-literals
 340 ] unit-test
 341
 342 [ V{ 3 } ] [ [ [ { 1 2 3 } ] [ { 4 5 6 } ] if length ] final-literals ] unit-test
 343
 344 [ V{ 3 } ] [ [ [ B{ 1 2 3 } ] [ B{ 4 5 6 } ] if length ] final-literals ] unit-test
 345
 346 [ V{ 3 } ] [ [ [ "yay" ] [ "hah" ] if length ] final-literals ] unit-test
 347
 348 [ V{ 3 } ] [ [ 3 <byte-array> length ] final-literals ] unit-test
 349
 350 [ V{ 3 } ] [ [ 3 f <string> length ] final-literals ] unit-test
 351
 352 ! Slot propagation
 353 TUPLE: prop-test-tuple { x integer } ;
 354
 355 [ V{ integer } ] [ [ { prop-test-tuple } declare x>> ] final-classes ] unit-test
 356
 357 TUPLE: fold-boa-test-tuple { x read-only } { y read-only } { z read-only } ;
 358
 359 [ V{ T{ fold-boa-test-tuple f 1 2 3 } } ]
 360 [ [ 1 2 3 fold-boa-test-tuple boa ] final-literals ]
 361 unit-test
 362
 363 TUPLE: immutable-prop-test-tuple { x sequence read-only } ;
 364
 365 [ V{ T{ immutable-prop-test-tuple f "hey" } } ] [
 366     [ "hey" immutable-prop-test-tuple boa ] final-literals
 367 ] unit-test
 368
 369 [ V{ { 1 2 } } ] [
 370     [ { 1 2 } immutable-prop-test-tuple boa x>> ] final-literals
 371 ] unit-test
 372
 373 [ V{ array } ] [
 374     [ { array } declare immutable-prop-test-tuple boa x>> ] final-classes
 375 ] unit-test
 376
 377 [ V{ complex } ] [
 378     [ complex boa ] final-classes
 379 ] unit-test
 380
 381 [ V{ complex } ] [
 382     [ { float float } declare dup 0.0 <= [ "Oops" throw ] [ rect> ] if ] final-classes
 383 ] unit-test
 384
 385 [ V{ float float } ] [
 386     [
 387         { float float } declare
 388         dup 0.0 <= [ "Oops" throw ] when rect>
 389         [ real>> ] [ imaginary>> ] bi
 390     ] final-classes
 391 ] unit-test
 392
 393 [ V{ complex } ] [
 394     [
 395         { float float object } declare
 396         [ "Oops" throw ] [ complex boa ] if
 397     ] final-classes
 398 ] unit-test
 399
 400 [ ] [ [ dup 3 slot swap 4 slot dup 3 slot swap 4 slot ] final-info drop ] unit-test
 401
 402 [ V{ number } ] [ [ [ "Oops" throw ] [ 2 + ] if ] final-classes ] unit-test
 403 [ V{ number } ] [ [ [ 2 + ] [ "Oops" throw ] if ] final-classes ] unit-test
 404
 405 [ V{ POSTPONE: f } ] [
 406     [ dup 1.0 <= [ drop f ] [ 0 number= ] if ] final-classes
 407 ] unit-test
 408
 409 ! Don't fold this
 410 TUPLE: mutable-tuple-test { x sequence } ;
 411
 412 [ V{ sequence } ] [
 413     [ "hey" mutable-tuple-test boa x>> ] final-classes
 414 ] unit-test
 415
 416 [ V{ sequence } ] [
 417     [ T{ mutable-tuple-test f "hey" } x>> ] final-classes
 418 ] unit-test
 419
 420 [ V{ array } ] [
 421     [ T{ mutable-tuple-test f "hey" } layout-of ] final-classes
 422 ] unit-test
 423
 424 ! Mixed mutable and immutable slots
 425 TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
 426
 427 [ V{ integer array } ] [
 428     [
 429         3 { 2 1 } mixed-mutable-immutable boa [ x>> ] [ y>> ] bi
 430     ] final-classes
 431 ] unit-test
 432
 433 [ V{ array integer } ] [
 434     [
 435         3 { 2 1 } mixed-mutable-immutable boa [ y>> ] [ x>> ] bi
 436     ] final-classes
 437 ] unit-test
 438
 439 [ V{ integer array } ] [
 440     [
 441         [ 2drop T{ mixed-mutable-immutable f 3 { } } ]
 442         [ { array } declare mixed-mutable-immutable boa ] if
 443         [ x>> ] [ y>> ] bi
 444     ] final-classes
 445 ] unit-test
 446
 447 ! Recursive propagation
 448 : recursive-test-1 ( a -- b ) recursive-test-1 ; inline recursive
 449
 450 [ V{ null } ] [ [ recursive-test-1 ] final-classes ] unit-test
 451
 452 : recursive-test-2 ( a -- b ) dup 10 < [ recursive-test-2 ] when ; inline recursive
 453
 454 [ V{ real } ] [ [ recursive-test-2 ] final-classes ] unit-test
 455
 456 : recursive-test-3 ( a -- b ) dup 10 < drop ; inline recursive
 457
 458 [ V{ real } ] [ [ recursive-test-3 ] final-classes ] unit-test
 459
 460 [ V{ real } ] [ [ [ dup 10 < ] [ ] while ] final-classes ] unit-test
 461
 462 [ V{ float } ] [
 463     [ { float } declare 10 [ 2.3 * ] times ] final-classes
 464 ] unit-test
 465
 466 [ V{ fixnum } ] [
 467     [ 0 10 [ nip ] each-integer ] final-classes
 468 ] unit-test
 469
 470 [ V{ t } ] [
 471     [ t 10 [ nip 0 >= ] each-integer ] final-literals
 472 ] unit-test
 473
 474 : recursive-test-4 ( i n -- )
 475     2dup < [ [ 1 + ] dip recursive-test-4 ] [ 2drop ] if ; inline recursive
 476
 477 [ ] [ [ recursive-test-4 ] final-info drop ] unit-test
 478
 479 : recursive-test-5 ( a -- b )
 480     dup 1 <= [ drop 1 ] [ dup 1 - recursive-test-5 * ] if ; inline recursive
 481
 482 [ V{ integer } ] [ [ { integer } declare recursive-test-5 ] final-classes ] unit-test
 483
 484 : recursive-test-6 ( a -- b )
 485     dup 1 <= [ drop 1 ] [ dup 1 - recursive-test-6 swap 2 - recursive-test-6 + ] if ; inline recursive
 486
 487 [ V{ integer } ] [ [ { fixnum } declare recursive-test-6 ] final-classes ] unit-test
 488
 489 : recursive-test-7 ( a -- b )
 490     dup 10 < [ 1 + recursive-test-7 ] when ; inline recursive
 491
 492 [ V{ fixnum } ] [ [ 0 recursive-test-7 ] final-classes ] unit-test
 493
 494 [ V{ fixnum } ] [ [ 1 10 [ dup 10 < [ 2 * ] when ] times ] final-classes ] unit-test
 495
 496 [ V{ integer } ] [ [ 0 2 100 ^ [ nip ] each-integer ] final-classes ] unit-test
 497
 498 [ ] [ [ [ ] [ ] compose curry call ] final-info drop ] unit-test
 499
 500 [ V{ } ] [
 501     [ [ drop ] [ drop ] compose curry (each-integer) ] final-classes
 502 ] unit-test
 503
 504 GENERIC: iterate ( obj -- next-obj ? )
 505 M: fixnum iterate f ;
 506 M: array iterate first t ;
 507
 508 : dead-loop ( obj -- final-obj )
 509     iterate [ dead-loop ] when ; inline recursive
 510
 511 [ V{ fixnum } ] [ [ { fixnum } declare dead-loop ] final-classes ] unit-test
 512
 513 : hang-1 ( m -- x )
 514     dup 0 number= [ hang-1 ] unless ; inline recursive
 515
 516 [ ] [ [ 3 hang-1 ] final-info drop ] unit-test
 517
 518 : hang-2 ( m n -- x )
 519     over 0 number= [
 520         nip
 521     ] [
 522         dup [
 523             drop 1 hang-2
 524         ] [
 525             dupd hang-2 hang-2
 526         ] if
 527     ] if ; inline recursive
 528
 529 [ ] [ [ 3 over hang-2 ] final-info drop ] unit-test
 530
 531 [ ] [
 532     [
 533         dup fixnum? [ 3 over hang-2 ] [ 3 over hang-2 ] if
 534     ] final-info drop
 535 ] unit-test
 536
 537 [ V{ word } ] [
 538     [ { hashtable } declare hashtable instance? ] final-classes
 539 ] unit-test
 540
 541 [ V{ POSTPONE: f } ] [
 542     [ { vector } declare hashtable instance? ] final-classes
 543 ] unit-test
 544
 545 [ V{ object } ] [
 546     [ { assoc } declare hashtable instance? ] final-classes
 547 ] unit-test
 548
 549 [ V{ word } ] [
 550     [ { string } declare string? ] final-classes
 551 ] unit-test
 552
 553 [ V{ POSTPONE: f } ] [
 554     [ 3 string? ] final-classes
 555 ] unit-test
 556
 557 [ V{ fixnum } ] [
 558     [ { fixnum } declare [ ] curry obj>> ] final-classes
 559 ] unit-test
 560
 561 [ V{ fixnum } ] [
 562     [ { fixnum fixnum } declare [ nth-unsafe ] curry call ] final-classes
 563 ] unit-test
 564
 565 [ V{ f } ] [
 566     [ 10 eq? [ drop 3 ] unless ] final-literals
 567 ] unit-test
 568
 569 GENERIC: bad-generic ( a -- b )
 570 M: fixnum bad-generic 1 fixnum+fast ;
 571 : bad-behavior ( -- b ) 4 bad-generic ; inline recursive
 572
 573 [ V{ fixnum } ] [ [ bad-behavior ] final-classes ] unit-test
 574
 575 [ V{ number } ] [
 576     [
 577         0 10 [ bad-generic dup 123 bitand drop bad-generic 1 + ] times
 578     ] final-classes
 579 ] unit-test
 580
 581 GENERIC: infinite-loop ( a -- b )
 582 M: integer infinite-loop infinite-loop ;
 583
 584 [ ] [ [ { integer } declare infinite-loop ] final-classes drop ] unit-test
 585
 586 [ V{ tuple } ] [ [ tuple-layout <tuple> ] final-classes ] unit-test
 587
 588 [ ] [ [ instance? ] final-classes drop ] unit-test
 589
 590 [ f ] [ [ V{ } clone ] final-info first literal?>> ] unit-test
 591
 592 : fold-throw-test ( a -- b ) "A" throw ; foldable
 593
 594 [ ] [ [ 0 fold-throw-test ] final-info drop ] unit-test
 595
 596 : too-deep ( a b -- c )
 597     dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline recursive
 598
 599 [ ] [ [ too-deep ] final-info drop ] unit-test
 600
 601 [ ] [ [ reversed boa slice boa nth-unsafe * ] final-info drop ] unit-test
 602
 603 MIXIN: empty-mixin
 604
 605 [ ] [ [ { empty-mixin } declare empty-mixin? ] final-info drop ] unit-test
 606
 607 [ V{ fixnum } ] [ [ [ bignum-shift drop ] keep ] final-classes ] unit-test
 608
 609 [ V{ float } ] [
 610     [
 611         [ { float float } declare complex boa ]
 612         [ 2drop C{ 0.0 0.0 } ]
 613         if real-part
 614     ] final-classes
 615 ] unit-test
 616
 617 [ V{ POSTPONE: f } ] [
 618     [ { float } declare 0 eq? ] final-classes
 619 ] unit-test
 620
 621 [ V{ integer } ] [
 622     [ { integer fixnum } declare mod ] final-classes
 623 ] unit-test
 624
 625 [ V{ integer } ] [
 626     [ { fixnum integer } declare bitand ] final-classes
 627 ] unit-test
 628
 629 [ V{ double-array } ] [ [| | double-array{ } ] final-classes ] unit-test
 630
 631 [ V{ t } ] [ [ netbsd unix? ] final-literals ] unit-test
 632
 633 [ V{ array } ] [ [ [ <=> ] sort [ <=> ] sort ] final-classes ] unit-test
 634
 635 [ V{ float } ] [ [ fsqrt ] final-classes ] unit-test
 636
 637 [ V{ t } ] [ [ { fixnum } declare 10 mod >float -20 > ] final-literals ] unit-test
 638
 639 [ T{ interval f { 0 t } { 127 t } } ] [
 640     [ { integer } declare 127 bitand ] final-info first interval>>
 641 ] unit-test
 642
 643 [ V{ t } ] [
 644     [ [ 123 bitand ] [ drop f ] if dup [ 0 >= ] [ not ] if ] final-literals
 645 ] unit-test
 646
 647 [ V{ bignum } ] [
 648     [ { bignum } declare dup 1 - bitxor ] final-classes
 649 ] unit-test
 650
 651 [ V{ bignum integer } ] [
 652     [ { bignum integer } declare [ shift ] keep ] final-classes
 653 ] unit-test
 654
 655 [ V{ fixnum } ] [ [ >fixnum 15 bitand 1 swap shift ] final-classes ] unit-test
 656
 657 [ V{ fixnum } ] [ [ 15 bitand 1 swap shift ] final-classes ] unit-test
 658
 659 [ V{ fixnum } ] [
 660     [ { fixnum } declare log2 ] final-classes
 661 ] unit-test
 662
 663 [ V{ word } ] [
 664     [ { fixnum } declare log2 0 >= ] final-classes
 665 ] unit-test
 666
 667 [ V{ POSTPONE: f } ] [
 668     [ { word object } declare equal? ] final-classes
 669 ] unit-test
 670
 671 ! [ V{ string } ] [
 672 !     [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
 673 ! ] unit-test
 674
 675 ! [ t ] [ [ dup t xor or ] final-classes first true-class? ] unit-test
 676
 677 ! [ t ] [ [ dup t xor swap or ] final-classes first true-class? ] unit-test
 678
 679 ! [ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test
 680
 681 ! [ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test
 682
 683 ! generalize-counter-interval wasn't being called in all the right places.
 684 ! bug found by littledan
 685
 686 TUPLE: littledan-1 { a read-only } ;
 687
 688 : (littledan-1-test) ( a -- ) a>> 1 + littledan-1 boa (littledan-1-test) ; inline recursive
 689
 690 : littledan-1-test ( -- ) 0 littledan-1 boa (littledan-1-test) ; inline
 691
 692 [ ] [ [ littledan-1-test ] final-classes drop ] unit-test
 693
 694 TUPLE: littledan-2 { from read-only } { to read-only } ;
 695
 696 : (littledan-2-test) ( x -- i elt )
 697     [ from>> ] [ to>> ] bi + dup littledan-2 boa (littledan-2-test) ; inline recursive
 698
 699 : littledan-2-test ( x -- i elt )
 700     [ 0 ] dip { array-capacity } declare littledan-2 boa (littledan-2-test) ; inline
 701
 702 [ ] [ [ littledan-2-test ] final-classes drop ] unit-test
 703
 704 : (littledan-3-test) ( x -- )
 705     length 1 + f <array> (littledan-3-test) ; inline recursive
 706
 707 : littledan-3-test ( -- )
 708     0 f <array> (littledan-3-test) ; inline
 709
 710 [ ] [ [ littledan-3-test ] final-classes drop ] unit-test
 711
 712 [ V{ 0 } ] [ [ { } length ] final-literals ] unit-test
 713
 714 [ V{ 1 } ] [ [ { } length 1 + f <array> length ] final-literals ] unit-test
 715
 716 ! generalize-counter is not tight enough
 717 [ V{ fixnum } ] [ [ 0 10 [ 1 + >fixnum ] times ] final-classes ] unit-test
 718
 719 [ V{ fixnum } ] [ [ 0 10 [ 1 + >fixnum ] times 0 + ] final-classes ] unit-test
 720
 721 ! Coercions need to update intervals
 722 [ V{ f } ] [ [ 1 2 ? 100 shift >fixnum 1 = ] final-literals ] unit-test
 723
 724 [ V{ t } ] [ [ >fixnum 1 + >fixnum most-positive-fixnum <= ] final-literals ] unit-test
 725
 726 [ V{ t } ] [ [ >fixnum 1 + >fixnum most-negative-fixnum >= ] final-literals ] unit-test
 727
 728 [ V{ f } ] [ [ >fixnum 1 + >fixnum most-negative-fixnum > ] final-literals ] unit-test
 729
 730 ! Mutable tuples with circularity should not cause problems
 731 TUPLE: circle me ;
 732
 733 [ ] [ circle new dup >>me 1quotation final-info drop ] unit-test
 734
 735 ! Joe found an oversight
 736 [ V{ integer } ] [ [ >integer ] final-classes ] unit-test
 737
 738 TUPLE: foo bar ;
 739
 740 [ t ] [ [ foo new ] { new } inlined? ] unit-test
 741
 742 GENERIC: whatever ( x -- y )
 743 M: number whatever drop foo ;
 744
 745 [ t ] [ [ 1 whatever new ] { new } inlined? ] unit-test
 746
 747 : that-thing ( -- class ) foo ;
 748
 749 [ f ] [ [ that-thing new ] { new } inlined? ] unit-test
 750
 751 GENERIC: whatever2 ( x -- y )
 752 M: number whatever2 drop H{ { 1 1 } { 2 2 } { 3 3 } { 4 4 } { 5 6 } } ;
 753 M: f whatever2 ;
 754
 755 [ t ] [ [ 1 whatever2 at ] { at* hashcode* } inlined? ] unit-test
 756 [ f ] [ [ whatever2 at ] { at* hashcode* } inlined? ] unit-test
 757
 758 [ t ] [ [ { 1 2 3 } member? ] { member? } inlined? ] unit-test
 759 [ f ] [ [ { 1 2 3 } swap member? ] { member? } inlined? ] unit-test
 760
 761 [ t ] [ [ { 1 2 3 } memq? ] { memq? } inlined? ] unit-test
 762 [ f ] [ [ { 1 2 3 } swap memq? ] { memq? } inlined? ] unit-test
 763
 764 [ t ] [ [ V{ } clone ] { clone (clone) } inlined? ] unit-test
 765 [ f ] [ [ { } clone ] { clone (clone) } inlined? ] unit-test
 766
 767 [ f ] [ [ instance? ] { instance? } inlined? ] unit-test
 768 [ f ] [ [ 5 instance? ] { instance? } inlined? ] unit-test
 769 [ t ] [ [ array instance? ] { instance? } inlined? ] unit-test
 770
 771 [ t ] [ [ (( a b c -- c b a )) shuffle ] { shuffle } inlined? ] unit-test
 772 [ f ] [ [ { 1 2 3 } swap shuffle ] { shuffle } inlined? ] unit-test