gcc/testsuite/gfortran.dg/alloc_comp_transformational_1.f90

   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
  16 contains
  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
  79 end
  80