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 layouts
   4 make math math.private sbufs sequences sequences.private strings ;
   5 IN: math.parser
   6
   7 <PRIVATE
   8 PRIMITIVE: (format-float) ( n fill width precision format locale -- byte-array )
   9 PRIVATE>
  10
  11 : digit> ( ch -- n )
  12     {
  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 ]
  16     } cond ; inline
  17
  18 : string>digits ( str -- digits )
  19     [ digit> ] B{ } map-as ; inline
  20
  21 : >digit ( n -- ch )
  22     dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] if ; inline
  23
  24 ERROR: invalid-radix radix ;
  25
  26 <PRIVATE
  27
  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.
  33 TUPLE: number-parse
  34     { str read-only }
  35     { length fixnum read-only }
  36     { radix fixnum }
  37     { magnitude fixnum } ;
  38
  39 : <number-parse> ( str radix -- i number-parse n )
  40     [ 0 ] 2dip [ dup length ] dip 0 number-parse boa 0 ; inline
  41
  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
  45
  46 : require-next-digit ( i number-parse n quot -- n/f )
  47     [ 3drop f ] (next-digit) ; inline
  48
  49 : next-digit ( i number-parse n quot -- n/f )
  50     [ 2nip ] (next-digit) ; inline
  51
  52 : inc-magnitude ( number-parse -- number-parse' )
  53     [ 1 fixnum+fast ] change-magnitude ; inline
  54
  55 : ?inc-magnitude ( number-parse n -- number-parse' )
  56     zero? [ inc-magnitude ] unless ; inline
  57
  58 : (add-digit) ( number-parse n digit -- number-parse n' )
  59     [ dup radix>> ] [ * ] [ + ] tri* ; inline
  60
  61 : add-digit ( i number-parse n digit quot -- n/f )
  62     [ (add-digit) [ ?inc-magnitude ] keep ] dip next-digit ; inline
  63
  64 : add-exponent-digit ( i number-parse n digit quot -- n/f )
  65     [ (add-digit) ] dip next-digit ; inline
  66
  67 : digit-in-radix ( number-parse n char -- number-parse n digit ? )
  68     digit> pick radix>> over > ; inline
  69
  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
  73
  74 TUPLE: float-parse
  75     { radix fixnum }
  76     { point fixnum }
  77     { exponent }
  78     { magnitude } ;
  79
  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
  83
  84 : store-exponent ( float-parse n expt -- float-parse' n )
  85     swap [ >>exponent ] dip ; inline
  86
  87 : ?store-exponent ( float-parse n expt/f -- float-parse' n/f )
  88     [ store-exponent ] [ drop f ] if* ; inline
  89
  90 : pow-until ( base x -- base^x )
  91     [ 1 ] 2dip
  92     [ dup zero? ] [
  93         dup odd? [ [ [ * ] keep ] [ 1 - ] bi* ] when
  94         [ sq ] [ 2/ ] bi*
  95     ] until 2drop ; 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 : ?neg ( n/f -- -n/f )
 173     [
 174         dup bignum? [
 175             dup first-bignum bignum=
 176             [ drop most-negative-fixnum ] [ neg ] if
 177         ] [ neg ] if
 178     ] [ f ] if* ; inline
 179
 180 : ?add-ratio ( m n/f -- m+n/f )
 181     dup ratio? [ + ] [ 2drop f ] if ; inline
 182
 183 : @abort ( i number-parse n x -- f )
 184     4drop f ; inline
 185
 186 : @split ( i number-parse n -- n i number-parse' n' )
 187     -rot 0 >>magnitude 0 ; inline
 188
 189 : @split-exponent ( i number-parse n -- n i number-parse' n' )
 190     -rot 10 >>radix 0 ; inline
 191
 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
 194
 195 DEFER: @exponent-digit
 196 DEFER: @mantissa-digit
 197 DEFER: @denom-digit
 198 DEFER: @num-digit
 199 DEFER: @pos-digit
 200 DEFER: @neg-digit
 201
 202 : @exponent-digit-or-punc ( float-parse i number-parse n char -- float-parse n/f )
 203     {
 204         { CHAR: , [ [ @exponent-digit ] require-next-digit ] }
 205         [ @exponent-digit ]
 206     } case ; inline
 207
 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 ;
 211
 212 : @exponent-first-char ( float-parse i number-parse n char -- float-parse n/f )
 213     {
 214         { CHAR: - [ [ @exponent-digit ] require-next-digit ?neg ] }
 215         { CHAR: + [ [ @exponent-digit ] require-next-digit ] }
 216         [ @exponent-digit ]
 217     } case ; inline
 218
 219 : ->exponent ( float-parse i number-parse n -- float-parse' n/f )
 220     @split-exponent [ @exponent-first-char ] require-next-digit ?store-exponent ; inline
 221
 222 : exponent-char? ( number-parse n char -- number-parse n char ? )
 223     pick radix>> {
 224         { 10 [ dup "eE" member-eq? ] }
 225         [ drop dup "pP" member-eq? ]
 226     } case ; inline
 227
 228 : or-exponent ( i number-parse n char quot -- n/f )
 229     [ exponent-char? [ drop <float-parse> ->exponent ?make-float ] ] dip if ; inline
 230
 231 : or-mantissa->exponent ( float-parse i number-parse n char quot -- float-parse n/f )
 232     [ exponent-char? [ drop ->exponent ] ] dip if ; inline
 233
 234 : @mantissa-digit-or-punc ( float-parse i number-parse n char -- float-parse n/f )
 235     {
 236         { CHAR: , [ [ @mantissa-digit ] require-next-digit ] }
 237         [ @mantissa-digit ]
 238     } case ; inline
 239
 240 : @mantissa-digit ( float-parse i number-parse n char -- float-parse n/f )
 241     { float-parse fixnum number-parse integer fixnum } declare
 242     [
 243         digit-in-radix
 244         [ [ @mantissa-digit-or-punc ] add-mantissa-digit ]
 245         [ @abort ] if
 246     ] or-mantissa->exponent ;
 247
 248 : ->mantissa ( i number-parse n -- n/f )
 249     <float-parse> [ @mantissa-digit ] next-digit ?make-float ; inline
 250
 251 : ->required-mantissa ( i number-parse n -- n/f )
 252     <float-parse> [ @mantissa-digit ] require-next-digit ?make-float ; inline
 253
 254 : @denom-digit-or-punc ( i number-parse n char -- n/f )
 255     {
 256         { CHAR: , [ [ @denom-digit ] require-next-digit ] }
 257         { CHAR: . [ ->mantissa ] }
 258         [ [ @denom-digit ] or-exponent ]
 259     } case ; inline
 260
 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 ;
 264
 265 : @denom-first-digit ( i number-parse n char -- n/f )
 266     {
 267         { CHAR: . [ ->mantissa ] }
 268         [ @denom-digit ]
 269     } case ; inline
 270
 271 : ->denominator ( i number-parse n -- n/f )
 272     { fixnum number-parse integer } declare
 273     @split [ @denom-first-digit ] require-next-digit ?make-ratio ;
 274
 275 : @num-digit-or-punc ( i number-parse n char -- n/f )
 276     {
 277         { CHAR: , [ [ @num-digit ] require-next-digit ] }
 278         { CHAR: / [ ->denominator ] }
 279         [ @num-digit ]
 280     } case ; inline
 281
 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 ;
 285
 286 : ->numerator ( i number-parse n -- n/f )
 287     { fixnum number-parse integer } declare
 288     @split [ @num-digit ] require-next-digit ?add-ratio ;
 289
 290 : @pos-digit-or-punc ( i number-parse n char -- n/f )
 291     {
 292         { CHAR: , [ [ @pos-digit ] require-next-digit ] }
 293         { CHAR: + [ ->numerator ] }
 294         { CHAR: / [ ->denominator ] }
 295         { CHAR: . [ ->mantissa ] }
 296         [ [ @pos-digit ] or-exponent ]
 297     } case ; inline
 298
 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 ;
 302
 303 : ->radix ( i number-parse n quot radix -- i number-parse n quot )
 304     [ >>radix ] curry 2dip ; inline
 305
 306 : with-radix-char ( i number-parse n radix-quot nonradix-quot -- n/f )
 307     [
 308         rot {
 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 ]
 313         } case
 314     ] 2curry next-digit ; inline
 315
 316 : @pos-first-digit ( i number-parse n char -- n/f )
 317     {
 318         { CHAR: . [ ->required-mantissa ] }
 319         { CHAR: 0 [ [ @pos-digit ] [ @pos-digit-or-punc ] with-radix-char ] }
 320         [ @pos-digit ]
 321     } case ; inline
 322
 323 : @neg-digit-or-punc ( i number-parse n char -- n/f )
 324     {
 325         { CHAR: , [ [ @neg-digit ] require-next-digit ] }
 326         { CHAR: - [ ->numerator ] }
 327         { CHAR: / [ ->denominator ] }
 328         { CHAR: . [ ->mantissa ] }
 329         [ [ @neg-digit ] or-exponent ]
 330     } case ; inline
 331
 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 ;
 335
 336 : @neg-first-digit ( i number-parse n char -- n/f )
 337     {
 338         { CHAR: . [ ->required-mantissa ] }
 339         { CHAR: 0 [ [ @neg-digit ] [ @neg-digit-or-punc ] with-radix-char ] }
 340         [ @neg-digit ]
 341     } case ; inline
 342
 343 : @first-char ( i number-parse n char -- n/f )
 344     {
 345         { CHAR: - [ [ @neg-first-digit ] require-next-digit ?neg ] }
 346         { CHAR: + [ [ @pos-first-digit ] require-next-digit ] }
 347         [ @pos-first-digit ]
 348     } case ; inline
 349
 350 : @neg-first-digit-no-radix ( i number-parse n char -- n/f )
 351     {
 352         { CHAR: . [ ->required-mantissa ] }
 353         [ @neg-digit ]
 354     } case ; inline
 355
 356 : @pos-first-digit-no-radix ( i number-parse n char -- n/f )
 357     {
 358         { CHAR: . [ ->required-mantissa ] }
 359         [ @pos-digit ]
 360     } case ; inline
 361
 362 : @first-char-no-radix ( i number-parse n char -- n/f )
 363     {
 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 ]
 367     } case ; inline
 368
 369 PRIVATE>
 370
 371 : string>number ( str -- n/f )
 372     10 <number-parse> [ @first-char ] require-next-digit ;
 373
 374 : base> ( str radix -- n/f )
 375     <number-parse> [ @first-char-no-radix ] require-next-digit ;
 376
 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
 381
 382 <PRIVATE
 383
 384 CONSTANT: TENS B{
 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
 390 }
 391
 392 CONSTANT: ONES B{
 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
 398 }
 399
 400 : (two-digit) ( num accum -- num' accum )
 401     [
 402         100 /mod [ TENS nth-unsafe ] [ ONES nth-unsafe ] bi
 403     ] dip [ push ] keep [ push ] keep ; inline
 404
 405 : (one-digit) ( num accum -- num' accum )
 406     [ 10 /mod CHAR: 0 + ] dip [ push ] keep ; inline
 407
 408 : (bignum>dec) ( num accum -- num' accum )
 409     [ over most-positive-fixnum > ]
 410     [ { bignum sbuf } declare (two-digit) ] while
 411     [ >fixnum ] dip ; inline
 412
 413 : (fixnum>dec) ( num accum -- num' accum )
 414     { fixnum sbuf } declare
 415     [ over 10 >= ] [ (two-digit) ] while
 416     [ over zero? ] [ (one-digit) ] until ; inline
 417
 418 GENERIC: (positive>dec) ( num -- str )
 419
 420 M: bignum (positive>dec)
 421     12 <sbuf> (bignum>dec) (fixnum>dec) "" like reverse! nip ; inline
 422
 423 : (count-digits) ( digits n -- digits' )
 424     {
 425         { [ dup 10 < ] [ drop ] }
 426         { [ dup 100 < ] [ drop 1 fixnum+fast ] }
 427         { [ dup 1,000 < ] [ drop 2 fixnum+fast ] }
 428         [
 429             dup 1,000,000,000,000 < [
 430                 dup 100,000,000 < [
 431                     dup 1,000,000 < [
 432                         dup 10,000 < [
 433                             drop 3
 434                         ] [
 435                             100,000 >= 5 4 ?
 436                         ] if
 437                     ] [
 438                         10,000,000 >= 7 6 ?
 439                     ] if
 440                 ] [
 441                     dup 10,000,000,000 < [
 442                         1,000,000,000 >= 9 8 ?
 443                     ] [
 444                         100,000,000,000 >= 11 10 ?
 445                     ] if
 446                 ] if fixnum+fast
 447             ] [
 448                 [ 12 fixnum+fast ] [ 1,000,000,000,000 /i ] bi*
 449                 (count-digits)
 450             ] if
 451         ]
 452     } cond ; inline recursive
 453
 454 M: fixnum (positive>dec)
 455     1 over (count-digits) <sbuf> (fixnum>dec) "" like reverse! nip ; inline
 456
 457 : (positive>base) ( num radix -- str )
 458     dup 1 <= [ invalid-radix ] when
 459     [ dup 0 > ] swap [ /mod >digit ] curry "" produce-as nip
 460     reverse! ; inline
 461
 462 : positive>base ( num radix -- str )
 463     dup 10 = [ drop (positive>dec) ] [ (positive>base) ] if ; inline
 464
 465 PRIVATE>
 466
 467 GENERIC#: >base 1 ( n radix -- str )
 468
 469 : number>string ( n -- str ) 10 >base ; inline
 470
 471 : >bin ( n -- str ) 2 >base ; inline
 472 : >oct ( n -- str ) 8 >base ; inline
 473 : >hex ( n -- str ) 16 >base ; inline
 474
 475 M: integer >base
 476     {
 477         { [ over 0 = ] [ 2drop "0" ] }
 478         { [ over 0 > ] [ positive>base ] }
 479         [ [ neg ] dip positive>base CHAR: - prefix ]
 480     } cond ;
 481
 482 M: ratio >base
 483     [ >fraction [ /mod ] keep ] [ [ >base ] curry tri@ ] bi*
 484     "/" glue over first-unsafe {
 485         { CHAR: 0 [ nip ] }
 486         { CHAR: - [ append ] }
 487         [ drop "+" glue ]
 488     } case ;
 489
 490 <PRIVATE
 491
 492 : (fix-float) ( str-no-exponent -- newstr )
 493     CHAR: . over member? [ ".0" append ] unless ; inline
 494
 495 : fix-float ( str exponent-char -- newstr )
 496     over index [
 497         cut [ (fix-float) ] dip append
 498     ] [ (fix-float) ] if* ; inline
 499
 500 : mantissa-expt-normalize ( mantissa expt -- mantissa' expt' )
 501     [ dup log2 52 swap - [ shift 52 2^ 1 - bitand ] [ 1022 + neg ] bi ]
 502     [ 1023 - ] if-zero ;
 503
 504 : mantissa-expt ( float -- mantissa expt )
 505     [ 52 2^ 1 - bitand ]
 506     [ -0.0 double>bits bitnot bitand -52 shift ] bi
 507     mantissa-expt-normalize ;
 508
 509 : bin-float-sign ( bits -- str )
 510     -0.0 double>bits bitand zero? "" "-" ? ;
 511
 512 : bin-float-value ( str size -- str' )
 513     CHAR: 0 pad-head [ CHAR: 0 = ] trim-tail
 514     [ "0" ] when-empty "1." prepend ;
 515
 516 : float>hex-value ( mantissa -- str )
 517     >hex 13 bin-float-value ;
 518
 519 : float>oct-value ( mantissa -- str )
 520     4 * >oct 18 bin-float-value ;
 521
 522 : float>bin-value ( mantissa -- str )
 523     >bin 52 bin-float-value ;
 524
 525 : bin-float-expt ( mantissa -- str )
 526     10 >base "p" prepend ;
 527
 528 : (bin-float>base) ( value-quot n -- str )
 529     double>bits
 530     [ bin-float-sign swap ] [
 531         mantissa-expt rot [ bin-float-expt ] bi*
 532     ] bi 3append ; inline
 533
 534 : bin-float>base ( n base -- str )
 535     {
 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) ] }
 539         [ invalid-radix ]
 540     } case ;
 541
 542 : format-string ( format -- format )
 543     0 suffix >byte-array ; foldable
 544
 545 : format-float ( n fill width precision format locale -- string )
 546     [
 547         [ format-string ] 4dip [ format-string ] bi@ (format-float)
 548         >string
 549     ] [
 550         "C" = [ [ "G" = ] [ "E" = ] bi or CHAR: E CHAR: e ? fix-float ]
 551         [ drop ] if
 552     ] 2bi ; inline
 553
 554 : float>base ( n radix -- str )
 555     {
 556         { 10 [ "" -1 16 "" "C" format-float ] }
 557         [ bin-float>base ]
 558     } case ; inline
 559
 560 PRIVATE>
 561
 562 M: float >base
 563     {
 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" ] }
 569         [ float>base ]
 570     } cond ;
 571
 572 : # ( n -- ) number>string % ; inline
 573
 574 : hex-string>bytes ( hex-string -- bytes )
 575     dup length 2/ <byte-array> [
 576         [
 577             [ digit> ] 2dip over even? [
 578                 [ 16 * ] [ 2/ ] [ set-nth ] tri*
 579             ] [
 580                 [ 2/ ] [ [ + ] change-nth ] bi*
 581             ] if
 582         ] curry each-index
 583     ] keep ;
 584
 585 : bytes>hex-string ( bytes -- hex-string )
 586     dup length 2 * CHAR: 0 <string> [
 587         [
 588             [ 16 /mod [ >digit ] bi@ ]
 589             [ 2 * dup 1 + ]
 590             [ [ set-nth ] curry bi-curry@ bi* ] tri*
 591         ] curry each-index
 592     ] keep ;