numeric.c

   1 /*    numeric.c
   2  *
   3  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2005 by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * "That only makes eleven (plus one mislaid) and not fourteen, unless
  13  * wizards count differently to other people."
  14  */
  15
  16 /*
  17 =head1 Numeric functions
  18
  19 This file contains all the stuff needed by perl for manipulating numeric
  20 values, including such things as replacements for the OS's atof() function
  21
  22 =cut
  23
  24 */
  25
  26 #include "EXTERN.h"
  27 #define PERL_IN_NUMERIC_C
  28 #include "perl.h"
  29
  30 U32
  31 Perl_cast_ulong(pTHX_ NV f)
  32 {
  33   if (f < 0.0)
  34     return f < I32_MIN ? (U32) I32_MIN : (U32)(I32) f;
  35   if (f < U32_MAX_P1) {
  36 #if CASTFLAGS & 2
  37     if (f < U32_MAX_P1_HALF)
  38       return (U32) f;
  39     f -= U32_MAX_P1_HALF;
  40     return ((U32) f) | (1 + U32_MAX >> 1);
  41 #else
  42     return (U32) f;
  43 #endif
  44   }
  45   return f > 0 ? U32_MAX : 0 /* NaN */;
  46 }
  47
  48 I32
  49 Perl_cast_i32(pTHX_ NV f)
  50 {
  51   if (f < I32_MAX_P1)
  52     return f < I32_MIN ? I32_MIN : (I32) f;
  53   if (f < U32_MAX_P1) {
  54 #if CASTFLAGS & 2
  55     if (f < U32_MAX_P1_HALF)
  56       return (I32)(U32) f;
  57     f -= U32_MAX_P1_HALF;
  58     return (I32)(((U32) f) | (1 + U32_MAX >> 1));
  59 #else
  60     return (I32)(U32) f;
  61 #endif
  62   }
  63   return f > 0 ? (I32)U32_MAX : 0 /* NaN */;
  64 }
  65
  66 IV
  67 Perl_cast_iv(pTHX_ NV f)
  68 {
  69   if (f < IV_MAX_P1)
  70     return f < IV_MIN ? IV_MIN : (IV) f;
  71   if (f < UV_MAX_P1) {
  72 #if CASTFLAGS & 2
  73     /* For future flexibility allowing for sizeof(UV) >= sizeof(IV)  */
  74     if (f < UV_MAX_P1_HALF)
  75       return (IV)(UV) f;
  76     f -= UV_MAX_P1_HALF;
  77     return (IV)(((UV) f) | (1 + UV_MAX >> 1));
  78 #else
  79     return (IV)(UV) f;
  80 #endif
  81   }
  82   return f > 0 ? (IV)UV_MAX : 0 /* NaN */;
  83 }
  84
  85 UV
  86 Perl_cast_uv(pTHX_ NV f)
  87 {
  88   if (f < 0.0)
  89     return f < IV_MIN ? (UV) IV_MIN : (UV)(IV) f;
  90   if (f < UV_MAX_P1) {
  91 #if CASTFLAGS & 2
  92     if (f < UV_MAX_P1_HALF)
  93       return (UV) f;
  94     f -= UV_MAX_P1_HALF;
  95     return ((UV) f) | (1 + UV_MAX >> 1);
  96 #else
  97     return (UV) f;
  98 #endif
  99   }
 100   return f > 0 ? UV_MAX : 0 /* NaN */;
 101 }
 102
 103 /*
 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     if (PL_numeric_radix_sv && IN_LOCALE) {
 502         STRLEN len;
 503         const char * const radix = SvPV(PL_numeric_radix_sv, len);
 504         if (*sp + len <= send && memEQ(*sp, radix, len)) {
 505             *sp += len;
 506             return TRUE;
 507         }
 508     }
 509     /* always try "." if numeric radix didn't match because
 510      * we may have data from different locales mixed */
 511 #endif
 512     if (*sp < send && **sp == '.') {
 513         ++*sp;
 514         return TRUE;
 515     }
 516     return FALSE;
 517 }
 518
 519 /*
 520 =for apidoc grok_number
 521
 522 Recognise (or not) a number.  The type of the number is returned
 523 (0 if unrecognised), otherwise it is a bit-ORed combination of
 524 IS_NUMBER_IN_UV, IS_NUMBER_GREATER_THAN_UV_MAX, IS_NUMBER_NOT_INT,
 525 IS_NUMBER_NEG, IS_NUMBER_INFINITY, IS_NUMBER_NAN (defined in perl.h).
 526
 527 If the value of the number can fit an in UV, it is returned in the *valuep
 528 IS_NUMBER_IN_UV will be set to indicate that *valuep is valid, IS_NUMBER_IN_UV
 529 will never be set unless *valuep is valid, but *valuep may have been assigned
 530 to during processing even though IS_NUMBER_IN_UV is not set on return.
 531 If valuep is NULL, IS_NUMBER_IN_UV will be set for the same cases as when
 532 valuep is non-NULL, but no actual assignment (or SEGV) will occur.
 533
 534 IS_NUMBER_NOT_INT will be set with IS_NUMBER_IN_UV if trailing decimals were
 535 seen (in which case *valuep gives the true value truncated to an integer), and
 536 IS_NUMBER_NEG if the number is negative (in which case *valuep holds the
 537 absolute value).  IS_NUMBER_IN_UV is not set if e notation was used or the
 538 number is larger than a UV.
 539
 540 =cut
 541  */
 542 int
 543 Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
 544 {
 545   const char *s = pv;
 546   const char * const send = pv + len;
 547   const UV max_div_10 = UV_MAX / 10;
 548   const char max_mod_10 = UV_MAX % 10;
 549   int numtype = 0;
 550   int sawinf = 0;
 551   int sawnan = 0;
 552
 553   while (s < send && isSPACE(*s))
 554     s++;
 555   if (s == send) {
 556     return 0;
 557   } else if (*s == '-') {
 558     s++;
 559     numtype = IS_NUMBER_NEG;
 560   }
 561   else if (*s == '+')
 562   s++;
 563
 564   if (s == send)
 565     return 0;
 566
 567   /* next must be digit or the radix separator or beginning of infinity */
 568   if (isDIGIT(*s)) {
 569     /* UVs are at least 32 bits, so the first 9 decimal digits cannot
 570        overflow.  */
 571     UV value = *s - '0';
 572     /* This construction seems to be more optimiser friendly.
 573        (without it gcc does the isDIGIT test and the *s - '0' separately)
 574        With it gcc on arm is managing 6 instructions (6 cycles) per digit.
 575        In theory the optimiser could deduce how far to unroll the loop
 576        before checking for overflow.  */
 577     if (++s < send) {
 578       int digit = *s - '0';
 579       if (digit >= 0 && digit <= 9) {
 580         value = value * 10 + digit;
 581         if (++s < send) {
 582           digit = *s - '0';
 583           if (digit >= 0 && digit <= 9) {
 584             value = value * 10 + digit;
 585             if (++s < send) {
 586               digit = *s - '0';
 587               if (digit >= 0 && digit <= 9) {
 588                 value = value * 10 + digit;
 589                 if (++s < send) {
 590                   digit = *s - '0';
 591                   if (digit >= 0 && digit <= 9) {
 592                     value = value * 10 + digit;
 593                     if (++s < send) {
 594                       digit = *s - '0';
 595                       if (digit >= 0 && digit <= 9) {
 596                         value = value * 10 + digit;
 597                         if (++s < send) {
 598                           digit = *s - '0';
 599                           if (digit >= 0 && digit <= 9) {
 600                             value = value * 10 + digit;
 601                             if (++s < send) {
 602                               digit = *s - '0';
 603                               if (digit >= 0 && digit <= 9) {
 604                                 value = value * 10 + digit;
 605                                 if (++s < send) {
 606                                   digit = *s - '0';
 607                                   if (digit >= 0 && digit <= 9) {
 608                                     value = value * 10 + digit;
 609                                     if (++s < send) {
 610                                       /* Now got 9 digits, so need to check
 611                                          each time for overflow.  */
 612                                       digit = *s - '0';
 613                                       while (digit >= 0 && digit <= 9
 614                                              && (value < max_div_10
 615                                                  || (value == max_div_10
 616                                                      && digit <= max_mod_10))) {
 617                                         value = value * 10 + digit;
 618                                         if (++s < send)
 619                                           digit = *s - '0';
 620                                         else
 621                                           break;
 622                                       }
 623                                       if (digit >= 0 && digit <= 9
 624                                           && (s < send)) {
 625                                         /* value overflowed.
 626                                            skip the remaining digits, don't
 627                                            worry about setting *valuep.  */
 628                                         do {
 629                                           s++;
 630                                         } while (s < send && isDIGIT(*s));
 631                                         numtype |=
 632                                           IS_NUMBER_GREATER_THAN_UV_MAX;
 633                                         goto skip_value;
 634                                       }
 635                                     }
 636                                   }
 637                                 }
 638                               }
 639                             }
 640                           }
 641                         }
 642                       }
 643                     }
 644                   }
 645                 }
 646               }
 647             }
 648           }
 649         }
 650       }
 651     }
 652     numtype |= IS_NUMBER_IN_UV;
 653     if (valuep)
 654       *valuep = value;
 655
 656   skip_value:
 657     if (GROK_NUMERIC_RADIX(&s, send)) {
 658       numtype |= IS_NUMBER_NOT_INT;
 659       while (s < send && isDIGIT(*s))  /* optional digits after the radix */
 660         s++;
 661     }
 662   }
 663   else if (GROK_NUMERIC_RADIX(&s, send)) {
 664     numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
 665     /* no digits before the radix means we need digits after it */
 666     if (s < send && isDIGIT(*s)) {
 667       do {
 668         s++;
 669       } while (s < send && isDIGIT(*s));
 670       if (valuep) {
 671         /* integer approximation is valid - it's 0.  */
 672         *valuep = 0;
 673       }
 674     }
 675     else
 676       return 0;
 677   } else if (*s == 'I' || *s == 'i') {
 678     s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
 679     s++; if (s == send || (*s != 'F' && *s != 'f')) return 0;
 680     s++; if (s < send && (*s == 'I' || *s == 'i')) {
 681       s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
 682       s++; if (s == send || (*s != 'I' && *s != 'i')) return 0;
 683       s++; if (s == send || (*s != 'T' && *s != 't')) return 0;
 684       s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0;
 685       s++;
 686     }
 687     sawinf = 1;
 688   } else if (*s == 'N' || *s == 'n') {
 689     /* XXX TODO: There are signaling NaNs and quiet NaNs. */
 690     s++; if (s == send || (*s != 'A' && *s != 'a')) return 0;
 691     s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
 692     s++;
 693     sawnan = 1;
 694   } else
 695     return 0;
 696
 697   if (sawinf) {
 698     numtype &= IS_NUMBER_NEG; /* Keep track of sign  */
 699     numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
 700   } else if (sawnan) {
 701     numtype &= IS_NUMBER_NEG; /* Keep track of sign  */
 702     numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
 703   } else if (s < send) {
 704     /* we can have an optional exponent part */
 705     if (*s == 'e' || *s == 'E') {
 706       /* The only flag we keep is sign.  Blow away any "it's UV"  */
 707       numtype &= IS_NUMBER_NEG;
 708       numtype |= IS_NUMBER_NOT_INT;
 709       s++;
 710       if (s < send && (*s == '-' || *s == '+'))
 711         s++;
 712       if (s < send && isDIGIT(*s)) {
 713         do {
 714           s++;
 715         } while (s < send && isDIGIT(*s));
 716       }
 717       else
 718       return 0;
 719     }
 720   }
 721   while (s < send && isSPACE(*s))
 722     s++;
 723   if (s >= send)
 724     return numtype;
 725   if (len == 10 && memEQ(pv, "0 but true", 10)) {
 726     if (valuep)
 727       *valuep = 0;
 728     return IS_NUMBER_IN_UV;
 729   }
 730   return 0;
 731 }
 732
 733 STATIC NV
 734 S_mulexp10(NV value, I32 exponent)
 735 {
 736     NV result = 1.0;
 737     NV power = 10.0;
 738     bool negative = 0;
 739     I32 bit;
 740
 741     if (exponent == 0)
 742         return value;
 743     if (value == 0)
 744         return (NV)0;
 745
 746     /* On OpenVMS VAX we by default use the D_FLOAT double format,
 747      * and that format does not have *easy* capabilities [1] for
 748      * overflowing doubles 'silently' as IEEE fp does.  We also need
 749      * to support G_FLOAT on both VAX and Alpha, and though the exponent
 750      * range is much larger than D_FLOAT it still doesn't do silent
 751      * overflow.  Therefore we need to detect early whether we would
 752      * overflow (this is the behaviour of the native string-to-float
 753      * conversion routines, and therefore of native applications, too).
 754      *
 755      * [1] Trying to establish a condition handler to trap floating point
 756      *     exceptions is not a good idea. */
 757
 758     /* In UNICOS and in certain Cray models (such as T90) there is no
 759      * IEEE fp, and no way at all from C to catch fp overflows gracefully.
 760      * There is something you can do if you are willing to use some
 761      * inline assembler: the instruction is called DFI-- but that will
 762      * disable *all* floating point interrupts, a little bit too large
 763      * a hammer.  Therefore we need to catch potential overflows before
 764      * it's too late. */
 765
 766 #if ((defined(VMS) && !defined(__IEEE_FP)) || defined(_UNICOS)) && defined(NV_MAX_10_EXP)
 767     STMT_START {
 768         const NV exp_v = log10(value);
 769         if (exponent >= NV_MAX_10_EXP || exponent + exp_v >= NV_MAX_10_EXP)
 770             return NV_MAX;
 771         if (exponent < 0) {
 772             if (-(exponent + exp_v) >= NV_MAX_10_EXP)
 773                 return 0.0;
 774             while (-exponent >= NV_MAX_10_EXP) {
 775                 /* combination does not overflow, but 10^(-exponent) does */
 776                 value /= 10;
 777                 ++exponent;
 778             }
 779         }
 780     } STMT_END;
 781 #endif
 782
 783     if (exponent < 0) {
 784         negative = 1;
 785         exponent = -exponent;
 786     }
 787     for (bit = 1; exponent; bit <<= 1) {
 788         if (exponent & bit) {
 789             exponent ^= bit;
 790             result *= power;
 791             /* Floating point exceptions are supposed to be turned off,
 792              *  but if we're obviously done, don't risk another iteration.
 793              */
 794              if (exponent == 0) break;
 795         }
 796         power *= power;
 797     }
 798     return negative ? value / result : value * result;
 799 }
 800
 801 NV
 802 Perl_my_atof(pTHX_ const char* s)
 803 {
 804     NV x = 0.0;
 805 #ifdef USE_LOCALE_NUMERIC
 806     if (PL_numeric_local && IN_LOCALE) {
 807         NV y;
 808
 809         /* Scan the number twice; once using locale and once without;
 810          * choose the larger result (in absolute value). */
 811         Perl_atof2(s, x);
 812         SET_NUMERIC_STANDARD();
 813         Perl_atof2(s, y);
 814         SET_NUMERIC_LOCAL();
 815         if ((y < 0.0 && y < x) || (y > 0.0 && y > x))
 816             return y;
 817     }
 818     else
 819         Perl_atof2(s, x);
 820 #else
 821     Perl_atof2(s, x);
 822 #endif
 823     return x;
 824 }
 825
 826 char*
 827 Perl_my_atof2(pTHX_ const char* orig, NV* value)
 828 {
 829     NV result[3] = {0.0, 0.0, 0.0};
 830     const char* s = orig;
 831 #ifdef USE_PERL_ATOF
 832     UV accumulator[2] = {0,0};  /* before/after dp */
 833     bool negative = 0;
 834     const char* send = s + strlen(orig) - 1;
 835     bool seen_digit = 0;
 836     I32 exp_adjust[2] = {0,0};
 837     I32 exp_acc[2] = {-1, -1};
 838     /* the current exponent adjust for the accumulators */
 839     I32 exponent = 0;
 840     I32 seen_dp  = 0;
 841     I32 digit = 0;
 842     I32 old_digit = 0;
 843     I32 sig_digits = 0; /* noof significant digits seen so far */
 844
 845 /* There is no point in processing more significant digits
 846  * than the NV can hold. Note that NV_DIG is a lower-bound value,
 847  * while we need an upper-bound value. We add 2 to account for this;
 848  * since it will have been conservative on both the first and last digit.
 849  * For example a 32-bit mantissa with an exponent of 4 would have
 850  * exact values in the set
 851  *               4
 852  *               8
 853  *              ..
 854  *     17179869172
 855  *     17179869176
 856  *     17179869180
 857  *
 858  * where for the purposes of calculating NV_DIG we would have to discount
 859  * both the first and last digit, since neither can hold all values from
 860  * 0..9; but for calculating the value we must examine those two digits.
 861  */
 862 #define MAX_SIG_DIGITS (NV_DIG+2)
 863
 864 /* the max number we can accumulate in a UV, and still safely do 10*N+9 */
 865 #define MAX_ACCUMULATE ( (UV) ((UV_MAX - 9)/10))
 866
 867     /* leading whitespace */
 868     while (isSPACE(*s))
 869         ++s;
 870
 871     /* sign */
 872     switch (*s) {
 873         case '-':
 874             negative = 1;
 875             /* fall through */
 876         case '+':
 877             ++s;
 878     }
 879
 880     /* punt to strtod for NaN/Inf; if no support for it there, tough luck */
 881
 882 #ifdef HAS_STRTOD
 883     if (*s == 'n' || *s == 'N' || *s == 'i' || *s == 'I') {
 884         const char *p = negative ? s - 1 : s;
 885         char *endp;
 886         NV rslt;
 887         rslt = strtod(p, &endp);
 888         if (endp != p) {
 889             *value = rslt;
 890             return (char *)endp;
 891         }
 892     }
 893 #endif
 894
 895     /* we accumulate digits into an integer; when this becomes too
 896      * large, we add the total to NV and start again */
 897
 898     while (1) {
 899         if (isDIGIT(*s)) {
 900             seen_digit = 1;
 901             old_digit = digit;
 902             digit = *s++ - '0';
 903             if (seen_dp)
 904                 exp_adjust[1]++;
 905
 906             /* don't start counting until we see the first significant
 907              * digit, eg the 5 in 0.00005... */
 908             if (!sig_digits && digit == 0)
 909                 continue;
 910
 911             if (++sig_digits > MAX_SIG_DIGITS) {
 912                 /* limits of precision reached */
 913                 if (digit > 5) {
 914                     ++accumulator[seen_dp];
 915                 } else if (digit == 5) {
 916                     if (old_digit % 2) { /* round to even - Allen */
 917                         ++accumulator[seen_dp];
 918                     }
 919                 }
 920                 if (seen_dp) {
 921                     exp_adjust[1]--;
 922                 } else {
 923                     exp_adjust[0]++;
 924                 }
 925                 /* skip remaining digits */
 926                 while (isDIGIT(*s)) {
 927                     ++s;
 928                     if (! seen_dp) {
 929                         exp_adjust[0]++;
 930                     }
 931                 }
 932                 /* warn of loss of precision? */
 933             }
 934             else {
 935                 if (accumulator[seen_dp] > MAX_ACCUMULATE) {
 936                     /* add accumulator to result and start again */
 937                     result[seen_dp] = S_mulexp10(result[seen_dp],
 938                                                  exp_acc[seen_dp])
 939                         + (NV)accumulator[seen_dp];
 940                     accumulator[seen_dp] = 0;
 941                     exp_acc[seen_dp] = 0;
 942                 }
 943                 accumulator[seen_dp] = accumulator[seen_dp] * 10 + digit;
 944                 ++exp_acc[seen_dp];
 945             }
 946         }
 947         else if (!seen_dp && GROK_NUMERIC_RADIX(&s, send)) {
 948             seen_dp = 1;
 949             if (sig_digits > MAX_SIG_DIGITS) {
 950                 ++s;
 951                 while (isDIGIT(*s)) {
 952                     ++s;
 953                 }
 954                 break;
 955             }
 956         }
 957         else {
 958             break;
 959         }
 960     }
 961
 962     result[0] = S_mulexp10(result[0], exp_acc[0]) + (NV)accumulator[0];
 963     if (seen_dp) {
 964         result[1] = S_mulexp10(result[1], exp_acc[1]) + (NV)accumulator[1];
 965     }
 966
 967     if (seen_digit && (*s == 'e' || *s == 'E')) {
 968         bool expnegative = 0;
 969
 970         ++s;
 971         switch (*s) {
 972             case '-':
 973                 expnegative = 1;
 974                 /* fall through */
 975             case '+':
 976                 ++s;
 977         }
 978         while (isDIGIT(*s))
 979             exponent = exponent * 10 + (*s++ - '0');
 980         if (expnegative)
 981             exponent = -exponent;
 982     }
 983
 984
 985
 986     /* now apply the exponent */
 987
 988     if (seen_dp) {
 989         result[2] = S_mulexp10(result[0],exponent+exp_adjust[0])
 990                 + S_mulexp10(result[1],exponent-exp_adjust[1]);
 991     } else {
 992         result[2] = S_mulexp10(result[0],exponent+exp_adjust[0]);
 993     }
 994
 995     /* now apply the sign */
 996     if (negative)
 997         result[2] = -result[2];
 998 #endif /* USE_PERL_ATOF */
 999     *value = result[2];
1000     return (char *)s;
1001 }
1002
1003 #if ! defined(HAS_MODFL) && defined(HAS_AINTL) && defined(HAS_COPYSIGNL)
1004 long double
1005 Perl_my_modfl(long double x, long double *ip)
1006 {
1007         *ip = aintl(x);
1008         return (x == *ip ? copysignl(0.0L, x) : x - *ip);
1009 }
1010 #endif
1011
1012 #if ! defined(HAS_FREXPL) && defined(HAS_ILOGBL) && defined(HAS_SCALBNL)
1013 long double
1014 Perl_my_frexpl(long double x, int *e) {
1015         *e = x == 0.0L ? 0 : ilogbl(x) + 1;
1016         return (scalbnl(x, -*e));
1017 }
1018 #endif
1019
1020 /*
1021  * Local variables:
1022  * c-indentation-style: bsd
1023  * c-basic-offset: 4
1024  * indent-tabs-mode: t
1025  * End:
1026  *
1027  * ex: set ts=8 sts=4 sw=4 noet:
1028  */