X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/8194bf885900463241631dc78b51b65378478827..8b57a5fa267949bb7bbe46ef30cee23c88855487:/numeric.c diff --git a/numeric.c b/numeric.c index 969901e..355980a 100644 --- a/numeric.c +++ b/numeric.c @@ -1,6 +1,7 @@ /* numeric.c * - * Copyright (c) 2001-2002, Larry Wall + * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, + * 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -8,12 +9,20 @@ */ /* - * "That only makes eleven (plus one mislaid) and not fourteen, unless - * wizards count differently to other people." + * "That only makes eleven (plus one mislaid) and not fourteen, + * unless wizards count differently to other people." --Beorn + * + * [p.115 of _The Hobbit_: "Queer Lodgings"] */ /* =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 + */ #include "EXTERN.h" @@ -21,7 +30,7 @@ #include "perl.h" U32 -Perl_cast_ulong(pTHX_ NV f) +Perl_cast_ulong(NV f) { if (f < 0.0) return f < I32_MIN ? (U32) I32_MIN : (U32)(I32) f; @@ -39,7 +48,7 @@ Perl_cast_ulong(pTHX_ NV f) } I32 -Perl_cast_i32(pTHX_ NV f) +Perl_cast_i32(NV f) { if (f < I32_MAX_P1) return f < I32_MIN ? I32_MIN : (I32) f; @@ -57,7 +66,7 @@ Perl_cast_i32(pTHX_ NV f) } IV -Perl_cast_iv(pTHX_ NV f) +Perl_cast_iv(NV f) { if (f < IV_MAX_P1) return f < IV_MIN ? IV_MIN : (IV) f; @@ -76,7 +85,7 @@ Perl_cast_iv(pTHX_ NV f) } UV -Perl_cast_uv(pTHX_ NV f) +Perl_cast_uv(NV f) { if (f < 0.0) return f < IV_MIN ? (UV) IV_MIN : (UV)(IV) f; @@ -93,22 +102,6 @@ Perl_cast_uv(pTHX_ NV f) return f > 0 ? UV_MAX : 0 /* NaN */; } -#if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)) -/* - * This hack is to force load of "huge" support from libm.a - * So it is in perl for (say) POSIX to use. - * Needed for SunOS with Sun's 'acc' for example. - */ -NV -Perl_huge(void) -{ -# if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL) - return HUGE_VALL; -# endif - return HUGE_VAL; -} -#endif - /* =for apidoc grok_bin @@ -117,52 +110,61 @@ 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. -On return I<*len> is set to the length scanned string, and I<*flags> gives -output flags. +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 +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). -The hex number may optionally be prefixed with "0b" or "b" unless -C is set in I<*flags> on entry. If +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. =cut + +Not documented yet because experimental is C= 1) { - if (s[0] == 'b') { + if (isALPHA_FOLD_EQ(s[0], 'b')) { s++; len--; } - else if (len >= 2 && s[0] == '0' && s[1] == 'b') { + else if (len >= 2 && s[0] == '0' && (isALPHA_FOLD_EQ(s[1], 'b'))) { s+=2; len-=2; } } } - for (; len-- && *s; s++) { - char bit = *s; + 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. @@ -174,9 +176,9 @@ Perl_grok_bin(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) { continue; } /* Bah. We're just overflowed. */ - if (ckWARN_d(WARN_OVERFLOW)) - Perl_warner(aTHX_ packWARN(WARN_OVERFLOW), - "Integer overflow in binary number"); + /* 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; } @@ -197,20 +199,20 @@ Perl_grok_bin(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) { ++s; goto redo; } - if (ckWARN(WARN_DIGIT)) - Perl_warner(aTHX_ packWARN(WARN_DIGIT), - "Illegal binary digit '%c' ignored", *s); + 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 ) + || (!overflowed && value > 0xffffffff + && ! (*flags & PERL_SCAN_SILENT_NON_PORTABLE)) #endif ) { - if (ckWARN(WARN_PORTABLE)) - Perl_warner(aTHX_ packWARN(WARN_PORTABLE), - "Binary number > 0b11111111111111111111111111111111 non-portable"); + Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), + "Binary number > 0b11111111111111111111111111111111 non-portable"); } *len_p = s - start; if (!overflowed) { @@ -228,48 +230,55 @@ Perl_grok_bin(pTHX_ 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 +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 non-hex-digit character. -On return I<*len> is set to the length scanned string, and I<*flags> gives -output flags. +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 +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> on entry. If C is set in I<*flags> then the hex number may use '_' characters to separate digits. =cut + +Not documented yet because experimental is C= 1) { - if (s[0] == 'x') { + if (isALPHA_FOLD_EQ(s[0], 'x')) { s++; len--; } - else if (len >= 2 && s[0] == '0' && s[1] == 'x') { + else if (len >= 2 && s[0] == '0' && (isALPHA_FOLD_EQ(s[1], 'x'))) { s+=2; len-=2; } @@ -277,21 +286,20 @@ Perl_grok_hex(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) { } for (; len-- && *s; s++) { - hexdigit = strchr((char *) 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. */ - if (ckWARN_d(WARN_OVERFLOW)) - Perl_warner(aTHX_ packWARN(WARN_OVERFLOW), - "Integer overflow in hexadecimal number"); + /* 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; } @@ -302,30 +310,30 @@ Perl_grok_hex(pTHX_ 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((char *) PL_hexdigit, s[1]))) + && isXDIGIT(s[1])) { --len; ++s; goto redo; } - if (ckWARN(WARN_DIGIT)) - Perl_warner(aTHX_ packWARN(WARN_DIGIT), + 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 ) + || (!overflowed && value > 0xffffffff + && ! (*flags & PERL_SCAN_SILENT_NON_PORTABLE)) #endif ) { - if (ckWARN(WARN_PORTABLE)) - Perl_warner(aTHX_ packWARN(WARN_PORTABLE), - "Hexadecimal number > 0xffffffff non-portable"); + Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), + "Hexadecimal number > 0xffffffff non-portable"); } *len_p = s - start; if (!overflowed) { @@ -341,39 +349,60 @@ Perl_grok_hex(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) { /* =for apidoc grok_oct +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. + +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 C is set in I<*flags> then the octal +number may use '_' characters to separate digits. =cut + +Not documented yet because experimental is C +which suppresses any message for non-portable numbers, but which are valid +on this platform. */ UV -Perl_grok_oct(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) { +Perl_grok_oct(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_8 = UV_MAX / 8; - bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + const bool allow_underscores = cBOOL(*flags & PERL_SCAN_ALLOW_UNDERSCORES); bool overflowed = FALSE; + 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. */ - if (ckWARN_d(WARN_OVERFLOW)) - Perl_warner(aTHX_ packWARN(WARN_OVERFLOW), - "Integer overflow in octal number"); + /* diag_listed_as: Integer overflow in %s number */ + Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW), + "Integer overflow in octal number"); overflowed = TRUE; value_nv = (NV) value; } @@ -384,35 +413,34 @@ Perl_grok_oct(pTHX_ 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 iff - * someone seems to want to use the digits eight and nine). */ - if (digit == 8 || digit == 9) { - if (ckWARN(WARN_DIGIT)) - Perl_warner(aTHX_ packWARN(WARN_DIGIT), - "Illegal octal digit '%c' ignored", *s); + * 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); } break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 - || (!overflowed && value > 0xffffffff ) + || (!overflowed && value > 0xffffffff + && ! (*flags & PERL_SCAN_SILENT_NON_PORTABLE)) #endif ) { - if (ckWARN(WARN_PORTABLE)) - Perl_warner(aTHX_ packWARN(WARN_PORTABLE), - "Octal number > 037777777777 non-portable"); + Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), + "Octal number > 037777777777 non-portable"); } *len_p = s - start; if (!overflowed) { @@ -428,47 +456,53 @@ Perl_grok_oct(pTHX_ 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 */ NV -Perl_scan_bin(pTHX_ char *start, STRLEN len, STRLEN *retlen) +Perl_scan_bin(pTHX_ const char *start, STRLEN len, STRLEN *retlen) { NV rnv; I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0; - UV ruv = grok_bin (start, &len, &flags, &rnv); + const UV ruv = grok_bin (start, &len, &flags, &rnv); + + PERL_ARGS_ASSERT_SCAN_BIN; *retlen = len; return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv; } NV -Perl_scan_oct(pTHX_ char *start, STRLEN len, STRLEN *retlen) +Perl_scan_oct(pTHX_ const char *start, STRLEN len, STRLEN *retlen) { NV rnv; I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0; - UV ruv = grok_oct (start, &len, &flags, &rnv); + 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_ char *start, STRLEN len, STRLEN *retlen) +Perl_scan_hex(pTHX_ const char *start, STRLEN len, STRLEN *retlen) { NV rnv; I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0; - UV ruv = grok_hex (start, &len, &flags, &rnv); + 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; @@ -485,17 +519,27 @@ bool Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send) { #ifdef USE_LOCALE_NUMERIC - if (PL_numeric_radix_sv && IN_LOCALE) { - STRLEN len; - char* radix = SvPV(PL_numeric_radix_sv, len); - if (*sp + len <= send && memEQ(*sp, radix, len)) { - *sp += len; - return TRUE; + 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; @@ -504,14 +548,14 @@ Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send) } /* -=for apidoc grok_number +=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 an in UV, it is returned in the *valuep +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. @@ -524,18 +568,144 @@ 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 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 grok_number_flags() with flags 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); +} + +/* +=for apidoc grok_infnan + +Helper for grok_number(), 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 + +If an infinity or not-a-number is recognized, the *sp will point to +one past the end of the recognized string. If the recognition fails, +zero is returned, and the *sp will not move. + +=cut +*/ + +int +Perl_grok_infnan(const char** sp, const char* send) +{ + const char* s = *sp; + int flags = 0; + + 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) */ + 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; + } + + 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'))) { + s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return 0; + s++; if (s == send || isALPHA_FOLD_NE(*s, 'I')) return 0; + s++; if (s == send || isALPHA_FOLD_NE(*s, 'T')) return 0; + s++; if (s == send || + /* allow either Infinity or Infinite */ + (isALPHA_FOLD_NE(*s, 'Y') && + isALPHA_FOLD_NE(*s, 'E'))) + return 0; + s++; + } else if (*s) + return 0; + flags |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; + } + else if (isALPHA_FOLD_EQ(*s, 'D')) { + s++; + flags |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; + } else + return 0; + + *sp = s; + return flags; + } + else { + /* NAN */ + 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 implementations just + * have weird stuff like NaN%. */ + s = send; + } + else + return 0; + + *sp = s; + return flags; + } + + return 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 *send = pv + len; - const UV max_div_10 = UV_MAX / 10; - const char max_mod_10 = UV_MAX % 10; + const char * const send = pv + len; + const char *d; int numtype = 0; - int sawinf = 0; - int sawnan = 0; + + PERL_ARGS_ASSERT_GROK_NUMBER_FLAGS; while (s < send && isSPACE(*s)) s++; @@ -546,12 +716,16 @@ Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep) numtype = IS_NUMBER_NEG; } else if (*s == '+') - s++; + s++; 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. */ @@ -598,9 +772,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'; @@ -660,39 +834,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 < 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++; @@ -701,8 +848,14 @@ 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)) @@ -714,10 +867,111 @@ Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *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". */ + int infnan = Perl_grok_infnan(&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; } -NV +/* +=for apidoc grok_atou + +grok_atou is a safer replacement for atoi and strtol. + +grok_atou 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_atou does NOT allow optional +leading whitespace, or negative inputs. If such features are +required, the calling code needs to explicitly implement those. + +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). + +Note that extraneous leading zeros also count as an overflow +(meaning that only "0" is the zero). + +On failure, the *endptr is also set to NULL, unless endptr is NULL. + +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 +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). + +=cut +*/ + +UV +Perl_grok_atou(const char *pv, 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; + } + } + } + } + if (s == pv) { + *eptr = NULL; /* If no progress, failed to parse anything. */ + return 0; + } + if (endptr == NULL && *s) { + return 0; /* If endptr is NULL, no trailing non-digits allowed. */ + } + *eptr = s; + return val; +} + +STATIC NV S_mulexp10(NV value, I32 exponent) { NV result = 1.0; @@ -727,6 +981,8 @@ S_mulexp10(NV value, I32 exponent) if (exponent == 0) return value; + 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 @@ -748,9 +1004,9 @@ 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(NV_MAX_10_EXP) STMT_START { - NV exp_v = log10(value); + const NV exp_v = log10(value); if (exponent >= NV_MAX_10_EXP || exponent + exp_v >= NV_MAX_10_EXP) return NV_MAX; if (exponent < 0) { @@ -768,6 +1024,17 @@ 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; + } +#endif } for (bit = 1; exponent; bit <<= 1) { if (exponent & bit) { @@ -788,20 +1055,38 @@ Perl_my_atof(pTHX_ const char* s) { NV x = 0.0; #ifdef USE_LOCALE_NUMERIC - if (PL_numeric_local && IN_LOCALE) { - NV y; - - /* Scan the number twice; once using locale and once without; - * choose the larger result (in absolute value). */ - Perl_atof2(s, x); - SET_NUMERIC_STANDARD(); - Perl_atof2(s, y); - SET_NUMERIC_LOCAL(); - if ((y < 0.0 && y < x) || (y > 0.0 && y > x)) - return y; + PERL_ARGS_ASSERT_MY_ATOF; + + { + 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; + + /* 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)); + + use_standard_radix = standard && (!local || standard < local); + + if (use_standard_radix) + SET_NUMERIC_STANDARD(); + + Perl_atof2(s, x); + + if (use_standard_radix) + SET_NUMERIC_LOCAL(); + } + else + Perl_atof2(s, x); + RESTORE_LC_NUMERIC(); } - else - Perl_atof2(s, x); #else Perl_atof2(s, x); #endif @@ -811,20 +1096,24 @@ Perl_my_atof(pTHX_ const char* s) char* Perl_my_atof2(pTHX_ const char* orig, NV* value) { - NV result = 0.0; - char* s = (char*)orig; + NV result[3] = {0.0, 0.0, 0.0}; + const char* s = orig; #ifdef USE_PERL_ATOF - UV accumulator = 0; + UV accumulator[2] = {0,0}; /* before/after dp */ bool negative = 0; - char* send = s + strlen(orig) - 1; + const char* send = s + strlen(orig); /* one past the last */ bool seen_digit = 0; - I32 exp_adjust = 0; - I32 exp_acc = 0; /* the current exponent adjust for the accumulator */ + I32 exp_adjust[2] = {0,0}; + I32 exp_acc[2] = {-1, -1}; + /* the current exponent adjust for the accumulators */ I32 exponent = 0; I32 seen_dp = 0; - I32 digit; + I32 digit = 0; + I32 old_digit = 0; I32 sig_digits = 0; /* noof significant digits seen so far */ + PERL_ARGS_ASSERT_MY_ATOF2; + /* 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; @@ -842,7 +1131,14 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value) * both the first and last digit, since neither can hold all values from * 0..9; but for calculating the value we must examine those two digits. */ -#define MAX_SIG_DIGITS (NV_DIG+2) +#ifdef MAX_SIG_DIG_PLUS + /* It is not necessarily the case that adding 2 to NV_DIG gets all the + possible digits in a NV, especially if NVs are not IEEE compliant + (e.g., long doubles on IRIX) - Allen */ +# define MAX_SIG_DIGITS (NV_DIG+MAX_SIG_DIG_PLUS) +#else +# define MAX_SIG_DIGITS (NV_DIG+2) +#endif /* the max number we can accumulate in a UV, and still safely do 10*N+9 */ #define MAX_ACCUMULATE ( (UV) ((UV_MAX - 9)/10)) @@ -855,19 +1151,88 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value) switch (*s) { case '-': negative = 1; - /* fall through */ + /* FALLTHROUGH */ case '+': ++s; } + { + const char *p0 = negative ? s - 1 : s; + const char *p = p0; + 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 INV_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; + if ((infnan & IS_NUMBER_INFINITY)) { + fake = ((infnan & IS_NUMBER_NEG)) ? "-inf" : "inf"; + } + else if ((infnan & IS_NUMBER_NAN)) { + fake = "nan"; + } + assert(fake); + nv = Perl_strtod(fake, &endp); + if (fake != endp) { + 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 */ + } + else 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 /* #ifdef Perl_strtod */ + } + } + /* we accumulate digits into an integer; when this becomes too * large, we add the total to NV and start again */ while (1) { if (isDIGIT(*s)) { seen_digit = 1; + old_digit = digit; digit = *s++ - '0'; - exp_adjust -= seen_dp; + if (seen_dp) + exp_adjust[1]++; /* don't start counting until we see the first significant * digit, eg the 5 in 0.00005... */ @@ -876,45 +1241,67 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value) if (++sig_digits > MAX_SIG_DIGITS) { /* limits of precision reached */ - if (digit >= 5) - ++accumulator; - ++exp_adjust; + if (digit > 5) { + ++accumulator[seen_dp]; + } else if (digit == 5) { + if (old_digit % 2) { /* round to even - Allen */ + ++accumulator[seen_dp]; + } + } + if (seen_dp) { + exp_adjust[1]--; + } else { + exp_adjust[0]++; + } /* skip remaining digits */ while (isDIGIT(*s)) { ++s; - exp_adjust += 1 - seen_dp; + if (! seen_dp) { + exp_adjust[0]++; + } } /* warn of loss of precision? */ } else { - if (accumulator > MAX_ACCUMULATE) { + if (accumulator[seen_dp] > MAX_ACCUMULATE) { /* add accumulator to result and start again */ - result = S_mulexp10(result, exp_acc) + (NV)accumulator; - accumulator = 0; - exp_acc = 0; + result[seen_dp] = S_mulexp10(result[seen_dp], + exp_acc[seen_dp]) + + (NV)accumulator[seen_dp]; + accumulator[seen_dp] = 0; + exp_acc[seen_dp] = 0; } - accumulator = accumulator * 10 + digit; - ++exp_acc; + accumulator[seen_dp] = accumulator[seen_dp] * 10 + digit; + ++exp_acc[seen_dp]; } } - else if (!seen_dp && GROK_NUMERIC_RADIX((const char **)&s, send)) { + else if (!seen_dp && GROK_NUMERIC_RADIX(&s, send)) { seen_dp = 1; + if (sig_digits > MAX_SIG_DIGITS) { + do { + ++s; + } while (isDIGIT(*s)); + break; + } } else { break; } } - result = S_mulexp10(result, exp_acc) + (NV)accumulator; + result[0] = S_mulexp10(result[0], exp_acc[0]) + (NV)accumulator[0]; + if (seen_dp) { + 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; } @@ -924,15 +1311,81 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value) exponent = -exponent; } + + /* now apply the exponent */ - exponent += exp_adjust; - result = S_mulexp10(result, exponent); + + if (seen_dp) { + result[2] = S_mulexp10(result[0],exponent+exp_adjust[0]) + + S_mulexp10(result[1],exponent-exp_adjust[1]); + } else { + result[2] = S_mulexp10(result[0],exponent+exp_adjust[0]); + } /* now apply the sign */ if (negative) - result = -result; + result[2] = -result[2]; #endif /* USE_PERL_ATOF */ - *value = result; - return s; + *value = result[2]; + return (char *)s; +} + +#if ! defined(HAS_MODFL) && 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 + +#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)); +} +#endif + +/* +=for apidoc Perl_signbit +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. The main use of this function +is catching -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() +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 +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(). + +=cut +*/ +#if !defined(HAS_SIGNBIT) +int +Perl_signbit(NV x) { +# ifdef Perl_fp_class_nzero + if (x == 0) + return Perl_fp_class_nzero(x); +# endif + return (x < 0.0) ? 1 : 0; +} +#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: + */