3 ! Test that the temporary in a sourced-ALLOCATE is not freeed.
5 ! Contributed by Juergen Reuter
7 module iso_varying_string
10 type, public
:: varying_string
12 character(LEN
=1), dimension(:), allocatable
:: chars
13 end type varying_string
15 interface assignment(=)
16 module procedure op_assign_VS_CH
17 end interface assignment(=)
19 interface operator(/=)
20 module procedure op_not_equal_VS_CA
21 end interface operator(/=)
28 module procedure var_str_
31 public
:: assignment(=)
32 public
:: operator(/=)
35 private
:: op_assign_VS_CH
36 private
:: op_not_equal_VS_CA
43 elemental
function len_ (string
) result (length
)
44 type(varying_string
), intent(in
) :: string
46 if(ALLOCATED(string
%chars
)) then
47 length
= SIZE(string
%chars
)
53 elemental
subroutine op_assign_VS_CH (var
, exp
)
54 type(varying_string
), intent(out
) :: var
55 character(LEN
=*), intent(in
) :: exp
57 end subroutine op_assign_VS_CH
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
65 if (len(exp
) /= size(var
%chars
)) return
66 do i
= 1, size(var
%chars
)
67 if (var
%chars(i
) /= exp(i
:i
)) return
70 end function op_not_equal_VS_CA
72 pure
function char_auto (string
) result (char_string
)
73 type(varying_string
), intent(in
) :: string
74 character(LEN
=len(string
)) :: char_string
76 forall(i_char
= 1:len(string
))
77 char_string(i_char
:i_char
) = string
%chars(i_char
)
79 end function char_auto
81 elemental
function var_str_ (char
) result (string
)
82 character(LEN
=*), intent(in
) :: char
83 type(varying_string
) :: string
87 ALLOCATE(string
%chars(length
))
88 forall(i_char
= 1:length
)
89 string
%chars(i_char
) = char(i_char
:i_char
)
93 end module iso_varying_string
99 use iso_varying_string
, string_t
=> varying_string
104 type(string_t
), dimension(:), allocatable
:: name
105 end type field_data_t
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
)
114 subroutine copy(prt
, prt_src
)
116 type(field_data_t
), intent(inout
) :: prt
117 type(field_data_t
), intent(in
) :: prt_src
119 if (allocated (prt_src
%name
)) then
120 if (prt_src
%name(1) /= "foo") call abort()
121 if (prt_src
%name(2) /= "bar") call abort()
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") call abort()
127 if (prt_src
%name(2) /= "bar") call abort()
128 if (prt
%name(1) /= "foo") call abort()
129 if (prt
%name(2) /= "bar") call abort()
133 end program test_pr79344