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.
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
19 module procedure oaInit
23 module procedure oaPrint
31 subroutine oaInit(oa,i)
37 subroutine oaPrint (oa)
39 write (10, '("simple = ",i5)') oa%i
40 end subroutine oaPrint
42 end module func_derived_3
44 module func_derived_3a
51 type(objA), pointer :: oa
55 module procedure obInit
59 module procedure obPrint
63 public objB, new, print, getOa, getOa2
67 subroutine obInit (ob,oa,i)
69 type(objA), target :: oa
76 subroutine obPrint (ob)
78 write (10, '("derived = ",i5)') ob%i
80 end subroutine obPrint
82 function getOa (ob) result (oa)
83 type (objB),target :: ob
84 type (objA), pointer :: oa
89 ! without a result clause
91 type (objB),target :: ob
92 type (objA), pointer :: getOa2
97 end module func_derived_3a
102 type (objA),target :: oa
103 type (objB),target :: ob
104 character (len=80) :: line
106 open (10, status='scratch')
112 call print (getOa (ob))
113 call print (getOa2 (ob))
116 read (10, '(80a)') line
117 if (trim (line).ne."derived = 2") call abort ()
118 read (10, '(80a)') line
119 if (trim (line).ne."simple = 1") call abort ()
120 read (10, '(80a)') line
121 if (trim (line).ne."simple = 1") call abort ()
122 read (10, '(80a)') line
123 if (trim (line).ne."simple = 1") call abort ()