numeric.c

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