[diagnostics/fortran] Move gfc_warning (buffered) to the common diagnostics machinery
diff mbox

Message ID CAESRpQCEaKNEhaRm=1LaUZuebRz41sNQiCridJPBg1=9s=_2zA@mail.gmail.com
State New
Headers show

Commit Message

Manuel López-Ibáñez Dec. 2, 2014, 11:53 p.m. UTC
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.

Comments

Tobias Burnus Dec. 3, 2014, 7:10 a.m. UTC | #1
Hello,

Manuel López-Ibáñez wrote:
> 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?

OK. Looks good to me. Thanks for the patch work!

Tobias

> 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.

Patch
diff mbox

Index: gcc/pretty-print.c
===================================================================
--- gcc/pretty-print.c	(revision 218278)
+++ gcc/pretty-print.c	(working copy)
@@ -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
Index: gcc/pretty-print.h
===================================================================
--- gcc/pretty-print.h	(revision 218278)
+++ gcc/pretty-print.h	(working copy)
@@ -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 *);
Index: gcc/testsuite/gfortran.dg/warnings_are_errors_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/warnings_are_errors_1.f90	(revision 218278)
+++ gcc/testsuite/gfortran.dg/warnings_are_errors_1.f90	(working copy)
@@ -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
Index: gcc/testsuite/gfortran.dg/warnings_are_errors_1.f
===================================================================
--- gcc/testsuite/gfortran.dg/warnings_are_errors_1.f	(revision 218278)
+++ gcc/testsuite/gfortran.dg/warnings_are_errors_1.f	(working copy)
@@ -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 } }
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c	(revision 218278)
+++ gcc/fortran/interface.c	(working copy)
@@ -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;
Index: gcc/fortran/intrinsic.c
===================================================================
--- gcc/fortran/intrinsic.c	(revision 218278)
+++ gcc/fortran/intrinsic.c	(working copy)
@@ -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);
 }
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(revision 218278)
+++ gcc/fortran/trans-expr.c	(working copy)
@@ -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);
Index: gcc/fortran/trans-array.c
===================================================================
--- gcc/fortran/trans-array.c	(revision 218278)
+++ gcc/fortran/trans-array.c	(working copy)
@@ -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);
 
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(revision 218278)
+++ gcc/fortran/symbol.c	(working copy)
@@ -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));
 	    }
 	}
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(revision 218278)
+++ gcc/fortran/decl.c	(working copy)
@@ -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));
 	    }
 	}
Index: gcc/fortran/trans-common.c
===================================================================
--- gcc/fortran/trans-common.c	(revision 218278)
+++ gcc/fortran/trans-common.c	(working copy)
@@ -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);
 }
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 218278)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -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);
Index: gcc/fortran/error.c
===================================================================
--- gcc/fortran/error.c	(revision 218278)
+++ gcc/fortran/error.c	(working copy)
@@ -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)
 {
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c	(revision 218278)
+++ gcc/fortran/trans-stmt.c	(working copy)
@@ -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);
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c	(revision 218278)
+++ gcc/fortran/expr.c	(working copy)
@@ -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;
 }
Index: gcc/fortran/scanner.c
===================================================================
--- gcc/fortran/scanner.c	(revision 218278)
+++ gcc/fortran/scanner.c	(working copy)
@@ -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)
Index: gcc/fortran/io.c
===================================================================
--- gcc/fortran/io.c	(revision 218278)
+++ gcc/fortran/io.c	(working copy)
@@ -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)
Index: gcc/fortran/frontend-passes.c
===================================================================
--- gcc/fortran/frontend-passes.c	(revision 218278)
+++ gcc/fortran/frontend-passes.c	(working copy)
@@ -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
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 218278)
+++ gcc/fortran/resolve.c	(working copy)
@@ -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;
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c	(revision 218278)
+++ gcc/fortran/trans-decl.c	(working copy)
@@ -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
Index: gcc/fortran/arith.c
===================================================================
--- gcc/fortran/arith.c	(revision 218278)
+++ gcc/fortran/arith.c	(working copy)
@@ -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,
Index: gcc/fortran/check.c
===================================================================
--- gcc/fortran/check.c	(revision 218278)
+++ gcc/fortran/check.c	(working copy)
@@ -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;
 }
 
 
Index: gcc/fortran/dependency.c
===================================================================
--- gcc/fortran/dependency.c	(revision 218278)
+++ gcc/fortran/dependency.c	(working copy)
@@ -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;
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c	(revision 218278)
+++ gcc/fortran/primary.c	(working copy)
@@ -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);
Index: gcc/fortran/trans-intrinsic.c
===================================================================
--- gcc/fortran/trans-intrinsic.c	(revision 218278)
+++ gcc/fortran/trans-intrinsic.c	(working copy)
@@ -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);
 
Index: gcc/fortran/simplify.c
===================================================================
--- gcc/fortran/simplify.c	(revision 218278)
+++ gcc/fortran/simplify.c	(working copy)
@@ -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;