From: François-Xavier Coudert Date: Sat, 11 Oct 2014 16:57:32 +0000 (+0000) Subject: re PR fortran/48979 (FRACTION und EXPONENT return invalid results for infinity/NaN) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=d2af8cc6f1463ea098b2d9fbac82f0f3c85b8e7b;p=gcc.git re PR fortran/48979 (FRACTION und EXPONENT return invalid results for infinity/NaN) PR fortran/48979 * simplify.c (gfc_simplify_atan): Use mpfr_zero_p to check for zeros. (gfc_simplify_log): Likewise. (gfc_simplify_scale): Likewise. (gfc_simplify_exponent): Handle infinities and NaNs. (gfc_simplify_fraction): Handle infinities. (gfc_simplify_rrspacing): Handle signed zeros and NaNs. (gfc_simplify_set_exponent): Handle infinities and NaNs. (gfc_simplify_spacing): Handle zeros, infinities and NaNs. * gfortran.dg/ieee/intrinsics_1.f90: New test. From-SVN: r216120 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 88fc33f87b4..e6ffc27bb9b 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,15 @@ +2014-10-11 Francois-Xavier Coudert + + PR fortran/48979 + * simplify.c (gfc_simplify_atan): Use mpfr_zero_p to check for zeros. + (gfc_simplify_log): Likewise. + (gfc_simplify_scale): Likewise. + (gfc_simplify_exponent): Handle infinities and NaNs. + (gfc_simplify_fraction): Handle infinities. + (gfc_simplify_rrspacing): Handle signed zeros and NaNs. + (gfc_simplify_set_exponent): Handle infinities and NaNs. + (gfc_simplify_spacing): Handle zeros, infinities and NaNs. + 2014-10-10 Jakub Jelinek PR fortran/59488 diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 278527c58d2..92b72ba2d8c 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -1169,7 +1169,7 @@ gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x) if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) return NULL; - if (mpfr_sgn (y->value.real) == 0 && mpfr_sgn (x->value.real) == 0) + if (mpfr_zero_p (y->value.real) && mpfr_zero_p (x->value.real)) { gfc_error ("If first argument of ATAN2 %L is zero, then the " "second argument must not be zero", &x->where); @@ -2191,7 +2191,7 @@ gfc_simplify_exp (gfc_expr *x) gfc_expr * gfc_simplify_exponent (gfc_expr *x) { - int i; + long int val; gfc_expr *result; if (x->expr_type != EXPR_CONSTANT) @@ -2200,16 +2200,25 @@ gfc_simplify_exponent (gfc_expr *x) result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, &x->where); - gfc_set_model (x->value.real); + /* EXPONENT(inf) = EXPONENT(nan) = HUGE(0) */ + if (mpfr_inf_p (x->value.real) || mpfr_nan_p (x->value.real)) + { + int i = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false); + mpz_set (result->value.integer, gfc_integer_kinds[i].huge); + return result; + } - if (mpfr_sgn (x->value.real) == 0) + /* EXPONENT(+/- 0.0) = 0 */ + if (mpfr_zero_p (x->value.real)) { mpz_set_ui (result->value.integer, 0); return result; } - i = (int) mpfr_get_exp (x->value.real); - mpz_set_si (result->value.integer, i); + gfc_set_model (x->value.real); + + val = (long int) mpfr_get_exp (x->value.real); + mpz_set_si (result->value.integer, val); return range_check (result, "EXPONENT"); } @@ -2373,6 +2382,13 @@ gfc_simplify_fraction (gfc_expr *x) result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); + /* FRACTION(inf) = NaN. */ + if (mpfr_inf_p (x->value.real)) + { + mpfr_set_nan (result->value.real); + return result; + } + #if MPFR_VERSION < MPFR_VERSION_NUM(3,1,0) /* MPFR versions before 3.1.0 do not include mpfr_frexp. @@ -2403,6 +2419,7 @@ gfc_simplify_fraction (gfc_expr *x) #else + /* mpfr_frexp() correctly handles zeros and NaNs. */ mpfr_frexp (&e, result->value.real, x->value.real, GFC_RND_MODE); #endif @@ -3809,8 +3826,8 @@ gfc_simplify_log (gfc_expr *x) break; case BT_COMPLEX: - if ((mpfr_sgn (mpc_realref (x->value.complex)) == 0) - && (mpfr_sgn (mpc_imagref (x->value.complex)) == 0)) + if (mpfr_zero_p (mpc_realref (x->value.complex)) + && mpfr_zero_p (mpc_imagref (x->value.complex))) { gfc_error ("Complex argument of LOG at %L cannot be zero", &x->where); @@ -5191,16 +5208,30 @@ gfc_simplify_rrspacing (gfc_expr *x) i = gfc_validate_kind (x->ts.type, x->ts.kind, false); result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); - mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE); - /* Special case x = -0 and 0. */ - if (mpfr_sgn (result->value.real) == 0) + /* RRSPACING(+/- 0.0) = 0.0 */ + if (mpfr_zero_p (x->value.real)) { mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); return result; } + /* RRSPACING(inf) = NaN */ + if (mpfr_inf_p (x->value.real)) + { + mpfr_set_nan (result->value.real); + return result; + } + + /* RRSPACING(NaN) = same NaN */ + if (mpfr_nan_p (x->value.real)) + { + mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); + return result; + } + /* | x * 2**(-e) | * 2**p. */ + mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE); e = - (long int) mpfr_get_exp (x->value.real); mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE); @@ -5223,7 +5254,7 @@ gfc_simplify_scale (gfc_expr *x, gfc_expr *i) result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); - if (mpfr_sgn (x->value.real) == 0) + if (mpfr_zero_p (x->value.real)) { mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); return result; @@ -5591,9 +5622,18 @@ gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i) result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); - if (mpfr_sgn (x->value.real) == 0) + /* SET_EXPONENT (+/-0.0, I) = +/- 0.0 + SET_EXPONENT (NaN) = same NaN */ + if (mpfr_zero_p (x->value.real) || mpfr_nan_p (x->value.real)) { - mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); + mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); + return result; + } + + /* SET_EXPONENT (inf) = NaN */ + if (mpfr_inf_p (x->value.real)) + { + mpfr_set_nan (result->value.real); return result; } @@ -5979,17 +6019,29 @@ gfc_simplify_spacing (gfc_expr *x) return NULL; i = gfc_validate_kind (x->ts.type, x->ts.kind, false); - result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); - /* Special case x = 0 and -0. */ - mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE); - if (mpfr_sgn (result->value.real) == 0) + /* SPACING(+/- 0.0) = SPACING(TINY(0.0)) = TINY(0.0) */ + if (mpfr_zero_p (x->value.real)) { mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE); return result; } + /* SPACING(inf) = NaN */ + if (mpfr_inf_p (x->value.real)) + { + mpfr_set_nan (result->value.real); + return result; + } + + /* SPACING(NaN) = same NaN */ + if (mpfr_nan_p (x->value.real)) + { + mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); + return result; + } + /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p are the radix, exponent of x, and precision. This excludes the possibility of subnormal numbers. Fortran 2003 states the result is diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index b038c828d38..6a63e33ab93 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,8 +1,13 @@ +2014-10-11 Francois-Xavier Coudert + + PR fortran/48979 + * gfortran.dg/ieee/intrinsics_1.f90: New test. + 2014-10-11 Christophe Lyon * lib/target-supports.exp (check_effective_target_shared): New function. - * g++.dg/ipa/devirt-28a.C: Check if -shared is supported. + * g++.dg/ipa/devirt-28a.C: Check if -shared is supported. 2014-10-10 Jakub Jelinek diff --git a/gcc/testsuite/gfortran.dg/ieee/intrinsics_1.f90 b/gcc/testsuite/gfortran.dg/ieee/intrinsics_1.f90 new file mode 100644 index 00000000000..6a9abdd670b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ieee/intrinsics_1.f90 @@ -0,0 +1,60 @@ +! { dg-do run } +! { dg-additional-options "-fno-range-check" } +! +! Check compile-time simplification of functions FRACTION, EXPONENT, +! SPACING, RRSPACING and SET_EXPONENT for special values. + +program test + implicit none + real, parameter :: inf = 2 * huge(0.) + real, parameter :: nan = 0. / 0. + + call check_positive_zero(fraction(0.)) + call check_negative_zero(fraction(-0.)) + if (.not. isnan(fraction(inf))) call abort + if (.not. isnan(fraction(-inf))) call abort + if (.not. isnan(fraction(nan))) call abort + + if (exponent(0.) /= 0) call abort + if (exponent(-0.) /= 0) call abort + if (exponent(inf) /= huge(0)) call abort + if (exponent(-inf) /= huge(0)) call abort + if (exponent(nan) /= huge(0)) call abort + + if (spacing(0.) /= spacing(tiny(0.))) call abort + if (spacing(-0.) /= spacing(tiny(0.))) call abort + if (.not. isnan(spacing(inf))) call abort + if (.not. isnan(spacing(-inf))) call abort + if (.not. isnan(spacing(nan))) call abort + + call check_positive_zero(rrspacing(0.)) + call check_positive_zero(rrspacing(-0.)) + if (.not. isnan(rrspacing(inf))) call abort + if (.not. isnan(rrspacing(-inf))) call abort + if (.not. isnan(rrspacing(nan))) call abort + + call check_positive_zero(set_exponent(0.,42)) + call check_negative_zero(set_exponent(-0.,42)) + if (.not. isnan(set_exponent(inf, 42))) call abort + if (.not. isnan(set_exponent(-inf, 42))) call abort + if (.not. isnan(set_exponent(nan, 42))) call abort + +contains + + subroutine check_positive_zero(x) + use ieee_arithmetic + implicit none + real, value :: x + + if (ieee_class (x) /= ieee_positive_zero) call abort + end + + subroutine check_negative_zero(x) + use ieee_arithmetic + implicit none + real, value :: x + + if (ieee_class (x) /= ieee_negative_zero) call abort + end + +end