From c4d832ce4d225c71b44fc2ac64ca229e0c133093 Mon Sep 17 00:00:00 2001
From: John Benediktsson <mrjbq7@gmail.com>
Date: Tue, 26 Mar 2013 19:04:50 -0700
Subject: [PATCH] compiler.tree.propagation.transforms: fix intersect and add
 intersects?.

---
 basis/compiler/tree/propagation/propagation-tests.factor | 3 +++
 .../tree/propagation/transforms/transforms.factor        | 9 +++++++--
 2 files changed, 10 insertions(+), 2 deletions(-)

diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor
index 3021bb6398..056dc54f3f 100644
--- a/basis/compiler/tree/propagation/propagation-tests.factor
+++ b/basis/compiler/tree/propagation/propagation-tests.factor
@@ -973,6 +973,9 @@ M: tuple-with-read-only-slot clone
 [ t ] [ [ { 1 } intersect ] { intersect } inlined? ] unit-test
 [ f ] [ [ { 1 } swap intersect ] { intersect } inlined? ] unit-test ! We could do this
 
+[ t ] [ [ { 1 } intersects? ] { intersects? } inlined? ] unit-test
+[ f ] [ [ { 1 } swap intersects? ] { intersects? } inlined? ] unit-test ! We could do this
+
 [ t ] [ [ { 1 } diff ] { diff } inlined? ] unit-test
 [ f ] [ [ { 1 } swap diff ] { diff } inlined? ] unit-test ! We could do this
 
diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor
index 705156ff2c..f1cf936840 100644
--- a/basis/compiler/tree/propagation/transforms/transforms.factor
+++ b/basis/compiler/tree/propagation/transforms/transforms.factor
@@ -11,7 +11,7 @@ assocs sets combinators.short-circuit sequences.private locals
 growable stack-checker namespaces compiler.tree.propagation.info
 hash-sets ;
 FROM: math => float ;
-FROM: sets => set ;
+FROM: sets => set members ;
 IN: compiler.tree.propagation.transforms
 
 \ equal? [
@@ -307,10 +307,15 @@ CONSTANT: lookup-table-at-max 256
 M\ set diff [ diff-quot ] 1 define-partial-eval
 
 : intersect-quot ( seq -- quot: ( seq' -- seq'' ) )
-    tester '[ [ _ filter ] keep set-like ] ;
+    tester '[ [ members _ filter ] keep set-like ] ;
 
 M\ set intersect [ intersect-quot ] 1 define-partial-eval
 
+: intersects?-quot ( seq -- quot: ( seq' -- seq'' ) )
+    tester '[ members _ any? ] ;
+
+M\ set intersects? [ intersects?-quot ] 1 define-partial-eval
+
 : bit-quot ( #call -- quot/f )
     in-d>> second value-info interval>> 0 fixnum-bits [a,b] interval-subset?
     [ [ >fixnum ] dip fixnum-bit? ] f ? ;