|
152
|
1 ! { dg-do run }
|
|
|
2 ! PR fortran/94788 - this leads to a double free.
|
|
|
3 ! Test case by Juergen Reuter.
|
|
|
4 module iso_varying_string
|
|
|
5 implicit none
|
|
|
6 integer, parameter, private :: GET_BUFFER_LEN = 1
|
|
|
7 type, public :: varying_string
|
|
|
8 private
|
|
|
9 character(LEN=1), dimension(:), allocatable :: chars
|
|
|
10 end type varying_string
|
|
|
11
|
|
|
12 interface assignment(=)
|
|
|
13 module procedure op_assign_CH_VS
|
|
|
14 module procedure op_assign_VS_CH
|
|
|
15 end interface assignment(=)
|
|
|
16
|
|
|
17 interface char
|
|
|
18 module procedure char_auto
|
|
|
19 module procedure char_fixed
|
|
|
20 end interface char
|
|
|
21
|
|
|
22 interface len
|
|
|
23 module procedure len_
|
|
|
24 end interface len
|
|
|
25
|
|
|
26 interface var_str
|
|
|
27 module procedure var_str_
|
|
|
28 end interface var_str
|
|
|
29
|
|
|
30 public :: assignment(=)
|
|
|
31 public :: char
|
|
|
32 public :: len
|
|
|
33 public :: var_str
|
|
|
34
|
|
|
35 private :: op_assign_CH_VS
|
|
|
36 private :: op_assign_VS_CH
|
|
|
37 private :: op_eq_VS_VS
|
|
|
38 private :: op_eq_CH_VS
|
|
|
39 private :: op_eq_VS_CH
|
|
|
40 private :: char_auto
|
|
|
41 private :: char_fixed
|
|
|
42 private :: len_
|
|
|
43 private :: var_str_
|
|
|
44
|
|
|
45 contains
|
|
|
46
|
|
|
47 elemental function len_ (string) result (length)
|
|
|
48 type(varying_string), intent(in) :: string
|
|
|
49 integer :: length
|
|
|
50 if(ALLOCATED(string%chars)) then
|
|
|
51 length = SIZE(string%chars)
|
|
|
52 else
|
|
|
53 length = 0
|
|
|
54 endif
|
|
|
55 end function len_
|
|
|
56
|
|
|
57 elemental subroutine op_assign_CH_VS (var, exp)
|
|
|
58 character(LEN=*), intent(out) :: var
|
|
|
59 type(varying_string), intent(in) :: exp
|
|
|
60 var = char(exp)
|
|
|
61 end subroutine op_assign_CH_VS
|
|
|
62
|
|
|
63 elemental subroutine op_assign_VS_CH (var, exp)
|
|
|
64 type(varying_string), intent(out) :: var
|
|
|
65 character(LEN=*), intent(in) :: exp
|
|
|
66 var = var_str(exp)
|
|
|
67 end subroutine op_assign_VS_CH
|
|
|
68
|
|
|
69 elemental function op_eq_VS_VS (string_a, string_b) result (op_eq)
|
|
|
70 type(varying_string), intent(in) :: string_a
|
|
|
71 type(varying_string), intent(in) :: string_b
|
|
|
72 logical :: op_eq
|
|
|
73 op_eq = char(string_a) == char(string_b)
|
|
|
74 end function op_eq_VS_VS
|
|
|
75
|
|
|
76 elemental function op_eq_CH_VS (string_a, string_b) result (op_eq)
|
|
|
77 character(LEN=*), intent(in) :: string_a
|
|
|
78 type(varying_string), intent(in) :: string_b
|
|
|
79 logical :: op_eq
|
|
|
80 op_eq = string_a == char(string_b)
|
|
|
81 end function op_eq_CH_VS
|
|
|
82
|
|
|
83 elemental function op_eq_VS_CH (string_a, string_b) result (op_eq)
|
|
|
84 type(varying_string), intent(in) :: string_a
|
|
|
85 character(LEN=*), intent(in) :: string_b
|
|
|
86 logical :: op_eq
|
|
|
87 op_eq = char(string_a) == string_b
|
|
|
88 end function op_eq_VS_CH
|
|
|
89
|
|
|
90
|
|
|
91 pure function char_auto (string) result (char_string)
|
|
|
92 type(varying_string), intent(in) :: string
|
|
|
93 character(LEN=len(string)) :: char_string
|
|
|
94 integer :: i_char
|
|
|
95 forall(i_char = 1:len(string))
|
|
|
96 char_string(i_char:i_char) = string%chars(i_char)
|
|
|
97 end forall
|
|
|
98
|
|
|
99 end function char_auto
|
|
|
100
|
|
|
101 pure function char_fixed (string, length) result (char_string)
|
|
|
102 type(varying_string), intent(in) :: string
|
|
|
103 integer, intent(in) :: length
|
|
|
104 character(LEN=length) :: char_string
|
|
|
105 char_string = char(string)
|
|
|
106 end function char_fixed
|
|
|
107
|
|
|
108 elemental function var_str_ (char) result (string)
|
|
|
109 character(LEN=*), intent(in) :: char
|
|
|
110 type(varying_string) :: string
|
|
|
111 integer :: length
|
|
|
112 integer :: i_char
|
|
|
113 length = LEN(char)
|
|
|
114 ALLOCATE(string%chars(length))
|
|
|
115 forall(i_char = 1:length)
|
|
|
116 string%chars(i_char) = char(i_char:i_char)
|
|
|
117 end forall
|
|
|
118 end function var_str_
|
|
|
119
|
|
|
120 end module iso_varying_string
|
|
|
121
|
|
|
122
|
|
|
123 module parser
|
|
|
124 implicit none
|
|
|
125 private
|
|
|
126 public :: parse_node_t
|
|
|
127 public :: parse_tree_t
|
|
|
128 type :: parse_node_t
|
|
|
129 private
|
|
|
130 end type parse_node_t
|
|
|
131
|
|
|
132 type :: parse_tree_t
|
|
|
133 private
|
|
|
134 type(parse_node_t), pointer :: root_node => null ()
|
|
|
135 contains
|
|
|
136 procedure :: get_root_ptr => parse_tree_get_root_ptr
|
|
|
137 end type parse_tree_t
|
|
|
138
|
|
|
139 contains
|
|
|
140 function parse_tree_get_root_ptr (parse_tree) result (node)
|
|
|
141 class(parse_tree_t), intent(in) :: parse_tree
|
|
|
142 type(parse_node_t), pointer :: node
|
|
|
143 node => parse_tree%root_node
|
|
|
144 end function parse_tree_get_root_ptr
|
|
|
145
|
|
|
146 end module parser
|
|
|
147
|
|
|
148
|
|
|
149
|
|
|
150 module rt_data
|
|
|
151 use iso_varying_string, string_t => varying_string
|
|
|
152 use parser, only: parse_node_t
|
|
|
153 implicit none
|
|
|
154 private
|
|
|
155
|
|
|
156 public :: rt_data_t
|
|
|
157
|
|
|
158 type :: rt_parse_nodes_t
|
|
|
159 type(parse_node_t), pointer :: weight_expr => null ()
|
|
|
160 end type rt_parse_nodes_t
|
|
|
161
|
|
|
162 type :: rt_data_t
|
|
|
163 type(rt_parse_nodes_t) :: pn
|
|
|
164 type(string_t) :: logfile
|
|
|
165 contains
|
|
|
166 procedure :: global_init => rt_data_global_init
|
|
|
167 procedure :: local_init => rt_data_local_init
|
|
|
168 procedure :: activate => rt_data_activate
|
|
|
169 end type rt_data_t
|
|
|
170
|
|
|
171
|
|
|
172 contains
|
|
|
173
|
|
|
174 subroutine rt_data_global_init (global, logfile)
|
|
|
175 class(rt_data_t), intent(out), target :: global
|
|
|
176 type(string_t), intent(in), optional :: logfile
|
|
|
177 integer :: seed
|
|
|
178 if (present (logfile)) then
|
|
|
179 global%logfile = logfile
|
|
|
180 else
|
|
|
181 global%logfile = ""
|
|
|
182 end if
|
|
|
183 call system_clock (seed)
|
|
|
184 end subroutine rt_data_global_init
|
|
|
185
|
|
|
186 subroutine rt_data_local_init (local, global, env)
|
|
|
187 class(rt_data_t), intent(inout), target :: local
|
|
|
188 type(rt_data_t), intent(in), target :: global
|
|
|
189 integer, intent(in), optional :: env
|
|
|
190 local%logfile = global%logfile
|
|
|
191 end subroutine rt_data_local_init
|
|
|
192
|
|
|
193 subroutine rt_data_activate (local)
|
|
|
194 class(rt_data_t), intent(inout), target :: local
|
|
|
195 class(rt_data_t), pointer :: global
|
|
|
196
|
|
|
197 ! global => local%context
|
|
|
198 ! if (associated (global)) then
|
|
|
199 ! local%logfile = global%logfile
|
|
|
200 ! local%pn = global%pn
|
|
|
201 ! end if
|
|
|
202 end subroutine rt_data_activate
|
|
|
203
|
|
|
204 end module rt_data
|
|
|
205
|
|
|
206 module events
|
|
|
207 implicit none
|
|
|
208 private
|
|
|
209 public :: event_t
|
|
|
210
|
|
|
211 type :: event_config_t
|
|
|
212 end type event_config_t
|
|
|
213
|
|
|
214 type :: event_t
|
|
|
215 type(event_config_t) :: config
|
|
|
216 end type event_t
|
|
|
217
|
|
|
218 end module events
|
|
|
219
|
|
|
220
|
|
|
221 module simulations
|
|
|
222 use iso_varying_string, string_t => varying_string
|
|
|
223 use events
|
|
|
224 use rt_data
|
|
|
225
|
|
|
226 implicit none
|
|
|
227 private
|
|
|
228
|
|
|
229 public :: simulation_t
|
|
|
230
|
|
|
231 type, extends (event_t) :: entry_t
|
|
|
232 private
|
|
|
233 type(entry_t), pointer :: next => null ()
|
|
|
234 end type entry_t
|
|
|
235
|
|
|
236 type, extends (entry_t) :: alt_entry_t
|
|
|
237 contains
|
|
|
238 procedure :: init_alt => alt_entry_init
|
|
|
239 end type alt_entry_t
|
|
|
240
|
|
|
241 type :: simulation_t
|
|
|
242 private
|
|
|
243 type(rt_data_t), pointer :: local => null ()
|
|
|
244 integer :: n_alt = 0
|
|
|
245 type(entry_t), dimension(:), allocatable :: entry
|
|
|
246 type(alt_entry_t), dimension(:,:), allocatable :: alt_entry
|
|
|
247 contains
|
|
|
248 procedure :: init => simulation_init
|
|
|
249 end type simulation_t
|
|
|
250
|
|
|
251
|
|
|
252 contains
|
|
|
253
|
|
|
254 subroutine alt_entry_init (entry, local)
|
|
|
255 class(alt_entry_t), intent(inout), target :: entry
|
|
|
256 type(rt_data_t), intent(inout), target :: local
|
|
|
257 integer :: i
|
|
|
258 end subroutine alt_entry_init
|
|
|
259
|
|
|
260 subroutine simulation_init (simulation, &
|
|
|
261 integrate, generate, local, global, alt_env)
|
|
|
262 class(simulation_t), intent(out), target :: simulation
|
|
|
263 logical, intent(in) :: integrate, generate
|
|
|
264 type(rt_data_t), intent(inout), target :: local
|
|
|
265 type(rt_data_t), intent(inout), optional, target :: global
|
|
|
266 type(rt_data_t), dimension(:), intent(inout), optional, target :: alt_env
|
|
|
267 simulation%local => local
|
|
|
268 allocate (simulation%entry (1))
|
|
|
269 if (present (alt_env)) then
|
|
|
270 simulation%n_alt = size (alt_env)
|
|
|
271 end if
|
|
|
272 end subroutine simulation_init
|
|
|
273
|
|
|
274 end module simulations
|
|
|
275
|
|
|
276
|
|
|
277 program main_ut
|
|
|
278 use iso_varying_string, string_t => varying_string
|
|
|
279 use parser, only: parse_tree_t
|
|
|
280 use rt_data
|
|
|
281 use simulations
|
|
|
282 implicit none
|
|
|
283 call simulations_10 (6)
|
|
|
284
|
|
|
285 contains
|
|
|
286
|
|
|
287 subroutine simulations_10 (u)
|
|
|
288 integer, intent(in) :: u
|
|
|
289 type(rt_data_t), target :: global
|
|
|
290 type(rt_data_t), dimension(1), target :: alt_env
|
|
|
291 type(parse_tree_t) :: pt_weight
|
|
|
292 type(simulation_t), target :: simulation
|
|
|
293
|
|
|
294 call global%global_init ()
|
|
|
295 call alt_env(1)%local_init (global)
|
|
|
296 call alt_env(1)%activate ()
|
|
|
297
|
|
|
298 !!!! This causes the pointer hiccup
|
|
|
299 alt_env(1)%pn%weight_expr => pt_weight%get_root_ptr ()
|
|
|
300 call simulation%init (.true., .true., global, alt_env=alt_env)
|
|
|
301
|
|
|
302 end subroutine simulations_10
|
|
|
303
|
|
|
304 end program main_ut
|
