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