1! { dg-do run }
2! This tests the "virtual fix" for PR19561, where pointers to derived
3! types were not generating correct code.  This testcase is based on
4! the original PR example.  This example not only tests the
5! original problem but throughly tests derived types in modules,
6! module interfaces and compound derived types.
7!
8! Original by Martin Reinecke  martin@mpa-garching.mpg.de
9! Submitted by Paul Thomas  pault@gcc.gnu.org
10! Slightly modified by Tobias Schlüter
11module func_derived_3
12  implicit none
13  type objA
14    private
15    integer :: i
16  end type objA
17
18  interface new
19    module procedure oaInit
20  end interface
21
22  interface print
23    module procedure oaPrint
24  end interface
25
26  private
27  public objA,new,print
28
29contains
30
31  subroutine oaInit(oa,i)
32    integer :: i
33    type(objA) :: oa
34    oa%i=i
35  end subroutine oaInit
36
37  subroutine oaPrint (oa)
38    type (objA) :: oa
39    write (10, '("simple  = ",i5)') oa%i
40    end subroutine oaPrint
41
42end module func_derived_3
43
44module func_derived_3a
45  use func_derived_3
46  implicit none
47
48  type objB
49    private
50    integer :: i
51    type(objA), pointer :: oa
52  end type objB
53
54  interface new
55    module procedure obInit
56  end interface
57
58  interface print
59    module procedure obPrint
60  end interface
61
62  private
63  public objB, new, print, getOa, getOa2
64
65contains
66
67  subroutine obInit (ob,oa,i)
68    integer :: i
69    type(objA), target :: oa
70    type(objB) :: ob
71
72    ob%i=i
73    ob%oa=>oa
74  end subroutine obInit
75
76  subroutine obPrint (ob)
77    type (objB) :: ob
78    write (10, '("derived = ",i5)') ob%i
79    call print (ob%oa)
80  end subroutine obPrint
81
82  function getOa (ob) result (oa)
83    type (objB),target :: ob
84    type (objA), pointer :: oa
85
86    oa=>ob%oa
87  end function getOa
88
89! without a result clause
90  function getOa2 (ob)
91    type (objB),target :: ob
92    type (objA), pointer :: getOa2
93
94    getOa2=>ob%oa
95  end function getOa2
96
97end module func_derived_3a
98
99  use func_derived_3
100  use func_derived_3a
101  implicit none
102  type (objA),target :: oa
103  type (objB),target :: ob
104  character (len=80) :: line
105
106  open (10, status='scratch')
107
108  call new (oa,1)
109  call new (ob, oa, 2)
110
111  call print (ob)
112  call print (getOa (ob))
113  call print (getOa2 (ob))
114
115  rewind (10)
116  read (10, '(80a)') line
117  if (trim (line).ne."derived =     2") STOP 1
118  read (10,  '(80a)') line
119  if (trim (line).ne."simple  =     1") STOP 2
120  read (10,  '(80a)') line
121  if (trim (line).ne."simple  =     1") STOP 3
122  read (10,  '(80a)') line
123  if (trim (line).ne."simple  =     1") STOP 4
124  close (10)
125end program
126