===================================================================
@@ -38,11 +38,12 @@ output_buffer::output_buffer ()
chunk_obstack (),
obstack (&formatted_obstack),
cur_chunk_array (),
stream (stderr),
line_length (),
- digit_buffer ()
+ digit_buffer (),
+ flush_p (true)
{
obstack_init (&formatted_obstack);
obstack_init (&chunk_obstack);
}
@@ -677,16 +678,29 @@ pp_format_verbatim (pretty_printer *pp,
/* Restore previous settings. */
pp_wrapping_mode (pp) = oldmode;
}
-/* Flush the content of BUFFER onto the attached stream. */
+/* Flush the content of BUFFER onto the attached stream. This
+ function does nothing unless pp->output_buffer->flush_p. */
void
pp_flush (pretty_printer *pp)
{
+ pp_clear_state (pp);
+ if (!pp->buffer->flush_p)
+ return;
pp_write_text_to_stream (pp);
+ fflush (pp_buffer (pp)->stream);
+}
+
+/* Flush the content of BUFFER onto the attached stream independently
+ of the value of pp->output_buffer->flush_p. */
+void
+pp_really_flush (pretty_printer *pp)
+{
pp_clear_state (pp);
+ pp_write_text_to_stream (pp);
fflush (pp_buffer (pp)->stream);
}
/* Sets the number of maximum characters per line PRETTY-PRINTER can
output in line-wrapping mode. A LENGTH value 0 suppresses
===================================================================
@@ -98,10 +98,15 @@ struct output_buffer
int line_length;
/* This must be large enough to hold any printed integer or
floating-point value. */
char digit_buffer[128];
+
+ /* Nonzero means that text should be flushed when
+ appropriate. Otherwise, text is buffered until either
+ pp_really_flush or pp_clear_output_area are called. */
+ bool flush_p;
};
/* The type of pretty-printer flags passed to clients. */
typedef unsigned int pp_flags;
@@ -312,10 +317,11 @@ extern void pp_printf (pretty_printer *,
ATTRIBUTE_GCC_PPDIAG(2,3);
extern void pp_verbatim (pretty_printer *, const char *, ...)
ATTRIBUTE_GCC_PPDIAG(2,3);
extern void pp_flush (pretty_printer *);
+extern void pp_really_flush (pretty_printer *);
extern void pp_format (pretty_printer *, text_info *);
extern void pp_output_formatted_text (pretty_printer *);
extern void pp_format_verbatim (pretty_printer *, text_info *);
extern void pp_indent (pretty_printer *);
===================================================================
@@ -15,11 +15,11 @@
! integer i
! end function wrong_warn
implicit none
! gfc_warning:
-1234 complex :: cplx ! { dg-warning "defined but cannot be used" }
+1234 complex :: cplx ! { dg-error "defined but cannot be used" }
cplx = 20.
! gfc_warning_now:
1 ! { dg-error "Ignoring statement label in empty statement" }
end
===================================================================
@@ -16,10 +16,10 @@
do r1 = 1, 2 ! { dg-warning "Deleted feature: Loop variable" }
i = i+1
end do
call foo j bar
! gfc_warning:
- r2(4) = 0 ! { dg-warning "is out of bounds" }
+ r2(4) = 0 ! { dg-error "is out of bounds" }
goto 3 45
end
! { dg-final { output-exists-not } }
===================================================================
@@ -1176,11 +1176,11 @@ check_dummy_characteristics (gfc_symbol
"in argument '%s'", s1->name);
return false;
case -2:
/* FIXME: Implement a warning for this case.
- gfc_warning ("Possible character length mismatch in argument '%s'",
+ gfc_warning ("Possible character length mismatch in argument %qs",
s1->name);*/
break;
case 0:
break;
@@ -1647,15 +1647,15 @@ check_interface1 (gfc_interface *p, gfc_
if (referenced)
gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
p->sym->name, q->sym->name, interface_name,
&p->where);
else if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)
- gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
+ gfc_warning ("Ambiguous interfaces %qs and %qs in %s at %L",
p->sym->name, q->sym->name, interface_name,
&p->where);
else
- gfc_warning ("Although not referenced, '%s' has ambiguous "
+ gfc_warning ("Although not referenced, %qs has ambiguous "
"interfaces at %L", interface_name, &p->where);
return 1;
}
}
return 0;
@@ -2145,12 +2145,13 @@ compare_parameter (gfc_symbol *formal, g
"INTENT(OUT) dummy argument '%s'", &actual->where,
formal->name);
return 0;
}
else if (warn_surprising && where && formal->attr.intent != INTENT_IN)
- gfc_warning ("Passing coarray at %L to allocatable, noncoarray dummy "
- "argument '%s', which is invalid if the allocation status"
+ gfc_warning (OPT_Wsurprising,
+ "Passing coarray at %L to allocatable, noncoarray dummy "
+ "argument %qs, which is invalid if the allocation status"
" is modified", &actual->where, formal->name);
}
/* If the rank is the same or the formal argument has assumed-rank. */
if (symbol_rank (formal) == actual->rank || symbol_rank (formal) == -1)
@@ -2671,17 +2672,17 @@ compare_actual_formal (gfc_actual_arglis
f->sym->ts.u.cl->length->value.integer) != 0))
{
if (where && (f->sym->attr.pointer || f->sym->attr.allocatable))
gfc_warning ("Character length mismatch (%ld/%ld) between actual "
"argument and pointer or allocatable dummy argument "
- "'%s' at %L",
+ "%qs at %L",
mpz_get_si (a->expr->ts.u.cl->length->value.integer),
mpz_get_si (f->sym->ts.u.cl->length->value.integer),
f->sym->name, &a->expr->where);
else if (where)
gfc_warning ("Character length mismatch (%ld/%ld) between actual "
- "argument and assumed-shape dummy argument '%s' "
+ "argument and assumed-shape dummy argument %qs "
"at %L",
mpz_get_si (a->expr->ts.u.cl->length->value.integer),
mpz_get_si (f->sym->ts.u.cl->length->value.integer),
f->sym->name, &a->expr->where);
return 0;
@@ -2708,16 +2709,16 @@ compare_actual_formal (gfc_actual_arglis
&& a->expr->ts.type != BT_PROCEDURE
&& f->sym->attr.flavor != FL_PROCEDURE)
{
if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
gfc_warning ("Character length of actual argument shorter "
- "than of dummy argument '%s' (%lu/%lu) at %L",
+ "than of dummy argument %qs (%lu/%lu) at %L",
f->sym->name, actual_size, formal_size,
&a->expr->where);
else if (where)
gfc_warning ("Actual argument contains too few "
- "elements for dummy argument '%s' (%lu/%lu) at %L",
+ "elements for dummy argument %qs (%lu/%lu) at %L",
f->sym->name, actual_size, formal_size,
&a->expr->where);
return 0;
}
@@ -3144,11 +3145,11 @@ check_some_aliasing (gfc_formal_arglist
if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
|| (f1_intent == INTENT_OUT && f2_intent == INTENT_IN)
|| (f1_intent == INTENT_OUT && f2_intent == INTENT_OUT))
{
gfc_warning ("Same actual argument associated with INTENT(%s) "
- "argument '%s' and INTENT(%s) argument '%s' at %L",
+ "argument %qs and INTENT(%s) argument %qs at %L",
gfc_intent_string (f1_intent), p[i].f->sym->name,
gfc_intent_string (f2_intent), p[j].f->sym->name,
&p[i].a->expr->where);
t = false;
}
@@ -3259,14 +3260,16 @@ gfc_procedure_use (gfc_symbol *sym, gfc_
gfc_error ("Procedure '%s' called at %L is not explicitly declared",
sym->name, where);
return false;
}
if (warn_implicit_interface)
- gfc_warning ("Procedure '%s' called with an implicit interface at %L",
+ gfc_warning (OPT_Wimplicit_interface,
+ "Procedure %qs called with an implicit interface at %L",
sym->name, where);
else if (warn_implicit_procedure && sym->attr.proc == PROC_UNKNOWN)
- gfc_warning ("Procedure '%s' called at %L is not explicitly declared",
+ gfc_warning (OPT_Wimplicit_procedure,
+ "Procedure %qs called at %L is not explicitly declared",
sym->name, where);
}
if (sym->attr.if_source == IFSRC_UNKNOWN)
{
@@ -3374,11 +3377,12 @@ gfc_ppc_use (gfc_component *comp, gfc_ac
for calling a ISO_C_BINDING because c_loc and c_funloc
are pseudo-unknown. */
if (warn_implicit_interface
&& comp->attr.if_source == IFSRC_UNKNOWN
&& !comp->attr.is_iso_c)
- gfc_warning ("Procedure pointer component '%s' called with an implicit "
+ gfc_warning (OPT_Wimplicit_interface,
+ "Procedure pointer component %qs called with an implicit "
"interface at %L", comp->name, where);
if (comp->attr.if_source == IFSRC_UNKNOWN)
{
gfc_actual_arglist *a;
===================================================================
@@ -4314,11 +4314,11 @@ gfc_check_intrinsic_standard (const gfc_
/* If warning about the standard, warn and succeed. */
if (gfc_option.warn_std & isym->standard)
{
/* Do only print a warning if not a GNU extension. */
if (!silent && isym->standard != GFC_STD_GNU)
- gfc_warning ("Intrinsic '%s' (is %s) is used at %L",
+ gfc_warning ("Intrinsic %qs (is %s) is used at %L",
isym->name, _(symstd_msg), &where);
return true;
}
@@ -4822,14 +4822,16 @@ gfc_warn_intrinsic_shadow (const gfc_sym
sym->declared_at))
return;
/* Emit the warning. */
if (in_module || sym->ns->proc_name)
- gfc_warning ("'%s' declared at %L may shadow the intrinsic of the same"
+ gfc_warning (OPT_Wintrinsic_shadow,
+ "%qs declared at %L may shadow the intrinsic of the same"
" name. In order to call the intrinsic, explicit INTRINSIC"
" declarations may be required.",
sym->name, &sym->declared_at);
else
- gfc_warning ("'%s' declared at %L is also the name of an intrinsic. It can"
+ gfc_warning (OPT_Wintrinsic_shadow,
+ "%qs declared at %L is also the name of an intrinsic. It can"
" only be called via an explicit interface or if declared"
" EXTERNAL.", sym->name, &sym->declared_at);
}
===================================================================
@@ -1110,14 +1110,16 @@ assign:
static void
realloc_lhs_warning (bt type, bool array, locus *where)
{
if (array && type != BT_CLASS && type != BT_DERIVED && warn_realloc_lhs)
- gfc_warning ("Code for reallocating the allocatable array at %L will "
+ gfc_warning (OPT_Wrealloc_lhs,
+ "Code for reallocating the allocatable array at %L will "
"be added", where);
else if (warn_realloc_lhs_all)
- gfc_warning ("Code for reallocating the allocatable variable at %L "
+ gfc_warning (OPT_Wrealloc_lhs_all,
+ "Code for reallocating the allocatable variable at %L "
"will be added", where);
}
static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
===================================================================
@@ -1040,11 +1040,12 @@ gfc_trans_create_temp_array (stmtblock_t
gcc_assert (ss->dimen > 0);
gcc_assert (ss->loop->dimen == ss->dimen);
if (warn_array_temporaries && where)
- gfc_warning ("Creating array temporary at %L", where);
+ gfc_warning (OPT_Warray_temporaries,
+ "Creating array temporary at %L", where);
/* Set the lower bound to zero. */
for (s = ss; s; s = s->parent)
{
loop = s->loop;
@@ -5920,11 +5921,12 @@ gfc_trans_dummy_array_bias (gfc_symbol *
gfor_fndecl_in_pack, 1, tmp);
stride = gfc_index_one_node;
if (warn_array_temporaries)
- gfc_warning ("Creating array temporary at %L", &loc);
+ gfc_warning (OPT_Warray_temporaries,
+ "Creating array temporary at %L", &loc);
}
/* This is for the case where the array data is used directly without
calling the repack function. */
if (no_repack || partial != NULL_TREE)
@@ -7203,14 +7205,16 @@ gfc_conv_array_parameter (gfc_se * se, g
/* Repack the array. */
if (warn_array_temporaries)
{
if (fsym)
- gfc_warning ("Creating array temporary at %L for argument '%s'",
+ gfc_warning (OPT_Warray_temporaries,
+ "Creating array temporary at %L for argument %qs",
&expr->where, fsym->name);
else
- gfc_warning ("Creating array temporary at %L", &expr->where);
+ gfc_warning (OPT_Warray_temporaries,
+ "Creating array temporary at %L", &expr->where);
}
ptr = build_call_expr_loc (input_location,
gfor_fndecl_in_pack, 1, desc);
===================================================================
@@ -3872,11 +3872,11 @@ verify_bind_c_derived_type (gfc_symbol *
to be interoperable with the C entity. There does not have to be such
an interoperating C entity."
*/
if (curr_comp == NULL)
{
- gfc_warning ("Derived type '%s' with BIND(C) attribute at %L is empty, "
+ gfc_warning ("Derived type %qs with BIND(C) attribute at %L is empty, "
"and may be inaccessible by the C companion processor",
derived_sym->name, &(derived_sym->declared_at));
derived_sym->ts.is_c_interop = 1;
derived_sym->attr.is_bind_c = 1;
return true;
@@ -3952,20 +3952,22 @@ verify_bind_c_derived_type (gfc_symbol *
x86_64 and using integer(4) to claim interop with a
C_LONG). */
if (derived_sym->attr.is_bind_c == 1 && warn_c_binding_type)
/* If the derived type is bind(c), all fields must be
interop. */
- gfc_warning ("Component '%s' in derived type '%s' at %L "
+ gfc_warning (OPT_Wc_binding_type,
+ "Component %qs in derived type %qs at %L "
"may not be C interoperable, even though "
- "derived type '%s' is BIND(C)",
+ "derived type %qs is BIND(C)",
curr_comp->name, derived_sym->name,
&(curr_comp->loc), derived_sym->name);
else if (warn_c_binding_type)
/* If derived type is param to bind(c) routine, or to one
of the iso_c_binding procs, it must be interoperable, so
all fields must interop too. */
- gfc_warning ("Component '%s' in derived type '%s' at %L "
+ gfc_warning (OPT_Wc_binding_type,
+ "Component %qs in derived type %qs at %L "
"may not be C interoperable",
curr_comp->name, derived_sym->name,
&(curr_comp->loc));
}
}
===================================================================
@@ -1028,12 +1028,13 @@ gfc_verify_c_interop_param (gfc_symbol *
"BIND(C) procedure '%s' but is not C interoperable "
"because it is polymorphic",
sym->name, &(sym->declared_at),
sym->ns->proc_name->name);
else if (warn_c_binding_type)
- gfc_warning ("Variable '%s' at %L is a dummy argument of the "
- "BIND(C) procedure '%s' but may not be C "
+ gfc_warning (OPT_Wc_binding_type,
+ "Variable %qs at %L is a dummy argument of the "
+ "BIND(C) procedure %qs but may not be C "
"interoperable",
sym->name, &(sym->declared_at),
sym->ns->proc_name->name);
}
@@ -3292,12 +3293,12 @@ gfc_match_import (void)
return MATCH_ERROR;
}
if (gfc_find_symtree (gfc_current_ns->sym_root, name))
{
- gfc_warning ("'%s' is already IMPORTed from host scoping unit "
- "at %C.", name);
+ gfc_warning ("%qs is already IMPORTed from host scoping unit "
+ "at %C", name);
goto next_item;
}
st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
st->n.sym = sym;
@@ -4029,11 +4030,12 @@ verify_bind_c_sym (gfc_symbol *tmp_sym,
{
tmp_sym = tmp_sym->result;
/* Make sure it wasn't an implicitly typed result. */
if (tmp_sym->attr.implicit_type && warn_c_binding_type)
{
- gfc_warning ("Implicitly declared BIND(C) function '%s' at "
+ gfc_warning (OPT_Wc_binding_type,
+ "Implicitly declared BIND(C) function %qs at "
"%L may not be C interoperable", tmp_sym->name,
&tmp_sym->declared_at);
tmp_sym->ts.f90_type = tmp_sym->ts.type;
/* Mark it as C interoperable to prevent duplicate warnings. */
tmp_sym->ts.is_c_interop = 1;
@@ -4050,24 +4052,25 @@ verify_bind_c_sym (gfc_symbol *tmp_sym,
if (!gfc_verify_c_interop (&(tmp_sym->ts)))
{
/* See if we're dealing with a sym in a common block or not. */
if (is_in_common == 1 && warn_c_binding_type)
{
- gfc_warning ("Variable '%s' in common block '%s' at %L "
+ gfc_warning (OPT_Wc_binding_type,
+ "Variable %qs in common block %qs at %L "
"may not be a C interoperable "
- "kind though common block '%s' is BIND(C)",
+ "kind though common block %qs is BIND(C)",
tmp_sym->name, com_block->name,
&(tmp_sym->declared_at), com_block->name);
}
else
{
if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED)
gfc_error ("Type declaration '%s' at %L is not C "
"interoperable but it is BIND(C)",
tmp_sym->name, &(tmp_sym->declared_at));
else if (warn_c_binding_type)
- gfc_warning ("Variable '%s' at %L "
+ gfc_warning (OPT_Wc_binding_type, "Variable %qs at %L "
"may not be a C interoperable "
"kind but it is bind(c)",
tmp_sym->name, &(tmp_sym->declared_at));
}
}
===================================================================
@@ -395,11 +395,11 @@ build_common_decl (gfc_common_head *com,
/* Named common blocks of the same name shall be of the same size
in all scoping units of a program in which they appear, but
blank common blocks may be of different sizes. */
if (!tree_int_cst_equal (DECL_SIZE_UNIT (decl), size)
&& strcmp (com->name, BLANK_COMMON_NAME))
- gfc_warning ("Named COMMON block '%s' at %L shall be of the "
+ gfc_warning ("Named COMMON block %qs at %L shall be of the "
"same size as elsewhere (%lu vs %lu bytes)", com->name,
&com->where,
(unsigned long) TREE_INT_CST_LOW (size),
(unsigned long) TREE_INT_CST_LOW (DECL_SIZE_UNIT (decl)));
@@ -1134,16 +1134,16 @@ translate_common (gfc_common_head *commo
requirements. Insert padding immediately before this
segment. */
if (warn_align_commons)
{
if (strcmp (common->name, BLANK_COMMON_NAME))
- gfc_warning ("Padding of %d bytes required before '%s' in "
- "COMMON '%s' at %L; reorder elements or use "
+ gfc_warning ("Padding of %d bytes required before %qs in "
+ "COMMON %qs at %L; reorder elements or use "
"-fno-align-commons", (int)offset,
s->sym->name, common->name, &common->where);
else
- gfc_warning ("Padding of %d bytes required before '%s' in "
+ gfc_warning ("Padding of %d bytes required before %qs in "
"COMMON at %L; reorder elements or use "
"-fno-align-commons", (int)offset,
s->sym->name, &common->where);
}
}
@@ -1168,16 +1168,18 @@ translate_common (gfc_common_head *commo
}
if (common_segment->offset != 0 && warn_align_commons)
{
if (strcmp (common->name, BLANK_COMMON_NAME))
- gfc_warning ("COMMON '%s' at %L requires %d bytes of padding; "
- "reorder elements or use -fno-align-commons",
+ gfc_warning (OPT_Walign_commons,
+ "COMMON %qs at %L requires %d bytes of padding; "
+ "reorder elements or use %<-fno-align-commons%>",
common->name, &common->where, (int)common_segment->offset);
else
- gfc_warning ("COMMON at %L requires %d bytes of padding; "
- "reorder elements or use -fno-align-commons",
+ gfc_warning (OPT_Walign_commons,
+ "COMMON at %L requires %d bytes of padding; "
+ "reorder elements or use %<-fno-align-commons%>",
&common->where, (int)common_segment->offset);
}
create_common (common, common_segment, saw_equiv);
}
===================================================================
@@ -2670,11 +2670,13 @@ void gfc_diagnostics_init (void);
void gfc_diagnostics_finish (void);
void gfc_buffer_error (int);
const char *gfc_print_wide_char (gfc_char_t);
-void gfc_warning (const char *, ...) ATTRIBUTE_GCC_GFC(1,2);
+void gfc_warning_1 (const char *, ...) ATTRIBUTE_GCC_GFC(1,2);
+bool gfc_warning (const char *, ...) ATTRIBUTE_GCC_GFC(1,2);
+bool gfc_warning (int opt, const char *, ...) ATTRIBUTE_GCC_GFC(2,3);
void gfc_warning_now_1 (const char *, ...) ATTRIBUTE_GCC_GFC(1,2);
bool gfc_warning_now (const char *, ...) ATTRIBUTE_GCC_GFC(1,2);
bool gfc_warning_now (int opt, const char *, ...) ATTRIBUTE_GCC_GFC(2,3);
void gfc_clear_warning (void);
===================================================================
@@ -48,10 +48,14 @@ static int warnings_not_errors = 0;
static int terminal_width, buffer_flag, errors, warnings;
static gfc_error_buf error_buffer, warning_buffer, *cur_error_buffer;
+static output_buffer pp_warning_buffer;
+static int warningcount_buffered, werrorcount_buffered;
+
+#include <new> /* For placement-new */
/* Go one level deeper suppressing errors. */
void
gfc_push_suppress_errors (void)
@@ -120,10 +124,11 @@ gfc_error_init_1 (void)
void
gfc_buffer_error (int flag)
{
buffer_flag = flag;
+ pp_warning_buffer.flush_p = !flag;
}
/* Add a single character to the error buffer or output depending on
buffer_flag. */
@@ -802,14 +807,29 @@ gfc_increment_error_count (void)
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)
+{
+ pretty_printer *pp = global_dc->printer;
+ output_buffer *tmp_buffer = pp->buffer;
+ pp->buffer = this_buffer;
+ pp_clear_output_area (pp);
+ pp->buffer = tmp_buffer;
+}
+
+
/* Issue a warning. */
+/* Use gfc_warning instead, unless two locations are used in the same
+ warning or for scanner.c, if the location is not properly set up. */
void
-gfc_warning (const char *gmsgid, ...)
+gfc_warning_1 (const char *gmsgid, ...)
{
va_list argp;
if (inhibit_warnings)
return;
@@ -831,10 +851,92 @@ gfc_warning (const char *gmsgid, ...)
gfc_increment_error_count();
}
}
+/* This is just a helper function to avoid duplicating the logic of
+ gfc_warning. */
+
+static bool
+gfc_warning (int opt, const char *gmsgid, va_list ap) ATTRIBUTE_GCC_GFC(2,0);
+
+static bool
+gfc_warning (int opt, const char *gmsgid, va_list ap)
+{
+ va_list argp;
+ va_copy (argp, ap);
+
+ diagnostic_info diagnostic;
+ bool fatal_errors = global_dc->fatal_errors;
+ pretty_printer *pp = global_dc->printer;
+ output_buffer *tmp_buffer = pp->buffer;
+ bool buffered_p = !pp_warning_buffer.flush_p;
+
+ gfc_clear_pp_buffer (&pp_warning_buffer);
+
+ if (buffered_p)
+ {
+ pp->buffer = &pp_warning_buffer;
+ global_dc->fatal_errors = false;
+ /* To prevent -fmax-errors= triggering. */
+ --werrorcount;
+ }
+
+ diagnostic_set_info (&diagnostic, gmsgid, &argp, UNKNOWN_LOCATION,
+ DK_WARNING);
+ diagnostic.option_index = opt;
+ bool ret = report_diagnostic (&diagnostic);
+
+ if (buffered_p)
+ {
+ pp->buffer = tmp_buffer;
+ global_dc->fatal_errors = fatal_errors;
+
+ warningcount_buffered = 0;
+ werrorcount_buffered = 0;
+ /* Undo the above --werrorcount if not Werror, otherwise
+ werrorcount is correct already. */
+ if (!ret)
+ ++werrorcount;
+ else if (diagnostic.kind == DK_ERROR)
+ ++werrorcount_buffered;
+ else
+ ++werrorcount, --warningcount, ++warningcount_buffered;
+ }
+
+ va_end (argp);
+ return ret;
+}
+
+/* Issue a warning. */
+/* 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_warning_1. */
+
+bool
+gfc_warning (int opt, const char *gmsgid, ...)
+{
+ va_list argp;
+
+ va_start (argp, gmsgid);
+ bool ret = gfc_warning (opt, gmsgid, argp);
+ va_end (argp);
+ return ret;
+}
+
+bool
+gfc_warning (const char *gmsgid, ...)
+{
+ va_list argp;
+
+ va_start (argp, gmsgid);
+ bool ret = gfc_warning (0, gmsgid, argp);
+ va_end (argp);
+ return ret;
+}
+
+
/* Whether, for a feature included in a given standard set (GFC_STD_*),
we should issue an error or a warning, or be quiet. */
notification
gfc_notification_std (int std)
@@ -1174,10 +1276,15 @@ gfc_fatal_error (const char *gmsgid, ...
void
gfc_clear_warning (void)
{
warning_buffer.flag = 0;
+
+ gfc_clear_pp_buffer (&pp_warning_buffer);
+ warningcount_buffered = 0;
+ werrorcount_buffered = 0;
+ pp_warning_buffer.flush_p = false;
}
/* Check to see if any warnings have been saved.
If so, print the warning. */
@@ -1190,10 +1297,24 @@ gfc_warning_check (void)
warnings++;
if (warning_buffer.message != NULL)
fputs (warning_buffer.message, stderr);
warning_buffer.flag = 0;
}
+
+ /* This is for the new diagnostics machinery. */
+ pretty_printer *pp = global_dc->printer;
+ output_buffer *tmp_buffer = pp->buffer;
+ pp->buffer = &pp_warning_buffer;
+ if (pp_last_position_in_text (pp) != NULL)
+ {
+ pp_really_flush (pp);
+ pp_warning_buffer.flush_p = true;
+ warningcount += warningcount_buffered;
+ werrorcount += werrorcount_buffered;
+ }
+
+ pp->buffer = tmp_buffer;
}
/* Issue an error. */
@@ -1393,10 +1514,10 @@ gfc_get_errors (int *w, int *e)
/* Switch errors into warnings. */
void
-gfc_errors_to_warnings (int f)
+gfc_errors_to_warnings (bool f)
{
- warnings_not_errors = (f == 1) ? 1 : 0;
+ warnings_not_errors = f;
}
@@ -1403,12 +1524,13 @@
void
gfc_diagnostics_init (void)
{
diagnostic_starter (global_dc) = gfc_diagnostic_starter;
diagnostic_finalizer (global_dc) = gfc_diagnostic_finalizer;
diagnostic_format_decoder (global_dc) = gfc_format_decoder;
global_dc->caret_char = '^';
+ new (&pp_warning_buffer) output_buffer ();
}
void
gfc_diagnostics_finish (void)
{
===================================================================
@@ -538,11 +538,11 @@ gfc_trans_return (gfc_code * code)
result = gfc_get_fake_result_decl (NULL, 0);
if (!result)
{
gfc_warning ("An alternate return at %L without a * dummy argument",
- &code->expr1->where);
+ &code->expr1->where);
return gfc_generate_return ();
}
/* Start a new block for this statement. */
gfc_init_se (&se, NULL);
===================================================================
@@ -3171,11 +3171,12 @@ gfc_check_assign (gfc_expr *lvalue, gfc_
}
/* This is possibly a typo: x = f() instead of x => f(). */
if (warn_surprising
&& rvalue->expr_type == EXPR_FUNCTION && gfc_expr_attr (rvalue).pointer)
- gfc_warning ("POINTER-valued function appears on right-hand side of "
+ gfc_warning (OPT_Wsurprising,
+ "POINTER-valued function appears on right-hand side of "
"assignment at %L", &rvalue->where);
/* Check size of array assignments. */
if (lvalue->rank != 0 && rvalue->rank != 0
&& !gfc_check_conformance (lvalue, rvalue, "array assignment"))
@@ -3196,13 +3197,14 @@ gfc_check_assign (gfc_expr *lvalue, gfc_
/* Handle the case of a BOZ literal on the RHS. */
if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER)
{
int rc;
if (warn_surprising)
- gfc_warning ("BOZ literal at %L is bitwise transferred "
- "non-integer symbol '%s'", &rvalue->where,
- lvalue->symtree->n.sym->name);
+ gfc_warning (OPT_Wsurprising,
+ "BOZ literal at %L is bitwise transferred "
+ "non-integer symbol %qs", &rvalue->where,
+ lvalue->symtree->n.sym->name);
if (!gfc_convert_boz (rvalue, &lvalue->ts))
return false;
if ((rc = gfc_range_check (rvalue)) != ARITH_OK)
{
if (rc == ARITH_UNDERFLOW)
@@ -3244,26 +3246,29 @@ gfc_check_assign (gfc_expr *lvalue, gfc_
mpfr_set (rv, rvalue->value.real, GFC_RND_MODE);
mpfr_sub (diff, rv, rvalue->value.real, GFC_RND_MODE);
if (!mpfr_zero_p (diff))
- gfc_warning ("Change of value in conversion from "
- " %s to %s at %L", gfc_typename (&rvalue->ts),
+ gfc_warning (OPT_Wconversion,
+ "Change of value in conversion from "
+ " %qs to %qs at %L", gfc_typename (&rvalue->ts),
gfc_typename (&lvalue->ts), &rvalue->where);
mpfr_clear (rv);
mpfr_clear (diff);
}
else
- gfc_warning ("Possible change of value in conversion from %s "
- "to %s at %L",gfc_typename (&rvalue->ts),
+ gfc_warning (OPT_Wconversion,
+ "Possible change of value in conversion from %qs "
+ "to %qs at %L", gfc_typename (&rvalue->ts),
gfc_typename (&lvalue->ts), &rvalue->where);
}
else if (warn_conversion_extra && lvalue->ts.kind > rvalue->ts.kind)
{
- gfc_warning ("Conversion from %s to %s at %L",
+ gfc_warning (OPT_Wconversion_extra,
+ "Conversion from %qs to %qs at %L",
gfc_typename (&rvalue->ts),
gfc_typename (&lvalue->ts), &rvalue->where);
}
}
@@ -3781,11 +3786,12 @@ gfc_check_pointer_assign (gfc_expr *lval
warn = true;
break;
}
if (warn)
- gfc_warning ("Pointer at %L in pointer assignment might outlive the "
+ gfc_warning (OPT_Wtarget_lifetime,
+ "Pointer at %L in pointer assignment might outlive the "
"pointer target", &lvalue->where);
}
return true;
}
===================================================================
@@ -1153,11 +1153,12 @@ restart:
{
if (in_string)
{
gfc_current_locus.nextc--;
if (warn_ampersand && in_string == INSTRING_WARN)
- gfc_warning ("Missing '&' in continued character "
+ gfc_warning (OPT_Wampersand,
+ "Missing %<&%> in continued character "
"constant at %C");
}
/* Both !$omp and !$ -fopenmp continuation lines have & on the
continuation line only optionally. */
else if (openmp_flag || openmp_cond_flag)
===================================================================
@@ -1719,11 +1719,11 @@ compare_to_allowed_values (const char *s
notification n = gfc_notification_std (GFC_STD_F2003);
if (n == WARNING || (warn && n == ERROR))
{
gfc_warning ("Fortran 2003: %s specifier in %s statement at %C "
- "has value '%s'", specifier, statement,
+ "has value %qs", specifier, statement,
allowed_f2003[i]);
return 1;
}
else
if (n == ERROR)
@@ -1746,11 +1746,11 @@ compare_to_allowed_values (const char *s
notification n = gfc_notification_std (GFC_STD_GNU);
if (n == WARNING || (warn && n == ERROR))
{
gfc_warning ("Extension: %s specifier in %s statement at %C "
- "has value '%s'", specifier, statement,
+ "has value %qs", specifier, statement,
allowed_gnu[i]);
return 1;
}
else
if (n == ERROR)
===================================================================
@@ -545,11 +545,12 @@ create_var (gfc_expr * e)
result->ref->u.ar.type = AR_FULL;
result->ref->u.ar.where = e->where;
result->ref->u.ar.as = symbol->ts.type == BT_CLASS
? CLASS_DATA (symbol)->as : symbol->as;
if (warn_array_temporaries)
- gfc_warning ("Creating array temporary at %L", &(e->where));
+ gfc_warning (OPT_Warray_temporaries,
+ "Creating array temporary at %L", &(e->where));
}
/* Generate the new assignment. */
n = XCNEW (gfc_code);
n->op = EXEC_ASSIGN;
@@ -568,14 +569,14 @@ static void
do_warn_function_elimination (gfc_expr *e)
{
if (e->expr_type != EXPR_FUNCTION)
return;
if (e->value.function.esym)
- gfc_warning ("Removing call to function '%s' at %L",
+ gfc_warning ("Removing call to function %qs at %L",
e->value.function.esym->name, &(e->where));
else if (e->value.function.isym)
- gfc_warning ("Removing call to function '%s' at %L",
+ gfc_warning ("Removing call to function %qs at %L",
e->value.function.isym->name, &(e->where));
}
/* Callback function for the code walker for doing common function
elimination. This builds up the list of functions in the expression
and goes through them to detect duplicates, which it then replaces
===================================================================
@@ -1643,11 +1643,12 @@ gfc_resolve_intrinsic (gfc_symbol *sym,
if (isym && !sym->attr.subroutine)
{
if (sym->ts.type != BT_UNKNOWN && warn_surprising
&& !sym->attr.implicit_type)
- gfc_warning ("Type specified for intrinsic function '%s' at %L is"
+ gfc_warning (OPT_Wsurprising,
+ "Type specified for intrinsic function %qs at %L is"
" ignored", sym->name, &sym->declared_at);
if (!sym->attr.function &&
!gfc_add_function(&sym->attr, sym->name, loc))
return false;
@@ -1716,13 +1717,13 @@ resolve_procedure_expression (gfc_expr*
return true;
/* A non-RECURSIVE procedure that is used as procedure expression within its
own body is in danger of being called recursively. */
if (is_illegal_recursion (sym, gfc_current_ns))
- gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
+ gfc_warning ("Non-RECURSIVE procedure %qs at %L is possibly calling"
" itself recursively. Declare it RECURSIVE or use"
- " -frecursive", sym->name, &expr->where);
+ " %<-frecursive%>", sym->name, &expr->where);
return true;
}
@@ -2099,11 +2100,11 @@ resolve_elemental_actual (gfc_expr *expr
&& formal_optional
&& arg->expr->rank
&& (set_by_optional || arg->expr->rank != rank)
&& !(isym && isym->id == GFC_ISYM_CONVERSION))
{
- gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
+ gfc_warning ("%qs at %L is an array and OPTIONAL; IF IT IS "
"MISSING, it cannot be the actual argument of an "
"ELEMENTAL procedure unless there is a non-optional "
"argument with the same rank (12.4.1.5)",
arg->expr->symtree->n.sym->name, &arg->expr->where);
}
@@ -6330,12 +6331,12 @@ gfc_resolve_iterator (gfc_iterator *iter
{
sgn = mpfr_sgn (iter->step->value.real);
cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real);
}
if (warn_zerotrip && ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0)))
- gfc_warning ("DO loop at %L will be executed zero times"
- " (use -Wno-zerotrip to suppress)",
+ gfc_warning (OPT_Wzerotrip,
+ "DO loop at %L will be executed zero times",
&iter->step->where);
}
return true;
}
@@ -7707,12 +7708,13 @@ resolve_select (gfc_code *code, bool sel
if (cp->low != NULL && cp->high != NULL
&& cp->low != cp->high
&& gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
{
if (warn_surprising)
- gfc_warning ("Range specification at %L can never "
- "be matched", &cp->where);
+ gfc_warning (OPT_Wsurprising,
+ "Range specification at %L can never be matched",
+ &cp->where);
cp->unreachable = 1;
seen_unreachable = 1;
}
else
@@ -7809,11 +7811,12 @@ resolve_select (gfc_code *code, bool sel
}
/* More than two cases is legal but insane for logical selects.
Issue a warning for it. */
if (warn_surprising && type == BT_LOGICAL && ncases > 2)
- gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
+ gfc_warning (OPT_Wsurprising,
+ "Logical SELECT CASE block at %L has more that two cases",
&code->loc);
}
/* Check if a derived type is extensible. */
@@ -8797,11 +8800,11 @@ gfc_resolve_assign_in_forall (gfc_code *
/* If one of the FORALL index variables doesn't appear in the
assignment variable, then there could be a many-to-one
assignment. Emit a warning rather than an error because the
mask could be resolving this problem. */
if (!find_forall_index (code->expr1, forall_index, 0))
- gfc_warning ("The FORALL with index '%s' is not used on the "
+ gfc_warning ("The FORALL with index %qs is not used on the "
"left side of the assignment at %L and so might "
"cause multiple assignment to this object",
var_expr[n]->symtree->name, &code->expr1->where);
}
}
@@ -9179,12 +9182,13 @@ resolve_ordinary_assign (gfc_code *code,
/* Handle the case of a BOZ literal on the RHS. */
if (rhs->is_boz && lhs->ts.type != BT_INTEGER)
{
int rc;
if (warn_surprising)
- gfc_warning ("BOZ literal at %L is bitwise transferred "
- "non-integer symbol '%s'", &code->loc,
+ gfc_warning (OPT_Wsurprising,
+ "BOZ literal at %L is bitwise transferred "
+ "non-integer symbol %qs", &code->loc,
lhs->symtree->n.sym->name);
if (!gfc_convert_boz (rhs, &lhs->ts))
return false;
if ((rc = gfc_range_check (rhs)) != ARITH_OK)
@@ -10480,11 +10484,12 @@ resolve_charlen (gfc_charlen *cl)
/* "If the character length parameter value evaluates to a negative
value, the length of character entities declared is zero." */
if (cl->length && !gfc_extract_int (cl->length, &i) && i < 0)
{
if (warn_surprising)
- gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
+ gfc_warning_now (OPT_Wsurprising,
+ "CHARACTER variable at %L has negative length %d,"
" the length has been set to zero",
&cl->length->where, i);
gfc_replace_expr (cl->length,
gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
}
@@ -11497,11 +11502,12 @@ gfc_resolve_finalizers (gfc_symbol* deri
}
/* Warn if the procedure is non-scalar and not assumed shape. */
if (warn_surprising && arg->as && arg->as->rank != 0
&& arg->as->type != AS_ASSUMED_SHAPE)
- gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
+ gfc_warning (OPT_Wsurprising,
+ "Non-scalar FINAL procedure at %L should have assumed"
" shape argument", &arg->declared_at);
/* Check that it does not match in kind and rank with a FINAL procedure
defined earlier. To really loop over the *earlier* declarations,
we need to walk the tail of the list as new ones were pushed at the
@@ -11555,11 +11561,12 @@ error:
/* Warn if we haven't seen a scalar finalizer procedure (but we know there
were nodes in the list, must have been for arrays. It is surely a good
idea to have a scalar version there if there's something to finalize. */
if (warn_surprising && result && !seen_scalar)
- gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
+ gfc_warning (OPT_Wsurprising,
+ "Only array FINAL procedures declared for derived type %qs"
" defined at %L, suggest also scalar one",
derived->name, &derived->declared_at);
vtab = gfc_find_derived_vtab (derived);
c = vtab->ts.u.derived->components->next->next->next->next->next;
===================================================================
@@ -3793,11 +3793,12 @@ gfc_trans_deferred_vars (gfc_symbol * pr
if (el->sym != el->sym->result)
break;
}
/* TODO: move to the appropriate place in resolve.c. */
if (warn_return_type && el == NULL)
- gfc_warning ("Return value of function '%s' at %L not set",
+ gfc_warning (OPT_Wreturn_type,
+ "Return value of function %qs at %L not set",
proc_sym->name, &proc_sym->declared_at);
}
else if (proc_sym->as)
{
tree result = TREE_VALUE (current_fake_result_decl);
@@ -4428,11 +4429,12 @@ gfc_create_module_variable (gfc_symbol *
&& gfc_option.flag_module_private))))
sym->attr.access = ACCESS_PRIVATE;
if (warn_unused_variable && !sym->attr.referenced
&& sym->attr.access == ACCESS_PRIVATE)
- gfc_warning ("Unused PRIVATE module variable '%s' declared at %L",
+ gfc_warning (OPT_Wunused_value,
+ "Unused PRIVATE module variable %qs declared at %L",
sym->name, &sym->declared_at);
/* We always want module variables to be created. */
sym->attr.referenced = 1;
/* Create the decl. */
@@ -4990,26 +4992,29 @@ generate_local_decl (gfc_symbol * sym)
{
/* INTENT(out) dummy arguments are likely meant to be set. */
if (warn_unused_dummy_argument && sym->attr.intent == INTENT_OUT)
{
if (sym->ts.type != BT_DERIVED)
- gfc_warning ("Dummy argument '%s' at %L was declared "
+ gfc_warning (OPT_Wunused_dummy_argument,
+ "Dummy argument %qs at %L was declared "
"INTENT(OUT) but was not set", sym->name,
&sym->declared_at);
else if (!gfc_has_default_initializer (sym->ts.u.derived)
&& !sym->ts.u.derived->attr.zero_comp)
- gfc_warning ("Derived-type dummy argument '%s' at %L was "
+ gfc_warning (OPT_Wunused_dummy_argument,
+ "Derived-type dummy argument %qs at %L was "
"declared INTENT(OUT) but was not set and "
"does not have a default initializer",
sym->name, &sym->declared_at);
if (sym->backend_decl != NULL_TREE)
TREE_NO_WARNING(sym->backend_decl) = 1;
}
else if (warn_unused_dummy_argument)
{
- gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
- &sym->declared_at);
+ gfc_warning (OPT_Wunused_dummy_argument,
+ "Unused dummy argument %qs at %L", sym->name,
+ &sym->declared_at);
if (sym->backend_decl != NULL_TREE)
TREE_NO_WARNING(sym->backend_decl) = 1;
}
}
@@ -5018,19 +5023,21 @@ generate_local_decl (gfc_symbol * sym)
else if (warn_unused_variable
&& !(sym->attr.in_common || sym->mark || sym->attr.in_namelist))
{
if (sym->attr.use_only)
{
- gfc_warning ("Unused module variable '%s' which has been "
+ gfc_warning (OPT_Wunused_variable,
+ "Unused module variable %qs which has been "
"explicitly imported at %L", sym->name,
&sym->declared_at);
if (sym->backend_decl != NULL_TREE)
TREE_NO_WARNING(sym->backend_decl) = 1;
}
else if (!sym->attr.use_assoc)
{
- gfc_warning ("Unused variable '%s' declared at %L",
+ gfc_warning (OPT_Wunused_variable,
+ "Unused variable %qs declared at %L",
sym->name, &sym->declared_at);
if (sym->backend_decl != NULL_TREE)
TREE_NO_WARNING(sym->backend_decl) = 1;
}
}
@@ -5074,14 +5081,16 @@ generate_local_decl (gfc_symbol * sym)
{
if (warn_unused_parameter
&& !sym->attr.referenced)
{
if (!sym->attr.use_assoc)
- gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
+ gfc_warning (OPT_Wunused_parameter,
+ "Unused parameter %qs declared at %L", sym->name,
&sym->declared_at);
else if (sym->attr.use_only)
- gfc_warning ("Unused parameter '%s' which has been explicitly "
+ gfc_warning (OPT_Wunused_parameter,
+ "Unused parameter %qs which has been explicitly "
"imported at %L", sym->name, &sym->declared_at);
}
}
else if (sym->attr.flavor == FL_PROCEDURE)
{
@@ -5092,11 +5101,12 @@ generate_local_decl (gfc_symbol * sym)
&& sym != sym->result
&& !sym->result->attr.referenced
&& !sym->attr.use_assoc
&& sym->attr.if_source != IFSRC_IFBODY)
{
- gfc_warning ("Return value '%s' of function '%s' declared at "
+ gfc_warning (OPT_Wreturn_type,
+ "Return value %qs of function %qs declared at "
"%L not set", sym->result->name, sym->name,
&sym->result->declared_at);
/* Prevents "Unused variable" warning for RESULT variables. */
sym->result->mark = 1;
@@ -5119,11 +5129,12 @@ generate_local_decl (gfc_symbol * sym)
if (sym->attr.flavor == FL_PROCEDURE)
{
if (!sym->attr.referenced)
{
if (warn_unused_dummy_argument)
- gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
+ gfc_warning (OPT_Wunused_dummy_argument,
+ "Unused dummy argument %qs at %L", sym->name,
&sym->declared_at);
}
/* Silence bogus "unused parameter" warnings from the
middle end. */
@@ -5799,11 +5810,12 @@ gfc_generate_function_code (gfc_namespac
if (result == NULL_TREE)
{
/* TODO: move to the appropriate place in resolve.c. */
if (warn_return_type && sym == sym->result)
- gfc_warning ("Return value of function '%s' at %L not set",
+ gfc_warning (OPT_Wreturn_type,
+ "Return value of function %qs at %L not set",
sym->name, &sym->declared_at);
if (warn_return_type)
TREE_NO_WARNING(sym->backend_decl) = 1;
}
else
===================================================================
@@ -543,11 +543,11 @@ check_result (arith rc, gfc_expr *x, gfc
arith val = rc;
if (val == ARITH_UNDERFLOW)
{
if (warn_underflow)
- gfc_warning (gfc_arith_error (val), &x->where);
+ gfc_warning (OPT_Wunderflow, gfc_arith_error (val), &x->where);
val = ARITH_OK;
}
if (val == ARITH_ASYMMETRIC)
{
@@ -2076,11 +2076,11 @@ gfc_real2real (gfc_expr *src, int kind)
rc = gfc_check_real_range (result->value.real, kind);
if (rc == ARITH_UNDERFLOW)
{
if (warn_underflow)
- gfc_warning (gfc_arith_error (rc), &src->where);
+ gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
}
else if (rc != ARITH_OK)
{
arith_error (rc, &src->ts, &result->ts, &src->where);
@@ -2107,11 +2107,11 @@ gfc_real2complex (gfc_expr *src, int kin
rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
if (rc == ARITH_UNDERFLOW)
{
if (warn_underflow)
- gfc_warning (gfc_arith_error (rc), &src->where);
+ gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
}
else if (rc != ARITH_OK)
{
arith_error (rc, &src->ts, &result->ts, &src->where);
@@ -2162,11 +2162,11 @@ gfc_complex2real (gfc_expr *src, int kin
rc = gfc_check_real_range (result->value.real, kind);
if (rc == ARITH_UNDERFLOW)
{
if (warn_underflow)
- gfc_warning (gfc_arith_error (rc), &src->where);
+ gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
}
if (rc != ARITH_OK)
{
arith_error (rc, &src->ts, &result->ts, &src->where);
@@ -2193,11 +2193,11 @@ gfc_complex2complex (gfc_expr *src, int
rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
if (rc == ARITH_UNDERFLOW)
{
if (warn_underflow)
- gfc_warning (gfc_arith_error (rc), &src->where);
+ gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
}
else if (rc != ARITH_OK)
{
arith_error (rc, &src->ts, &result->ts, &src->where);
@@ -2208,11 +2208,11 @@ gfc_complex2complex (gfc_expr *src, int
rc = gfc_check_real_range (mpc_imagref (result->value.complex), kind);
if (rc == ARITH_UNDERFLOW)
{
if (warn_underflow)
- gfc_warning (gfc_arith_error (rc), &src->where);
+ gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
mpfr_set_ui (mpc_imagref (result->value.complex), 0, GFC_RND_MODE);
}
else if (rc != ARITH_OK)
{
arith_error (rc, &src->ts, &result->ts, &src->where);
@@ -2278,11 +2278,11 @@ hollerith2representation (gfc_expr *resu
src_len = src->representation.length - src->ts.u.pad;
result_len = gfc_target_expr_size (result);
if (src_len > result_len)
{
- gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
+ gfc_warning ("The Hollerith constant at %L is too long to convert to %qs",
&src->where, gfc_typename(&result->ts));
}
result->representation.string = XCNEWVEC (char, result_len + 1);
memcpy (result->representation.string, src->representation.string,
===================================================================
@@ -5079,13 +5079,13 @@ gfc_check_transfer (gfc_expr *source, gf
if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size,
&result_size, NULL))
return true;
if (source_size < result_size)
- gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
- "source size %ld < result size %ld", &source->where,
- (long) source_size, (long) result_size);
+ gfc_warning ("Intrinsic TRANSFER at %L has partly undefined result: "
+ "source size %ld < result size %ld", &source->where,
+ (long) source_size, (long) result_size);
return true;
}
===================================================================
@@ -954,11 +954,11 @@ gfc_check_argument_var_dependency (gfc_e
/* We are told not to check dependencies.
We do it, however, and issue a warning in case we find one.
If a dependency is found in the case
elemental == ELEM_CHECK_VARIABLE, we will generate
a temporary, so we don't need to bother the user. */
- gfc_warning ("INTENT(%s) actual argument at %L might "
+ gfc_warning_1 ("INTENT(%s) actual argument at %L might "
"interfere with actual argument at %L.",
intent == INTENT_OUT ? "OUT" : "INOUT",
&var->where, &expr->where);
}
return 0;
===================================================================
@@ -556,12 +556,13 @@ match_real_constant (gfc_expr **result,
{
if (!gfc_notify_std (GFC_STD_GNU, "exponent-letter 'q' in "
"real-literal-constant at %C"))
return MATCH_ERROR;
else if (warn_real_q_constant)
- gfc_warning("Extension: exponent-letter 'q' in real-literal-constant "
- "at %C");
+ gfc_warning (OPT_Wreal_q_constant,
+ "Extension: exponent-letter %<q%> in real-literal-constant "
+ "at %C");
}
/* Scan exponent. */
c = gfc_next_ascii_char ();
count++;
@@ -725,11 +726,11 @@ done:
gfc_error ("Real constant overflows its kind at %C");
goto cleanup;
case ARITH_UNDERFLOW:
if (warn_underflow)
- gfc_warning ("Real constant underflows its kind at %C");
+ gfc_warning (OPT_Wunderflow, "Real constant underflows its kind at %C");
mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
break;
default:
gfc_internal_error ("gfc_range_check() returned bad value");
@@ -1070,11 +1071,11 @@ got_delim:
gfc_current_locus = start_locus;
/* We disable the warning for the following loop as the warning has already
been printed in the loop above. */
save_warn_ampersand = warn_ampersand;
- warn_ampersand = 0;
+ warn_ampersand = false;
p = e->value.character.string;
for (i = 0; i < length; i++)
{
c = next_string_char (delimiter, &ret);
===================================================================
@@ -6145,11 +6145,12 @@ gfc_conv_intrinsic_transfer (gfc_se * se
if (!gfc_is_simply_contiguous (arg->expr, false))
{
tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
if (warn_array_temporaries)
- gfc_warning ("Creating array temporary at %L", &expr->where);
+ gfc_warning (OPT_Warray_temporaries,
+ "Creating array temporary at %L", &expr->where);
source = build_call_expr_loc (input_location,
gfor_fndecl_in_pack, 1, tmp);
source = gfc_evaluate_now (source, &argse.pre);
===================================================================
@@ -714,11 +714,12 @@ simplify_achar_char (gfc_expr *e, gfc_ex
&e->where);
return &gfc_bad_expr;
}
if (ascii && warn_surprising && mpz_cmp_si (e->value.integer, 127) > 0)
- gfc_warning ("Argument of %s function at %L outside of range [0,127]",
+ gfc_warning (OPT_Wsurprising,
+ "Argument of %s function at %L outside of range [0,127]",
name, &e->where);
if (kind == 1 && mpz_cmp_si (e->value.integer, 255) > 0)
too_large = true;
else if (kind == 4)
@@ -2503,11 +2504,12 @@ gfc_simplify_iachar (gfc_expr *e, gfc_ex
}
index = e->value.character.string[0];
if (warn_surprising && index > 127)
- gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
+ gfc_warning (OPT_Wsurprising,
+ "Argument of IACHAR function at %L outside of range 0..127",
&e->where);
k = get_kind (BT_INTEGER, kind, "IACHAR", gfc_default_integer_kind);
if (k == -1)
return &gfc_bad_expr;
This is the final patch. Bootstrapped and regression tested. The diagnostics part is the same as in https://gcc.gnu.org/ml/gcc-patches/2014-11/msg03416.html, except for fixing the minor nit in a comment pointed out by Dodji. I decided that the best testing would be to convert all calls (except for a few that use multiple locations) and see what it breaks. Surprisingly nothing broke, which suggests that either is working as expected or the Fortran testsuite needs many more testcases ;-) Since I needed to check every gfc_warning call for the use of multiple locations, I took the opportunity to replace replace '%s' with %qs and add the appropriate OPT_W* option (I may have missed some, they can be added later as a follow-up). OK? gcc/testsuite/ChangeLog: 2014-12-03 Manuel López-Ibáñez <manu@gcc.gnu.org> * gfortran.dg/warnings_are_errors_1.f90: Update warnings to errors. * gfortran.dg/warnings_are_errors_1.f: Likewise. gcc/fortran/ChangeLog: 2014-12-03 Manuel López-Ibáñez <manu@gcc.gnu.org> * gfortran.h (gfc_warning): Now returns bool. Add overload that accepts opt. (gfc_warning_1): Declare. * error.c (pp_warning_buffer,warningcount_buffered,werrorcount_buffered): New. (gfc_buffer_error): Set pp_warning_buffer.flush_p. (gfc_clear_pp_buffer): New. (gfc_warning_1): Renamed from gfc_warning. (gfc_warning): Add three new overloads. One that takes just a format string and ellipsis, another that takes also a warning option, and another that takes also va_list instead of ellipsis. (gfc_clear_warning): Clear pp_warning_buffer. (gfc_warning_check): Flush pp_warning_buffer and update warning and werror counters. (gfc_diagnostics_init): Init pp_warning_buffer. * Update all gfc_warning calls that do not have multiple locations to use %qs and OPT_W*, otherwise use gfc_warning_1. gcc/ChangeLog: 2014-12-03 Manuel López-Ibáñez <manu@gcc.gnu.org> * pretty-print.c (output_buffer::output_buffer): Init flush_p to true. (pp_flush): Flush only if flush_p. (pp_really_flush): New. * pretty-print.h (struct output_buffer): Add flush_p. (pp_really_flush): Declare.