From 716da296ca061b7eae92924e6cec959133ce9b67 Mon Sep 17 00:00:00 2001 From: manu Date: Thu, 11 Dec 2014 15:13:33 +0000 Subject: [PATCH] gcc/ChangeLog: MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit 2014-12-11 Manuel López-Ibáñez 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-11 Manuel López-Ibáñez * gfortran.dg/do_iterator.f90: Remove bogus dg-warning. gcc/fortran/ChangeLog: 2014-12-11 Manuel López-Ibáñez PR fortran/44054 * error.c (pp_error_buffer): New static variable. (pp_warning_buffer): Make it a pointer. (gfc_output_buffer_empty_p): New. (gfc_error_init_1): Call gfc_buffer_error. (gfc_buffer_error): Do not use pp_warning_buffer.flush_p as the buffered_p flag. (gfc_clear_warning): Likewise. (gfc_warning_check): Call gfc_clear_warning. Only check the new pp_warning_buffer if the old warning_buffer was empty. Call diagnostic_action_after_output. (gfc_error_1): Renamed from gfc_error. (gfc_error): New. (gfc_clear_error): Clear also pp_error_buffer. (gfc_error_flag_test): Check also pp_error_buffer. (gfc_error_check): Likewise. Only check the new pp_error_buffer if the old error_buffer was empty. (gfc_move_output_buffer_from_to): New. (gfc_push_error): Use it here. Take also an output_buffer as argument. (gfc_pop_error): Likewise. (gfc_free_error): Likewise. (gfc_diagnostics_init): Use XNEW and placement-new to init pp_error_buffer and pp_warning_buffer. Set flush_p to false for both pp_warning_buffer and pp_error_buffer. * Update gfc_push_error, gfc_pop_error and gfc_free_error calls according to the above changes. * Use gfc_error_1 for all gfc_error calls that use multiple locations. * Use %qs instead of '%s' for many gfc_error calls. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@218627 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ChangeLog | 17 ++++ gcc/diagnostic.c | 20 ++-- gcc/diagnostic.h | 1 + gcc/fortran/ChangeLog | 33 ++++++ gcc/fortran/arith.c | 6 +- gcc/fortran/array.c | 14 +-- gcc/fortran/check.c | 244 ++++++++++++++++++++++----------------------- gcc/fortran/class.c | 6 +- gcc/fortran/data.c | 6 +- gcc/fortran/decl.c | 112 ++++++++++----------- gcc/fortran/error.c | 151 +++++++++++++++++++++++----- gcc/fortran/expr.c | 90 ++++++++--------- gcc/fortran/gfortran.h | 8 +- gcc/fortran/interface.c | 164 +++++++++++++++--------------- gcc/fortran/intrinsic.c | 14 +-- gcc/fortran/match.c | 19 ++-- gcc/fortran/openmp.c | 32 +++--- gcc/fortran/parse.c | 17 ++-- gcc/fortran/primary.c | 15 +-- gcc/fortran/resolve.c | 220 ++++++++++++++++++++-------------------- gcc/fortran/scanner.c | 1 + gcc/fortran/symbol.c | 30 +++--- gcc/fortran/trans-common.c | 2 +- gcc/pretty-print.c | 16 +-- gcc/pretty-print.h | 32 ++++++ gcc/testsuite/ChangeLog | 4 + 26 files changed, 730 insertions(+), 544 deletions(-) diff --git a/gcc/ChangeLog b/gcc/ChangeLog index dd50966..d689067 100644 --- a/gcc/ChangeLog +++ b/gcc/ChangeLog @@ -1,3 +1,20 @@ +2014-12-11 Manuel López-Ibáñez + + PR fortran/44054 + * diagnostic.c (diagnostic_action_after_output): Make it extern. + Take diagnostic_t argument instead of diagnostic_info. Count also + DK_WERROR towards max_errors. + (diagnostic_report_diagnostic): Update call according to the above. + (error_recursion): Likewise. + * diagnostic.h (diagnostic_action_after_output): Declare. + * pretty-print.c (pp_formatted_text_data): Delete. + (pp_append_r): Call output_buffer_append_r. + (pp_formatted_text): Call output_buffer_formatted_text. + (pp_last_position_in_text): Call output_buffer_last_position_in_text. + * pretty-print.h (output_buffer_formatted_text): New. + (output_buffer_append_r): New. + (output_buffer_last_position_in_text): New. + 2014-12-11 Kyrylo Tkachov kyrylo.tkachov@arm.com * config/aarch64/aarch64.c (aarch64_parse_extension): Update error diff --git a/gcc/diagnostic.c b/gcc/diagnostic.c index 2c2477f..7cbdb79 100644 --- a/gcc/diagnostic.c +++ b/gcc/diagnostic.c @@ -51,8 +51,6 @@ along with GCC; see the file COPYING3. If not see /* Prototypes. */ static void error_recursion (diagnostic_context *) ATTRIBUTE_NORETURN; -static void diagnostic_action_after_output (diagnostic_context *, - diagnostic_info *); static void real_abort (void) ATTRIBUTE_NORETURN; /* Name of program invoked, sans directories. */ @@ -483,11 +481,11 @@ bt_err_callback (void *data ATTRIBUTE_UNUSED, const char *msg, int errnum) /* Take any action which is expected to happen after the diagnostic is written out. This function does not always return. */ -static void +void diagnostic_action_after_output (diagnostic_context *context, - diagnostic_info *diagnostic) + diagnostic_t diag_kind) { - switch (diagnostic->kind) + switch (diag_kind) { case DK_DEBUG: case DK_NOTE: @@ -507,7 +505,8 @@ diagnostic_action_after_output (diagnostic_context *context, } if (context->max_errors != 0 && ((unsigned) (diagnostic_kind_count (context, DK_ERROR) - + diagnostic_kind_count (context, DK_SORRY)) + + diagnostic_kind_count (context, DK_SORRY) + + diagnostic_kind_count (context, DK_WERROR)) >= context->max_errors)) { fnotice (stderr, @@ -864,7 +863,7 @@ diagnostic_report_diagnostic (diagnostic_context *context, (*diagnostic_starter (context)) (context, diagnostic); pp_output_formatted_text (context->printer); (*diagnostic_finalizer (context)) (context, diagnostic); - diagnostic_action_after_output (context, diagnostic); + diagnostic_action_after_output (context, diagnostic->kind); diagnostic->message.format_spec = saved_format_spec; diagnostic->x_data = NULL; @@ -1264,8 +1263,6 @@ fnotice (FILE *file, const char *cmsgid, ...) static void error_recursion (diagnostic_context *context) { - diagnostic_info diagnostic; - if (context->lock < 3) pp_newline_and_flush (context->printer); @@ -1273,9 +1270,8 @@ error_recursion (diagnostic_context *context) "Internal compiler error: Error reporting routines re-entered.\n"); /* Call diagnostic_action_after_output to get the "please submit a bug - report" message. It only looks at the kind field of diagnostic_info. */ - diagnostic.kind = DK_ICE; - diagnostic_action_after_output (context, &diagnostic); + report" message. */ + diagnostic_action_after_output (context, DK_ICE); /* Do not use gcc_unreachable here; that goes through internal_error and therefore would cause infinite recursion. */ diff --git a/gcc/diagnostic.h b/gcc/diagnostic.h index 0c65deb..e699db8 100644 --- a/gcc/diagnostic.h +++ b/gcc/diagnostic.h @@ -294,6 +294,7 @@ extern char *diagnostic_build_prefix (diagnostic_context *, const diagnostic_inf void default_diagnostic_starter (diagnostic_context *, diagnostic_info *); void default_diagnostic_finalizer (diagnostic_context *, diagnostic_info *); void diagnostic_set_caret_max_width (diagnostic_context *context, int value); +void diagnostic_action_after_output (diagnostic_context *, diagnostic_t); void diagnostic_file_cache_fini (void); diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 8534a45..554474c 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,36 @@ +2014-12-11 Manuel López-Ibáñez + + PR fortran/44054 + * error.c (pp_error_buffer): New static variable. + (pp_warning_buffer): Make it a pointer. + (gfc_output_buffer_empty_p): New. + (gfc_error_init_1): Call gfc_buffer_error. + (gfc_buffer_error): Do not use pp_warning_buffer.flush_p as the + buffered_p flag. + (gfc_clear_warning): Likewise. + (gfc_warning_check): Call gfc_clear_warning. Only check the new + pp_warning_buffer if the old warning_buffer was empty. Call + diagnostic_action_after_output. + (gfc_error_1): Renamed from gfc_error. + (gfc_error): New. + (gfc_clear_error): Clear also pp_error_buffer. + (gfc_error_flag_test): Check also pp_error_buffer. + (gfc_error_check): Likewise. Only check the new pp_error_buffer + if the old error_buffer was empty. + (gfc_move_output_buffer_from_to): New. + (gfc_push_error): Use it here. Take also an output_buffer as argument. + (gfc_pop_error): Likewise. + (gfc_free_error): Likewise. + (gfc_diagnostics_init): Use XNEW and placement-new to init + pp_error_buffer and pp_warning_buffer. Set flush_p to false for + both pp_warning_buffer and pp_error_buffer. + + * Update gfc_push_error, gfc_pop_error and gfc_free_error calls + according to the above changes. + * Use gfc_error_1 for all gfc_error calls that use multiple + locations. + * Use %qs instead of '%s' for many gfc_error calls. + 2014-12-11 Tobias Burnus Manuel López-Ibáñez diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c index c692e62..6394547 100644 --- a/gcc/fortran/arith.c +++ b/gcc/fortran/arith.c @@ -1915,17 +1915,17 @@ arith_error (arith rc, gfc_typespec *from, gfc_typespec *to, locus *where) break; case ARITH_OVERFLOW: gfc_error ("Arithmetic overflow converting %s to %s at %L. This check " - "can be disabled with the option -fno-range-check", + "can be disabled with the option %<-fno-range-check%>", gfc_typename (from), gfc_typename (to), where); break; case ARITH_UNDERFLOW: gfc_error ("Arithmetic underflow converting %s to %s at %L. This check " - "can be disabled with the option -fno-range-check", + "can be disabled with the option %<-fno-range-check%>", gfc_typename (from), gfc_typename (to), where); break; case ARITH_NAN: gfc_error ("Arithmetic NaN converting %s to %s at %L. This check " - "can be disabled with the option -fno-range-check", + "can be disabled with the option %<-fno-range-check%>", gfc_typename (from), gfc_typename (to), where); break; case ARITH_DIV0: diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 159e626..e27ca01 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -100,7 +100,7 @@ match_subscript (gfc_array_ref *ar, int init, bool match_star) if (star) { - gfc_error ("Unexpected '*' in coarray subscript at %C"); + gfc_error ("Unexpected %<*%> in coarray subscript at %C"); return MATCH_ERROR; } @@ -246,7 +246,7 @@ coarray: if (gfc_match_char (',') != MATCH_YES) { if (gfc_match_char ('*') == MATCH_YES) - gfc_error ("Unexpected '*' for codimension %d of %d at %C", + gfc_error ("Unexpected %<*%> for codimension %d of %d at %C", ar->codimen + 1, corank); else gfc_error ("Invalid form of coarray reference at %C"); @@ -254,7 +254,7 @@ coarray: } else if (ar->dimen_type[ar->codimen + ar->dimen] == DIMEN_STAR) { - gfc_error ("Unexpected '*' for codimension %d of %d at %C", + gfc_error ("Unexpected %<*%> for codimension %d of %d at %C", ar->codimen + 1, corank); return MATCH_ERROR; } @@ -313,7 +313,7 @@ resolve_array_bound (gfc_expr *e, int check_constant) if (check_constant && !gfc_is_constant_expr (e)) { if (e->expr_type == EXPR_VARIABLE) - gfc_error ("Variable '%s' at %L in this context must be constant", + gfc_error ("Variable %qs at %L in this context must be constant", e->symtree->n.sym->name, &e->where); else gfc_error ("Expression at %L in this context must be constant", @@ -752,7 +752,7 @@ gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc) if ((sym->as->type == AS_ASSUMED_RANK && as->corank) || (as->type == AS_ASSUMED_RANK && sym->as->corank)) { - gfc_error ("The assumed-rank array '%s' at %L shall not have a " + gfc_error ("The assumed-rank array %qs at %L shall not have a " "codimension", sym->name, error_loc); return false; } @@ -912,7 +912,7 @@ check_duplicate_iterator (gfc_constructor_base base, gfc_symbol *master) if (c->iterator->var->symtree->n.sym == master) { - gfc_error ("DO-iterator '%s' at %L is inside iterator of the " + gfc_error ("DO-iterator %qs at %L is inside iterator of the " "same name", master->name, &c->where); return 1; @@ -1662,7 +1662,7 @@ gfc_expand_constructor (gfc_expr *e, bool fatal) { gfc_error ("The number of elements in the array constructor " "at %L requires an increase of the allowed %d " - "upper limit. See -fmax-array-constructor " + "upper limit. See %<-fmax-array-constructor%> " "option", &e->where, gfc_option.flag_max_array_constructor); return false; diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index c3f78e1..ef40e66 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -43,7 +43,7 @@ scalar_check (gfc_expr *e, int n) if (e->rank == 0) return true; - gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar", + gfc_error ("%qs argument of %qs intrinsic at %L must be a scalar", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); @@ -59,7 +59,7 @@ type_check (gfc_expr *e, int n, bt type) if (e->ts.type == type) return true; - gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s", + gfc_error ("%qs argument of %qs intrinsic at %L must be %s", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where, gfc_basic_typename (type)); @@ -86,7 +86,7 @@ numeric_check (gfc_expr *e, int n) return true; } - gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type", + gfc_error ("%qs argument of %qs intrinsic at %L must be a numeric type", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); @@ -101,7 +101,7 @@ int_or_real_check (gfc_expr *e, int n) { if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER " + gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER " "or REAL", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); return false; @@ -118,7 +118,7 @@ real_or_complex_check (gfc_expr *e, int n) { if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be REAL " + gfc_error ("%qs argument of %qs intrinsic at %L must be REAL " "or COMPLEX", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); return false; @@ -135,7 +135,7 @@ int_or_proc_check (gfc_expr *e, int n) { if (e->ts.type != BT_INTEGER && e->ts.type != BT_PROCEDURE) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER " + gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER " "or PROCEDURE", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); return false; @@ -164,7 +164,7 @@ kind_check (gfc_expr *k, int n, bt type) if (!gfc_check_init_expr (k)) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant", + gfc_error ("%qs argument of %qs intrinsic at %L must be a constant", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &k->where); return false; @@ -192,7 +192,7 @@ double_check (gfc_expr *d, int n) if (d->ts.kind != gfc_default_double_kind) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be double " + gfc_error ("%qs argument of %qs intrinsic at %L must be double " "precision", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &d->where); return false; @@ -215,7 +215,7 @@ coarray_check (gfc_expr *e, int n) if (!gfc_is_coarray (e)) { - gfc_error ("Expected coarray variable as '%s' argument to the %s " + gfc_error ("Expected coarray variable as %qs argument to the %s " "intrinsic at %L", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); return false; @@ -232,7 +232,7 @@ logical_array_check (gfc_expr *array, int n) { if (array->ts.type != BT_LOGICAL || array->rank == 0) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be a logical " + gfc_error ("%qs argument of %qs intrinsic at %L must be a logical " "array", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &array->where); return false; @@ -258,7 +258,7 @@ array_check (gfc_expr *e, int n) if (e->rank != 0 && e->ts.type != BT_PROCEDURE) return true; - gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array", + gfc_error ("%qs argument of %qs intrinsic at %L must be an array", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); @@ -279,7 +279,7 @@ nonnegative_check (const char *arg, gfc_expr *expr) gfc_extract_int (expr, &i); if (i < 0) { - gfc_error ("'%s' at %L must be nonnegative", arg, &expr->where); + gfc_error ("%qs at %L must be nonnegative", arg, &expr->where); return false; } } @@ -311,7 +311,7 @@ less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2, if (i2 > gfc_integer_kinds[i3].bit_size) { gfc_error ("The absolute value of SHIFT at %L must be less " - "than or equal to BIT_SIZE('%s')", + "than or equal to BIT_SIZE(%qs)", &expr2->where, arg1); return false; } @@ -321,8 +321,8 @@ less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2, { if (i2 > gfc_integer_kinds[i3].bit_size) { - gfc_error ("'%s' at %L must be less than " - "or equal to BIT_SIZE('%s')", + gfc_error ("%qs at %L must be less than " + "or equal to BIT_SIZE(%qs)", arg2, &expr2->where, arg1); return false; } @@ -331,7 +331,7 @@ less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2, { if (i2 >= gfc_integer_kinds[i3].bit_size) { - gfc_error ("'%s' at %L must be less than BIT_SIZE('%s')", + gfc_error ("%qs at %L must be less than BIT_SIZE(%qs)", arg2, &expr2->where, arg1); return false; } @@ -358,7 +358,7 @@ less_than_bitsizekind (const char *arg, gfc_expr *expr, int k) if (val > gfc_integer_kinds[i].bit_size) { - gfc_error ("'%s' at %L must be less than or equal to the BIT_SIZE of " + gfc_error ("%qs at %L must be less than or equal to the BIT_SIZE of " "INTEGER(KIND=%d)", arg, &expr->where, k); return false; } @@ -385,7 +385,7 @@ less_than_bitsize2 (const char *arg1, gfc_expr *expr1, const char *arg2, if (i2 > gfc_integer_kinds[i3].bit_size) { gfc_error ("'%s + %s' at %L must be less than or equal " - "to BIT_SIZE('%s')", + "to BIT_SIZE(%qs)", arg2, arg3, &expr2->where, arg1); return false; } @@ -402,8 +402,8 @@ same_type_check (gfc_expr *e, int n, gfc_expr *f, int m) if (gfc_compare_types (&e->ts, &f->ts)) return true; - gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type " - "and kind as '%s'", gfc_current_intrinsic_arg[m]->name, + gfc_error ("%qs argument of %qs intrinsic at %L must be the same type " + "and kind as %qs", gfc_current_intrinsic_arg[m]->name, gfc_current_intrinsic, &f->where, gfc_current_intrinsic_arg[n]->name); @@ -419,7 +419,7 @@ rank_check (gfc_expr *e, int n, int rank) if (e->rank == rank) return true; - gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d", + gfc_error ("%qs argument of %qs intrinsic at %L must be of rank %d", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where, rank); @@ -434,7 +434,7 @@ nonoptional_check (gfc_expr *e, int n) { if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL", + gfc_error ("%qs argument of %qs intrinsic at %L must not be OPTIONAL", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); } @@ -455,7 +455,7 @@ allocatable_check (gfc_expr *e, int n) attr = gfc_variable_attr (e, NULL); if (!attr.allocatable || attr.associate_var) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE", + gfc_error ("%qs argument of %qs intrinsic at %L must be ALLOCATABLE", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); return false; @@ -473,7 +473,7 @@ kind_value_check (gfc_expr *e, int n, int k) if (e->ts.kind == k) return true; - gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d", + gfc_error ("%qs argument of %qs intrinsic at %L must be of kind %d", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where, k); @@ -511,7 +511,7 @@ variable_check (gfc_expr *e, int n, bool allow_proc) if (!ref) { - gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be " + gfc_error ("%qs argument of %qs intrinsic at %L cannot be " "INTENT(IN)", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); return false; @@ -532,7 +532,7 @@ variable_check (gfc_expr *e, int n, bool allow_proc) return true; } - gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable", + gfc_error ("%qs argument of %qs intrinsic at %L must be a variable", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); return false; @@ -581,7 +581,7 @@ dim_corank_check (gfc_expr *dim, gfc_expr *array) if (mpz_cmp_ui (dim->value.integer, 1) < 0 || mpz_cmp_ui (dim->value.integer, corank) > 0) { - gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid " + gfc_error ("'dim' argument of %qs intrinsic at %L is not a valid " "codimension index", gfc_current_intrinsic, &dim->where); return false; @@ -631,7 +631,7 @@ dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed) if (mpz_cmp_ui (dim->value.integer, 1) < 0 || mpz_cmp_ui (dim->value.integer, rank) > 0) { - gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid " + gfc_error ("'dim' argument of %qs intrinsic at %L is not a valid " "dimension index", gfc_current_intrinsic, &dim->where); return false; @@ -856,7 +856,7 @@ gfc_check_a_p (gfc_expr *a, gfc_expr *p) if (a->ts.type != p->ts.type) { - gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must " + gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must " "have the same type", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &p->where); @@ -901,7 +901,7 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target) if (!attr1.pointer && !attr1.proc_pointer) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER", + gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &pointer->where); return false; @@ -910,7 +910,7 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target) /* F2008, C1242. */ if (attr1.pointer && gfc_is_coindexed (pointer)) { - gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be " + gfc_error ("%qs argument of %qs intrinsic at %L shall not be " "coindexed", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &pointer->where); return false; @@ -928,7 +928,7 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target) attr2 = gfc_expr_attr (target); else { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer " + gfc_error ("%qs argument of %qs intrinsic at %L must be a pointer " "or target VARIABLE or FUNCTION", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &target->where); @@ -937,7 +937,7 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target) if (attr1.pointer && !attr2.pointer && !attr2.target) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER " + gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER " "or a TARGET", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &target->where); return false; @@ -946,7 +946,7 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target) /* F2008, C1242. */ if (attr1.pointer && gfc_is_coindexed (target)) { - gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be " + gfc_error ("%qs argument of %qs intrinsic at %L shall not be " "coindexed", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &target->where); return false; @@ -974,7 +974,7 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target) null_arg: gfc_error ("NULL pointer at %L is not permitted as actual argument " - "of '%s' intrinsic function", where, gfc_current_intrinsic); + "of %qs intrinsic function", where, gfc_current_intrinsic); return false; } @@ -1031,7 +1031,7 @@ gfc_check_atomic (gfc_expr *atom, int atom_no, gfc_expr *value, int val_no, if (atom->ts.type != value->ts.type) { - gfc_error ("'%s' argument of '%s' intrinsic at %L shall have the same " + gfc_error_1 ("'%s' argument of '%s' intrinsic at %L shall have the same " "type as '%s' at %L", gfc_current_intrinsic_arg[val_no]->name, gfc_current_intrinsic, &value->where, gfc_current_intrinsic_arg[atom_no]->name, &atom->where); @@ -1377,7 +1377,7 @@ gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind) if (x->ts.type == BT_COMPLEX) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must not be " + gfc_error ("%qs argument of %qs intrinsic at %L must not be " "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &y->where); @@ -1386,7 +1386,7 @@ gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind) if (y->ts.type == BT_COMPLEX) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type " + gfc_error ("%qs argument of %qs intrinsic at %L must have a type " "of either REAL or INTEGER", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &y->where); @@ -1575,7 +1575,7 @@ gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image, if (!gfc_compare_types (&a->ts, &sym->result->ts)) { - gfc_error ("A argument at %L has type %s but the function passed as " + gfc_error_1 ("A argument at %L has type %s but the function passed as " "OPERATOR at %L returns %s", &a->where, gfc_typename (&a->ts), &op->where, gfc_typename (&sym->result->ts)); @@ -1655,16 +1655,16 @@ gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image, && ((formal_size1 && actual_size != formal_size1) || (formal_size2 && actual_size != formal_size2))) { - gfc_error ("The character length of the A argument at %L and of the " - "arguments of the OPERATOR at %L shall be the same", + gfc_error_1 ("The character length of the A argument at %L and of the " + "arguments of the OPERATOR at %L shall be the same", &a->where, &op->where); return false; } if (actual_size && result_size && actual_size != result_size) { - gfc_error ("The character length of the A argument at %L and of the " - "function result of the OPERATOR at %L shall be the same", - &a->where, &op->where); + gfc_error_1 ("The character length of the A argument at %L and of the " + "function result of the OPERATOR at %L shall be the same", + &a->where, &op->where); return false; } } @@ -1680,10 +1680,10 @@ gfc_check_co_minmax (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat, if (a->ts.type != BT_INTEGER && a->ts.type != BT_REAL && a->ts.type != BT_CHARACTER) { - gfc_error ("'%s' argument of '%s' intrinsic at %L shall be of type " - "integer, real or character", - gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, - &a->where); + gfc_error_1 ("'%s' argument of '%s' intrinsic at %L shall be of type " + "integer, real or character", + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &a->where); return false; } return check_co_collective (a, result_image, stat, errmsg, false); @@ -1775,7 +1775,7 @@ gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim) { if (!identical_dimen_shape (array, i, shift, j)) { - gfc_error ("'%s' argument of '%s' intrinsic at %L has " + gfc_error ("%qs argument of %qs intrinsic at %L has " "invalid shape in dimension %d (%ld/%ld)", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &shift->where, i + 1, @@ -1790,7 +1790,7 @@ gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim) } else { - gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank " + gfc_error ("%qs argument of intrinsic %qs at %L of must have rank " "%d or be a scalar", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &shift->where, array->rank - 1); return false; @@ -1834,7 +1834,7 @@ gfc_check_dcmplx (gfc_expr *x, gfc_expr *y) if (x->ts.type == BT_COMPLEX) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must not be " + gfc_error ("%qs argument of %qs intrinsic at %L must not be " "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &y->where); @@ -1843,7 +1843,7 @@ gfc_check_dcmplx (gfc_expr *x, gfc_expr *y) if (y->ts.type == BT_COMPLEX) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type " + gfc_error ("%qs argument of %qs intrinsic at %L must have a type " "of either REAL or INTEGER", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &y->where); @@ -1893,7 +1893,7 @@ gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b) break; default: - gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric " + gfc_error ("%qs argument of %qs intrinsic at %L must be numeric " "or LOGICAL", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &vector_a->where); return false; @@ -1907,7 +1907,7 @@ gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b) if (! identical_dimen_shape (vector_a, 0, vector_b, 0)) { - gfc_error ("Different shape for arguments '%s' and '%s' at %L for " + gfc_error ("Different shape for arguments %qs and %qs at %L for " "intrinsic 'dot_product'", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic_arg[1]->name, &vector_a->where); return false; @@ -1926,7 +1926,7 @@ gfc_check_dprod (gfc_expr *x, gfc_expr *y) if (x->ts.kind != gfc_default_real_kind) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be default " + gfc_error ("%qs argument of %qs intrinsic at %L must be default " "real", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &x->where); return false; @@ -1934,7 +1934,7 @@ gfc_check_dprod (gfc_expr *x, gfc_expr *y) if (y->ts.kind != gfc_default_real_kind) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be default " + gfc_error ("%qs argument of %qs intrinsic at %L must be default " "real", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &y->where); return false; @@ -1955,8 +1955,8 @@ gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift) if (i->is_boz && j->is_boz) { - gfc_error ("'I' at %L and 'J' at %L cannot both be BOZ literal " - "constants", &i->where, &j->where); + gfc_error_1 ("'I' at %L and 'J' at %L cannot both be BOZ literal " + "constants", &i->where, &j->where); return false; } @@ -2025,7 +2025,7 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, { if (!identical_dimen_shape (array, i, shift, j)) { - gfc_error ("'%s' argument of '%s' intrinsic at %L has " + gfc_error ("%qs argument of %qs intrinsic at %L has " "invalid shape in dimension %d (%ld/%ld)", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &shift->where, i + 1, @@ -2040,7 +2040,7 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, } else { - gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank " + gfc_error ("%qs argument of intrinsic %qs at %L of must have rank " "%d or be a scalar", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &shift->where, array->rank - 1); return false; @@ -2068,7 +2068,7 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, } else { - gfc_error ("'%s' argument of intrinsic '%s' at %L of must have " + gfc_error ("%qs argument of intrinsic %qs at %L of must have " "rank %d or be a scalar", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &shift->where, array->rank - 1); @@ -2369,8 +2369,8 @@ gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back, if (string->ts.kind != substring->ts.kind) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same " - "kind as '%s'", gfc_current_intrinsic_arg[1]->name, + gfc_error ("%qs argument of %qs intrinsic at %L must be the same " + "kind as %qs", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &substring->where, gfc_current_intrinsic_arg[0]->name); return false; @@ -2471,9 +2471,9 @@ gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size) if (i2 > i3) { - gfc_error ("The absolute value of SHIFT at %L must be less " - "than or equal to SIZE at %L", &shift->where, - &size->where); + gfc_error_1 ("The absolute value of SHIFT at %L must be less " + "than or equal to SIZE at %L", &shift->where, + &size->where); return false; } } @@ -2532,7 +2532,7 @@ gfc_check_kind (gfc_expr *x) { if (x->ts.type == BT_DERIVED) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be a " + gfc_error ("%qs argument of %qs intrinsic at %L must be a " "non-derived type", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &x->where); return false; @@ -2743,7 +2743,7 @@ min_max_args (gfc_actual_arglist *args) if (args == NULL || args->next == NULL) { - gfc_error ("Intrinsic '%s' at %L must have at least two arguments", + gfc_error ("Intrinsic %qs at %L must have at least two arguments", gfc_current_intrinsic, gfc_current_intrinsic_where); return false; } @@ -2791,7 +2791,7 @@ min_max_args (gfc_actual_arglist *args) if (!a1 || !a2) { - gfc_error ("Missing '%s' argument to the %s intrinsic at %L", + gfc_error ("Missing %qs argument to the %s intrinsic at %L", !a1 ? "a1" : "a2", gfc_current_intrinsic, gfc_current_intrinsic_where); return false; @@ -2806,12 +2806,12 @@ min_max_args (gfc_actual_arglist *args) return true; duplicate: - gfc_error ("Duplicate argument '%s' at %L to intrinsic %s", arg->name, + gfc_error ("Duplicate argument %qs at %L to intrinsic %s", arg->name, &arg->expr->where, gfc_current_intrinsic); return false; unknown: - gfc_error ("Unknown argument '%s' at %L to intrinsic %s", arg->name, + gfc_error ("Unknown argument %qs at %L to intrinsic %s", arg->name, &arg->expr->where, gfc_current_intrinsic); return false; } @@ -2840,7 +2840,7 @@ check_rest (bt type, int kind, gfc_actual_arglist *arglist) } else { - gfc_error ("'a%d' argument of '%s' intrinsic at %L must be " + gfc_error ("'a%d' argument of %qs intrinsic at %L must be " "%s(%d)", n, gfc_current_intrinsic, &x->where, gfc_basic_typename (type), kind); return false; @@ -2878,7 +2878,7 @@ gfc_check_min_max (gfc_actual_arglist *arg) } else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL) { - gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER, " + gfc_error ("'a1' argument of %qs intrinsic at %L must be INTEGER, " "REAL or CHARACTER", gfc_current_intrinsic, &x->where); return false; } @@ -2928,7 +2928,7 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) { if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts)) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric " + gfc_error ("%qs argument of %qs intrinsic at %L must be numeric " "or LOGICAL", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &matrix_a->where); return false; @@ -2936,7 +2936,7 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts)) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric " + gfc_error ("%qs argument of %qs intrinsic at %L must be numeric " "or LOGICAL", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &matrix_b->where); return false; @@ -2945,7 +2945,7 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) if ((matrix_a->ts.type == BT_LOGICAL && gfc_numeric_ts (&matrix_b->ts)) || (gfc_numeric_ts (&matrix_a->ts) && matrix_b->ts.type == BT_LOGICAL)) { - gfc_error ("Argument types of '%s' intrinsic at %L must match (%s/%s)", + gfc_error ("Argument types of %qs intrinsic at %L must match (%s/%s)", gfc_current_intrinsic, &matrix_a->where, gfc_typename(&matrix_a->ts), gfc_typename(&matrix_b->ts)); return false; @@ -2959,8 +2959,8 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */ if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0)) { - gfc_error ("Different shape on dimension 1 for arguments '%s' " - "and '%s' at %L for intrinsic matmul", + gfc_error ("Different shape on dimension 1 for arguments %qs " + "and %qs at %L for intrinsic matmul", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic_arg[1]->name, &matrix_a->where); return false; @@ -2978,8 +2978,8 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) - matrix_a has shape (n,m) and matrix_b has shape (m). */ if (!identical_dimen_shape (matrix_a, 1, matrix_b, 0)) { - gfc_error ("Different shape on dimension 2 for argument '%s' and " - "dimension 1 for argument '%s' at %L for intrinsic " + gfc_error ("Different shape on dimension 2 for argument %qs and " + "dimension 1 for argument %qs at %L for intrinsic " "matmul", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic_arg[1]->name, &matrix_a->where); return false; @@ -2987,7 +2987,7 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) break; default: - gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank " + gfc_error ("%qs argument of %qs intrinsic at %L must be of rank " "1 or 2", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &matrix_a->where); return false; @@ -3162,7 +3162,7 @@ gfc_check_transf_bit_intrins (gfc_actual_arglist *ap) { if (ap->expr->ts.type != BT_INTEGER) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER", + gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &ap->expr->where); return false; @@ -3337,7 +3337,7 @@ gfc_check_null (gfc_expr *mold) if (!attr.pointer && !attr.proc_pointer && !attr.allocatable) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER, " + gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER, " "ALLOCATABLE or procedure pointer", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &mold->where); @@ -3352,7 +3352,7 @@ gfc_check_null (gfc_expr *mold) /* F2008, C1242. */ if (gfc_is_coindexed (mold)) { - gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be " + gfc_error ("%qs argument of %qs intrinsic at %L shall not be " "coindexed", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &mold->where); return false; @@ -3424,9 +3424,9 @@ gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) if (mpz_get_si (vector_size) < mask_true_values) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must " + gfc_error ("%qs argument of %qs intrinsic at %L must " "provide at least as many elements as there " - "are .TRUE. values in '%s' (%ld/%d)", + "are .TRUE. values in %qs (%ld/%d)", gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic, &vector->where, gfc_current_intrinsic_arg[1]->name, @@ -3482,7 +3482,7 @@ gfc_check_present (gfc_expr *a) sym = a->symtree->n.sym; if (!sym->attr.dummy) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a " + gfc_error ("%qs argument of %qs intrinsic at %L must be of a " "dummy variable", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &a->where); return false; @@ -3490,7 +3490,7 @@ gfc_check_present (gfc_expr *a) if (!sym->attr.optional) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be of " + gfc_error ("%qs argument of %qs intrinsic at %L must be of " "an OPTIONAL dummy variable", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &a->where); @@ -3509,8 +3509,8 @@ gfc_check_present (gfc_expr *a) || (a->ref->u.ar.type == AR_ELEMENT && a->ref->u.ar.as->rank == 0)))) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a " - "subobject of '%s'", gfc_current_intrinsic_arg[0]->name, + gfc_error ("%qs argument of %qs intrinsic at %L must not be a " + "subobject of %qs", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &a->where, sym->name); return false; } @@ -3671,7 +3671,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, if (shape_size <= 0) { - gfc_error ("'%s' argument of '%s' intrinsic at %L is empty", + gfc_error ("%qs argument of %qs intrinsic at %L is empty", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &shape->where); return false; @@ -3695,7 +3695,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, gfc_extract_int (e, &extent); if (extent < 0) { - gfc_error ("'%s' argument of '%s' intrinsic at %L has " + gfc_error ("%qs argument of %qs intrinsic at %L has " "negative element (%d)", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &e->where, extent); @@ -3735,7 +3735,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, if (order_size != shape_size) { - gfc_error ("'%s' argument of '%s' intrinsic at %L " + gfc_error ("%qs argument of %qs intrinsic at %L " "has wrong number of elements (%d/%d)", gfc_current_intrinsic_arg[3]->name, gfc_current_intrinsic, &order->where, @@ -3753,7 +3753,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, if (dim < 1 || dim > order_size) { - gfc_error ("'%s' argument of '%s' intrinsic at %L " + gfc_error ("%qs argument of %qs intrinsic at %L " "has out-of-range dimension (%d)", gfc_current_intrinsic_arg[3]->name, gfc_current_intrinsic, &e->where, dim); @@ -3762,7 +3762,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, if (perm[dim-1] != 0) { - gfc_error ("'%s' argument of '%s' intrinsic at %L has " + gfc_error ("%qs argument of %qs intrinsic at %L has " "invalid permutation of dimensions (dimension " "'%d' duplicated)", gfc_current_intrinsic_arg[3]->name, @@ -3815,7 +3815,7 @@ gfc_check_same_type_as (gfc_expr *a, gfc_expr *b) { if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS) { - gfc_error ("'%s' argument of '%s' intrinsic at %L " + gfc_error ("%qs argument of %qs intrinsic at %L " "cannot be of type %s", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, @@ -3825,7 +3825,7 @@ gfc_check_same_type_as (gfc_expr *a, gfc_expr *b) if (!(gfc_type_is_extensible (a->ts.u.derived) || UNLIMITED_POLY (a))) { - gfc_error ("'%s' argument of '%s' intrinsic at %L " + gfc_error ("%qs argument of %qs intrinsic at %L " "must be of an extensible type", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &a->where); @@ -3834,7 +3834,7 @@ gfc_check_same_type_as (gfc_expr *a, gfc_expr *b) if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS) { - gfc_error ("'%s' argument of '%s' intrinsic at %L " + gfc_error ("%qs argument of %qs intrinsic at %L " "cannot be of type %s", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, @@ -3844,7 +3844,7 @@ gfc_check_same_type_as (gfc_expr *a, gfc_expr *b) if (!(gfc_type_is_extensible (b->ts.u.derived) || UNLIMITED_POLY (b))) { - gfc_error ("'%s' argument of '%s' intrinsic at %L " + gfc_error ("%qs argument of %qs intrinsic at %L " "must be of an extensible type", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &b->where); @@ -4086,7 +4086,7 @@ gfc_check_sizeof (gfc_expr *arg) { if (arg->ts.type == BT_PROCEDURE) { - gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be a procedure", + gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &arg->where); return false; @@ -4099,7 +4099,7 @@ gfc_check_sizeof (gfc_expr *arg) && arg->symtree->n.sym->as->type != AS_DEFERRED && arg->symtree->n.sym->as->type != AS_ASSUMED_RANK))) { - gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be TYPE(*)", + gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &arg->where); return false; @@ -4110,7 +4110,7 @@ gfc_check_sizeof (gfc_expr *arg) && arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref && arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL) { - gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be an " + gfc_error ("%qs argument of %qs intrinsic at %L shall not be an " "assumed-size array", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &arg->where); return false; @@ -4229,7 +4229,7 @@ gfc_check_c_sizeof (gfc_expr *arg) if (!is_c_interoperable (arg, &msg, false, false)) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be an " + gfc_error ("%qs argument of %qs intrinsic at %L must be an " "interoperable data entity: %s", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &arg->where, msg); @@ -4238,7 +4238,7 @@ gfc_check_c_sizeof (gfc_expr *arg) if (arg->ts.type == BT_ASSUMED) { - gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be " + gfc_error ("%qs argument of %qs intrinsic at %L shall not be " "TYPE(*)", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &arg->where); @@ -4250,7 +4250,7 @@ gfc_check_c_sizeof (gfc_expr *arg) && arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref && arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL) { - gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be an " + gfc_error ("%qs argument of %qs intrinsic at %L shall not be an " "assumed-size array", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &arg->where); return false; @@ -4449,7 +4449,7 @@ gfc_check_c_funloc (gfc_expr *x) for (ns = gfc_current_ns; ns; ns = ns->parent) if (x->symtree->n.sym == ns->proc_name) { - gfc_error ("Function result '%s' at %L is invalid as X argument " + gfc_error ("Function result %qs at %L is invalid as X argument " "to C_FUNLOC", x->symtree->n.sym->name, &x->where); return false; } @@ -4575,7 +4575,7 @@ gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies) { if (source->rank >= GFC_MAX_DIMENSIONS) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be less " + gfc_error ("%qs argument of %qs intrinsic at %L must be less " "than rank %d", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS); @@ -4594,7 +4594,7 @@ gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies) && (mpz_cmp_ui (dim->value.integer, 1) < 0 || mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0)) { - gfc_error ("'%s' argument of '%s' intrinsic at %L is not a valid " + gfc_error ("%qs argument of %qs intrinsic at %L is not a valid " "dimension index", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &dim->where); return false; @@ -5189,9 +5189,9 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) if (mpz_get_si (vector_size) < mask_true_count) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must " + gfc_error ("%qs argument of %qs intrinsic at %L must " "provide at least as many elements as there " - "are .TRUE. values in '%s' (%ld/%d)", + "are .TRUE. values in %qs (%ld/%d)", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &vector->where, gfc_current_intrinsic_arg[1]->name, mpz_get_si (vector_size), mask_true_count); @@ -5203,8 +5203,8 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) if (mask->rank != field->rank && field->rank != 0) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must have " - "the same rank as '%s' or be a scalar", + gfc_error ("%qs argument of %qs intrinsic at %L must have " + "the same rank as %qs or be a scalar", gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic, &field->where, gfc_current_intrinsic_arg[1]->name); return false; @@ -5216,7 +5216,7 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) for (i = 0; i < field->rank; i++) if (! identical_dimen_shape (mask, i, field, i)) { - gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L " + gfc_error ("%qs and %qs arguments of %qs intrinsic at %L " "must have identical shape.", gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, @@ -5474,7 +5474,7 @@ gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get) if (gfc_array_size (put, &put_size) && mpz_get_ui (put_size) < kiss_size) - gfc_error ("Size of '%s' argument of '%s' intrinsic at %L " + gfc_error ("Size of %qs argument of %qs intrinsic at %L " "too small (%i/%i)", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, where, (int) mpz_get_ui (put_size), kiss_size); @@ -5506,7 +5506,7 @@ gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get) if (gfc_array_size (get, &get_size) && mpz_get_ui (get_size) < kiss_size) - gfc_error ("Size of '%s' argument of '%s' intrinsic at %L " + gfc_error ("Size of %qs argument of %qs intrinsic at %L " "too small (%i/%i)", gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic, where, (int) mpz_get_ui (get_size), kiss_size); @@ -5817,7 +5817,7 @@ gfc_check_getarg (gfc_expr *pos, gfc_expr *value) if (pos->ts.kind > gfc_default_integer_kind) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind " + gfc_error ("%qs argument of %qs intrinsic at %L must be of a kind " "not wider than the default kind (%d)", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &pos->where, gfc_default_integer_kind); @@ -6169,7 +6169,7 @@ gfc_check_and (gfc_expr *i, gfc_expr *j) { if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER " + gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER " "or LOGICAL", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &i->where); return false; @@ -6177,7 +6177,7 @@ gfc_check_and (gfc_expr *i, gfc_expr *j) if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER " + gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER " "or LOGICAL", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &j->where); return false; @@ -6185,7 +6185,7 @@ gfc_check_and (gfc_expr *i, gfc_expr *j) if (i->ts.type != j->ts.type) { - gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must " + gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must " "have the same type", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &j->where); @@ -6207,7 +6207,7 @@ gfc_check_storage_size (gfc_expr *a, gfc_expr *kind) { if (a->ts.type == BT_ASSUMED) { - gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be TYPE(*)", + gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &a->where); return false; @@ -6215,7 +6215,7 @@ gfc_check_storage_size (gfc_expr *a, gfc_expr *kind) if (a->ts.type == BT_PROCEDURE) { - gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be a " + gfc_error ("%qs argument of %qs intrinsic at %L shall not be a " "procedure", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &a->where); return false; @@ -6232,7 +6232,7 @@ gfc_check_storage_size (gfc_expr *a, gfc_expr *kind) if (kind->expr_type != EXPR_CONSTANT) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant", + gfc_error ("%qs argument of %qs intrinsic at %L must be a constant", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &kind->where); return false; diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index 0286c9e..5130022 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -666,7 +666,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, up to 255 extension levels. */ if (ts->u.derived->attr.extension == 255) { - gfc_error ("Maximum extension level reached with type '%s' at %L", + gfc_error ("Maximum extension level reached with type %qs at %L", ts->u.derived->name, &ts->u.derived->declared_at); return false; } @@ -2686,7 +2686,7 @@ find_typebound_proc_uop (gfc_symbol* derived, bool* t, && res->n.tb->access == ACCESS_PRIVATE) { if (where) - gfc_error ("'%s' of '%s' is PRIVATE at %L", + gfc_error ("%qs of %qs is PRIVATE at %L", name, derived->name, where); if (t) *t = false; @@ -2760,7 +2760,7 @@ gfc_find_typebound_intrinsic_op (gfc_symbol* derived, bool* t, && res->access == ACCESS_PRIVATE) { if (where) - gfc_error ("'%s' of '%s' is PRIVATE at %L", + gfc_error ("%qs of %qs is PRIVATE at %L", gfc_op2string (op), derived->name, where); if (t) *t = false; diff --git a/gcc/fortran/data.c b/gcc/fortran/data.c index 8b270ac..5d0651e 100644 --- a/gcc/fortran/data.c +++ b/gcc/fortran/data.c @@ -253,9 +253,9 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index, if (init && expr->expr_type != EXPR_ARRAY) { - gfc_error ("'%s' at %L already is initialized at %L", - lvalue->symtree->n.sym->name, &lvalue->where, - &init->where); + gfc_error_1 ("'%s' at %L already is initialized at %L", + lvalue->symtree->n.sym->name, &lvalue->where, + &init->where); goto abort; } diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 6e55bbf..c6b46b9 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -261,7 +261,7 @@ var_element (gfc_data_variable *new_var) if (!sym->attr.function && gfc_current_ns->parent && gfc_current_ns->parent == sym->ns) { - gfc_error ("Host associated variable '%s' may not be in the DATA " + gfc_error ("Host associated variable %qs may not be in the DATA " "statement at %C", sym->name); return MATCH_ERROR; } @@ -379,7 +379,7 @@ match_data_constant (gfc_expr **result) || (sym->attr.flavor != FL_PARAMETER && (!dt_sym || dt_sym->attr.flavor != FL_DERIVED))) { - gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C", + gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C", name); return MATCH_ERROR; } @@ -1017,15 +1017,15 @@ gfc_verify_c_interop_param (gfc_symbol *sym) { /* Make personalized messages to give better feedback. */ if (sym->ts.type == BT_DERIVED) - gfc_error ("Variable '%s' at %L is a dummy argument to the " - "BIND(C) procedure '%s' but is not C interoperable " - "because derived type '%s' is not C interoperable", + gfc_error ("Variable %qs at %L is a dummy argument to the " + "BIND(C) procedure %qs but is not C interoperable " + "because derived type %qs is not C interoperable", sym->name, &(sym->declared_at), sym->ns->proc_name->name, sym->ts.u.derived->name); else if (sym->ts.type == BT_CLASS) - gfc_error ("Variable '%s' at %L is a dummy argument to the " - "BIND(C) procedure '%s' but is not C interoperable " + gfc_error ("Variable %qs at %L is a dummy argument to the " + "BIND(C) procedure %qs but is not C interoperable " "because it is polymorphic", sym->name, &(sym->declared_at), sym->ns->proc_name->name); @@ -1046,9 +1046,9 @@ gfc_verify_c_interop_param (gfc_symbol *sym) if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT || mpz_cmp_si (cl->length->value.integer, 1) != 0) { - gfc_error ("Character argument '%s' at %L " + gfc_error ("Character argument %qs at %L " "must be length 1 because " - "procedure '%s' is BIND(C)", + "procedure %qs is BIND(C)", sym->name, &sym->declared_at, sym->ns->proc_name->name); retval = false; @@ -1076,8 +1076,8 @@ gfc_verify_c_interop_param (gfc_symbol *sym) if ((sym->attr.allocatable || sym->attr.pointer) && !sym->as) { - gfc_error ("Scalar variable '%s' at %L with POINTER or " - "ALLOCATABLE in procedure '%s' with BIND(C) is not yet" + gfc_error ("Scalar variable %qs at %L with POINTER or " + "ALLOCATABLE in procedure %qs with BIND(C) is not yet" " supported", sym->name, &(sym->declared_at), sym->ns->proc_name->name); retval = false; @@ -1085,8 +1085,8 @@ gfc_verify_c_interop_param (gfc_symbol *sym) if (sym->attr.optional == 1 && sym->attr.value) { - gfc_error ("Variable '%s' at %L cannot have both the OPTIONAL " - "and the VALUE attribute because procedure '%s' " + gfc_error ("Variable %qs at %L cannot have both the OPTIONAL " + "and the VALUE attribute because procedure %qs " "is BIND(C)", sym->name, &(sym->declared_at), sym->ns->proc_name->name); retval = false; @@ -1323,7 +1323,7 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) && sym->value != NULL && *initp != NULL) { - gfc_error ("Initializer not allowed for PARAMETER '%s' at %C", + gfc_error ("Initializer not allowed for PARAMETER %qs at %C", sym->name); return false; } @@ -1343,7 +1343,7 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) initializer. */ if (sym->attr.data) { - gfc_error ("Variable '%s' at %C with an initializer already " + gfc_error ("Variable %qs at %C with an initializer already " "appears in a DATA statement", sym->name); return false; } @@ -1783,7 +1783,7 @@ check_function_name (char *name) && strcmp (block->result->name, "ppr@") != 0 && strcmp (block->name, name) == 0) { - gfc_error ("Function name '%s' not allowed at %C", name); + gfc_error ("Function name %qs not allowed at %C", name); return false; } } @@ -1850,7 +1850,7 @@ variable_decl (int elem) if (as->type == AS_IMPLIED_SHAPE && current_attr.flavor != FL_PARAMETER) { m = MATCH_ERROR; - gfc_error ("Non-PARAMETER symbol '%s' at %L can't be implied-shape", + gfc_error ("Non-PARAMETER symbol %qs at %L can't be implied-shape", name, &var_locus); goto cleanup; } @@ -2819,7 +2819,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) gfc_get_ha_symbol (name, &sym); if (sym->generic && gfc_find_symbol (dt_name, NULL, 0, &dt_sym)) { - gfc_error ("Type name '%s' at %C is ambiguous", name); + gfc_error ("Type name %qs at %C is ambiguous", name); return MATCH_ERROR; } if (sym->generic && !dt_sym) @@ -2832,7 +2832,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) gfc_find_symbol (name, NULL, iface, &sym); if (sym && sym->generic && gfc_find_symbol (dt_name, NULL, 1, &dt_sym)) { - gfc_error ("Type name '%s' at %C is ambiguous", name); + gfc_error ("Type name %qs at %C is ambiguous", name); return MATCH_ERROR; } if (sym && sym->generic && !dt_sym) @@ -2847,9 +2847,9 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic)) || sym->attr.subroutine) { - gfc_error ("Type name '%s' at %C conflicts with previously declared " - "entity at %L, which has the same name", name, - &sym->declared_at); + gfc_error_1 ("Type name '%s' at %C conflicts with previously declared " + "entity at %L, which has the same name", name, + &sym->declared_at); return MATCH_ERROR; } @@ -3274,7 +3274,7 @@ gfc_match_import (void) if (gfc_current_ns->parent != NULL && gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym)) { - gfc_error ("Type name '%s' at %C is ambiguous", name); + gfc_error ("Type name %qs at %C is ambiguous", name); return MATCH_ERROR; } else if (!sym && gfc_current_ns->proc_name->ns->parent != NULL @@ -3282,13 +3282,13 @@ gfc_match_import (void) gfc_current_ns->proc_name->ns->parent, 1, &sym)) { - gfc_error ("Type name '%s' at %C is ambiguous", name); + gfc_error ("Type name %qs at %C is ambiguous", name); return MATCH_ERROR; } if (sym == NULL) { - gfc_error ("Cannot IMPORT '%s' from host scoping unit " + gfc_error ("Cannot IMPORT %qs from host scoping unit " "at %C - does not exist.", name); return MATCH_ERROR; } @@ -4064,13 +4064,13 @@ verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts, else { if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED) - gfc_error ("Type declaration '%s' at %L is not C " + gfc_error ("Type declaration %qs at %L is not C " "interoperable but it is BIND(C)", tmp_sym->name, &(tmp_sym->declared_at)); else if (warn_c_binding_type) gfc_warning (OPT_Wc_binding_type, "Variable %qs at %L " "may not be a C interoperable " - "kind but it is bind(c)", + "kind but it is BIND(C)", tmp_sym->name, &(tmp_sym->declared_at)); } } @@ -4080,7 +4080,7 @@ verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts, semantically no reason for the attribute. */ if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1) { - gfc_error ("Variable '%s' in common block '%s' at " + gfc_error ("Variable %qs in common block %qs at " "%L cannot be declared with BIND(C) " "since it is not a global", tmp_sym->name, com_block->name, @@ -4094,7 +4094,7 @@ verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts, { if (tmp_sym->attr.pointer == 1) { - gfc_error ("Variable '%s' at %L cannot have both the " + gfc_error ("Variable %qs at %L cannot have both the " "POINTER and BIND(C) attributes", tmp_sym->name, &(tmp_sym->declared_at)); retval = false; @@ -4102,7 +4102,7 @@ verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts, if (tmp_sym->attr.allocatable == 1) { - gfc_error ("Variable '%s' at %L cannot have both the " + gfc_error ("Variable %qs at %L cannot have both the " "ALLOCATABLE and BIND(C) attributes", tmp_sym->name, &(tmp_sym->declared_at)); retval = false; @@ -4114,7 +4114,7 @@ verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts, scalar value. The previous tests in this function made sure the type is interoperable. */ if (bind_c_function && tmp_sym->as != NULL) - gfc_error ("Return type of BIND(C) function '%s' at %L cannot " + gfc_error ("Return type of BIND(C) function %qs at %L cannot " "be an array", tmp_sym->name, &(tmp_sym->declared_at)); /* BIND(C) functions can not return a character string. */ @@ -4122,7 +4122,7 @@ verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts, if (tmp_sym->ts.u.cl == NULL || tmp_sym->ts.u.cl->length == NULL || tmp_sym->ts.u.cl->length->expr_type != EXPR_CONSTANT || mpz_cmp_si (tmp_sym->ts.u.cl->length->value.integer, 1) != 0) - gfc_error ("Return type of BIND(C) function '%s' at %L cannot " + gfc_error ("Return type of BIND(C) function %qs at %L cannot " "be a character string", tmp_sym->name, &(tmp_sym->declared_at)); } @@ -4597,7 +4597,7 @@ gfc_match_formal_arglist (gfc_symbol *progname, int st_flag, int null_flag) if (gfc_new_block != NULL && sym != NULL && strcmp (sym->name, gfc_new_block->name) == 0) { - gfc_error ("Name '%s' at %C is the name of the procedure", + gfc_error ("Name %qs at %C is the name of the procedure", sym->name); m = MATCH_ERROR; goto cleanup; @@ -4626,7 +4626,7 @@ ok: for (q = p->next; q; q = q->next) if (p->sym == q->sym) { - gfc_error ("Duplicate symbol '%s' in formal argument list " + gfc_error ("Duplicate symbol %qs in formal argument list " "at %C", p->sym->name); m = MATCH_ERROR; @@ -5001,7 +5001,7 @@ match_procedure_decl (void) { if (sym->ts.type != BT_UNKNOWN) { - gfc_error ("Procedure '%s' at %L already has basic type of %s", + gfc_error ("Procedure %qs at %L already has basic type of %s", sym->name, &gfc_current_locus, gfc_basic_typename (sym->ts.type)); return MATCH_ERROR; @@ -6277,7 +6277,7 @@ gfc_match_end (gfc_statement *st) if (!block_name) return MATCH_YES; - gfc_error ("Expected block name of '%s' in %s statement at %L", + gfc_error ("Expected block name of %qs in %s statement at %L", block_name, gfc_ascii_statement (*st), &old_loc); return MATCH_ERROR; @@ -6303,7 +6303,7 @@ gfc_match_end (gfc_statement *st) if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0) { - gfc_error ("Expected label '%s' for %s statement at %C", block_name, + gfc_error ("Expected label %qs for %s statement at %C", block_name, gfc_ascii_statement (*st)); goto cleanup; } @@ -6311,7 +6311,7 @@ gfc_match_end (gfc_statement *st) else if (strcmp (block_name, "ppr@") == 0 && strcmp (name, gfc_current_block ()->ns->proc_name->name) != 0) { - gfc_error ("Expected label '%s' for %s statement at %C", + gfc_error ("Expected label %qs for %s statement at %C", gfc_current_block ()->ns->proc_name->name, gfc_ascii_statement (*st)); goto cleanup; @@ -7315,7 +7315,7 @@ gfc_match_volatile (void) for variable in a BLOCK which is defined outside of the BLOCK. */ if (sym->ns != gfc_current_ns && sym->attr.codimension) { - gfc_error ("Specifying VOLATILE for coarray variable '%s' at " + gfc_error ("Specifying VOLATILE for coarray variable %qs at " "%C, which is use-/host-associated", sym->name); return MATCH_ERROR; } @@ -7531,27 +7531,27 @@ check_extended_derived_type (char *name) /* F08:C428. */ if (!extended) { - gfc_error ("Symbol '%s' at %C has not been previously defined", name); + gfc_error ("Symbol %qs at %C has not been previously defined", name); return NULL; } if (extended->attr.flavor != FL_DERIVED) { - gfc_error ("'%s' in EXTENDS expression at %C is not a " + gfc_error ("%qs in EXTENDS expression at %C is not a " "derived type", name); return NULL; } if (extended->attr.is_bind_c) { - gfc_error ("'%s' cannot be extended at %C because it " + gfc_error ("%qs cannot be extended at %C because it " "is BIND(C)", extended->name); return NULL; } if (extended->attr.sequence) { - gfc_error ("'%s' cannot be extended at %C because it " + gfc_error ("%qs cannot be extended at %C because it " "is a SEQUENCE type", extended->name); return NULL; } @@ -7682,7 +7682,7 @@ gfc_match_derived_decl (void) /* Make sure the name is not the name of an intrinsic type. */ if (gfc_is_intrinsic_typename (name)) { - gfc_error ("Type name '%s' at %C cannot be the same as an intrinsic " + gfc_error ("Type name %qs at %C cannot be the same as an intrinsic " "type", name); return MATCH_ERROR; } @@ -7692,7 +7692,7 @@ gfc_match_derived_decl (void) if (!gensym->attr.generic && gensym->ts.type != BT_UNKNOWN) { - gfc_error ("Derived type name '%s' at %C already has a basic type " + gfc_error ("Derived type name %qs at %C already has a basic type " "of %s", gensym->name, gfc_typename (&gensym->ts)); return MATCH_ERROR; } @@ -7709,7 +7709,7 @@ gfc_match_derived_decl (void) if (sym && (sym->components != NULL || sym->attr.zero_comp)) { - gfc_error ("Derived type definition of '%s' at %C has already been " + gfc_error ("Derived type definition of %qs at %C has already been " "defined", sym->name); return MATCH_ERROR; } @@ -7780,7 +7780,7 @@ gfc_match_derived_decl (void) { /* Since the extension field is 8 bit wide, we can only have up to 255 extension levels. */ - gfc_error ("Maximum extension level reached with type '%s' at %L", + gfc_error ("Maximum extension level reached with type %qs at %L", extended->name, &extended->declared_at); return MATCH_ERROR; } @@ -8375,7 +8375,7 @@ match_procedure_in_type (void) /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */ if (tb.deferred && !block->attr.abstract) { - gfc_error ("Type '%s' containing DEFERRED binding at %C " + gfc_error ("Type %qs containing DEFERRED binding at %C " "is not ABSTRACT", block->name); return MATCH_ERROR; } @@ -8386,8 +8386,8 @@ match_procedure_in_type (void) stree = gfc_find_symtree (ns->tb_sym_root, name); if (stree && stree->n.tb) { - gfc_error ("There is already a procedure with binding name '%s' for " - "the derived type '%s' at %C", name, block->name); + gfc_error ("There is already a procedure with binding name %qs for " + "the derived type %qs at %C", name, block->name); return MATCH_ERROR; } @@ -8536,7 +8536,7 @@ gfc_match_generic (void) { gcc_assert (op_type == INTERFACE_GENERIC); gfc_error ("There's already a non-generic procedure with binding name" - " '%s' for the derived type '%s' at %C", + " %qs for the derived type %qs at %C", bind_name, block->name); goto error; } @@ -8544,7 +8544,7 @@ gfc_match_generic (void) if (tb->access != tbattr.access) { gfc_error ("Binding at %C must have the same access as already" - " defined binding '%s'", bind_name); + " defined binding %qs", bind_name); goto error; } } @@ -8602,8 +8602,8 @@ gfc_match_generic (void) for (target = tb->u.generic; target; target = target->next) if (target_st == target->specific_st) { - gfc_error ("'%s' already defined as specific binding for the" - " generic '%s' at %C", name, bind_name); + gfc_error ("%qs already defined as specific binding for the" + " generic %qs at %C", name, bind_name); goto error; } @@ -8711,7 +8711,7 @@ gfc_match_final_decl (void) if (gfc_get_symbol (name, module_ns, &sym)) { - gfc_error ("Unknown procedure name \"%s\" at %C", name); + gfc_error ("Unknown procedure name %qs at %C", name); return MATCH_ERROR; } @@ -8724,7 +8724,7 @@ gfc_match_final_decl (void) for (f = block->f2k_derived->finalizers; f; f = f->next) if (f->proc_sym == sym) { - gfc_error ("'%s' at %C is already defined as FINAL procedure!", + gfc_error ("%qs at %C is already defined as FINAL procedure!", name); return MATCH_ERROR; } diff --git a/gcc/fortran/error.c b/gcc/fortran/error.c index 851ba90..f7a6a6b 100644 --- a/gcc/fortran/error.c +++ b/gcc/fortran/error.c @@ -34,6 +34,8 @@ along with GCC; see the file COPYING3. If not see #include "diagnostic-color.h" #include "tree-diagnostic.h" /* tree_diagnostics_defaults */ +#include /* For placement-new */ + static int suppress_errors = 0; static bool warnings_not_errors = false; @@ -44,13 +46,18 @@ static gfc_error_buf error_buffer, warning_buffer, *cur_error_buffer; /* True if the error/warnings should be buffered. */ static bool buffered_p; - /* These are always buffered buffers (.flush_p == false) to be used by the pretty-printer. */ -static output_buffer pp_warning_buffer; +static output_buffer *pp_error_buffer, *pp_warning_buffer; static int warningcount_buffered, werrorcount_buffered; -#include /* For placement-new */ +/* Return true if there output_buffer is empty. */ + +static bool +gfc_output_buffer_empty_p (const output_buffer * buf) +{ + return output_buffer_last_position_in_text (buf) == NULL; +} /* Go one level deeper suppressing errors. */ @@ -99,7 +106,6 @@ void gfc_buffer_error (bool flag) { buffered_p = flag; - pp_warning_buffer.flush_p = !flag; } @@ -843,11 +849,11 @@ gfc_warning (int opt, const char *gmsgid, va_list ap) pretty_printer *pp = global_dc->printer; output_buffer *tmp_buffer = pp->buffer; - gfc_clear_pp_buffer (&pp_warning_buffer); + gfc_clear_pp_buffer (pp_warning_buffer); if (buffered_p) { - pp->buffer = &pp_warning_buffer; + pp->buffer = pp_warning_buffer; global_dc->fatal_errors = false; /* To prevent -fmax-errors= triggering. */ --werrorcount; @@ -1248,10 +1254,9 @@ gfc_clear_warning (void) { warning_buffer.flag = 0; - gfc_clear_pp_buffer (&pp_warning_buffer); + gfc_clear_pp_buffer (pp_warning_buffer); warningcount_buffered = 0; werrorcount_buffered = 0; - pp_warning_buffer.flush_p = false; } @@ -1266,29 +1271,32 @@ gfc_warning_check (void) warnings++; if (warning_buffer.message != NULL) fputs (warning_buffer.message, stderr); - warning_buffer.flag = 0; + gfc_clear_warning (); } - /* This is for the new diagnostics machinery. */ - pretty_printer *pp = global_dc->printer; - output_buffer *tmp_buffer = pp->buffer; - pp->buffer = &pp_warning_buffer; - if (pp_last_position_in_text (pp) != NULL) + else if (! gfc_output_buffer_empty_p (pp_warning_buffer)) { + pretty_printer *pp = global_dc->printer; + output_buffer *tmp_buffer = pp->buffer; + pp->buffer = pp_warning_buffer; pp_really_flush (pp); - pp_warning_buffer.flush_p = true; warningcount += warningcount_buffered; werrorcount += werrorcount_buffered; + gcc_assert (warningcount_buffered + werrorcount_buffered == 1); + diagnostic_action_after_output (global_dc, + warningcount_buffered + ? DK_WARNING : DK_ERROR); + pp->buffer = tmp_buffer; } - - pp->buffer = tmp_buffer; } /* Issue an error. */ +/* Use gfc_error instead, unless two locations are used in the same + warning or for scanner.c, if the location is not properly set up. */ void -gfc_error (const char *gmsgid, ...) +gfc_error_1 (const char *gmsgid, ...) { va_list argp; @@ -1336,6 +1344,59 @@ warning: } } +/* Issue an error. */ +/* This function uses the common diagnostics, but does not support + two locations; when being used in scanner.c, ensure that the location + is properly setup. Otherwise, use gfc_error_1. */ + +void +gfc_error (const char *gmsgid, ...) +{ + va_list argp; + va_start (argp, gmsgid); + + if (warnings_not_errors) + { + gfc_warning (/*opt=*/0, gmsgid, argp); + va_end (argp); + return; + } + + if (suppress_errors) + { + va_end (argp); + return; + } + + diagnostic_info diagnostic; + bool fatal_errors = global_dc->fatal_errors; + pretty_printer *pp = global_dc->printer; + output_buffer *tmp_buffer = pp->buffer; + + gfc_clear_pp_buffer (pp_error_buffer); + + if (buffered_p) + { + pp->buffer = pp_error_buffer; + global_dc->fatal_errors = false; + /* To prevent -fmax-errors= triggering, we decrease it before + report_diagnostic increases it. */ + --errorcount; + } + + diagnostic_set_info (&diagnostic, gmsgid, &argp, UNKNOWN_LOCATION, DK_ERROR); + report_diagnostic (&diagnostic); + + if (buffered_p) + { + pp->buffer = tmp_buffer; + global_dc->fatal_errors = fatal_errors; + } + + va_end (argp); +} + + /* Immediate error. */ /* Use gfc_error_now instead, unless two locations are used in the same @@ -1393,6 +1454,7 @@ gfc_clear_error (void) { error_buffer.flag = 0; warnings_not_errors = false; + gfc_clear_pp_buffer (pp_error_buffer); } @@ -1401,7 +1463,8 @@ gfc_clear_error (void) bool gfc_error_flag_test (void) { - return error_buffer.flag; + return error_buffer.flag + || !gfc_output_buffer_empty_p (pp_error_buffer); } @@ -1418,34 +1481,69 @@ gfc_error_check (void) if (error_buffer.message != NULL) fputs (error_buffer.message, stderr); error_buffer.flag = 0; + gfc_clear_pp_buffer (pp_error_buffer); gfc_increment_error_count(); if (flag_fatal_errors) exit (FATAL_EXIT_CODE); } + /* This is for the new diagnostics machinery. */ + else if (! gfc_output_buffer_empty_p (pp_error_buffer)) + { + error_raised = true; + pretty_printer *pp = global_dc->printer; + output_buffer *tmp_buffer = pp->buffer; + pp->buffer = pp_error_buffer; + pp_really_flush (pp); + ++errorcount; + gcc_assert (gfc_output_buffer_empty_p (pp_error_buffer)); + diagnostic_action_after_output (global_dc, DK_ERROR); + pp->buffer = tmp_buffer; + } return error_raised; } +/* Move the text buffered from FROM to TO, then clear + FROM. Independently if there was text in FROM, TO is also + cleared. */ + +static void +gfc_move_output_buffer_from_to (output_buffer *from, output_buffer *to) +{ + gfc_clear_pp_buffer (to); + /* We make sure this is always buffered. */ + to->flush_p = false; + + if (! gfc_output_buffer_empty_p (from)) + { + const char *str = output_buffer_formatted_text (from); + output_buffer_append_r (to, str, strlen (str)); + gfc_clear_pp_buffer (from); + } +} /* Save the existing error state. */ void -gfc_push_error (gfc_error_buf *err) +gfc_push_error (output_buffer *buffer_err, gfc_error_buf *err) { err->flag = error_buffer.flag; if (error_buffer.flag) err->message = xstrdup (error_buffer.message); error_buffer.flag = 0; + + /* This part uses the common diagnostics. */ + gfc_move_output_buffer_from_to (pp_error_buffer, buffer_err); } /* Restore a previous pushed error state. */ void -gfc_pop_error (gfc_error_buf *err) +gfc_pop_error (output_buffer *buffer_err, gfc_error_buf *err) { error_buffer.flag = err->flag; if (error_buffer.flag) @@ -1455,16 +1553,20 @@ gfc_pop_error (gfc_error_buf *err) memcpy (error_buffer.message, err->message, len); free (err->message); } + /* This part uses the common diagnostics. */ + gfc_move_output_buffer_from_to (buffer_err, pp_error_buffer); } /* Free a pushed error state, but keep the current error state. */ void -gfc_free_error (gfc_error_buf *err) +gfc_free_error (output_buffer *buffer_err, gfc_error_buf *err) { if (err->flag) free (err->message); + + gfc_clear_pp_buffer (buffer_err); } @@ -1495,7 +1597,10 @@ gfc_diagnostics_init (void) diagnostic_finalizer (global_dc) = gfc_diagnostic_finalizer; diagnostic_format_decoder (global_dc) = gfc_format_decoder; global_dc->caret_char = '^'; - new (&pp_warning_buffer) output_buffer (); + pp_warning_buffer = new (XNEW (output_buffer)) output_buffer (); + pp_warning_buffer->flush_p = false; + pp_error_buffer = new (XNEW (output_buffer)) output_buffer (); + pp_error_buffer->flush_p = false; } void diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index edf8336..bfe8356 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -2204,9 +2204,9 @@ check_alloc_comp_init (gfc_expr *e) if (comp->attr.allocatable && ctor->expr->expr_type != EXPR_NULL) { - gfc_error("Invalid initialization expression for ALLOCATABLE " - "component '%s' in structure constructor at %L", - comp->name, &ctor->expr->where); + gfc_error ("Invalid initialization expression for ALLOCATABLE " + "component %qs in structure constructor at %L", + comp->name, &ctor->expr->where); return false; } } @@ -2315,7 +2315,7 @@ check_inquiry (gfc_expr *e, int not_restricted) && (ap->expr->symtree->n.sym->ts.u.cl->length == NULL || ap->expr->symtree->n.sym->ts.deferred)) { - gfc_error ("Assumed or deferred character length variable '%s' " + gfc_error ("Assumed or deferred character length variable %qs " " in constant expression at %L", ap->expr->symtree->n.sym->name, &ap->expr->where); @@ -2381,8 +2381,8 @@ check_transformational (gfc_expr *e) if (functions[i] == NULL) { - gfc_error("transformational intrinsic '%s' at %L is not permitted " - "in an initialization expression", name, &e->where); + gfc_error ("transformational intrinsic %qs at %L is not permitted " + "in an initialization expression", name, &e->where); return MATCH_ERROR; } @@ -2481,7 +2481,7 @@ gfc_check_init_expr (gfc_expr *e) if (!gfc_is_intrinsic (sym, 0, e->where) || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES) { - gfc_error ("Function '%s' in initialization expression at %L " + gfc_error ("Function %qs in initialization expression at %L " "must be an intrinsic function", e->symtree->n.sym->name, &e->where); break; @@ -2493,7 +2493,7 @@ gfc_check_init_expr (gfc_expr *e) && (m = check_transformational (e)) == MATCH_NO && (m = check_elemental (e)) == MATCH_NO) { - gfc_error ("Intrinsic function '%s' at %L is not permitted " + gfc_error ("Intrinsic function %qs at %L is not permitted " "in an initialization expression", e->symtree->n.sym->name, &e->where); m = MATCH_ERROR; @@ -2528,8 +2528,8 @@ gfc_check_init_expr (gfc_expr *e) is invalid. */ if (!e->symtree->n.sym->value) { - gfc_error("PARAMETER '%s' is used at %L before its definition " - "is complete", e->symtree->n.sym->name, &e->where); + gfc_error ("PARAMETER %qs is used at %L before its definition " + "is complete", e->symtree->n.sym->name, &e->where); t = false; } else @@ -2548,25 +2548,25 @@ gfc_check_init_expr (gfc_expr *e) switch (e->symtree->n.sym->as->type) { case AS_ASSUMED_SIZE: - gfc_error ("Assumed size array '%s' at %L is not permitted " + gfc_error ("Assumed size array %qs at %L is not permitted " "in an initialization expression", e->symtree->n.sym->name, &e->where); break; case AS_ASSUMED_SHAPE: - gfc_error ("Assumed shape array '%s' at %L is not permitted " + gfc_error ("Assumed shape array %qs at %L is not permitted " "in an initialization expression", e->symtree->n.sym->name, &e->where); break; case AS_DEFERRED: - gfc_error ("Deferred array '%s' at %L is not permitted " + gfc_error ("Deferred array %qs at %L is not permitted " "in an initialization expression", e->symtree->n.sym->name, &e->where); break; case AS_EXPLICIT: - gfc_error ("Array '%s' at %L is a variable, which does " + gfc_error ("Array %qs at %L is a variable, which does " "not reduce to a constant expression", e->symtree->n.sym->name, &e->where); break; @@ -2576,7 +2576,7 @@ gfc_check_init_expr (gfc_expr *e) } } else - gfc_error ("Parameter '%s' at %L has not been declared or is " + gfc_error ("Parameter %qs at %L has not been declared or is " "a variable, which does not reduce to a constant " "expression", e->symtree->n.sym->name, &e->where); @@ -2729,28 +2729,28 @@ external_spec_function (gfc_expr *e) if (f->attr.proc == PROC_ST_FUNCTION) { - gfc_error ("Specification function '%s' at %L cannot be a statement " + gfc_error ("Specification function %qs at %L cannot be a statement " "function", f->name, &e->where); return false; } if (f->attr.proc == PROC_INTERNAL) { - gfc_error ("Specification function '%s' at %L cannot be an internal " + gfc_error ("Specification function %qs at %L cannot be an internal " "function", f->name, &e->where); return false; } if (!f->attr.pure && !f->attr.elemental) { - gfc_error ("Specification function '%s' at %L must be PURE", f->name, + gfc_error ("Specification function %qs at %L must be PURE", f->name, &e->where); return false; } if (f->attr.recursive) { - gfc_error ("Specification function '%s' at %L cannot be RECURSIVE", + gfc_error ("Specification function %qs at %L cannot be RECURSIVE", f->name, &e->where); return false; } @@ -2884,21 +2884,21 @@ check_restricted (gfc_expr *e) if (sym->attr.dummy && sym->ns == gfc_current_ns && sym->ns->proc_name && sym->ns->proc_name->attr.elemental) { - gfc_error ("Dummy argument '%s' not allowed in expression at %L", + gfc_error ("Dummy argument %qs not allowed in expression at %L", sym->name, &e->where); break; } if (sym->attr.optional) { - gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL", + gfc_error ("Dummy argument %qs at %L cannot be OPTIONAL", sym->name, &e->where); break; } if (sym->attr.intent == INTENT_OUT) { - gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)", + gfc_error ("Dummy argument %qs at %L cannot be INTENT(OUT)", sym->name, &e->where); break; } @@ -2929,7 +2929,7 @@ check_restricted (gfc_expr *e) break; } - gfc_error ("Variable '%s' cannot appear in the expression at %L", + gfc_error ("Variable %qs cannot appear in the expression at %L", sym->name, &e->where); /* Prevent a repetition of the error. */ e->error = 1; @@ -2992,7 +2992,7 @@ gfc_specification_expr (gfc_expr *e) && !gfc_pure (e->symtree->n.sym) && (!comp || !comp->attr.pure)) { - gfc_error ("Function '%s' at %L must be PURE", + gfc_error ("Function %qs at %L must be PURE", e->symtree->n.sym->name, &e->where); /* Prevent repeat error messages. */ e->symtree->n.sym->attr.pure = 1; @@ -3138,7 +3138,7 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform) if (bad_proc) { - gfc_error ("'%s' at %L is not a VALUE", sym->name, &lvalue->where); + gfc_error ("%qs at %L is not a VALUE", sym->name, &lvalue->where); return false; } } @@ -3331,7 +3331,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) if (lhs_attr.flavor == FL_PROCEDURE && lhs_attr.use_assoc && !lhs_attr.proc_pointer) { - gfc_error ("'%s' in the pointer assignment at %L cannot be an " + gfc_error ("%qs in the pointer assignment at %L cannot be an " "l-value since it is a procedure", lvalue->symtree->n.sym->name, &lvalue->where); return false; @@ -3354,7 +3354,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) if (ref->u.ar.type != AR_SECTION) { - gfc_error ("Expected bounds specification for '%s' at %L", + gfc_error ("Expected bounds specification for %qs at %L", lvalue->symtree->n.sym->name, &lvalue->where); return false; } @@ -3461,7 +3461,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) for (ns = gfc_current_ns; ns; ns = ns->parent) if (sym == ns->proc_name) { - gfc_error ("Function result '%s' is invalid as proc-target " + gfc_error ("Function result %qs is invalid as proc-target " "in procedure pointer assignment at %L", sym->name, &rvalue->where); return false; @@ -3470,7 +3470,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) } if (attr.abstract) { - gfc_error ("Abstract interface '%s' is invalid " + gfc_error ("Abstract interface %qs is invalid " "in procedure pointer assignment at %L", rvalue->symtree->name, &rvalue->where); return false; @@ -3480,7 +3480,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) { if (attr.proc == PROC_ST_FUNCTION) { - gfc_error ("Statement function '%s' is invalid " + gfc_error ("Statement function %qs is invalid " "in procedure pointer assignment at %L", rvalue->symtree->name, &rvalue->where); return false; @@ -3493,7 +3493,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) if (attr.intrinsic && gfc_intrinsic_actual_ok (rvalue->symtree->name, attr.subroutine) == 0) { - gfc_error ("Intrinsic '%s' at %L is invalid in procedure pointer " + gfc_error ("Intrinsic %qs at %L is invalid in procedure pointer " "assignment", rvalue->symtree->name, &rvalue->where); return false; } @@ -3501,7 +3501,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) /* Check for F08:C730. */ if (attr.elemental && !attr.intrinsic) { - gfc_error ("Nonintrinsic elemental procedure '%s' is invalid " + gfc_error ("Nonintrinsic elemental procedure %qs is invalid " "in procedure pointer assignment at %L", rvalue->symtree->name, &rvalue->where); return false; @@ -3580,14 +3580,14 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) if (s1->attr.if_source == IFSRC_UNKNOWN && gfc_explicit_interface_required (s2, err, sizeof(err))) { - gfc_error ("Explicit interface required for '%s' at %L: %s", + gfc_error ("Explicit interface required for %qs at %L: %s", s1->name, &lvalue->where, err); return false; } if (s2->attr.if_source == IFSRC_UNKNOWN && gfc_explicit_interface_required (s1, err, sizeof(err))) { - gfc_error ("Explicit interface required for '%s' at %L: %s", + gfc_error ("Explicit interface required for %qs at %L: %s", s2->name, &rvalue->where, err); return false; } @@ -3604,7 +3604,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) if (!s2->attr.intrinsic && s2->attr.if_source == IFSRC_UNKNOWN && !s2->attr.external && !s2->attr.subroutine && !s2->attr.function) { - gfc_error ("Procedure pointer target '%s' at %L must be either an " + gfc_error ("Procedure pointer target %qs at %L must be either an " "intrinsic, host or use associated, referenced or have " "the EXTERNAL attribute", s2->name, &rvalue->where); return false; @@ -4758,7 +4758,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, if (!pointer && sym->attr.flavor == FL_PARAMETER) { if (context) - gfc_error ("Named constant '%s' in variable definition context (%s)" + gfc_error ("Named constant %qs in variable definition context (%s)" " at %L", sym->name, context, &e->where); return false; } @@ -4767,7 +4767,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer)) { if (context) - gfc_error ("'%s' in variable definition context (%s) at %L is not" + gfc_error ("%qs in variable definition context (%s) at %L is not" " a variable", sym->name, context, &e->where); return false; } @@ -4820,7 +4820,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, if (pointer && is_pointer) { if (context) - gfc_error ("Dummy argument '%s' with INTENT(IN) in pointer" + gfc_error ("Dummy argument %qs with INTENT(IN) in pointer" " association context (%s) at %L", sym->name, context, &e->where); return false; @@ -4828,7 +4828,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, if (!pointer && !is_pointer && !sym->attr.pointer) { if (context) - gfc_error ("Dummy argument '%s' with INTENT(IN) in variable" + gfc_error ("Dummy argument %qs with INTENT(IN) in variable" " definition context (%s) at %L", sym->name, context, &e->where); return false; @@ -4841,7 +4841,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, if (pointer && is_pointer) { if (context) - gfc_error ("Variable '%s' is PROTECTED and can not appear in a" + gfc_error ("Variable %qs is PROTECTED and can not appear in a" " pointer association context (%s) at %L", sym->name, context, &e->where); return false; @@ -4849,7 +4849,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, if (!pointer && !is_pointer) { if (context) - gfc_error ("Variable '%s' is PROTECTED and can not appear in a" + gfc_error ("Variable %qs is PROTECTED and can not appear in a" " variable definition context (%s) at %L", sym->name, context, &e->where); return false; @@ -4861,7 +4861,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, if (!pointer && !own_scope && gfc_pure (NULL) && gfc_impure_variable (sym)) { if (context) - gfc_error ("Variable '%s' can not appear in a variable definition" + gfc_error ("Variable %qs can not appear in a variable definition" " context (%s) at %L in PURE procedure", sym->name, context, &e->where); return false; @@ -4920,11 +4920,11 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, if (context) { if (assoc->target->expr_type == EXPR_VARIABLE) - gfc_error ("'%s' at %L associated to vector-indexed target can" + gfc_error ("%qs at %L associated to vector-indexed target can" " not be used in a variable definition context (%s)", name, &e->where, context); else - gfc_error ("'%s' at %L associated to expression can" + gfc_error ("%qs at %L associated to expression can" " not be used in a variable definition context (%s)", name, &e->where, context); } @@ -4935,7 +4935,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, if (!gfc_check_vardef_context (assoc->target, pointer, false, false, NULL)) { if (context) - gfc_error ("Associate-name '%s' can not appear in a variable" + gfc_error_1 ("Associate-name '%s' can not appear in a variable" " definition context (%s) at %L because its target" " at %L can not, either", name, context, &e->where, diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 0ed42d0..9d96b85 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2682,6 +2682,7 @@ bool gfc_warning_now (int opt, const char *, ...) ATTRIBUTE_GCC_GFC(2,3); void gfc_clear_warning (void); void gfc_warning_check (void); +void gfc_error_1 (const char *, ...) ATTRIBUTE_GCC_GFC(1,2); void gfc_error (const char *, ...) ATTRIBUTE_GCC_GFC(1,2); void gfc_error_now_1 (const char *, ...) ATTRIBUTE_GCC_GFC(1,2); void gfc_error_now (const char *, ...) ATTRIBUTE_GCC_GFC(1,2); @@ -2698,9 +2699,10 @@ bool gfc_notify_std (int, const char *, ...) ATTRIBUTE_GCC_GFC(2,3); #define gfc_syntax_error(ST) \ gfc_error ("Syntax error in %s statement at %C", gfc_ascii_statement (ST)); -void gfc_push_error (gfc_error_buf *); -void gfc_pop_error (gfc_error_buf *); -void gfc_free_error (gfc_error_buf *); +#include "pretty-print.h" /* For output_buffer. */ +void gfc_push_error (output_buffer *, gfc_error_buf *); +void gfc_pop_error (output_buffer *, gfc_error_buf *); +void gfc_free_error (output_buffer *, gfc_error_buf *); void gfc_get_errors (int *, int *); void gfc_errors_to_warnings (bool); diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index b390dff..5f6ed83 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -219,7 +219,7 @@ gfc_match_interface (void) if (sym->attr.dummy) { - gfc_error ("Dummy procedure '%s' at %C cannot have a " + gfc_error ("Dummy procedure %qs at %C cannot have a " "generic interface", sym->name); return MATCH_ERROR; } @@ -1561,10 +1561,10 @@ check_interface0 (gfc_interface *p, const char *interface_name) && p->sym->attr.flavor != FL_DERIVED) { if (p->sym->attr.external) - gfc_error ("Procedure '%s' in %s at %L has no explicit interface", + gfc_error ("Procedure %qs in %s at %L has no explicit interface", p->sym->name, interface_name, &p->sym->declared_at); else - gfc_error ("Procedure '%s' in %s at %L is neither function nor " + gfc_error ("Procedure %qs in %s at %L is neither function nor " "subroutine", p->sym->name, interface_name, &p->sym->declared_at); return 1; @@ -1645,7 +1645,7 @@ check_interface1 (gfc_interface *p, gfc_interface *q0, generic_flag, 0, NULL, 0, NULL, NULL)) { if (referenced) - gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L", + gfc_error ("Ambiguous interfaces %qs and %qs in %s at %L", p->sym->name, q->sym->name, interface_name, &p->where); else if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc) @@ -1687,7 +1687,7 @@ check_sym_interfaces (gfc_symbol *sym) && (p->sym->attr.if_source != IFSRC_DECL || p->sym->attr.procedure)) { - gfc_error ("'%s' at %L is not a module procedure", + gfc_error ("%qs at %L is not a module procedure", p->sym->name, &p->where); return; } @@ -1892,21 +1892,21 @@ argument_rank_mismatch (const char *name, locus *where, if (rank2 == -1) { gfc_error ("The assumed-rank array at %L requires that the dummy argument" - " '%s' has assumed-rank", where, name); + " %qs has assumed-rank", where, name); } else if (rank1 == 0) { - gfc_error ("Rank mismatch in argument '%s' at %L " + gfc_error ("Rank mismatch in argument %qs at %L " "(scalar and rank-%d)", name, where, rank2); } else if (rank2 == 0) { - gfc_error ("Rank mismatch in argument '%s' at %L " + gfc_error ("Rank mismatch in argument %qs at %L " "(rank-%d and scalar)", name, where, rank1); } else { - gfc_error ("Rank mismatch in argument '%s' at %L " + gfc_error ("Rank mismatch in argument %qs at %L " "(rank-%d and rank-%d)", name, where, rank1, rank2); } } @@ -1956,7 +1956,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, sizeof(err), NULL, NULL)) { if (where) - gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s", + gfc_error ("Interface mismatch in dummy procedure %qs at %L: %s", formal->name, &actual->where, err); return 0; } @@ -1981,7 +1981,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, && !gfc_is_simply_contiguous (actual, true)) { if (where) - gfc_error ("Actual argument to contiguous pointer dummy '%s' at %L " + gfc_error ("Actual argument to contiguous pointer dummy %qs at %L " "must be simply contiguous", formal->name, &actual->where); return 0; } @@ -1996,7 +1996,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, CLASS_DATA (actual)->ts.u.derived))) { if (where) - gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s", + gfc_error ("Type mismatch in argument %qs at %L; passed %s to %s", formal->name, &actual->where, gfc_typename (&actual->ts), gfc_typename (&formal->ts)); return 0; @@ -2006,7 +2006,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, { if (where) gfc_error ("Assumed-type actual argument at %L requires that dummy " - "argument '%s' is of assumed type", &actual->where, + "argument %qs is of assumed type", &actual->where, formal->name); return 0; } @@ -2021,7 +2021,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, if (actual->ts.type != BT_CLASS) { if (where) - gfc_error ("Actual argument to '%s' at %L must be polymorphic", + gfc_error ("Actual argument to %qs at %L must be polymorphic", formal->name, &actual->where); return 0; } @@ -2034,7 +2034,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, CLASS_DATA (formal)->ts.u.derived)) { if (where) - gfc_error ("Actual argument to '%s' at %L must have the same " + gfc_error ("Actual argument to %qs at %L must have the same " "declared type", formal->name, &actual->where); return 0; } @@ -2049,7 +2049,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, ||CLASS_DATA (formal)->attr.class_pointer)) { if (where) - gfc_error ("Actual argument to '%s' at %L must be unlimited " + gfc_error ("Actual argument to %qs at %L must be unlimited " "polymorphic since the formal argument is a " "pointer or allocatable unlimited polymorphic " "entity [F2008: 12.5.2.5]", formal->name, @@ -2060,7 +2060,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, if (formal->attr.codimension && !gfc_is_coarray (actual)) { if (where) - gfc_error ("Actual argument to '%s' at %L must be a coarray", + gfc_error ("Actual argument to %qs at %L must be a coarray", formal->name, &actual->where); return 0; } @@ -2079,7 +2079,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, && actual->symtree->n.sym->as->corank != formal->as->corank)) { if (where) - gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)", + gfc_error ("Corank mismatch in argument %qs at %L (%d and %d)", formal->name, &actual->where, formal->as->corank, last ? last->u.c.component->as->corank : actual->symtree->n.sym->as->corank); @@ -2096,7 +2096,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, && !gfc_is_simply_contiguous (actual, true)) { if (where) - gfc_error ("Actual argument to '%s' at %L must be simply " + gfc_error ("Actual argument to %qs at %L must be simply " "contiguous", formal->name, &actual->where); return 0; } @@ -2110,7 +2110,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, { if (where) - gfc_error ("Actual argument to non-INTENT(INOUT) dummy '%s' at %L, " + gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, " "which is LOCK_TYPE or has a LOCK_TYPE component", formal->name, &actual->where); return 0; @@ -2128,7 +2128,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, || formal->attr.contiguous)) { if (where) - gfc_error ("Dummy argument '%s' has to be a pointer, assumed-shape or " + gfc_error ("Dummy argument %qs has to be a pointer, assumed-shape or " "assumed-rank array without CONTIGUOUS attribute - as actual" " argument at %L is not simply contiguous and both are " "ASYNCHRONOUS or VOLATILE", formal->name, &actual->where); @@ -2142,7 +2142,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, { if (where) gfc_error ("Passing coarray at %L to allocatable, noncoarray, " - "INTENT(OUT) dummy argument '%s'", &actual->where, + "INTENT(OUT) dummy argument %qs", &actual->where, formal->name); return 0; } @@ -2211,7 +2211,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, if (actual->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL) { if (where) - gfc_error ("Polymorphic scalar passed to array dummy argument '%s' " + gfc_error ("Polymorphic scalar passed to array dummy argument %qs " "at %L", formal->name, &actual->where); return 0; } @@ -2221,7 +2221,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, { if (where) gfc_error ("Element of assumed-shaped or pointer " - "array passed to array dummy argument '%s' at %L", + "array passed to array dummy argument %qs at %L", formal->name, &actual->where); return 0; } @@ -2234,14 +2234,14 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, if (where) gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind " "CHARACTER actual argument with array dummy argument " - "'%s' at %L", formal->name, &actual->where); + "%qs at %L", formal->name, &actual->where); return 0; } if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0) { gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with " - "array dummy argument '%s' at %L", + "array dummy argument %qs at %L", formal->name, &actual->where); return 0; } @@ -2555,7 +2555,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, if (f == NULL) { if (where) - gfc_error ("Keyword argument '%s' at %L is not in " + gfc_error ("Keyword argument %qs at %L is not in " "the procedure", a->name, &a->expr->where); return 0; } @@ -2563,7 +2563,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, if (new_arg[i] != NULL) { if (where) - gfc_error ("Keyword argument '%s' at %L is already associated " + gfc_error ("Keyword argument %qs at %L is already associated " "with another actual argument", a->name, &a->expr->where); return 0; @@ -2620,11 +2620,11 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, || (f->sym->ts.type != BT_CLASS && f->sym->attr.allocatable) || (f->sym->ts.type == BT_CLASS && CLASS_DATA (f->sym)->attr.allocatable))) - gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'", + gfc_error ("Unexpected NULL() intrinsic at %L to dummy %qs", where, f->sym->name); else if (where) gfc_error ("Fortran 2008: Null pointer at %L to non-pointer " - "dummy '%s'", where, f->sym->name); + "dummy %qs", where, f->sym->name); return 0; } @@ -2690,7 +2690,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, { if (where) gfc_error ("Actual argument at %L to allocatable or " - "pointer dummy argument '%s' must have a deferred " + "pointer dummy argument %qs must have a deferred " "length type parameter if and only if the dummy has one", &a->expr->where, f->sym->name); return 0; @@ -2730,7 +2730,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, || gfc_is_proc_ptr_comp (a->expr))) { if (where) - gfc_error ("Expected a procedure pointer for argument '%s' at %L", + gfc_error ("Expected a procedure pointer for argument %qs at %L", f->sym->name, &a->expr->where); return 0; } @@ -2741,7 +2741,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, && gfc_expr_attr (a->expr).flavor != FL_PROCEDURE) { if (where) - gfc_error ("Expected a procedure for argument '%s' at %L", + gfc_error ("Expected a procedure for argument %qs at %L", f->sym->name, &a->expr->where); return 0; } @@ -2755,7 +2755,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, && a->expr->ref->u.ar.type == AR_FULL))) { if (where) - gfc_error ("Actual argument for '%s' cannot be an assumed-size" + gfc_error ("Actual argument for %qs cannot be an assumed-size" " array at %L", f->sym->name, where); return 0; } @@ -2764,7 +2764,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, && compare_pointer (f->sym, a->expr) == 0) { if (where) - gfc_error ("Actual argument for '%s' must be a pointer at %L", + gfc_error ("Actual argument for %qs must be a pointer at %L", f->sym->name, &a->expr->where); return 0; } @@ -2775,7 +2775,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, { if (where) gfc_error ("Fortran 2008: Non-pointer actual argument at %L to " - "pointer dummy '%s'", &a->expr->where,f->sym->name); + "pointer dummy %qs", &a->expr->where,f->sym->name); return 0; } @@ -2785,7 +2785,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, { if (where) gfc_error ("Coindexed actual argument at %L to pointer " - "dummy '%s'", + "dummy %qs", &a->expr->where, f->sym->name); return 0; } @@ -2798,7 +2798,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, { if (where) gfc_error ("Coindexed actual argument at %L to allocatable " - "dummy '%s' requires INTENT(IN)", + "dummy %qs requires INTENT(IN)", &a->expr->where, f->sym->name); return 0; } @@ -2812,7 +2812,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, { if (where) gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at " - "%L requires that dummy '%s' has neither " + "%L requires that dummy %qs has neither " "ASYNCHRONOUS nor VOLATILE", &a->expr->where, f->sym->name); return 0; @@ -2826,7 +2826,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, { if (where) gfc_error ("Coindexed actual argument at %L with allocatable " - "ultimate component to dummy '%s' requires either VALUE " + "ultimate component to dummy %qs requires either VALUE " "or INTENT(IN)", &a->expr->where, f->sym->name); return 0; } @@ -2837,7 +2837,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, && !full_array) { if (where) - gfc_error ("Actual CLASS array argument for '%s' must be a full " + gfc_error ("Actual CLASS array argument for %qs must be a full " "array at %L", f->sym->name, &a->expr->where); return 0; } @@ -2847,7 +2847,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, && compare_allocatable (f->sym, a->expr) == 0) { if (where) - gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L", + gfc_error ("Actual argument for %qs must be ALLOCATABLE at %L", f->sym->name, &a->expr->where); return 0; } @@ -2879,7 +2879,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, gfc_error ("Array-section actual argument with vector " "subscripts at %L is incompatible with INTENT(OUT), " "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute " - "of the dummy argument '%s'", + "of the dummy argument %qs", &a->expr->where, f->sym->name); return 0; } @@ -2896,7 +2896,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, if (where) gfc_error ("Assumed-shape actual argument at %L is " "incompatible with the non-assumed-shape " - "dummy argument '%s' due to VOLATILE attribute", + "dummy argument %qs due to VOLATILE attribute", &a->expr->where,f->sym->name); return 0; } @@ -2908,7 +2908,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, if (where) gfc_error ("Array-section actual argument at %L is " "incompatible with the non-assumed-shape " - "dummy argument '%s' due to VOLATILE attribute", + "dummy argument %qs due to VOLATILE attribute", &a->expr->where,f->sym->name); return 0; } @@ -2927,7 +2927,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, if (where) gfc_error ("Pointer-array actual argument at %L requires " "an assumed-shape or pointer-array dummy " - "argument '%s' due to VOLATILE attribute", + "argument %qs due to VOLATILE attribute", &a->expr->where,f->sym->name); return 0; } @@ -2955,7 +2955,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, if (!f->sym->attr.optional) { if (where) - gfc_error ("Missing actual argument for argument '%s' at %L", + gfc_error ("Missing actual argument for argument %qs at %L", f->sym->name, where); return 0; } @@ -3226,7 +3226,7 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a) && gfc_is_coindexed (expr)) { gfc_error ("Coindexed polymorphic actual argument at %L is passed " - "polymorphic dummy argument '%s'", + "polymorphic dummy argument %qs", &expr->where, f->sym->name); return false; } @@ -3253,7 +3253,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) { if (sym->ns->has_implicit_none_export && sym->attr.proc == PROC_UNKNOWN) { - gfc_error ("Procedure '%s' called at %L is not explicitly declared", + gfc_error ("Procedure %qs called at %L is not explicitly declared", sym->name, where); return false; } @@ -3273,24 +3273,24 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) if (sym->attr.pointer) { - gfc_error("The pointer object '%s' at %L must have an explicit " - "function interface or be declared as array", - sym->name, where); + gfc_error ("The pointer object %qs at %L must have an explicit " + "function interface or be declared as array", + sym->name, where); return false; } if (sym->attr.allocatable && !sym->attr.external) { - gfc_error("The allocatable object '%s' at %L must have an explicit " - "function interface or be declared as array", - sym->name, where); + gfc_error ("The allocatable object %qs at %L must have an explicit " + "function interface or be declared as array", + sym->name, where); return false; } if (sym->attr.allocatable) { - gfc_error("Allocatable function '%s' at %L must have an explicit " - "function interface", sym->name, where); + gfc_error ("Allocatable function %qs at %L must have an explicit " + "function interface", sym->name, where); return false; } @@ -3299,8 +3299,8 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */ if (a->name != NULL && a->name[0] != '%') { - gfc_error("Keyword argument requires explicit interface " - "for procedure '%s' at %L", sym->name, &a->expr->where); + gfc_error ("Keyword argument requires explicit interface " + "for procedure %qs at %L", sym->name, &a->expr->where); break; } @@ -3321,9 +3321,9 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) && a->expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE) || gfc_expr_attr (a->expr).lock_comp)) { - gfc_error("Actual argument of LOCK_TYPE or with LOCK_TYPE " - "component at %L requires an explicit interface for " - "procedure '%s'", &a->expr->where, sym->name); + gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE " + "component at %L requires an explicit interface for " + "procedure %qs", &a->expr->where, sym->name); break; } @@ -3387,9 +3387,9 @@ gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where) /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */ if (a->name != NULL && a->name[0] != '%') { - gfc_error("Keyword argument requires explicit interface " - "for procedure pointer component '%s' at %L", - comp->name, &a->expr->where); + gfc_error ("Keyword argument requires explicit interface " + "for procedure pointer component %qs at %L", + comp->name, &a->expr->where); break; } } @@ -3913,7 +3913,7 @@ gfc_check_new_interface (gfc_interface *base, gfc_symbol *new_sym, locus loc) { if (ip->sym == new_sym) { - gfc_error ("Entity '%s' at %L is already present in the interface", + gfc_error ("Entity %qs at %L is already present in the interface", new_sym->name, &loc); return false; } @@ -4124,7 +4124,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old) /* If the overwritten procedure is GENERIC, this is an error. */ if (old->n.tb->is_generic) { - gfc_error ("Can't overwrite GENERIC '%s' at %L", + gfc_error ("Can't overwrite GENERIC %qs at %L", old->name, &proc->n.tb->where); return false; } @@ -4136,7 +4136,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old) /* Check that overridden binding is not NON_OVERRIDABLE. */ if (old->n.tb->non_overridable) { - gfc_error ("'%s' at %L overrides a procedure binding declared" + gfc_error ("%qs at %L overrides a procedure binding declared" " NON_OVERRIDABLE", proc->name, &where); return false; } @@ -4144,7 +4144,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old) /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */ if (!old->n.tb->deferred && proc->n.tb->deferred) { - gfc_error ("'%s' at %L must not be DEFERRED as it overrides a" + gfc_error ("%qs at %L must not be DEFERRED as it overrides a" " non-DEFERRED binding", proc->name, &where); return false; } @@ -4152,7 +4152,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old) /* If the overridden binding is PURE, the overriding must be, too. */ if (old_target->attr.pure && !proc_target->attr.pure) { - gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE", + gfc_error ("%qs at %L overrides a PURE procedure and must also be PURE", proc->name, &where); return false; } @@ -4161,13 +4161,13 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old) is not, the overriding must not be either. */ if (old_target->attr.elemental && !proc_target->attr.elemental) { - gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be" + gfc_error ("%qs at %L overrides an ELEMENTAL procedure and must also be" " ELEMENTAL", proc->name, &where); return false; } if (!old_target->attr.elemental && proc_target->attr.elemental) { - gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not" + gfc_error ("%qs at %L overrides a non-ELEMENTAL procedure and must not" " be ELEMENTAL, either", proc->name, &where); return false; } @@ -4176,7 +4176,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old) SUBROUTINE. */ if (old_target->attr.subroutine && !proc_target->attr.subroutine) { - gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a" + gfc_error ("%qs at %L overrides a SUBROUTINE and must also be a" " SUBROUTINE", proc->name, &where); return false; } @@ -4187,7 +4187,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old) { if (!proc_target->attr.function) { - gfc_error ("'%s' at %L overrides a FUNCTION and must also be a" + gfc_error ("%qs at %L overrides a FUNCTION and must also be a" " FUNCTION", proc->name, &where); return false; } @@ -4196,7 +4196,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old) sizeof(err))) { gfc_error ("Result mismatch for the overriding procedure " - "'%s' at %L: %s", proc->name, &where, err); + "%qs at %L: %s", proc->name, &where, err); return false; } } @@ -4206,7 +4206,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old) if (old->n.tb->access == ACCESS_PUBLIC && proc->n.tb->access == ACCESS_PRIVATE) { - gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be" + gfc_error ("%qs at %L overrides a PUBLIC procedure and must not be" " PRIVATE", proc->name, &where); return false; } @@ -4236,7 +4236,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old) /* Check that the names correspond. */ if (strcmp (proc_formal->sym->name, old_formal->sym->name)) { - gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as" + gfc_error ("Dummy argument %qs of %qs at %L should be named %qs as" " to match the corresponding argument of the overridden" " procedure", proc_formal->sym->name, proc->name, &where, old_formal->sym->name); @@ -4248,7 +4248,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old) check_type, err, sizeof(err))) { gfc_error ("Argument mismatch for the overriding procedure " - "'%s' at %L: %s", proc->name, &where, err); + "%qs at %L: %s", proc->name, &where, err); return false; } @@ -4256,7 +4256,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old) } if (proc_formal || old_formal) { - gfc_error ("'%s' at %L must have the same number of formal arguments as" + gfc_error ("%qs at %L must have the same number of formal arguments as" " the overridden procedure", proc->name, &where); return false; } @@ -4265,7 +4265,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old) NOPASS. */ if (old->n.tb->nopass && !proc->n.tb->nopass) { - gfc_error ("'%s' at %L overrides a NOPASS binding and must also be" + gfc_error ("%qs at %L overrides a NOPASS binding and must also be" " NOPASS", proc->name, &where); return false; } @@ -4276,14 +4276,14 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old) { if (proc->n.tb->nopass) { - gfc_error ("'%s' at %L overrides a binding with PASS and must also be" + gfc_error ("%qs at %L overrides a binding with PASS and must also be" " PASS", proc->name, &where); return false; } if (proc_pass_arg != old_pass_arg) { - gfc_error ("Passed-object dummy argument of '%s' at %L must be at" + gfc_error ("Passed-object dummy argument of %qs at %L must be at" " the same position as the passed-object dummy argument of" " the overridden procedure", proc->name, &where); return false; diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index baaa05a..5abd02d 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -3815,7 +3815,7 @@ sort_actual (const char *name, gfc_actual_arglist **ap, if (a == NULL) goto do_sort; - gfc_error ("Too many arguments in call to '%s' at %L", name, where); + gfc_error ("Too many arguments in call to %qs at %L", name, where); return false; keywords: @@ -3833,14 +3833,14 @@ keywords: gfc_error ("The argument list functions %%VAL, %%LOC or %%REF " "are not allowed in this context at %L", where); else - gfc_error ("Can't find keyword named '%s' in call to '%s' at %L", + gfc_error ("Can't find keyword named %qs in call to %qs at %L", a->name, name, where); return false; } if (f->actual != NULL) { - gfc_error ("Argument '%s' appears twice in call to '%s' at %L", + gfc_error ("Argument %qs appears twice in call to %qs at %L", f->name, name, where); return false; } @@ -3854,7 +3854,7 @@ optional: { if (f->actual == NULL && f->optional == 0) { - gfc_error ("Missing actual argument '%s' in call to '%s' at %L", + gfc_error ("Missing actual argument %qs in call to %qs at %L", f->name, name, where); return false; } @@ -3926,7 +3926,7 @@ check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym, if (!gfc_compare_types (&ts, &actual->expr->ts)) { if (error_flag) - gfc_error ("Type of argument '%s' in call to '%s' at %L should " + gfc_error ("Type of argument %qs in call to %qs at %L should " "be %s, not %s", gfc_current_intrinsic_arg[i]->name, gfc_current_intrinsic, &actual->expr->where, gfc_typename (&formal->ts), @@ -4534,14 +4534,14 @@ gfc_intrinsic_sub_interface (gfc_code *c, int error_flag) if (gfc_do_concurrent_flag && !isym->pure) { - gfc_error ("Subroutine call to intrinsic '%s' in DO CONCURRENT " + gfc_error ("Subroutine call to intrinsic %qs in DO CONCURRENT " "block at %L is not PURE", name, &c->loc); return MATCH_ERROR; } if (!isym->pure && gfc_pure (NULL)) { - gfc_error ("Subroutine call to intrinsic '%s' at %L is not PURE", name, + gfc_error ("Subroutine call to intrinsic %qs at %L is not PURE", name, &c->loc); return MATCH_ERROR; } diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 3b81a46..e322608 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -3548,7 +3548,7 @@ alloc_opt_list: /* The next 2 conditionals check C631. */ if (ts.type != BT_UNKNOWN) { - gfc_error ("SOURCE tag at %L conflicts with the typespec at %L", + gfc_error_1 ("SOURCE tag at %L conflicts with the typespec at %L", &tmp->where, &old_locus); goto cleanup; } @@ -3585,7 +3585,7 @@ alloc_opt_list: /* Check F08:C637. */ if (ts.type != BT_UNKNOWN) { - gfc_error ("MOLD tag at %L conflicts with the typespec at %L", + gfc_error_1 ("MOLD tag at %L conflicts with the typespec at %L", &tmp->where, &old_locus); goto cleanup; } @@ -3611,7 +3611,7 @@ alloc_opt_list: /* Check F08:C637. */ if (source && mold) { - gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L", + gfc_error_1 ("MOLD tag at %L conflicts with SOURCE tag at %L", &mold->where, &source->where); goto cleanup; } @@ -4315,7 +4315,7 @@ gfc_match_common (void) if (sym->attr.in_common) { - gfc_error ("Symbol '%s' at %C is already in a COMMON block", + gfc_error ("Symbol %qs at %C is already in a COMMON block", sym->name); goto cleanup; } @@ -4838,7 +4838,9 @@ recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym) match gfc_match_st_function (void) { - gfc_error_buf old_error; + gfc_error_buf old_error_1; + output_buffer old_error; + gfc_symbol *sym; gfc_expr *expr; match m; @@ -4847,7 +4849,7 @@ gfc_match_st_function (void) if (m != MATCH_YES) return m; - gfc_push_error (&old_error); + gfc_push_error (&old_error, &old_error_1); if (!gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, sym->name, NULL)) goto undo_error; @@ -4859,7 +4861,8 @@ gfc_match_st_function (void) if (m == MATCH_NO) goto undo_error; - gfc_free_error (&old_error); + gfc_free_error (&old_error, &old_error_1); + if (m == MATCH_ERROR) return m; @@ -4877,7 +4880,7 @@ gfc_match_st_function (void) return MATCH_YES; undo_error: - gfc_pop_error (&old_error); + gfc_pop_error (&old_error, &old_error_1); return MATCH_NO; } diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c index 3ee0f92..b0309fc 100644 --- a/gcc/fortran/openmp.c +++ b/gcc/fortran/openmp.c @@ -2326,31 +2326,31 @@ resolve_omp_clauses (gfc_code *code, locus *where, { bool bad = false; if (n->sym->attr.threadprivate) - gfc_error ("THREADPRIVATE object '%s' in %s clause at %L", + gfc_error ("THREADPRIVATE object %qs in %s clause at %L", n->sym->name, name, where); if (n->sym->attr.cray_pointee) - gfc_error ("Cray pointee '%s' in %s clause at %L", + gfc_error ("Cray pointee %qs in %s clause at %L", n->sym->name, name, where); if (n->sym->attr.associate_var) - gfc_error ("ASSOCIATE name '%s' in %s clause at %L", + gfc_error ("ASSOCIATE name %qs in %s clause at %L", n->sym->name, name, where); if (list != OMP_LIST_PRIVATE) { if (n->sym->attr.proc_pointer && list == OMP_LIST_REDUCTION) - gfc_error ("Procedure pointer '%s' in %s clause at %L", + gfc_error ("Procedure pointer %qs in %s clause at %L", n->sym->name, name, where); if (n->sym->attr.pointer && list == OMP_LIST_REDUCTION) - gfc_error ("POINTER object '%s' in %s clause at %L", + gfc_error ("POINTER object %qs in %s clause at %L", n->sym->name, name, where); if (n->sym->attr.cray_pointer && list == OMP_LIST_REDUCTION) - gfc_error ("Cray pointer '%s' in %s clause at %L", + gfc_error ("Cray pointer %qs in %s clause at %L", n->sym->name, name, where); } if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE) - gfc_error ("Assumed size array '%s' in %s clause at %L", + gfc_error ("Assumed size array %qs in %s clause at %L", n->sym->name, name, where); if (n->sym->attr.in_namelist && list != OMP_LIST_REDUCTION) - gfc_error ("Variable '%s' in %s clause is used in " + gfc_error ("Variable %qs in %s clause is used in " "NAMELIST statement at %L", n->sym->name, name, where); if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN) @@ -2360,7 +2360,7 @@ resolve_omp_clauses (gfc_code *code, locus *where, case OMP_LIST_LASTPRIVATE: case OMP_LIST_LINEAR: /* case OMP_LIST_REDUCTION: */ - gfc_error ("INTENT(IN) POINTER '%s' in %s clause at %L", + gfc_error ("INTENT(IN) POINTER %qs in %s clause at %L", n->sym->name, name, where); break; default: @@ -2475,10 +2475,10 @@ resolve_omp_clauses (gfc_code *code, locus *where, break; case OMP_LIST_LINEAR: if (n->sym->ts.type != BT_INTEGER) - gfc_error ("LINEAR variable '%s' must be INTEGER " + gfc_error ("LINEAR variable %qs must be INTEGER " "at %L", n->sym->name, where); else if (!code && !n->sym->attr.value) - gfc_error ("LINEAR dummy argument '%s' must have VALUE " + gfc_error ("LINEAR dummy argument %qs must have VALUE " "attribute at %L", n->sym->name, where); else if (n->expr) { @@ -2486,11 +2486,11 @@ resolve_omp_clauses (gfc_code *code, locus *where, if (!gfc_resolve_expr (expr) || expr->ts.type != BT_INTEGER || expr->rank != 0) - gfc_error ("'%s' in LINEAR clause at %L requires " + gfc_error ("%qs in LINEAR clause at %L requires " "a scalar integer linear-step expression", n->sym->name, where); else if (!code && expr->expr_type != EXPR_CONSTANT) - gfc_error ("'%s' in LINEAR clause at %L requires " + gfc_error ("%qs in LINEAR clause at %L requires " "a constant integer linear-step expression", n->sym->name, where); } @@ -2931,7 +2931,7 @@ resolve_omp_atomic (gfc_code *code) else if (expr_references_sym (arg->expr, var, NULL)) { gfc_error ("!$OMP ATOMIC intrinsic arguments except one must " - "not reference '%s' at %L", + "not reference %qs at %L", var->name, &arg->expr->where); return; } @@ -2946,7 +2946,7 @@ resolve_omp_atomic (gfc_code *code) if (var_arg == NULL) { gfc_error ("First or last !$OMP ATOMIC intrinsic argument must " - "be '%s' at %L", var->name, &expr2->where); + "be %qs at %L", var->name, &expr2->where); return; } @@ -3414,7 +3414,7 @@ gfc_resolve_omp_declare_simd (gfc_namespace *ns) { if (ods->proc_name != ns->proc_name) gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure " - "'%s' at %L", ns->proc_name->name, &ods->where); + "%qs at %L", ns->proc_name->name, &ods->where); if (ods->clauses) resolve_omp_clauses (NULL, &ods->where, ods->clauses, ns); } diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index e39a550..970815e 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -107,13 +107,14 @@ match_word_omp_simd (const char *str, match (*subr) (void), locus *old_locus, static void use_modules (void) { - gfc_error_buf old_error; + gfc_error_buf old_error_1; + output_buffer old_error; - gfc_push_error (&old_error); + gfc_push_error (&old_error, &old_error_1); gfc_buffer_error (false); gfc_use_modules (); gfc_buffer_error (true); - gfc_pop_error (&old_error); + gfc_pop_error (&old_error, &old_error_1); gfc_commit_symbols (); gfc_warning_check (); gfc_current_ns->old_cl_list = gfc_current_ns->cl_list; @@ -2202,7 +2203,7 @@ verify_st_order (st_state *p, gfc_statement st, bool silent) order: if (!silent) - gfc_error ("%s statement at %C cannot follow %s statement at %L", + gfc_error_1 ("%s statement at %C cannot follow %s statement at %L", gfc_ascii_statement (st), gfc_ascii_statement (p->last_statement), &p->where); @@ -2579,7 +2580,7 @@ endType: "subcomponent exists)", c->name, &c->loc, sym->name); if (sym->attr.lock_comp && coarray && !lock_type) - gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with " + gfc_error_1 ("Noncoarray component %s at %L of type LOCK_TYPE or with " "subcomponent of type LOCK_TYPE must have a codimension or " "be a subcomponent of a coarray. (Variables of type %s may " "not have a codimension as %s at %L has a codimension or a " @@ -3281,7 +3282,7 @@ parse_if_block (void) case ST_ELSEIF: if (seen_else) { - gfc_error ("ELSE IF statement at %C cannot follow ELSE " + gfc_error_1 ("ELSE IF statement at %C cannot follow ELSE " "statement at %L", &else_locus); reject_statement (); @@ -4674,10 +4675,10 @@ gfc_global_used (gfc_gsymbol *sym, locus *where) } if (sym->binding_label) - gfc_error ("Global binding name '%s' at %L is already being used as a %s " + gfc_error_1 ("Global binding name '%s' at %L is already being used as a %s " "at %L", sym->binding_label, where, name, &sym->where); else - gfc_error ("Global name '%s' at %L is already being used as a %s at %L", + gfc_error_1 ("Global name '%s' at %L is already being used as a %s at %L", sym->name, where, name, &sym->where); } diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 10ea61a..a9bf658 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -1274,7 +1274,8 @@ static match match_complex_constant (gfc_expr **result) { gfc_expr *e, *real, *imag; - gfc_error_buf old_error; + gfc_error_buf old_error_1; + output_buffer old_error; gfc_typespec target; locus old_loc; int kind; @@ -1287,18 +1288,18 @@ match_complex_constant (gfc_expr **result) if (m != MATCH_YES) return m; - gfc_push_error (&old_error); + gfc_push_error (&old_error, &old_error_1); m = match_complex_part (&real); if (m == MATCH_NO) { - gfc_free_error (&old_error); + gfc_free_error (&old_error, &old_error_1); goto cleanup; } if (gfc_match_char (',') == MATCH_NO) { - gfc_pop_error (&old_error); + gfc_pop_error (&old_error, &old_error_1); m = MATCH_NO; goto cleanup; } @@ -1310,10 +1311,10 @@ match_complex_constant (gfc_expr **result) if (m == MATCH_ERROR) { - gfc_free_error (&old_error); + gfc_free_error (&old_error, &old_error_1); goto cleanup; } - gfc_pop_error (&old_error); + gfc_pop_error (&old_error, &old_error_1); m = match_complex_part (&imag); if (m == MATCH_NO) @@ -2493,7 +2494,7 @@ gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **c gcc_assert (comp_iter); if (!strcmp (comp_iter->name, comp_tail->name)) { - gfc_error ("Component '%s' is initialized twice in the structure" + gfc_error ("Component %qs is initialized twice in the structure" " constructor at %L!", comp_tail->name, comp_tail->val ? &comp_tail->where : &gfc_current_locus); diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 6571578..3270943 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -469,7 +469,7 @@ resolve_formal_arglist (gfc_symbol *proc) || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) && CLASS_DATA (sym)->attr.class_pointer)) { - gfc_error ("Argument '%s' of elemental procedure at %L cannot " + gfc_error ("Argument %qs of elemental procedure at %L cannot " "have the POINTER attribute", sym->name, &sym->declared_at); continue; @@ -477,8 +477,8 @@ resolve_formal_arglist (gfc_symbol *proc) if (sym->attr.flavor == FL_PROCEDURE) { - gfc_error ("Dummy procedure '%s' not allowed in elemental " - "procedure '%s' at %L", sym->name, proc->name, + gfc_error ("Dummy procedure %qs not allowed in elemental " + "procedure %qs at %L", sym->name, proc->name, &sym->declared_at); continue; } @@ -486,7 +486,7 @@ resolve_formal_arglist (gfc_symbol *proc) /* Fortran 2008 Corrigendum 1, C1290a. */ if (sym->attr.intent == INTENT_UNKNOWN && !sym->attr.value) { - gfc_error ("Argument '%s' of elemental procedure '%s' at %L must " + gfc_error ("Argument %qs of elemental procedure %qs at %L must " "have its INTENT specified or have the VALUE " "attribute", sym->name, proc->name, &sym->declared_at); @@ -499,7 +499,7 @@ resolve_formal_arglist (gfc_symbol *proc) { if (sym->as != NULL) { - gfc_error ("Argument '%s' of statement function at %L must " + gfc_error ("Argument %qs of statement function at %L must " "be scalar", sym->name, &sym->declared_at); continue; } @@ -509,7 +509,7 @@ resolve_formal_arglist (gfc_symbol *proc) gfc_charlen *cl = sym->ts.u.cl; if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT) { - gfc_error ("Character-valued argument '%s' of statement " + gfc_error ("Character-valued argument %qs of statement " "function at %L must have constant length", sym->name, &sym->declared_at); continue; @@ -567,10 +567,10 @@ resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns) if (!t && !sym->result->attr.untyped) { if (sym->result == sym) - gfc_error ("Contained function '%s' at %L has no IMPLICIT type", + gfc_error ("Contained function %qs at %L has no IMPLICIT type", sym->name, &sym->declared_at); else if (!sym->result->attr.proc_pointer) - gfc_error ("Result '%s' of contained function '%s' at %L has " + gfc_error ("Result %qs of contained function %qs at %L has " "no IMPLICIT type", sym->result->name, sym->name, &sym->result->declared_at); sym->result->attr.untyped = 1; @@ -594,7 +594,7 @@ resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns) gcc_assert (ns->parent && ns->parent->proc_name); module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE); - gfc_error ("Character-valued %s '%s' at %L must not be" + gfc_error ("Character-valued %s %qs at %L must not be" " assumed length", module_proc ? _("module procedure") : _("internal function"), @@ -984,7 +984,7 @@ resolve_common_blocks (gfc_symtree *common_root) || (!common_root->n.common->binding_label && gsym->binding_label))) { - gfc_error ("In Fortran 2003 COMMON '%s' block at %L is a global " + gfc_error_1 ("In Fortran 2003 COMMON '%s' block at %L is a global " "identifier and must thus have the same binding name " "as the same-named COMMON block at %L: %s vs %s", common_root->n.common->name, &common_root->n.common->where, @@ -998,7 +998,7 @@ resolve_common_blocks (gfc_symtree *common_root) if (gsym && gsym->type != GSYM_COMMON && !common_root->n.common->binding_label) { - gfc_error ("COMMON block '%s' at %L uses the same global identifier " + gfc_error_1 ("COMMON block '%s' at %L uses the same global identifier " "as entity at %L", common_root->n.common->name, &common_root->n.common->where, &gsym->where); @@ -1006,7 +1006,7 @@ resolve_common_blocks (gfc_symtree *common_root) } if (gsym && gsym->type != GSYM_COMMON) { - gfc_error ("Fortran 2008: COMMON block '%s' with binding label at " + gfc_error_1 ("Fortran 2008: COMMON block '%s' with binding label at " "%L sharing the identifier with global non-COMMON-block " "entity at %L", common_root->n.common->name, &common_root->n.common->where, &gsym->where); @@ -1028,7 +1028,7 @@ resolve_common_blocks (gfc_symtree *common_root) common_root->n.common->binding_label); if (gsym && gsym->type != GSYM_COMMON) { - gfc_error ("COMMON block at %L with binding label %s uses the same " + gfc_error_1 ("COMMON block at %L with binding label %s uses the same " "global identifier as entity at %L", &common_root->n.common->where, common_root->n.common->binding_label, &gsym->where); @@ -1049,15 +1049,15 @@ resolve_common_blocks (gfc_symtree *common_root) return; if (sym->attr.flavor == FL_PARAMETER) - gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L", + gfc_error_1 ("COMMON block '%s' at %L is used as PARAMETER at %L", sym->name, &common_root->n.common->where, &sym->declared_at); if (sym->attr.external) - gfc_error ("COMMON block '%s' at %L can not have the EXTERNAL attribute", + gfc_error ("COMMON block %qs at %L can not have the EXTERNAL attribute", sym->name, &common_root->n.common->where); if (sym->attr.intrinsic) - gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure", + gfc_error ("COMMON block %qs at %L is also an intrinsic procedure", sym->name, &common_root->n.common->where); else if (sym->attr.result || gfc_is_function_return_value (sym, gfc_current_ns)) @@ -1171,7 +1171,7 @@ resolve_structure_cons (gfc_expr *expr, int init) else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN) { gfc_error ("The element in the structure constructor at %L, " - "for pointer component '%s', is %s but should be %s", + "for pointer component %qs, is %s but should be %s", &cons->expr->where, comp->name, gfc_basic_typename (cons->expr->ts.type), gfc_basic_typename (comp->ts.type)); @@ -1256,7 +1256,7 @@ resolve_structure_cons (gfc_expr *expr, int init) { t = false; gfc_error ("The NULL in the structure constructor at %L is " - "being applied to component '%s', which is neither " + "being applied to component %qs, which is neither " "a POINTER nor ALLOCATABLE", &cons->expr->where, comp->name); } @@ -1290,7 +1290,7 @@ resolve_structure_cons (gfc_expr *expr, int init) err, sizeof (err), NULL, NULL)) { gfc_error ("Interface mismatch for procedure-pointer component " - "'%s' in structure constructor at %L: %s", + "%qs in structure constructor at %L: %s", comp->name, &cons->expr->where, err); return false; } @@ -1306,7 +1306,7 @@ resolve_structure_cons (gfc_expr *expr, int init) { t = false; gfc_error ("The element in the structure constructor at %L, " - "for pointer component '%s' should be a POINTER or " + "for pointer component %qs should be a POINTER or " "a TARGET", &cons->expr->where, comp->name); } @@ -1335,7 +1335,7 @@ resolve_structure_cons (gfc_expr *expr, int init) { t = false; gfc_error ("Invalid expression in the structure constructor for " - "pointer component '%s' at %L in PURE procedure", + "pointer component %qs at %L in PURE procedure", comp->name, &cons->expr->where); } @@ -1461,7 +1461,7 @@ check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e) { gfc_error ("The upper bound in the last dimension must " "appear in the reference to the assumed size " - "array '%s' at %L", sym->name, &e->where); + "array %qs at %L", sym->name, &e->where); return true; } return false; @@ -1521,11 +1521,11 @@ count_specific_procs (gfc_expr *e) } if (n > 1) - gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name, + gfc_error ("%qs at %L is ambiguous", e->symtree->n.sym->name, &e->where); if (n == 0) - gfc_error ("GENERIC procedure '%s' is not allowed as an actual " + gfc_error ("GENERIC procedure %qs is not allowed as an actual " "argument at %L", sym->name, &e->where); return n; @@ -1659,7 +1659,7 @@ gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc) { if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type) { - gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type" + gfc_error ("Intrinsic subroutine %qs at %L shall not have a type" " specifier", sym->name, &sym->declared_at); return false; } @@ -1670,7 +1670,7 @@ gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc) } else { - gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym->name, + gfc_error ("%qs declared INTRINSIC at %L does not exist", sym->name, &sym->declared_at); return false; } @@ -1683,7 +1683,7 @@ gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc) /* Check it is actually available in the standard settings. */ if (!gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)) { - gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not" + gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not" " available in the current standard settings but %s. Use" " an appropriate -std=* option or enable -fall-intrinsics" " in order to use it.", @@ -1800,7 +1800,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, if (sym->attr.proc == PROC_ST_FUNCTION) { - gfc_error ("Statement function '%s' at %L is not allowed as an " + gfc_error ("Statement function %qs at %L is not allowed as an " "actual argument", sym->name, &e->where); } @@ -1808,7 +1808,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, sym->attr.subroutine); if (sym->attr.intrinsic && actual_ok == 0) { - gfc_error ("Intrinsic '%s' at %L is not allowed as an " + gfc_error ("Intrinsic %qs at %L is not allowed as an " "actual argument", sym->name, &e->where); } @@ -1823,7 +1823,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, if (sym->attr.elemental && !sym->attr.intrinsic) { - gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not " + gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not " "allowed as an actual argument at %L", sym->name, &e->where); } @@ -1851,7 +1851,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, if (isym == NULL || !isym->specific) { gfc_error ("Unable to find a specific INTRINSIC procedure " - "for the reference '%s' at %L", sym->name, + "for the reference %qs at %L", sym->name, &e->where); goto cleanup; } @@ -1872,7 +1872,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st)) { - gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where); + gfc_error ("Symbol %qs at %L is ambiguous", sym->name, &e->where); goto cleanup; } @@ -2139,8 +2139,8 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c) || eformal->sym->attr.intent == INTENT_INOUT) && arg->expr && arg->expr->rank == 0) { - gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of " - "ELEMENTAL subroutine '%s' is a scalar, but another " + gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of " + "ELEMENTAL subroutine %qs is a scalar, but another " "actual argument is an array", &arg->expr->where, (eformal->sym->attr.intent == INTENT_OUT) ? "OUT" : "INOUT", eformal->sym->name, esym->name); @@ -2416,7 +2416,7 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, if (sym->attr.function && !gfc_compare_types (&sym->ts, &def_sym->ts)) { - gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)", + gfc_error ("Return type mismatch of function %qs at %L (%s/%s)", sym->name, &sym->declared_at, gfc_typename (&sym->ts), gfc_typename (&def_sym->ts)); goto done; @@ -2425,7 +2425,7 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, if (sym->attr.if_source == IFSRC_UNKNOWN && gfc_explicit_interface_required (def_sym, reason, sizeof(reason))) { - gfc_error ("Explicit interface required for '%s' at %L: %s", + gfc_error ("Explicit interface required for %qs at %L: %s", sym->name, &sym->declared_at, reason); goto done; } @@ -2437,7 +2437,7 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, if (!gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1, reason, sizeof(reason), NULL, NULL)) { - gfc_error ("Interface mismatch in global procedure '%s' at %L: %s ", + gfc_error ("Interface mismatch in global procedure %qs at %L: %s ", sym->name, &sym->declared_at, reason); goto done; } @@ -2545,7 +2545,7 @@ generic: that possesses a matching interface. 14.1.2.4 */ if (sym && !intr && !gfc_is_intrinsic (sym, 0, expr->where)) { - gfc_error ("There is no specific function for the generic '%s' " + gfc_error ("There is no specific function for the generic %qs " "at %L", expr->symtree->n.sym->name, &expr->where); return false; } @@ -2563,7 +2563,7 @@ generic: return true; if (m == MATCH_NO) - gfc_error ("Generic function '%s' at %L is not consistent with a " + gfc_error ("Generic function %qs at %L is not consistent with a " "specific intrinsic interface", expr->symtree->n.sym->name, &expr->where); @@ -2601,7 +2601,7 @@ resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr) if (m == MATCH_YES) return MATCH_YES; if (m == MATCH_NO) - gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible " + gfc_error ("Function %qs at %L is INTRINSIC but is not compatible " "with an intrinsic", sym->name, &expr->where); return MATCH_ERROR; @@ -2652,7 +2652,7 @@ resolve_specific_f (gfc_expr *expr) break; } - gfc_error ("Unable to resolve the specific function '%s' at %L", + gfc_error ("Unable to resolve the specific function %qs at %L", expr->symtree->n.sym->name, &expr->where); return true; @@ -2708,7 +2708,7 @@ set_type: if (ts->type == BT_UNKNOWN) { - gfc_error ("Function '%s' at %L has no IMPLICIT type", + gfc_error ("Function %qs at %L has no IMPLICIT type", sym->name, &expr->where); return false; } @@ -2829,7 +2829,7 @@ resolve_function (gfc_expr *expr) if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine)) { - gfc_error ("'%s' at %L is not a function", sym->name, &expr->where); + gfc_error ("%qs at %L is not a function", sym->name, &expr->where); return false; } @@ -2837,7 +2837,7 @@ resolve_function (gfc_expr *expr) of course be referenced), expr->value.function.esym will be set. */ if (sym && sym->attr.abstract && !expr->value.function.esym) { - gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L", + gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L", sym->name, &expr->where); return false; } @@ -2880,7 +2880,7 @@ resolve_function (gfc_expr *expr) && !sym->attr.contained) { /* Internal procedures are taken care of in resolve_contained_fntype. */ - gfc_error ("Function '%s' is declared CHARACTER(*) and cannot " + gfc_error ("Function %qs is declared CHARACTER(*) and cannot " "be used at %L since it is not a dummy argument", sym->name, &expr->where); return false; @@ -2934,7 +2934,7 @@ resolve_function (gfc_expr *expr) && expr->value.function.esym && ! gfc_elemental (expr->value.function.esym)) { - gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed " + gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed " "in WORKSHARE construct", expr->value.function.esym->name, &expr->where); t = false; @@ -2988,21 +2988,21 @@ resolve_function (gfc_expr *expr) { if (forall_flag) { - gfc_error ("Reference to non-PURE function '%s' at %L inside a " + gfc_error ("Reference to non-PURE function %qs at %L inside a " "FORALL %s", name, &expr->where, forall_flag == 2 ? "mask" : "block"); t = false; } else if (gfc_do_concurrent_flag) { - gfc_error ("Reference to non-PURE function '%s' at %L inside a " + gfc_error ("Reference to non-PURE function %qs at %L inside a " "DO CONCURRENT %s", name, &expr->where, gfc_do_concurrent_flag == 2 ? "mask" : "block"); t = false; } else if (gfc_pure (NULL)) { - gfc_error ("Function reference to '%s' at %L is to a non-PURE " + gfc_error ("Function reference to %qs at %L is to a non-PURE " "procedure within a PURE procedure", name, &expr->where); t = false; } @@ -3020,11 +3020,11 @@ resolve_function (gfc_expr *expr) if (is_illegal_recursion (esym, gfc_current_ns)) { if (esym->attr.entry && esym->ns->entries) - gfc_error ("ENTRY '%s' at %L cannot be called recursively, as" - " function '%s' is not RECURSIVE", + gfc_error ("ENTRY %qs at %L cannot be called recursively, as" + " function %qs is not RECURSIVE", esym->name, &expr->where, esym->ns->entries->sym->name); else - gfc_error ("Function '%s' at %L cannot be called recursively, as it" + gfc_error ("Function %qs at %L cannot be called recursively, as it" " is not RECURSIVE", esym->name, &expr->where); t = false; @@ -3063,13 +3063,13 @@ pure_subroutine (gfc_code *c, gfc_symbol *sym) return; if (forall_flag) - gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE", + gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE", sym->name, &c->loc); else if (gfc_do_concurrent_flag) - gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not " + gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not " "PURE", sym->name, &c->loc); else if (gfc_pure (NULL)) - gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name, + gfc_error ("Subroutine call to %qs at %L is not PURE", sym->name, &c->loc); gfc_unset_implicit_pure (NULL); @@ -3134,7 +3134,7 @@ generic: if (!gfc_is_intrinsic (sym, 1, c->loc)) { - gfc_error ("There is no specific subroutine for the generic '%s' at %L", + gfc_error ("There is no specific subroutine for the generic %qs at %L", sym->name, &c->loc); return false; } @@ -3143,7 +3143,7 @@ generic: if (m == MATCH_YES) return true; if (m == MATCH_NO) - gfc_error ("Generic subroutine '%s' at %L is not consistent with an " + gfc_error ("Generic subroutine %qs at %L is not consistent with an " "intrinsic subroutine interface", sym->name, &c->loc); return false; @@ -3178,7 +3178,7 @@ resolve_specific_s0 (gfc_code *c, gfc_symbol *sym) if (m == MATCH_YES) return MATCH_YES; if (m == MATCH_NO) - gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible " + gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible " "with an intrinsic", sym->name, &c->loc); return MATCH_ERROR; @@ -3222,7 +3222,7 @@ resolve_specific_s (gfc_code *c) } sym = c->symtree->n.sym; - gfc_error ("Unable to resolve the specific subroutine '%s' at %L", + gfc_error ("Unable to resolve the specific subroutine %qs at %L", sym->name, &c->loc); return false; @@ -3282,7 +3282,7 @@ resolve_call (gfc_code *c) if (csym && csym->ts.type != BT_UNKNOWN) { - gfc_error ("'%s' at %L has a type, which is not consistent with " + gfc_error_1 ("'%s' at %L has a type, which is not consistent with " "the CALL at %L", csym->name, &csym->declared_at, &c->loc); return false; } @@ -3311,7 +3311,7 @@ resolve_call (gfc_code *c) { if (csym->attr.abstract) { - gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L", + gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L", csym->name, &c->loc); return false; } @@ -3321,11 +3321,11 @@ resolve_call (gfc_code *c) if (is_illegal_recursion (csym, gfc_current_ns)) { if (csym->attr.entry && csym->ns->entries) - gfc_error ("ENTRY '%s' at %L cannot be called recursively, " - "as subroutine '%s' is not RECURSIVE", + gfc_error ("ENTRY %qs at %L cannot be called recursively, " + "as subroutine %qs is not RECURSIVE", csym->name, &c->loc, csym->ns->entries->sym->name); else - gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, " + gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, " "as it is not RECURSIVE", csym->name, &c->loc); t = false; @@ -3402,7 +3402,7 @@ compare_shapes (gfc_expr *op1, gfc_expr *op2) { if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0) { - gfc_error ("Shapes for operands at %L and %L are not conformable", + gfc_error_1 ("Shapes for operands at %L and %L are not conformable", &op1->where, &op2->where); t = false; break; @@ -6676,7 +6676,7 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2) if (mpz_cmp (e1->shape[i], s) != 0) { - gfc_error ("Source-expr at %L and allocate-object at %L must " + gfc_error_1 ("Source-expr at %L and allocate-object at %L must " "have the same shape", &e1->where, &e2->where); mpz_clear (s); return false; @@ -6834,8 +6834,8 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) /* Check F03:C631. */ if (!gfc_type_compatible (&e->ts, &code->expr3->ts)) { - gfc_error ("Type of entity at %L is type incompatible with " - "source-expr at %L", &e->where, &code->expr3->where); + gfc_error_1 ("Type of entity at %L is type incompatible with " + "source-expr at %L", &e->where, &code->expr3->where); goto failure; } @@ -6846,7 +6846,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) /* Check F03:C633. */ if (code->expr3->ts.kind != e->ts.kind && !unlimited) { - gfc_error ("The allocate-object at %L and the source-expr at %L " + gfc_error_1 ("The allocate-object at %L and the source-expr at %L " "shall have the same kind type parameter", &e->where, &code->expr3->where); goto failure; @@ -6860,7 +6860,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) && code->expr3->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE))) { - gfc_error ("The source-expr at %L shall neither be of type " + gfc_error_1 ("The source-expr at %L shall neither be of type " "LOCK_TYPE nor have a LOCK_TYPE component if " "allocate-object at %L is a coarray", &code->expr3->where, &e->where); @@ -7204,20 +7204,20 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) { if (pr == NULL && qr == NULL) { - gfc_error ("Allocate-object at %L also appears at %L", - &pe->where, &qe->where); + gfc_error_1 ("Allocate-object at %L also appears at %L", + &pe->where, &qe->where); break; } else if (pr != NULL && qr == NULL) { - gfc_error ("Allocate-object at %L is subobject of" - " object at %L", &pe->where, &qe->where); + gfc_error_1 ("Allocate-object at %L is subobject of" + " object at %L", &pe->where, &qe->where); break; } else if (pr == NULL && qr != NULL) { - gfc_error ("Allocate-object at %L is subobject of" - " object at %L", &qe->where, &pe->where); + gfc_error_1 ("Allocate-object at %L is subobject of" + " object at %L", &qe->where, &pe->where); break; } /* Here, pr != NULL && qr != NULL */ @@ -7420,7 +7420,7 @@ check_case_overlap (gfc_case *list) element in the list. Either way, we must issue an error and get the next case from P. */ /* FIXME: Sort P and Q by line number. */ - gfc_error ("CASE label at %L overlaps with CASE " + gfc_error_1 ("CASE label at %L overlaps with CASE " "label at %L", &p->where, &q->where); overlap_seen = 1; e = p; @@ -7658,7 +7658,7 @@ resolve_select (gfc_code *code, bool select_type) { if (default_case != NULL) { - gfc_error ("The DEFAULT CASE at %L cannot be followed " + gfc_error_1 ("The DEFAULT CASE at %L cannot be followed " "by a second DEFAULT CASE at %L", &default_case->where, &cp->where); t = false; @@ -8028,7 +8028,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) /* Check F03:C818. */ if (default_case) { - gfc_error ("The DEFAULT CASE at %L cannot be followed " + gfc_error_1 ("The DEFAULT CASE at %L cannot be followed " "by a second DEFAULT CASE at %L", &default_case->ext.block.case_list->where, &c->where); error++; @@ -8586,7 +8586,7 @@ resolve_branch (gfc_st_label *label, gfc_code *code) if (label->defined != ST_LABEL_TARGET && label->defined != ST_LABEL_DO_TARGET) { - gfc_error ("Statement at %L is not a valid branch target statement " + gfc_error_1 ("Statement at %L is not a valid branch target statement " "for the branch statement at %L", &label->where, &code->loc); return; } @@ -8612,11 +8612,11 @@ resolve_branch (gfc_st_label *label, gfc_code *code) { if (stack->current->op == EXEC_CRITICAL && bitmap_bit_p (stack->reachable_labels, label->value)) - gfc_error ("GOTO statement at %L leaves CRITICAL construct for " + gfc_error_1 ("GOTO statement at %L leaves CRITICAL construct for " "label at %L", &code->loc, &label->where); else if (stack->current->op == EXEC_DO_CONCURRENT && bitmap_bit_p (stack->reachable_labels, label->value)) - gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct " + gfc_error_1 ("GOTO statement at %L leaves DO CONCURRENT construct " "for label at %L", &code->loc, &label->where); } @@ -8635,13 +8635,13 @@ resolve_branch (gfc_st_label *label, gfc_code *code) { /* Note: A label at END CRITICAL does not leave the CRITICAL construct as END CRITICAL is still part of it. */ - gfc_error ("GOTO statement at %L leaves CRITICAL construct for label" + gfc_error_1 ("GOTO statement at %L leaves CRITICAL construct for label" " at %L", &code->loc, &label->where); return; } else if (stack->current->op == EXEC_DO_CONCURRENT) { - gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for " + gfc_error_1 ("GOTO statement at %L leaves DO CONCURRENT construct for " "label at %L", &code->loc, &label->where); return; } @@ -10001,7 +10001,7 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns) gfc_error ("ASSIGNED GOTO statement at %L requires an " "INTEGER variable", &code->expr1->where); else if (code->expr1->symtree->n.sym->attr.assign != 1) - gfc_error ("Variable '%s' has not been assigned a target " + gfc_error ("Variable %qs has not been assigned a target " "label at %L", code->expr1->symtree->n.sym->name, &code->expr1->where); } @@ -10386,7 +10386,7 @@ gfc_verify_binding_labels (gfc_symbol *sym) if (sym->attr.flavor == FL_VARIABLE && gsym->type != GSYM_UNKNOWN) { - gfc_error ("Variable %s with binding label %s at %L uses the same global " + gfc_error_1 ("Variable %s with binding label %s at %L uses the same global " "identifier as entity at %L", sym->name, sym->binding_label, &sym->declared_at, &gsym->where); /* Clear the binding label to prevent checking multiple times. */ @@ -10399,8 +10399,8 @@ gfc_verify_binding_labels (gfc_symbol *sym) { /* This can only happen if the variable is defined in a module - if it isn't the same module, reject it. */ - gfc_error ("Variable %s from module %s with binding label %s at %L uses " - "the same global identifier as entity at %L from module %s", + gfc_error_1 ("Variable %s from module %s with binding label %s at %L uses " + "the same global identifier as entity at %L from module %s", sym->name, module, sym->binding_label, &sym->declared_at, &gsym->where, gsym->mod_name); sym->binding_label = NULL; @@ -10416,7 +10416,7 @@ gfc_verify_binding_labels (gfc_symbol *sym) /* Print an error if the procedure is defined multiple times; we have to exclude references to the same procedure via module association or multiple checks for the same procedure. */ - gfc_error ("Procedure %s with binding label %s at %L uses the same " + gfc_error_1 ("Procedure %s with binding label %s at %L uses the same " "global identifier as entity at %L", sym->name, sym->binding_label, &sym->declared_at, &gsym->where); sym->binding_label = NULL; @@ -10916,7 +10916,7 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) s = gfc_find_dt_in_generic (s); if (s && s->attr.flavor != FL_DERIVED) { - gfc_error ("The type '%s' cannot be host associated at %L " + gfc_error_1 ("The type '%s' cannot be host associated at %L " "because it is blocked by an incompatible object " "of the same name declared at %L", sym->ts.u.derived->name, &sym->declared_at, @@ -12335,7 +12335,7 @@ resolve_fl_derived0 (gfc_symbol *sym) && c->attr.codimension && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED))) { - gfc_error ("Coarray component '%s' at %L must be allocatable with " + gfc_error ("Coarray component %qs at %L must be allocatable with " "deferred shape", c->name, &c->loc); return false; } @@ -12344,7 +12344,7 @@ resolve_fl_derived0 (gfc_symbol *sym) if (c->attr.codimension && c->ts.type == BT_DERIVED && c->ts.u.derived->ts.is_iso_c) { - gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) " + gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) " "shall not be a coarray", c->name, &c->loc); return false; } @@ -12354,7 +12354,7 @@ resolve_fl_derived0 (gfc_symbol *sym) && (c->attr.codimension || c->attr.pointer || c->attr.dimension || c->attr.allocatable)) { - gfc_error ("Component '%s' at %L with coarray component " + gfc_error ("Component %qs at %L with coarray component " "shall be a nonpointer, nonallocatable scalar", c->name, &c->loc); return false; @@ -12363,7 +12363,7 @@ resolve_fl_derived0 (gfc_symbol *sym) /* F2008, C448. */ if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer)) { - gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but " + gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but " "is not an array pointer", c->name, &c->loc); return false; } @@ -12456,8 +12456,8 @@ resolve_fl_derived0 (gfc_symbol *sym) if (!me_arg) { - gfc_error ("Procedure pointer component '%s' with PASS(%s) " - "at %L has no argument '%s'", c->name, + gfc_error ("Procedure pointer component %qs with PASS(%s) " + "at %L has no argument %qs", c->name, c->tb->pass_arg, &c->loc, c->tb->pass_arg); c->tb->error = 1; return false; @@ -12470,7 +12470,7 @@ resolve_fl_derived0 (gfc_symbol *sym) c->tb->pass_arg_num = 1; if (!c->ts.interface->formal) { - gfc_error ("Procedure pointer component '%s' with PASS at %L " + gfc_error ("Procedure pointer component %qs with PASS at %L " "must have at least one argument", c->name, &c->loc); c->tb->error = 1; @@ -12486,8 +12486,8 @@ resolve_fl_derived0 (gfc_symbol *sym) || (me_arg->ts.type == BT_CLASS && CLASS_DATA (me_arg)->ts.u.derived != sym)) { - gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of" - " the derived type '%s'", me_arg->name, c->name, + gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of" + " the derived type %qs", me_arg->name, c->name, me_arg->name, &c->loc, sym->name); c->tb->error = 1; return false; @@ -12496,7 +12496,7 @@ resolve_fl_derived0 (gfc_symbol *sym) /* Check for C453. */ if (me_arg->attr.dimension) { - gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L " + gfc_error ("Argument %qs of %qs with PASS(%s) at %L " "must be scalar", me_arg->name, c->name, me_arg->name, &c->loc); c->tb->error = 1; @@ -12505,7 +12505,7 @@ resolve_fl_derived0 (gfc_symbol *sym) if (me_arg->attr.pointer) { - gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L " + gfc_error ("Argument %qs of %qs with PASS(%s) at %L " "may not have the POINTER attribute", me_arg->name, c->name, me_arg->name, &c->loc); c->tb->error = 1; @@ -12514,7 +12514,7 @@ resolve_fl_derived0 (gfc_symbol *sym) if (me_arg->attr.allocatable) { - gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L " + gfc_error ("Argument %qs of %qs with PASS(%s) at %L " "may not be ALLOCATABLE", me_arg->name, c->name, me_arg->name, &c->loc); c->tb->error = 1; @@ -12522,7 +12522,7 @@ resolve_fl_derived0 (gfc_symbol *sym) } if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS) - gfc_error ("Non-polymorphic passed-object dummy argument of '%s'" + gfc_error ("Non-polymorphic passed-object dummy argument of %qs" " at %L", c->name, &c->loc); } @@ -12551,7 +12551,7 @@ resolve_fl_derived0 (gfc_symbol *sym) if (super_type && !sym->attr.is_class && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL)) { - gfc_error ("Component '%s' of '%s' at %L has the same name as an" + gfc_error ("Component %qs of %qs at %L has the same name as an" " inherited type-bound procedure", c->name, sym->name, &c->loc); return false; @@ -12564,7 +12564,7 @@ resolve_fl_derived0 (gfc_symbol *sym) || (!resolve_charlen(c->ts.u.cl)) || !gfc_is_constant_expr (c->ts.u.cl->length)) { - gfc_error ("Character length of component '%s' needs to " + gfc_error ("Character length of component %qs needs to " "be a constant specification expression at %L", c->name, c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc); @@ -12575,7 +12575,7 @@ resolve_fl_derived0 (gfc_symbol *sym) if (c->ts.type == BT_CHARACTER && c->ts.deferred && !c->attr.pointer && !c->attr.allocatable) { - gfc_error ("Character component '%s' of '%s' at %L with deferred " + gfc_error ("Character component %qs of %qs at %L with deferred " "length must be a POINTER or ALLOCATABLE", c->name, sym->name, &c->loc); return false; @@ -12641,7 +12641,7 @@ resolve_fl_derived0 (gfc_symbol *sym) && c->attr.pointer && c->ts.u.derived->components == NULL && !c->ts.u.derived->attr.zero_comp) { - gfc_error ("The pointer component '%s' of '%s' at %L is a type " + gfc_error ("The pointer component %qs of %qs at %L is a type " "that has not been declared", c->name, sym->name, &c->loc); return false; @@ -12653,7 +12653,7 @@ resolve_fl_derived0 (gfc_symbol *sym) && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp && !UNLIMITED_POLY (c)) { - gfc_error ("The pointer component '%s' of '%s' at %L is a type " + gfc_error ("The pointer component %qs of %qs at %L is a type " "that has not been declared", c->name, sym->name, &c->loc); return false; @@ -12665,7 +12665,7 @@ resolve_fl_derived0 (gfc_symbol *sym) || !(CLASS_DATA (c)->attr.class_pointer || CLASS_DATA (c)->attr.allocatable))) { - gfc_error ("Component '%s' with CLASS at %L must be allocatable " + gfc_error ("Component %qs with CLASS at %L must be allocatable " "or pointer", c->name, &c->loc); /* Prevent a recurrence of the error. */ c->ts.type = BT_UNKNOWN; @@ -13317,7 +13317,7 @@ resolve_symbol (gfc_symbol *sym) if (sym->ns->proc_name->attr.flavor != FL_MODULE && sym->attr.in_common == 0) { - gfc_error ("Variable '%s' at %L cannot be BIND(C) because it " + gfc_error ("Variable %qs at %L cannot be BIND(C) because it " "is neither a COMMON block nor declared at the " "module level scope", sym->name, &(sym->declared_at)); t = false; diff --git a/gcc/fortran/scanner.c b/gcc/fortran/scanner.c index 718c323..6a37036 100644 --- a/gcc/fortran/scanner.c +++ b/gcc/fortran/scanner.c @@ -2045,6 +2045,7 @@ load_file (const char *realfilename, const char *displayedname, bool initial) b = XCNEWVAR (gfc_linebuf, gfc_linebuf_header_size + (len + 1) * sizeof (gfc_char_t)); + b->location = linemap_line_start (line_table, current_file->line++, len); /* ??? We add the location for the maximum column possible here, diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 92a15d0..aab144a 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -1701,18 +1701,18 @@ gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where) if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type)) { if (sym->attr.use_assoc) - gfc_error ("Symbol '%s' at %L conflicts with symbol from module '%s', " + gfc_error_1 ("Symbol '%s' at %L conflicts with symbol from module '%s', " "use-associated at %L", sym->name, where, sym->module, &sym->declared_at); else - gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name, + gfc_error ("Symbol %qs at %L already has basic type of %s", sym->name, where, gfc_basic_typename (type)); return false; } if (sym->attr.procedure && sym->ts.interface) { - gfc_error ("Procedure '%s' at %L may not have basic type of %s", + gfc_error ("Procedure %qs at %L may not have basic type of %s", sym->name, where, gfc_basic_typename (ts->type)); return false; } @@ -1895,7 +1895,7 @@ gfc_add_component (gfc_symbol *sym, const char *name, { if (strcmp (p->name, name) == 0) { - gfc_error ("Component '%s' at %C already declared at %L", + gfc_error_1 ("Component '%s' at %C already declared at %L", name, &p->loc); return false; } @@ -1906,7 +1906,7 @@ gfc_add_component (gfc_symbol *sym, const char *name, if (sym->attr.extension && gfc_find_component (sym->components->ts.u.derived, name, true, true)) { - gfc_error ("Component '%s' at %C already in the parent type " + gfc_error_1 ("Component '%s' at %C already in the parent type " "at %L", name, &sym->components->ts.u.derived->declared_at); return false; } @@ -2061,7 +2061,7 @@ gfc_find_component (gfc_symbol *sym, const char *name, && !is_parent_comp)) { if (!silent) - gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'", + gfc_error ("Component %qs at %C is a PRIVATE component of %qs", name, sym->name); return NULL; } @@ -2079,7 +2079,7 @@ gfc_find_component (gfc_symbol *sym, const char *name, } if (p == NULL && !silent) - gfc_error ("'%s' at %C is not a member of the '%s' structure", + gfc_error ("%qs at %C is not a member of the %qs structure", name, sym->name); return p; @@ -2218,7 +2218,7 @@ gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus) labelno = lp->value; if (lp->defined != ST_LABEL_UNKNOWN) - gfc_error ("Duplicate statement label %d at %L and %L", labelno, + gfc_error_1 ("Duplicate statement label %d at %L and %L", labelno, &lp->where, label_locus); else { @@ -2628,10 +2628,10 @@ ambiguous_symbol (const char *name, gfc_symtree *st) { if (st->n.sym->module) - gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' " - "from module '%s'", name, st->n.sym->name, st->n.sym->module); + gfc_error ("Name %qs at %C is an ambiguous reference to %qs " + "from module %qs", name, st->n.sym->name, st->n.sym->module); else - gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' " + gfc_error ("Name %qs at %C is an ambiguous reference to %qs " "from current program unit", name, st->n.sym->name); } @@ -2852,7 +2852,7 @@ gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result, && (ns->has_import_set || p->attr.imported))) { /* Symbol is from another namespace. */ - gfc_error ("Symbol '%s' at %C has already been host associated", + gfc_error ("Symbol %qs at %C has already been host associated", name); return 2; } @@ -3895,7 +3895,7 @@ verify_bind_c_derived_type (gfc_symbol *derived_sym) J3/04-007, Section 15.2.3, C1505. */ if (curr_comp->attr.pointer != 0) { - gfc_error ("Component '%s' at %L cannot have the " + gfc_error_1 ("Component '%s' at %L cannot have the " "POINTER attribute because it is a member " "of the BIND(C) derived type '%s' at %L", curr_comp->name, &(curr_comp->loc), @@ -3905,7 +3905,7 @@ verify_bind_c_derived_type (gfc_symbol *derived_sym) if (curr_comp->attr.proc_pointer != 0) { - gfc_error ("Procedure pointer component '%s' at %L cannot be a member" + gfc_error_1 ("Procedure pointer component '%s' at %L cannot be a member" " of the BIND(C) derived type '%s' at %L", curr_comp->name, &curr_comp->loc, derived_sym->name, &derived_sym->declared_at); @@ -3916,7 +3916,7 @@ verify_bind_c_derived_type (gfc_symbol *derived_sym) J3/04-007, Section 15.2.3, C1505. */ if (curr_comp->attr.allocatable != 0) { - gfc_error ("Component '%s' at %L cannot have the " + gfc_error_1 ("Component '%s' at %L cannot have the " "ALLOCATABLE attribute because it is a member " "of the BIND(C) derived type '%s' at %L", curr_comp->name, &(curr_comp->loc), diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c index f5d831f..a7d89c2 100644 --- a/gcc/fortran/trans-common.c +++ b/gcc/fortran/trans-common.c @@ -908,7 +908,7 @@ confirm_condition (segment_info *s1, gfc_equiv *eq1, segment_info *s2, offset2 = calculate_offset (eq2->expr); if (s1->offset + offset1 != s2->offset + offset2) - gfc_error ("Inconsistent equivalence rules involving '%s' at %L and " + gfc_error_1 ("Inconsistent equivalence rules involving '%s' at %L and " "'%s' at %L", s1->sym->name, &s1->sym->declared_at, s2->sym->name, &s2->sym->declared_at); } diff --git a/gcc/pretty-print.c b/gcc/pretty-print.c index 92912ca..0dbda9b 100644 --- a/gcc/pretty-print.c +++ b/gcc/pretty-print.c @@ -55,9 +55,6 @@ output_buffer::~output_buffer () obstack_free (&formatted_obstack, NULL); } -/* A pointer to the formatted diagnostic message. */ -#define pp_formatted_text_data(PP) \ - ((const char *) obstack_base (pp_buffer (PP)->obstack)) /* Format an integer given by va_arg (ARG, type-specifier T) where type-specifier is a precision modifier as indicated by PREC. F is @@ -225,8 +222,7 @@ pp_maybe_wrap_text (pretty_printer *pp, const char *start, const char *end) static inline void pp_append_r (pretty_printer *pp, const char *start, int length) { - obstack_grow (pp_buffer (pp)->obstack, start, length); - pp_buffer (pp)->line_length += length; + output_buffer_append_r (pp_buffer (pp), start, length); } /* Insert enough spaces into the output area of PRETTY-PRINTER to bring @@ -826,8 +822,7 @@ pp_append_text (pretty_printer *pp, const char *start, const char *end) const char * pp_formatted_text (pretty_printer *pp) { - obstack_1grow (pp_buffer (pp)->obstack, '\0'); - return pp_formatted_text_data (pp); + return output_buffer_formatted_text (pp_buffer (pp)); } /* Return a pointer to the last character emitted in PRETTY-PRINTER's @@ -835,12 +830,7 @@ pp_formatted_text (pretty_printer *pp) const char * pp_last_position_in_text (const pretty_printer *pp) { - const char *p = NULL; - struct obstack *text = pp_buffer (pp)->obstack; - - if (obstack_base (text) != obstack_next_free (text)) - p = ((const char *) obstack_next_free (text)) - 1; - return p; + return output_buffer_last_position_in_text (pp_buffer (pp)); } /* Return the amount of characters PRETTY-PRINTER can accept to diff --git a/gcc/pretty-print.h b/gcc/pretty-print.h index d9e49be..3b72d59 100644 --- a/gcc/pretty-print.h +++ b/gcc/pretty-print.h @@ -107,6 +107,38 @@ struct output_buffer bool flush_p; }; +/* Finishes constructing a NULL-terminated character string representing + the buffered text. */ +static inline const char * +output_buffer_formatted_text (output_buffer *buff) +{ + obstack_1grow (buff->obstack, '\0'); + return (const char *) obstack_base (buff->obstack); +} + +/* Append to the output buffer a string specified by its + STARTing character and LENGTH. */ +static inline void +output_buffer_append_r (output_buffer *buff, const char *start, int length) +{ + obstack_grow (buff->obstack, start, length); + buff->line_length += length; +} + +/* Return a pointer to the last character emitted in the + output_buffer. A NULL pointer means no character available. */ +static inline const char * +output_buffer_last_position_in_text (const output_buffer *buff) +{ + const char *p = NULL; + struct obstack *text = buff->obstack; + + if (obstack_base (text) != obstack_next_free (text)) + p = ((const char *) obstack_next_free (text)) - 1; + return p; +} + + /* The type of pretty-printer flags passed to clients. */ typedef unsigned int pp_flags; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 0ab4b39..c6a1932 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2014-12-11 Manuel López-Ibáñez + + * gfortran.dg/do_iterator.f90: Remove bogus dg-warning. + 2014-12-11 Kyrylo Tkachov * config/arm/arm_neon.h (vrndqn_f32): Rename to... -- 2.7.4