core/math/parser/parser.factor

   1 ! Copyright (C) 2009 Joe Groff, 2013 John Benediktsson
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors byte-arrays combinators kernel kernel.private
   4 layouts make math math.order math.private sbufs sequences
   5 sequences.private strings ;
   6 IN: math.parser
   7
   8 : digit> ( ch -- n )
   9     {
  10         { [ dup CHAR: 9 <= ] [ CHAR: 0 -      dup  0 < [ drop 255 ] when ] }
  11         { [ dup CHAR: a <  ] [ CHAR: A 10 - - dup 10 < [ drop 255 ] when ] }
  12                              [ CHAR: a 10 - - dup 10 < [ drop 255 ] when ]
  13     } cond ; inline
  14
  15 : string>digits ( str -- digits )
  16     [ digit> ] B{ } map-as ; inline
  17
  18 : >digit ( n -- ch )
  19     dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] if ; inline
  20
  21 ERROR: invalid-radix radix ;
  22
  23 <PRIVATE
  24
  25 ! magnitude is used only for floats to avoid
  26 ! expensive computations when we know that
  27 ! the result will overflow/underflow.
  28 ! The computation of magnitude starts in
  29 ! number-parse and continues in float-parse.
  30 TUPLE: number-parse
  31     { str read-only }
  32     { length fixnum read-only }
  33     { radix fixnum }
  34     { magnitude fixnum } ;
  35
  36 : <number-parse> ( str radix -- i number-parse n )
  37     [ 0 ] 2dip [ dup length ] dip 0 number-parse boa 0 ; inline
  38
  39 : (next-digit) ( i number-parse n digit-quot end-quot -- n/f )
  40     [ 2over length>> < ] 2dip
  41     [ [ 2over str>> nth-unsafe >fixnum [ 1 fixnum+fast ] 3dip ] prepose ] dip if ; inline
  42
  43 : require-next-digit ( i number-parse n quot -- n/f )
  44     [ 3drop f ] (next-digit) ; inline
  45
  46 : next-digit ( i number-parse n quot -- n/f )
  47     [ 2nip ] (next-digit) ; inline
  48
  49 : inc-magnitude ( number-parse -- number-parse' )
  50     [ 1 fixnum+fast ] change-magnitude ; inline
  51
  52 : ?inc-magnitude ( number-parse n -- number-parse' )
  53     zero? [ inc-magnitude ] unless ; inline
  54
  55 : (add-digit) ( number-parse n digit -- number-parse n' )
  56     [ dup radix>> ] [ * ] [ + ] tri* ; inline
  57
  58 : add-digit ( i number-parse n digit quot -- n/f )
  59     [ (add-digit) [ ?inc-magnitude ] keep ] dip next-digit ; inline
  60
  61 : add-exponent-digit ( i number-parse n digit quot -- n/f )
  62     [ (add-digit) ] dip next-digit ; inline
  63
  64 : digit-in-radix ( number-parse n char -- number-parse n digit ? )
  65     digit> pick radix>> over > ; inline
  66
  67 : ?make-ratio ( num denom/f -- ratio/f )
  68     ! don't use number= to allow 0. for "1/0."
  69     [ dup 0 = [ 2drop f ] [ / ] if ] [ drop f ] if* ; inline
  70
  71 TUPLE: float-parse
  72     { radix fixnum }
  73     { point fixnum }
  74     { exponent }
  75     { magnitude } ;
  76
  77 : inc-point-?dec-magnitude ( float-parse n -- float-parse' )
  78     zero? [ [ 1 fixnum-fast ] change-magnitude ] when
  79     [ 1 fixnum+fast ] change-point ; inline
  80
  81 : store-exponent ( float-parse n expt -- float-parse' n )
  82     swap [ >>exponent ] dip ; inline
  83
  84 : ?store-exponent ( float-parse n expt/f -- float-parse' n/f )
  85     [ store-exponent ] [ drop f ] if* ; inline
  86
  87 : pow-until ( base x -- base^x )
  88     [ 1 ] 2dip [
  89         dup odd? [ [ [ * ] keep ] [ 1 - ] bi* ] when
  90         [ sq ] [ 2/ ] bi*
  91     ] until-zero drop ; inline
  92
  93 : (pow) ( base x -- base^x )
  94     integer>fixnum-strict
  95     dup 0 >= [ pow-until ] [ [ recip ] [ neg ] bi* pow-until ] if ; inline
  96
  97 : add-mantissa-digit ( float-parse i number-parse n digit quot -- float-parse' n/f )
  98     [ (add-digit)
  99         dup [ inc-point-?dec-magnitude ] curry 3dip
 100     ] dip next-digit ; inline
 101
 102 ! IEE754 doubles are in the range ]10^309,10^-324[,
 103 ! or expressed in base 2, ]2^1024, 2^-1074].
 104 ! We don't need those ranges to be accurate as long as we are
 105 ! excluding all the floats because they are used only to
 106 ! optimize when we know there will be an overflow/underflow
 107 ! We compare these numbers to the magnitude slot of float-parse,
 108 ! which has the following behavior:
 109 ! ... ; 0.0xxx -> -1; 0.xxx -> 0; x.xxx -> 1; xx.xxx -> 2; ...;
 110 ! Also, take some margin as the current float parsing algorithm
 111 ! does some rounding; For example,
 112 ! 0x1.0p-1074 is the smallest IE754 double, but floats down to
 113 ! 0x0.8p-1074 (excluded) are parsed as 0x1.0p-1074
 114 CONSTANT: max-magnitude-10 309
 115 CONSTANT: min-magnitude-10 -323
 116 CONSTANT: max-magnitude-2 1027
 117 CONSTANT: min-magnitude-2 -1074
 118
 119 : make-float-dec-exponent ( float-parse n/f -- float/f )
 120     over [ exponent>> ] [ magnitude>> ] bi +
 121     {
 122         { [ dup max-magnitude-10 > ] [ 3drop 1/0. ] }
 123         { [ dup min-magnitude-10 < ] [ 3drop 0.0 ] }
 124         [ drop
 125             [ [ radix>> ] [ point>> ] [ exponent>> ] tri - (pow) ]
 126             [ swap /f ] bi*
 127         ]
 128     } cond ; inline
 129
 130 : base2-digits ( digits radix -- digits' )
 131     {
 132         { 16 [ 4 * ] }
 133         { 8  [ 3 * ] }
 134         { 2  [ ] }
 135     } case ; inline
 136
 137 : base2-point ( float-parse -- point )
 138     [ point>> ] [ radix>> ] bi base2-digits ; inline
 139
 140 : base2-magnitude ( float-parse -- point )
 141     [ magnitude>> ] [ radix>> ] bi base2-digits ; inline
 142
 143 : make-float-bin-exponent ( float-parse n/f -- float/f )
 144     over [ exponent>> ] [ base2-magnitude ] bi +
 145     {
 146         { [ dup max-magnitude-2 > ] [ 3drop 1/0. ] }
 147         { [ dup min-magnitude-2 < ] [ 3drop 0.0 ] }
 148         [ drop
 149             [ [ drop 2 ] [ base2-point ] [ exponent>> ] tri - (pow) ]
 150             [ swap /f ] bi*
 151         ]
 152     } cond ; inline
 153
 154 : ?default-exponent ( float-parse n/f -- float-parse' n/f' )
 155     over exponent>> [
 156         over radix>> 10 = [ 0 store-exponent ] [ drop f ] if
 157     ] unless ; inline
 158
 159 : ?make-float ( float-parse n/f -- float/f )
 160     { float-parse object } declare
 161     ?default-exponent
 162     {
 163         { [ dup not ] [ 2drop f ] }
 164         { [ over radix>> 10 = ] [ make-float-dec-exponent ] }
 165         [ make-float-bin-exponent ]
 166     } cond ;
 167
 168 : bignum-?neg ( n -- -n )
 169     dup first-bignum bignum= [ drop most-negative-fixnum ] [ neg ] if ;
 170
 171 : fp-?neg ( n -- -n )
 172     double>bits 63 2^ bitor bits>double ;
 173
 174 : ?neg ( n/f -- -n/f )
 175     [
 176         {
 177             { [ dup bignum? ] [ bignum-?neg ] }
 178             { [ dup fp-nan? ] [ fp-?neg ] }
 179             [ neg ]
 180         } cond
 181     ] [ f ] if* ; inline
 182
 183 : ?pos ( n/f -- +n/f )
 184     dup fp-nan? [
 185         double>bits 63 2^ bitnot bitand bits>double
 186     ] when ; inline
 187
 188 : add-ratio? ( n/f -- ? )
 189     dup real? [ dup >integer number= not ] [ drop f ] if ;
 190
 191 : ?add-ratio ( m n/f -- m+n/f )
 192     dup add-ratio? [ + ] [ 2drop f ] if ; inline
 193
 194 : @abort ( i number-parse n x -- f )
 195     4drop f ; inline
 196
 197 : @split ( i number-parse n -- n i number-parse' n' )
 198     -rot 0 >>magnitude 0 ; inline
 199
 200 : @split-exponent ( i number-parse n -- n i number-parse' n' )
 201     -rot 10 >>radix 0 ; inline
 202
 203 : <float-parse> ( i number-parse n -- float-parse i number-parse n )
 204     [ drop nip [ radix>> ] [ magnitude>> ] bi [ 0 f ] dip float-parse boa ] 3keep ; inline
 205
 206 : if-skip ( char true false -- )
 207     pick ",_" member-eq? [ drop nip call ] [ nip call ] if ; inline
 208
 209 DEFER: @exponent-digit
 210 DEFER: @mantissa-digit
 211 DEFER: @denom-digit
 212 DEFER: @num-digit
 213 DEFER: @pos-digit
 214 DEFER: @neg-digit
 215
 216 : @exponent-digit-or-punc ( float-parse i number-parse n char -- float-parse n/f )
 217     [ [ @exponent-digit ] require-next-digit ] [ @exponent-digit ] if-skip ; inline
 218
 219 : @exponent-digit ( float-parse i number-parse n char -- float-parse n/f )
 220     { float-parse fixnum number-parse integer fixnum } declare
 221     digit-in-radix [ [ @exponent-digit-or-punc ] add-exponent-digit ] [ @abort ] if ;
 222
 223 : @exponent-first-char ( float-parse i number-parse n char -- float-parse n/f )
 224     {
 225         { CHAR: - [ [ @exponent-digit ] require-next-digit ?neg ] }
 226         { CHAR: + [ [ @exponent-digit ] require-next-digit ?pos ] }
 227         [ @exponent-digit ?pos ]
 228     } case ; inline
 229
 230 : ->exponent ( float-parse i number-parse n -- float-parse' n/f )
 231     @split-exponent [ @exponent-first-char ] require-next-digit ?store-exponent ; inline
 232
 233 : exponent-char? ( number-parse n char -- number-parse n char ? )
 234     pick radix>> {
 235         { 10 [ dup "eE" member-eq? ] }
 236         [ drop dup "pP" member-eq? ]
 237     } case ; inline
 238
 239 : or-exponent ( i number-parse n char quot -- n/f )
 240     [ exponent-char? [ drop <float-parse> ->exponent ?make-float ] ] dip if ; inline
 241
 242 : or-mantissa->exponent ( float-parse i number-parse n char quot -- float-parse n/f )
 243     [ exponent-char? [ drop ->exponent ] ] dip if ; inline
 244
 245 : @mantissa-digit-or-punc ( float-parse i number-parse n char -- float-parse n/f )
 246     [ [ @mantissa-digit ] require-next-digit ] [ @mantissa-digit ] if-skip ; inline
 247
 248 : @mantissa-digit ( float-parse i number-parse n char -- float-parse n/f )
 249     { float-parse fixnum number-parse integer fixnum } declare
 250     [
 251         digit-in-radix
 252         [ [ @mantissa-digit-or-punc ] add-mantissa-digit ]
 253         [ @abort ] if
 254     ] or-mantissa->exponent ;
 255
 256 : ->mantissa ( i number-parse n -- n/f )
 257     <float-parse> [ @mantissa-digit ] next-digit ?make-float ; inline
 258
 259 : ->required-mantissa ( i number-parse n -- n/f )
 260     <float-parse> [ @mantissa-digit ] require-next-digit ?make-float ; inline
 261
 262 : @denom-digit-or-punc ( i number-parse n char -- n/f )
 263     [ [ @denom-digit ] require-next-digit ] [
 264         {
 265             { CHAR: . [ ->mantissa ] }
 266             [ [ @denom-digit ] or-exponent ]
 267         } case
 268     ] if-skip ; inline
 269
 270 : @denom-digit ( i number-parse n char -- n/f )
 271     { fixnum number-parse integer fixnum } declare
 272     digit-in-radix [ [ @denom-digit-or-punc ] add-digit ] [ @abort ] if ;
 273
 274 : @denom-first-digit ( i number-parse n char -- n/f )
 275     {
 276         { CHAR: . [ ->mantissa ] }
 277         [ @denom-digit ]
 278     } case ; inline
 279
 280 : ->denominator ( i number-parse n -- n/f )
 281     { fixnum number-parse integer } declare
 282     @split [ @denom-first-digit ] require-next-digit ?make-ratio ;
 283
 284 : @num-digit-or-punc ( i number-parse n char -- n/f )
 285     [ [ @num-digit ] require-next-digit ] [
 286         {
 287             { CHAR: / [ ->denominator ] }
 288             [ @num-digit ]
 289         } case
 290     ] if-skip ; inline
 291
 292 : @num-digit ( i number-parse n char -- n/f )
 293     { fixnum number-parse integer fixnum } declare
 294     digit-in-radix [ [ @num-digit-or-punc ] add-digit ] [ @abort ] if ;
 295
 296 : ->numerator ( i number-parse n -- n/f )
 297     { fixnum number-parse integer } declare
 298     @split [ @num-digit ] require-next-digit ?add-ratio ;
 299
 300 : @pos-digit-or-punc ( i number-parse n char -- n/f )
 301     [ [ @pos-digit ] require-next-digit ] [
 302         {
 303             { CHAR: + [ ->numerator ] }
 304             { CHAR: / [ ->denominator ] }
 305             { CHAR: . [ ->mantissa ] }
 306             [ [ @pos-digit ] or-exponent ]
 307         } case
 308     ] if-skip ; inline
 309
 310 : @pos-digit ( i number-parse n char -- n/f )
 311     { fixnum number-parse integer fixnum } declare
 312     digit-in-radix [ [ @pos-digit-or-punc ] add-digit ] [ @abort ] if ;
 313
 314 : ->radix ( i number-parse n quot radix -- i number-parse n quot )
 315     [ >>radix ] curry 2dip ; inline
 316
 317 : with-radix-char ( i number-parse n radix-quot nonradix-quot -- n/f )
 318     [
 319         rot {
 320             { [ dup "bB" member-eq? ] [ 2drop  2 ->radix require-next-digit ] }
 321             { [ dup "oO" member-eq? ] [ 2drop  8 ->radix require-next-digit ] }
 322             { [ dup "xX" member-eq? ] [ 2drop 16 ->radix require-next-digit ] }
 323             [ nipd swap call ]
 324         } cond
 325     ] 2curry next-digit ; inline
 326
 327 : @pos-first-digit ( i number-parse n char -- n/f )
 328     {
 329         { CHAR: . [ ->required-mantissa ] }
 330         { CHAR: 0 [ [ @pos-digit ] [ @pos-digit-or-punc ] with-radix-char ] }
 331         [ @pos-digit ]
 332     } case ; inline
 333
 334 : @neg-digit-or-punc ( i number-parse n char -- n/f )
 335     [ [ @neg-digit ] require-next-digit ] [
 336         {
 337             { CHAR: - [ ->numerator ] }
 338             { CHAR: / [ ->denominator ] }
 339             { CHAR: . [ ->mantissa ] }
 340             [ [ @neg-digit ] or-exponent ]
 341         } case
 342     ] if-skip ; inline
 343
 344 : @neg-digit ( i number-parse n char -- n/f )
 345     { fixnum number-parse integer fixnum } declare
 346     digit-in-radix [ [ @neg-digit-or-punc ] add-digit ] [ @abort ] if ;
 347
 348 : @neg-first-digit ( i number-parse n char -- n/f )
 349     {
 350         { CHAR: . [ ->required-mantissa ] }
 351         { CHAR: 0 [ [ @neg-digit ] [ @neg-digit-or-punc ] with-radix-char ] }
 352         [ @neg-digit ]
 353     } case ; inline
 354
 355 : @first-char ( i number-parse n char -- n/f )
 356     {
 357         { CHAR: - [ [ @neg-first-digit ] require-next-digit ?neg ] }
 358         { CHAR: + [ [ @pos-first-digit ] require-next-digit ?pos ] }
 359         [ @pos-first-digit ?pos ]
 360     } case ; inline
 361
 362 : @neg-first-digit-no-radix ( i number-parse n char -- n/f )
 363     {
 364         { CHAR: . [ ->required-mantissa ] }
 365         [ @neg-digit ]
 366     } case ; inline
 367
 368 : @pos-first-digit-no-radix ( i number-parse n char -- n/f )
 369     {
 370         { CHAR: . [ ->required-mantissa ] }
 371         [ @pos-digit ]
 372     } case ; inline
 373
 374 : @first-char-no-radix ( i number-parse n char -- n/f )
 375     {
 376         { CHAR: - [ [ @neg-first-digit-no-radix ] require-next-digit ?neg ] }
 377         { CHAR: + [ [ @pos-first-digit-no-radix ] require-next-digit ?pos ] }
 378         [ @pos-first-digit-no-radix ?pos ]
 379     } case ; inline
 380
 381 PRIVATE>
 382
 383 : string>number ( str -- n/f )
 384     10 <number-parse> [ @first-char ] require-next-digit ;
 385
 386 : base> ( str radix -- n/f )
 387     <number-parse> [ @first-char-no-radix ] require-next-digit ;
 388
 389 : bin> ( str -- n/f )  2 base> ; inline
 390 : oct> ( str -- n/f )  8 base> ; inline
 391 : dec> ( str -- n/f ) 10 base> ; inline
 392 : hex> ( str -- n/f ) 16 base> ; inline
 393
 394 <PRIVATE
 395
 396 CONSTANT: TENS B{
 397     48 48 48 48 48 48 48 48 48 48 49 49 49 49 49 49 49 49 49 49
 398     50 50 50 50 50 50 50 50 50 50 51 51 51 51 51 51 51 51 51 51
 399     52 52 52 52 52 52 52 52 52 52 53 53 53 53 53 53 53 53 53 53
 400     54 54 54 54 54 54 54 54 54 54 55 55 55 55 55 55 55 55 55 55
 401     56 56 56 56 56 56 56 56 56 56 57 57 57 57 57 57 57 57 57 57
 402 }
 403
 404 CONSTANT: ONES B{
 405     48 49 50 51 52 53 54 55 56 57 48 49 50 51 52 53 54 55 56 57
 406     48 49 50 51 52 53 54 55 56 57 48 49 50 51 52 53 54 55 56 57
 407     48 49 50 51 52 53 54 55 56 57 48 49 50 51 52 53 54 55 56 57
 408     48 49 50 51 52 53 54 55 56 57 48 49 50 51 52 53 54 55 56 57
 409     48 49 50 51 52 53 54 55 56 57 48 49 50 51 52 53 54 55 56 57
 410 }
 411
 412 : two-digit ( num accum -- num' accum )
 413     [
 414         100 /mod [ TENS nth-unsafe ] [ ONES nth-unsafe ] bi
 415     ] dip [ push ] keep [ push ] keep ; inline
 416
 417 : one-digit ( num accum -- num' accum )
 418     [ 10 /mod CHAR: 0 + ] dip [ push ] keep ; inline
 419
 420 : bignum>dec ( num accum -- num' accum )
 421     [ over most-positive-fixnum > ]
 422     [ { bignum sbuf } declare two-digit ] while
 423     [ >fixnum ] dip ; inline
 424
 425 : fixnum>dec ( num accum -- num' accum )
 426     { fixnum sbuf } declare
 427     [ over 10 >= ] [ two-digit ] while
 428     [ over zero? ] [ one-digit ] until ; inline
 429
 430 GENERIC: positive>dec ( num -- str )
 431
 432 M: bignum positive>dec
 433     12 <sbuf> bignum>dec fixnum>dec "" like reverse! nip ; inline
 434
 435 : count-digits ( digits n -- digits' )
 436     {
 437         { [ dup 10 < ] [ drop ] }
 438         { [ dup 100 < ] [ drop 1 fixnum+fast ] }
 439         { [ dup 1,000 < ] [ drop 2 fixnum+fast ] }
 440         [
 441             dup 1,000,000,000,000 < [
 442                 dup 100,000,000 < [
 443                     dup 1,000,000 < [
 444                         dup 10,000 < [
 445                             drop 3
 446                         ] [
 447                             100,000 >= 5 4 ?
 448                         ] if
 449                     ] [
 450                         10,000,000 >= 7 6 ?
 451                     ] if
 452                 ] [
 453                     dup 10,000,000,000 < [
 454                         1,000,000,000 >= 9 8 ?
 455                     ] [
 456                         100,000,000,000 >= 11 10 ?
 457                     ] if
 458                 ] if fixnum+fast
 459             ] [
 460                 [ 12 fixnum+fast ] [ 1,000,000,000,000 /i ] bi*
 461                 count-digits
 462             ] if
 463         ]
 464     } cond ; inline recursive
 465
 466 M: fixnum positive>dec
 467     1 over count-digits <sbuf> fixnum>dec "" like reverse! nip ; inline
 468
 469 : positive>base ( num radix -- str )
 470     {
 471         { 10 [ positive>dec ] }
 472         [
 473             dup 1 <= [ invalid-radix ] when
 474             [ dup 0 > ] swap [ /mod >digit ] curry "" produce-as nip
 475             reverse!
 476         ]
 477     } case ;
 478
 479 PRIVATE>
 480
 481 GENERIC#: >base 1 ( n radix -- str )
 482
 483 : >bin ( n -- str ) 2 >base ; inline
 484 : >oct ( n -- str ) 8 >base ; inline
 485 : >dec ( n -- str ) 10 >base ; inline
 486 : >hex ( n -- str ) 16 >base ; inline
 487
 488 ALIAS: number>string >dec
 489
 490 M: integer >base
 491     {
 492         { [ over 0 = ] [ 2drop "0" ] }
 493         { [ over 0 > ] [ positive>base ] }
 494         [ [ neg ] dip positive>base CHAR: - prefix ]
 495     } cond ;
 496
 497 M: ratio >base
 498     [ >fraction [ /mod ] keep ] [ [ >base ] curry tri@ ] bi*
 499     "/" glue over first-unsafe {
 500         { CHAR: 0 [ nip ] }
 501         { CHAR: - [ append ] }
 502         [ drop "+" glue ]
 503     } case ;
 504
 505 <PRIVATE
 506
 507 : mantissa-expt-normalize ( mantissa expt -- mantissa' expt' )
 508     [ dup log2 52 swap - [ shift 52 2^ 1 - bitand ] [ 1022 + neg ] bi ]
 509     [ 1023 - ] if-zero ;
 510
 511 : (mantissa-expt) ( bits -- mantissa expt )
 512     [ 52 2^ 1 - bitand ]
 513     [ -0.0 double>bits bitnot bitand -52 shift ] bi ; inline
 514
 515 : mantissa-expt ( bits -- mantissa expt )
 516     (mantissa-expt) mantissa-expt-normalize ;
 517
 518 : sign-negative? ( bits -- ? ) 63 bit? ; inline
 519
 520 : bin-float-value ( str size -- str' )
 521     CHAR: 0 pad-head [ CHAR: 0 = ] trim-tail
 522     [ "0" ] when-empty "1." prepend ;
 523
 524 : float>hex-value ( mantissa -- str )
 525     >hex 13 bin-float-value ;
 526
 527 : float>oct-value ( mantissa -- str )
 528     4 * >oct 18 bin-float-value ;
 529
 530 : float>bin-value ( mantissa -- str )
 531     >bin 52 bin-float-value ;
 532
 533 : bin-float-expt ( exponent -- str )
 534     >dec "p" prepend ;
 535
 536 : (bin-float>base) ( value-quot n -- str )
 537     double>bits
 538     [ sign-negative? "-" "" ? swap ] [
 539         mantissa-expt rot [ bin-float-expt ] bi*
 540     ] bi 3append ; inline
 541
 542 : bin-float>base ( n base -- str )
 543     {
 544         { 16 [ [ float>hex-value ] swap (bin-float>base) ] }
 545         { 8  [ [ float>oct-value ] swap (bin-float>base) ] }
 546         { 2  [ [ float>bin-value ] swap (bin-float>base) ] }
 547         [ invalid-radix ]
 548     } case ;
 549
 550 ! Dragonbox algorithm
 551
 552 : ⌊nlog10_2⌋ ( n -- m ) 315653 * -20 shift ; inline
 553
 554 : ⌊nlog2_10⌋ ( n -- m ) 1741647 * -19 shift ; inline
 555
 556 : 1000/ ( n -- m ) 2361183241434822607 * -71 shift ; inline
 557
 558 : ⌊nlog10_2-log10_4/3⌋ ( n -- m ) 631305 * 261663 - -21 shift ; inline
 559
 560 : 100/mod ( n -- t ρ≠0? )
 561     656 * [ -16 shift ] [ 16 2^ 1 - bitand 656 >= ] bi ; inline
 562
 563 : >float< ( n -- s F E )
 564     double>bits [ sign-negative? ] [ (mantissa-expt) ] bi ; inline
 565
 566 : mantissa-expt-normalize* ( F E -- F' E' )
 567     [ -1022 ] [ [ 52 2^ bitor ] [ 1023 - ] bi* ] if-zero
 568     52 - >fixnum ; inline
 569
 570 : shorter-interval? ( F E -- ? )
 571     [ zero? ] [ 1 > ] bi* and ; inline
 572
 573 : k ( E -- k ) ⌊nlog10_2⌋ neg 2 + ; inline
 574
 575 CONSTANT: lookup-table {
 576 0xc795830d75038c1dd59df5b9ef6a2418 0xf97ae3d0d2446f254b0573286b44ad1e
 577 0x9becce62836ac5774ee367f9430aec33 0xc2e801fb244576d5229c41f793cda740
 578 0xf3a20279ed56d48a6b43527578c11110 0x9845418c345644d6830a13896b78aaaa
 579 0xbe5691ef416bd60c23cc986bc656d554 0xedec366b11c6cb8f2cbfbe86b7ec8aa9
 580 0x94b3a202eb1c3f397bf7d71432f3d6aa 0xb9e08a83a5e34f07daf5ccd93fb0cc54
 581 0xe858ad248f5c22c9d1b3400f8f9cff69 0x91376c36d99995be23100809b9c21fa2
 582 0xb58547448ffffb2dabd40a0c2832a78b 0xe2e69915b3fff9f916c90c8f323f516d
 583 0x8dd01fad907ffc3bae3da7d97f6792e4 0xb1442798f49ffb4a99cd11cfdf41779d
 584 0xdd95317f31c7fa1d40405643d711d584 0x8a7d3eef7f1cfc52482835ea666b2573
 585 0xad1c8eab5ee43b66da3243650005eed0 0xd863b256369d4a4090bed43e40076a83
 586 0x873e4f75e2224e685a7744a6e804a292 0xa90de3535aaae202711515d0a205cb37
 587 0xd3515c2831559a830d5a5b44ca873e04 0x8412d9991ed58091e858790afe9486c3
 588 0xa5178fff668ae0b6626e974dbe39a873 0xce5d73ff402d98e3fb0a3d212dc81290
 589 0x80fa687f881c7f8e7ce66634bc9d0b9a 0xa139029f6a239f721c1fffc1ebc44e81
 590 0xc987434744ac874ea327ffb266b56221 0xfbe9141915d7a9224bf1ff9f0062baa9
 591 0x9d71ac8fada6c9b56f773fc3603db4aa 0xc4ce17b399107c22cb550fb4384d21d4
 592 0xf6019da07f549b2b7e2a53a146606a49 0x99c102844f94e0fb2eda7444cbfc426e
 593 0xc0314325637a1939fa911155fefb5309 0xf03d93eebc589f88793555ab7eba27cb
 594 0x96267c7535b763b54bc1558b2f3458df 0xbbb01b9283253ca29eb1aaedfb016f17
 595 0xea9c227723ee8bcb465e15a979c1cadd 0x92a1958a7675175f0bfacd89ec191eca
 596 0xb749faed14125d36cef980ec671f667c 0xe51c79a85916f48482b7e12780e7401b
 597 0x8f31cc0937ae58d2d1b2ecb8b0908811 0xb2fe3f0b8599ef07861fa7e6dcb4aa16
 598 0xdfbdcece67006ac967a791e093e1d49b 0x8bd6a141006042bde0c8bb2c5c6d24e1
 599 0xaecc49914078536d58fae9f773886e19 0xda7f5bf590966848af39a475506a899f
 600 0x888f99797a5e012d6d8406c952429604 0xaab37fd7d8f58178c8e5087ba6d33b84
 601 0xd5605fcdcf32e1d6fb1e4a9a90880a65 0x855c3be0a17fcd265cf2eea09a550680
 602 0xa6b34ad8c9dfc06ff42faa48c0ea481f 0xd0601d8efc57b08bf13b94daf124da27
 603 0x823c12795db6ce5776c53d08d6b70859 0xa2cb1717b52481ed54768c4b0c64ca6f
 604 0xcb7ddcdda26da268a9942f5dcf7dfd0a 0xfe5d54150b090b02d3f93b35435d7c4d
 605 0x9efa548d26e5a6e1c47bc5014a1a6db0 0xc6b8e9b0709f109a359ab6419ca1091c
 606 0xf867241c8cc6d4c0c30163d203c94b63 0x9b407691d7fc44f879e0de63425dcf1e
 607 0xc21094364dfb5636985915fc12f542e5 0xf294b943e17a2bc43e6f5b7b17b2939e
 608 0x979cf3ca6cec5b5aa705992ceecf9c43 0xbd8430bd0827723150c6ff782a838354
 609 0xece53cec4a314ebda4f8bf5635246429 0x940f4613ae5ed136871b7795e136be9a
 610 0xb913179899f6858428e2557b59846e40 0xe757dd7ec07426e5331aeada2fe589d0
 611 0x9096ea6f3848984f3ff0d2c85def7622 0xb4bca50b065abe630fed077a756b53aa
 612 0xe1ebce4dc7f16dfbd3e8495912c62895 0x8d3360f09cf6e4bd64712dd7abbbd95d
 613 0xb080392cc4349decbd8d794d96aacfb4 0xdca04777f541c567ecf0d7a0fc5583a1
 614 0x89e42caaf9491b60f41686c49db57245 0xac5d37d5b79b6239311c2875c522ced6
 615 0xd77485cb25823ac77d633293366b828c 0x86a8d39ef77164bcae5dff9c02033198
 616 0xa8530886b54dbdebd9f57f830283fdfd 0xd267caa862a12d66d072df63c324fd7c
 617 0x8380dea93da4bc604247cb9e59f71e6e 0xa46116538d0deb7852d9be85f074e609
 618 0xcd795be87051665667902e276c921f8c 0x806bd9714632dff600ba1cd8a3db53b7
 619 0xa086cfcd97bf97f380e8a40eccd228a5 0xc8a883c0fdaf7df06122cd128006b2ce
 620 0xfad2a4b13d1b5d6c796b805720085f82 0x9cc3a6eec6311a63cbe3303674053bb1
 621 0xc3f490aa77bd60fcbedbfc4411068a9d 0xf4f1b4d515acb93bee92fb5515482d45
 622 0x991711052d8bf3c5751bdd152d4d1c4b 0xbf5cd54678eef0b6d262d45a78a0635e
 623 0xef340a98172aace486fb897116c87c35 0x9580869f0e7aac0ed45d35e6ae3d4da1
 624 0xbae0a846d21957128974836059cca10a 0xe998d258869facd72bd1a438703fc94c
 625 0x91ff83775423cc067b6306a34627ddd0 0xb67f6455292cbf081a3bc84c17b1d543
 626 0xe41f3d6a7377eeca20caba5f1d9e4a94 0x8e938662882af53e547eb47b7282ee9d
 627 0xb23867fb2a35b28de99e619a4f23aa44 0xdec681f9f4c31f316405fa00e2ec94d5
 628 0x8b3c113c38f9f37ede83bc408dd3dd05 0xae0b158b4738705e9624ab50b148d446
 629 0xd98ddaee19068c763badd624dd9b0958 0x87f8a8d4cfa417c9e54ca5d70a80e5d7
 630 0xa9f6d30a038d1dbc5e9fcf4ccd211f4d 0xd47487cc8470652b7647c32000696720
 631 0x84c8d4dfd2c63f3b29ecd9f40041e074 0xa5fb0a17c777cf09f468107100525891
 632 0xcf79cc9db955c2cc7182148d4066eeb5 0x81ac1fe293d599bfc6f14cd848405531
 633 0xa21727db38cb002fb8ada00e5a506a7d 0xca9cf1d206fdc03ba6d90811f0e4851d
 634 0xfd442e4688bd304a908f4a166d1da664 0x9e4a9cec15763e2e9a598e4e043287ff
 635 0xc5dd44271ad3cdba40eff1e1853f29fe 0xf7549530e188c128d12bee59e68ef47d
 636 0x9a94dd3e8cf578b982bb74f8301958cf 0xc13a148e3032d6e7e36a52363c1faf02
 637 0xf18899b1bc3f8ca1dc44e6c3cb279ac2 0x96f5600f15a7b7e529ab103a5ef8c0ba
 638 0xbcb2b812db11a5de7415d448f6b6f0e8 0xebdf661791d60f56111b495b3464ad22
 639 0x936b9fcebb25c995cab10dd900beec35 0xb84687c269ef3bfb3d5d514f40eea743
 640 0xe65829b3046b0afa0cb4a5a3112a5113 0x8ff71a0fe2c2e6dc47f0e785eaba72ac
 641 0xb3f4e093db73a09359ed216765690f57 0xe0f218b8d25088b8306869c13ec3532d
 642 0x8c974f73837255731e414218c73a13fc 0xafbd2350644eeacfe5d1929ef90898fb
 643 0xdbac6c247d62a583df45f746b74abf3a 0x894bc396ce5da7726b8bba8c328eb784
 644 0xab9eb47c81f5114f066ea92f3f326565 0xd686619ba27255a2c80a537b0efefebe
 645 0x8613fd0145877585bd06742ce95f5f37 0xa798fc4196e952e72c48113823b73705
 646 0xd17f3b51fca3a7a0f75a15862ca504c6 0x82ef85133de648c49a984d73dbe722fc
 647 0xa3ab66580d5fdaf5c13e60d0d2e0ebbb 0xcc963fee10b7d1b3318df905079926a9
 648 0xffbbcfe994e5c61ffdf17746497f7053 0x9fd561f1fd0f9bd3feb6ea8bedefa634
 649 0xc7caba6e7c5382c8fe64a52ee96b8fc1 0xf9bd690a1b68637b3dfdce7aa3c673b1
 650 0x9c1661a651213e2d06bea10ca65c084f 0xc31bfa0fe5698db8486e494fcff30a63
 651 0xf3e2f893dec3f1265a89dba3c3efccfb 0x986ddb5c6b3a76b7f89629465a75e01d
 652 0xbe89523386091465f6bbb397f1135824 0xee2ba6c0678b597f746aa07ded582e2d
 653 0x94db483840b717efa8c2a44eb4571cdd 0xba121a4650e4ddeb92f34d62616ce414
 654 0xe896a0d7e51e156677b020baf9c81d18 0x915e2486ef32cd600ace1474dc1d122f
 655 0xb5b5ada8aaff80b80d819992132456bb 0xe3231912d5bf60e610e1fff697ed6c6a
 656 0x8df5efabc5979c8fca8d3ffa1ef463c2 0xb1736b96b6fd83b3bd308ff8a6b17cb3
 657 0xddd0467c64bce4a0ac7cb3f6d05ddbdf 0x8aa22c0dbef60ee46bcdf07a423aa96c
 658 0xad4ab7112eb3929d86c16c98d2c953c7 0xd89d64d57a607744e871c7bf077ba8b8
 659 0x87625f056c7c4a8b11471cd764ad4973 0xa93af6c6c79b5d2dd598e40d3dd89bd0
 660 0xd389b478798234794aff1d108d4ec2c4 0x843610cb4bf160cbcedf722a585139bb
 661 0xa54394fe1eedb8fec2974eb4ee658829 0xce947a3da6a9273e733d226229feea33
 662 0x811ccc668829b8870806357d5a3f5260 0xa163ff802a3426a8ca07c2dcb0cf26f8
 663 0xc9bcff6034c13052fc89b393dd02f0b6 0xfc2c3f3841f17c67bbac2078d443ace3
 664 0x9d9ba7832936edc0d54b944b84aa4c0e 0xc5029163f384a9310a9e795e65d4df12
 665 0xf64335bcf065d37d4d4617b5ff4a16d6 0x99ea0196163fa42e504bced1bf8e4e46
 666 0xc06481fb9bcf8d39e45ec2862f71e1d7 0xf07da27a82c370885d767327bb4e5a4d
 667 0x964e858c91ba26553a6a07f8d510f870 0xbbe226efb628afea890489f70a55368c
 668 0xeadab0aba3b2dbe52b45ac74ccea842f 0x92c8ae6b464fc96f3b0b8bc90012929e
 669 0xb77ada0617e3bbcb09ce6ebb40173745 0xe55990879ddcaabdcc420a6a101d0516
 670 0x8f57fa54c2a9eab69fa946824a12232e 0xb32df8e9f354656447939822dc96abfa
 671 0xdff9772470297ebd59787e2b93bc56f8 0x8bfbea76c619ef3657eb4edb3c55b65b
 672 0xaefae51477a06b03ede622920b6b23f2 0xdab99e59958885c4e95fab368e45ecee
 673 0x88b402f7fd75539b11dbcb0218ebb415 0xaae103b5fcd2a881d652bdc29f26a11a
 674 0xd59944a37c0752a24be76d3346f04960 0x857fcae62d8493a56f70a4400c562ddc
 675 0xa6dfbd9fb8e5b88ecb4ccd500f6bb953 0xd097ad07a71f26b27e2000a41346a7a8
 676 0x825ecc24c873782f8ed400668c0c28c9 0xa2f67f2dfa90563b728900802f0f32fb
 677 0xcbb41ef979346bca4f2b40a03ad2ffba 0xfea126b7d78186bce2f610c84987bfa9
 678 0x9f24b832e6b0f4360dd9ca7d2df4d7ca 0xc6ede63fa05d314391503d1c79720dbc
 679 0xf8a95fcf88747d9475a44c6397ce912b 0x9b69dbe1b548ce7cc986afbe3ee11abb
 680 0xc24452da229b021bfbe85badce996169 0xf2d56790ab41c2a2fae27299423fb9c4
 681 0x97c560ba6b0919a5dccd879fc967d41b 0xbdb6b8e905cb600f5400e987bbc1c921
 682 0xed246723473e3813290123e9aab23b69 0x9436c0760c86e30bf9a0b6720aaf6522
 683 0xb94470938fa89bcef808e40e8d5b3e6a 0xe7958cb87392c2c2b60b1d1230b20e05
 684 0x90bd77f3483bb9b9b1c6f22b5e6f48c3 0xb4ecd5f01a4aa8281e38aeb6360b1af4
 685 0xe2280b6c20dd523225c6da63c38de1b1 0x8d590723948a535f579c487e5a38ad0f
 686 0xb0af48ec79ace8372d835a9df0c6d852 0xdcdb1b2798182244f8e431456cf88e66
 687 0x8a08f0f8bf0f156b1b8e9ecb641b5900 0xac8b2d36eed2dac5e272467e3d222f40
 688 0xd7adf884aa8791775b0ed81dcc6abb10 0x86ccbb52ea94baea98e947129fc2b4ea
 689 0xa87fea27a539e9a53f2398d747b36225 0xd29fe4b18e88640e8eec7f0d19a03aae
 690 0x83a3eeeef9153e891953cf68300424ad 0xa48ceaaab75a8e2b5fa8c3423c052dd8
 691 0xcdb02555653131b63792f412cb06794e 0x808e17555f3ebf11e2bbd88bbee40bd1
 692 0xa0b19d2ab70e6ed65b6aceaeae9d0ec5 0xc8de047564d20a8bf245825a5a445276
 693 0xfb158592be068d2eeed6e2f0f0d56713 0x9ced737bb6c4183d55464dd69685606c
 694 0xc428d05aa4751e4caa97e14c3c26b887 0xf53304714d9265dfd53dd99f4b3066a9
 695 0x993fe2c6d07b7fabe546a8038efe402a 0xbf8fdb78849a5f96de98520472bdd034
 696 0xef73d256a5c0f77c963e66858f6d4441 0x95a8637627989aaddde7001379a44aa9
 697 0xbb127c53b17ec1595560c018580d5d53 0xe9d71b689dde71afaab8f01e6e10b4a7
 698 0x9226712162ab070dcab3961304ca70e9 0xb6b00d69bb55c8d13d607b97c5fd0d23
 699 0xe45c10c42a2b3b058cb89a7db77c506b 0x8eb98a7a9a5b04e377f3608e92adb243
 700 0xb267ed1940f1c61c55f038b237591ed4 0xdf01e85f912e37a36b6c46dec52f6689
 701 0x8b61313bbabce2c62323ac4b3b3da016 0xae397d8aa96c1b77abec975e0a0d081b
 702 0xd9c7dced53c7225596e7bd358c904a22 0x881cea14545c75757e50d64177da2e55
 703 0xaa242499697392d2dde50bd1d5d0b9ea 0xd4ad2dbfc3d07787955e4ec64b44e865
 704 0x84ec3c97da624ab4bd5af13bef0b113f 0xa6274bbdd0fadd61ecb1ad8aeacdd58f
 705 0xcfb11ead453994ba67de18eda5814af3 0x81ceb32c4b43fcf480eacf948770ced8
 706 0xa2425ff75e14fc31a1258379a94d028e 0xcad2f7f5359a3b3e096ee45813a04331
 707 0xfd87b5f28300ca0d8bca9d6e188853fd 0x9e74d1b791e07e48775ea264cf55347e
 708 0xc612062576589dda95364afe032a819e 0xf79687aed3eec5513a83ddbd83f52205
 709 0x9abe14cd44753b52c4926a9672793543 0xc16d9a0095928a2775b7053c0f178294
 710 0xf1c90080baf72cb15324c68b12dd6339 0x971da05074da7beed3f6fc16ebca5e04
 711 0xbce5086492111aea88f4bb1ca6bcf585 0xec1e4a7db69561a52b31e9e3d06c32e6
 712 0x9392ee8e921d5d073aff322e62439fd0 0xb877aa3236a4b44909befeb9fad487c3
 713 0xe69594bec44de15b4c2ebe687989a9b4 0x901d7cf73ab0acd90f9d37014bf60a11
 714 0xb424dc35095cd80f538484c19ef38c95 0xe12e13424bb40e132865a5f206b06fba
 715 0x8cbccc096f5088cbf93f87b7442e45d4 0xafebff0bcb24aafef78f69a51539d749
 716 0xdbe6fecebdedd5beb573440e5a884d1c 0x89705f4136b4a59731680a88f8953031
 717 0xabcc77118461cefcfdc20d2b36ba7c3e 0xd6bf94d5e57a42bc3d32907604691b4d
 718 0x8637bd05af6c69b5a63f9a49c2c1b110 0xa7c5ac471b4784230fcf80dc33721d54
 719 0xd1b71758e219652bd3c36113404ea4a9 0x83126e978d4fdf3b645a1cac083126ea
 720 0xa3d70a3d70a3d70a3d70a3d70a3d70a4 0xcccccccccccccccccccccccccccccccd
 721 0x80000000000000000000000000000000 0xa0000000000000000000000000000000
 722 0xc8000000000000000000000000000000 0xfa000000000000000000000000000000
 723 0x9c400000000000000000000000000000 0xc3500000000000000000000000000000
 724 0xf4240000000000000000000000000000 0x98968000000000000000000000000000
 725 0xbebc2000000000000000000000000000 0xee6b2800000000000000000000000000
 726 0x9502f900000000000000000000000000 0xba43b740000000000000000000000000
 727 0xe8d4a510000000000000000000000000 0x9184e72a000000000000000000000000
 728 0xb5e620f4800000000000000000000000 0xe35fa931a00000000000000000000000
 729 0x8e1bc9bf040000000000000000000000 0xb1a2bc2ec50000000000000000000000
 730 0xde0b6b3a764000000000000000000000 0x8ac7230489e800000000000000000000
 731 0xad78ebc5ac6200000000000000000000 0xd8d726b7177a80000000000000000000
 732 0x878678326eac90000000000000000000 0xa968163f0a57b4000000000000000000
 733 0xd3c21bcecceda1000000000000000000 0x84595161401484a00000000000000000
 734 0xa56fa5b99019a5c80000000000000000 0xcecb8f27f4200f3a0000000000000000
 735 0x813f3978f89409844000000000000000 0xa18f07d736b90be55000000000000000
 736 0xc9f2c9cd04674edea400000000000000 0xfc6f7c40458122964d00000000000000
 737 0x9dc5ada82b70b59df020000000000000 0xc5371912364ce3056c28000000000000
 738 0xf684df56c3e01bc6c732000000000000 0x9a130b963a6c115c3c7f400000000000
 739 0xc097ce7bc90715b34b9f100000000000 0xf0bdc21abb48db201e86d40000000000
 740 0x96769950b50d88f41314448000000000 0xbc143fa4e250eb3117d955a000000000
 741 0xeb194f8e1ae525fd5dcfab0800000000 0x92efd1b8d0cf37be5aa1cae500000000
 742 0xb7abc627050305adf14a3d9e40000000 0xe596b7b0c643c7196d9ccd05d0000000
 743 0x8f7e32ce7bea5c6fe4820023a2000000 0xb35dbf821ae4f38bdda2802c8a800000
 744 0xe0352f62a19e306ed50b2037ad200000 0x8c213d9da502de454526f422cc340000
 745 0xaf298d050e4395d69670b12b7f410000 0xdaf3f04651d47b4c3c0cdd765f114000
 746 0x88d8762bf324cd0fa5880a69fb6ac800 0xab0e93b6efee00538eea0d047a457a00
 747 0xd5d238a4abe9806872a4904598d6d880 0x85a36366eb71f04147a6da2b7f864750
 748 0xa70c3c40a64e6c51999090b65f67d924 0xd0cf4b50cfe20765fff4b4e3f741cf6d
 749 0x82818f1281ed449fbff8f10e7a8921a5 0xa321f2d7226895c7aff72d52192b6a0e
 750 0xcbea6f8ceb02bb399bf4f8a69f764491 0xfee50b7025c36a0802f236d04753d5b5
 751 0x9f4f2726179a224501d762422c946591 0xc722f0ef9d80aad6424d3ad2b7b97ef6
 752 0xf8ebad2b84e0d58bd2e0898765a7deb3 0x9b934c3b330c857763cc55f49f88eb30
 753 0xc2781f49ffcfa6d53cbf6b71c76b25fc 0xf316271c7fc3908a8bef464e3945ef7b
 754 0x97edd871cfda3a5697758bf0e3cbb5ad 0xbde94e8e43d0c8ec3d52eeed1cbea318
 755 0xed63a231d4c4fb274ca7aaa863ee4bde 0x945e455f24fb1cf88fe8caa93e74ef6b
 756 0xb975d6b6ee39e436b3e2fd538e122b45 0xe7d34c64a9c85d4460dbbca87196b617
 757 0x90e40fbeea1d3a4abc8955e946fe31ce 0xb51d13aea4a488dd6babab6398bdbe42
 758 0xe264589a4dcdab14c696963c7eed2dd2 0x8d7eb76070a08aecfc1e1de5cf543ca3
 759 0xb0de65388cc8ada83b25a55f43294bcc 0xdd15fe86affad91249ef0eb713f39ebf
 760 0x8a2dbf142dfcc7ab6e3569326c784338 0xacb92ed9397bf99649c2c37f07965405
 761 0xd7e77a8f87daf7fbdc33745ec97be907 0x86f0ac99b4e8dafd69a028bb3ded71a4
 762 0xa8acd7c0222311bcc40832ea0d68ce0d 0xd2d80db02aabd62bf50a3fa490c30191
 763 0x83c7088e1aab65db792667c6da79e0fb 0xa4b8cab1a1563f52577001b891185939
 764 0xcde6fd5e09abcf26ed4c0226b55e6f87 0x80b05e5ac60b6178544f8158315b05b5
 765 0xa0dc75f1778e39d6696361ae3db1c722 0xc913936dd571c84c03bc3a19cd1e38ea
 766 0xfb5878494ace3a5f04ab48a04065c724 0x9d174b2dcec0e47b62eb0d64283f9c77
 767 0xc45d1df942711d9a3ba5d0bd324f8395 0xf5746577930d6500ca8f44ec7ee3647a
 768 0x9968bf6abbe85f207e998b13cf4e1ecc 0xbfc2ef456ae276e89e3fedd8c321a67f
 769 0xefb3ab16c59b14a2c5cfe94ef3ea101f 0x95d04aee3b80ece5bba1f1d158724a13
 770 0xbb445da9ca61281f2a8a6e45ae8edc98 0xea1575143cf97226f52d09d71a3293be
 771 0x924d692ca61be758593c2626705f9c57 0xb6e0c377cfa2e12e6f8b2fb00c77836d
 772 0xe498f455c38b997a0b6dfb9c0f956448 0x8edf98b59a373fec4724bd4189bd5ead
 773 0xb2977ee300c50fe758edec91ec2cb658 0xdf3d5e9bc0f653e12f2967b66737e3ee
 774 0x8b865b215899f46cbd79e0d20082ee75 0xae67f1e9aec07187ecd8590680a3aa12
 775 0xda01ee641a708de9e80e6f4820cc9496 0x884134fe908658b23109058d147fdcde
 776 0xaa51823e34a7eedebd4b46f0599fd416 0xd4e5e2cdc1d1ea966c9e18ac7007c91b
 777 0x850fadc09923329e03e2cf6bc604ddb1 0xa6539930bf6bff4584db8346b786151d
 778 0xcfe87f7cef46ff16e612641865679a64 0x81f14fae158c5f6e4fcb7e8f3f60c07f
 779 0xa26da3999aef7749e3be5e330f38f09e 0xcb090c8001ab551c5cadf5bfd3072cc6
 780 0xfdcb4fa002162a6373d9732fc7c8f7f7 0x9e9f11c4014dda7e2867e7fddcdd9afb
 781 0xc646d63501a1511db281e1fd541501b9 0xf7d88bc24209a5651f225a7ca91a4227
 782 0x9ae757596946075f3375788de9b06959 0xc1a12d2fc39789370052d6b1641c83af
 783 0xf209787bb47d6b84c0678c5dbd23a49b 0x9745eb4d50ce6332f840b7ba963646e1
 784 0xbd176620a501fbffb650e5a93bc3d899 0xec5d3fa8ce427affa3e51f138ab4cebf
 785 0x93ba47c980e98cdfc66f336c36b10138 0xb8a8d9bbe123f017b80b0047445d4185
 786 0xe6d3102ad96cec1da60dc059157491e6 0x9043ea1ac7e4139287c89837ad68db30
 787 0xb454e4a179dd187729babe4598c311fc 0xe16a1dc9d8545e94f4296dd6fef3d67b
 788 0x8ce2529e2734bb1d1899e4a65f58660d 0xb01ae745b101e9e45ec05dcff72e7f90
 789 0xdc21a1171d42645d76707543f4fa1f74 0x899504ae72497eba6a06494a791c53a9
 790 0xabfa45da0edbde690487db9d17636893 0xd6f8d7509292d60345a9d2845d3c42b7
 791 0x865b86925b9bc5c20b8a2392ba45a9b3 0xa7f26836f282b7328e6cac7768d7141f
 792 0xd1ef0244af2364ff3207d795430cd927 0x8335616aed761f1f7f44e6bd49e807b9
 793 0xa402b9c5a8d3a6e75f16206c9c6209a7 0xcd036837130890a136dba887c37a8c10
 794 0x802221226be55a64c2494954da2c978a 0xa02aa96b06deb0fdf2db9baa10b7bd6d
 795 0xc83553c5c8965d3d6f92829494e5acc8 0xfa42a8b73abbf48ccb772339ba1f17fa
 796 0x9c69a97284b578d7ff2a760414536efc 0xc38413cf25e2d70dfef5138519684abb
 797 0xf46518c2ef5b8cd17eb258665fc25d6a 0x98bf2f79d5993802ef2f773ffbd97a62
 798 0xbeeefb584aff8603aafb550ffacfd8fb 0xeeaaba2e5dbf678495ba2a53f983cf39
 799 0x952ab45cfa97a0b2dd945a747bf26184 0xba756174393d88df94f971119aeef9e5
 800 0xe912b9d1478ceb177a37cd5601aab85e 0x91abb422ccb812eeac62e055c10ab33b
 801 0xb616a12b7fe617aa577b986b314d600a 0xe39c49765fdf9d94ed5a7e85fda0b80c
 802 0x8e41ade9fbebc27d14588f13be847308 0xb1d219647ae6b31c596eb2d8ae258fc9
 803 0xde469fbd99a05fe36fca5f8ed9aef3bc 0x8aec23d680043bee25de7bb9480d5855
 804 0xada72ccc20054ae9af561aa79a10ae6b 0xd910f7ff28069da41b2ba1518094da05
 805 0x87aa9aff7904228690fb44d2f05d0843 0xa99541bf57452b28353a1607ac744a54
 806 0xd3fa922f2d1675f242889b8997915ce9 0x847c9b5d7c2e09b769956135febada12
 807 0xa59bc234db398c2543fab9837e699096 0xcf02b2c21207ef2e94f967e45e03f4bc
 808 0x8161afb94b44f57d1d1be0eebac278f6 0xa1ba1ba79e1632dc6462d92a69731733
 809 0xca28a291859bbf937d7b8f7503cfdcff 0xfcb2cb35e702af785cda735244c3d43f
 810 0x9defbf01b061adab3a0888136afa64a8 0xc56baec21c7a1916088aaa1845b8fdd1
 811 0xf6c69a72a3989f5b8aad549e57273d46 0x9a3c2087a63f639936ac54e2f678864c
 812 0xc0cb28a98fcf3c7f84576a1bb416a7de 0xf0fdf2d3f3c30b9f656d44a2a11c51d6
 813 0x969eb7c47859e7439f644ae5a4b1b326 0xbc4665b596706114873d5d9f0dde1fef
 814 0xeb57ff22fc0c7959a90cb506d155a7eb 0x9316ff75dd87cbd809a7f12442d588f3
 815 0xb7dcbf5354e9bece0c11ed6d538aeb30 0xe5d3ef282a242e818f1668c8a86da5fb
 816 0x8fa475791a569d10f96e017d694487bd 0xb38d92d760ec445537c981dcc395a9ad
 817 0xe070f78d3927556a85bbe253f47b1418 0x8c469ab843b8956293956d7478ccec8f
 818 0xaf58416654a6babb387ac8d1970027b3 0xdb2e51bfe9d0696a06997b05fcc0319f
 819 0x88fcf317f22241e2441fece3bdf81f04 0xab3c2fddeeaad25ad527e81cad7626c4
 820 0xd60b3bd56a5586f18a71e223d8d3b075 0x85c7056562757456f6872d5667844e4a
 821 0xa738c6bebb12d16cb428f8ac016561dc 0xd106f86e69d785c7e13336d701beba53
 822 0x82a45b450226b39cecc0024661173474 0xa34d721642b0608427f002d7f95d0191
 823 0xcc20ce9bd35c78a531ec038df7b441f5 0xff290242c83396ce7e67047175a15272
 824 0x9f79a169bd203e410f0062c6e984d387 0xc75809c42c684dd152c07b78a3e60869
 825 0xf92e0c3537826145a7709a56ccdf8a83 0x9bbcc7a142b17ccb88a66076400bb692
 826 0xc2abf989935ddbfe6acff893d00ea436 0xf356f7ebf83552fe0583f6b8c4124d44
 827 0x98165af37b2153dec3727a337a8b704b 0xbe1bf1b059e9a8d6744f18c0592e4c5d
 828 0xeda2ee1c7064130c1162def06f79df74 0x9485d4d1c63e8be78addcb5645ac2ba9
 829 0xb9a74a0637ce2ee16d953e2bd7173693 0xe8111c87c5c1ba99c8fa8db6ccdd0438
 830 0x910ab1d4db9914a01d9c9892400a22a3 0xb54d5e4a127f59c82503beb6d00cab4c
 831 0xe2a0b5dc971f303a2e44ae64840fd61e 0x8da471a9de737e245ceaecfed289e5d3
 832 0xb10d8e1456105dad7425a83e872c5f48 0xdd50f1996b947518d12f124e28f7771a
 833 0x8a5296ffe33cc92f82bd6b70d99aaa70 0xace73cbfdc0bfb7b636cc64d1001550c
 834 0xd8210befd30efa5a3c47f7e05401aa4f 0x8714a775e3e95c7865acfaec34810a72
 835 0xa8d9d1535ce3b3967f1839a741a14d0e 0xd31045a8341ca07c1ede48111209a051
 836 0x83ea2b892091e44d934aed0aab460433 0xa4e4b66b68b65d60f81da84d56178540
 837 0xce1de40642e3f4b936251260ab9d668f 0x80d2ae83e9ce78f3c1d72b7c6b42601a
 838 0xa1075a24e4421730b24cf65b8612f820 0xc94930ae1d529cfcdee033f26797b628
 839 0xfb9b7cd9a4a7443c169840ef017da3b2 0x9d412e0806e88aa58e1f289560ee864f
 840 0xc491798a08a2ad4ef1a6f2bab92a27e3 0xf5b5d7ec8acb58a2ae10af696774b1dc
 841 0x9991a6f3d6bf1765acca6da1e0a8ef2a 0xbff610b0cc6edd3f17fd090a58d32af4
 842 0xeff394dcff8a948eddfc4b4cef07f5b1 0x95f83d0a1fb69cd94abdaf101564f98f
 843 0xbb764c4ca7a4440f9d6d1ad41abe37f2 0xea53df5fd18d551384c86189216dc5ee
 844 0x92746b9be2f8552c32fd3cf5b4e49bb5 0xb7118682dbb66a773fbc8c33221dc2a2
 845 0xe4d5e82392a405150fabaf3feaa5334b 0x8f05b1163ba6832d29cb4d87f2a7400f
 846 0xb2c71d5bca9023f8743e20e9ef511013 0xdf78e4b2bd342cf6914da9246b255417
 847 0x8bab8eefb6409c1a1ad089b6c2f7548f 0xae9672aba3d0c320a184ac2473b529b2
 848 0xda3c0f568cc4f3e8c9e5d72d90a2741f 0x8865899617fb18717e2fa67c7a658893
 849 0xaa7eebfb9df9de8dddbb901b98feeab8 0xd51ea6fa85785631552a74227f3ea566
 850 0x8533285c936b35ded53a88958f872760 0xa67ff273b84603568a892abaf368f138
 851 0xd01fef10a657842c2d2b7569b0432d86 0x8213f56a67f6b29b9c3b29620e29fc74
 852 0xa298f2c501f45f428349f3ba91b47b90 0xcb3f2f7642717713241c70a936219a74
 853 0xfe0efb53d30dd4d7ed238cd383aa0111 0x9ec95d1463e8a506f4363804324a40ab
 854 0xc67bb4597ce2ce48b143c6053edcd0d6 0xf81aa16fdc1b81dadd94b7868e94050b
 855 0x9b10a4e5e9913128ca7cf2b4191c8327 0xc1d4ce1f63f57d72fd1c2f611f63a3f1
 856 0xf24a01a73cf2dccfbc633b39673c8ced 0x976e41088617ca01d5be0503e085d814
 857 0xbd49d14aa79dbc824b2d8644d8a74e19 0xec9c459d51852ba2ddf8e7d60ed1219f
 858 0x93e1ab8252f33b45cabb90e5c942b504 0xb8da1662e7b00a173d6a751f3b936244
 859 0xe7109bfba19c0c9d0cc512670a783ad5 0x906a617d450187e227fb2b80668b24c6
 860 0xb484f9dc9641e9dab1f9f660802dedf7 0xe1a63853bbd264515e7873f8a0396974
 861 0x8d07e33455637eb2db0b487b6423e1e9 0xb049dc016abc5e5f91ce1a9a3d2cda63
 862 0xdc5c5301c56b75f77641a140cc7810fc 0x89b9b3e11b6329baa9e904c87fcb0a9e
 863 0xac2820d9623bf429546345fa9fbdcd45 0xd732290fbacaf133a97c177947ad4096
 864 0x867f59a9d4bed6c049ed8eabcccc485e 0xa81f301449ee8c705c68f256bfff5a75
 865 0xd226fc195c6a2f8c73832eec6fff3112 0x83585d8fd9c25db7c831fd53c5ff7eac
 866 0xa42e74f3d032f525ba3e7ca8b77f5e56 0xcd3a1230c43fb26f28ce1bd2e55f35ec
 867 0x80444b5e7aa7cf857980d163cf5b81b4 0xa0555e361951c366d7e105bcc3326220
 868 0xc86ab5c39fa634408dd9472bf3fefaa8 0xfa856334878fc150b14f98f6f0feb952
 869 0x9c935e00d4b9d8d26ed1bf9a569f33d4 0xc3b8358109e84f070a862f80ec4700c9
 870 0xf4a642e14c6262c8cd27bb612758c0fb 0x98e7e9cccfbd7dbd8038d51cb897789d
 871 0xbf21e44003acdd2ce0470a63e6bd56c4 0xeeea5d50049814781858ccfce06cac75
 872 0x95527a5202df0ccb0f37801e0c43ebc9 0xbaa718e68396cffdd30560258f54e6bb
 873 0xe950df20247c83fd47c6b82ef32a206a 0x91d28b7416cdd27e4cdc331d57fa5442
 874 0xb6472e511c81471de0133fe4adf8e953 0xe3d8f9e563a198e558180fddd97723a7
 875 0x8e679c2f5e44ff8f570f09eaa7ea7649 0xb201833b35d63f732cd2cc6551e513db
 876 0xde81e40a034bcf4ff8077f7ea65e58d2 0x8b112e86420f6191fb04afaf27faf783
 877 0xadd57a27d29339f679c5db9af1f9b564 0xd94ad8b1c738087418375281ae7822bd
 878 0x87cec76f1c8305488f2293910d0b15b6 0xa9c2794ae3a3c69ab2eb3875504ddb23
 879 0xd433179d9c8cb8415fa60692a46151ec 0x849feec281d7f328dbc7c41ba6bcd334
 880 0xa5c7ea73224deff312b9b522906c0801 0xcf39e50feae16befd768226b34870a01
 881 0x81842f29f2cce375e6a1158300d46641 0xa1e53af46f801c5360495ae3c1097fd1
 882 0xca5e89b18b602368385bb19cb14bdfc5 0xfcf62c1dee382c4246729e03dd9ed7b6
 883 0x9e19db92b4e31ba96c07a2c26a8346d2 0xc5a05277621be293c7098b7305241886
 884 0xf70867153aa2db38b8cbee4fc66d1ea8
 885 }
 886
 887 : φ ( k -- φ ) 290 + lookup-table nth ; inline
 888
 889 : β ( E k -- β ) ⌊nlog2_10⌋ + ; inline
 890
 891 :: wi ( F φ β n parity? -- wi wi? )
 892     F 2 * n + φ * β 128 -
 893     [ shift parity? [ odd? ] when ]
 894     [ neg 2^ 1 - bitand zero? ] 2bi ; inline
 895
 896 : xi ( F φ β -- xi-odd? xi? ) -1 t wi ; inline
 897 : yi ( F φ β -- yi-odd? yi? )  0 t wi ; inline
 898 : zi ( F φ β -- zi      zi? )  1 f wi ; inline
 899
 900 : s/r ( zi -- s r ) [ 1000/ ] keep over 1000 * - ; inline
 901
 902 : δi ( φ β -- δi ) 127 - shift ; inline
 903
 904 : strip-zeroes ( s -- s' d )
 905     0 [
 906         over 10 /mod zero?
 907         [ [ nipd swap 1 + ] [ drop ] if ] keep
 908     ] loop ; inline
 909
 910 :: normal-interval ( F E -- f e )
 911     F even? :> w∈I?
 912     E k :> k
 913     k φ :> φ
 914     E k β :> β
 915     φ β δi :> δi
 916     F φ β zi :> ( zi zi? )
 917     zi s/r
 918     dup δi 2dup > [ 2drop f ] [
 919         number= [
 920             F φ β xi :> ( xi-odd? xi? )
 921             xi-odd? [ w∈I? not xi? or ] unless*
 922         ] [
 923             w∈I? not over zero? zi? and and
 924             [ [ [ 1 - ] [ drop 1000 ] bi* ] when ] keep not
 925         ] if
 926     ] if [
 927         drop strip-zeroes k - 3 +
 928     ] [
 929         50 + δi 2/ - :> D
 930         D 100/mod :> ( t ρ≠0? )
 931         10 * t + ρ≠0? [
 932             F φ β yi :> ( yi-odd? yi? )
 933             D 50 - even? yi-odd? eq? over odd? yi? and or [
 934                 1 -
 935             ] when
 936         ] unless 2 k -
 937     ] if ; inline
 938
 939 : k0 ( E -- k0 ) ⌊nlog10_2-log10_4/3⌋ neg ; inline
 940
 941 :: w̃i ( φ β w∈I? E n1 q1 n2 q2 n3 -- w̃i )
 942     φ -64 2dup 52 - n1 - [ shift ] 2bi@ q1 call β 11 - shift
 943     w∈I? E n2 3 between? q2 call [ n3 + ] unless ; inline
 944
 945 : x̃i ( φ β x∈I? E -- x̃i ) 2 [ - ] 2 [ and    ]  1 w̃i ; inline
 946 : z̃i ( φ β z∈I? E -- z̃i ) 1 [ + ] 0 [ not or ] -1 w̃i ; inline
 947
 948 : yru ( φ β -- yru ) 74 - shift 1 + 2/ ; inline
 949
 950 :: shorter-interval ( F E -- f e )
 951     E k0 :> k0
 952     k0 φ :> φ
 953     E k0 β :> β
 954     F even? :> w∈I?
 955     φ β w∈I? E x̃i :> x̃i
 956     φ β w∈I? E z̃i :> z̃i
 957     z̃i 10 /i :> z̃i*
 958     x̃i z̃i* 10 * <= [ z̃i* strip-zeroes k0 - 1 + ] [
 959         φ β yru :> yru
 960         yru E -77 number= [
 961             yru odd? [ 1 - ] when
 962         ] [
 963             yru x̃i >= [ 1 + ] unless
 964         ] if k0 neg
 965     ] if ; inline
 966
 967 : dragonbox ( s F E -- s f e )
 968     [ mantissa-expt-normalize* ] [ shorter-interval? ] 2bi
 969     [ shorter-interval ] [ normal-interval ] if ; inline
 970
 971 : ?minus ( accum ? -- accum ) [ CHAR: - suffix! ] when ; inline
 972
 973 : ?exponent ( accum e -- accum )
 974     [ CHAR: e suffix! ] dip
 975     [ 0 >= [ CHAR: + suffix! ] when ]
 976     [ >dec append! ] bi ; inline
 977
 978 : exponential-format ( neg? f-str f-len e -- sbuf )
 979     + 1 - [ 24 <sbuf> ] 3dip
 980     [ ?minus ]
 981     [ unclip-slice pick push [
 982         CHAR: . pick push append!
 983     ] unless-empty ]
 984     [ ?exponent ] tri* ; inline
 985
 986 : decimal-format ( neg? f-str f-len e -- sbuf )
 987     [ 19 <sbuf> ] 4dip {
 988         { [ dup 0 >= ] [ nip 0 swap 1 ] }
 989         { [ 2dup neg <= ] [ over + neg 1 swap ] }
 990         [ nip neg 0 0 ]
 991     } cond [ cut-slice* ] 2dip rot {
 992         [ ?minus ]
 993         [ append! ]
 994         [ CHAR: 0 <string> append! CHAR: . suffix! ]
 995         [ CHAR: 0 <string> append! ]
 996         [ append! ]
 997     } spread ; inline
 998
 999 : (format) ( neg? f e quot -- str )
1000     [ >dec dup length ] 2dip call "" like ; inline
1001
1002 : general-format ( neg? f e -- str )
1003     [
1004         2dup [ + ] [ neg ] bi [ 0 max ] bi@ + 17 >
1005         [ exponential-format ] [ decimal-format ] if
1006     ] (format) ; inline
1007
1008 : float>dec ( n -- str ) >float< dragonbox general-format ; inline
1009
1010 : float>base ( n radix -- str )
1011     {
1012         { 10 [ float>dec ] }
1013         [ bin-float>base ]
1014     } case ; inline
1015
1016 PRIVATE>
1017
1018 M: float >base
1019     {
1020         { [ over fp-nan? ] [ drop fp-sign "-0/0." "0/0." ? ] }
1021         { [ over 1/0. =  ] [ 2drop "1/0." ] }
1022         { [ over -1/0. = ] [ 2drop "-1/0." ] }
1023         { [ over  0.0 fp-bitwise= ] [ 2drop  "0.0" ] }
1024         { [ over -0.0 fp-bitwise= ] [ 2drop "-0.0" ] }
1025         [ float>base ]
1026     } cond ;
1027
1028 : # ( n -- ) number>string % ; inline
1029
1030 ERROR: invalid-hex-string-length n ;
1031
1032 : hex-string>bytes ( hex-string -- bytes )
1033     dup length dup even? [ invalid-hex-string-length ] unless 2/ <byte-array> [
1034         [
1035             [ digit> ] 2dip over even? [
1036                 [ 16 * ] [ 2/ ] [ set-nth-unsafe ] tri*
1037             ] [
1038                 [ 2/ ] [ [ + ] change-nth-unsafe ] bi*
1039             ] if
1040         ] curry each-index
1041     ] keep ;
1042
1043 : bytes>hex-string ( bytes -- hex-string )
1044     dup length 2 * CHAR: 0 <string> [
1045         [
1046             [ 16 /mod [ >digit ] bi@ ]
1047             [ 2 * dup 1 + ]
1048             [ [ set-nth-unsafe ] curry bi-curry@ bi* ] tri*
1049         ] curry each-index
1050     ] keep ;