re PR fortran/80046 ([F03] Explicit interface required: pointer argument)

2017-04-10  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/80046
	* expr.c (gfc_check_pointer_assign): Check if procedure pointer
	components in a pointer assignment need an explicit interface.

2017-04-10  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/80046
	* gfortran.dg/proc_ptr_comp_48.f90: New test case.

From-SVN: r246823

4 files changed, 87 insertions, 13 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index e1057d7..7825295 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2017-04-10  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/80046
+	* expr.c (gfc_check_pointer_assign): Check if procedure pointer
+	components in a pointer assignment need an explicit interface.
+
 2017-03-18  Nicolas Koenig  <koenigni@student.ethz.ch> 
 
 	PR fortran/69498
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 0e5f04d..c8be951 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -3595,25 +3595,41 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
 	  return false;
 	}
 
-      if (s1 == s2 || !s1 || !s2)
-	return true;
-
       /* F08:7.2.2.4 (4)  */
-      if (s1->attr.if_source == IFSRC_UNKNOWN
-	  && gfc_explicit_interface_required (s2, err, sizeof(err)))
+      if (s2 && gfc_explicit_interface_required (s2, err, sizeof(err)))
 	{
-	  gfc_error ("Explicit interface required for %qs at %L: %s",
-		     s1->name, &lvalue->where, err);
-	  return false;
+	  if (comp1 && !s1)
+	    {
+	      gfc_error ("Explicit interface required for component %qs at %L: %s",
+			 comp1->name, &lvalue->where, err);
+	      return false;
+	    }
+	  else if (s1->attr.if_source == IFSRC_UNKNOWN)
+	    {
+	      gfc_error ("Explicit interface required for %qs at %L: %s",
+			 s1->name, &lvalue->where, err);
+	      return false;
+	    }
 	}
-      if (s2->attr.if_source == IFSRC_UNKNOWN
-	  && gfc_explicit_interface_required (s1, err, sizeof(err)))
+      if (s1 && gfc_explicit_interface_required (s1, err, sizeof(err)))
 	{
-	  gfc_error ("Explicit interface required for %qs at %L: %s",
-		     s2->name, &rvalue->where, err);
-	  return false;
+	  if (comp2 && !s2)
+	    {
+	      gfc_error ("Explicit interface required for component %qs at %L: %s",
+			 comp2->name, &rvalue->where, err);
+	      return false;
+	    }
+	  else if (s2->attr.if_source == IFSRC_UNKNOWN)
+	    {
+	      gfc_error ("Explicit interface required for %qs at %L: %s",
+			 s2->name, &rvalue->where, err);
+	      return false;
+	    }
 	}
 
+      if (s1 == s2 || !s1 || !s2)
+	return true;
+
       if (!gfc_compare_interfaces (s1, s2, name, 0, 1,
 				   err, sizeof(err), NULL, NULL))
 	{
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 9f94090..51fd41e 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2017-04-10  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/80046
+	* gfortran.dg/proc_ptr_comp_48.f90: New test case.
+
 2017-04-10  David Edelsohn  <dje.gcc@gmail.com>
 
 	* g++.dg/torture/pr79905.C: Add -maltivec option.
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_48.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_48.f90
new file mode 100644
index 0000000..de73b19
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_48.f90
@@ -0,0 +1,47 @@
+! { dg-do compile }
+!
+! PR 80046: [F03] Explicit interface required: pointer argument
+!
+! Contributed by Joachim Herb <joachim.herb@gmx.de>
+
+program p
+  implicit none
+
+  type :: Node_t
+    procedure(NodeCloner), nopass, pointer :: cloneProc => NULL()
+    procedure(), nopass, pointer :: noIfc => NULL()
+  end type
+
+  interface
+    subroutine NodeCloner( tgt, src )
+      import Node_t
+      type(Node_t), pointer, intent(out) :: tgt
+      type(Node_t),           intent(in) :: src
+    end subroutine
+  end interface
+
+  type(Node_t) :: node
+  procedure(NodeCloner), pointer :: cloneNode
+  procedure(), pointer :: noIfc
+
+  cloneNode => node%noIfc       ! { dg-error "Explicit interface required" }
+  node%noIfc => cloneNode       ! { dg-error "Explicit interface required" }
+
+  noIfc => node%cloneProc       ! { dg-error "Explicit interface required" }
+  node%cloneProc => noIfc       ! { dg-error "Explicit interface required" }
+
+  node%cloneProc => node%noIfc  ! { dg-error "Explicit interface required" }
+  node%noIfc => node%cloneProc  ! { dg-error "Explicit interface required" }
+
+  ! the following cases are legal
+
+  node%noIfc => node%noIfc
+  node%cloneProc => node%cloneProc
+
+  cloneNode => node%cloneProc
+  node%cloneProc => cloneNode
+
+  noIfc => node%noIfc
+  node%noIfc => noIfc
+
+end