X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/572cd85091706ffa2e19db60c41c6bb106297e3a..e7a3fd4551b610f58191be5da1b4d5115764196a:/numeric.c diff --git a/numeric.c b/numeric.c index 9cf6f6f..f5eadc8 100644 --- a/numeric.c +++ b/numeric.c @@ -29,6 +29,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 +140,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 +158,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 +177,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 +195,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 @@ -204,7 +305,7 @@ Perl_grok_bin(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) "Illegal binary digit '%c' ignored", *s); break; } - + if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff @@ -325,7 +426,7 @@ Perl_grok_hex(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) "Illegal hexadecimal digit '%c' ignored", *s); break; } - + if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff @@ -432,7 +533,7 @@ Perl_grok_oct(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) } break; } - + if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff @@ -518,33 +619,44 @@ Scan and skip for a numeric decimal separator (radix). bool Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send) { -#ifdef USE_LOCALE_NUMERIC PERL_ARGS_ASSERT_GROK_NUMERIC_RADIX; +#ifdef USE_LOCALE_NUMERIC + if (IN_LC(LC_NUMERIC)) { + STRLEN len; + char * radix; + bool matches_radix = FALSE; DECLARATION_FOR_LC_NUMERIC_MANIPULATION; - 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; - } - } + + STORE_LC_NUMERIC_FORCE_TO_UNDERLYING(); + + radix = SvPV(PL_numeric_radix_sv, len); + radix = savepvn(radix, len); + RESTORE_LC_NUMERIC(); + + if (*sp + len <= send) { + matches_radix = memEQ(*sp, radix, len); + } + + Safefree(radix); + + if (matches_radix) { + *sp += len; + return TRUE; + } } - /* always try "." if numeric radix didn't match because - * we may have data from different locales mixed */ -#endif - PERL_ARGS_ASSERT_GROK_NUMERIC_RADIX; +#endif + /* always try "." if numeric radix didn't match because + * we may have data from different locales mixed */ if (*sp < send && **sp == '.') { ++*sp; return TRUE; } + return FALSE; } @@ -554,9 +666,9 @@ Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send) 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 @@ -574,6 +686,7 @@ 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; @@ -798,6 +911,9 @@ Perl_grok_infnan(pTHX_ const char** sp, const char* send) while (s < send && isSPACE(*s)) s++; +#else + PERL_UNUSED_ARG(send); +#endif /* #if defined(NV_INF) || defined(NV_NAN) */ *sp = s; return flags; } @@ -884,41 +1000,41 @@ Perl_grok_number_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, U32 flags) before checking for overflow. */ if (++s < send) { int digit = *s - '0'; - if (digit >= 0 && digit <= 9) { + if (inRANGE(digit, 0, 9)) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; - if (digit >= 0 && digit <= 9) { + if (inRANGE(digit, 0, 9)) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; - if (digit >= 0 && digit <= 9) { + if (inRANGE(digit, 0, 9)) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; - if (digit >= 0 && digit <= 9) { + if (inRANGE(digit, 0, 9)) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; - if (digit >= 0 && digit <= 9) { + if (inRANGE(digit, 0, 9)) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; - if (digit >= 0 && digit <= 9) { + if (inRANGE(digit, 0, 9)) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; - if (digit >= 0 && digit <= 9) { + if (inRANGE(digit, 0, 9)) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; - if (digit >= 0 && digit <= 9) { + if (inRANGE(digit, 0, 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 + while ( inRANGE(digit, 0, 9) && (value < uv_max_div_10 || (value == uv_max_div_10 && digit <= uv_max_mod_10))) { @@ -928,7 +1044,7 @@ Perl_grok_number_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, U32 flags) else break; } - if (digit >= 0 && digit <= 9 + if (inRANGE(digit, 0, 9) && (s < send)) { /* value overflowed. skip the remaining digits, don't @@ -1009,7 +1125,7 @@ Perl_grok_number_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, U32 flags) s++; if (s >= send) return numtype; - if (len == 10 && memEQ(pv, "0 but true", 10)) { + if (memEQs(pv, len, "0 but true")) { if (valuep) *valuep = 0; return IS_NUMBER_IN_UV; @@ -1018,7 +1134,7 @@ Perl_grok_number_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, U32 flags) if ((s + 2 < send) && strchr("inqs#", toFOLD(*s))) { /* Really detect inf/nan. Start at d, not s, since the above * code might have already consumed the "1." or "1". */ - int infnan = Perl_grok_infnan(aTHX_ &d, send); + const int infnan = Perl_grok_infnan(aTHX_ &d, send); if ((infnan & IS_NUMBER_INFINITY)) { return (numtype | infnan); /* Keep sign for infinity. */ } @@ -1034,33 +1150,43 @@ Perl_grok_number_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, U32 flags) } /* -grok_atoUV +=for apidoc grok_atoUV -grok_atoUV 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_atoUV 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. -Returns true if a valid value could be parsed. In that case, valptr -is set to the parsed value, and endptr (if provided) is set to point -to the character after the last digit. +The only characters this accepts are the decimal digits '0'..'9'. -Returns false otherwise. This can happen if a) there is a leading zero -followed by another digit; b) the digits would overflow a UV; or c) -there are trailing non-digits AND endptr is not provided. +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. -Background: atoi has severe problems with illegal inputs, it cannot be +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. + +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 + */ bool @@ -1073,38 +1199,54 @@ Perl_grok_atoUV(const char *pv, UV *valptr, const char** endptr) PERL_ARGS_ASSERT_GROK_ATOUV; - eptr = endptr ? endptr : &end2; - if (isDIGIT(*s)) { - /* Single-digit inputs are quite common. */ - val = *s++ - '0'; - if (isDIGIT(*s)) { - /* Fail on extra leading zeros. */ - if (val == 0) + 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; - 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 { - return FALSE; - } } } } - if (s == pv) - return FALSE; - if (endptr == NULL && *s) - return FALSE; /* If endptr is NULL, no trailing non-digits allowed. */ - *eptr = s; + + if (endptr == NULL) { + if (*s) { + return FALSE; /* If endptr is NULL, no trailing non-digits allowed. */ + } + } + else { + *endptr = s; + } + *valptr = val; return TRUE; } -#ifndef USE_QUADMATH +#ifndef Perl_strtod STATIC NV S_mulexp10(NV value, I32 exponent) { @@ -1120,11 +1262,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 @@ -1138,7 +1280,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) @@ -1185,10 +1327,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; } @@ -1196,25 +1342,36 @@ 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) { + /* 's' must be NUL terminated */ + 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 + { DECLARATION_FOR_LC_NUMERIC_MANIPULATION; 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; + 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 @@ -1223,30 +1380,33 @@ 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)); - - use_standard_radix = standard && (!local || standard < local); + 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); - 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) + 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) @@ -1257,7 +1417,7 @@ 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); + 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 @@ -1276,46 +1436,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 } } } @@ -1327,16 +1493,27 @@ S_my_atof_infnan(pTHX_ const char* s, bool negative, const char* send, NV* value # 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}; @@ -1349,11 +1526,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 */ @@ -1366,12 +1543,34 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value) } #endif -#ifdef USE_QUADMATH +#ifdef Perl_strtod { char* endp; + char* copy = NULL; + if ((endp = S_my_atof_infnan(aTHX_ s, negative, send, value))) return endp; - result[2] = strtoflt128(s, &endp); + + /* 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; @@ -1409,16 +1608,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; @@ -1446,7 +1647,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]++; @@ -1470,9 +1671,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; } } @@ -1486,7 +1687,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; @@ -1497,14 +1698,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) { @@ -1536,6 +1735,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; @@ -1608,7 +1808,7 @@ 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 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, @@ -1630,11 +1830,9 @@ Users should just always call C. int Perl_signbit(NV x) { # ifdef Perl_fp_class_nzero - if (x == 0) - 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. */ + 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) @@ -1645,7 +1843,7 @@ Perl_signbit(NV x) { # elif defined(NV_BIG_ENDIAN) return (((unsigned char *)&x)[0] & 0x80); # else - /* This last fallback will fail for the negative zero. */ + /* This last resort fallback is wrong for the negative zero. */ return (x < 0.0) ? 1 : 0; # endif }