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
|
! { dg-do run }
! { dg-options "-fdump-tree-original" }
!
! Check some basic functionality of allocatable components, including that they
! are nullified when created and automatically deallocated when
! 1. A variable goes out of scope
! 2. INTENT(OUT) dummies
! 3. Function results
!
!
! Contributed by Erik Edelmann <eedelmann@gcc.gnu.org>
! and Paul Thomas <pault@gcc.gnu.org>
!
module alloc_m
implicit none
type :: alloc1
real, allocatable :: x(:)
end type alloc1
end module alloc_m
program alloc
use alloc_m
implicit none
type :: alloc2
type(alloc1), allocatable :: a1(:)
integer, allocatable :: a2(:)
end type alloc2
integer :: i
BLOCK ! To ensure that the allocatables are freed at the end of the scope
type(alloc2) :: b
type(alloc2), allocatable :: c(:)
if (allocated(b%a2) .OR. allocated(b%a1)) then
write (0, *) 'main - 1'
call abort()
end if
! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy)
call allocate_alloc2(b)
call check_alloc2(b)
do i = 1, size(b%a1)
! 1 call to _gfortran_deallocate
deallocate(b%a1(i)%x)
end do
! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy)
call allocate_alloc2(b)
call check_alloc2(return_alloc2())
! 3 calls to _gfortran_deallocate (function result)
allocate(c(1))
! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy)
call allocate_alloc2(c(1))
! 4 calls to _gfortran_deallocate
deallocate(c)
! 7 calls to _gfortran_deallocate (b (3) and c(4) goes aout of scope)
END BLOCK
contains
subroutine allocate_alloc2(b)
type(alloc2), intent(out) :: b
integer :: i
if (allocated(b%a2) .OR. allocated(b%a1)) then
write (0, *) 'allocate_alloc2 - 1'
call abort()
end if
allocate (b%a2(3))
b%a2 = [ 1, 2, 3 ]
allocate (b%a1(3))
do i = 1, 3
if (allocated(b%a1(i)%x)) then
write (0, *) 'allocate_alloc2 - 2', i
call abort()
end if
allocate (b%a1(i)%x(3))
b%a1(i)%x = i + [ 1.0, 2.0, 3.0 ]
end do
end subroutine allocate_alloc2
type(alloc2) function return_alloc2() result(b)
if (allocated(b%a2) .OR. allocated(b%a1)) then
write (0, *) 'return_alloc2 - 1'
call abort()
end if
allocate (b%a2(3))
b%a2 = [ 1, 2, 3 ]
allocate (b%a1(3))
do i = 1, 3
if (allocated(b%a1(i)%x)) then
write (0, *) 'return_alloc2 - 2', i
call abort()
end if
allocate (b%a1(i)%x(3))
b%a1(i)%x = i + [ 1.0, 2.0, 3.0 ]
end do
end function return_alloc2
subroutine check_alloc2(b)
type(alloc2), intent(in) :: b
if (.NOT.(allocated(b%a2) .AND. allocated(b%a1))) then
write (0, *) 'check_alloc2 - 1'
call abort()
end if
if (any(b%a2 /= [ 1, 2, 3 ])) then
write (0, *) 'check_alloc2 - 2'
call abort()
end if
do i = 1, 3
if (.NOT.allocated(b%a1(i)%x)) then
write (0, *) 'check_alloc2 - 3', i
call abort()
end if
if (any(b%a1(i)%x /= i + [ 1.0, 2.0, 3.0 ])) then
write (0, *) 'check_alloc2 - 4', i
call abort()
end if
end do
end subroutine check_alloc2
end program alloc
! { dg-final { scan-tree-dump-times "builtin_free" 18 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
|
