X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/87032ba1356fb03b9506881b2d4a3fca8143cce9..ec49eb61487587a42bcd56c4dcb46adecfe24bd4:/numeric.c diff --git a/numeric.c b/numeric.c index f12e9ba..34264f3 100644 --- a/numeric.c +++ b/numeric.c @@ -1,6 +1,7 @@ /* numeric.c * - * Copyright (c) 2001, Larry Wall + * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, + * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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. @@ -12,6 +13,16 @@ * wizards count differently to other people." */ +/* +=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" #define PERL_IN_NUMERIC_C #include "perl.h" @@ -19,6 +30,7 @@ U32 Perl_cast_ulong(pTHX_ NV f) { + PERL_UNUSED_CONTEXT; if (f < 0.0) return f < I32_MIN ? (U32) I32_MIN : (U32)(I32) f; if (f < U32_MAX_P1) { @@ -37,6 +49,7 @@ Perl_cast_ulong(pTHX_ NV f) I32 Perl_cast_i32(pTHX_ NV f) { + PERL_UNUSED_CONTEXT; if (f < I32_MAX_P1) return f < I32_MIN ? I32_MIN : (I32) f; if (f < U32_MAX_P1) { @@ -55,6 +68,7 @@ Perl_cast_i32(pTHX_ NV f) IV Perl_cast_iv(pTHX_ NV f) { + PERL_UNUSED_CONTEXT; if (f < IV_MAX_P1) return f < IV_MIN ? IV_MIN : (IV) f; if (f < UV_MAX_P1) { @@ -74,6 +88,7 @@ Perl_cast_iv(pTHX_ NV f) UV Perl_cast_uv(pTHX_ NV f) { + PERL_UNUSED_CONTEXT; if (f < 0.0) return f < IV_MIN ? (UV) IV_MIN : (UV)(IV) f; if (f < UV_MAX_P1) { @@ -89,230 +104,391 @@ 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. +=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. +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 <= 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 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 */ -NV -Perl_huge(void) -{ -# if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL) - return HUGE_VALL; -# endif - return HUGE_VAL; -} -#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; +UV +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; - 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; + const UV max_div_2 = UV_MAX / 2; + const bool allow_underscores = (bool)(*flags & PERL_SCAN_ALLOW_UNDERSCORES); + bool overflowed = FALSE; + char bit; + + 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-- && (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. + 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_ packWARN(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 + * represent a 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 (!(*flags & PERL_SCAN_SILENT_ILLDIGIT) && ckWARN(WARN_DIGIT)) + Perl_warner(aTHX_ packWARN(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, + Perl_warner(aTHX_ packWARN(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 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). + +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. + +=cut + */ + +UV +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; + const bool allow_underscores = (bool)(*flags & PERL_SCAN_ALLOW_UNDERSCORES); + bool overflowed = FALSE; + + 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')) + 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. + 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_ packWARN(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 a 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 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(PL_hexdigit, s[1]))) { --len; ++s; + goto redo; } - 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; - /* 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'); - } + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT) && ckWARN(WARN_DIGIT)) + Perl_warner(aTHX_ packWARN(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"); + Perl_warner(aTHX_ packWARN(WARN_PORTABLE), + "Hexadecimal number > 0xffffffff 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; } -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 + +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_ 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; + const bool allow_underscores = (bool)(*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]))) + /* 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_ packWARN(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 a 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 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; } - 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; - /* 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); - } + /* 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) { + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT) && ckWARN(WARN_DIGIT)) + Perl_warner(aTHX_ packWARN(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"); + Perl_warner(aTHX_ packWARN(WARN_PORTABLE), + "Octal number > 037777777777 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; +} + +/* +=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_ const char *start, STRLEN len, STRLEN *retlen) +{ + NV rnv; + I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0; + 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_ const char *start, STRLEN len, STRLEN *retlen) +{ + NV rnv; + I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0; + 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_ const char *start, STRLEN len, STRLEN *retlen) +{ + NV rnv; + I32 flags = *retlen ? PERL_SCAN_ALLOW_UNDERSCORES : 0; + const UV ruv = grok_hex (start, &len, &flags, &rnv); + + *retlen = len; + return (flags & PERL_SCAN_GREATER_THAN_UV_MAX) ? rnv : (NV)ruv; } /* @@ -326,9 +502,10 @@ bool Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send) { #ifdef USE_LOCALE_NUMERIC + dVAR; if (PL_numeric_radix_sv && IN_LOCALE) { STRLEN len; - char* radix = SvPV(PL_numeric_radix_sv, len); + const char * const radix = SvPV(PL_numeric_radix_sv, len); if (*sp + len <= send && memEQ(*sp, radix, len)) { *sp += len; return TRUE; @@ -371,7 +548,7 @@ int Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep) { const char *s = pv; - const char *send = pv + len; + const char * const send = pv + len; const UV max_div_10 = UV_MAX / 10; const char max_mod_10 = UV_MAX % 10; int numtype = 0; @@ -558,7 +735,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; @@ -568,30 +745,20 @@ S_mulexp10(NV value, I32 exponent) if (exponent == 0) return value; - else if (exponent < 0) { - negative = 1; - exponent = -exponent; - } + if (value == 0) + return (NV)0; - /* Avoid %SYSTEM-F-FLTOVF_F sans VAXC$ESTABLISH. - * In VAX VMS we by default use the D_FLOAT double format, + /* 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. Therefore we - * need to detect early whether we would overflow (this is - * the behaviour of the native string-to-float conversion routines, - * and therefore the behaviour of native applications, too.) + * 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] VAXC$EXTABLISH is the capability but it is basically a signal - * handler setup routine, and one cannot return from a fp exception - * handler and except much anything useful. */ -#if defined(VMS) && !defined(__IEEE_FP) -# if defined(__DECC_VER) && __DECC_VER <= 50390006 - /* __F_FLT_MAX_10_EXP - 5 == 33 */ - if (!negative && - (log10(value) + exponent) >= (__F_FLT_MAX_10_EXP - 5)) - return NV_MAX; -# endif -#endif + * [1] Trying to establish a condition handler to trap floating point + * exceptions is not a good idea. */ /* 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. @@ -600,18 +767,37 @@ S_mulexp10(NV value, I32 exponent) * 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; + +#if ((defined(VMS) && !defined(__IEEE_FP)) || defined(_UNICOS)) && 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) + return NV_MAX; + if (exponent < 0) { + if (-(exponent + exp_v) >= NV_MAX_10_EXP) + return 0.0; + while (-exponent >= NV_MAX_10_EXP) { + /* combination does not overflow, but 10^(-exponent) does */ + value /= 10; + ++exponent; + } + } + } STMT_END; #endif + if (exponent < 0) { + negative = 1; + exponent = -exponent; + } for (bit = 1; exponent; bit <<= 1) { if (exponent & bit) { exponent ^= bit; result *= power; + /* Floating point exceptions are supposed to be turned off, + * but if we're obviously done, don't risk another iteration. + */ + if (exponent == 0) break; } - /* Floating point exceptions are supposed to be turned off. */ power *= power; } return negative ? value / result : value * result; @@ -622,22 +808,23 @@ Perl_my_atof(pTHX_ const char* s) { NV x = 0.0; #ifdef USE_LOCALE_NUMERIC + dVAR; 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(aTHX_ s, &x); + Perl_atof2(s, x); SET_NUMERIC_STANDARD(); - Perl_atof2(aTHX_ s, &y); + Perl_atof2(s, y); SET_NUMERIC_LOCAL(); if ((y < 0.0 && y < x) || (y > 0.0 && y > x)) return y; } else - Perl_atof2(aTHX_ s, &x); + Perl_atof2(s, x); #else - Perl_atof2(aTHX_ s, &x); + Perl_atof2(s, x); #endif return x; } @@ -645,26 +832,43 @@ Perl_my_atof(pTHX_ const char* s) char* Perl_my_atof2(pTHX_ const char* orig, NV* value) { - NV result = 0.0; + 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 */ bool negative = 0; - char* s = (char*)orig; - char* send = s + strlen(orig) - 1; - bool seendigit = 0; - I32 expextra = 0; + const char* send = s + strlen(orig) - 1; + bool seen_digit = 0; + I32 exp_adjust[2] = {0,0}; + I32 exp_acc[2] = {-1, -1}; + /* the current exponent adjust for the accumulators */ I32 exponent = 0; - I32 i; -/* this is arbitrary */ -#define PARTLIM 6 -/* we want the largest integers we can usefully use */ -#if defined(HAS_QUAD) && defined(USE_64_BIT_INT) -# define PARTSIZE ((int)TYPE_DIGITS(U64)-1) - U64 part[PARTLIM]; -#else -# define PARTSIZE ((int)TYPE_DIGITS(U32)-1) - U32 part[PARTLIM]; -#endif - I32 ipart = 0; /* index into part[] */ - I32 offcount; /* number of digits in least significant part */ + I32 seen_dp = 0; + I32 digit = 0; + I32 old_digit = 0; + I32 sig_digits = 0; /* noof significant digits seen so far */ + +/* 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; + * since it will have been conservative on both the first and last digit. + * For example a 32-bit mantissa with an exponent of 4 would have + * exact values in the set + * 4 + * 8 + * .. + * 17179869172 + * 17179869176 + * 17179869180 + * + * where for the purposes of calculating NV_DIG we would have to discount + * 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) + +/* 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)) @@ -679,74 +883,93 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value) ++s; } - part[0] = offcount = 0; - if (isDIGIT(*s)) { - seendigit = 1; /* get this over with */ + /* punt to strtod for NaN/Inf; if no support for it there, tough luck */ - /* skip leading zeros */ - while (*s == '0') - ++s; +#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 - /* integer digits */ - while (isDIGIT(*s)) { - if (++offcount > PARTSIZE) { - if (++ipart < PARTLIM) { - part[ipart] = 0; - offcount = 1; /* ++0 */ - } - else { + /* 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'; + if (seen_dp) + exp_adjust[1]++; + + /* don't start counting until we see the first significant + * digit, eg the 5 in 0.00005... */ + if (!sig_digits && digit == 0) + continue; + + if (++sig_digits > MAX_SIG_DIGITS) { /* limits of precision reached */ - --ipart; - --offcount; - if (*s >= '5') - ++part[ipart]; + 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)) { - ++expextra; ++s; + if (! seen_dp) { + exp_adjust[0]++; + } } /* warn of loss of precision? */ - break; } - } - part[ipart] = part[ipart] * 10 + (*s++ - '0'); - } - - /* decimal point */ - if (GROK_NUMERIC_RADIX((const char **)&s, send)) { - if (isDIGIT(*s)) - seendigit = 1; /* get this over with */ - - /* decimal digits */ - while (isDIGIT(*s)) { - if (++offcount > PARTSIZE) { - if (++ipart < PARTLIM) { - part[ipart] = 0; - offcount = 1; /* ++0 */ - } - else { - /* limits of precision reached */ - --ipart; - --offcount; - if (*s >= '5') - ++part[ipart]; - while (isDIGIT(*s)) - ++s; - /* warn of loss of precision? */ - break; + else { + if (accumulator[seen_dp] > MAX_ACCUMULATE) { + /* add accumulator to result and start again */ + 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[seen_dp] = accumulator[seen_dp] * 10 + digit; + ++exp_acc[seen_dp]; + } + } + else if (!seen_dp && GROK_NUMERIC_RADIX(&s, send)) { + seen_dp = 1; + if (sig_digits > MAX_SIG_DIGITS) { + do { + ++s; + } while (isDIGIT(*s)); + break; } - --expextra; - part[ipart] = part[ipart] * 10 + (*s++ - '0'); + } + else { + break; } } - /* combine components of mantissa */ - for (i = 0; i <= ipart; ++i) - result += S_mulexp10((NV)part[ipart - i], - i ? offcount + (i - 1) * PARTSIZE : 0); + 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 (seendigit && (*s == 'e' || *s == 'E')) { + if (seen_digit && (*s == 'e' || *s == 'E')) { bool expnegative = 0; ++s; @@ -763,14 +986,80 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value) exponent = -exponent; } + + /* now apply the exponent */ - exponent += expextra; - 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; - *value = result; - return s; + result[2] = -result[2]; +#endif /* USE_PERL_ATOF */ + *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. 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. + + +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) { + return (x < 0.0) ? 1 : 0; } +#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: + */