Line data Source code
1 : !> YAML parser: read YAML text into an hsd_table tree.
2 : !>
3 : !> Implements a recursive-descent parser for a subset of YAML 1.2.
4 : !> Mapping (per SPECIFICATION.md):
5 : !> YAML mapping → hsd_table (keys become child names)
6 : !> YAML scalar → hsd_value (string)
7 : !> YAML sequence → hsd_value (space-separated) or multiple same-named children
8 : !> "key__attrib" → attrib on sibling "key"
9 : !> "_value" → anonymous value
10 : !> {re: v, im: v} → complex hsd_value
11 : !> Booleans (true/false/yes/no) → "Yes"/"No" strings
12 : !> null/~ → empty string
13 : !>
14 : !> NOT supported: anchors, aliases, tags
15 : module hsd_data_yaml_parser
16 : use hsd, only: hsd_table, hsd_value, hsd_node, hsd_error_t, new_table, &
17 : & new_value, HSD_STAT_SYNTAX_ERROR, HSD_STAT_IO_ERROR, dp
18 : implicit none(type, external)
19 : private
20 :
21 : public :: yaml_parse_file, yaml_parse_string
22 :
23 : !> Suffix for attribute sibling keys (must match writer)
24 : character(len=*), parameter :: ATTRIB_SUFFIX = "__attrib"
25 :
26 : !> Key for anonymous values (must match writer)
27 : character(len=*), parameter :: ANON_VALUE_KEY = "_value"
28 :
29 : contains
30 :
31 : !> Parse a YAML file into an hsd_table tree.
32 38 : subroutine yaml_parse_file(filename, root, error)
33 : character(len=*), intent(in) :: filename
34 : type(hsd_table), intent(out) :: root
35 : type(hsd_error_t), allocatable, intent(out), optional :: error
36 :
37 19 : character(len=:), allocatable :: source
38 19 : integer :: unit_num, ios, file_size
39 :
40 19 : inquire(file=filename, size=file_size)
41 19 : if (file_size < 0) then
42 0 : if (present(error)) then
43 0 : allocate(error)
44 0 : error%code = HSD_STAT_IO_ERROR
45 0 : error%message = "Cannot determine size of file: " // trim(filename)
46 : end if
47 0 : return
48 : end if
49 :
50 19 : allocate(character(len=file_size) :: source)
51 : open(newunit=unit_num, file=filename, status="old", access="stream", &
52 19 : & form="unformatted", action="read", iostat=ios)
53 19 : if (ios /= 0) then
54 0 : if (present(error)) then
55 0 : allocate(error)
56 0 : error%code = HSD_STAT_IO_ERROR
57 0 : error%message = "Cannot open file: " // trim(filename)
58 : end if
59 0 : return
60 : end if
61 19 : read(unit_num, iostat=ios) source
62 19 : close(unit_num)
63 19 : if (ios /= 0) then
64 0 : if (present(error)) then
65 0 : allocate(error)
66 0 : error%code = HSD_STAT_IO_ERROR
67 0 : error%message = "Cannot read file: " // trim(filename)
68 : end if
69 0 : return
70 : end if
71 :
72 19 : call yaml_parse_string(source, root, error, filename)
73 :
74 19 : end subroutine yaml_parse_file
75 :
76 : !> Parse a YAML string into an hsd_table tree.
77 82 : subroutine yaml_parse_string(source, root, error, filename)
78 : character(len=*), intent(in) :: source
79 : type(hsd_table), intent(out) :: root
80 : type(hsd_error_t), allocatable, intent(out), optional :: error
81 : character(len=*), intent(in), optional :: filename
82 :
83 41 : integer :: pos, src_len
84 41 : character(len=:), allocatable :: fname
85 :
86 41 : if (present(filename)) then
87 19 : fname = filename
88 : else
89 22 : fname = "<string>"
90 : end if
91 :
92 41 : call new_table(root)
93 :
94 41 : src_len = len(source)
95 41 : pos = 1
96 :
97 : ! Skip BOM if present
98 41 : if (src_len >= 3) then
99 : if (iachar(source(1:1)) == 239 .and. iachar(source(2:2)) == 187 &
100 41 : & .and. iachar(source(3:3)) == 191) then
101 0 : pos = 4
102 : end if
103 : end if
104 :
105 : ! Skip leading whitespace and comments
106 41 : call skip_ws_and_comments(source, src_len, pos)
107 :
108 41 : if (pos > src_len) return ! Empty input → empty root
109 :
110 : ! Skip document start marker ---
111 40 : if (pos + 2 <= src_len) then
112 40 : if (source(pos:pos + 2) == "---") then
113 1 : pos = pos + 3
114 1 : call skip_to_eol(source, src_len, pos)
115 1 : call skip_ws_and_comments(source, src_len, pos)
116 : end if
117 : end if
118 :
119 40 : if (pos > src_len) return
120 :
121 : ! Check for flow mapping at top level
122 42 : if (source(pos:pos) == "{") then
123 2 : call parse_flow_mapping(source, src_len, pos, root, error, fname)
124 2 : return
125 : end if
126 :
127 : ! Check for unsupported features
128 38 : if (source(pos:pos) == "&" .or. source(pos:pos) == "*") then
129 0 : call make_error(error, "Anchors/aliases are not supported", fname, pos)
130 0 : return
131 : end if
132 38 : if (pos + 1 <= src_len) then
133 38 : if (source(pos:pos + 1) == "!!") then
134 0 : call make_error(error, "Tags are not supported", fname, pos)
135 0 : return
136 : end if
137 : end if
138 :
139 : ! Parse block mapping at indent level 0
140 38 : call parse_block_mapping(source, src_len, pos, 0, root, error, fname)
141 :
142 60 : end subroutine yaml_parse_string
143 :
144 :
145 : !> Parse a block-style mapping at a given indent level.
146 : !> Reads key: value pairs where keys start at exactly `min_indent` columns.
147 151 : recursive subroutine parse_block_mapping(src, src_len, pos, min_indent, &
148 : & table, error, fname)
149 : character(len=*), intent(in) :: src
150 : integer, intent(in) :: src_len
151 : integer, intent(inout) :: pos
152 : integer, intent(in) :: min_indent
153 : type(hsd_table), intent(inout) :: table
154 : type(hsd_error_t), allocatable, intent(out), optional :: error
155 : character(len=*), intent(in) :: fname
156 :
157 151 : character(len=:), allocatable :: key
158 151 : integer :: key_indent, ii
159 :
160 : ! Deferred attrib storage
161 : integer, parameter :: MAX_DEFERRED = 64
162 : character(len=256) :: def_names(MAX_DEFERRED), def_vals(MAX_DEFERRED)
163 151 : integer :: ndef
164 :
165 151 : ndef = 0
166 :
167 296 : do
168 446 : call skip_ws_and_comments(src, src_len, pos)
169 446 : if (pos > src_len) exit
170 :
171 : ! Check for document end markers
172 382 : if (pos + 2 <= src_len) then
173 382 : if (src(pos:pos + 2) == "..." .or. src(pos:pos + 2) == "---") exit
174 : end if
175 :
176 : ! Check for flow collection start (closing brace/bracket means we're inside flow)
177 381 : if (src(pos:pos) == "}" .or. src(pos:pos) == "]") exit
178 :
179 : ! Calculate current indent
180 381 : key_indent = get_line_indent(src, src_len, pos)
181 :
182 : ! If indent is less than our level, we're done with this mapping
183 381 : if (key_indent < min_indent) exit
184 :
185 : ! If indent is greater, also done (parent will handle)
186 296 : if (key_indent > min_indent .and. min_indent >= 0) exit
187 :
188 : ! Check for block sequence indicator
189 296 : if (src(pos:pos) == "-") then
190 : ! This is a sequence, not a mapping — exit
191 0 : exit
192 : end if
193 :
194 : ! Parse the key
195 296 : call parse_yaml_key(src, src_len, pos, key, error, fname)
196 296 : if (present(error)) then
197 296 : if (allocated(error)) return
198 : end if
199 :
200 : ! Now parse the value
201 0 : call parse_mapping_value(src, src_len, pos, table, key, key_indent, &
202 296 : & error, fname, ndef, def_names, def_vals)
203 296 : if (present(error)) then
204 296 : if (allocated(error)) return
205 : end if
206 : end do
207 :
208 : ! Apply deferred attribs
209 151 : do ii = 1, ndef
210 151 : call apply_deferred_attrib(table, trim(def_names(ii)), trim(def_vals(ii)))
211 : end do
212 :
213 343 : end subroutine parse_block_mapping
214 :
215 :
216 : !> Parse a mapping value (the part after "key:").
217 296 : recursive subroutine parse_mapping_value(src, src_len, pos, table, key, &
218 592 : & key_indent, error, fname, ndef, def_names, def_vals)
219 : character(len=*), intent(in) :: src
220 : integer, intent(in) :: src_len
221 : integer, intent(inout) :: pos
222 : type(hsd_table), intent(inout) :: table
223 : character(len=*), intent(in) :: key
224 : integer, intent(in) :: key_indent
225 : type(hsd_error_t), allocatable, intent(out), optional :: error
226 : character(len=*), intent(in) :: fname
227 : integer, intent(inout) :: ndef
228 : character(len=256), intent(inout) :: def_names(:), def_vals(:)
229 :
230 296 : character(len=:), allocatable :: scalar_val, child_name
231 296 : type(hsd_table), allocatable :: child_table
232 296 : type(hsd_value), allocatable :: child_value
233 296 : integer :: next_indent, attrib_check
234 296 : logical :: is_attrib, applied
235 :
236 : ! Determine child name
237 296 : if (key == ANON_VALUE_KEY) then
238 10 : child_name = ""
239 : else
240 286 : child_name = key
241 : end if
242 :
243 : ! Check if this is an attribute key
244 296 : is_attrib = .false.
245 296 : attrib_check = len(key) - len(ATTRIB_SUFFIX)
246 296 : if (attrib_check > 0) then
247 141 : is_attrib = (key(attrib_check + 1:len(key)) == ATTRIB_SUFFIX)
248 : end if
249 :
250 : ! Skip inline whitespace after ':'
251 296 : call skip_inline_ws(src, src_len, pos)
252 :
253 : ! Check what follows the colon
254 522 : if (pos > src_len .or. is_eol(src, src_len, pos)) then
255 : ! Value is on the next line(s)
256 114 : call skip_to_eol(src, src_len, pos)
257 114 : call skip_ws_and_comments(src, src_len, pos)
258 :
259 114 : if (pos > src_len) then
260 : ! Empty value at end of file
261 0 : if (is_attrib) then
262 0 : call handle_attrib(table, key(1:attrib_check), "", applied)
263 0 : if (.not. applied .and. ndef < size(def_names)) then
264 0 : ndef = ndef + 1
265 0 : def_names(ndef) = ""
266 0 : def_names(ndef)(1:attrib_check) = key(1:attrib_check)
267 0 : def_vals(ndef) = ""
268 : end if
269 : else
270 0 : allocate(child_value)
271 0 : call new_value(child_value, name=child_name)
272 0 : call child_value%set_string("")
273 0 : call table%add_child(child_value)
274 : end if
275 0 : return
276 : end if
277 :
278 114 : next_indent = get_line_indent(src, src_len, pos)
279 :
280 114 : if (next_indent <= key_indent) then
281 : ! Empty value (next line is at same or lesser indent)
282 0 : if (is_attrib) then
283 0 : call handle_attrib(table, key(1:attrib_check), "", applied)
284 0 : if (.not. applied .and. ndef < size(def_names)) then
285 0 : ndef = ndef + 1
286 0 : def_names(ndef) = ""
287 0 : def_names(ndef)(1:attrib_check) = key(1:attrib_check)
288 0 : def_vals(ndef) = ""
289 : end if
290 : else
291 0 : allocate(child_value)
292 0 : call new_value(child_value, name=child_name)
293 0 : call child_value%set_string("")
294 0 : call table%add_child(child_value)
295 : end if
296 0 : return
297 : end if
298 :
299 : ! Check if next content is a block sequence
300 115 : if (src(pos:pos) == "-") then
301 : call parse_block_sequence_value(src, src_len, pos, next_indent, &
302 1 : & table, child_name, error, fname)
303 1 : return
304 : end if
305 :
306 : ! Otherwise it's a nested mapping
307 113 : if (is_attrib) then
308 : ! attrib values shouldn't be tables, skip
309 0 : return
310 : end if
311 113 : allocate(child_table)
312 113 : call new_table(child_table, name=child_name)
313 113 : call parse_block_mapping(src, src_len, pos, next_indent, child_table, &
314 113 : & error, fname)
315 113 : if (present(error)) then
316 113 : if (allocated(error)) return
317 : end if
318 :
319 : ! Check if this is a complex object
320 113 : if (is_complex_object(child_table)) then
321 0 : allocate(child_value)
322 0 : call new_value(child_value, name=child_name)
323 0 : call child_value%set_complex(complex_from_table(child_table))
324 0 : call table%add_child(child_value)
325 : else
326 113 : call table%add_child(child_table)
327 : end if
328 113 : return
329 : end if
330 :
331 : ! Inline value after colon
332 188 : if (src(pos:pos) == "{") then
333 : ! Flow mapping
334 3 : if (is_attrib) return
335 3 : allocate(child_table)
336 3 : call new_table(child_table, name=child_name)
337 3 : call parse_flow_mapping(src, src_len, pos, child_table, error, fname)
338 3 : if (present(error)) then
339 3 : if (allocated(error)) return
340 : end if
341 : ! Check complex
342 6 : if (is_complex_object(child_table)) then
343 3 : allocate(child_value)
344 3 : call new_value(child_value, name=child_name)
345 3 : call child_value%set_complex(complex_from_table(child_table))
346 3 : call table%add_child(child_value)
347 : else
348 0 : call table%add_child(child_table)
349 : end if
350 3 : call skip_to_eol(src, src_len, pos)
351 3 : return
352 : end if
353 :
354 187 : if (src(pos:pos) == "[") then
355 : ! Flow sequence
356 : call parse_flow_sequence_to_string(src, src_len, pos, scalar_val, &
357 8 : & error, fname)
358 8 : if (present(error)) then
359 8 : if (allocated(error)) return
360 : end if
361 16 : if (is_attrib) then
362 0 : call handle_attrib(table, key(1:attrib_check), scalar_val, applied)
363 0 : if (.not. applied .and. ndef < size(def_names)) then
364 0 : ndef = ndef + 1
365 0 : def_names(ndef) = ""
366 0 : def_names(ndef)(1:attrib_check) = key(1:attrib_check)
367 0 : def_vals(ndef) = ""
368 0 : def_vals(ndef)(1:len(scalar_val)) = scalar_val
369 : end if
370 : else
371 8 : allocate(child_value)
372 8 : call new_value(child_value, name=child_name)
373 8 : call child_value%set_raw(scalar_val)
374 8 : call table%add_child(child_value)
375 : end if
376 8 : call skip_to_eol(src, src_len, pos)
377 8 : return
378 : end if
379 :
380 173 : if (src(pos:pos) == "|" .or. src(pos:pos) == ">") then
381 : ! Block scalar (literal or folded)
382 : call parse_block_scalar(src, src_len, pos, key_indent, scalar_val, &
383 2 : & error)
384 2 : if (present(error)) then
385 2 : if (allocated(error)) return
386 : end if
387 4 : if (is_attrib) then
388 0 : call handle_attrib(table, key(1:attrib_check), scalar_val, applied)
389 0 : if (.not. applied .and. ndef < size(def_names)) then
390 0 : ndef = ndef + 1
391 0 : def_names(ndef) = ""
392 0 : def_names(ndef)(1:attrib_check) = key(1:attrib_check)
393 0 : def_vals(ndef) = ""
394 0 : if (len(scalar_val) <= 256) then
395 0 : def_vals(ndef)(1:len(scalar_val)) = scalar_val
396 : end if
397 : end if
398 : else
399 2 : allocate(child_value)
400 2 : call new_value(child_value, name=child_name)
401 2 : call child_value%set_string(scalar_val)
402 2 : call table%add_child(child_value)
403 : end if
404 2 : return
405 : end if
406 :
407 : ! Plain or quoted scalar
408 169 : call parse_yaml_scalar(src, src_len, pos, scalar_val, error, fname)
409 169 : if (present(error)) then
410 169 : if (allocated(error)) return
411 : end if
412 :
413 : ! Convert YAML booleans/nulls
414 168 : scalar_val = convert_yaml_scalar(scalar_val)
415 :
416 309 : if (is_attrib) then
417 27 : call handle_attrib(table, key(1:attrib_check), scalar_val, applied)
418 27 : if (.not. applied .and. ndef < size(def_names)) then
419 1 : ndef = ndef + 1
420 1 : def_names(ndef) = ""
421 1 : def_names(ndef)(1:attrib_check) = key(1:attrib_check)
422 1 : def_vals(ndef) = ""
423 1 : if (len(scalar_val) <= 256) then
424 1 : def_vals(ndef)(1:len(scalar_val)) = scalar_val
425 : end if
426 : end if
427 : else
428 141 : allocate(child_value)
429 141 : call new_value(child_value, name=child_name)
430 141 : call child_value%set_string(scalar_val)
431 141 : call table%add_child(child_value)
432 : end if
433 :
434 168 : call skip_to_eol(src, src_len, pos)
435 :
436 2680 : end subroutine parse_mapping_value
437 :
438 :
439 : !> Parse a block sequence and store as space-separated string value.
440 1 : recursive subroutine parse_block_sequence_value(src, src_len, pos, &
441 : & seq_indent, table, name, error, fname)
442 : character(len=*), intent(in) :: src
443 : integer, intent(in) :: src_len
444 : integer, intent(inout) :: pos
445 : integer, intent(in) :: seq_indent
446 : type(hsd_table), intent(inout) :: table
447 : character(len=*), intent(in) :: name
448 : type(hsd_error_t), allocatable, intent(out), optional :: error
449 : character(len=*), intent(in) :: fname
450 :
451 1 : character(len=:), allocatable :: result_str, item_str
452 1 : integer :: cur_indent, val_start
453 1 : logical :: first, is_obj_seq
454 1 : type(hsd_table), allocatable :: child_table
455 :
456 1 : result_str = ""
457 1 : first = .true.
458 :
459 : ! Peek: check if sequence items are mappings
460 1 : is_obj_seq = .false.
461 1 : val_start = pos
462 1 : if (pos < src_len .and. src(pos:pos) == "-") then
463 1 : val_start = pos + 1
464 1 : call skip_inline_ws_at(src, src_len, val_start)
465 1 : if (val_start <= src_len) then
466 : ! If after "- " there's a key: value, it's an object sequence
467 1 : if (is_mapping_key_line(src, src_len, val_start)) then
468 0 : is_obj_seq = .true.
469 : end if
470 : end if
471 : end if
472 :
473 1 : if (is_obj_seq) then
474 : ! Sequence of mappings → multiple same-named children
475 0 : do
476 0 : call skip_ws_and_comments(src, src_len, pos)
477 0 : if (pos > src_len) exit
478 0 : cur_indent = get_line_indent(src, src_len, pos)
479 0 : if (cur_indent < seq_indent) exit
480 0 : if (src(pos:pos) /= "-") exit
481 :
482 0 : pos = pos + 1 ! skip '-'
483 0 : call skip_inline_ws(src, src_len, pos)
484 :
485 : ! Parse the mapping content of this sequence item
486 0 : allocate(child_table)
487 0 : call new_table(child_table, name=name)
488 :
489 : ! Determine indent for the mapping entries
490 0 : val_start = get_line_indent(src, src_len, pos)
491 0 : call parse_block_mapping(src, src_len, pos, val_start, child_table, &
492 0 : & error, fname)
493 0 : if (present(error)) then
494 0 : if (allocated(error)) return
495 : end if
496 0 : call table%add_child(child_table)
497 0 : deallocate(child_table)
498 : end do
499 0 : return
500 : end if
501 :
502 : ! Sequence of scalars → space-separated string
503 3 : do
504 4 : call skip_ws_and_comments(src, src_len, pos)
505 4 : if (pos > src_len) exit
506 3 : cur_indent = get_line_indent(src, src_len, pos)
507 3 : if (cur_indent < seq_indent) exit
508 3 : if (src(pos:pos) /= "-") exit
509 :
510 3 : pos = pos + 1 ! skip '-'
511 3 : call skip_inline_ws(src, src_len, pos)
512 :
513 : ! Parse the scalar item
514 3 : if (pos <= src_len .and. .not. is_eol(src, src_len, pos)) then
515 6 : if (src(pos:pos) == "[") then
516 : ! Nested flow sequence → newline-separated row
517 : call parse_flow_sequence_to_string(src, src_len, pos, item_str, &
518 0 : & error, fname)
519 0 : if (present(error)) then
520 0 : if (allocated(error)) return
521 : end if
522 : else
523 3 : call parse_yaml_scalar(src, src_len, pos, item_str, error, fname)
524 3 : if (present(error)) then
525 3 : if (allocated(error)) return
526 : end if
527 3 : item_str = convert_yaml_scalar(item_str)
528 : end if
529 : else
530 0 : item_str = ""
531 : end if
532 :
533 3 : if (first) then
534 1 : result_str = item_str
535 1 : first = .false.
536 : else
537 2 : result_str = result_str // " " // item_str
538 : end if
539 :
540 3 : call skip_to_eol(src, src_len, pos)
541 : end do
542 :
543 : ! Store as value
544 13 : block
545 1 : type(hsd_value), allocatable :: child_value
546 1 : allocate(child_value)
547 1 : call new_value(child_value, name=name)
548 1 : call child_value%set_raw(result_str)
549 14 : call table%add_child(child_value)
550 : end block
551 :
552 2 : end subroutine parse_block_sequence_value
553 :
554 :
555 : !> Parse a flow mapping: { key: value, ... }
556 : !> On entry, pos is at '{'. On exit, pos is after '}'.
557 5 : recursive subroutine parse_flow_mapping(src, src_len, pos, table, error, fname)
558 : character(len=*), intent(in) :: src
559 : integer, intent(in) :: src_len
560 : integer, intent(inout) :: pos
561 : type(hsd_table), intent(inout) :: table
562 : type(hsd_error_t), allocatable, intent(out), optional :: error
563 : character(len=*), intent(in) :: fname
564 :
565 5 : character(len=:), allocatable :: key, scalar_val, child_name
566 5 : type(hsd_table), allocatable :: child_table
567 5 : type(hsd_value), allocatable :: child_value
568 5 : integer :: attrib_check
569 5 : logical :: is_attrib, applied
570 :
571 : integer, parameter :: MAX_DEFERRED = 64
572 : character(len=256) :: def_names(MAX_DEFERRED), def_vals(MAX_DEFERRED)
573 5 : integer :: ndef, ii
574 :
575 5 : ndef = 0
576 :
577 : ! Skip '{'
578 5 : pos = pos + 1
579 5 : call skip_flow_ws(src, src_len, pos)
580 :
581 : ! Empty mapping
582 5 : if (pos <= src_len .and. src(pos:pos) == "}") then
583 1 : pos = pos + 1
584 1 : return
585 : end if
586 :
587 8 : do
588 12 : call skip_flow_ws(src, src_len, pos)
589 12 : if (pos > src_len) then
590 0 : call make_error(error, "Unexpected end of input in flow mapping", fname, pos)
591 0 : return
592 : end if
593 12 : if (src(pos:pos) == "}") then
594 4 : pos = pos + 1
595 4 : exit
596 : end if
597 :
598 : ! Parse key
599 8 : call parse_flow_key(src, src_len, pos, key, error, fname)
600 8 : if (present(error)) then
601 8 : if (allocated(error)) return
602 : end if
603 :
604 : ! Expect ':'
605 8 : call skip_flow_ws(src, src_len, pos)
606 8 : if (pos > src_len .or. src(pos:pos) /= ":") then
607 0 : call make_error(error, "Expected ':' after key in flow mapping", fname, pos)
608 0 : return
609 : end if
610 8 : pos = pos + 1
611 8 : call skip_flow_ws(src, src_len, pos)
612 :
613 : ! Determine child name and attrib status
614 8 : if (key == ANON_VALUE_KEY) then
615 0 : child_name = ""
616 : else
617 8 : child_name = key
618 : end if
619 :
620 8 : is_attrib = .false.
621 8 : attrib_check = len(key) - len(ATTRIB_SUFFIX)
622 8 : if (attrib_check > 0) then
623 0 : is_attrib = (key(attrib_check + 1:len(key)) == ATTRIB_SUFFIX)
624 : end if
625 :
626 : ! Parse value
627 8 : if (pos > src_len) then
628 0 : call make_error(error, "Unexpected end of input", fname, pos)
629 0 : return
630 : end if
631 :
632 8 : if (src(pos:pos) == "{") then
633 0 : if (is_attrib) then
634 : ! Skip nested mapping for attrib
635 0 : call skip_flow_value(src, src_len, pos)
636 : else
637 0 : allocate(child_table)
638 0 : call new_table(child_table, name=child_name)
639 0 : call parse_flow_mapping(src, src_len, pos, child_table, error, fname)
640 0 : if (present(error)) then
641 0 : if (allocated(error)) return
642 : end if
643 0 : if (is_complex_object(child_table)) then
644 0 : if (allocated(child_value)) deallocate(child_value)
645 0 : allocate(child_value)
646 0 : call new_value(child_value, name=child_name)
647 0 : call child_value%set_complex(complex_from_table(child_table))
648 0 : call table%add_child(child_value)
649 0 : deallocate(child_value)
650 : else
651 0 : call table%add_child(child_table)
652 : end if
653 0 : deallocate(child_table)
654 : end if
655 16 : else if (src(pos:pos) == "[") then
656 : call parse_flow_sequence_to_string(src, src_len, pos, scalar_val, &
657 0 : & error, fname)
658 0 : if (present(error)) then
659 0 : if (allocated(error)) return
660 : end if
661 0 : if (is_attrib) then
662 0 : call handle_attrib(table, key(1:attrib_check), scalar_val, applied)
663 0 : if (.not. applied .and. ndef < MAX_DEFERRED) then
664 0 : ndef = ndef + 1
665 0 : def_names(ndef) = ""
666 0 : def_names(ndef)(1:attrib_check) = key(1:attrib_check)
667 0 : def_vals(ndef) = ""
668 0 : if (len(scalar_val) <= 256) &
669 0 : & def_vals(ndef)(1:len(scalar_val)) = scalar_val
670 : end if
671 : else
672 0 : if (allocated(child_value)) deallocate(child_value)
673 0 : allocate(child_value)
674 0 : call new_value(child_value, name=child_name)
675 0 : call child_value%set_raw(scalar_val)
676 0 : call table%add_child(child_value)
677 0 : deallocate(child_value)
678 : end if
679 : else
680 8 : call parse_flow_scalar(src, src_len, pos, scalar_val, error, fname)
681 8 : if (present(error)) then
682 8 : if (allocated(error)) return
683 : end if
684 8 : scalar_val = convert_yaml_scalar(scalar_val)
685 :
686 16 : if (is_attrib) then
687 0 : call handle_attrib(table, key(1:attrib_check), scalar_val, applied)
688 : if (.not. applied .and. ndef < MAX_DEFERRED &
689 0 : & .and. len(scalar_val) <= 256) then
690 0 : ndef = ndef + 1
691 0 : def_names(ndef) = ""
692 0 : def_names(ndef)(1:attrib_check) = key(1:attrib_check)
693 0 : def_vals(ndef) = ""
694 0 : def_vals(ndef)(1:len(scalar_val)) = scalar_val
695 : end if
696 : else
697 8 : if (allocated(child_value)) deallocate(child_value)
698 8 : allocate(child_value)
699 8 : call new_value(child_value, name=child_name)
700 8 : call child_value%set_string(scalar_val)
701 8 : call table%add_child(child_value)
702 8 : deallocate(child_value)
703 : end if
704 : end if
705 :
706 : ! Comma or closing brace
707 8 : call skip_flow_ws(src, src_len, pos)
708 8 : if (pos > src_len) then
709 0 : call make_error(error, "Unexpected end of input in flow mapping", fname, pos)
710 0 : return
711 : end if
712 8 : if (src(pos:pos) == ",") then
713 4 : pos = pos + 1
714 4 : else if (src(pos:pos) /= "}") then
715 0 : call make_error(error, "Expected ',' or '}' in flow mapping", fname, pos)
716 0 : return
717 : end if
718 : end do
719 :
720 : ! Apply deferred attribs
721 4 : do ii = 1, ndef
722 4 : call apply_deferred_attrib(table, trim(def_names(ii)), trim(def_vals(ii)))
723 : end do
724 :
725 10 : end subroutine parse_flow_mapping
726 :
727 :
728 : !> Parse a flow sequence to a space-separated string.
729 : !> Nested sequences produce newline-separated rows.
730 249 : recursive subroutine parse_flow_sequence_to_string(src, src_len, pos, &
731 : & str_val, error, fname)
732 : character(len=*), intent(in) :: src
733 : integer, intent(in) :: src_len
734 : integer, intent(inout) :: pos
735 : character(len=:), allocatable, intent(out) :: str_val
736 : type(hsd_error_t), allocatable, intent(out), optional :: error
737 : character(len=*), intent(in) :: fname
738 :
739 16 : character(len=:), allocatable :: elem_str, sub_str
740 16 : logical :: first
741 :
742 : ! Skip '['
743 16 : pos = pos + 1
744 16 : call skip_flow_ws(src, src_len, pos)
745 :
746 16 : str_val = ""
747 16 : first = .true.
748 :
749 : ! Empty sequence
750 16 : if (pos <= src_len .and. src(pos:pos) == "]") then
751 0 : pos = pos + 1
752 0 : return
753 : end if
754 :
755 31 : do
756 47 : call skip_flow_ws(src, src_len, pos)
757 47 : if (pos > src_len) then
758 0 : call make_error(error, "Unexpected end of input in flow sequence", fname, pos)
759 0 : return
760 : end if
761 :
762 94 : if (src(pos:pos) == "[") then
763 : ! Nested sequence → newline-separated row
764 : call parse_flow_sequence_to_string(src, src_len, pos, sub_str, &
765 8 : & error, fname)
766 8 : if (present(error)) then
767 8 : if (allocated(error)) return
768 : end if
769 8 : if (first) then
770 4 : str_val = sub_str
771 : else
772 4 : str_val = str_val // new_line("a") // sub_str
773 : end if
774 : else
775 39 : call parse_flow_scalar(src, src_len, pos, elem_str, error, fname)
776 39 : if (present(error)) then
777 39 : if (allocated(error)) return
778 : end if
779 : ! Don't convert booleans in flow sequences (keep raw)
780 39 : if (first) then
781 12 : str_val = elem_str
782 : else
783 27 : str_val = str_val // " " // elem_str
784 : end if
785 : end if
786 47 : first = .false.
787 :
788 47 : call skip_flow_ws(src, src_len, pos)
789 47 : if (pos > src_len) then
790 0 : call make_error(error, "Unexpected end of input in flow sequence", fname, pos)
791 0 : return
792 : end if
793 :
794 47 : if (src(pos:pos) == "]") then
795 16 : pos = pos + 1
796 16 : return
797 31 : else if (src(pos:pos) == ",") then
798 31 : pos = pos + 1
799 : else
800 0 : call make_error(error, "Expected ',' or ']' in flow sequence", fname, pos)
801 0 : return
802 : end if
803 : end do
804 :
805 32 : end subroutine parse_flow_sequence_to_string
806 :
807 :
808 : !> Parse a block scalar (| for literal, > for folded).
809 2 : subroutine parse_block_scalar(src, src_len, pos, parent_indent, &
810 : & result, error)
811 : character(len=*), intent(in) :: src
812 : integer, intent(in) :: src_len
813 : integer, intent(inout) :: pos
814 : integer, intent(in) :: parent_indent
815 : character(len=:), allocatable, intent(out) :: result
816 : type(hsd_error_t), allocatable, intent(out), optional :: error
817 :
818 : character(len=1) :: style
819 2 : integer :: content_indent, line_start, line_end, cur_indent
820 2 : logical :: first, indent_set
821 :
822 2 : style = src(pos:pos)
823 2 : pos = pos + 1
824 :
825 : ! Skip chomping indicator and other modifiers
826 2 : do while (pos <= src_len .and. .not. is_eol(src, src_len, pos))
827 0 : pos = pos + 1
828 : end do
829 2 : call skip_eol(src, src_len, pos)
830 :
831 2 : result = ""
832 2 : first = .true.
833 2 : indent_set = .false.
834 2 : content_indent = parent_indent + 2
835 :
836 6 : do while (pos <= src_len)
837 : ! Check if line is blank
838 4 : line_start = pos
839 4 : cur_indent = 0
840 12 : do while (pos <= src_len .and. src(pos:pos) == " ")
841 8 : cur_indent = cur_indent + 1
842 8 : pos = pos + 1
843 : end do
844 :
845 : ! Completely blank line
846 4 : if (pos > src_len .or. is_eol(src, src_len, pos)) then
847 0 : if (.not. first) result = result // new_line("a")
848 0 : call skip_eol(src, src_len, pos)
849 0 : cycle
850 : end if
851 :
852 : ! Determine content indent from first non-blank line
853 4 : if (.not. indent_set) then
854 2 : content_indent = cur_indent
855 2 : indent_set = .true.
856 : end if
857 :
858 : ! If indent is less than content indent, we're done
859 4 : if (cur_indent < content_indent) then
860 0 : pos = line_start ! rewind to start of this line
861 0 : exit
862 : end if
863 :
864 : ! Read until end of line
865 4 : line_end = pos
866 36 : do while (line_end <= src_len .and. .not. is_eol_at(src, src_len, line_end))
867 32 : line_end = line_end + 1
868 : end do
869 :
870 4 : if (first) then
871 2 : first = .false.
872 : else
873 2 : if (style == "|") then
874 1 : result = result // new_line("a")
875 : else
876 : ! Folded: use space for non-blank continuation
877 1 : result = result // " "
878 : end if
879 : end if
880 :
881 : ! Add the line content (strip content_indent leading spaces)
882 4 : if (cur_indent > content_indent) then
883 0 : result = result // repeat(" ", cur_indent - content_indent) &
884 0 : & // src(pos:line_end - 1)
885 : else
886 4 : result = result // src(pos:line_end - 1)
887 : end if
888 :
889 4 : pos = line_end
890 4 : call skip_eol(src, src_len, pos)
891 : end do
892 :
893 4 : end subroutine parse_block_scalar
894 :
895 :
896 : !> Parse a YAML key (before the colon).
897 296 : subroutine parse_yaml_key(src, src_len, pos, key, error, fname)
898 : character(len=*), intent(in) :: src
899 : integer, intent(in) :: src_len
900 : integer, intent(inout) :: pos
901 : character(len=:), allocatable, intent(out) :: key
902 : type(hsd_error_t), allocatable, intent(out), optional :: error
903 : character(len=*), intent(in) :: fname
904 :
905 296 : integer :: start_pos
906 :
907 0 : if (pos > src_len) then
908 0 : call make_error(error, "Expected key", fname, pos)
909 0 : return
910 : end if
911 :
912 : ! Check for unsupported features
913 296 : if (src(pos:pos) == "&" .or. src(pos:pos) == "*") then
914 0 : call make_error(error, "Anchors/aliases are not supported", fname, pos)
915 0 : return
916 : end if
917 :
918 301 : if (src(pos:pos) == '"') then
919 5 : call parse_double_quoted(src, src_len, pos, key, error, fname)
920 5 : if (present(error)) then
921 5 : if (allocated(error)) return
922 : end if
923 : ! Skip whitespace and colon
924 5 : call skip_inline_ws(src, src_len, pos)
925 5 : if (pos <= src_len .and. src(pos:pos) == ":") then
926 5 : pos = pos + 1
927 : else
928 0 : call make_error(error, "Expected ':' after key", fname, pos)
929 : end if
930 5 : return
931 : end if
932 :
933 291 : if (src(pos:pos) == "'") then
934 0 : call parse_single_quoted(src, src_len, pos, key, error, fname)
935 0 : if (present(error)) then
936 0 : if (allocated(error)) return
937 : end if
938 0 : call skip_inline_ws(src, src_len, pos)
939 0 : if (pos <= src_len .and. src(pos:pos) == ":") then
940 0 : pos = pos + 1
941 : else
942 0 : call make_error(error, "Expected ':' after key", fname, pos)
943 : end if
944 0 : return
945 : end if
946 :
947 : ! Plain key: read until ':'
948 291 : start_pos = pos
949 3180 : do while (pos <= src_len)
950 3180 : if (src(pos:pos) == ":") then
951 : if (pos + 1 > src_len .or. src(pos + 1:pos + 1) == " " &
952 291 : & .or. is_eol_at(src, src_len, pos + 1)) then
953 291 : exit
954 : end if
955 : end if
956 2889 : if (is_eol_at(src, src_len, pos)) then
957 0 : call make_error(error, "Expected ':' after key", fname, pos)
958 0 : return
959 : end if
960 2889 : pos = pos + 1
961 : end do
962 :
963 291 : if (pos <= start_pos) then
964 0 : call make_error(error, "Empty key", fname, pos)
965 0 : return
966 : end if
967 :
968 291 : key = trim_right(src(start_pos:pos - 1))
969 :
970 : ! Skip ':'
971 291 : if (pos <= src_len .and. src(pos:pos) == ":") then
972 291 : pos = pos + 1
973 : else
974 0 : call make_error(error, "Expected ':' after key", fname, pos)
975 : end if
976 :
977 298 : end subroutine parse_yaml_key
978 :
979 :
980 : !> Parse a YAML scalar value (plain, single-quoted, or double-quoted).
981 172 : subroutine parse_yaml_scalar(src, src_len, pos, val, error, fname)
982 : character(len=*), intent(in) :: src
983 : integer, intent(in) :: src_len
984 : integer, intent(inout) :: pos
985 : character(len=:), allocatable, intent(out) :: val
986 : type(hsd_error_t), allocatable, intent(out), optional :: error
987 : character(len=*), intent(in) :: fname
988 :
989 172 : integer :: start_pos
990 :
991 172 : if (pos > src_len) then
992 0 : val = ""
993 0 : return
994 : end if
995 :
996 248 : if (src(pos:pos) == '"') then
997 76 : call parse_double_quoted(src, src_len, pos, val, error, fname)
998 76 : return
999 : end if
1000 :
1001 97 : if (src(pos:pos) == "'") then
1002 1 : call parse_single_quoted(src, src_len, pos, val, error, fname)
1003 1 : return
1004 : end if
1005 :
1006 : ! Plain scalar: read until end of line or comment
1007 95 : start_pos = pos
1008 521 : do while (pos <= src_len)
1009 512 : if (is_eol_at(src, src_len, pos)) exit
1010 : ! Comment: ' #'
1011 427 : if (pos > start_pos .and. src(pos:pos) == "#") then
1012 1 : if (src(pos - 1:pos - 1) == " ") exit
1013 : end if
1014 426 : pos = pos + 1
1015 : end do
1016 :
1017 95 : val = trim_right(src(start_pos:pos - 1))
1018 :
1019 468 : end subroutine parse_yaml_scalar
1020 :
1021 :
1022 : !> Parse a flow scalar (inside flow collections).
1023 47 : subroutine parse_flow_scalar(src, src_len, pos, val, error, fname)
1024 : character(len=*), intent(in) :: src
1025 : integer, intent(in) :: src_len
1026 : integer, intent(inout) :: pos
1027 : character(len=:), allocatable, intent(out) :: val
1028 : type(hsd_error_t), allocatable, intent(out), optional :: error
1029 : character(len=*), intent(in) :: fname
1030 :
1031 47 : integer :: start_pos
1032 :
1033 47 : if (pos > src_len) then
1034 0 : val = ""
1035 0 : return
1036 : end if
1037 :
1038 47 : if (src(pos:pos) == '"') then
1039 0 : call parse_double_quoted(src, src_len, pos, val, error, fname)
1040 0 : return
1041 : end if
1042 :
1043 47 : if (src(pos:pos) == "'") then
1044 0 : call parse_single_quoted(src, src_len, pos, val, error, fname)
1045 0 : return
1046 : end if
1047 :
1048 : ! Plain scalar in flow context: stop at , ] } :
1049 47 : start_pos = pos
1050 184 : do while (pos <= src_len)
1051 368 : if (src(pos:pos) == "," .or. src(pos:pos) == "]" &
1052 552 : & .or. src(pos:pos) == "}" .or. src(pos:pos) == ":") exit
1053 137 : if (is_eol_at(src, src_len, pos)) exit
1054 137 : pos = pos + 1
1055 : end do
1056 :
1057 47 : val = trim_right(src(start_pos:pos - 1))
1058 :
1059 219 : end subroutine parse_flow_scalar
1060 :
1061 :
1062 : !> Parse a flow key (inside flow mappings).
1063 8 : subroutine parse_flow_key(src, src_len, pos, key, error, fname)
1064 : character(len=*), intent(in) :: src
1065 : integer, intent(in) :: src_len
1066 : integer, intent(inout) :: pos
1067 : character(len=:), allocatable, intent(out) :: key
1068 : type(hsd_error_t), allocatable, intent(out), optional :: error
1069 : character(len=*), intent(in) :: fname
1070 :
1071 8 : integer :: start_pos
1072 :
1073 0 : if (pos > src_len) then
1074 0 : call make_error(error, "Expected key in flow mapping", fname, pos)
1075 0 : return
1076 : end if
1077 :
1078 8 : if (src(pos:pos) == '"') then
1079 0 : call parse_double_quoted(src, src_len, pos, key, error, fname)
1080 0 : return
1081 : end if
1082 :
1083 8 : if (src(pos:pos) == "'") then
1084 0 : call parse_single_quoted(src, src_len, pos, key, error, fname)
1085 0 : return
1086 : end if
1087 :
1088 : ! Plain key in flow context: stop at : , } ]
1089 8 : start_pos = pos
1090 26 : do while (pos <= src_len)
1091 52 : if (src(pos:pos) == ":" .or. src(pos:pos) == "," &
1092 78 : & .or. src(pos:pos) == "}" .or. src(pos:pos) == "]") exit
1093 18 : if (is_eol_at(src, src_len, pos)) exit
1094 18 : pos = pos + 1
1095 : end do
1096 :
1097 8 : key = trim_right(src(start_pos:pos - 1))
1098 :
1099 55 : end subroutine parse_flow_key
1100 :
1101 :
1102 : !> Parse a double-quoted string.
1103 81 : subroutine parse_double_quoted(src, src_len, pos, val, error, fname)
1104 : character(len=*), intent(in) :: src
1105 : integer, intent(in) :: src_len
1106 : integer, intent(inout) :: pos
1107 : character(len=:), allocatable, intent(out) :: val
1108 : type(hsd_error_t), allocatable, intent(out), optional :: error
1109 : character(len=*), intent(in) :: fname
1110 :
1111 : ! Skip opening quote
1112 81 : pos = pos + 1
1113 81 : val = ""
1114 :
1115 1213 : do while (pos <= src_len)
1116 1212 : if (src(pos:pos) == '"') then
1117 80 : pos = pos + 1 ! skip closing quote
1118 80 : return
1119 1132 : else if (src(pos:pos) == "\") then
1120 34 : pos = pos + 1
1121 34 : if (pos > src_len) then
1122 0 : call make_error(error, "Unterminated escape in string", fname, pos)
1123 0 : return
1124 : end if
1125 34 : select case (src(pos:pos))
1126 : case ("n")
1127 32 : val = val // new_line("a")
1128 : case ("t")
1129 0 : val = val // achar(9)
1130 : case ("\")
1131 2 : val = val // "\"
1132 : case ('"')
1133 0 : val = val // '"'
1134 : case ("/")
1135 0 : val = val // "/"
1136 : case ("0")
1137 0 : val = val // achar(0)
1138 : case default
1139 34 : val = val // src(pos:pos)
1140 : end select
1141 34 : pos = pos + 1
1142 : else
1143 1098 : val = val // src(pos:pos)
1144 1098 : pos = pos + 1
1145 : end if
1146 : end do
1147 :
1148 1 : call make_error(error, "Unterminated double-quoted string", fname, pos)
1149 :
1150 89 : end subroutine parse_double_quoted
1151 :
1152 :
1153 : !> Parse a single-quoted string.
1154 1 : subroutine parse_single_quoted(src, src_len, pos, val, error, fname)
1155 : character(len=*), intent(in) :: src
1156 : integer, intent(in) :: src_len
1157 : integer, intent(inout) :: pos
1158 : character(len=:), allocatable, intent(out) :: val
1159 : type(hsd_error_t), allocatable, intent(out), optional :: error
1160 : character(len=*), intent(in) :: fname
1161 :
1162 : ! Skip opening quote
1163 1 : pos = pos + 1
1164 1 : val = ""
1165 :
1166 14 : do while (pos <= src_len)
1167 14 : if (src(pos:pos) == "'") then
1168 : ! Check for escaped single quote ''
1169 1 : if (pos + 1 <= src_len) then
1170 0 : if (src(pos + 1:pos + 1) == "'") then
1171 0 : val = val // "'"
1172 0 : pos = pos + 2
1173 0 : cycle
1174 : end if
1175 : end if
1176 1 : pos = pos + 1 ! skip closing quote
1177 1 : return
1178 : else
1179 13 : val = val // src(pos:pos)
1180 13 : pos = pos + 1
1181 : end if
1182 : end do
1183 :
1184 0 : call make_error(error, "Unterminated single-quoted string", fname, pos)
1185 :
1186 82 : end subroutine parse_single_quoted
1187 :
1188 :
1189 : !> Convert YAML scalar values to HSD conventions.
1190 : !> true/yes → "Yes", false/no → "No", null/~ → ""
1191 179 : function convert_yaml_scalar(raw) result(converted)
1192 : character(len=*), intent(in) :: raw
1193 : character(len=:), allocatable :: converted
1194 :
1195 179 : character(len=:), allocatable :: lower
1196 :
1197 179 : lower = to_lower(raw)
1198 :
1199 179 : if (lower == "true" .or. lower == "yes") then
1200 26 : converted = "Yes"
1201 153 : else if (lower == "false" .or. lower == "no") then
1202 5 : converted = "No"
1203 148 : else if (lower == "null" .or. raw == "~") then
1204 2 : converted = ""
1205 : else
1206 146 : converted = raw
1207 : end if
1208 :
1209 180 : end function convert_yaml_scalar
1210 :
1211 :
1212 : !> Handle setting an attribute on a sibling node.
1213 27 : subroutine handle_attrib(table, sibling_name, attrib_val, applied)
1214 : type(hsd_table), intent(inout) :: table
1215 : character(len=*), intent(in) :: sibling_name
1216 : character(len=*), intent(in) :: attrib_val
1217 : logical, intent(out) :: applied
1218 :
1219 27 : integer :: ii
1220 :
1221 27 : applied = .false.
1222 :
1223 27 : do ii = table%num_children, 1, -1
1224 26 : if (.not. associated(table%children(ii)%node)) cycle
1225 1 : select type (child => table%children(ii)%node)
1226 : type is (hsd_table)
1227 3 : if (allocated(child%name)) then
1228 3 : if (child%name == sibling_name) then
1229 3 : child%attrib = attrib_val
1230 3 : applied = .true.
1231 26 : return
1232 : end if
1233 : end if
1234 : type is (hsd_value)
1235 23 : if (allocated(child%name)) then
1236 23 : if (child%name == sibling_name) then
1237 23 : child%attrib = attrib_val
1238 23 : applied = .true.
1239 23 : return
1240 : end if
1241 : end if
1242 : end select
1243 : end do
1244 :
1245 206 : end subroutine handle_attrib
1246 :
1247 :
1248 : !> Apply a deferred attribute to a named sibling in the table.
1249 1 : subroutine apply_deferred_attrib(table, sibling_name, attrib_val)
1250 : type(hsd_table), intent(inout) :: table
1251 : character(len=*), intent(in) :: sibling_name, attrib_val
1252 :
1253 1 : integer :: ii
1254 :
1255 1 : do ii = table%num_children, 1, -1
1256 1 : if (.not. associated(table%children(ii)%node)) cycle
1257 0 : select type (child => table%children(ii)%node)
1258 : type is (hsd_table)
1259 0 : if (allocated(child%name)) then
1260 0 : if (child%name == sibling_name) then
1261 0 : child%attrib = attrib_val
1262 1 : return
1263 : end if
1264 : end if
1265 : type is (hsd_value)
1266 1 : if (allocated(child%name)) then
1267 1 : if (child%name == sibling_name) then
1268 1 : child%attrib = attrib_val
1269 1 : return
1270 : end if
1271 : end if
1272 : end select
1273 : end do
1274 :
1275 28 : end subroutine apply_deferred_attrib
1276 :
1277 :
1278 : ! ─── Complex-value detection ───
1279 :
1280 : !> Check whether a table represents a complex number.
1281 116 : function is_complex_object(table) result(is_cpx)
1282 : type(hsd_table), intent(in) :: table
1283 : logical :: is_cpx
1284 :
1285 : class(hsd_node), pointer :: re_node, im_node
1286 :
1287 116 : is_cpx = .false.
1288 113 : if (table%num_children /= 2) return
1289 :
1290 31 : call table%get_child_by_name("re", re_node)
1291 31 : if (.not. associated(re_node)) return
1292 3 : call table%get_child_by_name("im", im_node)
1293 3 : if (.not. associated(im_node)) return
1294 :
1295 : select type (re_node)
1296 : type is (hsd_value)
1297 3 : select type (im_node)
1298 : type is (hsd_value)
1299 3 : is_cpx = .true.
1300 : end select
1301 : end select
1302 :
1303 117 : end function is_complex_object
1304 :
1305 : !> Extract a complex value from a table with "re" and "im" children.
1306 3 : function complex_from_table(table) result(val)
1307 : type(hsd_table), intent(in) :: table
1308 : complex(dp) :: val
1309 :
1310 : class(hsd_node), pointer :: re_node, im_node
1311 3 : real(dp) :: re_part, im_part
1312 3 : integer :: ios
1313 :
1314 3 : re_part = 0.0_dp
1315 3 : im_part = 0.0_dp
1316 :
1317 3 : call table%get_child_by_name("re", re_node)
1318 3 : call table%get_child_by_name("im", im_node)
1319 :
1320 : select type (re_node)
1321 : type is (hsd_value)
1322 3 : if (allocated(re_node%string_value)) then
1323 3 : read(re_node%string_value, *, iostat=ios) re_part
1324 : end if
1325 : end select
1326 :
1327 : select type (im_node)
1328 : type is (hsd_value)
1329 3 : if (allocated(im_node%string_value)) then
1330 3 : read(im_node%string_value, *, iostat=ios) im_part
1331 : end if
1332 : end select
1333 :
1334 3 : val = cmplx(re_part, im_part, dp)
1335 :
1336 119 : end function complex_from_table
1337 :
1338 :
1339 : ! ─── Utility routines ───
1340 :
1341 : !> Get the indent level (number of leading spaces) of the line containing pos.
1342 : !> Assumes pos is at or past the leading whitespace.
1343 498 : function get_line_indent(src, src_len, pos) result(indent)
1344 : character(len=*), intent(in) :: src
1345 : integer, intent(in) :: src_len, pos
1346 : integer :: indent
1347 :
1348 498 : integer :: ll
1349 :
1350 : ! Find start of current line
1351 498 : ll = pos
1352 1874 : do while (ll > 1)
1353 1838 : if (src(ll - 1:ll - 1) == new_line("a") .or. iachar(src(ll - 1:ll - 1)) == 13) exit
1354 1376 : ll = ll - 1
1355 : end do
1356 :
1357 : ! Count leading spaces
1358 498 : indent = 0
1359 1874 : do while (ll + indent <= src_len .and. src(ll + indent:ll + indent) == " ")
1360 1376 : indent = indent + 1
1361 : end do
1362 :
1363 501 : end function get_line_indent
1364 :
1365 :
1366 : !> Skip whitespace and comments (block context).
1367 606 : subroutine skip_ws_and_comments(src, src_len, pos)
1368 : character(len=*), intent(in) :: src
1369 : integer, intent(in) :: src_len
1370 : integer, intent(inout) :: pos
1371 :
1372 1441 : do while (pos <= src_len)
1373 1375 : select case (iachar(src(pos:pos)))
1374 : case (32, 9, 10, 13) ! space, tab, LF, CR
1375 833 : pos = pos + 1
1376 : case (35) ! '#' — comment
1377 32 : do while (pos <= src_len .and. .not. is_eol_at(src, src_len, pos))
1378 30 : pos = pos + 1
1379 : end do
1380 : case default
1381 1375 : return
1382 : end select
1383 : end do
1384 :
1385 1104 : end subroutine skip_ws_and_comments
1386 :
1387 :
1388 : !> Skip whitespace in flow context (including newlines).
1389 151 : subroutine skip_flow_ws(src, src_len, pos)
1390 : character(len=*), intent(in) :: src
1391 : integer, intent(in) :: src_len
1392 : integer, intent(inout) :: pos
1393 :
1394 194 : do while (pos <= src_len)
1395 194 : select case (iachar(src(pos:pos)))
1396 : case (32, 9, 10, 13)
1397 43 : pos = pos + 1
1398 : case (35) ! comment
1399 0 : do while (pos <= src_len .and. .not. is_eol_at(src, src_len, pos))
1400 0 : pos = pos + 1
1401 : end do
1402 : case default
1403 194 : return
1404 : end select
1405 : end do
1406 :
1407 757 : end subroutine skip_flow_ws
1408 :
1409 :
1410 : !> Skip inline whitespace only (space, tab).
1411 304 : subroutine skip_inline_ws(src, src_len, pos)
1412 : character(len=*), intent(in) :: src
1413 : integer, intent(in) :: src_len
1414 : integer, intent(inout) :: pos
1415 :
1416 489 : do while (pos <= src_len)
1417 489 : if (src(pos:pos) == " " .or. src(pos:pos) == achar(9)) then
1418 185 : pos = pos + 1
1419 : else
1420 304 : return
1421 : end if
1422 : end do
1423 :
1424 455 : end subroutine skip_inline_ws
1425 :
1426 :
1427 : !> Skip inline whitespace at a given position (does not modify pos).
1428 1 : subroutine skip_inline_ws_at(src, src_len, pos)
1429 : character(len=*), intent(in) :: src
1430 : integer, intent(in) :: src_len
1431 : integer, intent(inout) :: pos
1432 :
1433 2 : do while (pos <= src_len)
1434 2 : if (src(pos:pos) == " " .or. src(pos:pos) == achar(9)) then
1435 1 : pos = pos + 1
1436 : else
1437 1 : return
1438 : end if
1439 : end do
1440 :
1441 305 : end subroutine skip_inline_ws_at
1442 :
1443 :
1444 : !> Skip to end of line.
1445 297 : subroutine skip_to_eol(src, src_len, pos)
1446 : character(len=*), intent(in) :: src
1447 : integer, intent(in) :: src_len
1448 : integer, intent(inout) :: pos
1449 :
1450 313 : do while (pos <= src_len)
1451 300 : if (is_eol_at(src, src_len, pos)) then
1452 284 : call skip_eol(src, src_len, pos)
1453 284 : return
1454 : end if
1455 16 : pos = pos + 1
1456 : end do
1457 :
1458 298 : end subroutine skip_to_eol
1459 :
1460 :
1461 : !> Skip past EOL characters.
1462 290 : subroutine skip_eol(src, src_len, pos)
1463 : character(len=*), intent(in) :: src
1464 : integer, intent(in) :: src_len
1465 : integer, intent(inout) :: pos
1466 :
1467 2 : if (pos > src_len) return
1468 288 : if (iachar(src(pos:pos)) == 13) then ! CR
1469 0 : pos = pos + 1
1470 0 : if (pos <= src_len .and. iachar(src(pos:pos)) == 10) pos = pos + 1 ! LF
1471 288 : else if (iachar(src(pos:pos)) == 10) then ! LF
1472 288 : pos = pos + 1
1473 : end if
1474 :
1475 587 : end subroutine skip_eol
1476 :
1477 :
1478 : !> Check if position is at end of line.
1479 305 : function is_eol(src, src_len, pos) result(at_eol)
1480 : character(len=*), intent(in) :: src
1481 : integer, intent(in) :: src_len, pos
1482 : logical :: at_eol
1483 :
1484 305 : if (pos > src_len) then
1485 0 : at_eol = .true.
1486 0 : return
1487 : end if
1488 305 : at_eol = (iachar(src(pos:pos)) == 10 .or. iachar(src(pos:pos)) == 13)
1489 :
1490 595 : end function is_eol
1491 :
1492 :
1493 : !> Check if position is at end of line (same as is_eol, named for clarity).
1494 4218 : function is_eol_at(src, src_len, pos) result(at_eol)
1495 : character(len=*), intent(in) :: src
1496 : integer, intent(in) :: src_len, pos
1497 : logical :: at_eol
1498 :
1499 4218 : if (pos > src_len) then
1500 2 : at_eol = .true.
1501 2 : return
1502 : end if
1503 4216 : at_eol = (iachar(src(pos:pos)) == 10 .or. iachar(src(pos:pos)) == 13)
1504 :
1505 4523 : end function is_eol_at
1506 :
1507 :
1508 : !> Check if a line starting at pos looks like a mapping key line (has key: pattern).
1509 1 : function is_mapping_key_line(src, src_len, pos) result(is_key)
1510 : character(len=*), intent(in) :: src
1511 : integer, intent(in) :: src_len, pos
1512 : logical :: is_key
1513 :
1514 1 : integer :: ii
1515 :
1516 1 : is_key = .false.
1517 1 : ii = pos
1518 :
1519 : ! Skip to find ':'
1520 3 : do while (ii <= src_len)
1521 3 : if (is_eol_at(src, src_len, ii)) return
1522 2 : if (src(ii:ii) == ":") then
1523 : if (ii + 1 > src_len .or. src(ii + 1:ii + 1) == " " &
1524 0 : & .or. is_eol_at(src, src_len, ii + 1)) then
1525 0 : is_key = .true.
1526 0 : return
1527 : end if
1528 : end if
1529 2 : ii = ii + 1
1530 : end do
1531 :
1532 4219 : end function is_mapping_key_line
1533 :
1534 :
1535 : !> Skip over a flow value (for ignoring attrib values that are mappings).
1536 0 : recursive subroutine skip_flow_value(src, src_len, pos)
1537 : character(len=*), intent(in) :: src
1538 : integer, intent(in) :: src_len
1539 : integer, intent(inout) :: pos
1540 :
1541 0 : integer :: depth
1542 :
1543 0 : if (pos > src_len) return
1544 :
1545 0 : if (src(pos:pos) == "{") then
1546 0 : depth = 1
1547 0 : pos = pos + 1
1548 0 : do while (pos <= src_len .and. depth > 0)
1549 0 : if (src(pos:pos) == "{") depth = depth + 1
1550 0 : if (src(pos:pos) == "}") depth = depth - 1
1551 0 : pos = pos + 1
1552 : end do
1553 0 : else if (src(pos:pos) == "[") then
1554 0 : depth = 1
1555 0 : pos = pos + 1
1556 0 : do while (pos <= src_len .and. depth > 0)
1557 0 : if (src(pos:pos) == "[") depth = depth + 1
1558 0 : if (src(pos:pos) == "]") depth = depth - 1
1559 0 : pos = pos + 1
1560 : end do
1561 0 : else if (src(pos:pos) == '"') then
1562 0 : pos = pos + 1
1563 0 : do while (pos <= src_len)
1564 0 : if (src(pos:pos) == '"') then
1565 0 : pos = pos + 1
1566 0 : return
1567 : end if
1568 0 : if (src(pos:pos) == "\") pos = pos + 1
1569 0 : pos = pos + 1
1570 : end do
1571 0 : else if (src(pos:pos) == "'") then
1572 0 : pos = pos + 1
1573 0 : do while (pos <= src_len)
1574 0 : if (src(pos:pos) == "'") then
1575 0 : if (pos + 1 <= src_len) then
1576 0 : if (src(pos + 1:pos + 1) == "'") then
1577 0 : pos = pos + 2
1578 0 : cycle
1579 : end if
1580 : end if
1581 0 : pos = pos + 1
1582 0 : return
1583 : else
1584 0 : pos = pos + 1
1585 : end if
1586 : end do
1587 : else
1588 : ! Plain scalar in flow context
1589 0 : do while (pos <= src_len)
1590 0 : if (src(pos:pos) == "," .or. src(pos:pos) == "}" &
1591 0 : & .or. src(pos:pos) == "]") return
1592 0 : pos = pos + 1
1593 : end do
1594 : end if
1595 :
1596 1 : end subroutine skip_flow_value
1597 :
1598 :
1599 : !> Create a parse error.
1600 1 : subroutine make_error(error, msg, fname, pos)
1601 : type(hsd_error_t), allocatable, intent(out), optional :: error
1602 : character(len=*), intent(in) :: msg, fname
1603 : integer, intent(in) :: pos
1604 :
1605 : character(len=20) :: pos_str
1606 :
1607 0 : if (.not. present(error)) return
1608 :
1609 1 : write(pos_str, "(i0)") pos
1610 1 : allocate(error)
1611 1 : error%code = HSD_STAT_SYNTAX_ERROR
1612 1 : error%message = trim(fname) // " pos " // trim(pos_str) // ": " // msg
1613 :
1614 1 : end subroutine make_error
1615 :
1616 :
1617 : !> Convert a string to lowercase (ASCII only).
1618 179 : pure function to_lower(str) result(lower)
1619 : character(len=*), intent(in) :: str
1620 : character(len=:), allocatable :: lower
1621 :
1622 179 : integer :: ii, ic
1623 :
1624 179 : allocate(character(len=len(str)) :: lower)
1625 1739 : do ii = 1, len(str)
1626 1560 : ic = iachar(str(ii:ii))
1627 1739 : if (ic >= iachar("A") .and. ic <= iachar("Z")) then
1628 70 : lower(ii:ii) = achar(ic + 32)
1629 : else
1630 1490 : lower(ii:ii) = str(ii:ii)
1631 : end if
1632 : end do
1633 :
1634 1 : end function to_lower
1635 :
1636 :
1637 : !> Trim trailing whitespace from a string.
1638 441 : pure function trim_right(str) result(trimmed)
1639 : character(len=*), intent(in) :: str
1640 : character(len=:), allocatable :: trimmed
1641 :
1642 441 : integer :: last
1643 :
1644 441 : last = len(str)
1645 443 : do while (last > 0)
1646 443 : if (str(last:last) /= " " .and. str(last:last) /= achar(9)) exit
1647 2 : last = last - 1
1648 : end do
1649 :
1650 441 : if (last > 0) then
1651 441 : trimmed = str(1:last)
1652 : else
1653 0 : trimmed = ""
1654 : end if
1655 :
1656 620 : end function trim_right
1657 :
1658 1223 : end module hsd_data_yaml_parser
|
