re PR fortran/91390 (treatment of extra parameter in a subroutine call)

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

	PR fortran/91390
	PR fortran/91519
	* 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_formal): 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-24  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/91390
	PR fortran/91519
	* 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 catch-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.

From-SVN: r274902

gcc/fortran/ChangeLog

+2019-08-24  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/91390
+	PR fortran/91519
+	* 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_formal): 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-23  Mark Eggleston  <mark.eggleston@codethink.com>
 
 	* intrinsics.text: References in 'See also:' are now on
@@ -14,7 +32,7 @@
 
 2019-08-23  Mark Eggleston  <mark.eggleston@codethink.com>
 
-	* intrinsics.text: Removed empty sections. The order of 
+	* intrinsics.text: Removed empty sections. The order of
 	sections for each intrinsic is now consistent throughout.
 	Stray words removed. Text in the wrong section moved.
 	Missing standard statement inserted.

gcc/fortran/frontend-passes.c

@@ -5369,72 +5369,104 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
    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);
   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,
 		      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)
-    return 0;
+}
 
-  gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
-  if (gsym == NULL)
+/* 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;
 
-  gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym);
+  sym = e->value.function.esym;
+  if (sym == NULL)
+    return 0;
 
-  if (sym && def_sym)
-    gfc_procedure_use (def_sym, &co->ext.actual, &co->loc);
+  loc = &e->where;
+  actual = e->value.function.actual;
 
-  return 0;
+  return check_externals_procedure (sym, loc, actual);
 }
 
 /* Called routine.  */

gcc/fortran/gfortran.h

@@ -3421,6 +3421,9 @@ bool gfc_check_typebound_override (gfc_symtree*, gfc_symtree*);
 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 */

gcc/fortran/interface.c

@@ -2878,10 +2878,10 @@ lookup_arg_fuzzy (const char *arg, gfc_formal_arglist *arguments)
    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_arglist **ap, locus *where)
 
   /* 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_arglist **ap, locus *where)
       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** args, gfc_symbol* sym)
   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);
+    }
+}

gcc/fortran/trans-types.c

@@ -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_actual_arglist *actual_args)
   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)

gcc/testsuite/ChangeLog

+2019-08-24  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/91390
+	PR fortran/91519
+	* 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 catch-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.
+
 2019-08-24  Paolo Carlini  <paolo.carlini@oracle.com>
 
 	* g++.dg/conversion/simd4.C: Test all the locations.

gcc/testsuite/gfortran.dg/bessel_3.f90

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

gcc/testsuite/gfortran.dg/coarray_7.f90

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

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

 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

gcc/testsuite/gfortran.dg/goacc/acc_on_device-1.f95

 ! 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")
 

gcc/testsuite/gfortran.dg/internal_pack_9.f90

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

gcc/testsuite/gfortran.dg/pr24823.f

 !     { 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

gcc/testsuite/gfortran.fortran-torture/compile/pr39937.f → gcc/testsuite/gfortran.dg/pr39937.f

+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, * ),
@@ -18,7 +20,7 @@
           END IF
           CALL DLALN2( .FALSE., 2, 2, SMIN, ONE,
      $                            T( J-1, J-1 ), LDT, ONE, ONE,
-     $                            XNORM, IERR )
+     $                            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,