[fortran] Fix PR 91390 - treatment of extra parameter in a subroutine call

Message ID 81d346ae-3da0-d082-234d-a0cc64050a7e@tkoenig.net
State New
Headers show
Series
  • [fortran] Fix PR 91390 - treatment of extra parameter in a subroutine call
Related show

Commit Message

Thomas König Aug. 20, 2019, 8:32 p.m.
Hello world,

here is the next installment of checking for mismatched calls,
this time for mismatching CALLs.

The solution is to build a separate namespace with procedure
arguments determined from the actual arguments the first time a
procedure is seen, and then compare it against that on subsequent
calls.

This has uncovered quite a few examples of non-conforming code
in our testsuite, so no separate test case needed, IMHO.

So, OK for trunk?  (The -std=legacy question can be settled
later).

2019-08-20  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/91390
	* frontend-passes.c (check_externals_procedure): New
	function. If a procedure is not in the translation unit, create
	an "interface" for it, including its formal arguments.
	(check_externals_code): Use check_externals_procedure for common
	code with check_externals_expr.
	(check_externals_expr): Vice versa.
	* gfortran.h (gfc_get_formal_from_actual-arglist): New prototype.
	(gfc_compare_actual_formal): New prototype.
	* interface.c (compare_actual_formal): Rename to
	(gfc_compare_actual_forma): New function, make global.
	(gfc_get_formal_from_actual_arglist): Make global, and move here from
	* trans-types.c (get_formal_from_actual_arglist): Remove here.
	(gfc_get_function_type): Use gfc_get_formal_from_actual_arglist.

2019-08-20  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/91390
	* gfortran.dg/bessel_3.f90: Add type mismatch errors.
	* gfortran.dg/coarray_7.f90: Rename subroutines to avoid
	additional errors.
	* gfortran.dg/g77/20010519-1.f: Add -std=legacy. Remove
	warnings for ASSIGN. Add warnings for type mismatch.
	* gfortran.dg/goacc/acc_on_device-1.f95: Add -std=legacy.
	Add cath-all warning.
	* gfortran.dg/internal_pack_9.f90: Rename subroutine to
	avoid type error.
	* gfortran.dg/internal_pack_9.f90: Add -std=legacy. Add
	warnings for type mismatch.
	* gfortran.dg/pr39937.f: Add -std=legacy and type warnings. Move
	here from
	* gfortran.fortran-torture/compile/pr39937.f: Move to gfortran.dg.

Comments

Thomas Koenig Aug. 22, 2019, 6:50 p.m. | #1
Am 20.08.19 um 22:32 schrieb Thomas König:

> here is the next installment of checking for mismatched calls,

> this time for mismatching CALLs.


The reorganization of the code also means that
https://gcc.gnu.org/bugzilla/show_bug.cgi?id=91519 (a rejects-valid
regression) is fixed by this patch.

So, OK for trunk?

Regards

	Thomas
Steve Kargl Aug. 22, 2019, 6:54 p.m. | #2
On Thu, Aug 22, 2019 at 08:50:20PM +0200, Thomas Koenig wrote:
> Am 20.08.19 um 22:32 schrieb Thomas König:

> 

> > here is the next installment of checking for mismatched calls,

> > this time for mismatching CALLs.

> 

> The reorganization of the code also means that

> https://gcc.gnu.org/bugzilla/show_bug.cgi?id=91519 (a rejects-valid

> regression) is fixed by this patch.

> 

> So, OK for trunk?

> 


I'll have time to look over the patch on Saturday.
If someone can give the patch a review, then go
for it.

-- 
Steve
Steve Kargl Aug. 24, 2019, 5:18 p.m. | #3
On Tue, Aug 20, 2019 at 10:32:37PM +0200, Thomas König wrote:
> 

> 2019-08-20  Thomas Koenig  <tkoenig@gcc.gnu.org>

> 

> 	PR fortran/91390

> 	* frontend-passes.c (check_externals_procedure): New

> 	function. If a procedure is not in the translation unit, create

> 	an "interface" for it, including its formal arguments.

> 	(check_externals_code): Use check_externals_procedure for common

> 	code with check_externals_expr.

> 	(check_externals_expr): Vice versa.

> 	* gfortran.h (gfc_get_formal_from_actual-arglist): New prototype.

> 	(gfc_compare_actual_formal): New prototype.

> 	* interface.c (compare_actual_formal): Rename to

> 	(gfc_compare_actual_forma): New function, make global.


spelling. forma -> formal

> 

> 2019-08-20  Thomas Koenig  <tkoenig@gcc.gnu.org>

> 

> 	PR fortran/91390

> 	* gfortran.dg/bessel_3.f90: Add type mismatch errors.

> 	* gfortran.dg/coarray_7.f90: Rename subroutines to avoid

> 	additional errors.

> 	* gfortran.dg/g77/20010519-1.f: Add -std=legacy. Remove

> 	warnings for ASSIGN. Add warnings for type mismatch.

> 	* gfortran.dg/goacc/acc_on_device-1.f95: Add -std=legacy.

> 	Add cath-all warning.


spelling. cath -> catch


OK.  Thanks for taking on this task.

As to the open question about how to handle this check,
I would create -fallow-argument-mismatch (or whatever
option name you like).  gfortran issues an error if
a mismatch is detected.  -fallow-... would reduce the
error to warning, which can only be silenced with -w.
Hopefully, this will encourage users to fix the code.

-- 
steve
Thomas König Aug. 24, 2019, 9:15 p.m. | #4
Hi Steve,

> OK.  Thanks for taking on this task.


Committed (r274902). Thanks for the review!

> As to the open question about how to handle this check,

> I would create -fallow-argument-mismatch (or whatever

> option name you like).  gfortran issues an error if

> a mismatch is detected.  -fallow-... would reduce the

> error to warning, which can only be silenced with -w.

> Hopefully, this will encourage users to fix the code.


Yes, that is what I will submit next.  -fallow-argument-mismatch
sounds like a good name, unless somebody else comes up with a
better name.

Regards

	Thomas

Patch

Index: fortran/frontend-passes.c
===================================================================
--- fortran/frontend-passes.c	(Revision 274623)
+++ fortran/frontend-passes.c	(Arbeitskopie)
@@ -5369,25 +5369,22 @@  gfc_code_walker (gfc_code **c, walk_code_fn_t code
    We do this by looping over the code (and expressions). The first call
    we happen to find is assumed to be canonical.  */
 
-/* Callback for external functions.  */
 
+/* Common tests for argument checking for both functions and subroutines.  */
+
 static int
-check_externals_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED,
-		      void *data ATTRIBUTE_UNUSED)
+check_externals_procedure (gfc_symbol *sym, locus *loc, gfc_actual_arglist *actual)
 {
-  gfc_expr *e = *ep;
-  gfc_symbol *sym, *def_sym;
   gfc_gsymbol *gsym;
+  gfc_symbol *def_sym = NULL;
 
-  if (e->expr_type != EXPR_FUNCTION)
+ if (sym == NULL || sym->attr.is_bind_c)
     return 0;
 
-  sym = e->value.function.esym;
-
-  if (sym == NULL || sym->attr.is_bind_c)
+  if (sym->attr.proc != PROC_EXTERNAL && sym->attr.proc != PROC_UNKNOWN)
     return 0;
 
-  if (sym->attr.proc != PROC_EXTERNAL && sym->attr.proc != PROC_UNKNOWN)
+  if (sym->attr.if_source == IFSRC_IFBODY || sym->attr.if_source == IFSRC_DECL)
     return 0;
 
   gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
@@ -5394,15 +5391,39 @@  static int
   if (gsym == NULL)
     return 0;
 
-  gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym);
+  if (gsym->ns)
+    gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym);
 
-  if (sym && def_sym)
-    gfc_procedure_use (def_sym, &e->value.function.actual, &e->where);
+  if (def_sym)
+    {
+      gfc_procedure_use (def_sym, &actual, loc);
+      return 0;
+    }
 
+  /* First time we have seen this procedure called. Let's create an
+     "interface" from the call and put it into a new namespace.  */
+  gfc_namespace *save_ns;
+  gfc_symbol *new_sym;
+
+  gsym->where = *loc;
+  save_ns = gfc_current_ns;
+  gsym->ns = gfc_get_namespace (gfc_current_ns, 0);
+  gsym->ns->proc_name = sym;
+
+  gfc_get_symbol (sym->name, gsym->ns, &new_sym);
+  gcc_assert (new_sym);
+  new_sym->attr = sym->attr;
+  new_sym->attr.if_source = IFSRC_DECL;
+  gfc_current_ns = gsym->ns;
+
+  gfc_get_formal_from_actual_arglist (new_sym, actual);
+  gfc_current_ns = save_ns;
+
   return 0;
+
 }
 
-/* Callback for external code.  */
+/* Callback for calls of external routines.  */
 
 static int
 check_externals_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
@@ -5409,32 +5430,43 @@  check_externals_code (gfc_code **c, int *walk_subt
 		      void *data ATTRIBUTE_UNUSED)
 {
   gfc_code *co = *c;
-  gfc_symbol *sym, *def_sym;
-  gfc_gsymbol *gsym;
+  gfc_symbol *sym;
+  locus *loc;
+  gfc_actual_arglist *actual;
 
   if (co->op != EXEC_CALL)
     return 0;
 
   sym = co->resolved_sym;
-  if (sym == NULL || sym->attr.is_bind_c)
-    return 0;
+  loc = &co->loc;
+  actual = co->ext.actual;
 
-  if (sym->attr.proc != PROC_EXTERNAL && sym->attr.proc != PROC_UNKNOWN)
-    return 0;
+  return check_externals_procedure (sym, loc, actual);
 
-  if (sym->attr.if_source == IFSRC_IFBODY || sym->attr.if_source == IFSRC_DECL)
+}
+
+/* Callback for external functions.  */
+
+static int
+check_externals_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED,
+		      void *data ATTRIBUTE_UNUSED)
+{
+  gfc_expr *e = *ep;
+  gfc_symbol *sym;
+  locus *loc;
+  gfc_actual_arglist *actual;
+
+  if (e->expr_type != EXPR_FUNCTION)
     return 0;
 
-  gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
-  if (gsym == NULL)
+  sym = e->value.function.esym;
+  if (sym == NULL)
     return 0;
 
-  gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym);
+  loc = &e->where;
+  actual = e->value.function.actual;
 
-  if (sym && def_sym)
-    gfc_procedure_use (def_sym, &co->ext.actual, &co->loc);
-
-  return 0;
+  return check_externals_procedure (sym, loc, actual);
 }
 
 /* Called routine.  */
Index: fortran/gfortran.h
===================================================================
--- fortran/gfortran.h	(Revision 274623)
+++ fortran/gfortran.h	(Arbeitskopie)
@@ -3421,6 +3421,9 @@  bool gfc_check_typebound_override (gfc_symtree*, g
 void gfc_check_dtio_interfaces (gfc_symbol*);
 gfc_symtree* gfc_find_typebound_dtio_proc (gfc_symbol *, bool, bool);
 gfc_symbol* gfc_find_specific_dtio_proc (gfc_symbol*, bool, bool);
+void gfc_get_formal_from_actual_arglist (gfc_symbol *, gfc_actual_arglist *);
+bool gfc_compare_actual_formal (gfc_actual_arglist **, gfc_formal_arglist *,
+				int, int, bool, locus *);
 
 
 /* io.c */
Index: fortran/interface.c
===================================================================
--- fortran/interface.c	(Revision 274623)
+++ fortran/interface.c	(Arbeitskopie)
@@ -2878,10 +2878,10 @@  lookup_arg_fuzzy (const char *arg, gfc_formal_argl
    errors when things don't match instead of just returning the status
    code.  */
 
-static bool
-compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
-	 	       int ranks_must_agree, int is_elemental,
-		       bool in_statement_function, locus *where)
+bool
+gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
+			   int ranks_must_agree, int is_elemental,
+			   bool in_statement_function, locus *where)
 {
   gfc_actual_arglist **new_arg, *a, *actual;
   gfc_formal_arglist *f;
@@ -3805,8 +3805,8 @@  gfc_procedure_use (gfc_symbol *sym, gfc_actual_arg
 
   /* For a statement function, check that types and type parameters of actual
      arguments and dummy arguments match.  */
-  if (!compare_actual_formal (ap, dummy_args, 0, sym->attr.elemental,
-			      sym->attr.proc == PROC_ST_FUNCTION, where))
+  if (!gfc_compare_actual_formal (ap, dummy_args, 0, sym->attr.elemental,
+				  sym->attr.proc == PROC_ST_FUNCTION, where))
     return false;
  
   if (!check_intents (dummy_args, *ap))
@@ -3854,7 +3854,7 @@  gfc_ppc_use (gfc_component *comp, gfc_actual_argli
       return;
     }
 
-  if (!compare_actual_formal (ap, comp->ts.interface->formal, 0,
+  if (!gfc_compare_actual_formal (ap, comp->ts.interface->formal, 0,
 			      comp->attr.elemental, false, where))
     return;
 
@@ -3880,7 +3880,7 @@  gfc_arglist_matches_symbol (gfc_actual_arglist** a
   dummy_args = gfc_sym_get_dummy_args (sym);
 
   r = !sym->attr.elemental;
-  if (compare_actual_formal (args, dummy_args, r, !r, false, NULL))
+  if (gfc_compare_actual_formal (args, dummy_args, r, !r, false, NULL))
     {
       check_intents (dummy_args, *args);
       if (warn_aliasing)
@@ -5131,3 +5131,65 @@  finish:
 
   return dtio_sub;
 }
+
+/* Helper function - if we do not find an interface for a procedure,
+   construct it from the actual arglist.  Luckily, this can only
+   happen for call by reference, so the information we actually need
+   to provide (and which would be impossible to guess from the call
+   itself) is not actually needed.  */
+
+void
+gfc_get_formal_from_actual_arglist (gfc_symbol *sym,
+				    gfc_actual_arglist *actual_args)
+{
+  gfc_actual_arglist *a;
+  gfc_formal_arglist **f;
+  gfc_symbol *s;
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  static int var_num;
+
+  f = &sym->formal;
+  for (a = actual_args; a != NULL; a = a->next)
+    {
+      (*f) = gfc_get_formal_arglist ();
+      if (a->expr)
+	{
+	  snprintf (name, GFC_MAX_SYMBOL_LEN, "_formal_%d", var_num ++);
+	  gfc_get_symbol (name, gfc_current_ns, &s);
+	  if (a->expr->ts.type == BT_PROCEDURE)
+	    {
+	      s->attr.flavor = FL_PROCEDURE;
+	    }
+	  else
+	    {
+	      s->ts = a->expr->ts;
+
+	      if (s->ts.type == BT_CHARACTER)
+		s->ts.u.cl = gfc_get_charlen ();
+
+	      s->ts.deferred = 0;
+	      s->ts.is_iso_c = 0;
+	      s->ts.is_c_interop = 0;
+	      s->attr.flavor = FL_VARIABLE;
+	      s->attr.artificial = 1;
+	      if (a->expr->rank > 0)
+		{
+		  s->attr.dimension = 1;
+		  s->as = gfc_get_array_spec ();
+		  s->as->rank = 1;
+		  s->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind,
+						      &a->expr->where, 1);
+		  s->as->upper[0] = NULL;
+		  s->as->type = AS_ASSUMED_SIZE;
+		}
+	    }
+	  s->attr.dummy = 1;
+	  s->attr.intent = INTENT_UNKNOWN;
+	  (*f)->sym = s;
+	}
+      else  /* If a->expr is NULL, this is an alternate rerturn.  */
+	(*f)->sym = NULL;
+
+      f = &((*f)->next);
+    }
+}
Index: fortran/trans-types.c
===================================================================
--- fortran/trans-types.c	(Revision 274623)
+++ fortran/trans-types.c	(Arbeitskopie)
@@ -2975,66 +2975,6 @@  create_fn_spec (gfc_symbol *sym, tree fntype)
   return build_type_attribute_variant (fntype, tmp);
 }
 
-/* Helper function - if we do not find an interface for a procedure,
-   construct it from the actual arglist.  Luckily, this can only
-   happen for call by reference, so the information we actually need
-   to provide (and which would be impossible to guess from the call
-   itself) is not actually needed.  */
-
-static void
-get_formal_from_actual_arglist (gfc_symbol *sym, gfc_actual_arglist *actual_args)
-{
-  gfc_actual_arglist *a;
-  gfc_formal_arglist **f;
-  gfc_symbol *s;
-  char name[GFC_MAX_SYMBOL_LEN + 1];
-  static int var_num;
-
-  f = &sym->formal;
-  for (a = actual_args; a != NULL; a = a->next)
-    {
-      (*f) = gfc_get_formal_arglist ();
-      if (a->expr)
-	{
-	  snprintf (name, GFC_MAX_SYMBOL_LEN, "_formal_%d", var_num ++);
-	  gfc_get_symbol (name, gfc_current_ns, &s);
-	  if (a->expr->ts.type == BT_PROCEDURE)
-	    {
-	      s->attr.flavor = FL_PROCEDURE;
-	    }
-	  else
-	    {
-	      s->ts = a->expr->ts;
-
-	      if (s->ts.type == BT_CHARACTER)
-		  s->ts.u.cl = gfc_get_charlen ();
-
-	      s->ts.deferred = 0;
-	      s->ts.is_iso_c = 0;
-	      s->ts.is_c_interop = 0;
-	      s->attr.flavor = FL_VARIABLE;
-	      if (a->expr->rank > 0)
-		{
-		  s->attr.dimension = 1;
-		  s->as = gfc_get_array_spec ();
-		  s->as->rank = 1;
-		  s->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind,
-						      &a->expr->where, 1);
-		  s->as->upper[0] = NULL;
-		  s->as->type = AS_ASSUMED_SIZE;
-		}
-	    }
-	  s->attr.dummy = 1;
-	  s->attr.intent = INTENT_UNKNOWN;
-	  (*f)->sym = s;
-	}
-      else  /* If a->expr is NULL, this is an alternate rerturn.  */
-	(*f)->sym = NULL;
-
-      f = &((*f)->next);
-    }
-}
-
 tree
 gfc_get_function_type (gfc_symbol * sym, gfc_actual_arglist *actual_args)
 {
@@ -3097,7 +3037,7 @@  gfc_get_function_type (gfc_symbol * sym, gfc_actua
   if (sym->backend_decl == error_mark_node && actual_args != NULL
       && sym->formal == NULL && (sym->attr.proc == PROC_EXTERNAL
 				 || sym->attr.proc == PROC_UNKNOWN))
-    get_formal_from_actual_arglist (sym, actual_args);
+    gfc_get_formal_from_actual_arglist (sym, actual_args);
 
   /* Build the argument types for the function.  */
   for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
Index: testsuite/gfortran.dg/bessel_3.f90
===================================================================
--- testsuite/gfortran.dg/bessel_3.f90	(Revision 274623)
+++ testsuite/gfortran.dg/bessel_3.f90	(Arbeitskopie)
@@ -9,10 +9,10 @@  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,2,1.0) ! { dg-error "has no IMPLICIT type" }
+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,2,1.0) ! { dg-error "has no IMPLICIT type" }
+print *, BESSEL_YN(1,2,1.0) ! { dg-error "has no IMPLICIT type|Type mismatch" }
 end
Index: testsuite/gfortran.dg/coarray_7.f90
===================================================================
--- testsuite/gfortran.dg/coarray_7.f90	(Revision 274623)
+++ testsuite/gfortran.dg/coarray_7.f90	(Arbeitskopie)
@@ -50,9 +50,9 @@  program test
   call coarray(caf2)
   call coarray(caf2[1]) ! { dg-error "must be a coarray" }
   call ups(i)
-  call ups(i[1]) ! { dg-error "with ultimate pointer component" }
-  call ups(i%ptr)
-  call ups(i[1]%ptr) ! OK - passes target not pointer
+  call ups1(i[1]) ! { dg-error "with ultimate pointer component" }
+  call ups2(i%ptr)
+  call ups3(i[1]%ptr) ! OK - passes target not pointer
 contains
   subroutine asyn(a)
     integer, intent(in), asynchronous :: a
Index: testsuite/gfortran.dg/g77/20010519-1.f
===================================================================
--- testsuite/gfortran.dg/g77/20010519-1.f	(Revision 274623)
+++ testsuite/gfortran.dg/g77/20010519-1.f	(Arbeitskopie)
@@ -1,4 +1,5 @@ 
 c { dg-do compile }
+c { dg-options "-std=legacy" }
 CHARMM Element source/dimb/nmdimb.src 1.1
 C.##IF DIMB
       SUBROUTINE NMDIMB(X,Y,Z,NAT3,BNBND,BIMAG,LNOMA,AMASS,DDS,DDSCR,
@@ -711,19 +712,19 @@  C Begin
      1     'NFREG IS LARGER THAN PARDIM*3')
 C
 C ALLOCATE-SPACE-FOR-TRANSROT-VECTORS
-      ASSIGN 801 TO I800 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" }
+      ASSIGN 801 TO I800
       GOTO 800
  801  CONTINUE
 C ALLOCATE-SPACE-FOR-DIAGONALIZATION
-      ASSIGN 721 TO I720 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" }
+      ASSIGN 721 TO I720
       GOTO 720
  721  CONTINUE
 C ALLOCATE-SPACE-FOR-REDUCED-BASIS
-      ASSIGN 761 TO I760 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" }
+      ASSIGN 761 TO I760
       GOTO 760
  761  CONTINUE
 C ALLOCATE-SPACE-FOR-OTHER-ARRAYS
-      ASSIGN 921 TO I920 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" }
+      ASSIGN 921 TO I920
       GOTO 920
  921  CONTINUE
 C
@@ -731,12 +732,12 @@  C Space allocation for working arrays of EISPACK
 C diagonalization subroutines
       IF(LSCI) THEN
 C ALLOCATE-SPACE-FOR-LSCI
-         ASSIGN 841 TO I840 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" }
+         ASSIGN 841 TO I840
          GOTO 840
  841     CONTINUE
       ELSE
 C ALLOCATE-DUMMY-SPACE-FOR-LSCI
-         ASSIGN 881 TO I880 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" }
+         ASSIGN 881 TO I880
          GOTO 880
  881     CONTINUE
       ENDIF
@@ -846,7 +847,7 @@  C Orthonormalize the eigenvectors
 C
          OLDPRN=PRNLEV
          PRNLEV=1
-         CALL ORTHNM(1,NFRET,NFRET,DDV,NAT3,LPURG,TOLER)
+         CALL ORTHNM(1,NFRET,NFRET,DDV,NAT3,LPURG,TOLER) ! { dg-warning "Type mismatch" }
          PRNLEV=OLDPRN
 C
 C Do reduced basis diagonalization using the DDV vectors
@@ -878,11 +879,11 @@  C
 C
 C DO-THE-DIAGONALISATIONS-WITH-RESIDUALS
 C
-         ASSIGN 621 TO I620 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" }
+         ASSIGN 621 TO I620
          GOTO 620
  621     CONTINUE
 C SAVE-MODES
-         ASSIGN 701 TO I700 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" }
+         ASSIGN 701 TO I700
          GOTO 700
  701     CONTINUE
          IF(ITER.EQ.ITMX) THEN
@@ -1025,17 +1026,17 @@  C
             CALL PARTDS(NAT3,NPARC,ATMPAR,NPARS,ATMPAS,INIDS,NPARMX,
      1                  DDF,NFREG,CUTF1,PARDIM,NFCUT1)
 C DO-THE-DIAGONALISATIONS
-            ASSIGN 641 to I640 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" }
+            ASSIGN 641 to I640
             GOTO 640
  641        CONTINUE
             QDIAG=.FALSE.
 C DO-THE-DIAGONALISATIONS-WITH-RESIDUALS
-            ASSIGN 622 TO I620 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" }
+            ASSIGN 622 TO I620
             GOTO 620
  622        CONTINUE
             QDIAG=.TRUE.
 C SAVE-MODES
-            ASSIGN 702 TO I700 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" }
+            ASSIGN 702 TO I700
             GOTO 700
  702        CONTINUE
 C
@@ -1048,7 +1049,7 @@  C
                   ITER=ITER+1
                   IF(PRNLEV.GE.2) WRITE(OUTU,553) ITER
 C DO-THE-DWIN-DIAGONALISATIONS
-                  ASSIGN 661 TO I660 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" }
+                  ASSIGN 661 TO I660
                   GOTO 660
  661              CONTINUE
                ENDIF
@@ -1056,13 +1057,13 @@  C DO-THE-DWIN-DIAGONALISATIONS
                   IRESF=0
                   QDIAG=.FALSE.
 C DO-THE-DIAGONALISATIONS-WITH-RESIDUALS
-                  ASSIGN 623 TO I620 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" }
+                  ASSIGN 623 TO I620
                   GOTO 620
  623              CONTINUE
                   QDIAG=.TRUE.
                   IF((CVGMX.LE.TOLDIM).OR.(ITER.EQ.ITMX)) GOTO 600
 C SAVE-MODES
-                  ASSIGN 703 TO I700 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" }
+                  ASSIGN 703 TO I700
                   GOTO 700
  703              CONTINUE
                ENDIF
@@ -1072,7 +1073,7 @@  C SAVE-MODES
  600  CONTINUE
 C
 C SAVE-MODES
-      ASSIGN 704 TO I700 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" }
+      ASSIGN 704 TO I700
       GOTO 700
  704  CONTINUE
       CALL CLEANHP(NAT3,NFREG,NPARD,NSUBP,PARDIM,DDV2,DDSS,DDVBAS,
@@ -1125,7 +1126,7 @@  C
          NFCUT=NFRET
          OLDPRN=PRNLEV
          PRNLEV=1
-         CALL ORTHNM(1,NFRET,NFCUT,DDV,NAT3,LPURG,TOLER)
+         CALL ORTHNM(1,NFRET,NFCUT,DDV,NAT3,LPURG,TOLER) ! { dg-warning "Type mismatch" }
          PRNLEV=OLDPRN
          NFRET=NFCUT
          IF(PRNLEV.GE.2) WRITE(OUTU,568) NFRET
@@ -1150,7 +1151,7 @@  C
      6     HEAP(BDRATQ),HEAP(INRATQ),LSCI,LBIG,IUNMOD)
          CALL SELNMD(DDF,NFRET,CUTF1,NFCUT1)
       ENDIF
-      GOTO I620 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" }
+      GOTO I620 
 C
 C-----------------------------------------------------------------------
 C TO DO-THE-DIAGONALISATIONS
@@ -1173,7 +1174,7 @@  C TO DO-THE-DIAGONALISATIONS
          NFSAV=NFCUT1
          OLDPRN=PRNLEV
          PRNLEV=1
-         CALL ORTHNM(1,NFCUT1,NFCUT,DDV,NAT3,LPURG,TOLER)
+         CALL ORTHNM(1,NFCUT1,NFCUT,DDV,NAT3,LPURG,TOLER) ! { dg-warning "Type mismatch" }
          PRNLEV=OLDPRN
          CALL CPARAY(HEAP(DDVBAS),DDV,NAT3,1,NFCUT,1)
          NFRET=NDIM+NFCUT
@@ -1190,7 +1191,7 @@  C TO DO-THE-DIAGONALISATIONS
          NFCUT1=NFCUT
          NFRET=NFCUT
       ENDDO
-      GOTO I640 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" }
+      GOTO I640 
 C
 C-----------------------------------------------------------------------
 C TO DO-THE-DWIN-DIAGONALISATIONS
@@ -1223,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)
+      CALL ORTHNM(1,NFCUT1,NFCUT,DDV,NAT3,LPURG,TOLER) ! { dg-warning "Type mismatch" }
       PRNLEV=OLDPRN
       CALL CPARAY(HEAP(DDVBAS),DDV,NAT3,1,NFCUT,1)
 C
@@ -1241,7 +1242,7 @@  C
       IF(NFCUT.GT.NFRRES) NFCUT=NFRRES
       NFCUT1=NFCUT
       NFRET=NFCUT
-      GOTO I660 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" }
+      GOTO I660 
 C
 C-----------------------------------------------------------------------
 C TO SAVE-MODES
@@ -1258,7 +1259,7 @@  C TO SAVE-MODES
       CALL WRTNMD(LCARD,ISTRT,ISTOP,NAT3,DDV,DDSCR,DDEV,IUNMOD,
      1            AMASS)
       CALL SAVEIT(IUNMOD)
-      GOTO I700 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" }
+      GOTO I700 
 C
 C-----------------------------------------------------------------------
 C TO ALLOCATE-SPACE-FOR-DIAGONALIZATION
@@ -1269,7 +1270,7 @@  C TO ALLOCATE-SPACE-FOR-DIAGONALIZATION
       JSPACE=JSPACE+JSP
       DDSS=ALLHP(JSPACE)
       DD5=DDSS+JSPACE-JSP
-      GOTO I720 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" }
+      GOTO I720 
 C
 C-----------------------------------------------------------------------
 C TO ALLOCATE-SPACE-FOR-REDUCED-BASIS
@@ -1279,13 +1280,13 @@  C TO ALLOCATE-SPACE-FOR-REDUCED-BASIS
       ELSE
          DDVBAS=ALLHP(IREAL8(NFREG*NAT3))
       ENDIF
-      GOTO I760 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" }
+      GOTO I760 
 C
 C-----------------------------------------------------------------------
 C TO ALLOCATE-SPACE-FOR-TRANSROT-VECTORS
  800  CONTINUE
       TRAROT=ALLHP(IREAL8(6*NAT3))
-      GOTO I800 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" }
+      GOTO I800 
 C
 C-----------------------------------------------------------------------
 C TO ALLOCATE-SPACE-FOR-LSCI
@@ -1300,7 +1301,7 @@  C TO ALLOCATE-SPACE-FOR-LSCI
       E2RATQ=ALLHP(IREAL8(PARDIM+3))
       BDRATQ=ALLHP(IREAL8(PARDIM+3))
       INRATQ=ALLHP(INTEG4(PARDIM+3))
-      GOTO I840 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" }
+      GOTO I840 
 C
 C-----------------------------------------------------------------------
 C TO ALLOCATE-DUMMY-SPACE-FOR-LSCI
@@ -1315,13 +1316,13 @@  C TO ALLOCATE-DUMMY-SPACE-FOR-LSCI
       E2RATQ=ALLHP(IREAL8(2))
       BDRATQ=ALLHP(IREAL8(2))
       INRATQ=ALLHP(INTEG4(2))
-      GOTO I880 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" }
+      GOTO I880 
 C
 C-----------------------------------------------------------------------
 C TO ALLOCATE-SPACE-FOR-OTHER-ARRAYS
  920  CONTINUE
       IUPD=ALLHP(INTEG4(PARDIM+3))
-      GOTO I920 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" }
+      GOTO I920 
 C.##ELSE
 C.##ENDIF
       END
Index: testsuite/gfortran.dg/goacc/acc_on_device-1.f95
===================================================================
--- testsuite/gfortran.dg/goacc/acc_on_device-1.f95	(Revision 274623)
+++ testsuite/gfortran.dg/goacc/acc_on_device-1.f95	(Arbeitskopie)
@@ -1,5 +1,5 @@ 
 ! Have to enable optimizations, as otherwise builtins won't be expanded.
-! { dg-additional-options "-O -fdump-rtl-expand" }
+! { dg-additional-options "-O -fdump-rtl-expand -std=legacy" }
 
 logical function f ()
   implicit none
@@ -9,7 +9,7 @@  logical function f ()
 
   f = .false.
   f = f .or. acc_on_device ()
-  f = f .or. acc_on_device (1, 2)
+  f = f .or. acc_on_device (1, 2) ! { dg-warning ".*" }
   f = f .or. acc_on_device (3.14)
   f = f .or. acc_on_device ("hello")
 
Index: testsuite/gfortran.dg/internal_pack_9.f90
===================================================================
--- testsuite/gfortran.dg/internal_pack_9.f90	(Revision 274623)
+++ testsuite/gfortran.dg/internal_pack_9.f90	(Arbeitskopie)
@@ -10,9 +10,9 @@ 
 ! Case 1: Substring encompassing the whole string
 subroutine foo2
   implicit none
-  external foo
+  external foo_char
   character(len=20) :: str(2) = '1234567890'
-  call foo(str(:)(1:20)) ! This is still not fixed.
+  call foo_char (str(:)(1:20)) ! This is still not fixed.
 end
 
 ! Case 2: Contiguous array section
Index: testsuite/gfortran.dg/pr24823.f
===================================================================
--- testsuite/gfortran.dg/pr24823.f	(Revision 274623)
+++ testsuite/gfortran.dg/pr24823.f	(Arbeitskopie)
@@ -1,5 +1,5 @@ 
 !     { dg-do compile }
-!     { dg-options "-O2" }
+!     { dg-options "-O2 -std=legacy" }
 !     PR24823 Flow didn't handle a PARALLEL as destination of a SET properly.
       SUBROUTINE ZLATMR( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX,
      $     RSIGN, GRADE, DL, MODEL, CONDL, DR, MODER,
@@ -52,7 +52,7 @@ 
                   A( J-I+1, I ) = DCONJG( ZLATM2( M, N, I, J, KL,
      $                 DR, IPVTNG, IWORK, SPARSE ) )
                ELSE
-                  A( J-I+1, I ) = ZLATM2( M, N, I, J, KL, KU,
+                  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,
+               A( I-J+KUU+1, J ) = ZLATM2( M, N, I, J, KL, KU, ! { dg-warning "Type mismatch" }
      $              DR, IPVTNG, IWORK, SPARSE )
             END IF
          END IF
Index: testsuite/gfortran.dg/pr39937.f
===================================================================
--- testsuite/gfortran.dg/pr39937.f	(nicht existent)
+++ testsuite/gfortran.dg/pr39937.f	(Arbeitskopie)
@@ -0,0 +1,30 @@ 
+C { dg-do compile }
+C { dg-options "-std=legacy" }
+      SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
+     $                   LDVR, MM, M, WORK, INFO )
+      DOUBLE PRECISION   T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
+     $                   WORK( * )
+      DOUBLE PRECISION   X( 2, 2 )
+      CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ),
+     $                            ZERO, X, 2, SCALE, XNORM, IERR )
+      CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 )
+      DO 90 J = KI - 2, 1, -1
+      IF( J.GT.JNXT )
+     $               GO TO 90
+      JNXT = J - 1
+      IF( J.GT.1 ) THEN
+          IF( T( J, J-1 ).NE.ZERO ) THEN
+              IF( WORK( J ).GT.BIGNUM / XNORM ) THEN
+                  X( 1, 1 ) = X( 1, 1 ) / XNORM
+              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" }
+          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,
+     $                           WORK( 1+N2 ), 1 )
+      END IF
+   90          CONTINUE
+      END
Index: testsuite/gfortran.fortran-torture/compile/pr39937.f
===================================================================
--- testsuite/gfortran.fortran-torture/compile/pr39937.f	(Revision 274623)
+++ testsuite/gfortran.fortran-torture/compile/pr39937.f	(nicht existent)
@@ -1,28 +0,0 @@ 
-      SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
-     $                   LDVR, MM, M, WORK, INFO )
-      DOUBLE PRECISION   T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
-     $                   WORK( * )
-      DOUBLE PRECISION   X( 2, 2 )
-      CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ),
-     $                            ZERO, X, 2, SCALE, XNORM, IERR )
-      CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 )
-      DO 90 J = KI - 2, 1, -1
-      IF( J.GT.JNXT )
-     $               GO TO 90
-      JNXT = J - 1
-      IF( J.GT.1 ) THEN
-          IF( T( J, J-1 ).NE.ZERO ) THEN
-              IF( WORK( J ).GT.BIGNUM / XNORM ) THEN
-                  X( 1, 1 ) = X( 1, 1 ) / XNORM
-              END IF
-          END IF
-          CALL DLALN2( .FALSE., 2, 2, SMIN, ONE,
-     $                            T( J-1, J-1 ), LDT, ONE, ONE,
-     $                            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,
-     $                           WORK( 1+N2 ), 1 )
-      END IF
-   90          CONTINUE
-      END