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