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