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