gcc/testsuite/gfortran.dg/derived_constructor_comps_6.f90

   1 ! { dg-do run }
   2 ! { dg-additional-options "-fdump-tree-original" }
   3 !
   4 ! PR fortran/61831
   5 ! The deallocation of components of array constructor elements
   6 ! used to have the side effect of also deallocating some other
   7 ! variable's components from which they were copied.
   8
   9 program main
  10   implicit none
  11
  12   integer, parameter :: n = 2
  13
  14   type :: string_t
  15      character(LEN=1), dimension(:), allocatable :: chars
  16   end type string_t
  17
  18   type :: string_container_t
  19      type(string_t) :: comp
  20   end type string_container_t
  21
  22   type :: string_array_container_t
  23      type(string_t) :: comp(n)
  24   end type string_array_container_t
  25
  26   type(string_t) :: prt_in, tmp, tmpa(n)
  27   type(string_container_t) :: tmpc, tmpca(n)
  28   type(string_array_container_t) :: tmpac, tmpaca(n)
  29   integer :: i, j, k
  30
  31   do i=1,16
  32
  33      ! Test without intermediary function
  34      prt_in = string_t(["A"])
  35      if (.not. allocated(prt_in%chars)) call abort
  36      if (any(prt_in%chars .ne. "A")) call abort
  37      deallocate (prt_in%chars)
  38
  39      ! scalar elemental function
  40      prt_in = string_t(["B"])
  41      if (.not. allocated(prt_in%chars)) call abort
  42      if (any(prt_in%chars .ne. "B")) call abort
  43      tmp = new_prt_spec (prt_in)
  44      if (.not. allocated(prt_in%chars)) call abort
  45      if (any(prt_in%chars .ne. "B")) call abort
  46      deallocate (prt_in%chars)
  47      deallocate (tmp%chars)
  48
  49      ! array elemental function with array constructor
  50      prt_in = string_t(["C"])
  51      if (.not. allocated(prt_in%chars)) call abort
  52      if (any(prt_in%chars .ne. "C")) call abort
  53      tmpa = new_prt_spec ([(prt_in, i=1,2)])
  54      if (.not. allocated(prt_in%chars)) call abort
  55      if (any(prt_in%chars .ne. "C")) call abort
  56      deallocate (prt_in%chars)
  57      do j=1,n
  58         deallocate (tmpa(j)%chars)
  59      end do
  60
  61      ! scalar elemental function with structure constructor
  62      prt_in = string_t(["D"])
  63      if (.not. allocated(prt_in%chars)) call abort
  64      if (any(prt_in%chars .ne. "D")) call abort
  65      tmpc = new_prt_spec2 (string_container_t(prt_in))
  66      if (.not. allocated(prt_in%chars)) call abort
  67      if (any(prt_in%chars .ne. "D")) call abort
  68      deallocate (prt_in%chars)
  69      deallocate(tmpc%comp%chars)
  70
  71      ! array elemental function of an array constructor of structure constructors
  72      prt_in = string_t(["E"])
  73      if (.not. allocated(prt_in%chars)) call abort
  74      if (any(prt_in%chars .ne. "E")) call abort
  75      tmpca = new_prt_spec2 ([ (string_container_t(prt_in), i=1,2) ])
  76      if (.not. allocated(prt_in%chars)) call abort
  77      if (any(prt_in%chars .ne. "E")) call abort
  78      deallocate (prt_in%chars)
  79      do j=1,n
  80         deallocate (tmpca(j)%comp%chars)
  81      end do
  82
  83      ! scalar elemental function with a structure constructor and a nested array constructor
  84      prt_in = string_t(["F"])
  85      if (.not. allocated(prt_in%chars)) call abort
  86      if (any(prt_in%chars .ne. "F")) call abort
  87      tmpac = new_prt_spec3 (string_array_container_t([ (prt_in, i=1,2) ]))
  88      if (.not. allocated(prt_in%chars)) call abort
  89      if (any(prt_in%chars .ne. "F")) call abort
  90      deallocate (prt_in%chars)
  91      do j=1,n
  92         deallocate (tmpac%comp(j)%chars)
  93      end do
  94
  95      ! array elemental function with an array constructor nested inside
  96      ! a structure constructor nested inside  an array constructor
  97      prt_in = string_t(["G"])
  98      if (.not. allocated(prt_in%chars)) call abort
  99      if (any(prt_in%chars .ne. "G")) call abort
 100      tmpaca = new_prt_spec3 ([ (string_array_container_t([ (prt_in, i=1,2) ]), j=1,2) ])
 101      if (.not. allocated(prt_in%chars)) call abort
 102      if (any(prt_in%chars .ne. "G")) call abort
 103      deallocate (prt_in%chars)
 104      do j=1,n
 105         do k=1,n
 106            deallocate (tmpaca(j)%comp(k)%chars)
 107         end do
 108      end do
 109
 110   end do
 111
 112 contains
 113
 114   elemental function new_prt_spec (name) result (prt_spec)
 115     type(string_t), intent(in) :: name
 116     type(string_t) :: prt_spec
 117     prt_spec = name
 118   end function new_prt_spec
 119
 120   elemental function new_prt_spec2 (name) result (prt_spec)
 121     type(string_container_t), intent(in) :: name
 122     type(string_container_t) :: prt_spec
 123     prt_spec = name
 124   end function new_prt_spec2
 125
 126   elemental function new_prt_spec3 (name) result (prt_spec)
 127     type(string_array_container_t), intent(in) :: name
 128     type(string_array_container_t) :: prt_spec
 129     prt_spec = name
 130   end function new_prt_spec3
 131 end program main
 132 ! { dg-final { scan-tree-dump-times "__builtin_malloc" 15 "original" } }
 133 ! { dg-final { scan-tree-dump-times "__builtin_free" 33 "original" } }