1! { dg-do run } 2! 3! PR fortran/51972 4! Also tests fixes for PR52102 5! 6! Check whether DT assignment with polymorphic components works. 7! 8 9subroutine test1 () 10 type t 11 integer :: x 12 end type t 13 14 type t2 15 class(t), allocatable :: a 16 end type t2 17 18 type(t2) :: one, two 19 20 one = two 21 if (allocated (one%a)) call abort () 22 23 allocate (two%a) 24 two%a%x = 7890 25 one = two 26 if (one%a%x /= 7890) call abort () 27 28 deallocate (two%a) 29 one = two 30 if (allocated (one%a)) call abort () 31end subroutine test1 32 33subroutine test2 () 34 type t 35 integer, allocatable :: x(:) 36 end type t 37 38 type t2 39 class(t), allocatable :: a 40 end type t2 41 42 type(t2) :: one, two 43 44 one = two 45 if (allocated (one%a)) call abort () 46 47 allocate (two%a) 48 one = two 49 if (.not.allocated (one%a)) call abort () 50 if (allocated (one%a%x)) call abort () 51 52 allocate (two%a%x(2)) 53 two%a%x(:) = 7890 54 one = two 55 if (any (one%a%x /= 7890)) call abort () 56 57 deallocate (two%a) 58 one = two 59 if (allocated (one%a)) call abort () 60end subroutine test2 61 62 63subroutine test3 () 64 type t 65 integer :: x 66 end type t 67 68 type t2 69 class(t), allocatable :: a(:) 70 end type t2 71 72 type(t2) :: one, two 73 74! Test allocate with array source - PR52102 75 allocate (two%a(2), source = [t(4), t(6)]) 76 77 if (allocated (one%a)) call abort () 78 79 one = two 80 if (.not.allocated (one%a)) call abort () 81 82 if ((one%a(1)%x /= 4)) call abort () 83 if ((one%a(2)%x /= 6)) call abort () 84 85 deallocate (two%a) 86 one = two 87 88 if (allocated (one%a)) call abort () 89 90! Test allocate with no source followed by assignments. 91 allocate (two%a(2)) 92 two%a(1)%x = 5 93 two%a(2)%x = 7 94 95 if (allocated (one%a)) call abort () 96 97 one = two 98 if (.not.allocated (one%a)) call abort () 99 100 if ((one%a(1)%x /= 5)) call abort () 101 if ((one%a(2)%x /= 7)) call abort () 102 103 deallocate (two%a) 104 one = two 105 if (allocated (one%a)) call abort () 106end subroutine test3 107 108subroutine test4 () 109 type t 110 integer, allocatable :: x(:) 111 end type t 112 113 type t2 114 class(t), allocatable :: a(:) 115 end type t2 116 117 type(t2) :: one, two 118 119 if (allocated (one%a)) call abort () 120 if (allocated (two%a)) call abort () 121 122 allocate (two%a(2)) 123 124 if (allocated (two%a(1)%x)) call abort () 125 if (allocated (two%a(2)%x)) call abort () 126 allocate (two%a(1)%x(3), source=[1,2,3]) 127 allocate (two%a(2)%x(5), source=[5,6,7,8,9]) 128 one = two 129 if (.not. allocated (one%a)) call abort () 130 if (.not. allocated (one%a(1)%x)) call abort () 131 if (.not. allocated (one%a(2)%x)) call abort () 132 133 if (size(one%a) /= 2) call abort() 134 if (size(one%a(1)%x) /= 3) call abort() 135 if (size(one%a(2)%x) /= 5) call abort() 136 if (any (one%a(1)%x /= [1,2,3])) call abort () 137 if (any (one%a(2)%x /= [5,6,7,8,9])) call abort () 138 139 deallocate (two%a(1)%x) 140 one = two 141 if (.not. allocated (one%a)) call abort () 142 if (allocated (one%a(1)%x)) call abort () 143 if (.not. allocated (one%a(2)%x)) call abort () 144 145 if (size(one%a) /= 2) call abort() 146 if (size(one%a(2)%x) /= 5) call abort() 147 if (any (one%a(2)%x /= [5,6,7,8,9])) call abort () 148 149 deallocate (two%a) 150 one = two 151 if (allocated (one%a)) call abort () 152 if (allocated (two%a)) call abort () 153end subroutine test4 154 155 156call test1 () 157call test2 () 158call test3 () 159call test4 () 160end 161 162