gcc/testsuite/gfortran.dg/derived_constructor_comps_6.f90

! { dg-do run }
! { dg-additional-options "-fdump-tree-original" }
!
! PR fortran/61831
! The deallocation of components of array constructor elements
! used to have the side effect of also deallocating some other
! variable's components from which they were copied.

program main
  implicit none

  integer, parameter :: n = 2

  type :: string_t
     character(LEN=1), dimension(:), allocatable :: chars
  end type string_t

  type :: string_container_t
     type(string_t) :: comp
  end type string_container_t

  type :: string_array_container_t
     type(string_t) :: comp(n)
  end type string_array_container_t

  type(string_t) :: prt_in, tmp, tmpa(n)
  type(string_container_t) :: tmpc, tmpca(n)
  type(string_array_container_t) :: tmpac, tmpaca(n)
  integer :: i, j, k

  do i=1,16

     ! Test without intermediary function
     prt_in = string_t(["A"])
     if (.not. allocated(prt_in%chars)) call abort
     if (any(prt_in%chars .ne. "A")) call abort
     deallocate (prt_in%chars)

     ! scalar elemental function
     prt_in = string_t(["B"])
     if (.not. allocated(prt_in%chars)) call abort
     if (any(prt_in%chars .ne. "B")) call abort
     tmp = new_prt_spec (prt_in)
     if (.not. allocated(prt_in%chars)) call abort
     if (any(prt_in%chars .ne. "B")) call abort
     deallocate (prt_in%chars)
     deallocate (tmp%chars)

     ! array elemental function with array constructor
     prt_in = string_t(["C"])
     if (.not. allocated(prt_in%chars)) call abort
     if (any(prt_in%chars .ne. "C")) call abort
     tmpa = new_prt_spec ([(prt_in, i=1,2)])
     if (.not. allocated(prt_in%chars)) call abort
     if (any(prt_in%chars .ne. "C")) call abort
     deallocate (prt_in%chars)
     do j=1,n
        deallocate (tmpa(j)%chars)
     end do

     ! scalar elemental function with structure constructor
     prt_in = string_t(["D"])
     if (.not. allocated(prt_in%chars)) call abort
     if (any(prt_in%chars .ne. "D")) call abort
     tmpc = new_prt_spec2 (string_container_t(prt_in))
     if (.not. allocated(prt_in%chars)) call abort
     if (any(prt_in%chars .ne. "D")) call abort
     deallocate (prt_in%chars)
     deallocate(tmpc%comp%chars)

     ! array elemental function of an array constructor of structure constructors
     prt_in = string_t(["E"])
     if (.not. allocated(prt_in%chars)) call abort
     if (any(prt_in%chars .ne. "E")) call abort
     tmpca = new_prt_spec2 ([ (string_container_t(prt_in), i=1,2) ])
     if (.not. allocated(prt_in%chars)) call abort
     if (any(prt_in%chars .ne. "E")) call abort
     deallocate (prt_in%chars)
     do j=1,n
        deallocate (tmpca(j)%comp%chars)
     end do

     ! scalar elemental function with a structure constructor and a nested array constructor
     prt_in = string_t(["F"])
     if (.not. allocated(prt_in%chars)) call abort
     if (any(prt_in%chars .ne. "F")) call abort
     tmpac = new_prt_spec3 (string_array_container_t([ (prt_in, i=1,2) ]))
     if (.not. allocated(prt_in%chars)) call abort
     if (any(prt_in%chars .ne. "F")) call abort
     deallocate (prt_in%chars)
     do j=1,n
        deallocate (tmpac%comp(j)%chars)
     end do

     ! array elemental function with an array constructor nested inside
     ! a structure constructor nested inside  an array constructor
     prt_in = string_t(["G"])
     if (.not. allocated(prt_in%chars)) call abort
     if (any(prt_in%chars .ne. "G")) call abort
     tmpaca = new_prt_spec3 ([ (string_array_container_t([ (prt_in, i=1,2) ]), j=1,2) ])
     if (.not. allocated(prt_in%chars)) call abort
     if (any(prt_in%chars .ne. "G")) call abort
     deallocate (prt_in%chars)
     do j=1,n
        do k=1,n
           deallocate (tmpaca(j)%comp(k)%chars)
        end do
     end do

  end do

contains

  elemental function new_prt_spec (name) result (prt_spec)
    type(string_t), intent(in) :: name
    type(string_t) :: prt_spec
    prt_spec = name
  end function new_prt_spec

  elemental function new_prt_spec2 (name) result (prt_spec)
    type(string_container_t), intent(in) :: name
    type(string_container_t) :: prt_spec
    prt_spec = name
  end function new_prt_spec2

  elemental function new_prt_spec3 (name) result (prt_spec)
    type(string_array_container_t), intent(in) :: name
    type(string_array_container_t) :: prt_spec
    prt_spec = name
  end function new_prt_spec3
end program main
! { dg-final { scan-tree-dump-times "__builtin_malloc" 15 "original" } }
! { dg-final { scan-tree-dump-times "__builtin_free" 33 "original" } }