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