Mercurial > hg > CbC > CbC_gcc
view gcc/testsuite/gfortran.dg/use_27.f90 @ 158:494b0b89df80 default tip
...
author | Shinji KONO <kono@ie.u-ryukyu.ac.jp> |
---|---|
date | Mon, 25 May 2020 18:13:55 +0900 |
parents | 84e7813d76e9 |
children |
line wrap: on
line source
! { 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