gcc/testsuite/gfortran.dg/dynamic_dispatch_10.f03

   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
   7 module 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
  37 end module BaseStrategy
  38
  39 !==============================================================================
  40
  41 module 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
  55 contains
  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
  75 end module LaxWendroffStrategy
  76
  77 !==============================================================================
  78
  79 module 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
  95 contains
  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
 134 end module KEStrategy
 135
 136 !==============================================================================
 137
 138 program 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
 169 end