re PR fortran/19310 ([4.1 Only] unnecessary error for overflowing results)

2006-06-18  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR fortran/19310
	* arith.c (gfc_range_check): Return ARITH_OK if -fno-range-check. Add
	return of ARITH_NAN, ARITH_UNDERFLOW, and ARITH_OVERFLOW.
	(gfc_arith_divide): If -fno-range-check allow mpfr to divide by zero.
	* gfortran.h (gfc_option_t): Add new flag.
	* invoke.texi: Document new flag.
	* lang.opt: Add option -frange-check.
	* options.c (gfc_init_options): Initialize new flag.
	(gfc_handle_options): Set flag if invoked.
	* simplify.c (range_check): Add error messages for
	overflow, underflow, and other errors.
	* trans-const.c (gfc_conv_mpfr_to_tree): Build NaN and Inf from mpfr
	result.

From-SVN: r114752

8 files changed, 127 insertions, 20 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index dac857a..0f35d86 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,19 @@
+2006-06-18  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/19310
+	* arith.c (gfc_range_check): Return ARITH_OK if -fno-range-check. Add
+	return of ARITH_NAN, ARITH_UNDERFLOW, and ARITH_OVERFLOW.
+	(gfc_arith_divide): If -fno-range-check allow mpfr to divide by zero.
+	* gfortran.h (gfc_option_t): Add new flag.
+	* invoke.texi: Document new flag.
+	* lang.opt: Add option -frange-check.
+	* options.c (gfc_init_options): Initialize new flag.
+	(gfc_handle_options): Set flag if invoked.
+	* simplify.c (range_check): Add error messages for
+	overflow, underflow, and other errors.
+	* trans-const.c (gfc_conv_mpfr_to_tree): Build NaN and Inf from mpfr
+	result.
+
 2006-06-17  Karl Berry  <karl@gnu.org>
 
 	* gfortran.texi (@dircategory): Use "Software development"
diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c
index 348b87f..55289b4 100644
--- a/gcc/fortran/arith.c
+++ b/gcc/fortran/arith.c
@@ -379,12 +379,36 @@ gfc_check_real_range (mpfr_t p, int kind)
   mpfr_init (q);
   mpfr_abs (q, p, GFC_RND_MODE);
 
-  if (mpfr_sgn (q) == 0)
+  if (mpfr_inf_p (p))
+    {
+      if (gfc_option.flag_range_check == 0)
+        retval = ARITH_OK;
+      else
+        retval = ARITH_OVERFLOW;
+    }
+  else if (mpfr_nan_p (p))
+    {
+      if (gfc_option.flag_range_check == 0)
+        retval = ARITH_OK;
+      else
+        retval = ARITH_NAN;
+    }
+  else if (mpfr_sgn (q) == 0)
     retval = ARITH_OK;
   else if (mpfr_cmp (q, gfc_real_kinds[i].huge) > 0)
-    retval = ARITH_OVERFLOW;
+    {
+      if (gfc_option.flag_range_check == 0)
+        retval = ARITH_OK;
+      else
+        retval = ARITH_OVERFLOW;
+    }
   else if (mpfr_cmp (q, gfc_real_kinds[i].subnormal) < 0)
-    retval = ARITH_UNDERFLOW;
+    {
+      if (gfc_option.flag_range_check == 0)
+        retval = ARITH_OK;
+      else
+        retval = ARITH_UNDERFLOW;
+    }
   else if (mpfr_cmp (q, gfc_real_kinds[i].tiny) < 0)
     {
       /* MPFR operates on a numbers with a given precision and enormous
@@ -564,19 +588,29 @@ gfc_range_check (gfc_expr * e)
     case BT_REAL:
       rc = gfc_check_real_range (e->value.real, e->ts.kind);
       if (rc == ARITH_UNDERFLOW)
-        mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
+	mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
+      if (rc == ARITH_OVERFLOW)
+	mpfr_set_inf (e->value.real, mpfr_sgn (e->value.real));
+      if (rc == ARITH_NAN)
+	mpfr_set_nan (e->value.real);
       break;
 
     case BT_COMPLEX:
       rc = gfc_check_real_range (e->value.complex.r, e->ts.kind);
       if (rc == ARITH_UNDERFLOW)
-        mpfr_set_ui (e->value.complex.r, 0, GFC_RND_MODE);
-      if (rc == ARITH_OK || rc == ARITH_UNDERFLOW)
-        {
-          rc = gfc_check_real_range (e->value.complex.i, e->ts.kind);
-          if (rc == ARITH_UNDERFLOW)
-            mpfr_set_ui (e->value.complex.i, 0, GFC_RND_MODE);
-        }
+	mpfr_set_ui (e->value.complex.r, 0, GFC_RND_MODE);
+      if (rc == ARITH_OVERFLOW)
+	mpfr_set_inf (e->value.complex.r, mpfr_sgn (e->value.complex.r));
+      if (rc == ARITH_NAN)
+	mpfr_set_nan (e->value.complex.r);
+
+      rc = gfc_check_real_range (e->value.complex.i, e->ts.kind);
+      if (rc == ARITH_UNDERFLOW)
+	mpfr_set_ui (e->value.complex.i, 0, GFC_RND_MODE);
+      if (rc == ARITH_OVERFLOW)
+	mpfr_set_inf (e->value.complex.i, mpfr_sgn (e->value.complex.i));
+      if (rc == ARITH_NAN)
+	mpfr_set_nan (e->value.complex.i);
 
       break;
 
@@ -813,8 +847,8 @@ gfc_arith_divide (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
       break;
 
     case BT_REAL:
-      /* FIXME: MPFR correctly generates NaN.  This may not be needed.  */
-      if (mpfr_sgn (op2->value.real) == 0)
+      if (mpfr_sgn (op2->value.real) == 0
+	  && gfc_option.flag_range_check == 1)
 	{
 	  rc = ARITH_DIV0;
 	  break;
@@ -825,9 +859,9 @@ gfc_arith_divide (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
       break;
 
     case BT_COMPLEX:
-      /* FIXME: MPFR correctly generates NaN.  This may not be needed.  */
       if (mpfr_sgn (op2->value.complex.r) == 0
-	  && mpfr_sgn (op2->value.complex.i) == 0)
+	  && mpfr_sgn (op2->value.complex.i) == 0
+	  && gfc_option.flag_range_check == 1)
 	{
 	  rc = ARITH_DIV0;
 	  break;
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 6cfd934..834d23f 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1627,6 +1627,7 @@ typedef struct
   int flag_max_stack_var_size;
   int flag_module_access_private;
   int flag_no_backend;
+  int flag_range_check;
   int flag_pack_derived;
   int flag_repack_arrays;
   int flag_preprocessed;
diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi
index aa646c4..7b8036c 100644
--- a/gcc/fortran/invoke.texi
+++ b/gcc/fortran/invoke.texi
@@ -122,7 +122,7 @@ by type.  Explanations are in the following sections.
 -ffixed-line-length-@var{n}  -ffixed-line-length-none @gol
 -ffree-line-length-@var{n}  -ffree-line-length-none @gol
 -fdefault-double-8  -fdefault-integer-8  -fdefault-real-8 @gol
--fcray-pointer  -fopenmp }
+-fcray-pointer  -fopenmp  -frange-check }
 
 @item Warning Options
 @xref{Warning Options,,Options to Request or Suppress Warnings}.
@@ -308,6 +308,15 @@ and @code{c$}, @code{*$} and @code{!$} sentinels in fixed form
 and when linking arranges for the OpenMP runtime library to be linked
 in.
 
+@cindex -frange-check
+@cindex options, -frange-check
+@item -frange-check
+Enable range checking on results of simplification of constant expressions
+during compilation.  For example, by default, @command{gfortran} will give
+an overflow error at compile time when simplifying @code{a = EXP(1000)}.
+With @samp{-fno-range-check}, no error will be given and the variable @code{a}
+will be assigned the value @code{+Infinity}.
+
 @cindex -std=@var{std} option
 @cindex option, -std=@var{std}
 @item -std=@var{std}
diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt
index 439eb02..2857ec8 100644
--- a/gcc/fortran/lang.opt
+++ b/gcc/fortran/lang.opt
@@ -181,6 +181,10 @@ fno-backend
 Fortran RejectNegative
 Don't generate code, just do syntax and semantics checking
 
+frange-check
+Fortran
+Enable range checking during compilation
+
 fpack-derived
 Fortran
 Try to layout derived types as compact as possible
diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c
index 6add2b8..cd550d4 100644
--- a/gcc/fortran/options.c
+++ b/gcc/fortran/options.c
@@ -73,6 +73,7 @@ gfc_init_options (unsigned int argc ATTRIBUTE_UNUSED,
   gfc_option.flag_max_stack_var_size = 32768;
   gfc_option.flag_module_access_private = 0;
   gfc_option.flag_no_backend = 0;
+  gfc_option.flag_range_check = 1;
   gfc_option.flag_pack_derived = 0;
   gfc_option.flag_repack_arrays = 0;
   gfc_option.flag_preprocessed = 0;
@@ -519,6 +520,10 @@ gfc_handle_option (size_t scode, const char *arg, int value)
       gfc_option.flag_no_backend = value;
       break;
 
+    case OPT_frange_check:
+      gfc_option.flag_range_check = value;
+      break;
+
     case OPT_fpack_derived:
       gfc_option.flag_pack_derived = value;
       break;
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index b40d026..f8bf372 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -95,10 +95,29 @@ static int xascii_table[256];
 static gfc_expr *
 range_check (gfc_expr * result, const char *name)
 {
-  if (gfc_range_check (result) == ARITH_OK)
-    return result;
 
-  gfc_error ("Result of %s overflows its kind at %L", name, &result->where);
+  switch (gfc_range_check (result))
+    {
+      case ARITH_OK:
+	return result;
+ 
+      case ARITH_OVERFLOW:
+	gfc_error ("Result of %s overflows its kind at %L", name, &result->where);
+	break;
+
+      case ARITH_UNDERFLOW:
+	gfc_error ("Result of %s underflows its kind at %L", name, &result->where);
+	break;
+
+      case ARITH_NAN:
+	gfc_error ("Result of %s is NaN at %L", name, &result->where);
+	break;
+
+      default:
+	gfc_error ("Result of %s gives range error for its kind at %L", name, &result->where);
+	break;
+    }
+
   gfc_free_expr (result);
   return &gfc_bad_expr;
 }
diff --git a/gcc/fortran/trans-const.c b/gcc/fortran/trans-const.c
index 936dd64..c1c9661 100644
--- a/gcc/fortran/trans-const.c
+++ b/gcc/fortran/trans-const.c
@@ -209,11 +209,31 @@ gfc_conv_mpfr_to_tree (mpfr_t f, int kind)
   mp_exp_t exp;
   char *p, *q;
   int n;
+  REAL_VALUE_TYPE real;
 
   n = gfc_validate_kind (BT_REAL, kind, false);
 
   gcc_assert (gfc_real_kinds[n].radix == 2);
 
+  type = gfc_get_real_type (kind);
+
+  /* Take care of Infinity and NaN.  */
+  if (mpfr_inf_p (f))
+    {
+      real_inf (&real);
+      if (mpfr_sgn (f) < 0)
+	real = REAL_VALUE_NEGATE(real);
+      res = build_real (type , real);
+      return res;
+    }
+
+  if (mpfr_nan_p (f))
+    {
+      real_nan (&real, "", 0, TYPE_MODE (type));
+      res = build_real (type , real);
+      return res;
+    }
+
   /* mpfr chooses too small a number of hexadecimal digits if the
      number of binary digits is not divisible by four, therefore we
      have to explicitly request a sufficient number of digits here.  */
@@ -234,7 +254,6 @@ gfc_conv_mpfr_to_tree (mpfr_t f, int kind)
   else
     sprintf (q, "0x.%sp%d", p, (int) exp);
 
-  type = gfc_get_real_type (kind);
   res = build_real (type, REAL_VALUE_ATOF (q, TYPE_MODE (type)));
 
   gfc_free (q);