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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@114752
138bc75d-0d04-0410-961f-
82ee72b054a4
+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"
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
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;
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;
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;
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;
-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}.
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}
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
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;
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;
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;
}
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. */
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);