This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[Patch, Fortran] PR34333 - Handle parameter NAN properly in MAX, MIN, == etc.
- From: Tobias Burnus <burnus at net-b dot de>
- To: "'fortran at gcc dot gnu dot org'" <fortran at gcc dot gnu dot org>, gcc-patches <gcc-patches at gcc dot gnu dot org>
- Date: Tue, 04 Dec 2007 21:43:57 +0100
- Subject: [Patch, Fortran] PR34333 - Handle parameter NAN properly in MAX, MIN, == etc.
:ADDPATCH fortran:
The program (to be compiled with -fno-range-check)
real, parameter :: nan = 0.0/0.0
if (nan == nan) call abort()
print *, max(nan, 4.0) ! shall print "4.0"
should not abort as (nan /= nan) shall evaluate as true. This patch
ensures that comparisons and MIN/MAX work properly for NaN, by using
mpfr_min and mpfr_max instead of home-grown mpfr_cmp/mpfr_set solutions.
It additionally replaces mpfr_cmp by mpfr_equal_p etc. which take NaN
into account. I had to pass the wanted argument to gfc_compare_expr to
ensure that for "nan > nan", "nan < nan" and "nan == nan" the result is
always false.
Build and regression tested on x86-64-linux.
OK for the trunk?
Tobias
PS: I essentially copied the test case nan_1.f90 and changed the
variables to parameters.
2007-12-04 Tobias Burnus <burnus@net-b.de>
PR fortran/34333
* arith.h (gfc_compare_expr): Add operator argument, needed
for compare_real.
* arith.c (gfc_arith_init_1): Use mpfr_min instead of mpfr_cmp/set
to account for NaN.
(compare_real): New function, as mpfr_cmp but takes NaN into account.
(gfc_compare_expr): Use compare_real.
(compare_complex): Take NaN into account.
(gfc_arith_eq,gfc_arith_ne,gfc_arith_gt,gfc_arith_ge,gfc_arith_lt,
gfc_arith_le): Pass operator to gfc_compare_expr.
* resolve.c (compare_cases,resolve_select): Pass operator
to gfc_compare_expr.
* simplify.c (simplify_min_max): Take NaN into account.
2007-12-04 Tobias Burnus <burnus@net-b.de>
PR fortran/34333
* gfortran.dg/nan_2.f90: New.
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (Revision 130602)
+++ gcc/fortran/resolve.c (Arbeitskopie)
@@ -4822,7 +4822,7 @@ compare_cases (const gfc_case *op1, cons
retval = 0;
/* op2 = (M:) or (M:N), L < M */
if (op2->low != NULL
- && gfc_compare_expr (op1->high, op2->low) < 0)
+ && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
retval = -1;
}
else if (op1->high == NULL) /* op1 = (K:) */
@@ -4831,23 +4831,25 @@ compare_cases (const gfc_case *op1, cons
retval = 0;
/* op2 = (:N) or (M:N), K > N */
if (op2->high != NULL
- && gfc_compare_expr (op1->low, op2->high) > 0)
+ && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
retval = 1;
}
else /* op1 = (K:L) */
{
if (op2->low == NULL) /* op2 = (:N), K > N */
- retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
+ retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
+ ? 1 : 0;
else if (op2->high == NULL) /* op2 = (M:), L < M */
- retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
+ retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
+ ? -1 : 0;
else /* op2 = (M:N) */
{
retval = 0;
/* L < M */
- if (gfc_compare_expr (op1->high, op2->low) < 0)
+ if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
retval = -1;
/* K > N */
- else if (gfc_compare_expr (op1->low, op2->high) > 0)
+ else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
retval = 1;
}
}
@@ -5122,7 +5124,7 @@ resolve_select (gfc_code *code)
/* Unreachable case ranges are discarded, so ignore. */
if (cp->low != NULL && cp->high != NULL
&& cp->low != cp->high
- && gfc_compare_expr (cp->low, cp->high) > 0)
+ && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
continue;
/* FIXME: Should a warning be issued? */
@@ -5210,7 +5212,7 @@ resolve_select (gfc_code *code)
if (cp->low != NULL && cp->high != NULL
&& cp->low != cp->high
- && gfc_compare_expr (cp->low, cp->high) > 0)
+ && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
{
if (gfc_option.warn_surprising)
gfc_warning ("Range specification at %L can never "
Index: gcc/fortran/arith.c
===================================================================
--- gcc/fortran/arith.c (Revision 130602)
+++ gcc/fortran/arith.c (Arbeitskopie)
@@ -226,8 +226,7 @@ gfc_arith_init_1 (void)
mpfr_neg (b, b, GFC_RND_MODE);
/* a = min(a, b) */
- if (mpfr_cmp (a, b) > 0)
- mpfr_set (a, b, GFC_RND_MODE);
+ mpfr_min (a, a, b, GFC_RND_MODE);
mpfr_trunc (a, a);
gfc_mpfr_to_mpz (r, a);
@@ -1115,12 +1114,43 @@ gfc_arith_concat (gfc_expr *op1, gfc_exp
return ARITH_OK;
}
+/* Comparison between real values; returns 0 if (op1 .op. op2) is true.
+ This function mimics mpr_cmp but takes NaN into account. */
+
+static int
+compare_real (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
+{
+ int rc;
+ switch (op)
+ {
+ case INTRINSIC_EQ:
+ rc = mpfr_equal_p (op1->value.real, op2->value.real) ? 0 : 1;
+ break;
+ case INTRINSIC_GT:
+ rc = mpfr_greater_p (op1->value.real, op2->value.real) ? 1 : -1;
+ break;
+ case INTRINSIC_GE:
+ rc = mpfr_greaterequal_p (op1->value.real, op2->value.real) ? 1 : -1;
+ break;
+ case INTRINSIC_LT:
+ rc = mpfr_less_p (op1->value.real, op2->value.real) ? -1 : 1;
+ break;
+ case INTRINSIC_LE:
+ rc = mpfr_lessequal_p (op1->value.real, op2->value.real) ? -1 : 1;
+ break;
+ default:
+ gfc_internal_error ("compare_real(): Bad operator");
+ }
+
+ return rc;
+}
/* Comparison operators. Assumes that the two expression nodes
- contain two constants of the same type. */
+ contain two constants of the same type. The op argument is
+ needed to handle NaN correctly. */
int
-gfc_compare_expr (gfc_expr *op1, gfc_expr *op2)
+gfc_compare_expr (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
{
int rc;
@@ -1131,7 +1161,7 @@ gfc_compare_expr (gfc_expr *op1, gfc_exp
break;
case BT_REAL:
- rc = mpfr_cmp (op1->value.real, op2->value.real);
+ rc = compare_real (op1, op2, op);
break;
case BT_CHARACTER:
@@ -1157,8 +1187,8 @@ gfc_compare_expr (gfc_expr *op1, gfc_exp
static int
compare_complex (gfc_expr *op1, gfc_expr *op2)
{
- return (mpfr_cmp (op1->value.complex.r, op2->value.complex.r) == 0
- && mpfr_cmp (op1->value.complex.i, op2->value.complex.i) == 0);
+ return (mpfr_equal_p (op1->value.complex.r, op2->value.complex.r)
+ && mpfr_equal_p (op1->value.complex.i, op2->value.complex.i));
}
@@ -1206,7 +1236,7 @@ gfc_arith_eq (gfc_expr *op1, gfc_expr *o
&op1->where);
result->value.logical = (op1->ts.type == BT_COMPLEX)
? compare_complex (op1, op2)
- : (gfc_compare_expr (op1, op2) == 0);
+ : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) == 0);
*resultp = result;
return ARITH_OK;
@@ -1222,7 +1252,7 @@ gfc_arith_ne (gfc_expr *op1, gfc_expr *o
&op1->where);
result->value.logical = (op1->ts.type == BT_COMPLEX)
? !compare_complex (op1, op2)
- : (gfc_compare_expr (op1, op2) != 0);
+ : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) != 0);
*resultp = result;
return ARITH_OK;
@@ -1236,7 +1266,7 @@ gfc_arith_gt (gfc_expr *op1, gfc_expr *o
result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
&op1->where);
- result->value.logical = (gfc_compare_expr (op1, op2) > 0);
+ result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GT) > 0);
*resultp = result;
return ARITH_OK;
@@ -1250,7 +1280,7 @@ gfc_arith_ge (gfc_expr *op1, gfc_expr *o
result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
&op1->where);
- result->value.logical = (gfc_compare_expr (op1, op2) >= 0);
+ result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GE) >= 0);
*resultp = result;
return ARITH_OK;
@@ -1264,7 +1294,7 @@ gfc_arith_lt (gfc_expr *op1, gfc_expr *o
result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
&op1->where);
- result->value.logical = (gfc_compare_expr (op1, op2) < 0);
+ result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LT) < 0);
*resultp = result;
return ARITH_OK;
@@ -1278,7 +1308,7 @@ gfc_arith_le (gfc_expr *op1, gfc_expr *o
result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
&op1->where);
- result->value.logical = (gfc_compare_expr (op1, op2) <= 0);
+ result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LE) <= 0);
*resultp = result;
return ARITH_OK;
Index: gcc/fortran/arith.h
===================================================================
--- gcc/fortran/arith.h (Revision 130602)
+++ gcc/fortran/arith.h (Arbeitskopie)
@@ -38,7 +38,7 @@ gfc_expr *gfc_constant_result (bt, int,
for overflow and underflow. */
arith gfc_range_check (gfc_expr *);
-int gfc_compare_expr (gfc_expr *, gfc_expr *);
+int gfc_compare_expr (gfc_expr *, gfc_expr *, gfc_intrinsic_op);
int gfc_compare_string (gfc_expr *, gfc_expr *);
/* Constant folding for gfc_expr trees. */
Index: gcc/fortran/simplify.c
===================================================================
--- gcc/fortran/simplify.c (Revision 130602)
+++ gcc/fortran/simplify.c (Arbeitskopie)
@@ -2444,10 +2444,13 @@ simplify_min_max (gfc_expr *expr, int si
break;
case BT_REAL:
- if (mpfr_cmp (arg->expr->value.real, extremum->expr->value.real)
- * sign > 0)
- mpfr_set (extremum->expr->value.real, arg->expr->value.real,
- GFC_RND_MODE);
+ /* We need to use mpfr_min and mpfr_max to treat NaN properly. */
+ if (sign > 0)
+ mpfr_max (extremum->expr->value.real, extremum->expr->value.real,
+ arg->expr->value.real, GFC_RND_MODE);
+ else
+ mpfr_min (extremum->expr->value.real, extremum->expr->value.real,
+ arg->expr->value.real, GFC_RND_MODE);
break;
case BT_CHARACTER:
Index: gcc/testsuite/gfortran.dg/nan_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/nan_2.f90 (Revision 0)
+++ gcc/testsuite/gfortran.dg/nan_2.f90 (Revision 0)
@@ -0,0 +1,105 @@
+! { dg-do run }
+! { dg-options "-fno-range-check -pedantic" }
+!
+! PR fortran/34333
+!
+! Check that (NaN /= NaN) == .TRUE.
+! and some other NaN options.
+!
+! Contrary to nan_1.f90, PARAMETERs are used and thus
+! the front end resolves the min, max and binary operators at
+! compile time.
+!
+
+module aux2
+ interface isinf
+ module procedure isinf_r
+ module procedure isinf_d
+ end interface isinf
+contains
+ pure function isinf_r(x) result (isinf)
+ logical :: isinf
+ real, intent(in) :: x
+
+ isinf = (x > huge(x)) .or. (x < -huge(x))
+ end function isinf_r
+
+ pure function isinf_d(x) result (isinf)
+ logical :: isinf
+ double precision, intent(in) :: x
+
+ isinf = (x > huge(x)) .or. (x < -huge(x))
+ end function isinf_d
+end module aux2
+
+program test
+ use aux2
+ implicit none
+ real, parameter :: nan = 0.0/0.0, large = huge(large), inf = 1.0/0.0
+
+ if (nan == nan .or. nan > nan .or. nan < nan .or. nan >= nan &
+ .or. nan <= nan) call abort
+ if (isnan (2.d0) .or. (.not. isnan(nan)) .or. &
+ (.not. isnan(real(nan,kind=kind(2.d0))))) call abort
+
+ ! Create an INF and check it
+ if (isinf(nan) .or. isinf(large) .or. .not. isinf(inf)) call abort
+ if (isinf(-nan) .or. isinf(-large) .or. .not. isinf(-inf)) call abort
+
+ ! Check that MIN and MAX behave correctly
+ if (max(2.0, nan) /= 2.0) call abort
+ if (min(2.0, nan) /= 2.0) call abort
+ if (max(nan, 2.0) /= 2.0) call abort
+ if (min(nan, 2.0) /= 2.0) call abort
+
+ if (max(2.d0, nan) /= 2.d0) call abort ! { dg-warning "Extension: Different type kinds" }
+ if (min(2.d0, nan) /= 2.d0) call abort ! { dg-warning "Extension: Different type kinds" }
+ if (max(nan, 2.d0) /= 2.d0) call abort ! { dg-warning "Extension: Different type kinds" }
+ if (min(nan, 2.d0) /= 2.d0) call abort ! { dg-warning "Extension: Different type kinds" }
+
+ if (.not. isnan(min(nan,nan))) call abort
+ if (.not. isnan(max(nan,nan))) call abort
+
+ ! Same thing, with more arguments
+
+ if (max(3.0, 2.0, nan) /= 3.0) call abort
+ if (min(3.0, 2.0, nan) /= 2.0) call abort
+ if (max(3.0, nan, 2.0) /= 3.0) call abort
+ if (min(3.0, nan, 2.0) /= 2.0) call abort
+ if (max(nan, 3.0, 2.0) /= 3.0) call abort
+ if (min(nan, 3.0, 2.0) /= 2.0) call abort
+
+ if (max(3.d0, 2.d0, nan) /= 3.d0) call abort ! { dg-warning "Extension: Different type kinds" }
+ if (min(3.d0, 2.d0, nan) /= 2.d0) call abort ! { dg-warning "Extension: Different type kinds" }
+ if (max(3.d0, nan, 2.d0) /= 3.d0) call abort ! { dg-warning "Extension: Different type kinds" }
+ if (min(3.d0, nan, 2.d0) /= 2.d0) call abort ! { dg-warning "Extension: Different type kinds" }
+ if (max(nan, 3.d0, 2.d0) /= 3.d0) call abort ! { dg-warning "Extension: Different type kinds" }
+ if (min(nan, 3.d0, 2.d0) /= 2.d0) call abort ! { dg-warning "Extension: Different type kinds" }
+
+ if (.not. isnan(min(nan,nan,nan))) call abort
+ if (.not. isnan(max(nan,nan,nan))) call abort
+ if (.not. isnan(min(nan,nan,nan,nan))) call abort
+ if (.not. isnan(max(nan,nan,nan,nan))) call abort
+ if (.not. isnan(min(nan,nan,nan,nan,nan))) call abort
+ if (.not. isnan(max(nan,nan,nan,nan,nan))) call abort
+
+ ! Large values, INF and NaNs
+ if (.not. isinf(max(large, inf))) call abort
+ if (isinf(min(large, inf))) call abort
+ if (.not. isinf(max(nan, large, inf))) call abort
+ if (isinf(min(nan, large, inf))) call abort
+ if (.not. isinf(max(large, nan, inf))) call abort
+ if (isinf(min(large, nan, inf))) call abort
+ if (.not. isinf(max(large, inf, nan))) call abort
+ if (isinf(min(large, inf, nan))) call abort
+
+ if (.not. isinf(min(-large, -inf))) call abort
+ if (isinf(max(-large, -inf))) call abort
+ if (.not. isinf(min(nan, -large, -inf))) call abort
+ if (isinf(max(nan, -large, -inf))) call abort
+ if (.not. isinf(min(-large, nan, -inf))) call abort
+ if (isinf(max(-large, nan, -inf))) call abort
+ if (.not. isinf(min(-large, -inf, nan))) call abort
+ if (isinf(max(-large, -inf, nan))) call abort
+
+end program test