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

    res = a%i
  end function getit
    
end module foo_mod

module s_bar_mod 
  use foo_mod
  type, extends(foo) :: s_bar 
    type(foo), allocatable :: a
  contains 
    procedure, pass(a) :: doit
    procedure, pass(a) :: getit
  end type s_bar
  private doit,getit
  
contains
  subroutine doit(a)
    class(s_bar) :: a
    allocate (a%a)   
    call a%a%doit()
  end subroutine doit
  function getit(a) result(res)
    class(s_bar) :: a
    integer :: res

    res = a%a%getit () * 2
  end function getit
end module s_bar_mod

module a_bar_mod 
  use foo_mod
  type, extends(foo) :: a_bar 
    type(foo), allocatable :: a(:)
  contains 
    procedure, pass(a) :: doit
    procedure, pass(a) :: getit
  end type a_bar
  private doit,getit
  
contains
  subroutine doit(a)
    class(a_bar) :: a
    allocate (a%a(1))   
    call a%a(1)%doit ()
  end subroutine doit
  function getit(a) result(res)
    class(a_bar) :: a
    integer :: res

    res = a%a(1)%getit () * 3
  end function getit
end module a_bar_mod

  use s_bar_mod
  use a_bar_mod
  type(foo), target :: b
  type(s_bar), target :: c
  type(a_bar), target :: d
  class(foo), pointer :: a
  a => b
  call a%doit
  if (a%getit () .ne. 1) call abort
  a => c
  call a%doit
  if (a%getit () .ne. 2) call abort
  a => d
  call a%doit
  if (a%getit () .ne. 3) call abort
end
! { dg-final { cleanup-modules "foo_mod s_bar_mod a_bar_mod" } }