1 ! Copyright (C) 2009 Joe Groff, 2013 John Benediktsson
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors byte-arrays combinators kernel kernel.private layouts
4 make math math.private sbufs sequences sequences.private strings ;
8 PRIMITIVE: (format-float) ( n fill width precision format locale -- byte-array )
13 { [ dup CHAR: 9 <= ] [ CHAR: 0 - dup 0 < [ drop 255 ] when ] }
14 { [ dup CHAR: a < ] [ CHAR: A 10 - - dup 10 < [ drop 255 ] when ] }
15 [ CHAR: a 10 - - dup 10 < [ drop 255 ] when ]
18 : string>digits ( str -- digits )
19 [ digit> ] B{ } map-as ; inline
22 dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] if ; inline
24 ERROR: invalid-radix radix ;
28 ! magnitude is used only for floats to avoid
29 ! expensive computations when we know that
30 ! the result will overflow/underflow.
31 ! The computation of magnitude starts in
32 ! number-parse and continues in float-parse.
35 { length fixnum read-only }
37 { magnitude fixnum } ;
39 : <number-parse> ( str radix -- i number-parse n )
40 [ 0 ] 2dip [ dup length ] dip 0 number-parse boa 0 ; inline
42 : (next-digit) ( i number-parse n digit-quot end-quot -- n/f )
43 [ 2over length>> < ] 2dip
44 [ [ 2over str>> nth-unsafe >fixnum [ 1 fixnum+fast ] 3dip ] prepose ] dip if ; inline
46 : require-next-digit ( i number-parse n quot -- n/f )
47 [ 3drop f ] (next-digit) ; inline
49 : next-digit ( i number-parse n quot -- n/f )
50 [ 2nip ] (next-digit) ; inline
52 : inc-magnitude ( number-parse -- number-parse' )
53 [ 1 fixnum+fast ] change-magnitude ; inline
55 : ?inc-magnitude ( number-parse n -- number-parse' )
56 zero? [ inc-magnitude ] unless ; inline
58 : (add-digit) ( number-parse n digit -- number-parse n' )
59 [ dup radix>> ] [ * ] [ + ] tri* ; inline
61 : add-digit ( i number-parse n digit quot -- n/f )
62 [ (add-digit) [ ?inc-magnitude ] keep ] dip next-digit ; inline
64 : add-exponent-digit ( i number-parse n digit quot -- n/f )
65 [ (add-digit) ] dip next-digit ; inline
67 : digit-in-radix ( number-parse n char -- number-parse n digit ? )
68 digit> pick radix>> over > ; inline
70 : ?make-ratio ( num denom/f -- ratio/f )
71 ! don't use number= to allow 0. for "1/0."
72 [ dup 0 = [ 2drop f ] [ / ] if ] [ drop f ] if* ; inline
80 : inc-point-?dec-magnitude ( float-parse n -- float-parse' )
81 zero? [ [ 1 fixnum-fast ] change-magnitude ] when
82 [ 1 fixnum+fast ] change-point ; inline
84 : store-exponent ( float-parse n expt -- float-parse' n )
85 swap [ >>exponent ] dip ; inline
87 : ?store-exponent ( float-parse n expt/f -- float-parse' n/f )
88 [ store-exponent ] [ drop f ] if* ; inline
90 : pow-until ( base x -- base^x )
93 dup odd? [ [ [ * ] keep ] [ 1 - ] bi* ] when
95 ] until 2drop ; inline
97 : (pow) ( base x -- base^x )
99 dup 0 >= [ pow-until ] [ [ recip ] [ neg ] bi* pow-until ] if ; inline
101 : add-mantissa-digit ( float-parse i number-parse n digit quot -- float-parse' n/f )
103 dup [ inc-point-?dec-magnitude ] curry 3dip
104 ] dip next-digit ; inline
106 ! IEE754 doubles are in the range ]10^309,10^-324[,
107 ! or expressed in base 2, ]2^1024, 2^-1074].
108 ! We don't need those ranges to be accurate as long as we are
109 ! excluding all the floats because they are used only to
110 ! optimize when we know there will be an overflow/underflow
111 ! We compare these numbers to the magnitude slot of float-parse,
112 ! which has the following behavior:
113 ! ... ; 0.0xxx -> -1; 0.xxx -> 0; x.xxx -> 1; xx.xxx -> 2; ...;
114 ! Also, take some margin as the current float parsing algorithm
115 ! does some rounding; For example,
116 ! 0x1.0p-1074 is the smallest IE754 double, but floats down to
117 ! 0x0.8p-1074 (excluded) are parsed as 0x1.0p-1074
118 CONSTANT: max-magnitude-10 309
119 CONSTANT: min-magnitude-10 -323
120 CONSTANT: max-magnitude-2 1027
121 CONSTANT: min-magnitude-2 -1074
123 : make-float-dec-exponent ( float-parse n/f -- float/f )
124 over [ exponent>> ] [ magnitude>> ] bi +
126 { [ dup max-magnitude-10 > ] [ 3drop 1/0. ] }
127 { [ dup min-magnitude-10 < ] [ 3drop 0.0 ] }
129 [ [ radix>> ] [ point>> ] [ exponent>> ] tri - (pow) ]
134 : base2-digits ( digits radix -- digits' )
141 : base2-point ( float-parse -- point )
142 [ point>> ] [ radix>> ] bi base2-digits ; inline
144 : base2-magnitude ( float-parse -- point )
145 [ magnitude>> ] [ radix>> ] bi base2-digits ; inline
147 : make-float-bin-exponent ( float-parse n/f -- float/f )
148 over [ exponent>> ] [ base2-magnitude ] bi +
150 { [ dup max-magnitude-2 > ] [ 3drop 1/0. ] }
151 { [ dup min-magnitude-2 < ] [ 3drop 0.0 ] }
153 [ [ drop 2 ] [ base2-point ] [ exponent>> ] tri - (pow) ]
158 : ?default-exponent ( float-parse n/f -- float-parse' n/f' )
160 over radix>> 10 = [ 0 store-exponent ] [ drop f ] if
163 : ?make-float ( float-parse n/f -- float/f )
164 { float-parse object } declare
167 { [ dup not ] [ 2drop f ] }
168 { [ over radix>> 10 = ] [ make-float-dec-exponent ] }
169 [ make-float-bin-exponent ]
172 : ?neg ( n/f -- -n/f )
175 dup first-bignum bignum=
176 [ drop most-negative-fixnum ] [ neg ] if
180 : ?add-ratio ( m n/f -- m+n/f )
181 dup ratio? [ + ] [ 2drop f ] if ; inline
183 : @abort ( i number-parse n x -- f )
186 : @split ( i number-parse n -- n i number-parse' n' )
187 -rot 0 >>magnitude 0 ; inline
189 : @split-exponent ( i number-parse n -- n i number-parse' n' )
190 -rot 10 >>radix 0 ; inline
192 : <float-parse> ( i number-parse n -- float-parse i number-parse n )
193 [ drop nip [ radix>> ] [ magnitude>> ] bi [ 0 f ] dip float-parse boa ] 3keep ; inline
195 DEFER: @exponent-digit
196 DEFER: @mantissa-digit
202 : @exponent-digit-or-punc ( float-parse i number-parse n char -- float-parse n/f )
204 { CHAR: , [ [ @exponent-digit ] require-next-digit ] }
208 : @exponent-digit ( float-parse i number-parse n char -- float-parse n/f )
209 { float-parse fixnum number-parse integer fixnum } declare
210 digit-in-radix [ [ @exponent-digit-or-punc ] add-exponent-digit ] [ @abort ] if ;
212 : @exponent-first-char ( float-parse i number-parse n char -- float-parse n/f )
214 { CHAR: - [ [ @exponent-digit ] require-next-digit ?neg ] }
215 { CHAR: + [ [ @exponent-digit ] require-next-digit ] }
219 : ->exponent ( float-parse i number-parse n -- float-parse' n/f )
220 @split-exponent [ @exponent-first-char ] require-next-digit ?store-exponent ; inline
222 : exponent-char? ( number-parse n char -- number-parse n char ? )
224 { 10 [ dup "eE" member-eq? ] }
225 [ drop dup "pP" member-eq? ]
228 : or-exponent ( i number-parse n char quot -- n/f )
229 [ exponent-char? [ drop <float-parse> ->exponent ?make-float ] ] dip if ; inline
231 : or-mantissa->exponent ( float-parse i number-parse n char quot -- float-parse n/f )
232 [ exponent-char? [ drop ->exponent ] ] dip if ; inline
234 : @mantissa-digit-or-punc ( float-parse i number-parse n char -- float-parse n/f )
236 { CHAR: , [ [ @mantissa-digit ] require-next-digit ] }
240 : @mantissa-digit ( float-parse i number-parse n char -- float-parse n/f )
241 { float-parse fixnum number-parse integer fixnum } declare
244 [ [ @mantissa-digit-or-punc ] add-mantissa-digit ]
246 ] or-mantissa->exponent ;
248 : ->mantissa ( i number-parse n -- n/f )
249 <float-parse> [ @mantissa-digit ] next-digit ?make-float ; inline
251 : ->required-mantissa ( i number-parse n -- n/f )
252 <float-parse> [ @mantissa-digit ] require-next-digit ?make-float ; inline
254 : @denom-digit-or-punc ( i number-parse n char -- n/f )
256 { CHAR: , [ [ @denom-digit ] require-next-digit ] }
257 { CHAR: . [ ->mantissa ] }
258 [ [ @denom-digit ] or-exponent ]
261 : @denom-digit ( i number-parse n char -- n/f )
262 { fixnum number-parse integer fixnum } declare
263 digit-in-radix [ [ @denom-digit-or-punc ] add-digit ] [ @abort ] if ;
265 : @denom-first-digit ( i number-parse n char -- n/f )
267 { CHAR: . [ ->mantissa ] }
271 : ->denominator ( i number-parse n -- n/f )
272 { fixnum number-parse integer } declare
273 @split [ @denom-first-digit ] require-next-digit ?make-ratio ;
275 : @num-digit-or-punc ( i number-parse n char -- n/f )
277 { CHAR: , [ [ @num-digit ] require-next-digit ] }
278 { CHAR: / [ ->denominator ] }
282 : @num-digit ( i number-parse n char -- n/f )
283 { fixnum number-parse integer fixnum } declare
284 digit-in-radix [ [ @num-digit-or-punc ] add-digit ] [ @abort ] if ;
286 : ->numerator ( i number-parse n -- n/f )
287 { fixnum number-parse integer } declare
288 @split [ @num-digit ] require-next-digit ?add-ratio ;
290 : @pos-digit-or-punc ( i number-parse n char -- n/f )
292 { CHAR: , [ [ @pos-digit ] require-next-digit ] }
293 { CHAR: + [ ->numerator ] }
294 { CHAR: / [ ->denominator ] }
295 { CHAR: . [ ->mantissa ] }
296 [ [ @pos-digit ] or-exponent ]
299 : @pos-digit ( i number-parse n char -- n/f )
300 { fixnum number-parse integer fixnum } declare
301 digit-in-radix [ [ @pos-digit-or-punc ] add-digit ] [ @abort ] if ;
303 : ->radix ( i number-parse n quot radix -- i number-parse n quot )
304 [ >>radix ] curry 2dip ; inline
306 : with-radix-char ( i number-parse n radix-quot nonradix-quot -- n/f )
309 { CHAR: b [ drop 2 ->radix require-next-digit ] }
310 { CHAR: o [ drop 8 ->radix require-next-digit ] }
311 { CHAR: x [ drop 16 ->radix require-next-digit ] }
312 [ [ drop ] 2dip swap call ]
314 ] 2curry next-digit ; inline
316 : @pos-first-digit ( i number-parse n char -- n/f )
318 { CHAR: . [ ->required-mantissa ] }
319 { CHAR: 0 [ [ @pos-digit ] [ @pos-digit-or-punc ] with-radix-char ] }
323 : @neg-digit-or-punc ( i number-parse n char -- n/f )
325 { CHAR: , [ [ @neg-digit ] require-next-digit ] }
326 { CHAR: - [ ->numerator ] }
327 { CHAR: / [ ->denominator ] }
328 { CHAR: . [ ->mantissa ] }
329 [ [ @neg-digit ] or-exponent ]
332 : @neg-digit ( i number-parse n char -- n/f )
333 { fixnum number-parse integer fixnum } declare
334 digit-in-radix [ [ @neg-digit-or-punc ] add-digit ] [ @abort ] if ;
336 : @neg-first-digit ( i number-parse n char -- n/f )
338 { CHAR: . [ ->required-mantissa ] }
339 { CHAR: 0 [ [ @neg-digit ] [ @neg-digit-or-punc ] with-radix-char ] }
343 : @first-char ( i number-parse n char -- n/f )
345 { CHAR: - [ [ @neg-first-digit ] require-next-digit ?neg ] }
346 { CHAR: + [ [ @pos-first-digit ] require-next-digit ] }
350 : @neg-first-digit-no-radix ( i number-parse n char -- n/f )
352 { CHAR: . [ ->required-mantissa ] }
356 : @pos-first-digit-no-radix ( i number-parse n char -- n/f )
358 { CHAR: . [ ->required-mantissa ] }
362 : @first-char-no-radix ( i number-parse n char -- n/f )
364 { CHAR: - [ [ @neg-first-digit-no-radix ] require-next-digit ?neg ] }
365 { CHAR: + [ [ @pos-first-digit-no-radix ] require-next-digit ] }
366 [ @pos-first-digit-no-radix ]
371 : string>number ( str -- n/f )
372 10 <number-parse> [ @first-char ] require-next-digit ;
374 : base> ( str radix -- n/f )
375 <number-parse> [ @first-char-no-radix ] require-next-digit ;
377 : bin> ( str -- n/f ) 2 base> ; inline
378 : oct> ( str -- n/f ) 8 base> ; inline
379 : dec> ( str -- n/f ) 10 base> ; inline
380 : hex> ( str -- n/f ) 16 base> ; inline
385 48 48 48 48 48 48 48 48 48 48 49 49 49 49 49 49 49 49 49 49
386 50 50 50 50 50 50 50 50 50 50 51 51 51 51 51 51 51 51 51 51
387 52 52 52 52 52 52 52 52 52 52 53 53 53 53 53 53 53 53 53 53
388 54 54 54 54 54 54 54 54 54 54 55 55 55 55 55 55 55 55 55 55
389 56 56 56 56 56 56 56 56 56 56 57 57 57 57 57 57 57 57 57 57
393 48 49 50 51 52 53 54 55 56 57 48 49 50 51 52 53 54 55 56 57
394 48 49 50 51 52 53 54 55 56 57 48 49 50 51 52 53 54 55 56 57
395 48 49 50 51 52 53 54 55 56 57 48 49 50 51 52 53 54 55 56 57
396 48 49 50 51 52 53 54 55 56 57 48 49 50 51 52 53 54 55 56 57
397 48 49 50 51 52 53 54 55 56 57 48 49 50 51 52 53 54 55 56 57
400 : (two-digit) ( num accum -- num' accum )
402 100 /mod [ TENS nth-unsafe ] [ ONES nth-unsafe ] bi
403 ] dip [ push ] keep [ push ] keep ; inline
405 : (one-digit) ( num accum -- num' accum )
406 [ 10 /mod CHAR: 0 + ] dip [ push ] keep ; inline
408 : (bignum>dec) ( num accum -- num' accum )
409 [ over most-positive-fixnum > ]
410 [ { bignum sbuf } declare (two-digit) ] while
411 [ >fixnum ] dip ; inline
413 : (fixnum>dec) ( num accum -- num' accum )
414 { fixnum sbuf } declare
415 [ over 10 >= ] [ (two-digit) ] while
416 [ over zero? ] [ (one-digit) ] until ; inline
418 GENERIC: (positive>dec) ( num -- str )
420 M: bignum (positive>dec)
421 12 <sbuf> (bignum>dec) (fixnum>dec) "" like reverse! nip ; inline
423 : (count-digits) ( digits n -- digits' )
425 { [ dup 10 < ] [ drop ] }
426 { [ dup 100 < ] [ drop 1 fixnum+fast ] }
427 { [ dup 1,000 < ] [ drop 2 fixnum+fast ] }
429 dup 1,000,000,000,000 < [
441 dup 10,000,000,000 < [
442 1,000,000,000 >= 9 8 ?
444 100,000,000,000 >= 11 10 ?
448 [ 12 fixnum+fast ] [ 1,000,000,000,000 /i ] bi*
452 } cond ; inline recursive
454 M: fixnum (positive>dec)
455 1 over (count-digits) <sbuf> (fixnum>dec) "" like reverse! nip ; inline
457 : (positive>base) ( num radix -- str )
458 dup 1 <= [ invalid-radix ] when
459 [ dup 0 > ] swap [ /mod >digit ] curry "" produce-as nip
462 : positive>base ( num radix -- str )
463 dup 10 = [ drop (positive>dec) ] [ (positive>base) ] if ; inline
467 GENERIC# >base 1 ( n radix -- str )
469 : number>string ( n -- str ) 10 >base ; inline
471 : >bin ( n -- str ) 2 >base ; inline
472 : >oct ( n -- str ) 8 >base ; inline
473 : >hex ( n -- str ) 16 >base ; inline
477 { [ over 0 = ] [ 2drop "0" ] }
478 { [ over 0 > ] [ positive>base ] }
479 [ [ neg ] dip positive>base CHAR: - prefix ]
483 [ >fraction [ /mod ] keep ] [ [ >base ] curry tri@ ] bi*
484 "/" glue over first-unsafe {
486 { CHAR: - [ append ] }
492 : (fix-float) ( str-no-exponent -- newstr )
493 CHAR: . over member? [ ".0" append ] unless ; inline
495 : fix-float ( str exponent-char -- newstr )
497 cut [ (fix-float) ] dip append
498 ] [ (fix-float) ] if* ; inline
500 : mantissa-expt-normalize ( mantissa expt -- mantissa' expt' )
501 [ dup log2 52 swap - [ shift 52 2^ 1 - bitand ] [ 1022 + neg ] bi ]
504 : mantissa-expt ( float -- mantissa expt )
506 [ -0.0 double>bits bitnot bitand -52 shift ] bi
507 mantissa-expt-normalize ;
509 : bin-float-sign ( bits -- str )
510 -0.0 double>bits bitand zero? "" "-" ? ;
512 : bin-float-value ( str size -- str' )
513 CHAR: 0 pad-head [ CHAR: 0 = ] trim-tail
514 [ "0" ] when-empty "1." prepend ;
516 : float>hex-value ( mantissa -- str )
517 >hex 13 bin-float-value ;
519 : float>oct-value ( mantissa -- str )
520 4 * >oct 18 bin-float-value ;
522 : float>bin-value ( mantissa -- str )
523 >bin 52 bin-float-value ;
525 : bin-float-expt ( mantissa -- str )
526 10 >base "p" prepend ;
528 : (bin-float>base) ( value-quot n -- str )
530 [ bin-float-sign swap ] [
531 mantissa-expt rot [ bin-float-expt ] bi*
532 ] bi 3append ; inline
534 : bin-float>base ( n base -- str )
536 { 16 [ [ float>hex-value ] swap (bin-float>base) ] }
537 { 8 [ [ float>oct-value ] swap (bin-float>base) ] }
538 { 2 [ [ float>bin-value ] swap (bin-float>base) ] }
542 : format-string ( format -- format )
543 0 suffix >byte-array ; foldable
545 : format-float ( n fill width precision format locale -- string )
547 [ format-string ] 4dip [ format-string ] bi@ (format-float)
550 "C" = [ [ "G" = ] [ "E" = ] bi or CHAR: E CHAR: e ? fix-float ]
554 : float>base ( n radix -- str )
556 { 10 [ "" -1 16 "" "C" format-float ] }
564 { [ over fp-nan? ] [ 2drop "0/0." ] }
565 { [ over 1/0. = ] [ 2drop "1/0." ] }
566 { [ over -1/0. = ] [ 2drop "-1/0." ] }
567 { [ over 0.0 fp-bitwise= ] [ 2drop "0.0" ] }
568 { [ over -0.0 fp-bitwise= ] [ 2drop "-0.0" ] }
572 : # ( n -- ) number>string % ; inline
574 : hex-string>bytes ( hex-string -- bytes )
575 dup length 2/ <byte-array> [
577 [ digit> ] 2dip over even? [
578 [ 16 * ] [ 2/ ] [ set-nth ] tri*
580 [ 2/ ] [ [ + ] change-nth ] bi*
585 : bytes>hex-string ( bytes -- hex-string )
586 dup length 2 * CHAR: 0 <string> [
588 [ 16 /mod [ >digit ] bi@ ]
590 [ [ set-nth ] curry bi-curry@ bi* ] tri*