1! { dg-do run } 2! 3! PR 41829: [OOP] Runtime error with dynamic dispatching. Tests 4! dynamic dispatch in a case where the caller knows nothing about 5! the dynamic type at compile time. 6! 7! Contributed by Salvatore Filippone <sfilippone@uniroma2.it> 8! 9module foo_mod 10 type foo 11 integer :: i 12 contains 13 procedure, pass(a) :: doit 14 procedure, pass(a) :: getit 15 end type foo 16 17 private doit,getit 18contains 19 subroutine doit(a) 20 class(foo) :: a 21 22 a%i = 1 23! write(*,*) 'FOO%DOIT base version' 24 end subroutine doit 25 function getit(a) result(res) 26 class(foo) :: a 27 integer :: res 28 29 res = a%i 30 end function getit 31 32end module foo_mod 33module foo2_mod 34 use foo_mod 35 36 type, extends(foo) :: foo2 37 integer :: j 38 contains 39 procedure, pass(a) :: doit => doit2 40 procedure, pass(a) :: getit => getit2 41 end type foo2 42 43 private doit2, getit2 44 45contains 46 47 subroutine doit2(a) 48 class(foo2) :: a 49 50 a%i = 2 51 a%j = 3 52! write(*,*) 'FOO2%DOIT derived version' 53 end subroutine doit2 54 function getit2(a) result(res) 55 class(foo2) :: a 56 integer :: res 57 58 res = a%j 59 end function getit2 60 61end module foo2_mod 62 63module bar_mod 64 use foo_mod 65 type bar 66 class(foo), allocatable :: a 67 contains 68 procedure, pass(a) :: doit 69 procedure, pass(a) :: getit 70 end type bar 71 private doit,getit 72 73contains 74 subroutine doit(a) 75 class(bar) :: a 76 77 call a%a%doit() 78 end subroutine doit 79 function getit(a) result(res) 80 class(bar) :: a 81 integer :: res 82 83 res = a%a%getit() 84 end function getit 85end module bar_mod 86 87 88program testd10 89 use foo_mod 90 use foo2_mod 91 use bar_mod 92 93 type(bar) :: a 94 95 allocate(foo :: a%a) 96 call a%doit() 97! write(*,*) 'Getit value : ', a%getit() 98 if (a%getit() .ne. 1) call abort 99 deallocate(a%a) 100 allocate(foo2 :: a%a) 101 call a%doit() 102! write(*,*) 'Getit value : ', a%getit() 103 if (a%getit() .ne. 3) call abort 104 105end program testd10 106