PR fortran/44054 Convert all gfc_error_1 calls to gfc_error
Manuel López-Ibáñez
lopezibanez@gmail.com
Sun May 17 19:11:00 GMT 2015
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 <manu@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.
-------------- next part --------------
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)
More information about the Gcc-patches
mailing list