|
1 /**************************************************************** |
|
2 * |
|
3 * The author of this software is David M. Gay. |
|
4 * |
|
5 * Copyright (c) 1991, 2000, 2001 by Lucent Technologies. |
|
6 * |
|
7 * Permission to use, copy, modify, and distribute this software for any |
|
8 * purpose without fee is hereby granted, provided that this entire notice |
|
9 * is included in all copies of any software which is or includes a copy |
|
10 * or modification of this software and in all copies of the supporting |
|
11 * documentation for such software. |
|
12 * |
|
13 * THIS SOFTWARE IS BEING PROVIDED "AS IS", WITHOUT ANY EXPRESS OR IMPLIED |
|
14 * WARRANTY. IN PARTICULAR, NEITHER THE AUTHOR NOR LUCENT MAKES ANY |
|
15 * REPRESENTATION OR WARRANTY OF ANY KIND CONCERNING THE MERCHANTABILITY |
|
16 * OF THIS SOFTWARE OR ITS FITNESS FOR ANY PARTICULAR PURPOSE. |
|
17 * |
|
18 ***************************************************************/ |
|
19 |
|
20 /* Please send bug reports to David M. Gay (dmg at acm dot org, |
|
21 * with " at " changed at "@" and " dot " changed to "."). */ |
|
22 |
|
23 /* On a machine with IEEE extended-precision registers, it is |
|
24 * necessary to specify double-precision (53-bit) rounding precision |
|
25 * before invoking strtod or dtoa. If the machine uses (the equivalent |
|
26 * of) Intel 80x87 arithmetic, the call |
|
27 * _control87(PC_53, MCW_PC); |
|
28 * does this with many compilers. Whether this or another call is |
|
29 * appropriate depends on the compiler; for this to work, it may be |
|
30 * necessary to #include "float.h" or another system-dependent header |
|
31 * file. |
|
32 */ |
|
33 |
|
34 /* strtod for IEEE-, VAX-, and IBM-arithmetic machines. |
|
35 * |
|
36 * This strtod returns a nearest machine number to the input decimal |
|
37 * string (or sets errno to ERANGE). With IEEE arithmetic, ties are |
|
38 * broken by the IEEE round-even rule. Otherwise ties are broken by |
|
39 * biased rounding (add half and chop). |
|
40 * |
|
41 * Inspired loosely by William D. Clinger's paper "How to Read Floating |
|
42 * Point Numbers Accurately" [Proc. ACM SIGPLAN '90, pp. 92-101]. |
|
43 * |
|
44 * Modifications: |
|
45 * |
|
46 * 1. We only require IEEE, IBM, or VAX double-precision |
|
47 * arithmetic (not IEEE double-extended). |
|
48 * 2. We get by with floating-point arithmetic in a case that |
|
49 * Clinger missed -- when we're computing d * 10^n |
|
50 * for a small integer d and the integer n is not too |
|
51 * much larger than 22 (the maximum integer k for which |
|
52 * we can represent 10^k exactly), we may be able to |
|
53 * compute (d*10^k) * 10^(e-k) with just one roundoff. |
|
54 * 3. Rather than a bit-at-a-time adjustment of the binary |
|
55 * result in the hard case, we use floating-point |
|
56 * arithmetic to determine the adjustment to within |
|
57 * one bit; only in really hard cases do we need to |
|
58 * compute a second residual. |
|
59 * 4. Because of 3., we don't need a large table of powers of 10 |
|
60 * for ten-to-e (just some small tables, e.g. of 10^k |
|
61 * for 0 <= k <= 22). |
|
62 */ |
|
63 |
|
64 /* |
|
65 * #define IEEE_8087 for IEEE-arithmetic machines where the least |
|
66 * significant byte has the lowest address. |
|
67 * #define IEEE_MC68k for IEEE-arithmetic machines where the most |
|
68 * significant byte has the lowest address. |
|
69 * #define Long int on machines with 32-bit ints and 64-bit longs. |
|
70 * #define IBM for IBM mainframe-style floating-point arithmetic. |
|
71 * #define VAX for VAX-style floating-point arithmetic (D_floating). |
|
72 * #define No_leftright to omit left-right logic in fast floating-point |
|
73 * computation of dtoa. This will cause dtoa modes 4 and 5 to be |
|
74 * treated the same as modes 2 and 3 for some inputs. |
|
75 * #define Honor_FLT_ROUNDS if FLT_ROUNDS can assume the values 2 or 3 |
|
76 * and strtod and dtoa should round accordingly. Unless Trust_FLT_ROUNDS |
|
77 * is also #defined, fegetround() will be queried for the rounding mode. |
|
78 * Note that both FLT_ROUNDS and fegetround() are specified by the C99 |
|
79 * standard (and are specified to be consistent, with fesetround() |
|
80 * affecting the value of FLT_ROUNDS), but that some (Linux) systems |
|
81 * do not work correctly in this regard, so using fegetround() is more |
|
82 * portable than using FLT_ROUNDS directly. |
|
83 * #define Check_FLT_ROUNDS if FLT_ROUNDS can assume the values 2 or 3 |
|
84 * and Honor_FLT_ROUNDS is not #defined. |
|
85 * #define RND_PRODQUOT to use rnd_prod and rnd_quot (assembly routines |
|
86 * that use extended-precision instructions to compute rounded |
|
87 * products and quotients) with IBM. |
|
88 * #define ROUND_BIASED for IEEE-format with biased rounding and arithmetic |
|
89 * that rounds toward +Infinity. |
|
90 * #define ROUND_BIASED_without_Round_Up for IEEE-format with biased |
|
91 * rounding when the underlying floating-point arithmetic uses |
|
92 * unbiased rounding. This prevent using ordinary floating-point |
|
93 * arithmetic when the result could be computed with one rounding error. |
|
94 * #define Inaccurate_Divide for IEEE-format with correctly rounded |
|
95 * products but inaccurate quotients, e.g., for Intel i860. |
|
96 * #define NO_LONG_LONG on machines that do not have a "long long" |
|
97 * integer type (of >= 64 bits). On such machines, you can |
|
98 * #define Just_16 to store 16 bits per 32-bit Long when doing |
|
99 * high-precision integer arithmetic. Whether this speeds things |
|
100 * up or slows things down depends on the machine and the number |
|
101 * being converted. If long long is available and the name is |
|
102 * something other than "long long", #define Llong to be the name, |
|
103 * and if "unsigned Llong" does not work as an unsigned version of |
|
104 * Llong, #define #ULLong to be the corresponding unsigned type. |
|
105 * #define KR_headers for old-style C function headers. |
|
106 * #define Bad_float_h if your system lacks a float.h or if it does not |
|
107 * define some or all of DBL_DIG, DBL_MAX_10_EXP, DBL_MAX_EXP, |
|
108 * FLT_RADIX, FLT_ROUNDS, and DBL_MAX. |
|
109 * #define MALLOC your_malloc, where your_malloc(n) acts like malloc(n) |
|
110 * if memory is available and otherwise does something you deem |
|
111 * appropriate. If MALLOC is undefined, malloc will be invoked |
|
112 * directly -- and assumed always to succeed. Similarly, if you |
|
113 * want something other than the system's free() to be called to |
|
114 * recycle memory acquired from MALLOC, #define FREE to be the |
|
115 * name of the alternate routine. (FREE or free is only called in |
|
116 * pathological cases, e.g., in a dtoa call after a dtoa return in |
|
117 * mode 3 with thousands of digits requested.) |
|
118 * #define Omit_Private_Memory to omit logic (added Jan. 1998) for making |
|
119 * memory allocations from a private pool of memory when possible. |
|
120 * When used, the private pool is PRIVATE_MEM bytes long: 2304 bytes, |
|
121 * unless #defined to be a different length. This default length |
|
122 * suffices to get rid of MALLOC calls except for unusual cases, |
|
123 * such as decimal-to-binary conversion of a very long string of |
|
124 * digits. The longest string dtoa can return is about 751 bytes |
|
125 * long. For conversions by strtod of strings of 800 digits and |
|
126 * all dtoa conversions in single-threaded executions with 8-byte |
|
127 * pointers, PRIVATE_MEM >= 7400 appears to suffice; with 4-byte |
|
128 * pointers, PRIVATE_MEM >= 7112 appears adequate. |
|
129 * #define NO_INFNAN_CHECK if you do not wish to have INFNAN_CHECK |
|
130 * #defined automatically on IEEE systems. On such systems, |
|
131 * when INFNAN_CHECK is #defined, strtod checks |
|
132 * for Infinity and NaN (case insensitively). On some systems |
|
133 * (e.g., some HP systems), it may be necessary to #define NAN_WORD0 |
|
134 * appropriately -- to the most significant word of a quiet NaN. |
|
135 * (On HP Series 700/800 machines, -DNAN_WORD0=0x7ff40000 works.) |
|
136 * When INFNAN_CHECK is #defined and No_Hex_NaN is not #defined, |
|
137 * strtod also accepts (case insensitively) strings of the form |
|
138 * NaN(x), where x is a string of hexadecimal digits and spaces; |
|
139 * if there is only one string of hexadecimal digits, it is taken |
|
140 * for the 52 fraction bits of the resulting NaN; if there are two |
|
141 * or more strings of hex digits, the first is for the high 20 bits, |
|
142 * the second and subsequent for the low 32 bits, with intervening |
|
143 * white space ignored; but if this results in none of the 52 |
|
144 * fraction bits being on (an IEEE Infinity symbol), then NAN_WORD0 |
|
145 * and NAN_WORD1 are used instead. |
|
146 * #define MULTIPLE_THREADS if the system offers preemptively scheduled |
|
147 * multiple threads. In this case, you must provide (or suitably |
|
148 * #define) two locks, acquired by ACQUIRE_DTOA_LOCK(n) and freed |
|
149 * by FREE_DTOA_LOCK(n) for n = 0 or 1. (The second lock, accessed |
|
150 * in pow5mult, ensures lazy evaluation of only one copy of high |
|
151 * powers of 5; omitting this lock would introduce a small |
|
152 * probability of wasting memory, but would otherwise be harmless.) |
|
153 * You must also invoke freedtoa(s) to free the value s returned by |
|
154 * dtoa. You may do so whether or not MULTIPLE_THREADS is #defined. |
|
155 * #define NO_IEEE_Scale to disable new (Feb. 1997) logic in strtod that |
|
156 * avoids underflows on inputs whose result does not underflow. |
|
157 * If you #define NO_IEEE_Scale on a machine that uses IEEE-format |
|
158 * floating-point numbers and flushes underflows to zero rather |
|
159 * than implementing gradual underflow, then you must also #define |
|
160 * Sudden_Underflow. |
|
161 * #define USE_LOCALE to use the current locale's decimal_point value. |
|
162 * #define SET_INEXACT if IEEE arithmetic is being used and extra |
|
163 * computation should be done to set the inexact flag when the |
|
164 * result is inexact and avoid setting inexact when the result |
|
165 * is exact. In this case, dtoa.c must be compiled in |
|
166 * an environment, perhaps provided by #include "dtoa.c" in a |
|
167 * suitable wrapper, that defines two functions, |
|
168 * int get_inexact(void); |
|
169 * void clear_inexact(void); |
|
170 * such that get_inexact() returns a nonzero value if the |
|
171 * inexact bit is already set, and clear_inexact() sets the |
|
172 * inexact bit to 0. When SET_INEXACT is #defined, strtod |
|
173 * also does extra computations to set the underflow and overflow |
|
174 * flags when appropriate (i.e., when the result is tiny and |
|
175 * inexact or when it is a numeric value rounded to +-infinity). |
|
176 * #define NO_ERRNO if strtod should not assign errno = ERANGE when |
|
177 * the result overflows to +-Infinity or underflows to 0. |
|
178 * #define NO_HEX_FP to omit recognition of hexadecimal floating-point |
|
179 * values by strtod. |
|
180 * #define NO_STRTOD_BIGCOMP (on IEEE-arithmetic systems only for now) |
|
181 * to disable logic for "fast" testing of very long input strings |
|
182 * to strtod. This testing proceeds by initially truncating the |
|
183 * input string, then if necessary comparing the whole string with |
|
184 * a decimal expansion to decide close cases. This logic is only |
|
185 * used for input more than STRTOD_DIGLIM digits long (default 40). |
|
186 */ |
|
187 |
|
188 #ifndef Long |
|
189 #define Long long |
|
190 #endif |
|
191 #ifndef ULong |
|
192 typedef unsigned Long ULong; |
|
193 #endif |
|
194 |
|
195 #ifdef DEBUG |
|
196 #include "stdio.h" |
|
197 #define Bug(x) {fprintf(stderr, "%s\n", x); exit(1);} |
|
198 #endif |
|
199 |
|
200 #include "stdlib.h" |
|
201 #include "string.h" |
|
202 |
|
203 #ifdef USE_LOCALE |
|
204 #include "locale.h" |
|
205 #endif |
|
206 |
|
207 #ifdef Honor_FLT_ROUNDS |
|
208 #ifndef Trust_FLT_ROUNDS |
|
209 #include <fenv.h> |
|
210 #endif |
|
211 #endif |
|
212 |
|
213 #ifdef MALLOC |
|
214 #ifdef KR_headers |
|
215 extern char *MALLOC(); |
|
216 #else |
|
217 extern void *MALLOC(size_t); |
|
218 #endif |
|
219 #else |
|
220 #define MALLOC malloc |
|
221 #endif |
|
222 |
|
223 #ifndef Omit_Private_Memory |
|
224 #ifndef PRIVATE_MEM |
|
225 #define PRIVATE_MEM 2304 |
|
226 #endif |
|
227 #define PRIVATE_mem ((PRIVATE_MEM+sizeof(double)-1)/sizeof(double)) |
|
228 static double private_mem[PRIVATE_mem], *pmem_next = private_mem; |
|
229 #endif |
|
230 |
|
231 #undef IEEE_Arith |
|
232 #undef Avoid_Underflow |
|
233 #ifdef IEEE_MC68k |
|
234 #define IEEE_Arith |
|
235 #endif |
|
236 #ifdef IEEE_8087 |
|
237 #define IEEE_Arith |
|
238 #endif |
|
239 |
|
240 #ifdef IEEE_Arith |
|
241 #ifndef NO_INFNAN_CHECK |
|
242 #undef INFNAN_CHECK |
|
243 #define INFNAN_CHECK |
|
244 #endif |
|
245 #else |
|
246 #undef INFNAN_CHECK |
|
247 #define NO_STRTOD_BIGCOMP |
|
248 #endif |
|
249 |
|
250 #include "errno.h" |
|
251 |
|
252 #ifdef Bad_float_h |
|
253 |
|
254 #ifdef IEEE_Arith |
|
255 #define DBL_DIG 15 |
|
256 #define DBL_MAX_10_EXP 308 |
|
257 #define DBL_MAX_EXP 1024 |
|
258 #define FLT_RADIX 2 |
|
259 #endif /*IEEE_Arith*/ |
|
260 |
|
261 #ifdef IBM |
|
262 #define DBL_DIG 16 |
|
263 #define DBL_MAX_10_EXP 75 |
|
264 #define DBL_MAX_EXP 63 |
|
265 #define FLT_RADIX 16 |
|
266 #define DBL_MAX 7.2370055773322621e+75 |
|
267 #endif |
|
268 |
|
269 #ifdef VAX |
|
270 #define DBL_DIG 16 |
|
271 #define DBL_MAX_10_EXP 38 |
|
272 #define DBL_MAX_EXP 127 |
|
273 #define FLT_RADIX 2 |
|
274 #define DBL_MAX 1.7014118346046923e+38 |
|
275 #endif |
|
276 |
|
277 #ifndef LONG_MAX |
|
278 #define LONG_MAX 2147483647 |
|
279 #endif |
|
280 |
|
281 #else /* ifndef Bad_float_h */ |
|
282 #include "float.h" |
|
283 #endif /* Bad_float_h */ |
|
284 |
|
285 #ifndef __MATH_H__ |
|
286 #include "math.h" |
|
287 #endif |
|
288 |
|
289 #ifdef __cplusplus |
|
290 extern "C" { |
|
291 #endif |
|
292 |
|
293 #ifndef CONST |
|
294 #ifdef KR_headers |
|
295 #define CONST /* blank */ |
|
296 #else |
|
297 #define CONST const |
|
298 #endif |
|
299 #endif |
|
300 |
|
301 #if defined(IEEE_8087) + defined(IEEE_MC68k) + defined(VAX) + defined(IBM) != 1 |
|
302 Exactly one of IEEE_8087, IEEE_MC68k, VAX, or IBM should be defined. |
|
303 #endif |
|
304 |
|
305 typedef union { double d; ULong L[2]; } U; |
|
306 |
|
307 #ifdef IEEE_8087 |
|
308 #define word0(x) (x)->L[1] |
|
309 #define word1(x) (x)->L[0] |
|
310 #else |
|
311 #define word0(x) (x)->L[0] |
|
312 #define word1(x) (x)->L[1] |
|
313 #endif |
|
314 #define dval(x) (x)->d |
|
315 |
|
316 #ifndef STRTOD_DIGLIM |
|
317 #define STRTOD_DIGLIM 40 |
|
318 #endif |
|
319 |
|
320 #ifdef DIGLIM_DEBUG |
|
321 extern int strtod_diglim; |
|
322 #else |
|
323 #define strtod_diglim STRTOD_DIGLIM |
|
324 #endif |
|
325 |
|
326 /* The following definition of Storeinc is appropriate for MIPS processors. |
|
327 * An alternative that might be better on some machines is |
|
328 * #define Storeinc(a,b,c) (*a++ = b << 16 | c & 0xffff) |
|
329 */ |
|
330 #if defined(IEEE_8087) + defined(VAX) |
|
331 #define Storeinc(a,b,c) (((unsigned short *)a)[1] = (unsigned short)b, \ |
|
332 ((unsigned short *)a)[0] = (unsigned short)c, a++) |
|
333 #else |
|
334 #define Storeinc(a,b,c) (((unsigned short *)a)[0] = (unsigned short)b, \ |
|
335 ((unsigned short *)a)[1] = (unsigned short)c, a++) |
|
336 #endif |
|
337 |
|
338 /* #define P DBL_MANT_DIG */ |
|
339 /* Ten_pmax = floor(P*log(2)/log(5)) */ |
|
340 /* Bletch = (highest power of 2 < DBL_MAX_10_EXP) / 16 */ |
|
341 /* Quick_max = floor((P-1)*log(FLT_RADIX)/log(10) - 1) */ |
|
342 /* Int_max = floor(P*log(FLT_RADIX)/log(10) - 1) */ |
|
343 |
|
344 #ifdef IEEE_Arith |
|
345 #define Exp_shift 20 |
|
346 #define Exp_shift1 20 |
|
347 #define Exp_msk1 0x100000 |
|
348 #define Exp_msk11 0x100000 |
|
349 #define Exp_mask 0x7ff00000 |
|
350 #define P 53 |
|
351 #define Nbits 53 |
|
352 #define Bias 1023 |
|
353 #define Emax 1023 |
|
354 #define Emin (-1022) |
|
355 #define Exp_1 0x3ff00000 |
|
356 #define Exp_11 0x3ff00000 |
|
357 #define Ebits 11 |
|
358 #define Frac_mask 0xfffff |
|
359 #define Frac_mask1 0xfffff |
|
360 #define Ten_pmax 22 |
|
361 #define Bletch 0x10 |
|
362 #define Bndry_mask 0xfffff |
|
363 #define Bndry_mask1 0xfffff |
|
364 #define LSB 1 |
|
365 #define Sign_bit 0x80000000 |
|
366 #define Log2P 1 |
|
367 #define Tiny0 0 |
|
368 #define Tiny1 1 |
|
369 #define Quick_max 14 |
|
370 #define Int_max 14 |
|
371 #ifndef NO_IEEE_Scale |
|
372 #define Avoid_Underflow |
|
373 #ifdef Flush_Denorm /* debugging option */ |
|
374 #undef Sudden_Underflow |
|
375 #endif |
|
376 #endif |
|
377 |
|
378 #ifndef Flt_Rounds |
|
379 #ifdef FLT_ROUNDS |
|
380 #define Flt_Rounds FLT_ROUNDS |
|
381 #else |
|
382 #define Flt_Rounds 1 |
|
383 #endif |
|
384 #endif /*Flt_Rounds*/ |
|
385 |
|
386 #ifdef Honor_FLT_ROUNDS |
|
387 #undef Check_FLT_ROUNDS |
|
388 #define Check_FLT_ROUNDS |
|
389 #else |
|
390 #define Rounding Flt_Rounds |
|
391 #endif |
|
392 |
|
393 #else /* ifndef IEEE_Arith */ |
|
394 #undef Check_FLT_ROUNDS |
|
395 #undef Honor_FLT_ROUNDS |
|
396 #undef SET_INEXACT |
|
397 #undef Sudden_Underflow |
|
398 #define Sudden_Underflow |
|
399 #ifdef IBM |
|
400 #undef Flt_Rounds |
|
401 #define Flt_Rounds 0 |
|
402 #define Exp_shift 24 |
|
403 #define Exp_shift1 24 |
|
404 #define Exp_msk1 0x1000000 |
|
405 #define Exp_msk11 0x1000000 |
|
406 #define Exp_mask 0x7f000000 |
|
407 #define P 14 |
|
408 #define Nbits 56 |
|
409 #define Bias 65 |
|
410 #define Emax 248 |
|
411 #define Emin (-260) |
|
412 #define Exp_1 0x41000000 |
|
413 #define Exp_11 0x41000000 |
|
414 #define Ebits 8 /* exponent has 7 bits, but 8 is the right value in b2d */ |
|
415 #define Frac_mask 0xffffff |
|
416 #define Frac_mask1 0xffffff |
|
417 #define Bletch 4 |
|
418 #define Ten_pmax 22 |
|
419 #define Bndry_mask 0xefffff |
|
420 #define Bndry_mask1 0xffffff |
|
421 #define LSB 1 |
|
422 #define Sign_bit 0x80000000 |
|
423 #define Log2P 4 |
|
424 #define Tiny0 0x100000 |
|
425 #define Tiny1 0 |
|
426 #define Quick_max 14 |
|
427 #define Int_max 15 |
|
428 #else /* VAX */ |
|
429 #undef Flt_Rounds |
|
430 #define Flt_Rounds 1 |
|
431 #define Exp_shift 23 |
|
432 #define Exp_shift1 7 |
|
433 #define Exp_msk1 0x80 |
|
434 #define Exp_msk11 0x800000 |
|
435 #define Exp_mask 0x7f80 |
|
436 #define P 56 |
|
437 #define Nbits 56 |
|
438 #define Bias 129 |
|
439 #define Emax 126 |
|
440 #define Emin (-129) |
|
441 #define Exp_1 0x40800000 |
|
442 #define Exp_11 0x4080 |
|
443 #define Ebits 8 |
|
444 #define Frac_mask 0x7fffff |
|
445 #define Frac_mask1 0xffff007f |
|
446 #define Ten_pmax 24 |
|
447 #define Bletch 2 |
|
448 #define Bndry_mask 0xffff007f |
|
449 #define Bndry_mask1 0xffff007f |
|
450 #define LSB 0x10000 |
|
451 #define Sign_bit 0x8000 |
|
452 #define Log2P 1 |
|
453 #define Tiny0 0x80 |
|
454 #define Tiny1 0 |
|
455 #define Quick_max 15 |
|
456 #define Int_max 15 |
|
457 #endif /* IBM, VAX */ |
|
458 #endif /* IEEE_Arith */ |
|
459 |
|
460 #ifndef IEEE_Arith |
|
461 #define ROUND_BIASED |
|
462 #else |
|
463 #ifdef ROUND_BIASED_without_Round_Up |
|
464 #undef ROUND_BIASED |
|
465 #define ROUND_BIASED |
|
466 #endif |
|
467 #endif |
|
468 |
|
469 #ifdef RND_PRODQUOT |
|
470 #define rounded_product(a,b) a = rnd_prod(a, b) |
|
471 #define rounded_quotient(a,b) a = rnd_quot(a, b) |
|
472 #ifdef KR_headers |
|
473 extern double rnd_prod(), rnd_quot(); |
|
474 #else |
|
475 extern double rnd_prod(double, double), rnd_quot(double, double); |
|
476 #endif |
|
477 #else |
|
478 #define rounded_product(a,b) a *= b |
|
479 #define rounded_quotient(a,b) a /= b |
|
480 #endif |
|
481 |
|
482 #define Big0 (Frac_mask1 | Exp_msk1*(DBL_MAX_EXP+Bias-1)) |
|
483 #define Big1 0xffffffff |
|
484 |
|
485 #ifndef Pack_32 |
|
486 #define Pack_32 |
|
487 #endif |
|
488 |
|
489 typedef struct BCinfo BCinfo; |
|
490 struct |
|
491 BCinfo { int dp0, dp1, dplen, dsign, e0, inexact, nd, nd0, rounding, scale, uflchk; }; |
|
492 |
|
493 #ifdef KR_headers |
|
494 #define FFFFFFFF ((((unsigned long)0xffff)<<16)|(unsigned long)0xffff) |
|
495 #else |
|
496 #define FFFFFFFF 0xffffffffUL |
|
497 #endif |
|
498 |
|
499 #ifdef NO_LONG_LONG |
|
500 #undef ULLong |
|
501 #ifdef Just_16 |
|
502 #undef Pack_32 |
|
503 /* When Pack_32 is not defined, we store 16 bits per 32-bit Long. |
|
504 * This makes some inner loops simpler and sometimes saves work |
|
505 * during multiplications, but it often seems to make things slightly |
|
506 * slower. Hence the default is now to store 32 bits per Long. |
|
507 */ |
|
508 #endif |
|
509 #else /* long long available */ |
|
510 #ifndef Llong |
|
511 #define Llong long long |
|
512 #endif |
|
513 #ifndef ULLong |
|
514 #define ULLong unsigned Llong |
|
515 #endif |
|
516 #endif /* NO_LONG_LONG */ |
|
517 |
|
518 #ifndef MULTIPLE_THREADS |
|
519 #define ACQUIRE_DTOA_LOCK(n) /*nothing*/ |
|
520 #define FREE_DTOA_LOCK(n) /*nothing*/ |
|
521 #endif |
|
522 |
|
523 #define Kmax 7 |
|
524 |
|
525 #ifdef __cplusplus |
|
526 extern "C" double strtod(const char *s00, char **se); |
|
527 extern "C" char *dtoa(double d, int mode, int ndigits, |
|
528 int *decpt, int *sign, char **rve); |
|
529 #endif |
|
530 |
|
531 struct |
|
532 Bigint { |
|
533 struct Bigint *next; |
|
534 int k, maxwds, sign, wds; |
|
535 ULong x[1]; |
|
536 }; |
|
537 |
|
538 typedef struct Bigint Bigint; |
|
539 |
|
540 static Bigint *freelist[Kmax+1]; |
|
541 |
|
542 static Bigint * |
|
543 Balloc |
|
544 #ifdef KR_headers |
|
545 (k) int k; |
|
546 #else |
|
547 (int k) |
|
548 #endif |
|
549 { |
|
550 int x; |
|
551 Bigint *rv; |
|
552 #ifndef Omit_Private_Memory |
|
553 unsigned int len; |
|
554 #endif |
|
555 |
|
556 ACQUIRE_DTOA_LOCK(0); |
|
557 /* The k > Kmax case does not need ACQUIRE_DTOA_LOCK(0), */ |
|
558 /* but this case seems very unlikely. */ |
|
559 if (k <= Kmax && (rv = freelist[k])) |
|
560 freelist[k] = rv->next; |
|
561 else { |
|
562 x = 1 << k; |
|
563 #ifdef Omit_Private_Memory |
|
564 rv = (Bigint *)MALLOC(sizeof(Bigint) + (x-1)*sizeof(ULong)); |
|
565 #else |
|
566 len = (sizeof(Bigint) + (x-1)*sizeof(ULong) + sizeof(double) - 1) |
|
567 /sizeof(double); |
|
568 if (k <= Kmax && pmem_next - private_mem + len <= PRIVATE_mem) { |
|
569 rv = (Bigint*)pmem_next; |
|
570 pmem_next += len; |
|
571 } |
|
572 else |
|
573 rv = (Bigint*)MALLOC(len*sizeof(double)); |
|
574 #endif |
|
575 rv->k = k; |
|
576 rv->maxwds = x; |
|
577 } |
|
578 FREE_DTOA_LOCK(0); |
|
579 rv->sign = rv->wds = 0; |
|
580 return rv; |
|
581 } |
|
582 |
|
583 static void |
|
584 Bfree |
|
585 #ifdef KR_headers |
|
586 (v) Bigint *v; |
|
587 #else |
|
588 (Bigint *v) |
|
589 #endif |
|
590 { |
|
591 if (v) { |
|
592 if (v->k > Kmax) |
|
593 #ifdef FREE |
|
594 FREE((void*)v); |
|
595 #else |
|
596 free((void*)v); |
|
597 #endif |
|
598 else { |
|
599 ACQUIRE_DTOA_LOCK(0); |
|
600 v->next = freelist[v->k]; |
|
601 freelist[v->k] = v; |
|
602 FREE_DTOA_LOCK(0); |
|
603 } |
|
604 } |
|
605 } |
|
606 |
|
607 #define Bcopy(x,y) memcpy((char *)&x->sign, (char *)&y->sign, \ |
|
608 y->wds*sizeof(Long) + 2*sizeof(int)) |
|
609 |
|
610 static Bigint * |
|
611 multadd |
|
612 #ifdef KR_headers |
|
613 (b, m, a) Bigint *b; int m, a; |
|
614 #else |
|
615 (Bigint *b, int m, int a) /* multiply by m and add a */ |
|
616 #endif |
|
617 { |
|
618 int i, wds; |
|
619 #ifdef ULLong |
|
620 ULong *x; |
|
621 ULLong carry, y; |
|
622 #else |
|
623 ULong carry, *x, y; |
|
624 #ifdef Pack_32 |
|
625 ULong xi, z; |
|
626 #endif |
|
627 #endif |
|
628 Bigint *b1; |
|
629 |
|
630 wds = b->wds; |
|
631 x = b->x; |
|
632 i = 0; |
|
633 carry = a; |
|
634 do { |
|
635 #ifdef ULLong |
|
636 y = *x * (ULLong)m + carry; |
|
637 carry = y >> 32; |
|
638 *x++ = y & FFFFFFFF; |
|
639 #else |
|
640 #ifdef Pack_32 |
|
641 xi = *x; |
|
642 y = (xi & 0xffff) * m + carry; |
|
643 z = (xi >> 16) * m + (y >> 16); |
|
644 carry = z >> 16; |
|
645 *x++ = (z << 16) + (y & 0xffff); |
|
646 #else |
|
647 y = *x * m + carry; |
|
648 carry = y >> 16; |
|
649 *x++ = y & 0xffff; |
|
650 #endif |
|
651 #endif |
|
652 } |
|
653 while(++i < wds); |
|
654 if (carry) { |
|
655 if (wds >= b->maxwds) { |
|
656 b1 = Balloc(b->k+1); |
|
657 Bcopy(b1, b); |
|
658 Bfree(b); |
|
659 b = b1; |
|
660 } |
|
661 b->x[wds++] = carry; |
|
662 b->wds = wds; |
|
663 } |
|
664 return b; |
|
665 } |
|
666 |
|
667 static Bigint * |
|
668 s2b |
|
669 #ifdef KR_headers |
|
670 (s, nd0, nd, y9, dplen) CONST char *s; int nd0, nd, dplen; ULong y9; |
|
671 #else |
|
672 (const char *s, int nd0, int nd, ULong y9, int dplen) |
|
673 #endif |
|
674 { |
|
675 Bigint *b; |
|
676 int i, k; |
|
677 Long x, y; |
|
678 |
|
679 x = (nd + 8) / 9; |
|
680 for(k = 0, y = 1; x > y; y <<= 1, k++) ; |
|
681 #ifdef Pack_32 |
|
682 b = Balloc(k); |
|
683 b->x[0] = y9; |
|
684 b->wds = 1; |
|
685 #else |
|
686 b = Balloc(k+1); |
|
687 b->x[0] = y9 & 0xffff; |
|
688 b->wds = (b->x[1] = y9 >> 16) ? 2 : 1; |
|
689 #endif |
|
690 |
|
691 i = 9; |
|
692 if (9 < nd0) { |
|
693 s += 9; |
|
694 do b = multadd(b, 10, *s++ - '0'); |
|
695 while(++i < nd0); |
|
696 s += dplen; |
|
697 } |
|
698 else |
|
699 s += dplen + 9; |
|
700 for(; i < nd; i++) |
|
701 b = multadd(b, 10, *s++ - '0'); |
|
702 return b; |
|
703 } |
|
704 |
|
705 static int |
|
706 hi0bits |
|
707 #ifdef KR_headers |
|
708 (x) ULong x; |
|
709 #else |
|
710 (ULong x) |
|
711 #endif |
|
712 { |
|
713 int k = 0; |
|
714 |
|
715 if (!(x & 0xffff0000)) { |
|
716 k = 16; |
|
717 x <<= 16; |
|
718 } |
|
719 if (!(x & 0xff000000)) { |
|
720 k += 8; |
|
721 x <<= 8; |
|
722 } |
|
723 if (!(x & 0xf0000000)) { |
|
724 k += 4; |
|
725 x <<= 4; |
|
726 } |
|
727 if (!(x & 0xc0000000)) { |
|
728 k += 2; |
|
729 x <<= 2; |
|
730 } |
|
731 if (!(x & 0x80000000)) { |
|
732 k++; |
|
733 if (!(x & 0x40000000)) |
|
734 return 32; |
|
735 } |
|
736 return k; |
|
737 } |
|
738 |
|
739 static int |
|
740 lo0bits |
|
741 #ifdef KR_headers |
|
742 (y) ULong *y; |
|
743 #else |
|
744 (ULong *y) |
|
745 #endif |
|
746 { |
|
747 int k; |
|
748 ULong x = *y; |
|
749 |
|
750 if (x & 7) { |
|
751 if (x & 1) |
|
752 return 0; |
|
753 if (x & 2) { |
|
754 *y = x >> 1; |
|
755 return 1; |
|
756 } |
|
757 *y = x >> 2; |
|
758 return 2; |
|
759 } |
|
760 k = 0; |
|
761 if (!(x & 0xffff)) { |
|
762 k = 16; |
|
763 x >>= 16; |
|
764 } |
|
765 if (!(x & 0xff)) { |
|
766 k += 8; |
|
767 x >>= 8; |
|
768 } |
|
769 if (!(x & 0xf)) { |
|
770 k += 4; |
|
771 x >>= 4; |
|
772 } |
|
773 if (!(x & 0x3)) { |
|
774 k += 2; |
|
775 x >>= 2; |
|
776 } |
|
777 if (!(x & 1)) { |
|
778 k++; |
|
779 x >>= 1; |
|
780 if (!x) |
|
781 return 32; |
|
782 } |
|
783 *y = x; |
|
784 return k; |
|
785 } |
|
786 |
|
787 static Bigint * |
|
788 i2b |
|
789 #ifdef KR_headers |
|
790 (i) int i; |
|
791 #else |
|
792 (int i) |
|
793 #endif |
|
794 { |
|
795 Bigint *b; |
|
796 |
|
797 b = Balloc(1); |
|
798 b->x[0] = i; |
|
799 b->wds = 1; |
|
800 return b; |
|
801 } |
|
802 |
|
803 static Bigint * |
|
804 mult |
|
805 #ifdef KR_headers |
|
806 (a, b) Bigint *a, *b; |
|
807 #else |
|
808 (Bigint *a, Bigint *b) |
|
809 #endif |
|
810 { |
|
811 Bigint *c; |
|
812 int k, wa, wb, wc; |
|
813 ULong *x, *xa, *xae, *xb, *xbe, *xc, *xc0; |
|
814 ULong y; |
|
815 #ifdef ULLong |
|
816 ULLong carry, z; |
|
817 #else |
|
818 ULong carry, z; |
|
819 #ifdef Pack_32 |
|
820 ULong z2; |
|
821 #endif |
|
822 #endif |
|
823 |
|
824 if (a->wds < b->wds) { |
|
825 c = a; |
|
826 a = b; |
|
827 b = c; |
|
828 } |
|
829 k = a->k; |
|
830 wa = a->wds; |
|
831 wb = b->wds; |
|
832 wc = wa + wb; |
|
833 if (wc > a->maxwds) |
|
834 k++; |
|
835 c = Balloc(k); |
|
836 for(x = c->x, xa = x + wc; x < xa; x++) |
|
837 *x = 0; |
|
838 xa = a->x; |
|
839 xae = xa + wa; |
|
840 xb = b->x; |
|
841 xbe = xb + wb; |
|
842 xc0 = c->x; |
|
843 #ifdef ULLong |
|
844 for(; xb < xbe; xc0++) { |
|
845 if ((y = *xb++)) { |
|
846 x = xa; |
|
847 xc = xc0; |
|
848 carry = 0; |
|
849 do { |
|
850 z = *x++ * (ULLong)y + *xc + carry; |
|
851 carry = z >> 32; |
|
852 *xc++ = z & FFFFFFFF; |
|
853 } |
|
854 while(x < xae); |
|
855 *xc = carry; |
|
856 } |
|
857 } |
|
858 #else |
|
859 #ifdef Pack_32 |
|
860 for(; xb < xbe; xb++, xc0++) { |
|
861 if (y = *xb & 0xffff) { |
|
862 x = xa; |
|
863 xc = xc0; |
|
864 carry = 0; |
|
865 do { |
|
866 z = (*x & 0xffff) * y + (*xc & 0xffff) + carry; |
|
867 carry = z >> 16; |
|
868 z2 = (*x++ >> 16) * y + (*xc >> 16) + carry; |
|
869 carry = z2 >> 16; |
|
870 Storeinc(xc, z2, z); |
|
871 } |
|
872 while(x < xae); |
|
873 *xc = carry; |
|
874 } |
|
875 if (y = *xb >> 16) { |
|
876 x = xa; |
|
877 xc = xc0; |
|
878 carry = 0; |
|
879 z2 = *xc; |
|
880 do { |
|
881 z = (*x & 0xffff) * y + (*xc >> 16) + carry; |
|
882 carry = z >> 16; |
|
883 Storeinc(xc, z, z2); |
|
884 z2 = (*x++ >> 16) * y + (*xc & 0xffff) + carry; |
|
885 carry = z2 >> 16; |
|
886 } |
|
887 while(x < xae); |
|
888 *xc = z2; |
|
889 } |
|
890 } |
|
891 #else |
|
892 for(; xb < xbe; xc0++) { |
|
893 if (y = *xb++) { |
|
894 x = xa; |
|
895 xc = xc0; |
|
896 carry = 0; |
|
897 do { |
|
898 z = *x++ * y + *xc + carry; |
|
899 carry = z >> 16; |
|
900 *xc++ = z & 0xffff; |
|
901 } |
|
902 while(x < xae); |
|
903 *xc = carry; |
|
904 } |
|
905 } |
|
906 #endif |
|
907 #endif |
|
908 for(xc0 = c->x, xc = xc0 + wc; wc > 0 && !*--xc; --wc) ; |
|
909 c->wds = wc; |
|
910 return c; |
|
911 } |
|
912 |
|
913 static Bigint *p5s; |
|
914 |
|
915 static Bigint * |
|
916 pow5mult |
|
917 #ifdef KR_headers |
|
918 (b, k) Bigint *b; int k; |
|
919 #else |
|
920 (Bigint *b, int k) |
|
921 #endif |
|
922 { |
|
923 Bigint *b1, *p5, *p51; |
|
924 int i; |
|
925 static int p05[3] = { 5, 25, 125 }; |
|
926 |
|
927 if ((i = k & 3)) |
|
928 b = multadd(b, p05[i-1], 0); |
|
929 |
|
930 if (!(k >>= 2)) |
|
931 return b; |
|
932 if (!(p5 = p5s)) { |
|
933 /* first time */ |
|
934 #ifdef MULTIPLE_THREADS |
|
935 ACQUIRE_DTOA_LOCK(1); |
|
936 if (!(p5 = p5s)) { |
|
937 p5 = p5s = i2b(625); |
|
938 p5->next = 0; |
|
939 } |
|
940 FREE_DTOA_LOCK(1); |
|
941 #else |
|
942 p5 = p5s = i2b(625); |
|
943 p5->next = 0; |
|
944 #endif |
|
945 } |
|
946 for(;;) { |
|
947 if (k & 1) { |
|
948 b1 = mult(b, p5); |
|
949 Bfree(b); |
|
950 b = b1; |
|
951 } |
|
952 if (!(k >>= 1)) |
|
953 break; |
|
954 if (!(p51 = p5->next)) { |
|
955 #ifdef MULTIPLE_THREADS |
|
956 ACQUIRE_DTOA_LOCK(1); |
|
957 if (!(p51 = p5->next)) { |
|
958 p51 = p5->next = mult(p5,p5); |
|
959 p51->next = 0; |
|
960 } |
|
961 FREE_DTOA_LOCK(1); |
|
962 #else |
|
963 p51 = p5->next = mult(p5,p5); |
|
964 p51->next = 0; |
|
965 #endif |
|
966 } |
|
967 p5 = p51; |
|
968 } |
|
969 return b; |
|
970 } |
|
971 |
|
972 static Bigint * |
|
973 lshift |
|
974 #ifdef KR_headers |
|
975 (b, k) Bigint *b; int k; |
|
976 #else |
|
977 (Bigint *b, int k) |
|
978 #endif |
|
979 { |
|
980 int i, k1, n, n1; |
|
981 Bigint *b1; |
|
982 ULong *x, *x1, *xe, z; |
|
983 |
|
984 #ifdef Pack_32 |
|
985 n = k >> 5; |
|
986 #else |
|
987 n = k >> 4; |
|
988 #endif |
|
989 k1 = b->k; |
|
990 n1 = n + b->wds + 1; |
|
991 for(i = b->maxwds; n1 > i; i <<= 1) |
|
992 k1++; |
|
993 b1 = Balloc(k1); |
|
994 x1 = b1->x; |
|
995 for(i = 0; i < n; i++) |
|
996 *x1++ = 0; |
|
997 x = b->x; |
|
998 xe = x + b->wds; |
|
999 #ifdef Pack_32 |
|
1000 if (k &= 0x1f) { |
|
1001 k1 = 32 - k; |
|
1002 z = 0; |
|
1003 do { |
|
1004 *x1++ = *x << k | z; |
|
1005 z = *x++ >> k1; |
|
1006 } |
|
1007 while(x < xe); |
|
1008 if ((*x1 = z)) |
|
1009 ++n1; |
|
1010 } |
|
1011 #else |
|
1012 if (k &= 0xf) { |
|
1013 k1 = 16 - k; |
|
1014 z = 0; |
|
1015 do { |
|
1016 *x1++ = *x << k & 0xffff | z; |
|
1017 z = *x++ >> k1; |
|
1018 } |
|
1019 while(x < xe); |
|
1020 if (*x1 = z) |
|
1021 ++n1; |
|
1022 } |
|
1023 #endif |
|
1024 else do |
|
1025 *x1++ = *x++; |
|
1026 while(x < xe); |
|
1027 b1->wds = n1 - 1; |
|
1028 Bfree(b); |
|
1029 return b1; |
|
1030 } |
|
1031 |
|
1032 static int |
|
1033 cmp |
|
1034 #ifdef KR_headers |
|
1035 (a, b) Bigint *a, *b; |
|
1036 #else |
|
1037 (Bigint *a, Bigint *b) |
|
1038 #endif |
|
1039 { |
|
1040 ULong *xa, *xa0, *xb, *xb0; |
|
1041 int i, j; |
|
1042 |
|
1043 i = a->wds; |
|
1044 j = b->wds; |
|
1045 #ifdef DEBUG |
|
1046 if (i > 1 && !a->x[i-1]) |
|
1047 Bug("cmp called with a->x[a->wds-1] == 0"); |
|
1048 if (j > 1 && !b->x[j-1]) |
|
1049 Bug("cmp called with b->x[b->wds-1] == 0"); |
|
1050 #endif |
|
1051 if (i -= j) |
|
1052 return i; |
|
1053 xa0 = a->x; |
|
1054 xa = xa0 + j; |
|
1055 xb0 = b->x; |
|
1056 xb = xb0 + j; |
|
1057 for(;;) { |
|
1058 if (*--xa != *--xb) |
|
1059 return *xa < *xb ? -1 : 1; |
|
1060 if (xa <= xa0) |
|
1061 break; |
|
1062 } |
|
1063 return 0; |
|
1064 } |
|
1065 |
|
1066 static Bigint * |
|
1067 diff |
|
1068 #ifdef KR_headers |
|
1069 (a, b) Bigint *a, *b; |
|
1070 #else |
|
1071 (Bigint *a, Bigint *b) |
|
1072 #endif |
|
1073 { |
|
1074 Bigint *c; |
|
1075 int i, wa, wb; |
|
1076 ULong *xa, *xae, *xb, *xbe, *xc; |
|
1077 #ifdef ULLong |
|
1078 ULLong borrow, y; |
|
1079 #else |
|
1080 ULong borrow, y; |
|
1081 #ifdef Pack_32 |
|
1082 ULong z; |
|
1083 #endif |
|
1084 #endif |
|
1085 |
|
1086 i = cmp(a,b); |
|
1087 if (!i) { |
|
1088 c = Balloc(0); |
|
1089 c->wds = 1; |
|
1090 c->x[0] = 0; |
|
1091 return c; |
|
1092 } |
|
1093 if (i < 0) { |
|
1094 c = a; |
|
1095 a = b; |
|
1096 b = c; |
|
1097 i = 1; |
|
1098 } |
|
1099 else |
|
1100 i = 0; |
|
1101 c = Balloc(a->k); |
|
1102 c->sign = i; |
|
1103 wa = a->wds; |
|
1104 xa = a->x; |
|
1105 xae = xa + wa; |
|
1106 wb = b->wds; |
|
1107 xb = b->x; |
|
1108 xbe = xb + wb; |
|
1109 xc = c->x; |
|
1110 borrow = 0; |
|
1111 #ifdef ULLong |
|
1112 do { |
|
1113 y = (ULLong)*xa++ - *xb++ - borrow; |
|
1114 borrow = y >> 32 & (ULong)1; |
|
1115 *xc++ = y & FFFFFFFF; |
|
1116 } |
|
1117 while(xb < xbe); |
|
1118 while(xa < xae) { |
|
1119 y = *xa++ - borrow; |
|
1120 borrow = y >> 32 & (ULong)1; |
|
1121 *xc++ = y & FFFFFFFF; |
|
1122 } |
|
1123 #else |
|
1124 #ifdef Pack_32 |
|
1125 do { |
|
1126 y = (*xa & 0xffff) - (*xb & 0xffff) - borrow; |
|
1127 borrow = (y & 0x10000) >> 16; |
|
1128 z = (*xa++ >> 16) - (*xb++ >> 16) - borrow; |
|
1129 borrow = (z & 0x10000) >> 16; |
|
1130 Storeinc(xc, z, y); |
|
1131 } |
|
1132 while(xb < xbe); |
|
1133 while(xa < xae) { |
|
1134 y = (*xa & 0xffff) - borrow; |
|
1135 borrow = (y & 0x10000) >> 16; |
|
1136 z = (*xa++ >> 16) - borrow; |
|
1137 borrow = (z & 0x10000) >> 16; |
|
1138 Storeinc(xc, z, y); |
|
1139 } |
|
1140 #else |
|
1141 do { |
|
1142 y = *xa++ - *xb++ - borrow; |
|
1143 borrow = (y & 0x10000) >> 16; |
|
1144 *xc++ = y & 0xffff; |
|
1145 } |
|
1146 while(xb < xbe); |
|
1147 while(xa < xae) { |
|
1148 y = *xa++ - borrow; |
|
1149 borrow = (y & 0x10000) >> 16; |
|
1150 *xc++ = y & 0xffff; |
|
1151 } |
|
1152 #endif |
|
1153 #endif |
|
1154 while(!*--xc) |
|
1155 wa--; |
|
1156 c->wds = wa; |
|
1157 return c; |
|
1158 } |
|
1159 |
|
1160 static double |
|
1161 ulp |
|
1162 #ifdef KR_headers |
|
1163 (x) U *x; |
|
1164 #else |
|
1165 (U *x) |
|
1166 #endif |
|
1167 { |
|
1168 Long L; |
|
1169 U u; |
|
1170 |
|
1171 L = (word0(x) & Exp_mask) - (P-1)*Exp_msk1; |
|
1172 #ifndef Avoid_Underflow |
|
1173 #ifndef Sudden_Underflow |
|
1174 if (L > 0) { |
|
1175 #endif |
|
1176 #endif |
|
1177 #ifdef IBM |
|
1178 L |= Exp_msk1 >> 4; |
|
1179 #endif |
|
1180 word0(&u) = L; |
|
1181 word1(&u) = 0; |
|
1182 #ifndef Avoid_Underflow |
|
1183 #ifndef Sudden_Underflow |
|
1184 } |
|
1185 else { |
|
1186 L = -L >> Exp_shift; |
|
1187 if (L < Exp_shift) { |
|
1188 word0(&u) = 0x80000 >> L; |
|
1189 word1(&u) = 0; |
|
1190 } |
|
1191 else { |
|
1192 word0(&u) = 0; |
|
1193 L -= Exp_shift; |
|
1194 word1(&u) = L >= 31 ? 1 : 1 << 31 - L; |
|
1195 } |
|
1196 } |
|
1197 #endif |
|
1198 #endif |
|
1199 return dval(&u); |
|
1200 } |
|
1201 |
|
1202 static double |
|
1203 b2d |
|
1204 #ifdef KR_headers |
|
1205 (a, e) Bigint *a; int *e; |
|
1206 #else |
|
1207 (Bigint *a, int *e) |
|
1208 #endif |
|
1209 { |
|
1210 ULong *xa, *xa0, w, y, z; |
|
1211 int k; |
|
1212 U d; |
|
1213 #ifdef VAX |
|
1214 ULong d0, d1; |
|
1215 #else |
|
1216 #define d0 word0(&d) |
|
1217 #define d1 word1(&d) |
|
1218 #endif |
|
1219 |
|
1220 xa0 = a->x; |
|
1221 xa = xa0 + a->wds; |
|
1222 y = *--xa; |
|
1223 #ifdef DEBUG |
|
1224 if (!y) Bug("zero y in b2d"); |
|
1225 #endif |
|
1226 k = hi0bits(y); |
|
1227 *e = 32 - k; |
|
1228 #ifdef Pack_32 |
|
1229 if (k < Ebits) { |
|
1230 d0 = Exp_1 | y >> (Ebits - k); |
|
1231 w = xa > xa0 ? *--xa : 0; |
|
1232 d1 = y << ((32-Ebits) + k) | w >> (Ebits - k); |
|
1233 goto ret_d; |
|
1234 } |
|
1235 z = xa > xa0 ? *--xa : 0; |
|
1236 if (k -= Ebits) { |
|
1237 d0 = Exp_1 | y << k | z >> (32 - k); |
|
1238 y = xa > xa0 ? *--xa : 0; |
|
1239 d1 = z << k | y >> (32 - k); |
|
1240 } |
|
1241 else { |
|
1242 d0 = Exp_1 | y; |
|
1243 d1 = z; |
|
1244 } |
|
1245 #else |
|
1246 if (k < Ebits + 16) { |
|
1247 z = xa > xa0 ? *--xa : 0; |
|
1248 d0 = Exp_1 | y << k - Ebits | z >> Ebits + 16 - k; |
|
1249 w = xa > xa0 ? *--xa : 0; |
|
1250 y = xa > xa0 ? *--xa : 0; |
|
1251 d1 = z << k + 16 - Ebits | w << k - Ebits | y >> 16 + Ebits - k; |
|
1252 goto ret_d; |
|
1253 } |
|
1254 z = xa > xa0 ? *--xa : 0; |
|
1255 w = xa > xa0 ? *--xa : 0; |
|
1256 k -= Ebits + 16; |
|
1257 d0 = Exp_1 | y << k + 16 | z << k | w >> 16 - k; |
|
1258 y = xa > xa0 ? *--xa : 0; |
|
1259 d1 = w << k + 16 | y << k; |
|
1260 #endif |
|
1261 ret_d: |
|
1262 #ifdef VAX |
|
1263 word0(&d) = d0 >> 16 | d0 << 16; |
|
1264 word1(&d) = d1 >> 16 | d1 << 16; |
|
1265 #else |
|
1266 #undef d0 |
|
1267 #undef d1 |
|
1268 #endif |
|
1269 return dval(&d); |
|
1270 } |
|
1271 |
|
1272 static Bigint * |
|
1273 d2b |
|
1274 #ifdef KR_headers |
|
1275 (d, e, bits) U *d; int *e, *bits; |
|
1276 #else |
|
1277 (U *d, int *e, int *bits) |
|
1278 #endif |
|
1279 { |
|
1280 Bigint *b; |
|
1281 int de, k; |
|
1282 ULong *x, y, z; |
|
1283 #ifndef Sudden_Underflow |
|
1284 int i; |
|
1285 #endif |
|
1286 #ifdef VAX |
|
1287 ULong d0, d1; |
|
1288 d0 = word0(d) >> 16 | word0(d) << 16; |
|
1289 d1 = word1(d) >> 16 | word1(d) << 16; |
|
1290 #else |
|
1291 #define d0 word0(d) |
|
1292 #define d1 word1(d) |
|
1293 #endif |
|
1294 |
|
1295 #ifdef Pack_32 |
|
1296 b = Balloc(1); |
|
1297 #else |
|
1298 b = Balloc(2); |
|
1299 #endif |
|
1300 x = b->x; |
|
1301 |
|
1302 z = d0 & Frac_mask; |
|
1303 d0 &= 0x7fffffff; /* clear sign bit, which we ignore */ |
|
1304 #ifdef Sudden_Underflow |
|
1305 de = (int)(d0 >> Exp_shift); |
|
1306 #ifndef IBM |
|
1307 z |= Exp_msk11; |
|
1308 #endif |
|
1309 #else |
|
1310 if ((de = (int)(d0 >> Exp_shift))) |
|
1311 z |= Exp_msk1; |
|
1312 #endif |
|
1313 #ifdef Pack_32 |
|
1314 if ((y = d1)) { |
|
1315 if ((k = lo0bits(&y))) { |
|
1316 x[0] = y | z << (32 - k); |
|
1317 z >>= k; |
|
1318 } |
|
1319 else |
|
1320 x[0] = y; |
|
1321 #ifndef Sudden_Underflow |
|
1322 i = |
|
1323 #endif |
|
1324 b->wds = (x[1] = z) ? 2 : 1; |
|
1325 } |
|
1326 else { |
|
1327 k = lo0bits(&z); |
|
1328 x[0] = z; |
|
1329 #ifndef Sudden_Underflow |
|
1330 i = |
|
1331 #endif |
|
1332 b->wds = 1; |
|
1333 k += 32; |
|
1334 } |
|
1335 #else |
|
1336 if (y = d1) { |
|
1337 if (k = lo0bits(&y)) |
|
1338 if (k >= 16) { |
|
1339 x[0] = y | z << 32 - k & 0xffff; |
|
1340 x[1] = z >> k - 16 & 0xffff; |
|
1341 x[2] = z >> k; |
|
1342 i = 2; |
|
1343 } |
|
1344 else { |
|
1345 x[0] = y & 0xffff; |
|
1346 x[1] = y >> 16 | z << 16 - k & 0xffff; |
|
1347 x[2] = z >> k & 0xffff; |
|
1348 x[3] = z >> k+16; |
|
1349 i = 3; |
|
1350 } |
|
1351 else { |
|
1352 x[0] = y & 0xffff; |
|
1353 x[1] = y >> 16; |
|
1354 x[2] = z & 0xffff; |
|
1355 x[3] = z >> 16; |
|
1356 i = 3; |
|
1357 } |
|
1358 } |
|
1359 else { |
|
1360 #ifdef DEBUG |
|
1361 if (!z) |
|
1362 Bug("Zero passed to d2b"); |
|
1363 #endif |
|
1364 k = lo0bits(&z); |
|
1365 if (k >= 16) { |
|
1366 x[0] = z; |
|
1367 i = 0; |
|
1368 } |
|
1369 else { |
|
1370 x[0] = z & 0xffff; |
|
1371 x[1] = z >> 16; |
|
1372 i = 1; |
|
1373 } |
|
1374 k += 32; |
|
1375 } |
|
1376 while(!x[i]) |
|
1377 --i; |
|
1378 b->wds = i + 1; |
|
1379 #endif |
|
1380 #ifndef Sudden_Underflow |
|
1381 if (de) { |
|
1382 #endif |
|
1383 #ifdef IBM |
|
1384 *e = (de - Bias - (P-1) << 2) + k; |
|
1385 *bits = 4*P + 8 - k - hi0bits(word0(d) & Frac_mask); |
|
1386 #else |
|
1387 *e = de - Bias - (P-1) + k; |
|
1388 *bits = P - k; |
|
1389 #endif |
|
1390 #ifndef Sudden_Underflow |
|
1391 } |
|
1392 else { |
|
1393 *e = de - Bias - (P-1) + 1 + k; |
|
1394 #ifdef Pack_32 |
|
1395 *bits = 32*i - hi0bits(x[i-1]); |
|
1396 #else |
|
1397 *bits = (i+2)*16 - hi0bits(x[i]); |
|
1398 #endif |
|
1399 } |
|
1400 #endif |
|
1401 return b; |
|
1402 } |
|
1403 #undef d0 |
|
1404 #undef d1 |
|
1405 |
|
1406 static double |
|
1407 ratio |
|
1408 #ifdef KR_headers |
|
1409 (a, b) Bigint *a, *b; |
|
1410 #else |
|
1411 (Bigint *a, Bigint *b) |
|
1412 #endif |
|
1413 { |
|
1414 U da, db; |
|
1415 int k, ka, kb; |
|
1416 |
|
1417 dval(&da) = b2d(a, &ka); |
|
1418 dval(&db) = b2d(b, &kb); |
|
1419 #ifdef Pack_32 |
|
1420 k = ka - kb + 32*(a->wds - b->wds); |
|
1421 #else |
|
1422 k = ka - kb + 16*(a->wds - b->wds); |
|
1423 #endif |
|
1424 #ifdef IBM |
|
1425 if (k > 0) { |
|
1426 word0(&da) += (k >> 2)*Exp_msk1; |
|
1427 if (k &= 3) |
|
1428 dval(&da) *= 1 << k; |
|
1429 } |
|
1430 else { |
|
1431 k = -k; |
|
1432 word0(&db) += (k >> 2)*Exp_msk1; |
|
1433 if (k &= 3) |
|
1434 dval(&db) *= 1 << k; |
|
1435 } |
|
1436 #else |
|
1437 if (k > 0) |
|
1438 word0(&da) += k*Exp_msk1; |
|
1439 else { |
|
1440 k = -k; |
|
1441 word0(&db) += k*Exp_msk1; |
|
1442 } |
|
1443 #endif |
|
1444 return dval(&da) / dval(&db); |
|
1445 } |
|
1446 |
|
1447 static CONST double |
|
1448 tens[] = { |
|
1449 1e0, 1e1, 1e2, 1e3, 1e4, 1e5, 1e6, 1e7, 1e8, 1e9, |
|
1450 1e10, 1e11, 1e12, 1e13, 1e14, 1e15, 1e16, 1e17, 1e18, 1e19, |
|
1451 1e20, 1e21, 1e22 |
|
1452 #ifdef VAX |
|
1453 , 1e23, 1e24 |
|
1454 #endif |
|
1455 }; |
|
1456 |
|
1457 static CONST double |
|
1458 #ifdef IEEE_Arith |
|
1459 bigtens[] = { 1e16, 1e32, 1e64, 1e128, 1e256 }; |
|
1460 static CONST double tinytens[] = { 1e-16, 1e-32, 1e-64, 1e-128, |
|
1461 #ifdef Avoid_Underflow |
|
1462 9007199254740992.*9007199254740992.e-256 |
|
1463 /* = 2^106 * 1e-256 */ |
|
1464 #else |
|
1465 1e-256 |
|
1466 #endif |
|
1467 }; |
|
1468 /* The factor of 2^53 in tinytens[4] helps us avoid setting the underflow */ |
|
1469 /* flag unnecessarily. It leads to a song and dance at the end of strtod. */ |
|
1470 #define Scale_Bit 0x10 |
|
1471 #define n_bigtens 5 |
|
1472 #else |
|
1473 #ifdef IBM |
|
1474 bigtens[] = { 1e16, 1e32, 1e64 }; |
|
1475 static CONST double tinytens[] = { 1e-16, 1e-32, 1e-64 }; |
|
1476 #define n_bigtens 3 |
|
1477 #else |
|
1478 bigtens[] = { 1e16, 1e32 }; |
|
1479 static CONST double tinytens[] = { 1e-16, 1e-32 }; |
|
1480 #define n_bigtens 2 |
|
1481 #endif |
|
1482 #endif |
|
1483 |
|
1484 #undef Need_Hexdig |
|
1485 #ifdef INFNAN_CHECK |
|
1486 #ifndef No_Hex_NaN |
|
1487 #define Need_Hexdig |
|
1488 #endif |
|
1489 #endif |
|
1490 |
|
1491 #ifndef Need_Hexdig |
|
1492 #ifndef NO_HEX_FP |
|
1493 #define Need_Hexdig |
|
1494 #endif |
|
1495 #endif |
|
1496 |
|
1497 #ifdef Need_Hexdig /*{*/ |
|
1498 static unsigned char hexdig[256]; |
|
1499 |
|
1500 static void |
|
1501 #ifdef KR_headers |
|
1502 htinit(h, s, inc) unsigned char *h; unsigned char *s; int inc; |
|
1503 #else |
|
1504 htinit(unsigned char *h, unsigned char *s, int inc) |
|
1505 #endif |
|
1506 { |
|
1507 int i, j; |
|
1508 for(i = 0; (j = s[i]) !=0; i++) |
|
1509 h[j] = i + inc; |
|
1510 } |
|
1511 |
|
1512 static void |
|
1513 #ifdef KR_headers |
|
1514 hexdig_init() |
|
1515 #else |
|
1516 hexdig_init(void) |
|
1517 #endif |
|
1518 { |
|
1519 #define USC (unsigned char *) |
|
1520 htinit(hexdig, USC "0123456789", 0x10); |
|
1521 htinit(hexdig, USC "abcdef", 0x10 + 10); |
|
1522 htinit(hexdig, USC "ABCDEF", 0x10 + 10); |
|
1523 } |
|
1524 #endif /* } Need_Hexdig */ |
|
1525 |
|
1526 #ifdef INFNAN_CHECK |
|
1527 |
|
1528 #ifndef NAN_WORD0 |
|
1529 #define NAN_WORD0 0x7ff80000 |
|
1530 #endif |
|
1531 |
|
1532 #ifndef NAN_WORD1 |
|
1533 #define NAN_WORD1 0 |
|
1534 #endif |
|
1535 |
|
1536 static int |
|
1537 match |
|
1538 #ifdef KR_headers |
|
1539 (sp, t) char **sp, *t; |
|
1540 #else |
|
1541 (const char **sp, const char *t) |
|
1542 #endif |
|
1543 { |
|
1544 int c, d; |
|
1545 CONST char *s = *sp; |
|
1546 |
|
1547 while((d = *t++)) { |
|
1548 if ((c = *++s) >= 'A' && c <= 'Z') |
|
1549 c += 'a' - 'A'; |
|
1550 if (c != d) |
|
1551 return 0; |
|
1552 } |
|
1553 *sp = s + 1; |
|
1554 return 1; |
|
1555 } |
|
1556 |
|
1557 #ifndef No_Hex_NaN |
|
1558 static void |
|
1559 hexnan |
|
1560 #ifdef KR_headers |
|
1561 (rvp, sp) U *rvp; CONST char **sp; |
|
1562 #else |
|
1563 (U *rvp, const char **sp) |
|
1564 #endif |
|
1565 { |
|
1566 ULong c, x[2]; |
|
1567 CONST char *s; |
|
1568 int c1, havedig, udx0, xshift; |
|
1569 |
|
1570 if (!hexdig['0']) |
|
1571 hexdig_init(); |
|
1572 x[0] = x[1] = 0; |
|
1573 havedig = xshift = 0; |
|
1574 udx0 = 1; |
|
1575 s = *sp; |
|
1576 /* allow optional initial 0x or 0X */ |
|
1577 while((c = *(CONST unsigned char*)(s+1)) && c <= ' ') |
|
1578 ++s; |
|
1579 if (s[1] == '0' && (s[2] == 'x' || s[2] == 'X')) |
|
1580 s += 2; |
|
1581 while((c = *(CONST unsigned char*)++s)) { |
|
1582 if ((c1 = hexdig[c])) |
|
1583 c = c1 & 0xf; |
|
1584 else if (c <= ' ') { |
|
1585 if (udx0 && havedig) { |
|
1586 udx0 = 0; |
|
1587 xshift = 1; |
|
1588 } |
|
1589 continue; |
|
1590 } |
|
1591 #ifdef GDTOA_NON_PEDANTIC_NANCHECK |
|
1592 else if (/*(*/ c == ')' && havedig) { |
|
1593 *sp = s + 1; |
|
1594 break; |
|
1595 } |
|
1596 else |
|
1597 return; /* invalid form: don't change *sp */ |
|
1598 #else |
|
1599 else { |
|
1600 do { |
|
1601 if (/*(*/ c == ')') { |
|
1602 *sp = s + 1; |
|
1603 break; |
|
1604 } |
|
1605 } while((c = *++s)); |
|
1606 break; |
|
1607 } |
|
1608 #endif |
|
1609 havedig = 1; |
|
1610 if (xshift) { |
|
1611 xshift = 0; |
|
1612 x[0] = x[1]; |
|
1613 x[1] = 0; |
|
1614 } |
|
1615 if (udx0) |
|
1616 x[0] = (x[0] << 4) | (x[1] >> 28); |
|
1617 x[1] = (x[1] << 4) | c; |
|
1618 } |
|
1619 if ((x[0] &= 0xfffff) || x[1]) { |
|
1620 word0(rvp) = Exp_mask | x[0]; |
|
1621 word1(rvp) = x[1]; |
|
1622 } |
|
1623 } |
|
1624 #endif /*No_Hex_NaN*/ |
|
1625 #endif /* INFNAN_CHECK */ |
|
1626 |
|
1627 #ifdef Pack_32 |
|
1628 #define ULbits 32 |
|
1629 #define kshift 5 |
|
1630 #define kmask 31 |
|
1631 #else |
|
1632 #define ULbits 16 |
|
1633 #define kshift 4 |
|
1634 #define kmask 15 |
|
1635 #endif |
|
1636 |
|
1637 #if !defined(NO_HEX_FP) || defined(Honor_FLT_ROUNDS) /*{*/ |
|
1638 static Bigint * |
|
1639 #ifdef KR_headers |
|
1640 increment(b) Bigint *b; |
|
1641 #else |
|
1642 increment(Bigint *b) |
|
1643 #endif |
|
1644 { |
|
1645 ULong *x, *xe; |
|
1646 Bigint *b1; |
|
1647 |
|
1648 x = b->x; |
|
1649 xe = x + b->wds; |
|
1650 do { |
|
1651 if (*x < (ULong)0xffffffffL) { |
|
1652 ++*x; |
|
1653 return b; |
|
1654 } |
|
1655 *x++ = 0; |
|
1656 } while(x < xe); |
|
1657 { |
|
1658 if (b->wds >= b->maxwds) { |
|
1659 b1 = Balloc(b->k+1); |
|
1660 Bcopy(b1,b); |
|
1661 Bfree(b); |
|
1662 b = b1; |
|
1663 } |
|
1664 b->x[b->wds++] = 1; |
|
1665 } |
|
1666 return b; |
|
1667 } |
|
1668 |
|
1669 #endif /*}*/ |
|
1670 |
|
1671 #ifndef NO_HEX_FP /*{*/ |
|
1672 |
|
1673 static void |
|
1674 #ifdef KR_headers |
|
1675 rshift(b, k) Bigint *b; int k; |
|
1676 #else |
|
1677 rshift(Bigint *b, int k) |
|
1678 #endif |
|
1679 { |
|
1680 ULong *x, *x1, *xe, y; |
|
1681 int n; |
|
1682 |
|
1683 x = x1 = b->x; |
|
1684 n = k >> kshift; |
|
1685 if (n < b->wds) { |
|
1686 xe = x + b->wds; |
|
1687 x += n; |
|
1688 if (k &= kmask) { |
|
1689 n = 32 - k; |
|
1690 y = *x++ >> k; |
|
1691 while(x < xe) { |
|
1692 *x1++ = (y | (*x << n)) & 0xffffffff; |
|
1693 y = *x++ >> k; |
|
1694 } |
|
1695 if ((*x1 = y) !=0) |
|
1696 x1++; |
|
1697 } |
|
1698 else |
|
1699 while(x < xe) |
|
1700 *x1++ = *x++; |
|
1701 } |
|
1702 if ((b->wds = x1 - b->x) == 0) |
|
1703 b->x[0] = 0; |
|
1704 } |
|
1705 |
|
1706 static ULong |
|
1707 #ifdef KR_headers |
|
1708 any_on(b, k) Bigint *b; int k; |
|
1709 #else |
|
1710 any_on(Bigint *b, int k) |
|
1711 #endif |
|
1712 { |
|
1713 int n, nwds; |
|
1714 ULong *x, *x0, x1, x2; |
|
1715 |
|
1716 x = b->x; |
|
1717 nwds = b->wds; |
|
1718 n = k >> kshift; |
|
1719 if (n > nwds) |
|
1720 n = nwds; |
|
1721 else if (n < nwds && (k &= kmask)) { |
|
1722 x1 = x2 = x[n]; |
|
1723 x1 >>= k; |
|
1724 x1 <<= k; |
|
1725 if (x1 != x2) |
|
1726 return 1; |
|
1727 } |
|
1728 x0 = x; |
|
1729 x += n; |
|
1730 while(x > x0) |
|
1731 if (*--x) |
|
1732 return 1; |
|
1733 return 0; |
|
1734 } |
|
1735 |
|
1736 enum { /* rounding values: same as FLT_ROUNDS */ |
|
1737 Round_zero = 0, |
|
1738 Round_near = 1, |
|
1739 Round_up = 2, |
|
1740 Round_down = 3 |
|
1741 }; |
|
1742 |
|
1743 void |
|
1744 #ifdef KR_headers |
|
1745 gethex(sp, rvp, rounding, sign) |
|
1746 CONST char **sp; U *rvp; int rounding, sign; |
|
1747 #else |
|
1748 gethex( CONST char **sp, U *rvp, int rounding, int sign) |
|
1749 #endif |
|
1750 { |
|
1751 Bigint *b; |
|
1752 CONST unsigned char *decpt, *s0, *s, *s1; |
|
1753 Long e, e1; |
|
1754 ULong L, lostbits, *x; |
|
1755 int big, denorm, esign, havedig, k, n, nbits, up, zret; |
|
1756 #ifdef IBM |
|
1757 int j; |
|
1758 #endif |
|
1759 enum { |
|
1760 #ifdef IEEE_Arith /*{{*/ |
|
1761 emax = 0x7fe - Bias - P + 1, |
|
1762 emin = Emin - P + 1 |
|
1763 #else /*}{*/ |
|
1764 emin = Emin - P, |
|
1765 #ifdef VAX |
|
1766 emax = 0x7ff - Bias - P + 1 |
|
1767 #endif |
|
1768 #ifdef IBM |
|
1769 emax = 0x7f - Bias - P |
|
1770 #endif |
|
1771 #endif /*}}*/ |
|
1772 }; |
|
1773 #ifdef USE_LOCALE |
|
1774 int i; |
|
1775 #ifdef NO_LOCALE_CACHE |
|
1776 const unsigned char *decimalpoint = (unsigned char*) |
|
1777 localeconv()->decimal_point; |
|
1778 #else |
|
1779 const unsigned char *decimalpoint; |
|
1780 static unsigned char *decimalpoint_cache; |
|
1781 if (!(s0 = decimalpoint_cache)) { |
|
1782 s0 = (unsigned char*)localeconv()->decimal_point; |
|
1783 if ((decimalpoint_cache = (unsigned char*) |
|
1784 MALLOC(strlen((CONST char*)s0) + 1))) { |
|
1785 strcpy((char*)decimalpoint_cache, (CONST char*)s0); |
|
1786 s0 = decimalpoint_cache; |
|
1787 } |
|
1788 } |
|
1789 decimalpoint = s0; |
|
1790 #endif |
|
1791 #endif |
|
1792 |
|
1793 if (!hexdig['0']) |
|
1794 hexdig_init(); |
|
1795 havedig = 0; |
|
1796 s0 = *(CONST unsigned char **)sp + 2; |
|
1797 while(s0[havedig] == '0') |
|
1798 havedig++; |
|
1799 s0 += havedig; |
|
1800 s = s0; |
|
1801 decpt = 0; |
|
1802 zret = 0; |
|
1803 e = 0; |
|
1804 if (hexdig[*s]) |
|
1805 havedig++; |
|
1806 else { |
|
1807 zret = 1; |
|
1808 #ifdef USE_LOCALE |
|
1809 for(i = 0; decimalpoint[i]; ++i) { |
|
1810 if (s[i] != decimalpoint[i]) |
|
1811 goto pcheck; |
|
1812 } |
|
1813 decpt = s += i; |
|
1814 #else |
|
1815 if (*s != '.') |
|
1816 goto pcheck; |
|
1817 decpt = ++s; |
|
1818 #endif |
|
1819 if (!hexdig[*s]) |
|
1820 goto pcheck; |
|
1821 while(*s == '0') |
|
1822 s++; |
|
1823 if (hexdig[*s]) |
|
1824 zret = 0; |
|
1825 havedig = 1; |
|
1826 s0 = s; |
|
1827 } |
|
1828 while(hexdig[*s]) |
|
1829 s++; |
|
1830 #ifdef USE_LOCALE |
|
1831 if (*s == *decimalpoint && !decpt) { |
|
1832 for(i = 1; decimalpoint[i]; ++i) { |
|
1833 if (s[i] != decimalpoint[i]) |
|
1834 goto pcheck; |
|
1835 } |
|
1836 decpt = s += i; |
|
1837 #else |
|
1838 if (*s == '.' && !decpt) { |
|
1839 decpt = ++s; |
|
1840 #endif |
|
1841 while(hexdig[*s]) |
|
1842 s++; |
|
1843 }/*}*/ |
|
1844 if (decpt) |
|
1845 e = -(((Long)(s-decpt)) << 2); |
|
1846 pcheck: |
|
1847 s1 = s; |
|
1848 big = esign = 0; |
|
1849 switch(*s) { |
|
1850 case 'p': |
|
1851 case 'P': |
|
1852 switch(*++s) { |
|
1853 case '-': |
|
1854 esign = 1; |
|
1855 /* no break */ |
|
1856 case '+': |
|
1857 s++; |
|
1858 } |
|
1859 if ((n = hexdig[*s]) == 0 || n > 0x19) { |
|
1860 s = s1; |
|
1861 break; |
|
1862 } |
|
1863 e1 = n - 0x10; |
|
1864 while((n = hexdig[*++s]) !=0 && n <= 0x19) { |
|
1865 if (e1 & 0xf8000000) |
|
1866 big = 1; |
|
1867 e1 = 10*e1 + n - 0x10; |
|
1868 } |
|
1869 if (esign) |
|
1870 e1 = -e1; |
|
1871 e += e1; |
|
1872 } |
|
1873 *sp = (char*)s; |
|
1874 if (!havedig) |
|
1875 *sp = (char*)s0 - 1; |
|
1876 if (zret) |
|
1877 goto retz1; |
|
1878 if (big) { |
|
1879 if (esign) { |
|
1880 #ifdef IEEE_Arith |
|
1881 switch(rounding) { |
|
1882 case Round_up: |
|
1883 if (sign) |
|
1884 break; |
|
1885 goto ret_tiny; |
|
1886 case Round_down: |
|
1887 if (!sign) |
|
1888 break; |
|
1889 goto ret_tiny; |
|
1890 } |
|
1891 #endif |
|
1892 goto retz; |
|
1893 #ifdef IEEE_Arith |
|
1894 ret_tiny: |
|
1895 #ifndef NO_ERRNO |
|
1896 errno = ERANGE; |
|
1897 #endif |
|
1898 word0(rvp) = 0; |
|
1899 word1(rvp) = 1; |
|
1900 return; |
|
1901 #endif /* IEEE_Arith */ |
|
1902 } |
|
1903 switch(rounding) { |
|
1904 case Round_near: |
|
1905 goto ovfl1; |
|
1906 case Round_up: |
|
1907 if (!sign) |
|
1908 goto ovfl1; |
|
1909 goto ret_big; |
|
1910 case Round_down: |
|
1911 if (sign) |
|
1912 goto ovfl1; |
|
1913 goto ret_big; |
|
1914 } |
|
1915 ret_big: |
|
1916 word0(rvp) = Big0; |
|
1917 word1(rvp) = Big1; |
|
1918 return; |
|
1919 } |
|
1920 n = s1 - s0 - 1; |
|
1921 for(k = 0; n > (1 << (kshift-2)) - 1; n >>= 1) |
|
1922 k++; |
|
1923 b = Balloc(k); |
|
1924 x = b->x; |
|
1925 n = 0; |
|
1926 L = 0; |
|
1927 #ifdef USE_LOCALE |
|
1928 for(i = 0; decimalpoint[i+1]; ++i); |
|
1929 #endif |
|
1930 while(s1 > s0) { |
|
1931 #ifdef USE_LOCALE |
|
1932 if (*--s1 == decimalpoint[i]) { |
|
1933 s1 -= i; |
|
1934 continue; |
|
1935 } |
|
1936 #else |
|
1937 if (*--s1 == '.') |
|
1938 continue; |
|
1939 #endif |
|
1940 if (n == ULbits) { |
|
1941 *x++ = L; |
|
1942 L = 0; |
|
1943 n = 0; |
|
1944 } |
|
1945 L |= (hexdig[*s1] & 0x0f) << n; |
|
1946 n += 4; |
|
1947 } |
|
1948 *x++ = L; |
|
1949 b->wds = n = x - b->x; |
|
1950 n = ULbits*n - hi0bits(L); |
|
1951 nbits = Nbits; |
|
1952 lostbits = 0; |
|
1953 x = b->x; |
|
1954 if (n > nbits) { |
|
1955 n -= nbits; |
|
1956 if (any_on(b,n)) { |
|
1957 lostbits = 1; |
|
1958 k = n - 1; |
|
1959 if (x[k>>kshift] & 1 << (k & kmask)) { |
|
1960 lostbits = 2; |
|
1961 if (k > 0 && any_on(b,k)) |
|
1962 lostbits = 3; |
|
1963 } |
|
1964 } |
|
1965 rshift(b, n); |
|
1966 e += n; |
|
1967 } |
|
1968 else if (n < nbits) { |
|
1969 n = nbits - n; |
|
1970 b = lshift(b, n); |
|
1971 e -= n; |
|
1972 x = b->x; |
|
1973 } |
|
1974 if (e > Emax) { |
|
1975 ovfl: |
|
1976 Bfree(b); |
|
1977 ovfl1: |
|
1978 #ifndef NO_ERRNO |
|
1979 errno = ERANGE; |
|
1980 #endif |
|
1981 word0(rvp) = Exp_mask; |
|
1982 word1(rvp) = 0; |
|
1983 return; |
|
1984 } |
|
1985 denorm = 0; |
|
1986 if (e < emin) { |
|
1987 denorm = 1; |
|
1988 n = emin - e; |
|
1989 if (n >= nbits) { |
|
1990 #ifdef IEEE_Arith /*{*/ |
|
1991 switch (rounding) { |
|
1992 case Round_near: |
|
1993 if (n == nbits && (n < 2 || any_on(b,n-1))) |
|
1994 goto ret_tiny; |
|
1995 break; |
|
1996 case Round_up: |
|
1997 if (!sign) |
|
1998 goto ret_tiny; |
|
1999 break; |
|
2000 case Round_down: |
|
2001 if (sign) |
|
2002 goto ret_tiny; |
|
2003 } |
|
2004 #endif /* } IEEE_Arith */ |
|
2005 Bfree(b); |
|
2006 retz: |
|
2007 #ifndef NO_ERRNO |
|
2008 errno = ERANGE; |
|
2009 #endif |
|
2010 retz1: |
|
2011 rvp->d = 0.; |
|
2012 return; |
|
2013 } |
|
2014 k = n - 1; |
|
2015 if (lostbits) |
|
2016 lostbits = 1; |
|
2017 else if (k > 0) |
|
2018 lostbits = any_on(b,k); |
|
2019 if (x[k>>kshift] & 1 << (k & kmask)) |
|
2020 lostbits |= 2; |
|
2021 nbits -= n; |
|
2022 rshift(b,n); |
|
2023 e = emin; |
|
2024 } |
|
2025 if (lostbits) { |
|
2026 up = 0; |
|
2027 switch(rounding) { |
|
2028 case Round_zero: |
|
2029 break; |
|
2030 case Round_near: |
|
2031 if (lostbits & 2 |
|
2032 && (lostbits & 1) | (x[0] & 1)) |
|
2033 up = 1; |
|
2034 break; |
|
2035 case Round_up: |
|
2036 up = 1 - sign; |
|
2037 break; |
|
2038 case Round_down: |
|
2039 up = sign; |
|
2040 } |
|
2041 if (up) { |
|
2042 k = b->wds; |
|
2043 b = increment(b); |
|
2044 x = b->x; |
|
2045 if (denorm) { |
|
2046 #if 0 |
|
2047 if (nbits == Nbits - 1 |
|
2048 && x[nbits >> kshift] & 1 << (nbits & kmask)) |
|
2049 denorm = 0; /* not currently used */ |
|
2050 #endif |
|
2051 } |
|
2052 else if (b->wds > k |
|
2053 || ((n = nbits & kmask) !=0 |
|
2054 && hi0bits(x[k-1]) < 32-n)) { |
|
2055 rshift(b,1); |
|
2056 if (++e > Emax) |
|
2057 goto ovfl; |
|
2058 } |
|
2059 } |
|
2060 } |
|
2061 #ifdef IEEE_Arith |
|
2062 if (denorm) |
|
2063 word0(rvp) = b->wds > 1 ? b->x[1] & ~0x100000 : 0; |
|
2064 else |
|
2065 word0(rvp) = (b->x[1] & ~0x100000) | ((e + 0x3ff + 52) << 20); |
|
2066 word1(rvp) = b->x[0]; |
|
2067 #endif |
|
2068 #ifdef IBM |
|
2069 if ((j = e & 3)) { |
|
2070 k = b->x[0] & ((1 << j) - 1); |
|
2071 rshift(b,j); |
|
2072 if (k) { |
|
2073 switch(rounding) { |
|
2074 case Round_up: |
|
2075 if (!sign) |
|
2076 increment(b); |
|
2077 break; |
|
2078 case Round_down: |
|
2079 if (sign) |
|
2080 increment(b); |
|
2081 break; |
|
2082 case Round_near: |
|
2083 j = 1 << (j-1); |
|
2084 if (k & j && ((k & (j-1)) | lostbits)) |
|
2085 increment(b); |
|
2086 } |
|
2087 } |
|
2088 } |
|
2089 e >>= 2; |
|
2090 word0(rvp) = b->x[1] | ((e + 65 + 13) << 24); |
|
2091 word1(rvp) = b->x[0]; |
|
2092 #endif |
|
2093 #ifdef VAX |
|
2094 /* The next two lines ignore swap of low- and high-order 2 bytes. */ |
|
2095 /* word0(rvp) = (b->x[1] & ~0x800000) | ((e + 129 + 55) << 23); */ |
|
2096 /* word1(rvp) = b->x[0]; */ |
|
2097 word0(rvp) = ((b->x[1] & ~0x800000) >> 16) | ((e + 129 + 55) << 7) | (b->x[1] << 16); |
|
2098 word1(rvp) = (b->x[0] >> 16) | (b->x[0] << 16); |
|
2099 #endif |
|
2100 Bfree(b); |
|
2101 } |
|
2102 #endif /*!NO_HEX_FP}*/ |
|
2103 |
|
2104 static int |
|
2105 #ifdef KR_headers |
|
2106 dshift(b, p2) Bigint *b; int p2; |
|
2107 #else |
|
2108 dshift(Bigint *b, int p2) |
|
2109 #endif |
|
2110 { |
|
2111 int rv = hi0bits(b->x[b->wds-1]) - 4; |
|
2112 if (p2 > 0) |
|
2113 rv -= p2; |
|
2114 return rv & kmask; |
|
2115 } |
|
2116 |
|
2117 static int |
|
2118 quorem |
|
2119 #ifdef KR_headers |
|
2120 (b, S) Bigint *b, *S; |
|
2121 #else |
|
2122 (Bigint *b, Bigint *S) |
|
2123 #endif |
|
2124 { |
|
2125 int n; |
|
2126 ULong *bx, *bxe, q, *sx, *sxe; |
|
2127 #ifdef ULLong |
|
2128 ULLong borrow, carry, y, ys; |
|
2129 #else |
|
2130 ULong borrow, carry, y, ys; |
|
2131 #ifdef Pack_32 |
|
2132 ULong si, z, zs; |
|
2133 #endif |
|
2134 #endif |
|
2135 |
|
2136 n = S->wds; |
|
2137 #ifdef DEBUG |
|
2138 /*debug*/ if (b->wds > n) |
|
2139 /*debug*/ Bug("oversize b in quorem"); |
|
2140 #endif |
|
2141 if (b->wds < n) |
|
2142 return 0; |
|
2143 sx = S->x; |
|
2144 sxe = sx + --n; |
|
2145 bx = b->x; |
|
2146 bxe = bx + n; |
|
2147 q = *bxe / (*sxe + 1); /* ensure q <= true quotient */ |
|
2148 #ifdef DEBUG |
|
2149 #ifdef NO_STRTOD_BIGCOMP |
|
2150 /*debug*/ if (q > 9) |
|
2151 #else |
|
2152 /* An oversized q is possible when quorem is called from bigcomp and */ |
|
2153 /* the input is near, e.g., twice the smallest denormalized number. */ |
|
2154 /*debug*/ if (q > 15) |
|
2155 #endif |
|
2156 /*debug*/ Bug("oversized quotient in quorem"); |
|
2157 #endif |
|
2158 if (q) { |
|
2159 borrow = 0; |
|
2160 carry = 0; |
|
2161 do { |
|
2162 #ifdef ULLong |
|
2163 ys = *sx++ * (ULLong)q + carry; |
|
2164 carry = ys >> 32; |
|
2165 y = *bx - (ys & FFFFFFFF) - borrow; |
|
2166 borrow = y >> 32 & (ULong)1; |
|
2167 *bx++ = y & FFFFFFFF; |
|
2168 #else |
|
2169 #ifdef Pack_32 |
|
2170 si = *sx++; |
|
2171 ys = (si & 0xffff) * q + carry; |
|
2172 zs = (si >> 16) * q + (ys >> 16); |
|
2173 carry = zs >> 16; |
|
2174 y = (*bx & 0xffff) - (ys & 0xffff) - borrow; |
|
2175 borrow = (y & 0x10000) >> 16; |
|
2176 z = (*bx >> 16) - (zs & 0xffff) - borrow; |
|
2177 borrow = (z & 0x10000) >> 16; |
|
2178 Storeinc(bx, z, y); |
|
2179 #else |
|
2180 ys = *sx++ * q + carry; |
|
2181 carry = ys >> 16; |
|
2182 y = *bx - (ys & 0xffff) - borrow; |
|
2183 borrow = (y & 0x10000) >> 16; |
|
2184 *bx++ = y & 0xffff; |
|
2185 #endif |
|
2186 #endif |
|
2187 } |
|
2188 while(sx <= sxe); |
|
2189 if (!*bxe) { |
|
2190 bx = b->x; |
|
2191 while(--bxe > bx && !*bxe) |
|
2192 --n; |
|
2193 b->wds = n; |
|
2194 } |
|
2195 } |
|
2196 if (cmp(b, S) >= 0) { |
|
2197 q++; |
|
2198 borrow = 0; |
|
2199 carry = 0; |
|
2200 bx = b->x; |
|
2201 sx = S->x; |
|
2202 do { |
|
2203 #ifdef ULLong |
|
2204 ys = *sx++ + carry; |
|
2205 carry = ys >> 32; |
|
2206 y = *bx - (ys & FFFFFFFF) - borrow; |
|
2207 borrow = y >> 32 & (ULong)1; |
|
2208 *bx++ = y & FFFFFFFF; |
|
2209 #else |
|
2210 #ifdef Pack_32 |
|
2211 si = *sx++; |
|
2212 ys = (si & 0xffff) + carry; |
|
2213 zs = (si >> 16) + (ys >> 16); |
|
2214 carry = zs >> 16; |
|
2215 y = (*bx & 0xffff) - (ys & 0xffff) - borrow; |
|
2216 borrow = (y & 0x10000) >> 16; |
|
2217 z = (*bx >> 16) - (zs & 0xffff) - borrow; |
|
2218 borrow = (z & 0x10000) >> 16; |
|
2219 Storeinc(bx, z, y); |
|
2220 #else |
|
2221 ys = *sx++ + carry; |
|
2222 carry = ys >> 16; |
|
2223 y = *bx - (ys & 0xffff) - borrow; |
|
2224 borrow = (y & 0x10000) >> 16; |
|
2225 *bx++ = y & 0xffff; |
|
2226 #endif |
|
2227 #endif |
|
2228 } |
|
2229 while(sx <= sxe); |
|
2230 bx = b->x; |
|
2231 bxe = bx + n; |
|
2232 if (!*bxe) { |
|
2233 while(--bxe > bx && !*bxe) |
|
2234 --n; |
|
2235 b->wds = n; |
|
2236 } |
|
2237 } |
|
2238 return q; |
|
2239 } |
|
2240 |
|
2241 #if defined(Avoid_Underflow) || !defined(NO_STRTOD_BIGCOMP) /*{*/ |
|
2242 static double |
|
2243 sulp |
|
2244 #ifdef KR_headers |
|
2245 (x, bc) U *x; BCinfo *bc; |
|
2246 #else |
|
2247 (U *x, BCinfo *bc) |
|
2248 #endif |
|
2249 { |
|
2250 U u; |
|
2251 double rv; |
|
2252 int i; |
|
2253 |
|
2254 rv = ulp(x); |
|
2255 if (!bc->scale || (i = 2*P + 1 - ((word0(x) & Exp_mask) >> Exp_shift)) <= 0) |
|
2256 return rv; /* Is there an example where i <= 0 ? */ |
|
2257 word0(&u) = Exp_1 + (i << Exp_shift); |
|
2258 word1(&u) = 0; |
|
2259 return rv * u.d; |
|
2260 } |
|
2261 #endif /*}*/ |
|
2262 |
|
2263 #ifndef NO_STRTOD_BIGCOMP |
|
2264 static void |
|
2265 bigcomp |
|
2266 #ifdef KR_headers |
|
2267 (rv, s0, bc) |
|
2268 U *rv; CONST char *s0; BCinfo *bc; |
|
2269 #else |
|
2270 (U *rv, const char *s0, BCinfo *bc) |
|
2271 #endif |
|
2272 { |
|
2273 Bigint *b, *d; |
|
2274 int b2, bbits, d2, dd, dig, dsign, i, j, nd, nd0, p2, p5, speccase; |
|
2275 |
|
2276 dsign = bc->dsign; |
|
2277 nd = bc->nd; |
|
2278 nd0 = bc->nd0; |
|
2279 p5 = nd + bc->e0 - 1; |
|
2280 speccase = 0; |
|
2281 #ifndef Sudden_Underflow |
|
2282 if (rv->d == 0.) { /* special case: value near underflow-to-zero */ |
|
2283 /* threshold was rounded to zero */ |
|
2284 b = i2b(1); |
|
2285 p2 = Emin - P + 1; |
|
2286 bbits = 1; |
|
2287 #ifdef Avoid_Underflow |
|
2288 word0(rv) = (P+2) << Exp_shift; |
|
2289 #else |
|
2290 word1(rv) = 1; |
|
2291 #endif |
|
2292 i = 0; |
|
2293 #ifdef Honor_FLT_ROUNDS |
|
2294 if (bc->rounding == 1) |
|
2295 #endif |
|
2296 { |
|
2297 speccase = 1; |
|
2298 --p2; |
|
2299 dsign = 0; |
|
2300 goto have_i; |
|
2301 } |
|
2302 } |
|
2303 else |
|
2304 #endif |
|
2305 b = d2b(rv, &p2, &bbits); |
|
2306 #ifdef Avoid_Underflow |
|
2307 p2 -= bc->scale; |
|
2308 #endif |
|
2309 /* floor(log2(rv)) == bbits - 1 + p2 */ |
|
2310 /* Check for denormal case. */ |
|
2311 i = P - bbits; |
|
2312 if (i > (j = P - Emin - 1 + p2)) { |
|
2313 #ifdef Sudden_Underflow |
|
2314 Bfree(b); |
|
2315 b = i2b(1); |
|
2316 p2 = Emin; |
|
2317 i = P - 1; |
|
2318 #ifdef Avoid_Underflow |
|
2319 word0(rv) = (1 + bc->scale) << Exp_shift; |
|
2320 #else |
|
2321 word0(rv) = Exp_msk1; |
|
2322 #endif |
|
2323 word1(rv) = 0; |
|
2324 #else |
|
2325 i = j; |
|
2326 #endif |
|
2327 } |
|
2328 #ifdef Honor_FLT_ROUNDS |
|
2329 if (bc->rounding != 1) { |
|
2330 if (i > 0) |
|
2331 b = lshift(b, i); |
|
2332 if (dsign) |
|
2333 b = increment(b); |
|
2334 } |
|
2335 else |
|
2336 #endif |
|
2337 { |
|
2338 b = lshift(b, ++i); |
|
2339 b->x[0] |= 1; |
|
2340 } |
|
2341 #ifndef Sudden_Underflow |
|
2342 have_i: |
|
2343 #endif |
|
2344 p2 -= p5 + i; |
|
2345 d = i2b(1); |
|
2346 /* Arrange for convenient computation of quotients: |
|
2347 * shift left if necessary so divisor has 4 leading 0 bits. |
|
2348 */ |
|
2349 if (p5 > 0) |
|
2350 d = pow5mult(d, p5); |
|
2351 else if (p5 < 0) |
|
2352 b = pow5mult(b, -p5); |
|
2353 if (p2 > 0) { |
|
2354 b2 = p2; |
|
2355 d2 = 0; |
|
2356 } |
|
2357 else { |
|
2358 b2 = 0; |
|
2359 d2 = -p2; |
|
2360 } |
|
2361 i = dshift(d, d2); |
|
2362 if ((b2 += i) > 0) |
|
2363 b = lshift(b, b2); |
|
2364 if ((d2 += i) > 0) |
|
2365 d = lshift(d, d2); |
|
2366 |
|
2367 /* Now b/d = exactly half-way between the two floating-point values */ |
|
2368 /* on either side of the input string. Compute first digit of b/d. */ |
|
2369 |
|
2370 if (!(dig = quorem(b,d))) { |
|
2371 b = multadd(b, 10, 0); /* very unlikely */ |
|
2372 dig = quorem(b,d); |
|
2373 } |
|
2374 |
|
2375 /* Compare b/d with s0 */ |
|
2376 |
|
2377 for(i = 0; i < nd0; ) { |
|
2378 if ((dd = s0[i++] - '0' - dig)) |
|
2379 goto ret; |
|
2380 if (!b->x[0] && b->wds == 1) { |
|
2381 if (i < nd) |
|
2382 dd = 1; |
|
2383 goto ret; |
|
2384 } |
|
2385 b = multadd(b, 10, 0); |
|
2386 dig = quorem(b,d); |
|
2387 } |
|
2388 for(j = bc->dp1; i++ < nd;) { |
|
2389 if ((dd = s0[j++] - '0' - dig)) |
|
2390 goto ret; |
|
2391 if (!b->x[0] && b->wds == 1) { |
|
2392 if (i < nd) |
|
2393 dd = 1; |
|
2394 goto ret; |
|
2395 } |
|
2396 b = multadd(b, 10, 0); |
|
2397 dig = quorem(b,d); |
|
2398 } |
|
2399 if (b->x[0] || b->wds > 1 || dig > 0) |
|
2400 dd = -1; |
|
2401 ret: |
|
2402 Bfree(b); |
|
2403 Bfree(d); |
|
2404 #ifdef Honor_FLT_ROUNDS |
|
2405 if (bc->rounding != 1) { |
|
2406 if (dd < 0) { |
|
2407 if (bc->rounding == 0) { |
|
2408 if (!dsign) |
|
2409 goto retlow1; |
|
2410 } |
|
2411 else if (dsign) |
|
2412 goto rethi1; |
|
2413 } |
|
2414 else if (dd > 0) { |
|
2415 if (bc->rounding == 0) { |
|
2416 if (dsign) |
|
2417 goto rethi1; |
|
2418 goto ret1; |
|
2419 } |
|
2420 if (!dsign) |
|
2421 goto rethi1; |
|
2422 dval(rv) += 2.*sulp(rv,bc); |
|
2423 } |
|
2424 else { |
|
2425 bc->inexact = 0; |
|
2426 if (dsign) |
|
2427 goto rethi1; |
|
2428 } |
|
2429 } |
|
2430 else |
|
2431 #endif |
|
2432 if (speccase) { |
|
2433 if (dd <= 0) |
|
2434 rv->d = 0.; |
|
2435 } |
|
2436 else if (dd < 0) { |
|
2437 if (!dsign) /* does not happen for round-near */ |
|
2438 retlow1: |
|
2439 dval(rv) -= sulp(rv,bc); |
|
2440 } |
|
2441 else if (dd > 0) { |
|
2442 if (dsign) { |
|
2443 rethi1: |
|
2444 dval(rv) += sulp(rv,bc); |
|
2445 } |
|
2446 } |
|
2447 else { |
|
2448 /* Exact half-way case: apply round-even rule. */ |
|
2449 if ((j = ((word0(rv) & Exp_mask) >> Exp_shift) - bc->scale) <= 0) { |
|
2450 i = 1 - j; |
|
2451 if (i <= 31) { |
|
2452 if (word1(rv) & (0x1 << i)) |
|
2453 goto odd; |
|
2454 } |
|
2455 else if (word0(rv) & (0x1 << (i-32))) |
|
2456 goto odd; |
|
2457 } |
|
2458 else if (word1(rv) & 1) { |
|
2459 odd: |
|
2460 if (dsign) |
|
2461 goto rethi1; |
|
2462 goto retlow1; |
|
2463 } |
|
2464 } |
|
2465 |
|
2466 #ifdef Honor_FLT_ROUNDS |
|
2467 ret1: |
|
2468 #endif |
|
2469 return; |
|
2470 } |
|
2471 #endif /* NO_STRTOD_BIGCOMP */ |
|
2472 |
|
2473 double |
|
2474 strtod |
|
2475 #ifdef KR_headers |
|
2476 (s00, se) CONST char *s00; char **se; |
|
2477 #else |
|
2478 (const char *s00, char **se) |
|
2479 #endif |
|
2480 { |
|
2481 int bb2, bb5, bbe, bd2, bd5, bbbits, bs2, c, e, e1; |
|
2482 int esign, i, j, k, nd, nd0, nf, nz, nz0, nz1, sign; |
|
2483 CONST char *s, *s0, *s1; |
|
2484 double aadj, aadj1; |
|
2485 Long L; |
|
2486 U aadj2, adj, rv, rv0; |
|
2487 ULong y, z; |
|
2488 BCinfo bc; |
|
2489 Bigint *bb, *bb1, *bd, *bd0, *bs, *delta; |
|
2490 #ifdef Avoid_Underflow |
|
2491 ULong Lsb, Lsb1; |
|
2492 #endif |
|
2493 #ifdef SET_INEXACT |
|
2494 int oldinexact; |
|
2495 #endif |
|
2496 #ifndef NO_STRTOD_BIGCOMP |
|
2497 int req_bigcomp = 0; |
|
2498 #endif |
|
2499 #ifdef Honor_FLT_ROUNDS /*{*/ |
|
2500 #ifdef Trust_FLT_ROUNDS /*{{ only define this if FLT_ROUNDS really works! */ |
|
2501 bc.rounding = Flt_Rounds; |
|
2502 #else /*}{*/ |
|
2503 bc.rounding = 1; |
|
2504 switch(fegetround()) { |
|
2505 case FE_TOWARDZERO: bc.rounding = 0; break; |
|
2506 case FE_UPWARD: bc.rounding = 2; break; |
|
2507 case FE_DOWNWARD: bc.rounding = 3; |
|
2508 } |
|
2509 #endif /*}}*/ |
|
2510 #endif /*}*/ |
|
2511 #ifdef USE_LOCALE |
|
2512 CONST char *s2; |
|
2513 #endif |
|
2514 |
|
2515 sign = nz0 = nz1 = nz = bc.dplen = bc.uflchk = 0; |
|
2516 dval(&rv) = 0.; |
|
2517 for(s = s00;;s++) switch(*s) { |
|
2518 case '-': |
|
2519 sign = 1; |
|
2520 /* no break */ |
|
2521 case '+': |
|
2522 if (*++s) |
|
2523 goto break2; |
|
2524 /* no break */ |
|
2525 case 0: |
|
2526 goto ret0; |
|
2527 case '\t': |
|
2528 case '\n': |
|
2529 case '\v': |
|
2530 case '\f': |
|
2531 case '\r': |
|
2532 case ' ': |
|
2533 continue; |
|
2534 default: |
|
2535 goto break2; |
|
2536 } |
|
2537 break2: |
|
2538 if (*s == '0') { |
|
2539 #ifndef NO_HEX_FP /*{*/ |
|
2540 switch(s[1]) { |
|
2541 case 'x': |
|
2542 case 'X': |
|
2543 #ifdef Honor_FLT_ROUNDS |
|
2544 gethex(&s, &rv, bc.rounding, sign); |
|
2545 #else |
|
2546 gethex(&s, &rv, 1, sign); |
|
2547 #endif |
|
2548 goto ret; |
|
2549 } |
|
2550 #endif /*}*/ |
|
2551 nz0 = 1; |
|
2552 while(*++s == '0') ; |
|
2553 if (!*s) |
|
2554 goto ret; |
|
2555 } |
|
2556 s0 = s; |
|
2557 y = z = 0; |
|
2558 for(nd = nf = 0; (c = *s) >= '0' && c <= '9'; nd++, s++) |
|
2559 if (nd < 9) |
|
2560 y = 10*y + c - '0'; |
|
2561 else if (nd < 16) |
|
2562 z = 10*z + c - '0'; |
|
2563 nd0 = nd; |
|
2564 bc.dp0 = bc.dp1 = s - s0; |
|
2565 for(s1 = s; s1 > s0 && *--s1 == '0'; ) |
|
2566 ++nz1; |
|
2567 #ifdef USE_LOCALE |
|
2568 s1 = localeconv()->decimal_point; |
|
2569 if (c == *s1) { |
|
2570 c = '.'; |
|
2571 if (*++s1) { |
|
2572 s2 = s; |
|
2573 for(;;) { |
|
2574 if (*++s2 != *s1) { |
|
2575 c = 0; |
|
2576 break; |
|
2577 } |
|
2578 if (!*++s1) { |
|
2579 s = s2; |
|
2580 break; |
|
2581 } |
|
2582 } |
|
2583 } |
|
2584 } |
|
2585 #endif |
|
2586 if (c == '.') { |
|
2587 c = *++s; |
|
2588 bc.dp1 = s - s0; |
|
2589 bc.dplen = bc.dp1 - bc.dp0; |
|
2590 if (!nd) { |
|
2591 for(; c == '0'; c = *++s) |
|
2592 nz++; |
|
2593 if (c > '0' && c <= '9') { |
|
2594 bc.dp0 = s0 - s; |
|
2595 bc.dp1 = bc.dp0 + bc.dplen; |
|
2596 s0 = s; |
|
2597 nf += nz; |
|
2598 nz = 0; |
|
2599 goto have_dig; |
|
2600 } |
|
2601 goto dig_done; |
|
2602 } |
|
2603 for(; c >= '0' && c <= '9'; c = *++s) { |
|
2604 have_dig: |
|
2605 nz++; |
|
2606 if (c -= '0') { |
|
2607 nf += nz; |
|
2608 for(i = 1; i < nz; i++) |
|
2609 if (nd++ < 9) |
|
2610 y *= 10; |
|
2611 else if (nd <= DBL_DIG + 1) |
|
2612 z *= 10; |
|
2613 if (nd++ < 9) |
|
2614 y = 10*y + c; |
|
2615 else if (nd <= DBL_DIG + 1) |
|
2616 z = 10*z + c; |
|
2617 nz = nz1 = 0; |
|
2618 } |
|
2619 } |
|
2620 } |
|
2621 dig_done: |
|
2622 e = 0; |
|
2623 if (c == 'e' || c == 'E') { |
|
2624 if (!nd && !nz && !nz0) { |
|
2625 goto ret0; |
|
2626 } |
|
2627 s00 = s; |
|
2628 esign = 0; |
|
2629 switch(c = *++s) { |
|
2630 case '-': |
|
2631 esign = 1; |
|
2632 case '+': |
|
2633 c = *++s; |
|
2634 } |
|
2635 if (c >= '0' && c <= '9') { |
|
2636 while(c == '0') |
|
2637 c = *++s; |
|
2638 if (c > '0' && c <= '9') { |
|
2639 L = c - '0'; |
|
2640 s1 = s; |
|
2641 while((c = *++s) >= '0' && c <= '9') |
|
2642 L = 10*L + c - '0'; |
|
2643 if (s - s1 > 8 || L > 19999) |
|
2644 /* Avoid confusion from exponents |
|
2645 * so large that e might overflow. |
|
2646 */ |
|
2647 e = 19999; /* safe for 16 bit ints */ |
|
2648 else |
|
2649 e = (int)L; |
|
2650 if (esign) |
|
2651 e = -e; |
|
2652 } |
|
2653 else |
|
2654 e = 0; |
|
2655 } |
|
2656 else |
|
2657 s = s00; |
|
2658 } |
|
2659 if (!nd) { |
|
2660 if (!nz && !nz0) { |
|
2661 #ifdef INFNAN_CHECK |
|
2662 /* Check for Nan and Infinity */ |
|
2663 if (!bc.dplen) |
|
2664 switch(c) { |
|
2665 case 'i': |
|
2666 case 'I': |
|
2667 if (match(&s,"nf")) { |
|
2668 --s; |
|
2669 if (!match(&s,"inity")) |
|
2670 ++s; |
|
2671 word0(&rv) = 0x7ff00000; |
|
2672 word1(&rv) = 0; |
|
2673 goto ret; |
|
2674 } |
|
2675 break; |
|
2676 case 'n': |
|
2677 case 'N': |
|
2678 if (match(&s, "an")) { |
|
2679 word0(&rv) = NAN_WORD0; |
|
2680 word1(&rv) = NAN_WORD1; |
|
2681 #ifndef No_Hex_NaN |
|
2682 if (*s == '(') /*)*/ |
|
2683 hexnan(&rv, &s); |
|
2684 #endif |
|
2685 goto ret; |
|
2686 } |
|
2687 } |
|
2688 #endif /* INFNAN_CHECK */ |
|
2689 ret0: |
|
2690 s = s00; |
|
2691 sign = 0; |
|
2692 } |
|
2693 goto ret; |
|
2694 } |
|
2695 bc.e0 = e1 = e -= nf; |
|
2696 |
|
2697 /* Now we have nd0 digits, starting at s0, followed by a |
|
2698 * decimal point, followed by nd-nd0 digits. The number we're |
|
2699 * after is the integer represented by those digits times |
|
2700 * 10**e */ |
|
2701 |
|
2702 if (!nd0) |
|
2703 nd0 = nd; |
|
2704 k = nd < DBL_DIG + 1 ? nd : DBL_DIG + 1; |
|
2705 dval(&rv) = y; |
|
2706 if (k > 9) { |
|
2707 #ifdef SET_INEXACT |
|
2708 if (k > DBL_DIG) |
|
2709 oldinexact = get_inexact(); |
|
2710 #endif |
|
2711 dval(&rv) = tens[k - 9] * dval(&rv) + z; |
|
2712 } |
|
2713 bd0 = 0; |
|
2714 if (nd <= DBL_DIG |
|
2715 #ifndef RND_PRODQUOT |
|
2716 #ifndef Honor_FLT_ROUNDS |
|
2717 && Flt_Rounds == 1 |
|
2718 #endif |
|
2719 #endif |
|
2720 ) { |
|
2721 if (!e) |
|
2722 goto ret; |
|
2723 #ifndef ROUND_BIASED_without_Round_Up |
|
2724 if (e > 0) { |
|
2725 if (e <= Ten_pmax) { |
|
2726 #ifdef VAX |
|
2727 goto vax_ovfl_check; |
|
2728 #else |
|
2729 #ifdef Honor_FLT_ROUNDS |
|
2730 /* round correctly FLT_ROUNDS = 2 or 3 */ |
|
2731 if (sign) { |
|
2732 rv.d = -rv.d; |
|
2733 sign = 0; |
|
2734 } |
|
2735 #endif |
|
2736 /* rv = */ rounded_product(dval(&rv), tens[e]); |
|
2737 goto ret; |
|
2738 #endif |
|
2739 } |
|
2740 i = DBL_DIG - nd; |
|
2741 if (e <= Ten_pmax + i) { |
|
2742 /* A fancier test would sometimes let us do |
|
2743 * this for larger i values. |
|
2744 */ |
|
2745 #ifdef Honor_FLT_ROUNDS |
|
2746 /* round correctly FLT_ROUNDS = 2 or 3 */ |
|
2747 if (sign) { |
|
2748 rv.d = -rv.d; |
|
2749 sign = 0; |
|
2750 } |
|
2751 #endif |
|
2752 e -= i; |
|
2753 dval(&rv) *= tens[i]; |
|
2754 #ifdef VAX |
|
2755 /* VAX exponent range is so narrow we must |
|
2756 * worry about overflow here... |
|
2757 */ |
|
2758 vax_ovfl_check: |
|
2759 word0(&rv) -= P*Exp_msk1; |
|
2760 /* rv = */ rounded_product(dval(&rv), tens[e]); |
|
2761 if ((word0(&rv) & Exp_mask) |
|
2762 > Exp_msk1*(DBL_MAX_EXP+Bias-1-P)) |
|
2763 goto ovfl; |
|
2764 word0(&rv) += P*Exp_msk1; |
|
2765 #else |
|
2766 /* rv = */ rounded_product(dval(&rv), tens[e]); |
|
2767 #endif |
|
2768 goto ret; |
|
2769 } |
|
2770 } |
|
2771 #ifndef Inaccurate_Divide |
|
2772 else if (e >= -Ten_pmax) { |
|
2773 #ifdef Honor_FLT_ROUNDS |
|
2774 /* round correctly FLT_ROUNDS = 2 or 3 */ |
|
2775 if (sign) { |
|
2776 rv.d = -rv.d; |
|
2777 sign = 0; |
|
2778 } |
|
2779 #endif |
|
2780 /* rv = */ rounded_quotient(dval(&rv), tens[-e]); |
|
2781 goto ret; |
|
2782 } |
|
2783 #endif |
|
2784 #endif /* ROUND_BIASED_without_Round_Up */ |
|
2785 } |
|
2786 e1 += nd - k; |
|
2787 |
|
2788 #ifdef IEEE_Arith |
|
2789 #ifdef SET_INEXACT |
|
2790 bc.inexact = 1; |
|
2791 if (k <= DBL_DIG) |
|
2792 oldinexact = get_inexact(); |
|
2793 #endif |
|
2794 #ifdef Avoid_Underflow |
|
2795 bc.scale = 0; |
|
2796 #endif |
|
2797 #ifdef Honor_FLT_ROUNDS |
|
2798 if (bc.rounding >= 2) { |
|
2799 if (sign) |
|
2800 bc.rounding = bc.rounding == 2 ? 0 : 2; |
|
2801 else |
|
2802 if (bc.rounding != 2) |
|
2803 bc.rounding = 0; |
|
2804 } |
|
2805 #endif |
|
2806 #endif /*IEEE_Arith*/ |
|
2807 |
|
2808 /* Get starting approximation = rv * 10**e1 */ |
|
2809 |
|
2810 if (e1 > 0) { |
|
2811 if ((i = e1 & 15)) |
|
2812 dval(&rv) *= tens[i]; |
|
2813 if (e1 &= ~15) { |
|
2814 if (e1 > DBL_MAX_10_EXP) { |
|
2815 ovfl: |
|
2816 /* Can't trust HUGE_VAL */ |
|
2817 #ifdef IEEE_Arith |
|
2818 #ifdef Honor_FLT_ROUNDS |
|
2819 switch(bc.rounding) { |
|
2820 case 0: /* toward 0 */ |
|
2821 case 3: /* toward -infinity */ |
|
2822 word0(&rv) = Big0; |
|
2823 word1(&rv) = Big1; |
|
2824 break; |
|
2825 default: |
|
2826 word0(&rv) = Exp_mask; |
|
2827 word1(&rv) = 0; |
|
2828 } |
|
2829 #else /*Honor_FLT_ROUNDS*/ |
|
2830 word0(&rv) = Exp_mask; |
|
2831 word1(&rv) = 0; |
|
2832 #endif /*Honor_FLT_ROUNDS*/ |
|
2833 #ifdef SET_INEXACT |
|
2834 /* set overflow bit */ |
|
2835 dval(&rv0) = 1e300; |
|
2836 dval(&rv0) *= dval(&rv0); |
|
2837 #endif |
|
2838 #else /*IEEE_Arith*/ |
|
2839 word0(&rv) = Big0; |
|
2840 word1(&rv) = Big1; |
|
2841 #endif /*IEEE_Arith*/ |
|
2842 range_err: |
|
2843 if (bd0) { |
|
2844 Bfree(bb); |
|
2845 Bfree(bd); |
|
2846 Bfree(bs); |
|
2847 Bfree(bd0); |
|
2848 Bfree(delta); |
|
2849 } |
|
2850 #ifndef NO_ERRNO |
|
2851 errno = ERANGE; |
|
2852 #endif |
|
2853 goto ret; |
|
2854 } |
|
2855 e1 >>= 4; |
|
2856 for(j = 0; e1 > 1; j++, e1 >>= 1) |
|
2857 if (e1 & 1) |
|
2858 dval(&rv) *= bigtens[j]; |
|
2859 /* The last multiplication could overflow. */ |
|
2860 word0(&rv) -= P*Exp_msk1; |
|
2861 dval(&rv) *= bigtens[j]; |
|
2862 if ((z = word0(&rv) & Exp_mask) |
|
2863 > Exp_msk1*(DBL_MAX_EXP+Bias-P)) |
|
2864 goto ovfl; |
|
2865 if (z > Exp_msk1*(DBL_MAX_EXP+Bias-1-P)) { |
|
2866 /* set to largest number */ |
|
2867 /* (Can't trust DBL_MAX) */ |
|
2868 word0(&rv) = Big0; |
|
2869 word1(&rv) = Big1; |
|
2870 } |
|
2871 else |
|
2872 word0(&rv) += P*Exp_msk1; |
|
2873 } |
|
2874 } |
|
2875 else if (e1 < 0) { |
|
2876 e1 = -e1; |
|
2877 if ((i = e1 & 15)) |
|
2878 dval(&rv) /= tens[i]; |
|
2879 if (e1 >>= 4) { |
|
2880 if (e1 >= 1 << n_bigtens) |
|
2881 goto undfl; |
|
2882 #ifdef Avoid_Underflow |
|
2883 if (e1 & Scale_Bit) |
|
2884 bc.scale = 2*P; |
|
2885 for(j = 0; e1 > 0; j++, e1 >>= 1) |
|
2886 if (e1 & 1) |
|
2887 dval(&rv) *= tinytens[j]; |
|
2888 if (bc.scale && (j = 2*P + 1 - ((word0(&rv) & Exp_mask) |
|
2889 >> Exp_shift)) > 0) { |
|
2890 /* scaled rv is denormal; clear j low bits */ |
|
2891 if (j >= 32) { |
|
2892 if (j > 54) |
|
2893 goto undfl; |
|
2894 word1(&rv) = 0; |
|
2895 if (j >= 53) |
|
2896 word0(&rv) = (P+2)*Exp_msk1; |
|
2897 else |
|
2898 word0(&rv) &= 0xffffffff << (j-32); |
|
2899 } |
|
2900 else |
|
2901 word1(&rv) &= 0xffffffff << j; |
|
2902 } |
|
2903 #else |
|
2904 for(j = 0; e1 > 1; j++, e1 >>= 1) |
|
2905 if (e1 & 1) |
|
2906 dval(&rv) *= tinytens[j]; |
|
2907 /* The last multiplication could underflow. */ |
|
2908 dval(&rv0) = dval(&rv); |
|
2909 dval(&rv) *= tinytens[j]; |
|
2910 if (!dval(&rv)) { |
|
2911 dval(&rv) = 2.*dval(&rv0); |
|
2912 dval(&rv) *= tinytens[j]; |
|
2913 #endif |
|
2914 if (!dval(&rv)) { |
|
2915 undfl: |
|
2916 dval(&rv) = 0.; |
|
2917 goto range_err; |
|
2918 } |
|
2919 #ifndef Avoid_Underflow |
|
2920 word0(&rv) = Tiny0; |
|
2921 word1(&rv) = Tiny1; |
|
2922 /* The refinement below will clean |
|
2923 * this approximation up. |
|
2924 */ |
|
2925 } |
|
2926 #endif |
|
2927 } |
|
2928 } |
|
2929 |
|
2930 /* Now the hard part -- adjusting rv to the correct value.*/ |
|
2931 |
|
2932 /* Put digits into bd: true value = bd * 10^e */ |
|
2933 |
|
2934 bc.nd = nd - nz1; |
|
2935 #ifndef NO_STRTOD_BIGCOMP |
|
2936 bc.nd0 = nd0; /* Only needed if nd > strtod_diglim, but done here */ |
|
2937 /* to silence an erroneous warning about bc.nd0 */ |
|
2938 /* possibly not being initialized. */ |
|
2939 if (nd > strtod_diglim) { |
|
2940 /* ASSERT(strtod_diglim >= 18); 18 == one more than the */ |
|
2941 /* minimum number of decimal digits to distinguish double values */ |
|
2942 /* in IEEE arithmetic. */ |
|
2943 i = j = 18; |
|
2944 if (i > nd0) |
|
2945 j += bc.dplen; |
|
2946 for(;;) { |
|
2947 if (--j < bc.dp1 && j >= bc.dp0) |
|
2948 j = bc.dp0 - 1; |
|
2949 if (s0[j] != '0') |
|
2950 break; |
|
2951 --i; |
|
2952 } |
|
2953 e += nd - i; |
|
2954 nd = i; |
|
2955 if (nd0 > nd) |
|
2956 nd0 = nd; |
|
2957 if (nd < 9) { /* must recompute y */ |
|
2958 y = 0; |
|
2959 for(i = 0; i < nd0; ++i) |
|
2960 y = 10*y + s0[i] - '0'; |
|
2961 for(j = bc.dp1; i < nd; ++i) |
|
2962 y = 10*y + s0[j++] - '0'; |
|
2963 } |
|
2964 } |
|
2965 #endif |
|
2966 bd0 = s2b(s0, nd0, nd, y, bc.dplen); |
|
2967 |
|
2968 for(;;) { |
|
2969 bd = Balloc(bd0->k); |
|
2970 Bcopy(bd, bd0); |
|
2971 bb = d2b(&rv, &bbe, &bbbits); /* rv = bb * 2^bbe */ |
|
2972 bs = i2b(1); |
|
2973 |
|
2974 if (e >= 0) { |
|
2975 bb2 = bb5 = 0; |
|
2976 bd2 = bd5 = e; |
|
2977 } |
|
2978 else { |
|
2979 bb2 = bb5 = -e; |
|
2980 bd2 = bd5 = 0; |
|
2981 } |
|
2982 if (bbe >= 0) |
|
2983 bb2 += bbe; |
|
2984 else |
|
2985 bd2 -= bbe; |
|
2986 bs2 = bb2; |
|
2987 #ifdef Honor_FLT_ROUNDS |
|
2988 if (bc.rounding != 1) |
|
2989 bs2++; |
|
2990 #endif |
|
2991 #ifdef Avoid_Underflow |
|
2992 Lsb = LSB; |
|
2993 Lsb1 = 0; |
|
2994 j = bbe - bc.scale; |
|
2995 i = j + bbbits - 1; /* logb(rv) */ |
|
2996 j = P + 1 - bbbits; |
|
2997 if (i < Emin) { /* denormal */ |
|
2998 i = Emin - i; |
|
2999 j -= i; |
|
3000 if (i < 32) |
|
3001 Lsb <<= i; |
|
3002 else if (i < 52) |
|
3003 Lsb1 = Lsb << (i-32); |
|
3004 else |
|
3005 Lsb1 = Exp_mask; |
|
3006 } |
|
3007 #else /*Avoid_Underflow*/ |
|
3008 #ifdef Sudden_Underflow |
|
3009 #ifdef IBM |
|
3010 j = 1 + 4*P - 3 - bbbits + ((bbe + bbbits - 1) & 3); |
|
3011 #else |
|
3012 j = P + 1 - bbbits; |
|
3013 #endif |
|
3014 #else /*Sudden_Underflow*/ |
|
3015 j = bbe; |
|
3016 i = j + bbbits - 1; /* logb(rv) */ |
|
3017 if (i < Emin) /* denormal */ |
|
3018 j += P - Emin; |
|
3019 else |
|
3020 j = P + 1 - bbbits; |
|
3021 #endif /*Sudden_Underflow*/ |
|
3022 #endif /*Avoid_Underflow*/ |
|
3023 bb2 += j; |
|
3024 bd2 += j; |
|
3025 #ifdef Avoid_Underflow |
|
3026 bd2 += bc.scale; |
|
3027 #endif |
|
3028 i = bb2 < bd2 ? bb2 : bd2; |
|
3029 if (i > bs2) |
|
3030 i = bs2; |
|
3031 if (i > 0) { |
|
3032 bb2 -= i; |
|
3033 bd2 -= i; |
|
3034 bs2 -= i; |
|
3035 } |
|
3036 if (bb5 > 0) { |
|
3037 bs = pow5mult(bs, bb5); |
|
3038 bb1 = mult(bs, bb); |
|
3039 Bfree(bb); |
|
3040 bb = bb1; |
|
3041 } |
|
3042 if (bb2 > 0) |
|
3043 bb = lshift(bb, bb2); |
|
3044 if (bd5 > 0) |
|
3045 bd = pow5mult(bd, bd5); |
|
3046 if (bd2 > 0) |
|
3047 bd = lshift(bd, bd2); |
|
3048 if (bs2 > 0) |
|
3049 bs = lshift(bs, bs2); |
|
3050 delta = diff(bb, bd); |
|
3051 bc.dsign = delta->sign; |
|
3052 delta->sign = 0; |
|
3053 i = cmp(delta, bs); |
|
3054 #ifndef NO_STRTOD_BIGCOMP /*{*/ |
|
3055 if (bc.nd > nd && i <= 0) { |
|
3056 if (bc.dsign) { |
|
3057 /* Must use bigcomp(). */ |
|
3058 req_bigcomp = 1; |
|
3059 break; |
|
3060 } |
|
3061 #ifdef Honor_FLT_ROUNDS |
|
3062 if (bc.rounding != 1) { |
|
3063 if (i < 0) { |
|
3064 req_bigcomp = 1; |
|
3065 break; |
|
3066 } |
|
3067 } |
|
3068 else |
|
3069 #endif |
|
3070 i = -1; /* Discarded digits make delta smaller. */ |
|
3071 } |
|
3072 #endif /*}*/ |
|
3073 #ifdef Honor_FLT_ROUNDS /*{*/ |
|
3074 if (bc.rounding != 1) { |
|
3075 if (i < 0) { |
|
3076 /* Error is less than an ulp */ |
|
3077 if (!delta->x[0] && delta->wds <= 1) { |
|
3078 /* exact */ |
|
3079 #ifdef SET_INEXACT |
|
3080 bc.inexact = 0; |
|
3081 #endif |
|
3082 break; |
|
3083 } |
|
3084 if (bc.rounding) { |
|
3085 if (bc.dsign) { |
|
3086 adj.d = 1.; |
|
3087 goto apply_adj; |
|
3088 } |
|
3089 } |
|
3090 else if (!bc.dsign) { |
|
3091 adj.d = -1.; |
|
3092 if (!word1(&rv) |
|
3093 && !(word0(&rv) & Frac_mask)) { |
|
3094 y = word0(&rv) & Exp_mask; |
|
3095 #ifdef Avoid_Underflow |
|
3096 if (!bc.scale || y > 2*P*Exp_msk1) |
|
3097 #else |
|
3098 if (y) |
|
3099 #endif |
|
3100 { |
|
3101 delta = lshift(delta,Log2P); |
|
3102 if (cmp(delta, bs) <= 0) |
|
3103 adj.d = -0.5; |
|
3104 } |
|
3105 } |
|
3106 apply_adj: |
|
3107 #ifdef Avoid_Underflow /*{*/ |
|
3108 if (bc.scale && (y = word0(&rv) & Exp_mask) |
|
3109 <= 2*P*Exp_msk1) |
|
3110 word0(&adj) += (2*P+1)*Exp_msk1 - y; |
|
3111 #else |
|
3112 #ifdef Sudden_Underflow |
|
3113 if ((word0(&rv) & Exp_mask) <= |
|
3114 P*Exp_msk1) { |
|
3115 word0(&rv) += P*Exp_msk1; |
|
3116 dval(&rv) += adj.d*ulp(dval(&rv)); |
|
3117 word0(&rv) -= P*Exp_msk1; |
|
3118 } |
|
3119 else |
|
3120 #endif /*Sudden_Underflow*/ |
|
3121 #endif /*Avoid_Underflow}*/ |
|
3122 dval(&rv) += adj.d*ulp(&rv); |
|
3123 } |
|
3124 break; |
|
3125 } |
|
3126 adj.d = ratio(delta, bs); |
|
3127 if (adj.d < 1.) |
|
3128 adj.d = 1.; |
|
3129 if (adj.d <= 0x7ffffffe) { |
|
3130 /* adj = rounding ? ceil(adj) : floor(adj); */ |
|
3131 y = adj.d; |
|
3132 if (y != adj.d) { |
|
3133 if (!((bc.rounding>>1) ^ bc.dsign)) |
|
3134 y++; |
|
3135 adj.d = y; |
|
3136 } |
|
3137 } |
|
3138 #ifdef Avoid_Underflow /*{*/ |
|
3139 if (bc.scale && (y = word0(&rv) & Exp_mask) <= 2*P*Exp_msk1) |
|
3140 word0(&adj) += (2*P+1)*Exp_msk1 - y; |
|
3141 #else |
|
3142 #ifdef Sudden_Underflow |
|
3143 if ((word0(&rv) & Exp_mask) <= P*Exp_msk1) { |
|
3144 word0(&rv) += P*Exp_msk1; |
|
3145 adj.d *= ulp(dval(&rv)); |
|
3146 if (bc.dsign) |
|
3147 dval(&rv) += adj.d; |
|
3148 else |
|
3149 dval(&rv) -= adj.d; |
|
3150 word0(&rv) -= P*Exp_msk1; |
|
3151 goto cont; |
|
3152 } |
|
3153 #endif /*Sudden_Underflow*/ |
|
3154 #endif /*Avoid_Underflow}*/ |
|
3155 adj.d *= ulp(&rv); |
|
3156 if (bc.dsign) { |
|
3157 if (word0(&rv) == Big0 && word1(&rv) == Big1) |
|
3158 goto ovfl; |
|
3159 dval(&rv) += adj.d; |
|
3160 } |
|
3161 else |
|
3162 dval(&rv) -= adj.d; |
|
3163 goto cont; |
|
3164 } |
|
3165 #endif /*}Honor_FLT_ROUNDS*/ |
|
3166 |
|
3167 if (i < 0) { |
|
3168 /* Error is less than half an ulp -- check for |
|
3169 * special case of mantissa a power of two. |
|
3170 */ |
|
3171 if (bc.dsign || word1(&rv) || word0(&rv) & Bndry_mask |
|
3172 #ifdef IEEE_Arith /*{*/ |
|
3173 #ifdef Avoid_Underflow |
|
3174 || (word0(&rv) & Exp_mask) <= (2*P+1)*Exp_msk1 |
|
3175 #else |
|
3176 || (word0(&rv) & Exp_mask) <= Exp_msk1 |
|
3177 #endif |
|
3178 #endif /*}*/ |
|
3179 ) { |
|
3180 #ifdef SET_INEXACT |
|
3181 if (!delta->x[0] && delta->wds <= 1) |
|
3182 bc.inexact = 0; |
|
3183 #endif |
|
3184 break; |
|
3185 } |
|
3186 if (!delta->x[0] && delta->wds <= 1) { |
|
3187 /* exact result */ |
|
3188 #ifdef SET_INEXACT |
|
3189 bc.inexact = 0; |
|
3190 #endif |
|
3191 break; |
|
3192 } |
|
3193 delta = lshift(delta,Log2P); |
|
3194 if (cmp(delta, bs) > 0) |
|
3195 goto drop_down; |
|
3196 break; |
|
3197 } |
|
3198 if (i == 0) { |
|
3199 /* exactly half-way between */ |
|
3200 if (bc.dsign) { |
|
3201 if ((word0(&rv) & Bndry_mask1) == Bndry_mask1 |
|
3202 && word1(&rv) == ( |
|
3203 #ifdef Avoid_Underflow |
|
3204 (bc.scale && (y = word0(&rv) & Exp_mask) <= 2*P*Exp_msk1) |
|
3205 ? (0xffffffff & (0xffffffff << (2*P+1-(y>>Exp_shift)))) : |
|
3206 #endif |
|
3207 0xffffffff)) { |
|
3208 /*boundary case -- increment exponent*/ |
|
3209 if (word0(&rv) == Big0 && word1(&rv) == Big1) |
|
3210 goto ovfl; |
|
3211 word0(&rv) = (word0(&rv) & Exp_mask) |
|
3212 + Exp_msk1 |
|
3213 #ifdef IBM |
|
3214 | Exp_msk1 >> 4 |
|
3215 #endif |
|
3216 ; |
|
3217 word1(&rv) = 0; |
|
3218 #ifdef Avoid_Underflow |
|
3219 bc.dsign = 0; |
|
3220 #endif |
|
3221 break; |
|
3222 } |
|
3223 } |
|
3224 else if (!(word0(&rv) & Bndry_mask) && !word1(&rv)) { |
|
3225 drop_down: |
|
3226 /* boundary case -- decrement exponent */ |
|
3227 #ifdef Sudden_Underflow /*{{*/ |
|
3228 L = word0(&rv) & Exp_mask; |
|
3229 #ifdef IBM |
|
3230 if (L < Exp_msk1) |
|
3231 #else |
|
3232 #ifdef Avoid_Underflow |
|
3233 if (L <= (bc.scale ? (2*P+1)*Exp_msk1 : Exp_msk1)) |
|
3234 #else |
|
3235 if (L <= Exp_msk1) |
|
3236 #endif /*Avoid_Underflow*/ |
|
3237 #endif /*IBM*/ |
|
3238 { |
|
3239 if (bc.nd >nd) { |
|
3240 bc.uflchk = 1; |
|
3241 break; |
|
3242 } |
|
3243 goto undfl; |
|
3244 } |
|
3245 L -= Exp_msk1; |
|
3246 #else /*Sudden_Underflow}{*/ |
|
3247 #ifdef Avoid_Underflow |
|
3248 if (bc.scale) { |
|
3249 L = word0(&rv) & Exp_mask; |
|
3250 if (L <= (2*P+1)*Exp_msk1) { |
|
3251 if (L > (P+2)*Exp_msk1) |
|
3252 /* round even ==> */ |
|
3253 /* accept rv */ |
|
3254 break; |
|
3255 /* rv = smallest denormal */ |
|
3256 if (bc.nd >nd) { |
|
3257 bc.uflchk = 1; |
|
3258 break; |
|
3259 } |
|
3260 goto undfl; |
|
3261 } |
|
3262 } |
|
3263 #endif /*Avoid_Underflow*/ |
|
3264 L = (word0(&rv) & Exp_mask) - Exp_msk1; |
|
3265 #endif /*Sudden_Underflow}}*/ |
|
3266 word0(&rv) = L | Bndry_mask1; |
|
3267 word1(&rv) = 0xffffffff; |
|
3268 #ifdef IBM |
|
3269 goto cont; |
|
3270 #else |
|
3271 #ifndef NO_STRTOD_BIGCOMP |
|
3272 if (bc.nd > nd) |
|
3273 goto cont; |
|
3274 #endif |
|
3275 break; |
|
3276 #endif |
|
3277 } |
|
3278 #ifndef ROUND_BIASED |
|
3279 #ifdef Avoid_Underflow |
|
3280 if (Lsb1) { |
|
3281 if (!(word0(&rv) & Lsb1)) |
|
3282 break; |
|
3283 } |
|
3284 else if (!(word1(&rv) & Lsb)) |
|
3285 break; |
|
3286 #else |
|
3287 if (!(word1(&rv) & LSB)) |
|
3288 break; |
|
3289 #endif |
|
3290 #endif |
|
3291 if (bc.dsign) |
|
3292 #ifdef Avoid_Underflow |
|
3293 dval(&rv) += sulp(&rv, &bc); |
|
3294 #else |
|
3295 dval(&rv) += ulp(&rv); |
|
3296 #endif |
|
3297 #ifndef ROUND_BIASED |
|
3298 else { |
|
3299 #ifdef Avoid_Underflow |
|
3300 dval(&rv) -= sulp(&rv, &bc); |
|
3301 #else |
|
3302 dval(&rv) -= ulp(&rv); |
|
3303 #endif |
|
3304 #ifndef Sudden_Underflow |
|
3305 if (!dval(&rv)) { |
|
3306 if (bc.nd >nd) { |
|
3307 bc.uflchk = 1; |
|
3308 break; |
|
3309 } |
|
3310 goto undfl; |
|
3311 } |
|
3312 #endif |
|
3313 } |
|
3314 #ifdef Avoid_Underflow |
|
3315 bc.dsign = 1 - bc.dsign; |
|
3316 #endif |
|
3317 #endif |
|
3318 break; |
|
3319 } |
|
3320 if ((aadj = ratio(delta, bs)) <= 2.) { |
|
3321 if (bc.dsign) |
|
3322 aadj = aadj1 = 1.; |
|
3323 else if (word1(&rv) || word0(&rv) & Bndry_mask) { |
|
3324 #ifndef Sudden_Underflow |
|
3325 if (word1(&rv) == Tiny1 && !word0(&rv)) { |
|
3326 if (bc.nd >nd) { |
|
3327 bc.uflchk = 1; |
|
3328 break; |
|
3329 } |
|
3330 goto undfl; |
|
3331 } |
|
3332 #endif |
|
3333 aadj = 1.; |
|
3334 aadj1 = -1.; |
|
3335 } |
|
3336 else { |
|
3337 /* special case -- power of FLT_RADIX to be */ |
|
3338 /* rounded down... */ |
|
3339 |
|
3340 if (aadj < 2./FLT_RADIX) |
|
3341 aadj = 1./FLT_RADIX; |
|
3342 else |
|
3343 aadj *= 0.5; |
|
3344 aadj1 = -aadj; |
|
3345 } |
|
3346 } |
|
3347 else { |
|
3348 aadj *= 0.5; |
|
3349 aadj1 = bc.dsign ? aadj : -aadj; |
|
3350 #ifdef Check_FLT_ROUNDS |
|
3351 switch(bc.rounding) { |
|
3352 case 2: /* towards +infinity */ |
|
3353 aadj1 -= 0.5; |
|
3354 break; |
|
3355 case 0: /* towards 0 */ |
|
3356 case 3: /* towards -infinity */ |
|
3357 aadj1 += 0.5; |
|
3358 } |
|
3359 #else |
|
3360 if (Flt_Rounds == 0) |
|
3361 aadj1 += 0.5; |
|
3362 #endif /*Check_FLT_ROUNDS*/ |
|
3363 } |
|
3364 y = word0(&rv) & Exp_mask; |
|
3365 |
|
3366 /* Check for overflow */ |
|
3367 |
|
3368 if (y == Exp_msk1*(DBL_MAX_EXP+Bias-1)) { |
|
3369 dval(&rv0) = dval(&rv); |
|
3370 word0(&rv) -= P*Exp_msk1; |
|
3371 adj.d = aadj1 * ulp(&rv); |
|
3372 dval(&rv) += adj.d; |
|
3373 if ((word0(&rv) & Exp_mask) >= |
|
3374 Exp_msk1*(DBL_MAX_EXP+Bias-P)) { |
|
3375 if (word0(&rv0) == Big0 && word1(&rv0) == Big1) |
|
3376 goto ovfl; |
|
3377 word0(&rv) = Big0; |
|
3378 word1(&rv) = Big1; |
|
3379 goto cont; |
|
3380 } |
|
3381 else |
|
3382 word0(&rv) += P*Exp_msk1; |
|
3383 } |
|
3384 else { |
|
3385 #ifdef Avoid_Underflow |
|
3386 if (bc.scale && y <= 2*P*Exp_msk1) { |
|
3387 if (aadj <= 0x7fffffff) { |
|
3388 if ((z = aadj) <= 0) |
|
3389 z = 1; |
|
3390 aadj = z; |
|
3391 aadj1 = bc.dsign ? aadj : -aadj; |
|
3392 } |
|
3393 dval(&aadj2) = aadj1; |
|
3394 word0(&aadj2) += (2*P+1)*Exp_msk1 - y; |
|
3395 aadj1 = dval(&aadj2); |
|
3396 adj.d = aadj1 * ulp(&rv); |
|
3397 dval(&rv) += adj.d; |
|
3398 if (rv.d == 0.) |
|
3399 #ifdef NO_STRTOD_BIGCOMP |
|
3400 goto undfl; |
|
3401 #else |
|
3402 { |
|
3403 if (bc.nd > nd) |
|
3404 bc.dsign = 1; |
|
3405 break; |
|
3406 } |
|
3407 #endif |
|
3408 } |
|
3409 else { |
|
3410 adj.d = aadj1 * ulp(&rv); |
|
3411 dval(&rv) += adj.d; |
|
3412 } |
|
3413 #else |
|
3414 #ifdef Sudden_Underflow |
|
3415 if ((word0(&rv) & Exp_mask) <= P*Exp_msk1) { |
|
3416 dval(&rv0) = dval(&rv); |
|
3417 word0(&rv) += P*Exp_msk1; |
|
3418 adj.d = aadj1 * ulp(&rv); |
|
3419 dval(&rv) += adj.d; |
|
3420 #ifdef IBM |
|
3421 if ((word0(&rv) & Exp_mask) < P*Exp_msk1) |
|
3422 #else |
|
3423 if ((word0(&rv) & Exp_mask) <= P*Exp_msk1) |
|
3424 #endif |
|
3425 { |
|
3426 if (word0(&rv0) == Tiny0 |
|
3427 && word1(&rv0) == Tiny1) { |
|
3428 if (bc.nd >nd) { |
|
3429 bc.uflchk = 1; |
|
3430 break; |
|
3431 } |
|
3432 goto undfl; |
|
3433 } |
|
3434 word0(&rv) = Tiny0; |
|
3435 word1(&rv) = Tiny1; |
|
3436 goto cont; |
|
3437 } |
|
3438 else |
|
3439 word0(&rv) -= P*Exp_msk1; |
|
3440 } |
|
3441 else { |
|
3442 adj.d = aadj1 * ulp(&rv); |
|
3443 dval(&rv) += adj.d; |
|
3444 } |
|
3445 #else /*Sudden_Underflow*/ |
|
3446 /* Compute adj so that the IEEE rounding rules will |
|
3447 * correctly round rv + adj in some half-way cases. |
|
3448 * If rv * ulp(rv) is denormalized (i.e., |
|
3449 * y <= (P-1)*Exp_msk1), we must adjust aadj to avoid |
|
3450 * trouble from bits lost to denormalization; |
|
3451 * example: 1.2e-307 . |
|
3452 */ |
|
3453 if (y <= (P-1)*Exp_msk1 && aadj > 1.) { |
|
3454 aadj1 = (double)(int)(aadj + 0.5); |
|
3455 if (!bc.dsign) |
|
3456 aadj1 = -aadj1; |
|
3457 } |
|
3458 adj.d = aadj1 * ulp(&rv); |
|
3459 dval(&rv) += adj.d; |
|
3460 #endif /*Sudden_Underflow*/ |
|
3461 #endif /*Avoid_Underflow*/ |
|
3462 } |
|
3463 z = word0(&rv) & Exp_mask; |
|
3464 #ifndef SET_INEXACT |
|
3465 if (bc.nd == nd) { |
|
3466 #ifdef Avoid_Underflow |
|
3467 if (!bc.scale) |
|
3468 #endif |
|
3469 if (y == z) { |
|
3470 /* Can we stop now? */ |
|
3471 L = (Long)aadj; |
|
3472 aadj -= L; |
|
3473 /* The tolerances below are conservative. */ |
|
3474 if (bc.dsign || word1(&rv) || word0(&rv) & Bndry_mask) { |
|
3475 if (aadj < .4999999 || aadj > .5000001) |
|
3476 break; |
|
3477 } |
|
3478 else if (aadj < .4999999/FLT_RADIX) |
|
3479 break; |
|
3480 } |
|
3481 } |
|
3482 #endif |
|
3483 cont: |
|
3484 Bfree(bb); |
|
3485 Bfree(bd); |
|
3486 Bfree(bs); |
|
3487 Bfree(delta); |
|
3488 } |
|
3489 Bfree(bb); |
|
3490 Bfree(bd); |
|
3491 Bfree(bs); |
|
3492 Bfree(bd0); |
|
3493 Bfree(delta); |
|
3494 #ifndef NO_STRTOD_BIGCOMP |
|
3495 if (req_bigcomp) { |
|
3496 bd0 = 0; |
|
3497 bc.e0 += nz1; |
|
3498 bigcomp(&rv, s0, &bc); |
|
3499 y = word0(&rv) & Exp_mask; |
|
3500 if (y == Exp_mask) |
|
3501 goto ovfl; |
|
3502 if (y == 0 && rv.d == 0.) |
|
3503 goto undfl; |
|
3504 } |
|
3505 #endif |
|
3506 #ifdef SET_INEXACT |
|
3507 if (bc.inexact) { |
|
3508 if (!oldinexact) { |
|
3509 word0(&rv0) = Exp_1 + (70 << Exp_shift); |
|
3510 word1(&rv0) = 0; |
|
3511 dval(&rv0) += 1.; |
|
3512 } |
|
3513 } |
|
3514 else if (!oldinexact) |
|
3515 clear_inexact(); |
|
3516 #endif |
|
3517 #ifdef Avoid_Underflow |
|
3518 if (bc.scale) { |
|
3519 word0(&rv0) = Exp_1 - 2*P*Exp_msk1; |
|
3520 word1(&rv0) = 0; |
|
3521 dval(&rv) *= dval(&rv0); |
|
3522 #ifndef NO_ERRNO |
|
3523 /* try to avoid the bug of testing an 8087 register value */ |
|
3524 #ifdef IEEE_Arith |
|
3525 if (!(word0(&rv) & Exp_mask)) |
|
3526 #else |
|
3527 if (word0(&rv) == 0 && word1(&rv) == 0) |
|
3528 #endif |
|
3529 errno = ERANGE; |
|
3530 #endif |
|
3531 } |
|
3532 #endif /* Avoid_Underflow */ |
|
3533 #ifdef SET_INEXACT |
|
3534 if (bc.inexact && !(word0(&rv) & Exp_mask)) { |
|
3535 /* set underflow bit */ |
|
3536 dval(&rv0) = 1e-300; |
|
3537 dval(&rv0) *= dval(&rv0); |
|
3538 } |
|
3539 #endif |
|
3540 ret: |
|
3541 if (se) |
|
3542 *se = (char *)s; |
|
3543 return sign ? -dval(&rv) : dval(&rv); |
|
3544 } |
|
3545 |
|
3546 #ifndef MULTIPLE_THREADS |
|
3547 static char *dtoa_result; |
|
3548 #endif |
|
3549 |
|
3550 static char * |
|
3551 #ifdef KR_headers |
|
3552 rv_alloc(i) int i; |
|
3553 #else |
|
3554 rv_alloc(int i) |
|
3555 #endif |
|
3556 { |
|
3557 int j, k, *r; |
|
3558 |
|
3559 j = sizeof(ULong); |
|
3560 for(k = 0; |
|
3561 sizeof(Bigint) - sizeof(ULong) - sizeof(int) + j <= i; |
|
3562 j <<= 1) |
|
3563 k++; |
|
3564 r = (int*)Balloc(k); |
|
3565 *r = k; |
|
3566 return |
|
3567 #ifndef MULTIPLE_THREADS |
|
3568 dtoa_result = |
|
3569 #endif |
|
3570 (char *)(r+1); |
|
3571 } |
|
3572 |
|
3573 static char * |
|
3574 #ifdef KR_headers |
|
3575 nrv_alloc(s, rve, n) char *s, **rve; int n; |
|
3576 #else |
|
3577 nrv_alloc(const char *s, char **rve, int n) |
|
3578 #endif |
|
3579 { |
|
3580 char *rv, *t; |
|
3581 |
|
3582 t = rv = rv_alloc(n); |
|
3583 while((*t = *s++)) t++; |
|
3584 if (rve) |
|
3585 *rve = t; |
|
3586 return rv; |
|
3587 } |
|
3588 |
|
3589 /* freedtoa(s) must be used to free values s returned by dtoa |
|
3590 * when MULTIPLE_THREADS is #defined. It should be used in all cases, |
|
3591 * but for consistency with earlier versions of dtoa, it is optional |
|
3592 * when MULTIPLE_THREADS is not defined. |
|
3593 */ |
|
3594 |
|
3595 void |
|
3596 #ifdef KR_headers |
|
3597 freedtoa(s) char *s; |
|
3598 #else |
|
3599 freedtoa(char *s) |
|
3600 #endif |
|
3601 { |
|
3602 Bigint *b = (Bigint *)((int *)s - 1); |
|
3603 b->maxwds = 1 << (b->k = *(int*)b); |
|
3604 Bfree(b); |
|
3605 #ifndef MULTIPLE_THREADS |
|
3606 if (s == dtoa_result) |
|
3607 dtoa_result = 0; |
|
3608 #endif |
|
3609 } |
|
3610 |
|
3611 /* dtoa for IEEE arithmetic (dmg): convert double to ASCII string. |
|
3612 * |
|
3613 * Inspired by "How to Print Floating-Point Numbers Accurately" by |
|
3614 * Guy L. Steele, Jr. and Jon L. White [Proc. ACM SIGPLAN '90, pp. 112-126]. |
|
3615 * |
|
3616 * Modifications: |
|
3617 * 1. Rather than iterating, we use a simple numeric overestimate |
|
3618 * to determine k = floor(log10(d)). We scale relevant |
|
3619 * quantities using O(log2(k)) rather than O(k) multiplications. |
|
3620 * 2. For some modes > 2 (corresponding to ecvt and fcvt), we don't |
|
3621 * try to generate digits strictly left to right. Instead, we |
|
3622 * compute with fewer bits and propagate the carry if necessary |
|
3623 * when rounding the final digit up. This is often faster. |
|
3624 * 3. Under the assumption that input will be rounded nearest, |
|
3625 * mode 0 renders 1e23 as 1e23 rather than 9.999999999999999e22. |
|
3626 * That is, we allow equality in stopping tests when the |
|
3627 * round-nearest rule will give the same floating-point value |
|
3628 * as would satisfaction of the stopping test with strict |
|
3629 * inequality. |
|
3630 * 4. We remove common factors of powers of 2 from relevant |
|
3631 * quantities. |
|
3632 * 5. When converting floating-point integers less than 1e16, |
|
3633 * we use floating-point arithmetic rather than resorting |
|
3634 * to multiple-precision integers. |
|
3635 * 6. When asked to produce fewer than 15 digits, we first try |
|
3636 * to get by with floating-point arithmetic; we resort to |
|
3637 * multiple-precision integer arithmetic only if we cannot |
|
3638 * guarantee that the floating-point calculation has given |
|
3639 * the correctly rounded result. For k requested digits and |
|
3640 * "uniformly" distributed input, the probability is |
|
3641 * something like 10^(k-15) that we must resort to the Long |
|
3642 * calculation. |
|
3643 */ |
|
3644 |
|
3645 char * |
|
3646 dtoa |
|
3647 #ifdef KR_headers |
|
3648 (dd, mode, ndigits, decpt, sign, rve) |
|
3649 double dd; int mode, ndigits, *decpt, *sign; char **rve; |
|
3650 #else |
|
3651 (double dd, int mode, int ndigits, int *decpt, int *sign, char **rve) |
|
3652 #endif |
|
3653 { |
|
3654 /* Arguments ndigits, decpt, sign are similar to those |
|
3655 of ecvt and fcvt; trailing zeros are suppressed from |
|
3656 the returned string. If not null, *rve is set to point |
|
3657 to the end of the return value. If d is +-Infinity or NaN, |
|
3658 then *decpt is set to 9999. |
|
3659 |
|
3660 mode: |
|
3661 0 ==> shortest string that yields d when read in |
|
3662 and rounded to nearest. |
|
3663 1 ==> like 0, but with Steele & White stopping rule; |
|
3664 e.g. with IEEE P754 arithmetic , mode 0 gives |
|
3665 1e23 whereas mode 1 gives 9.999999999999999e22. |
|
3666 2 ==> max(1,ndigits) significant digits. This gives a |
|
3667 return value similar to that of ecvt, except |
|
3668 that trailing zeros are suppressed. |
|
3669 3 ==> through ndigits past the decimal point. This |
|
3670 gives a return value similar to that from fcvt, |
|
3671 except that trailing zeros are suppressed, and |
|
3672 ndigits can be negative. |
|
3673 4,5 ==> similar to 2 and 3, respectively, but (in |
|
3674 round-nearest mode) with the tests of mode 0 to |
|
3675 possibly return a shorter string that rounds to d. |
|
3676 With IEEE arithmetic and compilation with |
|
3677 -DHonor_FLT_ROUNDS, modes 4 and 5 behave the same |
|
3678 as modes 2 and 3 when FLT_ROUNDS != 1. |
|
3679 6-9 ==> Debugging modes similar to mode - 4: don't try |
|
3680 fast floating-point estimate (if applicable). |
|
3681 |
|
3682 Values of mode other than 0-9 are treated as mode 0. |
|
3683 |
|
3684 Sufficient space is allocated to the return value |
|
3685 to hold the suppressed trailing zeros. |
|
3686 */ |
|
3687 |
|
3688 int bbits, b2, b5, be, dig, i, ieps, ilim, ilim0, ilim1, |
|
3689 j, j1, k, k0, k_check, leftright, m2, m5, s2, s5, |
|
3690 spec_case, try_quick; |
|
3691 Long L; |
|
3692 #ifndef Sudden_Underflow |
|
3693 int denorm; |
|
3694 ULong x; |
|
3695 #endif |
|
3696 Bigint *b, *b1, *delta, *mlo, *mhi, *S; |
|
3697 U d2, eps, u; |
|
3698 double ds; |
|
3699 char *s, *s0; |
|
3700 #ifndef No_leftright |
|
3701 #ifdef IEEE_Arith |
|
3702 U eps1; |
|
3703 #endif |
|
3704 #endif |
|
3705 #ifdef SET_INEXACT |
|
3706 int inexact, oldinexact; |
|
3707 #endif |
|
3708 #ifdef Honor_FLT_ROUNDS /*{*/ |
|
3709 int Rounding; |
|
3710 #ifdef Trust_FLT_ROUNDS /*{{ only define this if FLT_ROUNDS really works! */ |
|
3711 Rounding = Flt_Rounds; |
|
3712 #else /*}{*/ |
|
3713 Rounding = 1; |
|
3714 switch(fegetround()) { |
|
3715 case FE_TOWARDZERO: Rounding = 0; break; |
|
3716 case FE_UPWARD: Rounding = 2; break; |
|
3717 case FE_DOWNWARD: Rounding = 3; |
|
3718 } |
|
3719 #endif /*}}*/ |
|
3720 #endif /*}*/ |
|
3721 |
|
3722 #ifndef MULTIPLE_THREADS |
|
3723 if (dtoa_result) { |
|
3724 freedtoa(dtoa_result); |
|
3725 dtoa_result = 0; |
|
3726 } |
|
3727 #endif |
|
3728 |
|
3729 u.d = dd; |
|
3730 if (word0(&u) & Sign_bit) { |
|
3731 /* set sign for everything, including 0's and NaNs */ |
|
3732 *sign = 1; |
|
3733 word0(&u) &= ~Sign_bit; /* clear sign bit */ |
|
3734 } |
|
3735 else |
|
3736 *sign = 0; |
|
3737 |
|
3738 #if defined(IEEE_Arith) + defined(VAX) |
|
3739 #ifdef IEEE_Arith |
|
3740 if ((word0(&u) & Exp_mask) == Exp_mask) |
|
3741 #else |
|
3742 if (word0(&u) == 0x8000) |
|
3743 #endif |
|
3744 { |
|
3745 /* Infinity or NaN */ |
|
3746 *decpt = 9999; |
|
3747 #ifdef IEEE_Arith |
|
3748 if (!word1(&u) && !(word0(&u) & 0xfffff)) |
|
3749 return nrv_alloc("Infinity", rve, 8); |
|
3750 #endif |
|
3751 return nrv_alloc("NaN", rve, 3); |
|
3752 } |
|
3753 #endif |
|
3754 #ifdef IBM |
|
3755 dval(&u) += 0; /* normalize */ |
|
3756 #endif |
|
3757 if (!dval(&u)) { |
|
3758 *decpt = 1; |
|
3759 return nrv_alloc("0", rve, 1); |
|
3760 } |
|
3761 |
|
3762 #ifdef SET_INEXACT |
|
3763 try_quick = oldinexact = get_inexact(); |
|
3764 inexact = 1; |
|
3765 #endif |
|
3766 #ifdef Honor_FLT_ROUNDS |
|
3767 if (Rounding >= 2) { |
|
3768 if (*sign) |
|
3769 Rounding = Rounding == 2 ? 0 : 2; |
|
3770 else |
|
3771 if (Rounding != 2) |
|
3772 Rounding = 0; |
|
3773 } |
|
3774 #endif |
|
3775 |
|
3776 b = d2b(&u, &be, &bbits); |
|
3777 #ifdef Sudden_Underflow |
|
3778 i = (int)(word0(&u) >> Exp_shift1 & (Exp_mask>>Exp_shift1)); |
|
3779 #else |
|
3780 if ((i = (int)(word0(&u) >> Exp_shift1 & (Exp_mask>>Exp_shift1)))) { |
|
3781 #endif |
|
3782 dval(&d2) = dval(&u); |
|
3783 word0(&d2) &= Frac_mask1; |
|
3784 word0(&d2) |= Exp_11; |
|
3785 #ifdef IBM |
|
3786 if (j = 11 - hi0bits(word0(&d2) & Frac_mask)) |
|
3787 dval(&d2) /= 1 << j; |
|
3788 #endif |
|
3789 |
|
3790 /* log(x) ~=~ log(1.5) + (x-1.5)/1.5 |
|
3791 * log10(x) = log(x) / log(10) |
|
3792 * ~=~ log(1.5)/log(10) + (x-1.5)/(1.5*log(10)) |
|
3793 * log10(d) = (i-Bias)*log(2)/log(10) + log10(d2) |
|
3794 * |
|
3795 * This suggests computing an approximation k to log10(d) by |
|
3796 * |
|
3797 * k = (i - Bias)*0.301029995663981 |
|
3798 * + ( (d2-1.5)*0.289529654602168 + 0.176091259055681 ); |
|
3799 * |
|
3800 * We want k to be too large rather than too small. |
|
3801 * The error in the first-order Taylor series approximation |
|
3802 * is in our favor, so we just round up the constant enough |
|
3803 * to compensate for any error in the multiplication of |
|
3804 * (i - Bias) by 0.301029995663981; since |i - Bias| <= 1077, |
|
3805 * and 1077 * 0.30103 * 2^-52 ~=~ 7.2e-14, |
|
3806 * adding 1e-13 to the constant term more than suffices. |
|
3807 * Hence we adjust the constant term to 0.1760912590558. |
|
3808 * (We could get a more accurate k by invoking log10, |
|
3809 * but this is probably not worthwhile.) |
|
3810 */ |
|
3811 |
|
3812 i -= Bias; |
|
3813 #ifdef IBM |
|
3814 i <<= 2; |
|
3815 i += j; |
|
3816 #endif |
|
3817 #ifndef Sudden_Underflow |
|
3818 denorm = 0; |
|
3819 } |
|
3820 else { |
|
3821 /* d is denormalized */ |
|
3822 |
|
3823 i = bbits + be + (Bias + (P-1) - 1); |
|
3824 x = i > 32 ? word0(&u) << (64 - i) | word1(&u) >> (i - 32) |
|
3825 : word1(&u) << (32 - i); |
|
3826 dval(&d2) = x; |
|
3827 word0(&d2) -= 31*Exp_msk1; /* adjust exponent */ |
|
3828 i -= (Bias + (P-1) - 1) + 1; |
|
3829 denorm = 1; |
|
3830 } |
|
3831 #endif |
|
3832 ds = (dval(&d2)-1.5)*0.289529654602168 + 0.1760912590558 + i*0.301029995663981; |
|
3833 k = (int)ds; |
|
3834 if (ds < 0. && ds != k) |
|
3835 k--; /* want k = floor(ds) */ |
|
3836 k_check = 1; |
|
3837 if (k >= 0 && k <= Ten_pmax) { |
|
3838 if (dval(&u) < tens[k]) |
|
3839 k--; |
|
3840 k_check = 0; |
|
3841 } |
|
3842 j = bbits - i - 1; |
|
3843 if (j >= 0) { |
|
3844 b2 = 0; |
|
3845 s2 = j; |
|
3846 } |
|
3847 else { |
|
3848 b2 = -j; |
|
3849 s2 = 0; |
|
3850 } |
|
3851 if (k >= 0) { |
|
3852 b5 = 0; |
|
3853 s5 = k; |
|
3854 s2 += k; |
|
3855 } |
|
3856 else { |
|
3857 b2 -= k; |
|
3858 b5 = -k; |
|
3859 s5 = 0; |
|
3860 } |
|
3861 if (mode < 0 || mode > 9) |
|
3862 mode = 0; |
|
3863 |
|
3864 #ifndef SET_INEXACT |
|
3865 #ifdef Check_FLT_ROUNDS |
|
3866 try_quick = Rounding == 1; |
|
3867 #else |
|
3868 try_quick = 1; |
|
3869 #endif |
|
3870 #endif /*SET_INEXACT*/ |
|
3871 |
|
3872 if (mode > 5) { |
|
3873 mode -= 4; |
|
3874 try_quick = 0; |
|
3875 } |
|
3876 leftright = 1; |
|
3877 ilim = ilim1 = -1; /* Values for cases 0 and 1; done here to */ |
|
3878 /* silence erroneous "gcc -Wall" warning. */ |
|
3879 switch(mode) { |
|
3880 case 0: |
|
3881 case 1: |
|
3882 i = 18; |
|
3883 ndigits = 0; |
|
3884 break; |
|
3885 case 2: |
|
3886 leftright = 0; |
|
3887 /* no break */ |
|
3888 case 4: |
|
3889 if (ndigits <= 0) |
|
3890 ndigits = 1; |
|
3891 ilim = ilim1 = i = ndigits; |
|
3892 break; |
|
3893 case 3: |
|
3894 leftright = 0; |
|
3895 /* no break */ |
|
3896 case 5: |
|
3897 i = ndigits + k + 1; |
|
3898 ilim = i; |
|
3899 ilim1 = i - 1; |
|
3900 if (i <= 0) |
|
3901 i = 1; |
|
3902 } |
|
3903 s = s0 = rv_alloc(i); |
|
3904 |
|
3905 #ifdef Honor_FLT_ROUNDS |
|
3906 if (mode > 1 && Rounding != 1) |
|
3907 leftright = 0; |
|
3908 #endif |
|
3909 |
|
3910 if (ilim >= 0 && ilim <= Quick_max && try_quick) { |
|
3911 |
|
3912 /* Try to get by with floating-point arithmetic. */ |
|
3913 |
|
3914 i = 0; |
|
3915 dval(&d2) = dval(&u); |
|
3916 k0 = k; |
|
3917 ilim0 = ilim; |
|
3918 ieps = 2; /* conservative */ |
|
3919 if (k > 0) { |
|
3920 ds = tens[k&0xf]; |
|
3921 j = k >> 4; |
|
3922 if (j & Bletch) { |
|
3923 /* prevent overflows */ |
|
3924 j &= Bletch - 1; |
|
3925 dval(&u) /= bigtens[n_bigtens-1]; |
|
3926 ieps++; |
|
3927 } |
|
3928 for(; j; j >>= 1, i++) |
|
3929 if (j & 1) { |
|
3930 ieps++; |
|
3931 ds *= bigtens[i]; |
|
3932 } |
|
3933 dval(&u) /= ds; |
|
3934 } |
|
3935 else if ((j1 = -k)) { |
|
3936 dval(&u) *= tens[j1 & 0xf]; |
|
3937 for(j = j1 >> 4; j; j >>= 1, i++) |
|
3938 if (j & 1) { |
|
3939 ieps++; |
|
3940 dval(&u) *= bigtens[i]; |
|
3941 } |
|
3942 } |
|
3943 if (k_check && dval(&u) < 1. && ilim > 0) { |
|
3944 if (ilim1 <= 0) |
|
3945 goto fast_failed; |
|
3946 ilim = ilim1; |
|
3947 k--; |
|
3948 dval(&u) *= 10.; |
|
3949 ieps++; |
|
3950 } |
|
3951 dval(&eps) = ieps*dval(&u) + 7.; |
|
3952 word0(&eps) -= (P-1)*Exp_msk1; |
|
3953 if (ilim == 0) { |
|
3954 S = mhi = 0; |
|
3955 dval(&u) -= 5.; |
|
3956 if (dval(&u) > dval(&eps)) |
|
3957 goto one_digit; |
|
3958 if (dval(&u) < -dval(&eps)) |
|
3959 goto no_digits; |
|
3960 goto fast_failed; |
|
3961 } |
|
3962 #ifndef No_leftright |
|
3963 if (leftright) { |
|
3964 /* Use Steele & White method of only |
|
3965 * generating digits needed. |
|
3966 */ |
|
3967 dval(&eps) = 0.5/tens[ilim-1] - dval(&eps); |
|
3968 #ifdef IEEE_Arith |
|
3969 if (k0 < 0 && j1 >= 307) { |
|
3970 eps1.d = 1.01e256; /* 1.01 allows roundoff in the next few lines */ |
|
3971 word0(&eps1) -= Exp_msk1 * (Bias+P-1); |
|
3972 dval(&eps1) *= tens[j1 & 0xf]; |
|
3973 for(i = 0, j = (j1-256) >> 4; j; j >>= 1, i++) |
|
3974 if (j & 1) |
|
3975 dval(&eps1) *= bigtens[i]; |
|
3976 if (eps.d < eps1.d) |
|
3977 eps.d = eps1.d; |
|
3978 } |
|
3979 #endif |
|
3980 for(i = 0;;) { |
|
3981 L = dval(&u); |
|
3982 dval(&u) -= L; |
|
3983 *s++ = '0' + (int)L; |
|
3984 if (1. - dval(&u) < dval(&eps)) |
|
3985 goto bump_up; |
|
3986 if (dval(&u) < dval(&eps)) |
|
3987 goto ret1; |
|
3988 if (++i >= ilim) |
|
3989 break; |
|
3990 dval(&eps) *= 10.; |
|
3991 dval(&u) *= 10.; |
|
3992 } |
|
3993 } |
|
3994 else { |
|
3995 #endif |
|
3996 /* Generate ilim digits, then fix them up. */ |
|
3997 dval(&eps) *= tens[ilim-1]; |
|
3998 for(i = 1;; i++, dval(&u) *= 10.) { |
|
3999 L = (Long)(dval(&u)); |
|
4000 if (!(dval(&u) -= L)) |
|
4001 ilim = i; |
|
4002 *s++ = '0' + (int)L; |
|
4003 if (i == ilim) { |
|
4004 if (dval(&u) > 0.5 + dval(&eps)) |
|
4005 goto bump_up; |
|
4006 else if (dval(&u) < 0.5 - dval(&eps)) { |
|
4007 while(*--s == '0'); |
|
4008 s++; |
|
4009 goto ret1; |
|
4010 } |
|
4011 break; |
|
4012 } |
|
4013 } |
|
4014 #ifndef No_leftright |
|
4015 } |
|
4016 #endif |
|
4017 fast_failed: |
|
4018 s = s0; |
|
4019 dval(&u) = dval(&d2); |
|
4020 k = k0; |
|
4021 ilim = ilim0; |
|
4022 } |
|
4023 |
|
4024 /* Do we have a "small" integer? */ |
|
4025 |
|
4026 if (be >= 0 && k <= Int_max) { |
|
4027 /* Yes. */ |
|
4028 ds = tens[k]; |
|
4029 if (ndigits < 0 && ilim <= 0) { |
|
4030 S = mhi = 0; |
|
4031 if (ilim < 0 || dval(&u) <= 5*ds) |
|
4032 goto no_digits; |
|
4033 goto one_digit; |
|
4034 } |
|
4035 for(i = 1;; i++, dval(&u) *= 10.) { |
|
4036 L = (Long)(dval(&u) / ds); |
|
4037 dval(&u) -= L*ds; |
|
4038 #ifdef Check_FLT_ROUNDS |
|
4039 /* If FLT_ROUNDS == 2, L will usually be high by 1 */ |
|
4040 if (dval(&u) < 0) { |
|
4041 L--; |
|
4042 dval(&u) += ds; |
|
4043 } |
|
4044 #endif |
|
4045 *s++ = '0' + (int)L; |
|
4046 if (!dval(&u)) { |
|
4047 #ifdef SET_INEXACT |
|
4048 inexact = 0; |
|
4049 #endif |
|
4050 break; |
|
4051 } |
|
4052 if (i == ilim) { |
|
4053 #ifdef Honor_FLT_ROUNDS |
|
4054 if (mode > 1) |
|
4055 switch(Rounding) { |
|
4056 case 0: goto ret1; |
|
4057 case 2: goto bump_up; |
|
4058 } |
|
4059 #endif |
|
4060 dval(&u) += dval(&u); |
|
4061 #ifdef ROUND_BIASED |
|
4062 if (dval(&u) >= ds) |
|
4063 #else |
|
4064 if (dval(&u) > ds || (dval(&u) == ds && L & 1)) |
|
4065 #endif |
|
4066 { |
|
4067 bump_up: |
|
4068 while(*--s == '9') |
|
4069 if (s == s0) { |
|
4070 k++; |
|
4071 *s = '0'; |
|
4072 break; |
|
4073 } |
|
4074 ++*s++; |
|
4075 } |
|
4076 break; |
|
4077 } |
|
4078 } |
|
4079 goto ret1; |
|
4080 } |
|
4081 |
|
4082 m2 = b2; |
|
4083 m5 = b5; |
|
4084 mhi = mlo = 0; |
|
4085 if (leftright) { |
|
4086 i = |
|
4087 #ifndef Sudden_Underflow |
|
4088 denorm ? be + (Bias + (P-1) - 1 + 1) : |
|
4089 #endif |
|
4090 #ifdef IBM |
|
4091 1 + 4*P - 3 - bbits + ((bbits + be - 1) & 3); |
|
4092 #else |
|
4093 1 + P - bbits; |
|
4094 #endif |
|
4095 b2 += i; |
|
4096 s2 += i; |
|
4097 mhi = i2b(1); |
|
4098 } |
|
4099 if (m2 > 0 && s2 > 0) { |
|
4100 i = m2 < s2 ? m2 : s2; |
|
4101 b2 -= i; |
|
4102 m2 -= i; |
|
4103 s2 -= i; |
|
4104 } |
|
4105 if (b5 > 0) { |
|
4106 if (leftright) { |
|
4107 if (m5 > 0) { |
|
4108 mhi = pow5mult(mhi, m5); |
|
4109 b1 = mult(mhi, b); |
|
4110 Bfree(b); |
|
4111 b = b1; |
|
4112 } |
|
4113 if ((j = b5 - m5)) |
|
4114 b = pow5mult(b, j); |
|
4115 } |
|
4116 else |
|
4117 b = pow5mult(b, b5); |
|
4118 } |
|
4119 S = i2b(1); |
|
4120 if (s5 > 0) |
|
4121 S = pow5mult(S, s5); |
|
4122 |
|
4123 /* Check for special case that d is a normalized power of 2. */ |
|
4124 |
|
4125 spec_case = 0; |
|
4126 if ((mode < 2 || leftright) |
|
4127 #ifdef Honor_FLT_ROUNDS |
|
4128 && Rounding == 1 |
|
4129 #endif |
|
4130 ) { |
|
4131 if (!word1(&u) && !(word0(&u) & Bndry_mask) |
|
4132 #ifndef Sudden_Underflow |
|
4133 && word0(&u) & (Exp_mask & ~Exp_msk1) |
|
4134 #endif |
|
4135 ) { |
|
4136 /* The special case */ |
|
4137 b2 += Log2P; |
|
4138 s2 += Log2P; |
|
4139 spec_case = 1; |
|
4140 } |
|
4141 } |
|
4142 |
|
4143 /* Arrange for convenient computation of quotients: |
|
4144 * shift left if necessary so divisor has 4 leading 0 bits. |
|
4145 * |
|
4146 * Perhaps we should just compute leading 28 bits of S once |
|
4147 * and for all and pass them and a shift to quorem, so it |
|
4148 * can do shifts and ors to compute the numerator for q. |
|
4149 */ |
|
4150 i = dshift(S, s2); |
|
4151 b2 += i; |
|
4152 m2 += i; |
|
4153 s2 += i; |
|
4154 if (b2 > 0) |
|
4155 b = lshift(b, b2); |
|
4156 if (s2 > 0) |
|
4157 S = lshift(S, s2); |
|
4158 if (k_check) { |
|
4159 if (cmp(b,S) < 0) { |
|
4160 k--; |
|
4161 b = multadd(b, 10, 0); /* we botched the k estimate */ |
|
4162 if (leftright) |
|
4163 mhi = multadd(mhi, 10, 0); |
|
4164 ilim = ilim1; |
|
4165 } |
|
4166 } |
|
4167 if (ilim <= 0 && (mode == 3 || mode == 5)) { |
|
4168 if (ilim < 0 || cmp(b,S = multadd(S,5,0)) <= 0) { |
|
4169 /* no digits, fcvt style */ |
|
4170 no_digits: |
|
4171 k = -1 - ndigits; |
|
4172 goto ret; |
|
4173 } |
|
4174 one_digit: |
|
4175 *s++ = '1'; |
|
4176 k++; |
|
4177 goto ret; |
|
4178 } |
|
4179 if (leftright) { |
|
4180 if (m2 > 0) |
|
4181 mhi = lshift(mhi, m2); |
|
4182 |
|
4183 /* Compute mlo -- check for special case |
|
4184 * that d is a normalized power of 2. |
|
4185 */ |
|
4186 |
|
4187 mlo = mhi; |
|
4188 if (spec_case) { |
|
4189 mhi = Balloc(mhi->k); |
|
4190 Bcopy(mhi, mlo); |
|
4191 mhi = lshift(mhi, Log2P); |
|
4192 } |
|
4193 |
|
4194 for(i = 1;;i++) { |
|
4195 dig = quorem(b,S) + '0'; |
|
4196 /* Do we yet have the shortest decimal string |
|
4197 * that will round to d? |
|
4198 */ |
|
4199 j = cmp(b, mlo); |
|
4200 delta = diff(S, mhi); |
|
4201 j1 = delta->sign ? 1 : cmp(b, delta); |
|
4202 Bfree(delta); |
|
4203 #ifndef ROUND_BIASED |
|
4204 if (j1 == 0 && mode != 1 && !(word1(&u) & 1) |
|
4205 #ifdef Honor_FLT_ROUNDS |
|
4206 && Rounding >= 1 |
|
4207 #endif |
|
4208 ) { |
|
4209 if (dig == '9') |
|
4210 goto round_9_up; |
|
4211 if (j > 0) |
|
4212 dig++; |
|
4213 #ifdef SET_INEXACT |
|
4214 else if (!b->x[0] && b->wds <= 1) |
|
4215 inexact = 0; |
|
4216 #endif |
|
4217 *s++ = dig; |
|
4218 goto ret; |
|
4219 } |
|
4220 #endif |
|
4221 if (j < 0 || (j == 0 && mode != 1 |
|
4222 #ifndef ROUND_BIASED |
|
4223 && !(word1(&u) & 1) |
|
4224 #endif |
|
4225 )) { |
|
4226 if (!b->x[0] && b->wds <= 1) { |
|
4227 #ifdef SET_INEXACT |
|
4228 inexact = 0; |
|
4229 #endif |
|
4230 goto accept_dig; |
|
4231 } |
|
4232 #ifdef Honor_FLT_ROUNDS |
|
4233 if (mode > 1) |
|
4234 switch(Rounding) { |
|
4235 case 0: goto accept_dig; |
|
4236 case 2: goto keep_dig; |
|
4237 } |
|
4238 #endif /*Honor_FLT_ROUNDS*/ |
|
4239 if (j1 > 0) { |
|
4240 b = lshift(b, 1); |
|
4241 j1 = cmp(b, S); |
|
4242 #ifdef ROUND_BIASED |
|
4243 if (j1 >= 0 /*)*/ |
|
4244 #else |
|
4245 if ((j1 > 0 || (j1 == 0 && dig & 1)) |
|
4246 #endif |
|
4247 && dig++ == '9') |
|
4248 goto round_9_up; |
|
4249 } |
|
4250 accept_dig: |
|
4251 *s++ = dig; |
|
4252 goto ret; |
|
4253 } |
|
4254 if (j1 > 0) { |
|
4255 #ifdef Honor_FLT_ROUNDS |
|
4256 if (!Rounding) |
|
4257 goto accept_dig; |
|
4258 #endif |
|
4259 if (dig == '9') { /* possible if i == 1 */ |
|
4260 round_9_up: |
|
4261 *s++ = '9'; |
|
4262 goto roundoff; |
|
4263 } |
|
4264 *s++ = dig + 1; |
|
4265 goto ret; |
|
4266 } |
|
4267 #ifdef Honor_FLT_ROUNDS |
|
4268 keep_dig: |
|
4269 #endif |
|
4270 *s++ = dig; |
|
4271 if (i == ilim) |
|
4272 break; |
|
4273 b = multadd(b, 10, 0); |
|
4274 if (mlo == mhi) |
|
4275 mlo = mhi = multadd(mhi, 10, 0); |
|
4276 else { |
|
4277 mlo = multadd(mlo, 10, 0); |
|
4278 mhi = multadd(mhi, 10, 0); |
|
4279 } |
|
4280 } |
|
4281 } |
|
4282 else |
|
4283 for(i = 1;; i++) { |
|
4284 *s++ = dig = quorem(b,S) + '0'; |
|
4285 if (!b->x[0] && b->wds <= 1) { |
|
4286 #ifdef SET_INEXACT |
|
4287 inexact = 0; |
|
4288 #endif |
|
4289 goto ret; |
|
4290 } |
|
4291 if (i >= ilim) |
|
4292 break; |
|
4293 b = multadd(b, 10, 0); |
|
4294 } |
|
4295 |
|
4296 /* Round off last digit */ |
|
4297 |
|
4298 #ifdef Honor_FLT_ROUNDS |
|
4299 switch(Rounding) { |
|
4300 case 0: goto trimzeros; |
|
4301 case 2: goto roundoff; |
|
4302 } |
|
4303 #endif |
|
4304 b = lshift(b, 1); |
|
4305 j = cmp(b, S); |
|
4306 #ifdef ROUND_BIASED |
|
4307 if (j >= 0) |
|
4308 #else |
|
4309 if (j > 0 || (j == 0 && dig & 1)) |
|
4310 #endif |
|
4311 { |
|
4312 roundoff: |
|
4313 while(*--s == '9') |
|
4314 if (s == s0) { |
|
4315 k++; |
|
4316 *s++ = '1'; |
|
4317 goto ret; |
|
4318 } |
|
4319 ++*s++; |
|
4320 } |
|
4321 else { |
|
4322 #ifdef Honor_FLT_ROUNDS |
|
4323 trimzeros: |
|
4324 #endif |
|
4325 while(*--s == '0'); |
|
4326 s++; |
|
4327 } |
|
4328 ret: |
|
4329 Bfree(S); |
|
4330 if (mhi) { |
|
4331 if (mlo && mlo != mhi) |
|
4332 Bfree(mlo); |
|
4333 Bfree(mhi); |
|
4334 } |
|
4335 ret1: |
|
4336 #ifdef SET_INEXACT |
|
4337 if (inexact) { |
|
4338 if (!oldinexact) { |
|
4339 word0(&u) = Exp_1 + (70 << Exp_shift); |
|
4340 word1(&u) = 0; |
|
4341 dval(&u) += 1.; |
|
4342 } |
|
4343 } |
|
4344 else if (!oldinexact) |
|
4345 clear_inexact(); |
|
4346 #endif |
|
4347 Bfree(b); |
|
4348 *s = 0; |
|
4349 *decpt = k + 1; |
|
4350 if (rve) |
|
4351 *rve = s; |
|
4352 return s0; |
|
4353 } |
|
4354 #ifdef __cplusplus |
|
4355 } |
|
4356 #endif |