gcc/testsuite/gfortran.dg/dynamic_dispatch_4.f03

   1 ! { dg-do run }
   2 ! Tests the fix for PR41648 in which the reference a%a%getit () was wrongly
   3 ! identified as a recursive call to getit.
   4 !
   5 ! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
   6 !
   7 module foo_mod
   8   type foo
   9     integer :: i
  10   contains
  11     procedure, pass(a) :: doit
  12     procedure, pass(a) :: getit
  13   end type foo
  14
  15   private doit,getit
  16 contains
  17   subroutine  doit(a)
  18     class(foo) :: a
  19
  20     a%i = 1
  21   end subroutine doit
  22   function getit(a) result(res)
  23     class(foo) :: a
  24     integer :: res
  25
  26     res = a%i
  27   end function getit
  28
  29 end module foo_mod
  30
  31 module s_bar_mod
  32   use foo_mod
  33   type, extends(foo) :: s_bar
  34     type(foo), allocatable :: a
  35   contains
  36     procedure, pass(a) :: doit
  37     procedure, pass(a) :: getit
  38   end type s_bar
  39   private doit,getit
  40
  41 contains
  42   subroutine doit(a)
  43     class(s_bar) :: a
  44     allocate (a%a)
  45     call a%a%doit()
  46   end subroutine doit
  47   function getit(a) result(res)
  48     class(s_bar) :: a
  49     integer :: res
  50
  51     res = a%a%getit () * 2
  52   end function getit
  53 end module s_bar_mod
  54
  55 module a_bar_mod
  56   use foo_mod
  57   type, extends(foo) :: a_bar
  58     type(foo), allocatable :: a(:)
  59   contains
  60     procedure, pass(a) :: doit
  61     procedure, pass(a) :: getit
  62   end type a_bar
  63   private doit,getit
  64
  65 contains
  66   subroutine doit(a)
  67     class(a_bar) :: a
  68     allocate (a%a(1))
  69     call a%a(1)%doit ()
  70   end subroutine doit
  71   function getit(a) result(res)
  72     class(a_bar) :: a
  73     integer :: res
  74
  75     res = a%a(1)%getit () * 3
  76   end function getit
  77 end module a_bar_mod
  78
  79   use s_bar_mod
  80   use a_bar_mod
  81   type(foo), target :: b
  82   type(s_bar), target :: c
  83   type(a_bar), target :: d
  84   class(foo), pointer :: a
  85   a => b
  86   call a%doit
  87   if (a%getit () .ne. 1) call abort
  88   a => c
  89   call a%doit
  90   if (a%getit () .ne. 2) call abort
  91   a => d
  92   call a%doit
  93   if (a%getit () .ne. 3) call abort
  94 end
  95 ! { dg-final { cleanup-modules "foo_mod s_bar_mod a_bar_mod" } }
  96