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