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") call abort () 28 if (len(P1) .ne. 20) call abort () 29 if (len(P1) .eq. len("some test string")) call abort () 30 class default 31 call abort () 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") call abort () 39 if (len(A1) .ne. 20) call abort () 40 if (len(A1) .eq. len("some test string")) call abort () 41 class default 42 call abort () 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") call abort () 50 if (len(A2) .ne. 20) call abort () 51 if (len(A2) .eq. len("some test string")) call abort () 52 class default 53 call abort () 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") call abort () 61 if (len(P2) .eq. 20) call abort () 62 if (len(P2) .ne. len("string for test")) call abort () 63 class default 64 call abort () 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") call abort () 72 if (len(P3) .eq. 20) call abort () 73 if (len(P3) .ne. len("string for test")) call abort () 74 class default 75 call abort () 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 ") call abort () 84 if (any(len(PA1(:)) .ne. [10,10,10])) call abort () 85 class default 86 call abort () 87 end select 88 89 deallocate(PA1) 90 deallocate(P3) 91! if (len(P3) .ne. 0) call abort() ! 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") call abort () 106 if (len(P1) .ne. 20) call abort () 107 if (len(P1) .eq. len("some test string")) call abort () 108 type is (character(len=*,kind=1)) 109 call abort () 110 class default 111 call abort () 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") call abort () 119 if (len(A1) .ne. 20) call abort () 120 if (len(A1) .eq. len("some test string")) call abort () 121 type is (character(len=*,kind=1)) 122 call abort () 123 class default 124 call abort () 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") call abort () 132 if (len(A2) .ne. 20) call abort () 133 if (len(A2) .eq. len("some test string")) call abort () 134 class default 135 call abort () 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") call abort () 143 if (len(P2) .eq. 20) call abort () 144 if (len(P2) .ne. len("string for test")) call abort () 145 class default 146 call abort () 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") call abort () 154 if (len(P3) .eq. 20) call abort () 155 if (len(P3) .ne. len("string for test")) call abort () 156 class default 157 call abort () 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 ") call abort () 166 if (any(len(PA1(:)) .ne. [10,10,10])) call abort () 167 class default 168 call abort () 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') call abort () 183 class default 184 call abort() 185 end select 186 select type (d => o2%content) 187 type is (character(*)) 188 if (d /= 'test string') call abort () 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') call abort() 210 class default 211 call abort() 212 end select 213 end subroutine 214 215end program test 216