OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

error.c (gfc_error): Add variant which takes a va_list. 

2014-12-13  Tobias Burnus  <burnus@net-b.de>
            Manuel López-Ibáñez  <manu@gcc.gnu.org>

fortran/
        * error.c (gfc_error): Add variant which takes a va_list.
        (gfc_notify_std): Convert to common diagnostic.
        * array.c: Use %qs, %<...%> in more gfc_error calls and
        for gfc_notify_std.
        * check.c: Ditto.
        * data.c: Ditto.
        * decl.c: Ditto.
        * expr.c: Ditto.
        * interface.c: Ditto.
        * intrinsic.c: Ditto.
        * io.c: Ditto.
        * match.c: Ditto.
        * matchexp.c: Ditto.
        * module.c: Ditto.
        * openmp.c: Ditto.
        * parse.c: Ditto.
        * primary.c: Ditto.
        * resolve.c: Ditto.
        * simplify.c: Ditto.
        * symbol.c: Ditto.
        * trans-common.c: Ditto.
        * trans-intrinsic.c: Ditto.

gcc/testsuite/
        * gfortran.dg/realloc_on_assign_21.f90: Update dg-error.
        * gfortran.dg/warnings_are_errors_1.f: Ditto.
        * gfortran.dg/warnings_are_errors_1.f90: Ditto.


Co-Authored-By: Manuel López-Ibáñez <manu@gcc.gnu.org>

From-SVN: r218694
This commit is contained in:
Tobias Burnus 2014-12-13 00:12:06 +01:00 committed by Tobias Burnus
parent 33948765f1
commit a4d9b2212c
26 changed files with 517 additions and 408 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
gcc/fortran/ChangeLog
View File

@ -1,3 +1,29 @@
2014-12-13 Tobias Burnus <burnus@net-b.de>
Manuel López-Ibáñez <manu@gcc.gnu.org>
* error.c (gfc_error): Add variant which takes a va_list.
(gfc_notify_std): Convert to common diagnostic.
* array.c: Use %qs, %<...%> in more gfc_error calls and
for gfc_notify_std.
* check.c: Ditto.
* data.c: Ditto.
* decl.c: Ditto.
* expr.c: Ditto.
* interface.c: Ditto.
* intrinsic.c: Ditto.
* io.c: Ditto.
* match.c: Ditto.
* matchexp.c: Ditto.
* module.c: Ditto.
* openmp.c: Ditto.
* parse.c: Ditto.
* primary.c: Ditto.
* resolve.c: Ditto.
* simplify.c: Ditto.
* symbol.c: Ditto.
* trans-common.c: Ditto.
* trans-intrinsic.c: Ditto.
2014-12-11 Richard Biener <rguenther@suse.de>
PR tree-optimization/42108

2
gcc/fortran/array.c
View File

@ -684,7 +684,7 @@ coarray:
if (current_type == AS_EXPLICIT)
{
gfc_error ("Upper bound of last coarray dimension must be '*' at %C");
gfc_error ("Upper bound of last coarray dimension must be %<*%> at %C");
goto cleanup;
}

69
gcc/fortran/check.c
View File

@ -384,7 +384,7 @@ less_than_bitsize2 (const char *arg1, gfc_expr *expr1, const char *arg2,
i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
if (i2 > gfc_integer_kinds[i3].bit_size)
{
gfc_error ("'%s + %s' at %L must be less than or equal "
gfc_error ("%<%s + %s%> at %L must be less than or equal "
"to BIT_SIZE(%qs)",
arg2, arg3, &expr2->where, arg1);
return false;
@ -581,7 +581,7 @@ dim_corank_check (gfc_expr *dim, gfc_expr *array)
if (mpz_cmp_ui (dim->value.integer, 1) < 0
|| mpz_cmp_ui (dim->value.integer, corank) > 0)
{
gfc_error ("'dim' argument of %qs intrinsic at %L is not a valid "
gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid "
"codimension index", gfc_current_intrinsic, &dim->where);
return false;
@ -631,7 +631,7 @@ dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
if (mpz_cmp_ui (dim->value.integer, 1) < 0
|| mpz_cmp_ui (dim->value.integer, rank) > 0)
{
gfc_error ("'dim' argument of %qs intrinsic at %L is not a valid "
gfc_error ("%<dim%> argument of %qs intrinsic at %L is not a valid "
"dimension index", gfc_current_intrinsic, &dim->where);
return false;
@ -1378,7 +1378,7 @@ gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind)
if (x->ts.type == BT_COMPLEX)
{
gfc_error ("%qs argument of %qs intrinsic at %L must not be "
"present if 'x' is COMPLEX",
"present if %<x%> is COMPLEX",
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&y->where);
return false;
@ -1428,7 +1428,7 @@ check_co_collective (gfc_expr *a, gfc_expr *image_idx, gfc_expr *stat,
/* Fortran 2008, 12.5.2.4, paragraph 18. */
if (gfc_has_vector_subscript (a))
{
gfc_error ("Argument 'A' with INTENT(INOUT) at %L of the intrinsic "
gfc_error ("Argument %<A%> with INTENT(INOUT) at %L of the intrinsic "
"subroutine %s shall not have a vector subscript",
&a->where, gfc_current_intrinsic);
return false;
@ -1728,7 +1728,7 @@ gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
return false;
if (!kind_check (kind, 2, BT_INTEGER))
return false;
if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
"with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;
@ -1835,7 +1835,7 @@ gfc_check_dcmplx (gfc_expr *x, gfc_expr *y)
if (x->ts.type == BT_COMPLEX)
{
gfc_error ("%qs argument of %qs intrinsic at %L must not be "
"present if 'x' is COMPLEX",
"present if %<x%> is COMPLEX",
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&y->where);
return false;
@ -1908,7 +1908,8 @@ gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
if (! identical_dimen_shape (vector_a, 0, vector_b, 0))
{
gfc_error ("Different shape for arguments %qs and %qs at %L for "
"intrinsic 'dot_product'", gfc_current_intrinsic_arg[0]->name,
"intrinsic %<dot_product%>",
gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic_arg[1]->name, &vector_a->where);
return false;
}
@ -2146,9 +2147,9 @@ gfc_check_fn_rc2008 (gfc_expr *a)
return false;
if (a->ts.type == BT_COMPLEX
&& !gfc_notify_std (GFC_STD_F2008, "COMPLEX argument '%s' "
"of '%s' intrinsic at %L",
gfc_current_intrinsic_arg[0]->name,
&& !gfc_notify_std (GFC_STD_F2008, "COMPLEX argument %qs "
"of %qs intrinsic at %L",
gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &a->where))
return false;
@ -2259,7 +2260,7 @@ gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
if (!kind_check (kind, 1, BT_INTEGER))
return false;
if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
"with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;
@ -2362,7 +2363,7 @@ gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back,
if (!kind_check (kind, 3, BT_INTEGER))
return false;
if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
"with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;
@ -2556,7 +2557,7 @@ gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
if (!kind_check (kind, 2, BT_INTEGER))
return false;
if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
"with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;
@ -2601,7 +2602,7 @@ gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind)
if (!kind_check (kind, 1, BT_INTEGER))
return false;
if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
"with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;
@ -2840,7 +2841,7 @@ check_rest (bt type, int kind, gfc_actual_arglist *arglist)
}
else
{
gfc_error ("'a%d' argument of %qs intrinsic at %L must be "
gfc_error ("%<a%d%> argument of %qs intrinsic at %L must be "
"%s(%d)", n, gfc_current_intrinsic, &x->where,
gfc_basic_typename (type), kind);
return false;
@ -2848,9 +2849,9 @@ check_rest (bt type, int kind, gfc_actual_arglist *arglist)
}
for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++)
if (!gfc_check_conformance (tmp->expr, x,
if (!gfc_check_conformance (tmp->expr, x,
"arguments 'a%d' and 'a%d' for "
"intrinsic '%s'", m, n,
"intrinsic '%s'", m, n,
gfc_current_intrinsic))
return false;
}
@ -2871,14 +2872,14 @@ gfc_check_min_max (gfc_actual_arglist *arg)
if (x->ts.type == BT_CHARACTER)
{
if (!gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
if (!gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
"with CHARACTER argument at %L",
gfc_current_intrinsic, &x->where))
return false;
}
else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
{
gfc_error ("'a1' argument of %qs intrinsic at %L must be INTEGER, "
gfc_error ("%<a1%> argument of %qs intrinsic at %L must be INTEGER, "
"REAL or CHARACTER", gfc_current_intrinsic, &x->where);
return false;
}
@ -3287,7 +3288,7 @@ gfc_check_nearest (gfc_expr *x, gfc_expr *s)
{
if (mpfr_sgn (s->value.real) == 0)
{
gfc_error ("Argument 'S' of NEAREST at %L shall not be zero",
gfc_error ("Argument %<S%> of NEAREST at %L shall not be zero",
&s->where);
return false;
}
@ -3661,7 +3662,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
if (!gfc_array_size (shape, &size))
{
gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L must be an "
"array of constant size", &shape->where);
return false;
}
@ -3678,7 +3679,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
}
else if (shape_size > GFC_MAX_DIMENSIONS)
{
gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
gfc_error ("%<shape%> argument of %<reshape%> intrinsic at %L has more "
"than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
return false;
}
@ -3764,7 +3765,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
{
gfc_error ("%qs argument of %qs intrinsic at %L has "
"invalid permutation of dimensions (dimension "
"'%d' duplicated)",
"%<%d%> duplicated)",
gfc_current_intrinsic_arg[3]->name,
gfc_current_intrinsic, &e->where, dim);
return false;
@ -3882,7 +3883,7 @@ gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
if (!kind_check (kind, 3, BT_INTEGER))
return false;
if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
"with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;
@ -3944,7 +3945,7 @@ gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix)
{
if (p == NULL && r == NULL
&& !gfc_notify_std (GFC_STD_F2008, "SELECTED_REAL_KIND with"
" neither 'P' nor 'R' argument at %L",
" neither %<P%> nor %<R%> argument at %L",
gfc_current_intrinsic_where))
return false;
@ -3974,7 +3975,7 @@ gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix)
if (!scalar_check (radix, 1))
return false;
if (!gfc_notify_std (GFC_STD_F2008, "'%s' intrinsic with "
if (!gfc_notify_std (GFC_STD_F2008, "%qs intrinsic with "
"RADIX argument at %L", gfc_current_intrinsic,
&radix->where))
return false;
@ -4009,14 +4010,14 @@ gfc_check_shape (gfc_expr *source, gfc_expr *kind)
if (ar->as && ar->as->type == AS_ASSUMED_SIZE && ar->type == AR_FULL)
{
gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
gfc_error ("%<source%> argument of %<shape%> intrinsic at %L must not be "
"an assumed size array", &source->where);
return false;
}
if (!kind_check (kind, 1, BT_INTEGER))
return false;
if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
"with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;
@ -4071,7 +4072,7 @@ gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
if (!kind_check (kind, 2, BT_INTEGER))
return false;
if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
"with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;
@ -5053,8 +5054,8 @@ gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
if (mold->ts.type == BT_HOLLERITH)
{
gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s",
&mold->where, gfc_basic_typename (BT_HOLLERITH));
gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L must not be"
" %s", &mold->where, gfc_basic_typename (BT_HOLLERITH));
return false;
}
@ -5113,7 +5114,7 @@ gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
if (!kind_check (kind, 2, BT_INTEGER))
return false;
if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
"with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;
@ -5242,7 +5243,7 @@ gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
if (!kind_check (kind, 3, BT_INTEGER))
return false;
if (kind && !gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic "
if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
"with KIND argument at %L",
gfc_current_intrinsic, &kind->where))
return false;

4
gcc/fortran/data.c
View File

@ -324,7 +324,7 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index,
> LOCATION_LINE (rvalue->where.lb->location))
? con->expr : rvalue;
if (gfc_notify_std (GFC_STD_GNU,
"re-initialization of '%s' at %L",
"re-initialization of %qs at %L",
symbol->name, &exprd->where) == false)
return false;
}
@ -490,7 +490,7 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index,
> LOCATION_LINE (rvalue->where.lb->location))
? init : rvalue;
if (gfc_notify_std (GFC_STD_GNU,
"re-initialization of '%s' at %L",
"re-initialization of %qs at %L",
symbol->name, &expr->where) == false)
return false;
}

44
gcc/fortran/decl.c
View File

@ -269,7 +269,7 @@ var_element (gfc_data_variable *new_var)
if (gfc_current_state () != COMP_BLOCK_DATA
&& sym->attr.in_common
&& !gfc_notify_std (GFC_STD_GNU, "initialization of "
"common block variable '%s' in DATA statement at %C",
"common block variable %qs in DATA statement at %C",
sym->name))
return MATCH_ERROR;
@ -1059,16 +1059,16 @@ gfc_verify_c_interop_param (gfc_symbol *sym)
not have the allocatable, pointer, or optional attributes,
according to J3/04-007, section 5.1. */
if (sym->attr.allocatable == 1
&& !gfc_notify_std (GFC_STD_F2008_TS, "Variable '%s' at %L with "
"ALLOCATABLE attribute in procedure '%s' "
&& !gfc_notify_std (GFC_STD_F2008_TS, "Variable %qs at %L with "
"ALLOCATABLE attribute in procedure %qs "
"with BIND(C)", sym->name,
&(sym->declared_at),
sym->ns->proc_name->name))
retval = false;
if (sym->attr.pointer == 1
&& !gfc_notify_std (GFC_STD_F2008_TS, "Variable '%s' at %L with "
"POINTER attribute in procedure '%s' "
&& !gfc_notify_std (GFC_STD_F2008_TS, "Variable %qs at %L with "
"POINTER attribute in procedure %qs "
"with BIND(C)", sym->name,
&(sym->declared_at),
sym->ns->proc_name->name))
@ -1092,9 +1092,9 @@ gfc_verify_c_interop_param (gfc_symbol *sym)
retval = false;
}
else if (sym->attr.optional == 1
&& !gfc_notify_std (GFC_STD_F2008_TS, "Variable '%s' "
&& !gfc_notify_std (GFC_STD_F2008_TS, "Variable %qs "
"at %L with OPTIONAL attribute in "
"procedure '%s' which is BIND(C)",
"procedure %qs which is BIND(C)",
sym->name, &(sym->declared_at),
sym->ns->proc_name->name))
retval = false;
@ -1103,7 +1103,7 @@ gfc_verify_c_interop_param (gfc_symbol *sym)
either assumed size or explicit shape. Deferred shape is already
covered by the pointer/allocatable attribute. */
if (sym->as != NULL && sym->as->type == AS_ASSUMED_SHAPE
&& !gfc_notify_std (GFC_STD_F2008_TS, "Assumed-shape array '%s' "
&& !gfc_notify_std_1 (GFC_STD_F2008_TS, "Assumed-shape array '%s' "
"at %L as dummy argument to the BIND(C) "
"procedure '%s' at %L", sym->name,
&(sym->declared_at),
@ -2031,8 +2031,8 @@ variable_decl (int elem)
{
if (current_attr.pointer)
{
gfc_error ("Pointer initialization at %C requires '=>', "
"not '='");
gfc_error ("Pointer initialization at %C requires %<=>%>, "
"not %<=%>");
m = MATCH_ERROR;
goto cleanup;
}
@ -5096,7 +5096,7 @@ match_ppc_decl (void)
/* Match the colons (required). */
if (gfc_match (" ::") != MATCH_YES)
{
gfc_error ("Expected '::' after binding-attributes at %C");
gfc_error ("Expected %<::%> after binding-attributes at %C");
return MATCH_ERROR;
}
@ -6565,7 +6565,7 @@ cray_pointer_decl (void)
{
if (gfc_match_char ('(') != MATCH_YES)
{
gfc_error ("Expected '(' at %C");
gfc_error ("Expected %<(%> at %C");
return MATCH_ERROR;
}
@ -6680,7 +6680,7 @@ cray_pointer_decl (void)
if (m == MATCH_ERROR /* Failed when trying to find ',' above. */
|| gfc_match_eos () != MATCH_YES)
{
gfc_error ("Expected \",\" or end of statement at %C");
gfc_error ("Expected %<,%> or end of statement at %C");
return MATCH_ERROR;
}
return MATCH_YES;
@ -8272,13 +8272,13 @@ match_procedure_in_type (void)
return m;
if (m != MATCH_YES)
{
gfc_error ("Interface-name expected after '(' at %C");
gfc_error ("Interface-name expected after %<(%> at %C");
return MATCH_ERROR;
}
if (gfc_match (" )") != MATCH_YES)
{
gfc_error ("')' expected at %C");
gfc_error ("%<)%> expected at %C");
return MATCH_ERROR;
}
@ -8314,7 +8314,7 @@ match_procedure_in_type (void)
seen_colons = (m == MATCH_YES);
if (seen_attrs && !seen_colons)
{
gfc_error ("Expected '::' after binding-attributes at %C");
gfc_error ("Expected %<::%> after binding-attributes at %C");
return MATCH_ERROR;
}
@ -8342,13 +8342,13 @@ match_procedure_in_type (void)
{
if (tb.deferred)
{
gfc_error ("'=> target' is invalid for DEFERRED binding at %C");
gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
return MATCH_ERROR;
}
if (!seen_colons)
{
gfc_error ("'::' needed in PROCEDURE binding with explicit target"
gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
" at %C");
return MATCH_ERROR;
}
@ -8358,7 +8358,7 @@ match_procedure_in_type (void)
return m;
if (m == MATCH_NO)
{
gfc_error ("Expected binding target after '=>' at %C");
gfc_error ("Expected binding target after %<=>%> at %C");
return MATCH_ERROR;
}
target = target_buf;
@ -8455,7 +8455,7 @@ gfc_match_generic (void)
/* Now the colons, those are required. */
if (gfc_match (" ::") != MATCH_YES)
{
gfc_error ("Expected '::' at %C");
gfc_error ("Expected %<::%> at %C");
goto error;
}
@ -8493,7 +8493,7 @@ gfc_match_generic (void)
/* Match the required =>. */
if (gfc_match (" =>") != MATCH_YES)
{
gfc_error ("Expected '=>' at %C");
gfc_error ("Expected %<=>%> at %C");
goto error;
}
@ -8705,7 +8705,7 @@ gfc_match_final_decl (void)
last = true;
if (!last && gfc_match_char (',') != MATCH_YES)
{
gfc_error ("Expected ',' at %C");
gfc_error ("Expected %<,%> at %C");
return MATCH_ERROR;
}

94
gcc/fortran/error.c
View File

@ -68,6 +68,12 @@ gfc_push_suppress_errors (void)
++suppress_errors;
}
static void
gfc_error (const char *gmsgid, va_list ap) ATTRIBUTE_GCC_GFC(1,0);
static bool
gfc_warning (int opt, const char *gmsgid, va_list ap) ATTRIBUTE_GCC_GFC(2,0);
/* Leave one level of error suppressing. */
@ -835,9 +841,6 @@ gfc_warning_1 (const char *gmsgid, ...)
/* This is just a helper function to avoid duplicating the logic of
gfc_warning. */
static bool
gfc_warning (int opt, const char *gmsgid, va_list ap) ATTRIBUTE_GCC_GFC(2,0);
static bool
gfc_warning (int opt, const char *gmsgid, va_list ap)
{
@ -935,7 +938,7 @@ gfc_notification_std (int std)
an error is generated. */
bool
gfc_notify_std (int std, const char *gmsgid, ...)
gfc_notify_std_1 (int std, const char *gmsgid, ...)
{
va_list argp;
bool warning;
@ -1012,6 +1015,68 @@ gfc_notify_std (int std, const char *gmsgid, ...)
}
bool
gfc_notify_std (int std, const char *gmsgid, ...)
{
va_list argp;
bool warning;
const char *msg, *msg2;
char *buffer;
warning = ((gfc_option.warn_std & std) != 0) && !inhibit_warnings;
if ((gfc_option.allow_std & std) != 0 && !warning)
return true;
if (suppress_errors)
return warning ? true : false;
switch (std)
{
case GFC_STD_F2008_TS:
msg = "TS 29113/TS 18508:";
break;
case GFC_STD_F2008_OBS:
msg = _("Fortran 2008 obsolescent feature:");
break;
case GFC_STD_F2008:
msg = "Fortran 2008:";
break;
case GFC_STD_F2003:
msg = "Fortran 2003:";
break;
case GFC_STD_GNU:
msg = _("GNU Extension:");
break;
case GFC_STD_LEGACY:
msg = _("Legacy Extension:");
break;
case GFC_STD_F95_OBS:
msg = _("Obsolescent feature:");
break;
case GFC_STD_F95_DEL:
msg = _("Deleted feature:");
break;
default:
gcc_unreachable ();
}
msg2 = _(gmsgid);
buffer = (char *) alloca (strlen (msg) + strlen (msg2) + 2);
strcpy (buffer, msg);
strcat (buffer, " ");
strcat (buffer, msg2);
va_start (argp, gmsgid);
if (warning)
gfc_warning (0, buffer, argp);
else
gfc_error (buffer, argp);
va_end (argp);
return (warning && !warnings_are_errors) ? true : false;
}
/* Immediate warning (i.e. do not buffer the warning). */
/* Use gfc_warning_now instead, unless two locations are used in the same
warning or for scanner.c, if the location is not properly set up. */
@ -1349,11 +1414,11 @@ warning:
two locations; when being used in scanner.c, ensure that the location
is properly setup. Otherwise, use gfc_error_1. */
void
gfc_error (const char *gmsgid, ...)
static void
gfc_error (const char *gmsgid, va_list ap)
{
va_list argp;
va_start (argp, gmsgid);
va_copy (argp, ap);
if (warnings_not_errors)
{
@ -1380,8 +1445,8 @@ gfc_error (const char *gmsgid, ...)
pp->buffer = pp_error_buffer;
global_dc->fatal_errors = false;
/* To prevent -fmax-errors= triggering, we decrease it before
report_diagnostic increases it. */
--errorcount;
report_diagnostic increases it. */
--errorcount;
}
diagnostic_set_info (&diagnostic, gmsgid, &argp, UNKNOWN_LOCATION, DK_ERROR);
@ -1392,11 +1457,20 @@ gfc_error (const char *gmsgid, ...)
pp->buffer = tmp_buffer;
global_dc->fatal_errors = fatal_errors;
}
va_end (argp);
}
void
gfc_error (const char *gmsgid, ...)
{
va_list argp;
va_start (argp, gmsgid);
gfc_error (gmsgid, argp);
va_end (argp);
}
/* Immediate error. */
/* Use gfc_error_now instead, unless two locations are used in the same

15
gcc/fortran/expr.c
View File

@ -145,7 +145,8 @@ gfc_get_constant_expr (bt type, int kind, locus *where)
gfc_expr *e;
if (!where)
gfc_internal_error ("gfc_get_constant_expr(): locus 'where' cannot be NULL");
gfc_internal_error ("gfc_get_constant_expr(): locus %<where%> cannot be "
"NULL");
e = gfc_get_expr ();
@ -3185,7 +3186,7 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER
&& lvalue->symtree->n.sym->attr.data
&& !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L used to "
"initialize non-integer variable '%s'",
"initialize non-integer variable %qs",
&rvalue->where, lvalue->symtree->n.sym->name))
return false;
else if (rvalue->is_boz && !lvalue->symtree->n.sym->attr.data
@ -3210,15 +3211,15 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
if (rc == ARITH_UNDERFLOW)
gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
". This check can be disabled with the option "
"-fno-range-check", &rvalue->where);
"%<-fno-range-check%>", &rvalue->where);
else if (rc == ARITH_OVERFLOW)
gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
". This check can be disabled with the option "
"-fno-range-check", &rvalue->where);
"%<-fno-range-check%>", &rvalue->where);
else if (rc == ARITH_NAN)
gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
". This check can be disabled with the option "
"-fno-range-check", &rvalue->where);
"%<-fno-range-check%>", &rvalue->where);
return false;
}
}
@ -3360,7 +3361,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
}
if (!gfc_notify_std (GFC_STD_F2003, "Bounds specification "
"for '%s' in pointer assignment at %L",
"for %qs in pointer assignment at %L",
lvalue->symtree->n.sym->name, &lvalue->where))
return false;
@ -3486,7 +3487,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
return false;
}
if (attr.proc == PROC_INTERNAL &&
!gfc_notify_std(GFC_STD_F2008, "Internal procedure '%s' "
!gfc_notify_std(GFC_STD_F2008, "Internal procedure %qs "
"is invalid in procedure pointer assignment "
"at %L", rvalue->symtree->name, &rvalue->where))
return false;

1
gcc/fortran/gfortran.h
View File

@ -2693,6 +2693,7 @@ bool gfc_error_check (void);
bool gfc_error_flag_test (void);
notification gfc_notification_std (int);
bool gfc_notify_std_1 (int, const char *, ...) ATTRIBUTE_GCC_GFC(2,3);
bool gfc_notify_std (int, const char *, ...) ATTRIBUTE_GCC_GFC(2,3);
/* A general purpose syntax error. */

12
gcc/fortran/interface.c
View File

@ -316,7 +316,7 @@ gfc_match_end_interface (void)
if (current_interface.op == INTRINSIC_ASSIGN)
{
m = MATCH_ERROR;
gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
gfc_error ("Expected %<END INTERFACE ASSIGNMENT (=)%> at %C");
}
else
{
@ -346,7 +346,7 @@ gfc_match_end_interface (void)
break;
m = MATCH_ERROR;
gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C, "
gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> at %C, "
"but got %s", s1, s2);
}
@ -360,7 +360,7 @@ gfc_match_end_interface (void)
if (type != current_interface.type
|| strcmp (current_interface.uop->name, name) != 0)
{
gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C",
gfc_error ("Expecting %<END INTERFACE OPERATOR (.%s.)%> at %C",
current_interface.uop->name);
m = MATCH_ERROR;
}
@ -371,7 +371,7 @@ gfc_match_end_interface (void)
if (type != current_interface.type
|| strcmp (current_interface.sym->name, name) != 0)
{
gfc_error ("Expecting 'END INTERFACE %s' at %C",
gfc_error ("Expecting %<END INTERFACE %s%> at %C",
current_interface.sym->name);
m = MATCH_ERROR;
}
@ -1226,7 +1226,7 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
case -2:
/* FIXME: Implement a warning for this case.
gfc_warning ("Possible shape mismatch in argument '%s'",
gfc_warning ("Possible shape mismatch in argument %qs",
s1->name);*/
break;
@ -1589,7 +1589,7 @@ check_interface0 (gfc_interface *p, const char *interface_name)
/* F2003, C1207. F2008, C1207. */
if (p->sym->attr.proc == PROC_INTERNAL
&& !gfc_notify_std (GFC_STD_F2008, "Internal procedure "
"'%s' in %s at %L", p->sym->name,
"%qs in %s at %L", p->sym->name,
interface_name, &p->sym->declared_at))
return 1;
}

2
gcc/fortran/intrinsic.c
View File

@ -4387,7 +4387,7 @@ gfc_intrinsic_func_interface (gfc_expr *expr, int error_flag)
if ((isym->id == GFC_ISYM_REAL || isym->id == GFC_ISYM_DBLE
|| isym->id == GFC_ISYM_CMPLX)
&& gfc_init_expr_flag
&& !gfc_notify_std (GFC_STD_F2003, "Function '%s' as initialization "
&& !gfc_notify_std (GFC_STD_F2003, "Function %qs as initialization "
"expression at %L", name, &expr->where))
{
if (!error_flag)

34
gcc/fortran/io.c
View File

@ -550,8 +550,8 @@ check_format (bool is_input)
{
const char *posint_required = _("Positive width required");
const char *nonneg_required = _("Nonnegative width required");
const char *unexpected_element = _("Unexpected element '%c' in format string"
" at %L");
const char *unexpected_element = _("Unexpected element %<%c%> in format "
"string at %L");
const char *unexpected_end = _("Unexpected end of format string");
const char *zero_width = _("Zero width in format descriptor");
@ -602,7 +602,7 @@ format_item_1:
level++;
goto format_item;
}
error = _("Left parenthesis required after '*'");
error = _("Left parenthesis required after %<*%>");
goto syntax;
case FMT_POSINT:
@ -823,7 +823,7 @@ data_desc:
error = zero_width;
goto syntax;
}
if (!gfc_notify_std (GFC_STD_F2008, "'G0' in format at %L",
if (!gfc_notify_std (GFC_STD_F2008, "%<G0%> in format at %L",
&format_locus))
return false;
u = format_lex ();
@ -1408,14 +1408,14 @@ resolve_tag_format (const gfc_expr *e)
return false;
if (e->symtree->n.sym->attr.assign != 1)
{
gfc_error ("Variable '%s' at %L has not been assigned a "
gfc_error ("Variable %qs at %L has not been assigned a "
"format label", e->symtree->n.sym->name, &e->where);
return false;
}
}
else if (e->ts.type == BT_INTEGER)
{
gfc_error ("Scalar '%s' in FORMAT tag at %L is not an ASSIGNED "
gfc_error ("Scalar %qs in FORMAT tag at %L is not an ASSIGNED "
"variable", gfc_basic_typename (e->ts.type), &e->where);
return false;
}
@ -1729,7 +1729,7 @@ compare_to_allowed_values (const char *specifier, const char *allowed[],
if (n == ERROR)
{
gfc_notify_std (GFC_STD_F2003, "%s specifier in "
"%s statement at %C has value '%s'", specifier,
"%s statement at %C has value %qs", specifier,
statement, allowed_f2003[i]);
return 0;
}
@ -1756,7 +1756,7 @@ compare_to_allowed_values (const char *specifier, const char *allowed[],
if (n == ERROR)
{
gfc_notify_std (GFC_STD_GNU, "%s specifier in "
"%s statement at %C has value '%s'", specifier,
"%s statement at %C has value %qs", specifier,
statement, allowed_gnu[i]);
return 0;
}
@ -1768,7 +1768,7 @@ compare_to_allowed_values (const char *specifier, const char *allowed[],
if (warn)
{
char *s = gfc_widechar_to_char (value, -1);
gfc_warning ("%s specifier in %s statement at %C has invalid value '%s'",
gfc_warning ("%s specifier in %s statement at %C has invalid value %qs",
specifier, statement, s);
free (s);
return 1;
@ -1776,7 +1776,7 @@ compare_to_allowed_values (const char *specifier, const char *allowed[],
else
{
char *s = gfc_widechar_to_char (value, -1);
gfc_error ("%s specifier in %s statement at %C has invalid value '%s'",
gfc_error ("%s specifier in %s statement at %C has invalid value %qs",
specifier, statement, s);
free (s);
return 0;
@ -2085,7 +2085,7 @@ gfc_match_open (void)
char *s = gfc_widechar_to_char (open->status->value.character.string,
-1);
warn_or_error ("The STATUS specified in OPEN statement at %C is "
"'%s' and no FILE specifier is present", s);
"%qs and no FILE specifier is present", s);
free (s);
}
@ -2618,7 +2618,7 @@ check_namelist (gfc_symbol *sym)
for (p = sym->namelist; p; p = p->next)
if (p->sym->attr.intent == INTENT_IN)
{
gfc_error ("Symbol '%s' in namelist '%s' is INTENT(IN) at %C",
gfc_error ("Symbol %qs in namelist %qs is INTENT(IN) at %C",
p->sym->name, sym->name);
return 1;
}
@ -2663,7 +2663,7 @@ match_dt_element (io_kind k, gfc_dt *dt)
if (sym == NULL || sym->attr.flavor != FL_NAMELIST)
{
gfc_error ("Symbol '%s' at %C must be a NAMELIST group name",
gfc_error ("Symbol %qs at %C must be a NAMELIST group name",
sym != NULL ? sym->name : name);
return MATCH_ERROR;
}
@ -2892,8 +2892,8 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc)
if (!t)
{
gfc_error ("NAMELIST '%s' in READ statement at %L contains"
" the symbol '%s' which may not appear in a"
gfc_error ("NAMELIST %qs in READ statement at %L contains"
" the symbol %qs which may not appear in a"
" variable definition context",
dt->namelist->name, loc, n->sym->name);
return false;
@ -3533,11 +3533,11 @@ if (condition) \
"YES or NO.", &expr->where);
io_constraint (dt->size && not_no && k == M_READ,
"SIZE tag at %L requires an ADVANCE = 'NO'",
"SIZE tag at %L requires an ADVANCE = %<NO%>",
&dt->size->where);
io_constraint (dt->eor && not_no && k == M_READ,
"EOR tag at %L requires an ADVANCE = 'NO'",
"EOR tag at %L requires an ADVANCE = %<NO%>",
&dt->eor_where);
}

48
gcc/fortran/match.c
View File

@ -162,12 +162,12 @@ gfc_match_parens (void)
if (count > 0)
{
gfc_error ("Missing ')' in statement at or before %L", &where);
gfc_error ("Missing %<)%> in statement at or before %L", &where);
return MATCH_ERROR;
}
if (count < 0)
{
gfc_error ("Missing '(' in statement at or before %L", &where);
gfc_error ("Missing %<(%> in statement at or before %L", &where);
return MATCH_ERROR;
}
@ -496,13 +496,13 @@ gfc_match_label (void)
if (gfc_get_symbol (name, NULL, &gfc_new_block))
{
gfc_error ("Label name '%s' at %C is ambiguous", name);
gfc_error ("Label name %qs at %C is ambiguous", name);
return MATCH_ERROR;
}
if (gfc_new_block->attr.flavor == FL_LABEL)
{
gfc_error ("Duplicate construct label '%s' at %C", name);
gfc_error ("Duplicate construct label %qs at %C", name);
return MATCH_ERROR;
}
@ -1554,7 +1554,7 @@ gfc_match_else (void)
if (strcmp (name, gfc_current_block ()->name) != 0)
{
gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
gfc_error ("Label %qs at %C doesn't match IF label %qs",
name, gfc_current_block ()->name);
return MATCH_ERROR;
}
@ -1589,7 +1589,7 @@ gfc_match_elseif (void)
if (strcmp (name, gfc_current_block ()->name) != 0)
{
gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
gfc_error ("Label %qs at %C doesn't match IF label %qs",
name, gfc_current_block ()->name);
goto cleanup;
}
@ -1746,7 +1746,7 @@ gfc_match_associate (void)
for (a = new_st.ext.block.assoc; a; a = a->next)
if (!strcmp (a->name, newAssoc->name))
{
gfc_error ("Duplicate name '%s' in association at %C",
gfc_error ("Duplicate name %qs in association at %C",
newAssoc->name);
goto assocListError;
}
@ -1772,7 +1772,7 @@ gfc_match_associate (void)
break;
if (gfc_match_char (',') != MATCH_YES)
{
gfc_error ("Expected ')' or ',' at %C");
gfc_error ("Expected %<)%> or %<,%> at %C");
return MATCH_ERROR;
}
@ -1859,7 +1859,7 @@ gfc_match_type_spec (gfc_typespec *ts)
/* Enforce F03:C401. */
if (ts->u.derived->attr.abstract)
{
gfc_error ("Derived type '%s' at %L may not be ABSTRACT",
gfc_error ("Derived type %qs at %L may not be ABSTRACT",
ts->u.derived->name, &old_locus);
return MATCH_ERROR;
}
@ -2406,7 +2406,7 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op)
stree = gfc_find_symtree_in_proc (name, gfc_current_ns);
if (!stree)
{
gfc_error ("Name '%s' in %s statement at %C is unknown",
gfc_error ("Name %qs in %s statement at %C is unknown",
name, gfc_ascii_statement (st));
return MATCH_ERROR;
}
@ -2414,7 +2414,7 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op)
sym = stree->n.sym;
if (sym->attr.flavor != FL_LABEL)
{
gfc_error ("Name '%s' in %s statement at %C is not a construct name",
gfc_error ("Name %qs in %s statement at %C is not a construct name",
name, gfc_ascii_statement (st));
return MATCH_ERROR;
}
@ -2449,7 +2449,7 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op)
gfc_error ("%s statement at %C is not within a construct",
gfc_ascii_statement (st));
else
gfc_error ("%s statement at %C is not within construct '%s'",
gfc_error ("%s statement at %C is not within construct %qs",
gfc_ascii_statement (st), sym->name);
return MATCH_ERROR;
@ -2475,7 +2475,7 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op)
if (op == EXEC_CYCLE)
{
gfc_error ("CYCLE statement at %C is not applicable to non-loop"
" construct '%s'", sym->name);
" construct %qs", sym->name);
return MATCH_ERROR;
}
gcc_assert (op == EXEC_EXIT);
@ -2485,7 +2485,7 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op)
break;
default:
gfc_error ("%s statement at %C is not applicable to construct '%s'",
gfc_error ("%s statement at %C is not applicable to construct %qs",
gfc_ascii_statement (st), sym->name);
return MATCH_ERROR;
}
@ -4323,7 +4323,7 @@ gfc_match_common (void)
if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL)
|| sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
{
if (!gfc_notify_std (GFC_STD_GNU, "Initialized symbol '%s' at "
if (!gfc_notify_std (GFC_STD_GNU, "Initialized symbol %qs at "
"%C can only be COMMON in BLOCK DATA",
sym->name))
goto cleanup;
@ -4349,7 +4349,7 @@ gfc_match_common (void)
{
if (as->type != AS_EXPLICIT)
{
gfc_error ("Array specification for symbol '%s' in COMMON "
gfc_error ("Array specification for symbol %qs in COMMON "
"at %C must be explicit", sym->name);
goto cleanup;
}
@ -4359,7 +4359,7 @@ gfc_match_common (void)
if (sym->attr.pointer)
{
gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
gfc_error ("Symbol %qs in COMMON at %C cannot be a "
"POINTER array", sym->name);
goto cleanup;
}
@ -4391,9 +4391,9 @@ gfc_match_common (void)
if (other->common_head
&& other->common_head != sym->common_head)
{
gfc_error ("Symbol '%s', in COMMON block '%s' at "
gfc_error ("Symbol %qs, in COMMON block %qs at "
"%C is being indirectly equivalenced to "
"another COMMON block '%s'",
"another COMMON block %qs",
sym->name, sym->common_head->name,
other->common_head->name);
goto cleanup;
@ -4519,7 +4519,7 @@ gfc_match_namelist (void)
{
if (group_name->ts.type != BT_UNKNOWN)
{
gfc_error ("Namelist group name '%s' at %C already has a basic "
gfc_error ("Namelist group name %qs at %C already has a basic "
"type of %s", group_name->name,
gfc_typename (&group_name->ts));
return MATCH_ERROR;
@ -4527,7 +4527,7 @@ gfc_match_namelist (void)
if (group_name->attr.flavor == FL_NAMELIST
&& group_name->attr.use_assoc
&& !gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
&& !gfc_notify_std (GFC_STD_GNU, "Namelist group name %qs "
"at %C already is USE associated and can"
"not be respecified.", group_name->name))
return MATCH_ERROR;
@ -4553,7 +4553,7 @@ gfc_match_namelist (void)
these are the only errors for the next two lines. */
if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
{
gfc_error ("Assumed size array '%s' in namelist '%s' at "
gfc_error ("Assumed size array %qs in namelist %qs at "
"%C is not allowed", sym->name, group_name->name);
gfc_error_check ();
}
@ -4991,7 +4991,7 @@ match_case_eos (void)
if (strcmp (name, gfc_current_block ()->name) != 0)
{
gfc_error ("Expected block name '%s' of SELECT construct at %C",
gfc_error ("Expected block name %qs of SELECT construct at %C",
gfc_current_block ()->name);
return MATCH_ERROR;
}
@ -5669,7 +5669,7 @@ gfc_match_elsewhere (void)
if (strcmp (name, gfc_current_block ()->name) != 0)
{
gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
gfc_error ("Label %qs at %C doesn't match WHERE label %qs",
name, gfc_current_block ()->name);
goto cleanup;
}

4
gcc/fortran/matchexp.c
View File

@ -69,7 +69,7 @@ gfc_match_defined_op_name (char *result, int error_flag)
for (i = 0; name[i]; i++)
if (!ISALPHA (name[i]))
{
gfc_error ("Bad character '%c' in OPERATOR name at %C", name[i]);
gfc_error ("Bad character %<%c%> in OPERATOR name at %C", name[i]);
return MATCH_ERROR;
}
@ -77,7 +77,7 @@ gfc_match_defined_op_name (char *result, int error_flag)
return MATCH_YES;
error:
gfc_error ("The name '%s' cannot be used as a defined operator at %C",
gfc_error ("The name %qs cannot be used as a defined operator at %C",
name);
gfc_current_locus = old_loc;

36
gcc/fortran/module.c
View File

@ -670,7 +670,7 @@ gfc_match_use (void)
if (strcmp (new_use->use_name, use_list->module_name) == 0
|| strcmp (new_use->local_name, use_list->module_name) == 0)
{
gfc_error ("The name '%s' at %C has already been used as "
gfc_error ("The name %qs at %C has already been used as "
"an external module name.", use_list->module_name);
goto cleanup;
}
@ -4855,7 +4855,7 @@ check_for_ambiguous (gfc_symbol *st_sym, pointer_info *info)
if (gfc_current_ns->proc_name && st_sym->name == gfc_current_ns->proc_name->name)
{
gfc_error ("'%s' of module '%s', imported at %C, is also the name of the "
gfc_error ("%qs of module %qs, imported at %C, is also the name of the "
"current program unit", st_sym->name, module_name);
return true;
}
@ -5206,20 +5206,20 @@ read_module (void)
if (u->op == INTRINSIC_NONE)
{
gfc_error ("Symbol '%s' referenced at %L not found in module '%s'",
gfc_error ("Symbol %qs referenced at %L not found in module %qs",
u->use_name, &u->where, module_name);
continue;
}
if (u->op == INTRINSIC_USER)
{
gfc_error ("User operator '%s' referenced at %L not found "
"in module '%s'", u->use_name, &u->where, module_name);
gfc_error ("User operator %qs referenced at %L not found "
"in module %qs", u->use_name, &u->where, module_name);
continue;
}
gfc_error ("Intrinsic operator '%s' referenced at %L not found "
"in module '%s'", gfc_op2string (u->op), &u->where,
gfc_error ("Intrinsic operator %qs referenced at %L not found "
"in module %qs", gfc_op2string (u->op), &u->where,
module_name);
}
@ -6050,7 +6050,7 @@ gfc_dump_module (const char *name, int dump_flag)
else
{
if (remove (filename_tmp))
gfc_fatal_error ("Can't delete temporary module file '%s': %s",
gfc_fatal_error ("Can't delete temporary module file %qs: %s",
filename_tmp, xstrerror (errno));
}
}
@ -6070,7 +6070,7 @@ create_intrinsic_function (const char *name, int id,
{
if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
return;
gfc_error ("Symbol '%s' already declared", name);
gfc_error ("Symbol %qs already declared", name);
}
gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
@ -6248,7 +6248,7 @@ import_iso_c_binding_module (void)
if (not_in_std)
{
gfc_error ("The symbol '%s', referenced at %L, is not "
gfc_error ("The symbol %qs, referenced at %L, is not "
"in the selected standard", name, &u->where);
continue;
}
@ -6376,7 +6376,7 @@ import_iso_c_binding_module (void)
if (u->found)
continue;
gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
gfc_error ("Symbol %qs referenced at %L not found in intrinsic "
"module ISO_C_BINDING", u->use_name, &u->where);
}
}
@ -6397,7 +6397,7 @@ create_int_parameter (const char *name, int value, const char *modname,
if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
return;
else
gfc_error ("Symbol '%s' already declared", name);
gfc_error ("Symbol %qs already declared", name);
}
gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
@ -6430,7 +6430,7 @@ create_int_parameter_array (const char *name, int size, gfc_expr *value,
if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
return;
else
gfc_error ("Symbol '%s' already declared", name);
gfc_error ("Symbol %qs already declared", name);
}
gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
@ -6472,7 +6472,7 @@ create_derived_type (const char *name, const char *modname,
if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
return;
else
gfc_error ("Symbol '%s' already declared", name);
gfc_error ("Symbol %qs already declared", name);
}
gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
@ -6577,7 +6577,7 @@ use_iso_fortran_env_module (void)
}
else
if (!mod_symtree->n.sym->attr.intrinsic)
gfc_error ("Use of intrinsic module '%s' at %C conflicts with "
gfc_error ("Use of intrinsic module %qs at %C conflicts with "
"non-intrinsic module name used previously", mod);
/* Generate the symbols for the module integer named constants. */
@ -6592,7 +6592,7 @@ use_iso_fortran_env_module (void)
found = true;
u->found = 1;
if (!gfc_notify_std (symbol[i].standard, "The symbol '%s', "
if (!gfc_notify_std (symbol[i].standard, "The symbol %qs, "
"referenced at %L, is not in the selected "
"standard", symbol[i].name, &u->where))
continue;
@ -6720,7 +6720,7 @@ use_iso_fortran_env_module (void)
if (u->found)
continue;
gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
gfc_error ("Symbol %qs referenced at %L not found in intrinsic "
"module ISO_FORTRAN_ENV", u->use_name, &u->where);
}
}
@ -6822,7 +6822,7 @@ gfc_use_module (gfc_use_list *module)
mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, module_name);
if (mod_symtree && mod_symtree->n.sym->attr.intrinsic)
gfc_error ("Use of non-intrinsic module '%s' at %C conflicts with "
gfc_error ("Use of non-intrinsic module %qs at %C conflicts with "
"intrinsic module name used previously", module_name);
iomode = IO_INPUT;

42
gcc/fortran/openmp.c
View File

@ -2074,7 +2074,7 @@ resolve_omp_clauses (gfc_code *code, locus *where,
|| (!code && (!n->sym->attr.dummy || n->sym->ns != ns)))
{
if (!code && (!n->sym->attr.dummy || n->sym->ns != ns))
gfc_error ("Variable '%s' is not a dummy argument at %L",
gfc_error ("Variable %qs is not a dummy argument at %L",
n->sym->name, where);
continue;
}
@ -2106,7 +2106,7 @@ resolve_omp_clauses (gfc_code *code, locus *where,
continue;
}
}
gfc_error ("Object '%s' is not a variable at %L", n->sym->name,
gfc_error ("Object %qs is not a variable at %L", n->sym->name,
where);
}
@ -2121,7 +2121,7 @@ resolve_omp_clauses (gfc_code *code, locus *where,
for (n = omp_clauses->lists[list]; n; n = n->next)
{
if (n->sym->mark)
gfc_error ("Symbol '%s' present on multiple clauses at %L",
gfc_error ("Symbol %qs present on multiple clauses at %L",
n->sym->name, where);
else
n->sym->mark = 1;
@ -2132,7 +2132,7 @@ resolve_omp_clauses (gfc_code *code, locus *where,
for (n = omp_clauses->lists[list]; n; n = n->next)
if (n->sym->mark)
{
gfc_error ("Symbol '%s' present on multiple clauses at %L",
gfc_error ("Symbol %qs present on multiple clauses at %L",
n->sym->name, where);
n->sym->mark = 0;
}
@ -2140,7 +2140,7 @@ resolve_omp_clauses (gfc_code *code, locus *where,
for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next)
{
if (n->sym->mark)
gfc_error ("Symbol '%s' present on multiple clauses at %L",
gfc_error ("Symbol %qs present on multiple clauses at %L",
n->sym->name, where);
else
n->sym->mark = 1;
@ -2151,7 +2151,7 @@ resolve_omp_clauses (gfc_code *code, locus *where,
for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
{
if (n->sym->mark)
gfc_error ("Symbol '%s' present on multiple clauses at %L",
gfc_error ("Symbol %qs present on multiple clauses at %L",
n->sym->name, where);
else
n->sym->mark = 1;
@ -2163,7 +2163,7 @@ resolve_omp_clauses (gfc_code *code, locus *where,
for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
{
if (n->sym->mark)
gfc_error ("Symbol '%s' present on multiple clauses at %L",
gfc_error ("Symbol %qs present on multiple clauses at %L",
n->sym->name, where);
else
n->sym->mark = 1;
@ -2177,7 +2177,7 @@ resolve_omp_clauses (gfc_code *code, locus *where,
for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
{
if (n->expr == NULL && n->sym->mark)
gfc_error ("Symbol '%s' present on both FROM and TO clauses at %L",
gfc_error ("Symbol %qs present on both FROM and TO clauses at %L",
n->sym->name, where);
else
n->sym->mark = 1;
@ -2199,7 +2199,7 @@ resolve_omp_clauses (gfc_code *code, locus *where,
for (; n != NULL; n = n->next)
{
if (!n->sym->attr.threadprivate)
gfc_error ("Non-THREADPRIVATE object '%s' in COPYIN clause"
gfc_error ("Non-THREADPRIVATE object %qs in COPYIN clause"
" at %L", n->sym->name, where);
}
break;
@ -2207,10 +2207,10 @@ resolve_omp_clauses (gfc_code *code, locus *where,
for (; n != NULL; n = n->next)
{
if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
gfc_error ("Assumed size array '%s' in COPYPRIVATE clause "
gfc_error ("Assumed size array %qs in COPYPRIVATE clause "
"at %L", n->sym->name, where);
if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
gfc_error ("INTENT(IN) POINTER '%s' in COPYPRIVATE clause "
gfc_error ("INTENT(IN) POINTER %qs in COPYPRIVATE clause "
"at %L", n->sym->name, where);
}
break;
@ -2218,13 +2218,13 @@ resolve_omp_clauses (gfc_code *code, locus *where,
for (; n != NULL; n = n->next)
{
if (n->sym->attr.threadprivate)
gfc_error ("THREADPRIVATE object '%s' in SHARED clause at "
gfc_error ("THREADPRIVATE object %qs in SHARED clause at "
"%L", n->sym->name, where);
if (n->sym->attr.cray_pointee)
gfc_error ("Cray pointee '%s' in SHARED clause at %L",
gfc_error ("Cray pointee %qs in SHARED clause at %L",
n->sym->name, where);
if (n->sym->attr.associate_var)
gfc_error ("ASSOCIATE name '%s' in SHARED clause at %L",
gfc_error ("ASSOCIATE name %qs in SHARED clause at %L",
n->sym->name, where);
}
break;
@ -2239,7 +2239,7 @@ resolve_omp_clauses (gfc_code *code, locus *where,
!= INTMOD_ISO_C_BINDING)
|| (n->sym->ts.u.derived->intmod_sym_id
!= ISOCBINDING_PTR)))
gfc_error ("'%s' in ALIGNED clause must be POINTER, "
gfc_error ("%qs in ALIGNED clause must be POINTER, "
"ALLOCATABLE, Cray pointer or C_PTR at %L",
n->sym->name, where);
else if (n->expr)
@ -2251,7 +2251,7 @@ resolve_omp_clauses (gfc_code *code, locus *where,
|| expr->rank != 0
|| gfc_extract_int (expr, &alignment)
|| alignment <= 0)
gfc_error ("'%s' in ALIGNED clause at %L requires a scalar "
gfc_error ("%qs in ALIGNED clause at %L requires a scalar "
"positive constant integer alignment "
"expression", n->sym->name, where);
}
@ -2269,7 +2269,7 @@ resolve_omp_clauses (gfc_code *code, locus *where,
|| n->expr->ref == NULL
|| n->expr->ref->next
|| n->expr->ref->type != REF_ARRAY)
gfc_error ("'%s' in %s clause at %L is not a proper "
gfc_error ("%qs in %s clause at %L is not a proper "
"array section", n->sym->name, name, where);
else if (n->expr->ref->u.ar.codimen)
gfc_error ("Coarrays not supported in %s clause at %L",
@ -2289,7 +2289,7 @@ resolve_omp_clauses (gfc_code *code, locus *where,
else if (ar->dimen_type[i] != DIMEN_ELEMENT
&& ar->dimen_type[i] != DIMEN_RANGE)
{
gfc_error ("'%s' in %s clause at %L is not a "
gfc_error ("%qs in %s clause at %L is not a "
"proper array section",
n->sym->name, name, where);
break;
@ -2302,7 +2302,7 @@ resolve_omp_clauses (gfc_code *code, locus *where,
&& mpz_cmp (ar->start[i]->value.integer,
ar->end[i]->value.integer) > 0)
{
gfc_error ("'%s' in DEPEND clause at %L is a zero "
gfc_error ("%qs in DEPEND clause at %L is a zero "
"size array section", n->sym->name,
where);
break;
@ -2314,10 +2314,10 @@ resolve_omp_clauses (gfc_code *code, locus *where,
{
n->sym->attr.referenced = 1;
if (n->sym->attr.threadprivate)
gfc_error ("THREADPRIVATE object '%s' in %s clause at %L",
gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
n->sym->name, name, where);
if (n->sym->attr.cray_pointee)
gfc_error ("Cray pointee '%s' in %s clause at %L",
gfc_error ("Cray pointee %qs in %s clause at %L",
n->sym->name, name, where);
}
break;

16
gcc/fortran/parse.c
View File

@ -2220,7 +2220,7 @@ unexpected_eof (void)
{
gfc_state_data *p;
gfc_error ("Unexpected end of file in '%s'", gfc_source_file);
gfc_error ("Unexpected end of file in %qs", gfc_source_file);
/* Memory cleanup. Move to "second to last". */
for (p = gfc_state_stack; p && p->previous && p->previous->previous;
@ -2252,10 +2252,10 @@ parse_derived_contains (void)
/* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
section. */
if (gfc_current_block ()->attr.sequence)
gfc_error ("Derived-type '%s' with SEQUENCE must not have a CONTAINS"
gfc_error ("Derived-type %qs with SEQUENCE must not have a CONTAINS"
" section at %C", gfc_current_block ()->name);
if (gfc_current_block ()->attr.is_bind_c)
gfc_error ("Derived-type '%s' with BIND(C) must not have a CONTAINS"
gfc_error ("Derived-type %qs with BIND(C) must not have a CONTAINS"
" section at %C", gfc_current_block ()->name);
accept_statement (ST_CONTAINS);
@ -2739,7 +2739,7 @@ loop:
{
gfc_add_abstract (&gfc_new_block->attr, &gfc_current_locus);
if (gfc_is_intrinsic_typename (gfc_new_block->name))
gfc_error ("Name '%s' of ABSTRACT INTERFACE at %C "
gfc_error ("Name %qs of ABSTRACT INTERFACE at %C "
"cannot be the same as an intrinsic type",
gfc_new_block->name);
}
@ -2790,7 +2790,7 @@ decl:
&& current_interface.ns->proc_name
&& strcmp (current_interface.ns->proc_name->name,
prog_unit->name) == 0)
gfc_error ("INTERFACE procedure '%s' at %L has the same name as the "
gfc_error ("INTERFACE procedure %qs at %L has the same name as the "
"enclosing procedure", prog_unit->name,
&current_interface.ns->proc_name->declared_at);
@ -3088,11 +3088,11 @@ declSt:
{
ts = &gfc_current_block ()->result->ts;
if (ts->type != BT_DERIVED)
gfc_error ("Bad kind expression for function '%s' at %L",
gfc_error ("Bad kind expression for function %qs at %L",
gfc_current_block ()->name,
&gfc_current_block ()->declared_at);
else
gfc_error ("The type for function '%s' at %L is not accessible",
gfc_error ("The type for function %qs at %L is not accessible",
gfc_current_block ()->name,
&gfc_current_block ()->declared_at);
@ -4467,7 +4467,7 @@ parse_contained (int module)
if (!module)
{
if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
gfc_error ("Contained procedure '%s' at %C is already "
gfc_error ("Contained procedure %qs at %C is already "
"ambiguous", gfc_new_block->name);
else
{

40
gcc/fortran/primary.c
View File

@ -631,7 +631,7 @@ done:
case 'd':
if (kind != -2)
{
gfc_error ("Real number at %C has a 'd' exponent and an explicit "
gfc_error ("Real number at %C has a %<d%> exponent and an explicit "
"kind");
goto cleanup;
}
@ -661,7 +661,7 @@ done:
case 'q':
if (kind != -2)
{
gfc_error ("Real number at %C has a 'q' exponent and an explicit "
gfc_error ("Real number at %C has a %<q%> exponent and an explicit "
"kind");
goto cleanup;
}
@ -675,7 +675,7 @@ done:
kind = 10;
if (gfc_validate_kind (BT_REAL, kind, true) < 0)
{
gfc_error ("Invalid exponent-letter 'q' in "
gfc_error ("Invalid exponent-letter %<q%> in "
"real-literal-constant at %C");
goto cleanup;
}
@ -1083,7 +1083,7 @@ got_delim:
if (!gfc_check_character_range (c, kind))
{
gfc_free_expr (e);
gfc_error ("Character '%s' in string at %C is not representable "
gfc_error ("Character %qs in string at %C is not representable "
"in character kind %d", gfc_print_wide_char (c), kind);
return MATCH_ERROR;
}
@ -1580,7 +1580,7 @@ match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base)
for (a = base; a; a = a->next)
if (a->name != NULL && strcmp (a->name, name) == 0)
{
gfc_error ("Keyword '%s' at %C has already appeared in the "
gfc_error ("Keyword %qs at %C has already appeared in the "
"current argument list", name);
return MATCH_ERROR;
}
@ -1847,7 +1847,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
|| (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
&& !CLASS_DATA (sym)->attr.codimension))
{
gfc_error ("Coarray designator at %C but '%s' is not a coarray",
gfc_error ("Coarray designator at %C but %qs is not a coarray",
sym->name);
return MATCH_ERROR;
}
@ -1914,13 +1914,13 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
if (sym->ts.type == BT_UNKNOWN && gfc_match_char ('%') == MATCH_YES)
{
gfc_error ("Symbol '%s' at %C has no IMPLICIT type", sym->name);
gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym->name);
return MATCH_ERROR;
}
else if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
&& gfc_match_char ('%') == MATCH_YES)
{
gfc_error ("Unexpected '%%' for nonderived-type variable '%s' at %C",
gfc_error ("Unexpected %<%%%> for nonderived-type variable %qs at %C",
sym->name);
return MATCH_ERROR;
}
@ -2020,7 +2020,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
if (m == MATCH_NO && !gfc_matching_ptr_assignment
&& !gfc_matching_procptr_assignment && !matching_actual_arglist)
{
gfc_error ("Procedure pointer component '%s' requires an "
gfc_error ("Procedure pointer component %qs requires an "
"argument list at %C", component->name);
return MATCH_ERROR;
}
@ -2369,7 +2369,7 @@ build_actual_constructor (gfc_structure_ctor_component **comp_head,
}
else if (!comp->attr.deferred_parameter)
{
gfc_error ("No initializer for component '%s' given in the"
gfc_error ("No initializer for component %qs given in the"
" structure constructor at %C!", comp->name);
return false;
}
@ -2417,7 +2417,7 @@ gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **c
if (!parent && sym->attr.abstract)
{
gfc_error ("Can't construct ABSTRACT type '%s' at %L",
gfc_error ("Can't construct ABSTRACT type %qs at %L",
sym->name, &expr->where);
goto cleanup;
}
@ -2506,7 +2506,7 @@ gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **c
if (this_comp->attr.pointer && comp_tail->val
&& gfc_is_coindexed (comp_tail->val))
{
gfc_error ("Coindexed expression to pointer component '%s' in "
gfc_error ("Coindexed expression to pointer component %qs in "
"structure constructor at %L!", comp_tail->name,
&comp_tail->where);
goto cleanup;
@ -2560,7 +2560,7 @@ gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **c
{
for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
{
gfc_error ("component '%s' at %L has already been set by a "
gfc_error ("component %qs at %L has already been set by a "
"parent derived type constructor", comp_iter->name,
&comp_iter->where);
}
@ -2743,7 +2743,7 @@ gfc_match_rvalue (gfc_expr **result)
&& gfc_current_ns->proc_name == sym
&& !sym->attr.dimension)
{
gfc_error ("'%s' at %C is the name of a recursive function "
gfc_error ("%qs at %C is the name of a recursive function "
"and so refers to the result variable. Use an "
"explicit RESULT variable for direct recursion "
"(12.5.2.1)", sym->name);
@ -2866,7 +2866,7 @@ gfc_match_rvalue (gfc_expr **result)
if (sym->attr.subroutine)
{
gfc_error ("Unexpected use of subroutine name '%s' at %C",
gfc_error ("Unexpected use of subroutine name %qs at %C",
sym->name);
m = MATCH_ERROR;
break;
@ -2897,10 +2897,10 @@ gfc_match_rvalue (gfc_expr **result)
if (m == MATCH_NO)
{
if (sym->attr.proc == PROC_ST_FUNCTION)
gfc_error ("Statement function '%s' requires argument list at %C",
gfc_error ("Statement function %qs requires argument list at %C",
sym->name);
else
gfc_error ("Function '%s' requires an argument list at %C",
gfc_error ("Function %qs requires an argument list at %C",
sym->name);
m = MATCH_ERROR;
@ -2950,7 +2950,7 @@ gfc_match_rvalue (gfc_expr **result)
/* make sure we were given a param */
if (actual_arglist == NULL)
{
gfc_error ("Missing argument to '%s' at %C", sym->name);
gfc_error ("Missing argument to %qs at %C", sym->name);
m = MATCH_ERROR;
break;
}
@ -3106,7 +3106,7 @@ gfc_match_rvalue (gfc_expr **result)
m = gfc_match_actual_arglist (0, &e->value.function.actual);
if (m == MATCH_NO)
gfc_error ("Missing argument list in function '%s' at %C", sym->name);
gfc_error ("Missing argument list in function %qs at %C", sym->name);
if (m != MATCH_YES)
{
@ -3273,7 +3273,7 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag)
/* Fall through to error */
default:
gfc_error ("'%s' at %C is not a variable", sym->name);
gfc_error ("%qs at %C is not a variable", sym->name);
return MATCH_ERROR;
}

372
gcc/fortran/resolve.c
View File

File diff suppressed because it is too large Load Diff

2
gcc/fortran/simplify.c
View File

@ -6928,7 +6928,7 @@ gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind)
if (!gfc_check_character_range (result->value.character.string[i],
kind))
{
gfc_error ("Character '%s' in string at %L cannot be converted "
gfc_error ("Character %qs in string at %L cannot be converted "
"into character kind %d",
gfc_print_wide_char (result->value.character.string[i]),
&e->where, kind);

34
gcc/fortran/symbol.c
View File

@ -165,7 +165,7 @@ gfc_add_new_implicit_range (int c1, int c2)
{
if (new_flag[i])
{
gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
gfc_error ("Letter %<%c%> already set in IMPLICIT statement at %C",
i + 'A');
return false;
}
@ -253,7 +253,7 @@ gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
{
if (error_flag && !sym->attr.untyped)
{
gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
gfc_error ("Symbol %qs at %L has no IMPLICIT type",
sym->name, &sym->declared_at);
sym->attr.untyped = 1; /* Ensure we only give an error once. */
}
@ -330,7 +330,7 @@ gfc_check_function_type (gfc_namespace *ns)
}
else if (!proc->result->attr.proc_pointer)
{
gfc_error ("Function result '%s' at %L has no IMPLICIT type",
gfc_error ("Function result %qs at %L has no IMPLICIT type",
proc->result->name, &proc->result->declared_at);
proc->result->attr.untyped = 1;
}
@ -772,7 +772,7 @@ conflict:
gfc_error ("%s attribute conflicts with %s attribute at %L",
a1, a2, where);
else
gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
gfc_error ("%s attribute conflicts with %s attribute in %qs at %L",
a1, a2, name, where);
return false;
@ -787,7 +787,7 @@ conflict_std:
else
{
return gfc_notify_std (standard, "%s attribute "
"with %s attribute in '%s' at %L",
"with %s attribute in %qs at %L",
a1, a2, name, where);
}
}
@ -917,7 +917,7 @@ gfc_add_codimension (symbol_attribute *attr, const char *name, locus *where)
if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
&& !gfc_find_state (COMP_INTERFACE))
{
gfc_error ("CODIMENSION specified for '%s' outside its INTERFACE body "
gfc_error ("CODIMENSION specified for %qs outside its INTERFACE body "
"at %L", name, where);
return false;
}
@ -943,7 +943,7 @@ gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
&& !gfc_find_state (COMP_INTERFACE))
{
gfc_error ("DIMENSION specified for '%s' outside its INTERFACE body "
gfc_error ("DIMENSION specified for %qs outside its INTERFACE body "
"at %L", name, where);
return false;
}
@ -1502,7 +1502,7 @@ gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
where = &gfc_current_locus;
if (name)
gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
gfc_error ("%s attribute of %qs conflicts with %s attribute at %L",
gfc_code2string (flavors, attr->flavor), name,
gfc_code2string (flavors, f), where);
else
@ -1660,14 +1660,14 @@ gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source,
if (sym->attr.if_source != IFSRC_UNKNOWN
&& sym->attr.if_source != IFSRC_DECL)
{
gfc_error ("Symbol '%s' at %L already has an explicit interface",
gfc_error ("Symbol %qs at %L already has an explicit interface",
sym->name, where);
return false;
}
if (source == IFSRC_IFBODY && (sym->attr.dimension || sym->attr.allocatable))
{
gfc_error ("'%s' at %L has attributes specified outside its INTERFACE "
gfc_error ("%qs at %L has attributes specified outside its INTERFACE "
"body", sym->name, where);
return false;
}
@ -1724,7 +1724,7 @@ gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
|| (flavor == FL_PROCEDURE && sym->attr.subroutine)
|| flavor == FL_DERIVED || flavor == FL_NAMELIST)
{
gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where);
gfc_error ("Symbol %qs at %L cannot have a type", sym->name, where);
return false;
}
@ -1991,7 +1991,7 @@ gfc_use_derived (gfc_symbol *sym)
if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
{
gfc_error ("Symbol '%s' at %C is ambiguous", sym->name);
gfc_error ("Symbol %qs at %C is ambiguous", sym->name);
return NULL;
}
@ -2023,7 +2023,7 @@ gfc_use_derived (gfc_symbol *sym)
return s;
bad:
gfc_error ("Derived type '%s' at %C is being used before it is defined",
gfc_error ("Derived type %qs at %C is being used before it is defined",
sym->name);
return NULL;
}
@ -3979,7 +3979,7 @@ verify_bind_c_derived_type (gfc_symbol *derived_sym)
/* Make sure we don't have conflicts with the attributes. */
if (derived_sym->attr.access == ACCESS_PRIVATE)
{
gfc_error ("Derived type '%s' at %L cannot be declared with both "
gfc_error ("Derived type %qs at %L cannot be declared with both "
"PRIVATE and BIND(C) attributes", derived_sym->name,
&(derived_sym->declared_at));
retval = false;
@ -3987,7 +3987,7 @@ verify_bind_c_derived_type (gfc_symbol *derived_sym)
if (derived_sym->attr.sequence != 0)
{
gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
gfc_error ("Derived type %qs at %L cannot have the SEQUENCE "
"attribute because it is BIND(C)", derived_sym->name,
&(derived_sym->declared_at));
retval = false;
@ -4467,12 +4467,12 @@ gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns,
{
if (strict)
{
gfc_error ("Symbol '%s' is used before it is typed at %L",
gfc_error ("Symbol %qs is used before it is typed at %L",
sym->name, &where);
return false;
}
if (!gfc_notify_std (GFC_STD_GNU, "Symbol '%s' is used before"
if (!gfc_notify_std (GFC_STD_GNU, "Symbol %qs is used before"
" it is typed at %L", sym->name, &where))
return false;
}

10
gcc/fortran/trans-common.c
View File

@ -1041,7 +1041,7 @@ align_segment (unsigned HOST_WIDE_INT *palign)
if (this_offset & (max_align - 1))
{
/* Aligning this field would misalign a previous field. */
gfc_error ("The equivalence set for variable '%s' "
gfc_error ("The equivalence set for variable %qs "
"declared at %L violates alignment requirements",
s->sym->name, &s->sym->declared_at);
}
@ -1106,8 +1106,8 @@ translate_common (gfc_common_head *common, gfc_symbol *var_list)
/* Verify that it ended up where we expect it. */
if (s->offset != current_offset)
{
gfc_error ("Equivalence for '%s' does not match ordering of "
"COMMON '%s' at %L", sym->name,
gfc_error ("Equivalence for %qs does not match ordering of "
"COMMON %qs at %L", sym->name,
common->name, &common->where);
}
}
@ -1121,8 +1121,8 @@ translate_common (gfc_common_head *common, gfc_symbol *var_list)
add_equivalences (&saw_equiv);
if (current_segment->offset < 0)
gfc_error ("The equivalence set for '%s' cause an invalid "
"extension to COMMON '%s' at %L", sym->name,
gfc_error ("The equivalence set for %qs cause an invalid "
"extension to COMMON %qs at %L", sym->name,
common->name, &common->where);
if (gfc_option.flag_align_commons)

6
gcc/fortran/trans-intrinsic.c
View File

@ -1468,7 +1468,7 @@ trans_this_image (gfc_se * se, gfc_expr *expr)
{
if (wi::ltu_p (dim_arg, 1)
|| wi::gtu_p (dim_arg, GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))))
gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
"dimension index", expr->value.function.isym->name,
&expr->where);
}
@ -1854,7 +1854,7 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
if (((!as || as->type != AS_ASSUMED_RANK)
&& wi::geu_p (bound, GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))))
|| wi::gtu_p (bound, GFC_MAX_DIMENSIONS))
gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
"dimension index", upper ? "UBOUND" : "LBOUND",
&expr->where);
}
@ -2050,7 +2050,7 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
{
if (wi::ltu_p (bound, 1)
|| wi::gtu_p (bound, GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))))
gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
"dimension index", expr->value.function.isym->name,
&expr->where);
}

6
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,9 @@
2014-12-13 Tobias Burnus <burnus@net-b.de>
* gfortran.dg/realloc_on_assign_21.f90: Update dg-error.
* gfortran.dg/warnings_are_errors_1.f: Ditto.
* gfortran.dg/warnings_are_errors_1.f90: Ditto.
2014-12-12 Paolo Carlini <paolo.carlini@oracle.com>
PR c++/59240

2
gcc/testsuite/gfortran.dg/realloc_on_assign_21.f90
View File

@ -9,5 +9,5 @@ type t
end type t
class(t), allocatable :: var
var = t() ! { dg-error "Assignment to an allocatable polymorphic variable at .1. requires -frealloc-lhs" }
var = t() ! { dg-error "Assignment to an allocatable polymorphic variable at .1. requires '-frealloc-lhs'" }
end

2
gcc/testsuite/gfortran.dg/warnings_are_errors_1.f
View File

@ -13,7 +13,7 @@
!
34 5 i=0
! gfc_notify_std(GFC_STD_F95_DEL):
do r1 = 1, 2 ! { dg-warning "Deleted feature: Loop variable" }
do r1 = 1, 2 ! { dg-error "Deleted feature: Loop variable" }
i = i+1
end do
call foo j bar

2
gcc/testsuite/gfortran.dg/warnings_are_errors_1.f90
View File

@ -5,7 +5,7 @@
! free-form tests
! gfc_notify_std:
function char_ (ch) ! { dg-warning "Obsolescent feature" }
function char_ (ch) ! { dg-error "Obsolescent feature" }
character(*) :: char_, ch
char_ = ch
end function char_