From: Janus Weil <janus@gcc.gnu.org>
Date: Tue, 8 Nov 2016 16:10:56 +0000 (+0100)
Subject: re PR fortran/77596 ([F03] procedure pointer component with implicit interface can... 
X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=eba5aec8e347d75013268de658efa1c7af93123a;p=gcc.git

re PR fortran/77596 ([F03] procedure pointer component with implicit interface can point to a function)

2016-11-08  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/77596
	* expr.c (gfc_check_pointer_assign): Add special check for procedure-
	pointer component with absent interface.

2016-11-08  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/77596
	* gfortran.dg/proc_ptr_comp_46.f90: New test.

From-SVN: r241972
---

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 535a5c15c89..d3c16994cca 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2016-11-08  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/77596
+	* expr.c (gfc_check_pointer_assign): Add special check for procedure-
+	pointer component with absent interface.
+
 2016-11-07  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
 	PR fortran/78226
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index ba79190daf1..f059c3c1efa 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -3445,7 +3445,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
     {
       char err[200];
       gfc_symbol *s1,*s2;
-      gfc_component *comp;
+      gfc_component *comp1, *comp2;
       const char *name;
 
       attr = gfc_expr_attr (rvalue);
@@ -3549,9 +3549,9 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
 	    }
 	}
 
-      comp = gfc_get_proc_ptr_comp (lvalue);
-      if (comp)
-	s1 = comp->ts.interface;
+      comp1 = gfc_get_proc_ptr_comp (lvalue);
+      if (comp1)
+	s1 = comp1->ts.interface;
       else
 	{
 	  s1 = lvalue->symtree->n.sym;
@@ -3559,18 +3559,18 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
 	    s1 = s1->ts.interface;
 	}
 
-      comp = gfc_get_proc_ptr_comp (rvalue);
-      if (comp)
+      comp2 = gfc_get_proc_ptr_comp (rvalue);
+      if (comp2)
 	{
 	  if (rvalue->expr_type == EXPR_FUNCTION)
 	    {
-	      s2 = comp->ts.interface->result;
+	      s2 = comp2->ts.interface->result;
 	      name = s2->name;
 	    }
 	  else
 	    {
-	      s2 = comp->ts.interface;
-	      name = comp->name;
+	      s2 = comp2->ts.interface;
+	      name = comp2->name;
 	    }
 	}
       else if (rvalue->expr_type == EXPR_FUNCTION)
@@ -3591,6 +3591,15 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
       if (s2 && s2->attr.proc_pointer && s2->ts.interface)
 	s2 = s2->ts.interface;
 
+      /* Special check for the case of absent interface on the lvalue.
+       * All other interface checks are done below. */
+      if (!s1 && comp1 && comp1->attr.subroutine && s2 && s2->attr.function)
+	{
+	  gfc_error ("Interface mismatch in procedure pointer assignment "
+		     "at %L: '%s' is not a subroutine", &rvalue->where, name);
+	  return false;
+	}
+
       if (s1 == s2 || !s1 || !s2)
 	return true;
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index f3893ea852d..721b8f2ea6a 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2016-11-08  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/77596
+	* gfortran.dg/proc_ptr_comp_46.f90: New test.
+
 2016-11-08  Bin Cheng  <bin.cheng@arm.com>
 
 	* gcc.dg/vect/pr56541.c: Xfail on !vect_cond_mixed targets.
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_46.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_46.f90
new file mode 100644
index 00000000000..c01b8221210
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_46.f90
@@ -0,0 +1,29 @@
+! { dg-do compile }
+!
+! PR 77596: [F03] procedure pointer component with implicit interface can point to a function
+!
+! Contributed by toK <t.kondic@leeds.ac.uk>
+
+program xxx
+  implicit none
+
+  type tf
+     procedure(), nopass, pointer :: fp
+  end type tf
+
+  call ass()
+
+contains
+
+  integer function ff(x)
+    integer, intent(in) :: x
+    ff = x + 1
+  end function ff
+
+  subroutine ass()
+    type(tf) :: p
+    p%fp=>ff        ! { dg-error "is not a subroutine" }
+    call p%fp(3)
+  end subroutine ass
+
+end