core/math/parser/parser.factor

   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
   4 layouts make math math.private namespaces sbufs sequences
   5 sequences.private splitting strings strings.private ;
   6 IN: math.parser
   7
   8 <PRIVATE
   9 PRIMITIVE: (format-float) ( n format -- byte-array )
  10 PRIVATE>
  11
  12 : digit> ( ch -- n )
  13     {
  14         { [ dup CHAR: 9 <= ] [ CHAR: 0 -      dup  0 < [ drop 255 ] when ] }
  15         { [ dup CHAR: a <  ] [ CHAR: A 10 - - dup 10 < [ drop 255 ] when ] }
  16                              [ CHAR: a 10 - - dup 10 < [ drop 255 ] when ]
  17     } cond ; inline
  18
  19 : string>digits ( str -- digits )
  20     [ digit> ] B{ } map-as ; inline
  21
  22 : >digit ( n -- ch )
  23     dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] if ; inline
  24
  25 ERROR: invalid-radix radix ;
  26
  27 <PRIVATE
  28
  29 ! magnitude is used only for floats to avoid
  30 ! expensive computations when we know that
  31 ! the result will overflow/underflow.
  32 ! The computation of magnitude starts in
  33 ! number-parse and continues in float-parse.
  34 TUPLE: number-parse
  35     { str read-only }
  36     { length fixnum read-only }
  37     { radix fixnum }
  38     { magnitude fixnum } ;
  39
  40 : <number-parse> ( str radix -- i number-parse n )
  41     [ 0 ] 2dip [ dup length ] dip 0 number-parse boa 0 ; inline
  42
  43 : (next-digit) ( i number-parse n digit-quot end-quot -- n/f )
  44     [ 2over length>> < ] 2dip
  45     [ [ 2over str>> nth-unsafe >fixnum [ 1 fixnum+fast ] 3dip ] prepose ] dip if ; inline
  46
  47 : require-next-digit ( i number-parse n quot -- n/f )
  48     [ 3drop f ] (next-digit) ; inline
  49
  50 : next-digit ( i number-parse n quot -- n/f )
  51     [ 2nip ] (next-digit) ; inline
  52
  53 : inc-magnitude ( number-parse -- number-parse' )
  54     [ 1 fixnum+fast ] change-magnitude ; inline
  55
  56 : ?inc-magnitude ( number-parse n -- number-parse' )
  57     zero? [ inc-magnitude ] unless ; inline
  58
  59 : (add-digit) ( number-parse n digit -- number-parse n' )
  60     [ dup radix>> ] [ * ] [ + ] tri* ; inline
  61
  62 : add-digit ( i number-parse n digit quot -- n/f )
  63     [ (add-digit) [ ?inc-magnitude ] keep ] dip next-digit ; inline
  64
  65 : add-exponent-digit ( i number-parse n digit quot -- n/f )
  66     [ (add-digit) ] dip next-digit ; inline
  67
  68 : digit-in-radix ( number-parse n char -- number-parse n digit ? )
  69     digit> pick radix>> over > ; inline
  70
  71 : ?make-ratio ( num denom/f -- ratio/f )
  72     [ / ] [ drop f ] if* ; inline
  73
  74 TUPLE: float-parse
  75     { radix fixnum }
  76     { point fixnum }
  77     { exponent }
  78     { magnitude } ;
  79 : inc-point-?dec-magnitude ( float-parse n -- float-parse' )
  80     zero? [ [ 1 fixnum-fast ] change-magnitude ] when
  81     [ 1 fixnum+fast ] change-point ; inline
  82
  83 : store-exponent ( float-parse n expt -- float-parse' n )
  84     swap [ >>exponent ] dip ; inline
  85
  86 : ?store-exponent ( float-parse n expt/f -- float-parse' n/f )
  87     [ store-exponent ] [ drop f ] if* ; inline
  88
  89 : ((pow)) ( base x -- base^x )
  90     [ 1 ] 2dip
  91     [ dup zero? ] [
  92         dup odd? [ [ [ * ] keep ] [ 1 - ] bi* ] when
  93         [ sq ] [ 2/ ] bi*
  94     ] until 2drop ; inline
  95
  96 : (pow) ( base x -- base^x )
  97     integer>fixnum-strict
  98     dup 0 >= [ ((pow)) ] [ [ recip ] [ neg ] bi* ((pow)) ] if ; inline
  99
 100 : add-mantissa-digit ( float-parse i number-parse n digit quot -- float-parse' n/f )
 101     [ (add-digit)
 102         dup [ inc-point-?dec-magnitude ] curry 3dip
 103     ] dip next-digit ; inline
 104
 105 ! IEE754 doubles are in the range ]10^309,10^-324[,
 106 ! or expressed in base 2, ]2^1024, 2^-1074].
 107 ! We don't need those ranges to be accurate as long as we are
 108 ! excluding all the floats because they are used only to
 109 ! optimize when we know there will be an overflow/underflow
 110 ! We compare these numbers to the magnitude slot of float-parse,
 111 ! which has the following behavior:
 112 ! ... ; 0.0xxx -> -1; 0.xxx -> 0; x.xxx -> 1; xx.xxx -> 2; ...;
 113 ! Also, take some margin as the current float parsing algorithm
 114 ! does some rounding; For example,
 115 ! 0x1.0p-1074 is the smallest IE754 double, but floats down to
 116 ! 0x0.fffffffffffffcp-1074 are parsed as 0x1.0p-1074
 117 CONSTANT: max-magnitude-10 309
 118 CONSTANT: min-magnitude-10 -323
 119 CONSTANT: max-magnitude-2 1027
 120 CONSTANT: min-magnitude-2 -1074
 121
 122 : make-float-dec-exponent ( float-parse n/f -- float/f )
 123     over [ exponent>> ] [ magnitude>> ] bi +
 124     {
 125         { [ dup max-magnitude-10 > ] [ 3drop 1/0. ] }
 126         { [ dup min-magnitude-10 < ] [ 3drop 0.0 ] }
 127         [ drop
 128             [ [ radix>> ] [ point>> ] [ exponent>> ] tri - (pow) ]
 129             [ swap /f ] bi*
 130         ]
 131     } cond ; inline
 132
 133 : base2-digits ( digits radix -- digits' )
 134     {
 135         { 16 [ 4 * ] }
 136         { 8  [ 3 * ] }
 137         { 2  [ ] }
 138     } case ; inline
 139
 140 : base2-point ( float-parse -- point )
 141     [ point>> ] [ radix>> ] bi base2-digits ; inline
 142
 143 : base2-magnitude ( float-parse -- point )
 144     [ magnitude>> ] [ radix>> ] bi base2-digits ; inline
 145
 146 : make-float-bin-exponent ( float-parse n/f -- float/f )
 147     over [ exponent>> ] [ base2-magnitude ] bi +
 148     {
 149         { [ dup max-magnitude-2 > ] [ 3drop 1/0. ] }
 150         { [ dup min-magnitude-2 < ] [ 3drop 0.0 ] }
 151         [ drop
 152             [ [ drop 2 ] [ base2-point ] [ exponent>> ] tri - (pow) ]
 153             [ swap /f ] bi*
 154         ]
 155     } cond ; inline
 156
 157 : ?default-exponent ( float-parse n/f -- float-parse' n/f' )
 158     over exponent>> [
 159         over radix>> 10 = [ 0 store-exponent ] [ drop f ] if
 160     ] unless ; inline
 161
 162 : ?make-float ( float-parse n/f -- float/f )
 163     { float-parse object } declare
 164     ?default-exponent
 165     {
 166         { [ dup not ] [ 2drop f ] }
 167         { [ over radix>> 10 = ] [ make-float-dec-exponent ] }
 168         [ make-float-bin-exponent ]
 169     } cond ;
 170
 171 : ?neg ( n/f -- -n/f )
 172     [
 173         dup bignum? [
 174             dup first-bignum bignum=
 175             [ drop most-negative-fixnum ] [ neg ] if
 176         ] [ neg ] if
 177     ] [ f ] if* ; inline
 178
 179 : ?add-ratio ( m n/f -- m+n/f )
 180     dup ratio? [ + ] [ 2drop f ] if ; inline
 181
 182 : @abort ( i number-parse n x -- f )
 183     4drop f ; inline
 184
 185 : @split ( i number-parse n -- n i number-parse' n' )
 186     -rot 0 >>magnitude 0 ; inline
 187
 188 : @split-exponent ( i number-parse n -- n i number-parse' n' )
 189     -rot 10 >>radix 0 ; inline
 190
 191 : <float-parse> ( i number-parse n -- float-parse i number-parse n )
 192      [ drop nip [ radix>> ] [ magnitude>> ] bi [ 0 f ] dip float-parse boa ] 3keep ; inline
 193
 194 DEFER: @exponent-digit
 195 DEFER: @mantissa-digit
 196 DEFER: @denom-digit
 197 DEFER: @num-digit
 198 DEFER: @pos-digit
 199 DEFER: @neg-digit
 200
 201 : @exponent-digit-or-punc ( float-parse i number-parse n char -- float-parse n/f )
 202     {
 203         { CHAR: , [ [ @exponent-digit ] require-next-digit ] }
 204         [ @exponent-digit ]
 205     } case ; inline
 206
 207 : @exponent-digit ( float-parse i number-parse n char -- float-parse n/f )
 208     { float-parse fixnum number-parse integer fixnum } declare
 209     digit-in-radix [ [ @exponent-digit-or-punc ] add-exponent-digit ] [ @abort ] if ;
 210
 211 : @exponent-first-char ( float-parse i number-parse n char -- float-parse n/f )
 212     {
 213         { CHAR: - [ [ @exponent-digit ] require-next-digit ?neg ] }
 214         { CHAR: + [ [ @exponent-digit ] require-next-digit ] }
 215         [ @exponent-digit ]
 216     } case ; inline
 217
 218 : ->exponent ( float-parse i number-parse n -- float-parse' n/f )
 219     @split-exponent [ @exponent-first-char ] require-next-digit ?store-exponent ; inline
 220
 221 : exponent-char? ( number-parse n char -- number-parse n char ? )
 222     pick radix>> {
 223         { 10 [ dup "eE" member-eq? ] }
 224         [ drop dup "pP" member-eq? ]
 225     } case ; inline
 226
 227 : or-exponent ( i number-parse n char quot -- n/f )
 228     [ exponent-char? [ drop <float-parse> ->exponent ?make-float ] ] dip if ; inline
 229
 230 : or-mantissa->exponent ( float-parse i number-parse n char quot -- float-parse n/f )
 231     [ exponent-char? [ drop ->exponent ] ] dip if ; inline
 232
 233 : @mantissa-digit-or-punc ( float-parse i number-parse n char -- float-parse n/f )
 234     {
 235         { CHAR: , [ [ @mantissa-digit ] require-next-digit ] }
 236         [ @mantissa-digit ]
 237     } case ; inline
 238
 239 : @mantissa-digit ( float-parse i number-parse n char -- float-parse n/f )
 240     { float-parse fixnum number-parse integer fixnum } declare
 241     [
 242         digit-in-radix
 243         [ [ @mantissa-digit-or-punc ] add-mantissa-digit ]
 244         [ @abort ] if
 245     ] or-mantissa->exponent ;
 246
 247 : ->mantissa ( i number-parse n -- n/f )
 248     <float-parse> [ @mantissa-digit ] next-digit ?make-float ; inline
 249
 250 : ->required-mantissa ( i number-parse n -- n/f )
 251     <float-parse> [ @mantissa-digit ] require-next-digit ?make-float ; inline
 252
 253 : @denom-digit-or-punc ( i number-parse n char -- n/f )
 254     {
 255         { CHAR: , [ [ @denom-digit ] require-next-digit ] }
 256         { CHAR: . [ ->mantissa ] }
 257         [ [ @denom-digit ] or-exponent ]
 258     } case ; inline
 259
 260 : @denom-digit ( i number-parse n char -- n/f )
 261     { fixnum number-parse integer fixnum } declare
 262     digit-in-radix [ [ @denom-digit-or-punc ] add-digit ] [ @abort ] if ;
 263
 264 : @denom-first-digit ( i number-parse n char -- n/f )
 265     {
 266         { CHAR: . [ ->mantissa ] }
 267         [ @denom-digit ]
 268     } case ; inline
 269
 270 : ->denominator ( i number-parse n -- n/f )
 271     { fixnum number-parse integer } declare
 272     @split [ @denom-first-digit ] require-next-digit ?make-ratio ;
 273
 274 : @num-digit-or-punc ( i number-parse n char -- n/f )
 275     {
 276         { CHAR: , [ [ @num-digit ] require-next-digit ] }
 277         { CHAR: / [ ->denominator ] }
 278         [ @num-digit ]
 279     } case ; inline
 280
 281 : @num-digit ( i number-parse n char -- n/f )
 282     { fixnum number-parse integer fixnum } declare
 283     digit-in-radix [ [ @num-digit-or-punc ] add-digit ] [ @abort ] if ;
 284
 285 : ->numerator ( i number-parse n -- n/f )
 286     { fixnum number-parse integer } declare
 287     @split [ @num-digit ] require-next-digit ?add-ratio ;
 288
 289 : @pos-digit-or-punc ( i number-parse n char -- n/f )
 290     {
 291         { CHAR: , [ [ @pos-digit ] require-next-digit ] }
 292         { CHAR: + [ ->numerator ] }
 293         { CHAR: / [ ->denominator ] }
 294         { CHAR: . [ ->mantissa ] }
 295         [ [ @pos-digit ] or-exponent ]
 296     } case ; inline
 297
 298 : @pos-digit ( i number-parse n char -- n/f )
 299     { fixnum number-parse integer fixnum } declare
 300     digit-in-radix [ [ @pos-digit-or-punc ] add-digit ] [ @abort ] if ;
 301
 302 : ->radix ( i number-parse n quot radix -- i number-parse n quot )
 303     [ >>radix ] curry 2dip ; inline
 304
 305 : with-radix-char ( i number-parse n radix-quot nonradix-quot -- n/f )
 306     [
 307         rot {
 308             { CHAR: b [ drop  2 ->radix require-next-digit ] }
 309             { CHAR: o [ drop  8 ->radix require-next-digit ] }
 310             { CHAR: x [ drop 16 ->radix require-next-digit ] }
 311             [ [ drop ] 2dip swap call ]
 312         } case
 313     ] 2curry next-digit ; inline
 314
 315 : @pos-first-digit ( i number-parse n char -- n/f )
 316     {
 317         { CHAR: . [ ->required-mantissa ] }
 318         { CHAR: 0 [ [ @pos-digit ] [ @pos-digit-or-punc ] with-radix-char ] }
 319         [ @pos-digit ]
 320     } case ; inline
 321
 322 : @neg-digit-or-punc ( i number-parse n char -- n/f )
 323     {
 324         { CHAR: , [ [ @neg-digit ] require-next-digit ] }
 325         { CHAR: - [ ->numerator ] }
 326         { CHAR: / [ ->denominator ] }
 327         { CHAR: . [ ->mantissa ] }
 328         [ [ @neg-digit ] or-exponent ]
 329     } case ; inline
 330
 331 : @neg-digit ( i number-parse n char -- n/f )
 332     { fixnum number-parse integer fixnum } declare
 333     digit-in-radix [ [ @neg-digit-or-punc ] add-digit ] [ @abort ] if ;
 334
 335 : @neg-first-digit ( i number-parse n char -- n/f )
 336     {
 337         { CHAR: . [ ->required-mantissa ] }
 338         { CHAR: 0 [ [ @neg-digit ] [ @neg-digit-or-punc ] with-radix-char ] }
 339         [ @neg-digit ]
 340     } case ; inline
 341
 342 : @first-char ( i number-parse n char -- n/f )
 343     {
 344         { CHAR: - [ [ @neg-first-digit ] require-next-digit ?neg ] }
 345         { CHAR: + [ [ @pos-first-digit ] require-next-digit ] }
 346         [ @pos-first-digit ]
 347     } case ; inline
 348
 349 : @neg-first-digit-no-radix ( i number-parse n char -- n/f )
 350     {
 351         { CHAR: . [ ->required-mantissa ] }
 352         [ @neg-digit ]
 353     } case ; inline
 354
 355 : @pos-first-digit-no-radix ( i number-parse n char -- n/f )
 356     {
 357         { CHAR: . [ ->required-mantissa ] }
 358         [ @pos-digit ]
 359     } case ; inline
 360
 361 : @first-char-no-radix ( i number-parse n char -- n/f )
 362     {
 363         { CHAR: - [ [ @neg-first-digit-no-radix ] require-next-digit ?neg ] }
 364         { CHAR: + [ [ @pos-first-digit-no-radix ] require-next-digit ] }
 365         [ @pos-first-digit-no-radix ]
 366     } case ; inline
 367
 368 PRIVATE>
 369
 370 : string>number ( str -- n/f )
 371     10 <number-parse> [ @first-char ] require-next-digit ;
 372
 373 : base> ( str radix -- n/f )
 374     <number-parse> [ @first-char-no-radix ] require-next-digit ;
 375
 376 : bin> ( str -- n/f )  2 base> ; inline
 377 : oct> ( str -- n/f )  8 base> ; inline
 378 : dec> ( str -- n/f ) 10 base> ; inline
 379 : hex> ( str -- n/f ) 16 base> ; inline
 380
 381 <PRIVATE
 382
 383 CONSTANT: TENS B{
 384     48 48 48 48 48 48 48 48 48 48 49 49 49 49 49 49 49 49 49 49
 385     50 50 50 50 50 50 50 50 50 50 51 51 51 51 51 51 51 51 51 51
 386     52 52 52 52 52 52 52 52 52 52 53 53 53 53 53 53 53 53 53 53
 387     54 54 54 54 54 54 54 54 54 54 55 55 55 55 55 55 55 55 55 55
 388     56 56 56 56 56 56 56 56 56 56 57 57 57 57 57 57 57 57 57 57
 389 }
 390
 391 CONSTANT: ONES B{
 392     48 49 50 51 52 53 54 55 56 57 48 49 50 51 52 53 54 55 56 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 }
 398
 399 : (two-digit) ( num accum -- num' accum )
 400     [
 401         100 /mod [ TENS nth-unsafe ] [ ONES nth-unsafe ] bi
 402     ] dip [ push ] keep [ push ] keep ; inline
 403
 404 : (one-digit) ( num accum -- num' accum )
 405     [ 10 /mod CHAR: 0 + ] dip [ push ] keep ; inline
 406
 407 : (bignum>dec) ( num accum -- num' accum )
 408     [ over most-positive-fixnum > ]
 409     [ { bignum sbuf } declare (two-digit) ] while
 410     [ >fixnum ] dip ; inline
 411
 412 : (fixnum>dec) ( num accum -- num' accum )
 413     { fixnum sbuf } declare
 414     [ over 10 >= ] [ (two-digit) ] while
 415     [ over zero? ] [ (one-digit) ] until ; inline
 416
 417 GENERIC: (positive>dec) ( num -- str )
 418
 419 M: bignum (positive>dec)
 420     12 <sbuf> (bignum>dec) (fixnum>dec) "" like reverse! nip ; inline
 421
 422 : (count-digits) ( digits n -- digits' )
 423     {
 424         { [ dup 10 < ] [ drop ] }
 425         { [ dup 100 < ] [ drop 1 fixnum+fast ] }
 426         { [ dup 1,000 < ] [ drop 2 fixnum+fast ] }
 427         [
 428             dup 1,000,000,000,000 < [
 429                 dup 100,000,000 < [
 430                     dup 1,000,000 < [
 431                         dup 10,000 < [
 432                             drop 3
 433                         ] [
 434                             100,000 >= 5 4 ?
 435                         ] if
 436                     ] [
 437                         10,000,000 >= 7 6 ?
 438                     ] if
 439                 ] [
 440                     dup 10,000,000,000 < [
 441                         1,000,000,000 >= 9 8 ?
 442                     ] [
 443                         100,000,000,000 >= 11 10 ?
 444                     ] if
 445                 ] if fixnum+fast
 446             ] [
 447                 [ 12 fixnum+fast ] [ 1,000,000,000,000 /i ] bi*
 448                 (count-digits)
 449             ] if
 450         ]
 451     } cond ; inline recursive
 452
 453 M: fixnum (positive>dec)
 454     1 over (count-digits) <sbuf> (fixnum>dec) "" like reverse! nip ; inline
 455
 456 : (positive>base) ( num radix -- str )
 457     dup 1 <= [ throw-invalid-radix ] when
 458     [ dup 0 > ] swap [ /mod >digit ] curry "" produce-as nip
 459     reverse! ; inline
 460
 461 : positive>base ( num radix -- str )
 462     dup 10 = [ drop (positive>dec) ] [ (positive>base) ] if ; inline
 463
 464 PRIVATE>
 465
 466 GENERIC# >base 1 ( n radix -- str )
 467
 468 : number>string ( n -- str ) 10 >base ; inline
 469
 470 : >bin ( n -- str ) 2 >base ; inline
 471 : >oct ( n -- str ) 8 >base ; inline
 472 : >hex ( n -- str ) 16 >base ; inline
 473
 474 M: integer >base
 475     {
 476         { [ over 0 = ] [ 2drop "0" ] }
 477         { [ over 0 > ] [ positive>base ] }
 478         [ [ neg ] dip positive>base CHAR: - prefix ]
 479     } cond ;
 480
 481 M: ratio >base
 482     [ >fraction [ /mod ] keep ] [ [ >base ] curry tri@ ] bi*
 483     "/" glue over first-unsafe {
 484         { CHAR: 0 [ nip ] }
 485         { CHAR: - [ append ] }
 486         [ drop "+" glue ]
 487     } case ;
 488
 489 <PRIVATE
 490
 491 : fix-float ( str -- newstr )
 492     CHAR: e over index [
 493         cut [ fix-float ] dip append
 494     ] [
 495         CHAR: . over member? [ ".0" append ] unless
 496     ] if* ;
 497
 498 : mantissa-expt-normalize ( mantissa expt -- mantissa' expt' )
 499     [ dup log2 52 swap - [ shift 52 2^ 1 - bitand ] [ 1022 + neg ] bi ]
 500     [ 1023 - ] if-zero ;
 501
 502 : mantissa-expt ( float -- mantissa expt )
 503     [ 52 2^ 1 - bitand ]
 504     [ -0.0 double>bits bitnot bitand -52 shift ] bi
 505     mantissa-expt-normalize ;
 506
 507 : bin-float-sign ( bits -- str )
 508     -0.0 double>bits bitand zero? "" "-" ? ;
 509
 510 : bin-float-value ( str size -- str' )
 511     CHAR: 0 pad-head [ CHAR: 0 = ] trim-tail
 512     [ "0" ] when-empty "1." prepend ;
 513
 514 : float>hex-value ( mantissa -- str )
 515     >hex 13 bin-float-value ;
 516
 517 : float>oct-value ( mantissa -- str )
 518     4 * >oct 18 bin-float-value ;
 519
 520 : float>bin-value ( mantissa -- str )
 521     >bin 52 bin-float-value ;
 522
 523 : bin-float-expt ( mantissa -- str )
 524     10 >base "p" prepend ;
 525
 526 : (bin-float>base) ( value-quot n -- str )
 527     double>bits
 528     [ bin-float-sign swap ] [
 529         mantissa-expt rot [ bin-float-expt ] bi*
 530     ] bi 3append ; inline
 531
 532 : bin-float>base ( n base -- str )
 533     {
 534         { 16 [ [ float>hex-value ] swap (bin-float>base) ] }
 535         { 8  [ [ float>oct-value ] swap (bin-float>base) ] }
 536         { 2  [ [ float>bin-value ] swap (bin-float>base) ] }
 537         [ throw-invalid-radix ]
 538     } case ;
 539
 540 : format-string ( format -- format )
 541     0 suffix >byte-array ; foldable
 542
 543 : format-head ( byte-array n -- string )
 544     swap over 0 <string> [
 545         [
 546             [ [ nth-unsafe ] 2keep drop ]
 547             [ set-string-nth-fast ] bi*
 548         ] 2curry each-integer
 549     ] keep ; inline
 550
 551 : format-float ( n format -- string )
 552     format-string (format-float)
 553     dup [ 0 = ] find drop
 554     format-head fix-float ; inline
 555
 556 : float>base ( n radix -- str )
 557     {
 558         { 10 [ "%.16g" format-float ] }
 559         [ bin-float>base ]
 560     } case ; inline
 561
 562 PRIVATE>
 563
 564 M: float >base
 565     {
 566         { [ over fp-nan? ] [ 2drop "0/0." ] }
 567         { [ over 1/0. =  ] [ 2drop "1/0." ] }
 568         { [ over -1/0. = ] [ 2drop "-1/0." ] }
 569         { [ over  0.0 fp-bitwise= ] [ 2drop  "0.0" ] }
 570         { [ over -0.0 fp-bitwise= ] [ 2drop "-0.0" ] }
 571         [ float>base ]
 572     } cond ;
 573
 574 : # ( n -- ) number>string % ; inline