X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/4de1bcfe1abdaba0a5da394ddea0cc6fd7e36c7b..c1ec4bdd803f587dd2ae76548bca0ae59d0fe84b:/numeric.c diff --git a/numeric.c b/numeric.c index bf92e32..52c4547 100644 --- a/numeric.c +++ b/numeric.c @@ -16,9 +16,6 @@ */ /* -=head1 Numeric functions - -=cut This file contains all the stuff needed by perl for manipulating numeric values, including such things as replacements for the OS's atof() function @@ -29,6 +26,107 @@ values, including such things as replacements for the OS's atof() function #define PERL_IN_NUMERIC_C #include "perl.h" +#ifdef Perl_strtod + +PERL_STATIC_INLINE NV +S_strtod(pTHX_ const char * const s, char ** e) +{ + DECLARATION_FOR_LC_NUMERIC_MANIPULATION; + NV result; + + STORE_LC_NUMERIC_SET_TO_NEEDED(); + +# ifdef USE_QUADMATH + + result = strtoflt128(s, e); + +# elif defined(HAS_STRTOLD) && defined(HAS_LONG_DOUBLE) \ + && defined(USE_LONG_DOUBLE) +# if defined(__MINGW64_VERSION_MAJOR) + /*********************************************** + We are unable to use strtold because of + https://sourceforge.net/p/mingw-w64/bugs/711/ + & + https://sourceforge.net/p/mingw-w64/bugs/725/ + + but __mingw_strtold is fine. + ***********************************************/ + + result = __mingw_strtold(s, e); + +# else + + result = strtold(s, e); + +# endif +# elif defined(HAS_STRTOD) + + result = strtod(s, e); + +# else +# error No strtod() equivalent found +# endif + + RESTORE_LC_NUMERIC(); + + return result; +} + +#endif /* #ifdef Perl_strtod */ + +/* + +=for apidoc my_strtod + +This function is equivalent to the libc strtod() function, and is available +even on platforms that lack plain strtod(). Its return value is the best +available precision depending on platform capabilities and F +options. + +It properly handles the locale radix character, meaning it expects a dot except +when called from within the scope of S>, in which case the radix +character should be that specified by the current locale. + +The synonym Strtod() may be used instead. + +=cut + +*/ + +NV +Perl_my_strtod(const char * const s, char **e) +{ + dTHX; + + PERL_ARGS_ASSERT_MY_STRTOD; + +#ifdef Perl_strtod + + return S_strtod(aTHX_ s, e); + +#else + + { + NV result; + char ** end_ptr = NULL; + + *end_ptr = my_atof2(s, &result); + if (e) { + *e = *end_ptr; + } + + if (! *end_ptr) { + result = 0.0; + } + + return result; + } + +#endif + +} + + U32 Perl_cast_ulong(NV f) { @@ -39,7 +137,7 @@ Perl_cast_ulong(NV f) if (f < U32_MAX_P1_HALF) return (U32) f; f -= U32_MAX_P1_HALF; - return ((U32) f) | (1 + U32_MAX >> 1); + return ((U32) f) | (1 + (U32_MAX >> 1)); #else return (U32) f; #endif @@ -57,7 +155,7 @@ Perl_cast_i32(NV f) if (f < U32_MAX_P1_HALF) return (I32)(U32) f; f -= U32_MAX_P1_HALF; - return (I32)(((U32) f) | (1 + U32_MAX >> 1)); + return (I32)(((U32) f) | (1 + (U32_MAX >> 1))); #else return (I32)(U32) f; #endif @@ -76,7 +174,7 @@ Perl_cast_iv(NV f) if (f < UV_MAX_P1_HALF) return (IV)(UV) f; f -= UV_MAX_P1_HALF; - return (IV)(((UV) f) | (1 + UV_MAX >> 1)); + return (IV)(((UV) f) | (1 + (UV_MAX >> 1))); #else return (IV)(UV) f; #endif @@ -94,7 +192,7 @@ Perl_cast_uv(NV f) if (f < UV_MAX_P1_HALF) return (UV) f; f -= UV_MAX_P1_HALF; - return ((UV) f) | (1 + UV_MAX >> 1); + return ((UV) f) | (1 + (UV_MAX >> 1)); #else return (UV) f; #endif @@ -107,24 +205,31 @@ Perl_cast_uv(NV f) converts a string representing a binary number to numeric form. -On entry I and I<*len> give the string to scan, I<*flags> gives -conversion flags, and I should be NULL or a pointer to an NV. -The scan stops at the end of the string, or the first invalid character. -Unless C is set in I<*flags>, encountering an -invalid character will also trigger a warning. -On return I<*len> is set to the length of the scanned string, -and I<*flags> gives output flags. +On entry C and C<*len_p> give the string to scan, C<*flags> gives +conversion flags, and C should be C or a pointer to an NV. The +scan stops at the end of the string, or at just before the first invalid +character. Unless C is set in C<*flags>, +encountering an invalid character (except NUL) will also trigger a warning. On +return C<*len_p> is set to the length of the scanned string, and C<*flags> +gives output flags. If the value is <= C it is returned as a UV, the output flags are clear, -and nothing is written to I<*result>. If the value is > UV_MAX C -returns UV_MAX, sets C in the output flags, -and writes the value to I<*result> (or the value is discarded if I -is NULL). +and nothing is written to C<*result>. If the value is > C, C +returns C, sets C in the output flags, +and writes an approximation of the correct value into C<*result> (which is an +NV; or the approximation is discarded if C is NULL). -The binary number may optionally be prefixed with "0b" or "b" unless -C is set in I<*flags> on entry. If -C is set in I<*flags> then the binary -number may use '_' characters to separate digits. +The binary number may optionally be prefixed with C<"0b"> or C<"b"> unless +C is set in C<*flags> on entry. + +If C is set in C<*flags> then any or all pairs of +digits may be separated from each other by a single underscore; also a single +leading underscore is accepted. + +=for apidoc Amnh||PERL_SCAN_ALLOW_UNDERSCORES +=for apidoc Amnh||PERL_SCAN_DISALLOW_PREFIX +=for apidoc Amnh||PERL_SCAN_GREATER_THAN_UV_MAX +=for apidoc Amnh||PERL_SCAN_SILENT_ILLDIGIT =cut @@ -136,93 +241,9 @@ on this platform. UV Perl_grok_bin(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { - const char *s = start; - STRLEN len = *len_p; - UV value = 0; - NV value_nv = 0; - - const UV max_div_2 = UV_MAX / 2; - const bool allow_underscores = cBOOL(*flags & PERL_SCAN_ALLOW_UNDERSCORES); - bool overflowed = FALSE; - char bit; - PERL_ARGS_ASSERT_GROK_BIN; - if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { - /* strip off leading b or 0b. - for compatibility silently suffer "b" and "0b" as valid binary - numbers. */ - if (len >= 1) { - if (isALPHA_FOLD_EQ(s[0], 'b')) { - s++; - len--; - } - else if (len >= 2 && s[0] == '0' && (isALPHA_FOLD_EQ(s[1], 'b'))) { - s+=2; - len-=2; - } - } - } - - for (; len-- && (bit = *s); s++) { - if (bit == '0' || bit == '1') { - /* Write it in this wonky order with a goto to attempt to get the - compiler to make the common case integer-only loop pretty tight. - With gcc seems to be much straighter code than old scan_bin. */ - redo: - if (!overflowed) { - if (value <= max_div_2) { - value = (value << 1) | (bit - '0'); - continue; - } - /* Bah. We're just overflowed. */ - /* diag_listed_as: Integer overflow in %s number */ - Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW), - "Integer overflow in binary number"); - overflowed = TRUE; - value_nv = (NV) value; - } - value_nv *= 2.0; - /* If an NV has not enough bits in its mantissa to - * represent a UV this summing of small low-order numbers - * is a waste of time (because the NV cannot preserve - * the low-order bits anyway): we could just remember when - * did we overflow and in the end just multiply value_nv by the - * right amount. */ - value_nv += (NV)(bit - '0'); - continue; - } - if (bit == '_' && len && allow_underscores && (bit = s[1]) - && (bit == '0' || bit == '1')) - { - --len; - ++s; - goto redo; - } - if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) - Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT), - "Illegal binary digit '%c' ignored", *s); - break; - } - - if ( ( overflowed && value_nv > 4294967295.0) -#if UVSIZE > 4 - || (!overflowed && value > 0xffffffff - && ! (*flags & PERL_SCAN_SILENT_NON_PORTABLE)) -#endif - ) { - Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), - "Binary number > 0b11111111111111111111111111111111 non-portable"); - } - *len_p = s - start; - if (!overflowed) { - *flags = 0; - return value; - } - *flags = PERL_SCAN_GREATER_THAN_UV_MAX; - if (result) - *result = value_nv; - return UV_MAX; + return grok_bin(start, len_p, flags, result); } /* @@ -230,120 +251,40 @@ Perl_grok_bin(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) converts a string representing a hex number to numeric form. -On entry I and I<*len_p> give the string to scan, I<*flags> gives -conversion flags, and I should be NULL or a pointer to an NV. -The scan stops at the end of the string, or the first invalid character. -Unless C is set in I<*flags>, encountering an -invalid character will also trigger a warning. -On return I<*len> is set to the length of the scanned string, -and I<*flags> gives output flags. - -If the value is <= UV_MAX it is returned as a UV, the output flags are clear, -and nothing is written to I<*result>. If the value is > UV_MAX C -returns UV_MAX, sets C in the output flags, -and writes the value to I<*result> (or the value is discarded if I -is NULL). - -The hex number may optionally be prefixed with "0x" or "x" unless -C is set in I<*flags> on entry. If -C is set in I<*flags> then the hex -number may use '_' characters to separate digits. +On entry C and C<*len_p> give the string to scan, C<*flags> gives +conversion flags, and C should be C or a pointer to an NV. The +scan stops at the end of the string, or at just before the first invalid +character. Unless C is set in C<*flags>, +encountering an invalid character (except NUL) will also trigger a warning. On +return C<*len_p> is set to the length of the scanned string, and C<*flags> +gives output flags. + +If the value is <= C it is returned as a UV, the output flags are clear, +and nothing is written to C<*result>. If the value is > C, C +returns C, sets C in the output flags, +and writes an approximation of the correct value into C<*result> (which is an +NV; or the approximation is discarded if C is NULL). + +The hex number may optionally be prefixed with C<"0x"> or C<"x"> unless +C is set in C<*flags> on entry. + +If C is set in C<*flags> then any or all pairs of +digits may be separated from each other by a single underscore; also a single +leading underscore is accepted. =cut -Not documented yet because experimental is C which suppresses any message for non-portable numbers, but which are valid -on this platform. +on this platform. But, C<*flags> will have the corresponding flag bit set. */ UV Perl_grok_hex(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { - const char *s = start; - STRLEN len = *len_p; - UV value = 0; - NV value_nv = 0; - const UV max_div_16 = UV_MAX / 16; - const bool allow_underscores = cBOOL(*flags & PERL_SCAN_ALLOW_UNDERSCORES); - bool overflowed = FALSE; - PERL_ARGS_ASSERT_GROK_HEX; - if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { - /* strip off leading x or 0x. - for compatibility silently suffer "x" and "0x" as valid hex numbers. - */ - if (len >= 1) { - if (isALPHA_FOLD_EQ(s[0], 'x')) { - s++; - len--; - } - else if (len >= 2 && s[0] == '0' && (isALPHA_FOLD_EQ(s[1], 'x'))) { - s+=2; - len-=2; - } - } - } - - for (; len-- && *s; s++) { - if (isXDIGIT(*s)) { - /* Write it in this wonky order with a goto to attempt to get the - compiler to make the common case integer-only loop pretty tight. - With gcc seems to be much straighter code than old scan_hex. */ - redo: - if (!overflowed) { - if (value <= max_div_16) { - value = (value << 4) | XDIGIT_VALUE(*s); - continue; - } - /* Bah. We're just overflowed. */ - /* diag_listed_as: Integer overflow in %s number */ - Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW), - "Integer overflow in hexadecimal number"); - overflowed = TRUE; - value_nv = (NV) value; - } - value_nv *= 16.0; - /* If an NV has not enough bits in its mantissa to - * represent a UV this summing of small low-order numbers - * is a waste of time (because the NV cannot preserve - * the low-order bits anyway): we could just remember when - * did we overflow and in the end just multiply value_nv by the - * right amount of 16-tuples. */ - value_nv += (NV) XDIGIT_VALUE(*s); - continue; - } - if (*s == '_' && len && allow_underscores && s[1] - && isXDIGIT(s[1])) - { - --len; - ++s; - goto redo; - } - if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) - Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT), - "Illegal hexadecimal digit '%c' ignored", *s); - break; - } - - if ( ( overflowed && value_nv > 4294967295.0) -#if UVSIZE > 4 - || (!overflowed && value > 0xffffffff - && ! (*flags & PERL_SCAN_SILENT_NON_PORTABLE)) -#endif - ) { - Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), - "Hexadecimal number > 0xffffffff non-portable"); - } - *len_p = s - start; - if (!overflowed) { - *flags = 0; - return value; - } - *flags = PERL_SCAN_GREATER_THAN_UV_MAX; - if (result) - *result = value_nv; - return UV_MAX; + return grok_hex(start, len_p, flags, result); } /* @@ -351,22 +292,26 @@ Perl_grok_hex(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) converts a string representing an octal number to numeric form. -On entry I and I<*len> give the string to scan, I<*flags> gives -conversion flags, and I should be NULL or a pointer to an NV. -The scan stops at the end of the string, or the first invalid character. -Unless C is set in I<*flags>, encountering an -8 or 9 will also trigger a warning. -On return I<*len> is set to the length of the scanned string, -and I<*flags> gives output flags. +On entry C and C<*len_p> give the string to scan, C<*flags> gives +conversion flags, and C should be C or a pointer to an NV. The +scan stops at the end of the string, or at just before the first invalid +character. Unless C is set in C<*flags>, +encountering an invalid character (except NUL) will also trigger a warning. On +return C<*len_p> is set to the length of the scanned string, and C<*flags> +gives output flags. -If the value is <= UV_MAX it is returned as a UV, the output flags are clear, -and nothing is written to I<*result>. If the value is > UV_MAX C -returns UV_MAX, sets C in the output flags, -and writes the value to I<*result> (or the value is discarded if I -is NULL). +If the value is <= C it is returned as a UV, the output flags are clear, +and nothing is written to C<*result>. If the value is > C, C +returns C, sets C in the output flags, +and writes an approximation of the correct value into C<*result> (which is an +NV; or the approximation is discarded if C is NULL). -If C is set in I<*flags> then the octal -number may use '_' characters to separate digits. +If C is set in C<*flags> then any or all pairs of +digits may be separated from each other by a single underscore; also a single +leading underscore is accepted. + +The C flag is always treated as being set for +this function. =cut @@ -378,76 +323,277 @@ on this platform. UV Perl_grok_oct(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { - const char *s = start; + PERL_ARGS_ASSERT_GROK_OCT; + + return grok_oct(start, len_p, flags, result); +} + +STATIC void +S_output_non_portable(pTHX_ const U8 base) +{ + /* Display the proper message for a number in the given input base not + * fitting in 32 bits */ + const char * which = (base == 2) + ? "Binary number > 0b11111111111111111111111111111111" + : (base == 8) + ? "Octal number > 037777777777" + : "Hexadecimal number > 0xffffffff"; + + PERL_ARGS_ASSERT_OUTPUT_NON_PORTABLE; + + /* Also there are listings for the other two. That's because, since they + * are the first word, it would be hard for a user to find them there + * starting with a %s */ + /* diag_listed_as: Hexadecimal number > 0xffffffff non-portable */ + Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), "%s non-portable", which); +} + +UV +Perl_grok_bin_oct_hex(pTHX_ const char *start, + STRLEN *len_p, + I32 *flags, + NV *result, + const unsigned shift, /* 1 for binary; 3 for octal; + 4 for hex */ + const U8 class_bit, + const char prefix + ) + +{ + const char *s0 = start; + const char *s; STRLEN len = *len_p; + STRLEN bytes_so_far; /* How many real digits have been processed */ UV value = 0; NV value_nv = 0; - const UV max_div_8 = UV_MAX / 8; - const bool allow_underscores = cBOOL(*flags & PERL_SCAN_ALLOW_UNDERSCORES); + const PERL_UINT_FAST8_T base = 1 << shift; /* 2, 8, or 16 */ + const UV max_div= UV_MAX / base; /* Value above which, the next digit + processed would overflow */ + const I32 input_flags = *flags; + const bool allow_underscores = + cBOOL(input_flags & PERL_SCAN_ALLOW_UNDERSCORES); bool overflowed = FALSE; - PERL_ARGS_ASSERT_GROK_OCT; + /* In overflows, this keeps track of how much to multiply the overflowed NV + * by as we continue to parse the remaining digits */ + NV factor = 0; + + /* This function unifies the core of grok_bin, grok_oct, and grok_hex. It + * is optimized for hex conversion. For example, it uses XDIGIT_VALUE to + * find the numeric value of a digit. That requires more instructions than + * OCTAL_VALUE would, but gives the same result for the narrowed range of + * octal digits; same for binary. If it were ever critical to squeeze more + * performance from this, the function could become grok_hex, and a regen + * perl script could scan it and write out two edited copies for the other + * two functions. That would improve the performance of all three + * somewhat. Besides eliminating XDIGIT_VALUE for the other two, extra + * parameters are now passed to this to avoid conditionals. Those could + * become declared consts, like: + * const U8 base = 16; + * const U8 base = 8; + * ... + */ + + PERL_ARGS_ASSERT_GROK_BIN_OCT_HEX; + + ASSUME(inRANGE(shift, 1, 4) && shift != 2); - for (; len-- && *s; s++) { - if (isOCTAL(*s)) { + /* Clear output flags; unlikely to find a problem that sets them */ + *flags = 0; + + if (!(input_flags & PERL_SCAN_DISALLOW_PREFIX)) { + + /* strip off leading b or 0b; x or 0x. + for compatibility silently suffer "b" and "0b" as valid binary; "x" + and "0x" as valid hex numbers. */ + if (len >= 1) { + if (isALPHA_FOLD_EQ(s0[0], prefix)) { + s0++; + len--; + } + else if (len >= 2 && s0[0] == '0' && (isALPHA_FOLD_EQ(s0[1], prefix))) { + s0+=2; + len-=2; + } + } + } + + s = s0; /* s0 potentially advanced from 'start' */ + + /* Unroll the loop so that the first 8 digits are branchless except for the + * switch. A ninth hex one overflows a 32 bit word. */ + switch (len) { + case 0: + return 0; + default: + if (UNLIKELY(! _generic_isCC(*s, class_bit))) break; + value = (value << shift) | XDIGIT_VALUE(*s); + s++; + /* FALLTHROUGH */ + case 7: + if (UNLIKELY(! _generic_isCC(*s, class_bit))) break; + value = (value << shift) | XDIGIT_VALUE(*s); + s++; + /* FALLTHROUGH */ + case 6: + if (UNLIKELY(! _generic_isCC(*s, class_bit))) break; + value = (value << shift) | XDIGIT_VALUE(*s); + s++; + /* FALLTHROUGH */ + case 5: + if (UNLIKELY(! _generic_isCC(*s, class_bit))) break; + value = (value << shift) | XDIGIT_VALUE(*s); + s++; + /* FALLTHROUGH */ + case 4: + if (UNLIKELY(! _generic_isCC(*s, class_bit))) break; + value = (value << shift) | XDIGIT_VALUE(*s); + s++; + /* FALLTHROUGH */ + case 3: + if (UNLIKELY(! _generic_isCC(*s, class_bit))) break; + value = (value << shift) | XDIGIT_VALUE(*s); + s++; + /* FALLTHROUGH */ + case 2: + if (UNLIKELY(! _generic_isCC(*s, class_bit))) break; + value = (value << shift) | XDIGIT_VALUE(*s); + s++; + /* FALLTHROUGH */ + case 1: + if (UNLIKELY(! _generic_isCC(*s, class_bit))) break; + value = (value << shift) | XDIGIT_VALUE(*s); + + if (LIKELY(len <= 8)) { + return value; + } + + s++; + break; + } + + bytes_so_far = s - s0; + factor = shift << bytes_so_far; + len -= bytes_so_far; + + for (; len--; s++) { + if (_generic_isCC(*s, class_bit)) { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. - */ + With gcc seems to be much straighter code than old scan_hex. + (khw suspects that adding a LIKELY() just above would do the + same thing) */ redo: - if (!overflowed) { - if (value <= max_div_8) { - value = (value << 3) | OCTAL_VALUE(*s); - continue; - } - /* Bah. We're just overflowed. */ - /* diag_listed_as: Integer overflow in %s number */ - Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW), - "Integer overflow in octal number"); + if (LIKELY(value <= max_div)) { + value = (value << shift) | XDIGIT_VALUE(*s); + /* Note XDIGIT_VALUE() is branchless, works on binary + * and octal as well, so can be used here, without + * slowing those down */ + factor *= 1 << shift; + continue; + } + + /* Bah. We are about to overflow. Instead, add the unoverflowed + * value to an NV that contains an approximation to the correct + * value. Each time through the loop we have increased 'factor' so + * that it gives how much the current approximation needs to + * effectively be shifted to make room for this new value */ + value_nv *= factor; + value_nv += (NV) value; + + /* Then we keep accumulating digits, until all are parsed. We + * start over using the current input value. This will be added to + * 'value_nv' eventually, either when all digits are gone, or we + * have overflowed this fresh start. */ + value = XDIGIT_VALUE(*s); + factor = 1 << shift; + + if (! overflowed) { overflowed = TRUE; - value_nv = (NV) value; + if ( ! (input_flags & PERL_SCAN_SILENT_OVERFLOW) + && ckWARN_d(WARN_OVERFLOW)) + { + Perl_warner(aTHX_ packWARN(WARN_OVERFLOW), + "Integer overflow in %s number", + (base == 16) ? "hexadecimal" + : (base == 2) + ? "binary" + : "octal"); + } } - value_nv *= 8.0; - /* If an NV has not enough bits in its mantissa to - * represent a UV this summing of small low-order numbers - * is a waste of time (because the NV cannot preserve - * the low-order bits anyway): we could just remember when - * did we overflow and in the end just multiply value_nv by the - * right amount of 8-tuples. */ - value_nv += (NV) OCTAL_VALUE(*s); continue; } - if (*s == '_' && len && allow_underscores && isOCTAL(s[1])) { + + if ( *s == '_' + && len + && allow_underscores + && _generic_isCC(s[1], class_bit) + + /* Don't allow a leading underscore if the only-medial bit is + * set */ + && ( LIKELY(s > s0) + || UNLIKELY((input_flags & PERL_SCAN_ALLOW_MEDIAL_UNDERSCORES) + != PERL_SCAN_ALLOW_MEDIAL_UNDERSCORES))) + { --len; ++s; goto redo; } - /* Allow \octal to work the DWIM way (that is, stop scanning - * as soon as non-octal characters are seen, complain only if - * someone seems to want to use the digits eight and nine. Since we - * know it is not octal, then if isDIGIT, must be an 8 or 9). */ - if (isDIGIT(*s)) { - if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) - Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT), - "Illegal octal digit '%c' ignored", *s); + + if (*s) { + if ( ! (input_flags & PERL_SCAN_SILENT_ILLDIGIT) + && ckWARN(WARN_DIGIT)) + { + if (base != 8) { + Perl_warner(aTHX_ packWARN(WARN_DIGIT), + "Illegal %s digit '%c' ignored", + ((base == 2) + ? "binary" + : "hexadecimal"), + *s); + } + else if (isDIGIT(*s)) { /* octal base */ + + /* Allow \octal to work the DWIM way (that is, stop + * scanning as soon as non-octal characters are seen, + * complain only if someone seems to want to use the digits + * eight and nine. Since we know it is not octal, then if + * isDIGIT, must be an 8 or 9). */ + Perl_warner(aTHX_ packWARN(WARN_DIGIT), + "Illegal octal digit '%c' ignored", *s); + } + } + + if (input_flags & PERL_SCAN_NOTIFY_ILLDIGIT) { + *flags |= PERL_SCAN_NOTIFY_ILLDIGIT; + } } + break; } - - if ( ( overflowed && value_nv > 4294967295.0) + + *len_p = s - start; + + if (LIKELY(! overflowed)) { #if UVSIZE > 4 - || (!overflowed && value > 0xffffffff - && ! (*flags & PERL_SCAN_SILENT_NON_PORTABLE)) + if ( UNLIKELY(value > 0xffffffff) + && ! (input_flags & PERL_SCAN_SILENT_NON_PORTABLE)) + { + output_non_portable(base); + *flags |= PERL_SCAN_SILENT_NON_PORTABLE; + } #endif - ) { - Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), - "Octal number > 037777777777 non-portable"); - } - *len_p = s - start; - if (!overflowed) { - *flags = 0; return value; } - *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + + /* Overflowed: Calculate the final overflow approximation */ + value_nv *= factor; + value_nv += (NV) value; + + output_non_portable(base); + + *flags |= PERL_SCAN_GREATER_THAN_UV_MAX + | PERL_SCAN_SILENT_NON_PORTABLE; if (result) *result = value_nv; return UV_MAX; @@ -489,530 +635,114 @@ Perl_scan_oct(pTHX_ const char *start, STRLEN len, STRLEN *retlen) I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0; const UV ruv = grok_oct (start, &len, &flags, &rnv); - PERL_ARGS_ASSERT_SCAN_OCT; - - *retlen = len; - return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv; -} - -NV -Perl_scan_hex(pTHX_ const char *start, STRLEN len, STRLEN *retlen) -{ - NV rnv; - I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0; - const UV ruv = grok_hex (start, &len, &flags, &rnv); - - PERL_ARGS_ASSERT_SCAN_HEX; - - *retlen = len; - return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv; -} - -/* -=for apidoc grok_numeric_radix - -Scan and skip for a numeric decimal separator (radix). - -=cut - */ -bool -Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send) -{ -#ifdef USE_LOCALE_NUMERIC - PERL_ARGS_ASSERT_GROK_NUMERIC_RADIX; - - if (IN_LC(LC_NUMERIC)) { - DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED(); - if (PL_numeric_radix_sv) { - STRLEN len; - const char * const radix = SvPV(PL_numeric_radix_sv, len); - if (*sp + len <= send && memEQ(*sp, radix, len)) { - *sp += len; - RESTORE_LC_NUMERIC(); - return TRUE; - } - } - RESTORE_LC_NUMERIC(); - } - /* always try "." if numeric radix didn't match because - * we may have data from different locales mixed */ -#endif - - PERL_ARGS_ASSERT_GROK_NUMERIC_RADIX; - - if (*sp < send && **sp == '.') { - ++*sp; - return TRUE; - } - return FALSE; -} - -/* -=for apidoc nan_hibyte - -Given an NV, returns pointer to the byte containing the most -significant bit of the NaN, this bit is most commonly the -quiet/signaling bit of the NaN. The mask will contain a mask -appropriate for manipulating the most significant bit. -Note that this bit may not be the highest bit of the byte. - -If the NV is not a NaN, returns NULL. - -Most platforms have "high bit is one" -> quiet nan. -The known opposite exceptions are older MIPS and HPPA platforms. - -Some platforms do not differentiate between quiet and signaling NaNs. - -=cut -*/ -U8* -Perl_nan_hibyte(NV *nvp, U8* mask) -{ - STRLEN i = (NV_MANT_REAL_DIG - 1) / 8; - STRLEN j = (NV_MANT_REAL_DIG - 1) % 8; - - PERL_ARGS_ASSERT_NAN_HIBYTE; - - *mask = 1 << j; -#ifdef NV_BIG_ENDIAN - return (U8*) nvp + NVSIZE - 1 - i; -#endif -#ifdef NV_LITTLE_ENDIAN - return (U8*) nvp + i; -#endif -} - -/* -=for apidoc nan_signaling_set - -Set or unset the NaN signaling-ness. - -Of those platforms that differentiate between quiet and signaling -platforms the majority has the semantics of the most significant bit -being on meaning quiet NaN, so for signaling we need to clear the bit. - -Some platforms (older MIPS, and HPPA) have the opposite -semantics, and we set the bit for a signaling NaN. - -=cut -*/ -void -Perl_nan_signaling_set(NV *nvp, bool signaling) -{ - U8 mask; - U8* hibyte; - - PERL_ARGS_ASSERT_NAN_SIGNALING_SET; - - hibyte = nan_hibyte(nvp, &mask); - if (hibyte) { - const NV nan = NV_NAN; - /* Decent optimizers should make the irrelevant branch to disappear. */ - if ((((U8*)&nan)[hibyte - (U8*)nvp] & mask)) { - /* x86 style: the most significant bit of the NaN is off - * for a signaling NaN, and on for a quiet NaN. */ - if (signaling) { - *hibyte &= ~mask; - } else { - *hibyte |= mask; - } - } else { - /* MIPS/HPPA style: the most significant bit of the NaN is on - * for a signaling NaN, and off for a quiet NaN. */ - if (signaling) { - *hibyte |= mask; - } else { - *hibyte &= ~mask; - } - } - } -} - -/* -=for apidoc nan_is_signaling - -Returns true if the nv is a NaN is a signaling NaN. - -=cut -*/ -int -Perl_nan_is_signaling(NV nv) -{ - /* Quiet NaN bit pattern (64-bit doubles, ignore endianness): - * x86 00 00 00 00 00 00 f8 7f - * sparc 7f ff ff ff ff ff ff ff - * mips 7f f7 ff ff ff ff ff ff - * hppa 7f f4 00 00 00 00 00 00 - * The "7ff" is the exponent. The most significant bit of the NaN - * (note: here, not the most significant bit of the byte) is of - * interest: in the x86 style (also in sparc) the bit on means - * 'quiet', in the mips style the bit off means 'quiet'. */ -#ifdef Perl_fp_classify_snan - return Perl_fp_classify_snan(nv); -#else - if (Perl_isnan(nv)) { - U8 mask; - U8 *hibyte = Perl_nan_hibyte(&nv, &mask); - /* Hoping NV_NAN is a quiet nan - this might be a false hope. - * XXX Configure test */ - const NV nan = NV_NAN; - return (*hibyte & mask) != (((U8*)&nan)[hibyte - (U8*)&nv] & mask); - } else { - return 0; - } -#endif -} - -/* The largest known floating point numbers are the IEEE quadruple - * precision of 128 bits. */ -#define MAX_NV_BYTES (128/8) - -static const char nan_payload_error[] = "NaN payload error"; - -/* - -=for apidoc nan_payload_set - -Set the NaN payload of the nv. - -The first byte is the highest order byte of the payload (big-endian). - -The signaling flag, if true, turns the generated NaN into a signaling one. -In most platforms this means turning _off_ the most significant bit of the -NaN. Note the _most_ - some platforms have the opposite semantics. -Do not assume any portability of the NaN semantics. - -=cut -*/ -void -Perl_nan_payload_set(NV *nvp, const void *bytes, STRLEN byten, bool signaling) -{ - /* How many bits we can set in the payload. - * - * Note that whether the most signicant bit is a quiet or - * signaling NaN is actually unstandardized. Most platforms use - * it as the 'quiet' bit. The known exceptions to this are older - * MIPS, and HPPA. - * - * Yet another unstandardized area is what does the difference - * actually mean - if it exists: some platforms do not even have - * signaling NaNs. - * - * C99 nan() is supposed to generate quiet NaNs. */ - int bits = NV_MANT_REAL_DIG - 1; - - STRLEN i, nvi; - bool error = FALSE; - - /* XXX None of this works for doubledouble platforms, or for mixendians. */ - - PERL_ARGS_ASSERT_NAN_PAYLOAD_SET; - - *nvp = NV_NAN; - -#ifdef NV_BIG_ENDIAN - nvi = NVSIZE - 1; -#endif -#ifdef NV_LITTLE_ENDIAN - nvi = 0; -#endif - - if (byten > MAX_NV_BYTES) { - byten = MAX_NV_BYTES; - error = TRUE; - } - for (i = 0; bits > 0; i++) { - U8 b = i < byten ? ((U8*) bytes)[i] : 0; - if (bits > 0 && bits < 8) { - U8 m = (1 << bits) - 1; - ((U8*)nvp)[nvi] &= ~m; - ((U8*)nvp)[nvi] |= b & m; - bits = 0; - } else { - ((U8*)nvp)[nvi] = b; - bits -= 8; - } -#ifdef NV_BIG_ENDIAN - nvi--; -#endif -#ifdef NV_LITTLE_ENDIAN - nvi++; -#endif - } - if (error) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW), - nan_payload_error); - } - nan_signaling_set(nvp, signaling); -} - -/* -=for apidoc grok_nan_payload - -Helper for grok_nan(). - -Parses the "..." in C99-style "nan(...)" strings, and sets the nvp accordingly. - -If you want the parse the "nan" part you need to use grok_nan(). - -=cut -*/ -const char * -Perl_grok_nan_payload(pTHX_ const char* s, const char* send, bool signaling, int *flags, NV* nvp) -{ - U8 bytes[MAX_NV_BYTES]; - STRLEN byten = 0; - const char *t = send - 1; /* minus one for ')' */ - bool error = FALSE; - - PERL_ARGS_ASSERT_GROK_NAN_PAYLOAD; - - /* XXX: legacy nan payload formats like "nan123", - * "nan0xabc", or "nan(s123)" ("s" for signaling). */ - - while (t > s && isSPACE(*t)) t--; - if (*t != ')') { - return send; - } - - if (++s == send) { - *flags |= IS_NUMBER_TRAILING; - return s; - } - - while (s < t && byten < MAX_NV_BYTES) { - UV uv; - int nantype = 0; - - if (s[0] == '0' && s + 2 < t && - isALPHA_FOLD_EQ(s[1], 'x') && - isXDIGIT(s[2])) { - const char *u = s + 3; - STRLEN len; - I32 uvflags; - - while (isXDIGIT(*u)) u++; - len = u - s; - uvflags = PERL_SCAN_ALLOW_UNDERSCORES; - uv = grok_hex(s, &len, &uvflags, NULL); - if ((uvflags & PERL_SCAN_GREATER_THAN_UV_MAX)) { - nantype = 0; - } else { - nantype = IS_NUMBER_IN_UV; - } - s += len; - } else if (s[0] == '0' && s + 2 < t && - isALPHA_FOLD_EQ(s[1], 'b') && - (s[2] == '0' || s[2] == '1')) { - const char *u = s + 3; - STRLEN len; - I32 uvflags; - - while (*u == '0' || *u == '1') u++; - len = u - s; - uvflags = PERL_SCAN_ALLOW_UNDERSCORES; - uv = grok_bin(s, &len, &uvflags, NULL); - if ((uvflags & PERL_SCAN_GREATER_THAN_UV_MAX)) { - nantype = 0; - } else { - nantype = IS_NUMBER_IN_UV; - } - s += len; - } else if ((s[0] == '\'' || s[0] == '"') && - s + 2 < t && t[-1] == s[0]) { - /* Perl extension: if the input looks like a string - * constant ('' or ""), read its bytes as-they-come. */ - STRLEN n = t - s - 2; - STRLEN i; - if ((n > MAX_NV_BYTES - byten) || - (n * 8 > NV_MANT_REAL_DIG)) { - error = TRUE; - break; - } - /* Copy the bytes in reverse so that \x41\x42 ('AB') - * is equivalent to 0x4142. In other words, the bytes - * are in big-endian order. */ - for (i = 0; i < n; i++) { - bytes[n - i - 1] = s[i + 1]; - } - byten += n; - break; - } else if (s < t && isDIGIT(*s)) { - const char *u; - nantype = - grok_number_flags(s, (STRLEN)(t - s), &uv, - PERL_SCAN_TRAILING | - PERL_SCAN_ALLOW_UNDERSCORES); - /* Unfortunately grok_number_flags() doesn't - * tell how far we got and the ')' will always - * be "trailing", so we need to double-check - * whether we had something dubious. */ - for (u = s; u < send - 1; u++) { - if (!isDIGIT(*u)) { - *flags |= IS_NUMBER_TRAILING; - break; - } - } - s = u; - } else { - error = TRUE; - break; - } - /* XXX Doesn't do octal: nan("0123"). - * Probably not a big loss. */ - - if (!(nantype & IS_NUMBER_IN_UV)) { - error = TRUE; - break; - } - - if (uv) { - while (uv && byten < MAX_NV_BYTES) { - bytes[byten++] = (U8) (uv & 0xFF); - uv >>= 8; - } - } - } - - if (byten == 0) { - bytes[byten++] = 0; - } - - if (error) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW), - nan_payload_error); - } - - if (s == send) { - *flags |= IS_NUMBER_TRAILING; - return s; - } - - if (nvp) { - nan_payload_set(nvp, bytes, byten, signaling); - } + PERL_ARGS_ASSERT_SCAN_OCT; - return s; + *retlen = len; + return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv; } -/* -=for apidoc grok_nan +NV +Perl_scan_hex(pTHX_ const char *start, STRLEN len, STRLEN *retlen) +{ + NV rnv; + I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0; + const UV ruv = grok_hex (start, &len, &flags, &rnv); -Helper for grok_infnan(). + PERL_ARGS_ASSERT_SCAN_HEX; -Parses the C99-style "nan(...)" strings, and sets the nvp accordingly. + *retlen = len; + return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv; +} -*sp points to the beginning of "nan", which can be also "qnan", "nanq", -or "snan", "nans", and case is ignored. +/* +=for apidoc grok_numeric_radix -The "..." is parsed with grok_nan_payload(). +Scan and skip for a numeric decimal separator (radix). =cut -*/ -const char * -Perl_grok_nan(pTHX_ const char* s, const char* send, int *flags, NV* nvp) + */ +bool +Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send) { - bool signaling = FALSE; + PERL_ARGS_ASSERT_GROK_NUMERIC_RADIX; - PERL_ARGS_ASSERT_GROK_NAN; +#ifdef USE_LOCALE_NUMERIC - if (isALPHA_FOLD_EQ(*s, 'S')) { - signaling = TRUE; - s++; if (s == send) return s; - } else if (isALPHA_FOLD_EQ(*s, 'Q')) { - s++; if (s == send) return s; - } + if (IN_LC(LC_NUMERIC)) { + STRLEN len; + char * radix; + bool matches_radix = FALSE; + DECLARATION_FOR_LC_NUMERIC_MANIPULATION; - if (isALPHA_FOLD_EQ(*s, 'N')) { - s++; if (s == send || isALPHA_FOLD_NE(*s, 'A')) return s; - s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return s; - s++; + STORE_LC_NUMERIC_FORCE_TO_UNDERLYING(); - *flags |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; + radix = SvPV(PL_numeric_radix_sv, len); + radix = savepvn(radix, len); - /* NaN can be followed by various stuff (NaNQ, NaNS), while - * some legacy implementations have weird stuff like "NaN%" - * (no idea what that means). */ - if (isALPHA_FOLD_EQ(*s, 's')) { - signaling = TRUE; - s++; - } else if (isALPHA_FOLD_EQ(*s, 'q')) { - s++; - } + RESTORE_LC_NUMERIC(); - if (*s == '(') { - const char *n = grok_nan_payload(s, send, signaling, flags, nvp); - if (n == send) return NULL; - s = n; - if (*s != ')') { - *flags |= IS_NUMBER_TRAILING; - return s; - } - } else { - if (nvp) { - U8 bytes[1] = { 0 }; - nan_payload_set(nvp, bytes, 1, signaling); - } + if (*sp + len <= send) { + matches_radix = memEQ(*sp, radix, len); + } - while (s < send && isSPACE(*s)) s++; + Safefree(radix); - if (s < send && *s) { - /* Note that we here implicitly accept (parse as - * "nan", but with warnings) also any other weird - * trailing stuff for "nan". In the above we just - * check that if we got the C99-style "nan(...)", - * the "..." looks sane. If in future we accept - * more ways of specifying the nan payload (like - * "nan123" or "nan0xabc"), the accepting would - * happen around here. */ - *flags |= IS_NUMBER_TRAILING; - } + if (matches_radix) { + *sp += len; + return TRUE; } + } + +#endif - s = send; + /* always try "." if numeric radix didn't match because + * we may have data from different locales mixed */ + if (*sp < send && **sp == '.') { + ++*sp; + return TRUE; } - else - return NULL; - return s; + return FALSE; } /* =for apidoc grok_infnan -Helper for grok_number(), accepts various ways of spelling "infinity" +Helper for C, accepts various ways of spelling "infinity" or "not a number", and returns one of the following flag combinations: - IS_NUMBER_INFINITE + IS_NUMBER_INFINITY IS_NUMBER_NAN - IS_NUMBER_INFINITE | IS_NUMBER_NEG + IS_NUMBER_INFINITY | IS_NUMBER_NEG IS_NUMBER_NAN | IS_NUMBER_NEG 0 -possibly |-ed with IS_NUMBER_TRAILING. +possibly |-ed with C. -If an infinity or a not-a-number is recognized, the *sp will point to +If an infinity or a not-a-number is recognized, C<*sp> will point to one byte past the end of the recognized string. If the recognition fails, -zero is returned, and the *sp will not move. +zero is returned, and C<*sp> will not move. + +=for apidoc Amnh|bool|IS_NUMBER_GREATER_THAN_UV_MAX +=for apidoc Amnh|bool|IS_NUMBER_INFINITY +=for apidoc Amnh|bool|IS_NUMBER_IN_UV +=for apidoc Amnh|bool|IS_NUMBER_NAN +=for apidoc Amnh|bool|IS_NUMBER_NEG +=for apidoc Amnh|bool|IS_NUMBER_NOT_INT =cut */ int -Perl_grok_infnan(pTHX_ const char** sp, const char* send, NV* nvp) +Perl_grok_infnan(pTHX_ const char** sp, const char* send) { const char* s = *sp; int flags = 0; +#if defined(NV_INF) || defined(NV_NAN) bool odh = FALSE; /* one-dot-hash: 1.#INF */ PERL_ARGS_ASSERT_GROK_INFNAN; - /* XXX there are further legacy formats like HP-UX "++" for Inf - * and "--" for -Inf. While we might be able to grok those in - * string numification, having those in source code might open - * up too much golfing: ++++; - */ - if (*s == '+') { s++; if (s == send) return 0; } @@ -1051,7 +781,7 @@ Perl_grok_infnan(pTHX_ const char** sp, const char* send, NV* nvp) s++; if (s == send || isALPHA_FOLD_NE(*s, 'Y')) return fail; s++; } else if (odh) { - while (*s == '0') { /* 1.#INF00 */ + while (s < send && *s == '0') { /* 1.#INF00 */ s++; } } @@ -1061,20 +791,14 @@ Perl_grok_infnan(pTHX_ const char** sp, const char* send, NV* nvp) flags |= IS_NUMBER_TRAILING; } flags |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; - if (nvp) { - *nvp = (flags & IS_NUMBER_NEG) ? -NV_INF: NV_INF; - } } else if (isALPHA_FOLD_EQ(*s, 'D') && odh) { /* 1.#IND */ s++; flags |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; - if (nvp) { - *nvp = NV_NAN; - } - while (*s == '0') { /* 1.#IND00 */ + while (s < send && *s == '0') { /* 1.#IND00 */ s++; } - if (*s) { + if (s < send && *s) { flags |= IS_NUMBER_TRAILING; } } else @@ -1082,53 +806,206 @@ Perl_grok_infnan(pTHX_ const char** sp, const char* send, NV* nvp) } else { /* Maybe NAN of some sort */ - const char *n = grok_nan(s, send, &flags, nvp); - if (n == NULL) return 0; - s = n; + + if (isALPHA_FOLD_EQ(*s, 'S') || isALPHA_FOLD_EQ(*s, 'Q')) { + /* snan, qNaN */ + /* XXX do something with the snan/qnan difference */ + s++; if (s == send) return 0; + } + + if (isALPHA_FOLD_EQ(*s, 'N')) { + s++; if (s == send || isALPHA_FOLD_NE(*s, 'A')) return 0; + s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return 0; + s++; + + flags |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; + if (s == send) { + return flags; + } + + /* NaN can be followed by various stuff (NaNQ, NaNS), but + * there are also multiple different NaN values, and some + * implementations output the "payload" values, + * e.g. NaN123, NAN(abc), while some legacy implementations + * have weird stuff like NaN%. */ + if (isALPHA_FOLD_EQ(*s, 'q') || + isALPHA_FOLD_EQ(*s, 's')) { + /* "nanq" or "nans" are ok, though generating + * these portably is tricky. */ + s++; + if (s == send) { + return flags; + } + } + if (*s == '(') { + /* C99 style "nan(123)" or Perlish equivalent "nan($uv)". */ + const char *t; + s++; + if (s == send) { + return flags | IS_NUMBER_TRAILING; + } + t = s + 1; + while (t < send && *t && *t != ')') { + t++; + } + if (t == send) { + return flags | IS_NUMBER_TRAILING; + } + if (*t == ')') { + int nantype; + UV nanval; + if (s[0] == '0' && s + 2 < t && + isALPHA_FOLD_EQ(s[1], 'x') && + isXDIGIT(s[2])) { + STRLEN len = t - s; + I32 flags = PERL_SCAN_ALLOW_UNDERSCORES; + nanval = grok_hex(s, &len, &flags, NULL); + if ((flags & PERL_SCAN_GREATER_THAN_UV_MAX)) { + nantype = 0; + } else { + nantype = IS_NUMBER_IN_UV; + } + s += len; + } else if (s[0] == '0' && s + 2 < t && + isALPHA_FOLD_EQ(s[1], 'b') && + (s[2] == '0' || s[2] == '1')) { + STRLEN len = t - s; + I32 flags = PERL_SCAN_ALLOW_UNDERSCORES; + nanval = grok_bin(s, &len, &flags, NULL); + if ((flags & PERL_SCAN_GREATER_THAN_UV_MAX)) { + nantype = 0; + } else { + nantype = IS_NUMBER_IN_UV; + } + s += len; + } else { + const char *u; + nantype = + grok_number_flags(s, t - s, &nanval, + PERL_SCAN_TRAILING | + PERL_SCAN_ALLOW_UNDERSCORES); + /* Unfortunately grok_number_flags() doesn't + * tell how far we got and the ')' will always + * be "trailing", so we need to double-check + * whether we had something dubious. */ + for (u = s; u < t; u++) { + if (!isDIGIT(*u)) { + flags |= IS_NUMBER_TRAILING; + break; + } + } + s = u; + } + + /* XXX Doesn't do octal: nan("0123"). + * Probably not a big loss. */ + + if ((nantype & IS_NUMBER_NOT_INT) || + !(nantype && IS_NUMBER_IN_UV)) { + /* XXX the nanval is currently unused, that is, + * not inserted as the NaN payload of the NV. + * But the above code already parses the C99 + * nan(...) format. See below, and see also + * the nan() in POSIX.xs. + * + * Certain configuration combinations where + * NVSIZE is greater than UVSIZE mean that + * a single UV cannot contain all the possible + * NaN payload bits. There would need to be + * some more generic syntax than "nan($uv)". + * + * Issues to keep in mind: + * + * (1) In most common cases there would + * not be an integral number of bytes that + * could be set, only a certain number of bits. + * For example for the common case of + * NVSIZE == UVSIZE == 8 there is room for 52 + * bits in the payload, but the most significant + * bit is commonly reserved for the + * signaling/quiet bit, leaving 51 bits. + * Furthermore, the C99 nan() is supposed + * to generate quiet NaNs, so it is doubtful + * whether it should be able to generate + * signaling NaNs. For the x86 80-bit doubles + * (if building a long double Perl) there would + * be 62 bits (s/q bit being the 63rd). + * + * (2) Endianness of the payload bits. If the + * payload is specified as an UV, the low-order + * bits of the UV are naturally little-endianed + * (rightmost) bits of the payload. The endianness + * of UVs and NVs can be different. */ + return 0; + } + if (s < t) { + flags |= IS_NUMBER_TRAILING; + } + } else { + /* Looked like nan(...), but no close paren. */ + flags |= IS_NUMBER_TRAILING; + } + } else { + while (s < send && isSPACE(*s)) + s++; + if (s < send && *s) { + /* Note that we here implicitly accept (parse as + * "nan", but with warnings) also any other weird + * trailing stuff for "nan". In the above we just + * check that if we got the C99-style "nan(...)", + * the "..." looks sane. + * If in future we accept more ways of specifying + * the nan payload, the accepting would happen around + * here. */ + flags |= IS_NUMBER_TRAILING; + } + } + s = send; + } + else + return 0; } while (s < send && isSPACE(*s)) s++; +#else + PERL_UNUSED_ARG(send); +#endif /* #if defined(NV_INF) || defined(NV_NAN) */ *sp = s; return flags; } /* -=for apidoc grok_number2_flags +=for apidoc grok_number_flags Recognise (or not) a number. The type of the number is returned (0 if unrecognised), otherwise it is a bit-ORed combination of -IS_NUMBER_IN_UV, IS_NUMBER_GREATER_THAN_UV_MAX, IS_NUMBER_NOT_INT, -IS_NUMBER_NEG, IS_NUMBER_INFINITY, IS_NUMBER_NAN (defined in perl.h). - -If the value of the number can fit in a UV, it is returned in the *valuep -IS_NUMBER_IN_UV will be set to indicate that *valuep is valid, IS_NUMBER_IN_UV -will never be set unless *valuep is valid, but *valuep may have been assigned -to during processing even though IS_NUMBER_IN_UV is not set on return. -If valuep is NULL, IS_NUMBER_IN_UV will be set for the same cases as when -valuep is non-NULL, but no actual assignment (or SEGV) will occur. - -The nvp is used to directly set the value for infinities (Inf) and -not-a-numbers (NaN). - -IS_NUMBER_NOT_INT will be set with IS_NUMBER_IN_UV if trailing decimals were -seen (in which case *valuep gives the true value truncated to an integer), and -IS_NUMBER_NEG if the number is negative (in which case *valuep holds the -absolute value). IS_NUMBER_IN_UV is not set if e notation was used or the +C, C, C, +C, C, C (defined in perl.h). + +If the value of the number can fit in a UV, it is returned in C<*valuep>. +C will be set to indicate that C<*valuep> is valid, C +will never be set unless C<*valuep> is valid, but C<*valuep> may have been assigned +to during processing even though C is not set on return. +If C is C, C will be set for the same cases as when +C is non-C, but no actual assignment (or SEGV) will occur. + +C will be set with C if trailing decimals were +seen (in which case C<*valuep> gives the true value truncated to an integer), and +C if the number is negative (in which case C<*valuep> holds the +absolute value). C is not set if e notation was used or the number is larger than a UV. C allows only C, which allows for trailing non-numeric text on an otherwise successful I, setting C on the result. -=for apidoc grok_number_flags - -Identical to grok_number2_flags() with nvp and flags set to zero. +=for apidoc Amnh||PERL_SCAN_TRAILING =for apidoc grok_number -Identical to grok_number_flags() with flags set to zero. +Identical to C with C set to zero. =cut */ @@ -1140,130 +1017,166 @@ Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep) return grok_number_flags(pv, len, valuep, 0); } -int -Perl_grok_number_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, U32 flags) -{ - PERL_ARGS_ASSERT_GROK_NUMBER_FLAGS; - - return grok_number2_flags(pv, len, valuep, NULL, flags); -} - static const UV uv_max_div_10 = UV_MAX / 10; static const U8 uv_max_mod_10 = UV_MAX % 10; int -Perl_grok_number2_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, NV *nvp, U32 flags) +Perl_grok_number_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, U32 flags) { const char *s = pv; const char * const send = pv + len; const char *d; int numtype = 0; - PERL_ARGS_ASSERT_GROK_NUMBER2_FLAGS; + PERL_ARGS_ASSERT_GROK_NUMBER_FLAGS; - while (s < send && isSPACE(*s)) - s++; - if (s == send) { - return 0; - } else if (*s == '-') { - s++; - numtype = IS_NUMBER_NEG; + if (UNLIKELY(isSPACE(*s))) { + s++; + while (s < send) { + if (LIKELY(! isSPACE(*s))) goto non_space; + s++; + } + return 0; + non_space: ; } - else if (*s == '+') - s++; - if (s == send) - return 0; + /* See if signed. This assumes it is more likely to be unsigned, so + * penalizes signed by an extra conditional; rewarding unsigned by one fewer + * (because we detect '+' and '-' with a single test and then add a + * conditional to determine which) */ + if (UNLIKELY((*s & ~('+' ^ '-')) == ('+' & '-') )) { + + /* Here, on ASCII platforms, *s is one of: 0x29 = ')', 2B = '+', 2D = '-', + * 2F = '/'. That is, it is either a sign, or a character that doesn't + * belong in a number at all (unless it's a radix character in a weird + * locale). Given this, it's far more likely to be a minus than the + * others. (On EBCDIC it is one of 42, 44, 46, 48, 4A, 4C, 4E, (not 40 + * because can't be a space) 60, 62, 64, 66, 68, 6A, 6C, 6E. Again, + * only potentially a weird radix character, or 4E='+', or 60='-') */ + if (LIKELY(*s == '-')) { + s++; + numtype = IS_NUMBER_NEG; + } + else if (LIKELY(*s == '+')) + s++; + else /* Can't just return failure here, as it could be a weird radix + character */ + goto done_sign; + + if (UNLIKELY(s == send)) + return 0; + done_sign: ; + } /* The first digit (after optional sign): note that might * also point to "infinity" or "nan", or "1.#INF". */ d = s; /* next must be digit or the radix separator or beginning of infinity/nan */ - if (isDIGIT(*s)) { + if (LIKELY(isDIGIT(*s))) { /* UVs are at least 32 bits, so the first 9 decimal digits cannot overflow. */ - UV value = *s - '0'; - /* This construction seems to be more optimiser friendly. - (without it gcc does the isDIGIT test and the *s - '0' separately) - With it gcc on arm is managing 6 instructions (6 cycles) per digit. - In theory the optimiser could deduce how far to unroll the loop - before checking for overflow. */ - if (++s < send) { - int digit = *s - '0'; - if (digit >= 0 && digit <= 9) { + UV value = *s - '0'; /* Process this first (perhaps only) digit */ + int digit; + + s++; + + switch(send - s) { + default: /* 8 or more remaining characters */ + digit = *s - '0'; + if (UNLIKELY(! inRANGE(digit, 0, 9))) break; value = value * 10 + digit; - if (++s < send) { - digit = *s - '0'; - if (digit >= 0 && digit <= 9) { - value = value * 10 + digit; - if (++s < send) { - digit = *s - '0'; - if (digit >= 0 && digit <= 9) { + s++; + /* FALLTHROUGH */ + case 7: + digit = *s - '0'; + if (UNLIKELY(! inRANGE(digit, 0, 9))) break; + value = value * 10 + digit; + s++; + /* FALLTHROUGH */ + case 6: + digit = *s - '0'; + if (UNLIKELY(! inRANGE(digit, 0, 9))) break; + value = value * 10 + digit; + s++; + /* FALLTHROUGH */ + case 5: + digit = *s - '0'; + if (UNLIKELY(! inRANGE(digit, 0, 9))) break; + value = value * 10 + digit; + s++; + /* FALLTHROUGH */ + case 4: + digit = *s - '0'; + if (UNLIKELY(! inRANGE(digit, 0, 9))) break; + value = value * 10 + digit; + s++; + /* FALLTHROUGH */ + case 3: + digit = *s - '0'; + if (UNLIKELY(! inRANGE(digit, 0, 9))) break; + value = value * 10 + digit; + s++; + /* FALLTHROUGH */ + case 2: + digit = *s - '0'; + if (UNLIKELY(! inRANGE(digit, 0, 9))) break; + value = value * 10 + digit; + s++; + /* FALLTHROUGH */ + case 1: + digit = *s - '0'; + if (UNLIKELY(! inRANGE(digit, 0, 9))) break; + value = value * 10 + digit; + s++; + /* FALLTHROUGH */ + case 0: /* This case means the string consists of just the one + digit we already have processed */ + + /* If we got here by falling through other than the default: case, we + * have processed the whole string, and know it consists entirely of + * digits, and can't have overflowed. */ + if (s >= send) { + if (valuep) + *valuep = value; + return numtype|IS_NUMBER_IN_UV; + } + + /* Here, there are extra characters beyond the first 9 digits. Use a + * loop to accumulate any remaining digits, until we get a non-digit or + * would overflow. Note that leading zeros could cause us to get here + * without being close to overflowing. + * + * (The conditional 's >= send' above could be eliminated by making the + * default: in the switch to instead be 'case 8:', and process longer + * strings separately by using the loop below. This would penalize + * these inputs by the extra instructions needed for looping. That + * could be eliminated by copying the unwound code from above to handle + * the firt 9 digits of these. khw didn't think this saving of a + * single conditional was worth it.) */ + do { + digit = *s - '0'; + if (! inRANGE(digit, 0, 9)) goto mantissa_done; + if ( value < uv_max_div_10 + || ( value == uv_max_div_10 + && digit <= uv_max_mod_10)) + { value = value * 10 + digit; - if (++s < send) { - digit = *s - '0'; - if (digit >= 0 && digit <= 9) { - value = value * 10 + digit; - if (++s < send) { - digit = *s - '0'; - if (digit >= 0 && digit <= 9) { - value = value * 10 + digit; - if (++s < send) { - digit = *s - '0'; - if (digit >= 0 && digit <= 9) { - value = value * 10 + digit; - if (++s < send) { - digit = *s - '0'; - if (digit >= 0 && digit <= 9) { - value = value * 10 + digit; - if (++s < send) { - digit = *s - '0'; - if (digit >= 0 && digit <= 9) { - value = value * 10 + digit; - if (++s < send) { - /* Now got 9 digits, so need to check - each time for overflow. */ - digit = *s - '0'; - while (digit >= 0 && digit <= 9 - && (value < uv_max_div_10 - || (value == uv_max_div_10 - && digit <= uv_max_mod_10))) { - value = value * 10 + digit; - if (++s < send) - digit = *s - '0'; - else - break; - } - if (digit >= 0 && digit <= 9 - && (s < send)) { - /* value overflowed. - skip the remaining digits, don't - worry about setting *valuep. */ - do { - s++; - } while (s < send && isDIGIT(*s)); - numtype |= - IS_NUMBER_GREATER_THAN_UV_MAX; - goto skip_value; - } - } - } - } - } - } - } - } - } - } - } - } - } + s++; } - } - } - } - } + else { /* value would overflow. skip the remaining digits, don't + worry about setting *valuep. */ + do { + s++; + } while (s < send && isDIGIT(*s)); + numtype |= + IS_NUMBER_GREATER_THAN_UV_MAX; + goto skip_value; + } + } while (s < send); + } /* End switch on input length */ + + mantissa_done: numtype |= IS_NUMBER_IN_UV; if (valuep) *valuep = value; @@ -1274,7 +1187,7 @@ Perl_grok_number2_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, NV *nvp, U while (s < send && isDIGIT(*s)) /* optional digits after the radix */ s++; } - } + } /* End of *s is a digit */ else if (GROK_NUMERIC_RADIX(&s, send)) { numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */ /* no digits before the radix means we need digits after it */ @@ -1291,9 +1204,9 @@ Perl_grok_number2_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, NV *nvp, U return 0; } - if (s > d && s < send) { + if (LIKELY(s > d) && s < send) { /* we can have an optional exponent part */ - if (isALPHA_FOLD_EQ(*s, 'e')) { + if (UNLIKELY(isALPHA_FOLD_EQ(*s, 'e'))) { s++; if (s < send && (*s == '-' || *s == '+')) s++; @@ -1312,31 +1225,30 @@ Perl_grok_number2_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, NV *nvp, U numtype |= IS_NUMBER_NOT_INT; } } - while (s < send && isSPACE(*s)) + + while (s < send) { + if (LIKELY(! isSPACE(*s))) goto end_space; s++; - if (s >= send) - return numtype; - if (len == 10 && memEQ(pv, "0 but true", 10)) { + } + return numtype; + + end_space: + + if (UNLIKELY(memEQs(pv, len, "0 but true"))) { if (valuep) *valuep = 0; return IS_NUMBER_IN_UV; } + /* We could be e.g. at "Inf" or "NaN", or at the "#" of "1.#INF". */ - if ((s + 2 < send) && strchr("inqs#", toFOLD(*s))) { + if ((s + 2 < send) && UNLIKELY(memCHRs("inqs#", toFOLD(*s)))) { /* Really detect inf/nan. Start at d, not s, since the above * code might have already consumed the "1." or "1". */ - NV nanv; - int infnan = Perl_grok_infnan(aTHX_ &d, send, &nanv); + const int infnan = Perl_grok_infnan(aTHX_ &d, send); if ((infnan & IS_NUMBER_INFINITY)) { - if (nvp) { - *nvp = (numtype & IS_NUMBER_NEG) ? -NV_INF : NV_INF; - } return (numtype | infnan); /* Keep sign for infinity. */ } else if ((infnan & IS_NUMBER_NAN)) { - if (nvp) { - *nvp = nanv; - } return (numtype | infnan) & ~IS_NUMBER_NEG; /* Clear sign for nan. */ } } @@ -1348,91 +1260,104 @@ Perl_grok_number2_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, NV *nvp, U } /* -=for apidoc grok_atou - -grok_atou is a safer replacement for atoi and strtol. +=for apidoc grok_atoUV -grok_atou parses a C-style zero-byte terminated string, looking for -a decimal unsigned integer. +parse a string, looking for a decimal unsigned integer. -Returns the unsigned integer, if a valid value can be parsed -from the beginning of the string. +On entry, C points to the beginning of the string; +C points to a UV that will receive the converted value, if found; +C is either NULL or points to a variable that points to one byte +beyond the point in C that this routine should examine. +If C is NULL, C is assumed to be NUL-terminated. -Accepts only the decimal digits '0'..'9'. +Returns FALSE if C doesn't represent a valid unsigned integer value (with +no leading zeros). Otherwise it returns TRUE, and sets C<*valptr> to that +value. -As opposed to atoi or strtol, grok_atou does NOT allow optional -leading whitespace, or negative inputs. If such features are -required, the calling code needs to explicitly implement those. +If you constrain the portion of C that is looked at by this function (by +passing a non-NULL C), and if the intial bytes of that portion form a +valid value, it will return TRUE, setting C<*endptr> to the byte following the +final digit of the value. But if there is no constraint at what's looked at, +all of C must be valid in order for TRUE to be returned. C<*endptr> is +unchanged from its value on input if FALSE is returned; -If a valid value cannot be parsed, returns either zero (if non-digits -are met before any digits) or UV_MAX (if the value overflows). +The only characters this accepts are the decimal digits '0'..'9'. -Note that extraneous leading zeros also count as an overflow -(meaning that only "0" is the zero). +As opposed to L or L, C does NOT allow optional +leading whitespace, nor negative inputs. If such features are required, the +calling code needs to explicitly implement those. -On failure, the *endptr is also set to NULL, unless endptr is NULL. +Note that this function returns FALSE for inputs that would overflow a UV, +or have leading zeros. Thus a single C<0> is accepted, but not C<00> nor +C<01>, C<002>, I. -Trailing non-digit bytes are allowed if the endptr is non-NULL. -On return the *endptr will contain the pointer to the first non-digit byte. - -If the endptr is NULL, the first non-digit byte MUST be -the zero byte terminating the pv, or zero will be returned. - -Background: atoi has severe problems with illegal inputs, it cannot be +Background: C has severe problems with illegal inputs, it cannot be used for incremental parsing, and therefore should be avoided -atoi and strtol are also affected by locale settings, which can also be +C and C are also affected by locale settings, which can also be seen as a bug (global state controlled by user environment). =cut + */ -UV -Perl_grok_atou(const char *pv, const char** endptr) +bool +Perl_grok_atoUV(const char *pv, UV *valptr, const char** endptr) { const char* s = pv; const char** eptr; const char* end2; /* Used in case endptr is NULL. */ - UV val = 0; /* The return value. */ - - PERL_ARGS_ASSERT_GROK_ATOU; - - eptr = endptr ? endptr : &end2; - if (isDIGIT(*s)) { - /* Single-digit inputs are quite common. */ - val = *s++ - '0'; - if (isDIGIT(*s)) { - /* Extra leading zeros cause overflow. */ - if (val == 0) { - *eptr = NULL; - return UV_MAX; - } - while (isDIGIT(*s)) { - /* This could be unrolled like in grok_number(), but - * the expected uses of this are not speed-needy, and - * unlikely to need full 64-bitness. */ - U8 digit = *s++ - '0'; - if (val < uv_max_div_10 || - (val == uv_max_div_10 && digit <= uv_max_mod_10)) { - val = val * 10 + digit; - } else { - *eptr = NULL; - return UV_MAX; - } + UV val = 0; /* The parsed value. */ + + PERL_ARGS_ASSERT_GROK_ATOUV; + + if (endptr) { + eptr = endptr; + } + else { + end2 = s + strlen(s); + eptr = &end2; + } + + if ( *eptr <= s + || ! isDIGIT(*s)) + { + return FALSE; + } + + /* Single-digit inputs are quite common. */ + val = *s++ - '0'; + if (s < *eptr && isDIGIT(*s)) { + /* Fail on extra leading zeros. */ + if (val == 0) + return FALSE; + while (s < *eptr && isDIGIT(*s)) { + /* This could be unrolled like in grok_number(), but + * the expected uses of this are not speed-needy, and + * unlikely to need full 64-bitness. */ + const U8 digit = *s++ - '0'; + if (val < uv_max_div_10 || + (val == uv_max_div_10 && digit <= uv_max_mod_10)) { + val = val * 10 + digit; + } else { + return FALSE; } } } - if (s == pv) { - *eptr = NULL; /* If no progress, failed to parse anything. */ - return 0; + + if (endptr == NULL) { + if (*s) { + return FALSE; /* If endptr is NULL, no trailing non-digits allowed. */ + } } - if (endptr == NULL && *s) { - return 0; /* If endptr is NULL, no trailing non-digits allowed. */ + else { + *endptr = s; } - *eptr = s; - return val; + + *valptr = val; + return TRUE; } -#ifndef USE_QUADMATH +#ifndef Perl_strtod STATIC NV S_mulexp10(NV value, I32 exponent) { @@ -1448,11 +1373,11 @@ S_mulexp10(NV value, I32 exponent) /* On OpenVMS VAX we by default use the D_FLOAT double format, * and that format does not have *easy* capabilities [1] for - * overflowing doubles 'silently' as IEEE fp does. We also need - * to support G_FLOAT on both VAX and Alpha, and though the exponent - * range is much larger than D_FLOAT it still doesn't do silent - * overflow. Therefore we need to detect early whether we would - * overflow (this is the behaviour of the native string-to-float + * overflowing doubles 'silently' as IEEE fp does. We also need + * to support G_FLOAT on both VAX and Alpha, and though the exponent + * range is much larger than D_FLOAT it still doesn't do silent + * overflow. Therefore we need to detect early whether we would + * overflow (this is the behaviour of the native string-to-float * conversion routines, and therefore of native applications, too). * * [1] Trying to establish a condition handler to trap floating point @@ -1466,7 +1391,7 @@ S_mulexp10(NV value, I32 exponent) * a hammer. Therefore we need to catch potential overflows before * it's too late. */ -#if ((defined(VMS) && !defined(_IEEE_FP)) || defined(_UNICOS)) && defined(NV_MAX_10_EXP) +#if ((defined(VMS) && !defined(_IEEE_FP)) || defined(_UNICOS) || defined(DOUBLE_IS_VAX_FLOAT)) && defined(NV_MAX_10_EXP) STMT_START { const NV exp_v = log10(value); if (exponent >= NV_MAX_10_EXP || exponent + exp_v >= NV_MAX_10_EXP) @@ -1513,10 +1438,14 @@ S_mulexp10(NV value, I32 exponent) result *= power; #ifdef FP_OVERFLOWS_TO_ZERO if (result == 0) +# ifdef NV_INF return value < 0 ? -NV_INF : NV_INF; +# else + return value < 0 ? -FLT_MAX : FLT_MAX; +# endif #endif /* Floating point exceptions are supposed to be turned off, - * but if we're obviously done, don't risk another iteration. + * but if we're obviously done, don't risk another iteration. */ if (exponent == 0) break; } @@ -1524,24 +1453,47 @@ S_mulexp10(NV value, I32 exponent) } return negative ? value / result : value * result; } -#endif /* #ifndef USE_QUADMATH */ +#endif /* #ifndef Perl_strtod */ + +#ifdef Perl_strtod +# define ATOF(s, x) my_atof2(s, &x) +#else +# define ATOF(s, x) Perl_atof2(s, x) +#endif NV Perl_my_atof(pTHX_ const char* s) { + +/* +=for apidoc my_atof + +L(3)>, but properly works with Perl locale handling, accepting a dot +radix character always, but also the current locale's radix character if and +only if called from within the lexical scope of a Perl C statement. + +N.B. C must be NUL terminated. + +=cut +*/ + NV x = 0.0; -#ifdef USE_QUADMATH - Perl_my_atof2(aTHX_ s, &x); - return x; -#else -# ifdef USE_LOCALE_NUMERIC + PERL_ARGS_ASSERT_MY_ATOF; +#if ! defined(USE_LOCALE_NUMERIC) + + ATOF(s, x); + +#else + { - DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED(); - if (PL_numeric_radix_sv && IN_LC(LC_NUMERIC)) { - const char *standard = NULL, *local = NULL; - bool use_standard_radix; + DECLARATION_FOR_LC_NUMERIC_MANIPULATION; + STORE_LC_NUMERIC_SET_TO_NEEDED(); + if (! (PL_numeric_radix_sv && IN_LC(LC_NUMERIC))) { + ATOF(s,x); + } + else { /* Look through the string for the first thing that looks like a * decimal point: either the value in the current locale or the @@ -1550,52 +1502,51 @@ Perl_my_atof(pTHX_ const char* s) * that we have to determine this beforehand because on some * systems, Perl_atof2 is just a wrapper around the system's atof. * */ - standard = strchr(s, '.'); - local = strstr(s, SvPV_nolen(PL_numeric_radix_sv)); + const char * const standard_pos = strchr(s, '.'); + const char * const local_pos + = strstr(s, SvPV_nolen(PL_numeric_radix_sv)); + const bool use_standard_radix + = standard_pos && (!local_pos || standard_pos < local_pos); - use_standard_radix = standard && (!local || standard < local); - - if (use_standard_radix) + if (use_standard_radix) { SET_NUMERIC_STANDARD(); + LOCK_LC_NUMERIC_STANDARD(); + } - Perl_atof2(s, x); + ATOF(s,x); - if (use_standard_radix) - SET_NUMERIC_LOCAL(); + if (use_standard_radix) { + UNLOCK_LC_NUMERIC_STANDARD(); + SET_NUMERIC_UNDERLYING(); + } } - else - Perl_atof2(s, x); RESTORE_LC_NUMERIC(); } -# else - Perl_atof2(s, x); -# endif + #endif + return x; } +#if defined(NV_INF) || defined(NV_NAN) -#ifdef USING_MSVC6 -# pragma warning(push) -# pragma warning(disable:4756;disable:4056) -#endif static char* S_my_atof_infnan(pTHX_ const char* s, bool negative, const char* send, NV* value) { const char *p0 = negative ? s - 1 : s; const char *p = p0; - int infnan = grok_infnan(&p, send, value); + const int infnan = grok_infnan(&p, send); if (infnan && p != p0) { /* If we can generate inf/nan directly, let's do so. */ #ifdef NV_INF if ((infnan & IS_NUMBER_INFINITY)) { - /* grok_infnan() already set the value. */ + *value = (infnan & IS_NUMBER_NEG) ? -NV_INF: NV_INF; return (char*)p; } #endif #ifdef NV_NAN if ((infnan & IS_NUMBER_NAN)) { - /* grok_infnan() already set the value. */ + *value = NV_NAN; return (char*)p; } #endif @@ -1603,46 +1554,52 @@ S_my_atof_infnan(pTHX_ const char* s, bool negative, const char* send, NV* value /* If still here, we didn't have either NV_INF or NV_NAN, * and can try falling back to native strtod/strtold. * - * (Though, are our NV_INF or NV_NAN ever not defined?) - * * The native interface might not recognize all the possible * inf/nan strings Perl recognizes. What we can try * is to try faking the input. We will try inf/-inf/nan * as the most promising/portable input. */ { - const char* fake = NULL; + const char* fake = "silence compiler warning"; char* endp; NV nv; +#ifdef NV_INF if ((infnan & IS_NUMBER_INFINITY)) { fake = ((infnan & IS_NUMBER_NEG)) ? "-inf" : "inf"; } - else if ((infnan & IS_NUMBER_NAN)) { +#endif +#ifdef NV_NAN + if ((infnan & IS_NUMBER_NAN)) { fake = "nan"; } - assert(fake); - nv = Perl_strtod(fake, &endp); +#endif + assert(strNE(fake, "silence compiler warning")); + nv = S_strtod(aTHX_ fake, &endp); if (fake != endp) { +#ifdef NV_INF if ((infnan & IS_NUMBER_INFINITY)) { -#ifdef Perl_isinf +# ifdef Perl_isinf if (Perl_isinf(nv)) *value = nv; -#else +# else /* last resort, may generate SIGFPE */ *value = Perl_exp((NV)1e9); if ((infnan & IS_NUMBER_NEG)) *value = -*value; -#endif +# endif return (char*)p; /* p, not endp */ } - else if ((infnan & IS_NUMBER_NAN)) { -#ifdef Perl_isnan +#endif +#ifdef NV_NAN + if ((infnan & IS_NUMBER_NAN)) { +# ifdef Perl_isnan if (Perl_isnan(nv)) *value = nv; -#else +# else /* last resort, may generate SIGFPE */ *value = Perl_log((NV)-1.0); -#endif +# endif return (char*)p; /* p, not endp */ +#endif } } } @@ -1650,20 +1607,28 @@ S_my_atof_infnan(pTHX_ const char* s, bool negative, const char* send, NV* value } return NULL; } -#ifdef USING_MSVC6 -# pragma warning(pop) -#endif + +#endif /* if defined(NV_INF) || defined(NV_NAN) */ char* Perl_my_atof2(pTHX_ const char* orig, NV* value) { + PERL_ARGS_ASSERT_MY_ATOF2; + return my_atof3(orig, value, 0); +} + +char* +Perl_my_atof3(pTHX_ const char* orig, NV* value, const STRLEN len) +{ const char* s = orig; NV result[3] = {0.0, 0.0, 0.0}; -#if defined(USE_PERL_ATOF) || defined(USE_QUADMATH) - const char* send = s + strlen(orig); /* one past the last */ +#if defined(USE_PERL_ATOF) || defined(Perl_strtod) + const char* send = s + ((len != 0) + ? len + : strlen(orig)); /* one past the last */ bool negative = 0; #endif -#if defined(USE_PERL_ATOF) && !defined(USE_QUADMATH) +#if defined(USE_PERL_ATOF) && !defined(Perl_strtod) UV accumulator[2] = {0,0}; /* before/after dp */ bool seen_digit = 0; I32 exp_adjust[2] = {0,0}; @@ -1676,11 +1641,11 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value) I32 sig_digits = 0; /* noof significant digits seen so far */ #endif -#if defined(USE_PERL_ATOF) || defined(USE_QUADMATH) - PERL_ARGS_ASSERT_MY_ATOF2; +#if defined(USE_PERL_ATOF) || defined(Perl_strtod) + PERL_ARGS_ASSERT_MY_ATOF3; /* leading whitespace */ - while (isSPACE(*s)) + while (s < send && isSPACE(*s)) ++s; /* sign */ @@ -1693,12 +1658,43 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value) } #endif -#ifdef USE_QUADMATH +#ifdef Perl_strtod { char* endp; - if ((endp = S_my_atof_infnan(s, negative, send, value))) + char* copy = NULL; + + if ((endp = S_my_atof_infnan(aTHX_ s, negative, send, value))) return endp; - result[2] = strtoflt128(s, &endp); + + /* strtold() accepts 0x-prefixed hex and in POSIX implementations, + 0b-prefixed binary numbers, which is backward incompatible + */ + if ((len == 0 || len - (s-orig) >= 2) && *s == '0' && + (isALPHA_FOLD_EQ(s[1], 'x') || isALPHA_FOLD_EQ(s[1], 'b'))) { + *value = 0; + return (char *)s+1; + } + + /* If the length is passed in, the input string isn't NUL-terminated, + * and in it turns out the function below assumes it is; therefore we + * create a copy and NUL-terminate that */ + if (len) { + Newx(copy, len + 1, char); + Copy(orig, copy, len, char); + copy[len] = '\0'; + s = copy + (s - orig); + } + + result[2] = S_strtod(aTHX_ s, &endp); + + /* If we created a copy, 'endp' is in terms of that. Convert back to + * the original */ + if (copy) { + s = (s - copy) + (char *) orig; + endp = (endp - copy) + (char *) orig; + Safefree(copy); + } + if (s != endp) { *value = negative ? -result[2] : result[2]; return endp; @@ -1736,16 +1732,18 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value) /* the max number we can accumulate in a UV, and still safely do 10*N+9 */ #define MAX_ACCUMULATE ( (UV) ((UV_MAX - 9)/10)) +#if defined(NV_INF) || defined(NV_NAN) { - const char* endp; + char* endp; if ((endp = S_my_atof_infnan(aTHX_ s, negative, send, value))) - return (char*)endp; + return endp; } +#endif /* we accumulate digits into an integer; when this becomes too * large, we add the total to NV and start again */ - while (1) { + while (s < send) { if (isDIGIT(*s)) { seen_digit = 1; old_digit = digit; @@ -1773,7 +1771,7 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value) exp_adjust[0]++; } /* skip remaining digits */ - while (isDIGIT(*s)) { + while (s < send && isDIGIT(*s)) { ++s; if (! seen_dp) { exp_adjust[0]++; @@ -1797,9 +1795,9 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value) else if (!seen_dp && GROK_NUMERIC_RADIX(&s, send)) { seen_dp = 1; if (sig_digits > MAX_SIG_DIGITS) { - do { + while (s < send && isDIGIT(*s)) { ++s; - } while (isDIGIT(*s)); + } break; } } @@ -1813,7 +1811,7 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value) result[1] = S_mulexp10(result[1], exp_acc[1]) + (NV)accumulator[1]; } - if (seen_digit && (isALPHA_FOLD_EQ(*s, 'e'))) { + if (s < send && seen_digit && (isALPHA_FOLD_EQ(*s, 'e'))) { bool expnegative = 0; ++s; @@ -1824,14 +1822,12 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value) case '+': ++s; } - while (isDIGIT(*s)) + while (s < send && isDIGIT(*s)) exponent = exponent * 10 + (*s++ - '0'); if (expnegative) exponent = -exponent; } - - /* now apply the exponent */ if (seen_dp) { @@ -1844,17 +1840,23 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value) /* now apply the sign */ if (negative) result[2] = -result[2]; -#endif /* USE_PERL_ATOF */ *value = result[2]; return (char *)s; +#else /* USE_PERL_ATOF */ + /* If you see this error you both don't have strtod (or configured -Ud_strtod or + or it's long double/quadmath equivalent) and disabled USE_PERL_ATOF, thus + removing any way for perl to convert strings to floating point numbers. + */ +# error No mechanism to convert strings to numbers available +#endif } /* =for apidoc isinfnan -Perl_isinfnan() is utility function that returns true if the NV -argument is either an infinity or a NaN, false otherwise. To test -in more detail, use Perl_isinf() and Perl_isnan(). +C is a utility function that returns true if the NV +argument is either an infinity or a C, false otherwise. To test +in more detail, use C and C. This is also the logical inverse of Perl_isfinite(). @@ -1863,6 +1865,7 @@ This is also the logical inverse of Perl_isfinite(). bool Perl_isinfnan(NV nv) { + PERL_UNUSED_ARG(nv); #ifdef Perl_isinf if (Perl_isinf(nv)) return TRUE; @@ -1875,11 +1878,11 @@ Perl_isinfnan(NV nv) } /* -=for apidoc +=for apidoc isinfnansv -Checks whether the argument would be either an infinity or NaN when used +Checks whether the argument would be either an infinity or C when used as a number, but is careful not to trigger non-numeric or uninitialized -warnings. it assumes the caller has done SvGETMAGIC(sv) already. +warnings. it assumes the caller has done C already. =cut */ @@ -1897,7 +1900,7 @@ Perl_isinfnansv(pTHX_ SV *sv) { STRLEN len; const char *s = SvPV_nomg_const(sv, len); - return cBOOL(grok_infnan(&s, s+len, NULL)); + return cBOOL(grok_infnan(&s, s+len)); } } @@ -1935,21 +1938,21 @@ Perl_my_frexpl(long double x, int *e) { =for apidoc Perl_signbit Return a non-zero integer if the sign bit on an NV is set, and 0 if -it is not. +it is not. -If Configure detects this system has a signbit() that will work with -our NVs, then we just use it via the #define in perl.h. Otherwise, +If F detects this system has a C that will work with +our NVs, then we just use it via the C<#define> in F. Otherwise, fall back on this implementation. The main use of this function -is catching -0.0. +is catching C<-0.0>. -Configure notes: This function is called 'Perl_signbit' instead of a -plain 'signbit' because it is easy to imagine a system having a signbit() +C notes: This function is called C<'Perl_signbit'> instead of a +plain C<'signbit'> because it is easy to imagine a system having a C function or macro that doesn't happen to work with our particular choice -of NVs. We shouldn't just re-#define signbit as Perl_signbit and expect +of NVs. We shouldn't just re-C<#define> C as C and expect the standard system headers to be happy. Also, this is a no-context -function (no pTHX_) because Perl_signbit() is usually re-#defined in -perl.h as a simple macro call to the system's signbit(). -Users should just always call Perl_signbit(). +function (no C) because C is usually re-C<#defined> in +F as a simple macro call to the system's C. +Users should just always call C. =cut */ @@ -1957,19 +1960,25 @@ Users should just always call Perl_signbit(). int Perl_signbit(NV x) { # ifdef Perl_fp_class_nzero - if (x == 0) - return Perl_fp_class_nzero(x); -# endif + return Perl_fp_class_nzero(x); + /* Try finding the high byte, and assume it's highest bit + * is the sign. This assumption is probably wrong somewhere. */ +# elif defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN + return (((unsigned char *)&x)[9] & 0x80); +# elif defined(NV_LITTLE_ENDIAN) + /* Note that NVSIZE is sizeof(NV), which would make the below be + * wrong if the end bytes are unused, which happens with the x86 + * 80-bit long doubles, which is why take care of that above. */ + return (((unsigned char *)&x)[NVSIZE - 1] & 0x80); +# elif defined(NV_BIG_ENDIAN) + return (((unsigned char *)&x)[0] & 0x80); +# else + /* This last resort fallback is wrong for the negative zero. */ return (x < 0.0) ? 1 : 0; +# endif } #endif /* - * Local variables: - * c-indentation-style: bsd - * c-basic-offset: 4 - * indent-tabs-mode: nil - * End: - * * ex: set ts=8 sts=4 sw=4 et: */