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