Line data Source code
1 : !> Data types for HSD nodes
2 : !>
3 : !> This module provides the tree structure for representing parsed HSD data.
4 : !> The main types are:
5 : !> - hsd_node_t - Unified concrete node (table or value)
6 : !> - hsd_node_ptr_t - Pointer wrapper for child storage
7 : !> - hsd_iterator_t - Iterator for traversing table children
8 : !>
9 : !> ## Memory Ownership Semantics
10 : !>
11 : !> The HSD tree uses a **copy-on-add** ownership model:
12 : !>
13 : !> - **table_add_child**: Creates a deep copy of the node via
14 : !> `allocate(source=child)`. The caller retains ownership of the
15 : !> original node.
16 : !>
17 : !> - **table_get_child, table_get_child_by_name**: Return pointers to
18 : !> nodes owned by the table. Do NOT deallocate returned pointers.
19 : !>
20 : !> - **table_remove_child**: Deallocates the removed node. Any pointers
21 : !> previously obtained via get_child become invalid.
22 : !>
23 : !> - **destroy**: Recursively deallocates all children. Must be
24 : !> called explicitly to avoid memory leaks.
25 : !>
26 : !> ## Module Structure
27 : !>
28 : !> Type definitions and constructors live in this parent module.
29 : !> Implementations are split across two submodules for maintainability:
30 : !> - **hsd_table_ops** — table and iterator operations
31 : !> - **hsd_value_ops** — value setters, getters, and parse helpers
32 : module hsd_types
33 : use hsd_constants, only: dp
34 : use hsd_utils, only: to_lower
35 : use hsd_error, only: HSD_STAT_OK, HSD_STAT_TYPE_ERROR, &
36 : & HSD_STAT_NOT_FOUND
37 : implicit none (type, external)
38 : private
39 :
40 : public :: hsd_node_t, hsd_node_ptr_t, hsd_iterator_t
41 : public :: new_table, new_value
42 : public :: NODE_TYPE_TABLE, NODE_TYPE_VALUE
43 : public :: VALUE_TYPE_NONE, VALUE_TYPE_STRING, VALUE_TYPE_INTEGER
44 : public :: VALUE_TYPE_REAL, VALUE_TYPE_LOGICAL, VALUE_TYPE_ARRAY
45 : public :: VALUE_TYPE_COMPLEX
46 :
47 : !> Node type enumeration
48 : integer, parameter :: NODE_TYPE_TABLE = 1
49 : integer, parameter :: NODE_TYPE_VALUE = 2
50 :
51 : !> Value type enumeration
52 : integer, parameter :: VALUE_TYPE_NONE = 0
53 : integer, parameter :: VALUE_TYPE_STRING = 1
54 : integer, parameter :: VALUE_TYPE_INTEGER = 2
55 : integer, parameter :: VALUE_TYPE_REAL = 3
56 : integer, parameter :: VALUE_TYPE_LOGICAL = 4
57 : integer, parameter :: VALUE_TYPE_ARRAY = 5
58 : integer, parameter :: VALUE_TYPE_COMPLEX = 6
59 :
60 : !> Pointer wrapper for node storage
61 : !>
62 : !> Uses a pointer (not allocatable) so that when the children array
63 : !> is reallocated during growth, pointers to child nodes obtained via
64 : !> get_child/get_child_by_name remain valid.
65 : type :: hsd_node_ptr_t
66 : type(hsd_node_t), pointer :: node => null()
67 : end type hsd_node_ptr_t
68 :
69 : !> Unified HSD node type (table or value)
70 : type :: hsd_node_t
71 : !> Node name (tag name)
72 : character(len=:), allocatable :: name
73 : !> Optional attribute (e.g., unit)
74 : character(len=:), allocatable :: attrib
75 : !> Line number where this node was defined (for error messages)
76 : integer :: line = 0
77 : !> Whether this node has been accessed/processed
78 : logical :: processed = .false.
79 : !> Node type discriminator (NODE_TYPE_TABLE or NODE_TYPE_VALUE)
80 : integer :: node_type = 0
81 : !> Child nodes (table only)
82 : type(hsd_node_ptr_t), allocatable :: children(:)
83 : !> Number of children (table only)
84 : integer :: num_children = 0
85 : !> Type of value stored (value only)
86 : integer :: value_type = VALUE_TYPE_NONE
87 : !> String representation of the value (value only)
88 : character(len=:), allocatable :: string_value
89 : contains
90 : ! Common
91 : procedure :: has_attrib => node_has_attrib
92 : procedure :: get_attrib => node_get_attrib
93 : ! Table operations
94 : procedure :: add_child => table_add_child
95 : procedure :: get_child => table_get_child
96 : procedure :: get_child_by_name => table_get_child_by_name
97 : procedure :: has_child => table_has_child
98 : procedure :: num_children_func => table_num_children
99 : procedure :: remove_child => table_remove_child
100 : procedure :: remove_child_by_name => table_remove_child_by_name
101 : procedure :: get_keys => table_get_keys
102 : ! Value operations
103 : procedure :: set_string => value_set_string
104 : procedure :: set_integer => value_set_integer
105 : procedure :: set_real => value_set_real
106 : procedure :: set_logical => value_set_logical
107 : procedure :: set_complex => value_set_complex
108 : procedure :: set_raw => value_set_raw
109 : procedure :: get_string => value_get_string
110 : procedure :: get_integer => value_get_integer
111 : procedure :: get_real => value_get_real
112 : procedure :: get_logical => value_get_logical
113 : procedure :: get_complex => value_get_complex
114 : procedure :: get_int_array => value_get_int_array
115 : procedure :: get_real_array => value_get_real_array
116 : procedure :: get_logical_array => value_get_logical_array
117 : procedure :: get_string_array => value_get_string_array
118 : procedure :: get_complex_array => value_get_complex_array
119 : procedure :: get_int_matrix => value_get_int_matrix
120 : procedure :: get_real_matrix => value_get_real_matrix
121 : procedure :: get_complex_matrix => value_get_complex_matrix
122 : ! Destroy
123 : procedure :: destroy => node_destroy
124 : end type hsd_node_t
125 :
126 : !> Iterator for traversing table children
127 : type :: hsd_iterator_t
128 : !> Reference to the table being iterated
129 : type(hsd_node_t), pointer :: table => null()
130 : !> Current position (0 = before first)
131 : integer :: pos = 0
132 : contains
133 : procedure :: init => iterator_init
134 : procedure :: next => iterator_next
135 : procedure :: reset => iterator_reset
136 : procedure :: has_next => iterator_has_next
137 : end type hsd_iterator_t
138 :
139 : ! =================================================================
140 : ! Submodule procedure interfaces
141 : ! =================================================================
142 :
143 : interface
144 :
145 : ! --- Table operations (submodule hsd_table_ops) ---
146 :
147 : module subroutine table_add_child(self, child)
148 : implicit none (type, external)
149 : class(hsd_node_t), intent(inout) :: self
150 : type(hsd_node_t), intent(in) :: child
151 : end subroutine table_add_child
152 :
153 : module subroutine table_get_child( &
154 : & self, index, child)
155 : implicit none (type, external)
156 : class(hsd_node_t), intent(in), target :: self
157 : integer, intent(in) :: index
158 : type(hsd_node_t), pointer, intent(out) :: child
159 : end subroutine table_get_child
160 :
161 : module subroutine table_get_child_by_name( &
162 : & self, name, child)
163 : implicit none (type, external)
164 : class(hsd_node_t), intent(in), target :: self
165 : character(len=*), intent(in) :: name
166 : type(hsd_node_t), pointer, intent(out) :: child
167 : end subroutine table_get_child_by_name
168 :
169 : module function table_has_child( &
170 : & self, name) result(has)
171 : implicit none (type, external)
172 : class(hsd_node_t), intent(in) :: self
173 : character(len=*), intent(in) :: name
174 : logical :: has
175 : end function table_has_child
176 :
177 : pure module function table_num_children( &
178 : & self) result(n)
179 : implicit none (type, external)
180 : class(hsd_node_t), intent(in) :: self
181 : integer :: n
182 : end function table_num_children
183 :
184 : module subroutine table_get_keys(self, keys)
185 : implicit none (type, external)
186 : class(hsd_node_t), intent(in) :: self
187 : character(len=:), allocatable, intent(out) :: keys(:)
188 : end subroutine table_get_keys
189 :
190 : module subroutine table_remove_child( &
191 : & self, index, stat)
192 : implicit none (type, external)
193 : class(hsd_node_t), intent(inout) :: self
194 : integer, intent(in) :: index
195 : integer, intent(out), optional :: stat
196 : end subroutine table_remove_child
197 :
198 : module subroutine table_remove_child_by_name( &
199 : & self, name, stat)
200 : implicit none (type, external)
201 : class(hsd_node_t), intent(inout) :: self
202 : character(len=*), intent(in) :: name
203 : integer, intent(out), optional :: stat
204 : end subroutine table_remove_child_by_name
205 :
206 : recursive module subroutine node_destroy(self)
207 : implicit none (type, external)
208 : class(hsd_node_t), intent(inout) :: self
209 : end subroutine node_destroy
210 :
211 : ! --- Iterator operations (submodule hsd_table_ops) ---
212 :
213 : module subroutine iterator_init(self, table)
214 : implicit none (type, external)
215 : class(hsd_iterator_t), intent(inout) :: self
216 : type(hsd_node_t), target, intent(in) :: table
217 : end subroutine iterator_init
218 :
219 : module function iterator_next(self, child) &
220 : & result(has_more)
221 : implicit none (type, external)
222 : class(hsd_iterator_t), intent(inout) :: self
223 : type(hsd_node_t), pointer, intent(out) :: child
224 : logical :: has_more
225 : end function iterator_next
226 :
227 : module subroutine iterator_reset(self)
228 : implicit none (type, external)
229 : class(hsd_iterator_t), intent(inout) :: self
230 : end subroutine iterator_reset
231 :
232 : module function iterator_has_next( &
233 : & self) result(has_more)
234 : implicit none (type, external)
235 : class(hsd_iterator_t), intent(in) :: self
236 : logical :: has_more
237 : end function iterator_has_next
238 :
239 : ! --- Value setters (submodule hsd_value_ops) ---
240 :
241 : module subroutine value_set_string(self, val)
242 : implicit none (type, external)
243 : class(hsd_node_t), intent(inout) :: self
244 : character(len=*), intent(in) :: val
245 : end subroutine value_set_string
246 :
247 : module subroutine value_set_integer(self, val)
248 : implicit none (type, external)
249 : class(hsd_node_t), intent(inout) :: self
250 : integer, intent(in) :: val
251 : end subroutine value_set_integer
252 :
253 : module subroutine value_set_real(self, val)
254 : implicit none (type, external)
255 : class(hsd_node_t), intent(inout) :: self
256 : real(dp), intent(in) :: val
257 : end subroutine value_set_real
258 :
259 : module subroutine value_set_logical(self, val)
260 : implicit none (type, external)
261 : class(hsd_node_t), intent(inout) :: self
262 : logical, intent(in) :: val
263 : end subroutine value_set_logical
264 :
265 : module subroutine value_set_complex(self, val)
266 : implicit none (type, external)
267 : class(hsd_node_t), intent(inout) :: self
268 : complex(dp), intent(in) :: val
269 : end subroutine value_set_complex
270 :
271 : module subroutine value_set_raw(self, text)
272 : implicit none (type, external)
273 : class(hsd_node_t), intent(inout) :: self
274 : character(len=*), intent(in) :: text
275 : end subroutine value_set_raw
276 :
277 : ! --- Value getters (submodule hsd_value_ops) ---
278 :
279 : module subroutine value_get_string( &
280 : & self, val, stat)
281 : implicit none (type, external)
282 : class(hsd_node_t), intent(in) :: self
283 : character(len=:), allocatable, intent(out) :: val
284 : integer, intent(out), optional :: stat
285 : end subroutine value_get_string
286 :
287 : module subroutine value_get_integer( &
288 : & self, val, stat)
289 : implicit none (type, external)
290 : class(hsd_node_t), intent(in) :: self
291 : integer, intent(out) :: val
292 : integer, intent(out), optional :: stat
293 : end subroutine value_get_integer
294 :
295 : module subroutine value_get_real( &
296 : & self, val, stat)
297 : implicit none (type, external)
298 : class(hsd_node_t), intent(in) :: self
299 : real(dp), intent(out) :: val
300 : integer, intent(out), optional :: stat
301 : end subroutine value_get_real
302 :
303 : module subroutine value_get_logical( &
304 : & self, val, stat)
305 : implicit none (type, external)
306 : class(hsd_node_t), intent(in) :: self
307 : logical, intent(out) :: val
308 : integer, intent(out), optional :: stat
309 : end subroutine value_get_logical
310 :
311 : module subroutine value_get_complex( &
312 : & self, val, stat)
313 : implicit none (type, external)
314 : class(hsd_node_t), intent(in) :: self
315 : complex(dp), intent(out) :: val
316 : integer, intent(out), optional :: stat
317 : end subroutine value_get_complex
318 :
319 : ! --- Array getters (submodule hsd_value_ops) ---
320 :
321 : module subroutine value_get_int_array( &
322 : & self, val, stat)
323 : implicit none (type, external)
324 : class(hsd_node_t), intent(in) :: self
325 : integer, allocatable, intent(out) :: val(:)
326 : integer, intent(out), optional :: stat
327 : end subroutine value_get_int_array
328 :
329 : module subroutine value_get_real_array( &
330 : & self, val, stat)
331 : implicit none (type, external)
332 : class(hsd_node_t), intent(in) :: self
333 : real(dp), allocatable, intent(out) :: val(:)
334 : integer, intent(out), optional :: stat
335 : end subroutine value_get_real_array
336 :
337 : module subroutine value_get_logical_array( &
338 : & self, val, stat)
339 : implicit none (type, external)
340 : class(hsd_node_t), intent(in) :: self
341 : logical, allocatable, intent(out) :: val(:)
342 : integer, intent(out), optional :: stat
343 : end subroutine value_get_logical_array
344 :
345 : module subroutine value_get_string_array( &
346 : & self, val, stat)
347 : implicit none (type, external)
348 : class(hsd_node_t), intent(in) :: self
349 : character(len=:), allocatable, intent(out) :: val(:)
350 : integer, intent(out), optional :: stat
351 : end subroutine value_get_string_array
352 :
353 : module subroutine value_get_complex_array( &
354 : & self, val, stat)
355 : implicit none (type, external)
356 : class(hsd_node_t), intent(in) :: self
357 : complex(dp), allocatable, intent(out) :: val(:)
358 : integer, intent(out), optional :: stat
359 : end subroutine value_get_complex_array
360 :
361 : ! --- Matrix getters (submodule hsd_value_ops) ---
362 :
363 : module subroutine value_get_int_matrix( &
364 : & self, val, nrows, ncols, stat)
365 : implicit none (type, external)
366 : class(hsd_node_t), intent(in) :: self
367 : integer, allocatable, intent(out) :: val(:,:)
368 : integer, intent(out) :: nrows, ncols
369 : integer, intent(out), optional :: stat
370 : end subroutine value_get_int_matrix
371 :
372 : module subroutine value_get_real_matrix( &
373 : & self, val, nrows, ncols, stat)
374 : implicit none (type, external)
375 : class(hsd_node_t), intent(in) :: self
376 : real(dp), allocatable, intent(out) :: val(:,:)
377 : integer, intent(out) :: nrows, ncols
378 : integer, intent(out), optional :: stat
379 : end subroutine value_get_real_matrix
380 :
381 : module subroutine value_get_complex_matrix( &
382 : & self, val, nrows, ncols, stat)
383 : implicit none (type, external)
384 : class(hsd_node_t), intent(in) :: self
385 : complex(dp), allocatable, intent(out) :: val(:,:)
386 : integer, intent(out) :: nrows, ncols
387 : integer, intent(out), optional :: stat
388 : end subroutine value_get_complex_matrix
389 :
390 : end interface
391 :
392 : contains
393 :
394 : !> Check if node has an attribute
395 1169 : pure function node_has_attrib(self) result(has)
396 : class(hsd_node_t), intent(in) :: self
397 : logical :: has
398 1169 : has = allocated(self%attrib)
399 2338 : end function node_has_attrib
400 :
401 : !> Get node attribute (empty string if not set)
402 10 : pure function node_get_attrib(self) result(attrib)
403 : class(hsd_node_t), intent(in) :: self
404 : character(len=:), allocatable :: attrib
405 10 : if (allocated(self%attrib)) then
406 9 : attrib = self%attrib
407 : else
408 1 : attrib = ""
409 : end if
410 1169 : end function node_get_attrib
411 :
412 : !> Create a new table node
413 2176 : subroutine new_table(table, name, attrib, line)
414 : type(hsd_node_t), intent(out) :: table
415 : character(len=*), intent(in), optional :: name
416 : character(len=*), intent(in), optional :: attrib
417 : integer, intent(in), optional :: line
418 :
419 1088 : table%node_type = NODE_TYPE_TABLE
420 1088 : if (present(name)) table%name = to_lower(name)
421 1088 : if (present(attrib)) then
422 507 : if (len_trim(attrib) > 0) table%attrib = attrib
423 : end if
424 1088 : if (present(line)) table%line = line
425 :
426 5440 : allocate(table%children(4))
427 1088 : table%num_children = 0
428 :
429 10 : end subroutine new_table
430 :
431 : !> Create a new value node
432 5102 : subroutine new_value(val, name, attrib, line)
433 : type(hsd_node_t), intent(out) :: val
434 : character(len=*), intent(in), optional :: name
435 : character(len=*), intent(in), optional :: attrib
436 : integer, intent(in), optional :: line
437 :
438 2551 : val%node_type = NODE_TYPE_VALUE
439 2551 : if (present(name)) val%name = to_lower(name)
440 2551 : if (present(attrib)) then
441 1016 : if (len_trim(attrib) > 0) val%attrib = attrib
442 : end if
443 2551 : if (present(line)) val%line = line
444 2551 : val%value_type = VALUE_TYPE_NONE
445 :
446 1088 : end subroutine new_value
447 :
448 2551 : end module hsd_types
|
