X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/129ccace6b45e3574c0b430b1fbcc7f8d0aa8e50..d43c116b2ae74ec1f3ed78829d4f3ca76f091390:/numeric.c diff --git a/numeric.c b/numeric.c index 6e5bce7..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 @@ -279,7 +276,7 @@ leading underscore is accepted. 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 @@ -313,7 +310,7 @@ 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 the C flag is always treated as being set for +The C flag is always treated as being set for this function. =cut @@ -379,7 +376,7 @@ Perl_grok_bin_oct_hex(pTHX_ const char *start, /* In overflows, this keeps track of how much to multiply the overflowed NV * by as we continue to parse the remaining digits */ - UV factor; + 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 @@ -423,47 +420,51 @@ Perl_grok_bin_oct_hex(pTHX_ const char *start, s = s0; /* s0 potentially advanced from 'start' */ - /* Unroll the loop so that the first 7 digits are branchless except for the - * switch. An eighth one could overflow a 32 bit word. This should - * completely handle the common case without needing extra checks */ + /* 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 (! _generic_isCC(*s, class_bit)) break; + 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 (! _generic_isCC(*s, class_bit)) break; + if (UNLIKELY(! _generic_isCC(*s, class_bit))) break; value = (value << shift) | XDIGIT_VALUE(*s); s++; /* FALLTHROUGH */ case 5: - if (! _generic_isCC(*s, class_bit)) break; + if (UNLIKELY(! _generic_isCC(*s, class_bit))) break; value = (value << shift) | XDIGIT_VALUE(*s); s++; /* FALLTHROUGH */ case 4: - if (! _generic_isCC(*s, class_bit)) break; + if (UNLIKELY(! _generic_isCC(*s, class_bit))) break; value = (value << shift) | XDIGIT_VALUE(*s); s++; /* FALLTHROUGH */ case 3: - if (! _generic_isCC(*s, class_bit)) break; + if (UNLIKELY(! _generic_isCC(*s, class_bit))) break; value = (value << shift) | XDIGIT_VALUE(*s); s++; /* FALLTHROUGH */ case 2: - if (! _generic_isCC(*s, class_bit)) break; + if (UNLIKELY(! _generic_isCC(*s, class_bit))) break; value = (value << shift) | XDIGIT_VALUE(*s); s++; /* FALLTHROUGH */ case 1: - if (! _generic_isCC(*s, class_bit)) break; + if (UNLIKELY(! _generic_isCC(*s, class_bit))) break; value = (value << shift) | XDIGIT_VALUE(*s); - if (LIKELY(len <= 7)) { + if (LIKELY(len <= 8)) { return value; } @@ -488,7 +489,7 @@ Perl_grok_bin_oct_hex(pTHX_ const char *start, /* Note XDIGIT_VALUE() is branchless, works on binary * and octal as well, so can be used here, without * slowing those down */ - factor <<= shift; + factor *= 1 << shift; continue; } @@ -497,7 +498,7 @@ Perl_grok_bin_oct_hex(pTHX_ const char *start, * 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 *= (NV) factor; + value_nv *= factor; value_nv += (NV) value; /* Then we keep accumulating digits, until all are parsed. We @@ -509,12 +510,16 @@ Perl_grok_bin_oct_hex(pTHX_ const char *start, if (! overflowed) { overflowed = TRUE; - Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW), + 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"); + } } continue; } @@ -522,34 +527,45 @@ Perl_grok_bin_oct_hex(pTHX_ const char *start, if ( *s == '_' && len && allow_underscores - && _generic_isCC(s[1], class_bit)) + && _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; } - if ( *s - && ! (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), + 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; } } @@ -564,18 +580,20 @@ Perl_grok_bin_oct_hex(pTHX_ const char *start, && ! (input_flags & PERL_SCAN_SILENT_NON_PORTABLE)) { output_non_portable(base); + *flags |= PERL_SCAN_SILENT_NON_PORTABLE; } #endif return value; } /* Overflowed: Calculate the final overflow approximation */ - value_nv *= (NV) factor; + value_nv *= factor; value_nv += (NV) value; output_non_portable(base); - *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + *flags |= PERL_SCAN_GREATER_THAN_UV_MAX + | PERL_SCAN_SILENT_NON_PORTABLE; if (result) *result = value_nv; return UV_MAX; @@ -705,12 +723,12 @@ 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 C<*sp> will not move. -=for apidoc Amn|bool|IS_NUMBER_GREATER_THAN_UV_MAX -=for apidoc Amn|bool|IS_NUMBER_INFINITY -=for apidoc Amn|bool|IS_NUMBER_IN_UV -=for apidoc Amn|bool|IS_NUMBER_NAN -=for apidoc Amn|bool|IS_NUMBER_NEG -=for apidoc Amn|bool|IS_NUMBER_NOT_INT +=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 */ @@ -763,7 +781,7 @@ Perl_grok_infnan(pTHX_ const char** sp, const char* send) 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++; } } @@ -777,10 +795,10 @@ Perl_grok_infnan(pTHX_ const char** sp, const char* send) else if (isALPHA_FOLD_EQ(*s, 'D') && odh) { /* 1.#IND */ s++; flags |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; - while (*s == '0') { /* 1.#IND00 */ + while (s < send && *s == '0') { /* 1.#IND00 */ s++; } - if (*s) { + if (s < send && *s) { flags |= IS_NUMBER_TRAILING; } } else @@ -1033,8 +1051,8 @@ Perl_grok_number_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, U32 flags) * 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='-') */ + * 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; @@ -1260,7 +1278,8 @@ 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. +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; The only characters this accepts are the decimal digits '0'..'9'. @@ -1445,7 +1464,18 @@ S_mulexp10(NV value, I32 exponent) NV Perl_my_atof(pTHX_ const char* s) { - /* 's' must be NUL terminated */ + +/* +=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; @@ -1810,9 +1840,15 @@ Perl_my_atof3(pTHX_ const char* orig, NV* value, const STRLEN len) /* 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 } /*