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