Propagate slot types of literals

diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor
index 2281c140a4179babda5a3738588326b835aea8e0..d0f418f3c9834c16f963268c80ca68e618a7e674 100644 (file)
--- a/basis/compiler/tree/propagation/info/info.factor
+++ b/basis/compiler/tree/propagation/info/info.factor
@@ -59,10 +59,38 @@ slots ;
 
 : <value-info> ( -- info ) \ value-info new ;
 
+: read-only-slots ( values class -- slots )
+    #! Delegation.
+    all-slots rest-slice
+    [ read-only>> [ drop f ] unless ] 2map
+    { f f } prepend ;
+
+DEFER: <literal-info>
+
+: init-literal-info ( info -- info )
+    #! Delegation.
+    dup literal>> class >>class
+    dup literal>> dup real? [ [a,a] >>interval ] [
+        [ [-inf,inf] >>interval ] dip
+        {
+            { [ dup complex? ] [
+                [ real-part <literal-info> ]
+                [ imaginary-part <literal-info> ] bi
+                2array >>slots
+            ] }
+            { [ dup tuple? ] [
+                [
+                    tuple-slots rest-slice
+                    [ <literal-info> ] map
+                ] [ class ] bi read-only-slots >>slots
+            ] }
+            [ drop ]
+        } cond
+    ] if ; inline
+
 : init-value-info ( info -- info )
     dup literal?>> [
-        dup literal>> class >>class
-        dup literal>> dup real? [ [a,a] ] [ drop [-inf,inf] ] if >>interval
+        init-literal-info
     ] [
         dup [ class>> null-class? ] [ interval>> empty-interval eq? ] bi or [
             null >>class
@@ -73,7 +101,7 @@ slots ;
             dup [ class>> ] [ interval>> ] bi interval>literal
             [ >>literal ] [ >>literal? ] bi*
         ] if
-    ] if ;
+    ] if ; inline
 
 : <class/interval-info> ( class interval -- info )
     <value-info>

diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor
index 503c6330777d9673613d8d6cbc9ab5ed811dcfe1..559a9bf60b6f652147d970ef8a3e63df5f19af20 100644 (file)
--- a/basis/compiler/tree/propagation/propagation-tests.factor
+++ b/basis/compiler/tree/propagation/propagation-tests.factor
@@ -411,6 +411,14 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
     ] final-classes
 ] unit-test
 
+[ V{ integer array } ] [
+    [
+        [ 2drop T{ mixed-mutable-immutable f 3 { } } ]
+        [ { array } declare mixed-mutable-immutable boa ] if
+        [ x>> ] [ y>> ] bi
+    ] final-classes
+] unit-test
+
 ! Recursive propagation
 : recursive-test-1 ( a -- b ) recursive-test-1 ; inline recursive
 
@@ -573,6 +581,14 @@ MIXIN: empty-mixin
 
 [ V{ fixnum } ] [ [ [ bignum-shift drop ] keep ] final-classes ] unit-test
 
+[ V{ float } ] [
+    [
+        [ { float float } declare <complex> ]
+        [ 2drop C{ 0.0 0.0 } ]
+        if real-part
+    ] final-classes
+] unit-test
+
 ! [ V{ string } ] [
 !     [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
 ! ] unit-test

diff --git a/basis/compiler/tree/propagation/slots/slots.factor b/basis/compiler/tree/propagation/slots/slots.factor
index 5e3480be2fd183654d23d7a311c1674ec64d8826..a4bd48ecc00da049652c666e8b1195192c7ec269 100644 (file)
--- a/basis/compiler/tree/propagation/slots/slots.factor
+++ b/basis/compiler/tree/propagation/slots/slots.factor
@@ -31,12 +31,6 @@ UNION: fixed-length-sequence array byte-array string ;
 : tuple-constructor? ( word -- ? )
     { <tuple-boa> <complex> } memq? ;
 
-: read-only-slots ( values class -- slots )
-    #! Delegation.
-    all-slots rest-slice
-    [ read-only>> [ drop f ] unless ] 2map
-    { f f } prepend ;
-
 : fold-<tuple-boa> ( values class -- info )
     [ , f , [ literal>> ] map % ] { } make >tuple
     <literal-info> ;