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