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