From 565fad70aa35e354b628c5f94639e543a631e8e8 Mon Sep 17 00:00:00 2001 From: Francois-Xavier Coudert Date: Sun, 19 Oct 2014 20:49:27 +0000 Subject: [PATCH] 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 --- gcc/fortran/ChangeLog | 13 +++ gcc/fortran/trans-const.c | 10 ++ gcc/fortran/trans-const.h | 4 + gcc/fortran/trans-intrinsic.c | 109 +++++++++++++----- gcc/testsuite/ChangeLog | 5 + .../gfortran.dg/ieee/intrinsics_2.F90 | 67 +++++++++++ 6 files changed, 178 insertions(+), 30 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/ieee/intrinsics_2.F90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 1be334f1f65..6f05ef92925 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,16 @@ +2014-10-19 Francois-Xavier Coudert + + 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 PR fortran/63553 diff --git a/gcc/fortran/trans-const.c b/gcc/fortran/trans-const.c index 9135f29fa3d..99a18328be1 100644 --- a/gcc/fortran/trans-const.c +++ b/gcc/fortran/trans-const.c @@ -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 diff --git a/gcc/fortran/trans-const.h b/gcc/fortran/trans-const.h index 42ffe6952c2..b1f1910ff75 100644 --- a/gcc/fortran/trans-const.h +++ b/gcc/fortran/trans-const.h @@ -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. */ diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index b157b950ecc..18159033e65 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -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); } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index b5c8fb78cd1..11ef7267159 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2014-10-19 Francois-Xavier Coudert + + PR fortran/48979 + * gfortran.dg/ieee/intrinsics_2.F90: New test. + 2014-10-19 Marek Polacek PR c/63567 diff --git a/gcc/testsuite/gfortran.dg/ieee/intrinsics_2.F90 b/gcc/testsuite/gfortran.dg/ieee/intrinsics_2.F90 new file mode 100644 index 00000000000..a179da24090 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ieee/intrinsics_2.F90 @@ -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 -- 2.30.2