git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/34333 (if(nan == nan) wrongly returns TRUE, when nan is a parameter) 

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.

From-SVN: r130623
This commit is contained in:
Tobias Burnus 2007-12-05 14:42:32 +01:00
parent 59b130b365
commit 7b4c5f8b9b
7 changed files with 193 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
gcc/fortran/ChangeLog
View File

@ -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> 2007-12-04 Tobias Burnus <burnus@net-b.de>
PR fortran/34318 PR fortran/34318

56
gcc/fortran/arith.c
View File

@ -226,8 +226,7 @@ gfc_arith_init_1 (void)
mpfr_neg (b, b, GFC_RND_MODE); mpfr_neg (b, b, GFC_RND_MODE);
/* a = min(a, b) */ /* a = min(a, b) */
if (mpfr_cmp (a, b) > 0) mpfr_min (a, a, b, GFC_RND_MODE);
mpfr_set (a, b, GFC_RND_MODE);
mpfr_trunc (a, a); mpfr_trunc (a, a);
gfc_mpfr_to_mpz (r, 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; 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 /* 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 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; int rc;
@ -1131,7 +1161,7 @@ gfc_compare_expr (gfc_expr *op1, gfc_expr *op2)
break; break;
case BT_REAL: case BT_REAL:
rc = mpfr_cmp (op1->value.real, op2->value.real); rc = compare_real (op1, op2, op);
break; break;
case BT_CHARACTER: case BT_CHARACTER:
@ -1157,8 +1187,8 @@ gfc_compare_expr (gfc_expr *op1, gfc_expr *op2)
static int static int
compare_complex (gfc_expr *op1, gfc_expr *op2) compare_complex (gfc_expr *op1, gfc_expr *op2)
{ {
return (mpfr_cmp (op1->value.complex.r, op2->value.complex.r) == 0 return (mpfr_equal_p (op1->value.complex.r, op2->value.complex.r)
&& mpfr_cmp (op1->value.complex.i, op2->value.complex.i) == 0); && 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); &op1->where);
result->value.logical = (op1->ts.type == BT_COMPLEX) result->value.logical = (op1->ts.type == BT_COMPLEX)
? compare_complex (op1, op2) ? compare_complex (op1, op2)
: (gfc_compare_expr (op1, op2) == 0); : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) == 0);
*resultp = result; *resultp = result;
return ARITH_OK; return ARITH_OK;
@ -1222,7 +1252,7 @@ gfc_arith_ne (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
&op1->where); &op1->where);
result->value.logical = (op1->ts.type == BT_COMPLEX) result->value.logical = (op1->ts.type == BT_COMPLEX)
? !compare_complex (op1, op2) ? !compare_complex (op1, op2)
: (gfc_compare_expr (op1, op2) != 0); : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) != 0);
*resultp = result; *resultp = result;
return ARITH_OK; 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, result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
&op1->where); &op1->where);
result->value.logical = (gfc_compare_expr (op1, op2) > 0); result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GT) > 0);
*resultp = result; *resultp = result;
return ARITH_OK; 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, result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
&op1->where); &op1->where);
result->value.logical = (gfc_compare_expr (op1, op2) >= 0); result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GE) >= 0);
*resultp = result; *resultp = result;
return ARITH_OK; 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, result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
&op1->where); &op1->where);
result->value.logical = (gfc_compare_expr (op1, op2) < 0); result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LT) < 0);
*resultp = result; *resultp = result;
return ARITH_OK; 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, result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
&op1->where); &op1->where);
result->value.logical = (gfc_compare_expr (op1, op2) <= 0); result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LE) <= 0);
*resultp = result; *resultp = result;
return ARITH_OK; return ARITH_OK;

2
gcc/fortran/arith.h
View File

@ -38,7 +38,7 @@ gfc_expr *gfc_constant_result (bt, int, locus *);
for overflow and underflow. */ for overflow and underflow. */
arith gfc_range_check (gfc_expr *); 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 *); int gfc_compare_string (gfc_expr *, gfc_expr *);
/* Constant folding for gfc_expr trees. */ /* Constant folding for gfc_expr trees. */

18
gcc/fortran/resolve.c
View File

@ -4822,7 +4822,7 @@ compare_cases (const gfc_case *op1, const gfc_case *op2)
retval = 0; retval = 0;
/* op2 = (M:) or (M:N), L < M */ /* op2 = (M:) or (M:N), L < M */
if (op2->low != NULL if (op2->low != NULL
&& gfc_compare_expr (op1->high, op2->low) < 0) && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
retval = -1; retval = -1;
} }
else if (op1->high == NULL) /* op1 = (K:) */ else if (op1->high == NULL) /* op1 = (K:) */
@ -4831,23 +4831,25 @@ compare_cases (const gfc_case *op1, const gfc_case *op2)
retval = 0; retval = 0;
/* op2 = (:N) or (M:N), K > N */ /* op2 = (:N) or (M:N), K > N */
if (op2->high != NULL if (op2->high != NULL
&& gfc_compare_expr (op1->low, op2->high) > 0) && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0)
retval = 1; retval = 1;
} }
else /* op1 = (K:L) */ else /* op1 = (K:L) */
{ {
if (op2->low == NULL) /* op2 = (:N), K > N */ 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 */ 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) */ else /* op2 = (M:N) */
{ {
retval = 0; retval = 0;
/* L < M */ /* L < M */
if (gfc_compare_expr (op1->high, op2->low) < 0) if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0)
retval = -1; retval = -1;
/* K > N */ /* 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; retval = 1;
} }
} }
@ -5122,7 +5124,7 @@ resolve_select (gfc_code *code)
/* Unreachable case ranges are discarded, so ignore. */ /* Unreachable case ranges are discarded, so ignore. */
if (cp->low != NULL && cp->high != NULL if (cp->low != NULL && cp->high != NULL
&& cp->low != cp->high && cp->low != cp->high
&& gfc_compare_expr (cp->low, cp->high) > 0) && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
continue; continue;
/* FIXME: Should a warning be issued? */ /* FIXME: Should a warning be issued? */
@ -5210,7 +5212,7 @@ resolve_select (gfc_code *code)
if (cp->low != NULL && cp->high != NULL if (cp->low != NULL && cp->high != NULL
&& cp->low != cp->high && 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) if (gfc_option.warn_surprising)
gfc_warning ("Range specification at %L can never " gfc_warning ("Range specification at %L can never "

11
gcc/fortran/simplify.c
View File

@ -2444,10 +2444,13 @@ simplify_min_max (gfc_expr *expr, int sign)
break; break;
case BT_REAL: case BT_REAL:
if (mpfr_cmp (arg->expr->value.real, extremum->expr->value.real) /* We need to use mpfr_min and mpfr_max to treat NaN properly. */
* sign > 0) if (sign > 0)
mpfr_set (extremum->expr->value.real, arg->expr->value.real, mpfr_max (extremum->expr->value.real, extremum->expr->value.real,
GFC_RND_MODE); 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; break;
case BT_CHARACTER: case BT_CHARACTER:

17
gcc/testsuite/ChangeLog
View File

@ -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> 2007-12-05 Jakub Jelinek <jakub@redhat.com>
PR c++/34271 PR c++/34271
@ -16,8 +21,8 @@
2007-12-04 Douglas Gregor <doug.gregor@gmail.com> 2007-12-04 Douglas Gregor <doug.gregor@gmail.com>
PR c++/34101 PR c++/34101
* g++.dg/cpp0x/variadic-ttp.C: New. * g++.dg/cpp0x/variadic-ttp.C: New.
2007-12-04 Manuel Lopez-Ibanez <manu@gcc.gnu.org> 2007-12-04 Manuel Lopez-Ibanez <manu@gcc.gnu.org>
@ -26,13 +31,13 @@
2007-12-04 Douglas Gregor <doug.gregor@gmail.com> 2007-12-04 Douglas Gregor <doug.gregor@gmail.com>
PR c++/33509 PR c++/33509
* g++.dg/cpp0x/variadic-throw.C: New. * g++.dg/cpp0x/variadic-throw.C: New.
2007-12-04 Douglas Gregor <doug.gregor@gmail.com> 2007-12-04 Douglas Gregor <doug.gregor@gmail.com>
PR c++/33091 PR c++/33091
* g++.dg/cpp0x/variadic-unify.C: New. * g++.dg/cpp0x/variadic-unify.C: New.
2007-12-04 Richard Guenther <rguenther@suse.de> 2007-12-04 Richard Guenther <rguenther@suse.de>

105
gcc/testsuite/gfortran.dg/nan_2.f90 Normal file
View File

@ -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