OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/31270 (print subscript value and array bounds when out-of-bounds error occurs)

Browse Source 
PR fortran/31270

	* trans.c (gfc_trans_runtime_check): Reorder arguments and
	add extra variable arguments. Hand them to the library function.
	* trans.h (gfc_trans_runtime_check): Update prototype.
	* trans-array.c (gfc_trans_array_bound_check): Issue more
	detailled error messages.
	(gfc_conv_array_ref): Likewise.
	(gfc_conv_ss_startstride): Likewise.
	(gfc_trans_dummy_array_bias): Reorder arguments to
	gfc_trans_runtime_check.
	* trans-expr.c (gfc_conv_substring): Issue more detailled
	error messages.
	(gfc_conv_function_call): Reorder arguments to gfc_trans_runtime_check.
	* trans-stmt.c (gfc_trans_goto): Likewise.
	* trans-io.c (set_string): Reorder arguments to
	gfc_trans_runtime_check and issue a more detailled error message.
	* trans-decl.c (gfc_build_builtin_function_decls): Make
	runtime_error and runtime_error_at handle a variable number of
	arguments.
	* trans-intrinsic.c (gfc_conv_intrinsic_bound): Reorder arguments
	to gfc_trans_runtime_check.
	(gfc_conv_intrinsic_minmax): Likewise.
	(gfc_conv_intrinsic_repeat): Issue more detailled error messages.

	* runtime/error.c (runtime_error_at): Add a variable number of
	arguments.
	* libgfortran.h (runtime_error_at): Update prototype.

From-SVN: r127352
This commit is contained in:
Francois-Xavier Coudert 2007-08-10 22:12:04 +00:00 committed by François-Xavier Coudert
parent ac2610bf42
commit c8fe94c7ea
12 changed files with 169 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
gcc/fortran/ChangeLog
View File

@ -1,3 +1,29 @@
2007-08-10 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
PR fortran/31270
* trans.c (gfc_trans_runtime_check): Reorder arguments and
add extra variable arguments. Hand them to the library function.
* trans.h (gfc_trans_runtime_check): Update prototype.
* trans-array.c (gfc_trans_array_bound_check): Issue more
detailled error messages.
(gfc_conv_array_ref): Likewise.
(gfc_conv_ss_startstride): Likewise.
(gfc_trans_dummy_array_bias): Reorder arguments to
gfc_trans_runtime_check.
* trans-expr.c (gfc_conv_substring): Issue more detailled
error messages.
(gfc_conv_function_call): Reorder arguments to gfc_trans_runtime_check.
* trans-stmt.c (gfc_trans_goto): Likewise.
* trans-io.c (set_string): Reorder arguments to
gfc_trans_runtime_check and issue a more detailled error message.
* trans-decl.c (gfc_build_builtin_function_decls): Make
runtime_error and runtime_error_at handle a variable number of
arguments.
* trans-intrinsic.c (gfc_conv_intrinsic_bound): Reorder arguments
to gfc_trans_runtime_check.
(gfc_conv_intrinsic_minmax): Likewise.
(gfc_conv_intrinsic_repeat): Issue more detailled error messages.
2007-08-10 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
* gfortranspec.c (lang_specific_driver): Use CONST_CAST.

84
gcc/fortran/trans-array.c
View File

@ -2097,9 +2097,11 @@ gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
asprintf (&msg, "%s for array '%s', lower bound of dimension %d exceeded",
gfc_msg_fault, name, n+1);
else
asprintf (&msg, "%s, lower bound of dimension %d exceeded",
gfc_msg_fault, n+1);
gfc_trans_runtime_check (fault, msg, &se->pre, where);
asprintf (&msg, "%s, lower bound of dimension %d exceeded, %%ld is "
"smaller than %%ld", gfc_msg_fault, n+1);
gfc_trans_runtime_check (fault, &se->pre, where, msg,
fold_convert (long_integer_type_node, index),
fold_convert (long_integer_type_node, tmp));
gfc_free (msg);
/* Check upper bound. */
@ -2111,9 +2113,11 @@ gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
asprintf (&msg, "%s for array '%s', upper bound of dimension %d "
" exceeded", gfc_msg_fault, name, n+1);
else
asprintf (&msg, "%s, upper bound of dimension %d exceeded",
gfc_msg_fault, n+1);
gfc_trans_runtime_check (fault, msg, &se->pre, where);
asprintf (&msg, "%s, upper bound of dimension %d exceeded, %%ld is "
"larger than %%ld", gfc_msg_fault, n+1);
gfc_trans_runtime_check (fault, &se->pre, where, msg,
fold_convert (long_integer_type_node, index),
fold_convert (long_integer_type_node, tmp));
gfc_free (msg);
}
@ -2300,9 +2304,12 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
cond = fold_build2 (LT_EXPR, boolean_type_node,
indexse.expr, tmp);
asprintf (&msg, "%s for array '%s', "
"lower bound of dimension %d exceeded", gfc_msg_fault,
sym->name, n+1);
gfc_trans_runtime_check (cond, msg, &se->pre, where);
"lower bound of dimension %d exceeded, %%ld is smaller "
"than %%ld", gfc_msg_fault, sym->name, n+1);
gfc_trans_runtime_check (cond, &se->pre, where, msg,
fold_convert (long_integer_type_node,
indexse.expr),
fold_convert (long_integer_type_node, tmp));
gfc_free (msg);
/* Upper bound, but not for the last dimension of assumed-size
@ -2314,9 +2321,12 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
cond = fold_build2 (GT_EXPR, boolean_type_node,
indexse.expr, tmp);
asprintf (&msg, "%s for array '%s', "
"upper bound of dimension %d exceeded", gfc_msg_fault,
sym->name, n+1);
gfc_trans_runtime_check (cond, msg, &se->pre, where);
"upper bound of dimension %d exceeded, %%ld is "
"greater than %%ld", gfc_msg_fault, sym->name, n+1);
gfc_trans_runtime_check (cond, &se->pre, where, msg,
fold_convert (long_integer_type_node,
indexse.expr),
fold_convert (long_integer_type_node, tmp));
gfc_free (msg);
}
}
@ -2872,7 +2882,7 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
asprintf (&msg, "Zero stride is not allowed, for dimension %d "
"of array '%s'", info->dim[n]+1,
ss->expr->symtree->name);
gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
gfc_trans_runtime_check (tmp, &block, &ss->expr->where, msg);
gfc_free (msg);
desc = ss->data.info.descriptor;
@ -2912,9 +2922,13 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
non_zerosized, tmp);
asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
" exceeded", gfc_msg_fault, info->dim[n]+1,
ss->expr->symtree->name);
gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
" exceeded, %%ld is smaller than %%ld", gfc_msg_fault,
info->dim[n]+1, ss->expr->symtree->name);
gfc_trans_runtime_check (tmp, &block, &ss->expr->where, msg,
fold_convert (long_integer_type_node,
info->start[n]),
fold_convert (long_integer_type_node,
lbound));
gfc_free (msg);
if (check_upper)
@ -2924,9 +2938,12 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
non_zerosized, tmp);
asprintf (&msg, "%s, upper bound of dimension %d of array "
"'%s' exceeded", gfc_msg_fault, info->dim[n]+1,
"'%s' exceeded, %%ld is greater than %%ld",
gfc_msg_fault, info->dim[n]+1,
ss->expr->symtree->name);
gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
gfc_trans_runtime_check (tmp, &block, &ss->expr->where, msg,
fold_convert (long_integer_type_node, info->start[n]),
fold_convert (long_integer_type_node, ubound));
gfc_free (msg);
}
@ -2944,9 +2961,13 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
non_zerosized, tmp);
asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
" exceeded", gfc_msg_fault, info->dim[n]+1,
ss->expr->symtree->name);
gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
" exceeded, %%ld is smaller than %%ld", gfc_msg_fault,
info->dim[n]+1, ss->expr->symtree->name);
gfc_trans_runtime_check (tmp, &block, &ss->expr->where, msg,
fold_convert (long_integer_type_node,
tmp2),
fold_convert (long_integer_type_node,
lbound));
gfc_free (msg);
if (check_upper)
@ -2955,9 +2976,12 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
non_zerosized, tmp);
asprintf (&msg, "%s, upper bound of dimension %d of array "
"'%s' exceeded", gfc_msg_fault, info->dim[n]+1,
"'%s' exceeded, %%ld is greater than %%ld",
gfc_msg_fault, info->dim[n]+1,
ss->expr->symtree->name);
gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
gfc_trans_runtime_check (tmp, &block, &ss->expr->where, msg,
fold_convert (long_integer_type_node, tmp2),
fold_convert (long_integer_type_node, ubound));
gfc_free (msg);
}
@ -2970,12 +2994,14 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
others against this. */
if (size[n])
{
tmp =
fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
tree tmp3
= fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
asprintf (&msg, "%s, size mismatch for dimension %d "
"of array '%s'", gfc_msg_bounds, info->dim[n]+1,
ss->expr->symtree->name);
gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
"of array '%s' (%%ld/%%ld)", gfc_msg_bounds,
info->dim[n]+1, ss->expr->symtree->name);
gfc_trans_runtime_check (tmp3, &block, &ss->expr->where, msg,
fold_convert (long_integer_type_node, tmp),
fold_convert (long_integer_type_node, size[n]));
gfc_free (msg);
}
else
@ -4194,7 +4220,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2);
asprintf (&msg, "%s for dimension %d of array '%s'",
gfc_msg_bounds, n+1, sym->name);
gfc_trans_runtime_check (tmp, msg, &block, &loc);
gfc_trans_runtime_check (tmp, &block, &loc, msg);
gfc_free (msg);
}
}

4
gcc/fortran/trans-decl.c
View File

@ -2340,13 +2340,13 @@ gfc_build_builtin_function_decls (void)
gfor_fndecl_runtime_error =
gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
void_type_node, 1, pchar_type_node);
void_type_node, -1, pchar_type_node);
/* The runtime_error function does not return. */
TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
gfor_fndecl_runtime_error_at =
gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error_at")),
void_type_node, 2, pchar_type_node,
void_type_node, -2, pchar_type_node,
pchar_type_node);
/* The runtime_error_at function does not return. */
TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;

23
gcc/fortran/trans-expr.c
View File

@ -296,12 +296,14 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
nonempty, fault);
if (name)
asprintf (&msg, "Substring out of bounds: lower bound of '%s' "
asprintf (&msg, "Substring out of bounds: lower bound (%%ld) of '%s' "
"is less than one", name);
else
asprintf (&msg, "Substring out of bounds: lower bound "
asprintf (&msg, "Substring out of bounds: lower bound (%%ld)"
"is less than one");
gfc_trans_runtime_check (fault, msg, &se->pre, where);
gfc_trans_runtime_check (fault, &se->pre, where, msg,
fold_convert (long_integer_type_node,
start.expr));
gfc_free (msg);
/* Check upper bound. */
@ -310,12 +312,15 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
nonempty, fault);
if (name)
asprintf (&msg, "Substring out of bounds: upper bound of '%s' "
"exceeds string length", name);
asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' "
"exceeds string length (%%ld)", name);
else
asprintf (&msg, "Substring out of bounds: upper bound "
"exceeds string length");
gfc_trans_runtime_check (fault, msg, &se->pre, where);
asprintf (&msg, "Substring out of bounds: upper bound (%%ld) "
"exceeds string length (%%ld)");
gfc_trans_runtime_check (fault, &se->pre, where, msg,
fold_convert (long_integer_type_node, end.expr),
fold_convert (long_integer_type_node,
se->string_length));
gfc_free (msg);
}
@ -2589,7 +2594,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
tmp = gfc_conv_descriptor_data_get (info->descriptor);
tmp = fold_build2 (NE_EXPR, boolean_type_node,
tmp, info->data);
gfc_trans_runtime_check (tmp, gfc_msg_fault, &se->pre, NULL);
gfc_trans_runtime_check (tmp, &se->pre, NULL, gfc_msg_fault);
}
se->expr = info->descriptor;
/* Bundle in the string length. */

19
gcc/fortran/trans-intrinsic.c
View File

@ -855,7 +855,7 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp);
cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp);
gfc_trans_runtime_check (cond, gfc_msg_fault, &se->pre, &expr->where);
gfc_trans_runtime_check (cond, &se->pre, &expr->where, gfc_msg_fault);
}
}
@ -1485,7 +1485,7 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op)
expr->symtree->n.sym->name);
cond = build2 (EQ_EXPR, boolean_type_node, TREE_OPERAND (args[0], 0),
build_int_cst (TREE_TYPE (TREE_OPERAND (args[0], 0)), 0));
gfc_trans_runtime_check (cond, msg, &se->pre, &expr->where);
gfc_trans_runtime_check (cond, &se->pre, &expr->where, msg);
gfc_free (msg);
}
@ -1501,7 +1501,7 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op)
expr->symtree->n.sym->name);
cond = build2 (EQ_EXPR, boolean_type_node, TREE_OPERAND (args[1], 0),
build_int_cst (TREE_TYPE (TREE_OPERAND (args[1], 0)), 0));
gfc_trans_runtime_check (cond, msg, &se->pre, &expr->where);
gfc_trans_runtime_check (cond, &se->pre, &expr->where, msg);
gfc_free (msg);
}
@ -3665,9 +3665,10 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
/* Check that NCOPIES is not negative. */
cond = fold_build2 (LT_EXPR, boolean_type_node, ncopies,
build_int_cst (ncopies_type, 0));
gfc_trans_runtime_check (cond,
"Argument NCOPIES of REPEAT intrinsic is negative",
&se->pre, &expr->where);
gfc_trans_runtime_check (cond, &se->pre, &expr->where,
"Argument NCOPIES of REPEAT intrinsic is negative "
"(its value is %lld)",
fold_convert (long_integer_type_node, ncopies));
/* If the source length is zero, any non negative value of NCOPIES
is valid, and nothing happens. */
@ -3696,9 +3697,9 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
build_int_cst (size_type_node, 0));
cond = fold_build3 (COND_EXPR, boolean_type_node, tmp, boolean_false_node,
cond);
gfc_trans_runtime_check (cond,
"Argument NCOPIES of REPEAT intrinsic is too large",
&se->pre, &expr->where);
gfc_trans_runtime_check (cond, &se->pre, &expr->where,
"Argument NCOPIES of REPEAT intrinsic is too large");
/* Compute the destination length. */
dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node,

12
gcc/fortran/trans-io.c
View File

@ -653,15 +653,17 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
if (e->ts.type == BT_INTEGER && e->symtree->n.sym->attr.assign == 1)
{
char * msg;
tree cond;
gfc_conv_label_variable (&se, e);
tmp = GFC_DECL_STRING_LEN (se.expr);
tmp = fold_build2 (LT_EXPR, boolean_type_node,
tmp, build_int_cst (TREE_TYPE (tmp), 0));
cond = fold_build2 (LT_EXPR, boolean_type_node,
tmp, build_int_cst (TREE_TYPE (tmp), 0));
asprintf(&msg, "Label assigned to variable '%s' is not a format label",
e->symtree->name);
gfc_trans_runtime_check (tmp, msg, &se.pre, &e->where);
asprintf(&msg, "Label assigned to variable '%s' (%%ld) is not a format "
"label", e->symtree->name);
gfc_trans_runtime_check (cond, &se.pre, &e->where, msg,
fold_convert (long_integer_type_node, tmp));
gfc_free (msg);
gfc_add_modify_expr (&se.pre, io,

8
gcc/fortran/trans-stmt.c
View File

@ -153,8 +153,8 @@ gfc_trans_goto (gfc_code * code)
tmp = GFC_DECL_STRING_LEN (se.expr);
tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
build_int_cst (TREE_TYPE (tmp), -1));
gfc_trans_runtime_check (tmp, "Assigned label is not a target label",
&se.pre, &loc);
gfc_trans_runtime_check (tmp, &se.pre, &loc,
"Assigned label is not a target label");
assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr);
@ -179,8 +179,8 @@ gfc_trans_goto (gfc_code * code)
code = code->block;
}
while (code != NULL);
gfc_trans_runtime_check (boolean_true_node,
"Assigned label is not in the list", &se.pre, &loc);
gfc_trans_runtime_check (boolean_true_node, &se.pre, &loc,
"Assigned label is not in the list");
return gfc_finish_block (&se.pre);
}

37
gcc/fortran/trans.c
View File

@ -320,19 +320,32 @@ gfc_build_array_ref (tree base, tree offset)
/* Generate a runtime error if COND is true. */
void
gfc_trans_runtime_check (tree cond, const char * msgid, stmtblock_t * pblock,
locus * where)
gfc_trans_runtime_check (tree cond, stmtblock_t * pblock, locus * where,
const char * msgid, ...)
{
va_list ap;
stmtblock_t block;
tree body;
tree tmp;
tree arg, arg2;
tree *argarray;
tree fntype;
char *message;
int line;
const char *p;
int line, nargs, i;
if (integer_zerop (cond))
return;
/* Compute the number of extra arguments from the format string. */
for (p = msgid, nargs = 0; *p; p++)
if (*p == '%')
{
p++;
if (*p != '%')
nargs++;
}
/* The code to generate the error. */
gfc_start_block (&block);
@ -357,7 +370,23 @@ gfc_trans_runtime_check (tree cond, const char * msgid, stmtblock_t * pblock,
arg2 = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const(message));
gfc_free(message);
tmp = build_call_expr (gfor_fndecl_runtime_error_at, 2, arg, arg2);
/* Build the argument array. */
argarray = (tree *) alloca (sizeof (tree) * (nargs + 2));
argarray[0] = arg;
argarray[1] = arg2;
va_start (ap, msgid);
for (i = 0; i < nargs; i++)
argarray[2+i] = va_arg (ap, tree);
va_end (ap);
/* Build the function call to runtime_error_at; because of the variable
number of arguments, we can't use build_call_expr directly. */
fntype = TREE_TYPE (gfor_fndecl_runtime_error_at);
tmp = fold_builtin_call_array (TREE_TYPE (fntype),
build1 (ADDR_EXPR,
build_pointer_type (fntype),
gfor_fndecl_runtime_error_at),
nargs + 2, argarray);
gfc_add_expr_to_block (&block, tmp);
body = gfc_finish_block (&block);

2
gcc/fortran/trans.h
View File

@ -442,7 +442,7 @@ void gfc_generate_constructors (void);
bool get_array_ctor_strlen (stmtblock_t *, gfc_constructor *, tree *);
/* Generate a runtime error check. */
void gfc_trans_runtime_check (tree, const char *, stmtblock_t *, locus *);
void gfc_trans_runtime_check (tree, stmtblock_t *, locus *, const char *, ...);
/* Generate a call to free() after checking that its arg is non-NULL. */
tree gfc_call_free (tree);

7
libgfortran/ChangeLog
View File

@ -1,3 +1,10 @@
2007-08-10 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
PR fortran/31270
* runtime/error.c (runtime_error_at): Add a variable number of
arguments.
* libgfortran.h (runtime_error_at): Update prototype.
2007-08-10 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
PR fortran/32933

4
libgfortran/libgfortran.h
View File

@ -599,8 +599,8 @@ extern void runtime_error (const char *, ...)
__attribute__ ((noreturn, format (printf, 1, 2)));
iexport_proto(runtime_error);
extern void runtime_error_at (const char *, const char *)
__attribute__ ((noreturn));
extern void runtime_error_at (const char *, const char *, ...)
__attribute__ ((noreturn, format (printf, 2, 3)));
iexport_proto(runtime_error_at);
extern void internal_error (st_parameter_common *, const char *)

10
libgfortran/runtime/error.c
View File

@ -267,11 +267,17 @@ iexport(runtime_error);
* run time error generated by the front end compiler. */
void
runtime_error_at (const char *where, const char *message)
runtime_error_at (const char *where, const char *message, ...)
{
va_list ap;
recursion_check ();
st_printf ("%s\n", where);
st_printf ("Fortran runtime error: %s\n", message);
st_printf ("Fortran runtime error: ");
va_start (ap, message);
st_vprintf (message, ap);
va_end (ap);
st_printf ("\n");
sys_exit (2);
}
iexport(runtime_error_at);