gfortran.h (enum init_local_real.): Add GFC_INIT_REAL_SNAN.

2009-03-27  Tobias Burnus  <burnus@net-b.de>

        * gfortran.h (enum init_local_real.): Add GFC_INIT_REAL_SNAN.
        (gfc_expr): Add is_snan.
        * trans-const.c (gfc_conv_mpfr_to_tree): Support SNaN.
        (gfc_conv_constant_to_tree): Update call to gfc_conv_mpfr_to_tree.
        * trans-const.h (gfc_conv_mpfr_to_tree): Update prototype.
        * resolve.c (build_default_init_expr): Update call.
        * target-memory.c (encode_float): Ditto.
        * trans-intrinsic.c
        * (gfc_conv_intrinsic_aint,gfc_conv_intrinsic_mod,

From-SVN: r145129

9 files changed, 50 insertions, 20 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 9cb9c94..7714287 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,14 @@
+2009-03-27  Tobias Burnus  <burnus@net-b.de>
+
+	* gfortran.h (enum init_local_real.): Add GFC_INIT_REAL_SNAN.
+	(gfc_expr): Add is_snan.
+	* trans-const.c (gfc_conv_mpfr_to_tree): Support SNaN.
+	(gfc_conv_constant_to_tree): Update call to gfc_conv_mpfr_to_tree.
+	* trans-const.h (gfc_conv_mpfr_to_tree): Update prototype.
+	* resolve.c (build_default_init_expr): Update call.
+	* target-memory.c (encode_float): Ditto.
+	* trans-intrinsic.c (gfc_conv_intrinsic_aint,gfc_conv_intrinsic_mod,
+
 2009-03-18  Ralf Wildenhues  <Ralf.Wildenhues@gmx.de>
 
 	* lang.opt: Unify help texts for -I, -Wconversion, -d, -fopenmp,
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 8795bee..a5b4fc6 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -527,6 +527,7 @@ typedef enum
   GFC_INIT_REAL_OFF = 0,
   GFC_INIT_REAL_ZERO,
   GFC_INIT_REAL_NAN,
+  GFC_INIT_REAL_SNAN,
   GFC_INIT_REAL_INF,
   GFC_INIT_REAL_NEG_INF
 }
@@ -1547,8 +1548,10 @@ typedef struct gfc_expr
   locus where;
 
   /* True if the expression is a call to a function that returns an array,
-     and if we have decided not to allocate temporary data for that array.  */
-  unsigned int inline_noncopying_intrinsic : 1, is_boz : 1;
+     and if we have decided not to allocate temporary data for that array.
+     is_boz is true if the integer is regarded as BOZ bitpatten and is_snan
+     denotes a signalling not-a-number.  */
+  unsigned int inline_noncopying_intrinsic : 1, is_boz : 1, is_snan : 1;
 
   /* Sometimes, when an error has been emitted, it is necessary to prevent
       it from recurring.  */
diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi
index 8e18dd2..8138464 100644
--- a/gcc/fortran/invoke.texi
+++ b/gcc/fortran/invoke.texi
@@ -169,7 +169,7 @@ and warnings}.
 -fmax-stack-var-size=@var{n} @gol
 -fpack-derived  -frepack-arrays  -fshort-enums  -fexternal-blas @gol
 -fblas-matmul-limit=@var{n} -frecursive -finit-local-zero @gol
--finit-integer=@var{n} -finit-real=@var{<zero|inf|-inf|nan>} @gol
+-finit-integer=@var{n} -finit-real=@var{<zero|inf|-inf|nan|snan>} @gol
 -finit-logical=@var{<true|false>} -finit-character=@var{n} -fno-align-commons}
 @end table
 
@@ -1303,7 +1303,7 @@ on the stack. This flag cannot be used together with
 
 @item -finit-local-zero
 @item -finit-integer=@var{n}
-@item -finit-real=@var{<zero|inf|-inf|nan>} 
+@item -finit-real=@var{<zero|inf|-inf|nan|snan>} 
 @item -finit-logical=@var{<true|false>}
 @item -finit-character=@var{n}
 @opindex @code{finit-local-zero}
@@ -1317,7 +1317,7 @@ variables to zero, @code{LOGICAL} variables to false, and
 @code{CHARACTER} variables to a string of null bytes.  Finer-grained
 initialization options are provided by the
 @option{-finit-integer=@var{n}},
-@option{-finit-real=@var{<zero|inf|-inf|nan>}} (which also initializes
+@option{-finit-real=@var{<zero|inf|-inf|nan|snan>}} (which also initializes
 the real and imaginary parts of local @code{COMPLEX} variables),
 @option{-finit-logical=@var{<true|false>}}, and
 @option{-finit-character=@var{n}} (where @var{n} is an ASCII character
@@ -1327,7 +1327,10 @@ type variables, nor do they initialize variables that appear in an
 future releases).
 
 Note that the @option{-finit-real=nan} option initializes @code{REAL}
-and @code{COMPLEX} variables with a quiet NaN.
+and @code{COMPLEX} variables with a quiet NaN. For a signalling NaN
+use @option{-finit-real=snan}; note, however, that compile-time
+optimizations may convert them into quiet NaN and that trapping
+needs to be enabled (e.g. via @option{-ffpe-trap}).
 
 @item -falign-commons
 @opindex @code{falign-commons}
diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c
index 7a800ce..d48bf24 100644
--- a/gcc/fortran/options.c
+++ b/gcc/fortran/options.c
@@ -718,6 +718,8 @@ gfc_handle_option (size_t scode, const char *arg, int value)
 	gfc_option.flag_init_real = GFC_INIT_REAL_ZERO;
       else if (!strcasecmp (arg, "nan"))
 	gfc_option.flag_init_real = GFC_INIT_REAL_NAN;
+      else if (!strcasecmp (arg, "snan"))
+	gfc_option.flag_init_real = GFC_INIT_REAL_SNAN;
       else if (!strcasecmp (arg, "inf"))
 	gfc_option.flag_init_real = GFC_INIT_REAL_INF;
       else if (!strcasecmp (arg, "-inf"))
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 433f380..e887fb13 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -7357,6 +7357,9 @@ build_default_init_expr (gfc_symbol *sym)
       mpfr_init (init_expr->value.real);
       switch (gfc_option.flag_init_real)
 	{
+	case GFC_INIT_REAL_SNAN:
+	  init_expr->is_snan = 1;
+	  /* Fall through.  */
 	case GFC_INIT_REAL_NAN:
 	  mpfr_set_nan (init_expr->value.real);
 	  break;
@@ -7385,6 +7388,9 @@ build_default_init_expr (gfc_symbol *sym)
       mpfr_init (init_expr->value.complex.i);
       switch (gfc_option.flag_init_real)
 	{
+	case GFC_INIT_REAL_SNAN:
+	  init_expr->is_snan = 1;
+	  /* Fall through.  */
 	case GFC_INIT_REAL_NAN:
 	  mpfr_set_nan (init_expr->value.complex.r);
 	  mpfr_set_nan (init_expr->value.complex.i);
diff --git a/gcc/fortran/target-memory.c b/gcc/fortran/target-memory.c
index dc10b53..07d5e19 100644
--- a/gcc/fortran/target-memory.c
+++ b/gcc/fortran/target-memory.c
@@ -158,7 +158,7 @@ encode_integer (int kind, mpz_t integer, unsigned char *buffer,
 static int
 encode_float (int kind, mpfr_t real, unsigned char *buffer, size_t buffer_size)
 {
-  return native_encode_expr (gfc_conv_mpfr_to_tree (real, kind), buffer,
+  return native_encode_expr (gfc_conv_mpfr_to_tree (real, kind, 0), buffer,
 			     buffer_size);
 }
 
diff --git a/gcc/fortran/trans-const.c b/gcc/fortran/trans-const.c
index 4db3512..569aa7e 100644
--- a/gcc/fortran/trans-const.c
+++ b/gcc/fortran/trans-const.c
@@ -218,7 +218,7 @@ gfc_conv_tree_to_mpz (mpz_t i, tree source)
 /* Converts a real constant into backend form.  */
 
 tree
-gfc_conv_mpfr_to_tree (mpfr_t f, int kind)
+gfc_conv_mpfr_to_tree (mpfr_t f, int kind, int is_snan)
 {
   tree type;
   int n;
@@ -228,7 +228,11 @@ gfc_conv_mpfr_to_tree (mpfr_t f, int kind)
   gcc_assert (gfc_real_kinds[n].radix == 2);
 
   type = gfc_get_real_type (kind);
-  real_from_mpfr (&real, f, type, GFC_RND_MODE);
+  if (mpfr_nan_p (f) && is_snan)
+     real_from_string (&real, "SNaN");
+  else
+    real_from_mpfr (&real, f, type, GFC_RND_MODE);
+
   return build_real (type, real);
 }
 
@@ -277,7 +281,7 @@ gfc_conv_constant_to_tree (gfc_expr * expr)
 			    gfc_build_string_const (expr->representation.length,
 						    expr->representation.string));
       else
-	return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind);
+	return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind, expr->is_snan);
 
     case BT_LOGICAL:
       if (expr->representation.string)
@@ -304,9 +308,9 @@ gfc_conv_constant_to_tree (gfc_expr * expr)
       else
 	{
 	  tree real = gfc_conv_mpfr_to_tree (expr->value.complex.r,
-					  expr->ts.kind);
+					  expr->ts.kind, expr->is_snan);
 	  tree imag = gfc_conv_mpfr_to_tree (expr->value.complex.i,
-					  expr->ts.kind);
+					  expr->ts.kind, expr->is_snan);
 
 	  return build_complex (gfc_typenode_for_spec (&expr->ts),
 				real, imag);
diff --git a/gcc/fortran/trans-const.h b/gcc/fortran/trans-const.h
index 2cba791..6cc71c5 100644
--- a/gcc/fortran/trans-const.h
+++ b/gcc/fortran/trans-const.h
@@ -24,7 +24,7 @@ tree gfc_conv_mpz_to_tree (mpz_t, int);
 void gfc_conv_tree_to_mpz (mpz_t, tree);
 
 /* Converts between REAL_CST and MPFR floating-point representations.  */
-tree gfc_conv_mpfr_to_tree (mpfr_t, int);
+tree gfc_conv_mpfr_to_tree (mpfr_t, int, int);
 void gfc_conv_tree_to_mpfr (mpfr_ptr, tree);
 
 /* Build a tree for a constant.  Must be an EXPR_CONSTANT gfc_expr.
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index c0ffc14..b63f193 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -488,11 +488,11 @@ gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
   mpfr_init (huge);
   n = gfc_validate_kind (BT_INTEGER, kind, false);
   mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
-  tmp = gfc_conv_mpfr_to_tree (huge, kind);
+  tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
   cond = fold_build2 (LT_EXPR, boolean_type_node, arg[0], tmp);
 
   mpfr_neg (huge, huge, GFC_RND_MODE);
-  tmp = gfc_conv_mpfr_to_tree (huge, kind);
+  tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
   tmp = fold_build2 (GT_EXPR, boolean_type_node, arg[0], tmp);
   cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond, tmp);
   itype = gfc_get_int_type (kind);
@@ -1197,11 +1197,11 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
 	  ikind = gfc_max_integer_kind;
 	}
       mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
-      test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
+      test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
       test2 = fold_build2 (LT_EXPR, boolean_type_node, tmp, test);
 
       mpfr_neg (huge, huge, GFC_RND_MODE);
-      test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
+      test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
       test = fold_build2 (GT_EXPR, boolean_type_node, tmp, test);
       test2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
 
@@ -2163,7 +2163,8 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
   switch (arrayexpr->ts.type)
     {
     case BT_REAL:
-      tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, arrayexpr->ts.kind);
+      tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
+				   arrayexpr->ts.kind, 0);
       break;
 
     case BT_INTEGER:
@@ -2342,7 +2343,7 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op)
   switch (expr->ts.type)
     {
     case BT_REAL:
-      tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, expr->ts.kind);
+      tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, expr->ts.kind, 0);
       break;
 
     case BT_INTEGER:
@@ -3199,7 +3200,7 @@ gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
   k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
   prec = build_int_cst (NULL_TREE, gfc_real_kinds[k].digits);
   emin = build_int_cst (NULL_TREE, gfc_real_kinds[k].min_exponent - 1);
-  tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind);
+  tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
 
   switch (expr->ts.kind)
     {