numeric.c

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