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))
 203             Perl_ck_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         Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
 214                        "Binary number > 0b11111111111111111111111111111111 non-portable");
 215     }
 216     *len_p = s - start;
 217     if (!overflowed) {
 218         *flags = 0;
 219         return value;
 220     }
 221     *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
 222     if (result)
 223         *result = value_nv;
 224     return UV_MAX;
 225 }
 226
 227 /*
 228 =for apidoc grok_hex
 229
 230 converts a string representing a hex number to numeric form.
 231
 232 On entry I<start> and I<*len> give the string to scan, I<*flags> gives
 233 conversion flags, and I<result> should be NULL or a pointer to an NV.
 234 The scan stops at the end of the string, or the first invalid character.
 235 Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in I<*flags>, encountering an
 236 invalid character will also trigger a warning.
 237 On return I<*len> is set to the length of the scanned string,
 238 and I<*flags> gives output flags.
 239
 240 If the value is <= UV_MAX it is returned as a UV, the output flags are clear,
 241 and nothing is written to I<*result>. If the value is > UV_MAX C<grok_hex>
 242 returns UV_MAX, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags,
 243 and writes the value to I<*result> (or the value is discarded if I<result>
 244 is NULL).
 245
 246 The hex number may optionally be prefixed with "0x" or "x" unless
 247 C<PERL_SCAN_DISALLOW_PREFIX> is set in I<*flags> on entry. If
 248 C<PERL_SCAN_ALLOW_UNDERSCORES> is set in I<*flags> then the hex
 249 number may use '_' characters to separate digits.
 250
 251 =cut
 252  */
 253
 254 UV
 255 Perl_grok_hex(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
 256 {
 257     dVAR;
 258     const char *s = start;
 259     STRLEN len = *len_p;
 260     UV value = 0;
 261     NV value_nv = 0;
 262     const UV max_div_16 = UV_MAX / 16;
 263     const bool allow_underscores = (bool)(*flags & PERL_SCAN_ALLOW_UNDERSCORES);
 264     bool overflowed = FALSE;
 265
 266     PERL_ARGS_ASSERT_GROK_HEX;
 267
 268     if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
 269         /* strip off leading x or 0x.
 270            for compatibility silently suffer "x" and "0x" as valid hex numbers.
 271         */
 272         if (len >= 1) {
 273             if (s[0] == 'x') {
 274                 s++;
 275                 len--;
 276             }
 277             else if (len >= 2 && s[0] == '0' && s[1] == 'x') {
 278                 s+=2;
 279                 len-=2;
 280             }
 281         }
 282     }
 283
 284     for (; len-- && *s; s++) {
 285         const char *hexdigit = strchr(PL_hexdigit, *s);
 286         if (hexdigit) {
 287             /* Write it in this wonky order with a goto to attempt to get the
 288                compiler to make the common case integer-only loop pretty tight.
 289                With gcc seems to be much straighter code than old scan_hex.  */
 290           redo:
 291             if (!overflowed) {
 292                 if (value <= max_div_16) {
 293                     value = (value << 4) | ((hexdigit - PL_hexdigit) & 15);
 294                     continue;
 295                 }
 296                 /* Bah. We're just overflowed.  */
 297                 if (ckWARN_d(WARN_OVERFLOW))
 298                     Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
 299                                 "Integer overflow in hexadecimal number");
 300                 overflowed = TRUE;
 301                 value_nv = (NV) value;
 302             }
 303             value_nv *= 16.0;
 304             /* If an NV has not enough bits in its mantissa to
 305              * represent a UV this summing of small low-order numbers
 306              * is a waste of time (because the NV cannot preserve
 307              * the low-order bits anyway): we could just remember when
 308              * did we overflow and in the end just multiply value_nv by the
 309              * right amount of 16-tuples. */
 310             value_nv += (NV)((hexdigit - PL_hexdigit) & 15);
 311             continue;
 312         }
 313         if (*s == '_' && len && allow_underscores && s[1]
 314                 && (hexdigit = strchr(PL_hexdigit, s[1])))
 315             {
 316                 --len;
 317                 ++s;
 318                 goto redo;
 319             }
 320         if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
 321             Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
 322                         "Illegal hexadecimal digit '%c' ignored", *s);
 323         break;
 324     }
 325
 326     if (   ( overflowed && value_nv > 4294967295.0)
 327 #if UVSIZE > 4
 328         || (!overflowed && value > 0xffffffff  )
 329 #endif
 330         ) {
 331         Perl_ck_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))
 426                 Perl_ck_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         Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
 438                        "Octal number > 037777777777 non-portable");
 439     }
 440     *len_p = s - start;
 441     if (!overflowed) {
 442         *flags = 0;
 443         return value;
 444     }
 445     *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
 446     if (result)
 447         *result = value_nv;
 448     return UV_MAX;
 449 }
 450
 451 /*
 452 =for apidoc scan_bin
 453
 454 For backwards compatibility. Use C<grok_bin> instead.
 455
 456 =for apidoc scan_hex
 457
 458 For backwards compatibility. Use C<grok_hex> instead.
 459
 460 =for apidoc scan_oct
 461
 462 For backwards compatibility. Use C<grok_oct> instead.
 463
 464 =cut
 465  */
 466
 467 NV
 468 Perl_scan_bin(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
 469 {
 470     NV rnv;
 471     I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
 472     const UV ruv = grok_bin (start, &len, &flags, &rnv);
 473
 474     PERL_ARGS_ASSERT_SCAN_BIN;
 475
 476     *retlen = len;
 477     return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
 478 }
 479
 480 NV
 481 Perl_scan_oct(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
 482 {
 483     NV rnv;
 484     I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
 485     const UV ruv = grok_oct (start, &len, &flags, &rnv);
 486
 487     PERL_ARGS_ASSERT_SCAN_OCT;
 488
 489     *retlen = len;
 490     return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
 491 }
 492
 493 NV
 494 Perl_scan_hex(pTHX_ const char *start, STRLEN len, STRLEN *retlen)
 495 {
 496     NV rnv;
 497     I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0;
 498     const UV ruv = grok_hex (start, &len, &flags, &rnv);
 499
 500     PERL_ARGS_ASSERT_SCAN_HEX;
 501
 502     *retlen = len;
 503     return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv;
 504 }
 505
 506 /*
 507 =for apidoc grok_numeric_radix
 508
 509 Scan and skip for a numeric decimal separator (radix).
 510
 511 =cut
 512  */
 513 bool
 514 Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send)
 515 {
 516 #ifdef USE_LOCALE_NUMERIC
 517     dVAR;
 518
 519     PERL_ARGS_ASSERT_GROK_NUMERIC_RADIX;
 520
 521     if (PL_numeric_radix_sv && IN_LOCALE) {
 522         STRLEN len;
 523         const char * const radix = SvPV(PL_numeric_radix_sv, len);
 524         if (*sp + len <= send && memEQ(*sp, radix, len)) {
 525             *sp += len;
 526             return TRUE;
 527         }
 528     }
 529     /* always try "." if numeric radix didn't match because
 530      * we may have data from different locales mixed */
 531 #endif
 532
 533     PERL_ARGS_ASSERT_GROK_NUMERIC_RADIX;
 534
 535     if (*sp < send && **sp == '.') {
 536         ++*sp;
 537         return TRUE;
 538     }
 539     return FALSE;
 540 }
 541
 542 /*
 543 =for apidoc grok_number
 544
 545 Recognise (or not) a number.  The type of the number is returned
 546 (0 if unrecognised), otherwise it is a bit-ORed combination of
 547 IS_NUMBER_IN_UV, IS_NUMBER_GREATER_THAN_UV_MAX, IS_NUMBER_NOT_INT,
 548 IS_NUMBER_NEG, IS_NUMBER_INFINITY, IS_NUMBER_NAN (defined in perl.h).
 549
 550 If the value of the number can fit an in UV, it is returned in the *valuep
 551 IS_NUMBER_IN_UV will be set to indicate that *valuep is valid, IS_NUMBER_IN_UV
 552 will never be set unless *valuep is valid, but *valuep may have been assigned
 553 to during processing even though IS_NUMBER_IN_UV is not set on return.
 554 If valuep is NULL, IS_NUMBER_IN_UV will be set for the same cases as when
 555 valuep is non-NULL, but no actual assignment (or SEGV) will occur.
 556
 557 IS_NUMBER_NOT_INT will be set with IS_NUMBER_IN_UV if trailing decimals were
 558 seen (in which case *valuep gives the true value truncated to an integer), and
 559 IS_NUMBER_NEG if the number is negative (in which case *valuep holds the
 560 absolute value).  IS_NUMBER_IN_UV is not set if e notation was used or the
 561 number is larger than a UV.
 562
 563 =cut
 564  */
 565 int
 566 Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
 567 {
 568   const char *s = pv;
 569   const char * const send = pv + len;
 570   const UV max_div_10 = UV_MAX / 10;
 571   const char max_mod_10 = UV_MAX % 10;
 572   int numtype = 0;
 573   int sawinf = 0;
 574   int sawnan = 0;
 575
 576   PERL_ARGS_ASSERT_GROK_NUMBER;
 577
 578   while (s < send && isSPACE(*s))
 579     s++;
 580   if (s == send) {
 581     return 0;
 582   } else if (*s == '-') {
 583     s++;
 584     numtype = IS_NUMBER_NEG;
 585   }
 586   else if (*s == '+')
 587   s++;
 588
 589   if (s == send)
 590     return 0;
 591
 592   /* next must be digit or the radix separator or beginning of infinity */
 593   if (isDIGIT(*s)) {
 594     /* UVs are at least 32 bits, so the first 9 decimal digits cannot
 595        overflow.  */
 596     UV value = *s - '0';
 597     /* This construction seems to be more optimiser friendly.
 598        (without it gcc does the isDIGIT test and the *s - '0' separately)
 599        With it gcc on arm is managing 6 instructions (6 cycles) per digit.
 600        In theory the optimiser could deduce how far to unroll the loop
 601        before checking for overflow.  */
 602     if (++s < send) {
 603       int 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                               digit = *s - '0';
 628                               if (digit >= 0 && digit <= 9) {
 629                                 value = value * 10 + digit;
 630                                 if (++s < send) {
 631                                   digit = *s - '0';
 632                                   if (digit >= 0 && digit <= 9) {
 633                                     value = value * 10 + digit;
 634                                     if (++s < send) {
 635                                       /* Now got 9 digits, so need to check
 636                                          each time for overflow.  */
 637                                       digit = *s - '0';
 638                                       while (digit >= 0 && digit <= 9
 639                                              && (value < max_div_10
 640                                                  || (value == max_div_10
 641                                                      && digit <= max_mod_10))) {
 642                                         value = value * 10 + digit;
 643                                         if (++s < send)
 644                                           digit = *s - '0';
 645                                         else
 646                                           break;
 647                                       }
 648                                       if (digit >= 0 && digit <= 9
 649                                           && (s < send)) {
 650                                         /* value overflowed.
 651                                            skip the remaining digits, don't
 652                                            worry about setting *valuep.  */
 653                                         do {
 654                                           s++;
 655                                         } while (s < send && isDIGIT(*s));
 656                                         numtype |=
 657                                           IS_NUMBER_GREATER_THAN_UV_MAX;
 658                                         goto skip_value;
 659                                       }
 660                                     }
 661                                   }
 662                                 }
 663                               }
 664                             }
 665                           }
 666                         }
 667                       }
 668                     }
 669                   }
 670                 }
 671               }
 672             }
 673           }
 674         }
 675       }
 676     }
 677     numtype |= IS_NUMBER_IN_UV;
 678     if (valuep)
 679       *valuep = value;
 680
 681   skip_value:
 682     if (GROK_NUMERIC_RADIX(&s, send)) {
 683       numtype |= IS_NUMBER_NOT_INT;
 684       while (s < send && isDIGIT(*s))  /* optional digits after the radix */
 685         s++;
 686     }
 687   }
 688   else if (GROK_NUMERIC_RADIX(&s, send)) {
 689     numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
 690     /* no digits before the radix means we need digits after it */
 691     if (s < send && isDIGIT(*s)) {
 692       do {
 693         s++;
 694       } while (s < send && isDIGIT(*s));
 695       if (valuep) {
 696         /* integer approximation is valid - it's 0.  */
 697         *valuep = 0;
 698       }
 699     }
 700     else
 701       return 0;
 702   } else if (*s == 'I' || *s == 'i') {
 703     s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
 704     s++; if (s == send || (*s != 'F' && *s != 'f')) return 0;
 705     s++; if (s < send && (*s == 'I' || *s == 'i')) {
 706       s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
 707       s++; if (s == send || (*s != 'I' && *s != 'i')) return 0;
 708       s++; if (s == send || (*s != 'T' && *s != 't')) return 0;
 709       s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0;
 710       s++;
 711     }
 712     sawinf = 1;
 713   } else if (*s == 'N' || *s == 'n') {
 714     /* XXX TODO: There are signaling NaNs and quiet NaNs. */
 715     s++; if (s == send || (*s != 'A' && *s != 'a')) return 0;
 716     s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
 717     s++;
 718     sawnan = 1;
 719   } else
 720     return 0;
 721
 722   if (sawinf) {
 723     numtype &= IS_NUMBER_NEG; /* Keep track of sign  */
 724     numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
 725   } else if (sawnan) {
 726     numtype &= IS_NUMBER_NEG; /* Keep track of sign  */
 727     numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
 728   } else if (s < send) {
 729     /* we can have an optional exponent part */
 730     if (*s == 'e' || *s == 'E') {
 731       /* The only flag we keep is sign.  Blow away any "it's UV"  */
 732       numtype &= IS_NUMBER_NEG;
 733       numtype |= IS_NUMBER_NOT_INT;
 734       s++;
 735       if (s < send && (*s == '-' || *s == '+'))
 736         s++;
 737       if (s < send && isDIGIT(*s)) {
 738         do {
 739           s++;
 740         } while (s < send && isDIGIT(*s));
 741       }
 742       else
 743       return 0;
 744     }
 745   }
 746   while (s < send && isSPACE(*s))
 747     s++;
 748   if (s >= send)
 749     return numtype;
 750   if (len == 10 && memEQ(pv, "0 but true", 10)) {
 751     if (valuep)
 752       *valuep = 0;
 753     return IS_NUMBER_IN_UV;
 754   }
 755   return 0;
 756 }
 757
 758 STATIC NV
 759 S_mulexp10(NV value, I32 exponent)
 760 {
 761     NV result = 1.0;
 762     NV power = 10.0;
 763     bool negative = 0;
 764     I32 bit;
 765
 766     if (exponent == 0)
 767         return value;
 768     if (value == 0)
 769         return (NV)0;
 770
 771     /* On OpenVMS VAX we by default use the D_FLOAT double format,
 772      * and that format does not have *easy* capabilities [1] for
 773      * overflowing doubles 'silently' as IEEE fp does.  We also need
 774      * to support G_FLOAT on both VAX and Alpha, and though the exponent
 775      * range is much larger than D_FLOAT it still doesn't do silent
 776      * overflow.  Therefore we need to detect early whether we would
 777      * overflow (this is the behaviour of the native string-to-float
 778      * conversion routines, and therefore of native applications, too).
 779      *
 780      * [1] Trying to establish a condition handler to trap floating point
 781      *     exceptions is not a good idea. */
 782
 783     /* In UNICOS and in certain Cray models (such as T90) there is no
 784      * IEEE fp, and no way at all from C to catch fp overflows gracefully.
 785      * There is something you can do if you are willing to use some
 786      * inline assembler: the instruction is called DFI-- but that will
 787      * disable *all* floating point interrupts, a little bit too large
 788      * a hammer.  Therefore we need to catch potential overflows before
 789      * it's too late. */
 790
 791 #if ((defined(VMS) && !defined(__IEEE_FP)) || defined(_UNICOS)) && defined(NV_MAX_10_EXP)
 792     STMT_START {
 793         const NV exp_v = log10(value);
 794         if (exponent >= NV_MAX_10_EXP || exponent + exp_v >= NV_MAX_10_EXP)
 795             return NV_MAX;
 796         if (exponent < 0) {
 797             if (-(exponent + exp_v) >= NV_MAX_10_EXP)
 798                 return 0.0;
 799             while (-exponent >= NV_MAX_10_EXP) {
 800                 /* combination does not overflow, but 10^(-exponent) does */
 801                 value /= 10;
 802                 ++exponent;
 803             }
 804         }
 805     } STMT_END;
 806 #endif
 807
 808     if (exponent < 0) {
 809         negative = 1;
 810         exponent = -exponent;
 811     }
 812     for (bit = 1; exponent; bit <<= 1) {
 813         if (exponent & bit) {
 814             exponent ^= bit;
 815             result *= power;
 816             /* Floating point exceptions are supposed to be turned off,
 817              *  but if we're obviously done, don't risk another iteration.
 818              */
 819              if (exponent == 0) break;
 820         }
 821         power *= power;
 822     }
 823     return negative ? value / result : value * result;
 824 }
 825
 826 NV
 827 Perl_my_atof(pTHX_ const char* s)
 828 {
 829     NV x = 0.0;
 830 #ifdef USE_LOCALE_NUMERIC
 831     dVAR;
 832
 833     PERL_ARGS_ASSERT_MY_ATOF;
 834
 835     if (PL_numeric_local && IN_LOCALE) {
 836         NV y;
 837
 838         /* Scan the number twice; once using locale and once without;
 839          * choose the larger result (in absolute value). */
 840         Perl_atof2(s, x);
 841         SET_NUMERIC_STANDARD();
 842         Perl_atof2(s, y);
 843         SET_NUMERIC_LOCAL();
 844         if ((y < 0.0 && y < x) || (y > 0.0 && y > x))
 845             return y;
 846     }
 847     else
 848         Perl_atof2(s, x);
 849 #else
 850     Perl_atof2(s, x);
 851 #endif
 852     return x;
 853 }
 854
 855 char*
 856 Perl_my_atof2(pTHX_ const char* orig, NV* value)
 857 {
 858     NV result[3] = {0.0, 0.0, 0.0};
 859     const char* s = orig;
 860 #ifdef USE_PERL_ATOF
 861     UV accumulator[2] = {0,0};  /* before/after dp */
 862     bool negative = 0;
 863     const char* send = s + strlen(orig) - 1;
 864     bool seen_digit = 0;
 865     I32 exp_adjust[2] = {0,0};
 866     I32 exp_acc[2] = {-1, -1};
 867     /* the current exponent adjust for the accumulators */
 868     I32 exponent = 0;
 869     I32 seen_dp  = 0;
 870     I32 digit = 0;
 871     I32 old_digit = 0;
 872     I32 sig_digits = 0; /* noof significant digits seen so far */
 873
 874     PERL_ARGS_ASSERT_MY_ATOF2;
 875
 876 /* There is no point in processing more significant digits
 877  * than the NV can hold. Note that NV_DIG is a lower-bound value,
 878  * while we need an upper-bound value. We add 2 to account for this;
 879  * since it will have been conservative on both the first and last digit.
 880  * For example a 32-bit mantissa with an exponent of 4 would have
 881  * exact values in the set
 882  *               4
 883  *               8
 884  *              ..
 885  *     17179869172
 886  *     17179869176
 887  *     17179869180
 888  *
 889  * where for the purposes of calculating NV_DIG we would have to discount
 890  * both the first and last digit, since neither can hold all values from
 891  * 0..9; but for calculating the value we must examine those two digits.
 892  */
 893 #define MAX_SIG_DIGITS (NV_DIG+2)
 894
 895 /* the max number we can accumulate in a UV, and still safely do 10*N+9 */
 896 #define MAX_ACCUMULATE ( (UV) ((UV_MAX - 9)/10))
 897
 898     /* leading whitespace */
 899     while (isSPACE(*s))
 900         ++s;
 901
 902     /* sign */
 903     switch (*s) {
 904         case '-':
 905             negative = 1;
 906             /* fall through */
 907         case '+':
 908             ++s;
 909     }
 910
 911     /* punt to strtod for NaN/Inf; if no support for it there, tough luck */
 912
 913 #ifdef HAS_STRTOD
 914     if (*s == 'n' || *s == 'N' || *s == 'i' || *s == 'I') {
 915         const char *p = negative ? s - 1 : s;
 916         char *endp;
 917         NV rslt;
 918         rslt = strtod(p, &endp);
 919         if (endp != p) {
 920             *value = rslt;
 921             return (char *)endp;
 922         }
 923     }
 924 #endif
 925
 926     /* we accumulate digits into an integer; when this becomes too
 927      * large, we add the total to NV and start again */
 928
 929     while (1) {
 930         if (isDIGIT(*s)) {
 931             seen_digit = 1;
 932             old_digit = digit;
 933             digit = *s++ - '0';
 934             if (seen_dp)
 935                 exp_adjust[1]++;
 936
 937             /* don't start counting until we see the first significant
 938              * digit, eg the 5 in 0.00005... */
 939             if (!sig_digits && digit == 0)
 940                 continue;
 941
 942             if (++sig_digits > MAX_SIG_DIGITS) {
 943                 /* limits of precision reached */
 944                 if (digit > 5) {
 945                     ++accumulator[seen_dp];
 946                 } else if (digit == 5) {
 947                     if (old_digit % 2) { /* round to even - Allen */
 948                         ++accumulator[seen_dp];
 949                     }
 950                 }
 951                 if (seen_dp) {
 952                     exp_adjust[1]--;
 953                 } else {
 954                     exp_adjust[0]++;
 955                 }
 956                 /* skip remaining digits */
 957                 while (isDIGIT(*s)) {
 958                     ++s;
 959                     if (! seen_dp) {
 960                         exp_adjust[0]++;
 961                     }
 962                 }
 963                 /* warn of loss of precision? */
 964             }
 965             else {
 966                 if (accumulator[seen_dp] > MAX_ACCUMULATE) {
 967                     /* add accumulator to result and start again */
 968                     result[seen_dp] = S_mulexp10(result[seen_dp],
 969                                                  exp_acc[seen_dp])
 970                         + (NV)accumulator[seen_dp];
 971                     accumulator[seen_dp] = 0;
 972                     exp_acc[seen_dp] = 0;
 973                 }
 974                 accumulator[seen_dp] = accumulator[seen_dp] * 10 + digit;
 975                 ++exp_acc[seen_dp];
 976             }
 977         }
 978         else if (!seen_dp && GROK_NUMERIC_RADIX(&s, send)) {
 979             seen_dp = 1;
 980             if (sig_digits > MAX_SIG_DIGITS) {
 981                 do {
 982                     ++s;
 983                 } while (isDIGIT(*s));
 984                 break;
 985             }
 986         }
 987         else {
 988             break;
 989         }
 990     }
 991
 992     result[0] = S_mulexp10(result[0], exp_acc[0]) + (NV)accumulator[0];
 993     if (seen_dp) {
 994         result[1] = S_mulexp10(result[1], exp_acc[1]) + (NV)accumulator[1];
 995     }
 996
 997     if (seen_digit && (*s == 'e' || *s == 'E')) {
 998         bool expnegative = 0;
 999
1000         ++s;
1001         switch (*s) {
1002             case '-':
1003                 expnegative = 1;
1004                 /* fall through */
1005             case '+':
1006                 ++s;
1007         }
1008         while (isDIGIT(*s))
1009             exponent = exponent * 10 + (*s++ - '0');
1010         if (expnegative)
1011             exponent = -exponent;
1012     }
1013
1014
1015
1016     /* now apply the exponent */
1017
1018     if (seen_dp) {
1019         result[2] = S_mulexp10(result[0],exponent+exp_adjust[0])
1020                 + S_mulexp10(result[1],exponent-exp_adjust[1]);
1021     } else {
1022         result[2] = S_mulexp10(result[0],exponent+exp_adjust[0]);
1023     }
1024
1025     /* now apply the sign */
1026     if (negative)
1027         result[2] = -result[2];
1028 #endif /* USE_PERL_ATOF */
1029     *value = result[2];
1030     return (char *)s;
1031 }
1032
1033 #if ! defined(HAS_MODFL) && defined(HAS_AINTL) && defined(HAS_COPYSIGNL)
1034 long double
1035 Perl_my_modfl(long double x, long double *ip)
1036 {
1037         *ip = aintl(x);
1038         return (x == *ip ? copysignl(0.0L, x) : x - *ip);
1039 }
1040 #endif
1041
1042 #if ! defined(HAS_FREXPL) && defined(HAS_ILOGBL) && defined(HAS_SCALBNL)
1043 long double
1044 Perl_my_frexpl(long double x, int *e) {
1045         *e = x == 0.0L ? 0 : ilogbl(x) + 1;
1046         return (scalbnl(x, -*e));
1047 }
1048 #endif
1049
1050 /*
1051 =for apidoc Perl_signbit
1052
1053 Return a non-zero integer if the sign bit on an NV is set, and 0 if
1054 it is not.
1055
1056 If Configure detects this system has a signbit() that will work with
1057 our NVs, then we just use it via the #define in perl.h.  Otherwise,
1058 fall back on this implementation.  As a first pass, this gets everything
1059 right except -0.0.  Alas, catching -0.0 is the main use for this function,
1060 so this is not too helpful yet.  Still, at least we have the scaffolding
1061 in place to support other systems, should that prove useful.
1062
1063
1064 Configure notes:  This function is called 'Perl_signbit' instead of a
1065 plain 'signbit' because it is easy to imagine a system having a signbit()
1066 function or macro that doesn't happen to work with our particular choice
1067 of NVs.  We shouldn't just re-#define signbit as Perl_signbit and expect
1068 the standard system headers to be happy.  Also, this is a no-context
1069 function (no pTHX_) because Perl_signbit() is usually re-#defined in
1070 perl.h as a simple macro call to the system's signbit().
1071 Users should just always call Perl_signbit().
1072
1073 =cut
1074 */
1075 #if !defined(HAS_SIGNBIT)
1076 int
1077 Perl_signbit(NV x) {
1078     return (x < 0.0) ? 1 : 0;
1079 }
1080 #endif
1081
1082 /*
1083  * Local variables:
1084  * c-indentation-style: bsd
1085  * c-basic-offset: 4
1086  * indent-tabs-mode: t
1087  * End:
1088  *
1089  * ex: set ts=8 sts=4 sw=4 noet:
1090  */