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
9program 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
112contains
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
131end program main
132! { dg-final { scan-tree-dump-times "__builtin_malloc" 15 "original" } }
133! { dg-final { scan-tree-dump-times "__builtin_free" 33 "original" } }
134