Fold class predicates applied to literals

diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor
index d73e8b7db1d05c0bf57394d8fc3fdcbd0ccd856d..19ee051ac6706fff1340e2a196a78d5c90320d40 100644 (file)
--- a/basis/compiler/tree/propagation/propagation-tests.factor
+++ b/basis/compiler/tree/propagation/propagation-tests.factor
@@ -8,7 +8,7 @@ math.functions math.private strings layouts
 compiler.tree.propagation.info compiler.tree.def-use
 compiler.tree.debugger compiler.tree.checker
 slots.private words hashtables classes assocs locals
-float-arrays ;
+float-arrays system ;
 IN: compiler.tree.propagation.tests
 
 \ propagate must-infer
@@ -590,6 +590,8 @@ MIXIN: empty-mixin
 
 [ V{ float-array } ] [ [| | F{ } ] final-classes ] unit-test
 
+[ V{ t } ] [ [ netbsd unix? ] final-literals ] unit-test
+
 ! [ V{ string } ] [
 !     [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
 ! ] unit-test

diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor
index 7fc38239f1cfb56f2e247b4116c00602d3a9485d..d586ff398ff6399e6a5afcf09a639dac1b5729d9 100644 (file)
--- a/basis/compiler/tree/propagation/simple/simple.factor
+++ b/basis/compiler/tree/propagation/simple/simple.factor
@@ -76,13 +76,25 @@ M: #declare propagate-before
 : fold-call ( #call word -- )
     [ (fold-call) ] [ drop out-d>> ] 2bi set-value-infos ;
 
-: predicate-output-infos ( info class -- info )
+: predicate-output-infos/literal ( info class -- info )
+    [ literal>> ] dip
+    '[ _ _ instance? <literal-info> ]
+    [ drop object-info ]
+    recover ;
+
+: predicate-output-infos/class ( info class -- info )
     [ class>> ] dip {
         { [ 2dup class<= ] [ t <literal-info> ] }
         { [ 2dup classes-intersect? not ] [ f <literal-info> ] }
         [ object-info ]
     } cond 2nip ;
 
+: predicate-output-infos ( info class -- info )
+    over literal?>>
+    [ predicate-output-infos/literal ]
+    [ predicate-output-infos/class ]
+    if ;
+
 : propagate-predicate ( #call word -- infos )
     #! We need to force the caller word to recompile when the class
     #! is redefined, since now we're making assumptions but the