From: Allen Smith Date: Sat, 7 Sep 2002 05:25:45 +0000 (-0400) Subject: Re: [PATCH: perl #17849] (corrected) Long double bugs - sprintf.t _and_ num.t X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=20f6aaab8d64a33be1150bb7a380a1b5d03267cb;p=p5sagit%2Fp5-mst-13.2.git Re: [PATCH: perl #17849] (corrected) Long double bugs - sprintf.t _and_ num.t From: "Allen Smith" Message-Id: <10209070525.ZM1584639@puck2.rutgers.edu> p4raw-id: //depot/perl@17874 --- diff --git a/hints/irix_6.sh b/hints/irix_6.sh index a371d73..ef7c5a6 100644 --- a/hints/irix_6.sh +++ b/hints/irix_6.sh @@ -37,7 +37,7 @@ # If that fails, or you didn't use that, then try adjusting other # optimization options (-LNO, -INLINE, -O3 to -O2, etcetera). # The compiler bug has been reported to SGI. -# -- Allen Smith +# -- Allen Smith case "$use64bitall" in $define|true|[yY]*) @@ -90,8 +90,9 @@ case "$use64bitint" in esac cc=${cc:-cc} +cat=${cat:-cat} -cat > UU/cc.cbu <<'EOCCBU' +$cat > UU/cc.cbu <<'EOCCBU' # This script UU/cc.cbu will get 'called-back' by Configure after it # has prompted the user for the C compiler to use. @@ -141,7 +142,7 @@ esac' *"cc -64"*) case "`uname -s`" in IRIX) - cat >&4 <&4 < UU/usethreads.cbu <<'EOCBU' +$cat > UU/usethreads.cbu <<'EOCBU' # This script UU/usethreads.cbu will get 'called-back' by Configure # after it has prompted the user for whether to use threads. case "$usethreads" in @@ -448,7 +449,7 @@ EOCBU # The -n32 makes off_t to be 8 bytes, so we should have largefileness. -cat > UU/use64bitint.cbu <<'EOCBU' +$cat > UU/use64bitint.cbu <<'EOCBU' # This script UU/use64bitint.cbu will get 'called-back' by Configure # after it has prompted the user for whether to use 64 bit integers. @@ -471,7 +472,7 @@ esac EOCBU -cat > UU/use64bitall.cbu <<'EOCBU' +$cat > UU/use64bitall.cbu <<'EOCBU' # This script UU/use64bitall.cbu will get 'called-back' by Configure # after it has prompted the user for whether to be maximally 64 bitty. @@ -491,6 +492,123 @@ esac EOCBU +$cat > UU/uselongdouble.cbu <<'EOCBU' +# This script UU/uselongdouble.cbu will get 'called-back' by Configure +# after it has prompted the user for whether to use long doubles. + +# This script is designed to test IRIX (and other machines, once it's put into +# Configure) for a bug in which they fail to round correctly when using +# sprintf/printf/etcetera on a long double with precision specified (%.0Lf or +# whatever). Sometimes, this only happens when the number in question is +# between 1 and -1, weirdly enough. - Allen + +case "$uselongdouble" in +$define|true|[yY]*) + +case "$d_PRIfldbl" in +$define|true|[yY]*) + + echo " " >try.c + $cat >>try.c < + +#define sPRIfldbl $sPRIfldbl + +#define I_STDLIB $i_stdlib +#ifdef I_STDLIB +#include +#endif + +int main() +{ + char buf1[64]; + char buf2[64]; + buf1[63] = '\0'; + buf2[63] = '\0'; + + (void)sprintf(buf1,"%.0"sPRIfldbl,(long double)0.6L); + (void)sprintf(buf2,"%.0f",(double)0.6); + if (strcmp(buf1,buf2)) { + exit(1); + } + (void)sprintf(buf1,"%.0"sPRIfldbl,(long double)-0.6L); + (void)sprintf(buf2,"%.0f",(double)-0.6); + if (strcmp(buf1,buf2)) { + exit(1); + } else { + exit(0); + } +} + +EOP + + set try + if eval $compile && $run ./try; then + rm -f try try.* >/dev/null + else + rm -f try try.* core a.out >/dev/null + ccflags="$ccflags -DHAS_LDBL_SPRINTF_BUG" + cppflags="$cppflags -DHAS_LDBL_SPRINTF_BUG" + + echo " " >try.c + $cat >>try.c < + +#define sPRIfldbl $sPRIfldbl + +#define I_STDLIB $i_stdlib +#ifdef I_STDLIB +#include +#endif + +int main() +{ + char buf1[64]; + char buf2[64]; + buf1[63] = '\0'; + buf2[63] = '\0'; + + (void)sprintf(buf1,"%.0"sPRIfldbl,(long double)1.6L); + (void)sprintf(buf2,"%.0f",(double)1.6); + if (strcmp(buf1,buf2)) { + exit(1); + } + (void)sprintf(buf1,"%.0"sPRIfldbl,(long double)-1.6L); + (void)sprintf(buf2,"%.0f",(double)-1.6); + if (strcmp(buf1,buf2)) { + exit(1); + } else { + exit(0); + } +} + +EOP + + set try + if eval $compile && $run ./try; then + rm -f try try.c >/dev/null + ccflags="$ccflags -DHAS_LDBL_SPRINTF_BUG_LESS1" + cppflags="$cppflags -DHAS_LDBL_SPRINTF_BUG_LESS1" + else + rm -f try try.c core try.o a.out >/dev/null + fi + fi +;; +*) # Can't tell! + ccflags="$ccflags -DHAS_LDBL_SPRINTF_BUG" + cppflags="$cppflags -DHAS_LDBL_SPRINTF_BUG" + ;; +esac + +# end of case statement for how to print ldbl with 'f' +;; +*) ;; +esac + +# end of case statement for whether to do long doubles + +EOCBU + # Helmut Jarausch reports that Perl's malloc is rather unusable # with IRIX, and SGI confirms the problem. usemymalloc=${usemymalloc:-false} diff --git a/numeric.c b/numeric.c index 969901e..b472155 100644 --- a/numeric.c +++ b/numeric.c @@ -727,6 +727,8 @@ S_mulexp10(NV value, I32 exponent) if (exponent == 0) return value; + if (value == 0) + return 0; /* On OpenVMS VAX we by default use the D_FLOAT double format, * and that format does not have *easy* capabilities [1] for @@ -811,18 +813,20 @@ 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}; char* s = (char*)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; 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 */ /* There is no point in processing more significant digits @@ -866,8 +870,10 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value) 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,36 +882,59 @@ 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)) { seen_dp = 1; + if (sig_digits > MAX_SIG_DIGITS) { + ++s; + while (isDIGIT(*s)) { + ++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')) { bool expnegative = 0; @@ -924,15 +953,22 @@ 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; + *value = result[2]; return s; } diff --git a/perl.h b/perl.h index d1b369d..f37ec83 100644 --- a/perl.h +++ b/perl.h @@ -1186,6 +1186,27 @@ typedef UVTYPE UV; # endif #endif +/* + * This is for making sure we have a good DBL_MAX value, if possible, + * either for usage as NV_MAX or for usage in figuring out if we can + * fit a given long double into a double, if bug-fixing makes it + * necessary to do so. - Allen + */ + +#if defined(I_VALUES) +# if !defined(USE_LONG_DOUBLE) || defined(HAS_LDBL_SPRINTF_BUG) +# if (!defined(DBL_MIN) || !defined(DBL_MAX)) +# include +# if defined(MAXDOUBLE) && !defined(DBL_MAX) +# define DBL_MAX MAXDOUBLE +# endif +# if defined(MINDOUBLE) && !defined(DBL_MIN) +# define DBL_MIN MINDOUBLE +# endif +# endif +# endif +#endif + typedef NVTYPE NV; #ifdef I_IEEEFP @@ -1217,7 +1238,7 @@ typedef NVTYPE NV; # endif # ifdef LDBL_MAX # define NV_MAX LDBL_MAX -# define NV_MIN LDBL_MIN +/* Having LDBL_MAX doesn't necessarily mean that we have LDBL_MIN... -Allen */ # else # ifdef HUGE_VALL # define NV_MAX HUGE_VALL diff --git a/sv.c b/sv.c index 91b1926..aa50429 100644 --- a/sv.c +++ b/sv.c @@ -7941,6 +7941,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV bool has_precis = FALSE; STRLEN precis = 0; bool is_utf8 = FALSE; /* is this item utf8? */ +#ifdef HAS_LDBL_SPRINTF_BUG + /* This is to try to fix a bug with irix/nonstop-ux/powerux and + with sfio - Allen */ + bool fix_ldbl_sprintf_bug = FALSE; +#endif char esignbuf[4]; U8 utf8buf[UTF8_MAXLEN+1]; @@ -8529,9 +8534,92 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV need = BIT_DIGITS(i); } need += has_precis ? precis : 6; /* known default */ + if (need < width) need = width; +#ifdef HAS_LDBL_SPRINTF_BUG + /* This is to try to fix a bug with irix/nonstop-ux/powerux and + with sfio - Allen */ + if ((intsize == 'q') && (c == 'f') && +#ifdef HAS_LDBL_SPRINTF_BUG_LESS1 +/* Only happens between -1 and 1 ??? - Allen */ + ((nv < 1L) && (nv > -1L)) && +#endif + (need < DBL_DIG)) { /* it's going to be short enough that + long double precision is not needed */ + + if ((nv <= 0L) && (nv >= -0L)) { + fix_ldbl_sprintf_bug = TRUE; /* Easiest */ + } else { + /* SGI has fpclassl... but not with the same result values, + and it's via a typedef, so will need to redo Configure + to use. Not worth the trouble IMO. Also has fp_class_l, + BTW, via fp_class.h - Allen */ + + /* #if defined(HAS_FPCLASSL) && defined(USE_LONG_DOUBLE) */ + /* if (Perl_fp_class_zero((long double)nv)) { */ + /* fix_ldbl_sprintf_bug = TRUE; */ /* Easiest */ + /* } elsif (Perl_fp_class_norm((long double)nv)) { */ + /* #endif */ +#if !defined(DBL_MIN) || !defined(HAS_LDBL_SPRINTF_BUG_LESS1) +# ifdef DBL_MAX +# define MY_DBL_MAX DBL_MAX +# else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */ +# if DOUBLESIZE >= 8 +# define MY_DBL_MAX 1.7976931348623157E+308L +# else +# define MY_DBL_MAX 3.40282347E+38L +# endif +# endif +#endif /* !defined(DBL_MIN) || !defined(HAS_LDBL_SPRINTF_BUG_LESS1 */ + +#ifndef HAS_LDBL_SPRINTF_BUG_LESS1 + if ((nv < MY_DBL_MAX) && (nv > -MY_DBL_MAX)) { +#endif + +#ifdef DBL_MIN +# define MY_DBL_MIN DBL_MIN +#else /* XXX guessing! -Allen */ +# if DOUBLESIZE >= 8 +# define MY_DBL_MIN 2.2250738585072014E-308L +# else +# define MY_DBL_MIN 1.17549435E-38L +# endif +#endif + if (((nv > 0L) && (nv >= MY_DBL_MIN) +#ifndef DBL_MIN + && ((long double)1/MY_DBL_MAX <= nv) +#endif + ) || ((nv < -0L) && (nv <= -MY_DBL_MIN) +#ifndef DBL_MIN + && (-(long double)1/MY_DBL_MAX >= nv) +#endif + )) { + /* It's within the range that a double can represent */ + fix_ldbl_sprintf_bug = TRUE; + } +#undef MY_DBL_MIN +#ifndef HAS_LDBL_SPRINTF_BUG_LESS1 + } +#endif +#if !defined(DBL_MIN) || !defined(HAS_LDBL_SPRINTF_BUG_LESS1) +# undef MY_DBL_MAX +#endif +/* #if defined(HAS_FPCLASSL) && defined(USE_LONG_DOUBLE) */ +/* } */ +/* #endif */ + } + if (fix_ldbl_sprintf_bug == TRUE) { + double temp; + + intsize = 0; + temp = (double)nv; + nv = (NV)temp; + } + } +#endif /* HAS_LDBL_SPRINTF_BUG */ + need += 20; /* fudge factor */ if (PL_efloatsize < need) { Safefree(PL_efloatbuf); diff --git a/t/base/num.t b/t/base/num.t index 714881e..6a93355 100644 --- a/t/base/num.t +++ b/t/base/num.t @@ -1,6 +1,6 @@ #!./perl -print "1..49\n"; +print "1..50\n"; # First test whether the number stringification works okay. # (Testing with == would exercize the IV/NV part, not the PV.) @@ -179,3 +179,9 @@ print $a == 80000.0 ? "ok 48\n" : "not ok 48\n"; $a = 1.0000000000000000000000000000000000000000000000000000000000000000000e1; print $a == 10.0 ? "ok 49\n" : "not ok 49\n"; + +# From Math/Trig - number has to be long enough to exceed at least DBL_DIG + +$a = 57.295779513082320876798154814169; +print ok($a*10,572.95779513082320876798154814169,1e-10) ? "ok 50\n" : + "not ok 50 # $a\n"; diff --git a/t/op/sprintf.t b/t/op/sprintf.t index c67e65e..b23978c 100755 --- a/t/op/sprintf.t +++ b/t/op/sprintf.t @@ -236,6 +236,8 @@ __END__ >%#e< >-1234.875< >-1.234875e+03< >%.0e< >1234.875< >1e+03< >%#.0e< >1234.875< >1.e+03< +>%.0e< >1.875< >2e+00< +>%.0e< >0.875< >9e-01< >%.*e< >[0, 1234.875]< >1e+03< >%.1e< >1234.875< >1.2e+03< >%-12.4e< >1234.875< >1.2349e+03 < @@ -265,8 +267,10 @@ __END__ >%.0f< >0< >0< >%.0f< >2**38< >274877906944< >Should have exact int'l rep'n< >%.0f< >0.1< >0< ->%.0f< >0.6< >1< >Known to fail with sfio and (irix|nonstop-ux|powerux)< ->%.0f< >-0.6< >-1< >Known to fail with sfio and (irix|nonstop-ux|powerux)< +>%.0f< >0.6< >1< >Known to fail with sfio, (irix|nonstop-ux|powerux); -DHAS_LDBL_SPRINTF_BUG may fix< +>%.0f< >-0.6< >-1< >Known to fail with sfio, (irix|nonstop-ux|powerux); -DHAS_LDBL_SPRINTF_BUG may fix< +>%.0f< >1.6< >2< +>%.0f< >-1.6< >-2< >%.0f< >1< >1< >%#.0f< >1< >1.< >%g< >12345.6789< >12345.7<