re PR fortran/85537 ([F08] Invalid memory reference at runtime when calling subroutin...

fix PR 85537

2019-03-27  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/85537
	* expr.c (gfc_check_assign_symbol): Reject internal and dummy procedures
	in procedure pointer initialization.

2019-03-27  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/85537
	* gfortran.dg/dummy_procedure_11.f90: Fix test case.
	* gfortran.dg/pointer_init_11.f90: New test case.

From-SVN: r269980

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index e1fdb93f3d061baa56045915aa0408771e36cde1..372c517487f8a7b5b3f0e463492f94cfa93bcc52 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2019-03-27  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/85537
+       * expr.c (gfc_check_assign_symbol): Reject internal and dummy procedures
+       in procedure pointer initialization.
+
 2019-03-27  Paul Thomas  <pault@gcc.gnu.org>
 
        PR fortran/88247

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index f54affae18dc67d5b20b1a6dfb2b026a1a7c5b03..478a55577237c6e9fdd420c5252b9280a09b8783 100644 (file)
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -4407,6 +4407,20 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_component *comp, gfc_expr *rvalue)
                     "may not be a procedure pointer", &rvalue->where);
          return false;
        }
+      if (attr.proc == PROC_INTERNAL)
+       {
+         gfc_error ("Internal procedure %qs is invalid in "
+                    "procedure pointer initialization at %L",
+                    rvalue->symtree->name, &rvalue->where);
+         return false;
+       }
+      if (attr.dummy)
+       {
+         gfc_error ("Dummy procedure %qs is invalid in "
+                    "procedure pointer initialization at %L",
+                    rvalue->symtree->name, &rvalue->where);
+         return false;
+       }
     }
 
   return true;

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 97908fef01eb0e42c508cab2045e09ebef834ee0..f29455331f51857c8134141bf2d2884e56eb35da 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2019-03-27  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/85537
+       * gfortran.dg/dummy_procedure_11.f90: Fix test case.
+       * gfortran.dg/pointer_init_11.f90: New test case.
+
 2019-03-27  Mateusz B  <mateuszb@poczta.onet.pl>
 
        PR target/85667

diff --git a/gcc/testsuite/gfortran.dg/dummy_procedure_11.f90 b/gcc/testsuite/gfortran.dg/dummy_procedure_11.f90
index f51c5455c050d21a842a1307d976d0c6d605160b..3e4b2b1d6f03c34328d786345e04340212c807ef 100644 (file)
--- a/gcc/testsuite/gfortran.dg/dummy_procedure_11.f90
+++ b/gcc/testsuite/gfortran.dg/dummy_procedure_11.f90
@@ -5,16 +5,18 @@
 ! Contributed by Vladimir Fuka <vladimir.fuka@gmail.com>
 
 type :: t
-  procedure(g), pointer, nopass :: ppc => g
+  procedure(g), pointer, nopass :: ppc
 end type
 
-procedure(g), pointer :: pp => g
+procedure(g), pointer :: pp
 type(t)::x
 
 print *, f(g)
 print *, f(g())      ! { dg-error "Expected a procedure for argument" }
+pp => g
 print *, f(pp)
 print *, f(pp())     ! { dg-error "Expected a procedure for argument" }
+x%ppc => g
 print *, f(x%ppc)
 print *, f(x%ppc())  ! { dg-error "Expected a procedure for argument" }
 

diff --git a/gcc/testsuite/gfortran.dg/pointer_init_11.f90 b/gcc/testsuite/gfortran.dg/pointer_init_11.f90
new file mode 100644 (file)
index 0000000..3113e15
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pointer_init_11.f90
@@ -0,0 +1,44 @@
+! { dg-do compile }
+!
+! PR 85537: [F08] Invalid memory reference at runtime when calling subroutine through procedure pointer
+!
+! Contributed by Tiziano Müller <dev-zero@gentoo.org>
+
+module m1
+    implicit none
+contains
+    subroutine foo()
+      integer :: a
+
+      abstract interface
+        subroutine ibar()
+        end subroutine
+      end interface
+
+      procedure(ibar), pointer :: bar_ptr => bar_impl  ! { dg-error "invalid in procedure pointer initialization" }
+
+    contains
+      subroutine bar_impl()
+        write (*,*) "foo"
+        a = a + 1
+      end subroutine
+
+    end subroutine
+end module
+
+
+module m2
+    implicit none
+contains
+    subroutine foo(dbar)
+      interface
+        subroutine dbar()
+        end subroutine
+      end interface
+
+      procedure(dbar), pointer :: bar_ptr => dbar  ! { dg-error "invalid in procedure pointer initialization" }
+
+      call bar_ptr()
+
+    end subroutine
+end module