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