compiler.tree.propagation: type check inputs to unsafe foldable words manually, so...

diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor
index 879ab82c4b18cb9d9a85aa0247deea704a8b9fe8..209efb3913ad86120a825c02e8ad373d6c6f4ed3 100644 (file)
--- a/basis/compiler/tree/propagation/propagation-tests.factor
+++ b/basis/compiler/tree/propagation/propagation-tests.factor
@@ -799,3 +799,6 @@ SYMBOL: not-an-assoc
 
 [ t ] [ [ (( a b c -- c b a )) shuffle ] { shuffle } inlined? ] unit-test
 [ f ] [ [ { 1 2 3 } swap shuffle ] { shuffle } inlined? ] unit-test
+
+! Don't crash if bad literal inputs are passed to unsafe words
+[ f ] [ [ { } 1 fixnum+fast ] final-info first literal?>> ] unit-test

diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor
index 88c9831a24307a0169cfd2990035a15533d9f47d..5de5e26a304e4f8d8025157cf06364f5b21259ca 100644 (file)
--- a/basis/compiler/tree/propagation/simple/simple.factor
+++ b/basis/compiler/tree/propagation/simple/simple.factor
@@ -1,10 +1,10 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: fry accessors kernel sequences sequences.private assocs words
-namespaces classes.algebra combinators classes classes.tuple
-classes.tuple.private continuations arrays alien.c-types
-math math.private slots generic definitions
-stack-checker.state
+USING: fry accessors kernel sequences sequences.private assocs
+words namespaces classes.algebra combinators
+combinators.short-circuit classes classes.tuple
+classes.tuple.private continuations arrays alien.c-types math
+math.private slots generic definitions stack-checker.state
 compiler.tree
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes
@@ -63,9 +63,19 @@ M: #declare propagate-before
     [ in-d>> [ value-info ] map ] [ "outputs" word-prop ] bi*
     with-datastack ;
 
+: literal-inputs? ( #call -- ? )
+    in-d>> [ value-info literal?>> ] all? ;
+
+: input-classes-match? ( #call word -- ? )
+    [ in-d>> ] [ "input-classes" word-prop ] bi*
+    [ [ value-info literal>> ] dip instance? ] 2all? ;
+
 : foldable-call? ( #call word -- ? )
-    "foldable" word-prop
-    [ in-d>> [ value-info literal?>> ] all? ] [ drop f ] if ;
+    {
+        [ nip "foldable" word-prop ]
+        [ drop literal-inputs? ]
+        [ input-classes-match? ]
+    } 2&& ;
 
 : (fold-call) ( #call word -- info )
     [ [ out-d>> ] [ in-d>> [ value-info literal>> ] map ] bi ] [ '[ _ execute ] ] bi*