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