! Copyright (C) 2007, 2011 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.data accessors io.binary math math.bitwise
-alien.accessors kernel kernel.private sequences
-sequences.private byte-arrays parser prettyprint.custom fry
-locals ;
+USING: accessors alien alien.accessors byte-arrays fry io.binary
+kernel kernel.private locals math math.bitwise parser
+prettyprint.custom sequences sequences.private ;
IN: bit-arrays
TUPLE: bit-array
-{ length array-capacity read-only }
-{ underlying byte-array read-only } ;
+ { length array-capacity read-only }
+ { underlying byte-array read-only } ;
<PRIVATE
: bit/byte ( n -- bit byte ) [ 7 bitand ] [ n>byte ] bi ; inline
: bit-index ( n bit-array -- bit# byte# byte-array )
- [ integer>fixnum bit/byte ] [ underlying>> ] bi* ; inline
+ [ { integer-array-capacity } declare integer>fixnum bit/byte ]
+ [ underlying>> ] bi* ; inline
: bits>cells ( m -- n ) 31 + -5 shift ; inline
{ [ drop ] } [ [ array instance? drop ] optimize-quot ] unit-test
-{ [ drop ] } [ [ { integer } declare f <array> drop ] optimize-quot ] unit-test
+{
+ [ f <array> drop ]
+ [ f <array> drop ]
+ [ drop ]
+} [
+ ! Not flushed because the first argument to <array> can be
+ ! something random which would cause an exception.
+ [ f <array> drop ] optimize-quot
+
+ ! This call is not flushed because the integer can be outside
+ ! array-capacity-interval
+ [ { integer } declare f <array> drop ] optimize-quot
+
+ ! Flushed because the declaration guarantees that the integer is
+ ! within the array-capacity-interval.
+ [ { integer-array-capacity } declare f <array> drop ] optimize-quot
+] unit-test
{ [ f <array> drop ] } [ [ f <array> drop ] optimize-quot ] unit-test
-USING: accessors alien alien.accessors alien.c-types alien.data arrays assocs
-byte-arrays classes classes.algebra classes.struct classes.tuple.private
-combinators.short-circuit compiler.tree compiler.tree.builder
-compiler.tree.checker compiler.tree.debugger compiler.tree.def-use
-compiler.tree.normalization compiler.tree.optimizer compiler.tree.propagation
-compiler.tree.propagation.info compiler.tree.recursive effects fry
-generic.single hashtables kernel kernel.private layouts locals math
-math.floats.private math.functions math.integers.private math.intervals
-math.libm math.order math.private quotations sets sequences sequences.private
-slots.private sorting specialized-arrays strings strings.private system
-tools.test vectors vocabs words ;
+USING: accessors alien alien.accessors alien.c-types alien.data arrays
+assocs byte-arrays classes classes.algebra classes.struct
+classes.tuple.private combinators.short-circuit compiler.tree
+compiler.tree.builder compiler.tree.debugger compiler.tree.optimizer
+compiler.tree.propagation.info effects fry generic.single hashtables
+kernel kernel.private layouts literals locals math math.floats.private
+math.functions math.integers.private math.intervals math.libm
+math.order math.private quotations sequences sequences.private sets
+slots.private sorting specialized-arrays strings strings.private
+system tools.test vectors vocabs words ;
FROM: math => float ;
SPECIALIZED-ARRAY: double
SPECIALIZED-ARRAY: void*
IN: compiler.tree.propagation.tests
+! Arrays
+{ V{ array } } [
+ [ 10 f <array> ] final-classes
+] unit-test
+
+{ V{ array } } [
+ [ { array } declare ] final-classes
+] unit-test
+
+{ V{ array } } [
+ [ 10 f <array> swap [ ] [ ] if ] final-classes
+] unit-test
+
+{
+ T{ value-info-state
+ { class integer }
+ { interval $[ array-capacity-interval ] }
+ }
+} [
+ [ dup "foo" <array> drop ] final-info first
+] unit-test
+
+! Byte arrays
+{ V{ 3 } } [
+ [ 3 <byte-array> length ] final-literals
+] unit-test
+
+{ t } [
+ [ dup <byte-array> drop ] final-info first
+ integer-array-capacity <class-info> =
+] unit-test
+
+! Strings
+{ V{ 3 } } [
+ [ 3 f <string> length ] final-literals
+] unit-test
+
+{ V{ t } } [
+ [ { string } declare string? ] final-classes
+] unit-test
+
+{ V{ string } } [
+ [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
+] unit-test
+
+{ t } [
+ [ dupd <string> drop ] final-info first
+ integer-array-capacity <class-info> =
+] unit-test
+
{ { } } [
all-words [
"input-classes" word-prop [ class? ] all? not
{ V{ fixnum object } } [ [ 1 swap ] final-classes ] unit-test
-{ V{ array } } [ [ 10 f <array> ] final-classes ] unit-test
-
-{ V{ array } } [ [ { array } declare ] final-classes ] unit-test
-
-{ V{ array } } [ [ 10 f <array> swap [ ] [ ] if ] final-classes ] unit-test
-
{ V{ fixnum } } [ [ dup fixnum? [ ] [ drop 3 ] if ] final-classes ] unit-test
{ V{ 69 } } [ [ [ 69 ] [ 69 ] if ] final-literals ] unit-test
{ V{ 3 } } [ [ [ "yay" ] [ "hah" ] if length ] final-literals ] unit-test
-{ V{ 3 } } [ [ 3 <byte-array> length ] final-literals ] unit-test
-{ V{ 3 } } [ [ 3 f <string> length ] final-literals ] unit-test
! Slot propagation
TUPLE: prop-test-tuple { x integer } ;
[ { assoc } declare hashtable instance? ] final-classes
] unit-test
-{ V{ t } } [
- [ { string } declare string? ] final-classes
-] unit-test
-
{ V{ POSTPONE: f } } [
[ 3 string? ] final-classes
] unit-test
[ { fixnum } declare [ ] curry obj>> ] final-classes
] unit-test
-{ V{ fixnum } } [
- [ { fixnum fixnum } declare iota [ nth-unsafe ] curry call ] final-classes
-] unit-test
-
{ V{ f } } [
[ 10 eq? [ drop 3 ] unless ] final-literals
] unit-test
[ { word object } declare equal? ] final-classes
] unit-test
-{ V{ string } } [
- [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
-] unit-test
-
{ t } [ [ dup t xor or ] final-classes first true-class? ] unit-test
{ t } [ [ dup t xor swap or ] final-classes first true-class? ] unit-test