1! { dg-do run }
2! Tests the fix for PR41478, in which double frees would occur because
3! transformational intrinsics did not copy the allocatable components
4! so that they were (sometimes) freed twice on exit.  In addition,
5! The original allocatable components of a1 were not freed, so that
6! memory leakage occurred.
7!
8! Contributed by Juergen Reuter <reuter@physik.uni-freiburg.de>
9!
10  type :: container_t
11    integer, dimension(:), allocatable :: entry
12    integer index
13  end type container_t
14  call foo
15  call bar
16contains
17!
18! This is the reported problem.
19!
20  subroutine foo
21    type(container_t), dimension(4) :: a1, a2, a3
22    integer :: i
23    do i = 1, 4
24      allocate (a1(i)%entry (2), a2(i)%entry (2), a3(i)%entry (2))
25      a1(i)%entry = [1,2]
26      a2(i)%entry = [3,4]
27      a3(i)%entry = [4,5]
28      a1(i)%index = i
29      a2(i)%index = i
30      a3(i)%index = i
31    end do
32    a1(1:2) = pack (a2, [.true., .false., .true., .false.])
33    do i = 1, 4
34      if (.not.allocated (a1(i)%entry)) call abort
35      if (i .gt. 2) then
36        if (any (a1(i)%entry .ne. [1,2])) call abort
37      else
38        if (any (a1(i)%entry .ne. [3,4])) call abort
39      end if
40    end do
41!
42! Now check unpack
43!
44    a1 = unpack (a1, [.true., .true., .false., .false.], a3)
45    if (any (a1%index .ne. [1,3,3,4])) call abort
46    do i = 1, 4
47      if (.not.allocated (a1(i)%entry)) call abort
48      if (i .gt. 2) then
49        if (any (a1(i)%entry .ne. [4,5])) call abort
50      else
51        if (any (a1(i)%entry .ne. [3,4])) call abort
52      end if
53    end do
54  end subroutine
55!
56! Other all transformational intrinsics display it. Having done
57! PACK and UNPACK, just use TRANSPOSE as a demonstrator.
58!
59  subroutine bar
60    type(container_t), dimension(2,2) :: a1, a2
61    integer :: i, j
62    do i = 1, 2
63      do j = 1, 2
64        allocate (a1(i, j)%entry (2), a2(i, j)%entry (2))
65        a1(i, j)%entry = [i,j]
66        a2(i, j)%entry = [i,j]
67        a1(i,j)%index = j + (i - 1)*2
68        a2(i,j)%index = j + (i - 1)*2
69      end do
70    end do
71    a1 = transpose (a2)
72    do i = 1, 2
73      do j = 1, 2
74        if (a1(i,j)%index .ne. i + (j - 1)*2) call abort
75        if (any (a1(i,j)%entry .ne. [j,i])) call abort
76      end do
77    end do
78  end subroutine
79end
80
81