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

gcc/fortran/ChangeLog

+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

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)

gcc/testsuite/ChangeLog

+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

gcc/testsuite/gfortran.dg/proc_ptr_21.f90

+! { 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