+2013-01-06 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-05 Steven G. Kargl <kargl@gcc.gnu.org>
Mikael Morin <mikael@gcc.gnu.org>
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;
}
/* 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
{
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-06 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-06 Olivier Hainque <hainque@adacore.com>
* gnat.dg/specs/clause_on_volatile.ads: New test.
--- /dev/null
+! { 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
+
+
+
--- /dev/null
+! { 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
+
+
+
--- /dev/null
+! { 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
+
+
--- /dev/null
+! { 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
+
+
--- /dev/null
+! { 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
+
+
git://gcc.gnu.org / gcc.git / commitdiff