From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001
From: upstream source tree <ports@midipix.org>
Date: Sun, 15 Mar 2015 20:14:05 -0400
Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified
 gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream
 tarball.

downloading a git-generated archive based on the 'upstream' tag
should provide you with a source tree that is binary identical
to the one extracted from the above tarball.

if you have obtained the source via the command 'git clone',
however, do note that line-endings of files in your working
directory might differ from line-endings of the respective
files in the upstream repository.
---
 gcc/testsuite/gfortran.dg/dynamic_dispatch_10.f03 | 171 ++++++++++++++++++++++
 1 file changed, 171 insertions(+)
 create mode 100644 gcc/testsuite/gfortran.dg/dynamic_dispatch_10.f03

(limited to 'gcc/testsuite/gfortran.dg/dynamic_dispatch_10.f03')

diff --git a/gcc/testsuite/gfortran.dg/dynamic_dispatch_10.f03 b/gcc/testsuite/gfortran.dg/dynamic_dispatch_10.f03
new file mode 100644
index 000000000..2b8e0fbc5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/dynamic_dispatch_10.f03
@@ -0,0 +1,171 @@
+! { dg-do run }
+!
+! [OOP] Fortran runtime error: internal error: bad hash value in dynamic dispatch
+!
+! Contributed by David Car <david.car7@gmail.com>
+
+module BaseStrategy
+
+  type, public, abstract :: Strategy
+   contains
+     procedure(strategy_update), pass( this ), deferred :: update
+     procedure(strategy_pre_update), pass( this ), deferred :: preUpdate
+     procedure(strategy_post_update), pass( this ), deferred :: postUpdate
+  end type Strategy
+
+  abstract interface
+     subroutine strategy_update( this )
+       import Strategy
+       class (Strategy), target, intent(in) :: this
+     end subroutine strategy_update
+  end interface
+
+  abstract interface
+     subroutine strategy_pre_update( this )
+       import Strategy
+       class (Strategy), target, intent(in) :: this
+     end subroutine strategy_pre_update
+  end interface
+
+  abstract interface
+     subroutine strategy_post_update( this )
+       import Strategy
+       class (Strategy), target, intent(in) :: this
+     end subroutine strategy_post_update
+  end interface
+     
+end module BaseStrategy
+
+!==============================================================================
+
+module LaxWendroffStrategy
+
+  use BaseStrategy
+
+  private :: update, preUpdate, postUpdate
+
+  type, public, extends( Strategy ) :: LaxWendroff
+     class (Strategy), pointer :: child => null()
+     contains
+       procedure, pass( this ) :: update
+       procedure, pass( this ) :: preUpdate
+       procedure, pass( this ) :: postUpdate
+  end type LaxWendroff
+
+contains
+
+  subroutine update( this )
+    class (LaxWendroff), target, intent(in) :: this
+
+    print *, 'Calling LaxWendroff update'
+  end subroutine update
+
+  subroutine preUpdate( this )
+    class (LaxWendroff), target, intent(in) :: this
+    
+    print *, 'Calling LaxWendroff preUpdate'
+  end subroutine preUpdate
+
+  subroutine postUpdate( this )
+    class (LaxWendroff), target, intent(in) :: this
+    
+    print *, 'Calling LaxWendroff postUpdate'
+  end subroutine postUpdate
+  
+end module LaxWendroffStrategy
+
+!==============================================================================
+
+module KEStrategy
+
+  use BaseStrategy
+  ! Uncomment the line below and it runs fine
+  ! use LaxWendroffStrategy
+
+  private :: update, preUpdate, postUpdate
+
+  type, public, extends( Strategy ) :: KE
+     class (Strategy), pointer :: child => null()
+     contains
+       procedure, pass( this ) :: update
+       procedure, pass( this ) :: preUpdate
+       procedure, pass( this ) :: postUpdate
+  end type KE
+  
+contains
+
+  subroutine init( this, other )
+    class (KE), intent(inout) :: this
+    class (Strategy), target, intent(in) :: other
+
+    this % child => other
+  end subroutine init
+
+  subroutine update( this )
+    class (KE), target, intent(in) :: this
+
+    if ( associated( this % child ) ) then
+       call this % child % update()
+    end if
+
+    print *, 'Calling KE update'
+  end subroutine update
+
+ subroutine preUpdate( this )
+    class (KE), target, intent(in) :: this
+    
+    if ( associated( this % child ) ) then
+       call this % child % preUpdate()
+    end if
+
+    print *, 'Calling KE preUpdate'
+  end subroutine preUpdate
+
+  subroutine postUpdate( this )
+    class (KE), target, intent(in) :: this
+
+    if ( associated( this % child ) ) then
+       call this % child % postUpdate()
+    end if
+    
+    print *, 'Calling KE postUpdate'
+  end subroutine postUpdate
+  
+end module KEStrategy
+
+!==============================================================================
+
+program main
+
+  use LaxWendroffStrategy
+  use KEStrategy
+
+  type :: StratSeq
+     class (Strategy), pointer :: strat => null()
+  end type StratSeq
+
+  type (LaxWendroff), target :: lw_strat
+  type (KE), target :: ke_strat
+
+  type (StratSeq), allocatable, dimension( : ) :: seq
+  
+  allocate( seq(10) )
+
+  call init( ke_strat, lw_strat )
+  call ke_strat % preUpdate()
+  call ke_strat % update()
+  call ke_strat % postUpdate()
+  ! call lw_strat % update()
+
+  seq( 1 ) % strat => ke_strat
+  seq( 2 ) % strat => lw_strat
+
+  call seq( 1 ) % strat % update()
+
+  do i = 1, 2
+     call seq( i ) % strat % update()
+  end do
+
+end
+
+! { dg-final { cleanup-modules "BaseStrategy LaxWendroffStrategy KEStrategy" } }
-- 
cgit v1.2.3