numeric.c

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