OSDN Git Service

PR fortran/42769
authormikael <mikael@138bc75d-0d04-0410-961f-82ee72b054a4>
Tue, 8 Jan 2013 19:42:38 +0000 (19:42 +0000)
committermikael <mikael@138bc75d-0d04-0410-961f-82ee72b054a4>
Tue, 8 Jan 2013 19:42:38 +0000 (19:42 +0000)
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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/gcc-4_7-branch@195031 138bc75d-0d04-0410-961f-82ee72b054a4

gcc/fortran/ChangeLog
gcc/fortran/module.c
gcc/fortran/resolve.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/use_23.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/use_24.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/use_25.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/use_26.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/use_27.f90 [new file with mode: 0644]

index ffa1376..452e069 100644 (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>
 2013-01-07  Tobias Burnus  <burnus@net-b.de>
            Thomas Koenig  <tkoenig@gcc.gnu.org>
            Jakub Jelinek  <jakub@redhat.com>
index e363177..f6662b4 100644 (file)
@@ -4641,8 +4641,14 @@ read_module (void)
          if (p == NULL)
            {
              st = gfc_find_symtree (gfc_current_ns->sym_root, name);
          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;
            }
 
              continue;
            }
 
@@ -4663,7 +4669,8 @@ read_module (void)
              /* Check for ambiguous symbols.  */
              if (check_for_ambiguous (st->n.sym, info))
                st->ambiguous = 1;
              /* 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
            {
            }
          else
            {
index bbc1c22..18e94a1 100644 (file)
@@ -3636,7 +3636,7 @@ resolve_call (gfc_code *c)
   if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
     {
       gfc_symtree *st;
   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
       sym = st ? st->n.sym : NULL;
       if (sym && csym != sym
              && sym->ns == gfc_current_ns
index 1f9bccf..58a7e90 100644 (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
 2013-01-07  Tobias Burnus  <burnus@net-b.de>
 
        PR fortran/55852
diff --git a/gcc/testsuite/gfortran.dg/use_23.f90 b/gcc/testsuite/gfortran.dg/use_23.f90
new file mode 100644 (file)
index 0000000..da05e1a
--- /dev/null
@@ -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 
+
+
+
diff --git a/gcc/testsuite/gfortran.dg/use_24.f90 b/gcc/testsuite/gfortran.dg/use_24.f90
new file mode 100644 (file)
index 0000000..b709347
--- /dev/null
@@ -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
+
+
+
diff --git a/gcc/testsuite/gfortran.dg/use_25.f90 b/gcc/testsuite/gfortran.dg/use_25.f90
new file mode 100644 (file)
index 0000000..b79297f
--- /dev/null
@@ -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
+
+
diff --git a/gcc/testsuite/gfortran.dg/use_26.f90 b/gcc/testsuite/gfortran.dg/use_26.f90
new file mode 100644 (file)
index 0000000..2e66401
--- /dev/null
@@ -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
+
+
diff --git a/gcc/testsuite/gfortran.dg/use_27.f90 b/gcc/testsuite/gfortran.dg/use_27.f90
new file mode 100644 (file)
index 0000000..71d77cc
--- /dev/null
@@ -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
+
+