[fortran] Improve error messages for mismatched arguments
diff mbox series

Message ID 54670cdf-da24-6f46-a563-e78ff0632938@netcologne.de
State New
Headers show
Series
  • [fortran] Improve error messages for mismatched arguments
Related show

Commit Message

Thomas Koenig Sept. 14, 2019, 12:27 p.m. UTC
Hello world,

the attached patch improves the rather hard to read error
messages for argument mismatches.  With this patch, this reads

argument_checking_21.f90:7:11:

     6 |   call foo(1.0) ! { dg-warning "Rank mismatch" }
       |           2
     7 |   call foo(b)   ! { dg-warning "Rank mismatch" }
       |           1
Fehler: Rank mismatch between actual argument at (1) and actual argument 
at (2) (scalar and rank-2)

which I think is fairly clear.  It also makes sure that warnings are
always emitted by -fallow-argument-mismatch by removing
-Wargument-mismatch.  Finally, for people who do not want to have too
many warnings cluttering up their logs, a type mismatch is only
shown once if it is a warning.

While I was going on about fixing warnings, I also fixed PR 91557 with
the bit in trans-expr.c.  This part is trivial, I will backport it
to the other affected branches.

After this, I think we can close PR 91556. Regression-tested. OK for
trunk?

2019-09-13  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  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.

Comments

Steve Kargl Sept. 14, 2019, 3:30 p.m. UTC | #1
On Sat, Sep 14, 2019 at 02:27:15PM +0200, Thomas Koenig wrote:
> 
> the attached patch improves the rather hard to read error
> messages for argument mismatches.  With this patch, this reads
> 
> argument_checking_21.f90:7:11:
> 
>      6 |   call foo(1.0) ! { dg-warning "Rank mismatch" }
>        |           2
>      7 |   call foo(b)   ! { dg-warning "Rank mismatch" }
>        |           1
> Fehler: Rank mismatch between actual argument at (1) and actual argument 
> at (2) (scalar and rank-2)
> 
> which I think is fairly clear.  It also makes sure that warnings are
> always emitted by -fallow-argument-mismatch by removing
> -Wargument-mismatch.  Finally, for people who do not want to have too
> many warnings cluttering up their logs, a type mismatch is only
> shown once if it is a warning.
> 
> While I was going on about fixing warnings, I also fixed PR 91557 with
> the bit in trans-expr.c.  This part is trivial, I will backport it
> to the other affected branches.
> 
> After this, I think we can close PR 91556. Regression-tested. OK for
> trunk?
> 

Looks good to me.  Thanks for working of this issue.

Patch
diff mbox series

Index: fortran/frontend-passes.c
===================================================================
--- fortran/frontend-passes.c	(Revision 275713)
+++ fortran/frontend-passes.c	(Arbeitskopie)
@@ -5373,7 +5373,8 @@  gfc_code_walker (gfc_code **c, walk_code_fn_t code
 /* 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 @@  static int
 
   if (def_sym)
     {
-      gfc_procedure_use (def_sym, &actual, loc);
+      gfc_compare_actual_formal (&actual, def_sym->formal, 0, 0, 0, loc);
       return 0;
     }
 
Index: fortran/gfortran.h
===================================================================
--- fortran/gfortran.h	(Revision 275713)
+++ fortran/gfortran.h	(Arbeitskopie)
@@ -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 */
Index: fortran/interface.c
===================================================================
--- fortran/interface.c	(Revision 275713)
+++ fortran/interface.c	(Arbeitskopie)
@@ -1807,9 +1807,9 @@  gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol
 	    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 *act
 
 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 *a
 				   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 *a
 				   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 *a
 					 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 *a
 	  && 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 *a
   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,8 +3112,7 @@  gfc_compare_actual_formal (gfc_actual_arglist **ap
 		       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),
@@ -3070,8 +3119,7 @@  gfc_compare_actual_formal (gfc_actual_arglist **ap
 			 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
 	  && 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
 	    {
 	      /* 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, g
       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 *sy
 		}
 	    }
 	  s->attr.dummy = 1;
+	  s->declared_at = a->expr->where;
 	  s->attr.intent = INTENT_UNKNOWN;
 	  (*f)->sym = s;
 	}
Index: fortran/invoke.texi
===================================================================
--- fortran/invoke.texi	(Revision 275713)
+++ fortran/invoke.texi	(Arbeitskopie)
@@ -145,7 +145,7 @@  by type.  Explanations are in the following sectio
 @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,9 +236,16 @@  intrinsic will be called except when it is explici
 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}
 A BOZ literal constant can occur in a limited number of contexts in
@@ -907,15 +914,6 @@  character constant, GNU Fortran assumes continuati
 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
Index: fortran/lang.opt
===================================================================
--- fortran/lang.opt	(Revision 275713)
+++ fortran/lang.opt	(Arbeitskopie)
@@ -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)
Index: fortran/resolve.c
===================================================================
--- fortran/resolve.c	(Revision 275713)
+++ fortran/resolve.c	(Arbeitskopie)
@@ -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 *
       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;
 	}
Index: fortran/trans-decl.c
===================================================================
--- fortran/trans-decl.c	(Revision 275713)
+++ fortran/trans-decl.c	(Arbeitskopie)
@@ -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;
 	    }
Index: testsuite/gfortran.dg/bessel_3.f90
===================================================================
--- testsuite/gfortran.dg/bessel_3.f90	(Revision 275713)
+++ testsuite/gfortran.dg/bessel_3.f90	(Arbeitskopie)
@@ -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
Index: testsuite/gfortran.dg/g77/20010519-1.f
===================================================================
--- testsuite/gfortran.dg/g77/20010519-1.f	(Revision 275713)
+++ testsuite/gfortran.dg/g77/20010519-1.f	(Arbeitskopie)
@@ -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
Index: testsuite/gfortran.dg/pr24823.f
===================================================================
--- testsuite/gfortran.dg/pr24823.f	(Revision 275713)
+++ testsuite/gfortran.dg/pr24823.f	(Arbeitskopie)
@@ -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
Index: testsuite/gfortran.dg/pr39937.f
===================================================================
--- testsuite/gfortran.dg/pr39937.f	(Revision 275713)
+++ testsuite/gfortran.dg/pr39937.f	(Arbeitskopie)
@@ -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,