X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/aa42a541b3e55358a6845e5246813d47b2cb883b..34623dbb20698f0fedd1ded1b2461b2d281b172f:/numeric.c diff --git a/numeric.c b/numeric.c index 208a9aa..70654864 100644 --- a/numeric.c +++ b/numeric.c @@ -18,11 +18,11 @@ /* =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 -=cut - */ #include "EXTERN.h" @@ -30,9 +30,8 @@ values, including such things as replacements for the OS's atof() function #include "perl.h" U32 -Perl_cast_ulong(pTHX_ NV f) +Perl_cast_ulong(NV f) { - PERL_UNUSED_CONTEXT; if (f < 0.0) return f < I32_MIN ? (U32) I32_MIN : (U32)(I32) f; if (f < U32_MAX_P1) { @@ -40,7 +39,7 @@ Perl_cast_ulong(pTHX_ 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 @@ -49,9 +48,8 @@ Perl_cast_ulong(pTHX_ NV f) } I32 -Perl_cast_i32(pTHX_ NV f) +Perl_cast_i32(NV f) { - PERL_UNUSED_CONTEXT; if (f < I32_MAX_P1) return f < I32_MIN ? I32_MIN : (I32) f; if (f < U32_MAX_P1) { @@ -59,7 +57,7 @@ Perl_cast_i32(pTHX_ 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 @@ -68,9 +66,8 @@ Perl_cast_i32(pTHX_ NV f) } IV -Perl_cast_iv(pTHX_ NV f) +Perl_cast_iv(NV f) { - PERL_UNUSED_CONTEXT; if (f < IV_MAX_P1) return f < IV_MIN ? IV_MIN : (IV) f; if (f < UV_MAX_P1) { @@ -79,7 +76,7 @@ Perl_cast_iv(pTHX_ 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 @@ -88,9 +85,8 @@ Perl_cast_iv(pTHX_ NV f) } UV -Perl_cast_uv(pTHX_ NV f) +Perl_cast_uv(NV f) { - PERL_UNUSED_CONTEXT; if (f < 0.0) return f < IV_MIN ? (UV) IV_MIN : (UV)(IV) f; if (f < UV_MAX_P1) { @@ -98,7 +94,7 @@ Perl_cast_uv(pTHX_ 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 @@ -111,24 +107,24 @@ Perl_cast_uv(pTHX_ 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. +On entry C and C<*len> 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 the first invalid character. -Unless C is set in I<*flags>, encountering an +Unless C is set in C<*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 return C<*len> 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 +and nothing is written to C<*result>. If the value is > C, C +returns C, sets C in the output flags, +and writes the value to C<*result> (or the value 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 the binary +number may use C<"_"> characters to separate digits. =cut @@ -157,11 +153,11 @@ Perl_grok_bin(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) for compatibility silently suffer "b" and "0b" as valid binary numbers. */ if (len >= 1) { - if (s[0] == 'b' || s[0] == 'B') { + if (isALPHA_FOLD_EQ(s[0], 'b')) { s++; len--; } - else if (len >= 2 && s[0] == '0' && (s[1] == 'b' || s[1] == 'B')) { + else if (len >= 2 && s[0] == '0' && (isALPHA_FOLD_EQ(s[1], 'b'))) { s+=2; len-=2; } @@ -234,36 +230,35 @@ 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> give the string to scan, I<*flags> gives -conversion flags, and I should be NULL or a pointer to an NV. +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 the first invalid character. -Unless C is set in I<*flags>, encountering an +Unless C is set in C<*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 return C<*len> 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 the value to C<*result> (or the value is discarded if C +is C). -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. +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 the hex +number may use C<"_"> characters to separate digits. =cut Not documented yet because experimental is C= 1) { - if (s[0] == 'x' || s[0] == 'X') { + if (isALPHA_FOLD_EQ(s[0], 'x')) { s++; len--; } - else if (len >= 2 && s[0] == '0' && (s[1] == 'x' || s[1] == 'X')) { + else if (len >= 2 && s[0] == '0' && (isALPHA_FOLD_EQ(s[1], 'x'))) { s+=2; len-=2; } @@ -291,15 +286,14 @@ Perl_grok_hex(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) } for (; len-- && *s; s++) { - const char *hexdigit = strchr(PL_hexdigit, *s); - if (hexdigit) { + 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) | ((hexdigit - PL_hexdigit) & 15); + value = (value << 4) | XDIGIT_VALUE(*s); continue; } /* Bah. We're just overflowed. */ @@ -316,11 +310,11 @@ Perl_grok_hex(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) * 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)((hexdigit - PL_hexdigit) & 15); + value_nv += (NV) XDIGIT_VALUE(*s); continue; } if (*s == '_' && len && allow_underscores && s[1] - && (hexdigit = strchr(PL_hexdigit, s[1]))) + && isXDIGIT(s[1])) { --len; ++s; @@ -357,22 +351,22 @@ 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. +On entry C and C<*len> 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 the first invalid character. -Unless C is set in I<*flags>, encountering an +Unless C is set in C<*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 return C<*len> 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 the value to C<*result> (or the value is discarded if C +is C). -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 the octal +number may use C<"_"> characters to separate digits. =cut @@ -395,17 +389,14 @@ Perl_grok_oct(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) PERL_ARGS_ASSERT_GROK_OCT; for (; len-- && *s; s++) { - /* gcc 2.95 optimiser not smart enough to figure that this subtraction - out front allows slicker code. */ - int digit = *s - '0'; - if (digit >= 0 && digit <= 7) { + if (isOCTAL(*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. */ redo: if (!overflowed) { if (value <= max_div_8) { - value = (value << 3) | digit; + value = (value << 3) | OCTAL_VALUE(*s); continue; } /* Bah. We're just overflowed. */ @@ -422,20 +413,19 @@ Perl_grok_oct(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) * 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)digit; + value_nv += (NV) OCTAL_VALUE(*s); continue; } - if (digit == ('_' - '0') && len && allow_underscores - && (digit = s[1] - '0') && (digit >= 0 && digit <= 7)) - { - --len; - ++s; - goto redo; - } + if (*s == '_' && len && allow_underscores && isOCTAL(s[1])) { + --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). */ - if (digit == 8 || digit == 9) { + * 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); @@ -466,15 +456,15 @@ Perl_grok_oct(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) /* =for apidoc scan_bin -For backwards compatibility. Use C instead. +For backwards compatibility. Use C instead. =for apidoc scan_hex -For backwards compatibility. Use C instead. +For backwards compatibility. Use C instead. =for apidoc scan_oct -For backwards compatibility. Use C instead. +For backwards compatibility. Use C instead. =cut */ @@ -529,17 +519,21 @@ bool Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send) { #ifdef USE_LOCALE_NUMERIC - dVAR; - PERL_ARGS_ASSERT_GROK_NUMERIC_RADIX; - if (PL_numeric_radix_sv && IN_SOME_LOCALE_FORM) { - STRLEN len; - const char * const radix = SvPV(PL_numeric_radix_sv, len); - if (*sp + len <= send && memEQ(*sp, radix, len)) { - *sp += len; - return TRUE; + if (IN_LC(LC_NUMERIC)) { + 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; + } } + RESTORE_LC_NUMERIC(); } /* always try "." if numeric radix didn't match because * we may have data from different locales mixed */ @@ -555,40 +549,314 @@ Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send) } /* -=for apidoc grok_number +=for apidoc grok_infnan + +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_NAN + IS_NUMBER_INFINITE | IS_NUMBER_NEG + IS_NUMBER_NAN | IS_NUMBER_NEG + 0 + +possibly |-ed with C. + +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. + +=cut +*/ + +int +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; + + if (*s == '+') { + s++; if (s == send) return 0; + } + else if (*s == '-') { + flags |= IS_NUMBER_NEG; /* Yes, -NaN happens. Incorrect but happens. */ + s++; if (s == send) return 0; + } + + if (*s == '1') { + /* Visual C: 1.#SNAN, -1.#QNAN, 1#INF, 1.#IND (maybe also 1.#NAN) + * Let's keep the dot optional. */ + s++; if (s == send) return 0; + if (*s == '.') { + s++; if (s == send) return 0; + } + if (*s == '#') { + s++; if (s == send) return 0; + } else + return 0; + odh = TRUE; + } + + if (isALPHA_FOLD_EQ(*s, 'I')) { + /* INF or IND (1.#IND is "indeterminate", a certain type of NAN) */ + + s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return 0; + s++; if (s == send) return 0; + if (isALPHA_FOLD_EQ(*s, 'F')) { + s++; + if (s < send && (isALPHA_FOLD_EQ(*s, 'I'))) { + int fail = + flags | IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING; + s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return fail; + s++; if (s == send || isALPHA_FOLD_NE(*s, 'I')) return fail; + s++; if (s == send || isALPHA_FOLD_NE(*s, 'T')) return fail; + s++; if (s == send || isALPHA_FOLD_NE(*s, 'Y')) return fail; + s++; + } else if (odh) { + while (*s == '0') { /* 1.#INF00 */ + s++; + } + } + while (s < send && isSPACE(*s)) + s++; + if (s < send && *s) { + flags |= IS_NUMBER_TRAILING; + } + flags |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; + } + else if (isALPHA_FOLD_EQ(*s, 'D') && odh) { /* 1.#IND */ + s++; + flags |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; + while (*s == '0') { /* 1.#IND00 */ + s++; + } + if (*s) { + flags |= IS_NUMBER_TRAILING; + } + } else + return 0; + } + else { + /* Maybe NAN of some sort */ + + 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; + + /* 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 == '(') { + /* 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_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. - -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 + +Identical to C with C set to zero. + =cut */ int Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep) { + PERL_ARGS_ASSERT_GROK_NUMBER; + + return grok_number_flags(pv, len, valuep, 0); +} + +static const UV uv_max_div_10 = UV_MAX / 10; +static const U8 uv_max_mod_10 = UV_MAX % 10; + +int +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 UV max_div_10 = UV_MAX / 10; - const char max_mod_10 = UV_MAX % 10; + const char *d; int numtype = 0; - int sawinf = 0; - int sawnan = 0; - PERL_ARGS_ASSERT_GROK_NUMBER; + PERL_ARGS_ASSERT_GROK_NUMBER_FLAGS; while (s < send && isSPACE(*s)) s++; @@ -604,7 +872,11 @@ Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep) if (s == send) return 0; - /* next must be digit or the radix separator or beginning of infinity */ + /* 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)) { /* UVs are at least 32 bits, so the first 9 decimal digits cannot overflow. */ @@ -651,9 +923,9 @@ Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep) each time for overflow. */ digit = *s - '0'; while (digit >= 0 && digit <= 9 - && (value < max_div_10 - || (value == max_div_10 - && digit <= max_mod_10))) { + && (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'; @@ -713,39 +985,12 @@ Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep) } } else - return 0; - } else if (*s == 'I' || *s == 'i') { - s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; - s++; if (s == send || (*s != 'F' && *s != 'f')) return 0; - s++; if (s < send && (*s == 'I' || *s == 'i')) { - s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; - s++; if (s == send || (*s != 'I' && *s != 'i')) return 0; - s++; if (s == send || (*s != 'T' && *s != 't')) return 0; - s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0; - s++; - } - sawinf = 1; - } else if (*s == 'N' || *s == 'n') { - /* XXX TODO: There are signaling NaNs and quiet NaNs. */ - s++; if (s == send || (*s != 'A' && *s != 'a')) return 0; - s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; - s++; - sawnan = 1; - } else - return 0; + return 0; + } - if (sawinf) { - numtype &= IS_NUMBER_NEG; /* Keep track of sign */ - numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; - } else if (sawnan) { - numtype &= IS_NUMBER_NEG; /* Keep track of sign */ - numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; - } else if (s < send) { + if (s > d && s < send) { /* we can have an optional exponent part */ - if (*s == 'e' || *s == 'E') { - /* The only flag we keep is sign. Blow away any "it's UV" */ - numtype &= IS_NUMBER_NEG; - numtype |= IS_NUMBER_NOT_INT; + if (isALPHA_FOLD_EQ(*s, 'e')) { s++; if (s < send && (*s == '-' || *s == '+')) s++; @@ -754,22 +999,116 @@ Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep) s++; } while (s < send && isDIGIT(*s)); } + else if (flags & PERL_SCAN_TRAILING) + return numtype | IS_NUMBER_TRAILING; else - return 0; + return 0; + + /* The only flag we keep is sign. Blow away any "it's UV" */ + numtype &= IS_NUMBER_NEG; + numtype |= IS_NUMBER_NOT_INT; } } while (s < send && isSPACE(*s)) 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; } + /* We could be e.g. at "Inf" or "NaN", or at the "#" of "1.#INF". */ + 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". */ + const int infnan = Perl_grok_infnan(aTHX_ &d, send); + if ((infnan & IS_NUMBER_INFINITY)) { + return (numtype | infnan); /* Keep sign for infinity. */ + } + else if ((infnan & IS_NUMBER_NAN)) { + return (numtype | infnan) & ~IS_NUMBER_NEG; /* Clear sign for nan. */ + } + } + else if (flags & PERL_SCAN_TRAILING) { + return numtype | IS_NUMBER_TRAILING; + } + return 0; } +/* +grok_atoUV + +grok_atoUV parses a C-style zero-byte terminated string, looking for +a decimal unsigned integer. + +Returns the unsigned integer, if a valid value can be parsed +from the beginning of the string. + +Accepts only the decimal digits '0'..'9'. + +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. + +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. + +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. + +Background: atoi 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 +seen as a bug (global state controlled by user environment). + +*/ + +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 parsed value. */ + + 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) + 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. */ + 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) + return FALSE; + if (endptr == NULL && *s) + return FALSE; /* If endptr is NULL, no trailing non-digits allowed. */ + *eptr = s; + *valptr = val; + return TRUE; +} + +#ifndef USE_QUADMATH STATIC NV S_mulexp10(NV value, I32 exponent) { @@ -780,8 +1119,8 @@ S_mulexp10(NV value, I32 exponent) if (exponent == 0) return value; - if (NV_eq_nowarn(value, 0.0)) - return (NV)0.0; + if (value == 0) + return (NV)0; /* On OpenVMS VAX we by default use the D_FLOAT double format, * and that format does not have *easy* capabilities [1] for @@ -803,7 +1142,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) @@ -823,11 +1162,39 @@ S_mulexp10(NV value, I32 exponent) if (exponent < 0) { negative = 1; exponent = -exponent; +#ifdef NV_MAX_10_EXP + /* for something like 1234 x 10^-309, the action of calculating + * the intermediate value 10^309 then returning 1234 / (10^309) + * will fail, since 10^309 becomes infinity. In this case try to + * refactor it as 123 / (10^308) etc. + */ + while (value && exponent > NV_MAX_10_EXP) { + exponent--; + value /= 10; + } + if (value == 0.0) + return value; +#endif } +#if defined(__osf__) + /* Even with cc -ieee + ieee_set_fp_control(IEEE_TRAP_ENABLE_INV) + * Tru64 fp behavior on inf/nan is somewhat broken. Another way + * to do this would be ieee_set_fp_control(IEEE_TRAP_ENABLE_OVF) + * but that breaks another set of infnan.t tests. */ +# define FP_OVERFLOWS_TO_ZERO +#endif for (bit = 1; exponent; bit <<= 1) { if (exponent & bit) { exponent ^= bit; 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. */ @@ -837,56 +1204,162 @@ S_mulexp10(NV value, I32 exponent) } return negative ? value / result : value * result; } +#endif /* #ifndef USE_QUADMATH */ NV Perl_my_atof(pTHX_ const char* s) { + /* 's' must be NUL terminated */ + NV x = 0.0; -#ifdef USE_LOCALE_NUMERIC - dVAR; PERL_ARGS_ASSERT_MY_ATOF; - if (PL_numeric_local && PL_numeric_radix_sv && IN_SOME_LOCALE_FORM) { - const char *standard = NULL, *local = NULL; - bool use_standard_radix; +#ifdef USE_QUADMATH - /* Look through the string for the first thing that looks like a - * decimal point: either the value in the current locale or the - * standard fallback of '.'. The one which appears earliest in the - * input string is the one that we should have atof look for. Note 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)); + Perl_my_atof2(aTHX_ s, &x); - use_standard_radix = standard && (!local || standard < local); +#elif ! defined(USE_LOCALE_NUMERIC) - if (use_standard_radix) - SET_NUMERIC_STANDARD(); + Perl_atof2(s, x); - Perl_atof2(s, x); +#else - if (use_standard_radix) - SET_NUMERIC_LOCAL(); + { + DECLARATION_FOR_LC_NUMERIC_MANIPULATION; + STORE_LC_NUMERIC_SET_TO_NEEDED(); + if (PL_numeric_radix_sv && IN_LC(LC_NUMERIC)) { + /* Look through the string for the first thing that looks like a + * decimal point: either the value in the current locale or the + * standard fallback of '.'. The one which appears earliest in the + * input string is the one that we should have atof look for. Note + * that we have to determine this beforehand because on some + * systems, Perl_atof2 is just a wrapper around the system's atof. + * */ + 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) + SET_NUMERIC_STANDARD(); + + Perl_atof2(s, x); + + if (use_standard_radix) + SET_NUMERIC_UNDERLYING(); + } + else + Perl_atof2(s, x); + RESTORE_LC_NUMERIC(); } - else - Perl_atof2(s, x); -#else - Perl_atof2(s, x); + #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; + 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)) { + *value = (infnan & IS_NUMBER_NEG) ? -NV_INF: NV_INF; + return (char*)p; + } +#endif +#ifdef NV_NAN + if ((infnan & IS_NUMBER_NAN)) { + *value = NV_NAN; + return (char*)p; + } +#endif +#ifdef Perl_strtod + /* If still here, we didn't have either NV_INF or NV_NAN, + * and can try falling back to native strtod/strtold. + * + * 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; + char* endp; + NV nv; +#ifdef NV_INF + if ((infnan & IS_NUMBER_INFINITY)) { + fake = ((infnan & IS_NUMBER_NEG)) ? "-inf" : "inf"; + } +#endif +#ifdef NV_NAN + if ((infnan & IS_NUMBER_NAN)) { + fake = "nan"; + } +#endif + assert(fake); + nv = Perl_strtod(fake, &endp); + if (fake != endp) { +#ifdef NV_INF + if ((infnan & IS_NUMBER_INFINITY)) { +# ifdef Perl_isinf + if (Perl_isinf(nv)) + *value = nv; +# else + /* last resort, may generate SIGFPE */ + *value = Perl_exp((NV)1e9); + if ((infnan & IS_NUMBER_NEG)) + *value = -*value; +# endif + return (char*)p; /* p, not endp */ + } +#endif +#ifdef NV_NAN + if ((infnan & IS_NUMBER_NAN)) { +# ifdef Perl_isnan + if (Perl_isnan(nv)) + *value = nv; +# else + /* last resort, may generate SIGFPE */ + *value = Perl_log((NV)-1.0); +# endif + return (char*)p; /* p, not endp */ +#endif + } + } + } +#endif /* #ifdef Perl_strtod */ + } + 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) { - NV result[3] = {0.0, 0.0, 0.0}; const char* s = orig; -#ifdef USE_PERL_ATOF - UV accumulator[2] = {0,0}; /* before/after dp */ + 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 */ bool negative = 0; - const char* send = s + strlen(orig) - 1; +#endif +#if defined(USE_PERL_ATOF) && !defined(USE_QUADMATH) + UV accumulator[2] = {0,0}; /* before/after dp */ bool seen_digit = 0; I32 exp_adjust[2] = {0,0}; I32 exp_acc[2] = {-1, -1}; @@ -896,9 +1369,39 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value) I32 digit = 0; I32 old_digit = 0; I32 sig_digits = 0; /* noof significant digits seen so far */ +#endif +#if defined(USE_PERL_ATOF) || defined(USE_QUADMATH) PERL_ARGS_ASSERT_MY_ATOF2; + /* leading whitespace */ + while (isSPACE(*s)) + ++s; + + /* sign */ + switch (*s) { + case '-': + negative = 1; + /* FALLTHROUGH */ + case '+': + ++s; + } +#endif + +#ifdef USE_QUADMATH + { + char* endp; + if ((endp = S_my_atof_infnan(aTHX_ s, negative, send, value))) + return endp; + result[2] = strtoflt128(s, &endp); + if (s != endp) { + *value = negative ? -result[2] : result[2]; + return endp; + } + return NULL; + } +#elif defined(USE_PERL_ATOF) + /* There is no point in processing more significant digits * than the NV can hold. Note that NV_DIG is a lower-bound value, * while we need an upper-bound value. We add 2 to account for this; @@ -928,31 +1431,11 @@ 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)) - /* leading whitespace */ - while (isSPACE(*s)) - ++s; - - /* sign */ - switch (*s) { - case '-': - negative = 1; - /* fall through */ - case '+': - ++s; - } - - /* punt to strtod for NaN/Inf; if no support for it there, tough luck */ - -#ifdef HAS_STRTOD - if (*s == 'n' || *s == 'N' || *s == 'i' || *s == 'I') { - const char *p = negative ? s - 1 : s; - char *endp; - NV rslt; - rslt = strtod(p, &endp); - if (endp != p) { - *value = rslt; - return (char *)endp; - } +#if defined(NV_INF) || defined(NV_NAN) + { + char* endp; + if ((endp = S_my_atof_infnan(aTHX_ s, negative, send, value))) + return endp; } #endif @@ -1011,9 +1494,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 (isDIGIT(*s)) { ++s; - } while (isDIGIT(*s)); + } break; } } @@ -1027,14 +1510,14 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value) result[1] = S_mulexp10(result[1], exp_acc[1]) + (NV)accumulator[1]; } - if (seen_digit && (*s == 'e' || *s == 'E')) { + if (seen_digit && (isALPHA_FOLD_EQ(*s, 'e'))) { bool expnegative = 0; ++s; switch (*s) { case '-': expnegative = 1; - /* fall through */ + /* FALLTHROUGH */ case '+': ++s; } @@ -1063,20 +1546,86 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value) return (char *)s; } -#if ! defined(HAS_MODFL) && defined(HAS_AINTL) && defined(HAS_COPYSIGNL) +/* +=for apidoc isinfnan + +C is 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(). + +=cut +*/ +bool +Perl_isinfnan(NV nv) +{ + PERL_UNUSED_ARG(nv); +#ifdef Perl_isinf + if (Perl_isinf(nv)) + return TRUE; +#endif +#ifdef Perl_isnan + if (Perl_isnan(nv)) + return TRUE; +#endif + return FALSE; +} + +/* +=for apidoc + +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 C already. + +=cut +*/ + +bool +Perl_isinfnansv(pTHX_ SV *sv) +{ + PERL_ARGS_ASSERT_ISINFNANSV; + if (!SvOK(sv)) + return FALSE; + if (SvNOKp(sv)) + return Perl_isinfnan(SvNVX(sv)); + if (SvIOKp(sv)) + return FALSE; + { + STRLEN len; + const char *s = SvPV_nomg_const(sv, len); + return cBOOL(grok_infnan(&s, s+len)); + } +} + +#ifndef HAS_MODFL +/* C99 has truncl, pre-C99 Solaris had aintl. We can use either with + * copysignl to emulate modfl, which is in some platforms missing or + * broken. */ +# if defined(HAS_TRUNCL) && defined(HAS_COPYSIGNL) long double Perl_my_modfl(long double x, long double *ip) { - *ip = aintl(x); - return (x == *ip ? copysignl(0.0L, x) : x - *ip); + *ip = truncl(x); + return (x == *ip ? copysignl(0.0L, x) : x - *ip); } +# elif defined(HAS_AINTL) && defined(HAS_COPYSIGNL) +long double +Perl_my_modfl(long double x, long double *ip) +{ + *ip = aintl(x); + return (x == *ip ? copysignl(0.0L, x) : x - *ip); +} +# endif #endif +/* Similarly, with ilogbl and scalbnl we can emulate frexpl. */ #if ! defined(HAS_FREXPL) && defined(HAS_ILOGBL) && defined(HAS_SCALBNL) long double Perl_my_frexpl(long double x, int *e) { - *e = x == 0.0L ? 0 : ilogbl(x) + 1; - return (scalbnl(x, -*e)); + *e = x == 0.0L ? 0 : ilogbl(x) + 1; + return (scalbnl(x, -*e)); } #endif @@ -1086,38 +1635,45 @@ Perl_my_frexpl(long double x, int *e) { Return a non-zero integer if the sign bit on an NV is set, and 0 if 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, -fall back on this implementation. As a first pass, this gets everything -right except -0.0. Alas, catching -0.0 is the main use for this function, -so this is not too helpful yet. Still, at least we have the scaffolding -in place to support other systems, should that prove useful. - +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 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 */ #if !defined(HAS_SIGNBIT) int Perl_signbit(NV x) { +# ifdef Perl_fp_class_nzero + 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: */