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