Mercurial > hg > CbC > CbC_gcc
view gcc/testsuite/gfortran.dg/dynamic_dispatch_4.f03 @ 128:fe568345ddd5
fix CbC-example
author | mir3636 |
---|---|
date | Wed, 11 Apr 2018 19:32:28 +0900 |
parents | 04ced10e8804 |
children | 84e7813d76e9 |
line wrap: on
line source
! { dg-do run } ! Tests the fix for PR41648 in which the reference a%a%getit () was wrongly ! identified as a recursive call to getit. ! ! Contributed by Salvatore Filippone <sfilippone@uniroma2.it> ! module foo_mod type foo integer :: i contains procedure, pass(a) :: doit procedure, pass(a) :: getit end type foo private doit,getit contains subroutine doit(a) class(foo) :: a a%i = 1 end subroutine doit function getit(a) result(res) class(foo) :: a integer :: res res = a%i end function getit end module foo_mod module s_bar_mod use foo_mod type, extends(foo) :: s_bar type(foo), allocatable :: a contains procedure, pass(a) :: doit procedure, pass(a) :: getit end type s_bar private doit,getit contains subroutine doit(a) class(s_bar) :: a allocate (a%a) call a%a%doit() end subroutine doit function getit(a) result(res) class(s_bar) :: a integer :: res res = a%a%getit () * 2 end function getit end module s_bar_mod module a_bar_mod use foo_mod type, extends(foo) :: a_bar type(foo), allocatable :: a(:) contains procedure, pass(a) :: doit procedure, pass(a) :: getit end type a_bar private doit,getit contains subroutine doit(a) class(a_bar) :: a allocate (a%a(1)) call a%a(1)%doit () end subroutine doit function getit(a) result(res) class(a_bar) :: a integer :: res res = a%a(1)%getit () * 3 end function getit end module a_bar_mod use s_bar_mod use a_bar_mod type(foo), target :: b type(s_bar), target :: c type(a_bar), target :: d class(foo), pointer :: a a => b call a%doit if (a%getit () .ne. 1) call abort a => c call a%doit if (a%getit () .ne. 2) call abort a => d call a%doit if (a%getit () .ne. 3) call abort end