OSDN Git Service

* builtin-types.def (BT_FN_PTR_PTR_SIZE): New type.
[pf3gnuchains/gcc-fork.git] / gcc / testsuite / gfortran.dg / alloc_comp_basics_1.f90
1 ! { dg-do run }
2 ! { dg-options "-O2 -fdump-tree-original" }
3 !
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
8 ! 3. Function results
9 !
10 !
11 ! Contributed by Erik Edelmann  <eedelmann@gcc.gnu.org>
12 !            and Paul Thomas  <pault@gcc.gnu.org>
13 !
14 module alloc_m
15
16     implicit none
17
18     type :: alloc1
19         real, allocatable :: x(:)
20     end type alloc1
21
22 end module alloc_m
23
24
25 program alloc
26
27     use alloc_m
28
29     implicit none
30
31     type :: alloc2
32         type(alloc1), allocatable :: a1(:)
33         integer, allocatable :: a2(:)
34     end type alloc2
35
36     type(alloc2) :: b
37     integer :: i
38     type(alloc2), allocatable :: c(:)
39
40     if (allocated(b%a2) .OR. allocated(b%a1)) then
41         write (0, *) 'main - 1'
42         call abort()
43     end if
44
45     ! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy)
46     call allocate_alloc2(b)
47     call check_alloc2(b)
48
49     do i = 1, size(b%a1)
50         ! 1 call to _gfortran_deallocate
51         deallocate(b%a1(i)%x)
52     end do
53
54     ! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy)
55     call allocate_alloc2(b)
56
57     call check_alloc2(return_alloc2())
58     ! 3 calls to _gfortran_deallocate (function result)
59
60     allocate(c(1))
61     ! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy)
62     call allocate_alloc2(c(1))
63     ! 4 calls to _gfortran_deallocate
64     deallocate(c)
65
66     ! 7 calls to _gfortran_deallocate (b (3) and c(4) goes aout of scope)
67
68 contains
69
70     subroutine allocate_alloc2(b)
71         type(alloc2), intent(out) :: b
72         integer :: i
73
74         if (allocated(b%a2) .OR. allocated(b%a1)) then
75             write (0, *) 'allocate_alloc2 - 1'
76             call abort()
77         end if
78
79         allocate (b%a2(3))
80         b%a2 = [ 1, 2, 3 ]
81
82         allocate (b%a1(3))
83
84         do i = 1, 3
85             if (allocated(b%a1(i)%x)) then
86                 write (0, *) 'allocate_alloc2 - 2', i
87                 call abort()
88             end if
89             allocate (b%a1(i)%x(3))
90             b%a1(i)%x = i + [ 1.0, 2.0, 3.0 ]
91         end do
92
93     end subroutine allocate_alloc2
94
95
96     type(alloc2) function return_alloc2() result(b)
97         if (allocated(b%a2) .OR. allocated(b%a1)) then
98             write (0, *) 'return_alloc2 - 1'
99             call abort()
100         end if
101
102         allocate (b%a2(3))
103         b%a2 = [ 1, 2, 3 ]
104
105         allocate (b%a1(3))
106
107         do i = 1, 3
108             if (allocated(b%a1(i)%x)) then
109                 write (0, *) 'return_alloc2 - 2', i
110                 call abort()
111             end if
112             allocate (b%a1(i)%x(3))
113             b%a1(i)%x = i + [ 1.0, 2.0, 3.0 ]
114         end do
115     end function return_alloc2
116
117
118     subroutine check_alloc2(b)
119         type(alloc2), intent(in) :: b
120
121         if (.NOT.(allocated(b%a2) .AND. allocated(b%a1))) then
122             write (0, *) 'check_alloc2 - 1'
123             call abort()
124         end if
125         if (any(b%a2 /= [ 1, 2, 3 ])) then
126             write (0, *) 'check_alloc2 - 2'
127             call abort()
128         end if
129         do i = 1, 3
130             if (.NOT.allocated(b%a1(i)%x)) then
131                 write (0, *) 'check_alloc2 - 3', i
132                 call abort()
133             end if
134             if (any(b%a1(i)%x /= i + [ 1.0, 2.0, 3.0 ])) then
135                 write (0, *) 'check_alloc2 - 4', i
136                 call abort()
137             end if
138         end do
139     end subroutine check_alloc2
140
141 end program alloc
142 ! { dg-final { scan-tree-dump-times "builtin_free" 24 "original" } }
143 ! { dg-final { cleanup-tree-dump "original" } }
144 ! { dg-final { cleanup-modules "alloc_m" } }