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

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 44c61b6..cc040a6 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,33 @@
+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>
 
        PR fortran/27715
 2006-06-01  Thomas Koenig  <Thomas.Koenig@online.de>
 
        PR fortran/27715

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index be640bb..26d5feb 100644 (file)
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -1767,23 +1767,40 @@ gfc_conv_array_ubound (tree descriptor, int dim)
 static tree
 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n)
 {
 static tree
 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n)
 {

-  tree cond;

   tree fault;
   tree tmp;
   tree fault;
   tree tmp;

+  char *msg;

 
   if (!flag_bounds_check)
     return index;
 
   index = gfc_evaluate_now (index, &se->pre);
 
   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);
   /* 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);
   /* 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);
-
-  gfc_trans_runtime_check (fault, gfc_strconst_fault, &se->pre);
+  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);

 
   return index;
 }
 
   return index;
 }


@@ -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]]*/
 
 void
    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;
 {
   int n;
   tree index;
   tree tmp;
   tree stride;

-  tree fault;

   gfc_se indexse;
 
   /* Handle scalarized references separately.  */
   gfc_se indexse;
 
   /* Handle scalarized references separately.  */


@@ -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.  */
   for (n = 0; n < ar->dimen; n++)
     {
   /* Calculate the offsets from all the dimensions.  */
   for (n = 0; n < ar->dimen; n++)
     {


@@ -1953,20 +1968,27 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar)
        {
          /* Check array bounds.  */
          tree cond;
        {
          /* 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);
 
          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);
 
          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.  */
        }
 
       /* Multiply the index by the stride.  */


@@ -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);
   if (!integer_zerop (tmp))
     index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
   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 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
   if (flag_bounds_check)
     {
       stmtblock_t block;
   if (flag_bounds_check)
     {
       stmtblock_t block;

-      tree fault;

       tree bound;
       tree end;
       tree size[GFC_MAX_DIMENSIONS];
       gfc_ss_info *info;
       tree bound;
       tree end;
       tree size[GFC_MAX_DIMENSIONS];
       gfc_ss_info *info;

+      char *msg;

       int dim;
 
       gfc_start_block (&block);
 
       int dim;
 
       gfc_start_block (&block);
 

-      fault = boolean_false_node;

       for (n = 0; n < loop->dimen; n++)
        size[n] = NULL_TREE;
 
       for (n = 0; n < loop->dimen; n++)
        size[n] = NULL_TREE;
 


@@ -2492,15 +2510,21 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
              bound = gfc_conv_array_lbound (desc, dim);
              tmp = info->start[n];
              tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp, bound);
              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);
 
              /* 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,
 
              /* Check the section sizes match.  */
              tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,


@@ -2513,14 +2537,16 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
                {
                  tmp =
                    fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
                {
                  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);
            }
        }
                }
              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);
 
       tmp = gfc_finish_block (&block);
       gfc_add_expr_to_block (&loop->pre, tmp);


@@ -3709,13 +3735,17 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
          if (checkparm)
            {
              /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)).  */
          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);
 
              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, NULL);
+             gfc_free (msg);

            }
        }
       else
            }
        }
       else

diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 6f57429..ae08534 100644 (file)
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -86,7 +86,7 @@ void gfc_conv_resolve_dependencies (gfc_loopinfo *, gfc_ss *, gfc_ss *);
 tree gfc_build_null_descriptor (tree);
 
 /* Get a single array element.  */
 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.  */
 /* Translate a reference to a temporary array.  */
 void gfc_conv_tmp_array_ref (gfc_se * se);
 /* Translate a reference to an array temporary.  */

diff --git a/gcc/fortran/trans-const.c b/gcc/fortran/trans-const.c
index 4a23a56..936dd64 100644 (file)
--- a/gcc/fortran/trans-const.c
+++ b/gcc/fortran/trans-const.c
@@ -33,12 +33,6 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
 #include "trans-const.h"
 #include "trans-types.h"
 
 #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.  */
 tree gfc_rank_cst[GFC_MAX_DIMENSIONS + 1];
 
 /* Build a constant with given type from an int_cst.  */


@@ -154,17 +148,6 @@ gfc_init_constants (void)
 
   for (n = 0; n <= GFC_MAX_DIMENSIONS; n++)
     gfc_rank_cst[n] = build_int_cst (gfc_array_index_type, n);
 
   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.  */
 }
 
 /* Converts a GMP integer into a backend tree node.  */

diff --git a/gcc/fortran/trans-const.h b/gcc/fortran/trans-const.h
index 304a324..c01316e 100644 (file)
--- a/gcc/fortran/trans-const.h
+++ b/gcc/fortran/trans-const.h
@@ -49,12 +49,6 @@ void gfc_init_constants (void);
 /* Build a constant with given type from an int_cst.  */
 tree gfc_build_const (tree, tree);
 
 /* 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];
 
 /* Integer constants 0..GFC_MAX_DIMENSIONS.  */
 extern GTY(()) tree gfc_rank_cst[GFC_MAX_DIMENSIONS + 1];
 

diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 4efe4bd..30d51b9 100644 (file)
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -2275,10 +2275,7 @@ gfc_build_builtin_function_decls (void)
 
   gfor_fndecl_runtime_error =
     gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
 
   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;
 
   /* The runtime_error function does not return.  */
   TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
 

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 752609c..c0422b1 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -472,7 +472,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
              && ref->next == NULL && (se->descriptor_only))
            return;
 
              && 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;
 
          /* Return a pointer to an element.  */
          break;
 


@@ -2153,7 +2153,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);
                  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.  */
                }
              se->expr = info->descriptor;
              /* Bundle in the string length.  */

diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index c361ad4..e8fe286 100644 (file)
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -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 = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp);
           cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp);
           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);

         }
     }
 
         }
     }
 

diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c
index b4c83f4..e562321 100644 (file)
--- a/gcc/fortran/trans-io.c
+++ b/gcc/fortran/trans-io.c
@@ -518,7 +518,6 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
 {
   gfc_se se;
   tree tmp;
 {
   gfc_se se;
   tree tmp;

-  tree msg;

   tree io;
   tree len;
   gfc_st_parameter_field *p = &st_parameter_field[type];
   tree io;
   tree len;
   gfc_st_parameter_field *p = &st_parameter_field[type];


@@ -536,13 +535,18 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
   /* Integer variable assigned a format label.  */
   if (e->ts.type == BT_INTEGER && e->symtree->n.sym->attr.assign == 1)
     {
   /* 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);
       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));
       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));
       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));

diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 562e6f1..ef7d680 100644 (file)
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -31,6 +31,7 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
 #include "toplev.h"
 #include "real.h"
 #include "gfortran.h"
 #include "toplev.h"
 #include "real.h"
 #include "gfortran.h"

+#include "flags.h"

 #include "trans.h"
 #include "trans-stmt.h"
 #include "trans-types.h"
 #include "trans.h"
 #include "trans-stmt.h"
 #include "trans-types.h"


@@ -139,14 +140,12 @@ gfc_trans_label_assign (gfc_code * code)
 tree
 gfc_trans_goto (gfc_code * code)
 {
 tree
 gfc_trans_goto (gfc_code * code)
 {

+  locus loc = code->loc;

   tree assigned_goto;
   tree target;
   tree tmp;
   tree assigned_goto;
   tree target;
   tree tmp;

-  tree assign_error;
-  tree range_error;

   gfc_se se;
 
   gfc_se se;
 

-

   if (code->label != NULL)
     return build1_v (GOTO_EXPR, gfc_get_label_decl (code->label));
 
   if (code->label != NULL)
     return build1_v (GOTO_EXPR, gfc_get_label_decl (code->label));
 


@@ -154,12 +153,11 @@ gfc_trans_goto (gfc_code * code)
   gfc_init_se (&se, NULL);
   gfc_start_block (&se.pre);
   gfc_conv_label_variable (&se, code->expr);
   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));
   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);
 
 
   assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr);
 


@@ -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
     {
       target = gfc_get_label_decl (code->label);
   do
     {
       target = gfc_get_label_decl (code->label);


@@ -186,7 +182,9 @@ gfc_trans_goto (gfc_code * code)
       code = code->block;
     }
   while (code != NULL);
       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); 
 }
 
   return gfc_finish_block (&se.pre); 
 }
 

diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 3eec75c..d4856fd 100644 (file)
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -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)
 /* Generate a runtime error if COND is true.  */
 
 void
 /* 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;
 {
   stmtblock_t block;
   tree body;
   tree tmp;
   tree args;

+  char * message;
+  int line;

 
   if (integer_zerop (cond))
     return;
 
   if (integer_zerop (cond))
     return;


@@ -315,19 +322,24 @@ gfc_trans_runtime_check (tree cond, tree msg, stmtblock_t * pblock)
   /* The code to generate the error.  */
   gfc_start_block (&block);
 
   /* The code to generate the error.  */
   gfc_start_block (&block);
 

-  gcc_assert (TREE_CODE (msg) == STRING_CST);
-
-  TREE_USED (msg) = 1;
+  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);

 
 

-  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);
   gfc_add_expr_to_block (&block, tmp);
 
   tmp = build_function_call_expr (gfor_fndecl_runtime_error, args);
   gfc_add_expr_to_block (&block, tmp);
 

diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 78a5d15..738ed02 100644 (file)
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -423,7 +423,7 @@ void gfc_generate_constructors (void);
 bool get_array_ctor_strlen (gfc_constructor *, tree *);
 
 /* Generate a runtime error check.  */
 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 *);
 
 /* Generate code for an assignment, includes scalarization.  */
 tree gfc_trans_assignment (gfc_expr *, gfc_expr *);


@@ -674,4 +674,11 @@ void gfc_finish_interface_mapping (gfc_interface_mapping *,
 void gfc_apply_interface_mapping (gfc_interface_mapping *,
                                  gfc_se *, gfc_expr *);
 
 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 */
 #endif /* GFC_TRANS_H */