summaryrefslogtreecommitdiff
path: root/gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90
blob: e53112ce46e07b30be4a4fd3e55d80aa689cff98 (plain)
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
! { 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

    type(alloc2) :: b
    integer :: i
    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)

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" } }
! { dg-final { cleanup-modules "alloc_m" } }