+2014-12-03 Manuel López-Ibáñez <manu@gcc.gnu.org>
+
+ PR fortran/44054
+ * 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.
+
2014-12-03 Jakub Jelinek <jakub@redhat.com>
* Makefile.in (ALL_HOST_BACKEND_OBJS): Add $(GENGTYPE_OBJS),
+2014-12-03 Manuel López-Ibáñez <manu@gcc.gnu.org>
+
+ PR fortran/44054
+ * 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 use multiple
+ locations to use %qs and OPT_W*, otherwise use gfc_warning_1.
+
2014-12-02 Tobias Burnus <burnus@net-b.de>
Manuel López-Ibáñez <manu@gcc.gnu.org>
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 (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)
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)
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)
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)
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)
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));
}
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;
}
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);
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;
}
/* 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;
/* 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);
}
"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));
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);
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. */
gfc_buffer_error (int flag)
{
buffer_flag = flag;
+ pp_warning_buffer.flush_p = !flag;
}
}
+/* 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;
}
+/* 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. */
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;
}
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;
}
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
/* 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. */
{
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)
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);
}
}
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);
}
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. */
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
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);
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;
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;
}
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 (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),
{
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;
|| (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);
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 (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)
{
/* 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;
/* 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);
}
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;
}
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;
}
"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. */
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;
/* 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++)
{
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 &&
/* 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;
}
&& (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)",
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);
}
&& 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;
/* 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);
}
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);
{
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))
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,
/* 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
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);
{
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
}
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)
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 (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;
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));
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)
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
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,
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),
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);
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);
}
}
/* 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)
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. */
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);
}
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;
}
{
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)
}
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;
&& !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);
}
}
&& !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);
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);
}
{
/* 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;
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);
}
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);
if (!result)
{
gfc_warning ("An alternate return at %L without a * dummy argument",
- &code->expr1->where);
+ &code->expr1->where);
return gfc_generate_return ();
}
cur_chunk_array (),
stream (stderr),
line_length (),
- digit_buffer ()
+ digit_buffer (),
+ flush_p (true)
{
obstack_init (&formatted_obstack);
obstack_init (&chunk_obstack);
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);
}
/* 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. */
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 *);
+2014-12-03 Manuel López-Ibáñez <manu@gcc.gnu.org>
+
+ PR fortran/44054
+ * gfortran.dg/warnings_are_errors_1.f90: Update warnings to errors.
+ * gfortran.dg/warnings_are_errors_1.f: Likewise.
+
2014-12-03 David Edelsohn <dje.gcc@gmail.com>
* g++.dg/ext/visibility/anon[12].C: Require visibility support.
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
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:
projects / gcc.git / commitdiff