re PR fortran/91557 (Bogus warning about unused dummy argument _formal_*)

2019-09-14  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/91557
	PR fortran/91556
	* frontend-passes.c (check_externals_procedure): Reformat argument
	list. Use gfc_compare_actual_formal instead of gfc_procedure_use.
	* gfortran.h (gfc_symbol): Add flag error.
	* interface.c (gfc_compare_interfaces): Reformat.
	(argument_rank_mismatch): Add where_formal argument. If it is
	present, note that the error is between different calls.
	(compare_parameter): Change warnings that previously dependended
	on -Wargument-mismatch to unconditional.  Issue an error / warning
	on type mismatch only once.  Pass where_formal to
	argument_rank_mismatch for artificial variables.
	(compare_actual_formal): Change warnings that previously
	dependeded on -Wargument-mismatch to unconditional.
	(gfc_check_typebound_override): Likewise.
	(gfc_get_formal_from_actual_arglist): Set declared_at for
	artificial symbol.
	* invoke.texi: Extend description of -fallow-argument-mismatch.
	Delete -Wargument-mismatch.
	* lang.opt: Change -Wargument-mismatch to do-nothing option.
	* resolve.c (resolve_structure_cons): Change warnings that
	previously depended on -Wargument-mismatch to unconditional.
	* trans-decl.c (generate_local_decl): Do not warn if the symbol is
	artificial.

2019-09-14  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/91557
	PR fortran/91556
	* gfortran.dg/argument_checking_20.f90: New test.
	* gfortran.dg/argument_checking_21.f90: New test.
	* gfortran.dg/argument_checking_22.f90: New test.
	* gfortran.dg/argument_checking_23.f90: New test.
	* gfortran.dg/warn_unused_dummy_argument_5.f90: New test.
	* gfortran.dg/bessel_3.f90: Add pattern for type mismatch.
	* gfortran.dg/g77/20010519-1.f: Adjust dg-warning messages to new
	handling.
	* gfortran.dg/pr24823.f: Likewise.
	* gfortran.dg/pr39937.f: Likewise.

From-SVN: r275719

gcc/fortran/ChangeLog

+2019-09-14  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/91557
+	PR fortran/91556
+	* frontend-passes.c (check_externals_procedure): Reformat argument
+	list. Use gfc_compare_actual_formal instead of gfc_procedure_use.
+	* gfortran.h (gfc_symbol): Add flag error.
+	* interface.c (gfc_compare_interfaces): Reformat.
+	(argument_rank_mismatch): Add where_formal argument. If it is
+	present, note that the error is between different calls.
+	(compare_parameter): Change warnings that previously dependended
+	on -Wargument-mismatch to unconditional.  Issue an error / warning
+	on type mismatch only once.  Pass where_formal to
+	argument_rank_mismatch for artificial variables.
+	(compare_actual_formal): Change warnings that previously
+	dependeded on -Wargument-mismatch to unconditional.
+	(gfc_check_typebound_override): Likewise.
+	(gfc_get_formal_from_actual_arglist): Set declared_at for
+	artificial symbol.
+	* invoke.texi: Extend description of -fallow-argument-mismatch.
+	Delete -Wargument-mismatch.
+	* lang.opt: Change -Wargument-mismatch to do-nothing option.
+	* resolve.c (resolve_structure_cons): Change warnings that
+	previously depended on -Wargument-mismatch to unconditional.
+	* trans-decl.c (generate_local_decl): Do not warn if the symbol is
+	artificial.
+
 2019-09-13  Steven G. Kargl  <kargl@gcc.gnu.org>
 
 	PR fortran/91566

gcc/fortran/frontend-passes.c

@@ -5373,7 +5373,8 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
 /* Common tests for argument checking for both functions and subroutines.  */
 
 static int
-check_externals_procedure (gfc_symbol *sym, locus *loc, gfc_actual_arglist *actual)
+check_externals_procedure (gfc_symbol *sym, locus *loc,
+			   gfc_actual_arglist *actual)
 {
   gfc_gsymbol *gsym;
   gfc_symbol *def_sym = NULL;
@@ -5396,7 +5397,7 @@ check_externals_procedure (gfc_symbol *sym, locus *loc, gfc_actual_arglist *actu
 
   if (def_sym)
     {
-      gfc_procedure_use (def_sym, &actual, loc);
+      gfc_compare_actual_formal (&actual, def_sym->formal, 0, 0, 0, loc);
       return 0;
     }
 

gcc/fortran/gfortran.h

@@ -1610,6 +1610,9 @@ typedef struct gfc_symbol
   /* Set if this is a module function or subroutine with the
      abreviated declaration in a submodule.  */
   unsigned abr_modproc_decl:1;
+  /* Set if a previous error or warning has occurred and no other
+     should be reported.  */
+  unsigned error:1;
 
   int refs;
   struct gfc_namespace *ns;	/* namespace containing this symbol */

gcc/fortran/interface.c

@@ -1807,9 +1807,9 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
 	    if (!compare_rank (f2->sym, f1->sym))
 	      {
 		if (errmsg != NULL)
-		  snprintf (errmsg, err_len, "Rank mismatch in argument '%s' "
-			    "(%i/%i)", f1->sym->name, symbol_rank (f1->sym),
-			    symbol_rank (f2->sym));
+		  snprintf (errmsg, err_len, "Rank mismatch in argument "
+			    "'%s' (%i/%i)", f1->sym->name,
+			    symbol_rank (f1->sym), symbol_rank (f2->sym));
 		return false;
 	      }
 	    if ((gfc_option.allow_std & GFC_STD_F2008)
@@ -2189,22 +2189,42 @@ compare_pointer (gfc_symbol *formal, gfc_expr *actual)
 
 static void
 argument_rank_mismatch (const char *name, locus *where,
-			int rank1, int rank2)
+			int rank1, int rank2, locus *where_formal)
 {
 
   /* TS 29113, C407b.  */
-  if (rank2 == -1)
-    gfc_error ("The assumed-rank array at %L requires that the dummy argument"
-	       " %qs has assumed-rank", where, name);
-  else if (rank1 == 0)
-    gfc_error_opt (OPT_Wargument_mismatch, "Rank mismatch in argument %qs "
-		   "at %L (scalar and rank-%d)", name, where, rank2);
-  else if (rank2 == 0)
-    gfc_error_opt (OPT_Wargument_mismatch, "Rank mismatch in argument %qs "
-		   "at %L (rank-%d and scalar)", name, where, rank1);
+  if (where_formal == NULL)
+    {
+      if (rank2 == -1)
+	gfc_error ("The assumed-rank array at %L requires that the dummy "
+		   "argument %qs has assumed-rank", where, name);
+      else if (rank1 == 0)
+	gfc_error_opt (0, "Rank mismatch in argument %qs "
+		       "at %L (scalar and rank-%d)", name, where, rank2);
+      else if (rank2 == 0)
+	gfc_error_opt (0, "Rank mismatch in argument %qs "
+		       "at %L (rank-%d and scalar)", name, where, rank1);
+      else
+	gfc_error_opt (0, "Rank mismatch in argument %qs "
+		       "at %L (rank-%d and rank-%d)", name, where, rank1,
+		       rank2);
+    }
   else
-    gfc_error_opt (OPT_Wargument_mismatch, "Rank mismatch in argument %qs "
-		   "at %L (rank-%d and rank-%d)", name, where, rank1, rank2);
+    {
+      gcc_assert (rank2 != -1);
+      if (rank1 == 0)
+	gfc_error_opt (0, "Rank mismatch between actual argument at %L "
+		       "and actual argument at %L (scalar and rank-%d)",
+		       where, where_formal, rank2);
+      else if (rank2 == 0)
+	gfc_error_opt (0, "Rank mismatch between actual argument at %L "
+		       "and actual argument at %L (rank-%d and scalar)",
+		       where, where_formal, rank1);
+      else
+	gfc_error_opt (0, "Rank mismatch between actual argument at %L "
+		       "and actual argument at %L (rank-%d and rank-%d", where,
+		       where_formal, rank1, rank2);
+    }
 }
 
 
@@ -2253,8 +2273,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 				   sizeof(err), NULL, NULL))
 	{
 	  if (where)
-	    gfc_error_opt (OPT_Wargument_mismatch,
-			   "Interface mismatch in dummy procedure %qs at %L:"
+	    gfc_error_opt (0, "Interface mismatch in dummy procedure %qs at %L:"
 			   " %s", formal->name, &actual->where, err);
 	  return false;
 	}
@@ -2281,8 +2300,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 				   err, sizeof(err), NULL, NULL))
 	{
 	  if (where)
-	    gfc_error_opt (OPT_Wargument_mismatch,
-			   "Interface mismatch in dummy procedure %qs at %L:"
+	    gfc_error_opt (0, "Interface mismatch in dummy procedure %qs at %L:"
 			   " %s", formal->name, &actual->where, err);
 	  return false;
 	}
@@ -2312,10 +2330,24 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 					 CLASS_DATA (actual)->ts.u.derived)))
     {
       if (where)
-	gfc_error_opt (OPT_Wargument_mismatch,
-		       "Type mismatch in argument %qs at %L; passed %s to %s",
-		       formal->name, where, gfc_typename (&actual->ts),
-		       gfc_typename (&formal->ts));
+	{
+	  if (formal->attr.artificial)
+	    {
+	      if (!flag_allow_argument_mismatch || !formal->error)
+		gfc_error_opt (0, "Type mismatch between actual argument at %L "
+			       "and actual argument at %L (%s/%s).",
+			       &actual->where,
+			       &formal->declared_at,
+			       gfc_typename (&actual->ts),
+			       gfc_typename (&formal->ts));
+
+	      formal->error = 1;
+	    }
+	  else
+	    gfc_error_opt (0, "Type mismatch in argument %qs at %L; passed %s "
+			   "to %s", formal->name, where, gfc_typename (&actual->ts),
+			   gfc_typename (&formal->ts));
+	}
       return false;
     }
 
@@ -2512,8 +2544,17 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 	  && gfc_is_coindexed (actual)))
     {
       if (where)
-	argument_rank_mismatch (formal->name, &actual->where,
-				symbol_rank (formal), actual->rank);
+	{
+	  locus *where_formal;
+	  if (formal->attr.artificial)
+	    where_formal = &formal->declared_at;
+	  else
+	    where_formal = NULL;
+
+	  argument_rank_mismatch (formal->name, &actual->where,
+				  symbol_rank (formal), actual->rank,
+				  where_formal);
+	}
       return false;
     }
   else if (actual->rank != 0 && (is_elemental || formal->attr.dimension))
@@ -2584,8 +2625,17 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
   if (ref == NULL && actual->expr_type != EXPR_NULL)
     {
       if (where)
-	argument_rank_mismatch (formal->name, &actual->where,
-				symbol_rank (formal), actual->rank);
+	{
+	  locus *where_formal;
+	  if (formal->attr.artificial)
+	    where_formal = &formal->declared_at;
+	  else
+	    where_formal = NULL;
+
+	  argument_rank_mismatch (formal->name, &actual->where,
+				  symbol_rank (formal), actual->rank,
+				  where_formal);
+	}
       return false;
     }
 
@@ -3062,16 +3112,14 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 		       f->sym->ts.u.cl->length->value.integer) != 0))
 	{
 	  if (where && (f->sym->attr.pointer || f->sym->attr.allocatable))
-	    gfc_warning (OPT_Wargument_mismatch,
-			 "Character length mismatch (%ld/%ld) between actual "
+	    gfc_warning (0, "Character length mismatch (%ld/%ld) between actual "
 			 "argument and pointer or allocatable 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);
 	  else if (where)
-	    gfc_warning (OPT_Wargument_mismatch,
-			 "Character length mismatch (%ld/%ld) between actual "
+	    gfc_warning (0, "Character length mismatch (%ld/%ld) between actual "
 			 "argument and assumed-shape dummy argument %qs "
 			 "at %L",
 			 mpz_get_si (a->expr->ts.u.cl->length->value.integer),
@@ -3102,8 +3150,7 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	  && f->sym->attr.flavor != FL_PROCEDURE)
 	{
 	  if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
-	    gfc_warning (OPT_Wargument_mismatch,
-			 "Character length of actual argument shorter "
+	    gfc_warning (0, "Character length of actual argument shorter "
 			 "than of dummy argument %qs (%lu/%lu) at %L",
 			 f->sym->name, actual_size, formal_size,
 			 &a->expr->where);
@@ -3111,8 +3158,7 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	    {
 	      /* Emit a warning for -std=legacy and an error otherwise. */
 	      if (gfc_option.warn_std == 0)
-	        gfc_warning (OPT_Wargument_mismatch,
-			     "Actual argument contains too few "
+	        gfc_warning (0, "Actual argument contains too few "
 			     "elements for dummy argument %qs (%lu/%lu) "
 			     "at %L", f->sym->name, actual_size,
 			     formal_size, &a->expr->where);
@@ -4706,8 +4752,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
       if (!gfc_check_dummy_characteristics (proc_formal->sym, old_formal->sym,
 					check_type, err, sizeof(err)))
 	{
-	  gfc_error_opt (OPT_Wargument_mismatch,
-			 "Argument mismatch for the overriding procedure "
+	  gfc_error_opt (0, "Argument mismatch for the overriding procedure "
 			 "%qs at %L: %s", proc->name, &where, err);
 	  return false;
 	}
@@ -5184,6 +5229,7 @@ gfc_get_formal_from_actual_arglist (gfc_symbol *sym,
 		}
 	    }
 	  s->attr.dummy = 1;
+	  s->declared_at = a->expr->where;
 	  s->attr.intent = INTENT_UNKNOWN;
 	  (*f)->sym = s;
 	}

gcc/fortran/invoke.texi

@@ -145,7 +145,7 @@ by type.  Explanations are in the following sections.
 @item Error and Warning Options
 @xref{Error and Warning Options,,Options to request or suppress errors
 and warnings}.
-@gccoptlist{-Waliasing -Wall -Wampersand -Wargument-mismatch -Warray-bounds @gol
+@gccoptlist{-Waliasing -Wall -Wampersand -Warray-bounds @gol
 -Wc-binding-type -Wcharacter-truncation -Wconversion @gol
 -Wdo-subscript -Wfunction-elimination -Wimplicit-interface @gol
 -Wimplicit-procedure -Wintrinsic-shadow -Wuse-without-only @gol
@@ -236,8 +236,15 @@ intrinsic will be called except when it is explicitly declared @code{EXTERNAL}.
 Some code contains calls to external procedures whith mismatches
 between the calls and the procedure definition, or with mismatches
 between different calls. Such code is non-conforming, and will usually
-be flagged with an error.  This options degrades the error to a
-warning.  This option is implied by @option{-std=legacy}.
+be flagged wi1th an error.  This options degrades the error to a
+warning, which can only be disabled by disabling all warnings vial
+@option{-w}.  Only a single occurrence per argument is flagged by this
+warning.  @option{-fallow-argument-mismatch} is implied by
+@option{-std=legacy}.
+
+Using this option is @emph{strongly} discouraged.  It is possible to
+provide standard-conforming code which allows different types of
+arguments by using an explicit interface and @code{TYPE(*)}.
 
 @item -fallow-invalid-boz
 @opindex @code{allow-invalid-boz}
@@ -907,15 +914,6 @@ character constant, GNU Fortran assumes continuation at the first
 non-comment, non-whitespace character after the ampersand that
 initiated the continuation.
 
-@item -Wargument-mismatch
-@opindex @code{Wargument-mismatch}
-@cindex warnings, argument mismatch
-@cindex warnings, parameter mismatch
-@cindex warnings, interface mismatch
-Warn about type, rank, and other mismatches between formal parameters and actual
-arguments to functions and subroutines.  These warnings are recommended and
-thus enabled by default.
-
 @item -Warray-temporaries
 @opindex @code{Warray-temporaries}
 @cindex warnings, array temporaries

gcc/fortran/lang.opt

@@ -210,8 +210,8 @@ Fortran Warning Var(warn_array_temporaries)
 Warn about creation of array temporaries.
 
 Wargument-mismatch
-Fortran Warning Var(warn_argument_mismatch) Init(1)
-Warn about type and rank mismatches between arguments and parameters.
+Fortran WarnRemoved
+Does nothing. Preserved for backward compatibility.
 
 Wc-binding-type
 Fortran Var(warn_c_binding_type) Warning LangEnabledBy(Fortran,Wall)

gcc/fortran/resolve.c

@@ -1429,8 +1429,7 @@ resolve_structure_cons (gfc_expr *expr, int init)
 	  if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1,
 					     err, sizeof (err), NULL, NULL))
 	    {
-	      gfc_error_opt (OPT_Wargument_mismatch,
-			     "Interface mismatch for procedure-pointer "
+	      gfc_error_opt (0, "Interface mismatch for procedure-pointer "
 			     "component %qs in structure constructor at %L:"
 			     " %s", comp->name, &cons->expr->where, err);
 	      return false;
@@ -2609,8 +2608,7 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
       if (!gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1,
 				   reason, sizeof(reason), NULL, NULL))
 	{
-	  gfc_error_opt (OPT_Wargument_mismatch,
-			 "Interface mismatch in global procedure %qs at %L:"
+	  gfc_error_opt (0, "Interface mismatch in global procedure %qs at %L:"
 			 " %s", sym->name, &sym->declared_at, reason);
 	  goto done;
 	}

gcc/fortran/trans-decl.c

@@ -5881,9 +5881,11 @@ generate_local_decl (gfc_symbol * sym)
 	    }
 	  else if (warn_unused_dummy_argument)
 	    {
-	      gfc_warning (OPT_Wunused_dummy_argument,
-			   "Unused dummy argument %qs at %L", sym->name,
-			   &sym->declared_at);
+	      if (!sym->attr.artificial)
+		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;
 	    }

gcc/testsuite/ChangeLog

+2019-09-14  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/91557
+	PR fortran/91556
+	* gfortran.dg/argument_checking_20.f90: New test.
+	* gfortran.dg/argument_checking_21.f90: New test.
+	* gfortran.dg/argument_checking_22.f90: New test.
+	* gfortran.dg/argument_checking_23.f90: New test.
+	* gfortran.dg/warn_unused_dummy_argument_5.f90: New test.
+	* gfortran.dg/bessel_3.f90: Add pattern for type mismatch.
+	* gfortran.dg/g77/20010519-1.f: Adjust dg-warning messages to new
+	handling.
+	* gfortran.dg/pr24823.f: Likewise.
+	* gfortran.dg/pr39937.f: Likewise.
+
 2019-09-14  Sandra Loosemore  <sandra@codesourcery.com>
 
 	PR testsuite/83889

gcc/testsuite/gfortran.dg/argument_checking_20.f90

+! { dg-do compile }
+program main
+  real :: a(10), b(10,10)
+! This should be caugt
+  call foo(1.0) ! { dg-error "Rank mismatch" }
+  call foo(b)   ! { dg-error "Rank mismatch" }
+! This is OK
+  call bar(a)
+  call bar(b)
+
+end program main

gcc/testsuite/gfortran.dg/argument_checking_21.f90

+! { dg-do compile }
+! { dg-options "-fallow-argument-mismatch" }
+program main
+  real :: a(10), b(10,10)
+! This should be caugt
+  call foo(1.0) ! { dg-warning "Rank mismatch" }
+  call foo(b)   ! { dg-warning "Rank mismatch" }
+! This is OK
+  call bar(a)
+  call bar(b)
+
+end program main

gcc/testsuite/gfortran.dg/argument_checking_22.f90

+! { dg-do compile }
+! PR 91556 - check that multiple errors are emitted for type mismatch
+! (and that the check is also done in contained procedures).
+
+program main
+  real :: a
+  call foo(a) ! { dg-error "Type mismatch" }
+contains
+  subroutine bar
+    integer :: b
+    complex :: c
+    call foo(b) ! { dg-error "Type mismatch" }
+    call foo(c) ! { dg-error "Type mismatch" }
+  end subroutine bar
+end program main

gcc/testsuite/gfortran.dg/argument_checking_23.f90

+! { dg-do compile }
+! { dg-options "-fallow-argument-mismatch" }
+! PR 91556 - check that only a single warning iw emitted for type
+! mismatch (and that the check is also done in contained procedures).
+
+program main
+  real :: a
+  call foo(a) ! { dg-warning "Type mismatch" }
+contains
+  subroutine bar
+    integer :: b
+    complex :: c
+    call foo(b) ! { dg-warning "Type mismatch" }
+    call foo(c)
+  end subroutine bar
+end program main

gcc/testsuite/gfortran.dg/bessel_3.f90

@@ -8,11 +8,11 @@ IMPLICIT NONE
 print *, SIN (1.0)
 print *, BESSEL_J0(1.0) ! { dg-error "has no IMPLICIT type" })
 print *, BESSEL_J1(1.0) ! { dg-error "has no IMPLICIT type" }
-print *, BESSEL_JN(1,1.0) ! { dg-error "has no IMPLICIT type" }
+print *, BESSEL_JN(1,1.0) ! { dg-error "has no IMPLICIT type|Type mismatch" }
 print *, BESSEL_JN(1,2,1.0) ! { dg-error "has no IMPLICIT type|Type mismatch" }
 
 print *, BESSEL_Y0(1.0) ! { dg-error "has no IMPLICIT type" }
 print *, BESSEL_Y1(1.0) ! { dg-error "has no IMPLICIT type" }
-print *, BESSEL_YN(1,1.0) ! { dg-error "has no IMPLICIT type" }
+print *, BESSEL_YN(1,1.0) ! { dg-error "has no IMPLICIT type|Type mismatch" }
 print *, BESSEL_YN(1,2,1.0) ! { dg-error "has no IMPLICIT type|Type mismatch" }
 end

gcc/testsuite/gfortran.dg/g77/20010519-1.f

@@ -773,7 +773,7 @@ C
       NTR=6
       OLDPRN=PRNLEV
       PRNLEV=1
-      CALL ORTHNM(1,6,NTR,HEAP(TRAROT),NAT3,.FALSE.,TOLER)
+      CALL ORTHNM(1,6,NTR,HEAP(TRAROT),NAT3,.FALSE.,TOLER) ! { dg-warning "Type mismatch" }
       PRNLEV=OLDPRN
       IF(IUNRMD .LT. 0) THEN
 C
@@ -1126,7 +1126,7 @@ C
          NFCUT=NFRET
          OLDPRN=PRNLEV
          PRNLEV=1
-         CALL ORTHNM(1,NFRET,NFCUT,DDV,NAT3,LPURG,TOLER) ! { dg-warning "Type mismatch" }
+         CALL ORTHNM(1,NFRET,NFCUT,DDV,NAT3,LPURG,TOLER)
          PRNLEV=OLDPRN
          NFRET=NFCUT
          IF(PRNLEV.GE.2) WRITE(OUTU,568) NFRET
@@ -1174,7 +1174,7 @@ C TO DO-THE-DIAGONALISATIONS
          NFSAV=NFCUT1
          OLDPRN=PRNLEV
          PRNLEV=1
-         CALL ORTHNM(1,NFCUT1,NFCUT,DDV,NAT3,LPURG,TOLER) ! { dg-warning "Type mismatch" }
+         CALL ORTHNM(1,NFCUT1,NFCUT,DDV,NAT3,LPURG,TOLER)
          PRNLEV=OLDPRN
          CALL CPARAY(HEAP(DDVBAS),DDV,NAT3,1,NFCUT,1)
          NFRET=NDIM+NFCUT
@@ -1224,7 +1224,7 @@ C
       CALL ADZERD(DDV,1,NFCUT1,NAT3,IS1,IS2,IS3,IS4)
       OLDPRN=PRNLEV
       PRNLEV=1
-      CALL ORTHNM(1,NFCUT1,NFCUT,DDV,NAT3,LPURG,TOLER) ! { dg-warning "Type mismatch" }
+      CALL ORTHNM(1,NFCUT1,NFCUT,DDV,NAT3,LPURG,TOLER)
       PRNLEV=OLDPRN
       CALL CPARAY(HEAP(DDVBAS),DDV,NAT3,1,NFCUT,1)
 C

gcc/testsuite/gfortran.dg/pr24823.f

@@ -50,9 +50,9 @@
             IF( I.LT.1 ) THEN
                IF( ISYM.EQ.0 ) THEN
                   A( J-I+1, I ) = DCONJG( ZLATM2( M, N, I, J, KL,
-     $                 DR, IPVTNG, IWORK, SPARSE ) )
+     $                 DR, IPVTNG, IWORK, SPARSE ) )  ! { dg-warning "Type mismatch" }
                ELSE
-                  A( J-I+1, I ) = ZLATM2( M, N, I, J, KL, KU, ! { dg-warning "Type mismatch" }
+                  A( J-I+1, I ) = ZLATM2( M, N, I, J, KL, KU,  ! { dg-warning "Type mismatch" }
      $                 IPVTNG, IWORK, SPARSE )
                END IF
             END IF
@@ -61,7 +61,7 @@
                   IF( ISYM.EQ.0 ) THEN
                   END IF
                END IF
-               A( I-J+KUU+1, J ) = ZLATM2( M, N, I, J, KL, KU, ! { dg-warning "Type mismatch" }
+               A( I-J+KUU+1, J ) = ZLATM2( M, N, I, J, KL, KU,
      $              DR, IPVTNG, IWORK, SPARSE )
             END IF
          END IF

gcc/testsuite/gfortran.dg/pr39937.f

@@ -6,7 +6,7 @@ C { dg-options "-std=legacy" }
      $                   WORK( * )
       DOUBLE PRECISION   X( 2, 2 )
       CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ),
-     $                            ZERO, X, 2, SCALE, XNORM, IERR )
+     $                            ZERO, X, 2, SCALE, XNORM, IERR ) ! { dg-warning "Type mismatch" }
       CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 )
       DO 90 J = KI - 2, 1, -1
       IF( J.GT.JNXT )
@@ -19,8 +19,8 @@ C { dg-options "-std=legacy" }
               END IF
           END IF
           CALL DLALN2( .FALSE., 2, 2, SMIN, ONE,
-     $                            T( J-1, J-1 ), LDT, ONE, ONE,
-     $                            XNORM, IERR ) ! { dg-warning "Type mismatch" }
+     $                            T( J-1, J-1 ), LDT, ONE, ONE,  ! { dg-warning "Type mismatch" }
+     $                            XNORM, IERR )
           CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1,
      $                           WORK( 1+N ), 1 )
           CALL DAXPY( J-2, -X( 2, 2 ), T( 1, J ), 1,

gcc/testsuite/gfortran.dg/warn_unused_dummy_argument_5.f90

+! { dg-do compile }
+! { dg-additional-options "-Wunused-dummy-argument" }
+! PR 91557 - this used to generate a bogus warning
+! Test case by Gerhard Steinmetz
+program p
+   integer :: a, b
+   a = 1
+   call g
+contains
+   subroutine g
+      integer :: x, y
+      call h (x, y)
+      if ( a > 0 )   y = y - 1
+      b = y - x + 1
+   end
+end