numeric.c

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