1! { dg-do run } 2! 3! Test that the temporary in a sourced-ALLOCATE is not freeed. 4! PR fortran/79344 5! Contributed by Juergen Reuter 6 7module iso_varying_string 8 implicit none 9 10 type, public :: varying_string 11 private 12 character(LEN=1), dimension(:), allocatable :: chars 13 end type varying_string 14 15 interface assignment(=) 16 module procedure op_assign_VS_CH 17 end interface assignment(=) 18 19 interface operator(/=) 20 module procedure op_not_equal_VS_CA 21 end interface operator(/=) 22 23 interface len 24 module procedure len_ 25 end interface len 26 27 interface var_str 28 module procedure var_str_ 29 end interface var_str 30 31 public :: assignment(=) 32 public :: operator(/=) 33 public :: len 34 35 private :: op_assign_VS_CH 36 private :: op_not_equal_VS_CA 37 private :: char_auto 38 private :: len_ 39 private :: var_str_ 40 41contains 42 43 elemental function len_ (string) result (length) 44 type(varying_string), intent(in) :: string 45 integer :: length 46 if(ALLOCATED(string%chars)) then 47 length = SIZE(string%chars) 48 else 49 length = 0 50 endif 51 end function len_ 52 53 elemental subroutine op_assign_VS_CH (var, exp) 54 type(varying_string), intent(out) :: var 55 character(LEN=*), intent(in) :: exp 56 var = var_str(exp) 57 end subroutine op_assign_VS_CH 58 59 pure function op_not_equal_VS_CA (var, exp) result(res) 60 type(varying_string), intent(in) :: var 61 character(LEN=*), intent(in) :: exp 62 logical :: res 63 integer :: i 64 res = .true. 65 if (len(exp) /= size(var%chars)) return 66 do i = 1, size(var%chars) 67 if (var%chars(i) /= exp(i:i)) return 68 end do 69 res = .false. 70 end function op_not_equal_VS_CA 71 72 pure function char_auto (string) result (char_string) 73 type(varying_string), intent(in) :: string 74 character(LEN=len(string)) :: char_string 75 integer :: i_char 76 forall(i_char = 1:len(string)) 77 char_string(i_char:i_char) = string%chars(i_char) 78 end forall 79 end function char_auto 80 81 elemental function var_str_ (char) result (string) 82 character(LEN=*), intent(in) :: char 83 type(varying_string) :: string 84 integer :: length 85 integer :: i_char 86 length = LEN(char) 87 ALLOCATE(string%chars(length)) 88 forall(i_char = 1:length) 89 string%chars(i_char) = char(i_char:i_char) 90 end forall 91 end function var_str_ 92 93end module iso_varying_string 94 95!!!!! 96 97program test_pr79344 98 99 use iso_varying_string, string_t => varying_string 100 101 implicit none 102 103 type :: field_data_t 104 type(string_t), dimension(:), allocatable :: name 105 end type field_data_t 106 107 type(field_data_t) :: model, model2 108 allocate(model%name(2)) 109 model%name(1) = "foo" 110 model%name(2) = "bar" 111 call copy(model, model2) 112contains 113 114 subroutine copy(prt, prt_src) 115 implicit none 116 type(field_data_t), intent(inout) :: prt 117 type(field_data_t), intent(in) :: prt_src 118 integer :: i 119 if (allocated (prt_src%name)) then 120 if (prt_src%name(1) /= "foo") STOP 1 121 if (prt_src%name(2) /= "bar") STOP 2 122 123 if (allocated (prt%name)) deallocate (prt%name) 124 allocate (prt%name (size (prt_src%name)), source = prt_src%name) 125 ! The issue was, that prt_src was empty after sourced-allocate. 126 if (prt_src%name(1) /= "foo") STOP 3 127 if (prt_src%name(2) /= "bar") STOP 4 128 if (prt%name(1) /= "foo") STOP 5 129 if (prt%name(2) /= "bar") STOP 6 130 end if 131 end subroutine copy 132 133end program test_pr79344 134 135