Hello,
here is a fix for PR42769, where a type bound call was resolved
statically into a normal procedure call, but using the local procedure
(with the same name) instead of the original (and correct) one.
It turned out to not be OOP specific, and be a pure module loading
problem in the way we associate a symbol number in the module file with
the corresponding symbol pointer once module is loaded.
The first module.c hunk fixes comment #14 in the PR. Here, p == NULL,
which means that the user didn't ask to load the symbol (USE,ONLY:...),
so we can just continue to the next one. However, as an optimization,
we try to find the symbol in the current name space and associate the
pointer info (mapping module's integer <-> symbol pointer) with it if
found to avoid reloading it from the module file if needed.
The problem was there was no check that the symbol is really the same,
not another symbol with the same name. Fixed by checking symbol's name
and module name too. The original code was only reusing the symtree; I
took the opportunity to reuse the symbol as well, and the test suite
didn't complain :-).
The second module.c hunk fixes comment #24 in the PR. Here, p != NULL:
the symbol will have to be loaded. Before creating a new symbol and a
new symtree and inserting them in the current name space, we check
whether a symtree of the same name exists in the current name space. If
it exists and is not ambiguous, it is either the same one as the one
from the module, or both are generic so we can reuse the existing symbol
in both cases. However, if the symtree in the name space is ambiguous
we shall not reuse it as it is different than the one to be loaded.
Thus fixed by not reusing it in that case, and letting a unique non
ambiguous name being automatically generated later.
The resolve.c hunk fixes comment #34 in the PR. This one is not a
module problem, but let's fix all cases in one go. Resolve_call reloads
the call's procedure symbol to take into account contained procedure
which were not known at parse time. However, it uses the symbol's name
(original name) for lookup instead of the symtree's (local name). The
resolve.c hunk changes that.
The tests are adapted from comment 14, 24, 34 from pr42769, and the
original test cases from pr45836 and pr45900.
Regression tested on x86_64-unknown-linux-gnu. OK for trunk?
4.7?
4.6?
Mikael
2013-01-05 Mikael Morin <mik...@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.
diff --git a/module.c b/module.c
index cde5739..e63e510 100644
--- a/module.c
+++ b/module.c
@@ -4656,8 +4656,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;
}
@@ -4678,7 +4684,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
{
diff --git a/resolve.c b/resolve.c
index d4d5eb9..17ee716 100644
--- a/resolve.c
+++ b/resolve.c
@@ -3778,7 +3778,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
2013-01-05 Mikael Morin <mik...@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.
! { 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 <sfilipp...@uniroma2.it>
! Reduced by Janus Weil <ja...@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
! { 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 <sfilipp...@uniroma2.it>
! Reduced by Janus Weil <ja...@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
! { 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 <sfilipp...@uniroma2.it>
! Reduced by Janus Weil <ja...@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
! { 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 <ort...@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
! { 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 <ort...@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
