numeric.c

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