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

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