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