1 USING: accessors alien alien.accessors alien.c-types alien.data arrays
2 assocs byte-arrays classes classes.algebra classes.struct
3 classes.tuple.private combinators.short-circuit compiler.test
4 compiler.tree compiler.tree.builder compiler.tree.debugger
5 compiler.tree.optimizer compiler.tree.propagation.info effects fry
6 generic.single hashtables kernel kernel.private layouts literals
7 locals math math.floats.private math.functions math.integers.private
8 math.intervals math.libm math.order math.private quotations sequences
9 sequences.private sets slots.private sorting specialized-arrays
10 strings strings.private system tools.test vectors vocabs words ;
12 SPECIALIZED-ARRAY: double
13 SPECIALIZED-ARRAY: void*
14 IN: compiler.tree.propagation.tests
18 [ 10 f <array> ] final-classes
22 [ { array } declare ] final-classes
26 [ 10 f <array> swap [ ] [ ] if ] final-classes
32 { interval $[ array-capacity-interval ] }
35 [ dup "foo" <array> drop ] final-info first
39 [ resize-array length ] final-info first
40 array-capacity <class-info> =
44 [ 42 swap resize-array length ] final-literals first
48 [ resize-array ] { resize-array } inlined?
52 [ 3 { 1 2 3 } resize-array ] { resize-array } inlined?
56 [ 4 { 1 2 3 } resize-array ] { resize-array } inlined?
60 [ 4 swap { array } declare resize-array ] { resize-array } inlined?
65 [ 3 <byte-array> length ] final-literals
69 [ dup <byte-array> drop ] final-info first
70 integer-array-capacity <class-info> =
74 [ resize-byte-array length ] final-info first
75 array-capacity <class-info> =
79 [ 43 swap resize-byte-array length ] final-literals first
83 [ 3 B{ 1 2 3 } resize-byte-array ] { resize-byte-array } inlined?
88 [ 3 f <string> length ] final-literals
92 [ resize-string length ] final-info first
93 array-capacity <class-info> =
97 [ 44 swap resize-string length ] final-literals
101 [ 3 "123" resize-string ] { resize-string } inlined?
105 [ { string } declare string? ] final-classes
109 [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
114 integer-array-capacity <class-info>
118 [ 2dup <string> drop ] final-info
123 "input-classes" word-prop [ class? ] all? not
127 ! The value interval should be limited for these.
129 [ fixnum>bignum ] final-info first interval>> fixnum-interval =
130 [ fixnum>float ] final-info first interval>> fixnum-interval =
133 { V{ } } [ [ ] final-classes ] unit-test
135 { V{ fixnum } } [ [ 1 ] final-classes ] unit-test
137 { V{ fixnum } } [ [ 1 [ ] dip ] final-classes ] unit-test
139 { V{ fixnum object } } [ [ 1 swap ] final-classes ] unit-test
141 { V{ fixnum } } [ [ dup fixnum? [ ] [ drop 3 ] if ] final-classes ] unit-test
143 { V{ 69 } } [ [ [ 69 ] [ 69 ] if ] final-literals ] unit-test
145 { V{ integer } } [ [ bitnot ] final-classes ] unit-test
147 { V{ fixnum } } [ [ { fixnum } declare bitnot ] final-classes ] unit-test
149 ! Test type propagation for math ops
150 : cleanup-math-class ( obj -- class )
151 { null fixnum bignum integer ratio rational float real complex number }
152 [ class= ] with find nip ;
154 : final-math-class ( quot -- class )
155 final-classes first cleanup-math-class ;
157 { number } [ [ + ] final-math-class ] unit-test
159 { bignum } [ [ { fixnum bignum } declare + ] final-math-class ] unit-test
161 { integer } [ [ { fixnum integer } declare + ] final-math-class ] unit-test
163 { bignum } [ [ { integer bignum } declare + ] final-math-class ] unit-test
165 { integer } [ [ { fixnum fixnum } declare + ] final-math-class ] unit-test
167 { float } [ [ { float integer } declare + ] final-math-class ] unit-test
169 { float } [ [ { real float } declare + ] final-math-class ] unit-test
171 { float } [ [ { float real } declare + ] final-math-class ] unit-test
173 { rational } [ [ { ratio ratio } declare + ] final-math-class ] unit-test
175 { rational } [ [ { rational ratio } declare + ] final-math-class ] unit-test
177 { number } [ [ { complex complex } declare + ] final-math-class ] unit-test
179 { float } [ [ /f ] final-math-class ] unit-test
181 { float } [ [ { real real } declare /f ] final-math-class ] unit-test
183 { integer } [ [ /i ] final-math-class ] unit-test
185 { integer } [ [ { integer float } declare /i ] final-math-class ] unit-test
187 { integer } [ [ { float float } declare /i ] final-math-class ] unit-test
189 { integer } [ [ { integer } declare bitnot ] final-math-class ] unit-test
191 { null } [ [ { null null } declare + ] final-math-class ] unit-test
193 { null } [ [ { null fixnum } declare + ] final-math-class ] unit-test
195 { float } [ [ { float fixnum } declare + ] final-math-class ] unit-test
197 { bignum } [ [ { bignum bignum } declare bitxor ] final-math-class ] unit-test
199 { bignum } [ [ { integer } declare 123 >bignum bitand ] final-math-class ] unit-test
201 { float } [ [ { float float } declare mod ] final-math-class ] unit-test
203 { V{ integer float } } [ [ { float float } declare [ /i ] keep ] final-classes ] unit-test
205 { V{ fixnum } } [ [ 255 bitand ] final-classes ] unit-test
208 [ [ 255 bitand ] [ 65535 bitand ] bi + ] final-classes
213 { fixnum } declare [ 255 bitand ] [ 65535 bitand ] bi +
218 [ { fixnum } declare [ 255 bitand ] keep + ] final-classes
222 [ { fixnum } declare 615949 * ] final-classes
226 [ 255 bitand >fixnum 3 bitor ] final-classes
230 [ >fixnum 1 mod ] final-literals
234 [ >fixnum swap [ 1 mod 69 + ] [ drop 69 ] if ] final-literals
238 [ >fixnum dup 10 > [ 1 - ] when ] final-classes
241 { V{ integer } } [ [ >fixnum 2 * ] final-classes ] unit-test
244 [ >fixnum dup 10 < drop 2 * ] final-classes
248 [ >fixnum dup 10 < [ 2 * ] when ] final-classes
252 [ >fixnum dup 10 < [ 2 * ] [ 2 * ] if ] final-classes
256 [ >fixnum dup 10 < [ dup -10 > [ 2 * ] when ] when ] final-classes
260 [ dup 10 < [ dup 8 > [ drop 9 ] unless ] [ drop 9 ] if ] final-literals
266 dup 10 < [ dup 8 > [ drop 9 ] unless ] [ drop 9 ] if
270 { V{ t } } [ [ 40 mod 40 < ] final-literals ] unit-test
272 { V{ f } } [ [ 40 mod 0 >= ] final-literals ] unit-test
274 { V{ t } } [ [ 40 rem 0 >= ] final-literals ] unit-test
276 { V{ t } } [ [ abs 40 mod 0 >= ] final-literals ] unit-test
278 { t } [ [ abs ] final-info first interval>> [0,inf] = ] unit-test
280 { t } [ [ absq ] final-info first interval>> [0,inf] = ] unit-test
282 { t } [ [ { fixnum } declare abs ] final-info first interval>> [0,inf] interval-subset? ] unit-test
284 { t } [ [ { fixnum } declare absq ] final-info first interval>> [0,inf] interval-subset? ] unit-test
286 { V{ integer } } [ [ { fixnum } declare abs ] final-classes ] unit-test
288 { V{ integer } } [ [ { fixnum } declare absq ] final-classes ] unit-test
290 { t } [ [ { bignum } declare abs ] final-info first interval>> [0,inf] interval-subset? ] unit-test
292 { t } [ [ { bignum } declare absq ] final-info first interval>> [0,inf] interval-subset? ] unit-test
294 { t } [ [ { float } declare abs ] final-info first interval>> [0,inf] = ] unit-test
296 { t } [ [ { float } declare absq ] final-info first interval>> [0,inf] = ] unit-test
298 { t } [ [ { complex } declare abs ] final-info first interval>> [0,inf] = ] unit-test
300 { t } [ [ { complex } declare absq ] final-info first interval>> [0,inf] = ] unit-test
302 { t } [ [ { float float } declare rect> C{ 0.0 0.0 } + absq ] final-info first interval>> [0,inf] = ] unit-test
304 { V{ float } } [ [ { float float } declare rect> C{ 0.0 0.0 } + absq ] final-classes ] unit-test
306 { t } [ [ [ - absq ] [ + ] 2map-reduce ] final-info first interval>> [0,inf] = ] unit-test
308 { t } [ [ { double-array double-array } declare [ - absq ] [ + ] 2map-reduce ] final-info first interval>> [0,inf] = ] unit-test
311 [ dup string? not [ "Oops" throw ] [ ] if ] final-classes
315 [ dup string? not not >boolean [ ] [ "Oops" throw ] if ] final-classes
318 { f } [ [ t xor ] final-classes first null-class? ] unit-test
320 { t } [ [ t or ] final-classes first true-class? ] unit-test
322 { t } [ [ t swap or ] final-classes first true-class? ] unit-test
324 { t } [ [ f and ] final-classes first false-class? ] unit-test
326 { t } [ [ f swap and ] final-classes first false-class? ] unit-test
328 { t } [ [ dup not or ] final-classes first true-class? ] unit-test
330 { t } [ [ dup not swap or ] final-classes first true-class? ] unit-test
332 { t } [ [ dup not and ] final-classes first false-class? ] unit-test
334 { t } [ [ dup not swap and ] final-classes first false-class? ] unit-test
336 { t } [ [ over [ drop f ] when [ "A" throw ] unless ] final-classes first false-class? ] unit-test
340 [ { fixnum } declare ] [ drop f ] if
341 dup [ dup 13 eq? [ t ] [ f ] if ] [ t ] if
342 [ "Oops" throw ] when
349 dup [ 10 < ] [ -10 > ] bi and not [ 2 * ] unless
355 dup dup dup [ 100 < ] [ drop f ] if dup
356 [ 2drop f ] [ 2drop f ] if
357 [ ] [ dup [ ] [ ] if ] if
362 [ { fixnum } declare (clone) ] final-classes
366 [ vector new ] final-classes
371 { fixnum byte-array } declare
372 [ nth-unsafe ] 2keep [ nth-unsafe ] 2keep nth-unsafe
373 [ [ 298 * ] dip 100 * - ] dip 208 * - 128 + -8 shift
379 [ 0 dup 10 > [ 2 * ] when ] final-classes
383 [ [ 0.0 ] [ -0.0 ] if ] final-literals
387 [ /f 1.5 1.5 clamp ] final-literals
393 dup 1.5 <= [ dup 1.5 >= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if
400 dup 1.5 u<= [ dup 1.5 u>= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if
407 dup 1.5 <= [ dup 10 >= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if
414 dup 1.5 u<= [ dup 10 u>= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if
421 dup 0.0 <= [ dup 0.0 >= [ drop 0.0 ] unless ] [ drop 0.0 ] if
428 dup 0.0 u<= [ dup 0.0 u>= [ drop 0.0 ] unless ] [ drop 0.0 ] if
433 [ 0 dup 10 > [ 100 * ] when ] final-classes
437 [ 0 dup 10 > [ drop "foo" ] when ] final-classes
441 [ 0 dup 10 u> [ 100 * ] when ] final-classes
445 [ 0 dup 10 u> [ drop "foo" ] when ] final-classes
449 [ { fixnum } declare 3 3 - + ] final-classes
453 [ dup 10 < [ 3 * 30 < ] [ drop t ] if ] final-literals
457 [ dup 10 u< [ 3 * 30 u< ] [ drop t ] if ] final-literals
476 [ [ "hi" ] [ 123 3 throw ] if ] final-literals
480 [ >fixnum dup 100 < [ 1 + ] [ "Oops" throw ] if ] final-classes
484 [ >fixnum dup 100 u< [ 1 + ] [ "Oops" throw ] if ] final-classes
488 [ 0 dup 100 < not [ 1 + ] [ 1 - ] if ] final-literals
492 [ 0 dup 100 u< not [ 1 + ] [ 1 - ] if ] final-literals
496 [ [ 1 ] [ 1 ] if 1 + ] final-literals
500 [ 0 * 10 < ] final-classes
504 [ 0 * 10 u< ] final-classes
509 123 bitand dup 10 < over 8 > and [ 3 * ] [ "B" throw ] if
515 123 bitand dup 10 u< over 8 u> and [ 3 * ] [ "B" throw ] if
519 { V{ string string } } [
521 2dup [ dup string? [ "Oops" throw ] unless ] bi@ 2drop
526 [ { fixnum fixnum } declare 7 bitand neg shift ] final-classes
530 [ { fixnum fixnum } declare 7 bitand neg >bignum shift ] final-classes
534 [ { fixnum } declare 1 swap 7 bitand shift ] final-classes
538 [ { fixnum } declare 1 swap 7 bitand >bignum shift ] final-classes
543 [ { fixnum } declare 1 swap 31 bitand shift ]
548 ! Array length propagation
549 { V{ t } } [ [ 10 f <array> length 10 = ] final-literals ] unit-test
551 { V{ t } } [ [ [ 10 f <array> length ] [ 10 <byte-array> length ] if 10 = ] final-literals ] unit-test
553 { V{ t } } [ [ [ 1 f <array> ] [ 2 f <array> ] if length 3 < ] final-literals ] unit-test
556 [ { fixnum } declare dup 10 eq? [ "A" throw ] unless ] final-literals
559 { V{ 3 } } [ [ [ { 1 2 3 } ] [ { 4 5 6 } ] if length ] final-literals ] unit-test
561 { V{ 3 } } [ [ [ B{ 1 2 3 } ] [ B{ 4 5 6 } ] if length ] final-literals ] unit-test
563 { V{ 3 } } [ [ [ "yay" ] [ "hah" ] if length ] final-literals ] unit-test
568 TUPLE: prop-test-tuple { x integer } ;
570 { V{ integer } } [ [ { prop-test-tuple } declare x>> ] final-classes ] unit-test
572 TUPLE: fold-boa-test-tuple { x read-only } { y read-only } { z read-only } ;
574 { V{ T{ fold-boa-test-tuple f 1 2 3 } } }
575 [ [ 1 2 3 fold-boa-test-tuple boa ] final-literals ]
578 TUPLE: don't-fold-boa-test-tuple < identity-tuple ;
581 [ [ don't-fold-boa-test-tuple boa ] final-literals ]
584 TUPLE: immutable-prop-test-tuple { x sequence read-only } ;
586 { V{ T{ immutable-prop-test-tuple f "hey" } } } [
587 [ "hey" immutable-prop-test-tuple boa ] final-literals
591 [ { 1 2 } immutable-prop-test-tuple boa x>> ] final-literals
595 [ { array } declare immutable-prop-test-tuple boa x>> ] final-classes
599 [ complex boa ] final-classes
603 [ { float float } declare dup 0.0 <= [ "Oops" throw ] [ rect> ] if ] final-classes
606 { V{ float float } } [
608 { float float } declare
609 dup 0.0 <= [ "Oops" throw ] when rect>
610 [ real>> ] [ imaginary>> ] bi
616 { float float object } declare
617 [ "Oops" throw ] [ complex boa ] if
621 [ [ dup 3 slot swap 4 slot dup 3 slot swap 4 slot ] final-info ] must-not-fail
623 { V{ number } } [ [ [ "Oops" throw ] [ 2 + ] if ] final-classes ] unit-test
624 { V{ number } } [ [ [ 2 + ] [ "Oops" throw ] if ] final-classes ] unit-test
626 { V{ POSTPONE: f } } [
627 [ dup 1.0 <= [ drop f ] [ 0 number= ] if ] final-classes
631 TUPLE: mutable-tuple-test { x sequence } ;
634 [ "hey" mutable-tuple-test boa x>> ] final-classes
638 [ T{ mutable-tuple-test f "hey" } x>> ] final-classes
642 [ T{ mutable-tuple-test f "hey" } layout-of ] final-classes
645 ! Mixed mutable and immutable slots
646 TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
648 { V{ integer array } } [
650 3 { 2 1 } mixed-mutable-immutable boa [ x>> ] [ y>> ] bi
654 { V{ array integer } } [
656 3 { 2 1 } mixed-mutable-immutable boa [ y>> ] [ x>> ] bi
660 { V{ integer array } } [
662 [ 2drop T{ mixed-mutable-immutable f 3 { } } ]
663 [ { array } declare mixed-mutable-immutable boa ] if
670 T{ mixed-mutable-immutable f 3 { } }
675 ! Recursive propagation
676 : recursive-test-1 ( a -- b ) recursive-test-1 ; inline recursive
678 { V{ null } } [ [ recursive-test-1 ] final-classes ] unit-test
680 : recursive-test-2 ( a -- b ) dup 10 < [ recursive-test-2 ] when ; inline recursive
682 { V{ real } } [ [ recursive-test-2 ] final-classes ] unit-test
684 : recursive-test-3 ( a -- b ) dup 10 < drop ; inline recursive
686 { V{ real } } [ [ recursive-test-3 ] final-classes ] unit-test
688 { V{ real } } [ [ [ dup 10 < ] [ ] while ] final-classes ] unit-test
691 [ { float } declare 10 [ 2.3 * ] times ] final-classes
695 [ 0 10 [ nip ] each-integer ] final-classes
699 [ t 10 [ nip 0 >= ] each-integer ] final-literals
702 : recursive-test-4 ( i n -- )
703 2dup < [ [ 1 + ] dip recursive-test-4 ] [ 2drop ] if ; inline recursive
705 [ [ recursive-test-4 ] final-info ] must-not-fail
707 : recursive-test-5 ( a -- b )
708 dup 1 <= [ drop 1 ] [ dup 1 - recursive-test-5 * ] if ; inline recursive
710 { V{ integer } } [ [ { integer } declare recursive-test-5 ] final-classes ] unit-test
712 : recursive-test-6 ( a -- b )
713 dup 1 <= [ drop 1 ] [ dup 1 - recursive-test-6 swap 2 - recursive-test-6 + ] if ; inline recursive
715 { V{ integer } } [ [ { fixnum } declare recursive-test-6 ] final-classes ] unit-test
717 : recursive-test-7 ( a -- b )
718 dup 10 < [ 1 + recursive-test-7 ] when ; inline recursive
720 { V{ fixnum } } [ [ 0 recursive-test-7 ] final-classes ] unit-test
722 { V{ fixnum } } [ [ 1 10 [ dup 10 < [ 2 * ] when ] times ] final-classes ] unit-test
724 { V{ integer } } [ [ 0 2 100 ^ [ nip ] each-integer ] final-classes ] unit-test
726 [ [ [ ] [ ] compose curry call ] final-info ] must-not-fail
729 [ [ drop ] [ drop ] compose curry each-integer-from ] final-classes
732 GENERIC: iterate ( obj -- next-obj ? )
733 M: fixnum iterate f ; inline
734 M: array iterate first t ; inline
736 : dead-loop ( obj -- final-obj )
737 iterate [ dead-loop ] when ; inline recursive
739 { V{ fixnum } } [ [ { fixnum } declare dead-loop ] final-classes ] unit-test
742 dup 0 number= [ hang-1 ] unless ; inline recursive
744 [ [ 3 hang-1 ] final-info ] must-not-fail
746 : hang-2 ( m n -- x )
755 ] if ; inline recursive
757 [ [ 3 over hang-2 ] final-info ] must-not-fail
761 dup fixnum? [ 3 over hang-2 ] [ 3 over hang-2 ] if
766 [ { hashtable } declare hashtable instance? ] final-classes
769 { V{ POSTPONE: f } } [
770 [ { vector } declare hashtable instance? ] final-classes
774 [ { assoc } declare hashtable instance? ] final-classes
777 { V{ POSTPONE: f } } [
778 [ 3 string? ] final-classes
782 [ { fixnum } declare [ ] curry obj>> ] final-classes
786 [ 10 eq? [ drop 3 ] unless ] final-literals
789 GENERIC: bad-generic ( a -- b )
790 M: fixnum bad-generic 1 fixnum+fast ; inline
791 : bad-behavior ( -- b ) 4 bad-generic ; inline recursive
793 { V{ fixnum } } [ [ bad-behavior ] final-classes ] unit-test
797 0 10 [ bad-generic dup 123 bitand drop bad-generic 1 + ] times
801 GENERIC: infinite-loop ( a -- b )
802 M: integer infinite-loop infinite-loop ;
804 [ [ { integer } declare infinite-loop ] final-classes ] must-not-fail
806 { V{ tuple } } [ [ tuple-layout <tuple> ] final-classes ] unit-test
808 [ [ instance? ] final-classes ] must-not-fail
810 { f } [ [ V{ } clone ] final-info first literal?>> ] unit-test
812 : fold-throw-test ( a -- b ) "A" throw ; foldable
814 [ [ 0 fold-throw-test ] final-info ] must-not-fail
816 : too-deep ( a b -- c )
817 dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline recursive
819 [ [ too-deep ] final-info ] must-not-fail
821 [ [ reversed boa slice boa nth-unsafe * ] final-info ] must-not-fail
825 [ [ { empty-mixin } declare empty-mixin? ] final-info ] must-not-fail
827 { V{ fixnum } } [ [ [ bignum-shift drop ] keep ] final-classes ] unit-test
831 [ { float float } declare complex boa ]
832 [ 2drop C{ 0.0 0.0 } ]
837 { V{ POSTPONE: f } } [
838 [ { float } declare 0 eq? ] final-classes
842 { fixnum integer integer fixnum }
846 ! These two are tricky. Possibly, they will always be
847 ! fixnums. But that requires a better interval-mod.
851 } [ '[ _ declare mod ] final-classes first ] map
854 ! Due to downpromotion, we lose the type here.
856 [ { bignum bignum } declare bignum-mod ] final-classes
860 { V{ bignum integer } } [
861 [ { bignum bignum } declare /mod ] final-classes
864 ! So this code gets worse than it was.
867 bignum-mod 20 over tag 0 eq?
868 [ fixnum+ ] [ fixnum>bignum bignum+ ] if
871 [ { bignum bignum } declare bignum-mod 20 + ]
872 build-tree optimize-tree nodes>quot
876 [ fixnum-mod ] final-classes
880 [ { fixnum integer } declare bitand ] final-classes
883 { V{ double-array } } [ [| | double-array{ } ] final-classes ] unit-test
885 { V{ t } } [ [ macosx unix? ] final-literals ] unit-test
887 { V{ array } } [ [ [ <=> ] sort [ <=> ] sort ] final-classes ] unit-test
889 { V{ float } } [ [ fsqrt ] final-classes ] unit-test
891 { V{ t } } [ [ { fixnum } declare 10 mod >float -20 > ] final-literals ] unit-test
893 { T{ interval f { 0 t } { 127 t } } } [
894 [ { integer } declare 127 bitand ] final-info first interval>>
898 [ [ 123 bitand ] [ drop f ] if dup [ 0 >= ] [ not ] if ] final-literals
902 [ { bignum } declare dup 1 - bitxor ] final-classes
905 { V{ bignum integer } } [
906 [ { bignum integer } declare [ shift ] keep ] final-classes
909 { V{ fixnum } } [ [ >fixnum 15 bitand 1 swap shift ] final-classes ] unit-test
911 { V{ fixnum } } [ [ 15 bitand 1 swap shift ] final-classes ] unit-test
914 [ { fixnum } declare log2 ] final-classes
918 [ { fixnum } declare log2 0 >= ] final-classes
921 { V{ POSTPONE: f } } [
922 [ { word object } declare equal? ] final-classes
925 { t } [ [ dup t xor or ] final-classes first true-class? ] unit-test
927 { t } [ [ dup t xor swap or ] final-classes first true-class? ] unit-test
929 { t } [ [ dup t xor and ] final-classes first false-class? ] unit-test
931 { t } [ [ dup t xor swap and ] final-classes first false-class? ] unit-test
933 ! generalize-counter-interval wasn't being called in all the right places.
934 ! bug found by littledan
936 TUPLE: littledan-1 { a read-only } ;
938 : (littledan-1-test) ( a -- ) a>> 1 + littledan-1 boa (littledan-1-test) ; inline recursive
940 : littledan-1-test ( -- ) 0 littledan-1 boa (littledan-1-test) ; inline
942 [ [ littledan-1-test ] final-classes ] must-not-fail
944 TUPLE: littledan-2 { from read-only } { to read-only } ;
946 : (littledan-2-test) ( x -- i elt )
947 [ from>> ] [ to>> ] bi + dup littledan-2 boa (littledan-2-test) ; inline recursive
949 : littledan-2-test ( x -- i elt )
950 [ 0 ] dip { array-capacity } declare littledan-2 boa (littledan-2-test) ; inline
952 [ [ littledan-2-test ] final-classes ] must-not-fail
954 : (littledan-3-test) ( x -- )
955 length 1 + f <array> (littledan-3-test) ; inline recursive
957 : littledan-3-test ( -- )
958 0 f <array> (littledan-3-test) ; inline
960 [ [ littledan-3-test ] final-classes ] must-not-fail
962 { V{ 0 } } [ [ { } length ] final-literals ] unit-test
964 { V{ 1 } } [ [ { } length 1 + f <array> length ] final-literals ] unit-test
966 ! generalize-counter is not tight enough
967 { V{ fixnum } } [ [ 0 10 [ 1 + >fixnum ] times ] final-classes ] unit-test
969 { V{ fixnum } } [ [ 0 10 [ 1 + >fixnum ] times 0 + ] final-classes ] unit-test
971 ! Coercions need to update intervals
972 { V{ f } } [ [ 1 2 ? 100 shift >fixnum 1 = ] final-literals ] unit-test
974 { V{ t } } [ [ >fixnum 1 + >fixnum most-positive-fixnum <= ] final-literals ] unit-test
976 { V{ t } } [ [ >fixnum 1 + >fixnum most-negative-fixnum >= ] final-literals ] unit-test
978 { V{ f } } [ [ >fixnum 1 + >fixnum most-negative-fixnum > ] final-literals ] unit-test
980 ! Mutable tuples with circularity should not cause problems
983 [ circle new dup >>me 1quotation final-info ] must-not-fail
985 ! Joe found an oversight
986 { V{ integer } } [ [ >integer ] final-classes ] unit-test
990 { t } [ [ foo new ] { new } inlined? ] unit-test
992 GENERIC: whatever ( x -- y )
993 M: number whatever drop foo ; inline
995 { t } [ [ 1 whatever new ] { new } inlined? ] unit-test
997 : that-thing ( -- class ) foo ;
999 { f } [ [ that-thing new ] { new } inlined? ] unit-test
1001 GENERIC: whatever2 ( x -- y )
1002 M: number whatever2 drop H{ { 1 1 } { 2 2 } { 3 3 } { 4 4 } { 5 6 } } ; inline
1003 M: f whatever2 ; inline
1005 { t } [ [ 1 whatever2 at ] { at* hashcode* } inlined? ] unit-test
1006 { f } [ [ whatever2 at ] { at* hashcode* } inlined? ] unit-test
1008 SYMBOL: not-an-assoc
1010 { f } [ [ not-an-assoc at ] { at* } inlined? ] unit-test
1012 { t } [ [ { 1 2 3 } member? ] { member? } inlined? ] unit-test
1013 { f } [ [ { 1 2 3 } swap member? ] { member? } inlined? ] unit-test
1015 { t } [ [ { 1 2 3 } member-eq? ] { member-eq? } inlined? ] unit-test
1016 { f } [ [ { 1 2 3 } swap member-eq? ] { member-eq? } inlined? ] unit-test
1018 { t } [ [ V{ } clone ] { clone (clone) } inlined? ] unit-test
1019 { f } [ [ { } clone ] { clone (clone) } inlined? ] unit-test
1021 { f } [ [ instance? ] { instance? } inlined? ] unit-test
1022 { f } [ [ 5 instance? ] { instance? } inlined? ] unit-test
1023 { t } [ [ array instance? ] { instance? } inlined? ] unit-test
1025 { t } [ [ ( a b c -- c b a ) shuffle ] { shuffle } inlined? ] unit-test
1026 { f } [ [ { 1 2 3 } swap shuffle ] { shuffle } inlined? ] unit-test
1028 ! Type function for 'clone' had a subtle issue
1029 TUPLE: tuple-with-read-only-slot { x read-only } ;
1031 M: tuple-with-read-only-slot clone
1032 x>> clone tuple-with-read-only-slot boa ; inline
1035 [ { 1 2 3 } dup tuple-with-read-only-slot boa clone x>> eq? ] final-classes
1038 ! alien-cell outputs a alien or f
1040 [ { byte-array fixnum } declare alien-cell dup [ "OOPS" throw ] unless ] final-classes
1044 ! Don't crash if bad literal inputs are passed to unsafe words
1045 { f } [ [ { } 1 fixnum+fast ] final-info first literal?>> ] unit-test
1047 ! Converting /i to shift
1048 { t } [ [ >fixnum dup 0 >= [ 16 /i ] when ] { /i fixnum/i fixnum/i-fast } inlined? ] unit-test
1049 { f } [ [ >fixnum dup 0 >= [ 16 /i ] when ] { fixnum-shift-fast } inlined? ] unit-test
1050 { f } [ [ >float dup 0 >= [ 16 /i ] when ] { /i float/f } inlined? ] unit-test
1052 ! We want this to inline
1053 { t } [ [ void* <c-direct-array> ] { <c-direct-array> } inlined? ] unit-test
1054 { V{ void*-array } } [ [ void* <c-direct-array> ] final-classes ] unit-test
1057 { t } [ [ alien-unsigned-1 255 bitand ] { bitand fixnum-bitand } inlined? ] unit-test
1058 { t } [ [ alien-unsigned-1 255 swap bitand ] { bitand fixnum-bitand } inlined? ] unit-test
1060 { t } [ [ { fixnum } declare 256 rem -256 bitand ] { fixnum-bitand } inlined? ] unit-test
1061 { t } [ [ { fixnum } declare 250 rem -256 bitand ] { fixnum-bitand } inlined? ] unit-test
1062 { f } [ [ { fixnum } declare 257 rem -256 bitand ] { fixnum-bitand } inlined? ] unit-test
1064 { V{ fixnum } } [ [ >bignum 10 mod 2^ ] final-classes ] unit-test
1065 { V{ bignum } } [ [ >bignum 10 bitand ] final-classes ] unit-test
1066 { V{ bignum } } [ [ >bignum 10 >bignum bitand ] final-classes ] unit-test
1067 { V{ fixnum } } [ [ >bignum 10 mod ] final-classes ] unit-test
1068 { V{ bignum } } [ [ { fixnum } declare -1 >bignum bitand ] final-classes ] unit-test
1069 { V{ bignum } } [ [ { fixnum } declare -1 >bignum swap bitand ] final-classes ] unit-test
1071 ! Could be bignum not integer but who cares
1072 { V{ integer } } [ [ 10 >bignum bitand ] final-classes ] unit-test
1073 { V{ bignum } } [ [ { fixnum } declare 10 >bignum bitand ] final-classes ] unit-test
1074 { V{ bignum } } [ [ { integer } declare 10 >bignum bitand ] final-classes ] unit-test
1076 { t } [ [ { fixnum fixnum } declare min ] { min } inlined? ] unit-test
1077 { f } [ [ { fixnum fixnum } declare min ] { fixnum-min } inlined? ] unit-test
1079 { t } [ [ { float float } declare min ] { min } inlined? ] unit-test
1080 { f } [ [ { float float } declare min ] { float-min } inlined? ] unit-test
1082 { t } [ [ { fixnum fixnum } declare max ] { max } inlined? ] unit-test
1083 { f } [ [ { fixnum fixnum } declare max ] { fixnum-max } inlined? ] unit-test
1085 { t } [ [ { float float } declare max ] { max } inlined? ] unit-test
1086 { f } [ [ { float float } declare max ] { float-max } inlined? ] unit-test
1088 ! Propagation should not call equal?, hashcode, etc on literals in user code
1089 { V{ } } [ [ 4 <reversed> [ 2drop ] with each ] final-info ] unit-test
1092 { 1 } [ [ 4 <reversed> [ nth-unsafe ] [ ] unless ] final-info length ] unit-test
1094 ! Optimization on bit?
1095 { t } [ [ 3 bit? ] { bit? } inlined? ] unit-test
1096 { f } [ [ 500 bit? ] { bit? } inlined? ] unit-test
1098 { t } [ [ { 1 } intersect ] { intersect } inlined? ] unit-test
1099 { f } [ [ { 1 } swap intersect ] { intersect } inlined? ] unit-test ! We could do this
1101 { t } [ [ { 1 } intersects? ] { intersects? } inlined? ] unit-test
1102 { f } [ [ { 1 } swap intersects? ] { intersects? } inlined? ] unit-test ! We could do this
1104 { t } [ [ { 1 } diff ] { diff } inlined? ] unit-test
1105 { f } [ [ { 1 } swap diff ] { diff } inlined? ] unit-test ! We could do this
1107 ! Output range for string-nth now that string-nth is a library word and
1110 [ string-nth ] final-info first interval>> 0 23 2^ 1 - [a,b] =
1113 ! Non-zero displacement for <displaced-alien> restricts the output type
1115 [ { byte-array } declare <displaced-alien> ] final-classes
1116 first byte-array alien class-or class=
1120 [ { alien } declare <displaced-alien> ] final-classes
1124 [ { POSTPONE: f } declare <displaced-alien> ] final-classes
1125 first \ f alien class-or class=
1129 [ { byte-array } declare [ 10 bitand 2 + ] dip <displaced-alien> ] final-classes
1132 ! 'tag' should have a declared output interval
1134 [ tag 0 15 between? ] final-literals
1138 [ maybe{ integer } instance? ] { instance? } inlined?
1141 TUPLE: inline-please a ;
1143 [ maybe{ inline-please } instance? ] { instance? } inlined?
1146 GENERIC: derp ( obj -- obj' )
1148 M: integer derp 5 + ;
1153 [ dup maybe{ integer } instance? [ derp ] when ] { instance? } inlined?
1156 ! Type-check ratios with bitand operators
1158 : bitand-ratio0 ( x -- y )
1161 : bitand-ratio1 ( x -- y )
1162 1 swap bitand zero? ;
1164 [ 2+1/2 bitand-ratio0 ] [ no-method? ] must-fail-with
1165 [ 2+1/2 bitand-ratio1 ] [ no-method? ] must-fail-with
1167 : shift-test0 ( x -- y )
1170 [ 1 shift-test0 ] [ no-method? ] must-fail-with
1172 ! Test for the #1370 bug
1173 STRUCT: bar { s bar* } ;
1176 [ bar <struct> [ s>> ] follow ] build-tree optimize-tree
1177 [ #recursive? ] find nip
1178 child>> [ { [ #call? ] [ word>> \ alien-cell = ] } 1&& ] find nip