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

re PR fortran/44054 (Handle -Werror, -Werror=, -fdiagnostics-show-option, !GCC$ diagnostic (pragmas) and color) 

gcc/ChangeLog:

2014-12-11  Manuel López-Ibáñez  <manu@gcc.gnu.org>

	PR fortran/44054
	* diagnostic.c (diagnostic_action_after_output): Make it extern.
	Take diagnostic_t argument instead of diagnostic_info. Count also
	DK_WERROR towards max_errors.
	(diagnostic_report_diagnostic): Update call according to the above.
	(error_recursion): Likewise.
	* diagnostic.h (diagnostic_action_after_output): Declare.
	* pretty-print.c (pp_formatted_text_data): Delete.
	(pp_append_r): Call output_buffer_append_r.
	(pp_formatted_text): Call output_buffer_formatted_text.
	(pp_last_position_in_text): Call output_buffer_last_position_in_text.
	* pretty-print.h (output_buffer_formatted_text): New.
	(output_buffer_append_r): New.
	(output_buffer_last_position_in_text): New.

gcc/fortran/ChangeLog:

2014-12-11  Manuel López-Ibáñez  <manu@gcc.gnu.org>

	PR fortran/44054
	* error.c (pp_error_buffer): New static variable.
	(pp_warning_buffer): Make it a pointer.
	(gfc_output_buffer_empty_p): New.
	(gfc_error_init_1): Call gfc_buffer_error.
	(gfc_buffer_error): Do not use pp_warning_buffer.flush_p as the
	buffered_p flag.
	(gfc_clear_warning): Likewise.
	(gfc_warning_check): Call gfc_clear_warning. Only check the new
	pp_warning_buffer if the old warning_buffer was empty. Call
	diagnostic_action_after_output.
	(gfc_error_1): Renamed from gfc_error.
	(gfc_error): New.
	(gfc_clear_error): Clear also pp_error_buffer.
	(gfc_error_flag_test): Check also pp_error_buffer.
	(gfc_error_check): Likewise. Only check the new pp_error_buffer
	if the old error_buffer was empty.
	(gfc_move_output_buffer_from_to): New.
	(gfc_push_error): Use it here. Take also an output_buffer as argument.
	(gfc_pop_error): Likewise.
	(gfc_free_error): Likewise.
	(gfc_diagnostics_init): Use XNEW and placement-new to init
	pp_error_buffer and pp_warning_buffer. Set flush_p to false for
	both pp_warning_buffer and pp_error_buffer.

	* Update gfc_push_error, gfc_pop_error and gfc_free_error calls
	according to the above changes.
	* Use gfc_error_1 for all gfc_error calls that use multiple
	locations.
	* Use %qs instead of '%s' for many gfc_error calls.

From-SVN: r218627
This commit is contained in:
Manuel López-Ibáñez 2014-12-11 15:13:33 +00:00
parent 217d0904fa
commit c4100eaea3
26 changed files with 730 additions and 544 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
gcc/ChangeLog
View File

@ -1,3 +1,20 @@
2014-12-11 Manuel López-Ibáñez <manu@gcc.gnu.org>
PR fortran/44054
* diagnostic.c (diagnostic_action_after_output): Make it extern.
Take diagnostic_t argument instead of diagnostic_info. Count also
DK_WERROR towards max_errors.
(diagnostic_report_diagnostic): Update call according to the above.
(error_recursion): Likewise.
* diagnostic.h (diagnostic_action_after_output): Declare.
* pretty-print.c (pp_formatted_text_data): Delete.
(pp_append_r): Call output_buffer_append_r.
(pp_formatted_text): Call output_buffer_formatted_text.
(pp_last_position_in_text): Call output_buffer_last_position_in_text.
* pretty-print.h (output_buffer_formatted_text): New.
(output_buffer_append_r): New.
(output_buffer_last_position_in_text): New.
2014-12-11 Kyrylo Tkachov kyrylo.tkachov@arm.com
* config/aarch64/aarch64.c (aarch64_parse_extension): Update error

20
gcc/diagnostic.c
View File

@ -51,8 +51,6 @@ along with GCC; see the file COPYING3. If not see
/* Prototypes. */
static void error_recursion (diagnostic_context *) ATTRIBUTE_NORETURN;
static void diagnostic_action_after_output (diagnostic_context *,
diagnostic_info *);
static void real_abort (void) ATTRIBUTE_NORETURN;
/* Name of program invoked, sans directories. */
@ -483,11 +481,11 @@ bt_err_callback (void *data ATTRIBUTE_UNUSED, const char *msg, int errnum)
/* Take any action which is expected to happen after the diagnostic
is written out. This function does not always return. */
static void
void
diagnostic_action_after_output (diagnostic_context *context,
diagnostic_info *diagnostic)
diagnostic_t diag_kind)
{
switch (diagnostic->kind)
switch (diag_kind)
{
case DK_DEBUG:
case DK_NOTE:
@ -507,7 +505,8 @@ diagnostic_action_after_output (diagnostic_context *context,
}
if (context->max_errors != 0
&& ((unsigned) (diagnostic_kind_count (context, DK_ERROR)
+ diagnostic_kind_count (context, DK_SORRY))
+ diagnostic_kind_count (context, DK_SORRY)
+ diagnostic_kind_count (context, DK_WERROR))
>= context->max_errors))
{
fnotice (stderr,
@ -864,7 +863,7 @@ diagnostic_report_diagnostic (diagnostic_context *context,
(*diagnostic_starter (context)) (context, diagnostic);
pp_output_formatted_text (context->printer);
(*diagnostic_finalizer (context)) (context, diagnostic);
diagnostic_action_after_output (context, diagnostic);
diagnostic_action_after_output (context, diagnostic->kind);
diagnostic->message.format_spec = saved_format_spec;
diagnostic->x_data = NULL;
@ -1264,8 +1263,6 @@ fnotice (FILE *file, const char *cmsgid, ...)
static void
error_recursion (diagnostic_context *context)
{
diagnostic_info diagnostic;
if (context->lock < 3)
pp_newline_and_flush (context->printer);
@ -1273,9 +1270,8 @@ error_recursion (diagnostic_context *context)
"Internal compiler error: Error reporting routines re-entered.\n");
/* Call diagnostic_action_after_output to get the "please submit a bug
report" message. It only looks at the kind field of diagnostic_info. */
diagnostic.kind = DK_ICE;
diagnostic_action_after_output (context, &diagnostic);
report" message. */
diagnostic_action_after_output (context, DK_ICE);
/* Do not use gcc_unreachable here; that goes through internal_error
and therefore would cause infinite recursion. */

1
gcc/diagnostic.h
View File

@ -294,6 +294,7 @@ extern char *diagnostic_build_prefix (diagnostic_context *, const diagnostic_inf
void default_diagnostic_starter (diagnostic_context *, diagnostic_info *);
void default_diagnostic_finalizer (diagnostic_context *, diagnostic_info *);
void diagnostic_set_caret_max_width (diagnostic_context *context, int value);
void diagnostic_action_after_output (diagnostic_context *, diagnostic_t);
void diagnostic_file_cache_fini (void);

33
gcc/fortran/ChangeLog
View File

@ -1,3 +1,36 @@
2014-12-11 Manuel López-Ibáñez <manu@gcc.gnu.org>
PR fortran/44054
* error.c (pp_error_buffer): New static variable.
(pp_warning_buffer): Make it a pointer.
(gfc_output_buffer_empty_p): New.
(gfc_error_init_1): Call gfc_buffer_error.
(gfc_buffer_error): Do not use pp_warning_buffer.flush_p as the
buffered_p flag.
(gfc_clear_warning): Likewise.
(gfc_warning_check): Call gfc_clear_warning. Only check the new
pp_warning_buffer if the old warning_buffer was empty. Call
diagnostic_action_after_output.
(gfc_error_1): Renamed from gfc_error.
(gfc_error): New.
(gfc_clear_error): Clear also pp_error_buffer.
(gfc_error_flag_test): Check also pp_error_buffer.
(gfc_error_check): Likewise. Only check the new pp_error_buffer
if the old error_buffer was empty.
(gfc_move_output_buffer_from_to): New.
(gfc_push_error): Use it here. Take also an output_buffer as argument.
(gfc_pop_error): Likewise.
(gfc_free_error): Likewise.
(gfc_diagnostics_init): Use XNEW and placement-new to init
pp_error_buffer and pp_warning_buffer. Set flush_p to false for
both pp_warning_buffer and pp_error_buffer.
* Update gfc_push_error, gfc_pop_error and gfc_free_error calls
according to the above changes.
* Use gfc_error_1 for all gfc_error calls that use multiple
locations.
* Use %qs instead of '%s' for many gfc_error calls.
2014-12-11 Tobias Burnus <burnus@net-b.de>
Manuel López-Ibáñez <manu@gcc.gnu.org>

6
gcc/fortran/arith.c
View File

@ -1915,17 +1915,17 @@ arith_error (arith rc, gfc_typespec *from, gfc_typespec *to, locus *where)
break;
case ARITH_OVERFLOW:
gfc_error ("Arithmetic overflow converting %s to %s at %L. This check "
"can be disabled with the option -fno-range-check",
"can be disabled with the option %<-fno-range-check%>",
gfc_typename (from), gfc_typename (to), where);
break;
case ARITH_UNDERFLOW:
gfc_error ("Arithmetic underflow converting %s to %s at %L. This check "
"can be disabled with the option -fno-range-check",
"can be disabled with the option %<-fno-range-check%>",
gfc_typename (from), gfc_typename (to), where);
break;
case ARITH_NAN:
gfc_error ("Arithmetic NaN converting %s to %s at %L. This check "
"can be disabled with the option -fno-range-check",
"can be disabled with the option %<-fno-range-check%>",
gfc_typename (from), gfc_typename (to), where);
break;
case ARITH_DIV0:

14
gcc/fortran/array.c
View File

@ -100,7 +100,7 @@ match_subscript (gfc_array_ref *ar, int init, bool match_star)
if (star)
{
gfc_error ("Unexpected '*' in coarray subscript at %C");
gfc_error ("Unexpected %<*%> in coarray subscript at %C");
return MATCH_ERROR;
}
@ -246,7 +246,7 @@ coarray:
if (gfc_match_char (',') != MATCH_YES)
{
if (gfc_match_char ('*') == MATCH_YES)
gfc_error ("Unexpected '*' for codimension %d of %d at %C",
gfc_error ("Unexpected %<*%> for codimension %d of %d at %C",
ar->codimen + 1, corank);
else
gfc_error ("Invalid form of coarray reference at %C");
@ -254,7 +254,7 @@ coarray:
}
else if (ar->dimen_type[ar->codimen + ar->dimen] == DIMEN_STAR)
{
gfc_error ("Unexpected '*' for codimension %d of %d at %C",
gfc_error ("Unexpected %<*%> for codimension %d of %d at %C",
ar->codimen + 1, corank);
return MATCH_ERROR;
}
@ -313,7 +313,7 @@ resolve_array_bound (gfc_expr *e, int check_constant)
if (check_constant && !gfc_is_constant_expr (e))
{
if (e->expr_type == EXPR_VARIABLE)
gfc_error ("Variable '%s' at %L in this context must be constant",
gfc_error ("Variable %qs at %L in this context must be constant",
e->symtree->n.sym->name, &e->where);
else
gfc_error ("Expression at %L in this context must be constant",
@ -752,7 +752,7 @@ gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc)
if ((sym->as->type == AS_ASSUMED_RANK && as->corank)
|| (as->type == AS_ASSUMED_RANK && sym->as->corank))
{
gfc_error ("The assumed-rank array '%s' at %L shall not have a "
gfc_error ("The assumed-rank array %qs at %L shall not have a "
"codimension", sym->name, error_loc);
return false;
}
@ -912,7 +912,7 @@ check_duplicate_iterator (gfc_constructor_base base, gfc_symbol *master)
if (c->iterator->var->symtree->n.sym == master)
{
gfc_error ("DO-iterator '%s' at %L is inside iterator of the "
gfc_error ("DO-iterator %qs at %L is inside iterator of the "
"same name", master->name, &c->where);
return 1;
@ -1662,7 +1662,7 @@ gfc_expand_constructor (gfc_expr *e, bool fatal)
{
gfc_error ("The number of elements in the array constructor "
"at %L requires an increase of the allowed %d "
"upper limit. See -fmax-array-constructor "
"upper limit. See %<-fmax-array-constructor%> "
"option", &e->where,
gfc_option.flag_max_array_constructor);
return false;

244
gcc/fortran/check.c
View File

@ -43,7 +43,7 @@ scalar_check (gfc_expr *e, int n)
if (e->rank == 0)
return true;
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
gfc_error ("%qs argument of %qs intrinsic at %L must be a scalar",
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
&e->where);
@ -59,7 +59,7 @@ type_check (gfc_expr *e, int n, bt type)
if (e->ts.type == type)
return true;
gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
gfc_error ("%qs argument of %qs intrinsic at %L must be %s",
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
&e->where, gfc_basic_typename (type));
@ -86,7 +86,7 @@ numeric_check (gfc_expr *e, int n)
return true;
}
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type",
gfc_error ("%qs argument of %qs intrinsic at %L must be a numeric type",
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
&e->where);
@ -101,7 +101,7 @@ int_or_real_check (gfc_expr *e, int n)
{
if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
"or REAL", gfc_current_intrinsic_arg[n]->name,
gfc_current_intrinsic, &e->where);
return false;
@ -118,7 +118,7 @@ real_or_complex_check (gfc_expr *e, int n)
{
if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be REAL "
gfc_error ("%qs argument of %qs intrinsic at %L must be REAL "
"or COMPLEX", gfc_current_intrinsic_arg[n]->name,
gfc_current_intrinsic, &e->where);
return false;
@ -135,7 +135,7 @@ int_or_proc_check (gfc_expr *e, int n)
{
if (e->ts.type != BT_INTEGER && e->ts.type != BT_PROCEDURE)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
"or PROCEDURE", gfc_current_intrinsic_arg[n]->name,
gfc_current_intrinsic, &e->where);
return false;
@ -164,7 +164,7 @@ kind_check (gfc_expr *k, int n, bt type)
if (!gfc_check_init_expr (k))
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
&k->where);
return false;
@ -192,7 +192,7 @@ double_check (gfc_expr *d, int n)
if (d->ts.kind != gfc_default_double_kind)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be double "
gfc_error ("%qs argument of %qs intrinsic at %L must be double "
"precision", gfc_current_intrinsic_arg[n]->name,
gfc_current_intrinsic, &d->where);
return false;
@ -215,7 +215,7 @@ coarray_check (gfc_expr *e, int n)
if (!gfc_is_coarray (e))
{
gfc_error ("Expected coarray variable as '%s' argument to the %s "
gfc_error ("Expected coarray variable as %qs argument to the %s "
"intrinsic at %L", gfc_current_intrinsic_arg[n]->name,
gfc_current_intrinsic, &e->where);
return false;
@ -232,7 +232,7 @@ logical_array_check (gfc_expr *array, int n)
{
if (array->ts.type != BT_LOGICAL || array->rank == 0)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a logical "
gfc_error ("%qs argument of %qs intrinsic at %L must be a logical "
"array", gfc_current_intrinsic_arg[n]->name,
gfc_current_intrinsic, &array->where);
return false;
@ -258,7 +258,7 @@ array_check (gfc_expr *e, int n)
if (e->rank != 0 && e->ts.type != BT_PROCEDURE)
return true;
gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
gfc_error ("%qs argument of %qs intrinsic at %L must be an array",
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
&e->where);
@ -279,7 +279,7 @@ nonnegative_check (const char *arg, gfc_expr *expr)
gfc_extract_int (expr, &i);
if (i < 0)
{
gfc_error ("'%s' at %L must be nonnegative", arg, &expr->where);
gfc_error ("%qs at %L must be nonnegative", arg, &expr->where);
return false;
}
}
@ -311,7 +311,7 @@ less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2,
if (i2 > gfc_integer_kinds[i3].bit_size)
{
gfc_error ("The absolute value of SHIFT at %L must be less "
"than or equal to BIT_SIZE('%s')",
"than or equal to BIT_SIZE(%qs)",
&expr2->where, arg1);
return false;
}
@ -321,8 +321,8 @@ less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2,
{
if (i2 > gfc_integer_kinds[i3].bit_size)
{
gfc_error ("'%s' at %L must be less than "
"or equal to BIT_SIZE('%s')",
gfc_error ("%qs at %L must be less than "
"or equal to BIT_SIZE(%qs)",
arg2, &expr2->where, arg1);
return false;
}
@ -331,7 +331,7 @@ less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2,
{
if (i2 >= gfc_integer_kinds[i3].bit_size)
{
gfc_error ("'%s' at %L must be less than BIT_SIZE('%s')",
gfc_error ("%qs at %L must be less than BIT_SIZE(%qs)",
arg2, &expr2->where, arg1);
return false;
}
@ -358,7 +358,7 @@ less_than_bitsizekind (const char *arg, gfc_expr *expr, int k)
if (val > gfc_integer_kinds[i].bit_size)
{
gfc_error ("'%s' at %L must be less than or equal to the BIT_SIZE of "
gfc_error ("%qs at %L must be less than or equal to the BIT_SIZE of "
"INTEGER(KIND=%d)", arg, &expr->where, k);
return false;
}
@ -385,7 +385,7 @@ less_than_bitsize2 (const char *arg1, gfc_expr *expr1, const char *arg2,
if (i2 > gfc_integer_kinds[i3].bit_size)
{
gfc_error ("'%s + %s' at %L must be less than or equal "
"to BIT_SIZE('%s')",
"to BIT_SIZE(%qs)",
arg2, arg3, &expr2->where, arg1);
return false;
}
@ -402,8 +402,8 @@ same_type_check (gfc_expr *e, int n, gfc_expr *f, int m)
if (gfc_compare_types (&e->ts, &f->ts))
return true;
gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type "
"and kind as '%s'", gfc_current_intrinsic_arg[m]->name,
gfc_error ("%qs argument of %qs intrinsic at %L must be the same type "
"and kind as %qs", gfc_current_intrinsic_arg[m]->name,
gfc_current_intrinsic, &f->where,
gfc_current_intrinsic_arg[n]->name);
@ -419,7 +419,7 @@ rank_check (gfc_expr *e, int n, int rank)
if (e->rank == rank)
return true;
gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d",
gfc_error ("%qs argument of %qs intrinsic at %L must be of rank %d",
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
&e->where, rank);
@ -434,7 +434,7 @@ nonoptional_check (gfc_expr *e, int n)
{
if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
gfc_error ("%qs argument of %qs intrinsic at %L must not be OPTIONAL",
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
&e->where);
}
@ -455,7 +455,7 @@ allocatable_check (gfc_expr *e, int n)
attr = gfc_variable_attr (e, NULL);
if (!attr.allocatable || attr.associate_var)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
gfc_error ("%qs argument of %qs intrinsic at %L must be ALLOCATABLE",
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
&e->where);
return false;
@ -473,7 +473,7 @@ kind_value_check (gfc_expr *e, int n, int k)
if (e->ts.kind == k)
return true;
gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d",
gfc_error ("%qs argument of %qs intrinsic at %L must be of kind %d",
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
&e->where, k);
@ -511,7 +511,7 @@ variable_check (gfc_expr *e, int n, bool allow_proc)
if (!ref)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be "
gfc_error ("%qs argument of %qs intrinsic at %L cannot be "
"INTENT(IN)", gfc_current_intrinsic_arg[n]->name,
gfc_current_intrinsic, &e->where);
return false;
@ -532,7 +532,7 @@ variable_check (gfc_expr *e, int n, bool allow_proc)
return true;
}
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
gfc_error ("%qs argument of %qs intrinsic at %L must be a variable",
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where);
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 '%s' 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 '%s' 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;
@ -856,7 +856,7 @@ gfc_check_a_p (gfc_expr *a, gfc_expr *p)
if (a->ts.type != p->ts.type)
{
gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must "
"have the same type", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&p->where);
@ -901,7 +901,7 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
if (!attr1.pointer && !attr1.proc_pointer)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&pointer->where);
return false;
@ -910,7 +910,7 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
/* F2008, C1242. */
if (attr1.pointer && gfc_is_coindexed (pointer))
{
gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
"coindexed", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &pointer->where);
return false;
@ -928,7 +928,7 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
attr2 = gfc_expr_attr (target);
else
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
gfc_error ("%qs argument of %qs intrinsic at %L must be a pointer "
"or target VARIABLE or FUNCTION",
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&target->where);
@ -937,7 +937,7 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
if (attr1.pointer && !attr2.pointer && !attr2.target)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER "
"or a TARGET", gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &target->where);
return false;
@ -946,7 +946,7 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
/* F2008, C1242. */
if (attr1.pointer && gfc_is_coindexed (target))
{
gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
"coindexed", gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &target->where);
return false;
@ -974,7 +974,7 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
null_arg:
gfc_error ("NULL pointer at %L is not permitted as actual argument "
"of '%s' intrinsic function", where, gfc_current_intrinsic);
"of %qs intrinsic function", where, gfc_current_intrinsic);
return false;
}
@ -1031,7 +1031,7 @@ gfc_check_atomic (gfc_expr *atom, int atom_no, gfc_expr *value, int val_no,
if (atom->ts.type != value->ts.type)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L shall have the same "
gfc_error_1 ("'%s' argument of '%s' intrinsic at %L shall have the same "
"type as '%s' at %L", gfc_current_intrinsic_arg[val_no]->name,
gfc_current_intrinsic, &value->where,
gfc_current_intrinsic_arg[atom_no]->name, &atom->where);
@ -1377,7 +1377,7 @@ gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind)
if (x->ts.type == BT_COMPLEX)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
gfc_error ("%qs argument of %qs intrinsic at %L must not be "
"present if 'x' is COMPLEX",
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&y->where);
@ -1386,7 +1386,7 @@ gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind)
if (y->ts.type == BT_COMPLEX)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
"of either REAL or INTEGER",
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&y->where);
@ -1575,7 +1575,7 @@ gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image,
if (!gfc_compare_types (&a->ts, &sym->result->ts))
{
gfc_error ("A argument at %L has type %s but the function passed as "
gfc_error_1 ("A argument at %L has type %s but the function passed as "
"OPERATOR at %L returns %s",
&a->where, gfc_typename (&a->ts), &op->where,
gfc_typename (&sym->result->ts));
@ -1655,16 +1655,16 @@ gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image,
&& ((formal_size1 && actual_size != formal_size1)
|| (formal_size2 && actual_size != formal_size2)))
{
gfc_error ("The character length of the A argument at %L and of the "
"arguments of the OPERATOR at %L shall be the same",
gfc_error_1 ("The character length of the A argument at %L and of the "
"arguments of the OPERATOR at %L shall be the same",
&a->where, &op->where);
return false;
}
if (actual_size && result_size && actual_size != result_size)
{
gfc_error ("The character length of the A argument at %L and of the "
"function result of the OPERATOR at %L shall be the same",
&a->where, &op->where);
gfc_error_1 ("The character length of the A argument at %L and of the "
"function result of the OPERATOR at %L shall be the same",
&a->where, &op->where);
return false;
}
}
@ -1680,10 +1680,10 @@ gfc_check_co_minmax (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat,
if (a->ts.type != BT_INTEGER && a->ts.type != BT_REAL
&& a->ts.type != BT_CHARACTER)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L shall be of type "
"integer, real or character",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&a->where);
gfc_error_1 ("'%s' argument of '%s' intrinsic at %L shall be of type "
"integer, real or character",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&a->where);
return false;
}
return check_co_collective (a, result_image, stat, errmsg, false);
@ -1775,7 +1775,7 @@ gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
{
if (!identical_dimen_shape (array, i, shift, j))
{
gfc_error ("'%s' argument of '%s' intrinsic at %L has "
gfc_error ("%qs argument of %qs intrinsic at %L has "
"invalid shape in dimension %d (%ld/%ld)",
gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &shift->where, i + 1,
@ -1790,7 +1790,7 @@ gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
}
else
{
gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
"%d or be a scalar", gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &shift->where, array->rank - 1);
return false;
@ -1834,7 +1834,7 @@ gfc_check_dcmplx (gfc_expr *x, gfc_expr *y)
if (x->ts.type == BT_COMPLEX)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
gfc_error ("%qs argument of %qs intrinsic at %L must not be "
"present if 'x' is COMPLEX",
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&y->where);
@ -1843,7 +1843,7 @@ gfc_check_dcmplx (gfc_expr *x, gfc_expr *y)
if (y->ts.type == BT_COMPLEX)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type "
gfc_error ("%qs argument of %qs intrinsic at %L must have a type "
"of either REAL or INTEGER",
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&y->where);
@ -1893,7 +1893,7 @@ gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
break;
default:
gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
"or LOGICAL", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &vector_a->where);
return false;
@ -1907,7 +1907,7 @@ 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 '%s' and '%s' at %L for "
gfc_error ("Different shape for arguments %qs and %qs at %L for "
"intrinsic 'dot_product'", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic_arg[1]->name, &vector_a->where);
return false;
@ -1926,7 +1926,7 @@ gfc_check_dprod (gfc_expr *x, gfc_expr *y)
if (x->ts.kind != gfc_default_real_kind)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
gfc_error ("%qs argument of %qs intrinsic at %L must be default "
"real", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &x->where);
return false;
@ -1934,7 +1934,7 @@ gfc_check_dprod (gfc_expr *x, gfc_expr *y)
if (y->ts.kind != gfc_default_real_kind)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be default "
gfc_error ("%qs argument of %qs intrinsic at %L must be default "
"real", gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &y->where);
return false;
@ -1955,8 +1955,8 @@ gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift)
if (i->is_boz && j->is_boz)
{
gfc_error ("'I' at %L and 'J' at %L cannot both be BOZ literal "
"constants", &i->where, &j->where);
gfc_error_1 ("'I' at %L and 'J' at %L cannot both be BOZ literal "
"constants", &i->where, &j->where);
return false;
}
@ -2025,7 +2025,7 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
{
if (!identical_dimen_shape (array, i, shift, j))
{
gfc_error ("'%s' argument of '%s' intrinsic at %L has "
gfc_error ("%qs argument of %qs intrinsic at %L has "
"invalid shape in dimension %d (%ld/%ld)",
gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &shift->where, i + 1,
@ -2040,7 +2040,7 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
}
else
{
gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
gfc_error ("%qs argument of intrinsic %qs at %L of must have rank "
"%d or be a scalar", gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &shift->where, array->rank - 1);
return false;
@ -2068,7 +2068,7 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
}
else
{
gfc_error ("'%s' argument of intrinsic '%s' at %L of must have "
gfc_error ("%qs argument of intrinsic %qs at %L of must have "
"rank %d or be a scalar",
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&shift->where, array->rank - 1);
@ -2369,8 +2369,8 @@ gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back,
if (string->ts.kind != substring->ts.kind)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
"kind as '%s'", gfc_current_intrinsic_arg[1]->name,
gfc_error ("%qs argument of %qs intrinsic at %L must be the same "
"kind as %qs", gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &substring->where,
gfc_current_intrinsic_arg[0]->name);
return false;
@ -2471,9 +2471,9 @@ gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size)
if (i2 > i3)
{
gfc_error ("The absolute value of SHIFT at %L must be less "
"than or equal to SIZE at %L", &shift->where,
&size->where);
gfc_error_1 ("The absolute value of SHIFT at %L must be less "
"than or equal to SIZE at %L", &shift->where,
&size->where);
return false;
}
}
@ -2532,7 +2532,7 @@ gfc_check_kind (gfc_expr *x)
{
if (x->ts.type == BT_DERIVED)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
gfc_error ("%qs argument of %qs intrinsic at %L must be a "
"non-derived type", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &x->where);
return false;
@ -2743,7 +2743,7 @@ min_max_args (gfc_actual_arglist *args)
if (args == NULL || args->next == NULL)
{
gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
gfc_error ("Intrinsic %qs at %L must have at least two arguments",
gfc_current_intrinsic, gfc_current_intrinsic_where);
return false;
}
@ -2791,7 +2791,7 @@ min_max_args (gfc_actual_arglist *args)
if (!a1 || !a2)
{
gfc_error ("Missing '%s' argument to the %s intrinsic at %L",
gfc_error ("Missing %qs argument to the %s intrinsic at %L",
!a1 ? "a1" : "a2", gfc_current_intrinsic,
gfc_current_intrinsic_where);
return false;
@ -2806,12 +2806,12 @@ min_max_args (gfc_actual_arglist *args)
return true;
duplicate:
gfc_error ("Duplicate argument '%s' at %L to intrinsic %s", arg->name,
gfc_error ("Duplicate argument %qs at %L to intrinsic %s", arg->name,
&arg->expr->where, gfc_current_intrinsic);
return false;
unknown:
gfc_error ("Unknown argument '%s' at %L to intrinsic %s", arg->name,
gfc_error ("Unknown argument %qs at %L to intrinsic %s", arg->name,
&arg->expr->where, gfc_current_intrinsic);
return false;
}
@ -2840,7 +2840,7 @@ check_rest (bt type, int kind, gfc_actual_arglist *arglist)
}
else
{
gfc_error ("'a%d' argument of '%s' 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;
@ -2878,7 +2878,7 @@ gfc_check_min_max (gfc_actual_arglist *arg)
}
else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
{
gfc_error ("'a1' argument of '%s' 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;
}
@ -2928,7 +2928,7 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
{
if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
"or LOGICAL", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &matrix_a->where);
return false;
@ -2936,7 +2936,7 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
"or LOGICAL", gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &matrix_b->where);
return false;
@ -2945,7 +2945,7 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
if ((matrix_a->ts.type == BT_LOGICAL && gfc_numeric_ts (&matrix_b->ts))
|| (gfc_numeric_ts (&matrix_a->ts) && matrix_b->ts.type == BT_LOGICAL))
{
gfc_error ("Argument types of '%s' intrinsic at %L must match (%s/%s)",
gfc_error ("Argument types of %qs intrinsic at %L must match (%s/%s)",
gfc_current_intrinsic, &matrix_a->where,
gfc_typename(&matrix_a->ts), gfc_typename(&matrix_b->ts));
return false;
@ -2959,8 +2959,8 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
/* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0))
{
gfc_error ("Different shape on dimension 1 for arguments '%s' "
"and '%s' at %L for intrinsic matmul",
gfc_error ("Different shape on dimension 1 for arguments %qs "
"and %qs at %L for intrinsic matmul",
gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
return false;
@ -2978,8 +2978,8 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
- matrix_a has shape (n,m) and matrix_b has shape (m). */
if (!identical_dimen_shape (matrix_a, 1, matrix_b, 0))
{
gfc_error ("Different shape on dimension 2 for argument '%s' and "
"dimension 1 for argument '%s' at %L for intrinsic "
gfc_error ("Different shape on dimension 2 for argument %qs and "
"dimension 1 for argument %qs at %L for intrinsic "
"matmul", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic_arg[1]->name, &matrix_a->where);
return false;
@ -2987,7 +2987,7 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
break;
default:
gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
gfc_error ("%qs argument of %qs intrinsic at %L must be of rank "
"1 or 2", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &matrix_a->where);
return false;
@ -3162,7 +3162,7 @@ gfc_check_transf_bit_intrins (gfc_actual_arglist *ap)
{
if (ap->expr->ts.type != BT_INTEGER)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER",
gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &ap->expr->where);
return false;
@ -3337,7 +3337,7 @@ gfc_check_null (gfc_expr *mold)
if (!attr.pointer && !attr.proc_pointer && !attr.allocatable)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER, "
gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER, "
"ALLOCATABLE or procedure pointer",
gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &mold->where);
@ -3352,7 +3352,7 @@ gfc_check_null (gfc_expr *mold)
/* F2008, C1242. */
if (gfc_is_coindexed (mold))
{
gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
"coindexed", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &mold->where);
return false;
@ -3424,9 +3424,9 @@ gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
if (mpz_get_si (vector_size) < mask_true_values)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must "
gfc_error ("%qs argument of %qs intrinsic at %L must "
"provide at least as many elements as there "
"are .TRUE. values in '%s' (%ld/%d)",
"are .TRUE. values in %qs (%ld/%d)",
gfc_current_intrinsic_arg[2]->name,
gfc_current_intrinsic, &vector->where,
gfc_current_intrinsic_arg[1]->name,
@ -3482,7 +3482,7 @@ gfc_check_present (gfc_expr *a)
sym = a->symtree->n.sym;
if (!sym->attr.dummy)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
gfc_error ("%qs argument of %qs intrinsic at %L must be of a "
"dummy variable", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &a->where);
return false;
@ -3490,7 +3490,7 @@ gfc_check_present (gfc_expr *a)
if (!sym->attr.optional)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
gfc_error ("%qs argument of %qs intrinsic at %L must be of "
"an OPTIONAL dummy variable",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&a->where);
@ -3509,8 +3509,8 @@ gfc_check_present (gfc_expr *a)
|| (a->ref->u.ar.type == AR_ELEMENT
&& a->ref->u.ar.as->rank == 0))))
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
"subobject of '%s'", gfc_current_intrinsic_arg[0]->name,
gfc_error ("%qs argument of %qs intrinsic at %L must not be a "
"subobject of %qs", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &a->where, sym->name);
return false;
}
@ -3671,7 +3671,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
if (shape_size <= 0)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L is empty",
gfc_error ("%qs argument of %qs intrinsic at %L is empty",
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&shape->where);
return false;
@ -3695,7 +3695,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
gfc_extract_int (e, &extent);
if (extent < 0)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L has "
gfc_error ("%qs argument of %qs intrinsic at %L has "
"negative element (%d)",
gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &e->where, extent);
@ -3735,7 +3735,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
if (order_size != shape_size)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L "
gfc_error ("%qs argument of %qs intrinsic at %L "
"has wrong number of elements (%d/%d)",
gfc_current_intrinsic_arg[3]->name,
gfc_current_intrinsic, &order->where,
@ -3753,7 +3753,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
if (dim < 1 || dim > order_size)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L "
gfc_error ("%qs argument of %qs intrinsic at %L "
"has out-of-range dimension (%d)",
gfc_current_intrinsic_arg[3]->name,
gfc_current_intrinsic, &e->where, dim);
@ -3762,7 +3762,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
if (perm[dim-1] != 0)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L has "
gfc_error ("%qs argument of %qs intrinsic at %L has "
"invalid permutation of dimensions (dimension "
"'%d' duplicated)",
gfc_current_intrinsic_arg[3]->name,
@ -3815,7 +3815,7 @@ gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
{
if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L "
gfc_error ("%qs argument of %qs intrinsic at %L "
"cannot be of type %s",
gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic,
@ -3825,7 +3825,7 @@ gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
if (!(gfc_type_is_extensible (a->ts.u.derived) || UNLIMITED_POLY (a)))
{
gfc_error ("'%s' argument of '%s' intrinsic at %L "
gfc_error ("%qs argument of %qs intrinsic at %L "
"must be of an extensible type",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&a->where);
@ -3834,7 +3834,7 @@ gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L "
gfc_error ("%qs argument of %qs intrinsic at %L "
"cannot be of type %s",
gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic,
@ -3844,7 +3844,7 @@ gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
if (!(gfc_type_is_extensible (b->ts.u.derived) || UNLIMITED_POLY (b)))
{
gfc_error ("'%s' argument of '%s' intrinsic at %L "
gfc_error ("%qs argument of %qs intrinsic at %L "
"must be of an extensible type",
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&b->where);
@ -4086,7 +4086,7 @@ gfc_check_sizeof (gfc_expr *arg)
{
if (arg->ts.type == BT_PROCEDURE)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be a procedure",
gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&arg->where);
return false;
@ -4099,7 +4099,7 @@ gfc_check_sizeof (gfc_expr *arg)
&& arg->symtree->n.sym->as->type != AS_DEFERRED
&& arg->symtree->n.sym->as->type != AS_ASSUMED_RANK)))
{
gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be TYPE(*)",
gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&arg->where);
return false;
@ -4110,7 +4110,7 @@ gfc_check_sizeof (gfc_expr *arg)
&& arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref
&& arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be an "
gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
"assumed-size array", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &arg->where);
return false;
@ -4229,7 +4229,7 @@ gfc_check_c_sizeof (gfc_expr *arg)
if (!is_c_interoperable (arg, &msg, false, false))
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be an "
gfc_error ("%qs argument of %qs intrinsic at %L must be an "
"interoperable data entity: %s",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&arg->where, msg);
@ -4238,7 +4238,7 @@ gfc_check_c_sizeof (gfc_expr *arg)
if (arg->ts.type == BT_ASSUMED)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be "
gfc_error ("%qs argument of %qs intrinsic at %L shall not be "
"TYPE(*)",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&arg->where);
@ -4250,7 +4250,7 @@ gfc_check_c_sizeof (gfc_expr *arg)
&& arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref
&& arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be an "
gfc_error ("%qs argument of %qs intrinsic at %L shall not be an "
"assumed-size array", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &arg->where);
return false;
@ -4449,7 +4449,7 @@ gfc_check_c_funloc (gfc_expr *x)
for (ns = gfc_current_ns; ns; ns = ns->parent)
if (x->symtree->n.sym == ns->proc_name)
{
gfc_error ("Function result '%s' at %L is invalid as X argument "
gfc_error ("Function result %qs at %L is invalid as X argument "
"to C_FUNLOC", x->symtree->n.sym->name, &x->where);
return false;
}
@ -4575,7 +4575,7 @@ gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
{
if (source->rank >= GFC_MAX_DIMENSIONS)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
gfc_error ("%qs argument of %qs intrinsic at %L must be less "
"than rank %d", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
@ -4594,7 +4594,7 @@ gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
&& (mpz_cmp_ui (dim->value.integer, 1) < 0
|| mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0))
{
gfc_error ("'%s' argument of '%s' intrinsic at %L is not a valid "
gfc_error ("%qs argument of %qs intrinsic at %L is not a valid "
"dimension index", gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &dim->where);
return false;
@ -5189,9 +5189,9 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
if (mpz_get_si (vector_size) < mask_true_count)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must "
gfc_error ("%qs argument of %qs intrinsic at %L must "
"provide at least as many elements as there "
"are .TRUE. values in '%s' (%ld/%d)",
"are .TRUE. values in %qs (%ld/%d)",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&vector->where, gfc_current_intrinsic_arg[1]->name,
mpz_get_si (vector_size), mask_true_count);
@ -5203,8 +5203,8 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
if (mask->rank != field->rank && field->rank != 0)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must have "
"the same rank as '%s' or be a scalar",
gfc_error ("%qs argument of %qs intrinsic at %L must have "
"the same rank as %qs or be a scalar",
gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
&field->where, gfc_current_intrinsic_arg[1]->name);
return false;
@ -5216,7 +5216,7 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
for (i = 0; i < field->rank; i++)
if (! identical_dimen_shape (mask, i, field, i))
{
gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L "
gfc_error ("%qs and %qs arguments of %qs intrinsic at %L "
"must have identical shape.",
gfc_current_intrinsic_arg[2]->name,
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
@ -5474,7 +5474,7 @@ gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
if (gfc_array_size (put, &put_size)
&& mpz_get_ui (put_size) < kiss_size)
gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
gfc_error ("Size of %qs argument of %qs intrinsic at %L "
"too small (%i/%i)",
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
where, (int) mpz_get_ui (put_size), kiss_size);
@ -5506,7 +5506,7 @@ gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
if (gfc_array_size (get, &get_size)
&& mpz_get_ui (get_size) < kiss_size)
gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
gfc_error ("Size of %qs argument of %qs intrinsic at %L "
"too small (%i/%i)",
gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
where, (int) mpz_get_ui (get_size), kiss_size);
@ -5817,7 +5817,7 @@ gfc_check_getarg (gfc_expr *pos, gfc_expr *value)
if (pos->ts.kind > gfc_default_integer_kind)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
gfc_error ("%qs argument of %qs intrinsic at %L must be of a kind "
"not wider than the default kind (%d)",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&pos->where, gfc_default_integer_kind);
@ -6169,7 +6169,7 @@ gfc_check_and (gfc_expr *i, gfc_expr *j)
{
if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
"or LOGICAL", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &i->where);
return false;
@ -6177,7 +6177,7 @@ gfc_check_and (gfc_expr *i, gfc_expr *j)
if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER "
gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
"or LOGICAL", gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &j->where);
return false;
@ -6185,7 +6185,7 @@ gfc_check_and (gfc_expr *i, gfc_expr *j)
if (i->ts.type != j->ts.type)
{
gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must "
"have the same type", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&j->where);
@ -6207,7 +6207,7 @@ gfc_check_storage_size (gfc_expr *a, gfc_expr *kind)
{
if (a->ts.type == BT_ASSUMED)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be TYPE(*)",
gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&a->where);
return false;
@ -6215,7 +6215,7 @@ gfc_check_storage_size (gfc_expr *a, gfc_expr *kind)
if (a->ts.type == BT_PROCEDURE)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be a "
gfc_error ("%qs argument of %qs intrinsic at %L shall not be a "
"procedure", gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &a->where);
return false;
@ -6232,7 +6232,7 @@ gfc_check_storage_size (gfc_expr *a, gfc_expr *kind)
if (kind->expr_type != EXPR_CONSTANT)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
gfc_error ("%qs argument of %qs intrinsic at %L must be a constant",
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&kind->where);
return false;

6
gcc/fortran/class.c
View File

@ -666,7 +666,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
up to 255 extension levels. */
if (ts->u.derived->attr.extension == 255)
{
gfc_error ("Maximum extension level reached with type '%s' at %L",
gfc_error ("Maximum extension level reached with type %qs at %L",
ts->u.derived->name, &ts->u.derived->declared_at);
return false;
}
@ -2686,7 +2686,7 @@ find_typebound_proc_uop (gfc_symbol* derived, bool* t,
&& res->n.tb->access == ACCESS_PRIVATE)
{
if (where)
gfc_error ("'%s' of '%s' is PRIVATE at %L",
gfc_error ("%qs of %qs is PRIVATE at %L",
name, derived->name, where);
if (t)
*t = false;
@ -2760,7 +2760,7 @@ gfc_find_typebound_intrinsic_op (gfc_symbol* derived, bool* t,
&& res->access == ACCESS_PRIVATE)
{
if (where)
gfc_error ("'%s' of '%s' is PRIVATE at %L",
gfc_error ("%qs of %qs is PRIVATE at %L",
gfc_op2string (op), derived->name, where);
if (t)
*t = false;

6
gcc/fortran/data.c
View File

@ -253,9 +253,9 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index,
if (init && expr->expr_type != EXPR_ARRAY)
{
gfc_error ("'%s' at %L already is initialized at %L",
lvalue->symtree->n.sym->name, &lvalue->where,
&init->where);
gfc_error_1 ("'%s' at %L already is initialized at %L",
lvalue->symtree->n.sym->name, &lvalue->where,
&init->where);
goto abort;
}

112
gcc/fortran/decl.c
View File

@ -261,7 +261,7 @@ var_element (gfc_data_variable *new_var)
if (!sym->attr.function && gfc_current_ns->parent
&& gfc_current_ns->parent == sym->ns)
{
gfc_error ("Host associated variable '%s' may not be in the DATA "
gfc_error ("Host associated variable %qs may not be in the DATA "
"statement at %C", sym->name);
return MATCH_ERROR;
}
@ -379,7 +379,7 @@ match_data_constant (gfc_expr **result)
|| (sym->attr.flavor != FL_PARAMETER
&& (!dt_sym || dt_sym->attr.flavor != FL_DERIVED)))
{
gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C",
name);
return MATCH_ERROR;
}
@ -1017,15 +1017,15 @@ gfc_verify_c_interop_param (gfc_symbol *sym)
{
/* Make personalized messages to give better feedback. */
if (sym->ts.type == BT_DERIVED)
gfc_error ("Variable '%s' at %L is a dummy argument to the "
"BIND(C) procedure '%s' but is not C interoperable "
"because derived type '%s' is not C interoperable",
gfc_error ("Variable %qs at %L is a dummy argument to the "
"BIND(C) procedure %qs but is not C interoperable "
"because derived type %qs is not C interoperable",
sym->name, &(sym->declared_at),
sym->ns->proc_name->name,
sym->ts.u.derived->name);
else if (sym->ts.type == BT_CLASS)
gfc_error ("Variable '%s' at %L is a dummy argument to the "
"BIND(C) procedure '%s' but is not C interoperable "
gfc_error ("Variable %qs at %L is a dummy argument to the "
"BIND(C) procedure %qs but is not C interoperable "
"because it is polymorphic",
sym->name, &(sym->declared_at),
sym->ns->proc_name->name);
@ -1046,9 +1046,9 @@ gfc_verify_c_interop_param (gfc_symbol *sym)
if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT
|| mpz_cmp_si (cl->length->value.integer, 1) != 0)
{
gfc_error ("Character argument '%s' at %L "
gfc_error ("Character argument %qs at %L "
"must be length 1 because "
"procedure '%s' is BIND(C)",
"procedure %qs is BIND(C)",
sym->name, &sym->declared_at,
sym->ns->proc_name->name);
retval = false;
@ -1076,8 +1076,8 @@ gfc_verify_c_interop_param (gfc_symbol *sym)
if ((sym->attr.allocatable || sym->attr.pointer) && !sym->as)
{
gfc_error ("Scalar variable '%s' at %L with POINTER or "
"ALLOCATABLE in procedure '%s' with BIND(C) is not yet"
gfc_error ("Scalar variable %qs at %L with POINTER or "
"ALLOCATABLE in procedure %qs with BIND(C) is not yet"
" supported", sym->name, &(sym->declared_at),
sym->ns->proc_name->name);
retval = false;
@ -1085,8 +1085,8 @@ gfc_verify_c_interop_param (gfc_symbol *sym)
if (sym->attr.optional == 1 && sym->attr.value)
{
gfc_error ("Variable '%s' at %L cannot have both the OPTIONAL "
"and the VALUE attribute because procedure '%s' "
gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
"and the VALUE attribute because procedure %qs "
"is BIND(C)", sym->name, &(sym->declared_at),
sym->ns->proc_name->name);
retval = false;
@ -1323,7 +1323,7 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
&& sym->value != NULL
&& *initp != NULL)
{
gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
sym->name);
return false;
}
@ -1343,7 +1343,7 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
initializer. */
if (sym->attr.data)
{
gfc_error ("Variable '%s' at %C with an initializer already "
gfc_error ("Variable %qs at %C with an initializer already "
"appears in a DATA statement", sym->name);
return false;
}
@ -1783,7 +1783,7 @@ check_function_name (char *name)
&& strcmp (block->result->name, "ppr@") != 0
&& strcmp (block->name, name) == 0)
{
gfc_error ("Function name '%s' not allowed at %C", name);
gfc_error ("Function name %qs not allowed at %C", name);
return false;
}
}
@ -1850,7 +1850,7 @@ variable_decl (int elem)
if (as->type == AS_IMPLIED_SHAPE && current_attr.flavor != FL_PARAMETER)
{
m = MATCH_ERROR;
gfc_error ("Non-PARAMETER symbol '%s' at %L can't be implied-shape",
gfc_error ("Non-PARAMETER symbol %qs at %L can't be implied-shape",
name, &var_locus);
goto cleanup;
}
@ -2819,7 +2819,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
gfc_get_ha_symbol (name, &sym);
if (sym->generic && gfc_find_symbol (dt_name, NULL, 0, &dt_sym))
{
gfc_error ("Type name '%s' at %C is ambiguous", name);
gfc_error ("Type name %qs at %C is ambiguous", name);
return MATCH_ERROR;
}
if (sym->generic && !dt_sym)
@ -2832,7 +2832,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
gfc_find_symbol (name, NULL, iface, &sym);
if (sym && sym->generic && gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
{
gfc_error ("Type name '%s' at %C is ambiguous", name);
gfc_error ("Type name %qs at %C is ambiguous", name);
return MATCH_ERROR;
}
if (sym && sym->generic && !dt_sym)
@ -2847,9 +2847,9 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
&& !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic))
|| sym->attr.subroutine)
{
gfc_error ("Type name '%s' at %C conflicts with previously declared "
"entity at %L, which has the same name", name,
&sym->declared_at);
gfc_error_1 ("Type name '%s' at %C conflicts with previously declared "
"entity at %L, which has the same name", name,
&sym->declared_at);
return MATCH_ERROR;
}
@ -3274,7 +3274,7 @@ gfc_match_import (void)
if (gfc_current_ns->parent != NULL
&& gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym))
{
gfc_error ("Type name '%s' at %C is ambiguous", name);
gfc_error ("Type name %qs at %C is ambiguous", name);
return MATCH_ERROR;
}
else if (!sym && gfc_current_ns->proc_name->ns->parent != NULL
@ -3282,13 +3282,13 @@ gfc_match_import (void)
gfc_current_ns->proc_name->ns->parent,
1, &sym))
{
gfc_error ("Type name '%s' at %C is ambiguous", name);
gfc_error ("Type name %qs at %C is ambiguous", name);
return MATCH_ERROR;
}
if (sym == NULL)
{
gfc_error ("Cannot IMPORT '%s' from host scoping unit "
gfc_error ("Cannot IMPORT %qs from host scoping unit "
"at %C - does not exist.", name);
return MATCH_ERROR;
}
@ -4064,13 +4064,13 @@ verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
else
{
if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED)
gfc_error ("Type declaration '%s' at %L is not C "
gfc_error ("Type declaration %qs at %L is not C "
"interoperable but it is BIND(C)",
tmp_sym->name, &(tmp_sym->declared_at));
else if (warn_c_binding_type)
gfc_warning (OPT_Wc_binding_type, "Variable %qs at %L "
"may not be a C interoperable "
"kind but it is bind(c)",
"kind but it is BIND(C)",
tmp_sym->name, &(tmp_sym->declared_at));
}
}
@ -4080,7 +4080,7 @@ verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
semantically no reason for the attribute. */
if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1)
{
gfc_error ("Variable '%s' in common block '%s' at "
gfc_error ("Variable %qs in common block %qs at "
"%L cannot be declared with BIND(C) "
"since it is not a global",
tmp_sym->name, com_block->name,
@ -4094,7 +4094,7 @@ verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
{
if (tmp_sym->attr.pointer == 1)
{
gfc_error ("Variable '%s' at %L cannot have both the "
gfc_error ("Variable %qs at %L cannot have both the "
"POINTER and BIND(C) attributes",
tmp_sym->name, &(tmp_sym->declared_at));
retval = false;
@ -4102,7 +4102,7 @@ verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
if (tmp_sym->attr.allocatable == 1)
{
gfc_error ("Variable '%s' at %L cannot have both the "
gfc_error ("Variable %qs at %L cannot have both the "
"ALLOCATABLE and BIND(C) attributes",
tmp_sym->name, &(tmp_sym->declared_at));
retval = false;
@ -4114,7 +4114,7 @@ verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
scalar value. The previous tests in this function made sure
the type is interoperable. */
if (bind_c_function && tmp_sym->as != NULL)
gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
gfc_error ("Return type of BIND(C) function %qs at %L cannot "
"be an array", tmp_sym->name, &(tmp_sym->declared_at));
/* BIND(C) functions can not return a character string. */
@ -4122,7 +4122,7 @@ verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
if (tmp_sym->ts.u.cl == NULL || tmp_sym->ts.u.cl->length == NULL
|| tmp_sym->ts.u.cl->length->expr_type != EXPR_CONSTANT
|| mpz_cmp_si (tmp_sym->ts.u.cl->length->value.integer, 1) != 0)
gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
gfc_error ("Return type of BIND(C) function %qs at %L cannot "
"be a character string", tmp_sym->name,
&(tmp_sym->declared_at));
}
@ -4597,7 +4597,7 @@ gfc_match_formal_arglist (gfc_symbol *progname, int st_flag, int null_flag)
if (gfc_new_block != NULL && sym != NULL
&& strcmp (sym->name, gfc_new_block->name) == 0)
{
gfc_error ("Name '%s' at %C is the name of the procedure",
gfc_error ("Name %qs at %C is the name of the procedure",
sym->name);
m = MATCH_ERROR;
goto cleanup;
@ -4626,7 +4626,7 @@ ok:
for (q = p->next; q; q = q->next)
if (p->sym == q->sym)
{
gfc_error ("Duplicate symbol '%s' in formal argument list "
gfc_error ("Duplicate symbol %qs in formal argument list "
"at %C", p->sym->name);
m = MATCH_ERROR;
@ -5001,7 +5001,7 @@ match_procedure_decl (void)
{
if (sym->ts.type != BT_UNKNOWN)
{
gfc_error ("Procedure '%s' at %L already has basic type of %s",
gfc_error ("Procedure %qs at %L already has basic type of %s",
sym->name, &gfc_current_locus,
gfc_basic_typename (sym->ts.type));
return MATCH_ERROR;
@ -6277,7 +6277,7 @@ gfc_match_end (gfc_statement *st)
if (!block_name)
return MATCH_YES;
gfc_error ("Expected block name of '%s' in %s statement at %L",
gfc_error ("Expected block name of %qs in %s statement at %L",
block_name, gfc_ascii_statement (*st), &old_loc);
return MATCH_ERROR;
@ -6303,7 +6303,7 @@ gfc_match_end (gfc_statement *st)
if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0)
{
gfc_error ("Expected label '%s' for %s statement at %C", block_name,
gfc_error ("Expected label %qs for %s statement at %C", block_name,
gfc_ascii_statement (*st));
goto cleanup;
}
@ -6311,7 +6311,7 @@ gfc_match_end (gfc_statement *st)
else if (strcmp (block_name, "ppr@") == 0
&& strcmp (name, gfc_current_block ()->ns->proc_name->name) != 0)
{
gfc_error ("Expected label '%s' for %s statement at %C",
gfc_error ("Expected label %qs for %s statement at %C",
gfc_current_block ()->ns->proc_name->name,
gfc_ascii_statement (*st));
goto cleanup;
@ -7315,7 +7315,7 @@ gfc_match_volatile (void)
for variable in a BLOCK which is defined outside of the BLOCK. */
if (sym->ns != gfc_current_ns && sym->attr.codimension)
{
gfc_error ("Specifying VOLATILE for coarray variable '%s' at "
gfc_error ("Specifying VOLATILE for coarray variable %qs at "
"%C, which is use-/host-associated", sym->name);
return MATCH_ERROR;
}
@ -7531,27 +7531,27 @@ check_extended_derived_type (char *name)
/* F08:C428. */
if (!extended)
{
gfc_error ("Symbol '%s' at %C has not been previously defined", name);
gfc_error ("Symbol %qs at %C has not been previously defined", name);
return NULL;
}
if (extended->attr.flavor != FL_DERIVED)
{
gfc_error ("'%s' in EXTENDS expression at %C is not a "
gfc_error ("%qs in EXTENDS expression at %C is not a "
"derived type", name);
return NULL;
}
if (extended->attr.is_bind_c)
{
gfc_error ("'%s' cannot be extended at %C because it "
gfc_error ("%qs cannot be extended at %C because it "
"is BIND(C)", extended->name);
return NULL;
}
if (extended->attr.sequence)
{
gfc_error ("'%s' cannot be extended at %C because it "
gfc_error ("%qs cannot be extended at %C because it "
"is a SEQUENCE type", extended->name);
return NULL;
}
@ -7682,7 +7682,7 @@ gfc_match_derived_decl (void)
/* Make sure the name is not the name of an intrinsic type. */
if (gfc_is_intrinsic_typename (name))
{
gfc_error ("Type name '%s' at %C cannot be the same as an intrinsic "
gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
"type", name);
return MATCH_ERROR;
}
@ -7692,7 +7692,7 @@ gfc_match_derived_decl (void)
if (!gensym->attr.generic && gensym->ts.type != BT_UNKNOWN)
{
gfc_error ("Derived type name '%s' at %C already has a basic type "
gfc_error ("Derived type name %qs at %C already has a basic type "
"of %s", gensym->name, gfc_typename (&gensym->ts));
return MATCH_ERROR;
}
@ -7709,7 +7709,7 @@ gfc_match_derived_decl (void)
if (sym && (sym->components != NULL || sym->attr.zero_comp))
{
gfc_error ("Derived type definition of '%s' at %C has already been "
gfc_error ("Derived type definition of %qs at %C has already been "
"defined", sym->name);
return MATCH_ERROR;
}
@ -7780,7 +7780,7 @@ gfc_match_derived_decl (void)
{
/* Since the extension field is 8 bit wide, we can only have
up to 255 extension levels. */
gfc_error ("Maximum extension level reached with type '%s' at %L",
gfc_error ("Maximum extension level reached with type %qs at %L",
extended->name, &extended->declared_at);
return MATCH_ERROR;
}
@ -8375,7 +8375,7 @@ match_procedure_in_type (void)
/* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
if (tb.deferred && !block->attr.abstract)
{
gfc_error ("Type '%s' containing DEFERRED binding at %C "
gfc_error ("Type %qs containing DEFERRED binding at %C "
"is not ABSTRACT", block->name);
return MATCH_ERROR;
}
@ -8386,8 +8386,8 @@ match_procedure_in_type (void)
stree = gfc_find_symtree (ns->tb_sym_root, name);
if (stree && stree->n.tb)
{
gfc_error ("There is already a procedure with binding name '%s' for "
"the derived type '%s' at %C", name, block->name);
gfc_error ("There is already a procedure with binding name %qs for "
"the derived type %qs at %C", name, block->name);
return MATCH_ERROR;
}
@ -8536,7 +8536,7 @@ gfc_match_generic (void)
{
gcc_assert (op_type == INTERFACE_GENERIC);
gfc_error ("There's already a non-generic procedure with binding name"
" '%s' for the derived type '%s' at %C",
" %qs for the derived type %qs at %C",
bind_name, block->name);
goto error;
}
@ -8544,7 +8544,7 @@ gfc_match_generic (void)
if (tb->access != tbattr.access)
{
gfc_error ("Binding at %C must have the same access as already"
" defined binding '%s'", bind_name);
" defined binding %qs", bind_name);
goto error;
}
}
@ -8602,8 +8602,8 @@ gfc_match_generic (void)
for (target = tb->u.generic; target; target = target->next)
if (target_st == target->specific_st)
{
gfc_error ("'%s' already defined as specific binding for the"
" generic '%s' at %C", name, bind_name);
gfc_error ("%qs already defined as specific binding for the"
" generic %qs at %C", name, bind_name);
goto error;
}
@ -8711,7 +8711,7 @@ gfc_match_final_decl (void)
if (gfc_get_symbol (name, module_ns, &sym))
{
gfc_error ("Unknown procedure name \"%s\" at %C", name);
gfc_error ("Unknown procedure name %qs at %C", name);
return MATCH_ERROR;
}
@ -8724,7 +8724,7 @@ gfc_match_final_decl (void)
for (f = block->f2k_derived->finalizers; f; f = f->next)
if (f->proc_sym == sym)
{
gfc_error ("'%s' at %C is already defined as FINAL procedure!",
gfc_error ("%qs at %C is already defined as FINAL procedure!",
name);
return MATCH_ERROR;
}

151
gcc/fortran/error.c
View File

@ -34,6 +34,8 @@ along with GCC; see the file COPYING3. If not see
#include "diagnostic-color.h"
#include "tree-diagnostic.h" /* tree_diagnostics_defaults */
#include <new> /* For placement-new */
static int suppress_errors = 0;
static bool warnings_not_errors = false;
@ -44,13 +46,18 @@ static gfc_error_buf error_buffer, warning_buffer, *cur_error_buffer;
/* True if the error/warnings should be buffered. */
static bool buffered_p;
/* These are always buffered buffers (.flush_p == false) to be used by
the pretty-printer. */
static output_buffer pp_warning_buffer;
static output_buffer *pp_error_buffer, *pp_warning_buffer;
static int warningcount_buffered, werrorcount_buffered;
#include <new> /* For placement-new */
/* Return true if there output_buffer is empty. */
static bool
gfc_output_buffer_empty_p (const output_buffer * buf)
{
return output_buffer_last_position_in_text (buf) == NULL;
}
/* Go one level deeper suppressing errors. */
@ -99,7 +106,6 @@ void
gfc_buffer_error (bool flag)
{
buffered_p = flag;
pp_warning_buffer.flush_p = !flag;
}
@ -843,11 +849,11 @@ gfc_warning (int opt, const char *gmsgid, va_list ap)
pretty_printer *pp = global_dc->printer;
output_buffer *tmp_buffer = pp->buffer;
gfc_clear_pp_buffer (&pp_warning_buffer);
gfc_clear_pp_buffer (pp_warning_buffer);
if (buffered_p)
{
pp->buffer = &pp_warning_buffer;
pp->buffer = pp_warning_buffer;
global_dc->fatal_errors = false;
/* To prevent -fmax-errors= triggering. */
--werrorcount;
@ -1248,10 +1254,9 @@ gfc_clear_warning (void)
{
warning_buffer.flag = 0;
gfc_clear_pp_buffer (&pp_warning_buffer);
gfc_clear_pp_buffer (pp_warning_buffer);
warningcount_buffered = 0;
werrorcount_buffered = 0;
pp_warning_buffer.flush_p = false;
}
@ -1266,29 +1271,32 @@ gfc_warning_check (void)
warnings++;
if (warning_buffer.message != NULL)
fputs (warning_buffer.message, stderr);
warning_buffer.flag = 0;
gfc_clear_warning ();
}
/* This is for the new diagnostics machinery. */
pretty_printer *pp = global_dc->printer;
output_buffer *tmp_buffer = pp->buffer;
pp->buffer = &pp_warning_buffer;
if (pp_last_position_in_text (pp) != NULL)
else if (! gfc_output_buffer_empty_p (pp_warning_buffer))
{
pretty_printer *pp = global_dc->printer;
output_buffer *tmp_buffer = pp->buffer;
pp->buffer = pp_warning_buffer;
pp_really_flush (pp);
pp_warning_buffer.flush_p = true;
warningcount += warningcount_buffered;
werrorcount += werrorcount_buffered;
gcc_assert (warningcount_buffered + werrorcount_buffered == 1);
diagnostic_action_after_output (global_dc,
warningcount_buffered
? DK_WARNING : DK_ERROR);
pp->buffer = tmp_buffer;
}
pp->buffer = tmp_buffer;
}
/* Issue an error. */
/* Use gfc_error instead, unless two locations are used in the same
warning or for scanner.c, if the location is not properly set up. */
void
gfc_error (const char *gmsgid, ...)
gfc_error_1 (const char *gmsgid, ...)
{
va_list argp;
@ -1336,6 +1344,59 @@ warning:
}
}
/* Issue an error. */
/* This function uses the common diagnostics, but does not support
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, ...)
{
va_list argp;
va_start (argp, gmsgid);
if (warnings_not_errors)
{
gfc_warning (/*opt=*/0, gmsgid, argp);
va_end (argp);
return;
}
if (suppress_errors)
{
va_end (argp);
return;
}
diagnostic_info diagnostic;
bool fatal_errors = global_dc->fatal_errors;
pretty_printer *pp = global_dc->printer;
output_buffer *tmp_buffer = pp->buffer;
gfc_clear_pp_buffer (pp_error_buffer);
if (buffered_p)
{
pp->buffer = pp_error_buffer;
global_dc->fatal_errors = false;
/* To prevent -fmax-errors= triggering, we decrease it before
report_diagnostic increases it. */
--errorcount;
}
diagnostic_set_info (&diagnostic, gmsgid, &argp, UNKNOWN_LOCATION, DK_ERROR);
report_diagnostic (&diagnostic);
if (buffered_p)
{
pp->buffer = tmp_buffer;
global_dc->fatal_errors = fatal_errors;
}
va_end (argp);
}
/* Immediate error. */
/* Use gfc_error_now instead, unless two locations are used in the same
@ -1393,6 +1454,7 @@ gfc_clear_error (void)
{
error_buffer.flag = 0;
warnings_not_errors = false;
gfc_clear_pp_buffer (pp_error_buffer);
}
@ -1401,7 +1463,8 @@ gfc_clear_error (void)
bool
gfc_error_flag_test (void)
{
return error_buffer.flag;
return error_buffer.flag
|| !gfc_output_buffer_empty_p (pp_error_buffer);
}
@ -1418,34 +1481,69 @@ gfc_error_check (void)
if (error_buffer.message != NULL)
fputs (error_buffer.message, stderr);
error_buffer.flag = 0;
gfc_clear_pp_buffer (pp_error_buffer);
gfc_increment_error_count();
if (flag_fatal_errors)
exit (FATAL_EXIT_CODE);
}
/* This is for the new diagnostics machinery. */
else if (! gfc_output_buffer_empty_p (pp_error_buffer))
{
error_raised = true;
pretty_printer *pp = global_dc->printer;
output_buffer *tmp_buffer = pp->buffer;
pp->buffer = pp_error_buffer;
pp_really_flush (pp);
++errorcount;
gcc_assert (gfc_output_buffer_empty_p (pp_error_buffer));
diagnostic_action_after_output (global_dc, DK_ERROR);
pp->buffer = tmp_buffer;
}
return error_raised;
}
/* Move the text buffered from FROM to TO, then clear
FROM. Independently if there was text in FROM, TO is also
cleared. */
static void
gfc_move_output_buffer_from_to (output_buffer *from, output_buffer *to)
{
gfc_clear_pp_buffer (to);
/* We make sure this is always buffered. */
to->flush_p = false;
if (! gfc_output_buffer_empty_p (from))
{
const char *str = output_buffer_formatted_text (from);
output_buffer_append_r (to, str, strlen (str));
gfc_clear_pp_buffer (from);
}
}
/* Save the existing error state. */
void
gfc_push_error (gfc_error_buf *err)
gfc_push_error (output_buffer *buffer_err, gfc_error_buf *err)
{
err->flag = error_buffer.flag;
if (error_buffer.flag)
err->message = xstrdup (error_buffer.message);
error_buffer.flag = 0;
/* This part uses the common diagnostics. */
gfc_move_output_buffer_from_to (pp_error_buffer, buffer_err);
}
/* Restore a previous pushed error state. */
void
gfc_pop_error (gfc_error_buf *err)
gfc_pop_error (output_buffer *buffer_err, gfc_error_buf *err)
{
error_buffer.flag = err->flag;
if (error_buffer.flag)
@ -1455,16 +1553,20 @@ gfc_pop_error (gfc_error_buf *err)
memcpy (error_buffer.message, err->message, len);
free (err->message);
}
/* This part uses the common diagnostics. */
gfc_move_output_buffer_from_to (buffer_err, pp_error_buffer);
}
/* Free a pushed error state, but keep the current error state. */
void
gfc_free_error (gfc_error_buf *err)
gfc_free_error (output_buffer *buffer_err, gfc_error_buf *err)
{
if (err->flag)
free (err->message);
gfc_clear_pp_buffer (buffer_err);
}
@ -1495,7 +1597,10 @@ gfc_diagnostics_init (void)
diagnostic_finalizer (global_dc) = gfc_diagnostic_finalizer;
diagnostic_format_decoder (global_dc) = gfc_format_decoder;
global_dc->caret_char = '^';
new (&pp_warning_buffer) output_buffer ();
pp_warning_buffer = new (XNEW (output_buffer)) output_buffer ();
pp_warning_buffer->flush_p = false;
pp_error_buffer = new (XNEW (output_buffer)) output_buffer ();
pp_error_buffer->flush_p = false;
}
void

90
gcc/fortran/expr.c
View File

@ -2204,9 +2204,9 @@ check_alloc_comp_init (gfc_expr *e)
if (comp->attr.allocatable
&& ctor->expr->expr_type != EXPR_NULL)
{
gfc_error("Invalid initialization expression for ALLOCATABLE "
"component '%s' in structure constructor at %L",
comp->name, &ctor->expr->where);
gfc_error ("Invalid initialization expression for ALLOCATABLE "
"component %qs in structure constructor at %L",
comp->name, &ctor->expr->where);
return false;
}
}
@ -2315,7 +2315,7 @@ check_inquiry (gfc_expr *e, int not_restricted)
&& (ap->expr->symtree->n.sym->ts.u.cl->length == NULL
|| ap->expr->symtree->n.sym->ts.deferred))
{
gfc_error ("Assumed or deferred character length variable '%s' "
gfc_error ("Assumed or deferred character length variable %qs "
" in constant expression at %L",
ap->expr->symtree->n.sym->name,
&ap->expr->where);
@ -2381,8 +2381,8 @@ check_transformational (gfc_expr *e)
if (functions[i] == NULL)
{
gfc_error("transformational intrinsic '%s' at %L is not permitted "
"in an initialization expression", name, &e->where);
gfc_error ("transformational intrinsic %qs at %L is not permitted "
"in an initialization expression", name, &e->where);
return MATCH_ERROR;
}
@ -2481,7 +2481,7 @@ gfc_check_init_expr (gfc_expr *e)
if (!gfc_is_intrinsic (sym, 0, e->where)
|| (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
{
gfc_error ("Function '%s' in initialization expression at %L "
gfc_error ("Function %qs in initialization expression at %L "
"must be an intrinsic function",
e->symtree->n.sym->name, &e->where);
break;
@ -2493,7 +2493,7 @@ gfc_check_init_expr (gfc_expr *e)
&& (m = check_transformational (e)) == MATCH_NO
&& (m = check_elemental (e)) == MATCH_NO)
{
gfc_error ("Intrinsic function '%s' at %L is not permitted "
gfc_error ("Intrinsic function %qs at %L is not permitted "
"in an initialization expression",
e->symtree->n.sym->name, &e->where);
m = MATCH_ERROR;
@ -2528,8 +2528,8 @@ gfc_check_init_expr (gfc_expr *e)
is invalid. */
if (!e->symtree->n.sym->value)
{
gfc_error("PARAMETER '%s' is used at %L before its definition "
"is complete", e->symtree->n.sym->name, &e->where);
gfc_error ("PARAMETER %qs is used at %L before its definition "
"is complete", e->symtree->n.sym->name, &e->where);
t = false;
}
else
@ -2548,25 +2548,25 @@ gfc_check_init_expr (gfc_expr *e)
switch (e->symtree->n.sym->as->type)
{
case AS_ASSUMED_SIZE:
gfc_error ("Assumed size array '%s' at %L is not permitted "
gfc_error ("Assumed size array %qs at %L is not permitted "
"in an initialization expression",
e->symtree->n.sym->name, &e->where);
break;
case AS_ASSUMED_SHAPE:
gfc_error ("Assumed shape array '%s' at %L is not permitted "
gfc_error ("Assumed shape array %qs at %L is not permitted "
"in an initialization expression",
e->symtree->n.sym->name, &e->where);
break;
case AS_DEFERRED:
gfc_error ("Deferred array '%s' at %L is not permitted "
gfc_error ("Deferred array %qs at %L is not permitted "
"in an initialization expression",
e->symtree->n.sym->name, &e->where);
break;
case AS_EXPLICIT:
gfc_error ("Array '%s' at %L is a variable, which does "
gfc_error ("Array %qs at %L is a variable, which does "
"not reduce to a constant expression",
e->symtree->n.sym->name, &e->where);
break;
@ -2576,7 +2576,7 @@ gfc_check_init_expr (gfc_expr *e)
}
}
else
gfc_error ("Parameter '%s' at %L has not been declared or is "
gfc_error ("Parameter %qs at %L has not been declared or is "
"a variable, which does not reduce to a constant "
"expression", e->symtree->n.sym->name, &e->where);
@ -2729,28 +2729,28 @@ external_spec_function (gfc_expr *e)
if (f->attr.proc == PROC_ST_FUNCTION)
{
gfc_error ("Specification function '%s' at %L cannot be a statement "
gfc_error ("Specification function %qs at %L cannot be a statement "
"function", f->name, &e->where);
return false;
}
if (f->attr.proc == PROC_INTERNAL)
{
gfc_error ("Specification function '%s' at %L cannot be an internal "
gfc_error ("Specification function %qs at %L cannot be an internal "
"function", f->name, &e->where);
return false;
}
if (!f->attr.pure && !f->attr.elemental)
{
gfc_error ("Specification function '%s' at %L must be PURE", f->name,
gfc_error ("Specification function %qs at %L must be PURE", f->name,
&e->where);
return false;
}
if (f->attr.recursive)
{
gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
gfc_error ("Specification function %qs at %L cannot be RECURSIVE",
f->name, &e->where);
return false;
}
@ -2884,21 +2884,21 @@ check_restricted (gfc_expr *e)
if (sym->attr.dummy && sym->ns == gfc_current_ns
&& sym->ns->proc_name && sym->ns->proc_name->attr.elemental)
{
gfc_error ("Dummy argument '%s' not allowed in expression at %L",
gfc_error ("Dummy argument %qs not allowed in expression at %L",
sym->name, &e->where);
break;
}
if (sym->attr.optional)
{
gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
gfc_error ("Dummy argument %qs at %L cannot be OPTIONAL",
sym->name, &e->where);
break;
}
if (sym->attr.intent == INTENT_OUT)
{
gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
gfc_error ("Dummy argument %qs at %L cannot be INTENT(OUT)",
sym->name, &e->where);
break;
}
@ -2929,7 +2929,7 @@ check_restricted (gfc_expr *e)
break;
}
gfc_error ("Variable '%s' cannot appear in the expression at %L",
gfc_error ("Variable %qs cannot appear in the expression at %L",
sym->name, &e->where);
/* Prevent a repetition of the error. */
e->error = 1;
@ -2992,7 +2992,7 @@ gfc_specification_expr (gfc_expr *e)
&& !gfc_pure (e->symtree->n.sym)
&& (!comp || !comp->attr.pure))
{
gfc_error ("Function '%s' at %L must be PURE",
gfc_error ("Function %qs at %L must be PURE",
e->symtree->n.sym->name, &e->where);
/* Prevent repeat error messages. */
e->symtree->n.sym->attr.pure = 1;
@ -3138,7 +3138,7 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
if (bad_proc)
{
gfc_error ("'%s' at %L is not a VALUE", sym->name, &lvalue->where);
gfc_error ("%qs at %L is not a VALUE", sym->name, &lvalue->where);
return false;
}
}
@ -3331,7 +3331,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
if (lhs_attr.flavor == FL_PROCEDURE && lhs_attr.use_assoc
&& !lhs_attr.proc_pointer)
{
gfc_error ("'%s' in the pointer assignment at %L cannot be an "
gfc_error ("%qs in the pointer assignment at %L cannot be an "
"l-value since it is a procedure",
lvalue->symtree->n.sym->name, &lvalue->where);
return false;
@ -3354,7 +3354,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
if (ref->u.ar.type != AR_SECTION)
{
gfc_error ("Expected bounds specification for '%s' at %L",
gfc_error ("Expected bounds specification for %qs at %L",
lvalue->symtree->n.sym->name, &lvalue->where);
return false;
}
@ -3461,7 +3461,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
for (ns = gfc_current_ns; ns; ns = ns->parent)
if (sym == ns->proc_name)
{
gfc_error ("Function result '%s' is invalid as proc-target "
gfc_error ("Function result %qs is invalid as proc-target "
"in procedure pointer assignment at %L",
sym->name, &rvalue->where);
return false;
@ -3470,7 +3470,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
}
if (attr.abstract)
{
gfc_error ("Abstract interface '%s' is invalid "
gfc_error ("Abstract interface %qs is invalid "
"in procedure pointer assignment at %L",
rvalue->symtree->name, &rvalue->where);
return false;
@ -3480,7 +3480,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
{
if (attr.proc == PROC_ST_FUNCTION)
{
gfc_error ("Statement function '%s' is invalid "
gfc_error ("Statement function %qs is invalid "
"in procedure pointer assignment at %L",
rvalue->symtree->name, &rvalue->where);
return false;
@ -3493,7 +3493,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
if (attr.intrinsic && gfc_intrinsic_actual_ok (rvalue->symtree->name,
attr.subroutine) == 0)
{
gfc_error ("Intrinsic '%s' at %L is invalid in procedure pointer "
gfc_error ("Intrinsic %qs at %L is invalid in procedure pointer "
"assignment", rvalue->symtree->name, &rvalue->where);
return false;
}
@ -3501,7 +3501,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
/* Check for F08:C730. */
if (attr.elemental && !attr.intrinsic)
{
gfc_error ("Nonintrinsic elemental procedure '%s' is invalid "
gfc_error ("Nonintrinsic elemental procedure %qs is invalid "
"in procedure pointer assignment at %L",
rvalue->symtree->name, &rvalue->where);
return false;
@ -3580,14 +3580,14 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
if (s1->attr.if_source == IFSRC_UNKNOWN
&& gfc_explicit_interface_required (s2, err, sizeof(err)))
{
gfc_error ("Explicit interface required for '%s' at %L: %s",
gfc_error ("Explicit interface required for %qs at %L: %s",
s1->name, &lvalue->where, err);
return false;
}
if (s2->attr.if_source == IFSRC_UNKNOWN
&& gfc_explicit_interface_required (s1, err, sizeof(err)))
{
gfc_error ("Explicit interface required for '%s' at %L: %s",
gfc_error ("Explicit interface required for %qs at %L: %s",
s2->name, &rvalue->where, err);
return false;
}
@ -3604,7 +3604,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
if (!s2->attr.intrinsic && s2->attr.if_source == IFSRC_UNKNOWN
&& !s2->attr.external && !s2->attr.subroutine && !s2->attr.function)
{
gfc_error ("Procedure pointer target '%s' at %L must be either an "
gfc_error ("Procedure pointer target %qs at %L must be either an "
"intrinsic, host or use associated, referenced or have "
"the EXTERNAL attribute", s2->name, &rvalue->where);
return false;
@ -4758,7 +4758,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
if (!pointer && sym->attr.flavor == FL_PARAMETER)
{
if (context)
gfc_error ("Named constant '%s' in variable definition context (%s)"
gfc_error ("Named constant %qs in variable definition context (%s)"
" at %L", sym->name, context, &e->where);
return false;
}
@ -4767,7 +4767,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
&& !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
{
if (context)
gfc_error ("'%s' in variable definition context (%s) at %L is not"
gfc_error ("%qs in variable definition context (%s) at %L is not"
" a variable", sym->name, context, &e->where);
return false;
}
@ -4820,7 +4820,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
if (pointer && is_pointer)
{
if (context)
gfc_error ("Dummy argument '%s' with INTENT(IN) in pointer"
gfc_error ("Dummy argument %qs with INTENT(IN) in pointer"
" association context (%s) at %L",
sym->name, context, &e->where);
return false;
@ -4828,7 +4828,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
if (!pointer && !is_pointer && !sym->attr.pointer)
{
if (context)
gfc_error ("Dummy argument '%s' with INTENT(IN) in variable"
gfc_error ("Dummy argument %qs with INTENT(IN) in variable"
" definition context (%s) at %L",
sym->name, context, &e->where);
return false;
@ -4841,7 +4841,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
if (pointer && is_pointer)
{
if (context)
gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
gfc_error ("Variable %qs is PROTECTED and can not appear in a"
" pointer association context (%s) at %L",
sym->name, context, &e->where);
return false;
@ -4849,7 +4849,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
if (!pointer && !is_pointer)
{
if (context)
gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
gfc_error ("Variable %qs is PROTECTED and can not appear in a"
" variable definition context (%s) at %L",
sym->name, context, &e->where);
return false;
@ -4861,7 +4861,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
if (!pointer && !own_scope && gfc_pure (NULL) && gfc_impure_variable (sym))
{
if (context)
gfc_error ("Variable '%s' can not appear in a variable definition"
gfc_error ("Variable %qs can not appear in a variable definition"
" context (%s) at %L in PURE procedure",
sym->name, context, &e->where);
return false;
@ -4920,11 +4920,11 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
if (context)
{
if (assoc->target->expr_type == EXPR_VARIABLE)
gfc_error ("'%s' at %L associated to vector-indexed target can"
gfc_error ("%qs at %L associated to vector-indexed target can"
" not be used in a variable definition context (%s)",
name, &e->where, context);
else
gfc_error ("'%s' at %L associated to expression can"
gfc_error ("%qs at %L associated to expression can"
" not be used in a variable definition context (%s)",
name, &e->where, context);
}
@ -4935,7 +4935,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
if (!gfc_check_vardef_context (assoc->target, pointer, false, false, NULL))
{
if (context)
gfc_error ("Associate-name '%s' can not appear in a variable"
gfc_error_1 ("Associate-name '%s' can not appear in a variable"
" definition context (%s) at %L because its target"
" at %L can not, either",
name, context, &e->where,

8
gcc/fortran/gfortran.h
View File

@ -2682,6 +2682,7 @@ bool gfc_warning_now (int opt, const char *, ...) ATTRIBUTE_GCC_GFC(2,3);
void gfc_clear_warning (void);
void gfc_warning_check (void);
void gfc_error_1 (const char *, ...) ATTRIBUTE_GCC_GFC(1,2);
void gfc_error (const char *, ...) ATTRIBUTE_GCC_GFC(1,2);
void gfc_error_now_1 (const char *, ...) ATTRIBUTE_GCC_GFC(1,2);
void gfc_error_now (const char *, ...) ATTRIBUTE_GCC_GFC(1,2);
@ -2698,9 +2699,10 @@ bool gfc_notify_std (int, const char *, ...) ATTRIBUTE_GCC_GFC(2,3);
#define gfc_syntax_error(ST) \
gfc_error ("Syntax error in %s statement at %C", gfc_ascii_statement (ST));
void gfc_push_error (gfc_error_buf *);
void gfc_pop_error (gfc_error_buf *);
void gfc_free_error (gfc_error_buf *);
#include "pretty-print.h" /* For output_buffer. */
void gfc_push_error (output_buffer *, gfc_error_buf *);
void gfc_pop_error (output_buffer *, gfc_error_buf *);
void gfc_free_error (output_buffer *, gfc_error_buf *);
void gfc_get_errors (int *, int *);
void gfc_errors_to_warnings (bool);

164
gcc/fortran/interface.c
View File

@ -219,7 +219,7 @@ gfc_match_interface (void)
if (sym->attr.dummy)
{
gfc_error ("Dummy procedure '%s' at %C cannot have a "
gfc_error ("Dummy procedure %qs at %C cannot have a "
"generic interface", sym->name);
return MATCH_ERROR;
}
@ -1561,10 +1561,10 @@ check_interface0 (gfc_interface *p, const char *interface_name)
&& p->sym->attr.flavor != FL_DERIVED)
{
if (p->sym->attr.external)
gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
gfc_error ("Procedure %qs in %s at %L has no explicit interface",
p->sym->name, interface_name, &p->sym->declared_at);
else
gfc_error ("Procedure '%s' in %s at %L is neither function nor "
gfc_error ("Procedure %qs in %s at %L is neither function nor "
"subroutine", p->sym->name, interface_name,
&p->sym->declared_at);
return 1;
@ -1645,7 +1645,7 @@ check_interface1 (gfc_interface *p, gfc_interface *q0,
generic_flag, 0, NULL, 0, NULL, NULL))
{
if (referenced)
gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
gfc_error ("Ambiguous interfaces %qs and %qs in %s at %L",
p->sym->name, q->sym->name, interface_name,
&p->where);
else if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)
@ -1687,7 +1687,7 @@ check_sym_interfaces (gfc_symbol *sym)
&& (p->sym->attr.if_source != IFSRC_DECL
|| p->sym->attr.procedure))
{
gfc_error ("'%s' at %L is not a module procedure",
gfc_error ("%qs at %L is not a module procedure",
p->sym->name, &p->where);
return;
}
@ -1892,21 +1892,21 @@ argument_rank_mismatch (const char *name, locus *where,
if (rank2 == -1)
{
gfc_error ("The assumed-rank array at %L requires that the dummy argument"
" '%s' has assumed-rank", where, name);
" %qs has assumed-rank", where, name);
}
else if (rank1 == 0)
{
gfc_error ("Rank mismatch in argument '%s' at %L "
gfc_error ("Rank mismatch in argument %qs at %L "
"(scalar and rank-%d)", name, where, rank2);
}
else if (rank2 == 0)
{
gfc_error ("Rank mismatch in argument '%s' at %L "
gfc_error ("Rank mismatch in argument %qs at %L "
"(rank-%d and scalar)", name, where, rank1);
}
else
{
gfc_error ("Rank mismatch in argument '%s' at %L "
gfc_error ("Rank mismatch in argument %qs at %L "
"(rank-%d and rank-%d)", name, where, rank1, rank2);
}
}
@ -1956,7 +1956,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
sizeof(err), NULL, NULL))
{
if (where)
gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s",
gfc_error ("Interface mismatch in dummy procedure %qs at %L: %s",
formal->name, &actual->where, err);
return 0;
}
@ -1981,7 +1981,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
&& !gfc_is_simply_contiguous (actual, true))
{
if (where)
gfc_error ("Actual argument to contiguous pointer dummy '%s' at %L "
gfc_error ("Actual argument to contiguous pointer dummy %qs at %L "
"must be simply contiguous", formal->name, &actual->where);
return 0;
}
@ -1996,7 +1996,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
CLASS_DATA (actual)->ts.u.derived)))
{
if (where)
gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
gfc_error ("Type mismatch in argument %qs at %L; passed %s to %s",
formal->name, &actual->where, gfc_typename (&actual->ts),
gfc_typename (&formal->ts));
return 0;
@ -2006,7 +2006,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
{
if (where)
gfc_error ("Assumed-type actual argument at %L requires that dummy "
"argument '%s' is of assumed type", &actual->where,
"argument %qs is of assumed type", &actual->where,
formal->name);
return 0;
}
@ -2021,7 +2021,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
if (actual->ts.type != BT_CLASS)
{
if (where)
gfc_error ("Actual argument to '%s' at %L must be polymorphic",
gfc_error ("Actual argument to %qs at %L must be polymorphic",
formal->name, &actual->where);
return 0;
}
@ -2034,7 +2034,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
CLASS_DATA (formal)->ts.u.derived))
{
if (where)
gfc_error ("Actual argument to '%s' at %L must have the same "
gfc_error ("Actual argument to %qs at %L must have the same "
"declared type", formal->name, &actual->where);
return 0;
}
@ -2049,7 +2049,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
||CLASS_DATA (formal)->attr.class_pointer))
{
if (where)
gfc_error ("Actual argument to '%s' at %L must be unlimited "
gfc_error ("Actual argument to %qs at %L must be unlimited "
"polymorphic since the formal argument is a "
"pointer or allocatable unlimited polymorphic "
"entity [F2008: 12.5.2.5]", formal->name,
@ -2060,7 +2060,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
if (formal->attr.codimension && !gfc_is_coarray (actual))
{
if (where)
gfc_error ("Actual argument to '%s' at %L must be a coarray",
gfc_error ("Actual argument to %qs at %L must be a coarray",
formal->name, &actual->where);
return 0;
}
@ -2079,7 +2079,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
&& actual->symtree->n.sym->as->corank != formal->as->corank))
{
if (where)
gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)",
gfc_error ("Corank mismatch in argument %qs at %L (%d and %d)",
formal->name, &actual->where, formal->as->corank,
last ? last->u.c.component->as->corank
: actual->symtree->n.sym->as->corank);
@ -2096,7 +2096,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
&& !gfc_is_simply_contiguous (actual, true))
{
if (where)
gfc_error ("Actual argument to '%s' at %L must be simply "
gfc_error ("Actual argument to %qs at %L must be simply "
"contiguous", formal->name, &actual->where);
return 0;
}
@ -2110,7 +2110,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
{
if (where)
gfc_error ("Actual argument to non-INTENT(INOUT) dummy '%s' at %L, "
gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
"which is LOCK_TYPE or has a LOCK_TYPE component",
formal->name, &actual->where);
return 0;
@ -2128,7 +2128,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
|| formal->attr.contiguous))
{
if (where)
gfc_error ("Dummy argument '%s' has to be a pointer, assumed-shape or "
gfc_error ("Dummy argument %qs has to be a pointer, assumed-shape or "
"assumed-rank array without CONTIGUOUS attribute - as actual"
" argument at %L is not simply contiguous and both are "
"ASYNCHRONOUS or VOLATILE", formal->name, &actual->where);
@ -2142,7 +2142,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
{
if (where)
gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
"INTENT(OUT) dummy argument '%s'", &actual->where,
"INTENT(OUT) dummy argument %qs", &actual->where,
formal->name);
return 0;
}
@ -2211,7 +2211,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
if (actual->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL)
{
if (where)
gfc_error ("Polymorphic scalar passed to array dummy argument '%s' "
gfc_error ("Polymorphic scalar passed to array dummy argument %qs "
"at %L", formal->name, &actual->where);
return 0;
}
@ -2221,7 +2221,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
{
if (where)
gfc_error ("Element of assumed-shaped or pointer "
"array passed to array dummy argument '%s' at %L",
"array passed to array dummy argument %qs at %L",
formal->name, &actual->where);
return 0;
}
@ -2234,14 +2234,14 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
if (where)
gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
"CHARACTER actual argument with array dummy argument "
"'%s' at %L", formal->name, &actual->where);
"%qs at %L", formal->name, &actual->where);
return 0;
}
if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
{
gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
"array dummy argument '%s' at %L",
"array dummy argument %qs at %L",
formal->name, &actual->where);
return 0;
}
@ -2555,7 +2555,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
if (f == NULL)
{
if (where)
gfc_error ("Keyword argument '%s' at %L is not in "
gfc_error ("Keyword argument %qs at %L is not in "
"the procedure", a->name, &a->expr->where);
return 0;
}
@ -2563,7 +2563,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
if (new_arg[i] != NULL)
{
if (where)
gfc_error ("Keyword argument '%s' at %L is already associated "
gfc_error ("Keyword argument %qs at %L is already associated "
"with another actual argument", a->name,
&a->expr->where);
return 0;
@ -2620,11 +2620,11 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
|| (f->sym->ts.type != BT_CLASS && f->sym->attr.allocatable)
|| (f->sym->ts.type == BT_CLASS
&& CLASS_DATA (f->sym)->attr.allocatable)))
gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'",
gfc_error ("Unexpected NULL() intrinsic at %L to dummy %qs",
where, f->sym->name);
else if (where)
gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
"dummy '%s'", where, f->sym->name);
"dummy %qs", where, f->sym->name);
return 0;
}
@ -2690,7 +2690,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
{
if (where)
gfc_error ("Actual argument at %L to allocatable or "
"pointer dummy argument '%s' must have a deferred "
"pointer dummy argument %qs must have a deferred "
"length type parameter if and only if the dummy has one",
&a->expr->where, f->sym->name);
return 0;
@ -2730,7 +2730,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
|| gfc_is_proc_ptr_comp (a->expr)))
{
if (where)
gfc_error ("Expected a procedure pointer for argument '%s' at %L",
gfc_error ("Expected a procedure pointer for argument %qs at %L",
f->sym->name, &a->expr->where);
return 0;
}
@ -2741,7 +2741,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
&& gfc_expr_attr (a->expr).flavor != FL_PROCEDURE)
{
if (where)
gfc_error ("Expected a procedure for argument '%s' at %L",
gfc_error ("Expected a procedure for argument %qs at %L",
f->sym->name, &a->expr->where);
return 0;
}
@ -2755,7 +2755,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
&& a->expr->ref->u.ar.type == AR_FULL)))
{
if (where)
gfc_error ("Actual argument for '%s' cannot be an assumed-size"
gfc_error ("Actual argument for %qs cannot be an assumed-size"
" array at %L", f->sym->name, where);
return 0;
}
@ -2764,7 +2764,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
&& compare_pointer (f->sym, a->expr) == 0)
{
if (where)
gfc_error ("Actual argument for '%s' must be a pointer at %L",
gfc_error ("Actual argument for %qs must be a pointer at %L",
f->sym->name, &a->expr->where);
return 0;
}
@ -2775,7 +2775,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
{
if (where)
gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
"pointer dummy '%s'", &a->expr->where,f->sym->name);
"pointer dummy %qs", &a->expr->where,f->sym->name);
return 0;
}
@ -2785,7 +2785,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
{
if (where)
gfc_error ("Coindexed actual argument at %L to pointer "
"dummy '%s'",
"dummy %qs",
&a->expr->where, f->sym->name);
return 0;
}
@ -2798,7 +2798,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
{
if (where)
gfc_error ("Coindexed actual argument at %L to allocatable "
"dummy '%s' requires INTENT(IN)",
"dummy %qs requires INTENT(IN)",
&a->expr->where, f->sym->name);
return 0;
}
@ -2812,7 +2812,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
{
if (where)
gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
"%L requires that dummy '%s' has neither "
"%L requires that dummy %qs has neither "
"ASYNCHRONOUS nor VOLATILE", &a->expr->where,
f->sym->name);
return 0;
@ -2826,7 +2826,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
{
if (where)
gfc_error ("Coindexed actual argument at %L with allocatable "
"ultimate component to dummy '%s' requires either VALUE "
"ultimate component to dummy %qs requires either VALUE "
"or INTENT(IN)", &a->expr->where, f->sym->name);
return 0;
}
@ -2837,7 +2837,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
&& !full_array)
{
if (where)
gfc_error ("Actual CLASS array argument for '%s' must be a full "
gfc_error ("Actual CLASS array argument for %qs must be a full "
"array at %L", f->sym->name, &a->expr->where);
return 0;
}
@ -2847,7 +2847,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
&& compare_allocatable (f->sym, a->expr) == 0)
{
if (where)
gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
gfc_error ("Actual argument for %qs must be ALLOCATABLE at %L",
f->sym->name, &a->expr->where);
return 0;
}
@ -2879,7 +2879,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
gfc_error ("Array-section actual argument with vector "
"subscripts at %L is incompatible with INTENT(OUT), "
"INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
"of the dummy argument '%s'",
"of the dummy argument %qs",
&a->expr->where, f->sym->name);
return 0;
}
@ -2896,7 +2896,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
if (where)
gfc_error ("Assumed-shape actual argument at %L is "
"incompatible with the non-assumed-shape "
"dummy argument '%s' due to VOLATILE attribute",
"dummy argument %qs due to VOLATILE attribute",
&a->expr->where,f->sym->name);
return 0;
}
@ -2908,7 +2908,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
if (where)
gfc_error ("Array-section actual argument at %L is "
"incompatible with the non-assumed-shape "
"dummy argument '%s' due to VOLATILE attribute",
"dummy argument %qs due to VOLATILE attribute",
&a->expr->where,f->sym->name);
return 0;
}
@ -2927,7 +2927,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
if (where)
gfc_error ("Pointer-array actual argument at %L requires "
"an assumed-shape or pointer-array dummy "
"argument '%s' due to VOLATILE attribute",
"argument %qs due to VOLATILE attribute",
&a->expr->where,f->sym->name);
return 0;
}
@ -2955,7 +2955,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
if (!f->sym->attr.optional)
{
if (where)
gfc_error ("Missing actual argument for argument '%s' at %L",
gfc_error ("Missing actual argument for argument %qs at %L",
f->sym->name, where);
return 0;
}
@ -3226,7 +3226,7 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
&& gfc_is_coindexed (expr))
{
gfc_error ("Coindexed polymorphic actual argument at %L is passed "
"polymorphic dummy argument '%s'",
"polymorphic dummy argument %qs",
&expr->where, f->sym->name);
return false;
}
@ -3253,7 +3253,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
{
if (sym->ns->has_implicit_none_export && sym->attr.proc == PROC_UNKNOWN)
{
gfc_error ("Procedure '%s' called at %L is not explicitly declared",
gfc_error ("Procedure %qs called at %L is not explicitly declared",
sym->name, where);
return false;
}
@ -3273,24 +3273,24 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
if (sym->attr.pointer)
{
gfc_error("The pointer object '%s' at %L must have an explicit "
"function interface or be declared as array",
sym->name, where);
gfc_error ("The pointer object %qs at %L must have an explicit "
"function interface or be declared as array",
sym->name, where);
return false;
}
if (sym->attr.allocatable && !sym->attr.external)
{
gfc_error("The allocatable object '%s' at %L must have an explicit "
"function interface or be declared as array",
sym->name, where);
gfc_error ("The allocatable object %qs at %L must have an explicit "
"function interface or be declared as array",
sym->name, where);
return false;
}
if (sym->attr.allocatable)
{
gfc_error("Allocatable function '%s' at %L must have an explicit "
"function interface", sym->name, where);
gfc_error ("Allocatable function %qs at %L must have an explicit "
"function interface", sym->name, where);
return false;
}
@ -3299,8 +3299,8 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
/* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
if (a->name != NULL && a->name[0] != '%')
{
gfc_error("Keyword argument requires explicit interface "
"for procedure '%s' at %L", sym->name, &a->expr->where);
gfc_error ("Keyword argument requires explicit interface "
"for procedure %qs at %L", sym->name, &a->expr->where);
break;
}
@ -3321,9 +3321,9 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
&& a->expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
|| gfc_expr_attr (a->expr).lock_comp))
{
gfc_error("Actual argument of LOCK_TYPE or with LOCK_TYPE "
"component at %L requires an explicit interface for "
"procedure '%s'", &a->expr->where, sym->name);
gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE "
"component at %L requires an explicit interface for "
"procedure %qs", &a->expr->where, sym->name);
break;
}
@ -3387,9 +3387,9 @@ gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where)
/* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
if (a->name != NULL && a->name[0] != '%')
{
gfc_error("Keyword argument requires explicit interface "
"for procedure pointer component '%s' at %L",
comp->name, &a->expr->where);
gfc_error ("Keyword argument requires explicit interface "
"for procedure pointer component %qs at %L",
comp->name, &a->expr->where);
break;
}
}
@ -3913,7 +3913,7 @@ gfc_check_new_interface (gfc_interface *base, gfc_symbol *new_sym, locus loc)
{
if (ip->sym == new_sym)
{
gfc_error ("Entity '%s' at %L is already present in the interface",
gfc_error ("Entity %qs at %L is already present in the interface",
new_sym->name, &loc);
return false;
}
@ -4124,7 +4124,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
/* If the overwritten procedure is GENERIC, this is an error. */
if (old->n.tb->is_generic)
{
gfc_error ("Can't overwrite GENERIC '%s' at %L",
gfc_error ("Can't overwrite GENERIC %qs at %L",
old->name, &proc->n.tb->where);
return false;
}
@ -4136,7 +4136,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
/* Check that overridden binding is not NON_OVERRIDABLE. */
if (old->n.tb->non_overridable)
{
gfc_error ("'%s' at %L overrides a procedure binding declared"
gfc_error ("%qs at %L overrides a procedure binding declared"
" NON_OVERRIDABLE", proc->name, &where);
return false;
}
@ -4144,7 +4144,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
/* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
if (!old->n.tb->deferred && proc->n.tb->deferred)
{
gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
gfc_error ("%qs at %L must not be DEFERRED as it overrides a"
" non-DEFERRED binding", proc->name, &where);
return false;
}
@ -4152,7 +4152,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
/* If the overridden binding is PURE, the overriding must be, too. */
if (old_target->attr.pure && !proc_target->attr.pure)
{
gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
gfc_error ("%qs at %L overrides a PURE procedure and must also be PURE",
proc->name, &where);
return false;
}
@ -4161,13 +4161,13 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
is not, the overriding must not be either. */
if (old_target->attr.elemental && !proc_target->attr.elemental)
{
gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
gfc_error ("%qs at %L overrides an ELEMENTAL procedure and must also be"
" ELEMENTAL", proc->name, &where);
return false;
}
if (!old_target->attr.elemental && proc_target->attr.elemental)
{
gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
gfc_error ("%qs at %L overrides a non-ELEMENTAL procedure and must not"
" be ELEMENTAL, either", proc->name, &where);
return false;
}
@ -4176,7 +4176,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
SUBROUTINE. */
if (old_target->attr.subroutine && !proc_target->attr.subroutine)
{
gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
gfc_error ("%qs at %L overrides a SUBROUTINE and must also be a"
" SUBROUTINE", proc->name, &where);
return false;
}
@ -4187,7 +4187,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
{
if (!proc_target->attr.function)
{
gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
gfc_error ("%qs at %L overrides a FUNCTION and must also be a"
" FUNCTION", proc->name, &where);
return false;
}
@ -4196,7 +4196,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
sizeof(err)))
{
gfc_error ("Result mismatch for the overriding procedure "
"'%s' at %L: %s", proc->name, &where, err);
"%qs at %L: %s", proc->name, &where, err);
return false;
}
}
@ -4206,7 +4206,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
if (old->n.tb->access == ACCESS_PUBLIC
&& proc->n.tb->access == ACCESS_PRIVATE)
{
gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
gfc_error ("%qs at %L overrides a PUBLIC procedure and must not be"
" PRIVATE", proc->name, &where);
return false;
}
@ -4236,7 +4236,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
/* Check that the names correspond. */
if (strcmp (proc_formal->sym->name, old_formal->sym->name))
{
gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
gfc_error ("Dummy argument %qs of %qs at %L should be named %qs as"
" to match the corresponding argument of the overridden"
" procedure", proc_formal->sym->name, proc->name, &where,
old_formal->sym->name);
@ -4248,7 +4248,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
check_type, err, sizeof(err)))
{
gfc_error ("Argument mismatch for the overriding procedure "
"'%s' at %L: %s", proc->name, &where, err);
"%qs at %L: %s", proc->name, &where, err);
return false;
}
@ -4256,7 +4256,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
}
if (proc_formal || old_formal)
{
gfc_error ("'%s' at %L must have the same number of formal arguments as"
gfc_error ("%qs at %L must have the same number of formal arguments as"
" the overridden procedure", proc->name, &where);
return false;
}
@ -4265,7 +4265,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
NOPASS. */
if (old->n.tb->nopass && !proc->n.tb->nopass)
{
gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
gfc_error ("%qs at %L overrides a NOPASS binding and must also be"
" NOPASS", proc->name, &where);
return false;
}
@ -4276,14 +4276,14 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
{
if (proc->n.tb->nopass)
{
gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
gfc_error ("%qs at %L overrides a binding with PASS and must also be"
" PASS", proc->name, &where);
return false;
}
if (proc_pass_arg != old_pass_arg)
{
gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
gfc_error ("Passed-object dummy argument of %qs at %L must be at"
" the same position as the passed-object dummy argument of"
" the overridden procedure", proc->name, &where);
return false;

14
gcc/fortran/intrinsic.c
View File

@ -3815,7 +3815,7 @@ sort_actual (const char *name, gfc_actual_arglist **ap,
if (a == NULL)
goto do_sort;
gfc_error ("Too many arguments in call to '%s' at %L", name, where);
gfc_error ("Too many arguments in call to %qs at %L", name, where);
return false;
keywords:
@ -3833,14 +3833,14 @@ keywords:
gfc_error ("The argument list functions %%VAL, %%LOC or %%REF "
"are not allowed in this context at %L", where);
else
gfc_error ("Can't find keyword named '%s' in call to '%s' at %L",
gfc_error ("Can't find keyword named %qs in call to %qs at %L",
a->name, name, where);
return false;
}
if (f->actual != NULL)
{
gfc_error ("Argument '%s' appears twice in call to '%s' at %L",
gfc_error ("Argument %qs appears twice in call to %qs at %L",
f->name, name, where);
return false;
}
@ -3854,7 +3854,7 @@ optional:
{
if (f->actual == NULL && f->optional == 0)
{
gfc_error ("Missing actual argument '%s' in call to '%s' at %L",
gfc_error ("Missing actual argument %qs in call to %qs at %L",
f->name, name, where);
return false;
}
@ -3926,7 +3926,7 @@ check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym,
if (!gfc_compare_types (&ts, &actual->expr->ts))
{
if (error_flag)
gfc_error ("Type of argument '%s' in call to '%s' at %L should "
gfc_error ("Type of argument %qs in call to %qs at %L should "
"be %s, not %s", gfc_current_intrinsic_arg[i]->name,
gfc_current_intrinsic, &actual->expr->where,
gfc_typename (&formal->ts),
@ -4534,14 +4534,14 @@ gfc_intrinsic_sub_interface (gfc_code *c, int error_flag)
if (gfc_do_concurrent_flag && !isym->pure)
{
gfc_error ("Subroutine call to intrinsic '%s' in DO CONCURRENT "
gfc_error ("Subroutine call to intrinsic %qs in DO CONCURRENT "
"block at %L is not PURE", name, &c->loc);
return MATCH_ERROR;
}
if (!isym->pure && gfc_pure (NULL))
{
gfc_error ("Subroutine call to intrinsic '%s' at %L is not PURE", name,
gfc_error ("Subroutine call to intrinsic %qs at %L is not PURE", name,
&c->loc);
return MATCH_ERROR;
}

19
gcc/fortran/match.c
View File

@ -3548,7 +3548,7 @@ alloc_opt_list:
/* The next 2 conditionals check C631. */
if (ts.type != BT_UNKNOWN)
{
gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
gfc_error_1 ("SOURCE tag at %L conflicts with the typespec at %L",
&tmp->where, &old_locus);
goto cleanup;
}
@ -3585,7 +3585,7 @@ alloc_opt_list:
/* Check F08:C637. */
if (ts.type != BT_UNKNOWN)
{
gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
gfc_error_1 ("MOLD tag at %L conflicts with the typespec at %L",
&tmp->where, &old_locus);
goto cleanup;
}
@ -3611,7 +3611,7 @@ alloc_opt_list:
/* Check F08:C637. */
if (source && mold)
{
gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
gfc_error_1 ("MOLD tag at %L conflicts with SOURCE tag at %L",
&mold->where, &source->where);
goto cleanup;
}
@ -4315,7 +4315,7 @@ gfc_match_common (void)
if (sym->attr.in_common)
{
gfc_error ("Symbol '%s' at %C is already in a COMMON block",
gfc_error ("Symbol %qs at %C is already in a COMMON block",
sym->name);
goto cleanup;
}
@ -4838,7 +4838,9 @@ recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
match
gfc_match_st_function (void)
{
gfc_error_buf old_error;
gfc_error_buf old_error_1;
output_buffer old_error;
gfc_symbol *sym;
gfc_expr *expr;
match m;
@ -4847,7 +4849,7 @@ gfc_match_st_function (void)
if (m != MATCH_YES)
return m;
gfc_push_error (&old_error);
gfc_push_error (&old_error, &old_error_1);
if (!gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, sym->name, NULL))
goto undo_error;
@ -4859,7 +4861,8 @@ gfc_match_st_function (void)
if (m == MATCH_NO)
goto undo_error;
gfc_free_error (&old_error);
gfc_free_error (&old_error, &old_error_1);
if (m == MATCH_ERROR)
return m;
@ -4877,7 +4880,7 @@ gfc_match_st_function (void)
return MATCH_YES;
undo_error:
gfc_pop_error (&old_error);
gfc_pop_error (&old_error, &old_error_1);
return MATCH_NO;
}

32
gcc/fortran/openmp.c
View File

@ -2326,31 +2326,31 @@ resolve_omp_clauses (gfc_code *code, locus *where,
{
bool bad = false;
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);
if (n->sym->attr.associate_var)
gfc_error ("ASSOCIATE name '%s' in %s clause at %L",
gfc_error ("ASSOCIATE name %qs in %s clause at %L",
n->sym->name, name, where);
if (list != OMP_LIST_PRIVATE)
{
if (n->sym->attr.proc_pointer && list == OMP_LIST_REDUCTION)
gfc_error ("Procedure pointer '%s' in %s clause at %L",
gfc_error ("Procedure pointer %qs in %s clause at %L",
n->sym->name, name, where);
if (n->sym->attr.pointer && list == OMP_LIST_REDUCTION)
gfc_error ("POINTER object '%s' in %s clause at %L",
gfc_error ("POINTER object %qs in %s clause at %L",
n->sym->name, name, where);
if (n->sym->attr.cray_pointer && list == OMP_LIST_REDUCTION)
gfc_error ("Cray pointer '%s' in %s clause at %L",
gfc_error ("Cray pointer %qs in %s clause at %L",
n->sym->name, name, where);
}
if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
gfc_error ("Assumed size array '%s' in %s clause at %L",
gfc_error ("Assumed size array %qs in %s clause at %L",
n->sym->name, name, where);
if (n->sym->attr.in_namelist && list != OMP_LIST_REDUCTION)
gfc_error ("Variable '%s' in %s clause is used in "
gfc_error ("Variable %qs in %s clause is used in "
"NAMELIST statement at %L",
n->sym->name, name, where);
if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
@ -2360,7 +2360,7 @@ resolve_omp_clauses (gfc_code *code, locus *where,
case OMP_LIST_LASTPRIVATE:
case OMP_LIST_LINEAR:
/* case OMP_LIST_REDUCTION: */
gfc_error ("INTENT(IN) POINTER '%s' in %s clause at %L",
gfc_error ("INTENT(IN) POINTER %qs in %s clause at %L",
n->sym->name, name, where);
break;
default:
@ -2475,10 +2475,10 @@ resolve_omp_clauses (gfc_code *code, locus *where,
break;
case OMP_LIST_LINEAR:
if (n->sym->ts.type != BT_INTEGER)
gfc_error ("LINEAR variable '%s' must be INTEGER "
gfc_error ("LINEAR variable %qs must be INTEGER "
"at %L", n->sym->name, where);
else if (!code && !n->sym->attr.value)
gfc_error ("LINEAR dummy argument '%s' must have VALUE "
gfc_error ("LINEAR dummy argument %qs must have VALUE "
"attribute at %L", n->sym->name, where);
else if (n->expr)
{
@ -2486,11 +2486,11 @@ resolve_omp_clauses (gfc_code *code, locus *where,
if (!gfc_resolve_expr (expr)
|| expr->ts.type != BT_INTEGER
|| expr->rank != 0)
gfc_error ("'%s' in LINEAR clause at %L requires "
gfc_error ("%qs in LINEAR clause at %L requires "
"a scalar integer linear-step expression",
n->sym->name, where);
else if (!code && expr->expr_type != EXPR_CONSTANT)
gfc_error ("'%s' in LINEAR clause at %L requires "
gfc_error ("%qs in LINEAR clause at %L requires "
"a constant integer linear-step expression",
n->sym->name, where);
}
@ -2931,7 +2931,7 @@ resolve_omp_atomic (gfc_code *code)
else if (expr_references_sym (arg->expr, var, NULL))
{
gfc_error ("!$OMP ATOMIC intrinsic arguments except one must "
"not reference '%s' at %L",
"not reference %qs at %L",
var->name, &arg->expr->where);
return;
}
@ -2946,7 +2946,7 @@ resolve_omp_atomic (gfc_code *code)
if (var_arg == NULL)
{
gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
"be '%s' at %L", var->name, &expr2->where);
"be %qs at %L", var->name, &expr2->where);
return;
}
@ -3414,7 +3414,7 @@ gfc_resolve_omp_declare_simd (gfc_namespace *ns)
{
if (ods->proc_name != ns->proc_name)
gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure "
"'%s' at %L", ns->proc_name->name, &ods->where);
"%qs at %L", ns->proc_name->name, &ods->where);
if (ods->clauses)
resolve_omp_clauses (NULL, &ods->where, ods->clauses, ns);
}

17
gcc/fortran/parse.c
View File

@ -107,13 +107,14 @@ match_word_omp_simd (const char *str, match (*subr) (void), locus *old_locus,
static void
use_modules (void)
{
gfc_error_buf old_error;
gfc_error_buf old_error_1;
output_buffer old_error;
gfc_push_error (&old_error);
gfc_push_error (&old_error, &old_error_1);
gfc_buffer_error (false);
gfc_use_modules ();
gfc_buffer_error (true);
gfc_pop_error (&old_error);
gfc_pop_error (&old_error, &old_error_1);
gfc_commit_symbols ();
gfc_warning_check ();
gfc_current_ns->old_cl_list = gfc_current_ns->cl_list;
@ -2202,7 +2203,7 @@ verify_st_order (st_state *p, gfc_statement st, bool silent)
order:
if (!silent)
gfc_error ("%s statement at %C cannot follow %s statement at %L",
gfc_error_1 ("%s statement at %C cannot follow %s statement at %L",
gfc_ascii_statement (st),
gfc_ascii_statement (p->last_statement), &p->where);
@ -2579,7 +2580,7 @@ endType:
"subcomponent exists)", c->name, &c->loc, sym->name);
if (sym->attr.lock_comp && coarray && !lock_type)
gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
gfc_error_1 ("Noncoarray component %s at %L of type LOCK_TYPE or with "
"subcomponent of type LOCK_TYPE must have a codimension or "
"be a subcomponent of a coarray. (Variables of type %s may "
"not have a codimension as %s at %L has a codimension or a "
@ -3281,7 +3282,7 @@ parse_if_block (void)
case ST_ELSEIF:
if (seen_else)
{
gfc_error ("ELSE IF statement at %C cannot follow ELSE "
gfc_error_1 ("ELSE IF statement at %C cannot follow ELSE "
"statement at %L", &else_locus);
reject_statement ();
@ -4674,10 +4675,10 @@ gfc_global_used (gfc_gsymbol *sym, locus *where)
}
if (sym->binding_label)
gfc_error ("Global binding name '%s' at %L is already being used as a %s "
gfc_error_1 ("Global binding name '%s' at %L is already being used as a %s "
"at %L", sym->binding_label, where, name, &sym->where);
else
gfc_error ("Global name '%s' at %L is already being used as a %s at %L",
gfc_error_1 ("Global name '%s' at %L is already being used as a %s at %L",
sym->name, where, name, &sym->where);
}

15
gcc/fortran/primary.c
View File

@ -1274,7 +1274,8 @@ static match
match_complex_constant (gfc_expr **result)
{
gfc_expr *e, *real, *imag;
gfc_error_buf old_error;
gfc_error_buf old_error_1;
output_buffer old_error;
gfc_typespec target;
locus old_loc;
int kind;
@ -1287,18 +1288,18 @@ match_complex_constant (gfc_expr **result)
if (m != MATCH_YES)
return m;
gfc_push_error (&old_error);
gfc_push_error (&old_error, &old_error_1);
m = match_complex_part (&real);
if (m == MATCH_NO)
{
gfc_free_error (&old_error);
gfc_free_error (&old_error, &old_error_1);
goto cleanup;
}
if (gfc_match_char (',') == MATCH_NO)
{
gfc_pop_error (&old_error);
gfc_pop_error (&old_error, &old_error_1);
m = MATCH_NO;
goto cleanup;
}
@ -1310,10 +1311,10 @@ match_complex_constant (gfc_expr **result)
if (m == MATCH_ERROR)
{
gfc_free_error (&old_error);
gfc_free_error (&old_error, &old_error_1);
goto cleanup;
}
gfc_pop_error (&old_error);
gfc_pop_error (&old_error, &old_error_1);
m = match_complex_part (&imag);
if (m == MATCH_NO)
@ -2493,7 +2494,7 @@ gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **c
gcc_assert (comp_iter);
if (!strcmp (comp_iter->name, comp_tail->name))
{
gfc_error ("Component '%s' is initialized twice in the structure"
gfc_error ("Component %qs is initialized twice in the structure"
" constructor at %L!", comp_tail->name,
comp_tail->val ? &comp_tail->where
: &gfc_current_locus);

220
gcc/fortran/resolve.c
View File

@ -469,7 +469,7 @@ resolve_formal_arglist (gfc_symbol *proc)
|| (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
&& CLASS_DATA (sym)->attr.class_pointer))
{
gfc_error ("Argument '%s' of elemental procedure at %L cannot "
gfc_error ("Argument %qs of elemental procedure at %L cannot "
"have the POINTER attribute", sym->name,
&sym->declared_at);
continue;
@ -477,8 +477,8 @@ resolve_formal_arglist (gfc_symbol *proc)
if (sym->attr.flavor == FL_PROCEDURE)
{
gfc_error ("Dummy procedure '%s' not allowed in elemental "
"procedure '%s' at %L", sym->name, proc->name,
gfc_error ("Dummy procedure %qs not allowed in elemental "
"procedure %qs at %L", sym->name, proc->name,
&sym->declared_at);
continue;
}
@ -486,7 +486,7 @@ resolve_formal_arglist (gfc_symbol *proc)
/* Fortran 2008 Corrigendum 1, C1290a. */
if (sym->attr.intent == INTENT_UNKNOWN && !sym->attr.value)
{
gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
gfc_error ("Argument %qs of elemental procedure %qs at %L must "
"have its INTENT specified or have the VALUE "
"attribute", sym->name, proc->name,
&sym->declared_at);
@ -499,7 +499,7 @@ resolve_formal_arglist (gfc_symbol *proc)
{
if (sym->as != NULL)
{
gfc_error ("Argument '%s' of statement function at %L must "
gfc_error ("Argument %qs of statement function at %L must "
"be scalar", sym->name, &sym->declared_at);
continue;
}
@ -509,7 +509,7 @@ resolve_formal_arglist (gfc_symbol *proc)
gfc_charlen *cl = sym->ts.u.cl;
if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
{
gfc_error ("Character-valued argument '%s' of statement "
gfc_error ("Character-valued argument %qs of statement "
"function at %L must have constant length",
sym->name, &sym->declared_at);
continue;
@ -567,10 +567,10 @@ resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
if (!t && !sym->result->attr.untyped)
{
if (sym->result == sym)
gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
gfc_error ("Contained function %qs at %L has no IMPLICIT type",
sym->name, &sym->declared_at);
else if (!sym->result->attr.proc_pointer)
gfc_error ("Result '%s' of contained function '%s' at %L has "
gfc_error ("Result %qs of contained function %qs at %L has "
"no IMPLICIT type", sym->result->name, sym->name,
&sym->result->declared_at);
sym->result->attr.untyped = 1;
@ -594,7 +594,7 @@ resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
gcc_assert (ns->parent && ns->parent->proc_name);
module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
gfc_error ("Character-valued %s '%s' at %L must not be"
gfc_error ("Character-valued %s %qs at %L must not be"
" assumed length",
module_proc ? _("module procedure")
: _("internal function"),
@ -984,7 +984,7 @@ resolve_common_blocks (gfc_symtree *common_root)
|| (!common_root->n.common->binding_label
&& gsym->binding_label)))
{
gfc_error ("In Fortran 2003 COMMON '%s' block at %L is a global "
gfc_error_1 ("In Fortran 2003 COMMON '%s' block at %L is a global "
"identifier and must thus have the same binding name "
"as the same-named COMMON block at %L: %s vs %s",
common_root->n.common->name, &common_root->n.common->where,
@ -998,7 +998,7 @@ resolve_common_blocks (gfc_symtree *common_root)
if (gsym && gsym->type != GSYM_COMMON
&& !common_root->n.common->binding_label)
{
gfc_error ("COMMON block '%s' at %L uses the same global identifier "
gfc_error_1 ("COMMON block '%s' at %L uses the same global identifier "
"as entity at %L",
common_root->n.common->name, &common_root->n.common->where,
&gsym->where);
@ -1006,7 +1006,7 @@ resolve_common_blocks (gfc_symtree *common_root)
}
if (gsym && gsym->type != GSYM_COMMON)
{
gfc_error ("Fortran 2008: COMMON block '%s' with binding label at "
gfc_error_1 ("Fortran 2008: COMMON block '%s' with binding label at "
"%L sharing the identifier with global non-COMMON-block "
"entity at %L", common_root->n.common->name,
&common_root->n.common->where, &gsym->where);
@ -1028,7 +1028,7 @@ resolve_common_blocks (gfc_symtree *common_root)
common_root->n.common->binding_label);
if (gsym && gsym->type != GSYM_COMMON)
{
gfc_error ("COMMON block at %L with binding label %s uses the same "
gfc_error_1 ("COMMON block at %L with binding label %s uses the same "
"global identifier as entity at %L",
&common_root->n.common->where,
common_root->n.common->binding_label, &gsym->where);
@ -1049,15 +1049,15 @@ resolve_common_blocks (gfc_symtree *common_root)
return;
if (sym->attr.flavor == FL_PARAMETER)
gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
gfc_error_1 ("COMMON block '%s' at %L is used as PARAMETER at %L",
sym->name, &common_root->n.common->where, &sym->declared_at);
if (sym->attr.external)
gfc_error ("COMMON block '%s' at %L can not have the EXTERNAL attribute",
gfc_error ("COMMON block %qs at %L can not have the EXTERNAL attribute",
sym->name, &common_root->n.common->where);
if (sym->attr.intrinsic)
gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
gfc_error ("COMMON block %qs at %L is also an intrinsic procedure",
sym->name, &common_root->n.common->where);
else if (sym->attr.result
|| gfc_is_function_return_value (sym, gfc_current_ns))
@ -1171,7 +1171,7 @@ resolve_structure_cons (gfc_expr *expr, int init)
else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
{
gfc_error ("The element in the structure constructor at %L, "
"for pointer component '%s', is %s but should be %s",
"for pointer component %qs, is %s but should be %s",
&cons->expr->where, comp->name,
gfc_basic_typename (cons->expr->ts.type),
gfc_basic_typename (comp->ts.type));
@ -1256,7 +1256,7 @@ resolve_structure_cons (gfc_expr *expr, int init)
{
t = false;
gfc_error ("The NULL in the structure constructor at %L is "
"being applied to component '%s', which is neither "
"being applied to component %qs, which is neither "
"a POINTER nor ALLOCATABLE", &cons->expr->where,
comp->name);
}
@ -1290,7 +1290,7 @@ resolve_structure_cons (gfc_expr *expr, int init)
err, sizeof (err), NULL, NULL))
{
gfc_error ("Interface mismatch for procedure-pointer component "
"'%s' in structure constructor at %L: %s",
"%qs in structure constructor at %L: %s",
comp->name, &cons->expr->where, err);
return false;
}
@ -1306,7 +1306,7 @@ resolve_structure_cons (gfc_expr *expr, int init)
{
t = false;
gfc_error ("The element in the structure constructor at %L, "
"for pointer component '%s' should be a POINTER or "
"for pointer component %qs should be a POINTER or "
"a TARGET", &cons->expr->where, comp->name);
}
@ -1335,7 +1335,7 @@ resolve_structure_cons (gfc_expr *expr, int init)
{
t = false;
gfc_error ("Invalid expression in the structure constructor for "
"pointer component '%s' at %L in PURE procedure",
"pointer component %qs at %L in PURE procedure",
comp->name, &cons->expr->where);
}
@ -1461,7 +1461,7 @@ check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
{
gfc_error ("The upper bound in the last dimension must "
"appear in the reference to the assumed size "
"array '%s' at %L", sym->name, &e->where);
"array %qs at %L", sym->name, &e->where);
return true;
}
return false;
@ -1521,11 +1521,11 @@ count_specific_procs (gfc_expr *e)
}
if (n > 1)
gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
gfc_error ("%qs at %L is ambiguous", e->symtree->n.sym->name,
&e->where);
if (n == 0)
gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
gfc_error ("GENERIC procedure %qs is not allowed as an actual "
"argument at %L", sym->name, &e->where);
return n;
@ -1659,7 +1659,7 @@ gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc)
{
if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
{
gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
" specifier", sym->name, &sym->declared_at);
return false;
}
@ -1670,7 +1670,7 @@ gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc)
}
else
{
gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym->name,
gfc_error ("%qs declared INTRINSIC at %L does not exist", sym->name,
&sym->declared_at);
return false;
}
@ -1683,7 +1683,7 @@ gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc)
/* Check it is actually available in the standard settings. */
if (!gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at))
{
gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not"
" available in the current standard settings but %s. Use"
" an appropriate -std=* option or enable -fall-intrinsics"
" in order to use it.",
@ -1800,7 +1800,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
if (sym->attr.proc == PROC_ST_FUNCTION)
{
gfc_error ("Statement function '%s' at %L is not allowed as an "
gfc_error ("Statement function %qs at %L is not allowed as an "
"actual argument", sym->name, &e->where);
}
@ -1808,7 +1808,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
sym->attr.subroutine);
if (sym->attr.intrinsic && actual_ok == 0)
{
gfc_error ("Intrinsic '%s' at %L is not allowed as an "
gfc_error ("Intrinsic %qs at %L is not allowed as an "
"actual argument", sym->name, &e->where);
}
@ -1823,7 +1823,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
if (sym->attr.elemental && !sym->attr.intrinsic)
{
gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
"allowed as an actual argument at %L", sym->name,
&e->where);
}
@ -1851,7 +1851,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
if (isym == NULL || !isym->specific)
{
gfc_error ("Unable to find a specific INTRINSIC procedure "
"for the reference '%s' at %L", sym->name,
"for the reference %qs at %L", sym->name,
&e->where);
goto cleanup;
}
@ -1872,7 +1872,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
{
gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
gfc_error ("Symbol %qs at %L is ambiguous", sym->name, &e->where);
goto cleanup;
}
@ -2139,8 +2139,8 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
|| eformal->sym->attr.intent == INTENT_INOUT)
&& arg->expr && arg->expr->rank == 0)
{
gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
"ELEMENTAL subroutine '%s' is a scalar, but another "
gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
"ELEMENTAL subroutine %qs is a scalar, but another "
"actual argument is an array", &arg->expr->where,
(eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
: "INOUT", eformal->sym->name, esym->name);
@ -2416,7 +2416,7 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
if (sym->attr.function && !gfc_compare_types (&sym->ts, &def_sym->ts))
{
gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
sym->name, &sym->declared_at, gfc_typename (&sym->ts),
gfc_typename (&def_sym->ts));
goto done;
@ -2425,7 +2425,7 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
if (sym->attr.if_source == IFSRC_UNKNOWN
&& gfc_explicit_interface_required (def_sym, reason, sizeof(reason)))
{
gfc_error ("Explicit interface required for '%s' at %L: %s",
gfc_error ("Explicit interface required for %qs at %L: %s",
sym->name, &sym->declared_at, reason);
goto done;
}
@ -2437,7 +2437,7 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
if (!gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1,
reason, sizeof(reason), NULL, NULL))
{
gfc_error ("Interface mismatch in global procedure '%s' at %L: %s ",
gfc_error ("Interface mismatch in global procedure %qs at %L: %s ",
sym->name, &sym->declared_at, reason);
goto done;
}
@ -2545,7 +2545,7 @@ generic:
that possesses a matching interface. 14.1.2.4 */
if (sym && !intr && !gfc_is_intrinsic (sym, 0, expr->where))
{
gfc_error ("There is no specific function for the generic '%s' "
gfc_error ("There is no specific function for the generic %qs "
"at %L", expr->symtree->n.sym->name, &expr->where);
return false;
}
@ -2563,7 +2563,7 @@ generic:
return true;
if (m == MATCH_NO)
gfc_error ("Generic function '%s' at %L is not consistent with a "
gfc_error ("Generic function %qs at %L is not consistent with a "
"specific intrinsic interface", expr->symtree->n.sym->name,
&expr->where);
@ -2601,7 +2601,7 @@ resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
if (m == MATCH_YES)
return MATCH_YES;
if (m == MATCH_NO)
gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
"with an intrinsic", sym->name, &expr->where);
return MATCH_ERROR;
@ -2652,7 +2652,7 @@ resolve_specific_f (gfc_expr *expr)
break;
}
gfc_error ("Unable to resolve the specific function '%s' at %L",
gfc_error ("Unable to resolve the specific function %qs at %L",
expr->symtree->n.sym->name, &expr->where);
return true;
@ -2708,7 +2708,7 @@ set_type:
if (ts->type == BT_UNKNOWN)
{
gfc_error ("Function '%s' at %L has no IMPLICIT type",
gfc_error ("Function %qs at %L has no IMPLICIT type",
sym->name, &expr->where);
return false;
}
@ -2829,7 +2829,7 @@ resolve_function (gfc_expr *expr)
if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
{
gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
gfc_error ("%qs at %L is not a function", sym->name, &expr->where);
return false;
}
@ -2837,7 +2837,7 @@ resolve_function (gfc_expr *expr)
of course be referenced), expr->value.function.esym will be set. */
if (sym && sym->attr.abstract && !expr->value.function.esym)
{
gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
sym->name, &expr->where);
return false;
}
@ -2880,7 +2880,7 @@ resolve_function (gfc_expr *expr)
&& !sym->attr.contained)
{
/* Internal procedures are taken care of in resolve_contained_fntype. */
gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
"be used at %L since it is not a dummy argument",
sym->name, &expr->where);
return false;
@ -2934,7 +2934,7 @@ resolve_function (gfc_expr *expr)
&& expr->value.function.esym
&& ! gfc_elemental (expr->value.function.esym))
{
gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
"in WORKSHARE construct", expr->value.function.esym->name,
&expr->where);
t = false;
@ -2988,21 +2988,21 @@ resolve_function (gfc_expr *expr)
{
if (forall_flag)
{
gfc_error ("Reference to non-PURE function '%s' at %L inside a "
gfc_error ("Reference to non-PURE function %qs at %L inside a "
"FORALL %s", name, &expr->where,
forall_flag == 2 ? "mask" : "block");
t = false;
}
else if (gfc_do_concurrent_flag)
{
gfc_error ("Reference to non-PURE function '%s' at %L inside a "
gfc_error ("Reference to non-PURE function %qs at %L inside a "
"DO CONCURRENT %s", name, &expr->where,
gfc_do_concurrent_flag == 2 ? "mask" : "block");
t = false;
}
else if (gfc_pure (NULL))
{
gfc_error ("Function reference to '%s' at %L is to a non-PURE "
gfc_error ("Function reference to %qs at %L is to a non-PURE "
"procedure within a PURE procedure", name, &expr->where);
t = false;
}
@ -3020,11 +3020,11 @@ resolve_function (gfc_expr *expr)
if (is_illegal_recursion (esym, gfc_current_ns))
{
if (esym->attr.entry && esym->ns->entries)
gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
" function '%s' is not RECURSIVE",
gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
" function %qs is not RECURSIVE",
esym->name, &expr->where, esym->ns->entries->sym->name);
else
gfc_error ("Function '%s' at %L cannot be called recursively, as it"
gfc_error ("Function %qs at %L cannot be called recursively, as it"
" is not RECURSIVE", esym->name, &expr->where);
t = false;
@ -3063,13 +3063,13 @@ pure_subroutine (gfc_code *c, gfc_symbol *sym)
return;
if (forall_flag)
gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
sym->name, &c->loc);
else if (gfc_do_concurrent_flag)
gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
"PURE", sym->name, &c->loc);
else if (gfc_pure (NULL))
gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
gfc_error ("Subroutine call to %qs at %L is not PURE", sym->name,
&c->loc);
gfc_unset_implicit_pure (NULL);
@ -3134,7 +3134,7 @@ generic:
if (!gfc_is_intrinsic (sym, 1, c->loc))
{
gfc_error ("There is no specific subroutine for the generic '%s' at %L",
gfc_error ("There is no specific subroutine for the generic %qs at %L",
sym->name, &c->loc);
return false;
}
@ -3143,7 +3143,7 @@ generic:
if (m == MATCH_YES)
return true;
if (m == MATCH_NO)
gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
gfc_error ("Generic subroutine %qs at %L is not consistent with an "
"intrinsic subroutine interface", sym->name, &c->loc);
return false;
@ -3178,7 +3178,7 @@ resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
if (m == MATCH_YES)
return MATCH_YES;
if (m == MATCH_NO)
gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
"with an intrinsic", sym->name, &c->loc);
return MATCH_ERROR;
@ -3222,7 +3222,7 @@ resolve_specific_s (gfc_code *c)
}
sym = c->symtree->n.sym;
gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
gfc_error ("Unable to resolve the specific subroutine %qs at %L",
sym->name, &c->loc);
return false;
@ -3282,7 +3282,7 @@ resolve_call (gfc_code *c)
if (csym && csym->ts.type != BT_UNKNOWN)
{
gfc_error ("'%s' at %L has a type, which is not consistent with "
gfc_error_1 ("'%s' at %L has a type, which is not consistent with "
"the CALL at %L", csym->name, &csym->declared_at, &c->loc);
return false;
}
@ -3311,7 +3311,7 @@ resolve_call (gfc_code *c)
{
if (csym->attr.abstract)
{
gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
csym->name, &c->loc);
return false;
}
@ -3321,11 +3321,11 @@ resolve_call (gfc_code *c)
if (is_illegal_recursion (csym, gfc_current_ns))
{
if (csym->attr.entry && csym->ns->entries)
gfc_error ("ENTRY '%s' at %L cannot be called recursively, "
"as subroutine '%s' is not RECURSIVE",
gfc_error ("ENTRY %qs at %L cannot be called recursively, "
"as subroutine %qs is not RECURSIVE",
csym->name, &c->loc, csym->ns->entries->sym->name);
else
gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, "
gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
"as it is not RECURSIVE", csym->name, &c->loc);
t = false;
@ -3402,7 +3402,7 @@ compare_shapes (gfc_expr *op1, gfc_expr *op2)
{
if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
{
gfc_error ("Shapes for operands at %L and %L are not conformable",
gfc_error_1 ("Shapes for operands at %L and %L are not conformable",
&op1->where, &op2->where);
t = false;
break;
@ -6676,7 +6676,7 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2)
if (mpz_cmp (e1->shape[i], s) != 0)
{
gfc_error ("Source-expr at %L and allocate-object at %L must "
gfc_error_1 ("Source-expr at %L and allocate-object at %L must "
"have the same shape", &e1->where, &e2->where);
mpz_clear (s);
return false;
@ -6834,8 +6834,8 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
/* Check F03:C631. */
if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
{
gfc_error ("Type of entity at %L is type incompatible with "
"source-expr at %L", &e->where, &code->expr3->where);
gfc_error_1 ("Type of entity at %L is type incompatible with "
"source-expr at %L", &e->where, &code->expr3->where);
goto failure;
}
@ -6846,7 +6846,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
/* Check F03:C633. */
if (code->expr3->ts.kind != e->ts.kind && !unlimited)
{
gfc_error ("The allocate-object at %L and the source-expr at %L "
gfc_error_1 ("The allocate-object at %L and the source-expr at %L "
"shall have the same kind type parameter",
&e->where, &code->expr3->where);
goto failure;
@ -6860,7 +6860,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
&& code->expr3->ts.u.derived->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE)))
{
gfc_error ("The source-expr at %L shall neither be of type "
gfc_error_1 ("The source-expr at %L shall neither be of type "
"LOCK_TYPE nor have a LOCK_TYPE component if "
"allocate-object at %L is a coarray",
&code->expr3->where, &e->where);
@ -7204,20 +7204,20 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
{
if (pr == NULL && qr == NULL)
{
gfc_error ("Allocate-object at %L also appears at %L",
&pe->where, &qe->where);
gfc_error_1 ("Allocate-object at %L also appears at %L",
&pe->where, &qe->where);
break;
}
else if (pr != NULL && qr == NULL)
{
gfc_error ("Allocate-object at %L is subobject of"
" object at %L", &pe->where, &qe->where);
gfc_error_1 ("Allocate-object at %L is subobject of"
" object at %L", &pe->where, &qe->where);
break;
}
else if (pr == NULL && qr != NULL)
{
gfc_error ("Allocate-object at %L is subobject of"
" object at %L", &qe->where, &pe->where);
gfc_error_1 ("Allocate-object at %L is subobject of"
" object at %L", &qe->where, &pe->where);
break;
}
/* Here, pr != NULL && qr != NULL */
@ -7420,7 +7420,7 @@ check_case_overlap (gfc_case *list)
element in the list. Either way, we must
issue an error and get the next case from P. */
/* FIXME: Sort P and Q by line number. */
gfc_error ("CASE label at %L overlaps with CASE "
gfc_error_1 ("CASE label at %L overlaps with CASE "
"label at %L", &p->where, &q->where);
overlap_seen = 1;
e = p;
@ -7658,7 +7658,7 @@ resolve_select (gfc_code *code, bool select_type)
{
if (default_case != NULL)
{
gfc_error ("The DEFAULT CASE at %L cannot be followed "
gfc_error_1 ("The DEFAULT CASE at %L cannot be followed "
"by a second DEFAULT CASE at %L",
&default_case->where, &cp->where);
t = false;
@ -8028,7 +8028,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
/* Check F03:C818. */
if (default_case)
{
gfc_error ("The DEFAULT CASE at %L cannot be followed "
gfc_error_1 ("The DEFAULT CASE at %L cannot be followed "
"by a second DEFAULT CASE at %L",
&default_case->ext.block.case_list->where, &c->where);
error++;
@ -8586,7 +8586,7 @@ resolve_branch (gfc_st_label *label, gfc_code *code)
if (label->defined != ST_LABEL_TARGET && label->defined != ST_LABEL_DO_TARGET)
{
gfc_error ("Statement at %L is not a valid branch target statement "
gfc_error_1 ("Statement at %L is not a valid branch target statement "
"for the branch statement at %L", &label->where, &code->loc);
return;
}
@ -8612,11 +8612,11 @@ resolve_branch (gfc_st_label *label, gfc_code *code)
{
if (stack->current->op == EXEC_CRITICAL
&& bitmap_bit_p (stack->reachable_labels, label->value))
gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
gfc_error_1 ("GOTO statement at %L leaves CRITICAL construct for "
"label at %L", &code->loc, &label->where);
else if (stack->current->op == EXEC_DO_CONCURRENT
&& bitmap_bit_p (stack->reachable_labels, label->value))
gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
gfc_error_1 ("GOTO statement at %L leaves DO CONCURRENT construct "
"for label at %L", &code->loc, &label->where);
}
@ -8635,13 +8635,13 @@ resolve_branch (gfc_st_label *label, gfc_code *code)
{
/* Note: A label at END CRITICAL does not leave the CRITICAL
construct as END CRITICAL is still part of it. */
gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
gfc_error_1 ("GOTO statement at %L leaves CRITICAL construct for label"
" at %L", &code->loc, &label->where);
return;
}
else if (stack->current->op == EXEC_DO_CONCURRENT)
{
gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
gfc_error_1 ("GOTO statement at %L leaves DO CONCURRENT construct for "
"label at %L", &code->loc, &label->where);
return;
}
@ -10001,7 +10001,7 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
gfc_error ("ASSIGNED GOTO statement at %L requires an "
"INTEGER variable", &code->expr1->where);
else if (code->expr1->symtree->n.sym->attr.assign != 1)
gfc_error ("Variable '%s' has not been assigned a target "
gfc_error ("Variable %qs has not been assigned a target "
"label at %L", code->expr1->symtree->n.sym->name,
&code->expr1->where);
}
@ -10386,7 +10386,7 @@ gfc_verify_binding_labels (gfc_symbol *sym)
if (sym->attr.flavor == FL_VARIABLE && gsym->type != GSYM_UNKNOWN)
{
gfc_error ("Variable %s with binding label %s at %L uses the same global "
gfc_error_1 ("Variable %s with binding label %s at %L uses the same global "
"identifier as entity at %L", sym->name,
sym->binding_label, &sym->declared_at, &gsym->where);
/* Clear the binding label to prevent checking multiple times. */
@ -10399,8 +10399,8 @@ gfc_verify_binding_labels (gfc_symbol *sym)
{
/* This can only happen if the variable is defined in a module - if it
isn't the same module, reject it. */
gfc_error ("Variable %s from module %s with binding label %s at %L uses "
"the same global identifier as entity at %L from module %s",
gfc_error_1 ("Variable %s from module %s with binding label %s at %L uses "
"the same global identifier as entity at %L from module %s",
sym->name, module, sym->binding_label,
&sym->declared_at, &gsym->where, gsym->mod_name);
sym->binding_label = NULL;
@ -10416,7 +10416,7 @@ gfc_verify_binding_labels (gfc_symbol *sym)
/* Print an error if the procedure is defined multiple times; we have to
exclude references to the same procedure via module association or
multiple checks for the same procedure. */
gfc_error ("Procedure %s with binding label %s at %L uses the same "
gfc_error_1 ("Procedure %s with binding label %s at %L uses the same "
"global identifier as entity at %L", sym->name,
sym->binding_label, &sym->declared_at, &gsym->where);
sym->binding_label = NULL;
@ -10916,7 +10916,7 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
s = gfc_find_dt_in_generic (s);
if (s && s->attr.flavor != FL_DERIVED)
{
gfc_error ("The type '%s' cannot be host associated at %L "
gfc_error_1 ("The type '%s' cannot be host associated at %L "
"because it is blocked by an incompatible object "
"of the same name declared at %L",
sym->ts.u.derived->name, &sym->declared_at,
@ -12335,7 +12335,7 @@ resolve_fl_derived0 (gfc_symbol *sym)
&& c->attr.codimension
&& (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
{
gfc_error ("Coarray component '%s' at %L must be allocatable with "
gfc_error ("Coarray component %qs at %L must be allocatable with "
"deferred shape", c->name, &c->loc);
return false;
}
@ -12344,7 +12344,7 @@ resolve_fl_derived0 (gfc_symbol *sym)
if (c->attr.codimension && c->ts.type == BT_DERIVED
&& c->ts.u.derived->ts.is_iso_c)
{
gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
"shall not be a coarray", c->name, &c->loc);
return false;
}
@ -12354,7 +12354,7 @@ resolve_fl_derived0 (gfc_symbol *sym)
&& (c->attr.codimension || c->attr.pointer || c->attr.dimension
|| c->attr.allocatable))
{
gfc_error ("Component '%s' at %L with coarray component "
gfc_error ("Component %qs at %L with coarray component "
"shall be a nonpointer, nonallocatable scalar",
c->name, &c->loc);
return false;
@ -12363,7 +12363,7 @@ resolve_fl_derived0 (gfc_symbol *sym)
/* F2008, C448. */
if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer))
{
gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
"is not an array pointer", c->name, &c->loc);
return false;
}
@ -12456,8 +12456,8 @@ resolve_fl_derived0 (gfc_symbol *sym)
if (!me_arg)
{
gfc_error ("Procedure pointer component '%s' with PASS(%s) "
"at %L has no argument '%s'", c->name,
gfc_error ("Procedure pointer component %qs with PASS(%s) "
"at %L has no argument %qs", c->name,
c->tb->pass_arg, &c->loc, c->tb->pass_arg);
c->tb->error = 1;
return false;
@ -12470,7 +12470,7 @@ resolve_fl_derived0 (gfc_symbol *sym)
c->tb->pass_arg_num = 1;
if (!c->ts.interface->formal)
{
gfc_error ("Procedure pointer component '%s' with PASS at %L "
gfc_error ("Procedure pointer component %qs with PASS at %L "
"must have at least one argument",
c->name, &c->loc);
c->tb->error = 1;
@ -12486,8 +12486,8 @@ resolve_fl_derived0 (gfc_symbol *sym)
|| (me_arg->ts.type == BT_CLASS
&& CLASS_DATA (me_arg)->ts.u.derived != sym))
{
gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
" the derived type '%s'", me_arg->name, c->name,
gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
" the derived type %qs", me_arg->name, c->name,
me_arg->name, &c->loc, sym->name);
c->tb->error = 1;
return false;
@ -12496,7 +12496,7 @@ resolve_fl_derived0 (gfc_symbol *sym)
/* Check for C453. */
if (me_arg->attr.dimension)
{
gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
"must be scalar", me_arg->name, c->name, me_arg->name,
&c->loc);
c->tb->error = 1;
@ -12505,7 +12505,7 @@ resolve_fl_derived0 (gfc_symbol *sym)
if (me_arg->attr.pointer)
{
gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
"may not have the POINTER attribute", me_arg->name,
c->name, me_arg->name, &c->loc);
c->tb->error = 1;
@ -12514,7 +12514,7 @@ resolve_fl_derived0 (gfc_symbol *sym)
if (me_arg->attr.allocatable)
{
gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
"may not be ALLOCATABLE", me_arg->name, c->name,
me_arg->name, &c->loc);
c->tb->error = 1;
@ -12522,7 +12522,7 @@ resolve_fl_derived0 (gfc_symbol *sym)
}
if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
" at %L", c->name, &c->loc);
}
@ -12551,7 +12551,7 @@ resolve_fl_derived0 (gfc_symbol *sym)
if (super_type && !sym->attr.is_class
&& gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
{
gfc_error ("Component '%s' of '%s' at %L has the same name as an"
gfc_error ("Component %qs of %qs at %L has the same name as an"
" inherited type-bound procedure",
c->name, sym->name, &c->loc);
return false;
@ -12564,7 +12564,7 @@ resolve_fl_derived0 (gfc_symbol *sym)
|| (!resolve_charlen(c->ts.u.cl))
|| !gfc_is_constant_expr (c->ts.u.cl->length))
{
gfc_error ("Character length of component '%s' needs to "
gfc_error ("Character length of component %qs needs to "
"be a constant specification expression at %L",
c->name,
c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
@ -12575,7 +12575,7 @@ resolve_fl_derived0 (gfc_symbol *sym)
if (c->ts.type == BT_CHARACTER && c->ts.deferred
&& !c->attr.pointer && !c->attr.allocatable)
{
gfc_error ("Character component '%s' of '%s' at %L with deferred "
gfc_error ("Character component %qs of %qs at %L with deferred "
"length must be a POINTER or ALLOCATABLE",
c->name, sym->name, &c->loc);
return false;
@ -12641,7 +12641,7 @@ resolve_fl_derived0 (gfc_symbol *sym)
&& c->attr.pointer && c->ts.u.derived->components == NULL
&& !c->ts.u.derived->attr.zero_comp)
{
gfc_error ("The pointer component '%s' of '%s' at %L is a type "
gfc_error ("The pointer component %qs of %qs at %L is a type "
"that has not been declared", c->name, sym->name,
&c->loc);
return false;
@ -12653,7 +12653,7 @@ resolve_fl_derived0 (gfc_symbol *sym)
&& !CLASS_DATA (c)->ts.u.derived->attr.zero_comp
&& !UNLIMITED_POLY (c))
{
gfc_error ("The pointer component '%s' of '%s' at %L is a type "
gfc_error ("The pointer component %qs of %qs at %L is a type "
"that has not been declared", c->name, sym->name,
&c->loc);
return false;
@ -12665,7 +12665,7 @@ resolve_fl_derived0 (gfc_symbol *sym)
|| !(CLASS_DATA (c)->attr.class_pointer
|| CLASS_DATA (c)->attr.allocatable)))
{
gfc_error ("Component '%s' with CLASS at %L must be allocatable "
gfc_error ("Component %qs with CLASS at %L must be allocatable "
"or pointer", c->name, &c->loc);
/* Prevent a recurrence of the error. */
c->ts.type = BT_UNKNOWN;
@ -13317,7 +13317,7 @@ resolve_symbol (gfc_symbol *sym)
if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
sym->attr.in_common == 0)
{
gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
"is neither a COMMON block nor declared at the "
"module level scope", sym->name, &(sym->declared_at));
t = false;

1
gcc/fortran/scanner.c
View File

@ -2045,6 +2045,7 @@ load_file (const char *realfilename, const char *displayedname, bool initial)
b = XCNEWVAR (gfc_linebuf, gfc_linebuf_header_size
+ (len + 1) * sizeof (gfc_char_t));
b->location
= linemap_line_start (line_table, current_file->line++, len);
/* ??? We add the location for the maximum column possible here,

30
gcc/fortran/symbol.c
View File

@ -1701,18 +1701,18 @@ gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type))
{
if (sym->attr.use_assoc)
gfc_error ("Symbol '%s' at %L conflicts with symbol from module '%s', "
gfc_error_1 ("Symbol '%s' at %L conflicts with symbol from module '%s', "
"use-associated at %L", sym->name, where, sym->module,
&sym->declared_at);
else
gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name,
gfc_error ("Symbol %qs at %L already has basic type of %s", sym->name,
where, gfc_basic_typename (type));
return false;
}
if (sym->attr.procedure && sym->ts.interface)
{
gfc_error ("Procedure '%s' at %L may not have basic type of %s",
gfc_error ("Procedure %qs at %L may not have basic type of %s",
sym->name, where, gfc_basic_typename (ts->type));
return false;
}
@ -1895,7 +1895,7 @@ gfc_add_component (gfc_symbol *sym, const char *name,
{
if (strcmp (p->name, name) == 0)
{
gfc_error ("Component '%s' at %C already declared at %L",
gfc_error_1 ("Component '%s' at %C already declared at %L",
name, &p->loc);
return false;
}
@ -1906,7 +1906,7 @@ gfc_add_component (gfc_symbol *sym, const char *name,
if (sym->attr.extension
&& gfc_find_component (sym->components->ts.u.derived, name, true, true))
{
gfc_error ("Component '%s' at %C already in the parent type "
gfc_error_1 ("Component '%s' at %C already in the parent type "
"at %L", name, &sym->components->ts.u.derived->declared_at);
return false;
}
@ -2061,7 +2061,7 @@ gfc_find_component (gfc_symbol *sym, const char *name,
&& !is_parent_comp))
{
if (!silent)
gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
gfc_error ("Component %qs at %C is a PRIVATE component of %qs",
name, sym->name);
return NULL;
}
@ -2079,7 +2079,7 @@ gfc_find_component (gfc_symbol *sym, const char *name,
}
if (p == NULL && !silent)
gfc_error ("'%s' at %C is not a member of the '%s' structure",
gfc_error ("%qs at %C is not a member of the %qs structure",
name, sym->name);
return p;
@ -2218,7 +2218,7 @@ gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus)
labelno = lp->value;
if (lp->defined != ST_LABEL_UNKNOWN)
gfc_error ("Duplicate statement label %d at %L and %L", labelno,
gfc_error_1 ("Duplicate statement label %d at %L and %L", labelno,
&lp->where, label_locus);
else
{
@ -2628,10 +2628,10 @@ ambiguous_symbol (const char *name, gfc_symtree *st)
{
if (st->n.sym->module)
gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
"from module '%s'", name, st->n.sym->name, st->n.sym->module);
gfc_error ("Name %qs at %C is an ambiguous reference to %qs "
"from module %qs", name, st->n.sym->name, st->n.sym->module);
else
gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
gfc_error ("Name %qs at %C is an ambiguous reference to %qs "
"from current program unit", name, st->n.sym->name);
}
@ -2852,7 +2852,7 @@ gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result,
&& (ns->has_import_set || p->attr.imported)))
{
/* Symbol is from another namespace. */
gfc_error ("Symbol '%s' at %C has already been host associated",
gfc_error ("Symbol %qs at %C has already been host associated",
name);
return 2;
}
@ -3895,7 +3895,7 @@ verify_bind_c_derived_type (gfc_symbol *derived_sym)
J3/04-007, Section 15.2.3, C1505. */
if (curr_comp->attr.pointer != 0)
{
gfc_error ("Component '%s' at %L cannot have the "
gfc_error_1 ("Component '%s' at %L cannot have the "
"POINTER attribute because it is a member "
"of the BIND(C) derived type '%s' at %L",
curr_comp->name, &(curr_comp->loc),
@ -3905,7 +3905,7 @@ verify_bind_c_derived_type (gfc_symbol *derived_sym)
if (curr_comp->attr.proc_pointer != 0)
{
gfc_error ("Procedure pointer component '%s' at %L cannot be a member"
gfc_error_1 ("Procedure pointer component '%s' at %L cannot be a member"
" of the BIND(C) derived type '%s' at %L", curr_comp->name,
&curr_comp->loc, derived_sym->name,
&derived_sym->declared_at);
@ -3916,7 +3916,7 @@ verify_bind_c_derived_type (gfc_symbol *derived_sym)
J3/04-007, Section 15.2.3, C1505. */
if (curr_comp->attr.allocatable != 0)
{
gfc_error ("Component '%s' at %L cannot have the "
gfc_error_1 ("Component '%s' at %L cannot have the "
"ALLOCATABLE attribute because it is a member "
"of the BIND(C) derived type '%s' at %L",
curr_comp->name, &(curr_comp->loc),

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

@ -908,7 +908,7 @@ confirm_condition (segment_info *s1, gfc_equiv *eq1, segment_info *s2,
offset2 = calculate_offset (eq2->expr);
if (s1->offset + offset1 != s2->offset + offset2)
gfc_error ("Inconsistent equivalence rules involving '%s' at %L and "
gfc_error_1 ("Inconsistent equivalence rules involving '%s' at %L and "
"'%s' at %L", s1->sym->name, &s1->sym->declared_at,
s2->sym->name, &s2->sym->declared_at);
}

16
gcc/pretty-print.c
View File

@ -55,9 +55,6 @@ output_buffer::~output_buffer ()
obstack_free (&formatted_obstack, NULL);
}
/* A pointer to the formatted diagnostic message. */
#define pp_formatted_text_data(PP) \
((const char *) obstack_base (pp_buffer (PP)->obstack))
/* Format an integer given by va_arg (ARG, type-specifier T) where
type-specifier is a precision modifier as indicated by PREC. F is
@ -225,8 +222,7 @@ pp_maybe_wrap_text (pretty_printer *pp, const char *start, const char *end)
static inline void
pp_append_r (pretty_printer *pp, const char *start, int length)
{
obstack_grow (pp_buffer (pp)->obstack, start, length);
pp_buffer (pp)->line_length += length;
output_buffer_append_r (pp_buffer (pp), start, length);
}
/* Insert enough spaces into the output area of PRETTY-PRINTER to bring
@ -826,8 +822,7 @@ pp_append_text (pretty_printer *pp, const char *start, const char *end)
const char *
pp_formatted_text (pretty_printer *pp)
{
obstack_1grow (pp_buffer (pp)->obstack, '\0');
return pp_formatted_text_data (pp);
return output_buffer_formatted_text (pp_buffer (pp));
}
/* Return a pointer to the last character emitted in PRETTY-PRINTER's
@ -835,12 +830,7 @@ pp_formatted_text (pretty_printer *pp)
const char *
pp_last_position_in_text (const pretty_printer *pp)
{
const char *p = NULL;
struct obstack *text = pp_buffer (pp)->obstack;
if (obstack_base (text) != obstack_next_free (text))
p = ((const char *) obstack_next_free (text)) - 1;
return p;
return output_buffer_last_position_in_text (pp_buffer (pp));
}
/* Return the amount of characters PRETTY-PRINTER can accept to

32
gcc/pretty-print.h
View File

@ -107,6 +107,38 @@ struct output_buffer
bool flush_p;
};
/* Finishes constructing a NULL-terminated character string representing
the buffered text. */
static inline const char *
output_buffer_formatted_text (output_buffer *buff)
{
obstack_1grow (buff->obstack, '\0');
return (const char *) obstack_base (buff->obstack);
}
/* Append to the output buffer a string specified by its
STARTing character and LENGTH. */
static inline void
output_buffer_append_r (output_buffer *buff, const char *start, int length)
{
obstack_grow (buff->obstack, start, length);
buff->line_length += length;
}
/* Return a pointer to the last character emitted in the
output_buffer. A NULL pointer means no character available. */
static inline const char *
output_buffer_last_position_in_text (const output_buffer *buff)
{
const char *p = NULL;
struct obstack *text = buff->obstack;
if (obstack_base (text) != obstack_next_free (text))
p = ((const char *) obstack_next_free (text)) - 1;
return p;
}
/* The type of pretty-printer flags passed to clients. */
typedef unsigned int pp_flags;

4
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,7 @@
2014-12-11 Manuel López-Ibáñez <manu@gcc.gnu.org>
* gfortran.dg/do_iterator.f90: Remove bogus dg-warning.
2014-12-11 Kyrylo Tkachov <kyrylo.tkachov@arm.com>
* config/arm/arm_neon.h (vrndqn_f32): Rename to...