From ea37f786980deb2568b5ba6ea92f21666956316f Mon Sep 17 00:00:00 2001 From: fxcoudert Date: Mon, 24 Oct 2005 09:11:51 +0000 Subject: [PATCH] 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 --- gcc/fortran/ChangeLog | 24 ++++++++ gcc/fortran/arith.c | 69 +++++++++++++++++------ gcc/fortran/check.c | 148 ++++++++++++++++++++++++++++++-------------------- gcc/fortran/decl.c | 54 ++++++++++++++++-- gcc/fortran/parse.c | 57 ------------------- gcc/fortran/parse.h | 1 - 6 files changed, 213 insertions(+), 140 deletions(-) diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 095695f3bf0..5cb021b391f 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,27 @@ +2005-10-24 Francois-Xavier Coudert + + 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 PR fortran/23635 diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c index ccc7ae17222..e0c1f4b7e66 100644 --- 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 e2e95017cfc..49a7505be6f 100644 --- 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 48cb9205e7e..69c0fc87162 100644 --- 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 043c3b49e0a..69459251f04 100644 --- 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 7977c6342aa..1460ff301f6 100644 --- 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 */ -- 2.11.4.GIT