Commit 54554825 by Jerry DeLisle

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
parent 37b4da10
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> 2006-06-17 Karl Berry <karl@gnu.org>
* gfortran.texi (@dircategory): Use "Software development" * gfortran.texi (@dircategory): Use "Software development"
......
...@@ -379,12 +379,36 @@ gfc_check_real_range (mpfr_t p, int kind) ...@@ -379,12 +379,36 @@ gfc_check_real_range (mpfr_t p, int kind)
mpfr_init (q); mpfr_init (q);
mpfr_abs (q, p, GFC_RND_MODE); 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; retval = ARITH_OK;
else if (mpfr_cmp (q, gfc_real_kinds[i].huge) > 0) 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) 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) else if (mpfr_cmp (q, gfc_real_kinds[i].tiny) < 0)
{ {
/* MPFR operates on a numbers with a given precision and enormous /* MPFR operates on a numbers with a given precision and enormous
...@@ -564,19 +588,29 @@ gfc_range_check (gfc_expr * e) ...@@ -564,19 +588,29 @@ gfc_range_check (gfc_expr * e)
case BT_REAL: case BT_REAL:
rc = gfc_check_real_range (e->value.real, e->ts.kind); rc = gfc_check_real_range (e->value.real, e->ts.kind);
if (rc == ARITH_UNDERFLOW) 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; break;
case BT_COMPLEX: case BT_COMPLEX:
rc = gfc_check_real_range (e->value.complex.r, e->ts.kind); rc = gfc_check_real_range (e->value.complex.r, e->ts.kind);
if (rc == ARITH_UNDERFLOW) if (rc == ARITH_UNDERFLOW)
mpfr_set_ui (e->value.complex.r, 0, GFC_RND_MODE); mpfr_set_ui (e->value.complex.r, 0, GFC_RND_MODE);
if (rc == ARITH_OK || rc == ARITH_UNDERFLOW) if (rc == ARITH_OVERFLOW)
{ mpfr_set_inf (e->value.complex.r, mpfr_sgn (e->value.complex.r));
rc = gfc_check_real_range (e->value.complex.i, e->ts.kind); if (rc == ARITH_NAN)
if (rc == ARITH_UNDERFLOW) mpfr_set_nan (e->value.complex.r);
mpfr_set_ui (e->value.complex.i, 0, GFC_RND_MODE);
} 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; break;
...@@ -813,8 +847,8 @@ gfc_arith_divide (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp) ...@@ -813,8 +847,8 @@ gfc_arith_divide (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
break; break;
case BT_REAL: 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; rc = ARITH_DIV0;
break; break;
...@@ -825,9 +859,9 @@ gfc_arith_divide (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp) ...@@ -825,9 +859,9 @@ gfc_arith_divide (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp)
break; break;
case BT_COMPLEX: case BT_COMPLEX:
/* FIXME: MPFR correctly generates NaN. This may not be needed. */
if (mpfr_sgn (op2->value.complex.r) == 0 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; rc = ARITH_DIV0;
break; break;
......
...@@ -1627,6 +1627,7 @@ typedef struct ...@@ -1627,6 +1627,7 @@ typedef struct
int flag_max_stack_var_size; int flag_max_stack_var_size;
int flag_module_access_private; int flag_module_access_private;
int flag_no_backend; int flag_no_backend;
int flag_range_check;
int flag_pack_derived; int flag_pack_derived;
int flag_repack_arrays; int flag_repack_arrays;
int flag_preprocessed; int flag_preprocessed;
......
...@@ -122,7 +122,7 @@ by type. Explanations are in the following sections. ...@@ -122,7 +122,7 @@ by type. Explanations are in the following sections.
-ffixed-line-length-@var{n} -ffixed-line-length-none @gol -ffixed-line-length-@var{n} -ffixed-line-length-none @gol
-ffree-line-length-@var{n} -ffree-line-length-none @gol -ffree-line-length-@var{n} -ffree-line-length-none @gol
-fdefault-double-8 -fdefault-integer-8 -fdefault-real-8 @gol -fdefault-double-8 -fdefault-integer-8 -fdefault-real-8 @gol
-fcray-pointer -fopenmp } -fcray-pointer -fopenmp -frange-check }
@item Warning Options @item Warning Options
@xref{Warning Options,,Options to Request or Suppress Warnings}. @xref{Warning Options,,Options to Request or Suppress Warnings}.
...@@ -308,6 +308,15 @@ and @code{c$}, @code{*$} and @code{!$} sentinels in fixed form ...@@ -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 and when linking arranges for the OpenMP runtime library to be linked
in. 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 -std=@var{std} option
@cindex option, -std=@var{std} @cindex option, -std=@var{std}
@item -std=@var{std} @item -std=@var{std}
......
...@@ -181,6 +181,10 @@ fno-backend ...@@ -181,6 +181,10 @@ fno-backend
Fortran RejectNegative Fortran RejectNegative
Don't generate code, just do syntax and semantics checking Don't generate code, just do syntax and semantics checking
frange-check
Fortran
Enable range checking during compilation
fpack-derived fpack-derived
Fortran Fortran
Try to layout derived types as compact as possible Try to layout derived types as compact as possible
......
...@@ -73,6 +73,7 @@ gfc_init_options (unsigned int argc ATTRIBUTE_UNUSED, ...@@ -73,6 +73,7 @@ gfc_init_options (unsigned int argc ATTRIBUTE_UNUSED,
gfc_option.flag_max_stack_var_size = 32768; gfc_option.flag_max_stack_var_size = 32768;
gfc_option.flag_module_access_private = 0; gfc_option.flag_module_access_private = 0;
gfc_option.flag_no_backend = 0; gfc_option.flag_no_backend = 0;
gfc_option.flag_range_check = 1;
gfc_option.flag_pack_derived = 0; gfc_option.flag_pack_derived = 0;
gfc_option.flag_repack_arrays = 0; gfc_option.flag_repack_arrays = 0;
gfc_option.flag_preprocessed = 0; gfc_option.flag_preprocessed = 0;
...@@ -519,6 +520,10 @@ gfc_handle_option (size_t scode, const char *arg, int value) ...@@ -519,6 +520,10 @@ gfc_handle_option (size_t scode, const char *arg, int value)
gfc_option.flag_no_backend = value; gfc_option.flag_no_backend = value;
break; break;
case OPT_frange_check:
gfc_option.flag_range_check = value;
break;
case OPT_fpack_derived: case OPT_fpack_derived:
gfc_option.flag_pack_derived = value; gfc_option.flag_pack_derived = value;
break; break;
......
...@@ -95,10 +95,29 @@ static int xascii_table[256]; ...@@ -95,10 +95,29 @@ static int xascii_table[256];
static gfc_expr * static gfc_expr *
range_check (gfc_expr * result, const char *name) 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); gfc_free_expr (result);
return &gfc_bad_expr; return &gfc_bad_expr;
} }
......
...@@ -209,11 +209,31 @@ gfc_conv_mpfr_to_tree (mpfr_t f, int kind) ...@@ -209,11 +209,31 @@ gfc_conv_mpfr_to_tree (mpfr_t f, int kind)
mp_exp_t exp; mp_exp_t exp;
char *p, *q; char *p, *q;
int n; int n;
REAL_VALUE_TYPE real;
n = gfc_validate_kind (BT_REAL, kind, false); n = gfc_validate_kind (BT_REAL, kind, false);
gcc_assert (gfc_real_kinds[n].radix == 2); 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 /* mpfr chooses too small a number of hexadecimal digits if the
number of binary digits is not divisible by four, therefore we number of binary digits is not divisible by four, therefore we
have to explicitly request a sufficient number of digits here. */ have to explicitly request a sufficient number of digits here. */
...@@ -234,7 +254,6 @@ gfc_conv_mpfr_to_tree (mpfr_t f, int kind) ...@@ -234,7 +254,6 @@ gfc_conv_mpfr_to_tree (mpfr_t f, int kind)
else else
sprintf (q, "0x.%sp%d", p, (int) exp); 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))); res = build_real (type, REAL_VALUE_ATOF (q, TYPE_MODE (type)));
gfc_free (q); gfc_free (q);
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment