USING: parser words definitions kernel sequences assocs arrays
kernel.private fry combinators accessors vectors strings sbufs
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 ;
IN: hints
\ >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 set-at { { object fixnum object } { object word object } } "specializer" set-word-prop
! 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 math.order namespaces make quotations assocs
-combinators combinators.short-circuit classes.tuple
+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 ;
+sequences.private generalizations stack-checker.backend
+stack-checker.state stack-checker.visitor stack-checker.errors
+stack-checker.values stack-checker.recursive-state ;
IN: stack-checker.transforms
: give-up-transform ( word -- )
] [ drop f ] if
] 1 define-transform
-! Membership testing
-CONSTANT: bit-member-max 256
+! Fast at for integer maps
+CONSTANT: lookup-table-at-max 256
-: bit-member? ( seq -- ? )
+: lookup-table-at? ( assoc -- ? )
#! Can we use a fast byte array test here?
{
- [ length 4 > ]
+ [ assoc-size 4 > ]
+ [ values [ ] all? ]
+ [ keys [ integer? ] all? ]
+ [ keys [ 0 lookup-table-at-max between? ] all? ]
+ } 1&& ;
+
+: lookup-table-seq ( assoc -- table )
+ [ keys supremum 1+ ] keep '[ _ at ] { } map-as ;
+
+: lookup-table-quot ( seq -- newquot )
+ lookup-table-seq
+ '[
+ _ over integer? [
+ 2dup bounds-check? [
+ nth-unsafe dup >boolean
+ ] [ 2drop f f ] if
+ ] [ 2drop f f ] if
+ ] ;
+
+: fast-lookup-table-at? ( assoc -- ? )
+ values {
[ [ integer? ] all? ]
- [ [ 0 bit-member-max between? ] any? ]
+ [ [ 0 254 between? ] all? ]
} 1&& ;
-: bit-member-seq ( seq -- flags )
- [ supremum 1+ ] keep '[ _ member? 1 0 ? ] B{ } map-as ;
+: fast-lookup-table-seq ( assoc -- table )
+ lookup-table-seq [ 255 or ] B{ } map-as ;
-: bit-member-quot ( seq -- newquot )
- bit-member-seq
+: fast-lookup-table-quot ( seq -- newquot )
+ fast-lookup-table-seq
'[
- _ {
- { [ over fixnum? ] [ ?nth 1 eq? ] }
- { [ over bignum? ] [ ?nth 1 eq? ] }
- [ 2drop f ]
- } cond
+ _ over integer? [
+ 2dup bounds-check? [
+ nth-unsafe dup 255 eq? [ drop f f ] [ t ] if
+ ] [ 2drop f f ] if
+ ] [ 2drop f f ] if
] ;
-: member-quot ( seq -- newquot )
- dup bit-member? [
- bit-member-quot
- ] [
- dup length 4 <= [
- [ drop f ] swap
- [ literalize [ t ] ] { } map>assoc linear-case-quot
+: at-quot ( assoc -- quot )
+ dup lookup-table-at? [
+ dup fast-lookup-table-at? [
+ fast-lookup-table-quot
] [
- unique [ key? ] curry
+ lookup-table-quot
] if
+ ] [ drop f ] if ;
+
+\ at* [ at-quot ] 1 define-transform
+
+! Membership testing
+: member-quot ( seq -- newquot )
+ dup length 4 <= [
+ [ drop f ] swap
+ [ literalize [ t ] ] { } map>assoc linear-case-quot
+ ] [
+ unique [ key? ] curry
] if ;
\ member? [
\ shuffle [
shuffle-mapping nths-quot
-] 1 define-transform
\ No newline at end of file
+] 1 define-transform
[ 1 0 >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
-[ 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
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math.private namespaces sequences strings
-arrays combinators splitting math assocs make ;
+USING: kernel math.private namespaces sequences sequences.private
+strings arrays combinators splitting math assocs make ;
IN: math.parser
: digit> ( ch -- n )
{ CHAR: d 13 }
{ CHAR: e 14 }
{ CHAR: f 15 }
- } at ;
+ } at 255 or ; inline
: string>digits ( str -- digits )
- [ digit> ] { } map-as ;
+ [ digit> ] B{ } map-as ; inline
-: digits>integer ( seq radix -- n )
- 0 swap [ swapd * + ] curry reduce ;
+: (digits>integer) ( valid? accum digit radix -- valid? accum )
+ 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>
SYMBOL: radix
SYMBOL: negative?
+: string>natural ( seq radix -- n/f )
+ [ [ digit> ] dip (digits>integer) ] each-digit ; inline
+
: sign ( -- str ) negative? get "-" "+" ? ;
: with-radix ( radix quot -- )
sign split1 [ (base>) ] dip
dup [ (base>) ] [ drop 0 swap ] if ;
-: string>ratio ( str -- a/b )
- "-" ?head dup negative? set swap
- "/" split1 (base>) [ whole-part ] dip
- 3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if ;
-
-: valid-digits? ( seq -- ? )
- {
- { [ dup empty? ] [ drop f ] }
- { [ f over memq? ] [ drop f ] }
- [ radix get [ < ] curry all? ]
- } cond ;
+: string>ratio ( str radix -- a/b )
+ [
+ "-" ?head dup negative? set swap
+ "/" split1 (base>) [ whole-part ] dip
+ 3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if
+ ] with-radix ;
-: string>integer ( str -- n/f )
- "-" ?head swap
- string>digits dup valid-digits?
- [ radix get digits>integer swap [ neg ] when ] [ 2drop f ] if ;
+: string>integer ( str radix -- n/f )
+ over first-unsafe CHAR: - = [
+ [ rest-slice ] dip string>natural dup [ neg ] when
+ ] [
+ string>natural
+ ] if ; inline
PRIVATE>
: base> ( str radix -- n/f )
- [
- CHAR: / over member? [
- string>ratio
- ] [
- CHAR: . over member? [
- string>float
- ] [
- string>integer
- ] if
- ] if
- ] with-radix ;
+ over empty? [ 2drop f ] [
+ over [ "/." member? ] find nip {
+ { CHAR: / [ string>ratio ] }
+ { CHAR: . [ drop string>float ] }
+ [ drop string>integer ]
+ } case
+ ] if ;
: string>number ( str -- n/f ) 10 base> ;
: bin> ( str -- n/f ) 2 base> ;
M: float >base
drop {
- { [ dup fp-nan? ] [ drop "0.0/0.0" ] }
- { [ dup 1.0/0.0 = ] [ drop "1.0/0.0" ] }
- { [ dup -1.0/0.0 = ] [ drop "-1.0/0.0" ] }
+ { [ dup fp-nan? ] [ drop "0/0." ] }
+ { [ dup 1/0. = ] [ drop "1/0." ] }
+ { [ dup -1/0. = ] [ drop "-1/0." ] }
{ [ dup double>bits HEX: 8000000000000000 = ] [ drop "-0.0" ] }
[ float>string fix-float ]
} cond ;
projects / factor.git / commitdiff