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