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