1 ! (c)2009 Joe Groff bsd license
2 USING: accessors byte-arrays combinators kernel kernel.private
3 math namespaces sequences sequences.private splitting strings
9 { [ dup CHAR: 9 <= ] [ CHAR: 0 - dup 0 < [ drop 255 ] when ] }
10 { [ dup CHAR: a < ] [ CHAR: A 10 - - dup 10 < [ drop 255 ] when ] }
11 [ CHAR: a 10 - - dup 10 < [ drop 255 ] when ]
18 { length fixnum read-only }
19 { radix fixnum read-only } ;
21 : <number-parse> ( str radix -- i number-parse n )
27 : (next-digit) ( i number-parse n digit-quot end-quot -- n/f )
28 [ 2over length>> < ] 2dip
29 [ [ 2over str>> nth-unsafe >fixnum [ 1 + >fixnum ] 3dip ] prepose ] dip if ; inline
31 : require-next-digit ( i number-parse n quot -- n/f )
32 [ 3drop f ] (next-digit) ; inline
34 : next-digit ( i number-parse n quot -- n/f )
35 [ 2nip ] (next-digit) ; inline
37 : add-digit ( i number-parse n digit quot -- n/f )
38 [ [ dup radix>> ] [ * ] [ + ] tri* ] dip next-digit ; inline
40 : digit-in-radix ( number-parse n char -- number-parse n digit ? )
41 digit> pick radix>> over > ; inline
43 : ?make-ratio ( num denom/f -- ratio/f )
44 [ / ] [ drop f ] if* ; inline
49 { exponent read-only } ;
51 : inc-point ( float-parse -- float-parse' )
52 [ radix>> ] [ point>> 1 + ] [ exponent>> ] tri float-parse boa ; inline
54 : store-exponent ( float-parse n expt -- float-parse' n )
55 swap [ [ drop radix>> ] [ drop point>> ] [ nip ] 2tri float-parse boa ] dip ; inline
57 : ?store-exponent ( float-parse n expt/f -- float-parse' n/f )
58 [ store-exponent ] [ drop f ] if* ; inline
60 : ((pow)) ( base x -- base^x )
61 iota 1 rot [ nip * ] curry reduce ; inline
63 : (pow) ( base x -- base^x )
64 dup 0 >= [ ((pow)) ] [ [ recip ] [ neg ] bi* ((pow)) ] if ; inline
66 : add-mantissa-digit ( float-parse i number-parse n digit quot -- float-parse' n/f )
67 [ [ inc-point ] 4dip ] dip add-digit ; inline
69 : make-float-dec-exponent ( float-parse n/f -- float/f )
70 [ [ radix>> ] [ point>> ] [ exponent>> ] tri - (pow) ] [ swap /f ] bi* ; inline
72 : make-float-bin-exponent ( float-parse n/f -- float/f )
73 [ drop [ radix>> ] [ point>> ] bi (pow) ]
75 [ drop 2.0 swap exponent>> (pow) * ] 2tri ; inline
77 : ?make-float ( float-parse n/f -- float/f )
79 { [ dup not ] [ 2drop f ] }
80 { [ over radix>> 10 = ] [ make-float-dec-exponent ] }
81 [ make-float-bin-exponent ]
84 : ?neg ( n/f -- -n/f )
85 [ neg ] [ f ] if* ; inline
87 : ?add-ratio ( m n/f -- m+n/f )
88 dup ratio? [ + ] [ 2drop f ] if ; inline
90 : @abort ( i number-parse n x -- f )
91 2drop 2drop f ; inline
93 : @split ( i number-parse n -- n i number-parse n' )
96 : @split-exponent ( i number-parse n -- n i number-parse' n' )
97 -rot [ str>> ] [ length>> ] bi 10 number-parse boa 0 ; inline
99 : <float-parse> ( i number-parse n -- float-parse i number-parse n )
100 [ drop nip radix>> 0 0 float-parse boa ] 3keep ; inline
102 DEFER: @exponent-digit
103 DEFER: @mantissa-digit
109 : @exponent-digit-or-punc ( float-parse i number-parse n char -- float-parse n/f )
111 { CHAR: , [ [ @exponent-digit ] require-next-digit ] }
115 : @exponent-digit ( float-parse i number-parse n char -- float-parse n/f )
116 { float-parse fixnum number-parse integer fixnum } declare
117 digit-in-radix [ [ @exponent-digit-or-punc ] add-digit ] [ @abort ] if ;
119 : @exponent-first-char ( float-parse i number-parse n char -- float-parse n/f )
121 { CHAR: - [ [ @exponent-digit ] require-next-digit ?neg ] }
122 { CHAR: + [ [ @exponent-digit ] require-next-digit ] }
126 : ->exponent ( float-parse i number-parse n -- float-parse' n/f )
127 @split-exponent [ @exponent-first-char ] require-next-digit ?store-exponent ; inline
129 : exponent-char? ( number-parse n char -- number-parse n char ? )
130 3dup nip swap radix>> {
131 { 10 [ [ CHAR: e CHAR: E ] dip [ = ] curry either? ] }
132 [ drop [ CHAR: p CHAR: P ] dip [ = ] curry either? ]
135 : or-exponent ( i number-parse n char quot -- n/f )
136 [ exponent-char? [ drop <float-parse> ->exponent ?make-float ] ] dip if ; inline
138 : or-mantissa->exponent ( float-parse i number-parse n char quot -- float-parse n/f )
139 [ exponent-char? [ drop ->exponent ] ] dip if ; inline
141 : @mantissa-digit-or-punc ( float-parse i number-parse n char -- float-parse n/f )
143 { CHAR: , [ [ @mantissa-digit ] require-next-digit ] }
147 : @mantissa-digit ( float-parse i number-parse n char -- float-parse n/f )
148 { float-parse fixnum number-parse integer fixnum } declare
151 [ [ @mantissa-digit-or-punc ] add-mantissa-digit ]
153 ] or-mantissa->exponent ;
155 : ->mantissa ( i number-parse n -- n/f )
156 <float-parse> [ @mantissa-digit ] next-digit ?make-float ; inline
158 : ->required-mantissa ( i number-parse n -- n/f )
159 <float-parse> [ @mantissa-digit ] require-next-digit ?make-float ; inline
161 : @denom-digit-or-punc ( i number-parse n char -- n/f )
163 { CHAR: , [ [ @denom-digit ] require-next-digit ] }
164 { CHAR: . [ ->mantissa ] }
165 [ [ @denom-digit ] or-exponent ]
168 : @denom-digit ( i number-parse n char -- n/f )
169 { fixnum number-parse integer fixnum } declare
170 digit-in-radix [ [ @denom-digit-or-punc ] add-digit ] [ @abort ] if ;
172 : @denom-first-digit ( i number-parse n char -- n/f )
174 { CHAR: . [ ->mantissa ] }
178 : ->denominator ( i number-parse n -- n/f )
179 @split [ @denom-first-digit ] require-next-digit ?make-ratio ; inline
181 : @num-digit-or-punc ( i number-parse n char -- n/f )
183 { CHAR: , [ [ @num-digit ] require-next-digit ] }
184 { CHAR: / [ ->denominator ] }
188 : @num-digit ( i number-parse n char -- n/f )
189 { fixnum number-parse integer fixnum } declare
190 digit-in-radix [ [ @num-digit-or-punc ] add-digit ] [ @abort ] if ;
192 : ->numerator ( i number-parse n -- n/f )
193 @split [ @num-digit ] require-next-digit ?add-ratio ; inline
195 : @pos-digit-or-punc ( i number-parse n char -- n/f )
197 { CHAR: , [ [ @pos-digit ] require-next-digit ] }
198 { CHAR: + [ ->numerator ] }
199 { CHAR: / [ ->denominator ] }
200 { CHAR: . [ ->mantissa ] }
201 [ [ @pos-digit ] or-exponent ]
204 : @pos-digit ( i number-parse n char -- n/f )
205 { fixnum number-parse integer fixnum } declare
206 digit-in-radix [ [ @pos-digit-or-punc ] add-digit ] [ @abort ] if ;
208 : @pos-first-digit ( i number-parse n char -- n/f )
210 { CHAR: . [ ->required-mantissa ] }
214 : @neg-digit-or-punc ( i number-parse n char -- n/f )
216 { CHAR: , [ [ @neg-digit ] require-next-digit ] }
217 { CHAR: - [ ->numerator ] }
218 { CHAR: / [ ->denominator ] }
219 { CHAR: . [ ->mantissa ] }
220 [ [ @neg-digit ] or-exponent ]
223 : @neg-digit ( i number-parse n char -- n/f )
224 { fixnum number-parse integer fixnum } declare
225 digit-in-radix [ [ @neg-digit-or-punc ] add-digit ] [ @abort ] if ;
227 : @neg-first-digit ( i number-parse n char -- n/f )
229 { CHAR: . [ ->required-mantissa ] }
233 : @first-char ( i number-parse n char -- n/f )
235 { CHAR: - [ [ @neg-first-digit ] require-next-digit ?neg ] }
236 { CHAR: + [ [ @pos-first-digit ] require-next-digit ] }
242 : base> ( str radix -- n/f )
243 <number-parse> [ @first-char ] require-next-digit ;
245 : string>number ( str -- n/f ) 10 base> ; inline
247 : bin> ( str -- n/f ) 2 base> ; inline
248 : oct> ( str -- n/f ) 8 base> ; inline
249 : dec> ( str -- n/f ) 10 base> ; inline
250 : hex> ( str -- n/f ) 16 base> ; inline
252 : string>digits ( str -- digits )
253 [ digit> ] B{ } map-as ; inline
257 : (digits>integer) ( valid? accum digit radix -- valid? accum )
258 2dup < [ swapd * + ] [ 2drop 2drop f 0 ] if ; inline
260 : each-digit ( seq radix quot -- n/f )
261 [ t 0 ] 3dip curry each swap [ drop f ] unless ; inline
265 : digits>integer ( seq radix -- n/f )
266 [ (digits>integer) ] each-digit ; inline
269 dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] if ; inline
273 : positive>base ( num radix -- str )
274 dup 1 <= [ "Invalid radix" throw ] when
275 [ dup 0 > ] swap [ /mod >digit ] curry "" produce-as nip
280 GENERIC# >base 1 ( n radix -- str )
282 : number>string ( n -- str ) 10 >base ; inline
283 : >bin ( n -- str ) 2 >base ; inline
284 : >oct ( n -- str ) 8 >base ; inline
285 : >hex ( n -- str ) 16 >base ; inline
292 : sign ( -- str ) negative? get "-" "+" ? ;
294 : with-radix ( radix quot -- )
295 radix swap with-variable ; inline
297 : (>base) ( n -- str ) radix get positive>base ;
308 [ neg ] dip positive>base CHAR: - prefix
314 dup 0 < negative? set
316 [ [ "" ] [ (>base) sign append ] if-zero ]
318 [ numerator (>base) ]
319 [ denominator (>base) ] bi
322 negative? get [ CHAR: - prefix ] when
325 : fix-float ( str -- newstr )
328 [ CHAR: e over member? ]
329 [ "e" split1 [ fix-float "e" ] dip 3append ]
331 [ CHAR: . over member? ]
339 : mantissa-expt-normalize ( mantissa expt -- mantissa' expt' )
341 [ over log2 52 swap - [ shift 52 2^ 1 - bitand ] [ 1022 + - ] bi-curry bi* ]
344 : mantissa-expt ( float -- mantissa expt )
346 [ -0.0 double>bits bitnot bitand -52 shift ] bi
347 mantissa-expt-normalize ;
349 : float>hex-sign ( bits -- str )
350 -0.0 double>bits bitand zero? "" "-" ? ;
352 : float>hex-value ( mantissa -- str )
353 >hex 13 CHAR: 0 pad-head [ CHAR: 0 = ] trim-tail
354 [ "0" ] when-empty "1." prepend ;
356 : float>hex-expt ( mantissa -- str )
357 10 >base "p" prepend ;
359 : float>hex ( n -- str )
362 mantissa-expt [ float>hex-value ] [ float>hex-expt ] bi*
365 : format-float ( n format -- string )
366 0 suffix >byte-array (format-float)
367 dup [ 0 = ] find drop head >string
370 : float>base ( n base -- str )
373 [ drop "%.16g" format-float ]
378 : float>string ( n -- str )
379 10 float>base ; inline
383 { [ over fp-nan? ] [ 2drop "0/0." ] }
384 { [ over 1/0. = ] [ 2drop "1/0." ] }
385 { [ over -1/0. = ] [ 2drop "-1/0." ] }
386 { [ over 0.0 fp-bitwise= ] [ 2drop "0.0" ] }
387 { [ over -0.0 fp-bitwise= ] [ 2drop "-0.0" ] }
391 : # ( n -- ) number>string % ; inline