1 /* numeric.c 2 * 3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 4 * 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others 5 * 6 * You may distribute under the terms of either the GNU General Public 7 * License or the Artistic License, as specified in the README file. 8 * 9 */ 10 11 /* 12 * "That only makes eleven (plus one mislaid) and not fourteen, 13 * unless wizards count differently to other people." --Beorn 14 * 15 * [p.115 of _The Hobbit_: "Queer Lodgings"] 16 */ 17 18 /* 19 =head1 Numeric functions 20 21 =cut 22 23 This file contains all the stuff needed by perl for manipulating numeric 24 values, including such things as replacements for the OS's atof() function 25 26 */ 27 28 #include "EXTERN.h" 29 #define PERL_IN_NUMERIC_C 30 #include "perl.h" 31 32 U32 33 Perl_cast_ulong(NV f) 34 { 35 if (f < 0.0) 36 return f < I32_MIN ? (U32) I32_MIN : (U32)(I32) f; 37 if (f < U32_MAX_P1) { 38 #if CASTFLAGS & 2 39 if (f < U32_MAX_P1_HALF) 40 return (U32) f; 41 f -= U32_MAX_P1_HALF; 42 return ((U32) f) | (1 + (U32_MAX >> 1)); 43 #else 44 return (U32) f; 45 #endif 46 } 47 return f > 0 ? U32_MAX : 0 /* NaN */; 48 } 49 50 I32 51 Perl_cast_i32(NV f) 52 { 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(NV f) 70 { 71 if (f < IV_MAX_P1) 72 return f < IV_MIN ? IV_MIN : (IV) f; 73 if (f < UV_MAX_P1) { 74 #if CASTFLAGS & 2 75 /* For future flexibility allowing for sizeof(UV) >= sizeof(IV) */ 76 if (f < UV_MAX_P1_HALF) 77 return (IV)(UV) f; 78 f -= UV_MAX_P1_HALF; 79 return (IV)(((UV) f) | (1 + (UV_MAX >> 1))); 80 #else 81 return (IV)(UV) f; 82 #endif 83 } 84 return f > 0 ? (IV)UV_MAX : 0 /* NaN */; 85 } 86 87 UV 88 Perl_cast_uv(NV f) 89 { 90 if (f < 0.0) 91 return f < IV_MIN ? (UV) IV_MIN : (UV)(IV) f; 92 if (f < UV_MAX_P1) { 93 #if CASTFLAGS & 2 94 if (f < UV_MAX_P1_HALF) 95 return (UV) f; 96 f -= UV_MAX_P1_HALF; 97 return ((UV) f) | (1 + (UV_MAX >> 1)); 98 #else 99 return (UV) f; 100 #endif 101 } 102 return f > 0 ? UV_MAX : 0 /* NaN */; 103 } 104 105 /* 106 =for apidoc grok_bin 107 108 converts a string representing a binary number to numeric form. 109 110 On entry C<start> and C<*len> give the string to scan, C<*flags> gives 111 conversion flags, and C<result> should be C<NULL> or a pointer to an NV. 112 The scan stops at the end of the string, or the first invalid character. 113 Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in C<*flags>, encountering an 114 invalid character will also trigger a warning. 115 On return C<*len> is set to the length of the scanned string, 116 and C<*flags> gives output flags. 117 118 If the value is <= C<UV_MAX> it is returned as a UV, the output flags are clear, 119 and nothing is written to C<*result>. If the value is > C<UV_MAX>, C<grok_bin> 120 returns C<UV_MAX>, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags, 121 and writes the value to C<*result> (or the value is discarded if C<result> 122 is NULL). 123 124 The binary number may optionally be prefixed with C<"0b"> or C<"b"> unless 125 C<PERL_SCAN_DISALLOW_PREFIX> is set in C<*flags> on entry. If 126 C<PERL_SCAN_ALLOW_UNDERSCORES> is set in C<*flags> then the binary 127 number may use C<"_"> characters to separate digits. 128 129 =cut 130 131 Not documented yet because experimental is C<PERL_SCAN_SILENT_NON_PORTABLE 132 which suppresses any message for non-portable numbers that are still valid 133 on this platform. 134 */ 135 136 UV 137 Perl_grok_bin(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) 138 { 139 const char *s = start; 140 STRLEN len = *len_p; 141 UV value = 0; 142 NV value_nv = 0; 143 144 const UV max_div_2 = UV_MAX / 2; 145 const bool allow_underscores = cBOOL(*flags & PERL_SCAN_ALLOW_UNDERSCORES); 146 bool overflowed = FALSE; 147 char bit; 148 149 PERL_ARGS_ASSERT_GROK_BIN; 150 151 if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { 152 /* strip off leading b or 0b. 153 for compatibility silently suffer "b" and "0b" as valid binary 154 numbers. */ 155 if (len >= 1) { 156 if (isALPHA_FOLD_EQ(s[0], 'b')) { 157 s++; 158 len--; 159 } 160 else if (len >= 2 && s[0] == '0' && (isALPHA_FOLD_EQ(s[1], 'b'))) { 161 s+=2; 162 len-=2; 163 } 164 } 165 } 166 167 for (; len-- && (bit = *s); s++) { 168 if (bit == '0' || bit == '1') { 169 /* Write it in this wonky order with a goto to attempt to get the 170 compiler to make the common case integer-only loop pretty tight. 171 With gcc seems to be much straighter code than old scan_bin. */ 172 redo: 173 if (!overflowed) { 174 if (value <= max_div_2) { 175 value = (value << 1) | (bit - '0'); 176 continue; 177 } 178 /* Bah. We're just overflowed. */ 179 /* diag_listed_as: Integer overflow in %s number */ 180 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW), 181 "Integer overflow in binary number"); 182 overflowed = TRUE; 183 value_nv = (NV) value; 184 } 185 value_nv *= 2.0; 186 /* If an NV has not enough bits in its mantissa to 187 * represent a UV this summing of small low-order numbers 188 * is a waste of time (because the NV cannot preserve 189 * the low-order bits anyway): we could just remember when 190 * did we overflow and in the end just multiply value_nv by the 191 * right amount. */ 192 value_nv += (NV)(bit - '0'); 193 continue; 194 } 195 if (bit == '_' && len && allow_underscores && (bit = s[1]) 196 && (bit == '0' || bit == '1')) 197 { 198 --len; 199 ++s; 200 goto redo; 201 } 202 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) 203 Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT), 204 "Illegal binary digit '%c' ignored", *s); 205 break; 206 } 207 208 if ( ( overflowed && value_nv > 4294967295.0) 209 #if UVSIZE > 4 210 || (!overflowed && value > 0xffffffff 211 && ! (*flags & PERL_SCAN_SILENT_NON_PORTABLE)) 212 #endif 213 ) { 214 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), 215 "Binary number > 0b11111111111111111111111111111111 non-portable"); 216 } 217 *len_p = s - start; 218 if (!overflowed) { 219 *flags = 0; 220 return value; 221 } 222 *flags = PERL_SCAN_GREATER_THAN_UV_MAX; 223 if (result) 224 *result = value_nv; 225 return UV_MAX; 226 } 227 228 /* 229 =for apidoc grok_hex 230 231 converts a string representing a hex number to numeric form. 232 233 On entry C<start> and C<*len_p> give the string to scan, C<*flags> gives 234 conversion flags, and C<result> should be C<NULL> or a pointer to an NV. 235 The scan stops at the end of the string, or the first invalid character. 236 Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in C<*flags>, encountering an 237 invalid character will also trigger a warning. 238 On return C<*len> is set to the length of the scanned string, 239 and C<*flags> gives output flags. 240 241 If the value is <= C<UV_MAX> it is returned as a UV, the output flags are clear, 242 and nothing is written to C<*result>. If the value is > C<UV_MAX>, C<grok_hex> 243 returns C<UV_MAX>, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags, 244 and writes the value to C<*result> (or the value is discarded if C<result> 245 is C<NULL>). 246 247 The hex number may optionally be prefixed with C<"0x"> or C<"x"> unless 248 C<PERL_SCAN_DISALLOW_PREFIX> is set in C<*flags> on entry. If 249 C<PERL_SCAN_ALLOW_UNDERSCORES> is set in C<*flags> then the hex 250 number may use C<"_"> characters to separate digits. 251 252 =cut 253 254 Not documented yet because experimental is C<PERL_SCAN_SILENT_NON_PORTABLE 255 which suppresses any message for non-portable numbers, but which are valid 256 on this platform. 257 */ 258 259 UV 260 Perl_grok_hex(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) 261 { 262 const char *s = start; 263 STRLEN len = *len_p; 264 UV value = 0; 265 NV value_nv = 0; 266 const UV max_div_16 = UV_MAX / 16; 267 const bool allow_underscores = cBOOL(*flags & PERL_SCAN_ALLOW_UNDERSCORES); 268 bool overflowed = FALSE; 269 270 PERL_ARGS_ASSERT_GROK_HEX; 271 272 if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { 273 /* strip off leading x or 0x. 274 for compatibility silently suffer "x" and "0x" as valid hex numbers. 275 */ 276 if (len >= 1) { 277 if (isALPHA_FOLD_EQ(s[0], 'x')) { 278 s++; 279 len--; 280 } 281 else if (len >= 2 && s[0] == '0' && (isALPHA_FOLD_EQ(s[1], 'x'))) { 282 s+=2; 283 len-=2; 284 } 285 } 286 } 287 288 for (; len-- && *s; s++) { 289 if (isXDIGIT(*s)) { 290 /* Write it in this wonky order with a goto to attempt to get the 291 compiler to make the common case integer-only loop pretty tight. 292 With gcc seems to be much straighter code than old scan_hex. */ 293 redo: 294 if (!overflowed) { 295 if (value <= max_div_16) { 296 value = (value << 4) | XDIGIT_VALUE(*s); 297 continue; 298 } 299 /* Bah. We're just overflowed. */ 300 /* diag_listed_as: Integer overflow in %s number */ 301 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW), 302 "Integer overflow in hexadecimal number"); 303 overflowed = TRUE; 304 value_nv = (NV) value; 305 } 306 value_nv *= 16.0; 307 /* If an NV has not enough bits in its mantissa to 308 * represent a UV this summing of small low-order numbers 309 * is a waste of time (because the NV cannot preserve 310 * the low-order bits anyway): we could just remember when 311 * did we overflow and in the end just multiply value_nv by the 312 * right amount of 16-tuples. */ 313 value_nv += (NV) XDIGIT_VALUE(*s); 314 continue; 315 } 316 if (*s == '_' && len && allow_underscores && s[1] 317 && isXDIGIT(s[1])) 318 { 319 --len; 320 ++s; 321 goto redo; 322 } 323 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) 324 Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT), 325 "Illegal hexadecimal digit '%c' ignored", *s); 326 break; 327 } 328 329 if ( ( overflowed && value_nv > 4294967295.0) 330 #if UVSIZE > 4 331 || (!overflowed && value > 0xffffffff 332 && ! (*flags & PERL_SCAN_SILENT_NON_PORTABLE)) 333 #endif 334 ) { 335 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), 336 "Hexadecimal number > 0xffffffff non-portable"); 337 } 338 *len_p = s - start; 339 if (!overflowed) { 340 *flags = 0; 341 return value; 342 } 343 *flags = PERL_SCAN_GREATER_THAN_UV_MAX; 344 if (result) 345 *result = value_nv; 346 return UV_MAX; 347 } 348 349 /* 350 =for apidoc grok_oct 351 352 converts a string representing an octal number to numeric form. 353 354 On entry C<start> and C<*len> give the string to scan, C<*flags> gives 355 conversion flags, and C<result> should be C<NULL> or a pointer to an NV. 356 The scan stops at the end of the string, or the first invalid character. 357 Unless C<PERL_SCAN_SILENT_ILLDIGIT> is set in C<*flags>, encountering an 358 8 or 9 will also trigger a warning. 359 On return C<*len> is set to the length of the scanned string, 360 and C<*flags> gives output flags. 361 362 If the value is <= C<UV_MAX> it is returned as a UV, the output flags are clear, 363 and nothing is written to C<*result>. If the value is > C<UV_MAX>, C<grok_oct> 364 returns C<UV_MAX>, sets C<PERL_SCAN_GREATER_THAN_UV_MAX> in the output flags, 365 and writes the value to C<*result> (or the value is discarded if C<result> 366 is C<NULL>). 367 368 If C<PERL_SCAN_ALLOW_UNDERSCORES> is set in C<*flags> then the octal 369 number may use C<"_"> characters to separate digits. 370 371 =cut 372 373 Not documented yet because experimental is C<PERL_SCAN_SILENT_NON_PORTABLE> 374 which suppresses any message for non-portable numbers, but which are valid 375 on this platform. 376 */ 377 378 UV 379 Perl_grok_oct(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) 380 { 381 const char *s = start; 382 STRLEN len = *len_p; 383 UV value = 0; 384 NV value_nv = 0; 385 const UV max_div_8 = UV_MAX / 8; 386 const bool allow_underscores = cBOOL(*flags & PERL_SCAN_ALLOW_UNDERSCORES); 387 bool overflowed = FALSE; 388 389 PERL_ARGS_ASSERT_GROK_OCT; 390 391 for (; len-- && *s; s++) { 392 if (isOCTAL(*s)) { 393 /* Write it in this wonky order with a goto to attempt to get the 394 compiler to make the common case integer-only loop pretty tight. 395 */ 396 redo: 397 if (!overflowed) { 398 if (value <= max_div_8) { 399 value = (value << 3) | OCTAL_VALUE(*s); 400 continue; 401 } 402 /* Bah. We're just overflowed. */ 403 /* diag_listed_as: Integer overflow in %s number */ 404 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW), 405 "Integer overflow in octal number"); 406 overflowed = TRUE; 407 value_nv = (NV) value; 408 } 409 value_nv *= 8.0; 410 /* If an NV has not enough bits in its mantissa to 411 * represent a UV this summing of small low-order numbers 412 * is a waste of time (because the NV cannot preserve 413 * the low-order bits anyway): we could just remember when 414 * did we overflow and in the end just multiply value_nv by the 415 * right amount of 8-tuples. */ 416 value_nv += (NV) OCTAL_VALUE(*s); 417 continue; 418 } 419 if (*s == '_' && len && allow_underscores && isOCTAL(s[1])) { 420 --len; 421 ++s; 422 goto redo; 423 } 424 /* Allow \octal to work the DWIM way (that is, stop scanning 425 * as soon as non-octal characters are seen, complain only if 426 * someone seems to want to use the digits eight and nine. Since we 427 * know it is not octal, then if isDIGIT, must be an 8 or 9). */ 428 if (isDIGIT(*s)) { 429 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) 430 Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT), 431 "Illegal octal digit '%c' ignored", *s); 432 } 433 break; 434 } 435 436 if ( ( overflowed && value_nv > 4294967295.0) 437 #if UVSIZE > 4 438 || (!overflowed && value > 0xffffffff 439 && ! (*flags & PERL_SCAN_SILENT_NON_PORTABLE)) 440 #endif 441 ) { 442 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), 443 "Octal number > 037777777777 non-portable"); 444 } 445 *len_p = s - start; 446 if (!overflowed) { 447 *flags = 0; 448 return value; 449 } 450 *flags = PERL_SCAN_GREATER_THAN_UV_MAX; 451 if (result) 452 *result = value_nv; 453 return UV_MAX; 454 } 455 456 /* 457 =for apidoc scan_bin 458 459 For backwards compatibility. Use C<grok_bin> instead. 460 461 =for apidoc scan_hex 462 463 For backwards compatibility. Use C<grok_hex> instead. 464 465 =for apidoc scan_oct 466 467 For backwards compatibility. Use C<grok_oct> instead. 468 469 =cut 470 */ 471 472 NV 473 Perl_scan_bin(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_bin (start, &len, &flags, &rnv); 478 479 PERL_ARGS_ASSERT_SCAN_BIN; 480 481 *retlen = len; 482 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv; 483 } 484 485 NV 486 Perl_scan_oct(pTHX_ const char *start, STRLEN len, STRLEN *retlen) 487 { 488 NV rnv; 489 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0; 490 const UV ruv = grok_oct (start, &len, &flags, &rnv); 491 492 PERL_ARGS_ASSERT_SCAN_OCT; 493 494 *retlen = len; 495 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv; 496 } 497 498 NV 499 Perl_scan_hex(pTHX_ const char *start, STRLEN len, STRLEN *retlen) 500 { 501 NV rnv; 502 I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0; 503 const UV ruv = grok_hex (start, &len, &flags, &rnv); 504 505 PERL_ARGS_ASSERT_SCAN_HEX; 506 507 *retlen = len; 508 return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv; 509 } 510 511 /* 512 =for apidoc grok_numeric_radix 513 514 Scan and skip for a numeric decimal separator (radix). 515 516 =cut 517 */ 518 bool 519 Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send) 520 { 521 PERL_ARGS_ASSERT_GROK_NUMERIC_RADIX; 522 523 #ifdef USE_LOCALE_NUMERIC 524 525 if (IN_LC(LC_NUMERIC)) { 526 STRLEN len; 527 char * radix; 528 bool matches_radix = FALSE; 529 DECLARATION_FOR_LC_NUMERIC_MANIPULATION; 530 531 STORE_LC_NUMERIC_FORCE_TO_UNDERLYING(); 532 533 radix = SvPV(PL_numeric_radix_sv, len); 534 radix = savepvn(radix, len); 535 536 RESTORE_LC_NUMERIC(); 537 538 if (*sp + len <= send) { 539 matches_radix = memEQ(*sp, radix, len); 540 } 541 542 Safefree(radix); 543 544 if (matches_radix) { 545 *sp += len; 546 return TRUE; 547 } 548 } 549 550 #endif 551 552 /* always try "." if numeric radix didn't match because 553 * we may have data from different locales mixed */ 554 if (*sp < send && **sp == '.') { 555 ++*sp; 556 return TRUE; 557 } 558 559 return FALSE; 560 } 561 562 /* 563 =for apidoc grok_infnan 564 565 Helper for C<grok_number()>, accepts various ways of spelling "infinity" 566 or "not a number", and returns one of the following flag combinations: 567 568 IS_NUMBER_INFINITY 569 IS_NUMBER_NAN 570 IS_NUMBER_INFINITY | IS_NUMBER_NEG 571 IS_NUMBER_NAN | IS_NUMBER_NEG 572 0 573 574 possibly |-ed with C<IS_NUMBER_TRAILING>. 575 576 If an infinity or a not-a-number is recognized, C<*sp> will point to 577 one byte past the end of the recognized string. If the recognition fails, 578 zero is returned, and C<*sp> will not move. 579 580 =cut 581 */ 582 583 int 584 Perl_grok_infnan(pTHX_ const char** sp, const char* send) 585 { 586 const char* s = *sp; 587 int flags = 0; 588 #if defined(NV_INF) || defined(NV_NAN) 589 bool odh = FALSE; /* one-dot-hash: 1.#INF */ 590 591 PERL_ARGS_ASSERT_GROK_INFNAN; 592 593 if (*s == '+') { 594 s++; if (s == send) return 0; 595 } 596 else if (*s == '-') { 597 flags |= IS_NUMBER_NEG; /* Yes, -NaN happens. Incorrect but happens. */ 598 s++; if (s == send) return 0; 599 } 600 601 if (*s == '1') { 602 /* Visual C: 1.#SNAN, -1.#QNAN, 1#INF, 1.#IND (maybe also 1.#NAN) 603 * Let's keep the dot optional. */ 604 s++; if (s == send) return 0; 605 if (*s == '.') { 606 s++; if (s == send) return 0; 607 } 608 if (*s == '#') { 609 s++; if (s == send) return 0; 610 } else 611 return 0; 612 odh = TRUE; 613 } 614 615 if (isALPHA_FOLD_EQ(*s, 'I')) { 616 /* INF or IND (1.#IND is "indeterminate", a certain type of NAN) */ 617 618 s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return 0; 619 s++; if (s == send) return 0; 620 if (isALPHA_FOLD_EQ(*s, 'F')) { 621 s++; 622 if (s < send && (isALPHA_FOLD_EQ(*s, 'I'))) { 623 int fail = 624 flags | IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING; 625 s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return fail; 626 s++; if (s == send || isALPHA_FOLD_NE(*s, 'I')) return fail; 627 s++; if (s == send || isALPHA_FOLD_NE(*s, 'T')) return fail; 628 s++; if (s == send || isALPHA_FOLD_NE(*s, 'Y')) return fail; 629 s++; 630 } else if (odh) { 631 while (*s == '0') { /* 1.#INF00 */ 632 s++; 633 } 634 } 635 while (s < send && isSPACE(*s)) 636 s++; 637 if (s < send && *s) { 638 flags |= IS_NUMBER_TRAILING; 639 } 640 flags |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; 641 } 642 else if (isALPHA_FOLD_EQ(*s, 'D') && odh) { /* 1.#IND */ 643 s++; 644 flags |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; 645 while (*s == '0') { /* 1.#IND00 */ 646 s++; 647 } 648 if (*s) { 649 flags |= IS_NUMBER_TRAILING; 650 } 651 } else 652 return 0; 653 } 654 else { 655 /* Maybe NAN of some sort */ 656 657 if (isALPHA_FOLD_EQ(*s, 'S') || isALPHA_FOLD_EQ(*s, 'Q')) { 658 /* snan, qNaN */ 659 /* XXX do something with the snan/qnan difference */ 660 s++; if (s == send) return 0; 661 } 662 663 if (isALPHA_FOLD_EQ(*s, 'N')) { 664 s++; if (s == send || isALPHA_FOLD_NE(*s, 'A')) return 0; 665 s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return 0; 666 s++; 667 668 flags |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; 669 670 /* NaN can be followed by various stuff (NaNQ, NaNS), but 671 * there are also multiple different NaN values, and some 672 * implementations output the "payload" values, 673 * e.g. NaN123, NAN(abc), while some legacy implementations 674 * have weird stuff like NaN%. */ 675 if (isALPHA_FOLD_EQ(*s, 'q') || 676 isALPHA_FOLD_EQ(*s, 's')) { 677 /* "nanq" or "nans" are ok, though generating 678 * these portably is tricky. */ 679 s++; 680 } 681 if (*s == '(') { 682 /* C99 style "nan(123)" or Perlish equivalent "nan($uv)". */ 683 const char *t; 684 s++; 685 if (s == send) { 686 return flags | IS_NUMBER_TRAILING; 687 } 688 t = s + 1; 689 while (t < send && *t && *t != ')') { 690 t++; 691 } 692 if (t == send) { 693 return flags | IS_NUMBER_TRAILING; 694 } 695 if (*t == ')') { 696 int nantype; 697 UV nanval; 698 if (s[0] == '0' && s + 2 < t && 699 isALPHA_FOLD_EQ(s[1], 'x') && 700 isXDIGIT(s[2])) { 701 STRLEN len = t - s; 702 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES; 703 nanval = grok_hex(s, &len, &flags, NULL); 704 if ((flags & PERL_SCAN_GREATER_THAN_UV_MAX)) { 705 nantype = 0; 706 } else { 707 nantype = IS_NUMBER_IN_UV; 708 } 709 s += len; 710 } else if (s[0] == '0' && s + 2 < t && 711 isALPHA_FOLD_EQ(s[1], 'b') && 712 (s[2] == '0' || s[2] == '1')) { 713 STRLEN len = t - s; 714 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES; 715 nanval = grok_bin(s, &len, &flags, NULL); 716 if ((flags & PERL_SCAN_GREATER_THAN_UV_MAX)) { 717 nantype = 0; 718 } else { 719 nantype = IS_NUMBER_IN_UV; 720 } 721 s += len; 722 } else { 723 const char *u; 724 nantype = 725 grok_number_flags(s, t - s, &nanval, 726 PERL_SCAN_TRAILING | 727 PERL_SCAN_ALLOW_UNDERSCORES); 728 /* Unfortunately grok_number_flags() doesn't 729 * tell how far we got and the ')' will always 730 * be "trailing", so we need to double-check 731 * whether we had something dubious. */ 732 for (u = s; u < t; u++) { 733 if (!isDIGIT(*u)) { 734 flags |= IS_NUMBER_TRAILING; 735 break; 736 } 737 } 738 s = u; 739 } 740 741 /* XXX Doesn't do octal: nan("0123"). 742 * Probably not a big loss. */ 743 744 if ((nantype & IS_NUMBER_NOT_INT) || 745 !(nantype && IS_NUMBER_IN_UV)) { 746 /* XXX the nanval is currently unused, that is, 747 * not inserted as the NaN payload of the NV. 748 * But the above code already parses the C99 749 * nan(...) format. See below, and see also 750 * the nan() in POSIX.xs. 751 * 752 * Certain configuration combinations where 753 * NVSIZE is greater than UVSIZE mean that 754 * a single UV cannot contain all the possible 755 * NaN payload bits. There would need to be 756 * some more generic syntax than "nan($uv)". 757 * 758 * Issues to keep in mind: 759 * 760 * (1) In most common cases there would 761 * not be an integral number of bytes that 762 * could be set, only a certain number of bits. 763 * For example for the common case of 764 * NVSIZE == UVSIZE == 8 there is room for 52 765 * bits in the payload, but the most significant 766 * bit is commonly reserved for the 767 * signaling/quiet bit, leaving 51 bits. 768 * Furthermore, the C99 nan() is supposed 769 * to generate quiet NaNs, so it is doubtful 770 * whether it should be able to generate 771 * signaling NaNs. For the x86 80-bit doubles 772 * (if building a long double Perl) there would 773 * be 62 bits (s/q bit being the 63rd). 774 * 775 * (2) Endianness of the payload bits. If the 776 * payload is specified as an UV, the low-order 777 * bits of the UV are naturally little-endianed 778 * (rightmost) bits of the payload. The endianness 779 * of UVs and NVs can be different. */ 780 return 0; 781 } 782 if (s < t) { 783 flags |= IS_NUMBER_TRAILING; 784 } 785 } else { 786 /* Looked like nan(...), but no close paren. */ 787 flags |= IS_NUMBER_TRAILING; 788 } 789 } else { 790 while (s < send && isSPACE(*s)) 791 s++; 792 if (s < send && *s) { 793 /* Note that we here implicitly accept (parse as 794 * "nan", but with warnings) also any other weird 795 * trailing stuff for "nan". In the above we just 796 * check that if we got the C99-style "nan(...)", 797 * the "..." looks sane. 798 * If in future we accept more ways of specifying 799 * the nan payload, the accepting would happen around 800 * here. */ 801 flags |= IS_NUMBER_TRAILING; 802 } 803 } 804 s = send; 805 } 806 else 807 return 0; 808 } 809 810 while (s < send && isSPACE(*s)) 811 s++; 812 813 #else 814 PERL_UNUSED_ARG(send); 815 #endif /* #if defined(NV_INF) || defined(NV_NAN) */ 816 *sp = s; 817 return flags; 818 } 819 820 /* 821 =for apidoc grok_number_flags 822 823 Recognise (or not) a number. The type of the number is returned 824 (0 if unrecognised), otherwise it is a bit-ORed combination of 825 C<IS_NUMBER_IN_UV>, C<IS_NUMBER_GREATER_THAN_UV_MAX>, C<IS_NUMBER_NOT_INT>, 826 C<IS_NUMBER_NEG>, C<IS_NUMBER_INFINITY>, C<IS_NUMBER_NAN> (defined in perl.h). 827 828 If the value of the number can fit in a UV, it is returned in C<*valuep>. 829 C<IS_NUMBER_IN_UV> will be set to indicate that C<*valuep> is valid, C<IS_NUMBER_IN_UV> 830 will never be set unless C<*valuep> is valid, but C<*valuep> may have been assigned 831 to during processing even though C<IS_NUMBER_IN_UV> is not set on return. 832 If C<valuep> is C<NULL>, C<IS_NUMBER_IN_UV> will be set for the same cases as when 833 C<valuep> is non-C<NULL>, but no actual assignment (or SEGV) will occur. 834 835 C<IS_NUMBER_NOT_INT> will be set with C<IS_NUMBER_IN_UV> if trailing decimals were 836 seen (in which case C<*valuep> gives the true value truncated to an integer), and 837 C<IS_NUMBER_NEG> if the number is negative (in which case C<*valuep> holds the 838 absolute value). C<IS_NUMBER_IN_UV> is not set if e notation was used or the 839 number is larger than a UV. 840 841 C<flags> allows only C<PERL_SCAN_TRAILING>, which allows for trailing 842 non-numeric text on an otherwise successful I<grok>, setting 843 C<IS_NUMBER_TRAILING> on the result. 844 845 =for apidoc grok_number 846 847 Identical to C<grok_number_flags()> with C<flags> set to zero. 848 849 =cut 850 */ 851 int 852 Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep) 853 { 854 PERL_ARGS_ASSERT_GROK_NUMBER; 855 856 return grok_number_flags(pv, len, valuep, 0); 857 } 858 859 static const UV uv_max_div_10 = UV_MAX / 10; 860 static const U8 uv_max_mod_10 = UV_MAX % 10; 861 862 int 863 Perl_grok_number_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, U32 flags) 864 { 865 const char *s = pv; 866 const char * const send = pv + len; 867 const char *d; 868 int numtype = 0; 869 870 PERL_ARGS_ASSERT_GROK_NUMBER_FLAGS; 871 872 while (s < send && isSPACE(*s)) 873 s++; 874 if (s == send) { 875 return 0; 876 } else if (*s == '-') { 877 s++; 878 numtype = IS_NUMBER_NEG; 879 } 880 else if (*s == '+') 881 s++; 882 883 if (s == send) 884 return 0; 885 886 /* The first digit (after optional sign): note that might 887 * also point to "infinity" or "nan", or "1.#INF". */ 888 d = s; 889 890 /* next must be digit or the radix separator or beginning of infinity/nan */ 891 if (isDIGIT(*s)) { 892 /* UVs are at least 32 bits, so the first 9 decimal digits cannot 893 overflow. */ 894 UV value = *s - '0'; 895 /* This construction seems to be more optimiser friendly. 896 (without it gcc does the isDIGIT test and the *s - '0' separately) 897 With it gcc on arm is managing 6 instructions (6 cycles) per digit. 898 In theory the optimiser could deduce how far to unroll the loop 899 before checking for overflow. */ 900 if (++s < send) { 901 int digit = *s - '0'; 902 if (digit >= 0 && digit <= 9) { 903 value = value * 10 + digit; 904 if (++s < send) { 905 digit = *s - '0'; 906 if (digit >= 0 && digit <= 9) { 907 value = value * 10 + digit; 908 if (++s < send) { 909 digit = *s - '0'; 910 if (digit >= 0 && digit <= 9) { 911 value = value * 10 + digit; 912 if (++s < send) { 913 digit = *s - '0'; 914 if (digit >= 0 && digit <= 9) { 915 value = value * 10 + digit; 916 if (++s < send) { 917 digit = *s - '0'; 918 if (digit >= 0 && digit <= 9) { 919 value = value * 10 + digit; 920 if (++s < send) { 921 digit = *s - '0'; 922 if (digit >= 0 && digit <= 9) { 923 value = value * 10 + digit; 924 if (++s < send) { 925 digit = *s - '0'; 926 if (digit >= 0 && digit <= 9) { 927 value = value * 10 + digit; 928 if (++s < send) { 929 digit = *s - '0'; 930 if (digit >= 0 && digit <= 9) { 931 value = value * 10 + digit; 932 if (++s < send) { 933 /* Now got 9 digits, so need to check 934 each time for overflow. */ 935 digit = *s - '0'; 936 while (digit >= 0 && digit <= 9 937 && (value < uv_max_div_10 938 || (value == uv_max_div_10 939 && digit <= uv_max_mod_10))) { 940 value = value * 10 + digit; 941 if (++s < send) 942 digit = *s - '0'; 943 else 944 break; 945 } 946 if (digit >= 0 && digit <= 9 947 && (s < send)) { 948 /* value overflowed. 949 skip the remaining digits, don't 950 worry about setting *valuep. */ 951 do { 952 s++; 953 } while (s < send && isDIGIT(*s)); 954 numtype |= 955 IS_NUMBER_GREATER_THAN_UV_MAX; 956 goto skip_value; 957 } 958 } 959 } 960 } 961 } 962 } 963 } 964 } 965 } 966 } 967 } 968 } 969 } 970 } 971 } 972 } 973 } 974 } 975 numtype |= IS_NUMBER_IN_UV; 976 if (valuep) 977 *valuep = value; 978 979 skip_value: 980 if (GROK_NUMERIC_RADIX(&s, send)) { 981 numtype |= IS_NUMBER_NOT_INT; 982 while (s < send && isDIGIT(*s)) /* optional digits after the radix */ 983 s++; 984 } 985 } 986 else if (GROK_NUMERIC_RADIX(&s, send)) { 987 numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */ 988 /* no digits before the radix means we need digits after it */ 989 if (s < send && isDIGIT(*s)) { 990 do { 991 s++; 992 } while (s < send && isDIGIT(*s)); 993 if (valuep) { 994 /* integer approximation is valid - it's 0. */ 995 *valuep = 0; 996 } 997 } 998 else 999 return 0; 1000 } 1001 1002 if (s > d && s < send) { 1003 /* we can have an optional exponent part */ 1004 if (isALPHA_FOLD_EQ(*s, 'e')) { 1005 s++; 1006 if (s < send && (*s == '-' || *s == '+')) 1007 s++; 1008 if (s < send && isDIGIT(*s)) { 1009 do { 1010 s++; 1011 } while (s < send && isDIGIT(*s)); 1012 } 1013 else if (flags & PERL_SCAN_TRAILING) 1014 return numtype | IS_NUMBER_TRAILING; 1015 else 1016 return 0; 1017 1018 /* The only flag we keep is sign. Blow away any "it's UV" */ 1019 numtype &= IS_NUMBER_NEG; 1020 numtype |= IS_NUMBER_NOT_INT; 1021 } 1022 } 1023 while (s < send && isSPACE(*s)) 1024 s++; 1025 if (s >= send) 1026 return numtype; 1027 if (memEQs(pv, len, "0 but true")) { 1028 if (valuep) 1029 *valuep = 0; 1030 return IS_NUMBER_IN_UV; 1031 } 1032 /* We could be e.g. at "Inf" or "NaN", or at the "#" of "1.#INF". */ 1033 if ((s + 2 < send) && strchr("inqs#", toFOLD(*s))) { 1034 /* Really detect inf/nan. Start at d, not s, since the above 1035 * code might have already consumed the "1." or "1". */ 1036 const int infnan = Perl_grok_infnan(aTHX_ &d, send); 1037 if ((infnan & IS_NUMBER_INFINITY)) { 1038 return (numtype | infnan); /* Keep sign for infinity. */ 1039 } 1040 else if ((infnan & IS_NUMBER_NAN)) { 1041 return (numtype | infnan) & ~IS_NUMBER_NEG; /* Clear sign for nan. */ 1042 } 1043 } 1044 else if (flags & PERL_SCAN_TRAILING) { 1045 return numtype | IS_NUMBER_TRAILING; 1046 } 1047 1048 return 0; 1049 } 1050 1051 /* 1052 grok_atoUV 1053 1054 grok_atoUV parses a C-style zero-byte terminated string, looking for 1055 a decimal unsigned integer. 1056 1057 Returns the unsigned integer, if a valid value can be parsed 1058 from the beginning of the string. 1059 1060 Accepts only the decimal digits '0'..'9'. 1061 1062 As opposed to atoi or strtol, grok_atoUV does NOT allow optional 1063 leading whitespace, or negative inputs. If such features are 1064 required, the calling code needs to explicitly implement those. 1065 1066 Returns true if a valid value could be parsed. In that case, valptr 1067 is set to the parsed value, and endptr (if provided) is set to point 1068 to the character after the last digit. 1069 1070 Returns false otherwise. This can happen if a) there is a leading zero 1071 followed by another digit; b) the digits would overflow a UV; or c) 1072 there are trailing non-digits AND endptr is not provided. 1073 1074 Background: atoi has severe problems with illegal inputs, it cannot be 1075 used for incremental parsing, and therefore should be avoided 1076 atoi and strtol are also affected by locale settings, which can also be 1077 seen as a bug (global state controlled by user environment). 1078 1079 */ 1080 1081 bool 1082 Perl_grok_atoUV(const char *pv, UV *valptr, const char** endptr) 1083 { 1084 const char* s = pv; 1085 const char** eptr; 1086 const char* end2; /* Used in case endptr is NULL. */ 1087 UV val = 0; /* The parsed value. */ 1088 1089 PERL_ARGS_ASSERT_GROK_ATOUV; 1090 1091 eptr = endptr ? endptr : &end2; 1092 if (isDIGIT(*s)) { 1093 /* Single-digit inputs are quite common. */ 1094 val = *s++ - '0'; 1095 if (isDIGIT(*s)) { 1096 /* Fail on extra leading zeros. */ 1097 if (val == 0) 1098 return FALSE; 1099 while (isDIGIT(*s)) { 1100 /* This could be unrolled like in grok_number(), but 1101 * the expected uses of this are not speed-needy, and 1102 * unlikely to need full 64-bitness. */ 1103 const U8 digit = *s++ - '0'; 1104 if (val < uv_max_div_10 || 1105 (val == uv_max_div_10 && digit <= uv_max_mod_10)) { 1106 val = val * 10 + digit; 1107 } else { 1108 return FALSE; 1109 } 1110 } 1111 } 1112 } 1113 if (s == pv) 1114 return FALSE; 1115 if (endptr == NULL && *s) 1116 return FALSE; /* If endptr is NULL, no trailing non-digits allowed. */ 1117 *eptr = s; 1118 *valptr = val; 1119 return TRUE; 1120 } 1121 1122 #ifndef USE_QUADMATH 1123 STATIC NV 1124 S_mulexp10(NV value, I32 exponent) 1125 { 1126 NV result = 1.0; 1127 NV power = 10.0; 1128 bool negative = 0; 1129 I32 bit; 1130 1131 if (exponent == 0) 1132 return value; 1133 if (value == 0) 1134 return (NV)0; 1135 1136 /* On OpenVMS VAX we by default use the D_FLOAT double format, 1137 * and that format does not have *easy* capabilities [1] for 1138 * overflowing doubles 'silently' as IEEE fp does. We also need 1139 * to support G_FLOAT on both VAX and Alpha, and though the exponent 1140 * range is much larger than D_FLOAT it still doesn't do silent 1141 * overflow. Therefore we need to detect early whether we would 1142 * overflow (this is the behaviour of the native string-to-float 1143 * conversion routines, and therefore of native applications, too). 1144 * 1145 * [1] Trying to establish a condition handler to trap floating point 1146 * exceptions is not a good idea. */ 1147 1148 /* In UNICOS and in certain Cray models (such as T90) there is no 1149 * IEEE fp, and no way at all from C to catch fp overflows gracefully. 1150 * There is something you can do if you are willing to use some 1151 * inline assembler: the instruction is called DFI-- but that will 1152 * disable *all* floating point interrupts, a little bit too large 1153 * a hammer. Therefore we need to catch potential overflows before 1154 * it's too late. */ 1155 1156 #if ((defined(VMS) && !defined(_IEEE_FP)) || defined(_UNICOS) || defined(DOUBLE_IS_VAX_FLOAT)) && defined(NV_MAX_10_EXP) 1157 STMT_START { 1158 const NV exp_v = log10(value); 1159 if (exponent >= NV_MAX_10_EXP || exponent + exp_v >= NV_MAX_10_EXP) 1160 return NV_MAX; 1161 if (exponent < 0) { 1162 if (-(exponent + exp_v) >= NV_MAX_10_EXP) 1163 return 0.0; 1164 while (-exponent >= NV_MAX_10_EXP) { 1165 /* combination does not overflow, but 10^(-exponent) does */ 1166 value /= 10; 1167 ++exponent; 1168 } 1169 } 1170 } STMT_END; 1171 #endif 1172 1173 if (exponent < 0) { 1174 negative = 1; 1175 exponent = -exponent; 1176 #ifdef NV_MAX_10_EXP 1177 /* for something like 1234 x 10^-309, the action of calculating 1178 * the intermediate value 10^309 then returning 1234 / (10^309) 1179 * will fail, since 10^309 becomes infinity. In this case try to 1180 * refactor it as 123 / (10^308) etc. 1181 */ 1182 while (value && exponent > NV_MAX_10_EXP) { 1183 exponent--; 1184 value /= 10; 1185 } 1186 if (value == 0.0) 1187 return value; 1188 #endif 1189 } 1190 #if defined(__osf__) 1191 /* Even with cc -ieee + ieee_set_fp_control(IEEE_TRAP_ENABLE_INV) 1192 * Tru64 fp behavior on inf/nan is somewhat broken. Another way 1193 * to do this would be ieee_set_fp_control(IEEE_TRAP_ENABLE_OVF) 1194 * but that breaks another set of infnan.t tests. */ 1195 # define FP_OVERFLOWS_TO_ZERO 1196 #endif 1197 for (bit = 1; exponent; bit <<= 1) { 1198 if (exponent & bit) { 1199 exponent ^= bit; 1200 result *= power; 1201 #ifdef FP_OVERFLOWS_TO_ZERO 1202 if (result == 0) 1203 # ifdef NV_INF 1204 return value < 0 ? -NV_INF : NV_INF; 1205 # else 1206 return value < 0 ? -FLT_MAX : FLT_MAX; 1207 # endif 1208 #endif 1209 /* Floating point exceptions are supposed to be turned off, 1210 * but if we're obviously done, don't risk another iteration. 1211 */ 1212 if (exponent == 0) break; 1213 } 1214 power *= power; 1215 } 1216 return negative ? value / result : value * result; 1217 } 1218 #endif /* #ifndef USE_QUADMATH */ 1219 1220 NV 1221 Perl_my_atof(pTHX_ const char* s) 1222 { 1223 /* 's' must be NUL terminated */ 1224 1225 NV x = 0.0; 1226 1227 PERL_ARGS_ASSERT_MY_ATOF; 1228 1229 #ifdef USE_QUADMATH 1230 1231 Perl_my_atof2(aTHX_ s, &x); 1232 1233 #elif ! defined(USE_LOCALE_NUMERIC) 1234 1235 Perl_atof2(s, x); 1236 1237 #else 1238 1239 { 1240 DECLARATION_FOR_LC_NUMERIC_MANIPULATION; 1241 STORE_LC_NUMERIC_SET_TO_NEEDED(); 1242 if (PL_numeric_radix_sv && IN_LC(LC_NUMERIC)) { 1243 /* Look through the string for the first thing that looks like a 1244 * decimal point: either the value in the current locale or the 1245 * standard fallback of '.'. The one which appears earliest in the 1246 * input string is the one that we should have atof look for. Note 1247 * that we have to determine this beforehand because on some 1248 * systems, Perl_atof2 is just a wrapper around the system's atof. 1249 * */ 1250 const char * const standard_pos = strchr(s, '.'); 1251 const char * const local_pos 1252 = strstr(s, SvPV_nolen(PL_numeric_radix_sv)); 1253 const bool use_standard_radix 1254 = standard_pos && (!local_pos || standard_pos < local_pos); 1255 1256 if (use_standard_radix) { 1257 SET_NUMERIC_STANDARD(); 1258 LOCK_LC_NUMERIC_STANDARD(); 1259 } 1260 1261 Perl_atof2(s, x); 1262 1263 if (use_standard_radix) { 1264 UNLOCK_LC_NUMERIC_STANDARD(); 1265 SET_NUMERIC_UNDERLYING(); 1266 } 1267 } 1268 else 1269 Perl_atof2(s, x); 1270 RESTORE_LC_NUMERIC(); 1271 } 1272 1273 #endif 1274 1275 return x; 1276 } 1277 1278 #if defined(NV_INF) || defined(NV_NAN) 1279 1280 #ifdef USING_MSVC6 1281 # pragma warning(push) 1282 # pragma warning(disable:4756;disable:4056) 1283 #endif 1284 static char* 1285 S_my_atof_infnan(pTHX_ const char* s, bool negative, const char* send, NV* value) 1286 { 1287 const char *p0 = negative ? s - 1 : s; 1288 const char *p = p0; 1289 const int infnan = grok_infnan(&p, send); 1290 if (infnan && p != p0) { 1291 /* If we can generate inf/nan directly, let's do so. */ 1292 #ifdef NV_INF 1293 if ((infnan & IS_NUMBER_INFINITY)) { 1294 *value = (infnan & IS_NUMBER_NEG) ? -NV_INF: NV_INF; 1295 return (char*)p; 1296 } 1297 #endif 1298 #ifdef NV_NAN 1299 if ((infnan & IS_NUMBER_NAN)) { 1300 *value = NV_NAN; 1301 return (char*)p; 1302 } 1303 #endif 1304 #ifdef Perl_strtod 1305 /* If still here, we didn't have either NV_INF or NV_NAN, 1306 * and can try falling back to native strtod/strtold. 1307 * 1308 * The native interface might not recognize all the possible 1309 * inf/nan strings Perl recognizes. What we can try 1310 * is to try faking the input. We will try inf/-inf/nan 1311 * as the most promising/portable input. */ 1312 { 1313 const char* fake = NULL; 1314 char* endp; 1315 NV nv; 1316 #ifdef NV_INF 1317 if ((infnan & IS_NUMBER_INFINITY)) { 1318 fake = ((infnan & IS_NUMBER_NEG)) ? "-inf" : "inf"; 1319 } 1320 #endif 1321 #ifdef NV_NAN 1322 if ((infnan & IS_NUMBER_NAN)) { 1323 fake = "nan"; 1324 } 1325 #endif 1326 assert(fake); 1327 nv = Perl_strtod(fake, &endp); 1328 if (fake != endp) { 1329 #ifdef NV_INF 1330 if ((infnan & IS_NUMBER_INFINITY)) { 1331 # ifdef Perl_isinf 1332 if (Perl_isinf(nv)) 1333 *value = nv; 1334 # else 1335 /* last resort, may generate SIGFPE */ 1336 *value = Perl_exp((NV)1e9); 1337 if ((infnan & IS_NUMBER_NEG)) 1338 *value = -*value; 1339 # endif 1340 return (char*)p; /* p, not endp */ 1341 } 1342 #endif 1343 #ifdef NV_NAN 1344 if ((infnan & IS_NUMBER_NAN)) { 1345 # ifdef Perl_isnan 1346 if (Perl_isnan(nv)) 1347 *value = nv; 1348 # else 1349 /* last resort, may generate SIGFPE */ 1350 *value = Perl_log((NV)-1.0); 1351 # endif 1352 return (char*)p; /* p, not endp */ 1353 #endif 1354 } 1355 } 1356 } 1357 #endif /* #ifdef Perl_strtod */ 1358 } 1359 return NULL; 1360 } 1361 #ifdef USING_MSVC6 1362 # pragma warning(pop) 1363 #endif 1364 1365 #endif /* if defined(NV_INF) || defined(NV_NAN) */ 1366 1367 char* 1368 Perl_my_atof2(pTHX_ const char* orig, NV* value) 1369 { 1370 const char* s = orig; 1371 NV result[3] = {0.0, 0.0, 0.0}; 1372 #if defined(USE_PERL_ATOF) || defined(USE_QUADMATH) 1373 const char* send = s + strlen(orig); /* one past the last */ 1374 bool negative = 0; 1375 #endif 1376 #if defined(USE_PERL_ATOF) && !defined(USE_QUADMATH) 1377 UV accumulator[2] = {0,0}; /* before/after dp */ 1378 bool seen_digit = 0; 1379 I32 exp_adjust[2] = {0,0}; 1380 I32 exp_acc[2] = {-1, -1}; 1381 /* the current exponent adjust for the accumulators */ 1382 I32 exponent = 0; 1383 I32 seen_dp = 0; 1384 I32 digit = 0; 1385 I32 old_digit = 0; 1386 I32 sig_digits = 0; /* noof significant digits seen so far */ 1387 #endif 1388 1389 #if defined(USE_PERL_ATOF) || defined(USE_QUADMATH) 1390 PERL_ARGS_ASSERT_MY_ATOF2; 1391 1392 /* leading whitespace */ 1393 while (isSPACE(*s)) 1394 ++s; 1395 1396 /* sign */ 1397 switch (*s) { 1398 case '-': 1399 negative = 1; 1400 /* FALLTHROUGH */ 1401 case '+': 1402 ++s; 1403 } 1404 #endif 1405 1406 #ifdef USE_QUADMATH 1407 { 1408 char* endp; 1409 if ((endp = S_my_atof_infnan(aTHX_ s, negative, send, value))) 1410 return endp; 1411 result[2] = strtoflt128(s, &endp); 1412 if (s != endp) { 1413 *value = negative ? -result[2] : result[2]; 1414 return endp; 1415 } 1416 return NULL; 1417 } 1418 #elif defined(USE_PERL_ATOF) 1419 1420 /* There is no point in processing more significant digits 1421 * than the NV can hold. Note that NV_DIG is a lower-bound value, 1422 * while we need an upper-bound value. We add 2 to account for this; 1423 * since it will have been conservative on both the first and last digit. 1424 * For example a 32-bit mantissa with an exponent of 4 would have 1425 * exact values in the set 1426 * 4 1427 * 8 1428 * .. 1429 * 17179869172 1430 * 17179869176 1431 * 17179869180 1432 * 1433 * where for the purposes of calculating NV_DIG we would have to discount 1434 * both the first and last digit, since neither can hold all values from 1435 * 0..9; but for calculating the value we must examine those two digits. 1436 */ 1437 #ifdef MAX_SIG_DIG_PLUS 1438 /* It is not necessarily the case that adding 2 to NV_DIG gets all the 1439 possible digits in a NV, especially if NVs are not IEEE compliant 1440 (e.g., long doubles on IRIX) - Allen <allens@cpan.org> */ 1441 # define MAX_SIG_DIGITS (NV_DIG+MAX_SIG_DIG_PLUS) 1442 #else 1443 # define MAX_SIG_DIGITS (NV_DIG+2) 1444 #endif 1445 1446 /* the max number we can accumulate in a UV, and still safely do 10*N+9 */ 1447 #define MAX_ACCUMULATE ( (UV) ((UV_MAX - 9)/10)) 1448 1449 #if defined(NV_INF) || defined(NV_NAN) 1450 { 1451 char* endp; 1452 if ((endp = S_my_atof_infnan(aTHX_ s, negative, send, value))) 1453 return endp; 1454 } 1455 #endif 1456 1457 /* we accumulate digits into an integer; when this becomes too 1458 * large, we add the total to NV and start again */ 1459 1460 while (1) { 1461 if (isDIGIT(*s)) { 1462 seen_digit = 1; 1463 old_digit = digit; 1464 digit = *s++ - '0'; 1465 if (seen_dp) 1466 exp_adjust[1]++; 1467 1468 /* don't start counting until we see the first significant 1469 * digit, eg the 5 in 0.00005... */ 1470 if (!sig_digits && digit == 0) 1471 continue; 1472 1473 if (++sig_digits > MAX_SIG_DIGITS) { 1474 /* limits of precision reached */ 1475 if (digit > 5) { 1476 ++accumulator[seen_dp]; 1477 } else if (digit == 5) { 1478 if (old_digit % 2) { /* round to even - Allen */ 1479 ++accumulator[seen_dp]; 1480 } 1481 } 1482 if (seen_dp) { 1483 exp_adjust[1]--; 1484 } else { 1485 exp_adjust[0]++; 1486 } 1487 /* skip remaining digits */ 1488 while (isDIGIT(*s)) { 1489 ++s; 1490 if (! seen_dp) { 1491 exp_adjust[0]++; 1492 } 1493 } 1494 /* warn of loss of precision? */ 1495 } 1496 else { 1497 if (accumulator[seen_dp] > MAX_ACCUMULATE) { 1498 /* add accumulator to result and start again */ 1499 result[seen_dp] = S_mulexp10(result[seen_dp], 1500 exp_acc[seen_dp]) 1501 + (NV)accumulator[seen_dp]; 1502 accumulator[seen_dp] = 0; 1503 exp_acc[seen_dp] = 0; 1504 } 1505 accumulator[seen_dp] = accumulator[seen_dp] * 10 + digit; 1506 ++exp_acc[seen_dp]; 1507 } 1508 } 1509 else if (!seen_dp && GROK_NUMERIC_RADIX(&s, send)) { 1510 seen_dp = 1; 1511 if (sig_digits > MAX_SIG_DIGITS) { 1512 while (isDIGIT(*s)) { 1513 ++s; 1514 } 1515 break; 1516 } 1517 } 1518 else { 1519 break; 1520 } 1521 } 1522 1523 result[0] = S_mulexp10(result[0], exp_acc[0]) + (NV)accumulator[0]; 1524 if (seen_dp) { 1525 result[1] = S_mulexp10(result[1], exp_acc[1]) + (NV)accumulator[1]; 1526 } 1527 1528 if (seen_digit && (isALPHA_FOLD_EQ(*s, 'e'))) { 1529 bool expnegative = 0; 1530 1531 ++s; 1532 switch (*s) { 1533 case '-': 1534 expnegative = 1; 1535 /* FALLTHROUGH */ 1536 case '+': 1537 ++s; 1538 } 1539 while (isDIGIT(*s)) 1540 exponent = exponent * 10 + (*s++ - '0'); 1541 if (expnegative) 1542 exponent = -exponent; 1543 } 1544 1545 1546 1547 /* now apply the exponent */ 1548 1549 if (seen_dp) { 1550 result[2] = S_mulexp10(result[0],exponent+exp_adjust[0]) 1551 + S_mulexp10(result[1],exponent-exp_adjust[1]); 1552 } else { 1553 result[2] = S_mulexp10(result[0],exponent+exp_adjust[0]); 1554 } 1555 1556 /* now apply the sign */ 1557 if (negative) 1558 result[2] = -result[2]; 1559 #endif /* USE_PERL_ATOF */ 1560 *value = result[2]; 1561 return (char *)s; 1562 } 1563 1564 /* 1565 =for apidoc isinfnan 1566 1567 C<Perl_isinfnan()> is utility function that returns true if the NV 1568 argument is either an infinity or a C<NaN>, false otherwise. To test 1569 in more detail, use C<Perl_isinf()> and C<Perl_isnan()>. 1570 1571 This is also the logical inverse of Perl_isfinite(). 1572 1573 =cut 1574 */ 1575 bool 1576 Perl_isinfnan(NV nv) 1577 { 1578 PERL_UNUSED_ARG(nv); 1579 #ifdef Perl_isinf 1580 if (Perl_isinf(nv)) 1581 return TRUE; 1582 #endif 1583 #ifdef Perl_isnan 1584 if (Perl_isnan(nv)) 1585 return TRUE; 1586 #endif 1587 return FALSE; 1588 } 1589 1590 /* 1591 =for apidoc 1592 1593 Checks whether the argument would be either an infinity or C<NaN> when used 1594 as a number, but is careful not to trigger non-numeric or uninitialized 1595 warnings. it assumes the caller has done C<SvGETMAGIC(sv)> already. 1596 1597 =cut 1598 */ 1599 1600 bool 1601 Perl_isinfnansv(pTHX_ SV *sv) 1602 { 1603 PERL_ARGS_ASSERT_ISINFNANSV; 1604 if (!SvOK(sv)) 1605 return FALSE; 1606 if (SvNOKp(sv)) 1607 return Perl_isinfnan(SvNVX(sv)); 1608 if (SvIOKp(sv)) 1609 return FALSE; 1610 { 1611 STRLEN len; 1612 const char *s = SvPV_nomg_const(sv, len); 1613 return cBOOL(grok_infnan(&s, s+len)); 1614 } 1615 } 1616 1617 #ifndef HAS_MODFL 1618 /* C99 has truncl, pre-C99 Solaris had aintl. We can use either with 1619 * copysignl to emulate modfl, which is in some platforms missing or 1620 * broken. */ 1621 # if defined(HAS_TRUNCL) && defined(HAS_COPYSIGNL) 1622 long double 1623 Perl_my_modfl(long double x, long double *ip) 1624 { 1625 *ip = truncl(x); 1626 return (x == *ip ? copysignl(0.0L, x) : x - *ip); 1627 } 1628 # elif defined(HAS_AINTL) && defined(HAS_COPYSIGNL) 1629 long double 1630 Perl_my_modfl(long double x, long double *ip) 1631 { 1632 *ip = aintl(x); 1633 return (x == *ip ? copysignl(0.0L, x) : x - *ip); 1634 } 1635 # endif 1636 #endif 1637 1638 /* Similarly, with ilogbl and scalbnl we can emulate frexpl. */ 1639 #if ! defined(HAS_FREXPL) && defined(HAS_ILOGBL) && defined(HAS_SCALBNL) 1640 long double 1641 Perl_my_frexpl(long double x, int *e) { 1642 *e = x == 0.0L ? 0 : ilogbl(x) + 1; 1643 return (scalbnl(x, -*e)); 1644 } 1645 #endif 1646 1647 /* 1648 =for apidoc Perl_signbit 1649 1650 Return a non-zero integer if the sign bit on an NV is set, and 0 if 1651 it is not. 1652 1653 If F<Configure> detects this system has a C<signbit()> that will work with 1654 our NVs, then we just use it via the C<#define> in F<perl.h>. Otherwise, 1655 fall back on this implementation. The main use of this function 1656 is catching C<-0.0>. 1657 1658 C<Configure> notes: This function is called C<'Perl_signbit'> instead of a 1659 plain C<'signbit'> because it is easy to imagine a system having a C<signbit()> 1660 function or macro that doesn't happen to work with our particular choice 1661 of NVs. We shouldn't just re-C<#define> C<signbit> as C<Perl_signbit> and expect 1662 the standard system headers to be happy. Also, this is a no-context 1663 function (no C<pTHX_>) because C<Perl_signbit()> is usually re-C<#defined> in 1664 F<perl.h> as a simple macro call to the system's C<signbit()>. 1665 Users should just always call C<Perl_signbit()>. 1666 1667 =cut 1668 */ 1669 #if !defined(HAS_SIGNBIT) 1670 int 1671 Perl_signbit(NV x) { 1672 # ifdef Perl_fp_class_nzero 1673 return Perl_fp_class_nzero(x); 1674 /* Try finding the high byte, and assume it's highest bit 1675 * is the sign. This assumption is probably wrong somewhere. */ 1676 # elif defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN 1677 return (((unsigned char *)&x)[9] & 0x80); 1678 # elif defined(NV_LITTLE_ENDIAN) 1679 /* Note that NVSIZE is sizeof(NV), which would make the below be 1680 * wrong if the end bytes are unused, which happens with the x86 1681 * 80-bit long doubles, which is why take care of that above. */ 1682 return (((unsigned char *)&x)[NVSIZE - 1] & 0x80); 1683 # elif defined(NV_BIG_ENDIAN) 1684 return (((unsigned char *)&x)[0] & 0x80); 1685 # else 1686 /* This last resort fallback is wrong for the negative zero. */ 1687 return (x < 0.0) ? 1 : 0; 1688 # endif 1689 } 1690 #endif 1691 1692 /* 1693 * ex: set ts=8 sts=4 sw=4 et: 1694 */ 1695