mirror of
https://github.com/autc04/Retro68.git
synced 2024-06-28 11:30:19 +00:00
104 lines
2.0 KiB
Fortran
104 lines
2.0 KiB
Fortran
! { 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) STOP 1
|
|
iflag = 1
|
|
call solver( bTypeInstance, iflag )
|
|
if (iflag /= 7) STOP 2
|
|
|
|
iflag = 2
|
|
call aTypeInstance%callback(iflag)
|
|
if (iflag /= 3) STOP 3
|
|
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) STOP 4
|
|
iflag = 1
|
|
call solver( bTypeInstance, iflag )
|
|
if (iflag /= 7) STOP 5
|
|
|
|
iflag = 2
|
|
call aTypeInstance%callback(iflag)
|
|
if (iflag /= 3) STOP 6
|
|
end subroutine test2
|
|
end program main
|
|
|
|
|