steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Make the member? transform better

db4
Slava Pestov 2009-03-21 03:10:21 -05:00
parent 59dbba09a3
commit 385892be64
2 changed files with 26 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
basis/stack-checker/transforms/transforms-tests.factor
View File

@ -66,3 +66,8 @@ DEFER: curry-folding-test ( quot -- )
{ 3 0 } [ [ 1 2 3 ] curry-folding-test ] must-infer-as { 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 curry-folding-test ] must-infer-as
{ 3 0 } [ [ 1 2 ] 3 [ ] curry compose curry-folding-test ] must-infer-as { 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

48
basis/stack-checker/transforms/transforms.factor
View File

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