diff options
| -rw-r--r-- | gcc/fortran/ChangeLog | 16 | ||||
| -rw-r--r-- | gcc/fortran/arith.c | 56 | ||||
| -rw-r--r-- | gcc/fortran/arith.h | 2 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 18 | ||||
| -rw-r--r-- | gcc/fortran/simplify.c | 11 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 17 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/nan_2.f90 | 105 |
7 files changed, 193 insertions, 32 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index a457fa273bc..4752ae020ef 100644 --- 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 cfcbdf0cb76..01d2989f316 100644 --- 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 ea412792a08..67d73617a74 100644 --- 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 eaa15d3962f..5083b9b3be9 100644 --- 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 687e87f7177..598ec57d02b 100644 --- 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 77b97d213fd..539a0a2a641 100644 --- 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 index 00000000000..9976abc37e0 --- /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 |