===================================================================
@@ -41,12 +41,10 @@ along with GCC; see the file COPYING3.
#define permissive_error_option(DC) ((DC)->opt_permissive)
/* 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. */
const char *progname;
@@ -464,15 +462,15 @@ bt_err_callback (void *data ATTRIBUTE_UN
errnum == 0 ? "" : xstrerror (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:
case DK_ANACHRONISM:
case DK_WARNING:
@@ -488,11 +486,12 @@ diagnostic_action_after_output (diagnost
diagnostic_finish (context);
exit (FATAL_EXIT_CODE);
}
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,
"compilation terminated due to -fmax-errors=%u.\n",
context->max_errors);
@@ -845,11 +844,11 @@ diagnostic_report_diagnostic (diagnostic
diagnostic->x_data = NULL;
pp_format (context->printer, &diagnostic->message);
(*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;
context->lock--;
@@ -1245,22 +1244,19 @@ fnotice (FILE *file, const char *cmsgid,
This mustn't use internal_error, that will cause infinite recursion. */
static void
error_recursion (diagnostic_context *context)
{
- diagnostic_info diagnostic;
-
if (context->lock < 3)
pp_newline_and_flush (context->printer);
fnotice (stderr,
"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. */
real_abort ();
}
===================================================================
@@ -292,10 +292,11 @@ extern void diagnostic_append_note (diag
#endif
extern char *diagnostic_build_prefix (diagnostic_context *, const diagnostic_info *);
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);
/* Expand the location of this diagnostic. Use this function for consistency. */
===================================================================
@@ -53,13 +53,10 @@ output_buffer::~output_buffer ()
{
obstack_free (&chunk_obstack, NULL);
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
a string used to construct the appropriate format-specifier. */
#define pp_integer_with_precision(PP, ARG, PREC, T, F) \
@@ -223,12 +220,11 @@ pp_maybe_wrap_text (pretty_printer *pp,
/* Append to the output area of PRETTY-PRINTER a string specified by its
STARTing character and LENGTH. */
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
the column position to the current indentation level, assuming that a
newline has just been written to the buffer. */
@@ -824,25 +820,19 @@ pp_append_text (pretty_printer *pp, cons
/* Finishes constructing a NULL-terminated character string representing
the PRETTY-PRINTED text. */
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
output area. A NULL pointer means no character available. */
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
make a full line. Meaningful only in line-wrapping mode. */
int
===================================================================
@@ -105,10 +105,42 @@ struct output_buffer
appropriate. Otherwise, text is buffered until either
pp_really_flush or pp_clear_output_area are called. */
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;
enum pp_padding
{
New version of the patch. Tobias noticed several problems with the previous version: * Due to the use of placement-new for the buffered output_buffers pp_warning_buffer and pp_error_buffer, the pretty-printer destructor may end up trying to free something that it can't. Fixed here by not using placement new. * -fmax-errors= does not take into account DK_WERROR, thus the compiler may end up printing several errors (converted from warnings) before actually stopping. Fixed here by simply adding DK_WERROR when checking max_errors. Note that -Wfatal-errors does stop for a DK_WERROR, thus it makes sense that -fmax-errors= behaves in the same way. Bootstrapped and regression tested on x86_64-linux-gnu. The two fixes above could be applied separately before this patch, if that is considered more convenient, but it will take me some time to split the patches and test them separately. OK? gcc/ChangeLog: 2014-12-07 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/testsuite/ChangeLog: 2014-12-07 Manuel López-Ibáñez <manu@gcc.gnu.org> * gfortran.dg/do_iterator.f90: Remove bogus dg-warning. gcc/fortran/ChangeLog: 2014-12-07 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): Init pp_error_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. Index: gcc/fortran/openmp.c =================================================================== --- gcc/fortran/openmp.c (revision 218457) +++ gcc/fortran/openmp.c (working copy) @@ -2324,45 +2324,45 @@ resolve_omp_clauses (gfc_code *code, loc default: for (; n != NULL; n = n->next) { 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) switch (list) { case OMP_LIST_PRIVATE: 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: break; } @@ -2473,26 +2473,26 @@ resolve_omp_clauses (gfc_code *code, loc } } 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) { gfc_expr *expr = n->expr; 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); } break; /* Workaround for PR middle-end/26316, nothing really needs @@ -2929,11 +2929,11 @@ resolve_omp_atomic (gfc_code *code) && arg->expr->symtree->n.sym == var) var_arg = arg; 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; } if (arg->expr->rank != 0) { @@ -2944,11 +2944,11 @@ 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; } if (var_arg != expr2->value.function.actual) { @@ -3412,11 +3412,11 @@ gfc_resolve_omp_declare_simd (gfc_namesp for (ods = ns->omp_declare_simd; ods; ods = ods->next) { 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); } } Index: gcc/fortran/interface.c =================================================================== --- gcc/fortran/interface.c (revision 218457) +++ gcc/fortran/interface.c (working copy) @@ -217,11 +217,11 @@ gfc_match_interface (void) && !gfc_add_generic (&sym->attr, sym->name, NULL)) return MATCH_ERROR; 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; } current_interface.sym = gfc_new_block = sym; @@ -1559,14 +1559,14 @@ check_interface0 (gfc_interface *p, cons if (((!p->sym->attr.function && !p->sym->attr.subroutine) || !p->sym->attr.if_source) && 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; } @@ -1643,11 +1643,11 @@ check_interface1 (gfc_interface *p, gfc_ && q->sym->attr.flavor != FL_DERIVED && gfc_compare_interfaces (p->sym, q->sym, q->sym->name, 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) gfc_warning ("Ambiguous interfaces %qs and %qs in %s at %L", p->sym->name, q->sym->name, interface_name, @@ -1685,11 +1685,11 @@ check_sym_interfaces (gfc_symbol *sym) { if (p->sym->attr.mod_proc && (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; } } @@ -1890,25 +1890,25 @@ argument_rank_mismatch (const char *name /* TS 29113, C407b. */ 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); } } @@ -1954,11 +1954,11 @@ compare_parameter (gfc_symbol *formal, g if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err, 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; } if (formal->attr.function && !act_sym->attr.function) @@ -1979,11 +1979,11 @@ compare_parameter (gfc_symbol *formal, g /* F2008, C1241. */ if (formal->attr.pointer && formal->attr.contiguous && !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; } if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN) @@ -1994,21 +1994,21 @@ compare_parameter (gfc_symbol *formal, g && !(formal->ts.type == BT_DERIVED && actual->ts.type == BT_CLASS && gfc_compare_derived_types (formal->ts.u.derived, 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; } if (actual->ts.type == BT_ASSUMED && formal->ts.type != BT_ASSUMED) { 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; } /* F2008, 12.5.2.5; IR F08/0073. */ @@ -2019,11 +2019,11 @@ compare_parameter (gfc_symbol *formal, g || CLASS_DATA (formal)->attr.allocatable)) { 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; } if (!gfc_expr_attr (actual).class_ok) @@ -2032,11 +2032,11 @@ compare_parameter (gfc_symbol *formal, g if ((!UNLIMITED_POLY (formal) || !UNLIMITED_POLY(actual)) && !gfc_compare_derived_types (CLASS_DATA (actual)->ts.u.derived, 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; } } @@ -2047,22 +2047,22 @@ compare_parameter (gfc_symbol *formal, g if (UNLIMITED_POLY (formal) && !UNLIMITED_POLY (actual) && (CLASS_DATA (formal)->attr.allocatable ||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, &actual->where); return 0; } 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; } if (formal->attr.codimension && formal->attr.allocatable) @@ -2077,11 +2077,11 @@ compare_parameter (gfc_symbol *formal, g if ((last && last->u.c.component->as->corank != formal->as->corank) || (!last && 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); return 0; } @@ -2094,11 +2094,11 @@ compare_parameter (gfc_symbol *formal, g && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE) && gfc_expr_attr (actual).dimension && !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; } /* F2008, C1303 and C1304. */ @@ -2108,11 +2108,11 @@ compare_parameter (gfc_symbol *formal, g && formal->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE) || formal->attr.lock_comp)) { 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; } } @@ -2126,11 +2126,11 @@ compare_parameter (gfc_symbol *formal, g && ((formal->as->type != AS_ASSUMED_SHAPE && formal->as->type != AS_ASSUMED_RANK && !formal->attr.pointer) || 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); return 0; } @@ -2140,11 +2140,11 @@ compare_parameter (gfc_symbol *formal, g { if (formal->attr.intent == INTENT_OUT) { 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; } else if (warn_surprising && where && formal->attr.intent != INTENT_IN) gfc_warning (OPT_Wsurprising, @@ -2209,21 +2209,21 @@ compare_parameter (gfc_symbol *formal, g } 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; } if (actual->expr_type != EXPR_NULL && ref && actual->ts.type != BT_CHARACTER && (is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE)) { 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; } if (actual->ts.type == BT_CHARACTER && actual->expr_type != EXPR_NULL @@ -2232,18 +2232,18 @@ compare_parameter (gfc_symbol *formal, g if (formal->ts.kind != 1 && (gfc_option.allow_std & GFC_STD_GNU) == 0) { 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; } else if ((gfc_option.allow_std & GFC_STD_F2003) == 0) return 0; @@ -2553,19 +2553,19 @@ compare_actual_formal (gfc_actual_arglis } 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; } 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; } } @@ -2618,15 +2618,15 @@ compare_actual_formal (gfc_actual_arglis if (where && (!f->sym->attr.optional || (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; } if (!compare_parameter (f->sym, a->expr, ranks_must_agree, @@ -2688,11 +2688,11 @@ compare_actual_formal (gfc_actual_arglis && f->sym->ts.deferred != a->expr->ts.deferred && a->expr->ts.type == BT_CHARACTER) { 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; } @@ -2728,22 +2728,22 @@ compare_actual_formal (gfc_actual_arglis || (a->expr->expr_type == EXPR_FUNCTION && a->expr->symtree->n.sym->result->attr.proc_pointer) || 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; } /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is provided for a procedure formal argument. */ if (f->sym->attr.flavor == FL_PROCEDURE && 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; } if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE @@ -2753,41 +2753,41 @@ compare_actual_formal (gfc_actual_arglis && (a->expr->ref == NULL || (a->expr->ref->type == REF_ARRAY && 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; } if (a->expr->expr_type != EXPR_NULL && 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; } if (a->expr->expr_type != EXPR_NULL && (gfc_option.allow_std & GFC_STD_F2008) == 0 && compare_pointer (f->sym, a->expr) == 2) { 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; } /* Fortran 2008, C1242. */ if (f->sym->attr.pointer && gfc_is_coindexed (a->expr)) { if (where) gfc_error ("Coindexed actual argument at %L to pointer " - "dummy '%s'", + "dummy %qs", &a->expr->where, f->sym->name); return 0; } /* Fortran 2008, 12.5.2.5 (no constraint). */ @@ -2796,11 +2796,11 @@ compare_actual_formal (gfc_actual_arglis && f->sym->attr.allocatable && gfc_is_coindexed (a->expr)) { 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; } /* Fortran 2008, C1237. */ @@ -2810,11 +2810,11 @@ compare_actual_formal (gfc_actual_arglis && (a->expr->symtree->n.sym->attr.volatile_ || a->expr->symtree->n.sym->attr.asynchronous)) { 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; } @@ -2824,32 +2824,32 @@ compare_actual_formal (gfc_actual_arglis && gfc_is_coindexed (a->expr) && gfc_has_ultimate_allocatable (a->expr)) { 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; } if (f->sym->ts.type == BT_CLASS && CLASS_DATA (f->sym)->attr.allocatable && gfc_is_class_array_ref (a->expr, &full_array) && !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; } if (a->expr->expr_type != EXPR_NULL && 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; } /* Check intent = OUT/INOUT for definable actual argument. */ @@ -2877,11 +2877,11 @@ compare_actual_formal (gfc_actual_arglis { if (where) 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; } /* C1232 (R1221) For an actual argument which is an array section or @@ -2894,11 +2894,11 @@ compare_actual_formal (gfc_actual_arglis && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE)) { 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; } if (f->sym->attr.volatile_ @@ -2906,11 +2906,11 @@ compare_actual_formal (gfc_actual_arglis && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE)) { 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; } /* C1233 (R1221) For an actual argument which is a pointer array, the @@ -2925,11 +2925,11 @@ compare_actual_formal (gfc_actual_arglis || f->sym->attr.pointer))) { 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; } match: @@ -2953,11 +2953,11 @@ compare_actual_formal (gfc_actual_arglis return 0; } 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; } } @@ -3224,11 +3224,11 @@ check_intents (gfc_formal_arglist *f, gf /* F2008, Section 12.5.2.4. */ if (expr->ts.type == BT_CLASS && f->sym->ts.type == BT_CLASS && 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; } } @@ -3251,11 +3251,11 @@ gfc_procedure_use (gfc_symbol *sym, gfc_ explicitly declared at all if requested. */ if (sym->attr.if_source == IFSRC_UNKNOWN && !sym->attr.is_iso_c) { 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; } if (warn_implicit_interface) gfc_warning (OPT_Wimplicit_interface, @@ -3271,38 +3271,38 @@ gfc_procedure_use (gfc_symbol *sym, gfc_ { gfc_actual_arglist *a; 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; } for (a = *ap; a; a = a->next) { /* 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; } /* TS 29113, 6.2. */ if (a->expr && a->expr->ts.type == BT_ASSUMED @@ -3319,13 +3319,13 @@ gfc_procedure_use (gfc_symbol *sym, gfc_ && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS) && ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV && 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; } if (a->expr && a->expr->expr_type == EXPR_NULL && a->expr->ts.type == BT_UNKNOWN) @@ -3385,13 +3385,13 @@ gfc_ppc_use (gfc_component *comp, gfc_ac for (a = *ap; a; a = a->next) { /* 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; } } return; @@ -3911,11 +3911,11 @@ gfc_check_new_interface (gfc_interface * for (ip = base; ip; ip = ip->next) { 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; } } @@ -4122,11 +4122,11 @@ gfc_check_typebound_override (gfc_symtre gcc_assert (!proc->n.tb->is_generic); /* 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; } where = proc->n.tb->where; @@ -4134,81 +4134,81 @@ gfc_check_typebound_override (gfc_symtre old_target = old->n.tb->u.specific->n.sym; /* 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; } /* 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; } /* 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; } /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it 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; } /* If the overridden binding is a SUBROUTINE, the overriding must also be a 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; } /* If the overridden binding is a FUNCTION, the overriding must also be a FUNCTION and have the same characteristics. */ if (old_target->attr.function) { 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; } if (!check_result_characteristics (proc_target, old_target, err, 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; } } /* If the overridden binding is PUBLIC, the overriding one must not be PRIVATE. */ 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; } /* Compare the formal argument lists of both procedures. This is also abused @@ -4234,11 +4234,11 @@ gfc_check_typebound_override (gfc_symtre old_pass_arg = argpos; /* 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); return false; } @@ -4246,46 +4246,46 @@ gfc_check_typebound_override (gfc_symtre check_type = proc_pass_arg != argpos && old_pass_arg != argpos; if (!check_dummy_characteristics (proc_formal->sym, old_formal->sym, 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; } ++argpos; } 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; } /* If the overridden binding is NOPASS, the overriding one must also be 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; } /* If the overridden binding is PASS(x), the overriding one must also be PASS and the passed-object dummy arguments must correspond. */ if (!old->n.tb->nopass) { 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; } } Index: gcc/fortran/intrinsic.c =================================================================== --- gcc/fortran/intrinsic.c (revision 218457) +++ gcc/fortran/intrinsic.c (working copy) @@ -3813,11 +3813,11 @@ sort_actual (const char *name, gfc_actua } 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: /* Associate the remaining actual arguments, all of which have to be keyword arguments. */ @@ -3831,18 +3831,18 @@ keywords: { if (a->name[0] == '%') 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; } f->actual = a; @@ -3852,11 +3852,11 @@ optional: /* At this point, all unmatched formal args must be optional. */ for (f = formal; f; f = f->next) { 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; } } @@ -3924,11 +3924,11 @@ check_arglist (gfc_actual_arglist **ap, ts.kind = actual->expr->ts.kind; 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), gfc_typename (&actual->expr->ts)); return false; @@ -4532,18 +4532,18 @@ gfc_intrinsic_sub_interface (gfc_code *c c->resolved_sym->attr.elemental = isym->elemental; } 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; } if (!isym->pure) Index: gcc/fortran/symbol.c =================================================================== --- gcc/fortran/symbol.c (revision 218457) +++ gcc/fortran/symbol.c (working copy) @@ -1699,22 +1699,22 @@ gfc_add_type (gfc_symbol *sym, gfc_types type = sym->ns->proc_name->ts.type; 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; } flavor = sym->attr.flavor; @@ -1893,22 +1893,22 @@ gfc_add_component (gfc_symbol *sym, cons for (p = sym->components; p; p = p->next) { 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; } tail = p; } 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; } /* Allocate a new component. */ @@ -2059,11 +2059,11 @@ gfc_find_component (gfc_symbol *sym, con (p->attr.access != ACCESS_PUBLIC && sym->component_access == ACCESS_PRIVATE && !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; } } @@ -2077,11 +2077,11 @@ gfc_find_component (gfc_symbol *sym, con if (p == NULL) return p; } 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; } @@ -2216,11 +2216,11 @@ gfc_define_st_label (gfc_st_label *lp, g int labelno; 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 { lp->where = *label_locus; @@ -2626,14 +2626,14 @@ gfc_new_symbol (const char *name, gfc_na static void 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); } /* If we're in a SELECT TYPE block, check if the variable 'st' matches any @@ -2850,11 +2850,11 @@ gfc_get_sym_tree (const char *name, gfc_ && !(allow_subroutine && p->attr.subroutine) && !(ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY && (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; } p->mark = 1; @@ -3893,32 +3893,32 @@ verify_bind_c_derived_type (gfc_symbol * { /* The components cannot be pointers (fortran sense). 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), derived_sym->name, &(derived_sym->declared_at)); retval = false; } 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); retval = false; } /* The components cannot be allocatable. 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), derived_sym->name, &(derived_sym->declared_at)); retval = false; Index: gcc/fortran/class.c =================================================================== --- gcc/fortran/class.c (revision 218457) +++ gcc/fortran/class.c (working copy) @@ -664,11 +664,11 @@ gfc_build_class_symbol (gfc_typespec *ts { /* Since the extension field is 8 bit wide, we can only have 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; } fclass->attr.extension = ts->u.derived->attr.extension + 1; @@ -2684,11 +2684,11 @@ find_typebound_proc_uop (gfc_symbol* der if (!noaccess && derived->attr.use_assoc && 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; } @@ -2758,11 +2758,11 @@ gfc_find_typebound_intrinsic_op (gfc_sym if (!noaccess && derived->attr.use_assoc && 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; } Index: gcc/fortran/decl.c =================================================================== --- gcc/fortran/decl.c (revision 218457) +++ gcc/fortran/decl.c (working copy) @@ -259,11 +259,11 @@ var_element (gfc_data_variable *new_var) return MATCH_ERROR; 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; } if (gfc_current_state () != COMP_BLOCK_DATA @@ -377,11 +377,11 @@ match_data_constant (gfc_expr **result) if (sym == NULL || (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; } else if (dt_sym && dt_sym->attr.flavor == FL_DERIVED) return gfc_match_structure_constructor (dt_sym, result); @@ -1015,19 +1015,19 @@ gfc_verify_c_interop_param (gfc_symbol * if (is_c_interop != 1) { /* 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); else if (warn_c_binding_type) gfc_warning (OPT_Wc_binding_type, @@ -1044,13 +1044,13 @@ gfc_verify_c_interop_param (gfc_symbol * { gfc_charlen *cl = sym->ts.u.cl; 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; } } @@ -1074,21 +1074,21 @@ gfc_verify_c_interop_param (gfc_symbol * sym->ns->proc_name->name)) retval = false; 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; } 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; } else if (sym->attr.optional == 1 @@ -1321,11 +1321,11 @@ add_init_expr_to_sym (const char *name, then an initialization expression is not allowed. */ if (attr.flavor == FL_PARAMETER && 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; } if (init == NULL) @@ -1341,11 +1341,11 @@ add_init_expr_to_sym (const char *name, { /* If a variable appears in a DATA block, it cannot have an 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; } /* Check if the assignment can happen. This has to be put off @@ -1781,11 +1781,11 @@ check_function_name (char *name) gfc_symbol *block = gfc_current_block (); if (block && block->result && block->result != block && 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; } } return true; @@ -1848,11 +1848,11 @@ variable_decl (int elem) if (as) { 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; } if (as->type == AS_ASSUMED_SIZE && as->rank == 1 @@ -2817,11 +2817,11 @@ gfc_match_decl_type_spec (gfc_typespec * if (ts->kind != -1) { 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) dt_sym = gfc_find_dt_in_generic (sym); } @@ -2830,11 +2830,11 @@ gfc_match_decl_type_spec (gfc_typespec * int iface = gfc_state_stack->previous->state != COMP_INTERFACE || gfc_current_ns->has_import_set; 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) dt_sym = gfc_find_dt_in_generic (sym); @@ -2845,13 +2845,13 @@ gfc_match_decl_type_spec (gfc_typespec * if ((sym->attr.flavor != FL_UNKNOWN && !(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; } gfc_set_sym_referenced (sym); if (!sym->attr.generic @@ -3272,25 +3272,25 @@ gfc_match_import (void) { case MATCH_YES: 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 && gfc_find_symbol (name, 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; } if (gfc_find_symtree (gfc_current_ns->sym_root, name)) @@ -4062,27 +4062,27 @@ verify_bind_c_sym (gfc_symbol *tmp_sym, &(tmp_sym->declared_at), com_block->name); } 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)); } } /* Variables declared w/in a common block can't be bind(c) since there's no way for C to see these variables, so there's 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, &(tmp_sym->declared_at)); retval = false; @@ -4092,19 +4092,19 @@ verify_bind_c_sym (gfc_symbol *tmp_sym, or allocatable attributes. */ if (tmp_sym->attr.is_bind_c == 1) { 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; } 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; } @@ -4112,19 +4112,19 @@ verify_bind_c_sym (gfc_symbol *tmp_sym, /* If it is a BIND(C) function, make sure the return value is a 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. */ if (bind_c_function && tmp_sym->ts.type == BT_CHARACTER) 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)); } /* See if the symbol has been marked as private. If it has, make sure @@ -4595,11 +4595,11 @@ gfc_match_formal_arglist (gfc_symbol *pr so check for it explicitly. After the statement is accepted, the name is checked for especially in gfc_get_symbol(). */ 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; } @@ -4624,11 +4624,11 @@ ok: continue; 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; goto cleanup; } @@ -4999,11 +4999,11 @@ match_procedure_decl (void) /* Set interface. */ if (proc_if != NULL) { 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; } sym->ts.interface = proc_if; @@ -6275,11 +6275,11 @@ gfc_match_end (gfc_statement *st) return MATCH_YES; 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; } @@ -6301,19 +6301,19 @@ gfc_match_end (gfc_statement *st) if (block_name == NULL) goto syntax; 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; } /* Procedure pointer as function result. */ 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; } @@ -7313,11 +7313,11 @@ gfc_match_volatile (void) case MATCH_YES: /* F2008, C560+C561. VOLATILE for host-/use-associated variable or 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; } if (!gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus)) return MATCH_ERROR; @@ -7529,31 +7529,31 @@ check_extended_derived_type (char *name) extended = gfc_find_dt_in_generic (extended); /* 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; } return extended; @@ -7680,21 +7680,21 @@ gfc_match_derived_decl (void) return m; /* 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; } if (gfc_get_symbol (name, NULL, &gensym)) return MATCH_ERROR; 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; } if (!gensym->attr.generic @@ -7707,11 +7707,11 @@ gfc_match_derived_decl (void) sym = gfc_find_dt_in_generic (gensym); 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; } if (!sym) @@ -7778,11 +7778,11 @@ gfc_match_derived_decl (void) /* Set extension level. */ if (extended->attr.extension == 255) { /* 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; } sym->attr.extension = extended->attr.extension + 1; @@ -8373,23 +8373,23 @@ match_procedure_in_type (void) gcc_assert (ns); /* 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; } /* See if we already have a binding with this name in the symtree which would be an error. If a GENERIC already targeted this binding, it may be already there but then typebound is still NULL. */ 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; } /* Insert it and set attributes. */ @@ -8534,19 +8534,19 @@ gfc_match_generic (void) { if (!tb->is_generic) { 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; } 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; } } else { @@ -8600,12 +8600,12 @@ gfc_match_generic (void) /* See if this is a duplicate specification. */ 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; } target = gfc_get_tbp_generic (); target->specific_st = target_st; @@ -8709,11 +8709,11 @@ gfc_match_final_decl (void) return MATCH_ERROR; } 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; } /* Mark the symbol as module procedure. */ if (sym->attr.proc != PROC_MODULE @@ -8722,11 +8722,11 @@ gfc_match_final_decl (void) /* Check if we already have this symbol in the list, this is an error. */ 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; } /* Add this symbol to the list of finalizers. */ Index: gcc/fortran/trans-common.c =================================================================== --- gcc/fortran/trans-common.c (revision 218457) +++ gcc/fortran/trans-common.c (working copy) @@ -906,11 +906,11 @@ confirm_condition (segment_info *s1, gfc offset1 = calculate_offset (eq1->expr); 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); } Index: gcc/fortran/array.c =================================================================== --- gcc/fortran/array.c (revision 218457) +++ gcc/fortran/array.c (working copy) @@ -98,11 +98,11 @@ match_subscript (gfc_array_ref *ar, int if (gfc_match_char (':') == MATCH_NO) goto matched; if (star) { - gfc_error ("Unexpected '*' in coarray subscript at %C"); + gfc_error ("Unexpected %<*%> in coarray subscript at %C"); return MATCH_ERROR; } /* Get an optional end element. Because we've seen the colon, we definitely have a range along this dimension. */ @@ -244,19 +244,19 @@ 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"); return MATCH_ERROR; } 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; } if (ar->codimen >= corank) @@ -311,11 +311,11 @@ resolve_array_bound (gfc_expr *e, int ch return false; 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", &e->where); return false; @@ -750,11 +750,11 @@ gfc_set_array_spec (gfc_symbol *sym, gfc } 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; } if (as->corank) @@ -910,11 +910,11 @@ check_duplicate_iterator (gfc_constructo if (c->iterator == NULL) continue; 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; } } @@ -1660,11 +1660,11 @@ gfc_expand_constructor (gfc_expr *e, boo gfc_free_expr (f); if (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; } return true; Index: gcc/fortran/gfortran.h =================================================================== --- gcc/fortran/gfortran.h (revision 218457) +++ gcc/fortran/gfortran.h (working copy) @@ -2680,10 +2680,11 @@ bool gfc_warning_now (const char *, ...) 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); void gfc_fatal_error (const char *, ...) ATTRIBUTE_NORETURN ATTRIBUTE_GCC_GFC(1,2); void gfc_internal_error (const char *, ...) ATTRIBUTE_NORETURN ATTRIBUTE_GCC_GFC(1,2); @@ -2696,13 +2697,14 @@ bool gfc_notify_std (int, const char *, /* A general purpose syntax error. */ #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); /* arith.c */ Index: gcc/fortran/error.c =================================================================== --- gcc/fortran/error.c (revision 218457) +++ gcc/fortran/error.c (working copy) @@ -50,17 +50,22 @@ static int terminal_width, errors, warni 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. */ void gfc_push_suppress_errors (void) @@ -129,11 +134,10 @@ gfc_error_init_1 (void) void gfc_buffer_error (bool flag) { buffered_p = flag; - pp_warning_buffer.flush_p = !flag; } /* Add a single character to the error buffer or output depending on buffered_p. */ @@ -873,15 +877,15 @@ gfc_warning (int opt, const char *gmsgid 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_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; } @@ -1278,14 +1282,13 @@ gfc_fatal_error (const char *gmsgid, ... void 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; } /* Check to see if any warnings have been saved. If so, print the warning. */ @@ -1296,33 +1299,36 @@ gfc_warning_check (void) if (warning_buffer.flag) { 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; if (warnings_not_errors) goto warning; @@ -1366,10 +1372,63 @@ warning: if (warnings_are_errors) gfc_increment_error_count(); } } +/* 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 warning or for scanner.c, if the location is not properly set up. */ @@ -1423,19 +1482,21 @@ gfc_internal_error (const char *gmsgid, void gfc_clear_error (void) { error_buffer.flag = 0; warnings_not_errors = false; + gfc_clear_pp_buffer (pp_error_buffer); } /* Tests the state of error_flag. */ bool gfc_error_flag_test (void) { - return error_buffer.flag; + return error_buffer.flag + || !gfc_output_buffer_empty_p (pp_error_buffer); } /* Check to see if any errors have been saved. If so, print the error. Returns the state of error_flag. */ @@ -1448,57 +1509,96 @@ gfc_error_check (void) if (error_raised) { 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) { size_t len = strlen (err->message) + 1; gcc_assert (len <= error_buffer.allocated); 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); } /* Report the number of warnings and errors that occurred to the caller. */ @@ -1525,11 +1625,14 @@ gfc_diagnostics_init (void) { diagnostic_starter (global_dc) = gfc_diagnostic_starter; 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 output_buffer (); + pp_warning_buffer->flush_p = false; + pp_error_buffer = new output_buffer (); + pp_error_buffer->flush_p = false; } void gfc_diagnostics_finish (void) { Index: gcc/fortran/data.c =================================================================== --- gcc/fortran/data.c (revision 218457) +++ gcc/fortran/data.c (working copy) @@ -251,13 +251,13 @@ gfc_assign_data_value (gfc_expr *lvalue, continue; } 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; } if (init == NULL) { Index: gcc/fortran/expr.c =================================================================== --- gcc/fortran/expr.c (revision 218457) +++ gcc/fortran/expr.c (working copy) @@ -2202,13 +2202,13 @@ check_alloc_comp_init (gfc_expr *e) comp; comp = comp->next, ctor = gfc_constructor_next (ctor)) { 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; } } return true; @@ -2313,11 +2313,11 @@ check_inquiry (gfc_expr *e, int not_rest if (i == 5 && not_restricted && ap->expr->symtree->n.sym->ts.type == BT_CHARACTER && (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); return MATCH_ERROR; } @@ -2379,12 +2379,12 @@ check_transformational (gfc_expr *e) if (strcmp (functions[i], name) == 0) break; 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; } return check_init_expr_arguments (e); } @@ -2479,11 +2479,11 @@ 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; } @@ -2491,11 +2491,11 @@ gfc_check_init_expr (gfc_expr *e) && (m = check_inquiry (e, 1)) == MATCH_NO && (m = check_null (e)) == MATCH_NO && (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; } @@ -2526,12 +2526,12 @@ gfc_check_init_expr (gfc_expr *e) /* A PARAMETER shall not be used to define itself, i.e. REAL, PARAMETER :: x = transfer(0, x) 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 t = simplify_parameter_variable (e, 0); @@ -2546,39 +2546,39 @@ gfc_check_init_expr (gfc_expr *e) if (e->symtree->n.sym->as) { 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; default: gcc_unreachable(); } } 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); break; @@ -2727,32 +2727,32 @@ external_spec_function (gfc_expr *e) f = e->value.function.esym; 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; } return restricted_args (e->value.function.actual); @@ -2882,25 +2882,25 @@ check_restricted (gfc_expr *e) don't need to jump through hoops to distinguish valid from invalid cases. */ 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; } /* Check reference chain if any. */ @@ -2927,11 +2927,11 @@ check_restricted (gfc_expr *e) { t = true; 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; break; @@ -2990,11 +2990,11 @@ gfc_specification_expr (gfc_expr *e) && !e->value.function.isym && !e->value.function.esym && !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; return false; } @@ -3136,11 +3136,11 @@ gfc_check_assign (gfc_expr *lvalue, gfc_ && sym != gfc_current_ns->parent->proc_name->result) bad_proc = true; 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; } } if (rvalue->rank != 0 && lvalue->rank != rvalue->rank) @@ -3329,11 +3329,11 @@ gfc_check_pointer_assign (gfc_expr *lval } 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; } @@ -3352,11 +3352,11 @@ gfc_check_pointer_assign (gfc_expr *lval if (ref->u.ar.type == AR_FULL) break; 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; } if (!gfc_notify_std (GFC_STD_F2003, "Bounds specification " @@ -3459,30 +3459,30 @@ gfc_check_pointer_assign (gfc_expr *lval gfc_namespace *ns; 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; } } } 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; } /* Check for F08:C729. */ if (attr.flavor == FL_PROCEDURE) { 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; } if (attr.proc == PROC_INTERNAL && @@ -3491,19 +3491,19 @@ gfc_check_pointer_assign (gfc_expr *lval "at %L", rvalue->symtree->name, &rvalue->where)) return false; 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; } } /* 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; } @@ -3578,18 +3578,18 @@ gfc_check_pointer_assign (gfc_expr *lval /* F08:7.2.2.4 (4) */ 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; } if (!gfc_compare_interfaces (s1, s2, name, 0, 1, @@ -3602,11 +3602,11 @@ gfc_check_pointer_assign (gfc_expr *lval /* Check F2008Cor2, C729. */ 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; } @@ -4756,20 +4756,20 @@ gfc_check_vardef_context (gfc_expr* e, b } 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; } if (!pointer && sym->attr.flavor != FL_VARIABLE && !(sym->attr.flavor == FL_PROCEDURE && sym == sym->result) && !(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; } /* Find out whether the expr is a pointer; this also means following @@ -4818,19 +4818,19 @@ gfc_check_vardef_context (gfc_expr* e, b if (check_intentin && sym->attr.intent == INTENT_IN) { 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; } 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; } } @@ -4839,19 +4839,19 @@ gfc_check_vardef_context (gfc_expr* e, b if (sym->attr.is_protected && sym->attr.use_assoc && check_intentin) { 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; } 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; } } @@ -4859,11 +4859,11 @@ gfc_check_vardef_context (gfc_expr* e, b /* Variable not assignable from a PURE procedure but appears in variable definition context. */ 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; } @@ -4918,26 +4918,26 @@ gfc_check_vardef_context (gfc_expr* e, b if (!assoc->variable) { 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); } return false; } /* Target must be allowed to appear in a variable definition context. */ 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, &assoc->target->where); return false; Index: gcc/fortran/scanner.c =================================================================== --- gcc/fortran/scanner.c (revision 218457) +++ gcc/fortran/scanner.c (working copy) @@ -2043,10 +2043,11 @@ load_file (const char *realfilename, con /* Add line. */ 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, because otherwise if the next call creates a new line-map, it will not reserve space for any offset. */ Index: gcc/fortran/resolve.c =================================================================== --- gcc/fortran/resolve.c (revision 218457) +++ gcc/fortran/resolve.c (working copy) @@ -467,28 +467,28 @@ resolve_formal_arglist (gfc_symbol *proc if (sym->attr.pointer || (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; } 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; } /* 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); continue; } @@ -497,21 +497,21 @@ resolve_formal_arglist (gfc_symbol *proc /* Each dummy shall be specified to be scalar. */ if (proc->attr.proc == PROC_ST_FUNCTION) { 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; } if (sym->ts.type == BT_CHARACTER) { 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; } } @@ -565,14 +565,14 @@ resolve_contained_fntype (gfc_symbol *sy t = gfc_set_default_type (sym->result, 0, 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; } } @@ -592,11 +592,11 @@ resolve_contained_fntype (gfc_symbol *sy accordingly. */ bool module_proc; 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"), sym->name, &sym->declared_at); } @@ -982,11 +982,11 @@ resolve_common_blocks (gfc_symtree *comm || strcmp (common_root->n.common->binding_label, gsym->binding_label) != 0)) || (!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, &gsym->where, common_root->n.common->binding_label @@ -996,19 +996,19 @@ resolve_common_blocks (gfc_symtree *comm } 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); return; } 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); return; } @@ -1026,11 +1026,11 @@ resolve_common_blocks (gfc_symtree *comm { gsym = gfc_find_gsymbol (gfc_gsym_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); return; } @@ -1047,19 +1047,19 @@ resolve_common_blocks (gfc_symtree *comm gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym); if (sym == NULL) 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)) gfc_notify_std (GFC_STD_F2003, "COMMON block '%s' at %L " "that is also a function result", sym->name, @@ -1169,11 +1169,11 @@ resolve_structure_cons (gfc_expr *expr, cons->expr->ts = comp->ts; } 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)); t = false; } @@ -1254,11 +1254,11 @@ resolve_structure_cons (gfc_expr *expr, && (CLASS_DATA (comp)->attr.class_pointer || CLASS_DATA (comp)->attr.allocatable)))) { 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); } if (comp->attr.proc_pointer && comp->ts.interface) @@ -1288,11 +1288,11 @@ resolve_structure_cons (gfc_expr *expr, if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1, 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; } } @@ -1304,11 +1304,11 @@ resolve_structure_cons (gfc_expr *expr, if (!a.pointer && !a.target) { 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); } if (init) { @@ -1333,11 +1333,11 @@ resolve_structure_cons (gfc_expr *expr, || gfc_is_coindexed (cons->expr)); if (impure && gfc_pure (NULL)) { 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); } if (impure) gfc_unset_implicit_pure (NULL); @@ -1459,11 +1459,11 @@ check_assumed_size_reference (gfc_symbol && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE) && (e->ref->u.ar.type == AR_FULL)) { 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; } @@ -1519,15 +1519,15 @@ count_specific_procs (gfc_expr *e) sym->name); n++; } 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; } @@ -1657,22 +1657,22 @@ gfc_resolve_intrinsic (gfc_symbol *sym, } else if (isym || (isym = gfc_find_subroutine (sym->name))) { 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; } if (!sym->attr.subroutine && !gfc_add_subroutine(&sym->attr, sym->name, loc)) return false; } 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; } gfc_copy_formal_args_intr (sym, isym, NULL); @@ -1681,11 +1681,11 @@ gfc_resolve_intrinsic (gfc_symbol *sym, sym->attr.elemental = isym->elemental; /* 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.", sym->name, &sym->declared_at, symstd); return false; @@ -1798,19 +1798,19 @@ resolve_actual_arglist (gfc_actual_argli if (gfc_is_intrinsic (sym, sym->attr.subroutine, e->where)) sym->attr.intrinsic = 1; 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); } actual_ok = gfc_intrinsic_actual_ok (sym->name, 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); } if (sym->attr.contained && !sym->attr.use_assoc && sym->ns->proc_name->attr.flavor != FL_MODULE) @@ -1821,11 +1821,11 @@ resolve_actual_arglist (gfc_actual_argli goto cleanup; } 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); } /* Check if a generic interface has a specific procedure @@ -1849,11 +1849,11 @@ resolve_actual_arglist (gfc_actual_argli isym = gfc_find_function (sym->name); 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; } sym->ts = isym->ts; sym->attr.intrinsic = 1; @@ -1870,11 +1870,11 @@ resolve_actual_arglist (gfc_actual_argli if (was_declared (sym) || sym->ns->parent == NULL) goto got_variable; 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; } if (parent_st == NULL) goto got_variable; @@ -2137,12 +2137,12 @@ resolve_elemental_actual (gfc_expr *expr arg = arg->next, eformal = eformal->next) if ((eformal->sym->attr.intent == INTENT_OUT || 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); return false; } @@ -2414,20 +2414,20 @@ resolve_global_procedure (gfc_symbol *sy } } 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; } 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; } if (!pedantic && (gfc_option.allow_std & GFC_STD_GNU)) @@ -2435,11 +2435,11 @@ resolve_global_procedure (gfc_symbol *sy gfc_errors_to_warnings (true); 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; } if (!pedantic @@ -2543,11 +2543,11 @@ generic: /* Last ditch attempt. See if the reference is to an intrinsic 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; } if (intr) @@ -2561,11 +2561,11 @@ generic: m = gfc_intrinsic_func_interface (expr, 0); if (m == MATCH_YES) 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); return false; } @@ -2599,11 +2599,11 @@ resolve_specific_f0 (gfc_symbol *sym, gf { m = gfc_intrinsic_func_interface (expr, 1); 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; } @@ -2650,11 +2650,11 @@ resolve_specific_f (gfc_expr *expr) if (sym == NULL) 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; } @@ -2706,11 +2706,11 @@ set_type: { ts = gfc_get_default_type (sym->name, sym->ns); 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; } else expr->ts = *ts; @@ -2827,19 +2827,19 @@ resolve_function (gfc_expr *expr) && !gfc_resolve_intrinsic (sym, &expr->where)) return false; 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; } /* If this ia a deferred TBP with an abstract interface (which may 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; } /* Switch off assumed size checking and do this again for certain kinds @@ -2878,11 +2878,11 @@ resolve_function (gfc_expr *expr) && !sym->ts.deferred && expr->value.function.esym == NULL && !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; } @@ -2932,11 +2932,11 @@ resolve_function (gfc_expr *expr) if (omp_workshare_flag && 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; } @@ -2986,25 +2986,25 @@ resolve_function (gfc_expr *expr) if (!pure_function (expr, &name) && name) { 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; } gfc_unset_implicit_pure (NULL); @@ -3018,15 +3018,15 @@ resolve_function (gfc_expr *expr) esym = expr->value.function.esym; 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; } } @@ -3061,17 +3061,17 @@ pure_subroutine (gfc_code *c, gfc_symbol { if (gfc_pure (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); } @@ -3132,20 +3132,20 @@ generic: that possesses a matching interface. 14.1.2.4 */ sym = c->symtree->n.sym; 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; } m = gfc_intrinsic_sub_interface (c, 0); 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; } @@ -3176,11 +3176,11 @@ resolve_specific_s0 (gfc_code *c, gfc_sy { m = gfc_intrinsic_sub_interface (c, 1); 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; } @@ -3220,11 +3220,11 @@ resolve_specific_s (gfc_code *c) if (sym == NULL) break; } 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; } @@ -3280,11 +3280,11 @@ resolve_call (gfc_code *c) csym = c->symtree ? c->symtree->n.sym : NULL; 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; } if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns) @@ -3309,25 +3309,25 @@ resolve_call (gfc_code *c) /* If this ia a deferred TBP, c->expr1 will be set. */ if (!c->expr1 && csym) { 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; } /* Subroutines without the RECURSIVE attribution are not allowed to call themselves. */ 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; } } @@ -3400,11 +3400,11 @@ compare_shapes (gfc_expr *op1, gfc_expr { for (i = 0; i < op1->rank; i++) { 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; } } @@ -6674,11 +6674,11 @@ conformable_arrays (gfc_expr *e1, gfc_ex mpz_set (s, tail->u.ar.start[i]->value.integer); } 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; } } @@ -6832,23 +6832,23 @@ resolve_allocate_expr (gfc_expr *e, gfc_ if (code->expr3) { /* 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; } /* Check F03:C632 and restriction following Note 6.18. */ if (code->expr3->rank > 0 && !conformable_arrays (code->expr3, e)) goto failure; /* 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; } @@ -6858,11 +6858,11 @@ resolve_allocate_expr (gfc_expr *e, gfc_ || (code->expr3->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV && 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); goto failure; } @@ -7202,24 +7202,24 @@ resolve_allocate_deallocate (gfc_code *c c) One of them stops, which is also an error. */ while (1) { 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 */ gcc_assert(pr->type == qr->type); if (pr->type == REF_ARRAY) @@ -7418,11 +7418,11 @@ check_case_overlap (gfc_case *list) { /* The cases overlap, or they are the same 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; p = p->right; psize--; @@ -7656,11 +7656,11 @@ resolve_select (gfc_code *code, bool sel /* Intercept the DEFAULT case. */ if (cp->low == NULL && cp->high == NULL) { 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; break; } @@ -8026,11 +8026,11 @@ resolve_select_type (gfc_code *code, gfc if (c->ts.type == BT_UNKNOWN) { /* 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++; continue; } @@ -8584,11 +8584,11 @@ resolve_branch (gfc_st_label *label, gfc return; } 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; } /* Step two: make sure this branch is not a branch to itself ;-) */ @@ -8610,15 +8610,15 @@ resolve_branch (gfc_st_label *label, gfc which is invalid. */ for (stack = cs_base; stack; stack = stack->prev) { 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); } return; } @@ -8633,17 +8633,17 @@ resolve_branch (gfc_st_label *label, gfc break; if (stack->current->op == EXEC_CRITICAL) { /* 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; } } @@ -9999,11 +9999,11 @@ gfc_resolve_code (gfc_code *code, gfc_na { if (code->expr1->ts.type != BT_INTEGER) 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); } else resolve_branch (code->label1, code); @@ -10384,11 +10384,11 @@ gfc_verify_binding_labels (gfc_symbol *s return; } 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. */ sym->binding_label = NULL; @@ -10397,12 +10397,12 @@ gfc_verify_binding_labels (gfc_symbol *s && (strcmp (module, gsym->mod_name) != 0 || strcmp (sym->name, gsym->sym_name) != 0)) { /* 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; } else if ((sym->attr.function || sym->attr.subroutine) @@ -10414,11 +10414,11 @@ gfc_verify_binding_labels (gfc_symbol *s || (module && strcmp (module, gsym->mod_name) != 0))) { /* 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; } } @@ -10914,11 +10914,11 @@ resolve_fl_variable_derived (gfc_symbol gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s); if (s && s->attr.generic) 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, &s->declared_at); return false; @@ -12333,39 +12333,39 @@ resolve_fl_derived0 (gfc_symbol *sym) /* F2008, C442. */ if ((!sym->attr.is_class || c != sym->components) && 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; } /* F2008, C443. */ 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; } /* F2008, C444. */ if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp && (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; } /* 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; } if (c->attr.proc_pointer && c->ts.interface) @@ -12454,12 +12454,12 @@ resolve_fl_derived0 (gfc_symbol *sym) c->tb->pass_arg_num++; } 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; } } @@ -12468,11 +12468,11 @@ resolve_fl_derived0 (gfc_symbol *sym) /* Otherwise, take the first one; there should in fact be at least one. */ 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; return false; } @@ -12484,47 +12484,47 @@ resolve_fl_derived0 (gfc_symbol *sym) if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS) || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != 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; } /* 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; return false; } 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; return false; } 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; return false; } 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); } /* Check type-spec if this is not the parent-type component. */ @@ -12549,11 +12549,11 @@ resolve_fl_derived0 (gfc_symbol *sym) /* If this type is an extension, see if this component has the same name as an inherited type-bound procedure. */ 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; } @@ -12562,22 +12562,22 @@ resolve_fl_derived0 (gfc_symbol *sym) { if (c->ts.u.cl->length == NULL || (!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); return false; } } 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; } @@ -12639,11 +12639,11 @@ resolve_fl_derived0 (gfc_symbol *sym) if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype && 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; } @@ -12651,11 +12651,11 @@ resolve_fl_derived0 (gfc_symbol *sym) && CLASS_DATA (c)->attr.class_pointer && CLASS_DATA (c)->ts.u.derived->components == NULL && !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; } @@ -12663,11 +12663,11 @@ resolve_fl_derived0 (gfc_symbol *sym) if (c->ts.type == BT_CLASS && c->attr.flavor != FL_PROCEDURE && (!c->attr.class_ok || !(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; return false; } @@ -13315,11 +13315,11 @@ resolve_symbol (gfc_symbol *sym) /* First, make sure the variable is declared at the module-level scope (J3/04-007, Section 15.3). */ 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; } else if (sym->common_head != NULL) Index: gcc/fortran/match.c =================================================================== --- gcc/fortran/match.c (revision 218457) +++ gcc/fortran/match.c (working copy) @@ -3546,11 +3546,11 @@ 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; } if (head->next @@ -3583,11 +3583,11 @@ 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; } mold = tmp; @@ -3609,11 +3609,11 @@ alloc_opt_list: goto syntax; /* 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; } /* Check F03:C623, */ @@ -4313,11 +4313,11 @@ gfc_match_common (void) t->name); } 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; } if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL) @@ -4836,20 +4836,22 @@ recursive_stmt_fcn (gfc_expr *e, gfc_sym MATCH_NO that we suppress error message in most cases. */ 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; m = gfc_match_symbol (&sym, 0); 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; if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES) @@ -4857,11 +4859,12 @@ gfc_match_st_function (void) m = gfc_match (" = %e%t", &expr); 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; if (recursive_stmt_fcn (expr, sym)) { @@ -4875,11 +4878,11 @@ gfc_match_st_function (void) return MATCH_ERROR; return MATCH_YES; undo_error: - gfc_pop_error (&old_error); + gfc_pop_error (&old_error, &old_error_1); return MATCH_NO; } /***************** SELECT CASE subroutines ******************/ Index: gcc/fortran/arith.c =================================================================== --- gcc/fortran/arith.c (revision 218457) +++ gcc/fortran/arith.c (working copy) @@ -1913,21 +1913,21 @@ arith_error (arith rc, gfc_typespec *fro gfc_error ("Arithmetic OK converting %s to %s at %L", gfc_typename (from), gfc_typename (to), where); break; case ARITH_OVERFLOW: gfc_error ("Arithmetic overflow converting %s to %s at %L. 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: gfc_error ("Division by zero converting %s to %s at %L", gfc_typename (from), gfc_typename (to), where); Index: gcc/fortran/parse.c =================================================================== --- gcc/fortran/parse.c (revision 218457) +++ gcc/fortran/parse.c (working copy) @@ -105,17 +105,18 @@ match_word_omp_simd (const char *str, ma /* Load symbols from all USE statements encountered in this scoping unit. */ 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; gfc_current_ns->old_equiv = gfc_current_ns->equiv; last_was_use_stmt = false; @@ -2200,11 +2201,11 @@ verify_st_order (st_state *p, gfc_statem p->last_statement = st; return true; 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); return false; } @@ -2577,11 +2578,11 @@ endType: "be a subcomponent of a coarray. (Variables of type %s may " "not have a codimension as already a coarray " "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 " "coarray subcomponent)", lock_comp->name, &lock_comp->loc, sym->name, c->name, &c->loc); @@ -3279,11 +3280,11 @@ parse_if_block (void) unexpected_eof (); 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 (); break; } @@ -4672,14 +4673,14 @@ gfc_global_used (gfc_gsymbol *sym, locus gfc_internal_error ("gfc_global_used(): Bad type"); name = NULL; } 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); } /* Parse a block data program unit. */ Index: gcc/fortran/check.c =================================================================== --- gcc/fortran/check.c (revision 218457) +++ gcc/fortran/check.c (working copy) @@ -41,11 +41,11 @@ static bool 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); return false; } @@ -57,11 +57,11 @@ static bool 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)); return false; } @@ -84,11 +84,11 @@ numeric_check (gfc_expr *e, int n) { e->ts = e->symtree->n.sym->ts; 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); return false; } @@ -99,11 +99,11 @@ numeric_check (gfc_expr *e, int n) static bool 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; } @@ -116,11 +116,11 @@ int_or_real_check (gfc_expr *e, int n) static bool 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; } @@ -133,11 +133,11 @@ real_or_complex_check (gfc_expr *e, int static bool 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; } @@ -162,11 +162,11 @@ kind_check (gfc_expr *k, int n, bt type) if (!scalar_check (k, n)) return false; 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; } @@ -190,11 +190,11 @@ double_check (gfc_expr *d, int n) if (!type_check (d, n, BT_REAL)) return false; 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; } @@ -213,11 +213,11 @@ coarray_check (gfc_expr *e, int n) return true; } 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; } @@ -230,11 +230,11 @@ coarray_check (gfc_expr *e, int n) static bool 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; } @@ -256,11 +256,11 @@ 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); return false; } @@ -277,11 +277,11 @@ nonnegative_check (const char *arg, gfc_ if (expr->expr_type == EXPR_CONSTANT) { 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; } } return true; @@ -309,31 +309,31 @@ less_than_bitsize1 (const char *arg1, gf i2 = -i2; 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; } } if (or_equal) { 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; } } else { 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; } } } @@ -356,11 +356,11 @@ less_than_bitsizekind (const char *arg, i = gfc_validate_kind (BT_INTEGER, k, false); gfc_extract_int (expr, &val); 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; } return true; @@ -383,11 +383,11 @@ less_than_bitsize2 (const char *arg1, gf i2 += i3; i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false); if (i2 > gfc_integer_kinds[i3].bit_size) { gfc_error ("'%s + %s' at %L must be less than or equal " - "to BIT_SIZE('%s')", + "to BIT_SIZE(%qs)", arg2, arg3, &expr2->where, arg1); return false; } } @@ -400,12 +400,12 @@ static bool 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); return false; } @@ -417,11 +417,11 @@ static bool 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); return false; } @@ -432,11 +432,11 @@ rank_check (gfc_expr *e, int n, int rank static bool 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); } /* TODO: Recursive check on nonoptional variables? */ @@ -453,11 +453,11 @@ allocatable_check (gfc_expr *e, int n) symbol_attribute attr; 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; } @@ -471,11 +471,11 @@ static bool 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); return false; } @@ -509,11 +509,11 @@ variable_check (gfc_expr *e, int n, bool break; } 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; } } @@ -530,11 +530,11 @@ variable_check (gfc_expr *e, int n, bool for (ns = gfc_current_ns; ns; ns = ns->parent) if (ns->proc_name == e->symtree->n.sym) 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; } @@ -579,11 +579,11 @@ dim_corank_check (gfc_expr *dim, gfc_exp corank = gfc_get_corank (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; } @@ -629,11 +629,11 @@ dim_rank_check (gfc_expr *dim, gfc_expr } 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; } @@ -854,11 +854,11 @@ gfc_check_a_p (gfc_expr *a, gfc_expr *p) if (!int_or_real_check (a, 0)) return false; 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); return false; } @@ -899,20 +899,20 @@ gfc_check_associated (gfc_expr *pointer, attr1 = gfc_expr_attr (pointer); 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; } /* 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; } @@ -926,29 +926,29 @@ gfc_check_associated (gfc_expr *pointer, if (target->expr_type == EXPR_VARIABLE || target->expr_type == EXPR_FUNCTION) 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); return false; } 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; } /* 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; } @@ -972,11 +972,11 @@ gfc_check_associated (gfc_expr *pointer, return t; 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; } @@ -1029,11 +1029,11 @@ gfc_check_atomic (gfc_expr *atom, int at return false; } 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); return false; } @@ -1375,20 +1375,20 @@ gfc_check_cmplx (gfc_expr *x, gfc_expr * if (!numeric_check (y, 1)) return false; 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); return false; } 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); return false; } @@ -1573,11 +1573,11 @@ gfc_check_co_reduce (gfc_expr *a, gfc_ex if (sym->result->ts.type == BT_UNKNOWN) gfc_set_default_type (sym->result, 0, NULL); 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)); return false; } @@ -1653,20 +1653,20 @@ gfc_check_co_reduce (gfc_expr *a, gfc_ex if (actual_size && ((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; } } return true; @@ -1678,14 +1678,14 @@ gfc_check_co_minmax (gfc_expr *a, gfc_ex gfc_expr *errmsg) { 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); } @@ -1773,11 +1773,11 @@ gfc_check_cshift (gfc_expr *array, gfc_e for (i = 0, j = 0; i < array->rank; i++) if (i != d - 1) { 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, mpz_get_si (array->shape[i]), mpz_get_si (shift->shape[j])); @@ -1788,11 +1788,11 @@ gfc_check_cshift (gfc_expr *array, gfc_e } } } 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; } @@ -1832,20 +1832,20 @@ gfc_check_dcmplx (gfc_expr *x, gfc_expr if (!numeric_check (y, 1)) return false; 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); return false; } 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); return false; } @@ -1891,11 +1891,11 @@ gfc_check_dot_product (gfc_expr *vector_ if (!numeric_check (vector_b, 1)) return false; 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; } @@ -1905,11 +1905,11 @@ gfc_check_dot_product (gfc_expr *vector_ if (!rank_check (vector_b, 1, 1)) return false; 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; } @@ -1924,19 +1924,19 @@ gfc_check_dprod (gfc_expr *x, gfc_expr * || !type_check (y, 1, BT_REAL)) return false; 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; } 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; } @@ -1953,12 +1953,12 @@ gfc_check_dshift (gfc_expr *i, gfc_expr if (!type_check (j, 1, BT_INTEGER)) return false; 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; } if (!i->is_boz && !j->is_boz && !same_type_check (i, 0, j, 1)) return false; @@ -2023,11 +2023,11 @@ gfc_check_eoshift (gfc_expr *array, gfc_ for (i = 0, j = 0; i < array->rank; i++) if (i != d - 1) { 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, mpz_get_si (array->shape[i]), mpz_get_si (shift->shape[j])); @@ -2038,11 +2038,11 @@ gfc_check_eoshift (gfc_expr *array, gfc_ } } } 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; } @@ -2066,11 +2066,11 @@ gfc_check_eoshift (gfc_expr *array, gfc_ gfc_current_intrinsic)) return false; } 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); return false; } @@ -2367,12 +2367,12 @@ gfc_check_index (gfc_expr *string, gfc_e gfc_current_intrinsic, &kind->where)) return false; 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; } @@ -2469,13 +2469,13 @@ gfc_check_ishftc (gfc_expr *i, gfc_expr if (i2 < 0) i2 = -i2; 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; } } } } @@ -2530,11 +2530,11 @@ gfc_check_kill_sub (gfc_expr *pid, gfc_e bool 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; } @@ -2741,11 +2741,11 @@ min_max_args (gfc_actual_arglist *args) int i, j, nargs, *nlabels, nlabelless; bool a1 = false, a2 = false; 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; } if (!args->name) @@ -2789,11 +2789,11 @@ min_max_args (gfc_actual_arglist *args) else nlabelless++; 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; } @@ -2804,16 +2804,16 @@ min_max_args (gfc_actual_arglist *args) goto duplicate; 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; } @@ -2838,11 +2838,11 @@ check_rest (bt type, int kind, gfc_actua "kinds at %L", &x->where)) return false; } 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; } } @@ -2876,11 +2876,11 @@ gfc_check_min_max (gfc_actual_arglist *a gfc_current_intrinsic, &x->where)) return false; } 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; } return check_rest (x->ts.type, x->ts.kind, arg); @@ -2926,28 +2926,28 @@ gfc_check_malloc (gfc_expr *size) bool 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; } 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; } 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; } @@ -2957,12 +2957,12 @@ gfc_check_matmul (gfc_expr *matrix_a, gf if (!rank_check (matrix_b, 1, 2)) return false; /* 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; } break; @@ -2976,20 +2976,20 @@ gfc_check_matmul (gfc_expr *matrix_a, gf /* matrix_b has rank 1 or 2 here. Common check for the cases - matrix_a has shape (n,m) and matrix_b has shape (m, k) - 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; } 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; } @@ -3160,11 +3160,11 @@ gfc_check_mask (gfc_expr *i, gfc_expr *k bool 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; } @@ -3335,11 +3335,11 @@ gfc_check_null (gfc_expr *mold) attr = gfc_variable_attr (mold, NULL); 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); return false; } @@ -3350,11 +3350,11 @@ gfc_check_null (gfc_expr *mold) return false; /* 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; } @@ -3422,13 +3422,13 @@ gfc_check_pack (gfc_expr *array, gfc_exp else if (mask->expr_type == EXPR_CONSTANT && mask->value.logical) mask_true_values = mpz_get_si (array_size); 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, mpz_get_si (vector_size), mask_true_values); return false; @@ -3480,19 +3480,19 @@ gfc_check_present (gfc_expr *a) return false; 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; } 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); return false; } @@ -3507,12 +3507,12 @@ gfc_check_present (gfc_expr *a) && !(a->ref->next == NULL && a->ref->type == REF_ARRAY && (a->ref->u.ar.type == AR_FULL || (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; } return true; @@ -3669,11 +3669,11 @@ gfc_check_reshape (gfc_expr *source, gfc shape_size = mpz_get_ui (size); mpz_clear (size); 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; } else if (shape_size > GFC_MAX_DIMENSIONS) @@ -3693,11 +3693,11 @@ gfc_check_reshape (gfc_expr *source, gfc continue; 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); return false; } @@ -3733,11 +3733,11 @@ gfc_check_reshape (gfc_expr *source, gfc order_size = mpz_get_ui (size); mpz_clear (size); 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, order_size, shape_size); return false; @@ -3751,20 +3751,20 @@ gfc_check_reshape (gfc_expr *source, gfc gfc_extract_int (e, &dim); 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); return false; } 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, gfc_current_intrinsic, &e->where, dim); return false; @@ -3813,40 +3813,40 @@ gfc_check_reshape (gfc_expr *source, gfc bool 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, &a->where, gfc_typename (&a->ts)); return false; } 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); return false; } 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, &b->where, gfc_typename (&b->ts)); return false; } 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); return false; } @@ -4084,11 +4084,11 @@ gfc_check_size (gfc_expr *array, gfc_exp bool 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; } @@ -4097,22 +4097,22 @@ gfc_check_sizeof (gfc_expr *arg) && (arg->symtree->n.sym->as == NULL || (arg->symtree->n.sym->as->type != AS_ASSUMED_SHAPE && 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; } if (arg->rank && arg->expr_type == EXPR_VARIABLE && arg->symtree->n.sym->as != NULL && 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; } @@ -4227,20 +4227,20 @@ gfc_check_c_sizeof (gfc_expr *arg) { const char *msg; 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); return false; } 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); return false; } @@ -4248,11 +4248,11 @@ gfc_check_c_sizeof (gfc_expr *arg) if (arg->rank && arg->expr_type == EXPR_VARIABLE && arg->symtree->n.sym->as != NULL && 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; } @@ -4447,11 +4447,11 @@ gfc_check_c_funloc (gfc_expr *x) gfc_namespace *ns = gfc_current_ns; 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; } } @@ -4573,11 +4573,11 @@ gfc_check_sngl (gfc_expr *a) bool 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); return false; } @@ -4592,11 +4592,11 @@ gfc_check_spread (gfc_expr *source, gfc_ if (dim && dim->expr_type == EXPR_CONSTANT && (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; } @@ -5187,13 +5187,13 @@ gfc_check_unpack (gfc_expr *vector, gfc_ mask_ctor = gfc_constructor_next (mask_ctor); } 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); return false; } @@ -5201,12 +5201,12 @@ gfc_check_unpack (gfc_expr *vector, gfc_ mpz_clear (vector_size); } 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; } @@ -5214,11 +5214,11 @@ gfc_check_unpack (gfc_expr *vector, gfc_ { int i; 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, &field->where); } @@ -5472,11 +5472,11 @@ gfc_check_random_seed (gfc_expr *size, g if (!kind_value_check (put, 1, gfc_default_integer_kind)) return false; 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); } @@ -5504,11 +5504,11 @@ gfc_check_random_seed (gfc_expr *size, g if (!kind_value_check (get, 2, gfc_default_integer_kind)) return false; 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); } @@ -5815,11 +5815,11 @@ gfc_check_getarg (gfc_expr *pos, gfc_exp if (!type_check (pos, 0, BT_INTEGER)) return false; 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); return false; } @@ -6167,27 +6167,27 @@ gfc_check_system_sub (gfc_expr *cmd, gfc bool 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; } 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; } 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); return false; } @@ -6205,19 +6205,19 @@ gfc_check_and (gfc_expr *i, gfc_expr *j) bool 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; } 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; } @@ -6230,11 +6230,11 @@ gfc_check_storage_size (gfc_expr *a, gfc if (!scalar_check (kind, 1)) return false; 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; } Index: gcc/fortran/primary.c =================================================================== --- gcc/fortran/primary.c (revision 218457) +++ gcc/fortran/primary.c (working copy) @@ -1272,11 +1272,12 @@ match_complex_part (gfc_expr **result) 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; match m; @@ -1285,22 +1286,22 @@ match_complex_constant (gfc_expr **resul m = gfc_match_char ('('); 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; } /* If m is error, then something was wrong with the real part and we @@ -1308,14 +1309,14 @@ match_complex_constant (gfc_expr **resul ambiguous case here is the start of an iterator list of some sort. These sort of lists are matched prior to coming here. */ 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) goto syntax; if (m == MATCH_ERROR) @@ -2491,11 +2492,11 @@ gfc_convert_to_structure_constructor (gf comp_iter = comp_iter->next) { 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); goto cleanup; }