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)) STOP 1
  36      if (any(prt_in%chars .ne. "A")) STOP 2
  37      deallocate (prt_in%chars)
  38
  39      ! scalar elemental function
  40      prt_in = string_t(["B"])
  41      if (.not. allocated(prt_in%chars)) STOP 3
  42      if (any(prt_in%chars .ne. "B")) STOP 4
  43      tmp = new_prt_spec (prt_in)
  44      if (.not. allocated(prt_in%chars)) STOP 5
  45      if (any(prt_in%chars .ne. "B")) STOP 6
  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)) STOP 7
  52      if (any(prt_in%chars .ne. "C")) STOP 8
  53      tmpa = new_prt_spec ([(prt_in, i=1,2)])
  54      if (.not. allocated(prt_in%chars)) STOP 9
  55      if (any(prt_in%chars .ne. "C")) STOP 10
  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)) STOP 11
  64      if (any(prt_in%chars .ne. "D")) STOP 12
  65      tmpc = new_prt_spec2 (string_container_t(prt_in))
  66      if (.not. allocated(prt_in%chars)) STOP 13
  67      if (any(prt_in%chars .ne. "D")) STOP 14
  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)) STOP 15
  74      if (any(prt_in%chars .ne. "E")) STOP 16
  75      tmpca = new_prt_spec2 ([ (string_container_t(prt_in), i=1,2) ])
  76      if (.not. allocated(prt_in%chars)) STOP 17
  77      if (any(prt_in%chars .ne. "E")) STOP 18
  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)) STOP 19
  86      if (any(prt_in%chars .ne. "F")) STOP 20
  87      tmpac = new_prt_spec3 (string_array_container_t([ (prt_in, i=1,2) ]))
  88      if (.not. allocated(prt_in%chars)) STOP 21
  89      if (any(prt_in%chars .ne. "F")) STOP 22
  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)) STOP 23
  99      if (any(prt_in%chars .ne. "G")) STOP 24
 100      tmpaca = new_prt_spec3 ([ (string_array_container_t([ (prt_in, i=1,2) ]), j=1,2) ])
 101      if (.not. allocated(prt_in%chars)) STOP 25
 102      if (any(prt_in%chars .ne. "G")) STOP 26
 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" } }