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