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

re PR fortran/42769 ([OOP] ICE in resolve_typebound_procedure) 

PR fortran/42769
	PR fortran/45836
	PR fortran/45900
	* module.c (read_module): Don't reuse local symtree if the associated
	symbol isn't exactly the one wanted.  Don't reuse local symtree if it is
	ambiguous.
	* resolve.c (resolve_call): Use symtree's name instead of symbol's to
	lookup the symtree.

	PR fortran/42769
	PR fortran/45836
	PR fortran/45900
	* gfortran.dg/use_23.f90: New test.
	* gfortran.dg/use_24.f90: New test.
	* gfortran.dg/use_25.f90: New test.
	* gfortran.dg/use_26.f90: New test.
	* gfortran.dg/use_27.f90: New test.

From-SVN: r195031
This commit is contained in:
Mikael Morin 2013-01-08 19:42:38 +00:00
parent 5bc8309d72
commit b836ce06ef
9 changed files with 346 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
gcc/fortran/ChangeLog
View File

@ -1,3 +1,14 @@
2013-01-08 Mikael Morin <mikael@gcc.gnu.org>
PR fortran/42769
PR fortran/45836
PR fortran/45900
* module.c (read_module): Don't reuse local symtree if the associated
symbol isn't exactly the one wanted. Don't reuse local symtree if it is
ambiguous.
* resolve.c (resolve_call): Use symtree's name instead of symbol's to
lookup the symtree.
2013-01-07 Tobias Burnus <burnus@net-b.de>
Thomas Koenig <tkoenig@gcc.gnu.org>
Jakub Jelinek <jakub@redhat.com>

13
gcc/fortran/module.c
View File

@ -4641,8 +4641,14 @@ read_module (void)
if (p == NULL)
{
st = gfc_find_symtree (gfc_current_ns->sym_root, name);
if (st != NULL)
info->u.rsym.symtree = st;
if (st != NULL
&& strcmp (st->n.sym->name, info->u.rsym.true_name) == 0
&& st->n.sym->module != NULL
&& strcmp (st->n.sym->module, info->u.rsym.module) == 0)
{
info->u.rsym.symtree = st;
info->u.rsym.sym = st->n.sym;
}
continue;
}
@ -4663,7 +4669,8 @@ read_module (void)
/* Check for ambiguous symbols. */
if (check_for_ambiguous (st->n.sym, info))
st->ambiguous = 1;
info->u.rsym.symtree = st;
else
info->u.rsym.symtree = st;
}
else
{

2
gcc/fortran/resolve.c
View File

@ -3636,7 +3636,7 @@ resolve_call (gfc_code *c)
if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
{
gfc_symtree *st;
gfc_find_sym_tree (csym->name, gfc_current_ns, 1, &st);
gfc_find_sym_tree (c->symtree->name, gfc_current_ns, 1, &st);
sym = st ? st->n.sym : NULL;
if (sym && csym != sym
&& sym->ns == gfc_current_ns

11
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,14 @@
2013-01-08 Mikael Morin <mikael@gcc.gnu.org>
PR fortran/42769
PR fortran/45836
PR fortran/45900
* gfortran.dg/use_23.f90: New test.
* gfortran.dg/use_24.f90: New test.
* gfortran.dg/use_25.f90: New test.
* gfortran.dg/use_26.f90: New test.
* gfortran.dg/use_27.f90: New test.
2013-01-07 Tobias Burnus <burnus@net-b.de>
PR fortran/55852

42
gcc/testsuite/gfortran.dg/use_23.f90 Normal file
View File

@ -0,0 +1,42 @@
! { dg-do compile }
!
! PR fortran/42769
! This test used to ICE in resolve_typebound_procedure because T1's GET
! procedure was wrongly associated to MOD2's MY_GET (instead of the original
! MOD1's MY_GET) in MOD3's SUB.
!
! Original testcase by Salvator Filippone <sfilippone@uniroma2.it>
! Reduced by Janus Weil <janus@gcc.gnu.org>
module mod1
type :: t1
contains
procedure, nopass :: get => my_get
end type
contains
logical function my_get()
end function
end module
module mod2
contains
logical function my_get()
end function
end module
module mod3
contains
subroutine sub(a)
use mod2, only: my_get
use mod1, only: t1
type(t1) :: a
end subroutine
end module
use mod2, only: my_get
use mod3, only: sub
end

53
gcc/testsuite/gfortran.dg/use_24.f90 Normal file
View File

@ -0,0 +1,53 @@
! { dg-do run }
!
! PR fortran/42769
! The static resolution of A%GET used to be incorrectly simplified to MOD2's
! MY_GET instead of the original MOD1's MY_GET, depending on the order in which
! MOD1 and MOD2 were use-associated.
!
! Original testcase by Salvator Filippone <sfilippone@uniroma2.it>
! Reduced by Janus Weil <janus@gcc.gnu.org>
module mod1
type :: t1
contains
procedure, nopass :: get => my_get
end type
contains
subroutine my_get(i)
i = 2
end subroutine
end module
module mod2
contains
subroutine my_get(i) ! must have the same name as the function in mod1
i = 5
end subroutine
end module
call test1()
call test2()
contains
subroutine test1()
use mod2
use mod1
type(t1) :: a
call a%get(j)
if (j /= 2) call abort
end subroutine test1
subroutine test2()
use mod1
use mod2
type(t1) :: a
call a%get(j)
if (j /= 2) call abort
end subroutine test2
end

39
gcc/testsuite/gfortran.dg/use_25.f90 Normal file
View File

@ -0,0 +1,39 @@
! { dg-do compile }
!
! PR fortran/42769
! This test used to be rejected because the typebound call A%GET was
! simplified to MY_GET which is an ambiguous name in the main program
! namespace.
!
! Original testcase by Salvator Filippone <sfilippone@uniroma2.it>
! Reduced by Janus Weil <janus@gcc.gnu.org>
module mod1
type :: t1
contains
procedure, nopass :: get => my_get
end type
contains
subroutine my_get()
print *,"my_get (mod1)"
end subroutine
end module
module mod2
contains
subroutine my_get() ! must have the same name as the function in mod1
print *,"my_get (mod2)"
end subroutine
end module
use mod2
use mod1
type(t1) :: a
call call_get
contains
subroutine call_get
call a%get()
end subroutine call_get
end

76
gcc/testsuite/gfortran.dg/use_26.f90 Normal file
View File

@ -0,0 +1,76 @@
! { dg-do compile }
!
! PR fortran/45836
! The B_TYPE_INSTANCE%SIZERETURN() typebound function used to be rejected on a
! type mismatch because the function was resolved to A's SIZERETURN instead of
! B's because of the ambiguity of the SIZERETURN name in the MAIN namespace.
!
! Original testcase by someone <ortp21@gmail.com>
module A
implicit none
type :: a_type
private
integer :: size = 1
contains
procedure :: sizeReturn
end type a_type
contains
function sizeReturn( a_type_ )
implicit none
integer :: sizeReturn
class(a_type) :: a_type_
sizeReturn = a_type_%size
end function sizeReturn
end module A
module B
implicit none
type :: b_type
private
integer :: size = 2
contains
procedure :: sizeReturn
end type b_type
contains
function sizeReturn( b_type_ )
implicit none
integer :: sizeReturn
class(b_type) :: b_type_
sizeReturn = b_type_%size
end function sizeReturn
end module B
program main
call test1
call test2
contains
subroutine test1
use A
use B
implicit none
type(a_type) :: a_type_instance
type(b_type) :: b_type_instance
print *, a_type_instance%sizeReturn()
print *, b_type_instance%sizeReturn()
end subroutine test1
subroutine test2
use B
use A
implicit none
type(a_type) :: a_type_instance
type(b_type) :: b_type_instance
print *, a_type_instance%sizeReturn()
print *, b_type_instance%sizeReturn()
end subroutine test2
end program main

103
gcc/testsuite/gfortran.dg/use_27.f90 Normal file
View File

@ -0,0 +1,103 @@
! { dg-do run }
!
! PR fortran/45900
! The BTYPEINSTANCE%CALLBACK() typebound call was resolved incorrectly to
! A's CALLBACK procedure instead of B's because the CALLBACK name is ambiguous
! in the MAIN namespace.
!
! Original testcase by someone <ortp21@gmail.com>
module A
implicit none
type :: aType
contains
procedure :: callback
end type aType
contains
subroutine callback( callback_, i )
implicit none
class(aType) :: callback_
integer :: i
i = 3
end subroutine callback
subroutine solver( callback_, i )
implicit none
class(aType) :: callback_
integer :: i
call callback_%callback(i)
end subroutine solver
end module A
module B
use A, only: aType
implicit none
type, extends(aType) :: bType
integer :: i
contains
procedure :: callback
end type bType
contains
subroutine callback( callback_, i )
implicit none
class(bType) :: callback_
integer :: i
i = 7
end subroutine callback
end module B
program main
call test1()
call test2()
contains
subroutine test1
use A
use B
implicit none
type(aType) :: aTypeInstance
type(bType) :: bTypeInstance
integer :: iflag
bTypeInstance%i = 4
iflag = 0
call bTypeInstance%callback(iflag)
if (iflag /= 7) call abort
iflag = 1
call solver( bTypeInstance, iflag )
if (iflag /= 7) call abort
iflag = 2
call aTypeInstance%callback(iflag)
if (iflag /= 3) call abort
end subroutine test1
subroutine test2
use B
use A
implicit none
type(aType) :: aTypeInstance
type(bType) :: bTypeInstance
integer :: iflag
bTypeInstance%i = 4
iflag = 0
call bTypeInstance%callback(iflag)
if (iflag /= 7) call abort
iflag = 1
call solver( bTypeInstance, iflag )
if (iflag /= 7) call abort
iflag = 2
call aTypeInstance%callback(iflag)
if (iflag /= 3) call abort
end subroutine test2
end program main