Commit dd18a33b by Francois-Xavier Coudert Committed by François-Xavier Coudert

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

	* 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
parent 4f3d9054
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> 2006-06-01 Thomas Koenig <Thomas.Koenig@online.de>
PR fortran/27715 PR fortran/27715
......
...@@ -1767,23 +1767,40 @@ gfc_conv_array_ubound (tree descriptor, int dim) ...@@ -1767,23 +1767,40 @@ gfc_conv_array_ubound (tree descriptor, int dim)
static tree static tree
gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n) gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n)
{ {
tree cond;
tree fault; tree fault;
tree tmp; tree tmp;
char *msg;
if (!flag_bounds_check) if (!flag_bounds_check)
return index; return index;
index = gfc_evaluate_now (index, &se->pre); index = gfc_evaluate_now (index, &se->pre);
/* Check lower bound. */ /* Check lower bound. */
tmp = gfc_conv_array_lbound (descriptor, n); tmp = gfc_conv_array_lbound (descriptor, n);
fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp); 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. */ /* Check upper bound. */
tmp = gfc_conv_array_ubound (descriptor, n); tmp = gfc_conv_array_ubound (descriptor, n);
cond = fold_build2 (GT_EXPR, boolean_type_node, index, tmp); fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond); if (se->ss)
asprintf (&msg, "%s for array '%s', upper bound of dimension %d exceeded",
gfc_trans_runtime_check (fault, gfc_strconst_fault, &se->pre); 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; return index;
} }
...@@ -1919,13 +1936,13 @@ gfc_conv_tmp_array_ref (gfc_se * se) ...@@ -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]]*/ a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
void 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; int n;
tree index; tree index;
tree tmp; tree tmp;
tree stride; tree stride;
tree fault;
gfc_se indexse; gfc_se indexse;
/* Handle scalarized references separately. */ /* Handle scalarized references separately. */
...@@ -1938,8 +1955,6 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar) ...@@ -1938,8 +1955,6 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar)
index = gfc_index_zero_node; index = gfc_index_zero_node;
fault = gfc_index_zero_node;
/* Calculate the offsets from all the dimensions. */ /* Calculate the offsets from all the dimensions. */
for (n = 0; n < ar->dimen; n++) for (n = 0; n < ar->dimen; n++)
{ {
...@@ -1953,20 +1968,27 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar) ...@@ -1953,20 +1968,27 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar)
{ {
/* Check array bounds. */ /* Check array bounds. */
tree cond; tree cond;
char *msg;
indexse.expr = gfc_evaluate_now (indexse.expr, &se->pre); indexse.expr = gfc_evaluate_now (indexse.expr, &se->pre);
tmp = gfc_conv_array_lbound (se->expr, n); tmp = gfc_conv_array_lbound (se->expr, n);
cond = fold_build2 (LT_EXPR, boolean_type_node, cond = fold_build2 (LT_EXPR, boolean_type_node,
indexse.expr, tmp); indexse.expr, tmp);
fault = asprintf (&msg, "%s for array '%s', "
fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond); "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); tmp = gfc_conv_array_ubound (se->expr, n);
cond = fold_build2 (GT_EXPR, boolean_type_node, cond = fold_build2 (GT_EXPR, boolean_type_node,
indexse.expr, tmp); indexse.expr, tmp);
fault = asprintf (&msg, "%s for array '%s', "
fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond); "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. */ /* Multiply the index by the stride. */
...@@ -1978,9 +2000,6 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar) ...@@ -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); 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); tmp = gfc_conv_array_offset (se->expr);
if (!integer_zerop (tmp)) if (!integer_zerop (tmp))
index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp); index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
...@@ -2457,16 +2476,15 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) ...@@ -2457,16 +2476,15 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
if (flag_bounds_check) if (flag_bounds_check)
{ {
stmtblock_t block; stmtblock_t block;
tree fault;
tree bound; tree bound;
tree end; tree end;
tree size[GFC_MAX_DIMENSIONS]; tree size[GFC_MAX_DIMENSIONS];
gfc_ss_info *info; gfc_ss_info *info;
char *msg;
int dim; int dim;
gfc_start_block (&block); gfc_start_block (&block);
fault = boolean_false_node;
for (n = 0; n < loop->dimen; n++) for (n = 0; n < loop->dimen; n++)
size[n] = NULL_TREE; size[n] = NULL_TREE;
...@@ -2492,15 +2510,21 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) ...@@ -2492,15 +2510,21 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
bound = gfc_conv_array_lbound (desc, dim); bound = gfc_conv_array_lbound (desc, dim);
tmp = info->start[n]; tmp = info->start[n];
tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp, bound); tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp, bound);
fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
tmp); " 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. */ /* Check the upper bound. */
bound = gfc_conv_array_ubound (desc, dim); bound = gfc_conv_array_ubound (desc, dim);
end = gfc_conv_section_upper_bound (ss, n, &block); end = gfc_conv_section_upper_bound (ss, n, &block);
tmp = fold_build2 (GT_EXPR, boolean_type_node, end, bound); tmp = fold_build2 (GT_EXPR, boolean_type_node, end, bound);
fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, asprintf (&msg, "%s, upper bound of dimension %d of array '%s'"
tmp); " 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. */ /* Check the section sizes match. */
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end, tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
...@@ -2513,14 +2537,16 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) ...@@ -2513,14 +2537,16 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
{ {
tmp = tmp =
fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]); fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
fault = asprintf (&msg, "%s, size mismatch for dimension %d "
build2 (TRUTH_OR_EXPR, boolean_type_node, fault, tmp); "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 else
size[n] = gfc_evaluate_now (tmp, &block); size[n] = gfc_evaluate_now (tmp, &block);
} }
} }
gfc_trans_runtime_check (fault, gfc_strconst_bounds, &block);
tmp = gfc_finish_block (&block); tmp = gfc_finish_block (&block);
gfc_add_expr_to_block (&loop->pre, tmp); gfc_add_expr_to_block (&loop->pre, tmp);
...@@ -3709,13 +3735,17 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) ...@@ -3709,13 +3735,17 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
if (checkparm) if (checkparm)
{ {
/* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */ /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
char * msg;
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
ubound, lbound); ubound, lbound);
stride2 = build2 (MINUS_EXPR, gfc_array_index_type, stride2 = build2 (MINUS_EXPR, gfc_array_index_type,
dubound, dlbound); dubound, dlbound);
tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2); 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 else
......
...@@ -86,7 +86,7 @@ void gfc_conv_resolve_dependencies (gfc_loopinfo *, gfc_ss *, gfc_ss *); ...@@ -86,7 +86,7 @@ void gfc_conv_resolve_dependencies (gfc_loopinfo *, gfc_ss *, gfc_ss *);
tree gfc_build_null_descriptor (tree); tree gfc_build_null_descriptor (tree);
/* Get a single array element. */ /* 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. */ /* Translate a reference to a temporary array. */
void gfc_conv_tmp_array_ref (gfc_se * se); void gfc_conv_tmp_array_ref (gfc_se * se);
/* Translate a reference to an array temporary. */ /* Translate a reference to an array temporary. */
......
...@@ -33,12 +33,6 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA ...@@ -33,12 +33,6 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
#include "trans-const.h" #include "trans-const.h"
#include "trans-types.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]; tree gfc_rank_cst[GFC_MAX_DIMENSIONS + 1];
/* Build a constant with given type from an int_cst. */ /* Build a constant with given type from an int_cst. */
...@@ -154,17 +148,6 @@ gfc_init_constants (void) ...@@ -154,17 +148,6 @@ gfc_init_constants (void)
for (n = 0; n <= GFC_MAX_DIMENSIONS; n++) for (n = 0; n <= GFC_MAX_DIMENSIONS; n++)
gfc_rank_cst[n] = build_int_cst (gfc_array_index_type, 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. */ /* Converts a GMP integer into a backend tree node. */
......
...@@ -49,12 +49,6 @@ void gfc_init_constants (void); ...@@ -49,12 +49,6 @@ void gfc_init_constants (void);
/* Build a constant with given type from an int_cst. */ /* Build a constant with given type from an int_cst. */
tree gfc_build_const (tree, tree); 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. */ /* Integer constants 0..GFC_MAX_DIMENSIONS. */
extern GTY(()) tree gfc_rank_cst[GFC_MAX_DIMENSIONS + 1]; extern GTY(()) tree gfc_rank_cst[GFC_MAX_DIMENSIONS + 1];
......
...@@ -2275,10 +2275,7 @@ gfc_build_builtin_function_decls (void) ...@@ -2275,10 +2275,7 @@ gfc_build_builtin_function_decls (void)
gfor_fndecl_runtime_error = gfor_fndecl_runtime_error =
gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")), gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
void_type_node, void_type_node, 1, pchar_type_node);
3,
pchar_type_node, pchar_type_node,
gfc_int4_type_node);
/* The runtime_error function does not return. */ /* The runtime_error function does not return. */
TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1; TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
......
...@@ -472,7 +472,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) ...@@ -472,7 +472,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
&& ref->next == NULL && (se->descriptor_only)) && ref->next == NULL && (se->descriptor_only))
return; 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. */ /* Return a pointer to an element. */
break; break;
...@@ -2153,7 +2153,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, ...@@ -2153,7 +2153,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
tmp = gfc_conv_descriptor_data_get (info->descriptor); tmp = gfc_conv_descriptor_data_get (info->descriptor);
tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp = fold_build2 (NE_EXPR, boolean_type_node,
tmp, info->data); 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; se->expr = info->descriptor;
/* Bundle in the string length. */ /* Bundle in the string length. */
......
...@@ -761,7 +761,7 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) ...@@ -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 = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp); tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp);
cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, 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);
} }
} }
......
...@@ -518,7 +518,6 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var, ...@@ -518,7 +518,6 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
{ {
gfc_se se; gfc_se se;
tree tmp; tree tmp;
tree msg;
tree io; tree io;
tree len; tree len;
gfc_st_parameter_field *p = &st_parameter_field[type]; gfc_st_parameter_field *p = &st_parameter_field[type];
...@@ -536,13 +535,18 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var, ...@@ -536,13 +535,18 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
/* Integer variable assigned a format label. */ /* Integer variable assigned a format label. */
if (e->ts.type == BT_INTEGER && e->symtree->n.sym->attr.assign == 1) if (e->ts.type == BT_INTEGER && e->symtree->n.sym->attr.assign == 1)
{ {
char * msg;
gfc_conv_label_variable (&se, e); 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 = GFC_DECL_STRING_LEN (se.expr);
tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp = fold_build2 (LT_EXPR, boolean_type_node,
tmp, build_int_cst (TREE_TYPE (tmp), 0)); 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, gfc_add_modify_expr (&se.pre, io,
fold_convert (TREE_TYPE (io), GFC_DECL_ASSIGN_ADDR (se.expr))); fold_convert (TREE_TYPE (io), GFC_DECL_ASSIGN_ADDR (se.expr)));
gfc_add_modify_expr (&se.pre, len, GFC_DECL_STRING_LEN (se.expr)); gfc_add_modify_expr (&se.pre, len, GFC_DECL_STRING_LEN (se.expr));
......
...@@ -31,6 +31,7 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA ...@@ -31,6 +31,7 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
#include "toplev.h" #include "toplev.h"
#include "real.h" #include "real.h"
#include "gfortran.h" #include "gfortran.h"
#include "flags.h"
#include "trans.h" #include "trans.h"
#include "trans-stmt.h" #include "trans-stmt.h"
#include "trans-types.h" #include "trans-types.h"
...@@ -139,14 +140,12 @@ gfc_trans_label_assign (gfc_code * code) ...@@ -139,14 +140,12 @@ gfc_trans_label_assign (gfc_code * code)
tree tree
gfc_trans_goto (gfc_code * code) gfc_trans_goto (gfc_code * code)
{ {
locus loc = code->loc;
tree assigned_goto; tree assigned_goto;
tree target; tree target;
tree tmp; tree tmp;
tree assign_error;
tree range_error;
gfc_se se; gfc_se se;
if (code->label != NULL) if (code->label != NULL)
return build1_v (GOTO_EXPR, gfc_get_label_decl (code->label)); return build1_v (GOTO_EXPR, gfc_get_label_decl (code->label));
...@@ -154,12 +153,11 @@ gfc_trans_goto (gfc_code * code) ...@@ -154,12 +153,11 @@ gfc_trans_goto (gfc_code * code)
gfc_init_se (&se, NULL); gfc_init_se (&se, NULL);
gfc_start_block (&se.pre); gfc_start_block (&se.pre);
gfc_conv_label_variable (&se, code->expr); 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 = GFC_DECL_STRING_LEN (se.expr);
tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
build_int_cst (TREE_TYPE (tmp), -1)); 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); assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr);
...@@ -172,8 +170,6 @@ gfc_trans_goto (gfc_code * code) ...@@ -172,8 +170,6 @@ gfc_trans_goto (gfc_code * code)
} }
/* Check the label list. */ /* Check the label list. */
range_error = gfc_build_cstring_const ("Assigned label is not in the list");
do do
{ {
target = gfc_get_label_decl (code->label); target = gfc_get_label_decl (code->label);
...@@ -186,7 +182,9 @@ gfc_trans_goto (gfc_code * code) ...@@ -186,7 +182,9 @@ gfc_trans_goto (gfc_code * code)
code = code->block; code = code->block;
} }
while (code != NULL); 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); return gfc_finish_block (&se.pre);
} }
......
...@@ -46,6 +46,10 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA ...@@ -46,6 +46,10 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
static gfc_file *gfc_current_backend_file; 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. */ /* Advance along TREE_CHAIN n times. */
...@@ -302,12 +306,15 @@ gfc_build_array_ref (tree base, tree offset) ...@@ -302,12 +306,15 @@ gfc_build_array_ref (tree base, tree offset)
/* Generate a runtime error if COND is true. */ /* Generate a runtime error if COND is true. */
void 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; stmtblock_t block;
tree body; tree body;
tree tmp; tree tmp;
tree args; tree args;
char * message;
int line;
if (integer_zerop (cond)) if (integer_zerop (cond))
return; return;
...@@ -315,19 +322,24 @@ gfc_trans_runtime_check (tree cond, tree msg, stmtblock_t * pblock) ...@@ -315,19 +322,24 @@ gfc_trans_runtime_check (tree cond, tree msg, stmtblock_t * pblock)
/* The code to generate the error. */ /* The code to generate the error. */
gfc_start_block (&block); gfc_start_block (&block);
gcc_assert (TREE_CODE (msg) == STRING_CST); if (where)
{
TREE_USED (msg) = 1; #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);
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); 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); tmp = build_function_call_expr (gfor_fndecl_runtime_error, args);
gfc_add_expr_to_block (&block, tmp); gfc_add_expr_to_block (&block, tmp);
......
...@@ -423,7 +423,7 @@ void gfc_generate_constructors (void); ...@@ -423,7 +423,7 @@ void gfc_generate_constructors (void);
bool get_array_ctor_strlen (gfc_constructor *, tree *); bool get_array_ctor_strlen (gfc_constructor *, tree *);
/* Generate a runtime error check. */ /* 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. */ /* Generate code for an assignment, includes scalarization. */
tree gfc_trans_assignment (gfc_expr *, gfc_expr *); tree gfc_trans_assignment (gfc_expr *, gfc_expr *);
...@@ -674,4 +674,11 @@ void gfc_finish_interface_mapping (gfc_interface_mapping *, ...@@ -674,4 +674,11 @@ void gfc_finish_interface_mapping (gfc_interface_mapping *,
void gfc_apply_interface_mapping (gfc_interface_mapping *, void gfc_apply_interface_mapping (gfc_interface_mapping *,
gfc_se *, gfc_expr *); 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 */ #endif /* GFC_TRANS_H */
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