numeric.c

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