X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/3f774658ecc4b04691265c9db31d70a4a611b290..728f4ecd5858cf42b7be7efeced98ccdc4ba54ee:/numeric.c?ds=sidebyside diff --git a/numeric.c b/numeric.c index b472155..2970dad 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, 2005 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. @@ -14,6 +15,12 @@ /* =head1 Numeric functions + +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" @@ -117,16 +124,18 @@ 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, +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 +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. @@ -135,15 +144,16 @@ number may use '_' characters to separate digits. */ UV -Perl_grok_bin(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) { +Perl_grok_bin(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_2 = UV_MAX / 2; - bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + const bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; + char bit; if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { /* strip off leading b or 0b. @@ -161,8 +171,7 @@ Perl_grok_bin(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) { } } - 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. @@ -197,7 +206,7 @@ Perl_grok_bin(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) { ++s; goto redo; } - if (ckWARN(WARN_DIGIT)) + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT) && ckWARN(WARN_DIGIT)) Perl_warner(aTHX_ packWARN(WARN_DIGIT), "Illegal binary digit '%c' ignored", *s); break; @@ -230,9 +239,11 @@ 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. -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 @@ -249,16 +260,16 @@ number may use '_' characters to separate digits. */ UV -Perl_grok_hex(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) { +Perl_grok_hex(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { + dVAR; const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_16 = UV_MAX / 16; - bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + const bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; - const char *hexdigit; if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { /* strip off leading x or 0x. @@ -277,7 +288,7 @@ Perl_grok_hex(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) { } for (; len-- && *s; s++) { - hexdigit = strchr((char *) PL_hexdigit, *s); + const char *hexdigit = strchr(PL_hexdigit, *s); if (hexdigit) { /* 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. @@ -306,13 +317,13 @@ Perl_grok_hex(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) { continue; } if (*s == '_' && len && allow_underscores && s[1] - && (hexdigit = strchr((char *) PL_hexdigit, s[1]))) + && (hexdigit = strchr(PL_hexdigit, s[1]))) { --len; ++s; goto redo; } - if (ckWARN(WARN_DIGIT)) + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT) && ckWARN(WARN_DIGIT)) Perl_warner(aTHX_ packWARN(WARN_DIGIT), "Illegal hexadecimal digit '%c' ignored", *s); break; @@ -341,19 +352,37 @@ 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 +invalid character will also trigger a warning. +On return I<*len> is set to the length of the scanned string, +and I<*flags> gives output flags. + +If the value is <= UV_MAX it is returned as a UV, the output flags are clear, +and nothing is written to I<*result>. If the value is > UV_MAX C +returns UV_MAX, sets C in the output flags, +and writes the value to I<*result> (or the value is discarded if I +is NULL). + +If C is set in I<*flags> then the octal +number may use '_' characters to separate digits. =cut */ 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 = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; for (; len-- && *s; s++) { @@ -395,10 +424,10 @@ Perl_grok_oct(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) { goto redo; } /* Allow \octal to work the DWIM way (that is, stop scanning - * as soon as non-octal characters are seen, complain only iff + * 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) { - if (ckWARN(WARN_DIGIT)) + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT) && ckWARN(WARN_DIGIT)) Perl_warner(aTHX_ packWARN(WARN_DIGIT), "Illegal octal digit '%c' ignored", *s); } @@ -442,33 +471,33 @@ For backwards compatibility. Use C instead. */ 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); *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); *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); *retlen = len; return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv; @@ -487,7 +516,7 @@ 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); + const char* radix = SvPV(PL_numeric_radix_sv, len); if (*sp + len <= send && memEQ(*sp, radix, len)) { *sp += len; return TRUE; @@ -717,7 +746,7 @@ Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep) return 0; } -NV +STATIC NV S_mulexp10(NV value, I32 exponent) { NV result = 1.0; @@ -728,7 +757,7 @@ S_mulexp10(NV value, I32 exponent) if (exponent == 0) return value; if (value == 0) - return 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 @@ -814,11 +843,11 @@ char* Perl_my_atof2(pTHX_ const char* orig, NV* value) { NV result[3] = {0.0, 0.0, 0.0}; - char* s = (char*)orig; + const char* s = orig; #ifdef USE_PERL_ATOF UV accumulator[2] = {0,0}; /* before/after dp */ bool negative = 0; - char* send = s + strlen(orig) - 1; + const char* send = s + strlen(orig) - 1; bool seen_digit = 0; I32 exp_adjust[2] = {0,0}; I32 exp_acc[2] = {-1, -1}; @@ -864,6 +893,21 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value) ++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; + } + } +#endif + /* we accumulate digits into an integer; when this becomes too * large, we add the total to NV and start again */ @@ -916,7 +960,7 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value) ++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) { ++s; @@ -969,6 +1013,32 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value) result[2] = -result[2]; #endif /* USE_PERL_ATOF */ *value = result[2]; - return s; + 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 +/* + * Local variables: + * c-indentation-style: bsd + * c-basic-offset: 4 + * indent-tabs-mode: t + * End: + * + * ex: set ts=8 sts=4 sw=4 noet: + */