Mercurial > hg > CbC > CbC_gcc
diff gcc/testsuite/gfortran.dg/dynamic_dispatch_8.f03 @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 (2017-10-27) |
parents | |
children | 84e7813d76e9 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/gcc/testsuite/gfortran.dg/dynamic_dispatch_8.f03 Fri Oct 27 22:46:09 2017 +0900 @@ -0,0 +1,105 @@ +! { dg-do run } +! +! PR 41829: [OOP] Runtime error with dynamic dispatching. Tests +! dynamic dispatch in a case where the caller knows nothing about +! the dynamic type at compile time. +! +! 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 +! write(*,*) 'FOO%DOIT base version' + end subroutine doit + function getit(a) result(res) + class(foo) :: a + integer :: res + + res = a%i + end function getit + +end module foo_mod +module foo2_mod + use foo_mod + + type, extends(foo) :: foo2 + integer :: j + contains + procedure, pass(a) :: doit => doit2 + procedure, pass(a) :: getit => getit2 + end type foo2 + + private doit2, getit2 + +contains + + subroutine doit2(a) + class(foo2) :: a + + a%i = 2 + a%j = 3 +! write(*,*) 'FOO2%DOIT derived version' + end subroutine doit2 + function getit2(a) result(res) + class(foo2) :: a + integer :: res + + res = a%j + end function getit2 + +end module foo2_mod + +module bar_mod + use foo_mod + type bar + class(foo), allocatable :: a + contains + procedure, pass(a) :: doit + procedure, pass(a) :: getit + end type bar + private doit,getit + +contains + subroutine doit(a) + class(bar) :: a + + call a%a%doit() + end subroutine doit + function getit(a) result(res) + class(bar) :: a + integer :: res + + res = a%a%getit() + end function getit +end module bar_mod + + +program testd10 + use foo_mod + use foo2_mod + use bar_mod + + type(bar) :: a + + allocate(foo :: a%a) + call a%doit() +! write(*,*) 'Getit value : ', a%getit() + if (a%getit() .ne. 1) call abort + deallocate(a%a) + allocate(foo2 :: a%a) + call a%doit() +! write(*,*) 'Getit value : ', a%getit() + if (a%getit() .ne. 3) call abort + +end program testd10