PR fortran/15586

	* arith.c (gfc_arith_error): Change message to include locus.
	(check_result, eval_intrinsic, gfc_int2int, gfc_real2real,
	gfc_real2complex, gfc_complex2real, gfc_complex2complex): Use
	the new gfc_arith_error.
	(arith_error): Rewrite full error messages instead of building
	them from pieces.
	* check.c (must_be): Removed.
	(type_check, numeric_check, int_or_real_check, real_or_complex_check,
	kind_check, double_check, logical_array_check, array_check,
	scalar_check, same_type_check, rank_check, kind_value_check,
	variable_check, gfc_check_allocated, gfc_check_associated,
	gfc_check_cmplx, gfc_check_dcmplx, gfc_check_dot_product,
	gfc_check_index, gfc_check_kind, gfc_check_matmul, gfc_check_null,
	gfc_check_pack, gfc_check_precision, gfc_check_present,
	gfc_check_spread): Rewrite full error messages instead of
	building them from pieces.
	* decl.c (gfc_match_entry): Rewrite full error messages instead
	of building them from pieces.
	* parse.c (gfc_state_name): Remove.
	* parse.h: Remove prototype for gfc_state_name.

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 095695f..5cb021b 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,27 @@
+2005-10-24  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+       PR fortran/15586
+       * arith.c (gfc_arith_error): Change message to include locus.
+       (check_result, eval_intrinsic, gfc_int2int, gfc_real2real,
+       gfc_real2complex, gfc_complex2real, gfc_complex2complex): Use
+       the new gfc_arith_error.
+       (arith_error): Rewrite full error messages instead of building
+       them from pieces.
+       * check.c (must_be): Removed.
+       (type_check, numeric_check, int_or_real_check, real_or_complex_check,
+       kind_check, double_check, logical_array_check, array_check,
+       scalar_check, same_type_check, rank_check, kind_value_check,
+       variable_check, gfc_check_allocated, gfc_check_associated,
+       gfc_check_cmplx, gfc_check_dcmplx, gfc_check_dot_product,
+       gfc_check_index, gfc_check_kind, gfc_check_matmul, gfc_check_null,
+       gfc_check_pack, gfc_check_precision, gfc_check_present,
+       gfc_check_spread): Rewrite full error messages instead of
+       building them from pieces.
+       * decl.c (gfc_match_entry): Rewrite full error messages instead
+       of building them from pieces.
+       * parse.c (gfc_state_name): Remove.
+       * parse.h: Remove prototype for gfc_state_name.
+
 2005-10-23  Andrew Pinski  <pinskia@physics.uc.edu>
 
        PR fortran/23635

diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c
index ccc7ae1..e0c1f4b 100644 (file)
--- a/gcc/fortran/arith.c
+++ b/gcc/fortran/arith.c
@@ -138,25 +138,26 @@ gfc_arith_error (arith code)
   switch (code)
     {
     case ARITH_OK:
-      p = _("Arithmetic OK");
+      p = _("Arithmetic OK at %L");
       break;
     case ARITH_OVERFLOW:
-      p = _("Arithmetic overflow");
+      p = _("Arithmetic overflow at %L");
       break;
     case ARITH_UNDERFLOW:
-      p = _("Arithmetic underflow");
+      p = _("Arithmetic underflow at %L");
       break;
     case ARITH_NAN:
-      p = _("Arithmetic NaN");
+      p = _("Arithmetic NaN at %L");
       break;
     case ARITH_DIV0:
-      p = _("Division by zero");
+      p = _("Division by zero at %L");
       break;
     case ARITH_INCOMMENSURATE:
-      p = _("Array operands are incommensurate");
+      p = _("Array operands are incommensurate at %L");
       break;
     case ARITH_ASYMMETRIC:
-      p = _("Integer outside symmetric range implied by Standard Fortran");
+      p =
+       _("Integer outside symmetric range implied by Standard Fortran at %L");
       break;
     default:
       gfc_internal_error ("gfc_arith_error(): Bad error code");
@@ -598,13 +599,13 @@ check_result (arith rc, gfc_expr * x, gfc_expr * r, gfc_expr ** rp)
   if (val == ARITH_UNDERFLOW)
     {
       if (gfc_option.warn_underflow)
-       gfc_warning ("%s at %L", gfc_arith_error (val), &x->where);
+       gfc_warning (gfc_arith_error (val), &x->where);
       val = ARITH_OK;
     }
 
   if (val == ARITH_ASYMMETRIC)
     {
-      gfc_warning ("%s at %L", gfc_arith_error (val), &x->where);
+      gfc_warning (gfc_arith_error (val), &x->where);
       val = ARITH_OK;
     }
 
@@ -1604,7 +1605,7 @@ eval_intrinsic (gfc_intrinsic_op operator,
 
   if (rc != ARITH_OK)
     {                          /* Something went wrong */
-      gfc_error ("%s at %L", gfc_arith_error (rc), &op1->where);
+      gfc_error (gfc_arith_error (rc), &op1->where);
       return NULL;
     }
 
@@ -1907,8 +1908,40 @@ gfc_convert_complex (gfc_expr * real, gfc_expr * imag, int kind)
 static void
 arith_error (arith rc, gfc_typespec * from, gfc_typespec * to, locus * where)
 {
-  gfc_error ("%s converting %s to %s at %L", gfc_arith_error (rc),
-            gfc_typename (from), gfc_typename (to), where);
+  switch (rc)
+    {
+    case ARITH_OK:
+      gfc_error ("Arithmetic OK converting %s to %s at %L",
+                gfc_typename (from), gfc_typename (to), where);
+      break;
+    case ARITH_OVERFLOW:
+      gfc_error ("Arithmetic overflow converting %s to %s at %L",
+                gfc_typename (from), gfc_typename (to), where);
+      break;
+    case ARITH_UNDERFLOW:
+      gfc_error ("Arithmetic underflow converting %s to %s at %L",
+                gfc_typename (from), gfc_typename (to), where);
+      break;
+    case ARITH_NAN:
+      gfc_error ("Arithmetic NaN converting %s to %s at %L",
+                gfc_typename (from), gfc_typename (to), where);
+      break;
+    case ARITH_DIV0:
+      gfc_error ("Division by zero converting %s to %s at %L",
+                gfc_typename (from), gfc_typename (to), where);
+      break;
+    case ARITH_INCOMMENSURATE:
+      gfc_error ("Array operands are incommensurate converting %s to %s at %L",
+                gfc_typename (from), gfc_typename (to), where);
+      break;
+    case ARITH_ASYMMETRIC:
+      gfc_error ("Integer outside symmetric range implied by Standard Fortran"
+                " converting %s to %s at %L",
+                gfc_typename (from), gfc_typename (to), where);
+      break;
+    default:
+      gfc_internal_error ("gfc_arith_error(): Bad error code");
+    }
 
   /* TODO: Do something about the error, ie, throw exception, return
      NaN, etc.  */
@@ -1931,7 +1964,7 @@ gfc_int2int (gfc_expr * src, int kind)
     {
       if (rc == ARITH_ASYMMETRIC)
         {
-          gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
+          gfc_warning (gfc_arith_error (rc), &src->where);
         }
       else
         {
@@ -2033,7 +2066,7 @@ gfc_real2real (gfc_expr * src, int kind)
   if (rc == ARITH_UNDERFLOW)
     {
       if (gfc_option.warn_underflow)
-        gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
+        gfc_warning (gfc_arith_error (rc), &src->where);
       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
     }
   else if (rc != ARITH_OK)
@@ -2065,7 +2098,7 @@ gfc_real2complex (gfc_expr * src, int kind)
   if (rc == ARITH_UNDERFLOW)
     {
       if (gfc_option.warn_underflow)
-        gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
+        gfc_warning (gfc_arith_error (rc), &src->where);
       mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
     }
   else if (rc != ARITH_OK)
@@ -2120,7 +2153,7 @@ gfc_complex2real (gfc_expr * src, int kind)
   if (rc == ARITH_UNDERFLOW)
     {
       if (gfc_option.warn_underflow)
-        gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
+        gfc_warning (gfc_arith_error (rc), &src->where);
       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
     }
   if (rc != ARITH_OK)
@@ -2152,7 +2185,7 @@ gfc_complex2complex (gfc_expr * src, int kind)
   if (rc == ARITH_UNDERFLOW)
     {
       if (gfc_option.warn_underflow)
-        gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
+        gfc_warning (gfc_arith_error (rc), &src->where);
       mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
     }
   else if (rc != ARITH_OK)
@@ -2167,7 +2200,7 @@ gfc_complex2complex (gfc_expr * src, int kind)
   if (rc == ARITH_UNDERFLOW)
     {
       if (gfc_option.warn_underflow)
-        gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
+        gfc_warning (gfc_arith_error (rc), &src->where);
       mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
     }
   else if (rc != ARITH_OK)

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index e2e9501..49a7505 100644 (file)
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -33,18 +33,6 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
 #include "intrinsic.h"
 
 
-/* The fundamental complaint function of this source file.  This
-   function can be called in all kinds of ways.  */
-
-static void
-must_be (gfc_expr * e, int n, const char *thing_msgid)
-{
-  gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
-            gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where,
-            thing_msgid);
-}
-
-
 /* Check the type of an expression.  */
 
 static try
@@ -53,7 +41,9 @@ type_check (gfc_expr * e, int n, bt type)
   if (e->ts.type == type)
     return SUCCESS;
 
-  must_be (e, n, gfc_basic_typename (type));
+  gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
+            gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where,
+            gfc_basic_typename (type));
 
   return FAILURE;
 }
@@ -67,7 +57,8 @@ numeric_check (gfc_expr * e, int n)
   if (gfc_numeric_ts (&e->ts))
     return SUCCESS;
 
-  must_be (e, n, "a numeric type");
+  gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type",
+            gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
 
   return FAILURE;
 }
@@ -80,7 +71,9 @@ int_or_real_check (gfc_expr * e, int n)
 {
   if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
     {
-      must_be (e, n, "INTEGER or REAL");
+      gfc_error (
+       "'%s' argument of '%s' intrinsic at %L must be INTEGER or REAL",
+       gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
       return FAILURE;
     }
 
@@ -95,7 +88,9 @@ real_or_complex_check (gfc_expr * e, int n)
 {
   if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX)
     {
-      must_be (e, n, "REAL or COMPLEX");
+      gfc_error (
+       "'%s' argument of '%s' intrinsic at %L must be REAL or COMPLEX",
+       gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
       return FAILURE;
     }
 
@@ -119,7 +114,9 @@ kind_check (gfc_expr * k, int n, bt type)
 
   if (k->expr_type != EXPR_CONSTANT)
     {
-      must_be (k, n, "a constant");
+      gfc_error (
+       "'%s' argument of '%s' intrinsic at %L must be a constant",
+       gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &k->where);
       return FAILURE;
     }
 
@@ -145,7 +142,9 @@ double_check (gfc_expr * d, int n)
 
   if (d->ts.kind != gfc_default_double_kind)
     {
-      must_be (d, n, "double precision");
+      gfc_error (
+       "'%s' argument of '%s' intrinsic at %L must be double precision",
+       gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &d->where);
       return FAILURE;
     }
 
@@ -160,7 +159,9 @@ logical_array_check (gfc_expr * array, int n)
 {
   if (array->ts.type != BT_LOGICAL || array->rank == 0)
     {
-      must_be (array, n, "a logical array");
+      gfc_error (
+       "'%s' argument of '%s' intrinsic at %L must be a logical array",
+       gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &array->where);
       return FAILURE;
     }
 
@@ -176,7 +177,8 @@ array_check (gfc_expr * e, int n)
   if (e->rank != 0)
     return SUCCESS;
 
-  must_be (e, n, "an array");
+  gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
+            gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
 
   return FAILURE;
 }
@@ -190,7 +192,8 @@ scalar_check (gfc_expr * e, int n)
   if (e->rank == 0)
     return SUCCESS;
 
-  must_be (e, n, "a scalar");
+  gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
+            gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
 
   return FAILURE;
 }
@@ -201,16 +204,12 @@ scalar_check (gfc_expr * e, int n)
 static try
 same_type_check (gfc_expr * e, int n, gfc_expr * f, int m)
 {
-  char message[100];
-
   if (gfc_compare_types (&e->ts, &f->ts))
     return SUCCESS;
 
-  sprintf (message, _("the same type and kind as '%s'"),
-          gfc_current_intrinsic_arg[n]);
-
-  must_be (f, m, message);
-
+  gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type "
+            "and kind as '%s'", gfc_current_intrinsic_arg[m],
+            gfc_current_intrinsic, &f->where, gfc_current_intrinsic_arg[n]);
   return FAILURE;
 }
 
@@ -220,15 +219,12 @@ same_type_check (gfc_expr * e, int n, gfc_expr * f, int m)
 static try
 rank_check (gfc_expr * e, int n, int rank)
 {
-  char message[100];
-
   if (e->rank == rank)
     return SUCCESS;
 
-  sprintf (message, _("of rank %d"), rank);
-
-  must_be (e, n, message);
-
+  gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d",
+            gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
+            &e->where, rank);
   return FAILURE;
 }
 
@@ -257,14 +253,12 @@ nonoptional_check (gfc_expr * e, int n)
 static try
 kind_value_check (gfc_expr * e, int n, int k)
 {
-  char message[100];
-
   if (e->ts.kind == k)
     return SUCCESS;
 
-  sprintf (message, _("of kind %d"), k);
-
-  must_be (e, n, message);
+  gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d",
+            gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
+            &e->where, k);
   return FAILURE;
 }
 
@@ -289,7 +283,8 @@ variable_check (gfc_expr * e, int n)
       return FAILURE;
     }
 
-  must_be (e, n, "a variable");
+  gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
+            gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
 
   return FAILURE;
 }
@@ -436,7 +431,9 @@ gfc_check_allocated (gfc_expr * array)
 
   if (!array->symtree->n.sym->attr.allocatable)
     {
-      must_be (array, 0, "ALLOCATABLE");
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
+                gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
+                &array->where);
       return FAILURE;
     }
 
@@ -473,7 +470,9 @@ gfc_check_associated (gfc_expr * pointer, gfc_expr * target)
   attr = gfc_variable_attr (pointer, NULL);
   if (!attr.pointer)
     {
-      must_be (pointer, 0, "a POINTER");
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
+                gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
+                &pointer->where);
       return FAILURE;
     }
 
@@ -492,7 +491,9 @@ gfc_check_associated (gfc_expr * pointer, gfc_expr * target)
   attr = gfc_variable_attr (target, NULL);
   if (!attr.pointer && !attr.target)
     {
-      must_be (target, 1, "a POINTER or a TARGET");
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
+                "or a TARGET", gfc_current_intrinsic_arg[1],
+                gfc_current_intrinsic, &target->where);
       return FAILURE;
     }
 
@@ -616,7 +617,9 @@ gfc_check_cmplx (gfc_expr * x, gfc_expr * y, gfc_expr * kind)
 
       if (x->ts.type == BT_COMPLEX)
        {
-         must_be (y, 1, "not be present if 'x' is COMPLEX");
+         gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
+                    "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
+                    gfc_current_intrinsic, &y->where);
          return FAILURE;
        }
     }
@@ -676,7 +679,9 @@ gfc_check_dcmplx (gfc_expr * x, gfc_expr * y)
 
       if (x->ts.type == BT_COMPLEX)
        {
-         must_be (y, 1, "not be present if 'x' is COMPLEX");
+         gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
+                    "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
+                    gfc_current_intrinsic, &y->where);
          return FAILURE;
        }
     }
@@ -723,7 +728,9 @@ gfc_check_dot_product (gfc_expr * vector_a, gfc_expr * vector_b)
       break;
 
     default:
-      must_be (vector_a, 0, "numeric or LOGICAL");
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
+                "or LOGICAL", gfc_current_intrinsic_arg[0],
+                gfc_current_intrinsic, &vector_a->where);
       return FAILURE;
     }
 
@@ -1027,7 +1034,10 @@ gfc_check_index (gfc_expr * string, gfc_expr * substring, gfc_expr * back)
 
   if (string->ts.kind != substring->ts.kind)
     {
-      must_be (substring, 1, "the same kind as 'string'");
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
+                "kind as '%s'", gfc_current_intrinsic_arg[1],
+                gfc_current_intrinsic, &substring->where,
+                gfc_current_intrinsic_arg[0]);
       return FAILURE;
     }
 
@@ -1139,7 +1149,9 @@ gfc_check_kind (gfc_expr * x)
 {
   if (x->ts.type == BT_DERIVED)
     {
-      must_be (x, 0, "a non-derived type");
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
+                "non-derived type", gfc_current_intrinsic_arg[0],
+                gfc_current_intrinsic, &x->where);
       return FAILURE;
     }
 
@@ -1350,13 +1362,17 @@ gfc_check_matmul (gfc_expr * matrix_a, gfc_expr * matrix_b)
 {
   if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
     {
-      must_be (matrix_a, 0, "numeric or LOGICAL");
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
+                "or LOGICAL", gfc_current_intrinsic_arg[0],
+                gfc_current_intrinsic, &matrix_a->where);
       return FAILURE;
     }
 
   if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
     {
-      must_be (matrix_b, 0, "numeric or LOGICAL");
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
+                "or LOGICAL", gfc_current_intrinsic_arg[1],
+                gfc_current_intrinsic, &matrix_b->where);
       return FAILURE;
     }
 
@@ -1375,7 +1391,9 @@ gfc_check_matmul (gfc_expr * matrix_a, gfc_expr * matrix_b)
       break;
 
     default:
-      must_be (matrix_a, 0, "of rank 1 or 2");
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
+                "1 or 2", gfc_current_intrinsic_arg[0],
+                gfc_current_intrinsic, &matrix_a->where);
       return FAILURE;
     }
 
@@ -1540,7 +1558,9 @@ gfc_check_null (gfc_expr * mold)
 
   if (!attr.pointer)
     {
-      must_be (mold, 0, "a POINTER");
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
+                gfc_current_intrinsic_arg[0],
+                gfc_current_intrinsic, &mold->where);
       return FAILURE;
     }
 
@@ -1559,7 +1579,10 @@ gfc_check_pack (gfc_expr * array, gfc_expr * mask, gfc_expr * vector)
 
   if (mask->rank != 0 && mask->rank != array->rank)
     {
-      must_be (array, 0, "conformable with 'mask' argument");
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be conformable "
+                "with '%s' argument", gfc_current_intrinsic_arg[0],
+                gfc_current_intrinsic, &array->where,
+                gfc_current_intrinsic_arg[1]);
       return FAILURE;
     }
 
@@ -1583,7 +1606,9 @@ gfc_check_precision (gfc_expr * x)
 {
   if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
     {
-      must_be (x, 0, "of type REAL or COMPLEX");
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be of type "
+                "REAL or COMPLEX", gfc_current_intrinsic_arg[0],
+                gfc_current_intrinsic, &x->where);
       return FAILURE;
     }
 
@@ -1602,13 +1627,17 @@ gfc_check_present (gfc_expr * a)
   sym = a->symtree->n.sym;
   if (!sym->attr.dummy)
     {
-      must_be (a, 0, "a dummy variable");
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
+                "dummy variable", gfc_current_intrinsic_arg[0],
+                gfc_current_intrinsic, &a->where);
       return FAILURE;
     }
 
   if (!sym->attr.optional)
     {
-      must_be (a, 0, "an OPTIONAL dummy variable");
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
+                "an OPTIONAL dummy variable", gfc_current_intrinsic_arg[0],
+                gfc_current_intrinsic, &a->where);
       return FAILURE;
     }
 
@@ -1906,10 +1935,9 @@ gfc_check_spread (gfc_expr * source, gfc_expr * dim, gfc_expr * ncopies)
 {
   if (source->rank >= GFC_MAX_DIMENSIONS)
     {
-      char message[100];
-
-      sprintf (message, _("less than rank %d"), GFC_MAX_DIMENSIONS);
-      must_be (source, 0, message);
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
+                "than rank %d", gfc_current_intrinsic_arg[0],
+                gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
 
       return FAILURE;
     }

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 48cb920..69c0fc8 100644 (file)
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -2419,11 +2419,57 @@ gfc_match_entry (void)
     return m;
 
   state = gfc_current_state ();
-  if (state != COMP_SUBROUTINE
-      && state != COMP_FUNCTION)
+  if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
     {
-      gfc_error ("ENTRY statement at %C cannot appear within %s",
-                gfc_state_name (gfc_current_state ()));
+      switch (state)
+       {
+         case COMP_PROGRAM:
+           gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
+           break;
+         case COMP_MODULE:
+           gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
+           break;
+         case COMP_BLOCK_DATA:
+           gfc_error
+             ("ENTRY statement at %C cannot appear within a BLOCK DATA");
+           break;
+         case COMP_INTERFACE:
+           gfc_error
+             ("ENTRY statement at %C cannot appear within an INTERFACE");
+           break;
+         case COMP_DERIVED:
+           gfc_error
+             ("ENTRY statement at %C cannot appear "
+              "within a DERIVED TYPE block");
+           break;
+         case COMP_IF:
+           gfc_error
+             ("ENTRY statement at %C cannot appear within an IF-THEN block");
+           break;
+         case COMP_DO:
+           gfc_error
+             ("ENTRY statement at %C cannot appear within a DO block");
+           break;
+         case COMP_SELECT:
+           gfc_error
+             ("ENTRY statement at %C cannot appear within a SELECT block");
+           break;
+         case COMP_FORALL:
+           gfc_error
+             ("ENTRY statement at %C cannot appear within a FORALL block");
+           break;
+         case COMP_WHERE:
+           gfc_error
+             ("ENTRY statement at %C cannot appear within a WHERE block");
+           break;
+         case COMP_CONTAINS:
+           gfc_error
+             ("ENTRY statement at %C cannot appear "
+              "within a contained subprogram");
+           break;
+         default:
+           gfc_internal_error ("gfc_match_entry(): Bad state");
+       }
       return MATCH_ERROR;
     }
 

diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 043c3b4..6945925 100644 (file)
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -959,63 +959,6 @@ gfc_ascii_statement (gfc_statement st)
 }
 
 
-/* Return the name of a compile state.  */
-
-const char *
-gfc_state_name (gfc_compile_state state)
-{
-  const char *p;
-
-  switch (state)
-    {
-    case COMP_PROGRAM:
-      p = _("a PROGRAM");
-      break;
-    case COMP_MODULE:
-      p = _("a MODULE");
-      break;
-    case COMP_SUBROUTINE:
-      p = _("a SUBROUTINE");
-      break;
-    case COMP_FUNCTION:
-      p = _("a FUNCTION");
-      break;
-    case COMP_BLOCK_DATA:
-      p = _("a BLOCK DATA");
-      break;
-    case COMP_INTERFACE:
-      p = _("an INTERFACE");
-      break;
-    case COMP_DERIVED:
-      p = _("a DERIVED TYPE block");
-      break;
-    case COMP_IF:
-      p = _("an IF-THEN block");
-      break;
-    case COMP_DO:
-      p = _("a DO block");
-      break;
-    case COMP_SELECT:
-      p = _("a SELECT block");
-      break;
-    case COMP_FORALL:
-      p = _("a FORALL block");
-      break;
-    case COMP_WHERE:
-      p = _("a WHERE block");
-      break;
-    case COMP_CONTAINS:
-      p = _("a contained subprogram");
-      break;
-
-    default:
-      gfc_internal_error ("gfc_state_name(): Bad state");
-    }
-
-  return p;
-}
-
-
 /* Do whatever is necessary to accept the last statement.  */
 
 static void

diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h
index 7977c63..1460ff3 100644 (file)
--- a/gcc/fortran/parse.h
+++ b/gcc/fortran/parse.h
@@ -63,6 +63,5 @@ int gfc_check_do_variable (gfc_symtree *);
 try gfc_find_state (gfc_compile_state);
 gfc_state_data *gfc_enclosing_unit (gfc_compile_state *);
 const char *gfc_ascii_statement (gfc_statement);
-const char *gfc_state_name (gfc_compile_state);
 
 #endif  /* GFC_PARSE_H  */