gcc/testsuite/gfortran.dg/allocate_with_source_14.f03

   1 ! { dg-do compile }
   2 ! { dg-options "-fdump-tree-original" }
   3 !
   4 ! Tests the fix for PR61830.
   5 !
   6 ! Contributed by Salvatore Filippone  <sfilippone@uniroma2.it>
   7 !
   8 module foo_base_mod
   9   integer, parameter :: foo_dpk_ = kind(1.d0)
  10   type foo_d_base_vect_type
  11     real(foo_dpk_), allocatable :: v(:)
  12   contains
  13     procedure :: free     => d_base_free
  14     procedure :: get_vect => d_base_get_vect
  15     procedure :: allocate => d_base_allocate
  16   end type foo_d_base_vect_type
  17
  18
  19   type foo_d_vect_type
  20     class(foo_d_base_vect_type), allocatable :: v
  21   contains
  22     procedure :: free     => d_vect_free
  23     procedure :: get_vect => d_vect_get_vect
  24   end type foo_d_vect_type
  25
  26   type foo_desc_type
  27     integer :: nl=-1
  28   end type foo_desc_type
  29
  30 contains
  31
  32   subroutine  foo_cdall(map,nl)
  33     type(foo_desc_type) :: map
  34     integer, optional  :: nl
  35
  36     if (present(nl)) then
  37       map%nl = nl
  38     else
  39       map%nl = 1
  40     end if
  41   end subroutine foo_cdall
  42
  43
  44   subroutine  foo_cdasb(map,info)
  45     integer :: info
  46     type(foo_desc_type) :: map
  47     if (map%nl < 0) map%nl=1
  48   end subroutine foo_cdasb
  49
  50
  51
  52   subroutine d_base_allocate(this,n)
  53     class(foo_d_base_vect_type), intent(out) :: this
  54
  55     allocate(this%v(max(1,n)))
  56
  57   end subroutine d_base_allocate
  58
  59   subroutine d_base_free(this)
  60     class(foo_d_base_vect_type), intent(inout) :: this
  61     if (allocated(this%v))  then
  62       write(0,*) 'Scalar deallocation'
  63       deallocate(this%v)
  64     end if
  65   end subroutine d_base_free
  66
  67   function d_base_get_vect(this) result(res)
  68     class(foo_d_base_vect_type), intent(inout) :: this
  69     real(foo_dpk_), allocatable :: res(:)
  70
  71     if (allocated(this%v)) then
  72       res = this%v
  73     else
  74       allocate(res(1))
  75     end if
  76   end function d_base_get_vect
  77
  78   subroutine d_vect_free(this)
  79     class(foo_d_vect_type) :: this
  80     if (allocated(this%v)) then
  81       call this%v%free()
  82       write(0,*) 'Deallocate class() component'
  83       deallocate(this%v)
  84     end if
  85   end subroutine d_vect_free
  86
  87   function d_vect_get_vect(this) result(res)
  88     class(foo_d_vect_type) :: this
  89     real(foo_dpk_), allocatable :: res(:)
  90
  91     if (allocated(this%v)) then
  92       res = this%v%get_vect()
  93     else
  94       allocate(res(1))
  95     end if
  96   end function d_vect_get_vect
  97
  98   subroutine foo_geall(v,map,info)
  99     type(foo_d_vect_type), intent(out) :: v
 100     type(foo_Desc_type) :: map
 101     integer :: info
 102
 103     allocate(foo_d_base_vect_type :: v%v,stat=info)
 104     if (info == 0) call v%v%allocate(map%nl)
 105   end subroutine foo_geall
 106
 107 end module foo_base_mod
 108
 109
 110 module foo_scalar_field_mod
 111   use foo_base_mod
 112   implicit none
 113
 114   type scalar_field
 115     type(foo_d_vect_type)        :: f
 116     type(foo_desc_type), pointer :: map => null()
 117   contains
 118     procedure :: free
 119   end type
 120
 121   integer, parameter :: nx=4,ny=nx, nz=nx
 122   type(foo_desc_type), allocatable, save, target :: map
 123   integer ,save :: NumMy_xy_planes
 124   integer ,parameter :: NumGlobalElements = nx*ny*nz
 125   integer ,parameter :: NumGlobal_xy_planes = nz, &
 126        & Num_xy_points_per_plane = nx*ny
 127
 128 contains
 129   subroutine initialize_map(NumMyElements)
 130     integer :: NumMyElements, info
 131     info = 0
 132     if (allocated(map)) deallocate(map,stat=info)
 133     if (info == 0) allocate(map,stat=info)
 134     if (info == 0) call foo_cdall(map,nl=NumMyElements)
 135     if (info == 0) call foo_cdasb(map,info)
 136   end subroutine initialize_map
 137
 138   function new_scalar_field() result(this)
 139     type(scalar_field)                          :: this
 140     real(foo_dpk_) ,allocatable   :: f_v(:)
 141     integer :: i,j,k,NumMyElements, iam, np, info,ip
 142     integer, allocatable :: idxs(:)
 143
 144     NumMy_xy_planes = NumGlobal_xy_planes
 145     NumMyElements = NumMy_xy_planes*Num_xy_points_per_plane
 146     if (.not. allocated(map)) call initialize_map(NumMyElements)
 147     this%map => map
 148     call foo_geall(this%f,this%map,info)
 149   end function
 150
 151   subroutine free(this)
 152     class(scalar_field), intent(inout) :: this
 153     integer ::info
 154     call this%f%free()
 155   end subroutine free
 156
 157 end module foo_scalar_field_mod
 158
 159 module foo_vector_field_mod
 160   use foo_base_mod
 161   use foo_scalar_field_mod
 162   implicit none
 163   type vector_field
 164     type(scalar_field) :: u(1)
 165   end type vector_field
 166 contains
 167   function new_vector_field() result(this)
 168     type(vector_field) :: this
 169     integer :: i
 170     do i=1, size(this%u)
 171       associate(sf=>this%u(i))
 172         sf = new_scalar_field()
 173       end associate
 174     end do
 175   end function
 176
 177   subroutine free_v_field(this)
 178     class(vector_field), intent(inout) :: this
 179     integer :: i
 180     associate(vf=>this%u)
 181       do i=1, size(vf)
 182         call vf(i)%free()
 183       end do
 184     end associate
 185   end subroutine free_v_field
 186
 187 end module foo_vector_field_mod
 188
 189 program main
 190   use foo_base_mod
 191   use foo_vector_field_mod
 192   use foo_scalar_field_mod
 193   implicit none
 194   type(vector_field) :: u
 195   type(foo_d_vect_type) :: v
 196   real(foo_dpk_), allocatable :: av(:)
 197   integer  :: iam, np, i,info
 198
 199   u = new_vector_field()
 200   call foo_geall(v,map,info)
 201   call free_v_field(u)
 202   do i=1,10
 203     u = new_vector_field()
 204     call free_v_field(u)
 205     av = v%get_vect()
 206   end do
 207 ! This gets rid of the "memory leak"
 208   if (associated (u%u(1)%map)) deallocate (u%u(1)%map)
 209   call free_v_field(u)
 210   call v%free()
 211   deallocate(av)
 212 end program
 213 ! { dg-final { scan-tree-dump-times "__builtin_malloc" 22 "original" } }
 214 ! { dg-final { scan-tree-dump-times "__builtin_free" 29 "original" } }