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

trans.c (gfc_msg_bounds, [...]): Add strings for common runtime error messages.

Browse Source 
* trans.c (gfc_msg_bounds, gfc_msg_fault, gfc_msg_wrong_return):
	Add strings for common runtime error messages.
	(gfc_trans_runtime_check): Add a locus argument, use a string
	and not a string tree for the message.
	* trans.h (gfc_trans_runtime_check): Change prototype accordingly.
	(gfc_msg_bounds, gfc_msg_fault, gfc_msg_wrong_return): Add proto.
	* trans-const.c (gfc_strconst_bounds, gfc_strconst_fault,
	gfc_strconst_wrong_return, gfc_strconst_current_filename): Remove.
	(gfc_init_constants): Likewise.
	* trans-const.h: Likewise.
	* trans-decl.c (gfc_build_builtin_function_decls): Call to
	_gfortran_runtime_error has only one argument, the message string.
	* trans-array.h (gfc_conv_array_ref): Add a symbol argument and a
	locus.
	* trans-array.c (gfc_trans_array_bound_check): Build precise
	error messages.
	(gfc_conv_array_ref): Use the new symbol argument and the locus
	to build more precise error messages.
	(gfc_conv_ss_startstride): More precise error messages.
	* trans-expr.c (gfc_conv_variable): Give symbol reference and
	locus to gfc_conv_array_ref.
	(gfc_conv_function_call): Use the new prototype for
	gfc_trans_runtime_check.
	* trans-stmt.c (gfc_trans_goto): Build more precise error message.
	* trans-io.c (set_string): Likewise.
	* trans-intrinsic.c (gfc_conv_intrinsic_bound): Use new prototype
	for gfc_trans_runtime_check.

From-SVN: r114346
This commit is contained in:
Francois-Xavier Coudert 2006-06-03 19:28:33 +02:00 committed by François-Xavier Coudert
parent 4f3d90548b
commit dd18a33bd9
12 changed files with 137 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
gcc/fortran/ChangeLog
View File

@ -1,3 +1,33 @@
2006-06-03 Francois-Xavier Coudert <coudert@clipper.ens.fr>
* trans.c (gfc_msg_bounds, gfc_msg_fault, gfc_msg_wrong_return):
Add strings for common runtime error messages.
(gfc_trans_runtime_check): Add a locus argument, use a string
and not a string tree for the message.
* trans.h (gfc_trans_runtime_check): Change prototype accordingly.
(gfc_msg_bounds, gfc_msg_fault, gfc_msg_wrong_return): Add proto.
* trans-const.c (gfc_strconst_bounds, gfc_strconst_fault,
gfc_strconst_wrong_return, gfc_strconst_current_filename): Remove.
(gfc_init_constants): Likewise.
* trans-const.h: Likewise.
* trans-decl.c (gfc_build_builtin_function_decls): Call to
_gfortran_runtime_error has only one argument, the message string.
* trans-array.h (gfc_conv_array_ref): Add a symbol argument and a
locus.
* trans-array.c (gfc_trans_array_bound_check): Build precise
error messages.
(gfc_conv_array_ref): Use the new symbol argument and the locus
to build more precise error messages.
(gfc_conv_ss_startstride): More precise error messages.
* trans-expr.c (gfc_conv_variable): Give symbol reference and
locus to gfc_conv_array_ref.
(gfc_conv_function_call): Use the new prototype for
gfc_trans_runtime_check.
* trans-stmt.c (gfc_trans_goto): Build more precise error message.
* trans-io.c (set_string): Likewise.
* trans-intrinsic.c (gfc_conv_intrinsic_bound): Use new prototype
for gfc_trans_runtime_check.
2006-06-01 Thomas Koenig <Thomas.Koenig@online.de>
PR fortran/27715

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

@ -1767,23 +1767,40 @@ gfc_conv_array_ubound (tree descriptor, int dim)
static tree
gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n)
{
tree cond;
tree fault;
tree tmp;
char *msg;
if (!flag_bounds_check)
return index;
index = gfc_evaluate_now (index, &se->pre);
/* Check lower bound. */
tmp = gfc_conv_array_lbound (descriptor, n);
fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp);
if (se->ss)
asprintf (&msg, "%s for array '%s', lower bound of dimension %d exceeded",
gfc_msg_fault, se->ss->expr->symtree->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,
(se->ss ? &se->ss->expr->where : NULL));
gfc_free (msg);
/* Check upper bound. */
tmp = gfc_conv_array_ubound (descriptor, n);
cond = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
gfc_trans_runtime_check (fault, gfc_strconst_fault, &se->pre);
fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
if (se->ss)
asprintf (&msg, "%s for array '%s', upper bound of dimension %d exceeded",
gfc_msg_fault, se->ss->expr->symtree->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,
(se->ss ? &se->ss->expr->where : NULL));
gfc_free (msg);
return index;
}
@ -1919,13 +1936,13 @@ gfc_conv_tmp_array_ref (gfc_se * se)
a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
void
gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar)
gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
locus * where)
{
int n;
tree index;
tree tmp;
tree stride;
tree fault;
gfc_se indexse;
/* Handle scalarized references separately. */
@ -1938,8 +1955,6 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar)
index = gfc_index_zero_node;
fault = gfc_index_zero_node;
/* Calculate the offsets from all the dimensions. */
for (n = 0; n < ar->dimen; n++)
{
@ -1953,20 +1968,27 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar)
{
/* Check array bounds. */
tree cond;
char *msg;
indexse.expr = gfc_evaluate_now (indexse.expr, &se->pre);
tmp = gfc_conv_array_lbound (se->expr, n);
cond = fold_build2 (LT_EXPR, boolean_type_node,
indexse.expr, tmp);
fault =
fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
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);
gfc_free (msg);
tmp = gfc_conv_array_ubound (se->expr, n);
cond = fold_build2 (GT_EXPR, boolean_type_node,
indexse.expr, tmp);
fault =
fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond);
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);
gfc_free (msg);
}
/* Multiply the index by the stride. */
@ -1978,9 +2000,6 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar)
index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
}
if (flag_bounds_check)
gfc_trans_runtime_check (fault, gfc_strconst_fault, &se->pre);
tmp = gfc_conv_array_offset (se->expr);
if (!integer_zerop (tmp))
index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
@ -2457,16 +2476,15 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
if (flag_bounds_check)
{
stmtblock_t block;
tree fault;
tree bound;
tree end;
tree size[GFC_MAX_DIMENSIONS];
gfc_ss_info *info;
char *msg;
int dim;
gfc_start_block (&block);
fault = boolean_false_node;
for (n = 0; n < loop->dimen; n++)
size[n] = NULL_TREE;
@ -2492,15 +2510,21 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
bound = gfc_conv_array_lbound (desc, dim);
tmp = info->start[n];
tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp, bound);
fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault,
tmp);
asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
" exceeded", gfc_msg_bounds, n+1,
ss->expr->symtree->name);
gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
gfc_free (msg);
/* Check the upper bound. */
bound = gfc_conv_array_ubound (desc, dim);
end = gfc_conv_section_upper_bound (ss, n, &block);
tmp = fold_build2 (GT_EXPR, boolean_type_node, end, bound);
fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault,
tmp);
asprintf (&msg, "%s, upper bound of dimension %d of array '%s'"
" exceeded", gfc_msg_bounds, n+1,
ss->expr->symtree->name);
gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
gfc_free (msg);
/* Check the section sizes match. */
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
@ -2513,14 +2537,16 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
{
tmp =
fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
fault =
build2 (TRUTH_OR_EXPR, boolean_type_node, fault, tmp);
asprintf (&msg, "%s, size mismatch for dimension %d "
"of array '%s'", gfc_msg_bounds, n+1,
ss->expr->symtree->name);
gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
gfc_free (msg);
}
else
size[n] = gfc_evaluate_now (tmp, &block);
}
}
gfc_trans_runtime_check (fault, gfc_strconst_bounds, &block);
tmp = gfc_finish_block (&block);
gfc_add_expr_to_block (&loop->pre, tmp);
@ -3709,13 +3735,17 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
if (checkparm)
{
/* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
char * msg;
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
ubound, lbound);
stride2 = build2 (MINUS_EXPR, gfc_array_index_type,
dubound, dlbound);
tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2);
gfc_trans_runtime_check (tmp, gfc_strconst_bounds, &block);
asprintf (&msg, "%s for dimension %d of array '%s'",
gfc_msg_bounds, n+1, sym->name);
gfc_trans_runtime_check (tmp, msg, &block, NULL);
gfc_free (msg);
}
}
else

2
gcc/fortran/trans-array.h
View File

@ -86,7 +86,7 @@ void gfc_conv_resolve_dependencies (gfc_loopinfo *, gfc_ss *, gfc_ss *);
tree gfc_build_null_descriptor (tree);
/* Get a single array element. */
void gfc_conv_array_ref (gfc_se *, gfc_array_ref *);
void gfc_conv_array_ref (gfc_se *, gfc_array_ref *, gfc_symbol *, locus *);
/* Translate a reference to a temporary array. */
void gfc_conv_tmp_array_ref (gfc_se * se);
/* Translate a reference to an array temporary. */

17
gcc/fortran/trans-const.c
View File

@ -33,12 +33,6 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
#include "trans-const.h"
#include "trans-types.h"
/* String constants. */
tree gfc_strconst_bounds;
tree gfc_strconst_fault;
tree gfc_strconst_wrong_return;
tree gfc_strconst_current_filename;
tree gfc_rank_cst[GFC_MAX_DIMENSIONS + 1];
/* Build a constant with given type from an int_cst. */
@ -154,17 +148,6 @@ gfc_init_constants (void)
for (n = 0; n <= GFC_MAX_DIMENSIONS; n++)
gfc_rank_cst[n] = build_int_cst (gfc_array_index_type, n);
gfc_strconst_bounds = gfc_build_cstring_const ("Array bound mismatch");
gfc_strconst_fault =
gfc_build_cstring_const ("Array reference out of bounds");
gfc_strconst_wrong_return =
gfc_build_cstring_const ("Incorrect function return value");
gfc_strconst_current_filename =
gfc_build_cstring_const (gfc_source_file);
}
/* Converts a GMP integer into a backend tree node. */

6
gcc/fortran/trans-const.h
View File

@ -49,12 +49,6 @@ void gfc_init_constants (void);
/* Build a constant with given type from an int_cst. */
tree gfc_build_const (tree, tree);
/* String constants. */
extern GTY(()) tree gfc_strconst_current_filename;
extern GTY(()) tree gfc_strconst_bounds;
extern GTY(()) tree gfc_strconst_fault;
extern GTY(()) tree gfc_strconst_wrong_return;
/* Integer constants 0..GFC_MAX_DIMENSIONS. */
extern GTY(()) tree gfc_rank_cst[GFC_MAX_DIMENSIONS + 1];

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

@ -2275,10 +2275,7 @@ gfc_build_builtin_function_decls (void)
gfor_fndecl_runtime_error =
gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
void_type_node,
3,
pchar_type_node, pchar_type_node,
gfc_int4_type_node);
void_type_node, 1, pchar_type_node);
/* The runtime_error function does not return. */
TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;

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

@ -472,7 +472,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
&& ref->next == NULL && (se->descriptor_only))
return;
gfc_conv_array_ref (se, &ref->u.ar);
gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
/* Return a pointer to an element. */
break;
@ -2153,7 +2153,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_strconst_fault, &se->pre);
gfc_trans_runtime_check (tmp, gfc_msg_fault, &se->pre, NULL);
}
se->expr = info->descriptor;
/* Bundle in the string length. */

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

@ -761,7 +761,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_strconst_fault, &se->pre);
gfc_trans_runtime_check (cond, gfc_msg_fault, &se->pre, NULL);
}
}

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

@ -518,7 +518,6 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
{
gfc_se se;
tree tmp;
tree msg;
tree io;
tree len;
gfc_st_parameter_field *p = &st_parameter_field[type];
@ -536,13 +535,18 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
/* Integer variable assigned a format label. */
if (e->ts.type == BT_INTEGER && e->symtree->n.sym->attr.assign == 1)
{
char * msg;
gfc_conv_label_variable (&se, e);
msg =
gfc_build_cstring_const ("Assigned label is not a format label");
tmp = GFC_DECL_STRING_LEN (se.expr);
tmp = fold_build2 (LT_EXPR, boolean_type_node,
tmp, build_int_cst (TREE_TYPE (tmp), 0));
gfc_trans_runtime_check (tmp, msg, &se.pre);
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);
gfc_free (msg);
gfc_add_modify_expr (&se.pre, io,
fold_convert (TREE_TYPE (io), GFC_DECL_ASSIGN_ADDR (se.expr)));
gfc_add_modify_expr (&se.pre, len, GFC_DECL_STRING_LEN (se.expr));

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

@ -31,6 +31,7 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
#include "toplev.h"
#include "real.h"
#include "gfortran.h"
#include "flags.h"
#include "trans.h"
#include "trans-stmt.h"
#include "trans-types.h"
@ -139,14 +140,12 @@ gfc_trans_label_assign (gfc_code * code)
tree
gfc_trans_goto (gfc_code * code)
{
locus loc = code->loc;
tree assigned_goto;
tree target;
tree tmp;
tree assign_error;
tree range_error;
gfc_se se;
if (code->label != NULL)
return build1_v (GOTO_EXPR, gfc_get_label_decl (code->label));
@ -154,12 +153,11 @@ gfc_trans_goto (gfc_code * code)
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
gfc_conv_label_variable (&se, code->expr);
assign_error =
gfc_build_cstring_const ("Assigned label is not a target label");
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, assign_error, &se.pre);
gfc_trans_runtime_check (tmp, "Assigned label is not a target label",
&se.pre, &loc);
assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr);
@ -172,8 +170,6 @@ gfc_trans_goto (gfc_code * code)
}
/* Check the label list. */
range_error = gfc_build_cstring_const ("Assigned label is not in the list");
do
{
target = gfc_get_label_decl (code->label);
@ -186,7 +182,9 @@ gfc_trans_goto (gfc_code * code)
code = code->block;
}
while (code != NULL);
gfc_trans_runtime_check (boolean_true_node, range_error, &se.pre);
gfc_trans_runtime_check (boolean_true_node,
"Assigned label is not in the list", &se.pre, &loc);
return gfc_finish_block (&se.pre);
}

34
gcc/fortran/trans.c
View File

@ -46,6 +46,10 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
static gfc_file *gfc_current_backend_file;
char gfc_msg_bounds[] = N_("Array bound mismatch");
char gfc_msg_fault[] = N_("Array reference out of bounds");
char gfc_msg_wrong_return[] = N_("Incorrect function return value");
/* Advance along TREE_CHAIN n times. */
@ -302,12 +306,15 @@ gfc_build_array_ref (tree base, tree offset)
/* Generate a runtime error if COND is true. */
void
gfc_trans_runtime_check (tree cond, tree msg, stmtblock_t * pblock)
gfc_trans_runtime_check (tree cond, const char * msgid, stmtblock_t * pblock,
locus * where)
{
stmtblock_t block;
tree body;
tree tmp;
tree args;
char * message;
int line;
if (integer_zerop (cond))
return;
@ -315,19 +322,24 @@ gfc_trans_runtime_check (tree cond, tree msg, stmtblock_t * pblock)
/* The code to generate the error. */
gfc_start_block (&block);
gcc_assert (TREE_CODE (msg) == STRING_CST);
if (where)
{
#ifdef USE_MAPPED_LOCATION
line = LOCATION_LINE (where->lb->location);
#else
line = where->lb->linenum;
#endif
asprintf (&message, "%s (in file '%s', at line %d)", _(msgid),
where->lb->file->filename, line);
}
else
asprintf (&message, "%s (in file '%s', around line %d)", _(msgid),
gfc_source_file, input_line + 1);
TREE_USED (msg) = 1;
tmp = gfc_build_addr_expr (pchar_type_node, msg);
tmp = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const(message));
gfc_free(message);
args = gfc_chainon_list (NULL_TREE, tmp);
tmp = gfc_build_addr_expr (pchar_type_node, gfc_strconst_current_filename);
args = gfc_chainon_list (args, tmp);
tmp = build_int_cst (NULL_TREE, input_line);
args = gfc_chainon_list (args, tmp);
tmp = build_function_call_expr (gfor_fndecl_runtime_error, args);
gfc_add_expr_to_block (&block, tmp);

9
gcc/fortran/trans.h
View File

@ -423,7 +423,7 @@ void gfc_generate_constructors (void);
bool get_array_ctor_strlen (gfc_constructor *, tree *);
/* Generate a runtime error check. */
void gfc_trans_runtime_check (tree, tree, stmtblock_t *);
void gfc_trans_runtime_check (tree, const char *, stmtblock_t *, locus *);
/* Generate code for an assignment, includes scalarization. */
tree gfc_trans_assignment (gfc_expr *, gfc_expr *);
@ -674,4 +674,11 @@ void gfc_finish_interface_mapping (gfc_interface_mapping *,
void gfc_apply_interface_mapping (gfc_interface_mapping *,
gfc_se *, gfc_expr *);
/* Standard error messages used in all the trans-*.c files. */
extern char gfc_msg_bounds[];
extern char gfc_msg_fault[];
extern char gfc_msg_wrong_return[];
#endif /* GFC_TRANS_H */