re PR fortran/40591 (Procedure(interface): Rejected if interface is indirectly hostassociated)

2008-07-08  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/40591
	* decl.c (match_procedure_interface):  Correct the association
	or creation of the interface procedure's symbol.

2008-07-08  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/40591
	* gfortran.dg/proc_ptr_21.f90: New test.

From-SVN: r149362

4 files changed, 64 insertions, 6 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 6b66cbd..371fdde 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2008-07-08  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/40591
+	* decl.c (match_procedure_interface):  Correct the association
+	or creation of the interface procedure's symbol.
+
 2009-07-04  Jakub Jelinek  <jakub@redhat.com>
 
 	* trans-intrinsic.c (gfc_conv_intrinsic_minmaxloc): For integer
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index c3760a8..e281634 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -4156,9 +4156,12 @@ static match
 match_procedure_interface (gfc_symbol **proc_if)
 {
   match m;
+  gfc_symtree *st;
   locus old_loc, entry_loc;
-  old_loc = entry_loc = gfc_current_locus;
+  gfc_namespace *old_ns = gfc_current_ns;
+  char name[GFC_MAX_SYMBOL_LEN + 1];
 
+  old_loc = entry_loc = gfc_current_locus;
   gfc_clear_ts (&current_ts);
 
   if (gfc_match (" (") != MATCH_YES)
@@ -4177,13 +4180,25 @@ match_procedure_interface (gfc_symbol **proc_if)
   if (m == MATCH_ERROR)
     return m;
 
+  /* Procedure interface is itself a procedure.  */
   gfc_current_locus = old_loc;
+  m = gfc_match_name (name);
 
-  /* Get the name of the procedure or abstract interface
-  to inherit the interface from.  */
-  m = gfc_match_symbol (proc_if, 1);
-  if (m != MATCH_YES)
-    return m;
+  /* First look to see if it is already accessible in the current
+     namespace because it is use associated or contained.  */
+  st = NULL;
+  if (gfc_find_sym_tree (name, NULL, 0, &st))
+    return MATCH_ERROR;
+
+  /* If it is still not found, then try the parent namespace, if it
+     exists and create the symbol there if it is still not found.  */
+  if (gfc_current_ns->parent)
+    gfc_current_ns = gfc_current_ns->parent;
+  if (st == NULL && gfc_get_ha_sym_tree (name, &st))
+    return MATCH_ERROR;
+
+  gfc_current_ns = old_ns;
+  *proc_if = st->n.sym;
 
   /* Various interface checks.  */
   if (*proc_if)
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index d063cbb..c3603d1 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2008-07-08  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/40591
+	* gfortran.dg/proc_ptr_21.f90: New test.
+
 2009-07-08  Manuel López-Ibáñez  <manu@gcc.gnu.org>
 	
 	PR c++/31246
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_21.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_21.f90
new file mode 100644
index 0000000..312dca9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_21.f90
@@ -0,0 +1,32 @@
+! { dg-do run }

+! Tests the fix for PR40591 in which the interface 'sub2'

+! for 'pptr2' was not resolved.

+!

+! Contributed by Tobias Burnus  <burnus@gcc.gnu.org>

+!

+program main

+  call test

+contains

+  subroutine sub1(arg)
+    integer arg
+    arg = arg + 1

+  end subroutine sub1

+  subroutine test()

+    procedure(sub1), pointer :: pptr1

+    procedure(sub2), pointer :: pptr2
+    integer i

+    pptr1 => sub1
+    call pptr1 (i)

+    pptr1 => sub2
+    call pptr1 (i)

+    pptr2 => sub1
+    call pptr2 (i)

+    pptr2 => sub2
+    call pptr2 (i)
+    if (i .ne. 22) call abort

+  end subroutine test

+  subroutine sub2(arg)
+    integer arg
+    arg = arg + 10

+  end subroutine sub2

+end program main