Fortran: improve checking of procedures passed as actual argument [PR50377]

Procedures passed as actual argument require either an explicit interface
or must be declared EXTERNAL.  Add a check and generate an error (default)
or a warning when -std=legacy is specified.

	PR fortran/50377

gcc/fortran/ChangeLog:

	* resolve.cc (resolve_actual_arglist): Check procedure actual
	arguments.

gcc/testsuite/ChangeLog:

	* gfortran.dg/pr41011.f: Fix invalid testcase.
	* gfortran.dg/actual_procedure_2.f: New test.

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 75270064ed438a8069cdf56f332853285433778c..4c45de08f035d38c8455ea6c93763c72e8149d22 100644 (file)
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -2295,6 +2295,30 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
          goto cleanup;
        }
 
+      if (e->expr_type == EXPR_VARIABLE
+         && e->ts.type == BT_PROCEDURE
+         && no_formal_args
+         && sym->attr.flavor == FL_PROCEDURE
+         && sym->attr.if_source == IFSRC_UNKNOWN
+         && !sym->attr.external
+         && !sym->attr.intrinsic
+         && !sym->attr.artificial
+         && !sym->ts.interface)
+       {
+         /* Emit a warning for -std=legacy and an error otherwise. */
+         if (gfc_option.warn_std == 0)
+           gfc_warning (0, "Procedure %qs at %L used as actual argument but "
+                        "does neither have an explicit interface nor the "
+                        "EXTERNAL attribute", sym->name, &e->where);
+         else
+           {
+             gfc_error ("Procedure %qs at %L used as actual argument but "
+                        "does neither have an explicit interface nor the "
+                        "EXTERNAL attribute", sym->name, &e->where);
+             goto cleanup;
+           }
+       }
+
       first_actual_arg = false;
     }
 

diff --git a/gcc/testsuite/gfortran.dg/actual_procedure_2.f b/gcc/testsuite/gfortran.dg/actual_procedure_2.f
new file mode 100644 (file)
index 0000000..247ebc1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/actual_procedure_2.f
@@ -0,0 +1,22 @@
+! { dg-do compile }
+! PR fortran/50377
+!
+! Reject procedures passed as actual argument if there is no explicit
+! interface and they are not declared EXTERNAL
+!
+! Contributed by Vittorio Zecca
+
+!     external sub      ! Required for valid code
+!     external fun      ! Required for valid code
+      call sub(sub)     ! { dg-error "used as actual argument" }
+      z = fun(fun)      ! { dg-error "used as actual argument" }
+      end
+
+      subroutine sub(y)
+      external y
+      end
+
+      real function fun(z)
+      external z
+      f = 1.
+      end

diff --git a/gcc/testsuite/gfortran.dg/pr41011.f b/gcc/testsuite/gfortran.dg/pr41011.f
index c0323102a0c7bb2a4baa11d1e0f4a2e9061023ea..376ae8b0e41ceef3cc675e4665cb9e34ba7d00a5 100644 (file)
--- a/gcc/testsuite/gfortran.dg/pr41011.f
+++ b/gcc/testsuite/gfortran.dg/pr41011.f
@@ -1,5 +1,7 @@
 ! { dg-do compile }
 ! { dg-options "-O3 -std=legacy" }
+      SUBROUTINE PR41011 (DCDX)
+      DIMENSION DCDX(*)
       CALL UVSET(NX,NY,NZ,HVAR,ZET,NP,DZ,DKM,UM,VM,UG,VG,TM,DCDX, ! { dg-warning "Rank mismatch|Invalid procedure argument" }
      *ITY,ISH,NSMT,F)
          CALL DCTDX(NX,NY,NX1,NFILT,C(MLAG),DCDX(MLAG),HELP,HELPA,