2007-12-05 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-05  Tobias Burnus  <burnus@net-b.de>

        PR fortran/34333
        * gfortran.dg/nan_2.f90: New.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@130623 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index a457fa2..4752ae0 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,19 @@
+2007-12-05  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/34318

diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c
index cfcbdf0..01d2989 100644 (file)
--- a/gcc/fortran/arith.c
+++ b/gcc/fortran/arith.c
@@ -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_expr *op2, gfc_expr **resultp)
   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_expr *op2)
       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_expr *op2)
 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 *op2, gfc_expr **resultp)
                                &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 *op2, gfc_expr **resultp)
                                &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 *op2, gfc_expr **resultp)
 
   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 *op2, gfc_expr **resultp)
 
   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 *op2, gfc_expr **resultp)
 
   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 *op2, gfc_expr **resultp)
 
   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;

diff --git a/gcc/fortran/arith.h b/gcc/fortran/arith.h
index ea41279..67d7361 100644 (file)
--- a/gcc/fortran/arith.h
+++ b/gcc/fortran/arith.h
@@ -38,7 +38,7 @@ gfc_expr *gfc_constant_result (bt, int, locus *);
    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.  */

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index eaa15d3..5083b9b 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -4822,7 +4822,7 @@ compare_cases (const gfc_case *op1, const gfc_case *op2)
       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, const gfc_case *op2)
       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 "

diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 687e87f..598ec57 100644 (file)
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -2444,10 +2444,13 @@ simplify_min_max (gfc_expr *expr, int sign)
          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:

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 77b97d2..539a0a2 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2007-12-05  Tobias Burnus  <bU    gcc/stmt.c
+
+       PR fortran/34333
+       * gfortran.dg/nan_2.f90: New.
+
 2007-12-05  Jakub Jelinek  <jakub@redhat.com>
 
        PR c++/34271
@@ -16,8 +21,8 @@
 
 2007-12-04  Douglas Gregor  <doug.gregor@gmail.com>
 
-       PR c++/34101
-       * g++.dg/cpp0x/variadic-ttp.C: New.
+       PR c++/34101
+       * g++.dg/cpp0x/variadic-ttp.C: New.
 
 2007-12-04  Manuel Lopez-Ibanez  <manu@gcc.gnu.org>
        
@@ -26,13 +31,13 @@
        
 2007-12-04  Douglas Gregor  <doug.gregor@gmail.com>
 
-       PR c++/33509
-       * g++.dg/cpp0x/variadic-throw.C: New.
+       PR c++/33509
+       * g++.dg/cpp0x/variadic-throw.C: New.
 
 2007-12-04  Douglas Gregor  <doug.gregor@gmail.com>
 
-       PR c++/33091
-       * g++.dg/cpp0x/variadic-unify.C: New.
+       PR c++/33091
+       * g++.dg/cpp0x/variadic-unify.C: New.
 
 2007-12-04  Richard Guenther  <rguenther@suse.de>
 

diff --git a/gcc/testsuite/gfortran.dg/nan_2.f90 b/gcc/testsuite/gfortran.dg/nan_2.f90
new file mode 100644 (file)
index 0000000..9976abc
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/nan_2.f90
@@ -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