+2015-05-24 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.
+
2015-05-22 Jim Wilson <jim.wilson@linaro.org>
* Make-lang.in (check_gfortran_parallelize): Update comment.
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;
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));
&& ((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;
}
}
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);
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 (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;
}
}
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;
}
&& 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
&& 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)
&& !(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;
}
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;
gfc_error_init_1 (void)
{
terminal_width = gfc_get_terminal_width ();
- errors = 0;
- warnings = 0;
gfc_buffer_error (false);
}
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. */
}
}
-/* 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
/* 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);
void
gfc_clear_warning (void)
{
- warning_buffer.flag = 0;
-
gfc_clear_pp_buffer (pp_warning_buffer);
warningcount_buffered = 0;
werrorcount_buffered = 0;
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;
/* 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)
}
-/* 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
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;
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
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;
/* 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));
}
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;
}
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;
}
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,
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;
}
}
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);
&& 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;
&& 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;
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_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);
#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);
/* 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;
}
/* 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;
}
/* 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;
}
/* 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)
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;
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 (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;
return MATCH_YES;
undo_error:
- gfc_pop_error (&old_error, &old_error_1);
+ gfc_pop_error (&old_error);
return MATCH_NO;
}
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;
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);
"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 "
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 ();
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;
}
}
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);
}
/* 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;
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;
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 == 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)
/* 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;
|| (!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,
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);
}
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);
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;
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)
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 (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;
}
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;
/* 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: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;
}
&& 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);
{
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 */
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;
{
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;
/* 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++;
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;
}
{
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);
}
{
/* 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;
}
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. */
{
/* 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);
/* 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;
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,
{
/* 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;
&& (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 (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
{
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;
}
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;
}
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
{
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;
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;
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);
}
projects / gcc.git / commitdiff