00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021
00022
00023
00024
00025
00026
00027
00028
00029
00030
00031
00032
00033
00034
00035
00036
00037
00038
00039
00040
00041
00042
00043
00044
00045
00046
00047
00048
00049
00050
00051
00052
00053
00054
00055
00056
00057
00058
00059
00060
00061
00062
00063
00064
00065
00066
00067
00068
00069
00070
00071
00072
00073
00074
00075
00076
00077
00078
00079
00080
00081
00082
00083
00084
00085
00086
00087
00088
00089
00090
00091
00092
00093
00094
00095
00096
00097
00098
00099
00100
00101
00102
00103
00104
00105
00106
00107
00108
00109
00110
00111
00112
00113
00114
00115
00116
00117
00118
00119
00120
00121
00122
00123
00124
00125
00126
00127
00128
00129
00130
00131
00132
00133
00134
00135
00136
00137
00138
00139
00140
00141
00142
00143
00144
00145
00146
00147
00148
00149
00150
00151
00152
00153
00154
00155
00156
00157
00158
00159
00160
00161
00162
00163
00164
00165
00166
00167
00168
00175 #include "OSConfig.h"
00176 #include "OSdtoa.h"
00177 #include "OSParameters.h"
00178
00179
00180
00181 #ifdef WORDS_BIGENDIAN
00182 #define IEEE_MC68k
00183 #else
00184 #define IEEE_8087
00185 #endif
00186
00187 #define INFNAN_CHECK
00188
00189
00190
00191 #define NO_LONG_LONG
00192 #define Just_16
00193
00194
00195
00196
00197
00198
00199
00200
00201 #if SIZEOF_LONG == 2*SIZEOF_INT
00202 #define Long int
00203 #define Intcast (int)(long)
00204 #endif
00205
00206
00217 #ifndef Long
00218 #define Long long
00219 #endif
00220
00221
00222 #ifndef ULong
00223 typedef unsigned Long ULong;
00224 #endif
00225
00226 #ifdef DEBUG
00227 #include "stdio.h"
00228 #define Bug(x) {fprintf(stderr, "%s\n", x); exit(1);}
00229 #endif
00230
00231 #include "stdlib.h"
00232 #include "string.h"
00233
00234 #ifdef USE_LOCALE
00235 #include "locale.h"
00236 #endif
00237
00238 #ifdef MALLOC
00239 #ifdef KR_headers
00240 extern char *MALLOC();
00241 #else
00242 extern void *MALLOC(size_t);
00243 #endif
00244 #else
00245 #define MALLOC malloc
00246 #endif
00247
00248 #ifndef Omit_Private_Memory
00249 #ifndef PRIVATE_MEM
00250 #define PRIVATE_MEM 2304
00251 #endif
00252 #define PRIVATE_mem ((PRIVATE_MEM+sizeof(double)-1)/sizeof(double))
00253 static double private_mem[PRIVATE_mem], *pmem_next = private_mem;
00254 #endif
00255
00256 #undef IEEE_Arith
00257 #undef Avoid_Underflow
00258 #ifdef IEEE_MC68k
00259 #define IEEE_Arith
00260 #endif
00261 #ifdef IEEE_8087
00262 #define IEEE_Arith
00263 #endif
00264
00265 #ifdef IEEE_Arith
00266 #ifndef NO_INFNAN_CHECK
00267 #undef INFNAN_CHECK
00268 #define INFNAN_CHECK
00269 #endif
00270 #else
00271 #undef INFNAN_CHECK
00272 #endif
00273
00274 #include "errno.h"
00275
00276 #ifdef Bad_float_h
00277
00278 #ifdef IEEE_Arith
00279 #define DBL_DIG 15
00280 #define DBL_MAX_10_EXP 308
00281 #define DBL_MAX_EXP 1024
00282 #define FLT_RADIX 2
00283 #endif
00284
00285 #ifdef IBM
00286 #define DBL_DIG 16
00287 #define DBL_MAX_10_EXP 75
00288 #define DBL_MAX_EXP 63
00289 #define FLT_RADIX 16
00290 #define DBL_MAX 7.2370055773322621e+75
00291 #endif
00292
00293 #ifdef VAX
00294 #define DBL_DIG 16
00295 #define DBL_MAX_10_EXP 38
00296 #define DBL_MAX_EXP 127
00297 #define FLT_RADIX 2
00298 #define DBL_MAX 1.7014118346046923e+38
00299 #endif
00300
00301 #ifndef LONG_MAX
00302 #define LONG_MAX 2147483647
00303 #endif
00304
00305 #else
00306 #include "float.h"
00307 #endif
00308
00309 #ifndef __MATH_H__
00310 #include "math.h"
00311 #endif
00312
00313 #ifdef __cplusplus
00314 extern "C" {
00315 #endif
00316
00317 #ifndef CONST
00318 #ifdef KR_headers
00319 #define CONST
00320 #else
00321 #define CONST const
00322 #endif
00323 #endif
00324
00325 #if defined(IEEE_8087) + defined(IEEE_MC68k) + defined(VAX) + defined(IBM) != 1
00326 Exactly one of IEEE_8087, IEEE_MC68k, VAX, or IBM should be defined.
00327 #endif
00328
00329 typedef union { double d; ULong L[2]; } U;
00330
00331 #ifdef YES_ALIAS
00332 #define dval(x) x
00333 #ifdef IEEE_8087
00334 #define word0(x) ((ULong *)&x)[1]
00335 #define word1(x) ((ULong *)&x)[0]
00336 #else
00337 #define word0(x) ((ULong *)&x)[0]
00338 #define word1(x) ((ULong *)&x)[1]
00339 #endif
00340 #else
00341 #ifdef IEEE_8087
00342 #define word0(x) ((U*)&x)->L[1]
00343 #define word1(x) ((U*)&x)->L[0]
00344 #else
00345 #define word0(x) ((U*)&x)->L[0]
00346 #define word1(x) ((U*)&x)->L[1]
00347 #endif
00348 #define dval(x) ((U*)&x)->d
00349 #endif
00350
00351
00352
00353
00354
00355 #if defined(IEEE_8087) + defined(VAX)
00356 #define Storeinc(a,b,c) (((unsigned short *)a)[1] = (unsigned short)b, \
00357 ((unsigned short *)a)[0] = (unsigned short)c, a++)
00358 #else
00359 #define Storeinc(a,b,c) (((unsigned short *)a)[0] = (unsigned short)b, \
00360 ((unsigned short *)a)[1] = (unsigned short)c, a++)
00361 #endif
00362
00363
00364
00365
00366
00367
00368
00369 #ifdef IEEE_Arith
00370 #define Exp_shift 20
00371 #define Exp_shift1 20
00372 #define Exp_msk1 0x100000
00373 #define Exp_msk11 0x100000
00374 #define Exp_mask 0x7ff00000
00375 #define P 53
00376 #define Bias 1023
00377 #define Emin (-1022)
00378 #define Exp_1 0x3ff00000
00379 #define Exp_11 0x3ff00000
00380 #define Ebits 11
00381 #define Frac_mask 0xfffff
00382 #define Frac_mask1 0xfffff
00383 #define Ten_pmax 22
00384 #define Bletch 0x10
00385 #define Bndry_mask 0xfffff
00386 #define Bndry_mask1 0xfffff
00387 #define LSB 1
00388 #define Sign_bit 0x80000000
00389 #define Log2P 1
00390 #define Tiny0 0
00391 #define Tiny1 1
00392 #define Quick_max 14
00393 #define Int_max 14
00394 #ifndef NO_IEEE_Scale
00395 #define Avoid_Underflow
00396 #ifdef Flush_Denorm
00397 #undef Sudden_Underflow
00398 #endif
00399 #endif
00400
00401 #ifndef Flt_Rounds
00402 #ifdef FLT_ROUNDS
00403 #define Flt_Rounds FLT_ROUNDS
00404 #else
00405 #define Flt_Rounds 1
00406 #endif
00407 #endif
00408
00409 #ifdef Honor_FLT_ROUNDS
00410 #define Rounding rounding
00411 #undef Check_FLT_ROUNDS
00412 #define Check_FLT_ROUNDS
00413 #else
00414 #define Rounding Flt_Rounds
00415 #endif
00416
00417 #else
00418 #undef Check_FLT_ROUNDS
00419 #undef Honor_FLT_ROUNDS
00420 #undef SET_INEXACT
00421 #undef Sudden_Underflow
00422 #define Sudden_Underflow
00423 #ifdef IBM
00424 #undef Flt_Rounds
00425 #define Flt_Rounds 0
00426 #define Exp_shift 24
00427 #define Exp_shift1 24
00428 #define Exp_msk1 0x1000000
00429 #define Exp_msk11 0x1000000
00430 #define Exp_mask 0x7f000000
00431 #define P 14
00432 #define Bias 65
00433 #define Exp_1 0x41000000
00434 #define Exp_11 0x41000000
00435 #define Ebits 8
00436 #define Frac_mask 0xffffff
00437 #define Frac_mask1 0xffffff
00438 #define Bletch 4
00439 #define Ten_pmax 22
00440 #define Bndry_mask 0xefffff
00441 #define Bndry_mask1 0xffffff
00442 #define LSB 1
00443 #define Sign_bit 0x80000000
00444 #define Log2P 4
00445 #define Tiny0 0x100000
00446 #define Tiny1 0
00447 #define Quick_max 14
00448 #define Int_max 15
00449 #else
00450 #undef Flt_Rounds
00451 #define Flt_Rounds 1
00452 #define Exp_shift 23
00453 #define Exp_shift1 7
00454 #define Exp_msk1 0x80
00455 #define Exp_msk11 0x800000
00456 #define Exp_mask 0x7f80
00457 #define P 56
00458 #define Bias 129
00459 #define Exp_1 0x40800000
00460 #define Exp_11 0x4080
00461 #define Ebits 8
00462 #define Frac_mask 0x7fffff
00463 #define Frac_mask1 0xffff007f
00464 #define Ten_pmax 24
00465 #define Bletch 2
00466 #define Bndry_mask 0xffff007f
00467 #define Bndry_mask1 0xffff007f
00468 #define LSB 0x10000
00469 #define Sign_bit 0x8000
00470 #define Log2P 1
00471 #define Tiny0 0x80
00472 #define Tiny1 0
00473 #define Quick_max 15
00474 #define Int_max 15
00475 #endif
00476 #endif
00477
00478 #ifndef IEEE_Arith
00479 #define ROUND_BIASED
00480 #endif
00481
00482 #ifdef RND_PRODQUOT
00483 #define rounded_product(a,b) a = rnd_prod(a, b)
00484 #define rounded_quotient(a,b) a = rnd_quot(a, b)
00485 #ifdef KR_headers
00486 extern double rnd_prod(), rnd_quot();
00487 #else
00488 extern double rnd_prod(double, double), rnd_quot(double, double);
00489 #endif
00490 #else
00491 #define rounded_product(a,b) a *= b
00492 #define rounded_quotient(a,b) a /= b
00493 #endif
00494
00495 #define Big0 (Frac_mask1 | Exp_msk1*(DBL_MAX_EXP+Bias-1))
00496 #define Big1 0xffffffff
00497
00498 #ifndef Pack_32
00499 #define Pack_32
00500 #endif
00501
00502 #ifdef KR_headers
00503 #define FFFFFFFF ((((unsigned long)0xffff)<<16)|(unsigned long)0xffff)
00504 #else
00505 #define FFFFFFFF 0xffffffffUL
00506 #endif
00507
00508 #ifdef NO_LONG_LONG
00509 #undef ULLong
00510 #ifdef Just_16
00511 #undef Pack_32
00512
00513
00514
00515
00516
00517 #endif
00518 #else
00519 #ifndef Llong
00520 #define Llong long long
00521 #endif
00522 #ifndef ULLong
00523 #define ULLong unsigned Llong
00524 #endif
00525 #endif
00526
00527 #ifndef MULTIPLE_THREADS
00528 #define ACQUIRE_DTOA_LOCK(n)
00529 #define FREE_DTOA_LOCK(n)
00530 #endif
00531
00532 #define Kmax 15
00533
00534 #ifdef __cplusplus
00535 extern "C" double os_strtod(const char *s00, char **se);
00536 extern "C" char *os_dtoa(double d, int mode, int ndigits,
00537 int *decpt, int *sign, char **rve);
00538 #endif
00539
00540 struct
00541 Bigint {
00542 struct Bigint *next;
00543 int k, maxwds, sign, wds;
00544 ULong x[1];
00545 };
00546
00547 typedef struct Bigint Bigint;
00548
00549 static Bigint *freelist[Kmax+1];
00550
00551 static Bigint *
00552 Balloc
00553 #ifdef KR_headers
00554 (k) int k;
00555 #else
00556 (int k)
00557 #endif
00558 {
00559 int x;
00560 Bigint *rv;
00561 #ifndef Omit_Private_Memory
00562 unsigned int len;
00563 #endif
00564
00565 ACQUIRE_DTOA_LOCK(0);
00566 if ( (rv = freelist[k]) ) {
00567 freelist[k] = rv->next;
00568 }
00569 else {
00570 x = 1 << k;
00571 #ifdef Omit_Private_Memory
00572 rv = (Bigint *)MALLOC(sizeof(Bigint) + (x-1)*sizeof(ULong));
00573 #else
00574 len = (sizeof(Bigint) + (x-1)*sizeof(ULong) + sizeof(double) - 1)
00575 /sizeof(double);
00576 unsigned int tmpInt = PRIVATE_mem;
00577
00578 if (pmem_next - private_mem + len <= tmpInt) {
00579 rv = (Bigint*)pmem_next;
00580 pmem_next += len;
00581 }
00582 else
00583 rv = (Bigint*)MALLOC(len*sizeof(double));
00584 #endif
00585 rv->k = k;
00586 rv->maxwds = x;
00587 }
00588 FREE_DTOA_LOCK(0);
00589 rv->sign = rv->wds = 0;
00590 return rv;
00591 }
00592
00593 static void
00594 Bfree
00595 #ifdef KR_headers
00596 (v) Bigint *v;
00597 #else
00598 (Bigint *v)
00599 #endif
00600 {
00601 if (v) {
00602 ACQUIRE_DTOA_LOCK(0);
00603 v->next = freelist[v->k];
00604 freelist[v->k] = v;
00605 FREE_DTOA_LOCK(0);
00606 }
00607 }
00608
00609 #define Bcopy(x,y) memcpy((char *)&x->sign, (char *)&y->sign, \
00610 y->wds*sizeof(Long) + 2*sizeof(int))
00611
00612 static Bigint *
00613 multadd
00614 #ifdef KR_headers
00615 (b, m, a) Bigint *b; int m, a;
00616 #else
00617 (Bigint *b, int m, int a)
00618 #endif
00619 {
00620 int i, wds;
00621 #ifdef ULLong
00622 ULong *x;
00623 ULLong carry, y;
00624 #else
00625 ULong carry, *x, y;
00626 #ifdef Pack_32
00627 ULong xi, z;
00628 #endif
00629 #endif
00630 Bigint *b1;
00631
00632 wds = b->wds;
00633 x = b->x;
00634 i = 0;
00635 carry = a;
00636 do {
00637 #ifdef ULLong
00638 y = *x * (ULLong)m + carry;
00639 carry = y >> 32;
00640 *x++ = y & FFFFFFFF;
00641 #else
00642 #ifdef Pack_32
00643 xi = *x;
00644 y = (xi & 0xffff) * m + carry;
00645 z = (xi >> 16) * m + (y >> 16);
00646 carry = z >> 16;
00647 *x++ = (z << 16) + (y & 0xffff);
00648 #else
00649 y = *x * m + carry;
00650 carry = y >> 16;
00651 *x++ = y & 0xffff;
00652 #endif
00653 #endif
00654 }
00655 while(++i < wds);
00656 if (carry) {
00657 if (wds >= b->maxwds) {
00658 b1 = Balloc(b->k+1);
00659 Bcopy(b1, b);
00660 Bfree(b);
00661 b = b1;
00662 }
00663 b->x[wds++] = carry;
00664 b->wds = wds;
00665 }
00666 return b;
00667 }
00668
00669 static Bigint *
00670 s2b
00671 #ifdef KR_headers
00672 (s, nd0, nd, y9) CONST char *s; int nd0, nd; ULong y9;
00673 #else
00674 (CONST char *s, int nd0, int nd, ULong y9)
00675 #endif
00676 {
00677 Bigint *b;
00678 int i, k;
00679 Long x, y;
00680
00681 x = (nd + 8) / 9;
00682 for(k = 0, y = 1; x > y; y <<= 1, k++) ;
00683 #ifdef Pack_32
00684 b = Balloc(k);
00685 b->x[0] = y9;
00686 b->wds = 1;
00687 #else
00688 b = Balloc(k+1);
00689 b->x[0] = y9 & 0xffff;
00690 b->wds = (b->x[1] = y9 >> 16) ? 2 : 1;
00691 #endif
00692
00693 i = 9;
00694 if (9 < nd0) {
00695 s += 9;
00696 do b = multadd(b, 10, *s++ - '0');
00697 while(++i < nd0);
00698 s++;
00699 }
00700 else
00701 s += 10;
00702 for(; i < nd; i++)
00703 b = multadd(b, 10, *s++ - '0');
00704 return b;
00705 }
00706
00707 static int
00708 hi0bits
00709 #ifdef KR_headers
00710 (x) register ULong x;
00711 #else
00712 (register ULong x)
00713 #endif
00714 {
00715 register int k = 0;
00716
00717 if (!(x & 0xffff0000)) {
00718 k = 16;
00719 x <<= 16;
00720 }
00721 if (!(x & 0xff000000)) {
00722 k += 8;
00723 x <<= 8;
00724 }
00725 if (!(x & 0xf0000000)) {
00726 k += 4;
00727 x <<= 4;
00728 }
00729 if (!(x & 0xc0000000)) {
00730 k += 2;
00731 x <<= 2;
00732 }
00733 if (!(x & 0x80000000)) {
00734 k++;
00735 if (!(x & 0x40000000))
00736 return 32;
00737 }
00738 return k;
00739 }
00740
00741 static int
00742 lo0bits
00743 #ifdef KR_headers
00744 (y) ULong *y;
00745 #else
00746 (ULong *y)
00747 #endif
00748 {
00749 register int k;
00750 register ULong x = *y;
00751
00752 if (x & 7) {
00753 if (x & 1)
00754 return 0;
00755 if (x & 2) {
00756 *y = x >> 1;
00757 return 1;
00758 }
00759 *y = x >> 2;
00760 return 2;
00761 }
00762 k = 0;
00763 if (!(x & 0xffff)) {
00764 k = 16;
00765 x >>= 16;
00766 }
00767 if (!(x & 0xff)) {
00768 k += 8;
00769 x >>= 8;
00770 }
00771 if (!(x & 0xf)) {
00772 k += 4;
00773 x >>= 4;
00774 }
00775 if (!(x & 0x3)) {
00776 k += 2;
00777 x >>= 2;
00778 }
00779 if (!(x & 1)) {
00780 k++;
00781 x >>= 1;
00782 if (!x)
00783 return 32;
00784 }
00785 *y = x;
00786 return k;
00787 }
00788
00789 static Bigint *
00790 i2b
00791 #ifdef KR_headers
00792 (i) int i;
00793 #else
00794 (int i)
00795 #endif
00796 {
00797 Bigint *b;
00798
00799 b = Balloc(1);
00800 b->x[0] = i;
00801 b->wds = 1;
00802 return b;
00803 }
00804
00805 static Bigint *
00806 mult
00807 #ifdef KR_headers
00808 (a, b) Bigint *a, *b;
00809 #else
00810 (Bigint *a, Bigint *b)
00811 #endif
00812 {
00813 Bigint *c;
00814 int k, wa, wb, wc;
00815 ULong *x, *xa, *xae, *xb, *xbe, *xc, *xc0;
00816 ULong y;
00817 #ifdef ULLong
00818 ULLong carry, z;
00819 #else
00820 ULong carry, z;
00821 #ifdef Pack_32
00822 ULong z2;
00823 #endif
00824 #endif
00825
00826 if (a->wds < b->wds) {
00827 c = a;
00828 a = b;
00829 b = c;
00830 }
00831 k = a->k;
00832 wa = a->wds;
00833 wb = b->wds;
00834 wc = wa + wb;
00835 if (wc > a->maxwds)
00836 k++;
00837 c = Balloc(k);
00838 for(x = c->x, xa = x + wc; x < xa; x++)
00839 *x = 0;
00840 xa = a->x;
00841 xae = xa + wa;
00842 xb = b->x;
00843 xbe = xb + wb;
00844 xc0 = c->x;
00845 #ifdef ULLong
00846 for(; xb < xbe; xc0++) {
00847 if (y = *xb++) {
00848 x = xa;
00849 xc = xc0;
00850 carry = 0;
00851 do {
00852 z = *x++ * (ULLong)y + *xc + carry;
00853 carry = z >> 32;
00854 *xc++ = z & FFFFFFFF;
00855 }
00856 while(x < xae);
00857 *xc = carry;
00858 }
00859 }
00860 #else
00861 #ifdef Pack_32
00862 for(; xb < xbe; xb++, xc0++) {
00863 if (y = *xb & 0xffff) {
00864 x = xa;
00865 xc = xc0;
00866 carry = 0;
00867 do {
00868 z = (*x & 0xffff) * y + (*xc & 0xffff) + carry;
00869 carry = z >> 16;
00870 z2 = (*x++ >> 16) * y + (*xc >> 16) + carry;
00871 carry = z2 >> 16;
00872 Storeinc(xc, z2, z);
00873 }
00874 while(x < xae);
00875 *xc = carry;
00876 }
00877 if (y = *xb >> 16) {
00878 x = xa;
00879 xc = xc0;
00880 carry = 0;
00881 z2 = *xc;
00882 do {
00883 z = (*x & 0xffff) * y + (*xc >> 16) + carry;
00884 carry = z >> 16;
00885 Storeinc(xc, z, z2);
00886 z2 = (*x++ >> 16) * y + (*xc & 0xffff) + carry;
00887 carry = z2 >> 16;
00888 }
00889 while(x < xae);
00890 *xc = z2;
00891 }
00892 }
00893 #else
00894 for(; xb < xbe; xc0++) {
00895 if ( (y = *xb++) ) {
00896 x = xa;
00897 xc = xc0;
00898 carry = 0;
00899 do {
00900 z = *x++ * y + *xc + carry;
00901 carry = z >> 16;
00902 *xc++ = z & 0xffff;
00903 }
00904 while(x < xae);
00905 *xc = carry;
00906 }
00907 }
00908 #endif
00909 #endif
00910 for(xc0 = c->x, xc = xc0 + wc; wc > 0 && !*--xc; --wc) ;
00911 c->wds = wc;
00912 return c;
00913 }
00914
00915 static Bigint *p5s;
00916
00917 static Bigint *
00918 pow5mult
00919 #ifdef KR_headers
00920 (b, k) Bigint *b; int k;
00921 #else
00922 (Bigint *b, int k)
00923 #endif
00924 {
00925 Bigint *b1, *p5, *p51;
00926 int i;
00927 static int p05[3] = { 5, 25, 125 };
00928
00929 if ( (i = k & 3 ))
00930 b = multadd(b, p05[i-1], 0);
00931
00932 if (!(k >>= 2))
00933 return b;
00934 if (!(p5 = p5s)) {
00935
00936 #ifdef MULTIPLE_THREADS
00937 ACQUIRE_DTOA_LOCK(1);
00938 if (!(p5 = p5s)) {
00939 p5 = p5s = i2b(625);
00940 p5->next = 0;
00941 }
00942 FREE_DTOA_LOCK(1);
00943 #else
00944 p5 = p5s = i2b(625);
00945 p5->next = 0;
00946 #endif
00947 }
00948 for(;;) {
00949 if (k & 1) {
00950 b1 = mult(b, p5);
00951 Bfree(b);
00952 b = b1;
00953 }
00954 if (!(k >>= 1))
00955 break;
00956 if (!(p51 = p5->next)) {
00957 #ifdef MULTIPLE_THREADS
00958 ACQUIRE_DTOA_LOCK(1);
00959 if (!(p51 = p5->next)) {
00960 p51 = p5->next = mult(p5,p5);
00961 p51->next = 0;
00962 }
00963 FREE_DTOA_LOCK(1);
00964 #else
00965 p51 = p5->next = mult(p5,p5);
00966 p51->next = 0;
00967 #endif
00968 }
00969 p5 = p51;
00970 }
00971 return b;
00972 }
00973
00974 static Bigint *
00975 lshift
00976 #ifdef KR_headers
00977 (b, k) Bigint *b; int k;
00978 #else
00979 (Bigint *b, int k)
00980 #endif
00981 {
00982 int i, k1, n, n1;
00983 Bigint *b1;
00984 ULong *x, *x1, *xe, z;
00985
00986 #ifdef Pack_32
00987 n = k >> 5;
00988 #else
00989 n = k >> 4;
00990 #endif
00991 k1 = b->k;
00992 n1 = n + b->wds + 1;
00993 for(i = b->maxwds; n1 > i; i <<= 1)
00994 k1++;
00995 b1 = Balloc(k1);
00996 x1 = b1->x;
00997 for(i = 0; i < n; i++)
00998 *x1++ = 0;
00999 x = b->x;
01000 xe = x + b->wds;
01001 #ifdef Pack_32
01002 if (k &= 0x1f) {
01003 k1 = 32 - k;
01004 z = 0;
01005 do {
01006 *x1++ = *x << k | z;
01007 z = *x++ >> k1;
01008 }
01009 while(x < xe);
01010 if (*x1 = z)
01011 ++n1;
01012 }
01013 #else
01014 if (k &= 0xf) {
01015 k1 = 16 - k;
01016 z = 0;
01017 do {
01018 *x1++ = *x << k & 0xffff | z;
01019 z = *x++ >> k1;
01020 }
01021 while(x < xe);
01022 if ( (*x1 = z ))
01023 ++n1;
01024 }
01025 #endif
01026 else do
01027 *x1++ = *x++;
01028 while(x < xe);
01029 b1->wds = n1 - 1;
01030 Bfree(b);
01031 return b1;
01032 }
01033
01034 static int
01035 cmp
01036 #ifdef KR_headers
01037 (a, b) Bigint *a, *b;
01038 #else
01039 (Bigint *a, Bigint *b)
01040 #endif
01041 {
01042 ULong *xa, *xa0, *xb, *xb0;
01043 int i, j;
01044
01045 i = a->wds;
01046 j = b->wds;
01047 #ifdef DEBUG
01048 if (i > 1 && !a->x[i-1])
01049 Bug("cmp called with a->x[a->wds-1] == 0");
01050 if (j > 1 && !b->x[j-1])
01051 Bug("cmp called with b->x[b->wds-1] == 0");
01052 #endif
01053 if (i -= j)
01054 return i;
01055 xa0 = a->x;
01056 xa = xa0 + j;
01057 xb0 = b->x;
01058 xb = xb0 + j;
01059 for(;;) {
01060 if (*--xa != *--xb)
01061 return *xa < *xb ? -1 : 1;
01062 if (xa <= xa0)
01063 break;
01064 }
01065 return 0;
01066 }
01067
01068 static Bigint *
01069 diff
01070 #ifdef KR_headers
01071 (a, b) Bigint *a, *b;
01072 #else
01073 (Bigint *a, Bigint *b)
01074 #endif
01075 {
01076 Bigint *c;
01077 int i, wa, wb;
01078 ULong *xa, *xae, *xb, *xbe, *xc;
01079 #ifdef ULLong
01080 ULLong borrow, y;
01081 #else
01082 ULong borrow, y;
01083 #ifdef Pack_32
01084 ULong z;
01085 #endif
01086 #endif
01087
01088 i = cmp(a,b);
01089 if (!i) {
01090 c = Balloc(0);
01091 c->wds = 1;
01092 c->x[0] = 0;
01093 return c;
01094 }
01095 if (i < 0) {
01096 c = a;
01097 a = b;
01098 b = c;
01099 i = 1;
01100 }
01101 else
01102 i = 0;
01103 c = Balloc(a->k);
01104 c->sign = i;
01105 wa = a->wds;
01106 xa = a->x;
01107 xae = xa + wa;
01108 wb = b->wds;
01109 xb = b->x;
01110 xbe = xb + wb;
01111 xc = c->x;
01112 borrow = 0;
01113 #ifdef ULLong
01114 do {
01115 y = (ULLong)*xa++ - *xb++ - borrow;
01116 borrow = y >> 32 & (ULong)1;
01117 *xc++ = y & FFFFFFFF;
01118 }
01119 while(xb < xbe);
01120 while(xa < xae) {
01121 y = *xa++ - borrow;
01122 borrow = y >> 32 & (ULong)1;
01123 *xc++ = y & FFFFFFFF;
01124 }
01125 #else
01126 #ifdef Pack_32
01127 do {
01128 y = (*xa & 0xffff) - (*xb & 0xffff) - borrow;
01129 borrow = (y & 0x10000) >> 16;
01130 z = (*xa++ >> 16) - (*xb++ >> 16) - borrow;
01131 borrow = (z & 0x10000) >> 16;
01132 Storeinc(xc, z, y);
01133 }
01134 while(xb < xbe);
01135 while(xa < xae) {
01136 y = (*xa & 0xffff) - borrow;
01137 borrow = (y & 0x10000) >> 16;
01138 z = (*xa++ >> 16) - borrow;
01139 borrow = (z & 0x10000) >> 16;
01140 Storeinc(xc, z, y);
01141 }
01142 #else
01143 do {
01144 y = *xa++ - *xb++ - borrow;
01145 borrow = (y & 0x10000) >> 16;
01146 *xc++ = y & 0xffff;
01147 }
01148 while(xb < xbe);
01149 while(xa < xae) {
01150 y = *xa++ - borrow;
01151 borrow = (y & 0x10000) >> 16;
01152 *xc++ = y & 0xffff;
01153 }
01154 #endif
01155 #endif
01156 while(!*--xc)
01157 wa--;
01158 c->wds = wa;
01159 return c;
01160 }
01161
01162 static double
01163 ulp
01164 #ifdef KR_headers
01165 (x) double x;
01166 #else
01167 (double x)
01168 #endif
01169 {
01170 register Long L;
01171 double a;
01172
01173 L = (word0(x) & Exp_mask) - (P-1)*Exp_msk1;
01174 #ifndef Avoid_Underflow
01175 #ifndef Sudden_Underflow
01176 if (L > 0) {
01177 #endif
01178 #endif
01179 #ifdef IBM
01180 L |= Exp_msk1 >> 4;
01181 #endif
01182 word0(a) = L;
01183 word1(a) = 0;
01184 #ifndef Avoid_Underflow
01185 #ifndef Sudden_Underflow
01186 }
01187 else {
01188 L = -L >> Exp_shift;
01189 if (L < Exp_shift) {
01190 word0(a) = 0x80000 >> L;
01191 word1(a) = 0;
01192 }
01193 else {
01194 word0(a) = 0;
01195 L -= Exp_shift;
01196 word1(a) = L >= 31 ? 1 : 1 << 31 - L;
01197 }
01198 }
01199 #endif
01200 #endif
01201 return dval(a);
01202 }
01203
01204 static double
01205 b2d
01206 #ifdef KR_headers
01207 (a, e) Bigint *a; int *e;
01208 #else
01209 (Bigint *a, int *e)
01210 #endif
01211 {
01212 ULong *xa, *xa0, w, y, z;
01213 int k;
01214 double d;
01215 #ifdef VAX
01216 ULong d0, d1;
01217 #else
01218 #define d0 word0(d)
01219 #define d1 word1(d)
01220 #endif
01221
01222 xa0 = a->x;
01223 xa = xa0 + a->wds;
01224 y = *--xa;
01225 #ifdef DEBUG
01226 if (!y) Bug("zero y in b2d");
01227 #endif
01228 k = hi0bits(y);
01229 *e = 32 - k;
01230 #ifdef Pack_32
01231 if (k < Ebits) {
01232 d0 = Exp_1 | y >> Ebits - k;
01233 w = xa > xa0 ? *--xa : 0;
01234 d1 = y << (32-Ebits) + k | w >> Ebits - k;
01235 goto ret_d;
01236 }
01237 z = xa > xa0 ? *--xa : 0;
01238 if (k -= Ebits) {
01239 d0 = Exp_1 | y << k | z >> 32 - k;
01240 y = xa > xa0 ? *--xa : 0;
01241 d1 = z << k | y >> 32 - k;
01242 }
01243 else {
01244 d0 = Exp_1 | y;
01245 d1 = z;
01246 }
01247 #else
01248 if (k < Ebits + 16) {
01249 z = xa > xa0 ? *--xa : 0;
01250 d0 = Exp_1 | y << k - Ebits | z >> Ebits + 16 - k;
01251 w = xa > xa0 ? *--xa : 0;
01252 y = xa > xa0 ? *--xa : 0;
01253 d1 = z << k + 16 - Ebits | w << k - Ebits | y >> 16 + Ebits - k;
01254 goto ret_d;
01255 }
01256 z = xa > xa0 ? *--xa : 0;
01257 w = xa > xa0 ? *--xa : 0;
01258 k -= Ebits + 16;
01259 d0 = Exp_1 | y << k + 16 | z << k | w >> 16 - k;
01260 y = xa > xa0 ? *--xa : 0;
01261 d1 = w << k + 16 | y << k;
01262 #endif
01263 ret_d:
01264 #ifdef VAX
01265 word0(d) = d0 >> 16 | d0 << 16;
01266 word1(d) = d1 >> 16 | d1 << 16;
01267 #else
01268 #undef d0
01269 #undef d1
01270 #endif
01271 return dval(d);
01272 }
01273
01274 static Bigint *
01275 d2b
01276 #ifdef KR_headers
01277 (d, e, bits) double d; int *e, *bits;
01278 #else
01279 (double d, int *e, int *bits)
01280 #endif
01281 {
01282 Bigint *b;
01283 int de, k;
01284 ULong *x, y, z;
01285 #ifndef Sudden_Underflow
01286 int i;
01287 #endif
01288 #ifdef VAX
01289 ULong d0, d1;
01290 d0 = word0(d) >> 16 | word0(d) << 16;
01291 d1 = word1(d) >> 16 | word1(d) << 16;
01292 #else
01293 #define d0 word0(d)
01294 #define d1 word1(d)
01295 #endif
01296
01297 #ifdef Pack_32
01298 b = Balloc(1);
01299 #else
01300 b = Balloc(2);
01301 #endif
01302 x = b->x;
01303
01304 z = d0 & Frac_mask;
01305 d0 &= 0x7fffffff;
01306 #ifdef Sudden_Underflow
01307 de = (int)(d0 >> Exp_shift);
01308 #ifndef IBM
01309 z |= Exp_msk11;
01310 #endif
01311 #else
01312 if ( (de = (int)(d0 >> Exp_shift) ))
01313 z |= Exp_msk1;
01314 #endif
01315 #ifdef Pack_32
01316 if (y = d1) {
01317 if (k = lo0bits(&y)) {
01318 x[0] = y | z << 32 - k;
01319 z >>= k;
01320 }
01321 else
01322 x[0] = y;
01323 #ifndef Sudden_Underflow
01324 i =
01325 #endif
01326 b->wds = (x[1] = z) ? 2 : 1;
01327 }
01328 else {
01329 #ifdef DEBUG
01330 if (!z)
01331 Bug("Zero passed to d2b");
01332 #endif
01333 k = lo0bits(&z);
01334 x[0] = z;
01335 #ifndef Sudden_Underflow
01336 i =
01337 #endif
01338 b->wds = 1;
01339 k += 32;
01340 }
01341 #else
01342 if ( (y = d1) ) {
01343 if ( (k = lo0bits(&y)) )
01344 if (k >= 16) {
01345 x[0] = y | z << 32 - k & 0xffff;
01346 x[1] = z >> k - 16 & 0xffff;
01347 x[2] = z >> k;
01348 i = 2;
01349 }
01350 else {
01351 x[0] = y & 0xffff;
01352 x[1] = y >> 16 | z << 16 - k & 0xffff;
01353 x[2] = z >> k & 0xffff;
01354 x[3] = z >> k+16;
01355 i = 3;
01356 }
01357 else {
01358 x[0] = y & 0xffff;
01359 x[1] = y >> 16;
01360 x[2] = z & 0xffff;
01361 x[3] = z >> 16;
01362 i = 3;
01363 }
01364 }
01365 else {
01366 #ifdef DEBUG
01367 if (!z)
01368 Bug("Zero passed to d2b");
01369 #endif
01370 k = lo0bits(&z);
01371 if (k >= 16) {
01372 x[0] = z;
01373 i = 0;
01374 }
01375 else {
01376 x[0] = z & 0xffff;
01377 x[1] = z >> 16;
01378 i = 1;
01379 }
01380 k += 32;
01381 }
01382 while(!x[i])
01383 --i;
01384 b->wds = i + 1;
01385 #endif
01386 #ifndef Sudden_Underflow
01387 if (de) {
01388 #endif
01389 #ifdef IBM
01390 *e = (de - Bias - (P-1) << 2) + k;
01391 *bits = 4*P + 8 - k - hi0bits(word0(d) & Frac_mask);
01392 #else
01393 *e = de - Bias - (P-1) + k;
01394 *bits = P - k;
01395 #endif
01396 #ifndef Sudden_Underflow
01397 }
01398 else {
01399 *e = de - Bias - (P-1) + 1 + k;
01400 #ifdef Pack_32
01401 *bits = 32*i - hi0bits(x[i-1]);
01402 #else
01403 *bits = (i+2)*16 - hi0bits(x[i]);
01404 #endif
01405 }
01406 #endif
01407 return b;
01408 }
01409 #undef d0
01410 #undef d1
01411
01412 static double
01413 ratio
01414 #ifdef KR_headers
01415 (a, b) Bigint *a, *b;
01416 #else
01417 (Bigint *a, Bigint *b)
01418 #endif
01419 {
01420 double da, db;
01421 int k, ka, kb;
01422
01423 dval(da) = b2d(a, &ka);
01424 dval(db) = b2d(b, &kb);
01425 #ifdef Pack_32
01426 k = ka - kb + 32*(a->wds - b->wds);
01427 #else
01428 k = ka - kb + 16*(a->wds - b->wds);
01429 #endif
01430 #ifdef IBM
01431 if (k > 0) {
01432 word0(da) += (k >> 2)*Exp_msk1;
01433 if (k &= 3)
01434 dval(da) *= 1 << k;
01435 }
01436 else {
01437 k = -k;
01438 word0(db) += (k >> 2)*Exp_msk1;
01439 if (k &= 3)
01440 dval(db) *= 1 << k;
01441 }
01442 #else
01443 if (k > 0)
01444 word0(da) += k*Exp_msk1;
01445 else {
01446 k = -k;
01447 word0(db) += k*Exp_msk1;
01448 }
01449 #endif
01450 return dval(da) / dval(db);
01451 }
01452
01453 static CONST double
01454 tens[] = {
01455 1e0, 1e1, 1e2, 1e3, 1e4, 1e5, 1e6, 1e7, 1e8, 1e9,
01456 1e10, 1e11, 1e12, 1e13, 1e14, 1e15, 1e16, 1e17, 1e18, 1e19,
01457 1e20, 1e21, 1e22
01458 #ifdef VAX
01459 , 1e23, 1e24
01460 #endif
01461 };
01462
01463 static CONST double
01464 #ifdef IEEE_Arith
01465 bigtens[] = { 1e16, 1e32, 1e64, 1e128, 1e256 };
01466 static CONST double tinytens[] = { 1e-16, 1e-32, 1e-64, 1e-128,
01467 #ifdef Avoid_Underflow
01468 9007199254740992.*9007199254740992.e-256
01469
01470 #else
01471 1e-256
01472 #endif
01473 };
01474
01475
01476 #define Scale_Bit 0x10
01477 #define n_bigtens 5
01478 #else
01479 #ifdef IBM
01480 bigtens[] = { 1e16, 1e32, 1e64 };
01481 static CONST double tinytens[] = { 1e-16, 1e-32, 1e-64 };
01482 #define n_bigtens 3
01483 #else
01484 bigtens[] = { 1e16, 1e32 };
01485 static CONST double tinytens[] = { 1e-16, 1e-32 };
01486 #define n_bigtens 2
01487 #endif
01488 #endif
01489
01490 #ifdef INFNAN_CHECK
01491
01492 #ifndef NAN_WORD0
01493 #define NAN_WORD0 0x7ff80000
01494 #endif
01495
01496 #ifndef NAN_WORD1
01497 #define NAN_WORD1 0
01498 #endif
01499
01500 static int
01501 match
01502 #ifdef KR_headers
01503 (sp, t) char **sp; CONST char *t;
01504 #else
01505 (CONST char **sp, CONST char *t)
01506 #endif
01507 {
01508 int c, d;
01509 CONST char *s = *sp;
01510
01511 while( (d = *t++) ) {
01512 if ((c = *++s) >= 'A' && c <= 'Z')
01513 c += 'a' - 'A';
01514 if (c != d)
01515 return 0;
01516 }
01517 *sp = s + 1;
01518 return 1;
01519 }
01520
01521 #ifndef No_Hex_NaN
01522 static void
01523 hexnan
01524 #ifdef KR_headers
01525 (rvp, sp) double *rvp; CONST char **sp;
01526 #else
01527 (double *rvp, CONST char **sp)
01528 #endif
01529 {
01530 ULong c, x[2];
01531 CONST char *s;
01532 int havedig, udx0, xshift;
01533
01534 x[0] = x[1] = 0;
01535 havedig = xshift = 0;
01536 udx0 = 1;
01537 s = *sp;
01538 while( (c = *(CONST unsigned char*)++s) ) {
01539 if (c >= '0' && c <= '9')
01540 c -= '0';
01541 else if (c >= 'a' && c <= 'f')
01542 c += 10 - 'a';
01543 else if (c >= 'A' && c <= 'F')
01544 c += 10 - 'A';
01545 else if (c <= ' ') {
01546 if (udx0 && havedig) {
01547 udx0 = 0;
01548 xshift = 1;
01549 }
01550 continue;
01551 }
01552 else if ( c == ')' && havedig) {
01553 *sp = s + 1;
01554 break;
01555 }
01556 else
01557 return;
01558 havedig = 1;
01559 if (xshift) {
01560 xshift = 0;
01561 x[0] = x[1];
01562 x[1] = 0;
01563 }
01564 if (udx0)
01565 x[0] = (x[0] << 4) | (x[1] >> 28);
01566 x[1] = (x[1] << 4) | c;
01567 }
01568 if ((x[0] &= 0xfffff) || x[1]) {
01569 word0(*rvp) = Exp_mask | x[0];
01570 word1(*rvp) = x[1];
01571 }
01572 }
01573 #endif
01574 #endif
01575
01576 double
01577 os_strtod
01578 #ifdef KR_headers
01579 (s00, se) CONST char *s00; char **se;
01580 #else
01581 (CONST char *s00, char **se)
01582 #endif
01583 {
01584 #ifdef Avoid_Underflow
01585 int scale;
01586 #endif
01587 int bb2, bb5, bbe, bd2, bd5, bbbits, bs2, c, dsign,
01588 e, e1, esign, i, j, k, nd, nd0, nf, nz, nz0, sign;
01589 CONST char *s, *s0, *s1;
01590 double aadj, aadj1, adj, rv, rv0;
01591 Long L;
01592 ULong y, z;
01593 Bigint *bb = NULL, *bb1 = NULL, *bd = NULL,
01594 *bd0 = NULL, *bs = NULL, *delta = NULL;
01595 #ifdef SET_INEXACT
01596 int inexact, oldinexact;
01597 #endif
01598 #ifdef Honor_FLT_ROUNDS
01599 int rounding;
01600 #endif
01601 #ifdef USE_LOCALE
01602 CONST char *s2;
01603 #endif
01604
01605 sign = nz0 = nz = 0;
01606 dval(rv) = 0.;
01607 for(s = s00;;s++) switch(*s) {
01608 case '-':
01609 sign = 1;
01610
01611 case '+':
01612 if (*++s)
01613 goto break2;
01614
01615 case 0:
01616 goto ret0;
01617 case '\t':
01618 case '\n':
01619 case '\v':
01620 case '\f':
01621 case '\r':
01622 case ' ':
01623 continue;
01624 default:
01625 goto break2;
01626 }
01627 break2:
01628 if (*s == '0') {
01629 nz0 = 1;
01630 while(*++s == '0') ;
01631 if (!*s)
01632 goto ret;
01633 }
01634 s0 = s;
01635 y = z = 0;
01636 for(nd = nf = 0; (c = *s) >= '0' && c <= '9'; nd++, s++)
01637 if (nd < 9)
01638 y = 10*y + c - '0';
01639 else if (nd < 16)
01640 z = 10*z + c - '0';
01641 nd0 = nd;
01642 #ifdef USE_LOCALE
01643 s1 = localeconv()->decimal_point;
01644 if (c == *s1) {
01645 c = '.';
01646 if (*++s1) {
01647 s2 = s;
01648 for(;;) {
01649 if (*++s2 != *s1) {
01650 c = 0;
01651 break;
01652 }
01653 if (!*++s1) {
01654 s = s2;
01655 break;
01656 }
01657 }
01658 }
01659 }
01660 #endif
01661 if (c == '.') {
01662 c = *++s;
01663 if (!nd) {
01664 for(; c == '0'; c = *++s)
01665 nz++;
01666 if (c > '0' && c <= '9') {
01667 s0 = s;
01668 nf += nz;
01669 nz = 0;
01670 goto have_dig;
01671 }
01672 goto dig_done;
01673 }
01674 for(; c >= '0' && c <= '9'; c = *++s) {
01675 have_dig:
01676 nz++;
01677 if (c -= '0') {
01678 nf += nz;
01679 for(i = 1; i < nz; i++)
01680 if (nd++ < 9)
01681 y *= 10;
01682 else if (nd <= DBL_DIG + 1)
01683 z *= 10;
01684 if (nd++ < 9)
01685 y = 10*y + c;
01686 else if (nd <= DBL_DIG + 1)
01687 z = 10*z + c;
01688 nz = 0;
01689 }
01690 }
01691 }
01692 dig_done:
01693 e = 0;
01694 if (c == 'e' || c == 'E') {
01695 if (!nd && !nz && !nz0) {
01696 goto ret0;
01697 }
01698 s00 = s;
01699 esign = 0;
01700 switch(c = *++s) {
01701 case '-':
01702 esign = 1;
01703 case '+':
01704 c = *++s;
01705 }
01706 if (c >= '0' && c <= '9') {
01707 while(c == '0')
01708 c = *++s;
01709 if (c > '0' && c <= '9') {
01710 L = c - '0';
01711 s1 = s;
01712 while((c = *++s) >= '0' && c <= '9')
01713 L = 10*L + c - '0';
01714 if (s - s1 > 8 || L > 19999)
01715
01716
01717
01718 e = 19999;
01719 else
01720 e = (int)L;
01721 if (esign)
01722 e = -e;
01723 }
01724 else
01725 e = 0;
01726 }
01727 else
01728 s = s00;
01729 }
01730 if (!nd) {
01731 if (!nz && !nz0) {
01732 #ifdef INFNAN_CHECK
01733
01734 switch(c) {
01735 case 'i':
01736 case 'I':
01737 if (match(&s,"nf")) {
01738 --s;
01739 if (!match(&s,"inity"))
01740 ++s;
01741
01742
01743 rv = OSDBL_MAX;
01744 goto ret;
01745 }
01746 break;
01747 case 'n':
01748 case 'N':
01749 if (match(&s, "an")) {
01750 word0(rv) = NAN_WORD0;
01751 word1(rv) = NAN_WORD1;
01752 #ifndef No_Hex_NaN
01753 if (*s == '(')
01754 hexnan(&rv, &s);
01755 #endif
01756 goto ret;
01757 }
01758 }
01759 #endif
01760 ret0:
01761 s = s00;
01762 sign = 0;
01763 }
01764 goto ret;
01765 }
01766 e1 = e -= nf;
01767
01768
01769
01770
01771
01772
01773 if (!nd0)
01774 nd0 = nd;
01775 k = nd < DBL_DIG + 1 ? nd : DBL_DIG + 1;
01776 dval(rv) = y;
01777 if (k > 9) {
01778 #ifdef SET_INEXACT
01779 if (k > DBL_DIG)
01780 oldinexact = get_inexact();
01781 #endif
01782 dval(rv) = tens[k - 9] * dval(rv) + z;
01783 }
01784 bd0 = 0;
01785 if (nd <= DBL_DIG
01786 #ifndef RND_PRODQUOT
01787 #ifndef Honor_FLT_ROUNDS
01788 && Flt_Rounds == 1
01789 #endif
01790 #endif
01791 ) {
01792 if (!e)
01793 goto ret;
01794 if (e > 0) {
01795 if (e <= Ten_pmax) {
01796 #ifdef VAX
01797 goto vax_ovfl_check;
01798 #else
01799 #ifdef Honor_FLT_ROUNDS
01800
01801 if (sign) {
01802 rv = -rv;
01803 sign = 0;
01804 }
01805 #endif
01806 rounded_product(dval(rv), tens[e]);
01807 goto ret;
01808 #endif
01809 }
01810 i = DBL_DIG - nd;
01811 if (e <= Ten_pmax + i) {
01812
01813
01814
01815 #ifdef Honor_FLT_ROUNDS
01816
01817 if (sign) {
01818 rv = -rv;
01819 sign = 0;
01820 }
01821 #endif
01822 e -= i;
01823 dval(rv) *= tens[i];
01824 #ifdef VAX
01825
01826
01827
01828 vax_ovfl_check:
01829 word0(rv) -= P*Exp_msk1;
01830 rounded_product(dval(rv), tens[e]);
01831 if ((word0(rv) & Exp_mask)
01832 > Exp_msk1*(DBL_MAX_EXP+Bias-1-P))
01833 goto ovfl;
01834 word0(rv) += P*Exp_msk1;
01835 #else
01836 rounded_product(dval(rv), tens[e]);
01837 #endif
01838 goto ret;
01839 }
01840 }
01841 #ifndef Inaccurate_Divide
01842 else if (e >= -Ten_pmax) {
01843 #ifdef Honor_FLT_ROUNDS
01844
01845 if (sign) {
01846 rv = -rv;
01847 sign = 0;
01848 }
01849 #endif
01850 rounded_quotient(dval(rv), tens[-e]);
01851 goto ret;
01852 }
01853 #endif
01854 }
01855 e1 += nd - k;
01856
01857 #ifdef IEEE_Arith
01858 #ifdef SET_INEXACT
01859 inexact = 1;
01860 if (k <= DBL_DIG)
01861 oldinexact = get_inexact();
01862 #endif
01863 #ifdef Avoid_Underflow
01864 scale = 0;
01865 #endif
01866 #ifdef Honor_FLT_ROUNDS
01867 if ((rounding = Flt_Rounds) >= 2) {
01868 if (sign)
01869 rounding = rounding == 2 ? 0 : 2;
01870 else
01871 if (rounding != 2)
01872 rounding = 0;
01873 }
01874 #endif
01875 #endif
01876
01877
01878
01879 if (e1 > 0) {
01880 if ( (i = e1 & 15) )
01881 dval(rv) *= tens[i];
01882 if (e1 &= ~15) {
01883 if (e1 > DBL_MAX_10_EXP) {
01884 ovfl:
01885 #ifndef NO_ERRNO
01886 errno = ERANGE;
01887 #endif
01888
01889 #ifdef IEEE_Arith
01890 #ifdef Honor_FLT_ROUNDS
01891 switch(rounding) {
01892 case 0:
01893 case 3:
01894 word0(rv) = Big0;
01895 word1(rv) = Big1;
01896 break;
01897 default:
01898 word0(rv) = Exp_mask;
01899 word1(rv) = 0;
01900 }
01901 #else
01902 word0(rv) = Exp_mask;
01903 word1(rv) = 0;
01904 #endif
01905 #ifdef SET_INEXACT
01906
01907 dval(rv0) = 1e300;
01908 dval(rv0) *= dval(rv0);
01909 #endif
01910 #else
01911 word0(rv) = Big0;
01912 word1(rv) = Big1;
01913 #endif
01914 if (bd0)
01915 goto retfree;
01916 goto ret;
01917 }
01918 e1 >>= 4;
01919 for(j = 0; e1 > 1; j++, e1 >>= 1)
01920 if (e1 & 1)
01921 dval(rv) *= bigtens[j];
01922
01923 word0(rv) -= P*Exp_msk1;
01924 dval(rv) *= bigtens[j];
01925 if ((z = word0(rv) & Exp_mask)
01926 > Exp_msk1*(DBL_MAX_EXP+Bias-P))
01927 goto ovfl;
01928 if (z > Exp_msk1*(DBL_MAX_EXP+Bias-1-P)) {
01929
01930
01931 word0(rv) = Big0;
01932 word1(rv) = Big1;
01933 }
01934 else
01935 word0(rv) += P*Exp_msk1;
01936 }
01937 }
01938 else if (e1 < 0) {
01939 e1 = -e1;
01940 if ( (i = e1 & 15) )
01941 dval(rv) /= tens[i];
01942 if (e1 >>= 4) {
01943 if (e1 >= 1 << n_bigtens)
01944 goto undfl;
01945 #ifdef Avoid_Underflow
01946 if (e1 & Scale_Bit)
01947 scale = 2*P;
01948 for(j = 0; e1 > 0; j++, e1 >>= 1)
01949 if (e1 & 1)
01950 dval(rv) *= tinytens[j];
01951 if (scale && (j = 2*P + 1 - ((word0(rv) & Exp_mask)
01952 >> Exp_shift)) > 0) {
01953
01954 if (j >= 32) {
01955 word1(rv) = 0;
01956 if (j >= 53)
01957 word0(rv) = (P+2)*Exp_msk1;
01958 else
01959 word0(rv) &= 0xffffffff << j-32;
01960 }
01961 else
01962 word1(rv) &= 0xffffffff << j;
01963 }
01964 #else
01965 for(j = 0; e1 > 1; j++, e1 >>= 1)
01966 if (e1 & 1)
01967 dval(rv) *= tinytens[j];
01968
01969 dval(rv0) = dval(rv);
01970 dval(rv) *= tinytens[j];
01971 if (!dval(rv)) {
01972 dval(rv) = 2.*dval(rv0);
01973 dval(rv) *= tinytens[j];
01974 #endif
01975 if (!dval(rv)) {
01976 undfl:
01977 dval(rv) = 0.;
01978 #ifndef NO_ERRNO
01979 errno = ERANGE;
01980 #endif
01981 if (bd0)
01982 goto retfree;
01983 goto ret;
01984 }
01985 #ifndef Avoid_Underflow
01986 word0(rv) = Tiny0;
01987 word1(rv) = Tiny1;
01988
01989
01990
01991 }
01992 #endif
01993 }
01994 }
01995
01996
01997
01998
01999
02000 bd0 = s2b(s0, nd0, nd, y);
02001
02002 for(;;) {
02003 bd = Balloc(bd0->k);
02004 Bcopy(bd, bd0);
02005 bb = d2b(dval(rv), &bbe, &bbbits);
02006 bs = i2b(1);
02007
02008 if (e >= 0) {
02009 bb2 = bb5 = 0;
02010 bd2 = bd5 = e;
02011 }
02012 else {
02013 bb2 = bb5 = -e;
02014 bd2 = bd5 = 0;
02015 }
02016 if (bbe >= 0)
02017 bb2 += bbe;
02018 else
02019 bd2 -= bbe;
02020 bs2 = bb2;
02021 #ifdef Honor_FLT_ROUNDS
02022 if (rounding != 1)
02023 bs2++;
02024 #endif
02025 #ifdef Avoid_Underflow
02026 j = bbe - scale;
02027 i = j + bbbits - 1;
02028 if (i < Emin)
02029 j += P - Emin;
02030 else
02031 j = P + 1 - bbbits;
02032 #else
02033 #ifdef Sudden_Underflow
02034 #ifdef IBM
02035 j = 1 + 4*P - 3 - bbbits + ((bbe + bbbits - 1) & 3);
02036 #else
02037 j = P + 1 - bbbits;
02038 #endif
02039 #else
02040 j = bbe;
02041 i = j + bbbits - 1;
02042 if (i < Emin)
02043 j += P - Emin;
02044 else
02045 j = P + 1 - bbbits;
02046 #endif
02047 #endif
02048 bb2 += j;
02049 bd2 += j;
02050 #ifdef Avoid_Underflow
02051 bd2 += scale;
02052 #endif
02053 i = bb2 < bd2 ? bb2 : bd2;
02054 if (i > bs2)
02055 i = bs2;
02056 if (i > 0) {
02057 bb2 -= i;
02058 bd2 -= i;
02059 bs2 -= i;
02060 }
02061 if (bb5 > 0) {
02062 bs = pow5mult(bs, bb5);
02063 bb1 = mult(bs, bb);
02064 Bfree(bb);
02065 bb = bb1;
02066 }
02067 if (bb2 > 0)
02068 bb = lshift(bb, bb2);
02069 if (bd5 > 0)
02070 bd = pow5mult(bd, bd5);
02071 if (bd2 > 0)
02072 bd = lshift(bd, bd2);
02073 if (bs2 > 0)
02074 bs = lshift(bs, bs2);
02075 delta = diff(bb, bd);
02076 dsign = delta->sign;
02077 delta->sign = 0;
02078 i = cmp(delta, bs);
02079 #ifdef Honor_FLT_ROUNDS
02080 if (rounding != 1) {
02081 if (i < 0) {
02082
02083 if (!delta->x[0] && delta->wds <= 1) {
02084
02085 #ifdef SET_INEXACT
02086 inexact = 0;
02087 #endif
02088 break;
02089 }
02090 if (rounding) {
02091 if (dsign) {
02092 adj = 1.;
02093 goto apply_adj;
02094 }
02095 }
02096 else if (!dsign) {
02097 adj = -1.;
02098 if (!word1(rv)
02099 && !(word0(rv) & Frac_mask)) {
02100 y = word0(rv) & Exp_mask;
02101 #ifdef Avoid_Underflow
02102 if (!scale || y > 2*P*Exp_msk1)
02103 #else
02104 if (y)
02105 #endif
02106 {
02107 delta = lshift(delta,Log2P);
02108 if (cmp(delta, bs) <= 0)
02109 adj = -0.5;
02110 }
02111 }
02112 apply_adj:
02113 #ifdef Avoid_Underflow
02114 if (scale && (y = word0(rv) & Exp_mask)
02115 <= 2*P*Exp_msk1)
02116 word0(adj) += (2*P+1)*Exp_msk1 - y;
02117 #else
02118 #ifdef Sudden_Underflow
02119 if ((word0(rv) & Exp_mask) <=
02120 P*Exp_msk1) {
02121 word0(rv) += P*Exp_msk1;
02122 dval(rv) += adj*ulp(dval(rv));
02123 word0(rv) -= P*Exp_msk1;
02124 }
02125 else
02126 #endif
02127 #endif
02128 dval(rv) += adj*ulp(dval(rv));
02129 }
02130 break;
02131 }
02132 adj = ratio(delta, bs);
02133 if (adj < 1.)
02134 adj = 1.;
02135 if (adj <= 0x7ffffffe) {
02136
02137 y = adj;
02138 if (y != adj) {
02139 if (!((rounding>>1) ^ dsign))
02140 y++;
02141 adj = y;
02142 }
02143 }
02144 #ifdef Avoid_Underflow
02145 if (scale && (y = word0(rv) & Exp_mask) <= 2*P*Exp_msk1)
02146 word0(adj) += (2*P+1)*Exp_msk1 - y;
02147 #else
02148 #ifdef Sudden_Underflow
02149 if ((word0(rv) & Exp_mask) <= P*Exp_msk1) {
02150 word0(rv) += P*Exp_msk1;
02151 adj *= ulp(dval(rv));
02152 if (dsign)
02153 dval(rv) += adj;
02154 else
02155 dval(rv) -= adj;
02156 word0(rv) -= P*Exp_msk1;
02157 goto cont;
02158 }
02159 #endif
02160 #endif
02161 adj *= ulp(dval(rv));
02162 if (dsign)
02163 dval(rv) += adj;
02164 else
02165 dval(rv) -= adj;
02166 goto cont;
02167 }
02168 #endif
02169
02170 if (i < 0) {
02171
02172
02173
02174 if (dsign || word1(rv) || word0(rv) & Bndry_mask
02175 #ifdef IEEE_Arith
02176 #ifdef Avoid_Underflow
02177 || (word0(rv) & Exp_mask) <= (2*P+1)*Exp_msk1
02178 #else
02179 || (word0(rv) & Exp_mask) <= Exp_msk1
02180 #endif
02181 #endif
02182 ) {
02183 #ifdef SET_INEXACT
02184 if (!delta->x[0] && delta->wds <= 1)
02185 inexact = 0;
02186 #endif
02187 break;
02188 }
02189 if (!delta->x[0] && delta->wds <= 1) {
02190
02191 #ifdef SET_INEXACT
02192 inexact = 0;
02193 #endif
02194 break;
02195 }
02196 delta = lshift(delta,Log2P);
02197 if (cmp(delta, bs) > 0)
02198 goto drop_down;
02199 break;
02200 }
02201 if (i == 0) {
02202
02203 if (dsign) {
02204 if ((word0(rv) & Bndry_mask1) == Bndry_mask1
02205 && word1(rv) == (
02206 #ifdef Avoid_Underflow
02207 (scale && (y = word0(rv) & Exp_mask) <= 2*P*Exp_msk1)
02208 ? (0xffffffff & (0xffffffff << (2*P+1-(y>>Exp_shift)))) :
02209 #endif
02210 0xffffffff)) {
02211
02212 word0(rv) = (word0(rv) & Exp_mask)
02213 + Exp_msk1
02214 #ifdef IBM
02215 | Exp_msk1 >> 4
02216 #endif
02217 ;
02218 word1(rv) = 0;
02219 #ifdef Avoid_Underflow
02220 dsign = 0;
02221 #endif
02222 break;
02223 }
02224 }
02225 else if (!(word0(rv) & Bndry_mask) && !word1(rv)) {
02226 drop_down:
02227
02228 #ifdef Sudden_Underflow
02229 L = word0(rv) & Exp_mask;
02230 #ifdef IBM
02231 if (L < Exp_msk1)
02232 #else
02233 #ifdef Avoid_Underflow
02234 if (L <= (scale ? (2*P+1)*Exp_msk1 : Exp_msk1))
02235 #else
02236 if (L <= Exp_msk1)
02237 #endif
02238 #endif
02239 goto undfl;
02240 L -= Exp_msk1;
02241 #else
02242 #ifdef Avoid_Underflow
02243 if (scale) {
02244 L = word0(rv) & Exp_mask;
02245 if (L <= (2*P+1)*Exp_msk1) {
02246 if (L > (P+2)*Exp_msk1)
02247
02248
02249 break;
02250
02251 goto undfl;
02252 }
02253 }
02254 #endif
02255 L = (word0(rv) & Exp_mask) - Exp_msk1;
02256 #endif
02257 word0(rv) = L | Bndry_mask1;
02258 word1(rv) = 0xffffffff;
02259 #ifdef IBM
02260 goto cont;
02261 #else
02262 break;
02263 #endif
02264 }
02265 #ifndef ROUND_BIASED
02266 if (!(word1(rv) & LSB))
02267 break;
02268 #endif
02269 if (dsign)
02270 dval(rv) += ulp(dval(rv));
02271 #ifndef ROUND_BIASED
02272 else {
02273 dval(rv) -= ulp(dval(rv));
02274 #ifndef Sudden_Underflow
02275 if (!dval(rv))
02276 goto undfl;
02277 #endif
02278 }
02279 #ifdef Avoid_Underflow
02280 dsign = 1 - dsign;
02281 #endif
02282 #endif
02283 break;
02284 }
02285 if ((aadj = ratio(delta, bs)) <= 2.) {
02286 if (dsign)
02287 aadj = aadj1 = 1.;
02288 else if (word1(rv) || word0(rv) & Bndry_mask) {
02289 #ifndef Sudden_Underflow
02290 if (word1(rv) == Tiny1 && !word0(rv))
02291 goto undfl;
02292 #endif
02293 aadj = 1.;
02294 aadj1 = -1.;
02295 }
02296 else {
02297
02298
02299
02300 if (aadj < 2./FLT_RADIX)
02301 aadj = 1./FLT_RADIX;
02302 else
02303 aadj *= 0.5;
02304 aadj1 = -aadj;
02305 }
02306 }
02307 else {
02308 aadj *= 0.5;
02309 aadj1 = dsign ? aadj : -aadj;
02310 #ifdef Check_FLT_ROUNDS
02311 switch(Rounding) {
02312 case 2:
02313 aadj1 -= 0.5;
02314 break;
02315 case 0:
02316 case 3:
02317 aadj1 += 0.5;
02318 }
02319 #else
02320 if (Flt_Rounds == 0)
02321 aadj1 += 0.5;
02322 #endif
02323 }
02324 y = word0(rv) & Exp_mask;
02325
02326
02327
02328 if (y == Exp_msk1*(DBL_MAX_EXP+Bias-1)) {
02329 dval(rv0) = dval(rv);
02330 word0(rv) -= P*Exp_msk1;
02331 adj = aadj1 * ulp(dval(rv));
02332 dval(rv) += adj;
02333 if ((word0(rv) & Exp_mask) >=
02334 Exp_msk1*(DBL_MAX_EXP+Bias-P)) {
02335 if (word0(rv0) == Big0 && word1(rv0) == Big1)
02336 goto ovfl;
02337 word0(rv) = Big0;
02338 word1(rv) = Big1;
02339 goto cont;
02340 }
02341 else
02342 word0(rv) += P*Exp_msk1;
02343 }
02344 else {
02345 #ifdef Avoid_Underflow
02346 if (scale && y <= 2*P*Exp_msk1) {
02347 if (aadj <= 0x7fffffff) {
02348 if ((z = (ULong)aadj) <= 0)
02349 z = 1;
02350 aadj = z;
02351 aadj1 = dsign ? aadj : -aadj;
02352 }
02353 word0(aadj1) += (2*P+1)*Exp_msk1 - y;
02354 }
02355 adj = aadj1 * ulp(dval(rv));
02356 dval(rv) += adj;
02357 #else
02358 #ifdef Sudden_Underflow
02359 if ((word0(rv) & Exp_mask) <= P*Exp_msk1) {
02360 dval(rv0) = dval(rv);
02361 word0(rv) += P*Exp_msk1;
02362 adj = aadj1 * ulp(dval(rv));
02363 dval(rv) += adj;
02364 #ifdef IBM
02365 if ((word0(rv) & Exp_mask) < P*Exp_msk1)
02366 #else
02367 if ((word0(rv) & Exp_mask) <= P*Exp_msk1)
02368 #endif
02369 {
02370 if (word0(rv0) == Tiny0
02371 && word1(rv0) == Tiny1)
02372 goto undfl;
02373 word0(rv) = Tiny0;
02374 word1(rv) = Tiny1;
02375 goto cont;
02376 }
02377 else
02378 word0(rv) -= P*Exp_msk1;
02379 }
02380 else {
02381 adj = aadj1 * ulp(dval(rv));
02382 dval(rv) += adj;
02383 }
02384 #else
02385
02386
02387
02388
02389
02390
02391
02392 if (y <= (P-1)*Exp_msk1 && aadj > 1.) {
02393 aadj1 = (double)(int)(aadj + 0.5);
02394 if (!dsign)
02395 aadj1 = -aadj1;
02396 }
02397 adj = aadj1 * ulp(dval(rv));
02398 dval(rv) += adj;
02399 #endif
02400 #endif
02401 }
02402 z = word0(rv) & Exp_mask;
02403 #ifndef SET_INEXACT
02404 #ifdef Avoid_Underflow
02405 if (!scale)
02406 #endif
02407 if (y == z) {
02408
02409 L = (Long)aadj;
02410 aadj -= L;
02411
02412 if (dsign || word1(rv) || word0(rv) & Bndry_mask) {
02413 if (aadj < .4999999 || aadj > .5000001)
02414 break;
02415 }
02416 else if (aadj < .4999999/FLT_RADIX)
02417 break;
02418 }
02419 #endif
02420 cont:
02421 Bfree(bb);
02422 Bfree(bd);
02423 Bfree(bs);
02424 Bfree(delta);
02425 }
02426 #ifdef SET_INEXACT
02427 if (inexact) {
02428 if (!oldinexact) {
02429 word0(rv0) = Exp_1 + (70 << Exp_shift);
02430 word1(rv0) = 0;
02431 dval(rv0) += 1.;
02432 }
02433 }
02434 else if (!oldinexact)
02435 clear_inexact();
02436 #endif
02437 #ifdef Avoid_Underflow
02438 if (scale) {
02439 word0(rv0) = Exp_1 - 2*P*Exp_msk1;
02440 word1(rv0) = 0;
02441 dval(rv) *= dval(rv0);
02442 #ifndef NO_ERRNO
02443
02444 if (word0(rv) == 0 && word1(rv) == 0)
02445 errno = ERANGE;
02446 #endif
02447 }
02448 #endif
02449 #ifdef SET_INEXACT
02450 if (inexact && !(word0(rv) & Exp_mask)) {
02451
02452 dval(rv0) = 1e-300;
02453 dval(rv0) *= dval(rv0);
02454 }
02455 #endif
02456 retfree:
02457 Bfree(bb);
02458 Bfree(bd);
02459 Bfree(bs);
02460 Bfree(bd0);
02461 Bfree(delta);
02462 ret:
02463 if (se)
02464 *se = const_cast<char*>(s);
02465 return sign ? -dval(rv) : dval(rv);
02466 }
02467
02468 static int
02469 quorem
02470 #ifdef KR_headers
02471 (b, S) Bigint *b, *S;
02472 #else
02473 (Bigint *b, Bigint *S)
02474 #endif
02475 {
02476 int n;
02477 ULong *bx, *bxe, q, *sx, *sxe;
02478 #ifdef ULLong
02479 ULLong borrow, carry, y, ys;
02480 #else
02481 ULong borrow, carry, y, ys;
02482 #ifdef Pack_32
02483 ULong si, z, zs;
02484 #endif
02485 #endif
02486
02487 n = S->wds;
02488 #ifdef DEBUG
02489 if (b->wds > n)
02490 Bug("oversize b in quorem");
02491 #endif
02492 if (b->wds < n)
02493 return 0;
02494 sx = S->x;
02495 sxe = sx + --n;
02496 bx = b->x;
02497 bxe = bx + n;
02498 q = *bxe / (*sxe + 1);
02499 #ifdef DEBUG
02500 if (q > 9)
02501 Bug("oversized quotient in quorem");
02502 #endif
02503 if (q) {
02504 borrow = 0;
02505 carry = 0;
02506 do {
02507 #ifdef ULLong
02508 ys = *sx++ * (ULLong)q + carry;
02509 carry = ys >> 32;
02510 y = *bx - (ys & FFFFFFFF) - borrow;
02511 borrow = y >> 32 & (ULong)1;
02512 *bx++ = y & FFFFFFFF;
02513 #else
02514 #ifdef Pack_32
02515 si = *sx++;
02516 ys = (si & 0xffff) * q + carry;
02517 zs = (si >> 16) * q + (ys >> 16);
02518 carry = zs >> 16;
02519 y = (*bx & 0xffff) - (ys & 0xffff) - borrow;
02520 borrow = (y & 0x10000) >> 16;
02521 z = (*bx >> 16) - (zs & 0xffff) - borrow;
02522 borrow = (z & 0x10000) >> 16;
02523 Storeinc(bx, z, y);
02524 #else
02525 ys = *sx++ * q + carry;
02526 carry = ys >> 16;
02527 y = *bx - (ys & 0xffff) - borrow;
02528 borrow = (y & 0x10000) >> 16;
02529 *bx++ = y & 0xffff;
02530 #endif
02531 #endif
02532 }
02533 while(sx <= sxe);
02534 if (!*bxe) {
02535 bx = b->x;
02536 while(--bxe > bx && !*bxe)
02537 --n;
02538 b->wds = n;
02539 }
02540 }
02541 if (cmp(b, S) >= 0) {
02542 q++;
02543 borrow = 0;
02544 carry = 0;
02545 bx = b->x;
02546 sx = S->x;
02547 do {
02548 #ifdef ULLong
02549 ys = *sx++ + carry;
02550 carry = ys >> 32;
02551 y = *bx - (ys & FFFFFFFF) - borrow;
02552 borrow = y >> 32 & (ULong)1;
02553 *bx++ = y & FFFFFFFF;
02554 #else
02555 #ifdef Pack_32
02556 si = *sx++;
02557 ys = (si & 0xffff) + carry;
02558 zs = (si >> 16) + (ys >> 16);
02559 carry = zs >> 16;
02560 y = (*bx & 0xffff) - (ys & 0xffff) - borrow;
02561 borrow = (y & 0x10000) >> 16;
02562 z = (*bx >> 16) - (zs & 0xffff) - borrow;
02563 borrow = (z & 0x10000) >> 16;
02564 Storeinc(bx, z, y);
02565 #else
02566 ys = *sx++ + carry;
02567 carry = ys >> 16;
02568 y = *bx - (ys & 0xffff) - borrow;
02569 borrow = (y & 0x10000) >> 16;
02570 *bx++ = y & 0xffff;
02571 #endif
02572 #endif
02573 }
02574 while(sx <= sxe);
02575 bx = b->x;
02576 bxe = bx + n;
02577 if (!*bxe) {
02578 while(--bxe > bx && !*bxe)
02579 --n;
02580 b->wds = n;
02581 }
02582 }
02583 return q;
02584 }
02585
02586 #ifndef MULTIPLE_THREADS
02587 static char *dtoa_result;
02588 #endif
02589
02590 static char *
02591 #ifdef KR_headers
02592 rv_alloc(i) int i;
02593 #else
02594 rv_alloc(int i)
02595 #endif
02596 {
02597 int j, k, *r;
02598
02599 j = sizeof(ULong);
02600 for(k = 0;
02601 sizeof(Bigint) - sizeof(ULong) - sizeof(int) + j <= (unsigned)i;
02602 j <<= 1)
02603 k++;
02604 r = (int*)Balloc(k);
02605 *r = k;
02606 return
02607 #ifndef MULTIPLE_THREADS
02608 dtoa_result =
02609 #endif
02610 (char *)(r+1);
02611 }
02612
02613 static char *
02614 #ifdef KR_headers
02615 nrv_alloc(s, rve, n) CONST char *s; char **rve; int n;
02616 #else
02617 nrv_alloc(CONST char *s, char **rve, int n)
02618 #endif
02619 {
02620 char *rv, *t;
02621
02622 t = rv = rv_alloc(n);
02623 while( (*t = *s++) ) t++;
02624 if (rve)
02625 *rve = t;
02626 return rv;
02627 }
02628
02629
02630
02631
02632
02633
02634
02635 void
02636 #ifdef KR_headers
02637 os_freedtoa(s) char *s;
02638 #else
02639 os_freedtoa(char *s)
02640 #endif
02641 {
02642 Bigint *b = (Bigint *)((int *)s - 1);
02643 b->maxwds = 1 << (b->k = *(int*)b);
02644 Bfree(b);
02645 #ifndef MULTIPLE_THREADS
02646 if (s == dtoa_result)
02647 dtoa_result = 0;
02648 #endif
02649 }
02650
02651
02652
02653
02654
02655
02656
02657
02658
02659
02660
02661
02662
02663
02664
02665
02666
02667
02668
02669
02670
02671
02672
02673
02674
02675
02676
02677
02678
02679
02680
02681
02682
02683
02684
02685 char *
02686 os_dtoa
02687 #ifdef KR_headers
02688 (d, mode, ndigits, decpt, sign, rve)
02689 double d; int mode, ndigits, *decpt, *sign; char **rve;
02690 #else
02691 (double d, int mode, int ndigits, int *decpt, int *sign, char **rve)
02692 #endif
02693 {
02694
02695
02696
02697
02698
02699
02700
02701
02702
02703
02704
02705
02706
02707
02708
02709
02710
02711
02712
02713
02714
02715
02716
02717
02718
02719
02720
02721
02722
02723
02724
02725
02726
02727
02728 int bbits, b2, b5, be, dig, i, ieps, ilim = 0, ilim0, ilim1 =0,
02729 j, j1, k, k0, k_check, leftright, m2, m5, s2, s5,
02730 spec_case, try_quick;
02731 Long L;
02732 #ifndef Sudden_Underflow
02733 int denorm;
02734 ULong x;
02735 #endif
02736 Bigint *b, *b1, *delta, *mlo = NULL, *mhi, *S;
02737 double d2, ds, eps;
02738 char *s, *s0;
02739 #ifdef Honor_FLT_ROUNDS
02740 int rounding;
02741 #endif
02742 #ifdef SET_INEXACT
02743 int inexact, oldinexact;
02744 #endif
02745
02746 #ifndef MULTIPLE_THREADS
02747 if (dtoa_result) {
02748 os_freedtoa(dtoa_result);
02749 dtoa_result = 0;
02750 }
02751 #endif
02752
02753 if (word0(d) & Sign_bit) {
02754
02755 *sign = 1;
02756 word0(d) &= ~Sign_bit;
02757 }
02758 else
02759 *sign = 0;
02760
02761 #if defined(IEEE_Arith) + defined(VAX)
02762 #ifdef IEEE_Arith
02763 if ((word0(d) & Exp_mask) == Exp_mask)
02764 #else
02765 if (word0(d) == 0x8000)
02766 #endif
02767 {
02768
02769 *decpt = 9999;
02770 #ifdef IEEE_Arith
02771 if (!word1(d) && !(word0(d) & 0xfffff))
02772 return nrv_alloc("Infinity", rve, 8);
02773 #endif
02774 return nrv_alloc("NaN", rve, 3);
02775 }
02776 #endif
02777 #ifdef IBM
02778 dval(d) += 0;
02779 #endif
02780 if (!dval(d)) {
02781 *decpt = 1;
02782 return nrv_alloc("0", rve, 1);
02783 }
02784
02785 #ifdef SET_INEXACT
02786 try_quick = oldinexact = get_inexact();
02787 inexact = 1;
02788 #endif
02789 #ifdef Honor_FLT_ROUNDS
02790 if ((rounding = Flt_Rounds) >= 2) {
02791 if (*sign)
02792 rounding = rounding == 2 ? 0 : 2;
02793 else
02794 if (rounding != 2)
02795 rounding = 0;
02796 }
02797 #endif
02798
02799 b = d2b(dval(d), &be, &bbits);
02800 #ifdef Sudden_Underflow
02801 i = (int)(word0(d) >> Exp_shift1 & (Exp_mask>>Exp_shift1));
02802 #else
02803 if ( (i = (int)(word0(d) >> Exp_shift1 & (Exp_mask>>Exp_shift1)) ) ) {
02804 #endif
02805 dval(d2) = dval(d);
02806 word0(d2) &= Frac_mask1;
02807 word0(d2) |= Exp_11;
02808 #ifdef IBM
02809 if (j = 11 - hi0bits(word0(d2) & Frac_mask))
02810 dval(d2) /= 1 << j;
02811 #endif
02812
02813
02814
02815
02816
02817
02818
02819
02820
02821
02822
02823
02824
02825
02826
02827
02828
02829
02830
02831
02832
02833
02834
02835 i -= Bias;
02836 #ifdef IBM
02837 i <<= 2;
02838 i += j;
02839 #endif
02840 #ifndef Sudden_Underflow
02841 denorm = 0;
02842 }
02843 else {
02844
02845
02846 i = bbits + be + (Bias + (P-1) - 1);
02847 x = i > 32 ? word0(d) << 64 - i | word1(d) >> i - 32
02848 : word1(d) << 32 - i;
02849 dval(d2) = x;
02850 word0(d2) -= 31*Exp_msk1;
02851 i -= (Bias + (P-1) - 1) + 1;
02852 denorm = 1;
02853 }
02854 #endif
02855 ds = (dval(d2)-1.5)*0.289529654602168 + 0.1760912590558 + i*0.301029995663981;
02856 k = (int)ds;
02857 if (ds < 0. && ds != k)
02858 k--;
02859 k_check = 1;
02860 if (k >= 0 && k <= Ten_pmax) {
02861 if (dval(d) < tens[k])
02862 k--;
02863 k_check = 0;
02864 }
02865 j = bbits - i - 1;
02866 if (j >= 0) {
02867 b2 = 0;
02868 s2 = j;
02869 }
02870 else {
02871 b2 = -j;
02872 s2 = 0;
02873 }
02874 if (k >= 0) {
02875 b5 = 0;
02876 s5 = k;
02877 s2 += k;
02878 }
02879 else {
02880 b2 -= k;
02881 b5 = -k;
02882 s5 = 0;
02883 }
02884 if (mode < 0 || mode > 9)
02885 mode = 0;
02886
02887 #ifndef SET_INEXACT
02888 #ifdef Check_FLT_ROUNDS
02889 try_quick = Rounding == 1;
02890 #else
02891 try_quick = 1;
02892 #endif
02893 #endif
02894
02895 if (mode > 5) {
02896 mode -= 4;
02897 try_quick = 0;
02898 }
02899 leftright = 1;
02900 switch(mode) {
02901 case 0:
02902 case 1:
02903 ilim = ilim1 = -1;
02904 i = 18;
02905 ndigits = 0;
02906 break;
02907 case 2:
02908 leftright = 0;
02909
02910 case 4:
02911 if (ndigits <= 0)
02912 ndigits = 1;
02913 ilim = ilim1 = i = ndigits;
02914 break;
02915 case 3:
02916 leftright = 0;
02917
02918 case 5:
02919 i = ndigits + k + 1;
02920 ilim = i;
02921 ilim1 = i - 1;
02922 if (i <= 0)
02923 i = 1;
02924 }
02925 s = s0 = rv_alloc(i);
02926
02927 #ifdef Honor_FLT_ROUNDS
02928 if (mode > 1 && rounding != 1)
02929 leftright = 0;
02930 #endif
02931
02932 if (ilim >= 0 && ilim <= Quick_max && try_quick) {
02933
02934
02935
02936 i = 0;
02937 dval(d2) = dval(d);
02938 k0 = k;
02939 ilim0 = ilim;
02940 ieps = 2;
02941 if (k > 0) {
02942 ds = tens[k&0xf];
02943 j = k >> 4;
02944 if (j & Bletch) {
02945
02946 j &= Bletch - 1;
02947 dval(d) /= bigtens[n_bigtens-1];
02948 ieps++;
02949 }
02950 for(; j; j >>= 1, i++)
02951 if (j & 1) {
02952 ieps++;
02953 ds *= bigtens[i];
02954 }
02955 dval(d) /= ds;
02956 }
02957 else if ( (j1 = -k) ) {
02958 dval(d) *= tens[j1 & 0xf];
02959 for(j = j1 >> 4; j; j >>= 1, i++)
02960 if (j & 1) {
02961 ieps++;
02962 dval(d) *= bigtens[i];
02963 }
02964 }
02965 if (k_check && dval(d) < 1. && ilim > 0) {
02966 if (ilim1 <= 0)
02967 goto fast_failed;
02968 ilim = ilim1;
02969 k--;
02970 dval(d) *= 10.;
02971 ieps++;
02972 }
02973 dval(eps) = ieps*dval(d) + 7.;
02974 word0(eps) -= (P-1)*Exp_msk1;
02975 if (ilim == 0) {
02976 S = mhi = 0;
02977 dval(d) -= 5.;
02978 if (dval(d) > dval(eps))
02979 goto one_digit;
02980 if (dval(d) < -dval(eps))
02981 goto no_digits;
02982 goto fast_failed;
02983 }
02984 #ifndef No_leftright
02985 if (leftright) {
02986
02987
02988
02989 dval(eps) = 0.5/tens[ilim-1] - dval(eps);
02990 for(i = 0;;) {
02991 L = (long int) dval(d);
02992 dval(d) -= L;
02993 *s++ = '0' + (int)L;
02994 if (dval(d) < dval(eps))
02995 goto ret1;
02996 if (1. - dval(d) < dval(eps))
02997 goto bump_up;
02998 if (++i >= ilim)
02999 break;
03000 dval(eps) *= 10.;
03001 dval(d) *= 10.;
03002 }
03003 }
03004 else {
03005 #endif
03006
03007 dval(eps) *= tens[ilim-1];
03008 for(i = 1;; i++, dval(d) *= 10.) {
03009 L = (Long)(dval(d));
03010 if (!(dval(d) -= L))
03011 ilim = i;
03012 *s++ = '0' + (int)L;
03013 if (i == ilim) {
03014 if (dval(d) > 0.5 + dval(eps))
03015 goto bump_up;
03016 else if (dval(d) < 0.5 - dval(eps)) {
03017 while(*--s == '0');
03018 s++;
03019 goto ret1;
03020 }
03021 break;
03022 }
03023 }
03024 #ifndef No_leftright
03025 }
03026 #endif
03027 fast_failed:
03028 s = s0;
03029 dval(d) = dval(d2);
03030 k = k0;
03031 ilim = ilim0;
03032 }
03033
03034
03035
03036 if (be >= 0 && k <= Int_max) {
03037
03038 ds = tens[k];
03039 if (ndigits < 0 && ilim <= 0) {
03040 S = mhi = 0;
03041 if (ilim < 0 || dval(d) <= 5*ds)
03042 goto no_digits;
03043 goto one_digit;
03044 }
03045 for(i = 1;; i++, dval(d) *= 10.) {
03046 L = (Long)(dval(d) / ds);
03047 dval(d) -= L*ds;
03048 #ifdef Check_FLT_ROUNDS
03049
03050 if (dval(d) < 0) {
03051 L--;
03052 dval(d) += ds;
03053 }
03054 #endif
03055 *s++ = '0' + (int)L;
03056 if (!dval(d)) {
03057 #ifdef SET_INEXACT
03058 inexact = 0;
03059 #endif
03060 break;
03061 }
03062 if (i == ilim) {
03063 #ifdef Honor_FLT_ROUNDS
03064 if (mode > 1)
03065 switch(rounding) {
03066 case 0: goto ret1;
03067 case 2: goto bump_up;
03068 }
03069 #endif
03070 dval(d) += dval(d);
03071 if (dval(d) > ds || dval(d) == ds && L & 1) {
03072 bump_up:
03073 while(*--s == '9')
03074 if (s == s0) {
03075 k++;
03076 *s = '0';
03077 break;
03078 }
03079 ++*s++;
03080 }
03081 break;
03082 }
03083 }
03084 goto ret1;
03085 }
03086
03087 m2 = b2;
03088 m5 = b5;
03089 mhi = mlo = 0;
03090 if (leftright) {
03091 i =
03092 #ifndef Sudden_Underflow
03093 denorm ? be + (Bias + (P-1) - 1 + 1) :
03094 #endif
03095 #ifdef IBM
03096 1 + 4*P - 3 - bbits + ((bbits + be - 1) & 3);
03097 #else
03098 1 + P - bbits;
03099 #endif
03100 b2 += i;
03101 s2 += i;
03102 mhi = i2b(1);
03103 }
03104 if (m2 > 0 && s2 > 0) {
03105 i = m2 < s2 ? m2 : s2;
03106 b2 -= i;
03107 m2 -= i;
03108 s2 -= i;
03109 }
03110 if (b5 > 0) {
03111 if (leftright) {
03112 if (m5 > 0) {
03113 mhi = pow5mult(mhi, m5);
03114 b1 = mult(mhi, b);
03115 Bfree(b);
03116 b = b1;
03117 }
03118 if ( (j = b5 - m5) )
03119 b = pow5mult(b, j);
03120 }
03121 else
03122 b = pow5mult(b, b5);
03123 }
03124 S = i2b(1);
03125 if (s5 > 0)
03126 S = pow5mult(S, s5);
03127
03128
03129
03130 spec_case = 0;
03131 if ((mode < 2 || leftright)
03132 #ifdef Honor_FLT_ROUNDS
03133 && rounding == 1
03134 #endif
03135 ) {
03136 if (!word1(d) && !(word0(d) & Bndry_mask)
03137 #ifndef Sudden_Underflow
03138 && word0(d) & (Exp_mask & ~Exp_msk1)
03139 #endif
03140 ) {
03141
03142 b2 += Log2P;
03143 s2 += Log2P;
03144 spec_case = 1;
03145 }
03146 }
03147
03148
03149
03150
03151
03152
03153
03154
03155 #ifdef Pack_32
03156 if (i = ((s5 ? 32 - hi0bits(S->x[S->wds-1]) : 1) + s2) & 0x1f)
03157 i = 32 - i;
03158 #else
03159 if ( (i = ((s5 ? 32 - hi0bits(S->x[S->wds-1]) : 1) + s2) & 0xf) )
03160 i = 16 - i;
03161 #endif
03162 if (i > 4) {
03163 i -= 4;
03164 b2 += i;
03165 m2 += i;
03166 s2 += i;
03167 }
03168 else if (i < 4) {
03169 i += 28;
03170 b2 += i;
03171 m2 += i;
03172 s2 += i;
03173 }
03174 if (b2 > 0)
03175 b = lshift(b, b2);
03176 if (s2 > 0)
03177 S = lshift(S, s2);
03178 if (k_check) {
03179 if (cmp(b,S) < 0) {
03180 k--;
03181 b = multadd(b, 10, 0);
03182 if (leftright)
03183 mhi = multadd(mhi, 10, 0);
03184 ilim = ilim1;
03185 }
03186 }
03187 if (ilim <= 0 && (mode == 3 || mode == 5)) {
03188 if (ilim < 0 || cmp(b,S = multadd(S,5,0)) <= 0) {
03189
03190 no_digits:
03191 k = -1 - ndigits;
03192 goto ret;
03193 }
03194 one_digit:
03195 *s++ = '1';
03196 k++;
03197 goto ret;
03198 }
03199 if (leftright) {
03200 if (m2 > 0)
03201 mhi = lshift(mhi, m2);
03202
03203
03204
03205
03206
03207 mlo = mhi;
03208 if (spec_case) {
03209 mhi = Balloc(mhi->k);
03210 Bcopy(mhi, mlo);
03211 mhi = lshift(mhi, Log2P);
03212 }
03213
03214 for(i = 1;;i++) {
03215 dig = quorem(b,S) + '0';
03216
03217
03218
03219 j = cmp(b, mlo);
03220 delta = diff(S, mhi);
03221 j1 = delta->sign ? 1 : cmp(b, delta);
03222 Bfree(delta);
03223 #ifndef ROUND_BIASED
03224 if (j1 == 0 && mode != 1 && !(word1(d) & 1)
03225 #ifdef Honor_FLT_ROUNDS
03226 && rounding >= 1
03227 #endif
03228 ) {
03229 if (dig == '9')
03230 goto round_9_up;
03231 if (j > 0)
03232 dig++;
03233 #ifdef SET_INEXACT
03234 else if (!b->x[0] && b->wds <= 1)
03235 inexact = 0;
03236 #endif
03237 *s++ = dig;
03238 goto ret;
03239 }
03240 #endif
03241 if (j < 0 || j == 0 && mode != 1
03242 #ifndef ROUND_BIASED
03243 && !(word1(d) & 1)
03244 #endif
03245 ) {
03246 if (!b->x[0] && b->wds <= 1) {
03247 #ifdef SET_INEXACT
03248 inexact = 0;
03249 #endif
03250 goto accept_dig;
03251 }
03252 #ifdef Honor_FLT_ROUNDS
03253 if (mode > 1)
03254 switch(rounding) {
03255 case 0: goto accept_dig;
03256 case 2: goto keep_dig;
03257 }
03258 #endif
03259 if (j1 > 0) {
03260 b = lshift(b, 1);
03261 j1 = cmp(b, S);
03262 if ((j1 > 0 || j1 == 0 && dig & 1)
03263 && dig++ == '9')
03264 goto round_9_up;
03265 }
03266 accept_dig:
03267 *s++ = dig;
03268 goto ret;
03269 }
03270 if (j1 > 0) {
03271 #ifdef Honor_FLT_ROUNDS
03272 if (!rounding)
03273 goto accept_dig;
03274 #endif
03275 if (dig == '9') {
03276 round_9_up:
03277 *s++ = '9';
03278 goto roundoff;
03279 }
03280 *s++ = dig + 1;
03281 goto ret;
03282 }
03283 #ifdef Honor_FLT_ROUNDS
03284 keep_dig:
03285 #endif
03286 *s++ = dig;
03287 if (i == ilim)
03288 break;
03289 b = multadd(b, 10, 0);
03290 if (mlo == mhi)
03291 mlo = mhi = multadd(mhi, 10, 0);
03292 else {
03293 mlo = multadd(mlo, 10, 0);
03294 mhi = multadd(mhi, 10, 0);
03295 }
03296 }
03297 }
03298 else
03299 for(i = 1;; i++) {
03300 *s++ = dig = quorem(b,S) + '0';
03301 if (!b->x[0] && b->wds <= 1) {
03302 #ifdef SET_INEXACT
03303 inexact = 0;
03304 #endif
03305 goto ret;
03306 }
03307 if (i >= ilim)
03308 break;
03309 b = multadd(b, 10, 0);
03310 }
03311
03312
03313
03314 #ifdef Honor_FLT_ROUNDS
03315 switch(rounding) {
03316 case 0: goto trimzeros;
03317 case 2: goto roundoff;
03318 }
03319 #endif
03320 b = lshift(b, 1);
03321 j = cmp(b, S);
03322 if (j > 0 || j == 0 && dig & 1) {
03323 roundoff:
03324 while(*--s == '9')
03325 if (s == s0) {
03326 k++;
03327 *s++ = '1';
03328 goto ret;
03329 }
03330 ++*s++;
03331 }
03332 else {
03333 #ifdef Honor_FLT_ROUNDS
03334 trimzeros:
03335 #endif
03336 while(*--s == '0');
03337 s++;
03338 }
03339 ret:
03340 Bfree(S);
03341 if (mhi) {
03342 if (mlo && mlo != mhi)
03343 Bfree(mlo);
03344 Bfree(mhi);
03345 }
03346 ret1:
03347 #ifdef SET_INEXACT
03348 if (inexact) {
03349 if (!oldinexact) {
03350 word0(d) = Exp_1 + (70 << Exp_shift);
03351 word1(d) = 0;
03352 dval(d) += 1.;
03353 }
03354 }
03355 else if (!oldinexact)
03356 clear_inexact();
03357 #endif
03358 Bfree(b);
03359 *s = 0;
03360 *decpt = k + 1;
03361 if (rve)
03362 *rve = s;
03363 return s0;
03364 }
03365 #ifdef __cplusplus
03366 }
03367 #endif