From: Janus Weil <janus@gcc.gnu.org>
Date: Sun, 11 Jan 2015 17:31:22 +0000 (+0100)
Subject: re PR fortran/64508 ([F03] interface check missing for procedure pointer component... 
X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=5c0ba546b828cd8f59f250830abaf4fa9f0d881b;p=gcc.git

re PR fortran/64508 ([F03] interface check missing for procedure pointer component as actual argument)

2015-01-11  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/64508
	* interface.c (compare_parameter): Interface check for
	procedure-pointer component as actual argument.

2015-01-11  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/64508
	* gfortran.dg/proc_ptr_comp_41.f90: New.

From-SVN: r219431
---

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index c21b46ee996..b525ff40ba8 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2015-01-11  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/64508
+	* interface.c (compare_parameter): Interface check for
+	procedure-pointer component as actual argument.
+
 2015-01-10  Thomas Schwinge  <thomas@codesourcery.com>
 
 	* gfortran.texi: Update for libgomp being renamed from "GNU OpenMP
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index a1ecdba9737..ca9751fa096 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1922,6 +1922,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 {
   gfc_ref *ref;
   bool rank_check, is_pointer;
+  char err[200];
+  gfc_component *ppc;
 
   /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
      procs c_f_pointer or c_f_procpointer, and we need to accept most
@@ -1942,7 +1944,6 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 
   if (actual->ts.type == BT_PROCEDURE)
     {
-      char err[200];
       gfc_symbol *act_sym = actual->symtree->n.sym;
 
       if (formal->attr.flavor != FL_PROCEDURE)
@@ -1976,6 +1977,19 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
       return 1;
     }
 
+  ppc = gfc_get_proc_ptr_comp (actual);
+  if (ppc)
+    {
+      if (!gfc_compare_interfaces (formal, ppc->ts.interface, ppc->name, 0, 1,
+				   err, sizeof(err), NULL, NULL))
+	{
+	  if (where)
+	    gfc_error ("Interface mismatch in dummy procedure %qs at %L: %s",
+		       formal->name, &actual->where, err);
+	  return 0;
+	}
+    }
+
   /* F2008, C1241.  */
   if (formal->attr.pointer && formal->attr.contiguous
       && !gfc_is_simply_contiguous (actual, true))
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 84d2423b947..a7c24ce0caa 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2015-01-11  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/64508
+	* gfortran.dg/proc_ptr_comp_41.f90: New.
+
 2015-01-11  Segher Boessenkool  <segher@kernel.crashing.org>
 
 	* gcc.target/powerpc/recip-test.h (_ARCH_PPC64): Use __LP64__ instead.
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_41.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_41.f90
new file mode 100644
index 00000000000..e282fc1832d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_41.f90
@@ -0,0 +1,34 @@
+! { dg-do compile }
+!
+! PR 64508: [F03] interface check missing for procedure pointer component as actual argument
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+  TYPE :: parent
+  END TYPE
+
+  TYPE, EXTENDS(parent) :: extension
+    procedure(extension_proc), pointer :: ppc
+  END TYPE
+
+  CLASS(extension), ALLOCATABLE :: x
+  CALL some_proc(x%ppc)               !  { dg-error "Interface mismatch in dummy procedure" }
+
+contains
+
+  SUBROUTINE parent_proc(arg)
+    CLASS(parent), INTENT(IN) :: arg
+  END SUBROUTINE
+
+  SUBROUTINE extension_proc(arg)
+    CLASS(extension), INTENT(IN) :: arg
+  END SUBROUTINE
+
+
+  SUBROUTINE some_proc(proc)
+    PROCEDURE(parent_proc) :: proc
+    TYPE(Parent) :: a
+    CALL proc(a)
+  END SUBROUTINE
+
+end