/home/coin/SVN-release/OS-2.4.0/OS/src/OSUtils/OSdtoa.cpp

Go to the documentation of this file.
00001 /* $Id: OSdtoa.cpp 4292 2011-09-21 05:47:18Z kmartin $ */
00002 /****************************************************************
00003  *
00004  * The author of this software is David M. Gay.
00005  *
00006  * Copyright (c) 1991, 2000, 2001 by Lucent Technologies.
00007  *
00008  * Permission to use, copy, modify, and distribute this software for any
00009  * purpose without fee is hereby granted, provided that this entire notice
00010  * is included in all copies of any software which is or includes a copy
00011  * or modification of this software and in all copies of the supporting
00012  * documentation for such software.
00013  *
00014  * THIS SOFTWARE IS BEING PROVIDED "AS IS", WITHOUT ANY EXPRESS OR IMPLIED
00015  * WARRANTY.  IN PARTICULAR, NEITHER THE AUTHOR NOR LUCENT MAKES ANY
00016  * REPRESENTATION OR WARRANTY OF ANY KIND CONCERNING THE MERCHANTABILITY
00017  * OF THIS SOFTWARE OR ITS FITNESS FOR ANY PARTICULAR PURPOSE.
00018  *
00019  ***************************************************************/
00020 
00021 /* Please send bug reports to David M. Gay (dmg at acm dot org,
00022  * with " at " changed at "@" and " dot " changed to ".").      */
00023 
00024 /* On a machine with IEEE extended-precision registers, it is
00025  * necessary to specify double-precision (53-bit) rounding precision
00026  * before invoking strtod or dtoa.  If the machine uses (the equivalent
00027  * of) Intel 80x87 arithmetic, the call
00028  *      _control87(PC_53, MCW_PC);
00029  * does this with many compilers.  Whether this or another call is
00030  * appropriate depends on the compiler; for this to work, it may be
00031  * necessary to #include "float.h" or another system-dependent header
00032  * file.
00033  */
00034 
00035 /* strtod for IEEE-, VAX-, and IBM-arithmetic machines.
00036  *
00037  * This strtod returns a nearest machine number to the input decimal
00038  * string (or sets errno to ERANGE).  With IEEE arithmetic, ties are
00039  * broken by the IEEE round-even rule.  Otherwise ties are broken by
00040  * biased rounding (add half and chop).
00041  *
00042  * Inspired loosely by William D. Clinger's paper "How to Read Floating
00043  * Point Numbers Accurately" [Proc. ACM SIGPLAN '90, pp. 92-101].
00044  *
00045  * Modifications:
00046  *
00047  *      1. We only require IEEE, IBM, or VAX double-precision
00048  *              arithmetic (not IEEE double-extended).
00049  *      2. We get by with floating-point arithmetic in a case that
00050  *              Clinger missed -- when we're computing d * 10^n
00051  *              for a small integer d and the integer n is not too
00052  *              much larger than 22 (the maximum integer k for which
00053  *              we can represent 10^k exactly), we may be able to
00054  *              compute (d*10^k) * 10^(e-k) with just one roundoff.
00055  *      3. Rather than a bit-at-a-time adjustment of the binary
00056  *              result in the hard case, we use floating-point
00057  *              arithmetic to determine the adjustment to within
00058  *              one bit; only in really hard cases do we need to
00059  *              compute a second residual.
00060  *      4. Because of 3., we don't need a large table of powers of 10
00061  *              for ten-to-e (just some small tables, e.g. of 10^k
00062  *              for 0 <= k <= 22).
00063  */
00064 
00065 /*
00066  * #define IEEE_8087 for IEEE-arithmetic machines where the least
00067  *      significant byte has the lowest address.
00068  * #define IEEE_MC68k for IEEE-arithmetic machines where the most
00069  *      significant byte has the lowest address.
00070  * #define Long int on machines with 32-bit ints and 64-bit longs.
00071  * #define IBM for IBM mainframe-style floating-point arithmetic.
00072  * #define VAX for VAX-style floating-point arithmetic (D_floating).
00073  * #define No_leftright to omit left-right logic in fast floating-point
00074  *      computation of dtoa.
00075  * #define Honor_FLT_ROUNDS if FLT_ROUNDS can assume the values 2 or 3
00076  *      and strtod and dtoa should round accordingly.
00077  * #define Check_FLT_ROUNDS if FLT_ROUNDS can assume the values 2 or 3
00078  *      and Honor_FLT_ROUNDS is not #defined.
00079  * #define RND_PRODQUOT to use rnd_prod and rnd_quot (assembly routines
00080  *      that use extended-precision instructions to compute rounded
00081  *      products and quotients) with IBM.
00082  * #define ROUND_BIASED for IEEE-format with biased rounding.
00083  * #define Inaccurate_Divide for IEEE-format with correctly rounded
00084  *      products but inaccurate quotients, e.g., for Intel i860.
00085  * #define NO_LONG_LONG on machines that do not have a "long long"
00086  *      integer type (of >= 64 bits).  On such machines, you can
00087  *      #define Just_16 to store 16 bits per 32-bit Long when doing
00088  *      high-precision integer arithmetic.  Whether this speeds things
00089  *      up or slows things down depends on the machine and the number
00090  *      being converted.  If long long is available and the name is
00091  *      something other than "long long", #define Llong to be the name,
00092  *      and if "unsigned Llong" does not work as an unsigned version of
00093  *      Llong, #define #ULLong to be the corresponding unsigned type.
00094  * #define KR_headers for old-style C function headers.
00095  * #define Bad_float_h if your system lacks a float.h or if it does not
00096  *      define some or all of DBL_DIG, DBL_MAX_10_EXP, DBL_MAX_EXP,
00097  *      FLT_RADIX, FLT_ROUNDS, and DBL_MAX.
00098  * #define MALLOC your_malloc, where your_malloc(n) acts like malloc(n)
00099  *      if memory is available and otherwise does something you deem
00100  *      appropriate.  If MALLOC is undefined, malloc will be invoked
00101  *      directly -- and assumed always to succeed.
00102  * #define Omit_Private_Memory to omit logic (added Jan. 1998) for making
00103  *      memory allocations from a private pool of memory when possible.
00104  *      When used, the private pool is PRIVATE_MEM bytes long:  2304 bytes,
00105  *      unless #defined to be a different length.  This default length
00106  *      suffices to get rid of MALLOC calls except for unusual cases,
00107  *      such as decimal-to-binary conversion of a very long string of
00108  *      digits.  The longest string dtoa can return is about 751 bytes
00109  *      long.  For conversions by strtod of strings of 800 digits and
00110  *      all dtoa conversions in single-threaded executions with 8-byte
00111  *      pointers, PRIVATE_MEM >= 7400 appears to suffice; with 4-byte
00112  *      pointers, PRIVATE_MEM >= 7112 appears adequate.
00113  * #define NO_INFNAN_CHECK if you do not wish to have INFNAN_CHECK
00114  *      #defined automatically on IEEE systems.  On such systems,
00115  *      when INFNAN_CHECK is #defined, strtod checks
00116  *      for Infinity and NaN (case insensitively).  On some systems
00117  *      (e.g., some HP systems), it may be necessary to #define NAN_WORD0
00118  *      appropriately -- to the most significant word of a quiet NaN.
00119  *      (On HP Series 700/800 machines, -DNAN_WORD0=0x7ff40000 works.)
00120  *      When INFNAN_CHECK is #defined and No_Hex_NaN is not #defined,
00121  *      strtod also accepts (case insensitively) strings of the form
00122  *      NaN(x), where x is a string of hexadecimal digits and spaces;
00123  *      if there is only one string of hexadecimal digits, it is taken
00124  *      for the 52 fraction bits of the resulting NaN; if there are two
00125  *      or more strings of hex digits, the first is for the high 20 bits,
00126  *      the second and subsequent for the low 32 bits, with intervening
00127  *      white space ignored; but if this results in none of the 52
00128  *      fraction bits being on (an IEEE Infinity symbol), then NAN_WORD0
00129  *      and NAN_WORD1 are used instead.
00130  * #define MULTIPLE_THREADS if the system offers preemptively scheduled
00131  *      multiple threads.  In this case, you must provide (or suitably
00132  *      #define) two locks, acquired by ACQUIRE_DTOA_LOCK(n) and freed
00133  *      by FREE_DTOA_LOCK(n) for n = 0 or 1.  (The second lock, accessed
00134  *      in pow5mult, ensures lazy evaluation of only one copy of high
00135  *      powers of 5; omitting this lock would introduce a small
00136  *      probability of wasting memory, but would otherwise be harmless.)
00137  *      You must also invoke freedtoa(s) to free the value s returned by
00138  *      dtoa.  You may do so whether or not MULTIPLE_THREADS is #defined.
00139  * #define NO_IEEE_Scale to disable new (Feb. 1997) logic in strtod that
00140  *      avoids underflows on inputs whose result does not underflow.
00141  *      If you #define NO_IEEE_Scale on a machine that uses IEEE-format
00142  *      floating-point numbers and flushes underflows to zero rather
00143  *      than implementing gradual underflow, then you must also #define
00144  *      Sudden_Underflow.
00145  * #define YES_ALIAS to permit aliasing certain double values with
00146  *      arrays of ULongs.  This leads to slightly better code with
00147  *      some compilers and was always used prior to 19990916, but it
00148  *      is not strictly legal and can cause trouble with aggressively
00149  *      optimizing compilers (e.g., gcc 2.95.1 under -O2).
00150  * #define USE_LOCALE to use the current locale's decimal_point value.
00151  * #define SET_INEXACT if IEEE arithmetic is being used and extra
00152  *      computation should be done to set the inexact flag when the
00153  *      result is inexact and avoid setting inexact when the result
00154  *      is exact.  In this case, dtoa.c must be compiled in
00155  *      an environment, perhaps provided by #include "dtoa.c" in a
00156  *      suitable wrapper, that defines two functions,
00157  *              int get_inexact(void);
00158  *              void clear_inexact(void);
00159  *      such that get_inexact() returns a nonzero value if the
00160  *      inexact bit is already set, and clear_inexact() sets the
00161  *      inexact bit to 0.  When SET_INEXACT is #defined, strtod
00162  *      also does extra computations to set the underflow and overflow
00163  *      flags when appropriate (i.e., when the result is tiny and
00164  *      inexact or when it is a numeric value rounded to +-infinity).
00165  * #define NO_ERRNO if strtod should not assign errno = ERANGE when
00166  *      the result overflows to +-Infinity or underflows to 0.
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 #if  SIZEOF_LONG_LONG < 8
00196 #define NO_LONG_LONG
00197 #define Just_16
00198 #endif
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 /*IEEE_Arith*/
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 /* ifndef Bad_float_h */
00306 #include "float.h"
00307 #endif /* Bad_float_h */
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 /* blank */
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     /* The following definition of Storeinc is appropriate for MIPS processors.
00356      * An alternative that might be better on some machines is
00357      * #define Storeinc(a,b,c) (*a++ = b << 16 | c & 0xffff)
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     /* #define P DBL_MANT_DIG */
00368     /* Ten_pmax = floor(P*log(2)/log(5)) */
00369     /* Bletch = (highest power of 2 < DBL_MAX_10_EXP) / 16 */
00370     /* Quick_max = floor((P-1)*log(FLT_RADIX)/log(10) - 1) */
00371     /* Int_max = floor(P*log(FLT_RADIX)/log(10) - 1) */
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     /* debugging option */
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 /*Flt_Rounds*/
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 /* ifndef IEEE_Arith */
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 /* exponent has 7 bits, but 8 is the right value in b2d */
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 /* VAX */
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 /* IBM, VAX */
00480 #endif /* IEEE_Arith */
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     /* When Pack_32 is not defined, we store 16 bits per 32-bit Long.
00517      * This makes some inner loops simpler and sometimes saves work
00518      * during multiplications, but it often seems to make things slightly
00519      * slower.  Hence the default is now to store 32 bits per Long.
00520      */
00521 #endif
00522 #else   /* long long available */
00523 #ifndef Llong
00524 #define Llong long long
00525 #endif
00526 #ifndef ULLong
00527 #define ULLong unsigned Llong
00528 #endif
00529 #endif /* NO_LONG_LONG */
00530 
00531 #ifndef MULTIPLE_THREADS
00532 #define ACQUIRE_DTOA_LOCK(n)    /*nothing*/
00533 #define FREE_DTOA_LOCK(n)       /*nothing*/
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             //if (pmem_next - private_mem + len <= PRIVATE_mem) {
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)   /* multiply by m and add 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             /* first time */
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;       /* clear sign bit, which we ignore */
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                                        /* = 2^106 * 1e-53 */
01557 #else
01558                                        1e-256
01559 #endif
01560                                      };
01561     /* The factor of 2^53 in tinytens[4] helps us avoid setting the underflow */
01562     /* flag unnecessarily.  It leads to a song and dance at the end of strtod. */
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; /* invalid form: don't change *sp */
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 /*No_Hex_NaN*/
01670 #endif /* INFNAN_CHECK */
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                 /* no break */
01709             case '+':
01710                 if (*++s)
01711                     goto break2;
01712                 /* no break */
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                         /* Avoid confusion from exponents
01830                          * so large that e might overflow.
01831                          */
01832                         e = 19999; /* safe for 16 bit ints */
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                 /* Check for Nan and Infinity */
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 //                                      word0(rv) = 0x7ff00000;
01860 //                                      word1(rv) = 0;
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 /* INFNAN_CHECK */
01879 ret0:
01880                 s = s00;
01881                 sign = 0;
01882             }
01883             goto ret;
01884         }
01885         e1 = e -= nf;
01886 
01887         /* Now we have nd0 digits, starting at s0, followed by a
01888          * decimal point, followed by nd-nd0 digits.  The number we're
01889          * after is the integer represented by those digits times
01890          * 10**e */
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                     /* round correctly FLT_ROUNDS = 2 or 3 */
01924                     if (sign)
01925                     {
01926                         rv = -rv;
01927                         sign = 0;
01928                     }
01929 #endif
01930                     /* rv = */ 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                     /* A fancier test would sometimes let us do
01938                      * this for larger i values.
01939                      */
01940 #ifdef Honor_FLT_ROUNDS
01941                     /* round correctly FLT_ROUNDS = 2 or 3 */
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                     /* VAX exponent range is so narrow we must
01952                      * worry about overflow here...
01953                      */
01954 vax_ovfl_check:
01955                     word0(rv) -= P*Exp_msk1;
01956                     /* rv = */
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                     /* rv = */ 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                 /* round correctly FLT_ROUNDS = 2 or 3 */
01973                 if (sign)
01974                 {
01975                     rv = -rv;
01976                     sign = 0;
01977                 }
01978 #endif
01979                 /* rv = */ 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 /*IEEE_Arith*/
02005 
02006         /* Get starting approximation = rv * 10**e1 */
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                     /* Can't trust HUGE_VAL */
02021 #ifdef IEEE_Arith
02022 #ifdef Honor_FLT_ROUNDS
02023                     switch(rounding)
02024                     {
02025                     case 0: /* toward 0 */
02026                     case 3: /* toward -infinity */
02027                         word0(rv) = Big0;
02028                         word1(rv) = Big1;
02029                         break;
02030                     default:
02031                         word0(rv) = Exp_mask;
02032                         word1(rv) = 0;
02033                     }
02034 #else /*Honor_FLT_ROUNDS*/
02035                     word0(rv) = Exp_mask;
02036                     word1(rv) = 0;
02037 #endif /*Honor_FLT_ROUNDS*/
02038 #ifdef SET_INEXACT
02039                     /* set overflow bit */
02040                     dval(rv0) = 1e300;
02041                     dval(rv0) *= dval(rv0);
02042 #endif
02043 #else /*IEEE_Arith*/
02044                     word0(rv) = Big0;
02045                     word1(rv) = Big1;
02046 #endif /*IEEE_Arith*/
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                 /* The last multiplication could overflow. */
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                     /* set to largest number */
02064                     /* (Can't trust DBL_MAX) */
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                     /* scaled rv is denormal; zap j low bits */
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                 /* The last multiplication could underflow. */
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                 /* The refinement below will clean
02129                  * this approximation up.
02130                  */
02131             }
02132 #endif
02133         }
02134     }
02135 
02136     /* Now the hard part -- adjusting rv to the correct value.*/
02137 
02138     /* Put digits into bd: true value = bd * 10^e */
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);      /* rv = bb * 2^bbe */
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;     /* logb(rv) */
02171         if (i < Emin)   /* denormal */
02172             j += P - Emin;
02173         else
02174             j = P + 1 - bbbits;
02175 #else /*Avoid_Underflow*/
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 /*Sudden_Underflow*/
02183         j = bbe;
02184         i = j + bbbits - 1;     /* logb(rv) */
02185         if (i < Emin)   /* denormal */
02186             j += P - Emin;
02187         else
02188             j = P + 1 - bbbits;
02189 #endif /*Sudden_Underflow*/
02190 #endif /*Avoid_Underflow*/
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                 /* Error is less than an ulp */
02230                 if (!delta->x[0] && delta->wds <= 1)
02231                 {
02232                     /* exact */
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 /*Sudden_Underflow*/
02280 #endif /*Avoid_Underflow*/
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                 /* adj = rounding ? ceil(adj) : floor(adj); */
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 /*Sudden_Underflow*/
02316 #endif /*Avoid_Underflow*/
02317             adj *= ulp(dval(rv));
02318             if (dsign)
02319                 dval(rv) += adj;
02320             else
02321                 dval(rv) -= adj;
02322             goto cont;
02323         }
02324 #endif /*Honor_FLT_ROUNDS*/
02325 
02326         if (i < 0)
02327         {
02328             /* Error is less than half an ulp -- check for
02329              * special case of mantissa a power of two.
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                 /* exact result */
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             /* exactly half-way between */
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                     /*boundary case -- increment exponent*/
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                 /* boundary case -- decrement exponent */
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 /*Avoid_Underflow*/
02401 #endif /*IBM*/
02402                     goto undfl;
02403                 L -= Exp_msk1;
02404 #else /*Sudden_Underflow}{*/
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                             /* round even ==> */
02413                             /* accept rv */
02414                             break;
02415                         /* rv = smallest denormal */
02416                         goto undfl;
02417                     }
02418                 }
02419 #endif /*Avoid_Underflow*/
02420                 L = (word0(rv) & Exp_mask) - Exp_msk1;
02421 #endif /*Sudden_Underflow}}*/
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                 /* special case -- power of FLT_RADIX to be */
02467                 /* rounded down... */
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: /* towards +infinity */
02484                 aadj1 -= 0.5;
02485                 break;
02486             case 0: /* towards 0 */
02487             case 3: /* towards -infinity */
02488                 aadj1 += 0.5;
02489             }
02490 #else
02491             if (Flt_Rounds == 0)
02492                 aadj1 += 0.5;
02493 #endif /*Check_FLT_ROUNDS*/
02494         }
02495         y = word0(rv) & Exp_mask;
02496 
02497         /* Check for overflow */
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 /*Sudden_Underflow*/
02563             /* Compute adj so that the IEEE rounding rules will
02564              * correctly round rv + adj in some half-way cases.
02565              * If rv * ulp(rv) is denormalized (i.e.,
02566              * y <= (P-1)*Exp_msk1), we must adjust aadj to avoid
02567              * trouble from bits lost to denormalization;
02568              * example: 1.2e-307 .
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 /*Sudden_Underflow*/
02579 #endif /*Avoid_Underflow*/
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                 /* Can we stop now? */
02589                 L = (Long)aadj;
02590                 aadj -= L;
02591                 /* The tolerances below are conservative. */
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         /* try to avoid the bug of testing an 8087 register value */
02628         if (word0(rv) == 0 && word1(rv) == 0)
02629             errno = ERANGE;
02630 #endif
02631     }
02632 #endif /* Avoid_Underflow */
02633 #ifdef SET_INEXACT
02634     if (inexact && !(word0(rv) & Exp_mask))
02635     {
02636         /* set underflow bit */
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     /*debug*/ if (b->wds > n)
02675         /*debug*/       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);      /* ensure q <= true quotient */
02684 #ifdef DEBUG
02685     /*debug*/ if (q > 9)
02686         /*debug*/       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 /* freedtoa(s) must be used to free values s returned by dtoa
02823  * when MULTIPLE_THREADS is #defined.  It should be used in all cases,
02824  * but for consistency with earlier versions of dtoa, it is optional
02825  * when MULTIPLE_THREADS is not defined.
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 /* dtoa for IEEE arithmetic (dmg): convert double to ASCII string.
02845  *
02846  * Inspired by "How to Print Floating-Point Numbers Accurately" by
02847  * Guy L. Steele, Jr. and Jon L. White [Proc. ACM SIGPLAN '90, pp. 112-126].
02848  *
02849  * Modifications:
02850  *      1. Rather than iterating, we use a simple numeric overestimate
02851  *         to determine k = floor(log10(d)).  We scale relevant
02852  *         quantities using O(log2(k)) rather than O(k) multiplications.
02853  *      2. For some modes > 2 (corresponding to ecvt and fcvt), we don't
02854  *         try to generate digits strictly left to right.  Instead, we
02855  *         compute with fewer bits and propagate the carry if necessary
02856  *         when rounding the final digit up.  This is often faster.
02857  *      3. Under the assumption that input will be rounded nearest,
02858  *         mode 0 renders 1e23 as 1e23 rather than 9.999999999999999e22.
02859  *         That is, we allow equality in stopping tests when the
02860  *         round-nearest rule will give the same floating-point value
02861  *         as would satisfaction of the stopping test with strict
02862  *         inequality.
02863  *      4. We remove common factors of powers of 2 from relevant
02864  *         quantities.
02865  *      5. When converting floating-point integers less than 1e16,
02866  *         we use floating-point arithmetic rather than resorting
02867  *         to multiple-precision integers.
02868  *      6. When asked to produce fewer than 15 digits, we first try
02869  *         to get by with floating-point arithmetic; we resort to
02870  *         multiple-precision integer arithmetic only if we cannot
02871  *         guarantee that the floating-point calculation has given
02872  *         the correctly rounded result.  For k requested digits and
02873  *         "uniformly" distributed input, the probability is
02874  *         something like 10^(k-15) that we must resort to the Long
02875  *         calculation.
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     /*  Arguments ndigits, decpt, sign are similar to those
02890     of ecvt and fcvt; trailing zeros are suppressed from
02891     the returned string.  If not null, *rve is set to point
02892     to the end of the return value.  If d is +-Infinity or NaN,
02893     then *decpt is set to 9999.
02894 
02895     mode:
02896         0 ==> shortest string that yields d when read in
02897                 and rounded to nearest.
02898         1 ==> like 0, but with Steele & White stopping rule;
02899                 e.g. with IEEE P754 arithmetic , mode 0 gives
02900                 1e23 whereas mode 1 gives 9.999999999999999e22.
02901         2 ==> max(1,ndigits) significant digits.  This gives a
02902                 return value similar to that of ecvt, except
02903                 that trailing zeros are suppressed.
02904         3 ==> through ndigits past the decimal point.  This
02905                 gives a return value similar to that from fcvt,
02906                 except that trailing zeros are suppressed, and
02907                 ndigits can be negative.
02908         4,5 ==> similar to 2 and 3, respectively, but (in
02909                 round-nearest mode) with the tests of mode 0 to
02910                 possibly return a shorter string that rounds to d.
02911                 With IEEE arithmetic and compilation with
02912                 -DHonor_FLT_ROUNDS, modes 4 and 5 behave the same
02913                 as modes 2 and 3 when FLT_ROUNDS != 1.
02914         6-9 ==> Debugging modes similar to mode - 4:  don't try
02915                 fast floating-point estimate (if applicable).
02916 
02917         Values of mode other than 0-9 are treated as mode 0.
02918 
02919         Sufficient space is allocated to the return value
02920         to hold the suppressed trailing zeros.
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         /* set sign for everything, including 0's and NaNs */
02952         *sign = 1;
02953         word0(d) &= ~Sign_bit;  /* clear 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         /* Infinity or NaN */
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; /* normalize */
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     /* log(x)   ~=~ log(1.5) + (x-1.5)/1.5
03013      * log10(x)  =  log(x) / log(10)
03014      *          ~=~ log(1.5)/log(10) + (x-1.5)/(1.5*log(10))
03015      * log10(d) = (i-Bias)*log(2)/log(10) + log10(d2)
03016      *
03017      * This suggests computing an approximation k to log10(d) by
03018      *
03019      * k = (i - Bias)*0.301029995663981
03020      *  + ( (d2-1.5)*0.289529654602168 + 0.176091259055681 );
03021      *
03022      * We want k to be too large rather than too small.
03023      * The error in the first-order Taylor series approximation
03024      * is in our favor, so we just round up the constant enough
03025      * to compensate for any error in the multiplication of
03026      * (i - Bias) by 0.301029995663981; since |i - Bias| <= 1077,
03027      * and 1077 * 0.30103 * 2^-52 ~=~ 7.2e-14,
03028      * adding 1e-13 to the constant term more than suffices.
03029      * Hence we adjust the constant term to 0.1760912590558.
03030      * (We could get a more accurate k by invoking log10,
03031      *  but this is probably not worthwhile.)
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     /* d is denormalized */
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; /* adjust exponent */
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--;        /* want k = floor(ds) */
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 /*SET_INEXACT*/
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     /* no break */
03117 case 4:
03118     if (ndigits <= 0)
03119         ndigits = 1;
03120     ilim = ilim1 = i = ndigits;
03121     break;
03122 case 3:
03123     leftright = 0;
03124     /* no break */
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     /* Try to get by with floating-point arithmetic. */
03143 
03144     i = 0;
03145     dval(d2) = dval(d);
03146     k0 = k;
03147     ilim0 = ilim;
03148     ieps = 2; /* conservative */
03149     if (k > 0)
03150     {
03151         ds = tens[k&0xf];
03152         j = k >> 4;
03153         if (j & Bletch)
03154         {
03155             /* prevent overflows */
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         /* Use Steele & White method of only
03203          * generating digits needed.
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         /* Generate ilim digits, then fix them up. */
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 /* Do we have a "small" integer? */
03256 
03257 if (be >= 0 && k <= Int_max)
03258 {
03259     /* Yes. */
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         /* If FLT_ROUNDS == 2, L will usually be high by 1 */
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 /* Check for special case that d is a normalized power of 2. */
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         /* The special case */
03381         b2 += Log2P;
03382         s2 += Log2P;
03383         spec_case = 1;
03384     }
03385 }
03386 
03387 /* Arrange for convenient computation of quotients:
03388  * shift left if necessary so divisor has 4 leading 0 bits.
03389  *
03390  * Perhaps we should just compute leading 28 bits of S once
03391  * and for all and pass them and a shift to quorem, so it
03392  * can do shifts and ors to compute the numerator for q.
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);  /* we botched the k estimate */
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         /* no digits, fcvt style */
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     /* Compute mlo -- check for special case
03450      * that d is a normalized power of 2.
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         /* Do we yet have the shortest decimal string
03465          * that will round to d?
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 /*Honor_FLT_ROUNDS*/
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')   /* possible if i == 1 */
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 /* Round off last digit */
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

Generated on Thu Sep 22 03:06:04 2011 by  doxygen 1.4.7