diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index 50762c2b66..816368466f 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs classes classes.algebra classes.tuple classes.tuple.private kernel accessors math math.intervals -namespaces sequences words combinators +namespaces sequences words combinators byte-arrays strings arrays compiler.tree.propagation.copy ; IN: compiler.tree.propagation.info @@ -66,12 +66,17 @@ DEFER: [ read-only>> [ ] [ drop f ] if ] 2map f prefix ; +UNION: fixed-length array byte-array string ; + : init-literal-info ( info -- info ) + [-inf,inf] >>interval dup literal>> class >>class - dup literal>> dup real? [ [a,a] >>interval ] [ - [ [-inf,inf] >>interval ] dip - dup tuple? [ tuple-slot-infos >>slots ] [ drop ] if - ] if ; inline + dup literal>> { + { [ dup real? ] [ [a,a] >>interval ] } + { [ dup tuple? ] [ tuple-slot-infos >>slots ] } + { [ dup fixed-length? ] [ length >>length ] } + [ drop ] + } cond ; inline : init-value-info ( info -- info ) dup literal?>> [ diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 9cb0e41291..32c9f4ed0b 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -331,6 +331,16 @@ cell-bits 32 = [ [ { fixnum } declare dup 10 eq? [ "A" throw ] unless ] final-literals ] unit-test +[ V{ 3 } ] [ [ [ { 1 2 3 } ] [ { 4 5 6 } ] if length ] final-literals ] unit-test + +[ V{ 3 } ] [ [ [ B{ 1 2 3 } ] [ B{ 4 5 6 } ] if length ] final-literals ] unit-test + +[ V{ 3 } ] [ [ [ "yay" ] [ "hah" ] if length ] final-literals ] unit-test + +[ V{ 3 } ] [ [ 3 length ] final-literals ] unit-test + +[ V{ 3 } ] [ [ 3 f length ] final-literals ] unit-test + ! Slot propagation TUPLE: prop-test-tuple { x integer } ;