Line data Source code
1 : !> TOML backend — read/write hsd_table trees using toml-f.
2 : !>
3 : !> Mapping (per SPECIFICATION.md §3.4):
4 : !> hsd_table → TOML [section] or inline table
5 : !> hsd_value (string) → TOML string
6 : !> hsd_value (integer) → TOML integer
7 : !> hsd_value (real) → TOML float
8 : !> hsd_value (logical) → TOML boolean
9 : !> hsd_value (complex) → inline table {re = r, im = i}
10 : !> hsd_value (array) → TOML array [1, 2, 3]
11 : !> node%attrib → sibling key "name__attrib"
12 : !> anonymous value → "_value" key
13 : !>
14 : !> Requires toml-f. Compiled only when WITH_TOML is defined.
15 : module hsd_data_toml
16 : use hsd, only: hsd_table, hsd_value, hsd_node, hsd_node_ptr, hsd_error_t, &
17 : & new_table, new_value, dp, &
18 : & VALUE_TYPE_NONE, VALUE_TYPE_STRING, VALUE_TYPE_INTEGER, &
19 : & VALUE_TYPE_REAL, VALUE_TYPE_LOGICAL, VALUE_TYPE_ARRAY, &
20 : & VALUE_TYPE_COMPLEX, HSD_STAT_IO_ERROR, HSD_STAT_SYNTAX_ERROR
21 : use tomlf, only: toml_table, toml_array, toml_keyval, toml_key, &
22 : & toml_value, toml_error, toml_load, toml_loads, &
23 : & toml_serialize, get_value, set_value, add_table, add_array, &
24 : & new_table_ => new_table, len, toml_stat
25 : implicit none(type, external)
26 : private
27 :
28 : public :: toml_backend_load, toml_backend_load_string
29 : public :: toml_backend_dump, toml_backend_dump_to_string
30 :
31 : !> Suffix for attribute sibling keys (must match JSON backend)
32 : character(len=*), parameter :: ATTRIB_SUFFIX = "__attrib"
33 :
34 : !> Key for anonymous values (must match JSON backend)
35 : character(len=*), parameter :: ANON_VALUE_KEY = "_value"
36 :
37 : contains
38 :
39 : ! ---------------------------------------------------------------------------
40 : ! Loading (TOML → hsd_table)
41 : ! ---------------------------------------------------------------------------
42 :
43 : !> Load a TOML file into an hsd_table tree.
44 32 : subroutine toml_backend_load(filename, root, error)
45 : character(len=*), intent(in) :: filename
46 : type(hsd_table), intent(out) :: root
47 : type(hsd_error_t), allocatable, intent(out), optional :: error
48 :
49 16 : type(toml_table), allocatable :: toml_root
50 16 : type(toml_error), allocatable :: toml_err
51 :
52 16 : call toml_load(toml_root, filename, error=toml_err)
53 16 : if (allocated(toml_err)) then
54 0 : if (present(error)) then
55 0 : allocate(error)
56 0 : error%code = HSD_STAT_SYNTAX_ERROR
57 0 : error%message = toml_err%message
58 : end if
59 0 : return
60 : end if
61 16 : if (.not. allocated(toml_root)) then
62 0 : if (present(error)) then
63 0 : allocate(error)
64 0 : error%code = HSD_STAT_IO_ERROR
65 0 : error%message = "Failed to parse TOML file: " // trim(filename)
66 : end if
67 0 : return
68 : end if
69 :
70 16 : call new_table(root)
71 16 : call toml_table_to_hsd(toml_root, root)
72 :
73 16 : end subroutine toml_backend_load
74 :
75 : !> Load a TOML string into an hsd_table tree.
76 56 : subroutine toml_backend_load_string(source, root, error, filename)
77 : character(len=*), intent(in) :: source
78 : type(hsd_table), intent(out) :: root
79 : type(hsd_error_t), allocatable, intent(out), optional :: error
80 : character(len=*), intent(in), optional :: filename
81 :
82 28 : type(toml_table), allocatable :: toml_root
83 28 : type(toml_error), allocatable :: toml_err
84 :
85 28 : call toml_loads(toml_root, source, error=toml_err)
86 28 : if (allocated(toml_err)) then
87 0 : if (present(error)) then
88 0 : allocate(error)
89 0 : error%code = HSD_STAT_SYNTAX_ERROR
90 0 : error%message = toml_err%message
91 : end if
92 0 : return
93 : end if
94 28 : if (.not. allocated(toml_root)) then
95 0 : if (present(error)) then
96 0 : allocate(error)
97 0 : error%code = HSD_STAT_IO_ERROR
98 0 : if (present(filename)) then
99 0 : error%message = "Failed to parse TOML from: " // trim(filename)
100 : else
101 0 : error%message = "Failed to parse TOML string"
102 : end if
103 : end if
104 0 : return
105 : end if
106 :
107 28 : call new_table(root)
108 28 : call toml_table_to_hsd(toml_root, root)
109 :
110 44 : end subroutine toml_backend_load_string
111 :
112 : !> Recursively convert a toml_table to an hsd_table.
113 : !> Children of the TOML table become children of the HSD table.
114 232 : recursive subroutine toml_table_to_hsd(tt, ht)
115 : type(toml_table), intent(inout) :: tt
116 : type(hsd_table), intent(inout) :: ht
117 :
118 232 : type(toml_key), allocatable :: keys(:)
119 232 : integer :: ii, nkeys
120 232 : character(len=:), allocatable :: key_str, attrib_val
121 : type(toml_table), pointer :: child_tt
122 : type(toml_array), pointer :: child_arr
123 : type(toml_keyval), pointer :: child_kv
124 232 : integer :: stat
125 :
126 232 : call tt%get_keys(keys)
127 232 : nkeys = size(keys)
128 :
129 703 : do ii = 1, nkeys
130 471 : key_str = keys(ii)%key
131 :
132 : ! Skip __attrib keys — they are handled by their sibling
133 471 : if (is_attrib_key(key_str)) cycle
134 :
135 : ! Try to get as table first
136 425 : call get_value(tt, key_str, child_tt, requested=.false., stat=stat)
137 425 : if (associated(child_tt)) then
138 : ! Check if this is a complex value {re = ..., im = ...}
139 376 : if (is_complex_table(child_tt)) then
140 0 : call add_complex_value(child_tt, ht, key_str)
141 : else
142 188 : call add_hsd_table_child(child_tt, ht, key_str)
143 : end if
144 : ! Check for attrib sibling
145 188 : call get_attrib_from_toml(tt, key_str, attrib_val)
146 196 : if (allocated(attrib_val)) then
147 8 : call set_last_child_attrib(ht, attrib_val)
148 : end if
149 188 : cycle
150 : end if
151 :
152 : ! Try to get as array
153 237 : call get_value(tt, key_str, child_arr, requested=.false., stat=stat)
154 266 : if (associated(child_arr)) then
155 29 : call add_hsd_from_array(child_arr, ht, key_str)
156 : ! Check for attrib sibling
157 29 : call get_attrib_from_toml(tt, key_str, attrib_val)
158 29 : if (allocated(attrib_val)) then
159 0 : call set_last_child_attrib(ht, attrib_val)
160 : end if
161 29 : cycle
162 : end if
163 :
164 : ! Must be a keyval (scalar)
165 208 : call get_value(tt, key_str, child_kv, requested=.false., stat=stat)
166 648 : if (associated(child_kv)) then
167 208 : call add_hsd_from_keyval(child_kv, ht, key_str)
168 : ! Check for attrib sibling
169 208 : call get_attrib_from_toml(tt, key_str, attrib_val)
170 246 : if (allocated(attrib_val)) then
171 38 : call set_last_child_attrib(ht, attrib_val)
172 : end if
173 : end if
174 : end do
175 :
176 731 : end subroutine toml_table_to_hsd
177 :
178 : !> Add a child hsd_table from a toml_table.
179 188 : recursive subroutine add_hsd_table_child(tt, ht, key)
180 : type(toml_table), intent(inout), pointer :: tt
181 : type(hsd_table), intent(inout) :: ht
182 : character(len=*), intent(in) :: key
183 :
184 188 : type(hsd_table), allocatable :: child_ht
185 188 : character(len=:), allocatable :: child_name
186 :
187 188 : if (key == ANON_VALUE_KEY) then
188 0 : child_name = ""
189 : else
190 188 : child_name = key
191 : end if
192 :
193 188 : allocate(child_ht)
194 188 : call new_table(child_ht, name=child_name)
195 188 : call toml_table_to_hsd(tt, child_ht)
196 188 : call ht%add_child(child_ht)
197 :
198 3384 : end subroutine add_hsd_table_child
199 :
200 : !> Add a complex value from a toml inline table {re = ..., im = ...}.
201 0 : subroutine add_complex_value(tt, ht, key)
202 : type(toml_table), intent(inout), pointer :: tt
203 : type(hsd_table), intent(inout) :: ht
204 : character(len=*), intent(in) :: key
205 :
206 0 : type(hsd_value), allocatable :: child_val
207 0 : real(dp) :: re_part, im_part
208 0 : integer :: stat
209 0 : character(len=:), allocatable :: child_name
210 :
211 0 : if (key == ANON_VALUE_KEY) then
212 0 : child_name = ""
213 : else
214 0 : child_name = key
215 : end if
216 :
217 0 : re_part = 0.0_dp
218 0 : im_part = 0.0_dp
219 0 : call get_value(tt, "re", re_part, stat=stat)
220 0 : call get_value(tt, "im", im_part, stat=stat)
221 :
222 0 : allocate(child_val)
223 0 : call new_value(child_val, name=child_name)
224 0 : call child_val%set_complex(cmplx(re_part, im_part, dp))
225 0 : call ht%add_child(child_val)
226 :
227 0 : end subroutine add_complex_value
228 :
229 : !> Add an hsd child from a TOML scalar keyval.
230 208 : subroutine add_hsd_from_keyval(kv, ht, key)
231 : type(toml_keyval), intent(inout), pointer :: kv
232 : type(hsd_table), intent(inout) :: ht
233 : character(len=*), intent(in) :: key
234 :
235 208 : type(hsd_value), allocatable :: child_val
236 208 : character(len=:), allocatable :: str_val, child_name
237 208 : integer :: int_val, stat
238 208 : real(dp) :: real_val
239 208 : logical :: bool_val
240 :
241 208 : if (key == ANON_VALUE_KEY) then
242 5 : child_name = ""
243 : else
244 203 : child_name = key
245 : end if
246 :
247 208 : allocate(child_val)
248 208 : call new_value(child_val, name=child_name)
249 :
250 : ! Try boolean first
251 208 : call get_value(kv, bool_val, stat=stat)
252 208 : if (stat == toml_stat%success) then
253 40 : if (bool_val) then
254 34 : call child_val%set_string("Yes")
255 : else
256 6 : call child_val%set_string("No")
257 : end if
258 40 : call ht%add_child(child_val)
259 40 : return
260 : end if
261 :
262 : ! Try integer
263 168 : call get_value(kv, int_val, stat=stat)
264 168 : if (stat == toml_stat%success) then
265 27 : call child_val%set_string(int_to_string(int_val))
266 27 : call ht%add_child(child_val)
267 27 : return
268 : end if
269 :
270 : ! Try real
271 141 : call get_value(kv, real_val, stat=stat)
272 141 : if (stat == toml_stat%success) then
273 54 : call child_val%set_string(real_to_string(real_val))
274 54 : call ht%add_child(child_val)
275 54 : return
276 : end if
277 :
278 : ! Fall back to string
279 87 : call get_value(kv, str_val, stat=stat)
280 87 : if (stat == toml_stat%success) then
281 87 : call child_val%set_string(str_val)
282 : else
283 0 : call child_val%set_string("")
284 : end if
285 87 : call ht%add_child(child_val)
286 :
287 208 : end subroutine add_hsd_from_keyval
288 :
289 : !> Add HSD children from a TOML array.
290 : !> If the array contains tables → multiple same-named hsd_table children.
291 : !> If the array contains scalars → single hsd_value with space-separated text.
292 : !> If the array contains arrays → matrix (newline-separated rows).
293 29 : recursive subroutine add_hsd_from_array(arr, ht, key)
294 : type(toml_array), intent(inout), pointer :: arr
295 : type(hsd_table), intent(inout) :: ht
296 : character(len=*), intent(in) :: key
297 :
298 29 : integer :: nn, jj, stat
299 : type(toml_table), pointer :: elem_tt
300 : type(toml_array), pointer :: elem_arr
301 29 : type(hsd_table), allocatable :: child_ht
302 29 : type(hsd_value), allocatable :: child_val
303 29 : character(len=:), allocatable :: row_str, full_str, child_name
304 29 : logical :: first
305 :
306 0 : nn = len(arr)
307 29 : if (nn == 0) return
308 :
309 29 : if (key == ANON_VALUE_KEY) then
310 10 : child_name = ""
311 : else
312 19 : child_name = key
313 : end if
314 :
315 : ! Check first element type — try table
316 29 : call get_value(arr, 1, elem_tt, stat=stat)
317 29 : if (stat == toml_stat%success .and. associated(elem_tt)) then
318 : ! Array of tables → multiple same-named children
319 0 : do jj = 1, nn
320 0 : call get_value(arr, jj, elem_tt, stat=stat)
321 0 : if (stat /= toml_stat%success .or. .not. associated(elem_tt)) cycle
322 0 : allocate(child_ht)
323 0 : call new_table(child_ht, name=child_name)
324 0 : call toml_table_to_hsd(elem_tt, child_ht)
325 0 : call ht%add_child(child_ht)
326 0 : deallocate(child_ht)
327 : end do
328 0 : return
329 : end if
330 :
331 : ! Check first element type — try sub-array (matrix)
332 29 : call get_value(arr, 1, elem_arr, stat=stat)
333 38 : if (stat == toml_stat%success .and. associated(elem_arr)) then
334 : ! Array of arrays → matrix (newline-separated rows)
335 9 : full_str = ""
336 9 : first = .true.
337 33 : do jj = 1, nn
338 24 : call get_value(arr, jj, elem_arr, stat=stat)
339 24 : if (stat /= toml_stat%success .or. .not. associated(elem_arr)) cycle
340 24 : call array_to_space_string(elem_arr, row_str)
341 33 : if (first) then
342 9 : full_str = row_str
343 9 : first = .false.
344 : else
345 15 : full_str = full_str // new_line("a") // row_str
346 : end if
347 : end do
348 9 : allocate(child_val)
349 9 : call new_value(child_val, name=child_name)
350 9 : call child_val%set_raw(full_str)
351 9 : call ht%add_child(child_val)
352 9 : return
353 : end if
354 :
355 : ! Flat scalar array → space-separated string
356 20 : call array_to_space_string(arr, full_str)
357 20 : allocate(child_val)
358 20 : call new_value(child_val, name=child_name)
359 20 : call child_val%set_raw(full_str)
360 20 : call ht%add_child(child_val)
361 :
362 266 : end subroutine add_hsd_from_array
363 :
364 : !> Convert a flat TOML array of scalars to a space-separated string.
365 44 : subroutine array_to_space_string(arr, result_str)
366 : type(toml_array), intent(inout), pointer :: arr
367 : character(len=:), allocatable, intent(out) :: result_str
368 :
369 44 : integer :: nn, jj, stat
370 44 : integer :: int_val
371 44 : real(dp) :: real_val
372 44 : logical :: bool_val
373 44 : character(len=:), allocatable :: str_val, elem_str
374 44 : logical :: first
375 :
376 0 : nn = len(arr)
377 44 : result_str = ""
378 44 : first = .true.
379 :
380 230 : do jj = 1, nn
381 : ! Try integer
382 186 : call get_value(arr, jj, int_val, stat=stat)
383 186 : if (stat == toml_stat%success) then
384 37 : elem_str = int_to_string(int_val)
385 : else
386 : ! Try real
387 149 : call get_value(arr, jj, real_val, stat=stat)
388 149 : if (stat == toml_stat%success) then
389 133 : elem_str = real_to_string(real_val)
390 : else
391 : ! Try boolean
392 16 : call get_value(arr, jj, bool_val, stat=stat)
393 16 : if (stat == toml_stat%success) then
394 0 : if (bool_val) then
395 0 : elem_str = "Yes"
396 : else
397 0 : elem_str = "No"
398 : end if
399 : else
400 : ! Fall back to string
401 16 : call get_value(arr, jj, str_val, stat=stat)
402 16 : if (stat == toml_stat%success) then
403 16 : elem_str = str_val
404 : else
405 0 : elem_str = ""
406 : end if
407 : end if
408 : end if
409 : end if
410 :
411 230 : if (first) then
412 44 : result_str = elem_str
413 44 : first = .false.
414 : else
415 142 : result_str = result_str // " " // elem_str
416 : end if
417 : end do
418 :
419 44 : end subroutine array_to_space_string
420 :
421 : ! ---------------------------------------------------------------------------
422 : ! Dumping (hsd_table → TOML)
423 : ! ---------------------------------------------------------------------------
424 :
425 : !> Dump an hsd_table tree to a TOML string.
426 50 : subroutine toml_backend_dump_to_string(root, output, pretty)
427 : type(hsd_table), intent(in) :: root
428 : character(len=:), allocatable, intent(out) :: output
429 : logical, intent(in), optional :: pretty
430 :
431 50 : type(toml_table), allocatable :: toml_root
432 :
433 : ! TOML has no meaningful compact form — it always uses key = value lines
434 : ! and [section] headers. The pretty argument is accepted for API
435 : ! consistency with other backends but has no effect on the output.
436 : if (.false. .and. present(pretty)) continue
437 :
438 50 : allocate(toml_root)
439 50 : call new_table_(toml_root)
440 50 : call hsd_to_toml_table(root, toml_root)
441 50 : output = toml_serialize(toml_root)
442 :
443 94 : end subroutine toml_backend_dump_to_string
444 :
445 : !> Dump an hsd_table tree to a TOML file.
446 1 : subroutine toml_backend_dump(root, filename, error, pretty)
447 : type(hsd_table), intent(in) :: root
448 : character(len=*), intent(in) :: filename
449 : type(hsd_error_t), allocatable, intent(out), optional :: error
450 : logical, intent(in), optional :: pretty
451 :
452 1 : character(len=:), allocatable :: output
453 1 : integer :: unit_num, ios
454 :
455 1 : call toml_backend_dump_to_string(root, output, pretty)
456 :
457 : open(newunit=unit_num, file=filename, status="replace", action="write", &
458 1 : & iostat=ios)
459 1 : if (ios /= 0) then
460 0 : if (present(error)) then
461 0 : allocate(error)
462 0 : error%code = HSD_STAT_IO_ERROR
463 0 : error%message = "Failed to open file for writing: " // trim(filename)
464 : end if
465 0 : return
466 : end if
467 1 : write(unit_num, "(a)", iostat=ios) output
468 1 : close(unit_num)
469 :
470 1 : if (ios /= 0 .and. present(error)) then
471 0 : allocate(error)
472 0 : error%code = HSD_STAT_IO_ERROR
473 0 : error%message = "Failed to write to file: " // trim(filename)
474 : end if
475 :
476 51 : end subroutine toml_backend_dump
477 :
478 : !> Recursively convert an hsd_table to a toml_table.
479 263 : recursive subroutine hsd_to_toml_table(ht, tt)
480 : type(hsd_table), intent(in) :: ht
481 : type(toml_table), intent(inout) :: tt
482 :
483 263 : integer :: ii, jj, name_count
484 263 : character(len=:), allocatable :: child_name
485 263 : logical, allocatable :: emitted(:)
486 : type(toml_table), pointer :: child_tt
487 :
488 263 : allocate(emitted(ht%num_children))
489 734 : emitted = .false.
490 :
491 : ! --- Pass 1a: value children and their attribs ---
492 : ! Emit all scalar key-value pairs before any table sections so that
493 : ! the output matches what toml-f produces after parsing.
494 734 : do ii = 1, ht%num_children
495 471 : if (.not. associated(ht%children(ii)%node)) cycle
496 :
497 263 : select type (child => ht%children(ii)%node)
498 : type is (hsd_value)
499 258 : child_name = get_hsd_child_name(child)
500 : ! Check for same-named siblings (arrays handled in pass 2)
501 258 : name_count = 0
502 719 : do jj = ii, ht%num_children
503 461 : if (.not. associated(ht%children(jj)%node)) cycle
504 1180 : if (get_hsd_child_name(ht%children(jj)%node) == child_name) then
505 719 : name_count = name_count + 1
506 : end if
507 : end do
508 258 : if (name_count > 1 .or. emitted(ii)) cycle
509 258 : emitted(ii) = .true.
510 258 : call write_hsd_value_to_toml(child, child_name, tt)
511 516 : if (allocated(child%attrib)) then
512 37 : if (len_trim(child%attrib) > 0) then
513 37 : call set_value(tt, child_name // ATTRIB_SUFFIX, child%attrib)
514 : end if
515 : end if
516 : end select
517 : end do
518 :
519 : ! --- Pass 1b: table-child attribs (scalar keys for table attributes) ---
520 : ! These must appear after value scalars but before table sections.
521 734 : do ii = 1, ht%num_children
522 471 : if (.not. associated(ht%children(ii)%node)) cycle
523 :
524 263 : select type (child => ht%children(ii)%node)
525 : type is (hsd_table)
526 213 : if (allocated(child%attrib)) then
527 10 : if (len_trim(child%attrib) > 0) then
528 10 : child_name = get_hsd_child_name(child)
529 10 : call set_value(tt, child_name // ATTRIB_SUFFIX, child%attrib)
530 : end if
531 : end if
532 : end select
533 : end do
534 :
535 : ! --- Pass 2: table sections and array-of-tables ---
536 734 : do ii = 1, ht%num_children
537 471 : if (.not. associated(ht%children(ii)%node)) cycle
538 471 : if (emitted(ii)) cycle
539 :
540 213 : child_name = get_hsd_child_name(ht%children(ii)%node)
541 :
542 : ! Count same-named siblings
543 213 : name_count = 0
544 574 : do jj = ii, ht%num_children
545 361 : if (.not. associated(ht%children(jj)%node)) cycle
546 935 : if (get_hsd_child_name(ht%children(jj)%node) == child_name) then
547 574 : name_count = name_count + 1
548 : end if
549 : end do
550 :
551 476 : if (name_count > 1) then
552 0 : call write_array_of_tables(ht, child_name, ii, emitted, tt)
553 : else
554 213 : emitted(ii) = .true.
555 0 : select type (child => ht%children(ii)%node)
556 : type is (hsd_table)
557 213 : call get_value(tt, child_name, child_tt)
558 426 : call hsd_to_toml_table(child, child_tt)
559 : type is (hsd_value)
560 : ! Should not reach here — values are handled in pass 1a
561 0 : call write_hsd_value_to_toml(child, child_name, tt)
562 : end select
563 : end if
564 : end do
565 :
566 264 : end subroutine hsd_to_toml_table
567 :
568 : !> Write multiple same-named HSD children as a TOML array of tables.
569 0 : recursive subroutine write_array_of_tables(ht, name, start_idx, emitted, tt)
570 : type(hsd_table), intent(in) :: ht
571 : character(len=*), intent(in) :: name
572 : integer, intent(in) :: start_idx
573 : logical, intent(inout) :: emitted(:)
574 : type(toml_table), intent(inout) :: tt
575 :
576 0 : integer :: jj
577 : type(toml_array), pointer :: arr
578 : type(toml_table), pointer :: elem_tt
579 :
580 0 : call add_array(tt, name, arr)
581 :
582 0 : do jj = start_idx, ht%num_children
583 0 : if (.not. associated(ht%children(jj)%node)) cycle
584 0 : if (get_hsd_child_name(ht%children(jj)%node) /= name) cycle
585 0 : emitted(jj) = .true.
586 :
587 0 : select type (child => ht%children(jj)%node)
588 : type is (hsd_table)
589 0 : call get_value(arr, len(arr) + 1, elem_tt)
590 0 : call hsd_to_toml_table(child, elem_tt)
591 : type is (hsd_value)
592 : ! Scalar in duplicate-named group — store as string in array
593 0 : call get_value(arr, len(arr) + 1, elem_tt)
594 0 : call write_hsd_value_to_toml(child, ANON_VALUE_KEY, elem_tt)
595 : end select
596 : end do
597 :
598 0 : end subroutine write_array_of_tables
599 :
600 : !> Write a single hsd_value into a TOML table.
601 258 : subroutine write_hsd_value_to_toml(val, key, tt)
602 : type(hsd_value), intent(in) :: val
603 : character(len=*), intent(in) :: key
604 : type(toml_table), intent(inout) :: tt
605 :
606 258 : real(dp) :: re_part, im_part
607 : type(toml_table), pointer :: cpx_tt
608 258 : character(len=:), allocatable :: text
609 :
610 258 : select case (val%value_type)
611 : case (VALUE_TYPE_INTEGER)
612 0 : call set_value(tt, key, val%int_value)
613 :
614 : case (VALUE_TYPE_REAL)
615 0 : call set_value(tt, key, val%real_value)
616 :
617 : case (VALUE_TYPE_LOGICAL)
618 0 : call set_value(tt, key, val%logical_value)
619 :
620 : case (VALUE_TYPE_COMPLEX)
621 0 : re_part = real(val%complex_value, dp)
622 0 : im_part = aimag(val%complex_value)
623 0 : call get_value(tt, key, cpx_tt)
624 0 : cpx_tt%inline = .true.
625 0 : call set_value(cpx_tt, "re", re_part)
626 0 : call set_value(cpx_tt, "im", im_part)
627 :
628 : case (VALUE_TYPE_ARRAY)
629 26 : if (allocated(val%string_value)) then
630 26 : text = val%string_value
631 0 : else if (allocated(val%raw_text)) then
632 0 : text = val%raw_text
633 : else
634 0 : text = ""
635 : end if
636 52 : call write_array_text_to_toml(text, key, tt)
637 :
638 : case (VALUE_TYPE_STRING)
639 464 : if (allocated(val%string_value)) then
640 : ! Sniff for numeric/boolean strings that came from HSD
641 319 : if (looks_like_number(val%string_value)) then
642 87 : call write_numeric_string_to_toml(val%string_value, key, tt)
643 145 : else if (is_hsd_boolean(val%string_value)) then
644 42 : call set_value(tt, key, hsd_bool_to_logical(val%string_value))
645 : else
646 103 : call set_value(tt, key, val%string_value)
647 : end if
648 : else
649 0 : call set_value(tt, key, "")
650 : end if
651 :
652 : case (VALUE_TYPE_NONE)
653 0 : if (allocated(val%string_value)) then
654 0 : if (len(val%string_value) > 0) then
655 0 : call set_value(tt, key, val%string_value)
656 : else
657 0 : call set_value(tt, key, "")
658 : end if
659 : else
660 0 : call set_value(tt, key, "")
661 : end if
662 :
663 : case default
664 26 : if (allocated(val%string_value)) then
665 0 : call set_value(tt, key, val%string_value)
666 : else
667 0 : call set_value(tt, key, "")
668 : end if
669 : end select
670 :
671 258 : end subroutine write_hsd_value_to_toml
672 :
673 : !> Write array text (space-separated, possibly multi-line) as TOML array.
674 26 : subroutine write_array_text_to_toml(text, key, tt)
675 : character(len=*), intent(in) :: text
676 : character(len=*), intent(in) :: key
677 : type(toml_table), intent(inout) :: tt
678 :
679 : type(toml_array), pointer :: arr, sub_arr
680 26 : integer :: ii, line_start, line_end
681 26 : logical :: has_newlines, is_nl
682 :
683 26 : if (len_trim(text) == 0) then
684 : ! Empty array
685 0 : call add_array(tt, key, arr)
686 0 : return
687 : end if
688 :
689 : ! Check for multi-line (matrix)
690 26 : has_newlines = .false.
691 649 : do ii = 1, len(text)
692 649 : if (text(ii:ii) == new_line("a")) then
693 16 : has_newlines = .true.
694 16 : exit
695 : end if
696 : end do
697 :
698 26 : if (has_newlines) then
699 : ! Matrix: array of arrays
700 16 : call add_array(tt, key, arr)
701 16 : line_start = 1
702 1220 : do ii = 1, len(text) + 1
703 1204 : if (ii > len(text)) then
704 16 : is_nl = .true.
705 : else
706 1188 : is_nl = (text(ii:ii) == new_line("a"))
707 : end if
708 1220 : if (is_nl) then
709 43 : line_end = ii - 1
710 43 : if (line_start <= line_end .and. len_trim(text(line_start:line_end)) > 0) then
711 43 : call add_array(arr, sub_arr)
712 43 : call add_tokens_to_array(text(line_start:line_end), sub_arr)
713 : end if
714 43 : line_start = ii + 1
715 : end if
716 : end do
717 : else
718 : ! Flat array
719 10 : call add_array(tt, key, arr)
720 10 : call add_tokens_to_array(text, arr)
721 : end if
722 :
723 284 : end subroutine write_array_text_to_toml
724 :
725 : !> Add space-separated tokens to a TOML array.
726 53 : subroutine add_tokens_to_array(line, arr)
727 : character(len=*), intent(in) :: line
728 : type(toml_array), intent(inout), pointer :: arr
729 :
730 53 : integer :: ii, tok_start, tok_count, stat
731 53 : logical :: in_token, is_sep
732 53 : character(len=:), allocatable :: token
733 53 : integer :: int_val
734 53 : real(dp) :: real_val
735 :
736 53 : tok_count = 0
737 53 : in_token = .false.
738 53 : tok_start = 1
739 :
740 1471 : do ii = 1, len(line) + 1
741 1418 : if (ii > len(line)) then
742 53 : is_sep = .true.
743 : else
744 2730 : is_sep = (line(ii:ii) == " " .or. line(ii:ii) == achar(9) &
745 4095 : & .or. line(ii:ii) == ",")
746 : end if
747 :
748 1471 : if (is_sep) then
749 193 : if (in_token) then
750 163 : token = line(tok_start:ii - 1)
751 : ! Try integer first
752 163 : read(token, *, iostat=stat) int_val
753 163 : if (stat == 0 .and. is_pure_integer(token)) then
754 36 : call set_value(arr, len(arr) + 1, int_val)
755 : else
756 : ! Try real
757 127 : read(token, *, iostat=stat) real_val
758 127 : if (stat == 0 .and. looks_like_number(token)) then
759 115 : call set_value(arr, len(arr) + 1, real_val)
760 : else
761 : ! Store as string
762 12 : call set_value(arr, len(arr) + 1, token)
763 : end if
764 : end if
765 163 : tok_count = tok_count + 1
766 163 : in_token = .false.
767 : end if
768 : else
769 1225 : if (.not. in_token) then
770 163 : tok_start = ii
771 163 : in_token = .true.
772 : end if
773 : end if
774 : end do
775 :
776 79 : end subroutine add_tokens_to_array
777 :
778 : !> Write a numeric string to TOML as the appropriate type.
779 87 : subroutine write_numeric_string_to_toml(str, key, tt)
780 : character(len=*), intent(in) :: str
781 : character(len=*), intent(in) :: key
782 : type(toml_table), intent(inout) :: tt
783 :
784 87 : integer :: int_val, ios
785 87 : real(dp) :: real_val
786 :
787 : ! Try integer first
788 87 : if (is_pure_integer(str)) then
789 30 : read(str, *, iostat=ios) int_val
790 30 : if (ios == 0) then
791 30 : call set_value(tt, key, int_val)
792 30 : return
793 : end if
794 : end if
795 :
796 : ! Must be real
797 57 : read(str, *, iostat=ios) real_val
798 57 : if (ios == 0) then
799 57 : call set_value(tt, key, real_val)
800 : else
801 : ! Cannot parse — store as string
802 0 : call set_value(tt, key, str)
803 : end if
804 :
805 140 : end subroutine write_numeric_string_to_toml
806 :
807 : ! ---------------------------------------------------------------------------
808 : ! Utility routines
809 : ! ---------------------------------------------------------------------------
810 :
811 : !> Get the effective name of an HSD child node.
812 1303 : function get_hsd_child_name(node) result(name)
813 : class(hsd_node), intent(in) :: node
814 : character(len=:), allocatable :: name
815 :
816 : select type (node)
817 : type is (hsd_table)
818 667 : if (allocated(node%name)) then
819 667 : if (len_trim(node%name) > 0) then
820 667 : name = node%name
821 : else
822 0 : name = ANON_VALUE_KEY
823 : end if
824 : else
825 0 : name = ANON_VALUE_KEY
826 : end if
827 : type is (hsd_value)
828 636 : if (allocated(node%name)) then
829 636 : if (len_trim(node%name) > 0) then
830 616 : name = node%name
831 : else
832 20 : name = ANON_VALUE_KEY
833 : end if
834 : else
835 0 : name = ANON_VALUE_KEY
836 : end if
837 : class default
838 0 : name = ANON_VALUE_KEY
839 : end select
840 :
841 87 : end function get_hsd_child_name
842 :
843 : !> Check if key ends with __attrib.
844 471 : pure function is_attrib_key(key) result(is_attr)
845 : character(len=*), intent(in) :: key
846 : logical :: is_attr
847 :
848 471 : integer :: klen, slen
849 :
850 471 : is_attr = .false.
851 471 : klen = len(key)
852 471 : slen = len(ATTRIB_SUFFIX)
853 250 : if (klen <= slen) return
854 221 : is_attr = (key(klen - slen + 1:klen) == ATTRIB_SUFFIX)
855 :
856 471 : end function is_attrib_key
857 :
858 : !> Check if a TOML table is a complex number {re = ..., im = ...}.
859 188 : function is_complex_table(tt) result(is_cpx)
860 : type(toml_table), intent(inout), pointer :: tt
861 : logical :: is_cpx
862 :
863 188 : type(toml_key), allocatable :: keys(:)
864 188 : integer :: nkeys
865 :
866 188 : is_cpx = .false.
867 188 : call tt%get_keys(keys)
868 188 : nkeys = size(keys)
869 188 : if (nkeys /= 2) return
870 100 : if ((keys(1)%key == "re" .and. keys(2)%key == "im") .or. &
871 50 : & (keys(1)%key == "im" .and. keys(2)%key == "re")) then
872 0 : is_cpx = .true.
873 : end if
874 :
875 1022 : end function is_complex_table
876 :
877 : !> Look for a "key__attrib" sibling in the TOML table.
878 425 : subroutine get_attrib_from_toml(tt, key, attrib_val)
879 : type(toml_table), intent(inout) :: tt
880 : character(len=*), intent(in) :: key
881 : character(len=:), allocatable, intent(out) :: attrib_val
882 :
883 425 : integer :: stat
884 :
885 425 : call get_value(tt, key // ATTRIB_SUFFIX, attrib_val, stat=stat)
886 425 : if (stat /= toml_stat%success) then
887 379 : if (allocated(attrib_val)) deallocate(attrib_val)
888 : end if
889 :
890 188 : end subroutine get_attrib_from_toml
891 :
892 : !> Set attrib on the most recently added child of an hsd_table.
893 46 : subroutine set_last_child_attrib(ht, attrib_val)
894 : type(hsd_table), intent(inout) :: ht
895 : character(len=*), intent(in) :: attrib_val
896 :
897 0 : if (ht%num_children < 1) return
898 :
899 0 : select type (child => ht%children(ht%num_children)%node)
900 : type is (hsd_table)
901 8 : child%attrib = attrib_val
902 : type is (hsd_value)
903 38 : child%attrib = attrib_val
904 : end select
905 :
906 471 : end subroutine set_last_child_attrib
907 :
908 : !> Check if string looks like a number.
909 359 : pure function looks_like_number(str) result(is_num)
910 : character(len=*), intent(in) :: str
911 : logical :: is_num
912 :
913 359 : integer :: ii, slen
914 :
915 359 : is_num = .false.
916 359 : slen = len_trim(str)
917 0 : if (slen == 0) return
918 :
919 359 : ii = 1
920 359 : if (str(ii:ii) == "-" .or. str(ii:ii) == "+") then
921 4 : ii = ii + 1
922 4 : if (ii > slen) return
923 : end if
924 :
925 : ! Accept leading dot (e.g., ".2" from some compilers' g0 format)
926 359 : if (str(ii:ii) == ".") then
927 0 : ii = ii + 1
928 0 : if (ii > slen) return
929 : ! Must have at least one digit after the dot
930 0 : if (str(ii:ii) < "0" .or. str(ii:ii) > "9") return
931 0 : do while (ii <= slen)
932 0 : if (str(ii:ii) < "0" .or. str(ii:ii) > "9") exit
933 0 : ii = ii + 1
934 : end do
935 : ! Check for exponent part
936 0 : if (ii <= slen) then
937 0 : if (str(ii:ii) == "e" .or. str(ii:ii) == "E" &
938 0 : & .or. str(ii:ii) == "d" .or. str(ii:ii) == "D") then
939 0 : ii = ii + 1
940 0 : if (ii <= slen) then
941 0 : if (str(ii:ii) == "+" .or. str(ii:ii) == "-") ii = ii + 1
942 : end if
943 0 : if (ii > slen) return
944 0 : do while (ii <= slen)
945 0 : if (str(ii:ii) < "0" .or. str(ii:ii) > "9") exit
946 0 : ii = ii + 1
947 : end do
948 : end if
949 : end if
950 0 : is_num = (ii > slen)
951 0 : return
952 : end if
953 :
954 359 : if (str(ii:ii) < "0" .or. str(ii:ii) > "9") return
955 :
956 578 : do while (ii <= slen)
957 548 : if (str(ii:ii) < "0" .or. str(ii:ii) > "9") exit
958 332 : ii = ii + 1
959 : end do
960 :
961 246 : if (ii <= slen) then
962 216 : if (str(ii:ii) == ".") then
963 184 : ii = ii + 1
964 1613 : do while (ii <= slen)
965 1449 : if (str(ii:ii) < "0" .or. str(ii:ii) > "9") exit
966 1429 : ii = ii + 1
967 : end do
968 : end if
969 : end if
970 :
971 246 : if (ii <= slen) then
972 104 : if (str(ii:ii) == "e" .or. str(ii:ii) == "E" &
973 156 : & .or. str(ii:ii) == "d" .or. str(ii:ii) == "D") then
974 8 : ii = ii + 1
975 8 : if (ii <= slen) then
976 8 : if (str(ii:ii) == "+" .or. str(ii:ii) == "-") ii = ii + 1
977 : end if
978 8 : if (ii > slen) return
979 16 : do while (ii <= slen)
980 8 : if (str(ii:ii) < "0" .or. str(ii:ii) > "9") exit
981 8 : ii = ii + 1
982 : end do
983 : end if
984 : end if
985 :
986 246 : is_num = (ii > slen)
987 :
988 405 : end function looks_like_number
989 :
990 : !> Check if string is a pure integer (no decimal point or exponent).
991 250 : pure function is_pure_integer(str) result(is_int)
992 : character(len=*), intent(in) :: str
993 : logical :: is_int
994 :
995 250 : integer :: ii, slen
996 :
997 250 : is_int = .false.
998 250 : slen = len_trim(str)
999 0 : if (slen == 0) return
1000 :
1001 250 : ii = 1
1002 250 : if (str(ii:ii) == "-" .or. str(ii:ii) == "+") then
1003 4 : ii = ii + 1
1004 4 : if (ii > slen) return
1005 : end if
1006 :
1007 250 : if (str(ii:ii) < "0" .or. str(ii:ii) > "9") return
1008 :
1009 562 : do while (ii <= slen)
1010 496 : if (str(ii:ii) < "0" .or. str(ii:ii) > "9") return
1011 324 : ii = ii + 1
1012 : end do
1013 :
1014 66 : is_int = .true.
1015 :
1016 609 : end function is_pure_integer
1017 :
1018 : !> Check if string is an HSD boolean.
1019 145 : pure function is_hsd_boolean(str) result(is_bool)
1020 : character(len=*), intent(in) :: str
1021 : logical :: is_bool
1022 :
1023 145 : character(len=:), allocatable :: lower
1024 145 : integer :: ii, slen
1025 :
1026 145 : is_bool = .false.
1027 145 : slen = len_trim(str)
1028 0 : if (slen == 0) return
1029 :
1030 145 : allocate(character(len=slen) :: lower)
1031 1881 : do ii = 1, slen
1032 1881 : if (str(ii:ii) >= "A" .and. str(ii:ii) <= "Z") then
1033 76 : lower(ii:ii) = achar(iachar(str(ii:ii)) + 32)
1034 : else
1035 1660 : lower(ii:ii) = str(ii:ii)
1036 : end if
1037 : end do
1038 :
1039 : is_bool = (lower == "yes" .or. lower == "no" .or. lower == "true" &
1040 145 : & .or. lower == "false" .or. lower == ".true." .or. lower == ".false.")
1041 :
1042 395 : end function is_hsd_boolean
1043 :
1044 : !> Convert HSD boolean string to Fortran logical.
1045 42 : pure function hsd_bool_to_logical(str) result(val)
1046 : character(len=*), intent(in) :: str
1047 : logical :: val
1048 :
1049 42 : character(len=:), allocatable :: lower
1050 42 : integer :: ii, slen
1051 :
1052 42 : slen = len_trim(str)
1053 42 : allocate(character(len=slen) :: lower)
1054 161 : do ii = 1, slen
1055 161 : if (str(ii:ii) >= "A" .and. str(ii:ii) <= "Z") then
1056 42 : lower(ii:ii) = achar(iachar(str(ii:ii)) + 32)
1057 : else
1058 77 : lower(ii:ii) = str(ii:ii)
1059 : end if
1060 : end do
1061 :
1062 42 : val = (lower == "yes" .or. lower == "true" .or. lower == ".true.")
1063 :
1064 187 : end function hsd_bool_to_logical
1065 :
1066 : !> Convert integer to string.
1067 64 : function int_to_string(ival) result(str)
1068 : integer, intent(in) :: ival
1069 : character(len=:), allocatable :: str
1070 :
1071 : character(len=32) :: buf
1072 :
1073 64 : write(buf, "(i0)") ival
1074 64 : str = trim(adjustl(buf))
1075 :
1076 42 : end function int_to_string
1077 :
1078 : !> Convert real to string.
1079 187 : function real_to_string(rval) result(str)
1080 : real(dp), intent(in) :: rval
1081 : character(len=:), allocatable :: str
1082 :
1083 : character(len=64) :: buf
1084 :
1085 187 : write(buf, "(g0)") rval
1086 187 : str = trim(adjustl(buf))
1087 :
1088 64 : end function real_to_string
1089 :
1090 3132 : end module hsd_data_toml
|
