1! { dg-do run }
2!
3! [OOP] Fortran runtime error: internal error: bad hash value in dynamic dispatch
4!
5! Contributed by David Car <david.car7@gmail.com>
6
7module BaseStrategy
8
9  type, public, abstract :: Strategy
10   contains
11     procedure(strategy_update), pass( this ), deferred :: update
12     procedure(strategy_pre_update), pass( this ), deferred :: preUpdate
13     procedure(strategy_post_update), pass( this ), deferred :: postUpdate
14  end type Strategy
15
16  abstract interface
17     subroutine strategy_update( this )
18       import Strategy
19       class (Strategy), target, intent(in) :: this
20     end subroutine strategy_update
21  end interface
22
23  abstract interface
24     subroutine strategy_pre_update( this )
25       import Strategy
26       class (Strategy), target, intent(in) :: this
27     end subroutine strategy_pre_update
28  end interface
29
30  abstract interface
31     subroutine strategy_post_update( this )
32       import Strategy
33       class (Strategy), target, intent(in) :: this
34     end subroutine strategy_post_update
35  end interface
36
37end module BaseStrategy
38
39!==============================================================================
40
41module LaxWendroffStrategy
42
43  use BaseStrategy
44
45  private :: update, preUpdate, postUpdate
46
47  type, public, extends( Strategy ) :: LaxWendroff
48     class (Strategy), pointer :: child => null()
49     contains
50       procedure, pass( this ) :: update
51       procedure, pass( this ) :: preUpdate
52       procedure, pass( this ) :: postUpdate
53  end type LaxWendroff
54
55contains
56
57  subroutine update( this )
58    class (LaxWendroff), target, intent(in) :: this
59
60    print *, 'Calling LaxWendroff update'
61  end subroutine update
62
63  subroutine preUpdate( this )
64    class (LaxWendroff), target, intent(in) :: this
65
66    print *, 'Calling LaxWendroff preUpdate'
67  end subroutine preUpdate
68
69  subroutine postUpdate( this )
70    class (LaxWendroff), target, intent(in) :: this
71
72    print *, 'Calling LaxWendroff postUpdate'
73  end subroutine postUpdate
74
75end module LaxWendroffStrategy
76
77!==============================================================================
78
79module KEStrategy
80
81  use BaseStrategy
82  ! Uncomment the line below and it runs fine
83  ! use LaxWendroffStrategy
84
85  private :: update, preUpdate, postUpdate
86
87  type, public, extends( Strategy ) :: KE
88     class (Strategy), pointer :: child => null()
89     contains
90       procedure, pass( this ) :: update
91       procedure, pass( this ) :: preUpdate
92       procedure, pass( this ) :: postUpdate
93  end type KE
94
95contains
96
97  subroutine init( this, other )
98    class (KE), intent(inout) :: this
99    class (Strategy), target, intent(in) :: other
100
101    this % child => other
102  end subroutine init
103
104  subroutine update( this )
105    class (KE), target, intent(in) :: this
106
107    if ( associated( this % child ) ) then
108       call this % child % update()
109    end if
110
111    print *, 'Calling KE update'
112  end subroutine update
113
114 subroutine preUpdate( this )
115    class (KE), target, intent(in) :: this
116
117    if ( associated( this % child ) ) then
118       call this % child % preUpdate()
119    end if
120
121    print *, 'Calling KE preUpdate'
122  end subroutine preUpdate
123
124  subroutine postUpdate( this )
125    class (KE), target, intent(in) :: this
126
127    if ( associated( this % child ) ) then
128       call this % child % postUpdate()
129    end if
130
131    print *, 'Calling KE postUpdate'
132  end subroutine postUpdate
133
134end module KEStrategy
135
136!==============================================================================
137
138program main
139
140  use LaxWendroffStrategy
141  use KEStrategy
142
143  type :: StratSeq
144     class (Strategy), pointer :: strat => null()
145  end type StratSeq
146
147  type (LaxWendroff), target :: lw_strat
148  type (KE), target :: ke_strat
149
150  type (StratSeq), allocatable, dimension( : ) :: seq
151
152  allocate( seq(10) )
153
154  call init( ke_strat, lw_strat )
155  call ke_strat % preUpdate()
156  call ke_strat % update()
157  call ke_strat % postUpdate()
158  ! call lw_strat % update()
159
160  seq( 1 ) % strat => ke_strat
161  seq( 2 ) % strat => lw_strat
162
163  call seq( 1 ) % strat % update()
164
165  do i = 1, 2
166     call seq( i ) % strat % update()
167  end do
168
169end
170