gcc/testsuite/gfortran.dg/move_alloc_15.f90

   1 ! { dg-do run }
   2 ! { dg-options "-fdump-tree-original" }
   3 !
   4 ! Fix for PR......
   5 !
   6 ! The 'to' components of 'mytemp' would remain allocated after the call to
   7 ! MOVE_ALLOC, resulting in memory leaks.
   8 !
   9 ! Contributed by Alberto Luaces.
  10 !
  11 ! See https://groups.google.com/forum/#!topic/comp.lang.fortran/k3bkKUbOpFU
  12 !
  13 module alloctest
  14   type myallocatable
  15      integer, allocatable:: i(:)
  16   end type myallocatable
  17
  18 contains
  19   subroutine f(num, array)
  20     implicit none
  21     integer, intent(in) :: num
  22     integer :: i
  23     type(myallocatable):: array(:)
  24
  25     do i = 1, num
  26        allocate(array(i)%i(5), source = [1,2,3,4,5])
  27     end do
  28
  29   end subroutine f
  30 end module alloctest
  31
  32 program name
  33   use alloctest
  34   implicit none
  35   type(myallocatable), allocatable:: myarray(:), mytemp(:)
  36   integer, parameter:: OLDSIZE = 7, NEWSIZE = 20
  37   logical :: flag
  38
  39   allocate(myarray(OLDSIZE))
  40   call f(size(myarray), myarray)
  41
  42   allocate(mytemp(NEWSIZE))
  43   mytemp(1:OLDSIZE) = myarray
  44
  45   flag = .false.
  46   call foo
  47   call bar
  48
  49   deallocate(myarray)
  50   if (allocated (mytemp)) deallocate (mytemp)
  51
  52   allocate(myarray(OLDSIZE))
  53   call f(size(myarray), myarray)
  54
  55   allocate(mytemp(NEWSIZE))
  56   mytemp(1:OLDSIZE) = myarray
  57
  58 ! Verfify that there is no segfault if the allocatable components
  59 ! are deallocated before the call to move_alloc
  60   flag = .true.
  61   call foo
  62   call bar
  63
  64   deallocate(myarray)
  65 contains
  66   subroutine foo
  67     integer :: i
  68     if (flag) then
  69       do i = 1, OLDSIZE
  70         deallocate (mytemp(i)%i)
  71       end do
  72     end if
  73     call move_alloc(mytemp, myarray)
  74   end subroutine
  75
  76   subroutine bar
  77     integer :: i
  78     do i = 1, OLDSIZE
  79       if (.not.flag .and. allocated (myarray(i)%i)) then
  80         if (any (myarray(i)%i .ne. [1,2,3,4,5])) call abort
  81       else
  82         if (.not.flag) call abort
  83       end if
  84     end do
  85   end subroutine
  86 end program name
  87 ! { dg-final { scan-tree-dump-times "__builtin_malloc" 14 "original" } }
  88 ! { dg-final { scan-tree-dump-times "__builtin_free" 14 "original" } }