Make the member? transform better

diff --git a/basis/stack-checker/transforms/transforms-tests.factor b/basis/stack-checker/transforms/transforms-tests.factor
index 521cf9fcb7064c33cd489d682bbeb6618c4465c7..0aa38769079edfbade031f4ba86f425561bf4d5f 100644 (file)
--- a/basis/stack-checker/transforms/transforms-tests.factor
+++ b/basis/stack-checker/transforms/transforms-tests.factor
@@ -65,4 +65,9 @@ DEFER: curry-folding-test ( quot -- )
 
 { 3 0 } [ [ 1 2 3 ] curry-folding-test ] must-infer-as
 { 3 0 } [ 1 [ 2 3 ] curry curry-folding-test ] must-infer-as
-{ 3 0 } [ [ 1 2 ] 3 [ ] curry compose curry-folding-test ] must-infer-as
\ No newline at end of file
+{ 3 0 } [ [ 1 2 ] 3 [ ] curry compose curry-folding-test ] must-infer-as
+
+: member?-test ( a -- ? ) { 1 2 3 10 7 58 } member? ;
+
+[ f ] [ 1.0 member?-test ] unit-test
+[ t ] [ \ member?-test def>> first [ member?-test ] all? ] unit-test
\ No newline at end of file

diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor
index 3b783ce46783d3ba03fd88a7167ee2e2a360a6af..dd36c5a82b9dacc73782bf496724188519bf7290 100755 (executable)
--- a/basis/stack-checker/transforms/transforms.factor
+++ b/basis/stack-checker/transforms/transforms.factor
@@ -1,12 +1,12 @@
 ! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry accessors arrays kernel kernel.private combinators.private
-words sequences generic math namespaces make quotations assocs
-combinators classes.tuple classes.tuple.private effects summary
-hashtables classes generic sets definitions generic.standard
-slots.private continuations locals generalizations
-stack-checker.backend stack-checker.state stack-checker.visitor
-stack-checker.errors stack-checker.values
+words sequences generic math math.order namespaces make quotations assocs
+combinators combinators.short-circuit classes.tuple
+classes.tuple.private effects summary hashtables classes generic sets
+definitions generic.standard slots.private continuations locals
+generalizations stack-checker.backend stack-checker.state
+stack-checker.visitor stack-checker.errors stack-checker.values
 stack-checker.recursive-state ;
 IN: stack-checker.transforms
 
@@ -107,36 +107,28 @@ IN: stack-checker.transforms
 ] 1 define-transform
 
 ! Membership testing
-CONSTANT: bit-member-n 256
+CONSTANT: bit-member-max 256
 
 : bit-member? ( seq -- ? )
     #! Can we use a fast byte array test here?
     {
-        { [ dup length 8 < ] [ f ] }
-        { [ dup [ integer? not ] any? ] [ f ] }
-        { [ dup [ 0 < ] any? ] [ f ] }
-        { [ dup [ bit-member-n >= ] any? ] [ f ] }
-        [ t ]
-    } cond nip ;
+        [ length 4 > ]
+        [ [ integer? ] all? ]
+        [ [ 0 bit-member-max between? ] any? ]
+    } 1&& ;
 
 : bit-member-seq ( seq -- flags )
-    bit-member-n swap [ member? 1 0 ? ] curry B{ } map-as ;
-
-: exact-float? ( f -- ? )
-    dup float? [ dup >integer >float = ] [ drop f ] if ; inline
+    [ supremum 1+ ] keep '[ _ member? 1 0 ? ] B{ } map-as ;
 
 : bit-member-quot ( seq -- newquot )
-    [
-        bit-member-seq ,
-        [
-            {
-                { [ over fixnum? ] [ ?nth 1 eq? ] }
-                { [ over bignum? ] [ ?nth 1 eq? ] }
-                { [ over exact-float? ] [ ?nth 1 eq? ] }
-                [ 2drop f ]
-            } cond
-        ] %
-    ] [ ] make ;
+    bit-member-seq
+    '[
+        _ {
+            { [ over fixnum? ] [ ?nth 1 eq? ] }
+            { [ over bignum? ] [ ?nth 1 eq? ] }
+            [ 2drop f ]
+        } cond
+    ] ;
 
 : member-quot ( seq -- newquot )
     dup bit-member? [