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

Optimizing string>number

db4
Slava Pestov 2009-04-11 20:30:51 -05:00
parent db3818814d
commit 0fda643ab1
4 changed files with 103 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
basis/hints/hints.factor
View File

@ -3,7 +3,7 @@
USING: parser words definitions kernel sequences assocs arrays USING: parser words definitions kernel sequences assocs arrays
kernel.private fry combinators accessors vectors strings sbufs kernel.private fry combinators accessors vectors strings sbufs
byte-arrays byte-vectors io.binary io.streams.string splitting byte-arrays byte-vectors io.binary io.streams.string splitting
math generic generic.standard generic.standard.engines classes math math.parser generic generic.standard generic.standard.engines classes
hashtables ; hashtables ;
IN: hints IN: hints
@ -118,6 +118,8 @@ SYNTAX: HINTS:
\ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop \ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop
\ base> { string fixnum } "specializer" set-word-prop
M\ hashtable at* { { fixnum object } { word object } } "specializer" set-word-prop M\ hashtable at* { { fixnum object } { word object } } "specializer" set-word-prop
M\ hashtable set-at { { object fixnum object } { object word object } } "specializer" set-word-prop M\ hashtable set-at { { object fixnum object } { object word object } } "specializer" set-word-prop

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

@ -1,13 +1,13 @@
! 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 math.order namespaces make quotations assocs words sequences generic math math.order namespaces make quotations
combinators combinators.short-circuit classes.tuple assocs combinators combinators.short-circuit classes.tuple
classes.tuple.private effects summary hashtables classes generic sets classes.tuple.private effects summary hashtables classes generic sets
definitions generic.standard slots.private continuations locals definitions generic.standard slots.private continuations locals
generalizations stack-checker.backend stack-checker.state sequences.private generalizations stack-checker.backend
stack-checker.visitor stack-checker.errors stack-checker.values stack-checker.state stack-checker.visitor stack-checker.errors
stack-checker.recursive-state ; stack-checker.values stack-checker.recursive-state ;
IN: stack-checker.transforms IN: stack-checker.transforms
: give-up-transform ( word -- ) : give-up-transform ( word -- )
@ -106,40 +106,68 @@ IN: stack-checker.transforms
] [ drop f ] if ] [ drop f ] if
] 1 define-transform ] 1 define-transform
! Membership testing ! Fast at for integer maps
CONSTANT: bit-member-max 256 CONSTANT: lookup-table-at-max 256
: bit-member? ( seq -- ? ) : lookup-table-at? ( assoc -- ? )
#! Can we use a fast byte array test here? #! Can we use a fast byte array test here?
{ {
[ length 4 > ] [ assoc-size 4 > ]
[ [ integer? ] all? ] [ values [ ] all? ]
[ [ 0 bit-member-max between? ] any? ] [ keys [ integer? ] all? ]
[ keys [ 0 lookup-table-at-max between? ] all? ]
} 1&& ; } 1&& ;
: bit-member-seq ( seq -- flags ) : lookup-table-seq ( assoc -- table )
[ supremum 1+ ] keep '[ _ member? 1 0 ? ] B{ } map-as ; [ keys supremum 1+ ] keep '[ _ at ] { } map-as ;
: bit-member-quot ( seq -- newquot ) : lookup-table-quot ( seq -- newquot )
bit-member-seq lookup-table-seq
'[ '[
_ { _ over integer? [
{ [ over fixnum? ] [ ?nth 1 eq? ] } 2dup bounds-check? [
{ [ over bignum? ] [ ?nth 1 eq? ] } nth-unsafe dup >boolean
[ 2drop f ] ] [ 2drop f f ] if
} cond ] [ 2drop f f ] if
] ; ] ;
: member-quot ( seq -- newquot ) : fast-lookup-table-at? ( assoc -- ? )
dup bit-member? [ values {
bit-member-quot [ [ integer? ] all? ]
[ [ 0 254 between? ] all? ]
} 1&& ;
: fast-lookup-table-seq ( assoc -- table )
lookup-table-seq [ 255 or ] B{ } map-as ;
: fast-lookup-table-quot ( seq -- newquot )
fast-lookup-table-seq
'[
_ over integer? [
2dup bounds-check? [
nth-unsafe dup 255 eq? [ drop f f ] [ t ] if
] [ 2drop f f ] if
] [ 2drop f f ] if
] ;
: at-quot ( assoc -- quot )
dup lookup-table-at? [
dup fast-lookup-table-at? [
fast-lookup-table-quot
] [ ] [
lookup-table-quot
] if
] [ drop f ] if ;
\ at* [ at-quot ] 1 define-transform
! Membership testing
: member-quot ( seq -- newquot )
dup length 4 <= [ dup length 4 <= [
[ drop f ] swap [ drop f ] swap
[ literalize [ t ] ] { } map>assoc linear-case-quot [ literalize [ t ] ] { } map>assoc linear-case-quot
] [ ] [
unique [ key? ] curry unique [ key? ] curry
] if
] if ; ] if ;
\ member? [ \ member? [

10
core/math/parser/parser-tests.factor
View File

@ -95,17 +95,17 @@ unit-test
[ 1 0 >base ] must-fail [ 1 0 >base ] must-fail
[ 1 -1 >base ] must-fail [ 1 -1 >base ] must-fail
[ "0.0/0.0" ] [ 0.0 0.0 / number>string ] unit-test [ "0/0." ] [ 0.0 0.0 / number>string ] unit-test
[ "1.0/0.0" ] [ 1.0 0.0 / number>string ] unit-test [ "1/0." ] [ 1.0 0.0 / number>string ] unit-test
[ "-1.0/0.0" ] [ -1.0 0.0 / number>string ] unit-test [ "-1/0." ] [ -1.0 0.0 / number>string ] unit-test
[ t ] [ "0/0." string>number fp-nan? ] unit-test [ t ] [ "0/0." string>number fp-nan? ] unit-test
[ 1.0/0.0 ] [ "1/0." string>number ] unit-test [ 1/0. ] [ "1/0." string>number ] unit-test
[ -1.0/0.0 ] [ "-1/0." string>number ] unit-test [ -1/0. ] [ "-1/0." string>number ] unit-test
[ "-0.0" ] [ -0.0 number>string ] unit-test [ "-0.0" ] [ -0.0 number>string ] unit-test

70
core/math/parser/parser.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov. ! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel math.private namespaces sequences strings USING: kernel math.private namespaces sequences sequences.private
arrays combinators splitting math assocs make ; strings arrays combinators splitting math assocs make ;
IN: math.parser IN: math.parser
: digit> ( ch -- n ) : digit> ( ch -- n )
@ -28,13 +28,19 @@ IN: math.parser
{ CHAR: d 13 } { CHAR: d 13 }
{ CHAR: e 14 } { CHAR: e 14 }
{ CHAR: f 15 } { CHAR: f 15 }
} at ; } at 255 or ; inline
: string>digits ( str -- digits ) : string>digits ( str -- digits )
[ digit> ] { } map-as ; [ digit> ] B{ } map-as ; inline
: digits>integer ( seq radix -- n ) : (digits>integer) ( valid? accum digit radix -- valid? accum )
0 swap [ swapd * + ] curry reduce ; 2dup < [ swapd * + ] [ 2drop 2drop f 0 ] if ; inline
: each-digit ( seq radix quot -- n/f )
[ t 0 ] 3dip curry each swap [ drop f ] unless ; inline
: digits>integer ( seq radix -- n/f )
[ (digits>integer) ] each-digit ; inline
DEFER: base> DEFER: base>
@ -43,6 +49,9 @@ DEFER: base>
SYMBOL: radix SYMBOL: radix
SYMBOL: negative? SYMBOL: negative?
: string>natural ( seq radix -- n/f )
[ [ digit> ] dip (digits>integer) ] each-digit ; inline
: sign ( -- str ) negative? get "-" "+" ? ; : sign ( -- str ) negative? get "-" "+" ? ;
: with-radix ( radix quot -- ) : with-radix ( radix quot -- )
@ -54,37 +63,30 @@ SYMBOL: negative?
sign split1 [ (base>) ] dip sign split1 [ (base>) ] dip
dup [ (base>) ] [ drop 0 swap ] if ; dup [ (base>) ] [ drop 0 swap ] if ;
: string>ratio ( str -- a/b ) : string>ratio ( str radix -- a/b )
[
"-" ?head dup negative? set swap "-" ?head dup negative? set swap
"/" split1 (base>) [ whole-part ] dip "/" split1 (base>) [ whole-part ] dip
3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if ; 3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if
] with-radix ;
: valid-digits? ( seq -- ? ) : string>integer ( str radix -- n/f )
{ over first-unsafe CHAR: - = [
{ [ dup empty? ] [ drop f ] } [ rest-slice ] dip string>natural dup [ neg ] when
{ [ f over memq? ] [ drop f ] } ] [
[ radix get [ < ] curry all? ] string>natural
} cond ; ] if ; inline
: string>integer ( str -- n/f )
"-" ?head swap
string>digits dup valid-digits?
[ radix get digits>integer swap [ neg ] when ] [ 2drop f ] if ;
PRIVATE> PRIVATE>
: base> ( str radix -- n/f ) : base> ( str radix -- n/f )
[ over empty? [ 2drop f ] [
CHAR: / over member? [ over [ "/." member? ] find nip {
string>ratio { CHAR: / [ string>ratio ] }
] [ { CHAR: . [ drop string>float ] }
CHAR: . over member? [ [ drop string>integer ]
string>float } case
] [ ] if ;
string>integer
] if
] if
] with-radix ;
: string>number ( str -- n/f ) 10 base> ; : string>number ( str -- n/f ) 10 base> ;
: bin> ( str -- n/f ) 2 base> ; : bin> ( str -- n/f ) 2 base> ;
@ -147,9 +149,9 @@ M: ratio >base
M: float >base M: float >base
drop { drop {
{ [ dup fp-nan? ] [ drop "0.0/0.0" ] } { [ dup fp-nan? ] [ drop "0/0." ] }
{ [ dup 1.0/0.0 = ] [ drop "1.0/0.0" ] } { [ dup 1/0. = ] [ drop "1/0." ] }
{ [ dup -1.0/0.0 = ] [ drop "-1.0/0.0" ] } { [ dup -1/0. = ] [ drop "-1/0." ] }
{ [ dup double>bits HEX: 8000000000000000 = ] [ drop "-0.0" ] } { [ dup double>bits HEX: 8000000000000000 = ] [ drop "-0.0" ] }
[ float>string fix-float ] [ float>string fix-float ]
} cond ; } cond ;