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