From: Janus Weil <janus@gcc.gnu.org>
Date: Wed, 27 Mar 2019 22:40:22 +0000 (+0100)
Subject: re PR fortran/85537 ([F08] Invalid memory reference at runtime when calling subroutin... 
X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=7076b27b7488bd8395310811a9c0d39ed5404490;p=gcc.git

re PR fortran/85537 ([F08] Invalid memory reference at runtime when calling subroutine through procedure pointer)

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 e1fdb93f3d0..372c517487f 100644
--- 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 f54affae18d..478a5557723 100644
--- 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 97908fef01e..f29455331f5 100644
--- 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 f51c5455c05..3e4b2b1d6f0 100644
--- 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
index 00000000000..3113e157687
--- /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