procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source 
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>
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);
/* 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;

2
gcc/fortran/arith.h
View file

@ -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. */

18
gcc/fortran/resolve.c
View file

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

11
gcc/fortran/simplify.c
View file

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

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

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