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