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