OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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

Browse Source 
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
This commit is contained in:
Paul Thomas 2009-07-08 04:38:06 +00:00
parent d1b5afd557
commit 3276e0b350
4 changed files with 64 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
gcc/fortran/ChangeLog
View File

@ -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

27
gcc/fortran/decl.c
View File

@ -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)

5
gcc/testsuite/ChangeLog
View File

@ -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

32
gcc/testsuite/gfortran.dg/proc_ptr_21.f90 Normal file
View File

@ -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