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
10module A
11implicit 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
32end module A
33
34module B
35use A, only: aType
36implicit 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
50end module B
51
52program main
53  call test1()
54  call test2()
55
56contains
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) STOP 1
71    iflag = 1
72    call solver( bTypeInstance, iflag )
73    if (iflag /= 7) STOP 2
74
75    iflag = 2
76    call aTypeInstance%callback(iflag)
77    if (iflag /= 3) STOP 3
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) STOP 4
93    iflag = 1
94    call solver( bTypeInstance, iflag )
95    if (iflag /= 7) STOP 5
96
97    iflag = 2
98    call aTypeInstance%callback(iflag)
99    if (iflag /= 3) STOP 6
100  end subroutine test2
101end program main
102
103
104