Hi, This patch finishes the conversion of Fortran diagnostics to use the common diagnostics by removing all gfc_error*_1 variants.
I noticed that whether some buffered gfc_error_1() end up printed may depend on whether a gfc_error_now is given or not, and not only on whether there is any output buffered. Thus, I reintroduced a new error_buffer of type gfc_buffer_error. The rest is mostly mechanic. I did not make an attempt in this patch to remove all code that has become obsolete now: gfc_get_terminal_width (already implemented in diagnostics.c) error_char (already empty, but used by other obsolete functions) error_string (obsolete, just use %s) error_uinteger (obsolete, just use %lu) error_integer (obsolete, just use %ld) gfc_widechar_display_length, gfc_wide_display_length, print_wide_char_into_buffer, gfc_print_wide_char (I'm not sure how this functionality differs from what the common diagnostics already do, perhaps some of it should be moved to the common code) show_locus (obsolete, except "Included at" handling should be moved to the common diagnostics, no testcase is testing this). show_loci (obsolete, except "During initialization" handling should be moved to the common diagnostics, no testcase is testing this) error_print, error_printf (obsolete) Bootstrapped and regression tested on x86_64-linux-gnu. OK? gcc/fortran/ChangeLog: 2015-05-17 Manuel López-Ibáñez <m...@gcc.gnu.org> PR fortran/44054 * gfortran.h (struct gfc_error_buf): Rename as gfc_error_buffer. Move closer to push, pop and free methods. Reimplement using an output_buffer. * error.c (errors, warnings, warning_buffer, cur_error_buffer): Delete everywhere in this file. (error_char): Delete all contents. (gfc_increment_error_count): Delete. (gfc_error_now): Update comment. Set error_buffer.flag. (gfc_warning_check): Do not handle warning_buffer. (gfc_error_1): Delete. (gfc_error_now_1): Delete. (gfc_error_check): Simplify. (gfc_move_error_buffer_from_to): Renamed from gfc_move_output_buffer_from_to. (gfc_push_error): Handle only gfc_error_buffer. (gfc_pop_error): Likewise. (gfc_free_error): Likewise. (gfc_get_errors): Remove warnings and errors. (gfc_diagnostics_init): Use static error_buffer. (gfc_error_1,gfc_error_now_1): Delete declarations. * symbol.c, decl.c, trans-common.c, data.c, expr.c, expr.c, frontend-passes.c, resolve.c, match.c, parse.c: Replace gfc_error_1 with gfc_error and gfc_error_now_1 with gfc_error_1 everywhere. * f95-lang.c (gfc_be_parse_file): Do not update errorcount and warningcount here. * primary.c (match_complex_constant): Replace gfc_error_buf and output_buffer with gfc_error_buffer.
Index: gcc/fortran/symbol.c =================================================================== --- gcc/fortran/symbol.c (revision 223238) +++ gcc/fortran/symbol.c (working copy) @@ -1699,11 +1699,11 @@ 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_1 ("Symbol '%s' at %L conflicts with symbol from module '%s', " + gfc_error ("Symbol %qs at %L conflicts with symbol from module %qs, " "use-associated at %L", sym->name, where, sym->module, &sym->declared_at); else gfc_error ("Symbol %qs at %L already has basic type of %s", sym->name, where, gfc_basic_typename (type)); @@ -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_1 ("Component '%s' at %C already declared at %L", + gfc_error ("Component %qs 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_1 ("Component '%s' at %C already in the parent type " + gfc_error ("Component %qs at %C already in the parent type " "at %L", name, &sym->components->ts.u.derived->declared_at); return false; } /* Allocate a new component. */ @@ -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_1 ("Duplicate statement label %d at %L and %L", labelno, + gfc_error ("Duplicate statement label %d at %L and %L", labelno, &lp->where, label_locus); else { lp->where = *label_locus; @@ -3893,34 +3893,34 @@ 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_1 ("Component '%s' at %L cannot have the " + gfc_error ("Component %qs at %L cannot have the " "POINTER attribute because it is a member " - "of the BIND(C) derived type '%s' at %L", + "of the BIND(C) derived type %qs 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_1 ("Procedure pointer component '%s' at %L cannot be a member" - " of the BIND(C) derived type '%s' at %L", curr_comp->name, + gfc_error ("Procedure pointer component %qs at %L cannot be a member" + " of the BIND(C) derived type %qs 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_1 ("Component '%s' at %L cannot have the " + gfc_error ("Component %qs at %L cannot have the " "ALLOCATABLE attribute because it is a member " - "of the BIND(C) derived type '%s' at %L", + "of the BIND(C) derived type %qs 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 223238) +++ gcc/fortran/decl.c (working copy) @@ -919,34 +919,34 @@ get_proc_name (const char *name, gfc_sym accessible names. */ if (sym->attr.flavor != 0 && sym->attr.proc != 0 && (sym->attr.subroutine || sym->attr.function) && sym->attr.if_source != IFSRC_UNKNOWN) - gfc_error_now_1 ("Procedure '%s' at %C is already defined at %L", - name, &sym->declared_at); + gfc_error_now ("Procedure %qs at %C is already defined at %L", + name, &sym->declared_at); /* Trap a procedure with a name the same as interface in the encompassing scope. */ if (sym->attr.generic != 0 && (sym->attr.subroutine || sym->attr.function) && !sym->attr.mod_proc) - gfc_error_now_1 ("Name '%s' at %C is already defined" - " as a generic interface at %L", - name, &sym->declared_at); + gfc_error_now ("Name %qs at %C is already defined" + " as a generic interface at %L", + name, &sym->declared_at); /* Trap declarations of attributes in encompassing scope. The signature for this is that ts.kind is set. Legitimate references only set ts.type. */ if (sym->ts.kind != 0 && !sym->attr.implicit_type && sym->attr.proc == 0 && gfc_current_ns->parent != NULL && sym->attr.access == 0 && !module_fcn_entry) - gfc_error_now_1 ("Procedure '%s' at %C has an explicit interface " - "and must not have attributes declared at %L", - name, &sym->declared_at); + gfc_error_now ("Procedure %qs at %C has an explicit interface " + "and must not have attributes declared at %L", + name, &sym->declared_at); } if (gfc_current_ns->parent == NULL || *result == NULL) return rc; @@ -2866,13 +2866,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_1 ("Type name '%s' at %C conflicts with previously declared " - "entity at %L, which has the same name", name, - &sym->declared_at); + gfc_error ("Type name %qs at %C conflicts with previously declared " + "entity at %L, which has the same name", name, + &sym->declared_at); return MATCH_ERROR; } gfc_save_symbol_data (sym); gfc_set_sym_referenced (sym); Index: gcc/fortran/trans-common.c =================================================================== --- gcc/fortran/trans-common.c (revision 223238) +++ gcc/fortran/trans-common.c (working copy) @@ -916,12 +916,12 @@ 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_1 ("Inconsistent equivalence rules involving '%s' at %L and " - "'%s' at %L", s1->sym->name, &s1->sym->declared_at, + gfc_error ("Inconsistent equivalence rules involving %qs at %L and " + "%qs at %L", s1->sym->name, &s1->sym->declared_at, s2->sym->name, &s2->sym->declared_at); } /* Process a new equivalence condition. eq1 is know to be in segment f. Index: gcc/fortran/gfortran.h =================================================================== --- gcc/fortran/gfortran.h (revision 223238) +++ gcc/fortran/gfortran.h (working copy) @@ -2643,18 +2643,10 @@ void gfc_maybe_initialize_eh (void); /* iresolve.c */ const char * gfc_get_string (const char *, ...) ATTRIBUTE_PRINTF_1; bool gfc_find_sym_in_expr (gfc_symbol *, gfc_expr *); /* error.c */ - -typedef struct gfc_error_buf -{ - int flag; - size_t allocated, index; - char *message; -} gfc_error_buf; - void gfc_error_init_1 (void); void gfc_diagnostics_init (void); void gfc_diagnostics_finish (void); void gfc_buffer_error (bool); @@ -2666,13 +2658,11 @@ bool gfc_warning_now_at (location_t loc, ATTRIBUTE_GCC_GFC(3,4); 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); void gfc_clear_error (void); bool gfc_error_check (void); @@ -2683,14 +2673,21 @@ 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)); -#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 *); +#include "pretty-print.h" /* For output_buffer. */ +struct gfc_error_buffer +{ + bool flag; + output_buffer buffer; + gfc_error_buffer(void) : flag(false), buffer() {} +}; + +void gfc_push_error (gfc_error_buffer *); +void gfc_pop_error (gfc_error_buffer *); +void gfc_free_error (gfc_error_buffer *); void gfc_get_errors (int *, int *); void gfc_errors_to_warnings (bool); /* arith.c */ Index: gcc/fortran/error.c =================================================================== --- gcc/fortran/error.c (revision 223238) +++ gcc/fortran/error.c (working copy) @@ -38,16 +38,16 @@ along with GCC; see the file COPYING3. static int suppress_errors = 0; static bool warnings_not_errors = false; -static int terminal_width, errors, warnings; - -static gfc_error_buf error_buffer, warning_buffer, *cur_error_buffer; +static int terminal_width; /* True if the error/warnings should be buffered. */ static bool buffered_p; + +static gfc_error_buffer error_buffer; /* These are always buffered buffers (.flush_p == false) to be used by the pretty-printer. */ static output_buffer *pp_error_buffer, *pp_warning_buffer; static int warningcount_buffered, werrorcount_buffered; @@ -98,12 +98,10 @@ gfc_get_terminal_width (void) void gfc_error_init_1 (void) { terminal_width = gfc_get_terminal_width (); - errors = 0; - warnings = 0; gfc_buffer_error (false); } /* Set the flag for buffering errors or not. */ @@ -117,46 +115,13 @@ gfc_buffer_error (bool flag) /* Add a single character to the error buffer or output depending on buffered_p. */ static void -error_char (char c) +error_char (char) { - if (buffered_p) - { - if (cur_error_buffer->index >= cur_error_buffer->allocated) - { - cur_error_buffer->allocated = cur_error_buffer->allocated - ? cur_error_buffer->allocated * 2 : 1000; - cur_error_buffer->message = XRESIZEVEC (char, cur_error_buffer->message, - cur_error_buffer->allocated); - } - cur_error_buffer->message[cur_error_buffer->index++] = c; - } - else - { - if (c != 0) - { - /* We build up complete lines before handing things - over to the library in order to speed up error printing. */ - static char *line; - static size_t allocated = 0, index = 0; - - if (index + 1 >= allocated) - { - allocated = allocated ? allocated * 2 : 1000; - line = XRESIZEVEC (char, line, allocated); - } - line[index++] = c; - if (c == '\n') - { - line[index] = '\0'; - fputs (line, stderr); - index = 0; - } - } - } + /* FIXME: Unused function to be removed in a subsequent patch. */ } /* Copy a string to wherever it needs to go. */ @@ -780,22 +745,10 @@ error_printf (const char *gmsgid, ...) error_print ("", _(gmsgid), argp); va_end (argp); } -/* Increment the number of errors, and check whether too many have - been printed. */ - -static void -gfc_increment_error_count (void) -{ - errors++; - if ((gfc_option.max_errors != 0) && (errors >= gfc_option.max_errors)) - gfc_fatal_error ("Error count reached limit of %d.", gfc_option.max_errors); -} - - /* Clear any output buffered in a pretty-print output_buffer. */ static void gfc_clear_pp_buffer (output_buffer *this_buffer) { @@ -1245,20 +1198,19 @@ gfc_warning_now (int opt, const char *gm return ret; } /* Immediate error (i.e. do not buffer). */ -/* 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_now_1. */ void gfc_error_now (const char *gmsgid, ...) { va_list argp; diagnostic_info diagnostic; + error_buffer.flag = true; + va_start (argp, gmsgid); diagnostic_set_info (&diagnostic, gmsgid, &argp, UNKNOWN_LOCATION, DK_ERROR); report_diagnostic (&diagnostic); va_end (argp); } @@ -1283,12 +1235,10 @@ gfc_fatal_error (const char *gmsgid, ... /* Clear the warning flag. */ void gfc_clear_warning (void) { - warning_buffer.flag = 0; - gfc_clear_pp_buffer (pp_warning_buffer); warningcount_buffered = 0; werrorcount_buffered = 0; } @@ -1297,19 +1247,12 @@ gfc_clear_warning (void) If so, print the warning. */ void gfc_warning_check (void) { - if (warning_buffer.flag) - { - warnings++; - if (warning_buffer.message != NULL) - fputs (warning_buffer.message, stderr); - gfc_clear_warning (); - } /* This is for the new diagnostics machinery. */ - else if (! gfc_output_buffer_empty_p (pp_warning_buffer)) + 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); @@ -1323,66 +1266,10 @@ gfc_warning_check (void) } } /* 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_1 (const char *gmsgid, ...) -{ - va_list argp; - - if (warnings_not_errors) - goto warning; - - if (suppress_errors) - return; - - error_buffer.flag = 1; - error_buffer.index = 0; - cur_error_buffer = &error_buffer; - - va_start (argp, gmsgid); - error_print (_("Error:"), _(gmsgid), argp); - va_end (argp); - - error_char ('\0'); - - if (!buffered_p) - gfc_increment_error_count(); - - return; - -warning: - - if (inhibit_warnings) - return; - - warning_buffer.flag = 1; - warning_buffer.index = 0; - cur_error_buffer = &warning_buffer; - - va_start (argp, gmsgid); - error_print (_("Warning:"), _(gmsgid), argp); - va_end (argp); - - error_char ('\0'); - - if (!buffered_p) - { - warnings++; - 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. */ static void gfc_error (const char *gmsgid, va_list ap) { va_list argp; @@ -1438,42 +1325,10 @@ gfc_error (const char *gmsgid, ...) gfc_error (gmsgid, argp); 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. */ - -void -gfc_error_now_1 (const char *gmsgid, ...) -{ - va_list argp; - bool buffered_p_saved; - - error_buffer.flag = 1; - error_buffer.index = 0; - cur_error_buffer = &error_buffer; - - buffered_p_saved = buffered_p; - buffered_p = false; - - va_start (argp, gmsgid); - error_print (_("Error:"), _(gmsgid), argp); - va_end (argp); - - error_char ('\0'); - - gfc_increment_error_count(); - - buffered_p = buffered_p_saved; - - if (flag_fatal_errors) - exit (FATAL_EXIT_CODE); -} - - /* This shouldn't happen... but sometimes does. */ void gfc_internal_error (const char *gmsgid, ...) { @@ -1514,48 +1369,42 @@ gfc_error_flag_test (void) If so, print the error. Returns the state of error_flag. */ bool gfc_error_check (void) { - bool error_raised = (bool) error_buffer.flag; - - 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)) + if (error_buffer.flag + || ! gfc_output_buffer_empty_p (pp_error_buffer)) { - error_raised = true; + error_buffer.flag = false; pretty_printer *pp = global_dc->printer; output_buffer *tmp_buffer = pp->buffer; pp->buffer = pp_error_buffer; pp_really_flush (pp); ++errorcount; gcc_assert (gfc_output_buffer_empty_p (pp_error_buffer)); diagnostic_action_after_output (global_dc, DK_ERROR); pp->buffer = tmp_buffer; + return true; } - return error_raised; + return false; } /* 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_move_error_buffer_from_to (gfc_error_buffer * buffer_from, + gfc_error_buffer * buffer_to) { + output_buffer * from = &(buffer_from->buffer); + output_buffer * to = &(buffer_to->buffer); + + buffer_to->flag = buffer_from->flag; + buffer_from->flag = false; + gfc_clear_pp_buffer (to); /* We make sure this is always buffered. */ to->flush_p = false; if (! gfc_output_buffer_empty_p (from)) @@ -1567,62 +1416,43 @@ gfc_move_output_buffer_from_to (output_b } /* Save the existing error state. */ void -gfc_push_error (output_buffer *buffer_err, gfc_error_buf *err) +gfc_push_error (gfc_error_buffer *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); + gfc_move_error_buffer_from_to (&error_buffer, err); } /* Restore a previous pushed error state. */ void -gfc_pop_error (output_buffer *buffer_err, gfc_error_buf *err) +gfc_pop_error (gfc_error_buffer *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); + gfc_move_error_buffer_from_to (err, &error_buffer); } /* Free a pushed error state, but keep the current error state. */ void -gfc_free_error (output_buffer *buffer_err, gfc_error_buf *err) +gfc_free_error (gfc_error_buffer *err) { - if (err->flag) - free (err->message); - - gfc_clear_pp_buffer (buffer_err); + gfc_clear_pp_buffer (&(err->buffer)); } /* Report the number of warnings and errors that occurred to the caller. */ void gfc_get_errors (int *w, int *e) { if (w != NULL) - *w = warnings + warningcount + werrorcount; + *w = warningcount + werrorcount; if (e != NULL) - *e = errors + errorcount + sorrycount + werrorcount; + *e = errorcount + sorrycount + werrorcount; } /* Switch errors into warnings. */ @@ -1640,11 +1470,11 @@ gfc_diagnostics_init (void) diagnostic_format_decoder (global_dc) = gfc_format_decoder; global_dc->caret_chars[0] = '1'; global_dc->caret_chars[1] = '2'; pp_warning_buffer = new (XNEW (output_buffer)) output_buffer (); pp_warning_buffer->flush_p = false; - pp_error_buffer = new (XNEW (output_buffer)) output_buffer (); + pp_error_buffer = &(error_buffer.buffer); pp_error_buffer->flush_p = false; } void gfc_diagnostics_finish (void) Index: gcc/fortran/data.c =================================================================== --- gcc/fortran/data.c (revision 223238) +++ 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_1 ("'%s' at %L already is initialized at %L", - lvalue->symtree->n.sym->name, &lvalue->where, - &init->where); + gfc_error ("%qs 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 223238) +++ gcc/fortran/expr.c (working copy) @@ -4989,11 +4989,11 @@ gfc_check_vardef_context (gfc_expr* e, b /* 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_1 ("Associate-name '%s' can not appear in a variable" + gfc_error ("Associate-name %qs 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; @@ -5031,16 +5031,16 @@ gfc_check_vardef_context (gfc_expr* e, b en = n->expr; if (gfc_dep_compare_expr (ec, en) == 0) { if (context) - gfc_error_now_1 ("Elements with the same value " - "at %L and %L in vector " - "subscript in a variable " - "definition context (%s)", - &(ec->where), &(en->where), - context); + gfc_error_now ("Elements with the same value " + "at %L and %L in vector " + "subscript in a variable " + "definition context (%s)", + &(ec->where), &(en->where), + context); return false; } } } } Index: gcc/fortran/frontend-passes.c =================================================================== --- gcc/fortran/frontend-passes.c (revision 223238) +++ gcc/fortran/frontend-passes.c (working copy) @@ -1877,23 +1877,23 @@ doloop_code (gfc_code **c, int *walk_sub if (a->expr && a->expr->symtree && a->expr->symtree->n.sym == do_sym) { if (f->sym->attr.intent == INTENT_OUT) - gfc_error_now_1 ("Variable '%s' at %L set to undefined " - "value inside loop beginning at %L as " - "INTENT(OUT) argument to subroutine '%s'", - do_sym->name, &a->expr->where, - &doloop_list[i]->loc, - co->symtree->n.sym->name); + gfc_error_now ("Variable %qs at %L set to undefined " + "value inside loop beginning at %L as " + "INTENT(OUT) argument to subroutine %qs", + do_sym->name, &a->expr->where, + &doloop_list[i]->loc, + co->symtree->n.sym->name); else if (f->sym->attr.intent == INTENT_INOUT) - gfc_error_now_1 ("Variable '%s' at %L not definable inside " - "loop beginning at %L as INTENT(INOUT) " - "argument to subroutine '%s'", - do_sym->name, &a->expr->where, - &doloop_list[i]->loc, - co->symtree->n.sym->name); + gfc_error_now ("Variable %qs at %L not definable inside " + "loop beginning at %L as INTENT(INOUT) " + "argument to subroutine %qs", + do_sym->name, &a->expr->where, + &doloop_list[i]->loc, + co->symtree->n.sym->name); } } a = a->next; f = f->next; } @@ -1949,21 +1949,21 @@ do_function (gfc_expr **e, int *walk_sub if (a->expr && a->expr->symtree && a->expr->symtree->n.sym == do_sym) { if (f->sym->attr.intent == INTENT_OUT) - gfc_error_now_1 ("Variable '%s' at %L set to undefined value " - "inside loop beginning at %L as INTENT(OUT) " - "argument to function '%s'", do_sym->name, - &a->expr->where, &doloop_list[i]->loc, - expr->symtree->n.sym->name); + gfc_error_now ("Variable %qs at %L set to undefined value " + "inside loop beginning at %L as INTENT(OUT) " + "argument to function %qs", do_sym->name, + &a->expr->where, &doloop_list[i]->loc, + expr->symtree->n.sym->name); else if (f->sym->attr.intent == INTENT_INOUT) - gfc_error_now_1 ("Variable '%s' at %L not definable inside loop" - " beginning at %L as INTENT(INOUT) argument to" - " function '%s'", do_sym->name, - &a->expr->where, &doloop_list[i]->loc, - expr->symtree->n.sym->name); + gfc_error_now ("Variable %qs at %L not definable inside loop" + " beginning at %L as INTENT(INOUT) argument to" + " function %qs", do_sym->name, + &a->expr->where, &doloop_list[i]->loc, + expr->symtree->n.sym->name); } } a = a->next; f = f->next; } Index: gcc/fortran/resolve.c =================================================================== --- gcc/fortran/resolve.c (revision 223238) +++ gcc/fortran/resolve.c (working copy) @@ -416,11 +416,11 @@ resolve_formal_arglist (gfc_symbol *proc } /* F08:C1278a. */ if (sym->ts.type == BT_CLASS && sym->attr.intent == INTENT_OUT) { - gfc_error ("INTENT(OUT) argument '%s' of pure procedure %qs at %L" + gfc_error ("INTENT(OUT) argument %qs of pure procedure %qs at %L" " may not be polymorphic", sym->name, proc->name, &sym->declared_at); continue; } } @@ -991,11 +991,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_1 ("In Fortran 2003 COMMON '%s' block at %L is a global " + gfc_error ("In Fortran 2003 COMMON %qs 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 @@ -1005,19 +1005,19 @@ resolve_common_blocks (gfc_symtree *comm } if (gsym && gsym->type != GSYM_COMMON && !common_root->n.common->binding_label) { - gfc_error_1 ("COMMON block '%s' at %L uses the same global identifier " + gfc_error ("COMMON block %qs 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_1 ("Fortran 2008: COMMON block '%s' with binding label at " + gfc_error ("Fortran 2008: COMMON block %qs 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; } @@ -1035,11 +1035,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_1 ("COMMON block at %L with binding label %s uses the same " + gfc_error ("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; } @@ -1056,11 +1056,11 @@ 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_1 ("COMMON block '%s' at %L is used as PARAMETER at %L", + gfc_error ("COMMON block %qs 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 %qs at %L can not have the EXTERNAL attribute", sym->name, &common_root->n.common->where); @@ -3366,11 +3366,11 @@ resolve_call (gfc_code *c) csym = c->symtree ? c->symtree->n.sym : NULL; if (csym && csym->ts.type != BT_UNKNOWN) { - gfc_error_1 ("'%s' at %L has a type, which is not consistent with " + gfc_error ("%qs 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) @@ -3492,12 +3492,12 @@ 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_1 ("Shapes for operands at %L and %L are not conformable", - &op1->where, &op2->where); + gfc_error ("Shapes for operands at %L and %L are not conformable", + &op1->where, &op2->where); t = false; break; } } } @@ -6783,11 +6783,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_1 ("Source-expr at %L and allocate-object at %L must " + gfc_error ("Source-expr at %L and allocate-object at %L must " "have the same shape", &e1->where, &e2->where); mpz_clear (s); return false; } } @@ -6941,25 +6941,25 @@ resolve_allocate_expr (gfc_expr *e, gfc_ if (code->expr3) { /* Check F03:C631. */ if (!gfc_type_compatible (&e->ts, &code->expr3->ts)) { - gfc_error_1 ("Type of entity at %L is type incompatible with " - "source-expr at %L", &e->where, &code->expr3->where); + gfc_error ("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_1 ("The allocate-object at %L and the source-expr at %L " - "shall have the same kind type parameter", - &e->where, &code->expr3->where); + gfc_error ("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; } /* Check F2008, C642. */ if (code->expr3->ts.type == BT_DERIVED @@ -6967,11 +6967,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_1 ("The source-expr at %L shall neither be of type " + gfc_error ("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; } @@ -7316,24 +7316,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_1 ("Allocate-object at %L also appears at %L", - &pe->where, &qe->where); + gfc_error ("Allocate-object at %L also appears at %L", + &pe->where, &qe->where); break; } else if (pr != NULL && qr == NULL) { - gfc_error_1 ("Allocate-object at %L is subobject of" - " object at %L", &pe->where, &qe->where); + gfc_error ("Allocate-object at %L is subobject of" + " object at %L", &pe->where, &qe->where); break; } else if (pr == NULL && qr != NULL) { - gfc_error_1 ("Allocate-object at %L is subobject of" - " object at %L", &qe->where, &pe->where); + gfc_error ("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) @@ -7532,11 +7532,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_1 ("CASE label at %L overlaps with CASE " + gfc_error ("CASE label at %L overlaps with CASE " "label at %L", &p->where, &q->where); overlap_seen = 1; e = p; p = p->right; psize--; @@ -7770,11 +7770,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_1 ("The DEFAULT CASE at %L cannot be followed " + gfc_error ("The DEFAULT CASE at %L cannot be followed " "by a second DEFAULT CASE at %L", &default_case->where, &cp->where); t = false; break; } @@ -8143,11 +8143,11 @@ resolve_select_type (gfc_code *code, gfc if (c->ts.type == BT_UNKNOWN) { /* Check F03:C818. */ if (default_case) { - gfc_error_1 ("The DEFAULT CASE at %L cannot be followed " + gfc_error ("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; } @@ -8706,11 +8706,11 @@ resolve_branch (gfc_st_label *label, gfc return; } if (label->defined != ST_LABEL_TARGET && label->defined != ST_LABEL_DO_TARGET) { - gfc_error_1 ("Statement at %L is not a valid branch target statement " + gfc_error ("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 ;-) */ @@ -8733,15 +8733,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_1 ("GOTO statement at %L leaves CRITICAL construct for " + gfc_error ("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_1 ("GOTO statement at %L leaves DO CONCURRENT construct " + gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct " "for label at %L", &code->loc, &label->where); } return; } @@ -8756,17 +8756,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_1 ("GOTO statement at %L leaves CRITICAL construct for label" + gfc_error ("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_1 ("GOTO statement at %L leaves DO CONCURRENT construct for " + gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for " "label at %L", &code->loc, &label->where); return; } } @@ -10543,11 +10543,11 @@ gfc_verify_binding_labels (gfc_symbol *s return; } if (sym->attr.flavor == FL_VARIABLE && gsym->type != GSYM_UNKNOWN) { - gfc_error_1 ("Variable %s with binding label %s at %L uses the same global " + gfc_error ("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; @@ -10556,11 +10556,11 @@ 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_1 ("Variable %s from module %s with binding label %s at %L uses " + 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", sym->name, module, sym->binding_label, &sym->declared_at, &gsym->where, gsym->mod_name); sym->binding_label = NULL; } @@ -10573,11 +10573,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_1 ("Procedure %s with binding label %s at %L uses the same " + gfc_error ("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; } } @@ -11073,11 +11073,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_1 ("The type '%s' cannot be host associated at %L " + gfc_error ("The type %qs 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; @@ -11143,11 +11143,11 @@ resolve_fl_variable (gfc_symbol *sym, in && !sym->attr.pointer && is_non_constant_shape_array (sym)) { /* The shape of a main program or module array needs to be constant. */ - gfc_error ("The module or main program array '%s' at %L must " + gfc_error ("The module or main program array %qs at %L must " "have constant shape", sym->name, &sym->declared_at); specification_expr = saved_specification_expr; return false; } @@ -11192,11 +11192,11 @@ resolve_fl_variable (gfc_symbol *sym, in { if (!sym->attr.use_assoc && sym->ns->proc_name && (sym->ns->proc_name->attr.flavor == FL_MODULE || sym->ns->proc_name->attr.is_main_program)) { - gfc_error ("'%s' at %L must have constant character length " + gfc_error ("%qs at %L must have constant character length " "in this context", sym->name, &sym->declared_at); specification_expr = saved_specification_expr; return false; } if (sym->attr.in_common) Index: gcc/fortran/f95-lang.c =================================================================== --- gcc/fortran/f95-lang.c (revision 223238) +++ gcc/fortran/f95-lang.c (working copy) @@ -219,22 +219,14 @@ gfc_create_decls (void) static void gfc_be_parse_file (void) { - int errors; - int warnings; - gfc_create_decls (); gfc_parse_file (); gfc_generate_constructors (); - /* Tell the frontend about any errors. */ - gfc_get_errors (&warnings, &errors); - errorcount += errors; - warningcount += warnings; - /* Clear the binding level stack. */ while (!global_bindings_p ()) poplevel (0, 0); /* Switch to the default tree diagnostics here, because there may be Index: gcc/fortran/match.c =================================================================== --- gcc/fortran/match.c (revision 223238) +++ gcc/fortran/match.c (working copy) @@ -3594,11 +3594,11 @@ alloc_opt_list: } /* The next 2 conditionals check C631. */ if (ts.type != BT_UNKNOWN) { - gfc_error_1 ("SOURCE tag at %L conflicts with the typespec at %L", + gfc_error ("SOURCE tag at %L conflicts with the typespec at %L", &tmp->where, &old_locus); goto cleanup; } if (head->next @@ -3631,11 +3631,11 @@ alloc_opt_list: } /* Check F08:C637. */ if (ts.type != BT_UNKNOWN) { - gfc_error_1 ("MOLD tag at %L conflicts with the typespec at %L", + gfc_error ("MOLD tag at %L conflicts with the typespec at %L", &tmp->where, &old_locus); goto cleanup; } mold = tmp; @@ -3657,12 +3657,12 @@ alloc_opt_list: goto syntax; /* Check F08:C637. */ if (source && mold) { - gfc_error_1 ("MOLD tag at %L conflicts with SOURCE tag at %L", - &mold->where, &source->where); + gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L", + &mold->where, &source->where); goto cleanup; } /* Check F03:C623, */ if (saw_deferred && ts.type == BT_UNKNOWN && !source && !mold) @@ -4345,16 +4345,16 @@ gfc_match_common (void) if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1) { /* If we find an error, just print it and continue, cause it's just semantic, and we can see if there are more errors. */ - gfc_error_now_1 ("Variable '%s' at %L in common block '%s' " - "at %C must be declared with a C " - "interoperable kind since common block " - "'%s' is bind(c)", - sym->name, &(sym->declared_at), t->name, - t->name); + gfc_error_now ("Variable %qs at %L in common block %qs " + "at %C must be declared with a C " + "interoperable kind since common block " + "%qs is bind(c)", + sym->name, &(sym->declared_at), t->name, + t->name); } if (sym->attr.is_bind_c == 1) gfc_error_now ("Variable %qs in common block %qs at %C can not " "be bind(c) since it is not global", sym->name, @@ -4884,22 +4884,21 @@ 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_1; - output_buffer old_error; + gfc_error_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, &old_error_1); + gfc_push_error (&old_error); 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) @@ -4907,11 +4906,11 @@ gfc_match_st_function (void) m = gfc_match (" = %e%t", &expr); if (m == MATCH_NO) goto undo_error; - gfc_free_error (&old_error, &old_error_1); + gfc_free_error (&old_error); if (m == MATCH_ERROR) return m; if (recursive_stmt_fcn (expr, sym)) @@ -4926,11 +4925,11 @@ gfc_match_st_function (void) return MATCH_ERROR; return MATCH_YES; undo_error: - gfc_pop_error (&old_error, &old_error_1); + gfc_pop_error (&old_error); return MATCH_NO; } /***************** SELECT CASE subroutines ******************/ Index: gcc/fortran/parse.c =================================================================== --- gcc/fortran/parse.c (revision 223238) +++ gcc/fortran/parse.c (working copy) @@ -106,18 +106,17 @@ 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_1; - output_buffer old_error; + gfc_error_buffer old_error; - gfc_push_error (&old_error, &old_error_1); + gfc_push_error (&old_error); gfc_buffer_error (false); gfc_use_modules (); gfc_buffer_error (true); - gfc_pop_error (&old_error, &old_error_1); + gfc_pop_error (&old_error); 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; gfc_current_ns->old_data = gfc_current_ns->data; @@ -2434,11 +2433,11 @@ verify_st_order (st_state *p, gfc_statem p->last_statement = st; return true; order: if (!silent) - gfc_error_1 ("%s statement at %C cannot follow %s statement at %L", + gfc_error ("%s statement at %C cannot follow %s statement at %L", gfc_ascii_statement (st), gfc_ascii_statement (p->last_statement), &p->where); return false; } @@ -2811,11 +2810,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_1 ("Noncoarray component %s at %L of type LOCK_TYPE or with " + gfc_error ("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); @@ -3526,11 +3525,11 @@ parse_if_block (void) unexpected_eof (); case ST_ELSEIF: if (seen_else) { - gfc_error_1 ("ELSE IF statement at %C cannot follow ELSE " + gfc_error ("ELSE IF statement at %C cannot follow ELSE " "statement at %L", &else_locus); reject_statement (); break; } @@ -3750,12 +3749,12 @@ gfc_check_do_variable (gfc_symtree *st) gfc_state_data *s; for (s=gfc_state_stack; s; s = s->previous) if (s->do_variable == st) { - gfc_error_now_1 ("Variable '%s' at %C cannot be redefined inside " - "loop beginning at %L", st->name, &s->head->loc); + gfc_error_now ("Variable %qs at %C cannot be redefined inside " + "loop beginning at %L", st->name, &s->head->loc); return 1; } return 0; } @@ -5069,14 +5068,14 @@ gfc_global_used (gfc_gsymbol *sym, locus gfc_internal_error ("gfc_global_used(): Bad type"); name = NULL; } if (sym->binding_label) - gfc_error_1 ("Global binding name '%s' at %L is already being used as a %s " + gfc_error ("Global binding name %qs at %L is already being used as a %s " "at %L", sym->binding_label, where, name, &sym->where); else - gfc_error_1 ("Global name '%s' at %L is already being used as a %s at %L", + gfc_error ("Global name %qs at %L is already being used as a %s at %L", sym->name, where, name, &sym->where); } /* Parse a block data program unit. */ @@ -5542,11 +5541,11 @@ prog_units: duplicate_main: /* If we see a duplicate main program, shut down. If the second instance is an implied main program, i.e. data decls or executable statements, we're in for lots of errors. */ - gfc_error_1 ("Two main PROGRAMs at %L and %C", &prog_locus); + gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus); reject_statement (); gfc_done_2 (); return true; } Index: gcc/fortran/check.c =================================================================== --- gcc/fortran/check.c (revision 223238) +++ gcc/fortran/check.c (working copy) @@ -1029,12 +1029,12 @@ gfc_check_atomic (gfc_expr *atom, int at return false; } if (atom->ts.type != value->ts.type) { - 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_error ("%qs argument of %qs intrinsic at %L shall have the same " + "type as %qs 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; } @@ -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_1 ("A argument at %L has type %s but the function passed as " + gfc_error ("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_1 ("The character length of the A argument at %L and of the " - "arguments of the OPERATOR at %L shall be the same", + gfc_error ("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_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); + 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); 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_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); + gfc_error ("%qs argument of %qs 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); } @@ -1954,11 +1954,11 @@ 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_1 ("'I' at %L and 'J' at %L cannot both be BOZ literal " + gfc_error ("%<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)) @@ -2470,13 +2470,13 @@ gfc_check_ishftc (gfc_expr *i, gfc_expr if (i2 < 0) i2 = -i2; if (i2 > i3) { - gfc_error_1 ("The absolute value of SHIFT at %L must be less " - "than or equal to SIZE at %L", &shift->where, - &size->where); + gfc_error ("The absolute value of SHIFT at %L must be less " + "than or equal to SIZE at %L", &shift->where, + &size->where); return false; } } } } Index: gcc/fortran/primary.c =================================================================== --- gcc/fortran/primary.c (revision 223238) +++ gcc/fortran/primary.c (working copy) @@ -1272,12 +1272,11 @@ match_complex_part (gfc_expr **result) static match match_complex_constant (gfc_expr **result) { gfc_expr *e, *real, *imag; - gfc_error_buf old_error_1; - output_buffer old_error; + gfc_error_buffer old_error; gfc_typespec target; locus old_loc; int kind; match m; @@ -1286,22 +1285,22 @@ match_complex_constant (gfc_expr **resul m = gfc_match_char ('('); if (m != MATCH_YES) return m; - gfc_push_error (&old_error, &old_error_1); + gfc_push_error (&old_error); m = match_complex_part (&real); if (m == MATCH_NO) { - gfc_free_error (&old_error, &old_error_1); + gfc_free_error (&old_error); goto cleanup; } if (gfc_match_char (',') == MATCH_NO) { - gfc_pop_error (&old_error, &old_error_1); + gfc_pop_error (&old_error); m = MATCH_NO; goto cleanup; } /* If m is error, then something was wrong with the real part and we @@ -1309,14 +1308,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, &old_error_1); + gfc_free_error (&old_error); goto cleanup; } - gfc_pop_error (&old_error, &old_error_1); + gfc_pop_error (&old_error); m = match_complex_part (&imag); if (m == MATCH_NO) goto syntax; if (m == MATCH_ERROR)