1! { dg-do run } 2! Testing fix for PR fortran/60289 3! Contributed by: Andre Vehreschild <vehre@gmx.de> 4! 5program test 6 implicit none 7 8 class(*), pointer :: P1, P2, P3 9 class(*), pointer, dimension(:) :: PA1 10 class(*), allocatable :: A1, A2 11 integer :: string_len = 10 *2 12 character(len=:), allocatable, target :: str 13 character(len=:,kind=4), allocatable :: str4 14 type T 15 class(*), pointer :: content 16 end type 17 type(T) :: o1, o2 18 19 str = "string for test" 20 str4 = 4_"string for test" 21 22 allocate(character(string_len)::P1) 23 24 select type(P1) 25 type is (character(*)) 26 P1 ="some test string" 27 if (P1 .ne. "some test string") STOP 1 28 if (len(P1) .ne. 20) STOP 2 29 if (len(P1) .eq. len("some test string")) STOP 3 30 class default 31 STOP 4 32 end select 33 34 allocate(A1, source = P1) 35 36 select type(A1) 37 type is (character(*)) 38 if (A1 .ne. "some test string") STOP 5 39 if (len(A1) .ne. 20) STOP 6 40 if (len(A1) .eq. len("some test string")) STOP 7 41 class default 42 STOP 8 43 end select 44 45 allocate(A2, source = convertType(P1)) 46 47 select type(A2) 48 type is (character(*)) 49 if (A2 .ne. "some test string") STOP 9 50 if (len(A2) .ne. 20) STOP 10 51 if (len(A2) .eq. len("some test string")) STOP 11 52 class default 53 STOP 12 54 end select 55 56 allocate(P2, source = str) 57 58 select type(P2) 59 type is (character(*)) 60 if (P2 .ne. "string for test") STOP 13 61 if (len(P2) .eq. 20) STOP 14 62 if (len(P2) .ne. len("string for test")) STOP 15 63 class default 64 STOP 16 65 end select 66 67 allocate(P3, source = "string for test") 68 69 select type(P3) 70 type is (character(*)) 71 if (P3 .ne. "string for test") STOP 17 72 if (len(P3) .eq. 20) STOP 18 73 if (len(P3) .ne. len("string for test")) STOP 19 74 class default 75 STOP 20 76 end select 77 78 allocate(character(len=10)::PA1(3)) 79 80 select type(PA1) 81 type is (character(*)) 82 PA1(1) = "string 10 " 83 if (PA1(1) .ne. "string 10 ") STOP 21 84 if (any(len(PA1(:)) .ne. [10,10,10])) STOP 22 85 class default 86 STOP 23 87 end select 88 89 deallocate(PA1) 90 deallocate(P3) 91! if (len(P3) .ne. 0) STOP 24 ! Can't check, because select 92! type would be needed, which needs the vptr, which is 0 now. 93 deallocate(P2) 94 deallocate(A2) 95 deallocate(A1) 96 deallocate(P1) 97 98 ! Now for kind=4 chars. 99 100 allocate(character(len=20,kind=4)::P1) 101 102 select type(P1) 103 type is (character(len=*,kind=4)) 104 P1 ="some test string" 105 if (P1 .ne. 4_"some test string") STOP 25 106 if (len(P1) .ne. 20) STOP 26 107 if (len(P1) .eq. len("some test string")) STOP 27 108 type is (character(len=*,kind=1)) 109 STOP 28 110 class default 111 STOP 29 112 end select 113 114 allocate(A1, source=P1) 115 116 select type(A1) 117 type is (character(len=*,kind=4)) 118 if (A1 .ne. 4_"some test string") STOP 30 119 if (len(A1) .ne. 20) STOP 31 120 if (len(A1) .eq. len("some test string")) STOP 32 121 type is (character(len=*,kind=1)) 122 STOP 33 123 class default 124 STOP 34 125 end select 126 127 allocate(A2, source = convertType(P1)) 128 129 select type(A2) 130 type is (character(len=*, kind=4)) 131 if (A2 .ne. 4_"some test string") STOP 35 132 if (len(A2) .ne. 20) STOP 36 133 if (len(A2) .eq. len("some test string")) STOP 37 134 class default 135 STOP 38 136 end select 137 138 allocate(P2, source = str4) 139 140 select type(P2) 141 type is (character(len=*,kind=4)) 142 if (P2 .ne. 4_"string for test") STOP 39 143 if (len(P2) .eq. 20) STOP 40 144 if (len(P2) .ne. len("string for test")) STOP 41 145 class default 146 STOP 42 147 end select 148 149 allocate(P3, source = convertType(P2)) 150 151 select type(P3) 152 type is (character(len=*, kind=4)) 153 if (P3 .ne. 4_"string for test") STOP 43 154 if (len(P3) .eq. 20) STOP 44 155 if (len(P3) .ne. len("string for test")) STOP 45 156 class default 157 STOP 46 158 end select 159 160 allocate(character(kind=4, len=10)::PA1(3)) 161 162 select type(PA1) 163 type is (character(len=*, kind=4)) 164 PA1(1) = 4_"string 10 " 165 if (PA1(1) .ne. 4_"string 10 ") STOP 47 166 if (any(len(PA1(:)) .ne. [10,10,10])) STOP 48 167 class default 168 STOP 49 169 end select 170 171 deallocate(PA1) 172 deallocate(P3) 173 deallocate(P2) 174 deallocate(A2) 175 deallocate(P1) 176 deallocate(A1) 177 178 allocate(o1%content, source='test string') 179 allocate(o2%content, source=o1%content) 180 select type (c => o1%content) 181 type is (character(*)) 182 if (c /= 'test string') STOP 50 183 class default 184 STOP 51 185 end select 186 select type (d => o2%content) 187 type is (character(*)) 188 if (d /= 'test string') STOP 52 189 class default 190 end select 191 192 call AddCopy ('test string') 193 194contains 195 196 function convertType(in) 197 class(*), pointer, intent(in) :: in 198 class(*), pointer :: convertType 199 200 convertType => in 201 end function 202 203 subroutine AddCopy(C) 204 class(*), intent(in) :: C 205 class(*), pointer :: P 206 allocate(P, source=C) 207 select type (P) 208 type is (character(*)) 209 if (P /= 'test string') STOP 53 210 class default 211 STOP 54 212 end select 213 end subroutine 214 215end program test 216