2 ! { dg-options "-fdump-tree-original" }
4 ! Check some basic functionality of allocatable components, including that they
5 ! are nullified when created and automatically deallocated when
6 ! 1. A variable goes out of scope
7 ! 2. INTENT(OUT) dummies
11 ! Contributed by Erik Edelmann <eedelmann@gcc.gnu.org>
12 ! and Paul Thomas <pault@gcc.gnu.org>
19 real, allocatable :: x(:)
32 type(alloc1), allocatable :: a1(:)
33 integer, allocatable :: a2(:)
38 type(alloc2), allocatable :: c(:)
40 if (allocated(b%a2) .OR. allocated(b%a1)) then
41 write (0, *) 'main - 1'
45 ! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy)
46 call allocate_alloc2(b)
50 ! 1 call to _gfortran_deallocate
54 ! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy)
55 call allocate_alloc2(b)
57 call check_alloc2(return_alloc2())
58 ! 3 calls to _gfortran_deallocate (function result)
61 ! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy)
62 call allocate_alloc2(c(1))
63 ! 4 calls to _gfortran_deallocate
66 ! 7 calls to _gfortran_deallocate (b (3) and c(4) goes aout of scope)
70 subroutine allocate_alloc2(b)
71 type(alloc2), intent(out) :: b
74 if (allocated(b%a2) .OR. allocated(b%a1)) then
75 write (0, *) 'allocate_alloc2 - 1'
85 if (allocated(b%a1(i)%x)) then
86 write (0, *) 'allocate_alloc2 - 2', i
89 allocate (b%a1(i)%x(3))
90 b%a1(i)%x = i + [ 1.0, 2.0, 3.0 ]
93 end subroutine allocate_alloc2
96 type(alloc2) function return_alloc2() result(b)
97 if (allocated(b%a2) .OR. allocated(b%a1)) then
98 write (0, *) 'return_alloc2 - 1'
108 if (allocated(b%a1(i)%x)) then
109 write (0, *) 'return_alloc2 - 2', i
112 allocate (b%a1(i)%x(3))
113 b%a1(i)%x = i + [ 1.0, 2.0, 3.0 ]
115 end function return_alloc2
118 subroutine check_alloc2(b)
119 type(alloc2), intent(in) :: b
121 if (.NOT.(allocated(b%a2) .AND. allocated(b%a1))) then
122 write (0, *) 'check_alloc2 - 1'
125 if (any(b%a2 /= [ 1, 2, 3 ])) then
126 write (0, *) 'check_alloc2 - 2'
130 if (.NOT.allocated(b%a1(i)%x)) then
131 write (0, *) 'check_alloc2 - 3', i
134 if (any(b%a1(i)%x /= i + [ 1.0, 2.0, 3.0 ])) then
135 write (0, *) 'check_alloc2 - 4', i
139 end subroutine check_alloc2
142 ! { dg-final { scan-tree-dump-times "builtin_free" 18 "original" } }
143 ! { dg-final { cleanup-tree-dump "original" } }