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
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
|
! { dg-do run }
! { dg-options "-std=f2008" }
!
! Test finalization on intrinsic assignment (F2018 (7.5.6.3))
! With -std=f2008, structure and array constructors are finalized.
! See finalize_38.f90 for the result with -std=gnu.
! Tests fix for PR64290 as well.
!
module testmode
implicit none
type :: simple
integer :: ind
contains
final :: destructor1, destructor2
end type simple
type, extends(simple) :: complicated
real :: rind
contains
final :: destructor3, destructor4
end type complicated
integer :: check_scalar
integer :: check_array(4)
real :: check_real
real :: check_rarray(4)
integer :: final_count = 0
integer :: fails = 0
contains
subroutine destructor1(self)
type(simple), intent(inout) :: self
check_scalar = self%ind
check_array = 0
final_count = final_count + 1
end subroutine destructor1
subroutine destructor2(self)
type(simple), intent(inout) :: self(:)
check_scalar = 0
check_array(1:size(self, 1)) = self%ind
final_count = final_count + 1
end subroutine destructor2
subroutine destructor3(self)
type(complicated), intent(inout) :: self
check_real = self%rind
check_array = 0.0
final_count = final_count + 1
end subroutine destructor3
subroutine destructor4(self)
type(complicated), intent(inout) :: self(:)
check_real = 0.0
check_rarray(1:size(self, 1)) = self%rind
final_count = final_count + 1
end subroutine destructor4
function constructor1(ind) result(res)
class(simple), allocatable :: res
integer, intent(in) :: ind
allocate (res, source = simple (ind))
end function constructor1
function constructor2(ind, rind) result(res)
class(simple), allocatable :: res(:)
integer, intent(in) :: ind(:)
real, intent(in), optional :: rind(:)
type(complicated), allocatable :: src(:)
integer :: sz
integer :: i
if (present (rind)) then
sz = min (size (ind, 1), size (rind, 1))
src = [(complicated (ind(i), rind(i)), i = 1, sz)] ! { dg-warning "has been finalized" }
allocate (res, source = src)
else
sz = size (ind, 1)
allocate (res, source = [(simple (ind(i)), i = 1, sz)])
end if
end function constructor2
subroutine test (cnt, scalar, array, off, rind, rarray)
integer :: cnt
integer :: scalar
integer :: array(:)
integer :: off
real, optional :: rind
real, optional :: rarray(:)
if (final_count .ne. cnt) then
print *, 1 + off, final_count, '(', cnt, ')'
fails = fails + 1
endif
if (check_scalar .ne. scalar) then
print *, 2 + off, check_scalar, '(', scalar, ')'
fails = fails + 1
endif
if (any (check_array(1:size (array, 1)) .ne. array)) then
print *, 3 + off, check_array(1:size (array, 1)) , '(', array, ')'
fails = fails + 1
endif
if (present (rind)) then
if (check_real .ne. rind) then
print *, 4 + off, check_real,'(', rind, ')'
fails = fails + 1
endif
end if
if (present (rarray)) then
if (any (check_rarray(1:size (rarray, 1)) .ne. rarray)) then
print *, 5 + off, check_rarray(1:size (rarray, 1)), '(', rarray, ')'
fails = fails + 1
endif
end if
final_count = 0
end subroutine test
end module testmode
program test_final
use testmode
implicit none
type(simple), allocatable :: MyType, MyType2
type(simple), allocatable :: MyTypeArray(:)
type(simple) :: ThyType = simple(21), ThyType2 = simple(22)
class(simple), allocatable :: MyClass
class(simple), allocatable :: MyClassArray(:)
! ************************
! Derived type assignments
! ************************
! The original PR - no finalization of 'var' before (re)allocation
! because it is deallocated on scope entry (para 1 of F2018 7.5.6.3.)
MyType = ThyType
call test(0, 0, [0,0], 0)
if (.not. allocated(MyType)) allocate(MyType)
allocate(MyType2)
MyType%ind = 1
MyType2%ind = 2
! This should result in a final call with self = simple(1) (para 1 of F2018 7.5.6.3.).
MyType = MyType2
call test(1, 1, [0,0], 10)
allocate(MyTypeArray(2))
MyTypeArray%ind = [42, 43]
! This should result in a final call with self = [simple(42),simple(43)],
! followed by the finalization of the array constructor = self = [simple(21),simple(22)].
MyTypeArray = [ThyType, ThyType2] ! { dg-warning "has been finalized" }
call test(2, 0, [21,22], 20)
! This should result in a final call 'var' = initialization = simple(22),
! followed by one with for the structure constructor.
ThyType2 = simple(99) ! { dg-warning "has been finalized" }
call test(2, 99, [0,0], 30)
! This should result in a final call for 'var' with self = simple(21).
ThyType = ThyType2
call test(1, 21, [0,0], 40)
! This should result in two final calls; the last is for Mytype2 = simple(2).
deallocate (MyType, MyType2)
call test(2, 2, [0,0], 50)
! This should result in one final call; MyTypeArray = [simple(21),simple(22)].
deallocate (MyTypeArray)
call test(1, 0, [21,22], 60)
! The lhs is finalized before assignment.
! The function result is finalized after the assignment.
allocate (MyType, source = simple (11))
MyType = constructor1 (99)
call test(2, 99, [0,0], 70)
deallocate (MyType)
! *****************
! Class assignments
! *****************
final_count = 0
! This should result in a final call for MyClass, which is simple(3) and then
! the structure constructor with value simple(4)).
allocate (MyClass, source = simple (3))
MyClass = simple (4) ! { dg-warning "has been finalized" }
call test(2, 4, [0,0], 100)
! This should result in a final call with the assigned value of simple(4).
deallocate (MyClass)
call test(1, 4, [0,0], 110)
allocate (MyClassArray, source = [simple (5), simple (6)])
! Make sure that there is no final call since MyClassArray is not allocated.
call test(0, 4, [0,0], 120)
MyClassArray = [simple (7), simple (8)] ! { dg-warning "has been finalized" }
! The first final call should finalize MyClassArray and the second should return
! the value of the array constructor.
call test(2, 0, [7,8], 130)
! This should result in a final call with the assigned value.
deallocate (MyClassArray)
call test(1, 0, [7,8], 140)
! This should produce no final calls since MyClassArray was deallocated.
allocate (MyClassArray, source = [complicated(1, 2.0),complicated(3, 4.0)])
! This should produce calls to destructor4 then destructor2.
deallocate (MyClassArray)
! F2018 7.5.6.3: "If the entity is of extended type and the parent type is
! finalizable, the parent component is finalized.
call test(2, 0, [1, 3], 150, rarray = [2.0, 4.0])
! This produces 2 final calls in turn for 'src' as it goes out of scope, for
! MyClassArray before it is assigned to and the result of 'constructor2' after
! the assignment, for which the result should be should be [10,20] & [10.0,20.0].
MyClassArray = constructor2 ([10,20], [10.0,20.0])
call test(6, 0, [10,20], 160, rarray = [10.0,20.0])
! This produces two final calls with the contents of 'MyClassArray. and its
! parent component.
deallocate (MyClassArray)
call test(2, 0, [10, 20], 170, rarray = [10.0,20.0])
! Clean up for valgrind testing
if (allocated (MyType)) deallocate (MyType)
if (allocated (MyType2)) deallocate (MyType2)
if (allocated (MyTypeArray)) deallocate (MyTypeArray)
if (allocated (MyClass)) deallocate (MyClass)
if (allocated (MyClassArray)) deallocate (MyClassArray)
! Error messages printed out by 'test'.
if (fails .ne. 0) then
Print *, fails, " Errors"
error stop
endif
end program test_final
|
