re PR fortran/48979 (FRACTION und EXPONENT return invalid results for infinity/NaN)
PR fortran/48979 * trans-const.c (gfc_build_nan): New function. * trans-const.h (gfc_build_nan): New prototype. * trans-intrinsic.c (gfc_conv_intrinsic_exponent): Handle special values. (gfc_conv_intrinsic_minmaxval): Use gfc_build_nan. (gfc_conv_intrinsic_fraction): Handle special values. (gfc_conv_intrinsic_spacing): Likewise. (gfc_conv_intrinsic_rrspacing): Likewise. (gfc_conv_intrinsic_set_exponent): Likewise. * gfortran.dg/ieee/intrinsics_2.F90: New test. From-SVN: r216443
This commit is contained in:
Francois-Xavier Coudert
François-Xavier Coudert
parent
d856054bc7
commit
565fad70aa
6 changed files with 178 additions and 30 deletions
|
|
@ -1,3 +1,16 @@
|
|||
2014-10-19 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
|
||||
|
||||
PR fortran/48979
|
||||
* trans-const.c (gfc_build_nan): New function.
|
||||
* trans-const.h (gfc_build_nan): New prototype.
|
||||
* trans-intrinsic.c (gfc_conv_intrinsic_exponent): Handle special
|
||||
values.
|
||||
(gfc_conv_intrinsic_minmaxval): Use gfc_build_nan.
|
||||
(gfc_conv_intrinsic_fraction): Handle special values.
|
||||
(gfc_conv_intrinsic_spacing): Likewise.
|
||||
(gfc_conv_intrinsic_rrspacing): Likewise.
|
||||
(gfc_conv_intrinsic_set_exponent): Likewise.
|
||||
|
||||
2014-10-18 Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
PR fortran/63553
|
||||
|
|
|
|||
|
|
@ -256,6 +256,16 @@ gfc_build_inf_or_huge (tree type, int kind)
|
|||
}
|
||||
}
|
||||
|
||||
/* Returns a floating-point NaN of a given type. */
|
||||
|
||||
tree
|
||||
gfc_build_nan (tree type, const char *str)
|
||||
{
|
||||
REAL_VALUE_TYPE real;
|
||||
real_nan (&real, str, 1, TYPE_MODE (type));
|
||||
return build_real (type, real);
|
||||
}
|
||||
|
||||
/* Converts a backend tree into a real constant. */
|
||||
|
||||
void
|
||||
|
|
|
|||
|
|
@ -30,6 +30,10 @@ void gfc_conv_tree_to_mpfr (mpfr_ptr, tree);
|
|||
not supported for the given type. */
|
||||
tree gfc_build_inf_or_huge (tree, int);
|
||||
|
||||
/* Build a tree containing a NaN for the given type, with significand
|
||||
specified by second argument. */
|
||||
tree gfc_build_nan (tree, const char *);
|
||||
|
||||
/* Build a tree for a constant. Must be an EXPR_CONSTANT gfc_expr.
|
||||
For CHARACTER literal constants, the caller still has to set the
|
||||
string length as a separate operation. */
|
||||
|
|
|
|||
|
|
@ -901,29 +901,40 @@ gfc_trans_same_strlen_check (const char* intr_name, locus* where,
|
|||
}
|
||||
|
||||
|
||||
/* The EXPONENT(s) intrinsic function is translated into
|
||||
/* The EXPONENT(X) intrinsic function is translated into
|
||||
int ret;
|
||||
frexp (s, &ret);
|
||||
return ret;
|
||||
return isfinite(X) ? (frexp (X, &ret) , ret) : huge
|
||||
so that if X is a NaN or infinity, the result is HUGE(0).
|
||||
*/
|
||||
|
||||
static void
|
||||
gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
|
||||
{
|
||||
tree arg, type, res, tmp, frexp;
|
||||
tree arg, type, res, tmp, frexp, cond, huge;
|
||||
int i;
|
||||
|
||||
frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP,
|
||||
expr->value.function.actual->expr->ts.kind);
|
||||
|
||||
gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
|
||||
arg = gfc_evaluate_now (arg, &se->pre);
|
||||
|
||||
i = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false);
|
||||
huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_c_int_kind);
|
||||
cond = build_call_expr_loc (input_location,
|
||||
builtin_decl_explicit (BUILT_IN_ISFINITE),
|
||||
1, arg);
|
||||
|
||||
res = gfc_create_var (integer_type_node, NULL);
|
||||
tmp = build_call_expr_loc (input_location, frexp, 2, arg,
|
||||
gfc_build_addr_expr (NULL_TREE, res));
|
||||
gfc_add_expr_to_block (&se->pre, tmp);
|
||||
tmp = fold_build2_loc (input_location, COMPOUND_EXPR, integer_type_node,
|
||||
tmp, res);
|
||||
se->expr = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
|
||||
cond, tmp, huge);
|
||||
|
||||
type = gfc_typenode_for_spec (&expr->ts);
|
||||
se->expr = fold_convert (type, res);
|
||||
se->expr = fold_convert (type, se->expr);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -4123,11 +4134,7 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
|
|||
else
|
||||
tmp = huge_cst;
|
||||
if (HONOR_NANS (DECL_MODE (limit)))
|
||||
{
|
||||
REAL_VALUE_TYPE real;
|
||||
real_nan (&real, "", 1, DECL_MODE (limit));
|
||||
nan_cst = build_real (type, real);
|
||||
}
|
||||
nan_cst = gfc_build_nan (type, "");
|
||||
break;
|
||||
|
||||
case BT_INTEGER:
|
||||
|
|
@ -5435,21 +5442,31 @@ gfc_conv_intrinsic_mask (gfc_se * se, gfc_expr * expr, int left)
|
|||
}
|
||||
|
||||
|
||||
/* FRACTION (s) is translated into frexp (s, &dummy_int). */
|
||||
/* FRACTION (s) is translated into:
|
||||
isfinite (s) ? frexp (s, &dummy_int) : NaN */
|
||||
static void
|
||||
gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
|
||||
{
|
||||
tree arg, type, tmp, frexp;
|
||||
tree arg, type, tmp, res, frexp, cond;
|
||||
|
||||
frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
|
||||
|
||||
type = gfc_typenode_for_spec (&expr->ts);
|
||||
gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
|
||||
arg = gfc_evaluate_now (arg, &se->pre);
|
||||
|
||||
cond = build_call_expr_loc (input_location,
|
||||
builtin_decl_explicit (BUILT_IN_ISFINITE),
|
||||
1, arg);
|
||||
|
||||
tmp = gfc_create_var (integer_type_node, NULL);
|
||||
se->expr = build_call_expr_loc (input_location, frexp, 2,
|
||||
fold_convert (type, arg),
|
||||
gfc_build_addr_expr (NULL_TREE, tmp));
|
||||
se->expr = fold_convert (type, se->expr);
|
||||
res = build_call_expr_loc (input_location, frexp, 2,
|
||||
fold_convert (type, arg),
|
||||
gfc_build_addr_expr (NULL_TREE, tmp));
|
||||
res = fold_convert (type, res);
|
||||
|
||||
se->expr = fold_build3_loc (input_location, COND_EXPR, type,
|
||||
cond, res, gfc_build_nan (type, ""));
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -5479,7 +5496,9 @@ gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
|
|||
|
||||
/* SPACING (s) is translated into
|
||||
int e;
|
||||
if (s == 0)
|
||||
if (!isfinite (s))
|
||||
res = NaN;
|
||||
else if (s == 0)
|
||||
res = tiny;
|
||||
else
|
||||
{
|
||||
|
|
@ -5498,7 +5517,7 @@ static void
|
|||
gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
|
||||
{
|
||||
tree arg, type, prec, emin, tiny, res, e;
|
||||
tree cond, tmp, frexp, scalbn;
|
||||
tree cond, nan, tmp, frexp, scalbn;
|
||||
int k;
|
||||
stmtblock_t block;
|
||||
|
||||
|
|
@ -5533,12 +5552,19 @@ gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
|
|||
build_real_from_int_cst (type, integer_one_node), e);
|
||||
gfc_add_modify (&block, res, tmp);
|
||||
|
||||
/* Finish by building the IF statement. */
|
||||
/* Finish by building the IF statement for value zero. */
|
||||
cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, arg,
|
||||
build_real_from_int_cst (type, integer_zero_node));
|
||||
tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
|
||||
gfc_finish_block (&block));
|
||||
|
||||
/* And deal with infinities and NaNs. */
|
||||
cond = build_call_expr_loc (input_location,
|
||||
builtin_decl_explicit (BUILT_IN_ISFINITE),
|
||||
1, arg);
|
||||
nan = gfc_build_nan (type, "");
|
||||
tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, res, nan));
|
||||
|
||||
gfc_add_expr_to_block (&se->pre, tmp);
|
||||
se->expr = res;
|
||||
}
|
||||
|
|
@ -5548,11 +5574,16 @@ gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
|
|||
int e;
|
||||
real x;
|
||||
x = fabs (s);
|
||||
if (x != 0)
|
||||
if (isfinite (x))
|
||||
{
|
||||
frexp (s, &e);
|
||||
x = scalbn (x, precision - e);
|
||||
if (x != 0)
|
||||
{
|
||||
frexp (s, &e);
|
||||
x = scalbn (x, precision - e);
|
||||
}
|
||||
}
|
||||
else
|
||||
x = NaN;
|
||||
return x;
|
||||
|
||||
where precision is gfc_real_kinds[k].digits. */
|
||||
|
|
@ -5560,7 +5591,7 @@ gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
|
|||
static void
|
||||
gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
|
||||
{
|
||||
tree arg, type, e, x, cond, stmt, tmp, frexp, scalbn, fabs;
|
||||
tree arg, type, e, x, cond, nan, stmt, tmp, frexp, scalbn, fabs;
|
||||
int prec, k;
|
||||
stmtblock_t block;
|
||||
|
||||
|
|
@ -5592,11 +5623,19 @@ gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
|
|||
gfc_add_modify (&block, x, tmp);
|
||||
stmt = gfc_finish_block (&block);
|
||||
|
||||
/* if (x != 0) */
|
||||
cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, x,
|
||||
build_real_from_int_cst (type, integer_zero_node));
|
||||
tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location));
|
||||
gfc_add_expr_to_block (&se->pre, tmp);
|
||||
|
||||
/* And deal with infinities and NaNs. */
|
||||
cond = build_call_expr_loc (input_location,
|
||||
builtin_decl_explicit (BUILT_IN_ISFINITE),
|
||||
1, x);
|
||||
nan = gfc_build_nan (type, "");
|
||||
tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, x, nan));
|
||||
|
||||
gfc_add_expr_to_block (&se->pre, tmp);
|
||||
se->expr = fold_convert (type, x);
|
||||
}
|
||||
|
||||
|
|
@ -5619,25 +5658,35 @@ gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
|
|||
|
||||
|
||||
/* SET_EXPONENT (s, i) is translated into
|
||||
scalbn (frexp (s, &dummy_int), i). */
|
||||
isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */
|
||||
static void
|
||||
gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
|
||||
{
|
||||
tree args[2], type, tmp, frexp, scalbn;
|
||||
tree args[2], type, tmp, frexp, scalbn, cond, nan, res;
|
||||
|
||||
frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
|
||||
scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
|
||||
|
||||
type = gfc_typenode_for_spec (&expr->ts);
|
||||
gfc_conv_intrinsic_function_args (se, expr, args, 2);
|
||||
args[0] = gfc_evaluate_now (args[0], &se->pre);
|
||||
|
||||
tmp = gfc_create_var (integer_type_node, NULL);
|
||||
tmp = build_call_expr_loc (input_location, frexp, 2,
|
||||
fold_convert (type, args[0]),
|
||||
gfc_build_addr_expr (NULL_TREE, tmp));
|
||||
se->expr = build_call_expr_loc (input_location, scalbn, 2, tmp,
|
||||
fold_convert (integer_type_node, args[1]));
|
||||
se->expr = fold_convert (type, se->expr);
|
||||
res = build_call_expr_loc (input_location, scalbn, 2, tmp,
|
||||
fold_convert (integer_type_node, args[1]));
|
||||
res = fold_convert (type, res);
|
||||
|
||||
/* Call to isfinite */
|
||||
cond = build_call_expr_loc (input_location,
|
||||
builtin_decl_explicit (BUILT_IN_ISFINITE),
|
||||
1, args[0]);
|
||||
nan = gfc_build_nan (type, "");
|
||||
|
||||
se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
|
||||
res, nan);
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,3 +1,8 @@
|
|||
2014-10-19 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
|
||||
|
||||
PR fortran/48979
|
||||
* gfortran.dg/ieee/intrinsics_2.F90: New test.
|
||||
|
||||
2014-10-19 Marek Polacek <polacek@redhat.com>
|
||||
|
||||
PR c/63567
|
||||
|
|
|
|||
67
gcc/testsuite/gfortran.dg/ieee/intrinsics_2.F90
Normal file
67
gcc/testsuite/gfortran.dg/ieee/intrinsics_2.F90
Normal file
|
|
@ -0,0 +1,67 @@
|
|||
! { dg-do run }
|
||||
! { dg-additional-options "-fno-range-check" }
|
||||
!
|
||||
! Check handling of special values by FRACTION, EXPONENT,
|
||||
! SPACING, RRSPACING and SET_EXPONENT.
|
||||
|
||||
program test
|
||||
implicit none
|
||||
real, parameter :: inf = 2 * huge(0.)
|
||||
real, parameter :: nan = 0. / 0.
|
||||
|
||||
real, volatile :: x
|
||||
|
||||
x = 0.
|
||||
call check_positive_zero(fraction(x))
|
||||
if (exponent(x) /= 0) call abort
|
||||
if (spacing(x) /= spacing(tiny(x))) call abort
|
||||
call check_positive_zero(rrspacing(x))
|
||||
call check_positive_zero(set_exponent(x,42))
|
||||
|
||||
x = -0.
|
||||
call check_negative_zero(fraction(x))
|
||||
if (exponent(x) /= 0) call abort
|
||||
if (spacing(x) /= spacing(tiny(x))) call abort
|
||||
call check_positive_zero(rrspacing(x))
|
||||
call check_negative_zero(set_exponent(x,42))
|
||||
|
||||
x = inf
|
||||
if (.not. isnan(fraction(x))) call abort
|
||||
if (exponent(x) /= huge(0)) call abort
|
||||
if (.not. isnan(spacing(x))) call abort
|
||||
if (.not. isnan(rrspacing(x))) call abort
|
||||
if (.not. isnan(set_exponent(x, 42))) call abort
|
||||
|
||||
x = -inf
|
||||
if (.not. isnan(fraction(x))) call abort
|
||||
if (exponent(x) /= huge(0)) call abort
|
||||
if (.not. isnan(spacing(x))) call abort
|
||||
if (.not. isnan(rrspacing(x))) call abort
|
||||
if (.not. isnan(set_exponent(x, 42))) call abort
|
||||
|
||||
x = nan
|
||||
if (.not. isnan(fraction(x))) call abort
|
||||
if (exponent(x) /= huge(0)) call abort
|
||||
if (.not. isnan(spacing(x))) call abort
|
||||
if (.not. isnan(rrspacing(x))) call abort
|
||||
if (.not. isnan(set_exponent(x, 42))) call abort
|
||||
|
||||
contains
|
||||
|
||||
subroutine check_positive_zero(x)
|
||||
use ieee_arithmetic
|
||||
implicit none
|
||||
real, value :: x
|
||||
|
||||
if (ieee_class (x) /= ieee_positive_zero) call abort
|
||||
end
|
||||
|
||||
subroutine check_negative_zero(x)
|
||||
use ieee_arithmetic
|
||||
implicit none
|
||||
real, value :: x
|
||||
|
||||
if (ieee_class (x) /= ieee_negative_zero) call abort
|
||||
end
|
||||
|
||||
end
|
||||
Loading…
Add table
Reference in a new issue