X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/96a05aee450e24b2d5686c50a7e95ce03114af79..fb7a80d6959ce085b2bbdba270ba64e0a79ea6de:/numeric.c diff --git a/numeric.c b/numeric.c index 4363669..2e1e261 100644 --- a/numeric.c +++ b/numeric.c @@ -105,214 +105,369 @@ Perl_huge(void) } #endif -NV -Perl_scan_bin(pTHX_ char *start, STRLEN len, STRLEN *retlen) -{ - register char *s = start; - register NV rnv = 0.0; - register UV ruv = 0; - register bool seenb = FALSE; - register bool overflowed = FALSE; +/* +=for apidoc grok_bin + +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. + +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). + +The hex number may optinally 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 + */ + +UV +Perl_grok_bin(pTHX_ 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; + bool overflowed = FALSE; + + if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { + /* strip off leading b or 0b. + for compatibility silently suffer "b" and "0b" as valid binary + numbers. */ + if (len >= 1) { + if (s[0] == 'b') { + s++; + len--; + } + else if (len >= 2 && s[0] == '0' && s[1] == 'b') { + s+=2; + len-=2; + } + } + } for (; len-- && *s; s++) { - if (!(*s == '0' || *s == '1')) { - if (*s == '_' && len && *retlen - && (s[1] == '0' || s[1] == '1')) - { - --len; - ++s; - } - else if (seenb == FALSE && *s == 'b' && ruv == 0) { - /* Disallow 0bbb0b0bbb... */ - seenb = TRUE; - continue; - } - else { - if (ckWARN(WARN_DIGIT)) - Perl_warner(aTHX_ WARN_DIGIT, - "Illegal binary digit '%c' ignored", *s); - break; - } - } - if (!overflowed) { - register UV xuv = ruv << 1; - - if ((xuv >> 1) != ruv) { - overflowed = TRUE; - rnv = (NV) ruv; - if (ckWARN_d(WARN_OVERFLOW)) - Perl_warner(aTHX_ WARN_OVERFLOW, - "Integer overflow in binary number"); - } - else - ruv = xuv | (*s - '0'); - } - if (overflowed) { - rnv *= 2; + char bit = *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. + With gcc seems to be much straighter code than old scan_bin. */ + redo: + if (!overflowed) { + if (value <= max_div_2) { + value = (value << 1) | (bit - '0'); + continue; + } + /* Bah. We're just overflowed. */ + if (ckWARN_d(WARN_OVERFLOW)) + Perl_warner(aTHX_ WARN_OVERFLOW, + "Integer overflow in binary number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 2.0; /* If an NV has not enough bits in its mantissa to * represent an UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when - * did we overflow and in the end just multiply rnv by the + * did we overflow and in the end just multiply value_nv by the * right amount. */ - rnv += (*s - '0'); - } + value_nv += (NV)(bit - '0'); + continue; + } + if (bit == '_' && len && allow_underscores && (bit = s[1]) + && (bit == '0' || bit == '1')) + { + --len; + ++s; + goto redo; + } + if (ckWARN(WARN_DIGIT)) + Perl_warner(aTHX_ WARN_DIGIT, + "Illegal binary digit '%c' ignored", *s); + break; } - if (!overflowed) - rnv = (NV) ruv; - if ( ( overflowed && rnv > 4294967295.0) + + if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 - || (!overflowed && ruv > 0xffffffff ) + || (!overflowed && value > 0xffffffff ) #endif ) { if (ckWARN(WARN_PORTABLE)) Perl_warner(aTHX_ WARN_PORTABLE, "Binary number > 0b11111111111111111111111111111111 non-portable"); } - *retlen = s - start; - return rnv; + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; } -NV -Perl_scan_oct(pTHX_ char *start, STRLEN len, STRLEN *retlen) -{ - register char *s = start; - register NV rnv = 0.0; - register UV ruv = 0; - register bool overflowed = FALSE; +/* +=for apidoc grok_hex + +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. + +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). + +The hex number may optinally 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. + +=cut + */ + +UV +Perl_grok_hex(pTHX_ 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_16 = UV_MAX / 16; + 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. + for compatibility silently suffer "x" and "0x" as valid hex numbers. + */ + if (len >= 1) { + if (s[0] == 'x') { + s++; + len--; + } + else if (len >= 2 && s[0] == '0' && s[1] == 'x') { + s+=2; + len-=2; + } + } + } for (; len-- && *s; s++) { - if (!(*s >= '0' && *s <= '7')) { - if (*s == '_' && len && *retlen - && (s[1] >= '0' && s[1] <= '7')) - { - --len; - ++s; - } - else { - /* 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 (*s == '8' || *s == '9') { - if (ckWARN(WARN_DIGIT)) - Perl_warner(aTHX_ WARN_DIGIT, - "Illegal octal digit '%c' ignored", *s); - } - break; - } - } - if (!overflowed) { - register UV xuv = ruv << 3; - - if ((xuv >> 3) != ruv) { - overflowed = TRUE; - rnv = (NV) ruv; - if (ckWARN_d(WARN_OVERFLOW)) - Perl_warner(aTHX_ WARN_OVERFLOW, - "Integer overflow in octal number"); - } - else - ruv = xuv | (*s - '0'); - } - if (overflowed) { - rnv *= 8.0; + hexdigit = strchr((char *) 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. + 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); + continue; + } + /* Bah. We're just overflowed. */ + if (ckWARN_d(WARN_OVERFLOW)) + Perl_warner(aTHX_ WARN_OVERFLOW, + "Integer overflow in hexadecimal number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 16.0; /* If an NV has not enough bits in its mantissa to * represent an UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when - * did we overflow and in the end just multiply rnv by the - * right amount of 8-tuples. */ - rnv += (NV)(*s - '0'); - } + * 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); + continue; + } + if (*s == '_' && len && allow_underscores && s[1] + && (hexdigit = strchr((char *) PL_hexdigit, s[1]))) + { + --len; + ++s; + goto redo; + } + if (ckWARN(WARN_DIGIT)) + Perl_warner(aTHX_ WARN_DIGIT, + "Illegal hexadecimal digit '%c' ignored", *s); + break; } - if (!overflowed) - rnv = (NV) ruv; - if ( ( overflowed && rnv > 4294967295.0) + + if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 - || (!overflowed && ruv > 0xffffffff ) + || (!overflowed && value > 0xffffffff ) #endif ) { if (ckWARN(WARN_PORTABLE)) Perl_warner(aTHX_ WARN_PORTABLE, - "Octal number > 037777777777 non-portable"); + "Hexadecimal number > 0xffffffff non-portable"); } - *retlen = s - start; - return rnv; + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; } -NV -Perl_scan_hex(pTHX_ char *start, STRLEN len, STRLEN *retlen) -{ - register char *s = start; - register NV rnv = 0.0; - register UV ruv = 0; - register bool overflowed = FALSE; - char *hexdigit; - - if (len > 2) { - if (s[0] == 'x') { - s++; - len--; - } - else if (len > 3 && s[0] == '0' && s[1] == 'x') { - s+=2; - len-=2; - } - } +/* +=for apidoc grok_oct + + +=cut + */ + +UV +Perl_grok_oct(pTHX_ 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; + bool overflowed = FALSE; for (; len-- && *s; s++) { - hexdigit = strchr((char *) PL_hexdigit, *s); - if (!hexdigit) { - if (*s == '_' && len && *retlen && s[1] - && (hexdigit = strchr((char *) PL_hexdigit, s[1]))) - { - --len; - ++s; - } - else { - if (ckWARN(WARN_DIGIT)) - Perl_warner(aTHX_ WARN_DIGIT, - "Illegal hexadecimal digit '%c' ignored", *s); - break; - } - } - if (!overflowed) { - register UV xuv = ruv << 4; - - if ((xuv >> 4) != ruv) { - overflowed = TRUE; - rnv = (NV) ruv; - if (ckWARN_d(WARN_OVERFLOW)) - Perl_warner(aTHX_ WARN_OVERFLOW, - "Integer overflow in hexadecimal number"); - } - else - ruv = xuv | ((hexdigit - PL_hexdigit) & 15); - } - if (overflowed) { - rnv *= 16.0; + /* 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) { + /* 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; + continue; + } + /* Bah. We're just overflowed. */ + if (ckWARN_d(WARN_OVERFLOW)) + Perl_warner(aTHX_ WARN_OVERFLOW, + "Integer overflow in octal number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 8.0; /* If an NV has not enough bits in its mantissa to * represent an UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when - * did we overflow and in the end just multiply rnv by the - * right amount of 16-tuples. */ - rnv += (NV)((hexdigit - PL_hexdigit) & 15); - } + * did we overflow and in the end just multiply value_nv by the + * right amount of 8-tuples. */ + value_nv += (NV)digit; + continue; + } + if (digit == ('_' - '0') && len && allow_underscores + && (digit = s[1] - '0') && (digit >= 0 && digit <= 7)) + { + --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_ WARN_DIGIT, + "Illegal octal digit '%c' ignored", *s); + } + break; } - if (!overflowed) - rnv = (NV) ruv; - if ( ( overflowed && rnv > 4294967295.0) + + if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 - || (!overflowed && ruv > 0xffffffff ) + || (!overflowed && value > 0xffffffff ) #endif ) { if (ckWARN(WARN_PORTABLE)) Perl_warner(aTHX_ WARN_PORTABLE, - "Hexadecimal number > 0xffffffff non-portable"); + "Octal number > 037777777777 non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; } - *retlen = s - start; - return rnv; + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} + +/* +=for apidoc scan_bin + +For backwards compatibility. Use C instead. + +=for apidoc scan_hex + +For backwards compatibility. Use C instead. + +=for apidoc scan_oct + +For backwards compatibility. Use C instead. + +=cut + */ + +NV +Perl_scan_bin(pTHX_ char *start, STRLEN len, STRLEN *retlen) +{ + NV rnv; + I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0; + 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) +{ + NV rnv; + I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0; + 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) +{ + NV rnv; + I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0; + UV ruv = grok_hex (start, &len, &flags, &rnv); + + *retlen = len; + return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv; } /* @@ -350,7 +505,7 @@ Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send) 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 (defined in perl.h). +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 IS_NUMBER_IN_UV will be set to indicate that *valuep is valid, IS_NUMBER_IN_UV @@ -376,6 +531,7 @@ Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep) const char max_mod_10 = UV_MAX % 10; int numtype = 0; int sawinf = 0; + int sawnan = 0; while (s < send && isSPACE(*s)) s++; @@ -512,12 +668,21 @@ Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep) s++; } sawinf = 1; - } else /* Add test for NaN here. */ + } 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; 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) { /* we can have an optional exponent part */ if (*s == 'e' || *s == 'E') { @@ -539,7 +704,7 @@ Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep) while (s < send && isSPACE(*s)) s++; if (s >= send) - return numtype; + return numtype; if (len == 10 && memEQ(pv, "0 but true", 10)) { if (valuep) *valuep = 0; @@ -562,19 +727,43 @@ S_mulexp10(NV value, I32 exponent) negative = 1; exponent = -exponent; } -#ifdef __VAX /* avoid %SYSTEM-F-FLTOVF_F sans VAXC$ESTABLISH */ -# if defined(__DECC_VER) && __DECC_VER <= 50390006 - /* __F_FLT_MAX_10_EXP - 5 == 33 */ + + /* On OpenVMS VAX we by default use the D_FLOAT double format, + * and that format does not have *easy* capabilities [1] for + * overflowing doubles 'silently' as IEEE fp does. We also need + * to support G_FLOAT on both VAX and Alpha, and though the exponent + * range is much larger than D_FLOAT it still doesn't do silent + * overflow. Therefore we need to detect early whether we would + * overflow (this is the behaviour of the native string-to-float + * conversion routines, and therefore of native applications, too). + * + * [1] Trying to establish a condition handler to trap floating point + * exceptions is not a good idea. */ +#if defined(VMS) && !defined(__IEEE_FP) && defined(NV_MAX_10_EXP) if (!negative && - (log10(value) + exponent) >= (__F_FLT_MAX_10_EXP - 5)) + (log10(value) + exponent) >= (NV_MAX_10_EXP)) return NV_MAX; -# endif #endif + + /* In UNICOS and in certain Cray models (such as T90) there is no + * IEEE fp, and no way at all from C to catch fp overflows gracefully. + * There is something you can do if you are willing to use some + * inline assembler: the instruction is called DFI-- but that will + * disable *all* floating point interrupts, a little bit too large + * a hammer. Therefore we need to catch potential overflows before + * it's too late. */ +#if defined(_UNICOS) && defined(NV_MAX_10_EXP) + if (!negative && + (log10(value) + exponent) >= NV_MAX_10_EXP) + return NV_MAX; +#endif + for (bit = 1; exponent; bit <<= 1) { if (exponent & bit) { exponent ^= bit; result *= power; } + /* Floating point exceptions are supposed to be turned off. */ power *= power; } return negative ? value / result : value * result;