Index: trans-expr.c =================================================================== --- trans-expr.c (revision 114340) +++ trans-expr.c (working copy) @@ -472,7 +472,7 @@ && 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 @@ 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. */ Index: trans-array.c =================================================================== --- trans-array.c (revision 114340) +++ trans-array.c (working copy) @@ -1767,24 +1767,41 @@ 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); + 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); - gfc_trans_runtime_check (fault, gfc_strconst_fault, &se->pre); - return index; } @@ -1919,13 +1936,13 @@ 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 @@ 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 @@ { /* 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 @@ 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 @@ 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 @@ 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 @@ { 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,18 @@ 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, + (se.ss ? &se.ss->expr->where : NULL)); + gfc_free (msg); } } else Index: trans-array.h =================================================================== --- trans-array.h (revision 114340) +++ trans-array.h (working copy) @@ -86,7 +86,7 @@ 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. */ Index: trans-const.c =================================================================== --- trans-const.c (revision 114340) +++ trans-const.c (working copy) @@ -33,12 +33,6 @@ #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 @@ 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. */ Index: trans-stmt.c =================================================================== --- trans-stmt.c (revision 114340) +++ trans-stmt.c (working copy) @@ -139,14 +139,12 @@ 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 +152,11 @@ 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 +169,6 @@ } /* 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 +181,9 @@ 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); } Index: trans-const.h =================================================================== --- trans-const.h (revision 114340) +++ trans-const.h (working copy) @@ -49,12 +49,6 @@ /* 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]; Index: trans.c =================================================================== --- trans.c (revision 114340) +++ trans.c (working copy) @@ -46,7 +46,11 @@ 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. */ tree @@ -302,12 +306,15 @@ /* 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 @@ /* 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); Index: trans.h =================================================================== --- trans.h (revision 114340) +++ trans.h (working copy) @@ -423,7 +423,7 @@ 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_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 */ Index: trans-io.c =================================================================== --- trans-io.c (revision 114340) +++ trans-io.c (working copy) @@ -518,7 +518,6 @@ { gfc_se se; tree tmp; - tree msg; tree io; tree len; gfc_st_parameter_field *p = &st_parameter_field[type]; @@ -536,13 +535,18 @@ /* 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)); Index: trans-decl.c =================================================================== --- trans-decl.c (revision 114340) +++ trans-decl.c (working copy) @@ -2275,10 +2275,7 @@ 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; Index: trans-intrinsic.c =================================================================== --- trans-intrinsic.c (revision 114340) +++ trans-intrinsic.c (working copy) @@ -761,7 +761,7 @@ 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); } }