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

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

gcc/fortran/ChangeLog

@@ -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.

gcc/fortran/trans-array.c

@@ -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",
+    asprintf (&msg, "%s, lower bound of dimension %d exceeded, %%ld is "
-	      gfc_msg_fault, n+1);
+	      "smaller than %%ld", gfc_msg_fault, n+1);
-  gfc_trans_runtime_check (fault, msg, &se->pre, where);
+  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",
+	asprintf (&msg, "%s, upper bound of dimension %d exceeded, %%ld is "
-		  gfc_msg_fault, n+1);
+		  "larger than %%ld", gfc_msg_fault, n+1);
-      gfc_trans_runtime_check (fault, msg, &se->pre, where);
+      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,
+	            "lower bound of dimension %d exceeded, %%ld is smaller "
-		    sym->name, n+1);
+		    "than %%ld", gfc_msg_fault, sym->name, n+1);
-	  gfc_trans_runtime_check (cond, msg, &se->pre, where);
+	  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,
+			"upper bound of dimension %d exceeded, %%ld is "
-			sym->name, n+1);
+			"greater than %%ld", gfc_msg_fault, sym->name, n+1);
-	      gfc_trans_runtime_check (cond, msg, &se->pre, where);
+	      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,
+			" exceeded, %%ld is smaller than %%ld", gfc_msg_fault,
-			ss->expr->symtree->name);
+			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,
+						     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,
+			" exceeded, %%ld is smaller than %%ld", gfc_msg_fault,
-			ss->expr->symtree->name);
+			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,
+						     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 =
+		  tree tmp3
-		    fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
+		    = 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,
+			    "of array '%s' (%%ld/%%ld)", gfc_msg_bounds,
-			    ss->expr->symtree->name);
+			    info->dim[n]+1, ss->expr->symtree->name);
-		  gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
+		  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);
 	    }
 	}

gcc/fortran/trans-decl.c

@@ -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;

gcc/fortran/trans-expr.c

@@ -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' "
+	asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' "
-		  "exceeds string length", name);
+		  "exceeds string length (%%ld)", name);
       else
-	asprintf (&msg, "Substring out of bounds: upper bound "
+	asprintf (&msg, "Substring out of bounds: upper bound (%%ld) "
-		  "exceeds string length");
+		  "exceeds string length (%%ld)");
-      gfc_trans_runtime_check (fault, msg, &se->pre, where);
+      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.  */

gcc/fortran/trans-intrinsic.c

@@ -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,
+  gfc_trans_runtime_check (cond, &se->pre, &expr->where,
-			   "Argument NCOPIES of REPEAT intrinsic is negative",
+			   "Argument NCOPIES of REPEAT intrinsic is negative "
-			   &se->pre, &expr->where);
+			   "(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,
+  gfc_trans_runtime_check (cond, &se->pre, &expr->where,
-			   "Argument NCOPIES of REPEAT intrinsic is too large",
+			   "Argument NCOPIES of REPEAT intrinsic is too large");
-			   &se->pre, &expr->where);
+			   
 
   /* Compute the destination length.  */
   dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node,

gcc/fortran/trans-io.c

@@ -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,
+      cond = fold_build2 (LT_EXPR, boolean_type_node,
-			 tmp, build_int_cst (TREE_TYPE (tmp), 0));
+			  tmp, build_int_cst (TREE_TYPE (tmp), 0));
 
-      asprintf(&msg, "Label assigned to variable '%s' is not a format label",
+      asprintf(&msg, "Label assigned to variable '%s' (%%ld) is not a format "
-	       e->symtree->name);
+	       "label", e->symtree->name);
-      gfc_trans_runtime_check (tmp, msg, &se.pre, &e->where);
+      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,

gcc/fortran/trans-stmt.c

@@ -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",
+  gfc_trans_runtime_check (tmp, &se.pre, &loc,
-			   &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,
+  gfc_trans_runtime_check (boolean_true_node, &se.pre, &loc,
-			   "Assigned label is not in the list", &se.pre, &loc);
+			   "Assigned label is not in the list");
 
   return gfc_finish_block (&se.pre); 
 }

gcc/fortran/trans.c

@@ -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,
+gfc_trans_runtime_check (tree cond, stmtblock_t * pblock, locus * where,
-			 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);

gcc/fortran/trans.h

@@ -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);

libgfortran/ChangeLog

@@ -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

libgfortran/libgfortran.h

@@ -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 *)
+extern void runtime_error_at (const char *, const char *, ...)
-__attribute__ ((noreturn));
+     __attribute__ ((noreturn, format (printf, 2, 3)));
 iexport_proto(runtime_error_at);
 
 extern void internal_error (st_parameter_common *, const char *)

libgfortran/runtime/error.c

@@ -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);