[Fortran,patch]

[Fortran,patch]

[Tobias Burnus]

:ADDPATCH fortran:

The following is a puzzle for me. I know that dumping cores and
backtracing worked at some point. (Don't ask me whether this was with
the committed or with the submitted version.)

Nonetheless, both the current version (by FX) and the version submitted
before don't contain this fix. In any case, _gfortran_set_std only
contains 3 arguments and - obviously - dumping core or backtracing does
not work.

I think this counts as real Schrödinbug. ("A Schroedinbug is a bug that
manifests itself apparently only after the software is used in an
unusual way or seemingly at the point in time that a programmer reading
the source code notices that the program should never have worked in the
first place, at which point the program stops working entirely until the
mysteriously now non-functioning code is repaired." [wikipedia].)

Build and regression-tested on x86_64-unknown-linux-gnu.
Ok for the trunk?

Tobias



2007-03-15  Tobias Burnus  <burnus@net-b.de>

    * trans-decl.c (gfc_generate_function_code): Use all arguments of
set_std.

Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c    (revision 122956)
--- gcc/fortran/trans-decl.c    (working copy)
*************** gfc_generate_function_code (gfc_namespac
*** 3137,3143 ****
    if (sym->attr.is_main_program)
      {
        tree gfc_int4_type_node = gfc_get_int_type (4);
!       tmp = build_call_expr (gfor_fndecl_set_std, 3,
                             build_int_cst (gfc_int4_type_node,
                                            gfc_option.warn_std),
                             build_int_cst (gfc_int4_type_node,
--- 3137,3143 ----
    if (sym->attr.is_main_program)
      {
        tree gfc_int4_type_node = gfc_get_int_type (4);
!       tmp = build_call_expr (gfor_fndecl_set_std, 5,
                             build_int_cst (gfc_int4_type_node,
                                            gfc_option.warn_std),
                             build_int_cst (gfc_int4_type_node,

Re: [Fortran,patch]

[FX Coudert]

> 2007-03-15  Tobias Burnus  <burnus@net-b.de>
>
>     * trans-decl.c (gfc_generate_function_code): Use all arguments of
> set_std.

OK, under the "commiter did stupid typo in last-minute update" rule :(

I must have not take enough care when merging this bit manually,  
after the build_call_expr merge. Sorry for the inconvenience, and  
thanks for spotting it,

FX

[fortran,patch]

[FX]

[-- Attachment #1: Type: text/plain, Size: 275 bytes --]

After the compile-time simplification, this patch fixes the handling of special values (infinities and NaNs) by intrinsics EXPONENT, FRACTION, SPACING, RRSPACING & SET_EXPONENT on the code generation side.

Bootstrapped and regtested on x86_64-linux.
OK to commit?




[-- Attachment #2: intrinsics.ChangeLog --]
[-- Type: application/octet-stream, Size: 621 bytes --]

2014-10-11  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-11  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>

	PR fortran/48979
	* gfortran.dg/ieee/intrinsics_2.F90: New test.


[-- Attachment #3: intrinsics.diff --]
[-- Type: application/octet-stream, Size: 10518 bytes --]

Index: gcc/fortran/trans-const.c
===================================================================
--- gcc/fortran/trans-const.c	(revision 216120)
+++ gcc/fortran/trans-const.c	(working copy)
@@ -256,6 +256,16 @@
     }
 }
 
+/* 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
Index: gcc/fortran/trans-const.h
===================================================================
--- gcc/fortran/trans-const.h	(revision 216120)
+++ gcc/fortran/trans-const.h	(working copy)
@@ -30,6 +30,10 @@
    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.  */
Index: gcc/fortran/trans-intrinsic.c
===================================================================
--- gcc/fortran/trans-intrinsic.c	(revision 216120)
+++ gcc/fortran/trans-intrinsic.c	(working copy)
@@ -901,29 +901,40 @@
 }
 
 
-/* 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 @@
       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 @@
 }
 
 
-/* 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 @@
 
 /* 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 @@
 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 @@
 			 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 @@
       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 @@
 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_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));
+
+  /* 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 @@
 
 
 /* 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);
 }
 
 
Index: gcc/testsuite/gfortran.dg/ieee/intrinsics_2.F90
===================================================================
--- gcc/testsuite/gfortran.dg/ieee/intrinsics_2.F90	(revision 0)
+++ gcc/testsuite/gfortran.dg/ieee/intrinsics_2.F90	(revision 0)
@@ -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