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

+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

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

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

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);
 }
 
 

gcc/testsuite/ChangeLog

+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

gcc/testsuite/gfortran.dg/ieee/intrinsics_2.F90

+! { 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