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