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 sbufs sequences sequences.private
   5 strings ;
   6 IN: math.parser
   7
   8 <PRIVATE
   9 PRIMITIVE: (format-float) ( n fill width precision format locale -- 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     ! don't use number= to allow 0. for "1/0."
  73     [ dup 0 = [ 2drop f ] [ / ] if ] [ drop f ] if* ; inline
  74
  75 TUPLE: float-parse
  76     { radix fixnum }
  77     { point fixnum }
  78     { exponent }
  79     { magnitude } ;
  80
  81 : inc-point-?dec-magnitude ( float-parse n -- float-parse' )
  82     zero? [ [ 1 fixnum-fast ] change-magnitude ] when
  83     [ 1 fixnum+fast ] change-point ; inline
  84
  85 : store-exponent ( float-parse n expt -- float-parse' n )
  86     swap [ >>exponent ] dip ; inline
  87
  88 : ?store-exponent ( float-parse n expt/f -- float-parse' n/f )
  89     [ store-exponent ] [ drop f ] if* ; inline
  90
  91 : pow-until ( base x -- base^x )
  92     [ 1 ] 2dip [
  93         dup odd? [ [ [ * ] keep ] [ 1 - ] bi* ] when
  94         [ sq ] [ 2/ ] bi*
  95     ] until-zero drop ; inline
  96
  97 : (pow) ( base x -- base^x )
  98     integer>fixnum-strict
  99     dup 0 >= [ pow-until ] [ [ recip ] [ neg ] bi* pow-until ] if ; inline
 100
 101 : add-mantissa-digit ( float-parse i number-parse n digit quot -- float-parse' n/f )
 102     [ (add-digit)
 103         dup [ inc-point-?dec-magnitude ] curry 3dip
 104     ] dip next-digit ; inline
 105
 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
 122
 123 : make-float-dec-exponent ( float-parse n/f -- float/f )
 124     over [ exponent>> ] [ magnitude>> ] bi +
 125     {
 126         { [ dup max-magnitude-10 > ] [ 3drop 1/0. ] }
 127         { [ dup min-magnitude-10 < ] [ 3drop 0.0 ] }
 128         [ drop
 129             [ [ radix>> ] [ point>> ] [ exponent>> ] tri - (pow) ]
 130             [ swap /f ] bi*
 131         ]
 132     } cond ; inline
 133
 134 : base2-digits ( digits radix -- digits' )
 135     {
 136         { 16 [ 4 * ] }
 137         { 8  [ 3 * ] }
 138         { 2  [ ] }
 139     } case ; inline
 140
 141 : base2-point ( float-parse -- point )
 142     [ point>> ] [ radix>> ] bi base2-digits ; inline
 143
 144 : base2-magnitude ( float-parse -- point )
 145     [ magnitude>> ] [ radix>> ] bi base2-digits ; inline
 146
 147 : make-float-bin-exponent ( float-parse n/f -- float/f )
 148     over [ exponent>> ] [ base2-magnitude ] bi +
 149     {
 150         { [ dup max-magnitude-2 > ] [ 3drop 1/0. ] }
 151         { [ dup min-magnitude-2 < ] [ 3drop 0.0 ] }
 152         [ drop
 153             [ [ drop 2 ] [ base2-point ] [ exponent>> ] tri - (pow) ]
 154             [ swap /f ] bi*
 155         ]
 156     } cond ; inline
 157
 158 : ?default-exponent ( float-parse n/f -- float-parse' n/f' )
 159     over exponent>> [
 160         over radix>> 10 = [ 0 store-exponent ] [ drop f ] if
 161     ] unless ; inline
 162
 163 : ?make-float ( float-parse n/f -- float/f )
 164     { float-parse object } declare
 165     ?default-exponent
 166     {
 167         { [ dup not ] [ 2drop f ] }
 168         { [ over radix>> 10 = ] [ make-float-dec-exponent ] }
 169         [ make-float-bin-exponent ]
 170     } cond ;
 171
 172 : bignum-?neg ( n -- -n )
 173     dup first-bignum bignum= [ drop most-negative-fixnum ] [ neg ] if ;
 174
 175 : fp-?neg ( n -- -n )
 176     double>bits 63 2^ bitor bits>double ;
 177
 178 : ?neg ( n/f -- -n/f )
 179     [
 180         {
 181             { [ dup bignum? ] [ bignum-?neg ] }
 182             { [ dup fp-nan? ] [ fp-?neg ] }
 183             [ neg ]
 184         } cond
 185     ] [ f ] if* ; inline
 186
 187 : ?pos ( n/f -- +n/f )
 188     dup fp-nan? [
 189         double>bits 63 2^ bitnot bitand bits>double
 190     ] when ; inline
 191
 192 : add-ratio? ( n/f -- ? )
 193     dup real? [ dup >integer number= not ] [ drop f ] if ;
 194
 195 : ?add-ratio ( m n/f -- m+n/f )
 196     dup add-ratio? [ + ] [ 2drop f ] if ; inline
 197
 198 : @abort ( i number-parse n x -- f )
 199     4drop f ; inline
 200
 201 : @split ( i number-parse n -- n i number-parse' n' )
 202     -rot 0 >>magnitude 0 ; inline
 203
 204 : @split-exponent ( i number-parse n -- n i number-parse' n' )
 205     -rot 10 >>radix 0 ; inline
 206
 207 : <float-parse> ( i number-parse n -- float-parse i number-parse n )
 208      [ drop nip [ radix>> ] [ magnitude>> ] bi [ 0 f ] dip float-parse boa ] 3keep ; inline
 209
 210 : if-skip ( char true false -- )
 211     pick ",_" member-eq? [ drop nip call ] [ nip call ] if ; inline
 212
 213 DEFER: @exponent-digit
 214 DEFER: @mantissa-digit
 215 DEFER: @denom-digit
 216 DEFER: @num-digit
 217 DEFER: @pos-digit
 218 DEFER: @neg-digit
 219
 220 : @exponent-digit-or-punc ( float-parse i number-parse n char -- float-parse n/f )
 221     [ [ @exponent-digit ] require-next-digit ] [ @exponent-digit ] if-skip ; inline
 222
 223 : @exponent-digit ( float-parse i number-parse n char -- float-parse n/f )
 224     { float-parse fixnum number-parse integer fixnum } declare
 225     digit-in-radix [ [ @exponent-digit-or-punc ] add-exponent-digit ] [ @abort ] if ;
 226
 227 : @exponent-first-char ( float-parse i number-parse n char -- float-parse n/f )
 228     {
 229         { CHAR: - [ [ @exponent-digit ] require-next-digit ?neg ] }
 230         { CHAR: + [ [ @exponent-digit ] require-next-digit ?pos ] }
 231         [ @exponent-digit ?pos ]
 232     } case ; inline
 233
 234 : ->exponent ( float-parse i number-parse n -- float-parse' n/f )
 235     @split-exponent [ @exponent-first-char ] require-next-digit ?store-exponent ; inline
 236
 237 : exponent-char? ( number-parse n char -- number-parse n char ? )
 238     pick radix>> {
 239         { 10 [ dup "eE" member-eq? ] }
 240         [ drop dup "pP" member-eq? ]
 241     } case ; inline
 242
 243 : or-exponent ( i number-parse n char quot -- n/f )
 244     [ exponent-char? [ drop <float-parse> ->exponent ?make-float ] ] dip if ; inline
 245
 246 : or-mantissa->exponent ( float-parse i number-parse n char quot -- float-parse n/f )
 247     [ exponent-char? [ drop ->exponent ] ] dip if ; inline
 248
 249 : @mantissa-digit-or-punc ( float-parse i number-parse n char -- float-parse n/f )
 250     [ [ @mantissa-digit ] require-next-digit ] [ @mantissa-digit ] if-skip ; inline
 251
 252 : @mantissa-digit ( float-parse i number-parse n char -- float-parse n/f )
 253     { float-parse fixnum number-parse integer fixnum } declare
 254     [
 255         digit-in-radix
 256         [ [ @mantissa-digit-or-punc ] add-mantissa-digit ]
 257         [ @abort ] if
 258     ] or-mantissa->exponent ;
 259
 260 : ->mantissa ( i number-parse n -- n/f )
 261     <float-parse> [ @mantissa-digit ] next-digit ?make-float ; inline
 262
 263 : ->required-mantissa ( i number-parse n -- n/f )
 264     <float-parse> [ @mantissa-digit ] require-next-digit ?make-float ; inline
 265
 266 : @denom-digit-or-punc ( i number-parse n char -- n/f )
 267     [ [ @denom-digit ] require-next-digit ] [
 268         {
 269             { CHAR: . [ ->mantissa ] }
 270             [ [ @denom-digit ] or-exponent ]
 271         } case
 272     ] if-skip ; inline
 273
 274 : @denom-digit ( i number-parse n char -- n/f )
 275     { fixnum number-parse integer fixnum } declare
 276     digit-in-radix [ [ @denom-digit-or-punc ] add-digit ] [ @abort ] if ;
 277
 278 : @denom-first-digit ( i number-parse n char -- n/f )
 279     {
 280         { CHAR: . [ ->mantissa ] }
 281         [ @denom-digit ]
 282     } case ; inline
 283
 284 : ->denominator ( i number-parse n -- n/f )
 285     { fixnum number-parse integer } declare
 286     @split [ @denom-first-digit ] require-next-digit ?make-ratio ;
 287
 288 : @num-digit-or-punc ( i number-parse n char -- n/f )
 289     [ [ @num-digit ] require-next-digit ] [
 290         {
 291             { CHAR: / [ ->denominator ] }
 292             [ @num-digit ]
 293         } case
 294     ] if-skip ; inline
 295
 296 : @num-digit ( i number-parse n char -- n/f )
 297     { fixnum number-parse integer fixnum } declare
 298     digit-in-radix [ [ @num-digit-or-punc ] add-digit ] [ @abort ] if ;
 299
 300 : ->numerator ( i number-parse n -- n/f )
 301     { fixnum number-parse integer } declare
 302     @split [ @num-digit ] require-next-digit ?add-ratio ;
 303
 304 : @pos-digit-or-punc ( i number-parse n char -- n/f )
 305     [ [ @pos-digit ] require-next-digit ] [
 306         {
 307             { CHAR: + [ ->numerator ] }
 308             { CHAR: / [ ->denominator ] }
 309             { CHAR: . [ ->mantissa ] }
 310             [ [ @pos-digit ] or-exponent ]
 311         } case
 312     ] if-skip ; inline
 313
 314 : @pos-digit ( i number-parse n char -- n/f )
 315     { fixnum number-parse integer fixnum } declare
 316     digit-in-radix [ [ @pos-digit-or-punc ] add-digit ] [ @abort ] if ;
 317
 318 : ->radix ( i number-parse n quot radix -- i number-parse n quot )
 319     [ >>radix ] curry 2dip ; inline
 320
 321 : with-radix-char ( i number-parse n radix-quot nonradix-quot -- n/f )
 322     [
 323         rot {
 324             { [ dup "bB" member-eq? ] [ 2drop  2 ->radix require-next-digit ] }
 325             { [ dup "oO" member-eq? ] [ 2drop  8 ->radix require-next-digit ] }
 326             { [ dup "xX" member-eq? ] [ 2drop 16 ->radix require-next-digit ] }
 327             [ nipd swap call ]
 328         } cond
 329     ] 2curry next-digit ; inline
 330
 331 : @pos-first-digit ( i number-parse n char -- n/f )
 332     {
 333         { CHAR: . [ ->required-mantissa ] }
 334         { CHAR: 0 [ [ @pos-digit ] [ @pos-digit-or-punc ] with-radix-char ] }
 335         [ @pos-digit ]
 336     } case ; inline
 337
 338 : @neg-digit-or-punc ( i number-parse n char -- n/f )
 339     [ [ @neg-digit ] require-next-digit ] [
 340         {
 341             { CHAR: - [ ->numerator ] }
 342             { CHAR: / [ ->denominator ] }
 343             { CHAR: . [ ->mantissa ] }
 344             [ [ @neg-digit ] or-exponent ]
 345         } case
 346     ] if-skip ; inline
 347
 348 : @neg-digit ( i number-parse n char -- n/f )
 349     { fixnum number-parse integer fixnum } declare
 350     digit-in-radix [ [ @neg-digit-or-punc ] add-digit ] [ @abort ] if ;
 351
 352 : @neg-first-digit ( i number-parse n char -- n/f )
 353     {
 354         { CHAR: . [ ->required-mantissa ] }
 355         { CHAR: 0 [ [ @neg-digit ] [ @neg-digit-or-punc ] with-radix-char ] }
 356         [ @neg-digit ]
 357     } case ; inline
 358
 359 : @first-char ( i number-parse n char -- n/f )
 360     {
 361         { CHAR: - [ [ @neg-first-digit ] require-next-digit ?neg ] }
 362         { CHAR: + [ [ @pos-first-digit ] require-next-digit ?pos ] }
 363         [ @pos-first-digit ?pos ]
 364     } case ; inline
 365
 366 : @neg-first-digit-no-radix ( i number-parse n char -- n/f )
 367     {
 368         { CHAR: . [ ->required-mantissa ] }
 369         [ @neg-digit ]
 370     } case ; inline
 371
 372 : @pos-first-digit-no-radix ( i number-parse n char -- n/f )
 373     {
 374         { CHAR: . [ ->required-mantissa ] }
 375         [ @pos-digit ]
 376     } case ; inline
 377
 378 : @first-char-no-radix ( i number-parse n char -- n/f )
 379     {
 380         { CHAR: - [ [ @neg-first-digit-no-radix ] require-next-digit ?neg ] }
 381         { CHAR: + [ [ @pos-first-digit-no-radix ] require-next-digit ?pos ] }
 382         [ @pos-first-digit-no-radix ?pos ]
 383     } case ; inline
 384
 385 PRIVATE>
 386
 387 : string>number ( str -- n/f )
 388     10 <number-parse> [ @first-char ] require-next-digit ;
 389
 390 : base> ( str radix -- n/f )
 391     <number-parse> [ @first-char-no-radix ] require-next-digit ;
 392
 393 : bin> ( str -- n/f )  2 base> ; inline
 394 : oct> ( str -- n/f )  8 base> ; inline
 395 : dec> ( str -- n/f ) 10 base> ; inline
 396 : hex> ( str -- n/f ) 16 base> ; inline
 397
 398 <PRIVATE
 399
 400 CONSTANT: TENS B{
 401     48 48 48 48 48 48 48 48 48 48 49 49 49 49 49 49 49 49 49 49
 402     50 50 50 50 50 50 50 50 50 50 51 51 51 51 51 51 51 51 51 51
 403     52 52 52 52 52 52 52 52 52 52 53 53 53 53 53 53 53 53 53 53
 404     54 54 54 54 54 54 54 54 54 54 55 55 55 55 55 55 55 55 55 55
 405     56 56 56 56 56 56 56 56 56 56 57 57 57 57 57 57 57 57 57 57
 406 }
 407
 408 CONSTANT: ONES B{
 409     48 49 50 51 52 53 54 55 56 57 48 49 50 51 52 53 54 55 56 57
 410     48 49 50 51 52 53 54 55 56 57 48 49 50 51 52 53 54 55 56 57
 411     48 49 50 51 52 53 54 55 56 57 48 49 50 51 52 53 54 55 56 57
 412     48 49 50 51 52 53 54 55 56 57 48 49 50 51 52 53 54 55 56 57
 413     48 49 50 51 52 53 54 55 56 57 48 49 50 51 52 53 54 55 56 57
 414 }
 415
 416 : (two-digit) ( num accum -- num' accum )
 417     [
 418         100 /mod [ TENS nth-unsafe ] [ ONES nth-unsafe ] bi
 419     ] dip [ push ] keep [ push ] keep ; inline
 420
 421 : (one-digit) ( num accum -- num' accum )
 422     [ 10 /mod CHAR: 0 + ] dip [ push ] keep ; inline
 423
 424 : (bignum>dec) ( num accum -- num' accum )
 425     [ over most-positive-fixnum > ]
 426     [ { bignum sbuf } declare (two-digit) ] while
 427     [ >fixnum ] dip ; inline
 428
 429 : (fixnum>dec) ( num accum -- num' accum )
 430     { fixnum sbuf } declare
 431     [ over 10 >= ] [ (two-digit) ] while
 432     [ over zero? ] [ (one-digit) ] until ; inline
 433
 434 GENERIC: (positive>dec) ( num -- str )
 435
 436 M: bignum (positive>dec)
 437     12 <sbuf> (bignum>dec) (fixnum>dec) "" like reverse! nip ; inline
 438
 439 : (count-digits) ( digits n -- digits' )
 440     {
 441         { [ dup 10 < ] [ drop ] }
 442         { [ dup 100 < ] [ drop 1 fixnum+fast ] }
 443         { [ dup 1,000 < ] [ drop 2 fixnum+fast ] }
 444         [
 445             dup 1,000,000,000,000 < [
 446                 dup 100,000,000 < [
 447                     dup 1,000,000 < [
 448                         dup 10,000 < [
 449                             drop 3
 450                         ] [
 451                             100,000 >= 5 4 ?
 452                         ] if
 453                     ] [
 454                         10,000,000 >= 7 6 ?
 455                     ] if
 456                 ] [
 457                     dup 10,000,000,000 < [
 458                         1,000,000,000 >= 9 8 ?
 459                     ] [
 460                         100,000,000,000 >= 11 10 ?
 461                     ] if
 462                 ] if fixnum+fast
 463             ] [
 464                 [ 12 fixnum+fast ] [ 1,000,000,000,000 /i ] bi*
 465                 (count-digits)
 466             ] if
 467         ]
 468     } cond ; inline recursive
 469
 470 M: fixnum (positive>dec)
 471     1 over (count-digits) <sbuf> (fixnum>dec) "" like reverse! nip ; inline
 472
 473 : (positive>base) ( num radix -- str )
 474     dup 1 <= [ invalid-radix ] when
 475     [ dup 0 > ] swap [ /mod >digit ] curry "" produce-as nip
 476     reverse! ; inline
 477
 478 : positive>base ( num radix -- str )
 479     dup 10 = [ drop (positive>dec) ] [ (positive>base) ] if ; inline
 480
 481 PRIVATE>
 482
 483 GENERIC#: >base 1 ( n radix -- str )
 484
 485 : number>string ( n -- str ) 10 >base ; inline
 486
 487 : >bin ( n -- str ) 2 >base ; inline
 488 : >oct ( n -- str ) 8 >base ; inline
 489 : >hex ( n -- str ) 16 >base ; inline
 490
 491 M: integer >base
 492     {
 493         { [ over 0 = ] [ 2drop "0" ] }
 494         { [ over 0 > ] [ positive>base ] }
 495         [ [ neg ] dip positive>base CHAR: - prefix ]
 496     } cond ;
 497
 498 M: ratio >base
 499     [ >fraction [ /mod ] keep ] [ [ >base ] curry tri@ ] bi*
 500     "/" glue over first-unsafe {
 501         { CHAR: 0 [ nip ] }
 502         { CHAR: - [ append ] }
 503         [ drop "+" glue ]
 504     } case ;
 505
 506 <PRIVATE
 507
 508 : (fix-float) ( str-no-exponent -- newstr )
 509     CHAR: . over member? [ ".0" append ] unless ; inline
 510
 511 : fix-float ( str exponent-char -- newstr )
 512     over index [
 513         cut [ (fix-float) ] dip append
 514     ] [ (fix-float) ] if* ; inline
 515
 516 : mantissa-expt-normalize ( mantissa expt -- mantissa' expt' )
 517     [ dup log2 52 swap - [ shift 52 2^ 1 - bitand ] [ 1022 + neg ] bi ]
 518     [ 1023 - ] if-zero ;
 519
 520 : mantissa-expt ( float -- mantissa expt )
 521     [ 52 2^ 1 - bitand ]
 522     [ -0.0 double>bits bitnot bitand -52 shift ] bi
 523     mantissa-expt-normalize ;
 524
 525 : bin-float-sign ( bits -- str )
 526     -0.0 double>bits bitand zero? "" "-" ? ;
 527
 528 : bin-float-value ( str size -- str' )
 529     CHAR: 0 pad-head [ CHAR: 0 = ] trim-tail
 530     [ "0" ] when-empty "1." prepend ;
 531
 532 : float>hex-value ( mantissa -- str )
 533     >hex 13 bin-float-value ;
 534
 535 : float>oct-value ( mantissa -- str )
 536     4 * >oct 18 bin-float-value ;
 537
 538 : float>bin-value ( mantissa -- str )
 539     >bin 52 bin-float-value ;
 540
 541 : bin-float-expt ( mantissa -- str )
 542     10 >base "p" prepend ;
 543
 544 : (bin-float>base) ( value-quot n -- str )
 545     double>bits
 546     [ bin-float-sign swap ] [
 547         mantissa-expt rot [ bin-float-expt ] bi*
 548     ] bi 3append ; inline
 549
 550 : bin-float>base ( n base -- str )
 551     {
 552         { 16 [ [ float>hex-value ] swap (bin-float>base) ] }
 553         { 8  [ [ float>oct-value ] swap (bin-float>base) ] }
 554         { 2  [ [ float>bin-value ] swap (bin-float>base) ] }
 555         [ invalid-radix ]
 556     } case ;
 557
 558 : format-string ( format -- format )
 559     0 suffix >byte-array ; foldable
 560
 561 : format-float ( n fill width precision format locale -- string )
 562     [
 563         [ format-string ] 4dip [ format-string ] bi@ (format-float)
 564         >string
 565     ] [
 566         "C" = [ [ "G" = ] [ "E" = ] bi or CHAR: E CHAR: e ? fix-float ]
 567         [ drop ] if
 568     ] 2bi ; inline
 569
 570 : float>base ( n radix -- str )
 571     {
 572         { 10 [ "" -1 16 "" "C" format-float ] }
 573         [ bin-float>base ]
 574     } case ; inline
 575
 576 PRIVATE>
 577
 578 M: float >base
 579     {
 580         { [ over fp-nan? ] [ drop fp-sign "-0/0." "0/0." ? ] }
 581         { [ over 1/0. =  ] [ 2drop "1/0." ] }
 582         { [ over -1/0. = ] [ 2drop "-1/0." ] }
 583         { [ over  0.0 fp-bitwise= ] [ 2drop  "0.0" ] }
 584         { [ over -0.0 fp-bitwise= ] [ 2drop "-0.0" ] }
 585         [ float>base ]
 586     } cond ;
 587
 588 : # ( n -- ) number>string % ; inline
 589
 590 : hex-string>bytes ( hex-string -- bytes )
 591     dup length 2/ <byte-array> [
 592         [
 593             [ digit> ] 2dip over even? [
 594                 [ 16 * ] [ 2/ ] [ set-nth ] tri*
 595             ] [
 596                 [ 2/ ] [ [ + ] change-nth ] bi*
 597             ] if
 598         ] curry each-index
 599     ] keep ;
 600
 601 : bytes>hex-string ( bytes -- hex-string )
 602     dup length 2 * CHAR: 0 <string> [
 603         [
 604             [ 16 /mod [ >digit ] bi@ ]
 605             [ 2 * dup 1 + ]
 606             [ [ set-nth ] curry bi-curry@ bi* ] tri*
 607         ] curry each-index
 608     ] keep ;