Merge branch 'master' of git://factorcode.org/git/factor into constraints

diff --git a/basis/compiler/tree/propagation/branches/branches.factor b/basis/compiler/tree/propagation/branches/branches.factor
index f2613022fc21be595dda41ae6bc06a48c2f5d3ed..5756f78bfddc5302f9fd8a03f9805fa796adffdd 100755 (executable)
--- a/basis/compiler/tree/propagation/branches/branches.factor
+++ b/basis/compiler/tree/propagation/branches/branches.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry kernel sequences assocs accessors namespaces
 math.intervals arrays classes.algebra combinators columns
-stack-checker.branches
+stack-checker.branches locals
 compiler.utilities
 compiler.tree
 compiler.tree.combinators
@@ -82,6 +82,13 @@ M: #phi propagate-before ( #phi -- )
     [ [ phi-info-d>> flip ] [ out-d>> ] bi merge-value-infos ]
     bi ;
 
+:: update-constraints ( new old -- )
+    new [| key value | key old [ value append ] change-at ] assoc-each ;
+
+: include-child-constraints ( i -- )
+    infer-children-data get nth constraints swap at last
+    constraints get last update-constraints ;
+
 : branch-phi-constraints ( output values booleans -- )
      {
         {
@@ -116,22 +123,24 @@ M: #phi propagate-before ( #phi -- )
                 swap t-->
             ]
         }
-        ! {
-        !     { { t f } { } }
-        !     [ B
-        !         first
-        !         [ [ =t ] bi@ <--> ]
-        !         [ [ =f ] bi@ <--> ] 2bi /\
-        !     ]
-        ! }
-        ! {
-        !     { { } { t f } }
-        !     [
-        !         second
-        !         [ [ =t ] bi@ <--> ]
-        !         [ [ =f ] bi@ <--> ] 2bi /\
-        !     ]
-        ! }
+        {
+            { { t f } { } }
+            [
+                first
+                [ [ =t ] bi@ <--> ]
+                [ [ =f ] bi@ <--> ] 2bi /\
+                0 include-child-constraints
+            ]
+        }
+        {
+            { { } { t f } }
+            [
+                second
+                [ [ =t ] bi@ <--> ]
+                [ [ =f ] bi@ <--> ] 2bi /\
+                1 include-child-constraints
+            ]
+        }
         [ 3drop f ]
     } case assume ;
 
@@ -147,6 +156,7 @@ M: #phi propagate-after ( #phi -- )
     ] [ drop ] if ;
 
 M: #phi propagate-around ( #phi -- )
+    ! Is this necessary?
     [ propagate-before ] [ propagate-after ] bi ;
 
 M: #branch propagate-around

diff --git a/basis/compiler/tree/propagation/constraints/constraints.factor b/basis/compiler/tree/propagation/constraints/constraints.factor
index 31f6cea14864d9099585aa5b635fcd6f1de3c201..59c9912e47539f3a519a200f207b97d7c3b19f7a 100644 (file)
--- a/basis/compiler/tree/propagation/constraints/constraints.factor
+++ b/basis/compiler/tree/propagation/constraints/constraints.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs math math.intervals kernel accessors
 sequences namespaces classes classes.algebra
-combinators words
+combinators words combinators.short-circuit
 compiler.tree
 compiler.tree.propagation.info
 compiler.tree.propagation.copy ;
@@ -28,15 +28,19 @@ M: object satisfied? drop f ;
 ! Boolean constraints
 TUPLE: true-constraint value ;
 
-: =t ( value -- constriant ) resolve-copy true-constraint boa ;
+: =t ( value -- constraint ) resolve-copy true-constraint boa ;
+
+: follow-implications ( constraint -- )
+    constraints get assoc-stack [ assume ] when* ;
 
 M: true-constraint assume*
     [ \ f class-not <class-info> swap value>> refine-value-info ]
-    [ constraints get assoc-stack [ assume ] when* ]
+    [ follow-implications ]
     bi ;
 
 M: true-constraint satisfied?
-    value>> value-info class>> true-class? ;
+    value>> value-info class>>
+    { [ true-class? ] [ null-class? not ] } 1&& ;
 
 TUPLE: false-constraint value ;
 
@@ -44,11 +48,12 @@ TUPLE: false-constraint value ;
 
 M: false-constraint assume*
     [ \ f <class-info> swap value>> refine-value-info ]
-    [ constraints get assoc-stack [ assume ] when* ]
+    [ follow-implications ]
     bi ;
 
 M: false-constraint satisfied?
-    value>> value-info class>> false-class? ;
+    value>> value-info class>>
+    { [ false-class? ] [ null-class? not ] } 1&& ;
 
 ! Class constraints
 TUPLE: class-constraint value class ;
@@ -82,7 +87,7 @@ TUPLE: implication p q ;
 
 C: --> implication
 
-: assume-implication ( p q -- )
+: assume-implication ( q p -- )
     [ constraints get [ assoc-stack swap suffix ] 2keep last set-at ]
     [ satisfied? [ assume ] [ drop ] if ] 2bi ;
 

diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor
index 0a04b48160c12af21a908a36b7471c72431ec761..53b2109bbb336834d3123dd7d0570ac94fc6c9bb 100644 (file)
--- a/basis/compiler/tree/propagation/info/info.factor
+++ b/basis/compiler/tree/propagation/info/info.factor
@@ -302,7 +302,7 @@ SYMBOL: value-infos
 
 : refine-value-info ( info value -- )
     resolve-copy value-infos get
-    [ assoc-stack value-info-intersect ] 2keep
+    [ assoc-stack [ value-info-intersect ] when* ] 2keep
     last set-at ;
 
 : value-literal ( value -- obj ? )

diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor
index 0da234791b8d707a6c769b28a435f086829d225f..b436b21329f84fc4e02accee8f3f76343fd849cc 100644 (file)
--- a/basis/compiler/tree/propagation/propagation-tests.factor
+++ b/basis/compiler/tree/propagation/propagation-tests.factor
@@ -764,17 +764,17 @@ MIXIN: empty-mixin
     [ { word object } declare equal? ] final-classes
 ] unit-test
 
-! [ V{ string } ] [
-!     [ dup string? t xor [ "A" throw ] [ ] if ] 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 or ] final-classes first true-class? ] unit-test
 
-! [ t ] [ [ dup t xor swap or ] final-classes first true-class? ] unit-test
+[ t ] [ [ dup t xor swap or ] final-classes first true-class? ] unit-test
 
-! [ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test
+[ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test
 
-! [ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test
+[ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test
 
 ! generalize-counter-interval wasn't being called in all the right places.
 ! bug found by littledan