2007-12-04 Tobias Burnus 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 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