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