git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/44054 (Handle -Werror, -Werror=, -fdiagnostics-show-option, !GCC$ diagnostic (pragmas) and color) 

gcc/fortran/ChangeLog:

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.

From-SVN: r223614
This commit is contained in:
Manuel López-Ibáñez 2015-05-23 23:02:52 +00:00
parent 84a3423b97
commit fea70c9963
15 changed files with 211 additions and 363 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
gcc/fortran/ChangeLog
View File

@ -1,3 +1,35 @@
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> 2015-05-22 Jim Wilson <jim.wilson@linaro.org>
* Make-lang.in (check_gfortran_parallelize): Update comment. * Make-lang.in (check_gfortran_parallelize): Update comment.

16
gcc/fortran/check.c
View File

@ -1031,8 +1031,8 @@ gfc_check_atomic (gfc_expr *atom, int atom_no, gfc_expr *value, int val_no,
if (atom->ts.type != value->ts.type) if (atom->ts.type != value->ts.type)
{ {
gfc_error_1 ("'%s' argument of '%s' intrinsic at %L shall have the same " gfc_error ("%qs argument of %qs intrinsic at %L shall have the same "
"type as '%s' at %L", gfc_current_intrinsic_arg[val_no]->name, "type as %qs at %L", gfc_current_intrinsic_arg[val_no]->name,
gfc_current_intrinsic, &value->where, gfc_current_intrinsic, &value->where,
gfc_current_intrinsic_arg[atom_no]->name, &atom->where); gfc_current_intrinsic_arg[atom_no]->name, &atom->where);
return false; return false;
@ -1575,7 +1575,7 @@ gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image,
if (!gfc_compare_types (&a->ts, &sym->result->ts)) 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", "OPERATOR at %L returns %s",
&a->where, gfc_typename (&a->ts), &op->where, &a->where, gfc_typename (&a->ts), &op->where,
gfc_typename (&sym->result->ts)); gfc_typename (&sym->result->ts));
@ -1655,14 +1655,14 @@ gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image,
&& ((formal_size1 && actual_size != formal_size1) && ((formal_size1 && actual_size != formal_size1)
|| (formal_size2 && actual_size != formal_size2))) || (formal_size2 && actual_size != formal_size2)))
{ {
gfc_error_1 ("The character length of the A argument at %L and of the " gfc_error ("The character length of the A argument at %L and of the "
"arguments of the OPERATOR at %L shall be the same", "arguments of the OPERATOR at %L shall be the same",
&a->where, &op->where); &a->where, &op->where);
return false; return false;
} }
if (actual_size && result_size && actual_size != result_size) if (actual_size && result_size && actual_size != result_size)
{ {
gfc_error_1 ("The character length of the A argument at %L and of the " 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", "function result of the OPERATOR at %L shall be the same",
&a->where, &op->where); &a->where, &op->where);
return false; return false;
@ -1680,7 +1680,7 @@ gfc_check_co_minmax (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat,
if (a->ts.type != BT_INTEGER && a->ts.type != BT_REAL if (a->ts.type != BT_INTEGER && a->ts.type != BT_REAL
&& a->ts.type != BT_CHARACTER) && a->ts.type != BT_CHARACTER)
{ {
gfc_error_1 ("'%s' argument of '%s' intrinsic at %L shall be of type " gfc_error ("%qs argument of %qs intrinsic at %L shall be of type "
"integer, real or character", "integer, real or character",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&a->where); &a->where);
@ -1956,7 +1956,7 @@ gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift)
if (i->is_boz && j->is_boz) 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); "constants", &i->where, &j->where);
return false; return false;
} }
@ -2472,7 +2472,7 @@ gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size)
if (i2 > i3) if (i2 > i3)
{ {
gfc_error_1 ("The absolute value of SHIFT at %L must be less " gfc_error ("The absolute value of SHIFT at %L must be less "
"than or equal to SIZE at %L", &shift->where, "than or equal to SIZE at %L", &shift->where,
&size->where); &size->where);
return false; return false;

2
gcc/fortran/data.c
View File

@ -253,7 +253,7 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index,
if (init && expr->expr_type != EXPR_ARRAY) if (init && expr->expr_type != EXPR_ARRAY)
{ {
gfc_error_1 ("'%s' at %L already is initialized at %L", gfc_error ("%qs at %L already is initialized at %L",
lvalue->symtree->n.sym->name, &lvalue->where, lvalue->symtree->n.sym->name, &lvalue->where,
&init->where); &init->where);
goto abort; goto abort;

8
gcc/fortran/decl.c
View File

@ -921,7 +921,7 @@ get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
&& sym->attr.proc != 0 && sym->attr.proc != 0
&& (sym->attr.subroutine || sym->attr.function) && (sym->attr.subroutine || sym->attr.function)
&& sym->attr.if_source != IFSRC_UNKNOWN) && sym->attr.if_source != IFSRC_UNKNOWN)
gfc_error_now_1 ("Procedure '%s' at %C is already defined at %L", gfc_error_now ("Procedure %qs at %C is already defined at %L",
name, &sym->declared_at); name, &sym->declared_at);
/* Trap a procedure with a name the same as interface in the /* Trap a procedure with a name the same as interface in the
@ -929,7 +929,7 @@ get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
if (sym->attr.generic != 0 if (sym->attr.generic != 0
&& (sym->attr.subroutine || sym->attr.function) && (sym->attr.subroutine || sym->attr.function)
&& !sym->attr.mod_proc) && !sym->attr.mod_proc)
gfc_error_now_1 ("Name '%s' at %C is already defined" gfc_error_now ("Name %qs at %C is already defined"
" as a generic interface at %L", " as a generic interface at %L",
name, &sym->declared_at); name, &sym->declared_at);
@ -942,7 +942,7 @@ get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
&& gfc_current_ns->parent != NULL && gfc_current_ns->parent != NULL
&& sym->attr.access == 0 && sym->attr.access == 0
&& !module_fcn_entry) && !module_fcn_entry)
gfc_error_now_1 ("Procedure '%s' at %C has an explicit interface " gfc_error_now ("Procedure %qs at %C has an explicit interface "
"and must not have attributes declared at %L", "and must not have attributes declared at %L",
name, &sym->declared_at); name, &sym->declared_at);
} }
@ -2868,7 +2868,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
&& !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic)) && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic))
|| sym->attr.subroutine) || sym->attr.subroutine)
{ {
gfc_error_1 ("Type name '%s' at %C conflicts with previously declared " gfc_error ("Type name %qs at %C conflicts with previously declared "
"entity at %L, which has the same name", name, "entity at %L, which has the same name", name,
&sym->declared_at); &sym->declared_at);
return MATCH_ERROR; return MATCH_ERROR;

230
gcc/fortran/error.c
View File

@ -40,12 +40,12 @@ static int suppress_errors = 0;
static bool warnings_not_errors = false; static bool warnings_not_errors = false;
static int terminal_width, errors, warnings; static int terminal_width;
static gfc_error_buf error_buffer, warning_buffer, *cur_error_buffer;
/* True if the error/warnings should be buffered. */ /* True if the error/warnings should be buffered. */
static bool buffered_p; static bool buffered_p;
static gfc_error_buffer error_buffer;
/* These are always buffered buffers (.flush_p == false) to be used by /* These are always buffered buffers (.flush_p == false) to be used by
the pretty-printer. */ the pretty-printer. */
static output_buffer *pp_error_buffer, *pp_warning_buffer; static output_buffer *pp_error_buffer, *pp_warning_buffer;
@ -100,8 +100,6 @@ void
gfc_error_init_1 (void) gfc_error_init_1 (void)
{ {
terminal_width = gfc_get_terminal_width (); terminal_width = gfc_get_terminal_width ();
errors = 0;
warnings = 0;
gfc_buffer_error (false); gfc_buffer_error (false);
} }
@ -119,42 +117,9 @@ gfc_buffer_error (bool flag)
buffered_p. */ buffered_p. */
static void static void
error_char (char c) error_char (char)
{ {
if (buffered_p) /* FIXME: Unused function to be removed in a subsequent patch. */
{
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;
}
}
}
} }
@ -782,18 +747,6 @@ error_printf (const char *gmsgid, ...)
} }
/* 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. */ /* Clear any output buffered in a pretty-print output_buffer. */
static void static void
@ -1247,9 +1200,6 @@ gfc_warning_now (int opt, const char *gmsgid, ...)
/* Immediate error (i.e. do not buffer). */ /* 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 void
gfc_error_now (const char *gmsgid, ...) gfc_error_now (const char *gmsgid, ...)
@ -1257,6 +1207,8 @@ gfc_error_now (const char *gmsgid, ...)
va_list argp; va_list argp;
diagnostic_info diagnostic; diagnostic_info diagnostic;
error_buffer.flag = true;
va_start (argp, gmsgid); va_start (argp, gmsgid);
diagnostic_set_info (&diagnostic, gmsgid, &argp, UNKNOWN_LOCATION, DK_ERROR); diagnostic_set_info (&diagnostic, gmsgid, &argp, UNKNOWN_LOCATION, DK_ERROR);
report_diagnostic (&diagnostic); report_diagnostic (&diagnostic);
@ -1285,8 +1237,6 @@ gfc_fatal_error (const char *gmsgid, ...)
void void
gfc_clear_warning (void) gfc_clear_warning (void)
{ {
warning_buffer.flag = 0;
gfc_clear_pp_buffer (pp_warning_buffer); gfc_clear_pp_buffer (pp_warning_buffer);
warningcount_buffered = 0; warningcount_buffered = 0;
werrorcount_buffered = 0; werrorcount_buffered = 0;
@ -1299,15 +1249,8 @@ gfc_clear_warning (void)
void void
gfc_warning_check (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. */ /* 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; pretty_printer *pp = global_dc->printer;
output_buffer *tmp_buffer = pp->buffer; output_buffer *tmp_buffer = pp->buffer;
@ -1325,62 +1268,6 @@ gfc_warning_check (void)
/* Issue an error. */ /* 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 static void
gfc_error (const char *gmsgid, va_list ap) gfc_error (const char *gmsgid, va_list ap)
@ -1440,38 +1327,6 @@ gfc_error (const char *gmsgid, ...)
} }
/* 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. */ /* This shouldn't happen... but sometimes does. */
void void
@ -1516,24 +1371,10 @@ gfc_error_flag_test (void)
bool bool
gfc_error_check (void) gfc_error_check (void)
{ {
bool error_raised = (bool) error_buffer.flag; if (error_buffer.flag
|| ! gfc_output_buffer_empty_p (pp_error_buffer))
if (error_raised)
{ {
if (error_buffer.message != NULL) error_buffer.flag = false;
fputs (error_buffer.message, stderr);
error_buffer.flag = 0;
gfc_clear_pp_buffer (pp_error_buffer);
gfc_increment_error_count();
if (flag_fatal_errors)
exit (FATAL_EXIT_CODE);
}
/* This is for the new diagnostics machinery. */
else if (! gfc_output_buffer_empty_p (pp_error_buffer))
{
error_raised = true;
pretty_printer *pp = global_dc->printer; pretty_printer *pp = global_dc->printer;
output_buffer *tmp_buffer = pp->buffer; output_buffer *tmp_buffer = pp->buffer;
pp->buffer = pp_error_buffer; pp->buffer = pp_error_buffer;
@ -1542,9 +1383,10 @@ gfc_error_check (void)
gcc_assert (gfc_output_buffer_empty_p (pp_error_buffer)); gcc_assert (gfc_output_buffer_empty_p (pp_error_buffer));
diagnostic_action_after_output (global_dc, DK_ERROR); diagnostic_action_after_output (global_dc, DK_ERROR);
pp->buffer = tmp_buffer; pp->buffer = tmp_buffer;
return true;
} }
return error_raised; return false;
} }
/* Move the text buffered from FROM to TO, then clear /* Move the text buffered from FROM to TO, then clear
@ -1552,8 +1394,15 @@ gfc_error_check (void)
cleared. */ cleared. */
static void 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); gfc_clear_pp_buffer (to);
/* We make sure this is always buffered. */ /* We make sure this is always buffered. */
to->flush_p = false; to->flush_p = false;
@ -1569,46 +1418,27 @@ gfc_move_output_buffer_from_to (output_buffer *from, output_buffer *to)
/* Save the existing error state. */ /* Save the existing error state. */
void void
gfc_push_error (output_buffer *buffer_err, gfc_error_buf *err) gfc_push_error (gfc_error_buffer *err)
{ {
err->flag = error_buffer.flag; gfc_move_error_buffer_from_to (&error_buffer, err);
if (error_buffer.flag)
err->message = xstrdup (error_buffer.message);
error_buffer.flag = 0;
/* This part uses the common diagnostics. */
gfc_move_output_buffer_from_to (pp_error_buffer, buffer_err);
} }
/* Restore a previous pushed error state. */ /* Restore a previous pushed error state. */
void void
gfc_pop_error (output_buffer *buffer_err, gfc_error_buf *err) gfc_pop_error (gfc_error_buffer *err)
{ {
error_buffer.flag = err->flag; gfc_move_error_buffer_from_to (err, &error_buffer);
if (error_buffer.flag)
{
size_t len = strlen (err->message) + 1;
gcc_assert (len <= error_buffer.allocated);
memcpy (error_buffer.message, err->message, len);
free (err->message);
}
/* This part uses the common diagnostics. */
gfc_move_output_buffer_from_to (buffer_err, pp_error_buffer);
} }
/* Free a pushed error state, but keep the current error state. */ /* Free a pushed error state, but keep the current error state. */
void void
gfc_free_error (output_buffer *buffer_err, gfc_error_buf *err) gfc_free_error (gfc_error_buffer *err)
{ {
if (err->flag) gfc_clear_pp_buffer (&(err->buffer));
free (err->message);
gfc_clear_pp_buffer (buffer_err);
} }
@ -1618,9 +1448,9 @@ void
gfc_get_errors (int *w, int *e) gfc_get_errors (int *w, int *e)
{ {
if (w != NULL) if (w != NULL)
*w = warnings + warningcount + werrorcount; *w = warningcount + werrorcount;
if (e != NULL) if (e != NULL)
*e = errors + errorcount + sorrycount + werrorcount; *e = errorcount + sorrycount + werrorcount;
} }
@ -1642,7 +1472,7 @@ gfc_diagnostics_init (void)
global_dc->caret_chars[1] = '2'; global_dc->caret_chars[1] = '2';
pp_warning_buffer = new (XNEW (output_buffer)) output_buffer (); pp_warning_buffer = new (XNEW (output_buffer)) output_buffer ();
pp_warning_buffer->flush_p = false; 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; pp_error_buffer->flush_p = false;
} }

4
gcc/fortran/expr.c
View File

@ -4994,7 +4994,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
if (!gfc_check_vardef_context (assoc->target, pointer, false, false, NULL)) if (!gfc_check_vardef_context (assoc->target, pointer, false, false, NULL))
{ {
if (context) 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" " definition context (%s) at %L because its target"
" at %L can not, either", " at %L can not, either",
name, context, &e->where, name, context, &e->where,
@ -5036,7 +5036,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
if (gfc_dep_compare_expr (ec, en) == 0) if (gfc_dep_compare_expr (ec, en) == 0)
{ {
if (context) if (context)
gfc_error_now_1 ("Elements with the same value " gfc_error_now ("Elements with the same value "
"at %L and %L in vector " "at %L and %L in vector "
"subscript in a variable " "subscript in a variable "
"definition context (%s)", "definition context (%s)",

8
gcc/fortran/f95-lang.c
View File

@ -221,18 +221,10 @@ gfc_create_decls (void)
static void static void
gfc_be_parse_file (void) gfc_be_parse_file (void)
{ {
int errors;
int warnings;
gfc_create_decls (); gfc_create_decls ();
gfc_parse_file (); gfc_parse_file ();
gfc_generate_constructors (); gfc_generate_constructors ();
/* Tell the frontend about any errors. */
gfc_get_errors (&warnings, &errors);
errorcount += errors;
warningcount += warnings;
/* Clear the binding level stack. */ /* Clear the binding level stack. */
while (!global_bindings_p ()) while (!global_bindings_p ())
poplevel (0, 0); poplevel (0, 0);

16
gcc/fortran/frontend-passes.c
View File

@ -1879,16 +1879,16 @@ doloop_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
&& a->expr->symtree->n.sym == do_sym) && a->expr->symtree->n.sym == do_sym)
{ {
if (f->sym->attr.intent == INTENT_OUT) if (f->sym->attr.intent == INTENT_OUT)
gfc_error_now_1 ("Variable '%s' at %L set to undefined " gfc_error_now ("Variable %qs at %L set to undefined "
"value inside loop beginning at %L as " "value inside loop beginning at %L as "
"INTENT(OUT) argument to subroutine '%s'", "INTENT(OUT) argument to subroutine %qs",
do_sym->name, &a->expr->where, do_sym->name, &a->expr->where,
&doloop_list[i]->loc, &doloop_list[i]->loc,
co->symtree->n.sym->name); co->symtree->n.sym->name);
else if (f->sym->attr.intent == INTENT_INOUT) else if (f->sym->attr.intent == INTENT_INOUT)
gfc_error_now_1 ("Variable '%s' at %L not definable inside " gfc_error_now ("Variable %qs at %L not definable inside "
"loop beginning at %L as INTENT(INOUT) " "loop beginning at %L as INTENT(INOUT) "
"argument to subroutine '%s'", "argument to subroutine %qs",
do_sym->name, &a->expr->where, do_sym->name, &a->expr->where,
&doloop_list[i]->loc, &doloop_list[i]->loc,
co->symtree->n.sym->name); co->symtree->n.sym->name);
@ -1951,15 +1951,15 @@ do_function (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
&& a->expr->symtree->n.sym == do_sym) && a->expr->symtree->n.sym == do_sym)
{ {
if (f->sym->attr.intent == INTENT_OUT) if (f->sym->attr.intent == INTENT_OUT)
gfc_error_now_1 ("Variable '%s' at %L set to undefined value " gfc_error_now ("Variable %qs at %L set to undefined value "
"inside loop beginning at %L as INTENT(OUT) " "inside loop beginning at %L as INTENT(OUT) "
"argument to function '%s'", do_sym->name, "argument to function %qs", do_sym->name,
&a->expr->where, &doloop_list[i]->loc, &a->expr->where, &doloop_list[i]->loc,
expr->symtree->n.sym->name); expr->symtree->n.sym->name);
else if (f->sym->attr.intent == INTENT_INOUT) else if (f->sym->attr.intent == INTENT_INOUT)
gfc_error_now_1 ("Variable '%s' at %L not definable inside loop" gfc_error_now ("Variable %qs at %L not definable inside loop"
" beginning at %L as INTENT(INOUT) argument to" " beginning at %L as INTENT(INOUT) argument to"
" function '%s'", do_sym->name, " function %qs", do_sym->name,
&a->expr->where, &doloop_list[i]->loc, &a->expr->where, &doloop_list[i]->loc,
expr->symtree->n.sym->name); expr->symtree->n.sym->name);
} }

23
gcc/fortran/gfortran.h
View File

@ -2645,14 +2645,6 @@ const char * gfc_get_string (const char *, ...) ATTRIBUTE_PRINTF_1;
bool gfc_find_sym_in_expr (gfc_symbol *, gfc_expr *); bool gfc_find_sym_in_expr (gfc_symbol *, gfc_expr *);
/* error.c */ /* 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_error_init_1 (void);
void gfc_diagnostics_init (void); void gfc_diagnostics_init (void);
void gfc_diagnostics_finish (void); void gfc_diagnostics_finish (void);
@ -2668,9 +2660,7 @@ bool gfc_warning_now_at (location_t loc, int opt, const char *gmsgid, ...)
void gfc_clear_warning (void); void gfc_clear_warning (void);
void gfc_warning_check (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 (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_error_now (const char *, ...) ATTRIBUTE_GCC_GFC(1,2);
void gfc_fatal_error (const char *, ...) ATTRIBUTE_NORETURN 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_internal_error (const char *, ...) ATTRIBUTE_NORETURN ATTRIBUTE_GCC_GFC(1,2);
@ -2686,9 +2676,16 @@ bool gfc_notify_std (int, const char *, ...) ATTRIBUTE_GCC_GFC(2,3);
gfc_error ("Syntax error in %s statement at %C", gfc_ascii_statement (ST)); gfc_error ("Syntax error in %s statement at %C", gfc_ascii_statement (ST));
#include "pretty-print.h" /* For output_buffer. */ #include "pretty-print.h" /* For output_buffer. */
void gfc_push_error (output_buffer *, gfc_error_buf *); struct gfc_error_buffer
void gfc_pop_error (output_buffer *, gfc_error_buf *); {
void gfc_free_error (output_buffer *, gfc_error_buf *); 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_get_errors (int *, int *);
void gfc_errors_to_warnings (bool); void gfc_errors_to_warnings (bool);

19
gcc/fortran/match.c
View File

@ -3599,7 +3599,7 @@ alloc_opt_list:
/* The next 2 conditionals check C631. */ /* The next 2 conditionals check C631. */
if (ts.type != BT_UNKNOWN) 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); &tmp->where, &old_locus);
goto cleanup; goto cleanup;
} }
@ -3636,7 +3636,7 @@ alloc_opt_list:
/* Check F08:C637. */ /* Check F08:C637. */
if (ts.type != BT_UNKNOWN) 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); &tmp->where, &old_locus);
goto cleanup; goto cleanup;
} }
@ -3662,7 +3662,7 @@ alloc_opt_list:
/* Check F08:C637. */ /* Check F08:C637. */
if (source && mold) if (source && mold)
{ {
gfc_error_1 ("MOLD tag at %L conflicts with SOURCE tag at %L", gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
&mold->where, &source->where); &mold->where, &source->where);
goto cleanup; goto cleanup;
} }
@ -4350,10 +4350,10 @@ gfc_match_common (void)
/* If we find an error, just print it and continue, /* If we find an error, just print it and continue,
cause it's just semantic, and we can see if there cause it's just semantic, and we can see if there
are more errors. */ are more errors. */
gfc_error_now_1 ("Variable '%s' at %L in common block '%s' " gfc_error_now ("Variable %qs at %L in common block %qs "
"at %C must be declared with a C " "at %C must be declared with a C "
"interoperable kind since common block " "interoperable kind since common block "
"'%s' is bind(c)", "%qs is bind(c)",
sym->name, &(sym->declared_at), t->name, sym->name, &(sym->declared_at), t->name,
t->name); t->name);
} }
@ -4889,8 +4889,7 @@ recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
match match
gfc_match_st_function (void) gfc_match_st_function (void)
{ {
gfc_error_buf old_error_1; gfc_error_buffer old_error;
output_buffer old_error;
gfc_symbol *sym; gfc_symbol *sym;
gfc_expr *expr; gfc_expr *expr;
@ -4900,7 +4899,7 @@ gfc_match_st_function (void)
if (m != MATCH_YES) if (m != MATCH_YES)
return m; 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)) if (!gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, sym->name, NULL))
goto undo_error; goto undo_error;
@ -4912,7 +4911,7 @@ gfc_match_st_function (void)
if (m == MATCH_NO) if (m == MATCH_NO)
goto undo_error; goto undo_error;
gfc_free_error (&old_error, &old_error_1); gfc_free_error (&old_error);
if (m == MATCH_ERROR) if (m == MATCH_ERROR)
return m; return m;
@ -4931,7 +4930,7 @@ gfc_match_st_function (void)
return MATCH_YES; return MATCH_YES;
undo_error: undo_error:
gfc_pop_error (&old_error, &old_error_1); gfc_pop_error (&old_error);
return MATCH_NO; return MATCH_NO;
} }

21
gcc/fortran/parse.c
View File

@ -108,14 +108,13 @@ match_word_omp_simd (const char *str, match (*subr) (void), locus *old_locus,
static void static void
use_modules (void) use_modules (void)
{ {
gfc_error_buf old_error_1; gfc_error_buffer old_error;
output_buffer old_error;
gfc_push_error (&old_error, &old_error_1); gfc_push_error (&old_error);
gfc_buffer_error (false); gfc_buffer_error (false);
gfc_use_modules (); gfc_use_modules ();
gfc_buffer_error (true); gfc_buffer_error (true);
gfc_pop_error (&old_error, &old_error_1); gfc_pop_error (&old_error);
gfc_commit_symbols (); gfc_commit_symbols ();
gfc_warning_check (); gfc_warning_check ();
gfc_current_ns->old_cl_list = gfc_current_ns->cl_list; gfc_current_ns->old_cl_list = gfc_current_ns->cl_list;
@ -2435,7 +2434,7 @@ verify_st_order (st_state *p, gfc_statement st, bool silent)
order: order:
if (!silent) 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 (st),
gfc_ascii_statement (p->last_statement), &p->where); gfc_ascii_statement (p->last_statement), &p->where);
@ -2812,7 +2811,7 @@ endType:
"subcomponent exists)", c->name, &c->loc, sym->name); "subcomponent exists)", c->name, &c->loc, sym->name);
if (sym->attr.lock_comp && coarray && !lock_type) 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 " "subcomponent of type LOCK_TYPE must have a codimension or "
"be a subcomponent of a coarray. (Variables of type %s may " "be a subcomponent of a coarray. (Variables of type %s may "
"not have a codimension as %s at %L has a codimension or a " "not have a codimension as %s at %L has a codimension or a "
@ -3527,7 +3526,7 @@ parse_if_block (void)
case ST_ELSEIF: case ST_ELSEIF:
if (seen_else) 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); "statement at %L", &else_locus);
reject_statement (); reject_statement ();
@ -3751,7 +3750,7 @@ gfc_check_do_variable (gfc_symtree *st)
for (s=gfc_state_stack; s; s = s->previous) for (s=gfc_state_stack; s; s = s->previous)
if (s->do_variable == st) if (s->do_variable == st)
{ {
gfc_error_now_1 ("Variable '%s' at %C cannot be redefined inside " gfc_error_now ("Variable %qs at %C cannot be redefined inside "
"loop beginning at %L", st->name, &s->head->loc); "loop beginning at %L", st->name, &s->head->loc);
return 1; return 1;
} }
@ -5070,10 +5069,10 @@ gfc_global_used (gfc_gsymbol *sym, locus *where)
} }
if (sym->binding_label) 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); "at %L", sym->binding_label, where, name, &sym->where);
else 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); sym->name, where, name, &sym->where);
} }
@ -5543,7 +5542,7 @@ duplicate_main:
/* If we see a duplicate main program, shut down. If the second /* If we see a duplicate main program, shut down. If the second
instance is an implied main program, i.e. data decls or executable instance is an implied main program, i.e. data decls or executable
statements, we're in for lots of errors. */ 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 (); reject_statement ();
gfc_done_2 (); gfc_done_2 ();
return true; return true;

13
gcc/fortran/primary.c
View File

@ -1274,8 +1274,7 @@ static match
match_complex_constant (gfc_expr **result) match_complex_constant (gfc_expr **result)
{ {
gfc_expr *e, *real, *imag; gfc_expr *e, *real, *imag;
gfc_error_buf old_error_1; gfc_error_buffer old_error;
output_buffer old_error;
gfc_typespec target; gfc_typespec target;
locus old_loc; locus old_loc;
int kind; int kind;
@ -1288,18 +1287,18 @@ match_complex_constant (gfc_expr **result)
if (m != MATCH_YES) if (m != MATCH_YES)
return m; return m;
gfc_push_error (&old_error, &old_error_1); gfc_push_error (&old_error);
m = match_complex_part (&real); m = match_complex_part (&real);
if (m == MATCH_NO) if (m == MATCH_NO)
{ {
gfc_free_error (&old_error, &old_error_1); gfc_free_error (&old_error);
goto cleanup; goto cleanup;
} }
if (gfc_match_char (',') == MATCH_NO) if (gfc_match_char (',') == MATCH_NO)
{ {
gfc_pop_error (&old_error, &old_error_1); gfc_pop_error (&old_error);
m = MATCH_NO; m = MATCH_NO;
goto cleanup; goto cleanup;
} }
@ -1311,10 +1310,10 @@ match_complex_constant (gfc_expr **result)
if (m == MATCH_ERROR) if (m == MATCH_ERROR)
{ {
gfc_free_error (&old_error, &old_error_1); gfc_free_error (&old_error);
goto cleanup; goto cleanup;
} }
gfc_pop_error (&old_error, &old_error_1); gfc_pop_error (&old_error);
m = match_complex_part (&imag); m = match_complex_part (&imag);
if (m == MATCH_NO) if (m == MATCH_NO)

58
gcc/fortran/resolve.c
View File

@ -418,7 +418,7 @@ resolve_formal_arglist (gfc_symbol *proc)
/* F08:C1278a. */ /* F08:C1278a. */
if (sym->ts.type == BT_CLASS && sym->attr.intent == INTENT_OUT) 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, " may not be polymorphic", sym->name, proc->name,
&sym->declared_at); &sym->declared_at);
continue; continue;
@ -993,7 +993,7 @@ resolve_common_blocks (gfc_symtree *common_root)
|| (!common_root->n.common->binding_label || (!common_root->n.common->binding_label
&& gsym->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 " "identifier and must thus have the same binding name "
"as the same-named COMMON block at %L: %s vs %s", "as the same-named COMMON block at %L: %s vs %s",
common_root->n.common->name, &common_root->n.common->where, common_root->n.common->name, &common_root->n.common->where,
@ -1007,7 +1007,7 @@ resolve_common_blocks (gfc_symtree *common_root)
if (gsym && gsym->type != GSYM_COMMON if (gsym && gsym->type != GSYM_COMMON
&& !common_root->n.common->binding_label) && !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", "as entity at %L",
common_root->n.common->name, &common_root->n.common->where, common_root->n.common->name, &common_root->n.common->where,
&gsym->where); &gsym->where);
@ -1015,7 +1015,7 @@ resolve_common_blocks (gfc_symtree *common_root)
} }
if (gsym && gsym->type != GSYM_COMMON) 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 " "%L sharing the identifier with global non-COMMON-block "
"entity at %L", common_root->n.common->name, "entity at %L", common_root->n.common->name,
&common_root->n.common->where, &gsym->where); &common_root->n.common->where, &gsym->where);
@ -1037,7 +1037,7 @@ resolve_common_blocks (gfc_symtree *common_root)
common_root->n.common->binding_label); common_root->n.common->binding_label);
if (gsym && gsym->type != GSYM_COMMON) 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", "global identifier as entity at %L",
&common_root->n.common->where, &common_root->n.common->where,
common_root->n.common->binding_label, &gsym->where); common_root->n.common->binding_label, &gsym->where);
@ -1058,7 +1058,7 @@ resolve_common_blocks (gfc_symtree *common_root)
return; return;
if (sym->attr.flavor == FL_PARAMETER) 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); sym->name, &common_root->n.common->where, &sym->declared_at);
if (sym->attr.external) if (sym->attr.external)
@ -3368,7 +3368,7 @@ resolve_call (gfc_code *c)
if (csym && csym->ts.type != BT_UNKNOWN) 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); "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
return false; return false;
} }
@ -3494,7 +3494,7 @@ compare_shapes (gfc_expr *op1, gfc_expr *op2)
{ {
if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0) if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
{ {
gfc_error_1 ("Shapes for operands at %L and %L are not conformable", gfc_error ("Shapes for operands at %L and %L are not conformable",
&op1->where, &op2->where); &op1->where, &op2->where);
t = false; t = false;
break; break;
@ -6785,7 +6785,7 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2)
if (mpz_cmp (e1->shape[i], s) != 0) 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); "have the same shape", &e1->where, &e2->where);
mpz_clear (s); mpz_clear (s);
return false; return false;
@ -6943,7 +6943,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
/* Check F03:C631. */ /* Check F03:C631. */
if (!gfc_type_compatible (&e->ts, &code->expr3->ts)) if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
{ {
gfc_error_1 ("Type of entity at %L is type incompatible with " gfc_error ("Type of entity at %L is type incompatible with "
"source-expr at %L", &e->where, &code->expr3->where); "source-expr at %L", &e->where, &code->expr3->where);
goto failure; goto failure;
} }
@ -6955,7 +6955,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
/* Check F03:C633. */ /* Check F03:C633. */
if (code->expr3->ts.kind != e->ts.kind && !unlimited) if (code->expr3->ts.kind != e->ts.kind && !unlimited)
{ {
gfc_error_1 ("The allocate-object at %L and the source-expr at %L " gfc_error ("The allocate-object at %L and the source-expr at %L "
"shall have the same kind type parameter", "shall have the same kind type parameter",
&e->where, &code->expr3->where); &e->where, &code->expr3->where);
goto failure; goto failure;
@ -6969,7 +6969,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
&& code->expr3->ts.u.derived->intmod_sym_id && code->expr3->ts.u.derived->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE))) == 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 " "LOCK_TYPE nor have a LOCK_TYPE component if "
"allocate-object at %L is a coarray", "allocate-object at %L is a coarray",
&code->expr3->where, &e->where); &code->expr3->where, &e->where);
@ -7318,19 +7318,19 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
{ {
if (pr == NULL && qr == NULL) if (pr == NULL && qr == NULL)
{ {
gfc_error_1 ("Allocate-object at %L also appears at %L", gfc_error ("Allocate-object at %L also appears at %L",
&pe->where, &qe->where); &pe->where, &qe->where);
break; break;
} }
else if (pr != NULL && qr == NULL) else if (pr != NULL && qr == NULL)
{ {
gfc_error_1 ("Allocate-object at %L is subobject of" gfc_error ("Allocate-object at %L is subobject of"
" object at %L", &pe->where, &qe->where); " object at %L", &pe->where, &qe->where);
break; break;
} }
else if (pr == NULL && qr != NULL) else if (pr == NULL && qr != NULL)
{ {
gfc_error_1 ("Allocate-object at %L is subobject of" gfc_error ("Allocate-object at %L is subobject of"
" object at %L", &qe->where, &pe->where); " object at %L", &qe->where, &pe->where);
break; break;
} }
@ -7534,7 +7534,7 @@ check_case_overlap (gfc_case *list)
element in the list. Either way, we must element in the list. Either way, we must
issue an error and get the next case from P. */ issue an error and get the next case from P. */
/* FIXME: Sort P and Q by line number. */ /* 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); "label at %L", &p->where, &q->where);
overlap_seen = 1; overlap_seen = 1;
e = p; e = p;
@ -7772,7 +7772,7 @@ resolve_select (gfc_code *code, bool select_type)
{ {
if (default_case != 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", "by a second DEFAULT CASE at %L",
&default_case->where, &cp->where); &default_case->where, &cp->where);
t = false; t = false;
@ -8145,7 +8145,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
/* Check F03:C818. */ /* Check F03:C818. */
if (default_case) 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", "by a second DEFAULT CASE at %L",
&default_case->ext.block.case_list->where, &c->where); &default_case->ext.block.case_list->where, &c->where);
error++; error++;
@ -8708,7 +8708,7 @@ resolve_branch (gfc_st_label *label, gfc_code *code)
if (label->defined != ST_LABEL_TARGET && label->defined != ST_LABEL_DO_TARGET) 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); "for the branch statement at %L", &label->where, &code->loc);
return; return;
} }
@ -8735,11 +8735,11 @@ resolve_branch (gfc_st_label *label, gfc_code *code)
{ {
if (stack->current->op == EXEC_CRITICAL if (stack->current->op == EXEC_CRITICAL
&& bitmap_bit_p (stack->reachable_labels, label->value)) && 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); "label at %L", &code->loc, &label->where);
else if (stack->current->op == EXEC_DO_CONCURRENT else if (stack->current->op == EXEC_DO_CONCURRENT
&& bitmap_bit_p (stack->reachable_labels, label->value)) && 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); "for label at %L", &code->loc, &label->where);
} }
@ -8758,13 +8758,13 @@ resolve_branch (gfc_st_label *label, gfc_code *code)
{ {
/* Note: A label at END CRITICAL does not leave the CRITICAL /* Note: A label at END CRITICAL does not leave the CRITICAL
construct as END CRITICAL is still part of it. */ 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); " at %L", &code->loc, &label->where);
return; return;
} }
else if (stack->current->op == EXEC_DO_CONCURRENT) 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); "label at %L", &code->loc, &label->where);
return; return;
} }
@ -10545,7 +10545,7 @@ gfc_verify_binding_labels (gfc_symbol *sym)
if (sym->attr.flavor == FL_VARIABLE && gsym->type != GSYM_UNKNOWN) 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, "identifier as entity at %L", sym->name,
sym->binding_label, &sym->declared_at, &gsym->where); sym->binding_label, &sym->declared_at, &gsym->where);
/* Clear the binding label to prevent checking multiple times. */ /* Clear the binding label to prevent checking multiple times. */
@ -10558,7 +10558,7 @@ gfc_verify_binding_labels (gfc_symbol *sym)
{ {
/* This can only happen if the variable is defined in a module - if it /* This can only happen if the variable is defined in a module - if it
isn't the same module, reject 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", "the same global identifier as entity at %L from module %s",
sym->name, module, sym->binding_label, sym->name, module, sym->binding_label,
&sym->declared_at, &gsym->where, gsym->mod_name); &sym->declared_at, &gsym->where, gsym->mod_name);
@ -10575,7 +10575,7 @@ gfc_verify_binding_labels (gfc_symbol *sym)
/* Print an error if the procedure is defined multiple times; we have to /* Print an error if the procedure is defined multiple times; we have to
exclude references to the same procedure via module association or exclude references to the same procedure via module association or
multiple checks for the same procedure. */ 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, "global identifier as entity at %L", sym->name,
sym->binding_label, &sym->declared_at, &gsym->where); sym->binding_label, &sym->declared_at, &gsym->where);
sym->binding_label = NULL; sym->binding_label = NULL;
@ -11075,7 +11075,7 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
s = gfc_find_dt_in_generic (s); s = gfc_find_dt_in_generic (s);
if (s && s->attr.flavor != FL_DERIVED) 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 " "because it is blocked by an incompatible object "
"of the same name declared at %L", "of the same name declared at %L",
sym->ts.u.derived->name, &sym->declared_at, sym->ts.u.derived->name, &sym->declared_at,
@ -11145,7 +11145,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
{ {
/* The shape of a main program or module array needs to be /* The shape of a main program or module array needs to be
constant. */ 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); "have constant shape", sym->name, &sym->declared_at);
specification_expr = saved_specification_expr; specification_expr = saved_specification_expr;
return false; return false;
@ -11194,7 +11194,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
&& (sym->ns->proc_name->attr.flavor == FL_MODULE && (sym->ns->proc_name->attr.flavor == FL_MODULE
|| sym->ns->proc_name->attr.is_main_program)) || 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); "in this context", sym->name, &sym->declared_at);
specification_expr = saved_specification_expr; specification_expr = saved_specification_expr;
return false; return false;

20
gcc/fortran/symbol.c
View File

@ -1706,7 +1706,7 @@ gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type)) if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type))
{ {
if (sym->attr.use_assoc) 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, "use-associated at %L", sym->name, where, sym->module,
&sym->declared_at); &sym->declared_at);
else else
@ -1900,7 +1900,7 @@ gfc_add_component (gfc_symbol *sym, const char *name,
{ {
if (strcmp (p->name, name) == 0) 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); name, &p->loc);
return false; return false;
} }
@ -1911,7 +1911,7 @@ gfc_add_component (gfc_symbol *sym, const char *name,
if (sym->attr.extension if (sym->attr.extension
&& gfc_find_component (sym->components->ts.u.derived, name, true, true)) && 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); "at %L", name, &sym->components->ts.u.derived->declared_at);
return false; return false;
} }
@ -2223,7 +2223,7 @@ gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus)
labelno = lp->value; labelno = lp->value;
if (lp->defined != ST_LABEL_UNKNOWN) 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); &lp->where, label_locus);
else else
{ {
@ -3900,9 +3900,9 @@ verify_bind_c_derived_type (gfc_symbol *derived_sym)
J3/04-007, Section 15.2.3, C1505. */ J3/04-007, Section 15.2.3, C1505. */
if (curr_comp->attr.pointer != 0) 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 " "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), curr_comp->name, &(curr_comp->loc),
derived_sym->name, &(derived_sym->declared_at)); derived_sym->name, &(derived_sym->declared_at));
retval = false; retval = false;
@ -3910,8 +3910,8 @@ verify_bind_c_derived_type (gfc_symbol *derived_sym)
if (curr_comp->attr.proc_pointer != 0) if (curr_comp->attr.proc_pointer != 0)
{ {
gfc_error_1 ("Procedure pointer component '%s' at %L cannot be a member" gfc_error ("Procedure pointer component %qs at %L cannot be a member"
" of the BIND(C) derived type '%s' at %L", curr_comp->name, " of the BIND(C) derived type %qs at %L", curr_comp->name,
&curr_comp->loc, derived_sym->name, &curr_comp->loc, derived_sym->name,
&derived_sym->declared_at); &derived_sym->declared_at);
retval = false; retval = false;
@ -3921,9 +3921,9 @@ verify_bind_c_derived_type (gfc_symbol *derived_sym)
J3/04-007, Section 15.2.3, C1505. */ J3/04-007, Section 15.2.3, C1505. */
if (curr_comp->attr.allocatable != 0) 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 " "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), curr_comp->name, &(curr_comp->loc),
derived_sym->name, &(derived_sym->declared_at)); derived_sym->name, &(derived_sym->declared_at));
retval = false; retval = false;

4
gcc/fortran/trans-common.c
View File

@ -918,8 +918,8 @@ confirm_condition (segment_info *s1, gfc_equiv *eq1, segment_info *s2,
offset2 = calculate_offset (eq2->expr); offset2 = calculate_offset (eq2->expr);
if (s1->offset + offset1 != s2->offset + offset2) if (s1->offset + offset1 != s2->offset + offset2)
gfc_error_1 ("Inconsistent equivalence rules involving '%s' at %L and " gfc_error ("Inconsistent equivalence rules involving %qs at %L and "
"'%s' at %L", s1->sym->name, &s1->sym->declared_at, "%qs at %L", s1->sym->name, &s1->sym->declared_at,
s2->sym->name, &s2->sym->declared_at); s2->sym->name, &s2->sym->declared_at);
} }