OSDN Git Service

PR fortran/31270
authorfxcoudert <fxcoudert@138bc75d-0d04-0410-961f-82ee72b054a4>
Fri, 10 Aug 2007 22:12:04 +0000 (22:12 +0000)
committerfxcoudert <fxcoudert@138bc75d-0d04-0410-961f-82ee72b054a4>
Fri, 10 Aug 2007 22:12:04 +0000 (22:12 +0000)
* 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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@127352 138bc75d-0d04-0410-961f-82ee72b054a4

12 files changed:
gcc/fortran/ChangeLog
gcc/fortran/trans-array.c
gcc/fortran/trans-decl.c
gcc/fortran/trans-expr.c
gcc/fortran/trans-intrinsic.c
gcc/fortran/trans-io.c
gcc/fortran/trans-stmt.c
gcc/fortran/trans.c
gcc/fortran/trans.h
libgfortran/ChangeLog
libgfortran/libgfortran.h
libgfortran/runtime/error.c

index d9a7580..d768b08 100644 (file)
@@ -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.
index abbf8f6..78b038a 100644 (file)
@@ -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",
-             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.  */
@@ -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",
-                 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);
     }
 
@@ -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,
-                   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
@@ -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,
-                       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);
            }
        }
@@ -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,
-                       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)
@@ -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,
-                       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)
@@ -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 =
-                   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
@@ -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);
            }
        }
index cf6d9d2..58cbc37 100644 (file)
@@ -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;
index 674448b..b24a8ac 100644 (file)
@@ -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' "
-                 "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);
     }
 
@@ -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.  */
index 8849e44..b9dbf46 100644 (file)
@@ -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,
-                          "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.  */
@@ -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,
-                          "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,
index 0fa81c8..80646cd 100644 (file)
@@ -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,
-                        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,
index 2e2be2f..47e0822 100644 (file)
@@ -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",
-                          &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);
 
@@ -179,8 +179,8 @@ gfc_trans_goto (gfc_code * code)
       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); 
 }
index 38375af..79112e5 100644 (file)
@@ -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,
-                        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);
 
@@ -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);
index 645f9a3..829551e 100644 (file)
@@ -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);
index b77eeef..46f7282 100644 (file)
@@ -1,5 +1,12 @@
 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
        * intrinsics/associated.c: Change return type of associated into
        a C int.
index ce6d621..c32b5a3 100644 (file)
@@ -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 *)
-__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 *)
index 4dda227..3512ab4 100644 (file)
@@ -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);