OSDN Git Service

PR fortran/42769
[pf3gnuchains/gcc-fork.git] / gcc / testsuite / gfortran.dg / use_27.f90
1 ! { dg-do run }
2 !
3 ! PR fortran/45900
4 ! The BTYPEINSTANCE%CALLBACK() typebound call was resolved incorrectly to
5 ! A's CALLBACK procedure instead of B's because the CALLBACK name is ambiguous
6 ! in the MAIN namespace.
7 !
8 ! Original testcase by someone <ortp21@gmail.com>
9
10 module A
11 implicit none
12     type :: aType
13     contains
14         procedure :: callback
15     end type aType
16     contains
17         subroutine callback( callback_, i )
18             implicit none
19             class(aType) :: callback_
20             integer :: i
21
22             i = 3
23         end subroutine callback
24
25         subroutine solver( callback_, i )
26             implicit none
27             class(aType) :: callback_
28             integer :: i
29
30             call callback_%callback(i)
31         end subroutine solver
32 end module A
33
34 module B
35 use A, only: aType
36 implicit none
37     type, extends(aType) :: bType
38         integer :: i
39     contains
40         procedure :: callback
41     end type bType
42     contains
43         subroutine callback( callback_, i )
44             implicit none
45             class(bType) :: callback_
46             integer :: i
47
48             i = 7
49         end subroutine callback
50 end module B
51
52 program main
53   call test1()
54   call test2()
55
56 contains
57
58   subroutine test1
59     use A
60     use B
61     implicit none
62     type(aType) :: aTypeInstance
63     type(bType) :: bTypeInstance
64     integer :: iflag
65
66     bTypeInstance%i = 4
67
68     iflag = 0
69     call bTypeInstance%callback(iflag)
70     if (iflag /= 7) call abort
71     iflag = 1
72     call solver( bTypeInstance, iflag )
73     if (iflag /= 7) call abort
74
75     iflag = 2
76     call aTypeInstance%callback(iflag)
77     if (iflag /= 3) call abort
78   end subroutine test1
79
80   subroutine test2
81     use B
82     use A
83     implicit none
84     type(aType) :: aTypeInstance
85     type(bType) :: bTypeInstance
86     integer :: iflag
87
88     bTypeInstance%i = 4
89
90     iflag = 0
91     call bTypeInstance%callback(iflag)
92     if (iflag /= 7) call abort
93     iflag = 1
94     call solver( bTypeInstance, iflag )
95     if (iflag /= 7) call abort
96
97     iflag = 2
98     call aTypeInstance%callback(iflag)
99     if (iflag /= 3) call abort
100   end subroutine test2
101 end program main
102
103