numeric.c

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