+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.
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. */
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);
}
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
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);
}
}
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;
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)
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);
}
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)
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);
}
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
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);
}
}
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;
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. */
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);
}
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. */
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);
}
}
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);
}
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);
}
/* 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. */
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,
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,
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);
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);
}
/* 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);
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);
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);
+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
__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 *)
* 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);
projects / gcc.git / commitdiff