From patchwork Sun Dec 7 00:27:27 2014 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?b?TWFudWVsIEzDs3Blei1JYsOhw7Fleg==?= X-Patchwork-Id: 418442 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 36B06140082 for ; Sun, 7 Dec 2014 11:28:39 +1100 (AEDT) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :mime-version:from:date:message-id:subject:to:cc:content-type; q=dns; s=default; b=UQwjD0l3etr0DJWV7ib+MGB9QlvAJhCqAy+aNJavi5W kDx8ULPLEOPRwC1Ta5J9u0CtTHzpMTcNOSToXB7dgT/doG90i6SdBJSEErcGhFBF v3YdrwcRFTCwMcNO6DVQK21LWqm1L2QHR4+jfSMucZYfhZD3b/SV9QE+xgTLYas4 = DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :mime-version:from:date:message-id:subject:to:cc:content-type; s=default; bh=Rg6GJpW1TYYEaG3M3tZsOFil178=; b=piNm33k/OEuZwGiAY TEa+OIn3qZaNzTOR/Pt+jpGCxKUP/ZKZQe+W63X6zJH1jm30Y1KrXgNu1l6jnM0K xIOiqeoEFuFe4vlzW2JUoBlCja4hoPliFye/SvW1ANphbxE/gcIVuxttVrBy7IB2 0wTIFBRDc7XUxIJAZyQ/eS13Mk= Received: (qmail 14953 invoked by alias); 7 Dec 2014 00:28:27 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 14934 invoked by uid 89); 7 Dec 2014 00:28:26 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=1.3 required=5.0 tests=AWL, BAYES_99, BAYES_999, FREEMAIL_FROM, KAM_STOCKGEN, RCVD_IN_DNSWL_LOW, SPF_PASS autolearn=no version=3.3.2 X-Spam-User: qpsmtpd, 2 recipients X-HELO: mail-wg0-f47.google.com Received: from mail-wg0-f47.google.com (HELO mail-wg0-f47.google.com) (74.125.82.47) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES128-SHA encrypted) ESMTPS; Sun, 07 Dec 2014 00:28:12 +0000 Received: by mail-wg0-f47.google.com with SMTP id n12so3628965wgh.20 for ; Sat, 06 Dec 2014 16:28:08 -0800 (PST) X-Received: by 10.194.7.97 with SMTP id i1mr25615334wja.31.1417912088266; Sat, 06 Dec 2014 16:28:08 -0800 (PST) MIME-Version: 1.0 Received: by 10.217.141.72 with HTTP; Sat, 6 Dec 2014 16:27:27 -0800 (PST) From: =?ISO-8859-1?Q?Manuel_L=F3pez=2DIb=E1=F1ez?= Date: Sun, 7 Dec 2014 01:27:27 +0100 Message-ID: Subject: [PATCH fortran/diagnostics] Move gfc_error (buffered) to common diagnostics To: Tobias Burnus Cc: Gcc Patch List , "fortran@gcc.gnu.org List" , Dodji Seketeli OK, this is then the final patch. Bootstrapped and regression tested on x86_64-linux-gnu. OK to commit? gcc/ChangeLog: 2014-12-07 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. (diagnostic_report_diagnostic): Update call according to the above. (error_recursion): Likewise. * diagnostic.h (diagnostic_action_after_output): Declare. * pretty-print.c (pp_formatted_text_data): Delete. (pp_append_r): Call output_buffer_append_r. (pp_formatted_text): Call output_buffer_formatted_text. (pp_last_position_in_text): Call output_buffer_last_position_in_text. * pretty-print.h (output_buffer_formatted_text): New. (output_buffer_append_r): New. (output_buffer_last_position_in_text): New gcc/testsuite/ChangeLog: 2014-12-07 Manuel López-Ibáñez * gfortran.dg/do_iterator.f90: Remove bogus dg-warning. gcc/fortran/ChangeLog: 2014-12-07 Manuel López-Ibáñez PR fortran/44054 * error.c (pp_error_buffer): New static variable. (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. (gfc_error_1): Renamed from gfc_error. (gfc_error): New. (gfc_clear_error): Clear also pp_error_buffer. (gfc_error_flag_test): Check also pp_error_buffer. (gfc_error_check): Likewise. Only check the new pp_error_buffer if the old error_buffer was empty. (gfc_move_output_buffer_from_to): New. (gfc_push_error): Use it here. Take also an output_buffer as argument. (gfc_pop_error): Likewise. (gfc_free_error): Likewise. (gfc_diagnostics_init): Init pp_error_buffer. Set flush_p to false for both pp_warning_buffer and pp_error_buffer. * Update gfc_push_error, gfc_pop_error and gfc_free_error calls according to the above changes. * Use gfc_error_1 for all gfc_error calls that use multiple locations. * Use %qs instead of '%s' for many gfc_error calls. Index: gcc/fortran/openmp.c =================================================================== --- gcc/fortran/openmp.c (revision 218457) +++ gcc/fortran/openmp.c (working copy) @@ -2324,45 +2324,45 @@ resolve_omp_clauses (gfc_code *code, loc default: for (; n != NULL; n = n->next) { bool bad = false; if (n->sym->attr.threadprivate) - gfc_error ("THREADPRIVATE object '%s' in %s clause at %L", + gfc_error ("THREADPRIVATE object %qs in %s clause at %L", n->sym->name, name, where); if (n->sym->attr.cray_pointee) - gfc_error ("Cray pointee '%s' in %s clause at %L", + gfc_error ("Cray pointee %qs in %s clause at %L", n->sym->name, name, where); if (n->sym->attr.associate_var) - gfc_error ("ASSOCIATE name '%s' in %s clause at %L", + gfc_error ("ASSOCIATE name %qs in %s clause at %L", n->sym->name, name, where); if (list != OMP_LIST_PRIVATE) { if (n->sym->attr.proc_pointer && list == OMP_LIST_REDUCTION) - gfc_error ("Procedure pointer '%s' in %s clause at %L", + gfc_error ("Procedure pointer %qs in %s clause at %L", n->sym->name, name, where); if (n->sym->attr.pointer && list == OMP_LIST_REDUCTION) - gfc_error ("POINTER object '%s' in %s clause at %L", + gfc_error ("POINTER object %qs in %s clause at %L", n->sym->name, name, where); if (n->sym->attr.cray_pointer && list == OMP_LIST_REDUCTION) - gfc_error ("Cray pointer '%s' in %s clause at %L", + gfc_error ("Cray pointer %qs in %s clause at %L", n->sym->name, name, where); } if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE) - gfc_error ("Assumed size array '%s' in %s clause at %L", + gfc_error ("Assumed size array %qs in %s clause at %L", n->sym->name, name, where); if (n->sym->attr.in_namelist && list != OMP_LIST_REDUCTION) - gfc_error ("Variable '%s' in %s clause is used in " + gfc_error ("Variable %qs in %s clause is used in " "NAMELIST statement at %L", n->sym->name, name, where); if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN) switch (list) { case OMP_LIST_PRIVATE: case OMP_LIST_LASTPRIVATE: case OMP_LIST_LINEAR: /* case OMP_LIST_REDUCTION: */ - gfc_error ("INTENT(IN) POINTER '%s' in %s clause at %L", + gfc_error ("INTENT(IN) POINTER %qs in %s clause at %L", n->sym->name, name, where); break; default: break; } @@ -2473,26 +2473,26 @@ resolve_omp_clauses (gfc_code *code, loc } } break; case OMP_LIST_LINEAR: if (n->sym->ts.type != BT_INTEGER) - gfc_error ("LINEAR variable '%s' must be INTEGER " + gfc_error ("LINEAR variable %qs must be INTEGER " "at %L", n->sym->name, where); else if (!code && !n->sym->attr.value) - gfc_error ("LINEAR dummy argument '%s' must have VALUE " + gfc_error ("LINEAR dummy argument %qs must have VALUE " "attribute at %L", n->sym->name, where); else if (n->expr) { gfc_expr *expr = n->expr; if (!gfc_resolve_expr (expr) || expr->ts.type != BT_INTEGER || expr->rank != 0) - gfc_error ("'%s' in LINEAR clause at %L requires " + gfc_error ("%qs in LINEAR clause at %L requires " "a scalar integer linear-step expression", n->sym->name, where); else if (!code && expr->expr_type != EXPR_CONSTANT) - gfc_error ("'%s' in LINEAR clause at %L requires " + gfc_error ("%qs in LINEAR clause at %L requires " "a constant integer linear-step expression", n->sym->name, where); } break; /* Workaround for PR middle-end/26316, nothing really needs @@ -2929,11 +2929,11 @@ resolve_omp_atomic (gfc_code *code) && arg->expr->symtree->n.sym == var) var_arg = arg; else if (expr_references_sym (arg->expr, var, NULL)) { gfc_error ("!$OMP ATOMIC intrinsic arguments except one must " - "not reference '%s' at %L", + "not reference %qs at %L", var->name, &arg->expr->where); return; } if (arg->expr->rank != 0) { @@ -2944,11 +2944,11 @@ resolve_omp_atomic (gfc_code *code) } if (var_arg == NULL) { gfc_error ("First or last !$OMP ATOMIC intrinsic argument must " - "be '%s' at %L", var->name, &expr2->where); + "be %qs at %L", var->name, &expr2->where); return; } if (var_arg != expr2->value.function.actual) { @@ -3412,11 +3412,11 @@ gfc_resolve_omp_declare_simd (gfc_namesp for (ods = ns->omp_declare_simd; ods; ods = ods->next) { if (ods->proc_name != ns->proc_name) gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure " - "'%s' at %L", ns->proc_name->name, &ods->where); + "%qs at %L", ns->proc_name->name, &ods->where); if (ods->clauses) resolve_omp_clauses (NULL, &ods->where, ods->clauses, ns); } } Index: gcc/fortran/interface.c =================================================================== --- gcc/fortran/interface.c (revision 218457) +++ gcc/fortran/interface.c (working copy) @@ -217,11 +217,11 @@ gfc_match_interface (void) && !gfc_add_generic (&sym->attr, sym->name, NULL)) return MATCH_ERROR; if (sym->attr.dummy) { - gfc_error ("Dummy procedure '%s' at %C cannot have a " + gfc_error ("Dummy procedure %qs at %C cannot have a " "generic interface", sym->name); return MATCH_ERROR; } current_interface.sym = gfc_new_block = sym; @@ -1559,14 +1559,14 @@ check_interface0 (gfc_interface *p, cons if (((!p->sym->attr.function && !p->sym->attr.subroutine) || !p->sym->attr.if_source) && p->sym->attr.flavor != FL_DERIVED) { if (p->sym->attr.external) - gfc_error ("Procedure '%s' in %s at %L has no explicit interface", + gfc_error ("Procedure %qs in %s at %L has no explicit interface", p->sym->name, interface_name, &p->sym->declared_at); else - gfc_error ("Procedure '%s' in %s at %L is neither function nor " + gfc_error ("Procedure %qs in %s at %L is neither function nor " "subroutine", p->sym->name, interface_name, &p->sym->declared_at); return 1; } @@ -1643,11 +1643,11 @@ check_interface1 (gfc_interface *p, gfc_ && q->sym->attr.flavor != FL_DERIVED && gfc_compare_interfaces (p->sym, q->sym, q->sym->name, generic_flag, 0, NULL, 0, NULL, NULL)) { if (referenced) - gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L", + gfc_error ("Ambiguous interfaces %qs and %qs in %s at %L", p->sym->name, q->sym->name, interface_name, &p->where); else if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc) gfc_warning ("Ambiguous interfaces %qs and %qs in %s at %L", p->sym->name, q->sym->name, interface_name, @@ -1685,11 +1685,11 @@ check_sym_interfaces (gfc_symbol *sym) { if (p->sym->attr.mod_proc && (p->sym->attr.if_source != IFSRC_DECL || p->sym->attr.procedure)) { - gfc_error ("'%s' at %L is not a module procedure", + gfc_error ("%qs at %L is not a module procedure", p->sym->name, &p->where); return; } } @@ -1890,25 +1890,25 @@ argument_rank_mismatch (const char *name /* TS 29113, C407b. */ if (rank2 == -1) { gfc_error ("The assumed-rank array at %L requires that the dummy argument" - " '%s' has assumed-rank", where, name); + " %qs has assumed-rank", where, name); } else if (rank1 == 0) { - gfc_error ("Rank mismatch in argument '%s' at %L " + gfc_error ("Rank mismatch in argument %qs at %L " "(scalar and rank-%d)", name, where, rank2); } else if (rank2 == 0) { - gfc_error ("Rank mismatch in argument '%s' at %L " + gfc_error ("Rank mismatch in argument %qs at %L " "(rank-%d and scalar)", name, where, rank1); } else { - gfc_error ("Rank mismatch in argument '%s' at %L " + gfc_error ("Rank mismatch in argument %qs at %L " "(rank-%d and rank-%d)", name, where, rank1, rank2); } } @@ -1954,11 +1954,11 @@ compare_parameter (gfc_symbol *formal, g if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err, sizeof(err), NULL, NULL)) { if (where) - gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s", + gfc_error ("Interface mismatch in dummy procedure %qs at %L: %s", formal->name, &actual->where, err); return 0; } if (formal->attr.function && !act_sym->attr.function) @@ -1979,11 +1979,11 @@ compare_parameter (gfc_symbol *formal, g /* F2008, C1241. */ if (formal->attr.pointer && formal->attr.contiguous && !gfc_is_simply_contiguous (actual, true)) { if (where) - gfc_error ("Actual argument to contiguous pointer dummy '%s' at %L " + gfc_error ("Actual argument to contiguous pointer dummy %qs at %L " "must be simply contiguous", formal->name, &actual->where); return 0; } if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN) @@ -1994,21 +1994,21 @@ compare_parameter (gfc_symbol *formal, g && !(formal->ts.type == BT_DERIVED && actual->ts.type == BT_CLASS && gfc_compare_derived_types (formal->ts.u.derived, CLASS_DATA (actual)->ts.u.derived))) { if (where) - gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s", + gfc_error ("Type mismatch in argument %qs at %L; passed %s to %s", formal->name, &actual->where, gfc_typename (&actual->ts), gfc_typename (&formal->ts)); return 0; } if (actual->ts.type == BT_ASSUMED && formal->ts.type != BT_ASSUMED) { if (where) gfc_error ("Assumed-type actual argument at %L requires that dummy " - "argument '%s' is of assumed type", &actual->where, + "argument %qs is of assumed type", &actual->where, formal->name); return 0; } /* F2008, 12.5.2.5; IR F08/0073. */ @@ -2019,11 +2019,11 @@ compare_parameter (gfc_symbol *formal, g || CLASS_DATA (formal)->attr.allocatable)) { if (actual->ts.type != BT_CLASS) { if (where) - gfc_error ("Actual argument to '%s' at %L must be polymorphic", + gfc_error ("Actual argument to %qs at %L must be polymorphic", formal->name, &actual->where); return 0; } if (!gfc_expr_attr (actual).class_ok) @@ -2032,11 +2032,11 @@ compare_parameter (gfc_symbol *formal, g if ((!UNLIMITED_POLY (formal) || !UNLIMITED_POLY(actual)) && !gfc_compare_derived_types (CLASS_DATA (actual)->ts.u.derived, CLASS_DATA (formal)->ts.u.derived)) { if (where) - gfc_error ("Actual argument to '%s' at %L must have the same " + gfc_error ("Actual argument to %qs at %L must have the same " "declared type", formal->name, &actual->where); return 0; } } @@ -2047,22 +2047,22 @@ compare_parameter (gfc_symbol *formal, g if (UNLIMITED_POLY (formal) && !UNLIMITED_POLY (actual) && (CLASS_DATA (formal)->attr.allocatable ||CLASS_DATA (formal)->attr.class_pointer)) { if (where) - gfc_error ("Actual argument to '%s' at %L must be unlimited " + gfc_error ("Actual argument to %qs at %L must be unlimited " "polymorphic since the formal argument is a " "pointer or allocatable unlimited polymorphic " "entity [F2008: 12.5.2.5]", formal->name, &actual->where); return 0; } if (formal->attr.codimension && !gfc_is_coarray (actual)) { if (where) - gfc_error ("Actual argument to '%s' at %L must be a coarray", + gfc_error ("Actual argument to %qs at %L must be a coarray", formal->name, &actual->where); return 0; } if (formal->attr.codimension && formal->attr.allocatable) @@ -2077,11 +2077,11 @@ compare_parameter (gfc_symbol *formal, g if ((last && last->u.c.component->as->corank != formal->as->corank) || (!last && actual->symtree->n.sym->as->corank != formal->as->corank)) { if (where) - gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)", + gfc_error ("Corank mismatch in argument %qs at %L (%d and %d)", formal->name, &actual->where, formal->as->corank, last ? last->u.c.component->as->corank : actual->symtree->n.sym->as->corank); return 0; } @@ -2094,11 +2094,11 @@ compare_parameter (gfc_symbol *formal, g && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE) && gfc_expr_attr (actual).dimension && !gfc_is_simply_contiguous (actual, true)) { if (where) - gfc_error ("Actual argument to '%s' at %L must be simply " + gfc_error ("Actual argument to %qs at %L must be simply " "contiguous", formal->name, &actual->where); return 0; } /* F2008, C1303 and C1304. */ @@ -2108,11 +2108,11 @@ compare_parameter (gfc_symbol *formal, g && formal->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE) || formal->attr.lock_comp)) { if (where) - gfc_error ("Actual argument to non-INTENT(INOUT) dummy '%s' at %L, " + gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, " "which is LOCK_TYPE or has a LOCK_TYPE component", formal->name, &actual->where); return 0; } } @@ -2126,11 +2126,11 @@ compare_parameter (gfc_symbol *formal, g && ((formal->as->type != AS_ASSUMED_SHAPE && formal->as->type != AS_ASSUMED_RANK && !formal->attr.pointer) || formal->attr.contiguous)) { if (where) - gfc_error ("Dummy argument '%s' has to be a pointer, assumed-shape or " + gfc_error ("Dummy argument %qs has to be a pointer, assumed-shape or " "assumed-rank array without CONTIGUOUS attribute - as actual" " argument at %L is not simply contiguous and both are " "ASYNCHRONOUS or VOLATILE", formal->name, &actual->where); return 0; } @@ -2140,11 +2140,11 @@ compare_parameter (gfc_symbol *formal, g { if (formal->attr.intent == INTENT_OUT) { if (where) gfc_error ("Passing coarray at %L to allocatable, noncoarray, " - "INTENT(OUT) dummy argument '%s'", &actual->where, + "INTENT(OUT) dummy argument %qs", &actual->where, formal->name); return 0; } else if (warn_surprising && where && formal->attr.intent != INTENT_IN) gfc_warning (OPT_Wsurprising, @@ -2209,21 +2209,21 @@ compare_parameter (gfc_symbol *formal, g } if (actual->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL) { if (where) - gfc_error ("Polymorphic scalar passed to array dummy argument '%s' " + gfc_error ("Polymorphic scalar passed to array dummy argument %qs " "at %L", formal->name, &actual->where); return 0; } if (actual->expr_type != EXPR_NULL && ref && actual->ts.type != BT_CHARACTER && (is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE)) { if (where) gfc_error ("Element of assumed-shaped or pointer " - "array passed to array dummy argument '%s' at %L", + "array passed to array dummy argument %qs at %L", formal->name, &actual->where); return 0; } if (actual->ts.type == BT_CHARACTER && actual->expr_type != EXPR_NULL @@ -2232,18 +2232,18 @@ compare_parameter (gfc_symbol *formal, g if (formal->ts.kind != 1 && (gfc_option.allow_std & GFC_STD_GNU) == 0) { if (where) gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind " "CHARACTER actual argument with array dummy argument " - "'%s' at %L", formal->name, &actual->where); + "%qs at %L", formal->name, &actual->where); return 0; } if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0) { gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with " - "array dummy argument '%s' at %L", + "array dummy argument %qs at %L", formal->name, &actual->where); return 0; } else if ((gfc_option.allow_std & GFC_STD_F2003) == 0) return 0; @@ -2553,19 +2553,19 @@ compare_actual_formal (gfc_actual_arglis } if (f == NULL) { if (where) - gfc_error ("Keyword argument '%s' at %L is not in " + gfc_error ("Keyword argument %qs at %L is not in " "the procedure", a->name, &a->expr->where); return 0; } if (new_arg[i] != NULL) { if (where) - gfc_error ("Keyword argument '%s' at %L is already associated " + gfc_error ("Keyword argument %qs at %L is already associated " "with another actual argument", a->name, &a->expr->where); return 0; } } @@ -2618,15 +2618,15 @@ compare_actual_formal (gfc_actual_arglis if (where && (!f->sym->attr.optional || (f->sym->ts.type != BT_CLASS && f->sym->attr.allocatable) || (f->sym->ts.type == BT_CLASS && CLASS_DATA (f->sym)->attr.allocatable))) - gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'", + gfc_error ("Unexpected NULL() intrinsic at %L to dummy %qs", where, f->sym->name); else if (where) gfc_error ("Fortran 2008: Null pointer at %L to non-pointer " - "dummy '%s'", where, f->sym->name); + "dummy %qs", where, f->sym->name); return 0; } if (!compare_parameter (f->sym, a->expr, ranks_must_agree, @@ -2688,11 +2688,11 @@ compare_actual_formal (gfc_actual_arglis && f->sym->ts.deferred != a->expr->ts.deferred && a->expr->ts.type == BT_CHARACTER) { if (where) gfc_error ("Actual argument at %L to allocatable or " - "pointer dummy argument '%s' must have a deferred " + "pointer dummy argument %qs must have a deferred " "length type parameter if and only if the dummy has one", &a->expr->where, f->sym->name); return 0; } @@ -2728,22 +2728,22 @@ compare_actual_formal (gfc_actual_arglis || (a->expr->expr_type == EXPR_FUNCTION && a->expr->symtree->n.sym->result->attr.proc_pointer) || gfc_is_proc_ptr_comp (a->expr))) { if (where) - gfc_error ("Expected a procedure pointer for argument '%s' at %L", + gfc_error ("Expected a procedure pointer for argument %qs at %L", f->sym->name, &a->expr->where); return 0; } /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is provided for a procedure formal argument. */ if (f->sym->attr.flavor == FL_PROCEDURE && gfc_expr_attr (a->expr).flavor != FL_PROCEDURE) { if (where) - gfc_error ("Expected a procedure for argument '%s' at %L", + gfc_error ("Expected a procedure for argument %qs at %L", f->sym->name, &a->expr->where); return 0; } if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE @@ -2753,41 +2753,41 @@ compare_actual_formal (gfc_actual_arglis && (a->expr->ref == NULL || (a->expr->ref->type == REF_ARRAY && a->expr->ref->u.ar.type == AR_FULL))) { if (where) - gfc_error ("Actual argument for '%s' cannot be an assumed-size" + gfc_error ("Actual argument for %qs cannot be an assumed-size" " array at %L", f->sym->name, where); return 0; } if (a->expr->expr_type != EXPR_NULL && compare_pointer (f->sym, a->expr) == 0) { if (where) - gfc_error ("Actual argument for '%s' must be a pointer at %L", + gfc_error ("Actual argument for %qs must be a pointer at %L", f->sym->name, &a->expr->where); return 0; } if (a->expr->expr_type != EXPR_NULL && (gfc_option.allow_std & GFC_STD_F2008) == 0 && compare_pointer (f->sym, a->expr) == 2) { if (where) gfc_error ("Fortran 2008: Non-pointer actual argument at %L to " - "pointer dummy '%s'", &a->expr->where,f->sym->name); + "pointer dummy %qs", &a->expr->where,f->sym->name); return 0; } /* Fortran 2008, C1242. */ if (f->sym->attr.pointer && gfc_is_coindexed (a->expr)) { if (where) gfc_error ("Coindexed actual argument at %L to pointer " - "dummy '%s'", + "dummy %qs", &a->expr->where, f->sym->name); return 0; } /* Fortran 2008, 12.5.2.5 (no constraint). */ @@ -2796,11 +2796,11 @@ compare_actual_formal (gfc_actual_arglis && f->sym->attr.allocatable && gfc_is_coindexed (a->expr)) { if (where) gfc_error ("Coindexed actual argument at %L to allocatable " - "dummy '%s' requires INTENT(IN)", + "dummy %qs requires INTENT(IN)", &a->expr->where, f->sym->name); return 0; } /* Fortran 2008, C1237. */ @@ -2810,11 +2810,11 @@ compare_actual_formal (gfc_actual_arglis && (a->expr->symtree->n.sym->attr.volatile_ || a->expr->symtree->n.sym->attr.asynchronous)) { if (where) gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at " - "%L requires that dummy '%s' has neither " + "%L requires that dummy %qs has neither " "ASYNCHRONOUS nor VOLATILE", &a->expr->where, f->sym->name); return 0; } @@ -2824,32 +2824,32 @@ compare_actual_formal (gfc_actual_arglis && gfc_is_coindexed (a->expr) && gfc_has_ultimate_allocatable (a->expr)) { if (where) gfc_error ("Coindexed actual argument at %L with allocatable " - "ultimate component to dummy '%s' requires either VALUE " + "ultimate component to dummy %qs requires either VALUE " "or INTENT(IN)", &a->expr->where, f->sym->name); return 0; } if (f->sym->ts.type == BT_CLASS && CLASS_DATA (f->sym)->attr.allocatable && gfc_is_class_array_ref (a->expr, &full_array) && !full_array) { if (where) - gfc_error ("Actual CLASS array argument for '%s' must be a full " + gfc_error ("Actual CLASS array argument for %qs must be a full " "array at %L", f->sym->name, &a->expr->where); return 0; } if (a->expr->expr_type != EXPR_NULL && compare_allocatable (f->sym, a->expr) == 0) { if (where) - gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L", + gfc_error ("Actual argument for %qs must be ALLOCATABLE at %L", f->sym->name, &a->expr->where); return 0; } /* Check intent = OUT/INOUT for definable actual argument. */ @@ -2877,11 +2877,11 @@ compare_actual_formal (gfc_actual_arglis { if (where) gfc_error ("Array-section actual argument with vector " "subscripts at %L is incompatible with INTENT(OUT), " "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute " - "of the dummy argument '%s'", + "of the dummy argument %qs", &a->expr->where, f->sym->name); return 0; } /* C1232 (R1221) For an actual argument which is an array section or @@ -2894,11 +2894,11 @@ compare_actual_formal (gfc_actual_arglis && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE)) { if (where) gfc_error ("Assumed-shape actual argument at %L is " "incompatible with the non-assumed-shape " - "dummy argument '%s' due to VOLATILE attribute", + "dummy argument %qs due to VOLATILE attribute", &a->expr->where,f->sym->name); return 0; } if (f->sym->attr.volatile_ @@ -2906,11 +2906,11 @@ compare_actual_formal (gfc_actual_arglis && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE)) { if (where) gfc_error ("Array-section actual argument at %L is " "incompatible with the non-assumed-shape " - "dummy argument '%s' due to VOLATILE attribute", + "dummy argument %qs due to VOLATILE attribute", &a->expr->where,f->sym->name); return 0; } /* C1233 (R1221) For an actual argument which is a pointer array, the @@ -2925,11 +2925,11 @@ compare_actual_formal (gfc_actual_arglis || f->sym->attr.pointer))) { if (where) gfc_error ("Pointer-array actual argument at %L requires " "an assumed-shape or pointer-array dummy " - "argument '%s' due to VOLATILE attribute", + "argument %qs due to VOLATILE attribute", &a->expr->where,f->sym->name); return 0; } match: @@ -2953,11 +2953,11 @@ compare_actual_formal (gfc_actual_arglis return 0; } if (!f->sym->attr.optional) { if (where) - gfc_error ("Missing actual argument for argument '%s' at %L", + gfc_error ("Missing actual argument for argument %qs at %L", f->sym->name, where); return 0; } } @@ -3224,11 +3224,11 @@ check_intents (gfc_formal_arglist *f, gf /* F2008, Section 12.5.2.4. */ if (expr->ts.type == BT_CLASS && f->sym->ts.type == BT_CLASS && gfc_is_coindexed (expr)) { gfc_error ("Coindexed polymorphic actual argument at %L is passed " - "polymorphic dummy argument '%s'", + "polymorphic dummy argument %qs", &expr->where, f->sym->name); return false; } } @@ -3251,11 +3251,11 @@ gfc_procedure_use (gfc_symbol *sym, gfc_ explicitly declared at all if requested. */ if (sym->attr.if_source == IFSRC_UNKNOWN && !sym->attr.is_iso_c) { if (sym->ns->has_implicit_none_export && sym->attr.proc == PROC_UNKNOWN) { - gfc_error ("Procedure '%s' called at %L is not explicitly declared", + gfc_error ("Procedure %qs called at %L is not explicitly declared", sym->name, where); return false; } if (warn_implicit_interface) gfc_warning (OPT_Wimplicit_interface, @@ -3271,38 +3271,38 @@ gfc_procedure_use (gfc_symbol *sym, gfc_ { gfc_actual_arglist *a; if (sym->attr.pointer) { - gfc_error("The pointer object '%s' at %L must have an explicit " - "function interface or be declared as array", - sym->name, where); + gfc_error ("The pointer object %qs at %L must have an explicit " + "function interface or be declared as array", + sym->name, where); return false; } if (sym->attr.allocatable && !sym->attr.external) { - gfc_error("The allocatable object '%s' at %L must have an explicit " - "function interface or be declared as array", - sym->name, where); + gfc_error ("The allocatable object %qs at %L must have an explicit " + "function interface or be declared as array", + sym->name, where); return false; } if (sym->attr.allocatable) { - gfc_error("Allocatable function '%s' at %L must have an explicit " - "function interface", sym->name, where); + gfc_error ("Allocatable function %qs at %L must have an explicit " + "function interface", sym->name, where); return false; } for (a = *ap; a; a = a->next) { /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */ if (a->name != NULL && a->name[0] != '%') { - gfc_error("Keyword argument requires explicit interface " - "for procedure '%s' at %L", sym->name, &a->expr->where); + gfc_error ("Keyword argument requires explicit interface " + "for procedure %qs at %L", sym->name, &a->expr->where); break; } /* TS 29113, 6.2. */ if (a->expr && a->expr->ts.type == BT_ASSUMED @@ -3319,13 +3319,13 @@ gfc_procedure_use (gfc_symbol *sym, gfc_ && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS) && ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV && a->expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE) || gfc_expr_attr (a->expr).lock_comp)) { - gfc_error("Actual argument of LOCK_TYPE or with LOCK_TYPE " - "component at %L requires an explicit interface for " - "procedure '%s'", &a->expr->where, sym->name); + gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE " + "component at %L requires an explicit interface for " + "procedure %qs", &a->expr->where, sym->name); break; } if (a->expr && a->expr->expr_type == EXPR_NULL && a->expr->ts.type == BT_UNKNOWN) @@ -3385,13 +3385,13 @@ gfc_ppc_use (gfc_component *comp, gfc_ac for (a = *ap; a; a = a->next) { /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */ if (a->name != NULL && a->name[0] != '%') { - gfc_error("Keyword argument requires explicit interface " - "for procedure pointer component '%s' at %L", - comp->name, &a->expr->where); + gfc_error ("Keyword argument requires explicit interface " + "for procedure pointer component %qs at %L", + comp->name, &a->expr->where); break; } } return; @@ -3911,11 +3911,11 @@ gfc_check_new_interface (gfc_interface * for (ip = base; ip; ip = ip->next) { if (ip->sym == new_sym) { - gfc_error ("Entity '%s' at %L is already present in the interface", + gfc_error ("Entity %qs at %L is already present in the interface", new_sym->name, &loc); return false; } } @@ -4122,11 +4122,11 @@ gfc_check_typebound_override (gfc_symtre gcc_assert (!proc->n.tb->is_generic); /* If the overwritten procedure is GENERIC, this is an error. */ if (old->n.tb->is_generic) { - gfc_error ("Can't overwrite GENERIC '%s' at %L", + gfc_error ("Can't overwrite GENERIC %qs at %L", old->name, &proc->n.tb->where); return false; } where = proc->n.tb->where; @@ -4134,81 +4134,81 @@ gfc_check_typebound_override (gfc_symtre old_target = old->n.tb->u.specific->n.sym; /* Check that overridden binding is not NON_OVERRIDABLE. */ if (old->n.tb->non_overridable) { - gfc_error ("'%s' at %L overrides a procedure binding declared" + gfc_error ("%qs at %L overrides a procedure binding declared" " NON_OVERRIDABLE", proc->name, &where); return false; } /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */ if (!old->n.tb->deferred && proc->n.tb->deferred) { - gfc_error ("'%s' at %L must not be DEFERRED as it overrides a" + gfc_error ("%qs at %L must not be DEFERRED as it overrides a" " non-DEFERRED binding", proc->name, &where); return false; } /* If the overridden binding is PURE, the overriding must be, too. */ if (old_target->attr.pure && !proc_target->attr.pure) { - gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE", + gfc_error ("%qs at %L overrides a PURE procedure and must also be PURE", proc->name, &where); return false; } /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it is not, the overriding must not be either. */ if (old_target->attr.elemental && !proc_target->attr.elemental) { - gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be" + gfc_error ("%qs at %L overrides an ELEMENTAL procedure and must also be" " ELEMENTAL", proc->name, &where); return false; } if (!old_target->attr.elemental && proc_target->attr.elemental) { - gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not" + gfc_error ("%qs at %L overrides a non-ELEMENTAL procedure and must not" " be ELEMENTAL, either", proc->name, &where); return false; } /* If the overridden binding is a SUBROUTINE, the overriding must also be a SUBROUTINE. */ if (old_target->attr.subroutine && !proc_target->attr.subroutine) { - gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a" + gfc_error ("%qs at %L overrides a SUBROUTINE and must also be a" " SUBROUTINE", proc->name, &where); return false; } /* If the overridden binding is a FUNCTION, the overriding must also be a FUNCTION and have the same characteristics. */ if (old_target->attr.function) { if (!proc_target->attr.function) { - gfc_error ("'%s' at %L overrides a FUNCTION and must also be a" + gfc_error ("%qs at %L overrides a FUNCTION and must also be a" " FUNCTION", proc->name, &where); return false; } if (!check_result_characteristics (proc_target, old_target, err, sizeof(err))) { gfc_error ("Result mismatch for the overriding procedure " - "'%s' at %L: %s", proc->name, &where, err); + "%qs at %L: %s", proc->name, &where, err); return false; } } /* If the overridden binding is PUBLIC, the overriding one must not be PRIVATE. */ if (old->n.tb->access == ACCESS_PUBLIC && proc->n.tb->access == ACCESS_PRIVATE) { - gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be" + gfc_error ("%qs at %L overrides a PUBLIC procedure and must not be" " PRIVATE", proc->name, &where); return false; } /* Compare the formal argument lists of both procedures. This is also abused @@ -4234,11 +4234,11 @@ gfc_check_typebound_override (gfc_symtre old_pass_arg = argpos; /* Check that the names correspond. */ if (strcmp (proc_formal->sym->name, old_formal->sym->name)) { - gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as" + gfc_error ("Dummy argument %qs of %qs at %L should be named %qs as" " to match the corresponding argument of the overridden" " procedure", proc_formal->sym->name, proc->name, &where, old_formal->sym->name); return false; } @@ -4246,46 +4246,46 @@ gfc_check_typebound_override (gfc_symtre check_type = proc_pass_arg != argpos && old_pass_arg != argpos; if (!check_dummy_characteristics (proc_formal->sym, old_formal->sym, check_type, err, sizeof(err))) { gfc_error ("Argument mismatch for the overriding procedure " - "'%s' at %L: %s", proc->name, &where, err); + "%qs at %L: %s", proc->name, &where, err); return false; } ++argpos; } if (proc_formal || old_formal) { - gfc_error ("'%s' at %L must have the same number of formal arguments as" + gfc_error ("%qs at %L must have the same number of formal arguments as" " the overridden procedure", proc->name, &where); return false; } /* If the overridden binding is NOPASS, the overriding one must also be NOPASS. */ if (old->n.tb->nopass && !proc->n.tb->nopass) { - gfc_error ("'%s' at %L overrides a NOPASS binding and must also be" + gfc_error ("%qs at %L overrides a NOPASS binding and must also be" " NOPASS", proc->name, &where); return false; } /* If the overridden binding is PASS(x), the overriding one must also be PASS and the passed-object dummy arguments must correspond. */ if (!old->n.tb->nopass) { if (proc->n.tb->nopass) { - gfc_error ("'%s' at %L overrides a binding with PASS and must also be" + gfc_error ("%qs at %L overrides a binding with PASS and must also be" " PASS", proc->name, &where); return false; } if (proc_pass_arg != old_pass_arg) { - gfc_error ("Passed-object dummy argument of '%s' at %L must be at" + gfc_error ("Passed-object dummy argument of %qs at %L must be at" " the same position as the passed-object dummy argument of" " the overridden procedure", proc->name, &where); return false; } } Index: gcc/fortran/intrinsic.c =================================================================== --- gcc/fortran/intrinsic.c (revision 218457) +++ gcc/fortran/intrinsic.c (working copy) @@ -3813,11 +3813,11 @@ sort_actual (const char *name, gfc_actua } if (a == NULL) goto do_sort; - gfc_error ("Too many arguments in call to '%s' at %L", name, where); + gfc_error ("Too many arguments in call to %qs at %L", name, where); return false; keywords: /* Associate the remaining actual arguments, all of which have to be keyword arguments. */ @@ -3831,18 +3831,18 @@ keywords: { if (a->name[0] == '%') gfc_error ("The argument list functions %%VAL, %%LOC or %%REF " "are not allowed in this context at %L", where); else - gfc_error ("Can't find keyword named '%s' in call to '%s' at %L", + gfc_error ("Can't find keyword named %qs in call to %qs at %L", a->name, name, where); return false; } if (f->actual != NULL) { - gfc_error ("Argument '%s' appears twice in call to '%s' at %L", + gfc_error ("Argument %qs appears twice in call to %qs at %L", f->name, name, where); return false; } f->actual = a; @@ -3852,11 +3852,11 @@ optional: /* At this point, all unmatched formal args must be optional. */ for (f = formal; f; f = f->next) { if (f->actual == NULL && f->optional == 0) { - gfc_error ("Missing actual argument '%s' in call to '%s' at %L", + gfc_error ("Missing actual argument %qs in call to %qs at %L", f->name, name, where); return false; } } @@ -3924,11 +3924,11 @@ check_arglist (gfc_actual_arglist **ap, ts.kind = actual->expr->ts.kind; if (!gfc_compare_types (&ts, &actual->expr->ts)) { if (error_flag) - gfc_error ("Type of argument '%s' in call to '%s' at %L should " + gfc_error ("Type of argument %qs in call to %qs at %L should " "be %s, not %s", gfc_current_intrinsic_arg[i]->name, gfc_current_intrinsic, &actual->expr->where, gfc_typename (&formal->ts), gfc_typename (&actual->expr->ts)); return false; @@ -4532,18 +4532,18 @@ gfc_intrinsic_sub_interface (gfc_code *c c->resolved_sym->attr.elemental = isym->elemental; } if (gfc_do_concurrent_flag && !isym->pure) { - gfc_error ("Subroutine call to intrinsic '%s' in DO CONCURRENT " + gfc_error ("Subroutine call to intrinsic %qs in DO CONCURRENT " "block at %L is not PURE", name, &c->loc); return MATCH_ERROR; } if (!isym->pure && gfc_pure (NULL)) { - gfc_error ("Subroutine call to intrinsic '%s' at %L is not PURE", name, + gfc_error ("Subroutine call to intrinsic %qs at %L is not PURE", name, &c->loc); return MATCH_ERROR; } if (!isym->pure) Index: gcc/fortran/class.c =================================================================== --- gcc/fortran/class.c (revision 218457) +++ gcc/fortran/class.c (working copy) @@ -664,11 +664,11 @@ gfc_build_class_symbol (gfc_typespec *ts { /* Since the extension field is 8 bit wide, we can only have up to 255 extension levels. */ if (ts->u.derived->attr.extension == 255) { - gfc_error ("Maximum extension level reached with type '%s' at %L", + gfc_error ("Maximum extension level reached with type %qs at %L", ts->u.derived->name, &ts->u.derived->declared_at); return false; } fclass->attr.extension = ts->u.derived->attr.extension + 1; @@ -2684,11 +2684,11 @@ find_typebound_proc_uop (gfc_symbol* der if (!noaccess && derived->attr.use_assoc && res->n.tb->access == ACCESS_PRIVATE) { if (where) - gfc_error ("'%s' of '%s' is PRIVATE at %L", + gfc_error ("%qs of %qs is PRIVATE at %L", name, derived->name, where); if (t) *t = false; } @@ -2758,11 +2758,11 @@ gfc_find_typebound_intrinsic_op (gfc_sym if (!noaccess && derived->attr.use_assoc && res->access == ACCESS_PRIVATE) { if (where) - gfc_error ("'%s' of '%s' is PRIVATE at %L", + gfc_error ("%qs of %qs is PRIVATE at %L", gfc_op2string (op), derived->name, where); if (t) *t = false; } Index: gcc/fortran/symbol.c =================================================================== --- gcc/fortran/symbol.c (revision 218457) +++ gcc/fortran/symbol.c (working copy) @@ -1699,22 +1699,22 @@ gfc_add_type (gfc_symbol *sym, gfc_types type = sym->ns->proc_name->ts.type; if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type)) { if (sym->attr.use_assoc) - gfc_error ("Symbol '%s' at %L conflicts with symbol from module '%s', " + gfc_error_1 ("Symbol '%s' at %L conflicts with symbol from module '%s', " "use-associated at %L", sym->name, where, sym->module, &sym->declared_at); else - gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name, + gfc_error ("Symbol %qs at %L already has basic type of %s", sym->name, where, gfc_basic_typename (type)); return false; } if (sym->attr.procedure && sym->ts.interface) { - gfc_error ("Procedure '%s' at %L may not have basic type of %s", + gfc_error ("Procedure %qs at %L may not have basic type of %s", sym->name, where, gfc_basic_typename (ts->type)); return false; } flavor = sym->attr.flavor; @@ -1893,22 +1893,22 @@ gfc_add_component (gfc_symbol *sym, cons for (p = sym->components; p; p = p->next) { if (strcmp (p->name, name) == 0) { - gfc_error ("Component '%s' at %C already declared at %L", + gfc_error_1 ("Component '%s' at %C already declared at %L", name, &p->loc); return false; } tail = p; } if (sym->attr.extension && gfc_find_component (sym->components->ts.u.derived, name, true, true)) { - gfc_error ("Component '%s' at %C already in the parent type " + gfc_error_1 ("Component '%s' at %C already in the parent type " "at %L", name, &sym->components->ts.u.derived->declared_at); return false; } /* Allocate a new component. */ @@ -2059,11 +2059,11 @@ gfc_find_component (gfc_symbol *sym, con (p->attr.access != ACCESS_PUBLIC && sym->component_access == ACCESS_PRIVATE && !is_parent_comp)) { if (!silent) - gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'", + gfc_error ("Component %qs at %C is a PRIVATE component of %qs", name, sym->name); return NULL; } } @@ -2077,11 +2077,11 @@ gfc_find_component (gfc_symbol *sym, con if (p == NULL) return p; } if (p == NULL && !silent) - gfc_error ("'%s' at %C is not a member of the '%s' structure", + gfc_error ("%qs at %C is not a member of the %qs structure", name, sym->name); return p; } @@ -2216,11 +2216,11 @@ gfc_define_st_label (gfc_st_label *lp, g int labelno; labelno = lp->value; if (lp->defined != ST_LABEL_UNKNOWN) - gfc_error ("Duplicate statement label %d at %L and %L", labelno, + gfc_error_1 ("Duplicate statement label %d at %L and %L", labelno, &lp->where, label_locus); else { lp->where = *label_locus; @@ -2626,14 +2626,14 @@ gfc_new_symbol (const char *name, gfc_na static void ambiguous_symbol (const char *name, gfc_symtree *st) { if (st->n.sym->module) - gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' " - "from module '%s'", name, st->n.sym->name, st->n.sym->module); + gfc_error ("Name %qs at %C is an ambiguous reference to %qs " + "from module %qs", name, st->n.sym->name, st->n.sym->module); else - gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' " + gfc_error ("Name %qs at %C is an ambiguous reference to %qs " "from current program unit", name, st->n.sym->name); } /* If we're in a SELECT TYPE block, check if the variable 'st' matches any @@ -2850,11 +2850,11 @@ gfc_get_sym_tree (const char *name, gfc_ && !(allow_subroutine && p->attr.subroutine) && !(ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY && (ns->has_import_set || p->attr.imported))) { /* Symbol is from another namespace. */ - gfc_error ("Symbol '%s' at %C has already been host associated", + gfc_error ("Symbol %qs at %C has already been host associated", name); return 2; } p->mark = 1; @@ -3893,32 +3893,32 @@ verify_bind_c_derived_type (gfc_symbol * { /* The components cannot be pointers (fortran sense). J3/04-007, Section 15.2.3, C1505. */ if (curr_comp->attr.pointer != 0) { - gfc_error ("Component '%s' at %L cannot have the " + gfc_error_1 ("Component '%s' at %L cannot have the " "POINTER attribute because it is a member " "of the BIND(C) derived type '%s' at %L", curr_comp->name, &(curr_comp->loc), derived_sym->name, &(derived_sym->declared_at)); retval = false; } if (curr_comp->attr.proc_pointer != 0) { - gfc_error ("Procedure pointer component '%s' at %L cannot be a member" + gfc_error_1 ("Procedure pointer component '%s' at %L cannot be a member" " of the BIND(C) derived type '%s' at %L", curr_comp->name, &curr_comp->loc, derived_sym->name, &derived_sym->declared_at); retval = false; } /* The components cannot be allocatable. J3/04-007, Section 15.2.3, C1505. */ if (curr_comp->attr.allocatable != 0) { - gfc_error ("Component '%s' at %L cannot have the " + gfc_error_1 ("Component '%s' at %L cannot have the " "ALLOCATABLE attribute because it is a member " "of the BIND(C) derived type '%s' at %L", curr_comp->name, &(curr_comp->loc), derived_sym->name, &(derived_sym->declared_at)); retval = false; Index: gcc/fortran/decl.c =================================================================== --- gcc/fortran/decl.c (revision 218457) +++ gcc/fortran/decl.c (working copy) @@ -259,11 +259,11 @@ var_element (gfc_data_variable *new_var) return MATCH_ERROR; if (!sym->attr.function && gfc_current_ns->parent && gfc_current_ns->parent == sym->ns) { - gfc_error ("Host associated variable '%s' may not be in the DATA " + gfc_error ("Host associated variable %qs may not be in the DATA " "statement at %C", sym->name); return MATCH_ERROR; } if (gfc_current_state () != COMP_BLOCK_DATA @@ -377,11 +377,11 @@ match_data_constant (gfc_expr **result) if (sym == NULL || (sym->attr.flavor != FL_PARAMETER && (!dt_sym || dt_sym->attr.flavor != FL_DERIVED))) { - gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C", + gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C", name); return MATCH_ERROR; } else if (dt_sym && dt_sym->attr.flavor == FL_DERIVED) return gfc_match_structure_constructor (dt_sym, result); @@ -1015,19 +1015,19 @@ gfc_verify_c_interop_param (gfc_symbol * if (is_c_interop != 1) { /* Make personalized messages to give better feedback. */ if (sym->ts.type == BT_DERIVED) - gfc_error ("Variable '%s' at %L is a dummy argument to the " - "BIND(C) procedure '%s' but is not C interoperable " - "because derived type '%s' is not C interoperable", + gfc_error ("Variable %qs at %L is a dummy argument to the " + "BIND(C) procedure %qs but is not C interoperable " + "because derived type %qs is not C interoperable", sym->name, &(sym->declared_at), sym->ns->proc_name->name, sym->ts.u.derived->name); else if (sym->ts.type == BT_CLASS) - gfc_error ("Variable '%s' at %L is a dummy argument to the " - "BIND(C) procedure '%s' but is not C interoperable " + gfc_error ("Variable %qs at %L is a dummy argument to the " + "BIND(C) procedure %qs but is not C interoperable " "because it is polymorphic", sym->name, &(sym->declared_at), sym->ns->proc_name->name); else if (warn_c_binding_type) gfc_warning (OPT_Wc_binding_type, @@ -1044,13 +1044,13 @@ gfc_verify_c_interop_param (gfc_symbol * { gfc_charlen *cl = sym->ts.u.cl; if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT || mpz_cmp_si (cl->length->value.integer, 1) != 0) { - gfc_error ("Character argument '%s' at %L " + gfc_error ("Character argument %qs at %L " "must be length 1 because " - "procedure '%s' is BIND(C)", + "procedure %qs is BIND(C)", sym->name, &sym->declared_at, sym->ns->proc_name->name); retval = false; } } @@ -1074,21 +1074,21 @@ gfc_verify_c_interop_param (gfc_symbol * sym->ns->proc_name->name)) retval = false; if ((sym->attr.allocatable || sym->attr.pointer) && !sym->as) { - gfc_error ("Scalar variable '%s' at %L with POINTER or " - "ALLOCATABLE in procedure '%s' with BIND(C) is not yet" + gfc_error ("Scalar variable %qs at %L with POINTER or " + "ALLOCATABLE in procedure %qs with BIND(C) is not yet" " supported", sym->name, &(sym->declared_at), sym->ns->proc_name->name); retval = false; } if (sym->attr.optional == 1 && sym->attr.value) { - gfc_error ("Variable '%s' at %L cannot have both the OPTIONAL " - "and the VALUE attribute because procedure '%s' " + gfc_error ("Variable %qs at %L cannot have both the OPTIONAL " + "and the VALUE attribute because procedure %qs " "is BIND(C)", sym->name, &(sym->declared_at), sym->ns->proc_name->name); retval = false; } else if (sym->attr.optional == 1 @@ -1321,11 +1321,11 @@ add_init_expr_to_sym (const char *name, then an initialization expression is not allowed. */ if (attr.flavor == FL_PARAMETER && sym->value != NULL && *initp != NULL) { - gfc_error ("Initializer not allowed for PARAMETER '%s' at %C", + gfc_error ("Initializer not allowed for PARAMETER %qs at %C", sym->name); return false; } if (init == NULL) @@ -1341,11 +1341,11 @@ add_init_expr_to_sym (const char *name, { /* If a variable appears in a DATA block, it cannot have an initializer. */ if (sym->attr.data) { - gfc_error ("Variable '%s' at %C with an initializer already " + gfc_error ("Variable %qs at %C with an initializer already " "appears in a DATA statement", sym->name); return false; } /* Check if the assignment can happen. This has to be put off @@ -1781,11 +1781,11 @@ check_function_name (char *name) gfc_symbol *block = gfc_current_block (); if (block && block->result && block->result != block && strcmp (block->result->name, "ppr@") != 0 && strcmp (block->name, name) == 0) { - gfc_error ("Function name '%s' not allowed at %C", name); + gfc_error ("Function name %qs not allowed at %C", name); return false; } } return true; @@ -1848,11 +1848,11 @@ variable_decl (int elem) if (as) { if (as->type == AS_IMPLIED_SHAPE && current_attr.flavor != FL_PARAMETER) { m = MATCH_ERROR; - gfc_error ("Non-PARAMETER symbol '%s' at %L can't be implied-shape", + gfc_error ("Non-PARAMETER symbol %qs at %L can't be implied-shape", name, &var_locus); goto cleanup; } if (as->type == AS_ASSUMED_SIZE && as->rank == 1 @@ -2817,11 +2817,11 @@ gfc_match_decl_type_spec (gfc_typespec * if (ts->kind != -1) { gfc_get_ha_symbol (name, &sym); if (sym->generic && gfc_find_symbol (dt_name, NULL, 0, &dt_sym)) { - gfc_error ("Type name '%s' at %C is ambiguous", name); + gfc_error ("Type name %qs at %C is ambiguous", name); return MATCH_ERROR; } if (sym->generic && !dt_sym) dt_sym = gfc_find_dt_in_generic (sym); } @@ -2830,11 +2830,11 @@ gfc_match_decl_type_spec (gfc_typespec * int iface = gfc_state_stack->previous->state != COMP_INTERFACE || gfc_current_ns->has_import_set; gfc_find_symbol (name, NULL, iface, &sym); if (sym && sym->generic && gfc_find_symbol (dt_name, NULL, 1, &dt_sym)) { - gfc_error ("Type name '%s' at %C is ambiguous", name); + gfc_error ("Type name %qs at %C is ambiguous", name); return MATCH_ERROR; } if (sym && sym->generic && !dt_sym) dt_sym = gfc_find_dt_in_generic (sym); @@ -2845,13 +2845,13 @@ gfc_match_decl_type_spec (gfc_typespec * if ((sym->attr.flavor != FL_UNKNOWN && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic)) || sym->attr.subroutine) { - gfc_error ("Type name '%s' at %C conflicts with previously declared " - "entity at %L, which has the same name", name, - &sym->declared_at); + gfc_error_1 ("Type name '%s' at %C conflicts with previously declared " + "entity at %L, which has the same name", name, + &sym->declared_at); return MATCH_ERROR; } gfc_set_sym_referenced (sym); if (!sym->attr.generic @@ -3272,25 +3272,25 @@ gfc_match_import (void) { case MATCH_YES: if (gfc_current_ns->parent != NULL && gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym)) { - gfc_error ("Type name '%s' at %C is ambiguous", name); + gfc_error ("Type name %qs at %C is ambiguous", name); return MATCH_ERROR; } else if (!sym && gfc_current_ns->proc_name->ns->parent != NULL && gfc_find_symbol (name, gfc_current_ns->proc_name->ns->parent, 1, &sym)) { - gfc_error ("Type name '%s' at %C is ambiguous", name); + gfc_error ("Type name %qs at %C is ambiguous", name); return MATCH_ERROR; } if (sym == NULL) { - gfc_error ("Cannot IMPORT '%s' from host scoping unit " + gfc_error ("Cannot IMPORT %qs from host scoping unit " "at %C - does not exist.", name); return MATCH_ERROR; } if (gfc_find_symtree (gfc_current_ns->sym_root, name)) @@ -4062,27 +4062,27 @@ verify_bind_c_sym (gfc_symbol *tmp_sym, &(tmp_sym->declared_at), com_block->name); } else { if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED) - gfc_error ("Type declaration '%s' at %L is not C " + gfc_error ("Type declaration %qs at %L is not C " "interoperable but it is BIND(C)", tmp_sym->name, &(tmp_sym->declared_at)); else if (warn_c_binding_type) gfc_warning (OPT_Wc_binding_type, "Variable %qs at %L " "may not be a C interoperable " - "kind but it is bind(c)", + "kind but it is BIND(C)", tmp_sym->name, &(tmp_sym->declared_at)); } } /* Variables declared w/in a common block can't be bind(c) since there's no way for C to see these variables, so there's semantically no reason for the attribute. */ if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1) { - gfc_error ("Variable '%s' in common block '%s' at " + gfc_error ("Variable %qs in common block %qs at " "%L cannot be declared with BIND(C) " "since it is not a global", tmp_sym->name, com_block->name, &(tmp_sym->declared_at)); retval = false; @@ -4092,19 +4092,19 @@ verify_bind_c_sym (gfc_symbol *tmp_sym, or allocatable attributes. */ if (tmp_sym->attr.is_bind_c == 1) { if (tmp_sym->attr.pointer == 1) { - gfc_error ("Variable '%s' at %L cannot have both the " + gfc_error ("Variable %qs at %L cannot have both the " "POINTER and BIND(C) attributes", tmp_sym->name, &(tmp_sym->declared_at)); retval = false; } if (tmp_sym->attr.allocatable == 1) { - gfc_error ("Variable '%s' at %L cannot have both the " + gfc_error ("Variable %qs at %L cannot have both the " "ALLOCATABLE and BIND(C) attributes", tmp_sym->name, &(tmp_sym->declared_at)); retval = false; } @@ -4112,19 +4112,19 @@ verify_bind_c_sym (gfc_symbol *tmp_sym, /* If it is a BIND(C) function, make sure the return value is a scalar value. The previous tests in this function made sure the type is interoperable. */ if (bind_c_function && tmp_sym->as != NULL) - gfc_error ("Return type of BIND(C) function '%s' at %L cannot " + gfc_error ("Return type of BIND(C) function %qs at %L cannot " "be an array", tmp_sym->name, &(tmp_sym->declared_at)); /* BIND(C) functions can not return a character string. */ if (bind_c_function && tmp_sym->ts.type == BT_CHARACTER) if (tmp_sym->ts.u.cl == NULL || tmp_sym->ts.u.cl->length == NULL || tmp_sym->ts.u.cl->length->expr_type != EXPR_CONSTANT || mpz_cmp_si (tmp_sym->ts.u.cl->length->value.integer, 1) != 0) - gfc_error ("Return type of BIND(C) function '%s' at %L cannot " + gfc_error ("Return type of BIND(C) function %qs at %L cannot " "be a character string", tmp_sym->name, &(tmp_sym->declared_at)); } /* See if the symbol has been marked as private. If it has, make sure @@ -4595,11 +4595,11 @@ gfc_match_formal_arglist (gfc_symbol *pr so check for it explicitly. After the statement is accepted, the name is checked for especially in gfc_get_symbol(). */ if (gfc_new_block != NULL && sym != NULL && strcmp (sym->name, gfc_new_block->name) == 0) { - gfc_error ("Name '%s' at %C is the name of the procedure", + gfc_error ("Name %qs at %C is the name of the procedure", sym->name); m = MATCH_ERROR; goto cleanup; } @@ -4624,11 +4624,11 @@ ok: continue; for (q = p->next; q; q = q->next) if (p->sym == q->sym) { - gfc_error ("Duplicate symbol '%s' in formal argument list " + gfc_error ("Duplicate symbol %qs in formal argument list " "at %C", p->sym->name); m = MATCH_ERROR; goto cleanup; } @@ -4999,11 +4999,11 @@ match_procedure_decl (void) /* Set interface. */ if (proc_if != NULL) { if (sym->ts.type != BT_UNKNOWN) { - gfc_error ("Procedure '%s' at %L already has basic type of %s", + gfc_error ("Procedure %qs at %L already has basic type of %s", sym->name, &gfc_current_locus, gfc_basic_typename (sym->ts.type)); return MATCH_ERROR; } sym->ts.interface = proc_if; @@ -6275,11 +6275,11 @@ gfc_match_end (gfc_statement *st) return MATCH_YES; if (!block_name) return MATCH_YES; - gfc_error ("Expected block name of '%s' in %s statement at %L", + gfc_error ("Expected block name of %qs in %s statement at %L", block_name, gfc_ascii_statement (*st), &old_loc); return MATCH_ERROR; } @@ -6301,19 +6301,19 @@ gfc_match_end (gfc_statement *st) if (block_name == NULL) goto syntax; if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0) { - gfc_error ("Expected label '%s' for %s statement at %C", block_name, + gfc_error ("Expected label %qs for %s statement at %C", block_name, gfc_ascii_statement (*st)); goto cleanup; } /* Procedure pointer as function result. */ else if (strcmp (block_name, "ppr@") == 0 && strcmp (name, gfc_current_block ()->ns->proc_name->name) != 0) { - gfc_error ("Expected label '%s' for %s statement at %C", + gfc_error ("Expected label %qs for %s statement at %C", gfc_current_block ()->ns->proc_name->name, gfc_ascii_statement (*st)); goto cleanup; } @@ -7313,11 +7313,11 @@ gfc_match_volatile (void) case MATCH_YES: /* F2008, C560+C561. VOLATILE for host-/use-associated variable or for variable in a BLOCK which is defined outside of the BLOCK. */ if (sym->ns != gfc_current_ns && sym->attr.codimension) { - gfc_error ("Specifying VOLATILE for coarray variable '%s' at " + gfc_error ("Specifying VOLATILE for coarray variable %qs at " "%C, which is use-/host-associated", sym->name); return MATCH_ERROR; } if (!gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus)) return MATCH_ERROR; @@ -7529,31 +7529,31 @@ check_extended_derived_type (char *name) extended = gfc_find_dt_in_generic (extended); /* F08:C428. */ if (!extended) { - gfc_error ("Symbol '%s' at %C has not been previously defined", name); + gfc_error ("Symbol %qs at %C has not been previously defined", name); return NULL; } if (extended->attr.flavor != FL_DERIVED) { - gfc_error ("'%s' in EXTENDS expression at %C is not a " + gfc_error ("%qs in EXTENDS expression at %C is not a " "derived type", name); return NULL; } if (extended->attr.is_bind_c) { - gfc_error ("'%s' cannot be extended at %C because it " + gfc_error ("%qs cannot be extended at %C because it " "is BIND(C)", extended->name); return NULL; } if (extended->attr.sequence) { - gfc_error ("'%s' cannot be extended at %C because it " + gfc_error ("%qs cannot be extended at %C because it " "is a SEQUENCE type", extended->name); return NULL; } return extended; @@ -7680,21 +7680,21 @@ gfc_match_derived_decl (void) return m; /* Make sure the name is not the name of an intrinsic type. */ if (gfc_is_intrinsic_typename (name)) { - gfc_error ("Type name '%s' at %C cannot be the same as an intrinsic " + gfc_error ("Type name %qs at %C cannot be the same as an intrinsic " "type", name); return MATCH_ERROR; } if (gfc_get_symbol (name, NULL, &gensym)) return MATCH_ERROR; if (!gensym->attr.generic && gensym->ts.type != BT_UNKNOWN) { - gfc_error ("Derived type name '%s' at %C already has a basic type " + gfc_error ("Derived type name %qs at %C already has a basic type " "of %s", gensym->name, gfc_typename (&gensym->ts)); return MATCH_ERROR; } if (!gensym->attr.generic @@ -7707,11 +7707,11 @@ gfc_match_derived_decl (void) sym = gfc_find_dt_in_generic (gensym); if (sym && (sym->components != NULL || sym->attr.zero_comp)) { - gfc_error ("Derived type definition of '%s' at %C has already been " + gfc_error ("Derived type definition of %qs at %C has already been " "defined", sym->name); return MATCH_ERROR; } if (!sym) @@ -7778,11 +7778,11 @@ gfc_match_derived_decl (void) /* Set extension level. */ if (extended->attr.extension == 255) { /* Since the extension field is 8 bit wide, we can only have up to 255 extension levels. */ - gfc_error ("Maximum extension level reached with type '%s' at %L", + gfc_error ("Maximum extension level reached with type %qs at %L", extended->name, &extended->declared_at); return MATCH_ERROR; } sym->attr.extension = extended->attr.extension + 1; @@ -8373,23 +8373,23 @@ match_procedure_in_type (void) gcc_assert (ns); /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */ if (tb.deferred && !block->attr.abstract) { - gfc_error ("Type '%s' containing DEFERRED binding at %C " + gfc_error ("Type %qs containing DEFERRED binding at %C " "is not ABSTRACT", block->name); return MATCH_ERROR; } /* See if we already have a binding with this name in the symtree which would be an error. If a GENERIC already targeted this binding, it may be already there but then typebound is still NULL. */ stree = gfc_find_symtree (ns->tb_sym_root, name); if (stree && stree->n.tb) { - gfc_error ("There is already a procedure with binding name '%s' for " - "the derived type '%s' at %C", name, block->name); + gfc_error ("There is already a procedure with binding name %qs for " + "the derived type %qs at %C", name, block->name); return MATCH_ERROR; } /* Insert it and set attributes. */ @@ -8534,19 +8534,19 @@ gfc_match_generic (void) { if (!tb->is_generic) { gcc_assert (op_type == INTERFACE_GENERIC); gfc_error ("There's already a non-generic procedure with binding name" - " '%s' for the derived type '%s' at %C", + " %qs for the derived type %qs at %C", bind_name, block->name); goto error; } if (tb->access != tbattr.access) { gfc_error ("Binding at %C must have the same access as already" - " defined binding '%s'", bind_name); + " defined binding %qs", bind_name); goto error; } } else { @@ -8600,12 +8600,12 @@ gfc_match_generic (void) /* See if this is a duplicate specification. */ for (target = tb->u.generic; target; target = target->next) if (target_st == target->specific_st) { - gfc_error ("'%s' already defined as specific binding for the" - " generic '%s' at %C", name, bind_name); + gfc_error ("%qs already defined as specific binding for the" + " generic %qs at %C", name, bind_name); goto error; } target = gfc_get_tbp_generic (); target->specific_st = target_st; @@ -8709,11 +8709,11 @@ gfc_match_final_decl (void) return MATCH_ERROR; } if (gfc_get_symbol (name, module_ns, &sym)) { - gfc_error ("Unknown procedure name \"%s\" at %C", name); + gfc_error ("Unknown procedure name %qs at %C", name); return MATCH_ERROR; } /* Mark the symbol as module procedure. */ if (sym->attr.proc != PROC_MODULE @@ -8722,11 +8722,11 @@ gfc_match_final_decl (void) /* Check if we already have this symbol in the list, this is an error. */ for (f = block->f2k_derived->finalizers; f; f = f->next) if (f->proc_sym == sym) { - gfc_error ("'%s' at %C is already defined as FINAL procedure!", + gfc_error ("%qs at %C is already defined as FINAL procedure!", name); return MATCH_ERROR; } /* Add this symbol to the list of finalizers. */ Index: gcc/fortran/trans-common.c =================================================================== --- gcc/fortran/trans-common.c (revision 218457) +++ gcc/fortran/trans-common.c (working copy) @@ -906,11 +906,11 @@ confirm_condition (segment_info *s1, gfc offset1 = calculate_offset (eq1->expr); offset2 = calculate_offset (eq2->expr); if (s1->offset + offset1 != s2->offset + offset2) - gfc_error ("Inconsistent equivalence rules involving '%s' at %L and " + gfc_error_1 ("Inconsistent equivalence rules involving '%s' at %L and " "'%s' at %L", s1->sym->name, &s1->sym->declared_at, s2->sym->name, &s2->sym->declared_at); } Index: gcc/fortran/array.c =================================================================== --- gcc/fortran/array.c (revision 218457) +++ gcc/fortran/array.c (working copy) @@ -98,11 +98,11 @@ match_subscript (gfc_array_ref *ar, int if (gfc_match_char (':') == MATCH_NO) goto matched; if (star) { - gfc_error ("Unexpected '*' in coarray subscript at %C"); + gfc_error ("Unexpected %<*%> in coarray subscript at %C"); return MATCH_ERROR; } /* Get an optional end element. Because we've seen the colon, we definitely have a range along this dimension. */ @@ -244,19 +244,19 @@ coarray: } if (gfc_match_char (',') != MATCH_YES) { if (gfc_match_char ('*') == MATCH_YES) - gfc_error ("Unexpected '*' for codimension %d of %d at %C", + gfc_error ("Unexpected %<*%> for codimension %d of %d at %C", ar->codimen + 1, corank); else gfc_error ("Invalid form of coarray reference at %C"); return MATCH_ERROR; } else if (ar->dimen_type[ar->codimen + ar->dimen] == DIMEN_STAR) { - gfc_error ("Unexpected '*' for codimension %d of %d at %C", + gfc_error ("Unexpected %<*%> for codimension %d of %d at %C", ar->codimen + 1, corank); return MATCH_ERROR; } if (ar->codimen >= corank) @@ -311,11 +311,11 @@ resolve_array_bound (gfc_expr *e, int ch return false; if (check_constant && !gfc_is_constant_expr (e)) { if (e->expr_type == EXPR_VARIABLE) - gfc_error ("Variable '%s' at %L in this context must be constant", + gfc_error ("Variable %qs at %L in this context must be constant", e->symtree->n.sym->name, &e->where); else gfc_error ("Expression at %L in this context must be constant", &e->where); return false; @@ -750,11 +750,11 @@ gfc_set_array_spec (gfc_symbol *sym, gfc } if ((sym->as->type == AS_ASSUMED_RANK && as->corank) || (as->type == AS_ASSUMED_RANK && sym->as->corank)) { - gfc_error ("The assumed-rank array '%s' at %L shall not have a " + gfc_error ("The assumed-rank array %qs at %L shall not have a " "codimension", sym->name, error_loc); return false; } if (as->corank) @@ -910,11 +910,11 @@ check_duplicate_iterator (gfc_constructo if (c->iterator == NULL) continue; if (c->iterator->var->symtree->n.sym == master) { - gfc_error ("DO-iterator '%s' at %L is inside iterator of the " + gfc_error ("DO-iterator %qs at %L is inside iterator of the " "same name", master->name, &c->where); return 1; } } @@ -1660,11 +1660,11 @@ gfc_expand_constructor (gfc_expr *e, boo gfc_free_expr (f); if (fatal) { gfc_error ("The number of elements in the array constructor " "at %L requires an increase of the allowed %d " - "upper limit. See -fmax-array-constructor " + "upper limit. See %<-fmax-array-constructor%> " "option", &e->where, gfc_option.flag_max_array_constructor); return false; } return true; Index: gcc/fortran/gfortran.h =================================================================== --- gcc/fortran/gfortran.h (revision 218457) +++ gcc/fortran/gfortran.h (working copy) @@ -2680,10 +2680,11 @@ bool gfc_warning_now (const char *, ...) bool gfc_warning_now (int opt, const char *, ...) ATTRIBUTE_GCC_GFC(2,3); void gfc_clear_warning (void); void gfc_warning_check (void); +void gfc_error_1 (const char *, ...) ATTRIBUTE_GCC_GFC(1,2); void gfc_error (const char *, ...) ATTRIBUTE_GCC_GFC(1,2); void gfc_error_now_1 (const char *, ...) ATTRIBUTE_GCC_GFC(1,2); void gfc_error_now (const char *, ...) ATTRIBUTE_GCC_GFC(1,2); void gfc_fatal_error (const char *, ...) ATTRIBUTE_NORETURN ATTRIBUTE_GCC_GFC(1,2); void gfc_internal_error (const char *, ...) ATTRIBUTE_NORETURN ATTRIBUTE_GCC_GFC(1,2); @@ -2696,13 +2697,14 @@ bool gfc_notify_std (int, const char *, /* A general purpose syntax error. */ #define gfc_syntax_error(ST) \ gfc_error ("Syntax error in %s statement at %C", gfc_ascii_statement (ST)); -void gfc_push_error (gfc_error_buf *); -void gfc_pop_error (gfc_error_buf *); -void gfc_free_error (gfc_error_buf *); +#include "pretty-print.h" /* For output_buffer. */ +void gfc_push_error (output_buffer *, gfc_error_buf *); +void gfc_pop_error (output_buffer *, gfc_error_buf *); +void gfc_free_error (output_buffer *, gfc_error_buf *); void gfc_get_errors (int *, int *); void gfc_errors_to_warnings (bool); /* arith.c */ Index: gcc/fortran/error.c =================================================================== --- gcc/fortran/error.c (revision 218457) +++ gcc/fortran/error.c (working copy) @@ -50,18 +50,26 @@ static int terminal_width, errors, warni static gfc_error_buf error_buffer, warning_buffer, *cur_error_buffer; /* True if the error/warnings should be buffered. */ static bool buffered_p; - /* These are always buffered buffers (.flush_p == false) to be used by the pretty-printer. */ -static output_buffer pp_warning_buffer; +static output_buffer pp_error_buffer, pp_warning_buffer; static int warningcount_buffered, werrorcount_buffered; #include /* For placement-new */ + +/* Return true if there output_buffer is empty. */ + +static bool +gfc_output_buffer_empty_p (const output_buffer * buf) +{ + return output_buffer_last_position_in_text (buf) == NULL; +} + /* Go one level deeper suppressing errors. */ void gfc_push_suppress_errors (void) { @@ -129,11 +137,11 @@ gfc_error_init_1 (void) void gfc_buffer_error (bool flag) { buffered_p = flag; - pp_warning_buffer.flush_p = !flag; + buffered_p = flag; } /* Add a single character to the error buffer or output depending on buffered_p. */ @@ -1281,11 +1289,10 @@ gfc_clear_warning (void) warning_buffer.flag = 0; gfc_clear_pp_buffer (&pp_warning_buffer); warningcount_buffered = 0; werrorcount_buffered = 0; - pp_warning_buffer.flush_p = false; } /* Check to see if any warnings have been saved. If so, print the warning. */ @@ -1296,33 +1303,32 @@ gfc_warning_check (void) if (warning_buffer.flag) { warnings++; if (warning_buffer.message != NULL) fputs (warning_buffer.message, stderr); - warning_buffer.flag = 0; + gfc_clear_warning (); } - /* This is for the new diagnostics machinery. */ - pretty_printer *pp = global_dc->printer; - output_buffer *tmp_buffer = pp->buffer; - pp->buffer = &pp_warning_buffer; - if (pp_last_position_in_text (pp) != NULL) + else if (! gfc_output_buffer_empty_p (&pp_warning_buffer)) { + pretty_printer *pp = global_dc->printer; + output_buffer *tmp_buffer = pp->buffer; + pp->buffer = &pp_warning_buffer; pp_really_flush (pp); - pp_warning_buffer.flush_p = true; warningcount += warningcount_buffered; werrorcount += werrorcount_buffered; + pp->buffer = tmp_buffer; } - - pp->buffer = tmp_buffer; } /* Issue an error. */ +/* Use gfc_error instead, unless two locations are used in the same + warning or for scanner.c, if the location is not properly set up. */ void -gfc_error (const char *gmsgid, ...) +gfc_error_1 (const char *gmsgid, ...) { va_list argp; if (warnings_not_errors) goto warning; @@ -1366,10 +1372,63 @@ warning: if (warnings_are_errors) gfc_increment_error_count(); } } +/* Issue an error. */ +/* This function uses the common diagnostics, but does not support + two locations; when being used in scanner.c, ensure that the location + is properly setup. Otherwise, use gfc_error_1. */ + +void +gfc_error (const char *gmsgid, ...) +{ + va_list argp; + va_start (argp, gmsgid); + + if (warnings_not_errors) + { + gfc_warning (/*opt=*/0, gmsgid, argp); + va_end (argp); + return; + } + + if (suppress_errors) + { + va_end (argp); + return; + } + + diagnostic_info diagnostic; + bool fatal_errors = global_dc->fatal_errors; + pretty_printer *pp = global_dc->printer; + output_buffer *tmp_buffer = pp->buffer; + + gfc_clear_pp_buffer (&pp_error_buffer); + + if (buffered_p) + { + pp->buffer = &pp_error_buffer; + global_dc->fatal_errors = false; + /* To prevent -fmax-errors= triggering, we decrease it before + report_diagnostic increases it. */ + --errorcount; + } + + diagnostic_set_info (&diagnostic, gmsgid, &argp, UNKNOWN_LOCATION, DK_ERROR); + report_diagnostic (&diagnostic); + + if (buffered_p) + { + pp->buffer = tmp_buffer; + global_dc->fatal_errors = fatal_errors; + } + + va_end (argp); +} + + /* Immediate error. */ /* Use gfc_error_now instead, unless two locations are used in the same warning or for scanner.c, if the location is not properly set up. */ @@ -1423,19 +1482,21 @@ gfc_internal_error (const char *gmsgid, void gfc_clear_error (void) { error_buffer.flag = 0; warnings_not_errors = false; + gfc_clear_pp_buffer (&pp_error_buffer); } /* Tests the state of error_flag. */ bool gfc_error_flag_test (void) { - return error_buffer.flag; + return error_buffer.flag + || !gfc_output_buffer_empty_p (&pp_error_buffer); } /* Check to see if any errors have been saved. If so, print the error. Returns the state of error_flag. */ @@ -1448,57 +1509,97 @@ gfc_error_check (void) if (error_raised) { if (error_buffer.message != NULL) fputs (error_buffer.message, stderr); error_buffer.flag = 0; + gfc_clear_pp_buffer (&pp_error_buffer); gfc_increment_error_count(); if (flag_fatal_errors) exit (FATAL_EXIT_CODE); } + /* This is for the new diagnostics machinery. */ + else if (! gfc_output_buffer_empty_p (&pp_error_buffer)) + { + error_raised = true; + pretty_printer *pp = global_dc->printer; + output_buffer *tmp_buffer = pp->buffer; + pp->buffer = &pp_error_buffer; + pp_really_flush (pp); + ++errorcount; + diagnostic_action_after_output (global_dc, DK_ERROR); + pp_really_flush (pp); + gcc_assert (gfc_output_buffer_empty_p (&pp_error_buffer)); + pp->buffer = tmp_buffer; + } return error_raised; } +/* Move the text buffered from FROM to TO, then clear + FROM. Independently if there was text in FROM, TO is also + cleared. */ + +static void +gfc_move_output_buffer_from_to (output_buffer *from, output_buffer *to) +{ + gfc_clear_pp_buffer (to); + /* We make sure this is always buffered. */ + to->flush_p = false; + + if (! gfc_output_buffer_empty_p (from)) + { + const char *str = output_buffer_formatted_text (from); + output_buffer_append_r (to, str, strlen (str)); + gfc_clear_pp_buffer (from); + } +} /* Save the existing error state. */ void -gfc_push_error (gfc_error_buf *err) +gfc_push_error (output_buffer *buffer_err, gfc_error_buf *err) { err->flag = error_buffer.flag; if (error_buffer.flag) err->message = xstrdup (error_buffer.message); error_buffer.flag = 0; + + /* This part uses the common diagnostics. */ + gfc_move_output_buffer_from_to (&pp_error_buffer, buffer_err); } /* Restore a previous pushed error state. */ void -gfc_pop_error (gfc_error_buf *err) +gfc_pop_error (output_buffer *buffer_err, gfc_error_buf *err) { error_buffer.flag = err->flag; if (error_buffer.flag) { size_t len = strlen (err->message) + 1; gcc_assert (len <= error_buffer.allocated); memcpy (error_buffer.message, err->message, len); free (err->message); } + /* This part uses the common diagnostics. */ + gfc_move_output_buffer_from_to (buffer_err, &pp_error_buffer); } /* Free a pushed error state, but keep the current error state. */ void -gfc_free_error (gfc_error_buf *err) +gfc_free_error (output_buffer *buffer_err, gfc_error_buf *err) { if (err->flag) free (err->message); + + gfc_clear_pp_buffer (buffer_err); } /* Report the number of warnings and errors that occurred to the caller. */ @@ -1526,10 +1627,13 @@ gfc_diagnostics_init (void) diagnostic_starter (global_dc) = gfc_diagnostic_starter; diagnostic_finalizer (global_dc) = gfc_diagnostic_finalizer; diagnostic_format_decoder (global_dc) = gfc_format_decoder; global_dc->caret_char = '^'; new (&pp_warning_buffer) output_buffer (); + pp_warning_buffer.flush_p = false; + new (&pp_error_buffer) output_buffer (); + pp_error_buffer.flush_p = false; } void gfc_diagnostics_finish (void) { Index: gcc/fortran/data.c =================================================================== --- gcc/fortran/data.c (revision 218457) +++ gcc/fortran/data.c (working copy) @@ -251,13 +251,13 @@ gfc_assign_data_value (gfc_expr *lvalue, continue; } if (init && expr->expr_type != EXPR_ARRAY) { - gfc_error ("'%s' at %L already is initialized at %L", - lvalue->symtree->n.sym->name, &lvalue->where, - &init->where); + gfc_error_1 ("'%s' at %L already is initialized at %L", + lvalue->symtree->n.sym->name, &lvalue->where, + &init->where); goto abort; } if (init == NULL) { Index: gcc/fortran/expr.c =================================================================== --- gcc/fortran/expr.c (revision 218457) +++ gcc/fortran/expr.c (working copy) @@ -2202,13 +2202,13 @@ check_alloc_comp_init (gfc_expr *e) comp; comp = comp->next, ctor = gfc_constructor_next (ctor)) { if (comp->attr.allocatable && ctor->expr->expr_type != EXPR_NULL) { - gfc_error("Invalid initialization expression for ALLOCATABLE " - "component '%s' in structure constructor at %L", - comp->name, &ctor->expr->where); + gfc_error ("Invalid initialization expression for ALLOCATABLE " + "component %qs in structure constructor at %L", + comp->name, &ctor->expr->where); return false; } } return true; @@ -2313,11 +2313,11 @@ check_inquiry (gfc_expr *e, int not_rest if (i == 5 && not_restricted && ap->expr->symtree->n.sym->ts.type == BT_CHARACTER && (ap->expr->symtree->n.sym->ts.u.cl->length == NULL || ap->expr->symtree->n.sym->ts.deferred)) { - gfc_error ("Assumed or deferred character length variable '%s' " + gfc_error ("Assumed or deferred character length variable %qs " " in constant expression at %L", ap->expr->symtree->n.sym->name, &ap->expr->where); return MATCH_ERROR; } @@ -2379,12 +2379,12 @@ check_transformational (gfc_expr *e) if (strcmp (functions[i], name) == 0) break; if (functions[i] == NULL) { - gfc_error("transformational intrinsic '%s' at %L is not permitted " - "in an initialization expression", name, &e->where); + gfc_error ("transformational intrinsic %qs at %L is not permitted " + "in an initialization expression", name, &e->where); return MATCH_ERROR; } return check_init_expr_arguments (e); } @@ -2479,11 +2479,11 @@ gfc_check_init_expr (gfc_expr *e) } if (!gfc_is_intrinsic (sym, 0, e->where) || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES) { - gfc_error ("Function '%s' in initialization expression at %L " + gfc_error ("Function %qs in initialization expression at %L " "must be an intrinsic function", e->symtree->n.sym->name, &e->where); break; } @@ -2491,11 +2491,11 @@ gfc_check_init_expr (gfc_expr *e) && (m = check_inquiry (e, 1)) == MATCH_NO && (m = check_null (e)) == MATCH_NO && (m = check_transformational (e)) == MATCH_NO && (m = check_elemental (e)) == MATCH_NO) { - gfc_error ("Intrinsic function '%s' at %L is not permitted " + gfc_error ("Intrinsic function %qs at %L is not permitted " "in an initialization expression", e->symtree->n.sym->name, &e->where); m = MATCH_ERROR; } @@ -2526,12 +2526,12 @@ gfc_check_init_expr (gfc_expr *e) /* A PARAMETER shall not be used to define itself, i.e. REAL, PARAMETER :: x = transfer(0, x) is invalid. */ if (!e->symtree->n.sym->value) { - gfc_error("PARAMETER '%s' is used at %L before its definition " - "is complete", e->symtree->n.sym->name, &e->where); + gfc_error ("PARAMETER %qs is used at %L before its definition " + "is complete", e->symtree->n.sym->name, &e->where); t = false; } else t = simplify_parameter_variable (e, 0); @@ -2546,39 +2546,39 @@ gfc_check_init_expr (gfc_expr *e) if (e->symtree->n.sym->as) { switch (e->symtree->n.sym->as->type) { case AS_ASSUMED_SIZE: - gfc_error ("Assumed size array '%s' at %L is not permitted " + gfc_error ("Assumed size array %qs at %L is not permitted " "in an initialization expression", e->symtree->n.sym->name, &e->where); break; case AS_ASSUMED_SHAPE: - gfc_error ("Assumed shape array '%s' at %L is not permitted " + gfc_error ("Assumed shape array %qs at %L is not permitted " "in an initialization expression", e->symtree->n.sym->name, &e->where); break; case AS_DEFERRED: - gfc_error ("Deferred array '%s' at %L is not permitted " + gfc_error ("Deferred array %qs at %L is not permitted " "in an initialization expression", e->symtree->n.sym->name, &e->where); break; case AS_EXPLICIT: - gfc_error ("Array '%s' at %L is a variable, which does " + gfc_error ("Array %qs at %L is a variable, which does " "not reduce to a constant expression", e->symtree->n.sym->name, &e->where); break; default: gcc_unreachable(); } } else - gfc_error ("Parameter '%s' at %L has not been declared or is " + gfc_error ("Parameter %qs at %L has not been declared or is " "a variable, which does not reduce to a constant " "expression", e->symtree->n.sym->name, &e->where); break; @@ -2727,32 +2727,32 @@ external_spec_function (gfc_expr *e) f = e->value.function.esym; if (f->attr.proc == PROC_ST_FUNCTION) { - gfc_error ("Specification function '%s' at %L cannot be a statement " + gfc_error ("Specification function %qs at %L cannot be a statement " "function", f->name, &e->where); return false; } if (f->attr.proc == PROC_INTERNAL) { - gfc_error ("Specification function '%s' at %L cannot be an internal " + gfc_error ("Specification function %qs at %L cannot be an internal " "function", f->name, &e->where); return false; } if (!f->attr.pure && !f->attr.elemental) { - gfc_error ("Specification function '%s' at %L must be PURE", f->name, + gfc_error ("Specification function %qs at %L must be PURE", f->name, &e->where); return false; } if (f->attr.recursive) { - gfc_error ("Specification function '%s' at %L cannot be RECURSIVE", + gfc_error ("Specification function %qs at %L cannot be RECURSIVE", f->name, &e->where); return false; } return restricted_args (e->value.function.actual); @@ -2882,25 +2882,25 @@ check_restricted (gfc_expr *e) don't need to jump through hoops to distinguish valid from invalid cases. */ if (sym->attr.dummy && sym->ns == gfc_current_ns && sym->ns->proc_name && sym->ns->proc_name->attr.elemental) { - gfc_error ("Dummy argument '%s' not allowed in expression at %L", + gfc_error ("Dummy argument %qs not allowed in expression at %L", sym->name, &e->where); break; } if (sym->attr.optional) { - gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL", + gfc_error ("Dummy argument %qs at %L cannot be OPTIONAL", sym->name, &e->where); break; } if (sym->attr.intent == INTENT_OUT) { - gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)", + gfc_error ("Dummy argument %qs at %L cannot be INTENT(OUT)", sym->name, &e->where); break; } /* Check reference chain if any. */ @@ -2927,11 +2927,11 @@ check_restricted (gfc_expr *e) { t = true; break; } - gfc_error ("Variable '%s' cannot appear in the expression at %L", + gfc_error ("Variable %qs cannot appear in the expression at %L", sym->name, &e->where); /* Prevent a repetition of the error. */ e->error = 1; break; @@ -2990,11 +2990,11 @@ gfc_specification_expr (gfc_expr *e) && !e->value.function.isym && !e->value.function.esym && !gfc_pure (e->symtree->n.sym) && (!comp || !comp->attr.pure)) { - gfc_error ("Function '%s' at %L must be PURE", + gfc_error ("Function %qs at %L must be PURE", e->symtree->n.sym->name, &e->where); /* Prevent repeat error messages. */ e->symtree->n.sym->attr.pure = 1; return false; } @@ -3136,11 +3136,11 @@ gfc_check_assign (gfc_expr *lvalue, gfc_ && sym != gfc_current_ns->parent->proc_name->result) bad_proc = true; if (bad_proc) { - gfc_error ("'%s' at %L is not a VALUE", sym->name, &lvalue->where); + gfc_error ("%qs at %L is not a VALUE", sym->name, &lvalue->where); return false; } } if (rvalue->rank != 0 && lvalue->rank != rvalue->rank) @@ -3329,11 +3329,11 @@ gfc_check_pointer_assign (gfc_expr *lval } if (lhs_attr.flavor == FL_PROCEDURE && lhs_attr.use_assoc && !lhs_attr.proc_pointer) { - gfc_error ("'%s' in the pointer assignment at %L cannot be an " + gfc_error ("%qs in the pointer assignment at %L cannot be an " "l-value since it is a procedure", lvalue->symtree->n.sym->name, &lvalue->where); return false; } @@ -3352,11 +3352,11 @@ gfc_check_pointer_assign (gfc_expr *lval if (ref->u.ar.type == AR_FULL) break; if (ref->u.ar.type != AR_SECTION) { - gfc_error ("Expected bounds specification for '%s' at %L", + gfc_error ("Expected bounds specification for %qs at %L", lvalue->symtree->n.sym->name, &lvalue->where); return false; } if (!gfc_notify_std (GFC_STD_F2003, "Bounds specification " @@ -3459,30 +3459,30 @@ gfc_check_pointer_assign (gfc_expr *lval gfc_namespace *ns; for (ns = gfc_current_ns; ns; ns = ns->parent) if (sym == ns->proc_name) { - gfc_error ("Function result '%s' is invalid as proc-target " + gfc_error ("Function result %qs is invalid as proc-target " "in procedure pointer assignment at %L", sym->name, &rvalue->where); return false; } } } if (attr.abstract) { - gfc_error ("Abstract interface '%s' is invalid " + gfc_error ("Abstract interface %qs is invalid " "in procedure pointer assignment at %L", rvalue->symtree->name, &rvalue->where); return false; } /* Check for F08:C729. */ if (attr.flavor == FL_PROCEDURE) { if (attr.proc == PROC_ST_FUNCTION) { - gfc_error ("Statement function '%s' is invalid " + gfc_error ("Statement function %qs is invalid " "in procedure pointer assignment at %L", rvalue->symtree->name, &rvalue->where); return false; } if (attr.proc == PROC_INTERNAL && @@ -3491,19 +3491,19 @@ gfc_check_pointer_assign (gfc_expr *lval "at %L", rvalue->symtree->name, &rvalue->where)) return false; if (attr.intrinsic && gfc_intrinsic_actual_ok (rvalue->symtree->name, attr.subroutine) == 0) { - gfc_error ("Intrinsic '%s' at %L is invalid in procedure pointer " + gfc_error ("Intrinsic %qs at %L is invalid in procedure pointer " "assignment", rvalue->symtree->name, &rvalue->where); return false; } } /* Check for F08:C730. */ if (attr.elemental && !attr.intrinsic) { - gfc_error ("Nonintrinsic elemental procedure '%s' is invalid " + gfc_error ("Nonintrinsic elemental procedure %qs is invalid " "in procedure pointer assignment at %L", rvalue->symtree->name, &rvalue->where); return false; } @@ -3578,18 +3578,18 @@ gfc_check_pointer_assign (gfc_expr *lval /* F08:7.2.2.4 (4) */ if (s1->attr.if_source == IFSRC_UNKNOWN && gfc_explicit_interface_required (s2, err, sizeof(err))) { - gfc_error ("Explicit interface required for '%s' at %L: %s", + gfc_error ("Explicit interface required for %qs at %L: %s", s1->name, &lvalue->where, err); return false; } if (s2->attr.if_source == IFSRC_UNKNOWN && gfc_explicit_interface_required (s1, err, sizeof(err))) { - gfc_error ("Explicit interface required for '%s' at %L: %s", + gfc_error ("Explicit interface required for %qs at %L: %s", s2->name, &rvalue->where, err); return false; } if (!gfc_compare_interfaces (s1, s2, name, 0, 1, @@ -3602,11 +3602,11 @@ gfc_check_pointer_assign (gfc_expr *lval /* Check F2008Cor2, C729. */ if (!s2->attr.intrinsic && s2->attr.if_source == IFSRC_UNKNOWN && !s2->attr.external && !s2->attr.subroutine && !s2->attr.function) { - gfc_error ("Procedure pointer target '%s' at %L must be either an " + gfc_error ("Procedure pointer target %qs at %L must be either an " "intrinsic, host or use associated, referenced or have " "the EXTERNAL attribute", s2->name, &rvalue->where); return false; } @@ -4756,20 +4756,20 @@ gfc_check_vardef_context (gfc_expr* e, b } if (!pointer && sym->attr.flavor == FL_PARAMETER) { if (context) - gfc_error ("Named constant '%s' in variable definition context (%s)" + gfc_error ("Named constant %qs in variable definition context (%s)" " at %L", sym->name, context, &e->where); return false; } if (!pointer && sym->attr.flavor != FL_VARIABLE && !(sym->attr.flavor == FL_PROCEDURE && sym == sym->result) && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer)) { if (context) - gfc_error ("'%s' in variable definition context (%s) at %L is not" + gfc_error ("%qs in variable definition context (%s) at %L is not" " a variable", sym->name, context, &e->where); return false; } /* Find out whether the expr is a pointer; this also means following @@ -4818,19 +4818,19 @@ gfc_check_vardef_context (gfc_expr* e, b if (check_intentin && sym->attr.intent == INTENT_IN) { if (pointer && is_pointer) { if (context) - gfc_error ("Dummy argument '%s' with INTENT(IN) in pointer" + gfc_error ("Dummy argument %qs with INTENT(IN) in pointer" " association context (%s) at %L", sym->name, context, &e->where); return false; } if (!pointer && !is_pointer && !sym->attr.pointer) { if (context) - gfc_error ("Dummy argument '%s' with INTENT(IN) in variable" + gfc_error ("Dummy argument %qs with INTENT(IN) in variable" " definition context (%s) at %L", sym->name, context, &e->where); return false; } } @@ -4839,19 +4839,19 @@ gfc_check_vardef_context (gfc_expr* e, b if (sym->attr.is_protected && sym->attr.use_assoc && check_intentin) { if (pointer && is_pointer) { if (context) - gfc_error ("Variable '%s' is PROTECTED and can not appear in a" + gfc_error ("Variable %qs is PROTECTED and can not appear in a" " pointer association context (%s) at %L", sym->name, context, &e->where); return false; } if (!pointer && !is_pointer) { if (context) - gfc_error ("Variable '%s' is PROTECTED and can not appear in a" + gfc_error ("Variable %qs is PROTECTED and can not appear in a" " variable definition context (%s) at %L", sym->name, context, &e->where); return false; } } @@ -4859,11 +4859,11 @@ gfc_check_vardef_context (gfc_expr* e, b /* Variable not assignable from a PURE procedure but appears in variable definition context. */ if (!pointer && !own_scope && gfc_pure (NULL) && gfc_impure_variable (sym)) { if (context) - gfc_error ("Variable '%s' can not appear in a variable definition" + gfc_error ("Variable %qs can not appear in a variable definition" " context (%s) at %L in PURE procedure", sym->name, context, &e->where); return false; } @@ -4918,26 +4918,26 @@ gfc_check_vardef_context (gfc_expr* e, b if (!assoc->variable) { if (context) { if (assoc->target->expr_type == EXPR_VARIABLE) - gfc_error ("'%s' at %L associated to vector-indexed target can" + gfc_error ("%qs at %L associated to vector-indexed target can" " not be used in a variable definition context (%s)", name, &e->where, context); else - gfc_error ("'%s' at %L associated to expression can" + gfc_error ("%qs at %L associated to expression can" " not be used in a variable definition context (%s)", name, &e->where, context); } return false; } /* Target must be allowed to appear in a variable definition context. */ if (!gfc_check_vardef_context (assoc->target, pointer, false, false, NULL)) { if (context) - gfc_error ("Associate-name '%s' can not appear in a variable" + gfc_error_1 ("Associate-name '%s' can not appear in a variable" " definition context (%s) at %L because its target" " at %L can not, either", name, context, &e->where, &assoc->target->where); return false; Index: gcc/fortran/scanner.c =================================================================== --- gcc/fortran/scanner.c (revision 218457) +++ gcc/fortran/scanner.c (working copy) @@ -2043,10 +2043,11 @@ load_file (const char *realfilename, con /* Add line. */ b = XCNEWVAR (gfc_linebuf, gfc_linebuf_header_size + (len + 1) * sizeof (gfc_char_t)); + b->location = linemap_line_start (line_table, current_file->line++, len); /* ??? We add the location for the maximum column possible here, because otherwise if the next call creates a new line-map, it will not reserve space for any offset. */ Index: gcc/fortran/resolve.c =================================================================== --- gcc/fortran/resolve.c (revision 218457) +++ gcc/fortran/resolve.c (working copy) @@ -467,28 +467,28 @@ resolve_formal_arglist (gfc_symbol *proc if (sym->attr.pointer || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) && CLASS_DATA (sym)->attr.class_pointer)) { - gfc_error ("Argument '%s' of elemental procedure at %L cannot " + gfc_error ("Argument %qs of elemental procedure at %L cannot " "have the POINTER attribute", sym->name, &sym->declared_at); continue; } if (sym->attr.flavor == FL_PROCEDURE) { - gfc_error ("Dummy procedure '%s' not allowed in elemental " - "procedure '%s' at %L", sym->name, proc->name, + gfc_error ("Dummy procedure %qs not allowed in elemental " + "procedure %qs at %L", sym->name, proc->name, &sym->declared_at); continue; } /* Fortran 2008 Corrigendum 1, C1290a. */ if (sym->attr.intent == INTENT_UNKNOWN && !sym->attr.value) { - gfc_error ("Argument '%s' of elemental procedure '%s' at %L must " + gfc_error ("Argument %qs of elemental procedure %qs at %L must " "have its INTENT specified or have the VALUE " "attribute", sym->name, proc->name, &sym->declared_at); continue; } @@ -497,21 +497,21 @@ resolve_formal_arglist (gfc_symbol *proc /* Each dummy shall be specified to be scalar. */ if (proc->attr.proc == PROC_ST_FUNCTION) { if (sym->as != NULL) { - gfc_error ("Argument '%s' of statement function at %L must " + gfc_error ("Argument %qs of statement function at %L must " "be scalar", sym->name, &sym->declared_at); continue; } if (sym->ts.type == BT_CHARACTER) { gfc_charlen *cl = sym->ts.u.cl; if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT) { - gfc_error ("Character-valued argument '%s' of statement " + gfc_error ("Character-valued argument %qs of statement " "function at %L must have constant length", sym->name, &sym->declared_at); continue; } } @@ -565,14 +565,14 @@ resolve_contained_fntype (gfc_symbol *sy t = gfc_set_default_type (sym->result, 0, ns); if (!t && !sym->result->attr.untyped) { if (sym->result == sym) - gfc_error ("Contained function '%s' at %L has no IMPLICIT type", + gfc_error ("Contained function %qs at %L has no IMPLICIT type", sym->name, &sym->declared_at); else if (!sym->result->attr.proc_pointer) - gfc_error ("Result '%s' of contained function '%s' at %L has " + gfc_error ("Result %qs of contained function %qs at %L has " "no IMPLICIT type", sym->result->name, sym->name, &sym->result->declared_at); sym->result->attr.untyped = 1; } } @@ -592,11 +592,11 @@ resolve_contained_fntype (gfc_symbol *sy accordingly. */ bool module_proc; gcc_assert (ns->parent && ns->parent->proc_name); module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE); - gfc_error ("Character-valued %s '%s' at %L must not be" + gfc_error ("Character-valued %s %qs at %L must not be" " assumed length", module_proc ? _("module procedure") : _("internal function"), sym->name, &sym->declared_at); } @@ -982,11 +982,11 @@ resolve_common_blocks (gfc_symtree *comm || strcmp (common_root->n.common->binding_label, gsym->binding_label) != 0)) || (!common_root->n.common->binding_label && gsym->binding_label))) { - gfc_error ("In Fortran 2003 COMMON '%s' block at %L is a global " + gfc_error_1 ("In Fortran 2003 COMMON '%s' block at %L is a global " "identifier and must thus have the same binding name " "as the same-named COMMON block at %L: %s vs %s", common_root->n.common->name, &common_root->n.common->where, &gsym->where, common_root->n.common->binding_label @@ -996,19 +996,19 @@ resolve_common_blocks (gfc_symtree *comm } if (gsym && gsym->type != GSYM_COMMON && !common_root->n.common->binding_label) { - gfc_error ("COMMON block '%s' at %L uses the same global identifier " + gfc_error_1 ("COMMON block '%s' at %L uses the same global identifier " "as entity at %L", common_root->n.common->name, &common_root->n.common->where, &gsym->where); return; } if (gsym && gsym->type != GSYM_COMMON) { - gfc_error ("Fortran 2008: COMMON block '%s' with binding label at " + gfc_error_1 ("Fortran 2008: COMMON block '%s' with binding label at " "%L sharing the identifier with global non-COMMON-block " "entity at %L", common_root->n.common->name, &common_root->n.common->where, &gsym->where); return; } @@ -1026,11 +1026,11 @@ resolve_common_blocks (gfc_symtree *comm { gsym = gfc_find_gsymbol (gfc_gsym_root, common_root->n.common->binding_label); if (gsym && gsym->type != GSYM_COMMON) { - gfc_error ("COMMON block at %L with binding label %s uses the same " + gfc_error_1 ("COMMON block at %L with binding label %s uses the same " "global identifier as entity at %L", &common_root->n.common->where, common_root->n.common->binding_label, &gsym->where); return; } @@ -1047,19 +1047,19 @@ resolve_common_blocks (gfc_symtree *comm gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym); if (sym == NULL) return; if (sym->attr.flavor == FL_PARAMETER) - gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L", + gfc_error_1 ("COMMON block '%s' at %L is used as PARAMETER at %L", sym->name, &common_root->n.common->where, &sym->declared_at); if (sym->attr.external) - gfc_error ("COMMON block '%s' at %L can not have the EXTERNAL attribute", + gfc_error ("COMMON block %qs at %L can not have the EXTERNAL attribute", sym->name, &common_root->n.common->where); if (sym->attr.intrinsic) - gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure", + gfc_error ("COMMON block %qs at %L is also an intrinsic procedure", sym->name, &common_root->n.common->where); else if (sym->attr.result || gfc_is_function_return_value (sym, gfc_current_ns)) gfc_notify_std (GFC_STD_F2003, "COMMON block '%s' at %L " "that is also a function result", sym->name, @@ -1169,11 +1169,11 @@ resolve_structure_cons (gfc_expr *expr, cons->expr->ts = comp->ts; } else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN) { gfc_error ("The element in the structure constructor at %L, " - "for pointer component '%s', is %s but should be %s", + "for pointer component %qs, is %s but should be %s", &cons->expr->where, comp->name, gfc_basic_typename (cons->expr->ts.type), gfc_basic_typename (comp->ts.type)); t = false; } @@ -1254,11 +1254,11 @@ resolve_structure_cons (gfc_expr *expr, && (CLASS_DATA (comp)->attr.class_pointer || CLASS_DATA (comp)->attr.allocatable)))) { t = false; gfc_error ("The NULL in the structure constructor at %L is " - "being applied to component '%s', which is neither " + "being applied to component %qs, which is neither " "a POINTER nor ALLOCATABLE", &cons->expr->where, comp->name); } if (comp->attr.proc_pointer && comp->ts.interface) @@ -1288,11 +1288,11 @@ resolve_structure_cons (gfc_expr *expr, if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1, err, sizeof (err), NULL, NULL)) { gfc_error ("Interface mismatch for procedure-pointer component " - "'%s' in structure constructor at %L: %s", + "%qs in structure constructor at %L: %s", comp->name, &cons->expr->where, err); return false; } } @@ -1304,11 +1304,11 @@ resolve_structure_cons (gfc_expr *expr, if (!a.pointer && !a.target) { t = false; gfc_error ("The element in the structure constructor at %L, " - "for pointer component '%s' should be a POINTER or " + "for pointer component %qs should be a POINTER or " "a TARGET", &cons->expr->where, comp->name); } if (init) { @@ -1333,11 +1333,11 @@ resolve_structure_cons (gfc_expr *expr, || gfc_is_coindexed (cons->expr)); if (impure && gfc_pure (NULL)) { t = false; gfc_error ("Invalid expression in the structure constructor for " - "pointer component '%s' at %L in PURE procedure", + "pointer component %qs at %L in PURE procedure", comp->name, &cons->expr->where); } if (impure) gfc_unset_implicit_pure (NULL); @@ -1459,11 +1459,11 @@ check_assumed_size_reference (gfc_symbol && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE) && (e->ref->u.ar.type == AR_FULL)) { gfc_error ("The upper bound in the last dimension must " "appear in the reference to the assumed size " - "array '%s' at %L", sym->name, &e->where); + "array %qs at %L", sym->name, &e->where); return true; } return false; } @@ -1519,15 +1519,15 @@ count_specific_procs (gfc_expr *e) sym->name); n++; } if (n > 1) - gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name, + gfc_error ("%qs at %L is ambiguous", e->symtree->n.sym->name, &e->where); if (n == 0) - gfc_error ("GENERIC procedure '%s' is not allowed as an actual " + gfc_error ("GENERIC procedure %qs is not allowed as an actual " "argument at %L", sym->name, &e->where); return n; } @@ -1657,22 +1657,22 @@ gfc_resolve_intrinsic (gfc_symbol *sym, } else if (isym || (isym = gfc_find_subroutine (sym->name))) { if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type) { - gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type" + gfc_error ("Intrinsic subroutine %qs at %L shall not have a type" " specifier", sym->name, &sym->declared_at); return false; } if (!sym->attr.subroutine && !gfc_add_subroutine(&sym->attr, sym->name, loc)) return false; } else { - gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym->name, + gfc_error ("%qs declared INTRINSIC at %L does not exist", sym->name, &sym->declared_at); return false; } gfc_copy_formal_args_intr (sym, isym, NULL); @@ -1681,11 +1681,11 @@ gfc_resolve_intrinsic (gfc_symbol *sym, sym->attr.elemental = isym->elemental; /* Check it is actually available in the standard settings. */ if (!gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)) { - gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not" + gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not" " available in the current standard settings but %s. Use" " an appropriate -std=* option or enable -fall-intrinsics" " in order to use it.", sym->name, &sym->declared_at, symstd); return false; @@ -1798,19 +1798,19 @@ resolve_actual_arglist (gfc_actual_argli if (gfc_is_intrinsic (sym, sym->attr.subroutine, e->where)) sym->attr.intrinsic = 1; if (sym->attr.proc == PROC_ST_FUNCTION) { - gfc_error ("Statement function '%s' at %L is not allowed as an " + gfc_error ("Statement function %qs at %L is not allowed as an " "actual argument", sym->name, &e->where); } actual_ok = gfc_intrinsic_actual_ok (sym->name, sym->attr.subroutine); if (sym->attr.intrinsic && actual_ok == 0) { - gfc_error ("Intrinsic '%s' at %L is not allowed as an " + gfc_error ("Intrinsic %qs at %L is not allowed as an " "actual argument", sym->name, &e->where); } if (sym->attr.contained && !sym->attr.use_assoc && sym->ns->proc_name->attr.flavor != FL_MODULE) @@ -1821,11 +1821,11 @@ resolve_actual_arglist (gfc_actual_argli goto cleanup; } if (sym->attr.elemental && !sym->attr.intrinsic) { - gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not " + gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not " "allowed as an actual argument at %L", sym->name, &e->where); } /* Check if a generic interface has a specific procedure @@ -1849,11 +1849,11 @@ resolve_actual_arglist (gfc_actual_argli isym = gfc_find_function (sym->name); if (isym == NULL || !isym->specific) { gfc_error ("Unable to find a specific INTRINSIC procedure " - "for the reference '%s' at %L", sym->name, + "for the reference %qs at %L", sym->name, &e->where); goto cleanup; } sym->ts = isym->ts; sym->attr.intrinsic = 1; @@ -1870,11 +1870,11 @@ resolve_actual_arglist (gfc_actual_argli if (was_declared (sym) || sym->ns->parent == NULL) goto got_variable; if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st)) { - gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where); + gfc_error ("Symbol %qs at %L is ambiguous", sym->name, &e->where); goto cleanup; } if (parent_st == NULL) goto got_variable; @@ -2137,12 +2137,12 @@ resolve_elemental_actual (gfc_expr *expr arg = arg->next, eformal = eformal->next) if ((eformal->sym->attr.intent == INTENT_OUT || eformal->sym->attr.intent == INTENT_INOUT) && arg->expr && arg->expr->rank == 0) { - gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of " - "ELEMENTAL subroutine '%s' is a scalar, but another " + gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of " + "ELEMENTAL subroutine %qs is a scalar, but another " "actual argument is an array", &arg->expr->where, (eformal->sym->attr.intent == INTENT_OUT) ? "OUT" : "INOUT", eformal->sym->name, esym->name); return false; } @@ -2414,20 +2414,20 @@ resolve_global_procedure (gfc_symbol *sy } } if (sym->attr.function && !gfc_compare_types (&sym->ts, &def_sym->ts)) { - gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)", + gfc_error ("Return type mismatch of function %qs at %L (%s/%s)", sym->name, &sym->declared_at, gfc_typename (&sym->ts), gfc_typename (&def_sym->ts)); goto done; } if (sym->attr.if_source == IFSRC_UNKNOWN && gfc_explicit_interface_required (def_sym, reason, sizeof(reason))) { - gfc_error ("Explicit interface required for '%s' at %L: %s", + gfc_error ("Explicit interface required for %qs at %L: %s", sym->name, &sym->declared_at, reason); goto done; } if (!pedantic && (gfc_option.allow_std & GFC_STD_GNU)) @@ -2435,11 +2435,11 @@ resolve_global_procedure (gfc_symbol *sy gfc_errors_to_warnings (true); if (!gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1, reason, sizeof(reason), NULL, NULL)) { - gfc_error ("Interface mismatch in global procedure '%s' at %L: %s ", + gfc_error ("Interface mismatch in global procedure %qs at %L: %s ", sym->name, &sym->declared_at, reason); goto done; } if (!pedantic @@ -2543,11 +2543,11 @@ generic: /* Last ditch attempt. See if the reference is to an intrinsic that possesses a matching interface. 14.1.2.4 */ if (sym && !intr && !gfc_is_intrinsic (sym, 0, expr->where)) { - gfc_error ("There is no specific function for the generic '%s' " + gfc_error ("There is no specific function for the generic %qs " "at %L", expr->symtree->n.sym->name, &expr->where); return false; } if (intr) @@ -2561,11 +2561,11 @@ generic: m = gfc_intrinsic_func_interface (expr, 0); if (m == MATCH_YES) return true; if (m == MATCH_NO) - gfc_error ("Generic function '%s' at %L is not consistent with a " + gfc_error ("Generic function %qs at %L is not consistent with a " "specific intrinsic interface", expr->symtree->n.sym->name, &expr->where); return false; } @@ -2599,11 +2599,11 @@ resolve_specific_f0 (gfc_symbol *sym, gf { m = gfc_intrinsic_func_interface (expr, 1); if (m == MATCH_YES) return MATCH_YES; if (m == MATCH_NO) - gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible " + gfc_error ("Function %qs at %L is INTRINSIC but is not compatible " "with an intrinsic", sym->name, &expr->where); return MATCH_ERROR; } @@ -2650,11 +2650,11 @@ resolve_specific_f (gfc_expr *expr) if (sym == NULL) break; } - gfc_error ("Unable to resolve the specific function '%s' at %L", + gfc_error ("Unable to resolve the specific function %qs at %L", expr->symtree->n.sym->name, &expr->where); return true; } @@ -2706,11 +2706,11 @@ set_type: { ts = gfc_get_default_type (sym->name, sym->ns); if (ts->type == BT_UNKNOWN) { - gfc_error ("Function '%s' at %L has no IMPLICIT type", + gfc_error ("Function %qs at %L has no IMPLICIT type", sym->name, &expr->where); return false; } else expr->ts = *ts; @@ -2827,19 +2827,19 @@ resolve_function (gfc_expr *expr) && !gfc_resolve_intrinsic (sym, &expr->where)) return false; if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine)) { - gfc_error ("'%s' at %L is not a function", sym->name, &expr->where); + gfc_error ("%qs at %L is not a function", sym->name, &expr->where); return false; } /* If this ia a deferred TBP with an abstract interface (which may of course be referenced), expr->value.function.esym will be set. */ if (sym && sym->attr.abstract && !expr->value.function.esym) { - gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L", + gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L", sym->name, &expr->where); return false; } /* Switch off assumed size checking and do this again for certain kinds @@ -2878,11 +2878,11 @@ resolve_function (gfc_expr *expr) && !sym->ts.deferred && expr->value.function.esym == NULL && !sym->attr.contained) { /* Internal procedures are taken care of in resolve_contained_fntype. */ - gfc_error ("Function '%s' is declared CHARACTER(*) and cannot " + gfc_error ("Function %qs is declared CHARACTER(*) and cannot " "be used at %L since it is not a dummy argument", sym->name, &expr->where); return false; } @@ -2932,11 +2932,11 @@ resolve_function (gfc_expr *expr) if (omp_workshare_flag && expr->value.function.esym && ! gfc_elemental (expr->value.function.esym)) { - gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed " + gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed " "in WORKSHARE construct", expr->value.function.esym->name, &expr->where); t = false; } @@ -2986,25 +2986,25 @@ resolve_function (gfc_expr *expr) if (!pure_function (expr, &name) && name) { if (forall_flag) { - gfc_error ("Reference to non-PURE function '%s' at %L inside a " + gfc_error ("Reference to non-PURE function %qs at %L inside a " "FORALL %s", name, &expr->where, forall_flag == 2 ? "mask" : "block"); t = false; } else if (gfc_do_concurrent_flag) { - gfc_error ("Reference to non-PURE function '%s' at %L inside a " + gfc_error ("Reference to non-PURE function %qs at %L inside a " "DO CONCURRENT %s", name, &expr->where, gfc_do_concurrent_flag == 2 ? "mask" : "block"); t = false; } else if (gfc_pure (NULL)) { - gfc_error ("Function reference to '%s' at %L is to a non-PURE " + gfc_error ("Function reference to %qs at %L is to a non-PURE " "procedure within a PURE procedure", name, &expr->where); t = false; } gfc_unset_implicit_pure (NULL); @@ -3018,15 +3018,15 @@ resolve_function (gfc_expr *expr) esym = expr->value.function.esym; if (is_illegal_recursion (esym, gfc_current_ns)) { if (esym->attr.entry && esym->ns->entries) - gfc_error ("ENTRY '%s' at %L cannot be called recursively, as" - " function '%s' is not RECURSIVE", + gfc_error ("ENTRY %qs at %L cannot be called recursively, as" + " function %qs is not RECURSIVE", esym->name, &expr->where, esym->ns->entries->sym->name); else - gfc_error ("Function '%s' at %L cannot be called recursively, as it" + gfc_error ("Function %qs at %L cannot be called recursively, as it" " is not RECURSIVE", esym->name, &expr->where); t = false; } } @@ -3061,17 +3061,17 @@ pure_subroutine (gfc_code *c, gfc_symbol { if (gfc_pure (sym)) return; if (forall_flag) - gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE", + gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE", sym->name, &c->loc); else if (gfc_do_concurrent_flag) - gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not " + gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not " "PURE", sym->name, &c->loc); else if (gfc_pure (NULL)) - gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name, + gfc_error ("Subroutine call to %qs at %L is not PURE", sym->name, &c->loc); gfc_unset_implicit_pure (NULL); } @@ -3132,20 +3132,20 @@ generic: that possesses a matching interface. 14.1.2.4 */ sym = c->symtree->n.sym; if (!gfc_is_intrinsic (sym, 1, c->loc)) { - gfc_error ("There is no specific subroutine for the generic '%s' at %L", + gfc_error ("There is no specific subroutine for the generic %qs at %L", sym->name, &c->loc); return false; } m = gfc_intrinsic_sub_interface (c, 0); if (m == MATCH_YES) return true; if (m == MATCH_NO) - gfc_error ("Generic subroutine '%s' at %L is not consistent with an " + gfc_error ("Generic subroutine %qs at %L is not consistent with an " "intrinsic subroutine interface", sym->name, &c->loc); return false; } @@ -3176,11 +3176,11 @@ resolve_specific_s0 (gfc_code *c, gfc_sy { m = gfc_intrinsic_sub_interface (c, 1); if (m == MATCH_YES) return MATCH_YES; if (m == MATCH_NO) - gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible " + gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible " "with an intrinsic", sym->name, &c->loc); return MATCH_ERROR; } @@ -3220,11 +3220,11 @@ resolve_specific_s (gfc_code *c) if (sym == NULL) break; } sym = c->symtree->n.sym; - gfc_error ("Unable to resolve the specific subroutine '%s' at %L", + gfc_error ("Unable to resolve the specific subroutine %qs at %L", sym->name, &c->loc); return false; } @@ -3280,11 +3280,11 @@ resolve_call (gfc_code *c) csym = c->symtree ? c->symtree->n.sym : NULL; if (csym && csym->ts.type != BT_UNKNOWN) { - gfc_error ("'%s' at %L has a type, which is not consistent with " + gfc_error_1 ("'%s' at %L has a type, which is not consistent with " "the CALL at %L", csym->name, &csym->declared_at, &c->loc); return false; } if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns) @@ -3309,25 +3309,25 @@ resolve_call (gfc_code *c) /* If this ia a deferred TBP, c->expr1 will be set. */ if (!c->expr1 && csym) { if (csym->attr.abstract) { - gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L", + gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L", csym->name, &c->loc); return false; } /* Subroutines without the RECURSIVE attribution are not allowed to call themselves. */ if (is_illegal_recursion (csym, gfc_current_ns)) { if (csym->attr.entry && csym->ns->entries) - gfc_error ("ENTRY '%s' at %L cannot be called recursively, " - "as subroutine '%s' is not RECURSIVE", + gfc_error ("ENTRY %qs at %L cannot be called recursively, " + "as subroutine %qs is not RECURSIVE", csym->name, &c->loc, csym->ns->entries->sym->name); else - gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, " + gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, " "as it is not RECURSIVE", csym->name, &c->loc); t = false; } } @@ -3400,11 +3400,11 @@ compare_shapes (gfc_expr *op1, gfc_expr { for (i = 0; i < op1->rank; i++) { if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0) { - gfc_error ("Shapes for operands at %L and %L are not conformable", + gfc_error_1 ("Shapes for operands at %L and %L are not conformable", &op1->where, &op2->where); t = false; break; } } @@ -6674,11 +6674,11 @@ conformable_arrays (gfc_expr *e1, gfc_ex mpz_set (s, tail->u.ar.start[i]->value.integer); } if (mpz_cmp (e1->shape[i], s) != 0) { - gfc_error ("Source-expr at %L and allocate-object at %L must " + gfc_error_1 ("Source-expr at %L and allocate-object at %L must " "have the same shape", &e1->where, &e2->where); mpz_clear (s); return false; } } @@ -6832,23 +6832,23 @@ resolve_allocate_expr (gfc_expr *e, gfc_ if (code->expr3) { /* Check F03:C631. */ if (!gfc_type_compatible (&e->ts, &code->expr3->ts)) { - gfc_error ("Type of entity at %L is type incompatible with " - "source-expr at %L", &e->where, &code->expr3->where); + gfc_error_1 ("Type of entity at %L is type incompatible with " + "source-expr at %L", &e->where, &code->expr3->where); goto failure; } /* Check F03:C632 and restriction following Note 6.18. */ if (code->expr3->rank > 0 && !conformable_arrays (code->expr3, e)) goto failure; /* Check F03:C633. */ if (code->expr3->ts.kind != e->ts.kind && !unlimited) { - gfc_error ("The allocate-object at %L and the source-expr at %L " + gfc_error_1 ("The allocate-object at %L and the source-expr at %L " "shall have the same kind type parameter", &e->where, &code->expr3->where); goto failure; } @@ -6858,11 +6858,11 @@ resolve_allocate_expr (gfc_expr *e, gfc_ || (code->expr3->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV && code->expr3->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE))) { - gfc_error ("The source-expr at %L shall neither be of type " + gfc_error_1 ("The source-expr at %L shall neither be of type " "LOCK_TYPE nor have a LOCK_TYPE component if " "allocate-object at %L is a coarray", &code->expr3->where, &e->where); goto failure; } @@ -7202,24 +7202,24 @@ resolve_allocate_deallocate (gfc_code *c c) One of them stops, which is also an error. */ while (1) { if (pr == NULL && qr == NULL) { - gfc_error ("Allocate-object at %L also appears at %L", - &pe->where, &qe->where); + gfc_error_1 ("Allocate-object at %L also appears at %L", + &pe->where, &qe->where); break; } else if (pr != NULL && qr == NULL) { - gfc_error ("Allocate-object at %L is subobject of" - " object at %L", &pe->where, &qe->where); + gfc_error_1 ("Allocate-object at %L is subobject of" + " object at %L", &pe->where, &qe->where); break; } else if (pr == NULL && qr != NULL) { - gfc_error ("Allocate-object at %L is subobject of" - " object at %L", &qe->where, &pe->where); + gfc_error_1 ("Allocate-object at %L is subobject of" + " object at %L", &qe->where, &pe->where); break; } /* Here, pr != NULL && qr != NULL */ gcc_assert(pr->type == qr->type); if (pr->type == REF_ARRAY) @@ -7418,11 +7418,11 @@ check_case_overlap (gfc_case *list) { /* The cases overlap, or they are the same element in the list. Either way, we must issue an error and get the next case from P. */ /* FIXME: Sort P and Q by line number. */ - gfc_error ("CASE label at %L overlaps with CASE " + gfc_error_1 ("CASE label at %L overlaps with CASE " "label at %L", &p->where, &q->where); overlap_seen = 1; e = p; p = p->right; psize--; @@ -7656,11 +7656,11 @@ resolve_select (gfc_code *code, bool sel /* Intercept the DEFAULT case. */ if (cp->low == NULL && cp->high == NULL) { if (default_case != NULL) { - gfc_error ("The DEFAULT CASE at %L cannot be followed " + gfc_error_1 ("The DEFAULT CASE at %L cannot be followed " "by a second DEFAULT CASE at %L", &default_case->where, &cp->where); t = false; break; } @@ -8026,11 +8026,11 @@ resolve_select_type (gfc_code *code, gfc if (c->ts.type == BT_UNKNOWN) { /* Check F03:C818. */ if (default_case) { - gfc_error ("The DEFAULT CASE at %L cannot be followed " + gfc_error_1 ("The DEFAULT CASE at %L cannot be followed " "by a second DEFAULT CASE at %L", &default_case->ext.block.case_list->where, &c->where); error++; continue; } @@ -8584,11 +8584,11 @@ resolve_branch (gfc_st_label *label, gfc return; } if (label->defined != ST_LABEL_TARGET && label->defined != ST_LABEL_DO_TARGET) { - gfc_error ("Statement at %L is not a valid branch target statement " + gfc_error_1 ("Statement at %L is not a valid branch target statement " "for the branch statement at %L", &label->where, &code->loc); return; } /* Step two: make sure this branch is not a branch to itself ;-) */ @@ -8610,15 +8610,15 @@ resolve_branch (gfc_st_label *label, gfc which is invalid. */ for (stack = cs_base; stack; stack = stack->prev) { if (stack->current->op == EXEC_CRITICAL && bitmap_bit_p (stack->reachable_labels, label->value)) - gfc_error ("GOTO statement at %L leaves CRITICAL construct for " + gfc_error_1 ("GOTO statement at %L leaves CRITICAL construct for " "label at %L", &code->loc, &label->where); else if (stack->current->op == EXEC_DO_CONCURRENT && bitmap_bit_p (stack->reachable_labels, label->value)) - gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct " + gfc_error_1 ("GOTO statement at %L leaves DO CONCURRENT construct " "for label at %L", &code->loc, &label->where); } return; } @@ -8633,17 +8633,17 @@ resolve_branch (gfc_st_label *label, gfc break; if (stack->current->op == EXEC_CRITICAL) { /* Note: A label at END CRITICAL does not leave the CRITICAL construct as END CRITICAL is still part of it. */ - gfc_error ("GOTO statement at %L leaves CRITICAL construct for label" + gfc_error_1 ("GOTO statement at %L leaves CRITICAL construct for label" " at %L", &code->loc, &label->where); return; } else if (stack->current->op == EXEC_DO_CONCURRENT) { - gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for " + gfc_error_1 ("GOTO statement at %L leaves DO CONCURRENT construct for " "label at %L", &code->loc, &label->where); return; } } @@ -9999,11 +9999,11 @@ gfc_resolve_code (gfc_code *code, gfc_na { if (code->expr1->ts.type != BT_INTEGER) gfc_error ("ASSIGNED GOTO statement at %L requires an " "INTEGER variable", &code->expr1->where); else if (code->expr1->symtree->n.sym->attr.assign != 1) - gfc_error ("Variable '%s' has not been assigned a target " + gfc_error ("Variable %qs has not been assigned a target " "label at %L", code->expr1->symtree->n.sym->name, &code->expr1->where); } else resolve_branch (code->label1, code); @@ -10384,11 +10384,11 @@ gfc_verify_binding_labels (gfc_symbol *s return; } if (sym->attr.flavor == FL_VARIABLE && gsym->type != GSYM_UNKNOWN) { - gfc_error ("Variable %s with binding label %s at %L uses the same global " + gfc_error_1 ("Variable %s with binding label %s at %L uses the same global " "identifier as entity at %L", sym->name, sym->binding_label, &sym->declared_at, &gsym->where); /* Clear the binding label to prevent checking multiple times. */ sym->binding_label = NULL; @@ -10397,12 +10397,12 @@ gfc_verify_binding_labels (gfc_symbol *s && (strcmp (module, gsym->mod_name) != 0 || strcmp (sym->name, gsym->sym_name) != 0)) { /* This can only happen if the variable is defined in a module - if it isn't the same module, reject it. */ - gfc_error ("Variable %s from module %s with binding label %s at %L uses " - "the same global identifier as entity at %L from module %s", + gfc_error_1 ("Variable %s from module %s with binding label %s at %L uses " + "the same global identifier as entity at %L from module %s", sym->name, module, sym->binding_label, &sym->declared_at, &gsym->where, gsym->mod_name); sym->binding_label = NULL; } else if ((sym->attr.function || sym->attr.subroutine) @@ -10414,11 +10414,11 @@ gfc_verify_binding_labels (gfc_symbol *s || (module && strcmp (module, gsym->mod_name) != 0))) { /* Print an error if the procedure is defined multiple times; we have to exclude references to the same procedure via module association or multiple checks for the same procedure. */ - gfc_error ("Procedure %s with binding label %s at %L uses the same " + gfc_error_1 ("Procedure %s with binding label %s at %L uses the same " "global identifier as entity at %L", sym->name, sym->binding_label, &sym->declared_at, &gsym->where); sym->binding_label = NULL; } } @@ -10914,11 +10914,11 @@ resolve_fl_variable_derived (gfc_symbol gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s); if (s && s->attr.generic) s = gfc_find_dt_in_generic (s); if (s && s->attr.flavor != FL_DERIVED) { - gfc_error ("The type '%s' cannot be host associated at %L " + gfc_error_1 ("The type '%s' cannot be host associated at %L " "because it is blocked by an incompatible object " "of the same name declared at %L", sym->ts.u.derived->name, &sym->declared_at, &s->declared_at); return false; @@ -12333,39 +12333,39 @@ resolve_fl_derived0 (gfc_symbol *sym) /* F2008, C442. */ if ((!sym->attr.is_class || c != sym->components) && c->attr.codimension && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED))) { - gfc_error ("Coarray component '%s' at %L must be allocatable with " + gfc_error ("Coarray component %qs at %L must be allocatable with " "deferred shape", c->name, &c->loc); return false; } /* F2008, C443. */ if (c->attr.codimension && c->ts.type == BT_DERIVED && c->ts.u.derived->ts.is_iso_c) { - gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) " + gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) " "shall not be a coarray", c->name, &c->loc); return false; } /* F2008, C444. */ if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp && (c->attr.codimension || c->attr.pointer || c->attr.dimension || c->attr.allocatable)) { - gfc_error ("Component '%s' at %L with coarray component " + gfc_error ("Component %qs at %L with coarray component " "shall be a nonpointer, nonallocatable scalar", c->name, &c->loc); return false; } /* F2008, C448. */ if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer)) { - gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but " + gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but " "is not an array pointer", c->name, &c->loc); return false; } if (c->attr.proc_pointer && c->ts.interface) @@ -12454,12 +12454,12 @@ resolve_fl_derived0 (gfc_symbol *sym) c->tb->pass_arg_num++; } if (!me_arg) { - gfc_error ("Procedure pointer component '%s' with PASS(%s) " - "at %L has no argument '%s'", c->name, + gfc_error ("Procedure pointer component %qs with PASS(%s) " + "at %L has no argument %qs", c->name, c->tb->pass_arg, &c->loc, c->tb->pass_arg); c->tb->error = 1; return false; } } @@ -12468,11 +12468,11 @@ resolve_fl_derived0 (gfc_symbol *sym) /* Otherwise, take the first one; there should in fact be at least one. */ c->tb->pass_arg_num = 1; if (!c->ts.interface->formal) { - gfc_error ("Procedure pointer component '%s' with PASS at %L " + gfc_error ("Procedure pointer component %qs with PASS at %L " "must have at least one argument", c->name, &c->loc); c->tb->error = 1; return false; } @@ -12484,47 +12484,47 @@ resolve_fl_derived0 (gfc_symbol *sym) if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS) || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym) || (me_arg->ts.type == BT_CLASS && CLASS_DATA (me_arg)->ts.u.derived != sym)) { - gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of" - " the derived type '%s'", me_arg->name, c->name, + gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of" + " the derived type %qs", me_arg->name, c->name, me_arg->name, &c->loc, sym->name); c->tb->error = 1; return false; } /* Check for C453. */ if (me_arg->attr.dimension) { - gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L " + gfc_error ("Argument %qs of %qs with PASS(%s) at %L " "must be scalar", me_arg->name, c->name, me_arg->name, &c->loc); c->tb->error = 1; return false; } if (me_arg->attr.pointer) { - gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L " + gfc_error ("Argument %qs of %qs with PASS(%s) at %L " "may not have the POINTER attribute", me_arg->name, c->name, me_arg->name, &c->loc); c->tb->error = 1; return false; } if (me_arg->attr.allocatable) { - gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L " + gfc_error ("Argument %qs of %qs with PASS(%s) at %L " "may not be ALLOCATABLE", me_arg->name, c->name, me_arg->name, &c->loc); c->tb->error = 1; return false; } if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS) - gfc_error ("Non-polymorphic passed-object dummy argument of '%s'" + gfc_error ("Non-polymorphic passed-object dummy argument of %qs" " at %L", c->name, &c->loc); } /* Check type-spec if this is not the parent-type component. */ @@ -12549,11 +12549,11 @@ resolve_fl_derived0 (gfc_symbol *sym) /* If this type is an extension, see if this component has the same name as an inherited type-bound procedure. */ if (super_type && !sym->attr.is_class && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL)) { - gfc_error ("Component '%s' of '%s' at %L has the same name as an" + gfc_error ("Component %qs of %qs at %L has the same name as an" " inherited type-bound procedure", c->name, sym->name, &c->loc); return false; } @@ -12562,22 +12562,22 @@ resolve_fl_derived0 (gfc_symbol *sym) { if (c->ts.u.cl->length == NULL || (!resolve_charlen(c->ts.u.cl)) || !gfc_is_constant_expr (c->ts.u.cl->length)) { - gfc_error ("Character length of component '%s' needs to " + gfc_error ("Character length of component %qs needs to " "be a constant specification expression at %L", c->name, c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc); return false; } } if (c->ts.type == BT_CHARACTER && c->ts.deferred && !c->attr.pointer && !c->attr.allocatable) { - gfc_error ("Character component '%s' of '%s' at %L with deferred " + gfc_error ("Character component %qs of %qs at %L with deferred " "length must be a POINTER or ALLOCATABLE", c->name, sym->name, &c->loc); return false; } @@ -12639,11 +12639,11 @@ resolve_fl_derived0 (gfc_symbol *sym) if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype && c->attr.pointer && c->ts.u.derived->components == NULL && !c->ts.u.derived->attr.zero_comp) { - gfc_error ("The pointer component '%s' of '%s' at %L is a type " + gfc_error ("The pointer component %qs of %qs at %L is a type " "that has not been declared", c->name, sym->name, &c->loc); return false; } @@ -12651,11 +12651,11 @@ resolve_fl_derived0 (gfc_symbol *sym) && CLASS_DATA (c)->attr.class_pointer && CLASS_DATA (c)->ts.u.derived->components == NULL && !CLASS_DATA (c)->ts.u.derived->attr.zero_comp && !UNLIMITED_POLY (c)) { - gfc_error ("The pointer component '%s' of '%s' at %L is a type " + gfc_error ("The pointer component %qs of %qs at %L is a type " "that has not been declared", c->name, sym->name, &c->loc); return false; } @@ -12663,11 +12663,11 @@ resolve_fl_derived0 (gfc_symbol *sym) if (c->ts.type == BT_CLASS && c->attr.flavor != FL_PROCEDURE && (!c->attr.class_ok || !(CLASS_DATA (c)->attr.class_pointer || CLASS_DATA (c)->attr.allocatable))) { - gfc_error ("Component '%s' with CLASS at %L must be allocatable " + gfc_error ("Component %qs with CLASS at %L must be allocatable " "or pointer", c->name, &c->loc); /* Prevent a recurrence of the error. */ c->ts.type = BT_UNKNOWN; return false; } @@ -13315,11 +13315,11 @@ resolve_symbol (gfc_symbol *sym) /* First, make sure the variable is declared at the module-level scope (J3/04-007, Section 15.3). */ if (sym->ns->proc_name->attr.flavor != FL_MODULE && sym->attr.in_common == 0) { - gfc_error ("Variable '%s' at %L cannot be BIND(C) because it " + gfc_error ("Variable %qs at %L cannot be BIND(C) because it " "is neither a COMMON block nor declared at the " "module level scope", sym->name, &(sym->declared_at)); t = false; } else if (sym->common_head != NULL) Index: gcc/fortran/match.c =================================================================== --- gcc/fortran/match.c (revision 218457) +++ gcc/fortran/match.c (working copy) @@ -3546,11 +3546,11 @@ alloc_opt_list: } /* The next 2 conditionals check C631. */ if (ts.type != BT_UNKNOWN) { - gfc_error ("SOURCE tag at %L conflicts with the typespec at %L", + gfc_error_1 ("SOURCE tag at %L conflicts with the typespec at %L", &tmp->where, &old_locus); goto cleanup; } if (head->next @@ -3583,11 +3583,11 @@ alloc_opt_list: } /* Check F08:C637. */ if (ts.type != BT_UNKNOWN) { - gfc_error ("MOLD tag at %L conflicts with the typespec at %L", + gfc_error_1 ("MOLD tag at %L conflicts with the typespec at %L", &tmp->where, &old_locus); goto cleanup; } mold = tmp; @@ -3609,11 +3609,11 @@ alloc_opt_list: goto syntax; /* Check F08:C637. */ if (source && mold) { - gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L", + gfc_error_1 ("MOLD tag at %L conflicts with SOURCE tag at %L", &mold->where, &source->where); goto cleanup; } /* Check F03:C623, */ @@ -4313,11 +4313,11 @@ gfc_match_common (void) t->name); } if (sym->attr.in_common) { - gfc_error ("Symbol '%s' at %C is already in a COMMON block", + gfc_error ("Symbol %qs at %C is already in a COMMON block", sym->name); goto cleanup; } if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL) @@ -4836,20 +4836,22 @@ recursive_stmt_fcn (gfc_expr *e, gfc_sym MATCH_NO that we suppress error message in most cases. */ match gfc_match_st_function (void) { - gfc_error_buf old_error; + gfc_error_buf old_error_1; + output_buffer old_error; + gfc_symbol *sym; gfc_expr *expr; match m; m = gfc_match_symbol (&sym, 0); if (m != MATCH_YES) return m; - gfc_push_error (&old_error); + gfc_push_error (&old_error, &old_error_1); if (!gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, sym->name, NULL)) goto undo_error; if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES) @@ -4857,11 +4859,12 @@ gfc_match_st_function (void) m = gfc_match (" = %e%t", &expr); if (m == MATCH_NO) goto undo_error; - gfc_free_error (&old_error); + gfc_free_error (&old_error, &old_error_1); + if (m == MATCH_ERROR) return m; if (recursive_stmt_fcn (expr, sym)) { @@ -4875,11 +4878,11 @@ gfc_match_st_function (void) return MATCH_ERROR; return MATCH_YES; undo_error: - gfc_pop_error (&old_error); + gfc_pop_error (&old_error, &old_error_1); return MATCH_NO; } /***************** SELECT CASE subroutines ******************/ Index: gcc/fortran/arith.c =================================================================== --- gcc/fortran/arith.c (revision 218457) +++ gcc/fortran/arith.c (working copy) @@ -1913,21 +1913,21 @@ arith_error (arith rc, gfc_typespec *fro gfc_error ("Arithmetic OK converting %s to %s at %L", gfc_typename (from), gfc_typename (to), where); break; case ARITH_OVERFLOW: gfc_error ("Arithmetic overflow converting %s to %s at %L. This check " - "can be disabled with the option -fno-range-check", + "can be disabled with the option %<-fno-range-check%>", gfc_typename (from), gfc_typename (to), where); break; case ARITH_UNDERFLOW: gfc_error ("Arithmetic underflow converting %s to %s at %L. This check " - "can be disabled with the option -fno-range-check", + "can be disabled with the option %<-fno-range-check%>", gfc_typename (from), gfc_typename (to), where); break; case ARITH_NAN: gfc_error ("Arithmetic NaN converting %s to %s at %L. This check " - "can be disabled with the option -fno-range-check", + "can be disabled with the option %<-fno-range-check%>", gfc_typename (from), gfc_typename (to), where); break; case ARITH_DIV0: gfc_error ("Division by zero converting %s to %s at %L", gfc_typename (from), gfc_typename (to), where); Index: gcc/fortran/parse.c =================================================================== --- gcc/fortran/parse.c (revision 218457) +++ gcc/fortran/parse.c (working copy) @@ -105,17 +105,18 @@ match_word_omp_simd (const char *str, ma /* Load symbols from all USE statements encountered in this scoping unit. */ static void use_modules (void) { - gfc_error_buf old_error; + gfc_error_buf old_error_1; + output_buffer old_error; - gfc_push_error (&old_error); + gfc_push_error (&old_error, &old_error_1); gfc_buffer_error (false); gfc_use_modules (); gfc_buffer_error (true); - gfc_pop_error (&old_error); + gfc_pop_error (&old_error, &old_error_1); gfc_commit_symbols (); gfc_warning_check (); gfc_current_ns->old_cl_list = gfc_current_ns->cl_list; gfc_current_ns->old_equiv = gfc_current_ns->equiv; last_was_use_stmt = false; @@ -2200,11 +2201,11 @@ verify_st_order (st_state *p, gfc_statem p->last_statement = st; return true; order: if (!silent) - gfc_error ("%s statement at %C cannot follow %s statement at %L", + gfc_error_1 ("%s statement at %C cannot follow %s statement at %L", gfc_ascii_statement (st), gfc_ascii_statement (p->last_statement), &p->where); return false; } @@ -2577,11 +2578,11 @@ endType: "be a subcomponent of a coarray. (Variables of type %s may " "not have a codimension as already a coarray " "subcomponent exists)", c->name, &c->loc, sym->name); if (sym->attr.lock_comp && coarray && !lock_type) - gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with " + gfc_error_1 ("Noncoarray component %s at %L of type LOCK_TYPE or with " "subcomponent of type LOCK_TYPE must have a codimension or " "be a subcomponent of a coarray. (Variables of type %s may " "not have a codimension as %s at %L has a codimension or a " "coarray subcomponent)", lock_comp->name, &lock_comp->loc, sym->name, c->name, &c->loc); @@ -3279,11 +3280,11 @@ parse_if_block (void) unexpected_eof (); case ST_ELSEIF: if (seen_else) { - gfc_error ("ELSE IF statement at %C cannot follow ELSE " + gfc_error_1 ("ELSE IF statement at %C cannot follow ELSE " "statement at %L", &else_locus); reject_statement (); break; } @@ -4672,14 +4673,14 @@ gfc_global_used (gfc_gsymbol *sym, locus gfc_internal_error ("gfc_global_used(): Bad type"); name = NULL; } if (sym->binding_label) - gfc_error ("Global binding name '%s' at %L is already being used as a %s " + gfc_error_1 ("Global binding name '%s' at %L is already being used as a %s " "at %L", sym->binding_label, where, name, &sym->where); else - gfc_error ("Global name '%s' at %L is already being used as a %s at %L", + gfc_error_1 ("Global name '%s' at %L is already being used as a %s at %L", sym->name, where, name, &sym->where); } /* Parse a block data program unit. */ Index: gcc/fortran/check.c =================================================================== --- gcc/fortran/check.c (revision 218457) +++ gcc/fortran/check.c (working copy) @@ -41,11 +41,11 @@ static bool scalar_check (gfc_expr *e, int n) { if (e->rank == 0) return true; - gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar", + gfc_error ("%qs argument of %qs intrinsic at %L must be a scalar", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); return false; } @@ -57,11 +57,11 @@ static bool type_check (gfc_expr *e, int n, bt type) { if (e->ts.type == type) return true; - gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s", + gfc_error ("%qs argument of %qs intrinsic at %L must be %s", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where, gfc_basic_typename (type)); return false; } @@ -84,11 +84,11 @@ numeric_check (gfc_expr *e, int n) { e->ts = e->symtree->n.sym->ts; return true; } - gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type", + gfc_error ("%qs argument of %qs intrinsic at %L must be a numeric type", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); return false; } @@ -99,11 +99,11 @@ numeric_check (gfc_expr *e, int n) static bool int_or_real_check (gfc_expr *e, int n) { if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER " + gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER " "or REAL", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); return false; } @@ -116,11 +116,11 @@ int_or_real_check (gfc_expr *e, int n) static bool real_or_complex_check (gfc_expr *e, int n) { if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be REAL " + gfc_error ("%qs argument of %qs intrinsic at %L must be REAL " "or COMPLEX", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); return false; } @@ -133,11 +133,11 @@ real_or_complex_check (gfc_expr *e, int static bool int_or_proc_check (gfc_expr *e, int n) { if (e->ts.type != BT_INTEGER && e->ts.type != BT_PROCEDURE) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER " + gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER " "or PROCEDURE", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); return false; } @@ -162,11 +162,11 @@ kind_check (gfc_expr *k, int n, bt type) if (!scalar_check (k, n)) return false; if (!gfc_check_init_expr (k)) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant", + gfc_error ("%qs argument of %qs intrinsic at %L must be a constant", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &k->where); return false; } @@ -190,11 +190,11 @@ double_check (gfc_expr *d, int n) if (!type_check (d, n, BT_REAL)) return false; if (d->ts.kind != gfc_default_double_kind) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be double " + gfc_error ("%qs argument of %qs intrinsic at %L must be double " "precision", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &d->where); return false; } @@ -213,11 +213,11 @@ coarray_check (gfc_expr *e, int n) return true; } if (!gfc_is_coarray (e)) { - gfc_error ("Expected coarray variable as '%s' argument to the %s " + gfc_error ("Expected coarray variable as %qs argument to the %s " "intrinsic at %L", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); return false; } @@ -230,11 +230,11 @@ coarray_check (gfc_expr *e, int n) static bool logical_array_check (gfc_expr *array, int n) { if (array->ts.type != BT_LOGICAL || array->rank == 0) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be a logical " + gfc_error ("%qs argument of %qs intrinsic at %L must be a logical " "array", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &array->where); return false; } @@ -256,11 +256,11 @@ array_check (gfc_expr *e, int n) } if (e->rank != 0 && e->ts.type != BT_PROCEDURE) return true; - gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array", + gfc_error ("%qs argument of %qs intrinsic at %L must be an array", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); return false; } @@ -277,11 +277,11 @@ nonnegative_check (const char *arg, gfc_ if (expr->expr_type == EXPR_CONSTANT) { gfc_extract_int (expr, &i); if (i < 0) { - gfc_error ("'%s' at %L must be nonnegative", arg, &expr->where); + gfc_error ("%qs at %L must be nonnegative", arg, &expr->where); return false; } } return true; @@ -309,31 +309,31 @@ less_than_bitsize1 (const char *arg1, gf i2 = -i2; if (i2 > gfc_integer_kinds[i3].bit_size) { gfc_error ("The absolute value of SHIFT at %L must be less " - "than or equal to BIT_SIZE('%s')", + "than or equal to BIT_SIZE(%qs)", &expr2->where, arg1); return false; } } if (or_equal) { if (i2 > gfc_integer_kinds[i3].bit_size) { - gfc_error ("'%s' at %L must be less than " - "or equal to BIT_SIZE('%s')", + gfc_error ("%qs at %L must be less than " + "or equal to BIT_SIZE(%qs)", arg2, &expr2->where, arg1); return false; } } else { if (i2 >= gfc_integer_kinds[i3].bit_size) { - gfc_error ("'%s' at %L must be less than BIT_SIZE('%s')", + gfc_error ("%qs at %L must be less than BIT_SIZE(%qs)", arg2, &expr2->where, arg1); return false; } } } @@ -356,11 +356,11 @@ less_than_bitsizekind (const char *arg, i = gfc_validate_kind (BT_INTEGER, k, false); gfc_extract_int (expr, &val); if (val > gfc_integer_kinds[i].bit_size) { - gfc_error ("'%s' at %L must be less than or equal to the BIT_SIZE of " + gfc_error ("%qs at %L must be less than or equal to the BIT_SIZE of " "INTEGER(KIND=%d)", arg, &expr->where, k); return false; } return true; @@ -383,11 +383,11 @@ less_than_bitsize2 (const char *arg1, gf i2 += i3; i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false); if (i2 > gfc_integer_kinds[i3].bit_size) { gfc_error ("'%s + %s' at %L must be less than or equal " - "to BIT_SIZE('%s')", + "to BIT_SIZE(%qs)", arg2, arg3, &expr2->where, arg1); return false; } } @@ -400,12 +400,12 @@ static bool same_type_check (gfc_expr *e, int n, gfc_expr *f, int m) { if (gfc_compare_types (&e->ts, &f->ts)) return true; - gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type " - "and kind as '%s'", gfc_current_intrinsic_arg[m]->name, + gfc_error ("%qs argument of %qs intrinsic at %L must be the same type " + "and kind as %qs", gfc_current_intrinsic_arg[m]->name, gfc_current_intrinsic, &f->where, gfc_current_intrinsic_arg[n]->name); return false; } @@ -417,11 +417,11 @@ static bool rank_check (gfc_expr *e, int n, int rank) { if (e->rank == rank) return true; - gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d", + gfc_error ("%qs argument of %qs intrinsic at %L must be of rank %d", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where, rank); return false; } @@ -432,11 +432,11 @@ rank_check (gfc_expr *e, int n, int rank static bool nonoptional_check (gfc_expr *e, int n) { if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL", + gfc_error ("%qs argument of %qs intrinsic at %L must not be OPTIONAL", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); } /* TODO: Recursive check on nonoptional variables? */ @@ -453,11 +453,11 @@ allocatable_check (gfc_expr *e, int n) symbol_attribute attr; attr = gfc_variable_attr (e, NULL); if (!attr.allocatable || attr.associate_var) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE", + gfc_error ("%qs argument of %qs intrinsic at %L must be ALLOCATABLE", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); return false; } @@ -471,11 +471,11 @@ static bool kind_value_check (gfc_expr *e, int n, int k) { if (e->ts.kind == k) return true; - gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d", + gfc_error ("%qs argument of %qs intrinsic at %L must be of kind %d", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where, k); return false; } @@ -509,11 +509,11 @@ variable_check (gfc_expr *e, int n, bool break; } if (!ref) { - gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be " + gfc_error ("%qs argument of %qs intrinsic at %L cannot be " "INTENT(IN)", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); return false; } } @@ -530,11 +530,11 @@ variable_check (gfc_expr *e, int n, bool for (ns = gfc_current_ns; ns; ns = ns->parent) if (ns->proc_name == e->symtree->n.sym) return true; } - gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable", + gfc_error ("%qs argument of %qs intrinsic at %L must be a variable", gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); return false; } @@ -579,11 +579,11 @@ dim_corank_check (gfc_expr *dim, gfc_exp corank = gfc_get_corank (array); if (mpz_cmp_ui (dim->value.integer, 1) < 0 || mpz_cmp_ui (dim->value.integer, corank) > 0) { - gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid " + gfc_error ("'dim' argument of %qs intrinsic at %L is not a valid " "codimension index", gfc_current_intrinsic, &dim->where); return false; } @@ -629,11 +629,11 @@ dim_rank_check (gfc_expr *dim, gfc_expr } if (mpz_cmp_ui (dim->value.integer, 1) < 0 || mpz_cmp_ui (dim->value.integer, rank) > 0) { - gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid " + gfc_error ("'dim' argument of %qs intrinsic at %L is not a valid " "dimension index", gfc_current_intrinsic, &dim->where); return false; } @@ -854,11 +854,11 @@ gfc_check_a_p (gfc_expr *a, gfc_expr *p) if (!int_or_real_check (a, 0)) return false; if (a->ts.type != p->ts.type) { - gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must " + gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must " "have the same type", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &p->where); return false; } @@ -899,20 +899,20 @@ gfc_check_associated (gfc_expr *pointer, attr1 = gfc_expr_attr (pointer); if (!attr1.pointer && !attr1.proc_pointer) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER", + gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &pointer->where); return false; } /* F2008, C1242. */ if (attr1.pointer && gfc_is_coindexed (pointer)) { - gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be " + gfc_error ("%qs argument of %qs intrinsic at %L shall not be " "coindexed", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &pointer->where); return false; } @@ -926,29 +926,29 @@ gfc_check_associated (gfc_expr *pointer, if (target->expr_type == EXPR_VARIABLE || target->expr_type == EXPR_FUNCTION) attr2 = gfc_expr_attr (target); else { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer " + gfc_error ("%qs argument of %qs intrinsic at %L must be a pointer " "or target VARIABLE or FUNCTION", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &target->where); return false; } if (attr1.pointer && !attr2.pointer && !attr2.target) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER " + gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER " "or a TARGET", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &target->where); return false; } /* F2008, C1242. */ if (attr1.pointer && gfc_is_coindexed (target)) { - gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be " + gfc_error ("%qs argument of %qs intrinsic at %L shall not be " "coindexed", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &target->where); return false; } @@ -972,11 +972,11 @@ gfc_check_associated (gfc_expr *pointer, return t; null_arg: gfc_error ("NULL pointer at %L is not permitted as actual argument " - "of '%s' intrinsic function", where, gfc_current_intrinsic); + "of %qs intrinsic function", where, gfc_current_intrinsic); return false; } @@ -1029,11 +1029,11 @@ gfc_check_atomic (gfc_expr *atom, int at return false; } if (atom->ts.type != value->ts.type) { - gfc_error ("'%s' argument of '%s' intrinsic at %L shall have the same " + gfc_error_1 ("'%s' argument of '%s' intrinsic at %L shall have the same " "type as '%s' at %L", gfc_current_intrinsic_arg[val_no]->name, gfc_current_intrinsic, &value->where, gfc_current_intrinsic_arg[atom_no]->name, &atom->where); return false; } @@ -1375,20 +1375,20 @@ gfc_check_cmplx (gfc_expr *x, gfc_expr * if (!numeric_check (y, 1)) return false; if (x->ts.type == BT_COMPLEX) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must not be " + gfc_error ("%qs argument of %qs intrinsic at %L must not be " "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &y->where); return false; } if (y->ts.type == BT_COMPLEX) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type " + gfc_error ("%qs argument of %qs intrinsic at %L must have a type " "of either REAL or INTEGER", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &y->where); return false; } @@ -1573,11 +1573,11 @@ gfc_check_co_reduce (gfc_expr *a, gfc_ex if (sym->result->ts.type == BT_UNKNOWN) gfc_set_default_type (sym->result, 0, NULL); if (!gfc_compare_types (&a->ts, &sym->result->ts)) { - gfc_error ("A argument at %L has type %s but the function passed as " + gfc_error_1 ("A argument at %L has type %s but the function passed as " "OPERATOR at %L returns %s", &a->where, gfc_typename (&a->ts), &op->where, gfc_typename (&sym->result->ts)); return false; } @@ -1653,20 +1653,20 @@ gfc_check_co_reduce (gfc_expr *a, gfc_ex if (actual_size && ((formal_size1 && actual_size != formal_size1) || (formal_size2 && actual_size != formal_size2))) { - gfc_error ("The character length of the A argument at %L and of the " - "arguments of the OPERATOR at %L shall be the same", + gfc_error_1 ("The character length of the A argument at %L and of the " + "arguments of the OPERATOR at %L shall be the same", &a->where, &op->where); return false; } if (actual_size && result_size && actual_size != result_size) { - gfc_error ("The character length of the A argument at %L and of the " - "function result of the OPERATOR at %L shall be the same", - &a->where, &op->where); + gfc_error_1 ("The character length of the A argument at %L and of the " + "function result of the OPERATOR at %L shall be the same", + &a->where, &op->where); return false; } } return true; @@ -1678,14 +1678,14 @@ gfc_check_co_minmax (gfc_expr *a, gfc_ex gfc_expr *errmsg) { if (a->ts.type != BT_INTEGER && a->ts.type != BT_REAL && a->ts.type != BT_CHARACTER) { - gfc_error ("'%s' argument of '%s' intrinsic at %L shall be of type " - "integer, real or character", - gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, - &a->where); + gfc_error_1 ("'%s' argument of '%s' intrinsic at %L shall be of type " + "integer, real or character", + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &a->where); return false; } return check_co_collective (a, result_image, stat, errmsg, false); } @@ -1773,11 +1773,11 @@ gfc_check_cshift (gfc_expr *array, gfc_e for (i = 0, j = 0; i < array->rank; i++) if (i != d - 1) { if (!identical_dimen_shape (array, i, shift, j)) { - gfc_error ("'%s' argument of '%s' intrinsic at %L has " + gfc_error ("%qs argument of %qs intrinsic at %L has " "invalid shape in dimension %d (%ld/%ld)", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &shift->where, i + 1, mpz_get_si (array->shape[i]), mpz_get_si (shift->shape[j])); @@ -1788,11 +1788,11 @@ gfc_check_cshift (gfc_expr *array, gfc_e } } } else { - gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank " + gfc_error ("%qs argument of intrinsic %qs at %L of must have rank " "%d or be a scalar", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &shift->where, array->rank - 1); return false; } @@ -1832,20 +1832,20 @@ gfc_check_dcmplx (gfc_expr *x, gfc_expr if (!numeric_check (y, 1)) return false; if (x->ts.type == BT_COMPLEX) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must not be " + gfc_error ("%qs argument of %qs intrinsic at %L must not be " "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &y->where); return false; } if (y->ts.type == BT_COMPLEX) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type " + gfc_error ("%qs argument of %qs intrinsic at %L must have a type " "of either REAL or INTEGER", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &y->where); return false; } @@ -1891,11 +1891,11 @@ gfc_check_dot_product (gfc_expr *vector_ if (!numeric_check (vector_b, 1)) return false; break; default: - gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric " + gfc_error ("%qs argument of %qs intrinsic at %L must be numeric " "or LOGICAL", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &vector_a->where); return false; } @@ -1905,11 +1905,11 @@ gfc_check_dot_product (gfc_expr *vector_ if (!rank_check (vector_b, 1, 1)) return false; if (! identical_dimen_shape (vector_a, 0, vector_b, 0)) { - gfc_error ("Different shape for arguments '%s' and '%s' at %L for " + gfc_error ("Different shape for arguments %qs and %qs at %L for " "intrinsic 'dot_product'", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic_arg[1]->name, &vector_a->where); return false; } @@ -1924,19 +1924,19 @@ gfc_check_dprod (gfc_expr *x, gfc_expr * || !type_check (y, 1, BT_REAL)) return false; if (x->ts.kind != gfc_default_real_kind) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be default " + gfc_error ("%qs argument of %qs intrinsic at %L must be default " "real", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &x->where); return false; } if (y->ts.kind != gfc_default_real_kind) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be default " + gfc_error ("%qs argument of %qs intrinsic at %L must be default " "real", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &y->where); return false; } @@ -1953,12 +1953,12 @@ gfc_check_dshift (gfc_expr *i, gfc_expr if (!type_check (j, 1, BT_INTEGER)) return false; if (i->is_boz && j->is_boz) { - gfc_error ("'I' at %L and 'J' at %L cannot both be BOZ literal " - "constants", &i->where, &j->where); + gfc_error_1 ("'I' at %L and 'J' at %L cannot both be BOZ literal " + "constants", &i->where, &j->where); return false; } if (!i->is_boz && !j->is_boz && !same_type_check (i, 0, j, 1)) return false; @@ -2023,11 +2023,11 @@ gfc_check_eoshift (gfc_expr *array, gfc_ for (i = 0, j = 0; i < array->rank; i++) if (i != d - 1) { if (!identical_dimen_shape (array, i, shift, j)) { - gfc_error ("'%s' argument of '%s' intrinsic at %L has " + gfc_error ("%qs argument of %qs intrinsic at %L has " "invalid shape in dimension %d (%ld/%ld)", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &shift->where, i + 1, mpz_get_si (array->shape[i]), mpz_get_si (shift->shape[j])); @@ -2038,11 +2038,11 @@ gfc_check_eoshift (gfc_expr *array, gfc_ } } } else { - gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank " + gfc_error ("%qs argument of intrinsic %qs at %L of must have rank " "%d or be a scalar", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &shift->where, array->rank - 1); return false; } @@ -2066,11 +2066,11 @@ gfc_check_eoshift (gfc_expr *array, gfc_ gfc_current_intrinsic)) return false; } else { - gfc_error ("'%s' argument of intrinsic '%s' at %L of must have " + gfc_error ("%qs argument of intrinsic %qs at %L of must have " "rank %d or be a scalar", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &shift->where, array->rank - 1); return false; } @@ -2367,12 +2367,12 @@ gfc_check_index (gfc_expr *string, gfc_e gfc_current_intrinsic, &kind->where)) return false; if (string->ts.kind != substring->ts.kind) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same " - "kind as '%s'", gfc_current_intrinsic_arg[1]->name, + gfc_error ("%qs argument of %qs intrinsic at %L must be the same " + "kind as %qs", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &substring->where, gfc_current_intrinsic_arg[0]->name); return false; } @@ -2469,13 +2469,13 @@ gfc_check_ishftc (gfc_expr *i, gfc_expr if (i2 < 0) i2 = -i2; if (i2 > i3) { - gfc_error ("The absolute value of SHIFT at %L must be less " - "than or equal to SIZE at %L", &shift->where, - &size->where); + gfc_error_1 ("The absolute value of SHIFT at %L must be less " + "than or equal to SIZE at %L", &shift->where, + &size->where); return false; } } } } @@ -2530,11 +2530,11 @@ gfc_check_kill_sub (gfc_expr *pid, gfc_e bool gfc_check_kind (gfc_expr *x) { if (x->ts.type == BT_DERIVED) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be a " + gfc_error ("%qs argument of %qs intrinsic at %L must be a " "non-derived type", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &x->where); return false; } @@ -2741,11 +2741,11 @@ min_max_args (gfc_actual_arglist *args) int i, j, nargs, *nlabels, nlabelless; bool a1 = false, a2 = false; if (args == NULL || args->next == NULL) { - gfc_error ("Intrinsic '%s' at %L must have at least two arguments", + gfc_error ("Intrinsic %qs at %L must have at least two arguments", gfc_current_intrinsic, gfc_current_intrinsic_where); return false; } if (!args->name) @@ -2789,11 +2789,11 @@ min_max_args (gfc_actual_arglist *args) else nlabelless++; if (!a1 || !a2) { - gfc_error ("Missing '%s' argument to the %s intrinsic at %L", + gfc_error ("Missing %qs argument to the %s intrinsic at %L", !a1 ? "a1" : "a2", gfc_current_intrinsic, gfc_current_intrinsic_where); return false; } @@ -2804,16 +2804,16 @@ min_max_args (gfc_actual_arglist *args) goto duplicate; return true; duplicate: - gfc_error ("Duplicate argument '%s' at %L to intrinsic %s", arg->name, + gfc_error ("Duplicate argument %qs at %L to intrinsic %s", arg->name, &arg->expr->where, gfc_current_intrinsic); return false; unknown: - gfc_error ("Unknown argument '%s' at %L to intrinsic %s", arg->name, + gfc_error ("Unknown argument %qs at %L to intrinsic %s", arg->name, &arg->expr->where, gfc_current_intrinsic); return false; } @@ -2838,11 +2838,11 @@ check_rest (bt type, int kind, gfc_actua "kinds at %L", &x->where)) return false; } else { - gfc_error ("'a%d' argument of '%s' intrinsic at %L must be " + gfc_error ("'a%d' argument of %qs intrinsic at %L must be " "%s(%d)", n, gfc_current_intrinsic, &x->where, gfc_basic_typename (type), kind); return false; } } @@ -2876,11 +2876,11 @@ gfc_check_min_max (gfc_actual_arglist *a gfc_current_intrinsic, &x->where)) return false; } else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL) { - gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER, " + gfc_error ("'a1' argument of %qs intrinsic at %L must be INTEGER, " "REAL or CHARACTER", gfc_current_intrinsic, &x->where); return false; } return check_rest (x->ts.type, x->ts.kind, arg); @@ -2926,28 +2926,28 @@ gfc_check_malloc (gfc_expr *size) bool gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) { if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts)) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric " + gfc_error ("%qs argument of %qs intrinsic at %L must be numeric " "or LOGICAL", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &matrix_a->where); return false; } if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts)) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric " + gfc_error ("%qs argument of %qs intrinsic at %L must be numeric " "or LOGICAL", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &matrix_b->where); return false; } if ((matrix_a->ts.type == BT_LOGICAL && gfc_numeric_ts (&matrix_b->ts)) || (gfc_numeric_ts (&matrix_a->ts) && matrix_b->ts.type == BT_LOGICAL)) { - gfc_error ("Argument types of '%s' intrinsic at %L must match (%s/%s)", + gfc_error ("Argument types of %qs intrinsic at %L must match (%s/%s)", gfc_current_intrinsic, &matrix_a->where, gfc_typename(&matrix_a->ts), gfc_typename(&matrix_b->ts)); return false; } @@ -2957,12 +2957,12 @@ gfc_check_matmul (gfc_expr *matrix_a, gf if (!rank_check (matrix_b, 1, 2)) return false; /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */ if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0)) { - gfc_error ("Different shape on dimension 1 for arguments '%s' " - "and '%s' at %L for intrinsic matmul", + gfc_error ("Different shape on dimension 1 for arguments %qs " + "and %qs at %L for intrinsic matmul", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic_arg[1]->name, &matrix_a->where); return false; } break; @@ -2976,20 +2976,20 @@ gfc_check_matmul (gfc_expr *matrix_a, gf /* matrix_b has rank 1 or 2 here. Common check for the cases - matrix_a has shape (n,m) and matrix_b has shape (m, k) - matrix_a has shape (n,m) and matrix_b has shape (m). */ if (!identical_dimen_shape (matrix_a, 1, matrix_b, 0)) { - gfc_error ("Different shape on dimension 2 for argument '%s' and " - "dimension 1 for argument '%s' at %L for intrinsic " + gfc_error ("Different shape on dimension 2 for argument %qs and " + "dimension 1 for argument %qs at %L for intrinsic " "matmul", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic_arg[1]->name, &matrix_a->where); return false; } break; default: - gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank " + gfc_error ("%qs argument of %qs intrinsic at %L must be of rank " "1 or 2", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &matrix_a->where); return false; } @@ -3160,11 +3160,11 @@ gfc_check_mask (gfc_expr *i, gfc_expr *k bool gfc_check_transf_bit_intrins (gfc_actual_arglist *ap) { if (ap->expr->ts.type != BT_INTEGER) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER", + gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &ap->expr->where); return false; } @@ -3335,11 +3335,11 @@ gfc_check_null (gfc_expr *mold) attr = gfc_variable_attr (mold, NULL); if (!attr.pointer && !attr.proc_pointer && !attr.allocatable) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER, " + gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER, " "ALLOCATABLE or procedure pointer", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &mold->where); return false; } @@ -3350,11 +3350,11 @@ gfc_check_null (gfc_expr *mold) return false; /* F2008, C1242. */ if (gfc_is_coindexed (mold)) { - gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be " + gfc_error ("%qs argument of %qs intrinsic at %L shall not be " "coindexed", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &mold->where); return false; } @@ -3422,13 +3422,13 @@ gfc_check_pack (gfc_expr *array, gfc_exp else if (mask->expr_type == EXPR_CONSTANT && mask->value.logical) mask_true_values = mpz_get_si (array_size); if (mpz_get_si (vector_size) < mask_true_values) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must " + gfc_error ("%qs argument of %qs intrinsic at %L must " "provide at least as many elements as there " - "are .TRUE. values in '%s' (%ld/%d)", + "are .TRUE. values in %qs (%ld/%d)", gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic, &vector->where, gfc_current_intrinsic_arg[1]->name, mpz_get_si (vector_size), mask_true_values); return false; @@ -3480,19 +3480,19 @@ gfc_check_present (gfc_expr *a) return false; sym = a->symtree->n.sym; if (!sym->attr.dummy) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a " + gfc_error ("%qs argument of %qs intrinsic at %L must be of a " "dummy variable", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &a->where); return false; } if (!sym->attr.optional) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be of " + gfc_error ("%qs argument of %qs intrinsic at %L must be of " "an OPTIONAL dummy variable", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &a->where); return false; } @@ -3507,12 +3507,12 @@ gfc_check_present (gfc_expr *a) && !(a->ref->next == NULL && a->ref->type == REF_ARRAY && (a->ref->u.ar.type == AR_FULL || (a->ref->u.ar.type == AR_ELEMENT && a->ref->u.ar.as->rank == 0)))) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a " - "subobject of '%s'", gfc_current_intrinsic_arg[0]->name, + gfc_error ("%qs argument of %qs intrinsic at %L must not be a " + "subobject of %qs", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &a->where, sym->name); return false; } return true; @@ -3669,11 +3669,11 @@ gfc_check_reshape (gfc_expr *source, gfc shape_size = mpz_get_ui (size); mpz_clear (size); if (shape_size <= 0) { - gfc_error ("'%s' argument of '%s' intrinsic at %L is empty", + gfc_error ("%qs argument of %qs intrinsic at %L is empty", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &shape->where); return false; } else if (shape_size > GFC_MAX_DIMENSIONS) @@ -3693,11 +3693,11 @@ gfc_check_reshape (gfc_expr *source, gfc continue; gfc_extract_int (e, &extent); if (extent < 0) { - gfc_error ("'%s' argument of '%s' intrinsic at %L has " + gfc_error ("%qs argument of %qs intrinsic at %L has " "negative element (%d)", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &e->where, extent); return false; } @@ -3733,11 +3733,11 @@ gfc_check_reshape (gfc_expr *source, gfc order_size = mpz_get_ui (size); mpz_clear (size); if (order_size != shape_size) { - gfc_error ("'%s' argument of '%s' intrinsic at %L " + gfc_error ("%qs argument of %qs intrinsic at %L " "has wrong number of elements (%d/%d)", gfc_current_intrinsic_arg[3]->name, gfc_current_intrinsic, &order->where, order_size, shape_size); return false; @@ -3751,20 +3751,20 @@ gfc_check_reshape (gfc_expr *source, gfc gfc_extract_int (e, &dim); if (dim < 1 || dim > order_size) { - gfc_error ("'%s' argument of '%s' intrinsic at %L " + gfc_error ("%qs argument of %qs intrinsic at %L " "has out-of-range dimension (%d)", gfc_current_intrinsic_arg[3]->name, gfc_current_intrinsic, &e->where, dim); return false; } if (perm[dim-1] != 0) { - gfc_error ("'%s' argument of '%s' intrinsic at %L has " + gfc_error ("%qs argument of %qs intrinsic at %L has " "invalid permutation of dimensions (dimension " "'%d' duplicated)", gfc_current_intrinsic_arg[3]->name, gfc_current_intrinsic, &e->where, dim); return false; @@ -3813,40 +3813,40 @@ gfc_check_reshape (gfc_expr *source, gfc bool gfc_check_same_type_as (gfc_expr *a, gfc_expr *b) { if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS) { - gfc_error ("'%s' argument of '%s' intrinsic at %L " + gfc_error ("%qs argument of %qs intrinsic at %L " "cannot be of type %s", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &a->where, gfc_typename (&a->ts)); return false; } if (!(gfc_type_is_extensible (a->ts.u.derived) || UNLIMITED_POLY (a))) { - gfc_error ("'%s' argument of '%s' intrinsic at %L " + gfc_error ("%qs argument of %qs intrinsic at %L " "must be of an extensible type", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &a->where); return false; } if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS) { - gfc_error ("'%s' argument of '%s' intrinsic at %L " + gfc_error ("%qs argument of %qs intrinsic at %L " "cannot be of type %s", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &b->where, gfc_typename (&b->ts)); return false; } if (!(gfc_type_is_extensible (b->ts.u.derived) || UNLIMITED_POLY (b))) { - gfc_error ("'%s' argument of '%s' intrinsic at %L " + gfc_error ("%qs argument of %qs intrinsic at %L " "must be of an extensible type", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &b->where); return false; } @@ -4084,11 +4084,11 @@ gfc_check_size (gfc_expr *array, gfc_exp bool gfc_check_sizeof (gfc_expr *arg) { if (arg->ts.type == BT_PROCEDURE) { - gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be a procedure", + gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &arg->where); return false; } @@ -4097,22 +4097,22 @@ gfc_check_sizeof (gfc_expr *arg) && (arg->symtree->n.sym->as == NULL || (arg->symtree->n.sym->as->type != AS_ASSUMED_SHAPE && arg->symtree->n.sym->as->type != AS_DEFERRED && arg->symtree->n.sym->as->type != AS_ASSUMED_RANK))) { - gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be TYPE(*)", + gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &arg->where); return false; } if (arg->rank && arg->expr_type == EXPR_VARIABLE && arg->symtree->n.sym->as != NULL && arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref && arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL) { - gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be an " + gfc_error ("%qs argument of %qs intrinsic at %L shall not be an " "assumed-size array", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &arg->where); return false; } @@ -4227,20 +4227,20 @@ gfc_check_c_sizeof (gfc_expr *arg) { const char *msg; if (!is_c_interoperable (arg, &msg, false, false)) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be an " + gfc_error ("%qs argument of %qs intrinsic at %L must be an " "interoperable data entity: %s", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &arg->where, msg); return false; } if (arg->ts.type == BT_ASSUMED) { - gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be " + gfc_error ("%qs argument of %qs intrinsic at %L shall not be " "TYPE(*)", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &arg->where); return false; } @@ -4248,11 +4248,11 @@ gfc_check_c_sizeof (gfc_expr *arg) if (arg->rank && arg->expr_type == EXPR_VARIABLE && arg->symtree->n.sym->as != NULL && arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref && arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL) { - gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be an " + gfc_error ("%qs argument of %qs intrinsic at %L shall not be an " "assumed-size array", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &arg->where); return false; } @@ -4447,11 +4447,11 @@ gfc_check_c_funloc (gfc_expr *x) gfc_namespace *ns = gfc_current_ns; for (ns = gfc_current_ns; ns; ns = ns->parent) if (x->symtree->n.sym == ns->proc_name) { - gfc_error ("Function result '%s' at %L is invalid as X argument " + gfc_error ("Function result %qs at %L is invalid as X argument " "to C_FUNLOC", x->symtree->n.sym->name, &x->where); return false; } } @@ -4573,11 +4573,11 @@ gfc_check_sngl (gfc_expr *a) bool gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies) { if (source->rank >= GFC_MAX_DIMENSIONS) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be less " + gfc_error ("%qs argument of %qs intrinsic at %L must be less " "than rank %d", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS); return false; } @@ -4592,11 +4592,11 @@ gfc_check_spread (gfc_expr *source, gfc_ if (dim && dim->expr_type == EXPR_CONSTANT && (mpz_cmp_ui (dim->value.integer, 1) < 0 || mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0)) { - gfc_error ("'%s' argument of '%s' intrinsic at %L is not a valid " + gfc_error ("%qs argument of %qs intrinsic at %L is not a valid " "dimension index", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &dim->where); return false; } @@ -5187,13 +5187,13 @@ gfc_check_unpack (gfc_expr *vector, gfc_ mask_ctor = gfc_constructor_next (mask_ctor); } if (mpz_get_si (vector_size) < mask_true_count) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must " + gfc_error ("%qs argument of %qs intrinsic at %L must " "provide at least as many elements as there " - "are .TRUE. values in '%s' (%ld/%d)", + "are .TRUE. values in %qs (%ld/%d)", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &vector->where, gfc_current_intrinsic_arg[1]->name, mpz_get_si (vector_size), mask_true_count); return false; } @@ -5201,12 +5201,12 @@ gfc_check_unpack (gfc_expr *vector, gfc_ mpz_clear (vector_size); } if (mask->rank != field->rank && field->rank != 0) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must have " - "the same rank as '%s' or be a scalar", + gfc_error ("%qs argument of %qs intrinsic at %L must have " + "the same rank as %qs or be a scalar", gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic, &field->where, gfc_current_intrinsic_arg[1]->name); return false; } @@ -5214,11 +5214,11 @@ gfc_check_unpack (gfc_expr *vector, gfc_ { int i; for (i = 0; i < field->rank; i++) if (! identical_dimen_shape (mask, i, field, i)) { - gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L " + gfc_error ("%qs and %qs arguments of %qs intrinsic at %L " "must have identical shape.", gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &field->where); } @@ -5472,11 +5472,11 @@ gfc_check_random_seed (gfc_expr *size, g if (!kind_value_check (put, 1, gfc_default_integer_kind)) return false; if (gfc_array_size (put, &put_size) && mpz_get_ui (put_size) < kiss_size) - gfc_error ("Size of '%s' argument of '%s' intrinsic at %L " + gfc_error ("Size of %qs argument of %qs intrinsic at %L " "too small (%i/%i)", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, where, (int) mpz_get_ui (put_size), kiss_size); } @@ -5504,11 +5504,11 @@ gfc_check_random_seed (gfc_expr *size, g if (!kind_value_check (get, 2, gfc_default_integer_kind)) return false; if (gfc_array_size (get, &get_size) && mpz_get_ui (get_size) < kiss_size) - gfc_error ("Size of '%s' argument of '%s' intrinsic at %L " + gfc_error ("Size of %qs argument of %qs intrinsic at %L " "too small (%i/%i)", gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic, where, (int) mpz_get_ui (get_size), kiss_size); } @@ -5815,11 +5815,11 @@ gfc_check_getarg (gfc_expr *pos, gfc_exp if (!type_check (pos, 0, BT_INTEGER)) return false; if (pos->ts.kind > gfc_default_integer_kind) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind " + gfc_error ("%qs argument of %qs intrinsic at %L must be of a kind " "not wider than the default kind (%d)", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &pos->where, gfc_default_integer_kind); return false; } @@ -6167,27 +6167,27 @@ gfc_check_system_sub (gfc_expr *cmd, gfc bool gfc_check_and (gfc_expr *i, gfc_expr *j) { if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER " + gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER " "or LOGICAL", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &i->where); return false; } if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be INTEGER " + gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER " "or LOGICAL", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &j->where); return false; } if (i->ts.type != j->ts.type) { - gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must " + gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must " "have the same type", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &j->where); return false; } @@ -6205,19 +6205,19 @@ gfc_check_and (gfc_expr *i, gfc_expr *j) bool gfc_check_storage_size (gfc_expr *a, gfc_expr *kind) { if (a->ts.type == BT_ASSUMED) { - gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be TYPE(*)", + gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &a->where); return false; } if (a->ts.type == BT_PROCEDURE) { - gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be a " + gfc_error ("%qs argument of %qs intrinsic at %L shall not be a " "procedure", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &a->where); return false; } @@ -6230,11 +6230,11 @@ gfc_check_storage_size (gfc_expr *a, gfc if (!scalar_check (kind, 1)) return false; if (kind->expr_type != EXPR_CONSTANT) { - gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant", + gfc_error ("%qs argument of %qs intrinsic at %L must be a constant", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, &kind->where); return false; } Index: gcc/fortran/primary.c =================================================================== --- gcc/fortran/primary.c (revision 218457) +++ gcc/fortran/primary.c (working copy) @@ -1272,11 +1272,12 @@ match_complex_part (gfc_expr **result) static match match_complex_constant (gfc_expr **result) { gfc_expr *e, *real, *imag; - gfc_error_buf old_error; + gfc_error_buf old_error_1; + output_buffer old_error; gfc_typespec target; locus old_loc; int kind; match m; @@ -1285,22 +1286,22 @@ match_complex_constant (gfc_expr **resul m = gfc_match_char ('('); if (m != MATCH_YES) return m; - gfc_push_error (&old_error); + gfc_push_error (&old_error, &old_error_1); m = match_complex_part (&real); if (m == MATCH_NO) { - gfc_free_error (&old_error); + gfc_free_error (&old_error, &old_error_1); goto cleanup; } if (gfc_match_char (',') == MATCH_NO) { - gfc_pop_error (&old_error); + gfc_pop_error (&old_error, &old_error_1); m = MATCH_NO; goto cleanup; } /* If m is error, then something was wrong with the real part and we @@ -1308,14 +1309,14 @@ match_complex_constant (gfc_expr **resul ambiguous case here is the start of an iterator list of some sort. These sort of lists are matched prior to coming here. */ if (m == MATCH_ERROR) { - gfc_free_error (&old_error); + gfc_free_error (&old_error, &old_error_1); goto cleanup; } - gfc_pop_error (&old_error); + gfc_pop_error (&old_error, &old_error_1); m = match_complex_part (&imag); if (m == MATCH_NO) goto syntax; if (m == MATCH_ERROR) @@ -2491,11 +2492,11 @@ gfc_convert_to_structure_constructor (gf comp_iter = comp_iter->next) { gcc_assert (comp_iter); if (!strcmp (comp_iter->name, comp_tail->name)) { - gfc_error ("Component '%s' is initialized twice in the structure" + gfc_error ("Component %qs is initialized twice in the structure" " constructor at %L!", comp_tail->name, comp_tail->val ? &comp_tail->where : &gfc_current_locus); goto cleanup; } Index: gcc/testsuite/gfortran.dg/do_iterator.f90 =================================================================== --- gcc/testsuite/gfortran.dg/do_iterator.f90 (revision 218457) +++ gcc/testsuite/gfortran.dg/do_iterator.f90 (working copy) @@ -8,6 +8,6 @@ DO I=1,5 ! { dg-error "cannot be r END DO DO I=1,5 ! { dg-error "cannot be redefined" "changing do-iterator 3" } READ(5,*,iostat=i) j ! { dg-error "cannot be redefined" "changing do-iterator 3" } ENDDO END -! { dg-error "Invalid character" "character" { target *-*-* } 7 } + Index: gcc/diagnostic.c =================================================================== --- gcc/diagnostic.c (revision 218457) +++ gcc/diagnostic.c (working copy) @@ -41,12 +41,10 @@ along with GCC; see the file COPYING3. #define permissive_error_option(DC) ((DC)->opt_permissive) /* Prototypes. */ static void error_recursion (diagnostic_context *) ATTRIBUTE_NORETURN; -static void diagnostic_action_after_output (diagnostic_context *, - diagnostic_info *); static void real_abort (void) ATTRIBUTE_NORETURN; /* Name of program invoked, sans directories. */ const char *progname; @@ -464,15 +462,15 @@ bt_err_callback (void *data ATTRIBUTE_UN errnum == 0 ? "" : xstrerror (errnum)); } /* Take any action which is expected to happen after the diagnostic is written out. This function does not always return. */ -static void +void diagnostic_action_after_output (diagnostic_context *context, - diagnostic_info *diagnostic) + diagnostic_t diag_kind) { - switch (diagnostic->kind) + switch (diag_kind) { case DK_DEBUG: case DK_NOTE: case DK_ANACHRONISM: case DK_WARNING: @@ -845,11 +843,11 @@ diagnostic_report_diagnostic (diagnostic diagnostic->x_data = NULL; pp_format (context->printer, &diagnostic->message); (*diagnostic_starter (context)) (context, diagnostic); pp_output_formatted_text (context->printer); (*diagnostic_finalizer (context)) (context, diagnostic); - diagnostic_action_after_output (context, diagnostic); + diagnostic_action_after_output (context, diagnostic->kind); diagnostic->message.format_spec = saved_format_spec; diagnostic->x_data = NULL; context->lock--; @@ -1245,22 +1243,19 @@ fnotice (FILE *file, const char *cmsgid, This mustn't use internal_error, that will cause infinite recursion. */ static void error_recursion (diagnostic_context *context) { - diagnostic_info diagnostic; - if (context->lock < 3) pp_newline_and_flush (context->printer); fnotice (stderr, "Internal compiler error: Error reporting routines re-entered.\n"); /* Call diagnostic_action_after_output to get the "please submit a bug - report" message. It only looks at the kind field of diagnostic_info. */ - diagnostic.kind = DK_ICE; - diagnostic_action_after_output (context, &diagnostic); + report" message. */ + diagnostic_action_after_output (context, DK_ICE); /* Do not use gcc_unreachable here; that goes through internal_error and therefore would cause infinite recursion. */ real_abort (); } Index: gcc/diagnostic.h =================================================================== --- gcc/diagnostic.h (revision 218457) +++ gcc/diagnostic.h (working copy) @@ -292,10 +292,11 @@ extern void diagnostic_append_note (diag #endif extern char *diagnostic_build_prefix (diagnostic_context *, const diagnostic_info *); void default_diagnostic_starter (diagnostic_context *, diagnostic_info *); void default_diagnostic_finalizer (diagnostic_context *, diagnostic_info *); void diagnostic_set_caret_max_width (diagnostic_context *context, int value); +void diagnostic_action_after_output (diagnostic_context *, diagnostic_t); void diagnostic_file_cache_fini (void); /* Expand the location of this diagnostic. Use this function for consistency. */ Index: gcc/pretty-print.c =================================================================== --- gcc/pretty-print.c (revision 218457) +++ gcc/pretty-print.c (working copy) @@ -53,13 +53,10 @@ output_buffer::~output_buffer () { obstack_free (&chunk_obstack, NULL); obstack_free (&formatted_obstack, NULL); } -/* A pointer to the formatted diagnostic message. */ -#define pp_formatted_text_data(PP) \ - ((const char *) obstack_base (pp_buffer (PP)->obstack)) /* Format an integer given by va_arg (ARG, type-specifier T) where type-specifier is a precision modifier as indicated by PREC. F is a string used to construct the appropriate format-specifier. */ #define pp_integer_with_precision(PP, ARG, PREC, T, F) \ @@ -223,12 +220,11 @@ pp_maybe_wrap_text (pretty_printer *pp, /* Append to the output area of PRETTY-PRINTER a string specified by its STARTing character and LENGTH. */ static inline void pp_append_r (pretty_printer *pp, const char *start, int length) { - obstack_grow (pp_buffer (pp)->obstack, start, length); - pp_buffer (pp)->line_length += length; + output_buffer_append_r (pp_buffer (pp), start, length); } /* Insert enough spaces into the output area of PRETTY-PRINTER to bring the column position to the current indentation level, assuming that a newline has just been written to the buffer. */ @@ -824,25 +820,19 @@ pp_append_text (pretty_printer *pp, cons /* Finishes constructing a NULL-terminated character string representing the PRETTY-PRINTED text. */ const char * pp_formatted_text (pretty_printer *pp) { - obstack_1grow (pp_buffer (pp)->obstack, '\0'); - return pp_formatted_text_data (pp); + return output_buffer_formatted_text (pp_buffer (pp)); } /* Return a pointer to the last character emitted in PRETTY-PRINTER's output area. A NULL pointer means no character available. */ const char * pp_last_position_in_text (const pretty_printer *pp) { - const char *p = NULL; - struct obstack *text = pp_buffer (pp)->obstack; - - if (obstack_base (text) != obstack_next_free (text)) - p = ((const char *) obstack_next_free (text)) - 1; - return p; + return output_buffer_last_position_in_text (pp_buffer (pp)); } /* Return the amount of characters PRETTY-PRINTER can accept to make a full line. Meaningful only in line-wrapping mode. */ int Index: gcc/pretty-print.h =================================================================== --- gcc/pretty-print.h (revision 218457) +++ gcc/pretty-print.h (working copy) @@ -105,10 +105,42 @@ struct output_buffer appropriate. Otherwise, text is buffered until either pp_really_flush or pp_clear_output_area are called. */ bool flush_p; }; +/* Finishes constructing a NULL-terminated character string representing + the buffered text. */ +static inline const char * +output_buffer_formatted_text (output_buffer *buff) +{ + obstack_1grow (buff->obstack, '\0'); + return (const char *) obstack_base (buff->obstack); +} + +/* Append to the output buffer a string specified by its + STARTing character and LENGTH. */ +static inline void +output_buffer_append_r (output_buffer *buff, const char *start, int length) +{ + obstack_grow (buff->obstack, start, length); + buff->line_length += length; +} + +/* Return a pointer to the last character emitted in the + output_buffer. A NULL pointer means no character available. */ +static inline const char * +output_buffer_last_position_in_text (const output_buffer *buff) +{ + const char *p = NULL; + struct obstack *text = buff->obstack; + + if (obstack_base (text) != obstack_next_free (text)) + p = ((const char *) obstack_next_free (text)) - 1; + return p; +} + + /* The type of pretty-printer flags passed to clients. */ typedef unsigned int pp_flags; enum pp_padding {