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