security/sandbox/chromium/base/third_party/dmg_fp/dtoa.cc

Fri, 16 Jan 2015 04:50:19 +0100

author
Michael Schloh von Bennewitz <michael@schloh.com>
date
Fri, 16 Jan 2015 04:50:19 +0100
branch
TOR_BUG_9701
changeset 13
44a2da4a2ab2
permissions
-rw-r--r--

Replace accessor implementation with direct member state manipulation, by
request https://trac.torproject.org/projects/tor/ticket/9701#comment:32

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

mercurial