numeric.c

   1 /*    numeric.c
   2  *
   3  *    Copyright (c) 2001, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * "That only makes eleven (plus one mislaid) and not fourteen, unless
  12  * wizards count differently to other people."
  13  */
  14
  15 #include "EXTERN.h"
  16 #define PERL_IN_NUMERIC_C
  17 #include "perl.h"
  18
  19 U32
  20 Perl_cast_ulong(pTHX_ NV f)
  21 {
  22   if (f < 0.0)
  23     return f < I32_MIN ? (U32) I32_MIN : (U32)(I32) f;
  24   if (f < U32_MAX_P1) {
  25 #if CASTFLAGS & 2
  26     if (f < U32_MAX_P1_HALF)
  27       return (U32) f;
  28     f -= U32_MAX_P1_HALF;
  29     return ((U32) f) | (1 + U32_MAX >> 1);
  30 #else
  31     return (U32) f;
  32 #endif
  33   }
  34   return f > 0 ? U32_MAX : 0 /* NaN */;
  35 }
  36
  37 I32
  38 Perl_cast_i32(pTHX_ NV f)
  39 {
  40   if (f < I32_MAX_P1)
  41     return f < I32_MIN ? I32_MIN : (I32) f;
  42   if (f < U32_MAX_P1) {
  43 #if CASTFLAGS & 2
  44     if (f < U32_MAX_P1_HALF)
  45       return (I32)(U32) f;
  46     f -= U32_MAX_P1_HALF;
  47     return (I32)(((U32) f) | (1 + U32_MAX >> 1));
  48 #else
  49     return (I32)(U32) f;
  50 #endif
  51   }
  52   return f > 0 ? (I32)U32_MAX : 0 /* NaN */;
  53 }
  54
  55 IV
  56 Perl_cast_iv(pTHX_ NV f)
  57 {
  58   if (f < IV_MAX_P1)
  59     return f < IV_MIN ? IV_MIN : (IV) f;
  60   if (f < UV_MAX_P1) {
  61 #if CASTFLAGS & 2
  62     /* For future flexibility allowing for sizeof(UV) >= sizeof(IV)  */
  63     if (f < UV_MAX_P1_HALF)
  64       return (IV)(UV) f;
  65     f -= UV_MAX_P1_HALF;
  66     return (IV)(((UV) f) | (1 + UV_MAX >> 1));
  67 #else
  68     return (IV)(UV) f;
  69 #endif
  70   }
  71   return f > 0 ? (IV)UV_MAX : 0 /* NaN */;
  72 }
  73
  74 UV
  75 Perl_cast_uv(pTHX_ NV f)
  76 {
  77   if (f < 0.0)
  78     return f < IV_MIN ? (UV) IV_MIN : (UV)(IV) f;
  79   if (f < UV_MAX_P1) {
  80 #if CASTFLAGS & 2
  81     if (f < UV_MAX_P1_HALF)
  82       return (UV) f;
  83     f -= UV_MAX_P1_HALF;
  84     return ((UV) f) | (1 + UV_MAX >> 1);
  85 #else
  86     return (UV) f;
  87 #endif
  88   }
  89   return f > 0 ? UV_MAX : 0 /* NaN */;
  90 }
  91
  92 #if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL))
  93 /*
  94  * This hack is to force load of "huge" support from libm.a
  95  * So it is in perl for (say) POSIX to use.
  96  * Needed for SunOS with Sun's 'acc' for example.
  97  */
  98 NV
  99 Perl_huge(void)
 100 {
 101 #   if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)
 102     return HUGE_VALL;
 103 #   endif
 104     return HUGE_VAL;
 105 }
 106 #endif
 107
 108 NV
 109 Perl_scan_bin(pTHX_ char *start, STRLEN len, STRLEN *retlen)
 110 {
 111     register char *s = start;
 112     register NV rnv = 0.0;
 113     register UV ruv = 0;
 114     register bool seenb = FALSE;
 115     register bool overflowed = FALSE;
 116
 117     for (; len-- && *s; s++) {
 118         if (!(*s == '0' || *s == '1')) {
 119             if (*s == '_' && len && *retlen
 120                 && (s[1] == '0' || s[1] == '1'))
 121             {
 122                 --len;
 123                 ++s;
 124             }
 125             else if (seenb == FALSE && *s == 'b' && ruv == 0) {
 126                 /* Disallow 0bbb0b0bbb... */
 127                 seenb = TRUE;
 128                 continue;
 129             }
 130             else {
 131                 if (ckWARN(WARN_DIGIT))
 132                     Perl_warner(aTHX_ WARN_DIGIT,
 133                                 "Illegal binary digit '%c' ignored", *s);
 134                 break;
 135             }
 136         }
 137         if (!overflowed) {
 138             register UV xuv = ruv << 1;
 139
 140             if ((xuv >> 1) != ruv) {
 141                 overflowed = TRUE;
 142                 rnv = (NV) ruv;
 143                 if (ckWARN_d(WARN_OVERFLOW))
 144                     Perl_warner(aTHX_ WARN_OVERFLOW,
 145                                 "Integer overflow in binary number");
 146             }
 147             else
 148                 ruv = xuv | (*s - '0');
 149         }
 150         if (overflowed) {
 151             rnv *= 2;
 152             /* If an NV has not enough bits in its mantissa to
 153              * represent an UV this summing of small low-order numbers
 154              * is a waste of time (because the NV cannot preserve
 155              * the low-order bits anyway): we could just remember when
 156              * did we overflow and in the end just multiply rnv by the
 157              * right amount. */
 158             rnv += (*s - '0');
 159         }
 160     }
 161     if (!overflowed)
 162         rnv = (NV) ruv;
 163     if (   ( overflowed && rnv > 4294967295.0)
 164 #if UVSIZE > 4
 165         || (!overflowed && ruv > 0xffffffff  )
 166 #endif
 167         ) {
 168         if (ckWARN(WARN_PORTABLE))
 169             Perl_warner(aTHX_ WARN_PORTABLE,
 170                         "Binary number > 0b11111111111111111111111111111111 non-portable");
 171     }
 172     *retlen = s - start;
 173     return rnv;
 174 }
 175
 176 NV
 177 Perl_scan_oct(pTHX_ char *start, STRLEN len, STRLEN *retlen)
 178 {
 179     register char *s = start;
 180     register NV rnv = 0.0;
 181     register UV ruv = 0;
 182     register bool overflowed = FALSE;
 183
 184     for (; len-- && *s; s++) {
 185         if (!(*s >= '0' && *s <= '7')) {
 186             if (*s == '_' && len && *retlen
 187                 && (s[1] >= '0' && s[1] <= '7'))
 188             {
 189                 --len;
 190                 ++s;
 191             }
 192             else {
 193                 /* Allow \octal to work the DWIM way (that is, stop scanning
 194                  * as soon as non-octal characters are seen, complain only iff
 195                  * someone seems to want to use the digits eight and nine). */
 196                 if (*s == '8' || *s == '9') {
 197                     if (ckWARN(WARN_DIGIT))
 198                         Perl_warner(aTHX_ WARN_DIGIT,
 199                                     "Illegal octal digit '%c' ignored", *s);
 200                 }
 201                 break;
 202             }
 203         }
 204         if (!overflowed) {
 205             register UV xuv = ruv << 3;
 206
 207             if ((xuv >> 3) != ruv) {
 208                 overflowed = TRUE;
 209                 rnv = (NV) ruv;
 210                 if (ckWARN_d(WARN_OVERFLOW))
 211                     Perl_warner(aTHX_ WARN_OVERFLOW,
 212                                 "Integer overflow in octal number");
 213             }
 214             else
 215                 ruv = xuv | (*s - '0');
 216         }
 217         if (overflowed) {
 218             rnv *= 8.0;
 219             /* If an NV has not enough bits in its mantissa to
 220              * represent an UV this summing of small low-order numbers
 221              * is a waste of time (because the NV cannot preserve
 222              * the low-order bits anyway): we could just remember when
 223              * did we overflow and in the end just multiply rnv by the
 224              * right amount of 8-tuples. */
 225             rnv += (NV)(*s - '0');
 226         }
 227     }
 228     if (!overflowed)
 229         rnv = (NV) ruv;
 230     if (   ( overflowed && rnv > 4294967295.0)
 231 #if UVSIZE > 4
 232         || (!overflowed && ruv > 0xffffffff  )
 233 #endif
 234         ) {
 235         if (ckWARN(WARN_PORTABLE))
 236             Perl_warner(aTHX_ WARN_PORTABLE,
 237                         "Octal number > 037777777777 non-portable");
 238     }
 239     *retlen = s - start;
 240     return rnv;
 241 }
 242
 243 NV
 244 Perl_scan_hex(pTHX_ char *start, STRLEN len, STRLEN *retlen)
 245 {
 246     register char *s = start;
 247     register NV rnv = 0.0;
 248     register UV ruv = 0;
 249     register bool overflowed = FALSE;
 250     char *hexdigit;
 251
 252     if (len > 2) {
 253         if (s[0] == 'x') {
 254             s++;
 255             len--;
 256         }
 257         else if (len > 3 && s[0] == '0' && s[1] == 'x') {
 258             s+=2;
 259             len-=2;
 260         }
 261     }
 262
 263     for (; len-- && *s; s++) {
 264         hexdigit = strchr((char *) PL_hexdigit, *s);
 265         if (!hexdigit) {
 266             if (*s == '_' && len && *retlen && s[1]
 267                 && (hexdigit = strchr((char *) PL_hexdigit, s[1])))
 268             {
 269                 --len;
 270                 ++s;
 271             }
 272             else {
 273                 if (ckWARN(WARN_DIGIT))
 274                     Perl_warner(aTHX_ WARN_DIGIT,
 275                                 "Illegal hexadecimal digit '%c' ignored", *s);
 276                 break;
 277             }
 278         }
 279         if (!overflowed) {
 280             register UV xuv = ruv << 4;
 281
 282             if ((xuv >> 4) != ruv) {
 283                 overflowed = TRUE;
 284                 rnv = (NV) ruv;
 285                 if (ckWARN_d(WARN_OVERFLOW))
 286                     Perl_warner(aTHX_ WARN_OVERFLOW,
 287                                 "Integer overflow in hexadecimal number");
 288             }
 289             else
 290                 ruv = xuv | ((hexdigit - PL_hexdigit) & 15);
 291         }
 292         if (overflowed) {
 293             rnv *= 16.0;
 294             /* If an NV has not enough bits in its mantissa to
 295              * represent an UV this summing of small low-order numbers
 296              * is a waste of time (because the NV cannot preserve
 297              * the low-order bits anyway): we could just remember when
 298              * did we overflow and in the end just multiply rnv by the
 299              * right amount of 16-tuples. */
 300             rnv += (NV)((hexdigit - PL_hexdigit) & 15);
 301         }
 302     }
 303     if (!overflowed)
 304         rnv = (NV) ruv;
 305     if (   ( overflowed && rnv > 4294967295.0)
 306 #if UVSIZE > 4
 307         || (!overflowed && ruv > 0xffffffff  )
 308 #endif
 309         ) {
 310         if (ckWARN(WARN_PORTABLE))
 311             Perl_warner(aTHX_ WARN_PORTABLE,
 312                         "Hexadecimal number > 0xffffffff non-portable");
 313     }
 314     *retlen = s - start;
 315     return rnv;
 316 }
 317
 318 /*
 319 =for apidoc grok_numeric_radix
 320
 321 Scan and skip for a numeric decimal separator (radix).
 322
 323 =cut
 324  */
 325 bool
 326 Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send)
 327 {
 328 #ifdef USE_LOCALE_NUMERIC
 329     if (PL_numeric_radix_sv && IN_LOCALE) {
 330         STRLEN len;
 331         char* radix = SvPV(PL_numeric_radix_sv, len);
 332         if (*sp + len <= send && memEQ(*sp, radix, len)) {
 333             *sp += len;
 334             return TRUE;
 335         }
 336     }
 337     /* always try "." if numeric radix didn't match because
 338      * we may have data from different locales mixed */
 339 #endif
 340     if (*sp < send && **sp == '.') {
 341         ++*sp;
 342         return TRUE;
 343     }
 344     return FALSE;
 345 }
 346
 347 /*
 348 =for apidoc grok_number
 349
 350 Recognise (or not) a number.  The type of the number is returned
 351 (0 if unrecognised), otherwise it is a bit-ORed combination of
 352 IS_NUMBER_IN_UV, IS_NUMBER_GREATER_THAN_UV_MAX, IS_NUMBER_NOT_INT,
 353 IS_NUMBER_NEG, IS_NUMBER_INFINITY, IS_NUMBER_NAN (defined in perl.h).
 354
 355 If the value of the number can fit an in UV, it is returned in the *valuep
 356 IS_NUMBER_IN_UV will be set to indicate that *valuep is valid, IS_NUMBER_IN_UV
 357 will never be set unless *valuep is valid, but *valuep may have been assigned
 358 to during processing even though IS_NUMBER_IN_UV is not set on return.
 359 If valuep is NULL, IS_NUMBER_IN_UV will be set for the same cases as when
 360 valuep is non-NULL, but no actual assignment (or SEGV) will occur.
 361
 362 IS_NUMBER_NOT_INT will be set with IS_NUMBER_IN_UV if trailing decimals were
 363 seen (in which case *valuep gives the true value truncated to an integer), and
 364 IS_NUMBER_NEG if the number is negative (in which case *valuep holds the
 365 absolute value).  IS_NUMBER_IN_UV is not set if e notation was used or the
 366 number is larger than a UV.
 367
 368 =cut
 369  */
 370 int
 371 Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
 372 {
 373   const char *s = pv;
 374   const char *send = pv + len;
 375   const UV max_div_10 = UV_MAX / 10;
 376   const char max_mod_10 = UV_MAX % 10;
 377   int numtype = 0;
 378   int sawinf = 0;
 379   int sawnan = 0;
 380
 381   while (s < send && isSPACE(*s))
 382     s++;
 383   if (s == send) {
 384     return 0;
 385   } else if (*s == '-') {
 386     s++;
 387     numtype = IS_NUMBER_NEG;
 388   }
 389   else if (*s == '+')
 390   s++;
 391
 392   if (s == send)
 393     return 0;
 394
 395   /* next must be digit or the radix separator or beginning of infinity */
 396   if (isDIGIT(*s)) {
 397     /* UVs are at least 32 bits, so the first 9 decimal digits cannot
 398        overflow.  */
 399     UV value = *s - '0';
 400     /* This construction seems to be more optimiser friendly.
 401        (without it gcc does the isDIGIT test and the *s - '0' separately)
 402        With it gcc on arm is managing 6 instructions (6 cycles) per digit.
 403        In theory the optimiser could deduce how far to unroll the loop
 404        before checking for overflow.  */
 405     if (++s < send) {
 406       int digit = *s - '0';
 407       if (digit >= 0 && digit <= 9) {
 408         value = value * 10 + digit;
 409         if (++s < send) {
 410           digit = *s - '0';
 411           if (digit >= 0 && digit <= 9) {
 412             value = value * 10 + digit;
 413             if (++s < send) {
 414               digit = *s - '0';
 415               if (digit >= 0 && digit <= 9) {
 416                 value = value * 10 + digit;
 417                 if (++s < send) {
 418                   digit = *s - '0';
 419                   if (digit >= 0 && digit <= 9) {
 420                     value = value * 10 + digit;
 421                     if (++s < send) {
 422                       digit = *s - '0';
 423                       if (digit >= 0 && digit <= 9) {
 424                         value = value * 10 + digit;
 425                         if (++s < send) {
 426                           digit = *s - '0';
 427                           if (digit >= 0 && digit <= 9) {
 428                             value = value * 10 + digit;
 429                             if (++s < send) {
 430                               digit = *s - '0';
 431                               if (digit >= 0 && digit <= 9) {
 432                                 value = value * 10 + digit;
 433                                 if (++s < send) {
 434                                   digit = *s - '0';
 435                                   if (digit >= 0 && digit <= 9) {
 436                                     value = value * 10 + digit;
 437                                     if (++s < send) {
 438                                       /* Now got 9 digits, so need to check
 439                                          each time for overflow.  */
 440                                       digit = *s - '0';
 441                                       while (digit >= 0 && digit <= 9
 442                                              && (value < max_div_10
 443                                                  || (value == max_div_10
 444                                                      && digit <= max_mod_10))) {
 445                                         value = value * 10 + digit;
 446                                         if (++s < send)
 447                                           digit = *s - '0';
 448                                         else
 449                                           break;
 450                                       }
 451                                       if (digit >= 0 && digit <= 9
 452                                           && (s < send)) {
 453                                         /* value overflowed.
 454                                            skip the remaining digits, don't
 455                                            worry about setting *valuep.  */
 456                                         do {
 457                                           s++;
 458                                         } while (s < send && isDIGIT(*s));
 459                                         numtype |=
 460                                           IS_NUMBER_GREATER_THAN_UV_MAX;
 461                                         goto skip_value;
 462                                       }
 463                                     }
 464                                   }
 465                                 }
 466                               }
 467                             }
 468                           }
 469                         }
 470                       }
 471                     }
 472                   }
 473                 }
 474               }
 475             }
 476           }
 477         }
 478       }
 479     }
 480     numtype |= IS_NUMBER_IN_UV;
 481     if (valuep)
 482       *valuep = value;
 483
 484   skip_value:
 485     if (GROK_NUMERIC_RADIX(&s, send)) {
 486       numtype |= IS_NUMBER_NOT_INT;
 487       while (s < send && isDIGIT(*s))  /* optional digits after the radix */
 488         s++;
 489     }
 490   }
 491   else if (GROK_NUMERIC_RADIX(&s, send)) {
 492     numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
 493     /* no digits before the radix means we need digits after it */
 494     if (s < send && isDIGIT(*s)) {
 495       do {
 496         s++;
 497       } while (s < send && isDIGIT(*s));
 498       if (valuep) {
 499         /* integer approximation is valid - it's 0.  */
 500         *valuep = 0;
 501       }
 502     }
 503     else
 504       return 0;
 505   } else if (*s == 'I' || *s == 'i') {
 506     s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
 507     s++; if (s == send || (*s != 'F' && *s != 'f')) return 0;
 508     s++; if (s < send && (*s == 'I' || *s == 'i')) {
 509       s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
 510       s++; if (s == send || (*s != 'I' && *s != 'i')) return 0;
 511       s++; if (s == send || (*s != 'T' && *s != 't')) return 0;
 512       s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0;
 513       s++;
 514     }
 515     sawinf = 1;
 516   } else if (*s == 'N' || *s == 'n') {
 517     /* XXX TODO: There are signaling NaNs and quiet NaNs. */
 518     s++; if (s == send || (*s != 'A' && *s != 'a')) return 0;
 519     s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
 520     s++;
 521     sawnan = 1;
 522   } else
 523     return 0;
 524
 525   if (sawinf) {
 526     numtype &= IS_NUMBER_NEG; /* Keep track of sign  */
 527     numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
 528   } else if (sawnan) {
 529     numtype &= IS_NUMBER_NEG; /* Keep track of sign  */
 530     numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
 531   } else if (s < send) {
 532     /* we can have an optional exponent part */
 533     if (*s == 'e' || *s == 'E') {
 534       /* The only flag we keep is sign.  Blow away any "it's UV"  */
 535       numtype &= IS_NUMBER_NEG;
 536       numtype |= IS_NUMBER_NOT_INT;
 537       s++;
 538       if (s < send && (*s == '-' || *s == '+'))
 539         s++;
 540       if (s < send && isDIGIT(*s)) {
 541         do {
 542           s++;
 543         } while (s < send && isDIGIT(*s));
 544       }
 545       else
 546       return 0;
 547     }
 548   }
 549   while (s < send && isSPACE(*s))
 550     s++;
 551   if (s >= send)
 552     return numtype;
 553   if (len == 10 && memEQ(pv, "0 but true", 10)) {
 554     if (valuep)
 555       *valuep = 0;
 556     return IS_NUMBER_IN_UV;
 557   }
 558   return 0;
 559 }
 560
 561 NV
 562 S_mulexp10(NV value, I32 exponent)
 563 {
 564     NV result = 1.0;
 565     NV power = 10.0;
 566     bool negative = 0;
 567     I32 bit;
 568
 569     if (exponent == 0)
 570         return value;
 571     else if (exponent < 0) {
 572         negative = 1;
 573         exponent = -exponent;
 574     }
 575
 576     /* On OpenVMS VAX we by default use the D_FLOAT double format,
 577      * and that format does not have *easy* capabilities [1] for
 578      * overflowing doubles 'silently' as IEEE fp does.  We also need
 579      * to support G_FLOAT on both VAX and Alpha, and though the exponent
 580      * range is much larger than D_FLOAT it still doesn't do silent
 581      * overflow.  Therefore we need to detect early whether we would
 582      * overflow (this is the behaviour of the native string-to-float
 583      * conversion routines, and therefore of native applications, too).
 584      *
 585      * [1] Trying to establish a condition handler to trap floating point
 586      *     exceptions is not a good idea. */
 587 #if defined(VMS) && !defined(__IEEE_FP) && defined(NV_MAX_10_EXP)
 588     if (!negative &&
 589         (log10(value) + exponent) >= (NV_MAX_10_EXP))
 590         return NV_MAX;
 591 #endif
 592
 593     /* In UNICOS and in certain Cray models (such as T90) there is no
 594      * IEEE fp, and no way at all from C to catch fp overflows gracefully.
 595      * There is something you can do if you are willing to use some
 596      * inline assembler: the instruction is called DFI-- but that will
 597      * disable *all* floating point interrupts, a little bit too large
 598      * a hammer.  Therefore we need to catch potential overflows before
 599      * it's too late. */
 600 #if defined(_UNICOS) && defined(NV_MAX_10_EXP)
 601     if (!negative &&
 602         (log10(value) + exponent) >= NV_MAX_10_EXP)
 603         return NV_MAX;
 604 #endif
 605
 606     for (bit = 1; exponent; bit <<= 1) {
 607         if (exponent & bit) {
 608             exponent ^= bit;
 609             result *= power;
 610         }
 611         /* Floating point exceptions are supposed to be turned off. */
 612         power *= power;
 613     }
 614     return negative ? value / result : value * result;
 615 }
 616
 617 NV
 618 Perl_my_atof(pTHX_ const char* s)
 619 {
 620     NV x = 0.0;
 621 #ifdef USE_LOCALE_NUMERIC
 622     if (PL_numeric_local && IN_LOCALE) {
 623         NV y;
 624
 625         /* Scan the number twice; once using locale and once without;
 626          * choose the larger result (in absolute value). */
 627         Perl_atof2(aTHX_ s, &x);
 628         SET_NUMERIC_STANDARD();
 629         Perl_atof2(aTHX_ s, &y);
 630         SET_NUMERIC_LOCAL();
 631         if ((y < 0.0 && y < x) || (y > 0.0 && y > x))
 632             return y;
 633     }
 634     else
 635         Perl_atof2(aTHX_ s, &x);
 636 #else
 637     Perl_atof2(aTHX_ s, &x);
 638 #endif
 639     return x;
 640 }
 641
 642 char*
 643 Perl_my_atof2(pTHX_ const char* orig, NV* value)
 644 {
 645     NV result = 0.0;
 646     bool negative = 0;
 647     char* s = (char*)orig;
 648     char* send = s + strlen(orig) - 1;
 649     bool seendigit = 0;
 650     I32 expextra = 0;
 651     I32 exponent = 0;
 652     I32 i;
 653 /* this is arbitrary */
 654 #define PARTLIM 6
 655 /* we want the largest integers we can usefully use */
 656 #if defined(HAS_QUAD) && defined(USE_64_BIT_INT)
 657 #   define PARTSIZE ((int)TYPE_DIGITS(U64)-1)
 658     U64 part[PARTLIM];
 659 #else
 660 #   define PARTSIZE ((int)TYPE_DIGITS(U32)-1)
 661     U32 part[PARTLIM];
 662 #endif
 663     I32 ipart = 0;      /* index into part[] */
 664     I32 offcount;       /* number of digits in least significant part */
 665
 666     /* leading whitespace */
 667     while (isSPACE(*s))
 668         ++s;
 669
 670     /* sign */
 671     switch (*s) {
 672         case '-':
 673             negative = 1;
 674             /* fall through */
 675         case '+':
 676             ++s;
 677     }
 678
 679     part[0] = offcount = 0;
 680     if (isDIGIT(*s)) {
 681         seendigit = 1;  /* get this over with */
 682
 683         /* skip leading zeros */
 684         while (*s == '0')
 685             ++s;
 686     }
 687
 688     /* integer digits */
 689     while (isDIGIT(*s)) {
 690         if (++offcount > PARTSIZE) {
 691             if (++ipart < PARTLIM) {
 692                 part[ipart] = 0;
 693                 offcount = 1;   /* ++0 */
 694             }
 695             else {
 696                 /* limits of precision reached */
 697                 --ipart;
 698                 --offcount;
 699                 if (*s >= '5')
 700                     ++part[ipart];
 701                 while (isDIGIT(*s)) {
 702                     ++expextra;
 703                     ++s;
 704                 }
 705                 /* warn of loss of precision? */
 706                 break;
 707             }
 708         }
 709         part[ipart] = part[ipart] * 10 + (*s++ - '0');
 710     }
 711
 712     /* decimal point */
 713     if (GROK_NUMERIC_RADIX((const char **)&s, send)) {
 714         if (isDIGIT(*s))
 715             seendigit = 1;      /* get this over with */
 716
 717         /* decimal digits */
 718         while (isDIGIT(*s)) {
 719             if (++offcount > PARTSIZE) {
 720                 if (++ipart < PARTLIM) {
 721                     part[ipart] = 0;
 722                     offcount = 1;       /* ++0 */
 723                 }
 724                 else {
 725                     /* limits of precision reached */
 726                     --ipart;
 727                     --offcount;
 728                     if (*s >= '5')
 729                         ++part[ipart];
 730                     while (isDIGIT(*s))
 731                         ++s;
 732                     /* warn of loss of precision? */
 733                     break;
 734                 }
 735             }
 736             --expextra;
 737             part[ipart] = part[ipart] * 10 + (*s++ - '0');
 738         }
 739     }
 740
 741     /* combine components of mantissa */
 742     for (i = 0; i <= ipart; ++i)
 743         result += S_mulexp10((NV)part[ipart - i],
 744                 i ? offcount + (i - 1) * PARTSIZE : 0);
 745
 746     if (seendigit && (*s == 'e' || *s == 'E')) {
 747         bool expnegative = 0;
 748
 749         ++s;
 750         switch (*s) {
 751             case '-':
 752                 expnegative = 1;
 753                 /* fall through */
 754             case '+':
 755                 ++s;
 756         }
 757         while (isDIGIT(*s))
 758             exponent = exponent * 10 + (*s++ - '0');
 759         if (expnegative)
 760             exponent = -exponent;
 761     }
 762
 763     /* now apply the exponent */
 764     exponent += expextra;
 765     result = S_mulexp10(result, exponent);
 766
 767     /* now apply the sign */
 768     if (negative)
 769         result = -result;
 770     *value = result;
 771     return s;
 772 }
 773