Line data Source code
1 : !> JSON parser: read JSON text into an hsd_table tree.
2 : !>
3 : !> Implements a recursive-descent parser for RFC 8259 JSON.
4 : !> Mapping (per SPECIFICATION.md §3.3):
5 : !> JSON object → hsd_table (keys become child names)
6 : !> JSON number → hsd_value (integer or real)
7 : !> JSON string → hsd_value (string)
8 : !> JSON boolean → hsd_value (logical)
9 : !> JSON null → hsd_value (empty string)
10 : !> JSON array → hsd_value (string of space-separated elements)
11 : !> "key__attrib" → attrib on sibling "key"
12 : !> "_value" → anonymous value
13 : module hsd_data_json_parser
14 : use hsd, only: hsd_table, hsd_value, hsd_node, hsd_error_t, new_table, &
15 : & new_value, HSD_STAT_SYNTAX_ERROR, HSD_STAT_IO_ERROR, dp
16 : use hsd_data_json_escape, only: json_unescape_string
17 : implicit none(type, external)
18 : private
19 :
20 : public :: json_parse_file, json_parse_string
21 :
22 : !> Suffix for attribute sibling keys (must match writer)
23 : character(len=*), parameter :: ATTRIB_SUFFIX = "__attrib"
24 :
25 : !> Key for anonymous values (must match writer)
26 : character(len=*), parameter :: ANON_VALUE_KEY = "_value"
27 :
28 : contains
29 :
30 : !> Parse a JSON file into an hsd_table tree.
31 68 : subroutine json_parse_file(filename, root, error)
32 : character(len=*), intent(in) :: filename
33 : type(hsd_table), intent(out) :: root
34 : type(hsd_error_t), allocatable, intent(out), optional :: error
35 :
36 34 : character(len=:), allocatable :: source
37 34 : integer :: unit_num, ios, file_size
38 :
39 34 : inquire(file=filename, size=file_size)
40 34 : if (file_size < 0) then
41 0 : if (present(error)) then
42 0 : allocate(error)
43 0 : error%code = HSD_STAT_IO_ERROR
44 0 : error%message = "Cannot determine size of file: " // trim(filename)
45 : end if
46 0 : return
47 : end if
48 :
49 34 : allocate(character(len=file_size) :: source)
50 : open(newunit=unit_num, file=filename, status="old", access="stream", &
51 34 : & form="unformatted", action="read", iostat=ios)
52 34 : if (ios /= 0) then
53 0 : if (present(error)) then
54 0 : allocate(error)
55 0 : error%code = HSD_STAT_IO_ERROR
56 0 : error%message = "Cannot open file: " // trim(filename)
57 : end if
58 0 : return
59 : end if
60 34 : read(unit_num, iostat=ios) source
61 34 : close(unit_num)
62 34 : if (ios /= 0) then
63 0 : if (present(error)) then
64 0 : allocate(error)
65 0 : error%code = HSD_STAT_IO_ERROR
66 0 : error%message = "Cannot read file: " // trim(filename)
67 : end if
68 0 : return
69 : end if
70 :
71 34 : call json_parse_string(source, root, error, filename)
72 :
73 34 : end subroutine json_parse_file
74 :
75 : !> Parse a JSON string into an hsd_table tree.
76 : !> The top-level JSON value must be an object.
77 188 : subroutine json_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 94 : integer :: pos, src_len
84 94 : character(len=:), allocatable :: fname
85 :
86 94 : if (present(filename)) then
87 34 : fname = filename
88 : else
89 60 : fname = "<string>"
90 : end if
91 :
92 94 : call new_table(root)
93 :
94 94 : src_len = len_trim(source)
95 94 : pos = 1
96 :
97 94 : call skip_ws(source, src_len, pos)
98 :
99 94 : if (pos > src_len) return ! Empty input → empty root
100 :
101 93 : if (source(pos:pos) /= "{") then
102 0 : call make_error(error, "Expected '{' at start of JSON", fname, pos)
103 0 : return
104 : end if
105 :
106 : ! Parse the top-level object directly into root (unwrap)
107 93 : call parse_object_members(source, src_len, pos, root, error, fname)
108 :
109 128 : end subroutine json_parse_string
110 :
111 : !> Parse a JSON object: { "key": value, ... }
112 : !> On entry, pos is at '{'. On exit, pos is after '}'.
113 : !> Members are added as children of `table`.
114 636 : recursive subroutine parse_object_members(src, src_len, pos, table, &
115 : & error, fname)
116 : character(len=*), intent(in) :: src
117 : integer, intent(in) :: src_len
118 : integer, intent(inout) :: pos
119 : type(hsd_table), intent(inout) :: table
120 : type(hsd_error_t), allocatable, intent(out), optional :: error
121 : character(len=*), intent(in) :: fname
122 :
123 636 : character(len=:), allocatable :: key, deferred_val
124 636 : integer :: attrib_check, ii
125 :
126 : ! Deferred attrib storage for forward-referenced __attrib keys
127 : integer, parameter :: MAX_DEFERRED = 64
128 : character(len=256) :: def_names(MAX_DEFERRED), def_vals(MAX_DEFERRED)
129 636 : integer :: ndef
130 636 : logical :: is_attrib, applied
131 :
132 636 : ndef = 0
133 :
134 : ! Skip '{'
135 636 : pos = pos + 1
136 636 : call skip_ws(src, src_len, pos)
137 :
138 : ! Empty object
139 636 : if (pos <= src_len .and. src(pos:pos) == "}") then
140 2 : pos = pos + 1
141 2 : return
142 : end if
143 :
144 2005 : do
145 : ! Read key
146 2005 : if (pos > src_len .or. src(pos:pos) /= '"') then
147 0 : call make_error(error, 'Expected ''"'' for object key', fname, pos)
148 0 : return
149 : end if
150 2005 : call parse_json_string(src, src_len, pos, key, error, fname)
151 2005 : if (allocated(error)) return
152 :
153 : ! Expect ':'
154 2005 : call skip_ws(src, src_len, pos)
155 2005 : if (pos > src_len .or. src(pos:pos) /= ":") then
156 0 : call make_error(error, "Expected ':' after object key", fname, pos)
157 0 : return
158 : end if
159 2005 : pos = pos + 1
160 2005 : call skip_ws(src, src_len, pos)
161 :
162 : ! Check if this is an attribute key (ends with __attrib)
163 2005 : is_attrib = .false.
164 2005 : attrib_check = len(key) - len(ATTRIB_SUFFIX)
165 2005 : if (attrib_check > 0) then
166 1454 : is_attrib = (key(attrib_check + 1:len(key)) == ATTRIB_SUFFIX)
167 : end if
168 3948 : if (is_attrib) then
169 : call parse_attrib_value(src, src_len, pos, table, &
170 62 : & key(1:attrib_check), error, fname, applied, deferred_val)
171 62 : if (allocated(error)) return
172 : ! If sibling not found yet, defer for later application
173 : if (.not. applied .and. ndef < MAX_DEFERRED &
174 62 : & .and. allocated(deferred_val)) then
175 1 : ndef = ndef + 1
176 1 : def_names(ndef) = ""
177 1 : def_names(ndef)(1:attrib_check) = key(1:attrib_check)
178 1 : def_vals(ndef) = ""
179 1 : def_vals(ndef)(1:len(deferred_val)) = deferred_val
180 : end if
181 : else
182 : ! Parse value and add as child
183 1943 : call parse_member_value(src, src_len, pos, table, key, error, fname)
184 1943 : if (allocated(error)) return
185 : end if
186 :
187 2005 : call skip_ws(src, src_len, pos)
188 :
189 : ! Check for comma or closing brace
190 2005 : if (pos > src_len) then
191 0 : call make_error(error, "Unexpected end of input in object", fname, pos)
192 0 : return
193 : end if
194 :
195 2005 : if (src(pos:pos) == "}") then
196 634 : pos = pos + 1
197 634 : exit
198 1371 : else if (src(pos:pos) == ",") then
199 1371 : pos = pos + 1
200 1371 : call skip_ws(src, src_len, pos)
201 : else
202 0 : call make_error(error, "Expected ',' or '}' in object", fname, pos)
203 0 : return
204 : end if
205 : end do
206 :
207 : ! Apply any deferred attribs (for __attrib keys that appeared before sibling)
208 635 : do ii = 1, ndef
209 1 : call apply_deferred_attrib(table, trim(def_names(ii)), &
210 636 : & trim(def_vals(ii)))
211 : end do
212 :
213 1366 : end subroutine parse_object_members
214 :
215 : !> Parse a JSON value and add it as a child of table with the given key.
216 1943 : recursive subroutine parse_member_value(src, src_len, pos, table, key, &
217 : & error, fname)
218 : character(len=*), intent(in) :: src
219 : integer, intent(in) :: src_len
220 : integer, intent(inout) :: pos
221 : type(hsd_table), intent(inout) :: table
222 : character(len=*), intent(in) :: key
223 : type(hsd_error_t), allocatable, intent(out), optional :: error
224 : character(len=*), intent(in) :: fname
225 :
226 1943 : type(hsd_table), allocatable :: child_table
227 1943 : type(hsd_value), allocatable :: child_value
228 1943 : character(len=:), allocatable :: str_val, child_name
229 :
230 0 : if (pos > src_len) then
231 0 : call make_error(error, "Unexpected end of input", fname, pos)
232 0 : return
233 : end if
234 :
235 : ! Determine the name for the child
236 1943 : if (key == ANON_VALUE_KEY) then
237 24 : child_name = ""
238 : else
239 1919 : child_name = key
240 : end if
241 :
242 1943 : select case (src(pos:pos))
243 : case ("{")
244 : ! Object → hsd_table (or complex value if {"re": ..., "im": ...})
245 539 : allocate(child_table)
246 539 : call new_table(child_table, name=child_name)
247 539 : call parse_object_members(src, src_len, pos, child_table, error, fname)
248 539 : if (allocated(error)) return
249 1083 : if (is_complex_object(child_table)) then
250 5 : allocate(child_value)
251 5 : call new_value(child_value, name=child_name)
252 5 : call child_value%set_complex(complex_from_table(child_table))
253 5 : call table%add_child(child_value)
254 : else
255 534 : call table%add_child(child_table)
256 : end if
257 :
258 : case ("[")
259 : ! Array: peek to determine if it contains objects
260 138 : if (array_contains_objects(src, src_len, pos)) then
261 : ! Array of objects → multiple same-named children
262 2 : call parse_object_array(src, src_len, pos, table, child_name, &
263 2 : & error, fname)
264 2 : if (allocated(error)) return
265 : else
266 : ! Array of scalars → flatten to space-separated string value
267 33 : call parse_array_to_string(src, src_len, pos, str_val, error, fname)
268 33 : if (allocated(error)) return
269 33 : allocate(child_value)
270 33 : call new_value(child_value, name=child_name)
271 33 : call child_value%set_raw(str_val)
272 33 : call table%add_child(child_value)
273 : end if
274 :
275 : case ('"')
276 : ! String
277 233 : call parse_json_string(src, src_len, pos, str_val, error, fname)
278 233 : if (allocated(error)) return
279 233 : allocate(child_value)
280 233 : call new_value(child_value, name=child_name)
281 233 : call child_value%set_string(str_val)
282 233 : call table%add_child(child_value)
283 :
284 : case ("t", "f")
285 : ! Boolean — store as string for hsd_get compatibility
286 27 : allocate(child_value)
287 27 : call new_value(child_value, name=child_name)
288 27 : if (pos + 3 <= src_len .and. src(pos:pos + 3) == "true") then
289 23 : call child_value%set_string("Yes")
290 23 : pos = pos + 4
291 4 : else if (pos + 4 <= src_len .and. src(pos:pos + 4) == "false") then
292 4 : call child_value%set_string("No")
293 4 : pos = pos + 5
294 : else
295 0 : call make_error(error, "Invalid literal", fname, pos)
296 0 : return
297 : end if
298 27 : call table%add_child(child_value)
299 :
300 : case ("n")
301 : ! null → empty string value
302 3 : if (pos + 3 <= src_len .and. src(pos:pos + 3) == "null") then
303 1 : pos = pos + 4
304 1 : allocate(child_value)
305 1 : call new_value(child_value, name=child_name)
306 1 : call child_value%set_string("")
307 1 : call table%add_child(child_value)
308 : else
309 0 : call make_error(error, "Invalid literal", fname, pos)
310 0 : return
311 : end if
312 :
313 : case default
314 : ! Number (integer or real)
315 1108 : call parse_number_value(src, src_len, pos, table, child_name, &
316 1108 : & error, fname)
317 4622 : if (allocated(error)) return
318 : end select
319 :
320 14468 : end subroutine parse_member_value
321 :
322 : !> Parse an attribute value and attach it to the sibling node.
323 62 : recursive subroutine parse_attrib_value(src, src_len, pos, table, &
324 : & sibling_name, error, fname, applied, parsed_val)
325 : character(len=*), intent(in) :: src
326 : integer, intent(in) :: src_len
327 : integer, intent(inout) :: pos
328 : type(hsd_table), intent(inout) :: table
329 : character(len=*), intent(in) :: sibling_name
330 : type(hsd_error_t), allocatable, intent(out), optional :: error
331 : character(len=*), intent(in) :: fname
332 : logical, intent(out), optional :: applied
333 : character(len=:), allocatable, intent(out), optional :: parsed_val
334 :
335 62 : character(len=:), allocatable :: attrib_val
336 62 : integer :: ii
337 :
338 62 : if (present(applied)) applied = .false.
339 :
340 : ! Parse the value as a string
341 62 : if (pos > src_len .or. src(pos:pos) /= '"') then
342 : ! Skip non-string attrib values
343 0 : call skip_json_value(src, src_len, pos, error, fname)
344 0 : if (present(applied)) applied = .true. ! consumed, nothing to defer
345 0 : return
346 : end if
347 :
348 62 : call parse_json_string(src, src_len, pos, attrib_val, error, fname)
349 62 : if (allocated(error)) return
350 :
351 : ! Find the sibling and set its attrib
352 62 : do ii = table%num_children, 1, -1
353 61 : if (.not. associated(table%children(ii)%node)) cycle
354 1 : select type (child => table%children(ii)%node)
355 : type is (hsd_table)
356 10 : if (allocated(child%name)) then
357 10 : if (child%name == sibling_name) then
358 10 : child%attrib = attrib_val
359 10 : if (present(applied)) applied = .true.
360 61 : return
361 : end if
362 : end if
363 : type is (hsd_value)
364 51 : if (allocated(child%name)) then
365 51 : if (child%name == sibling_name) then
366 51 : child%attrib = attrib_val
367 51 : if (present(applied)) applied = .true.
368 51 : return
369 : end if
370 : end if
371 : end select
372 : end do
373 :
374 : ! Sibling not found — return parsed value for deferral
375 1 : if (present(parsed_val)) parsed_val = attrib_val
376 :
377 124 : end subroutine parse_attrib_value
378 :
379 : !> Apply a deferred attribute to a named sibling in the table.
380 1 : subroutine apply_deferred_attrib(table, sibling_name, attrib_val)
381 : type(hsd_table), intent(inout) :: table
382 : character(len=*), intent(in) :: sibling_name, attrib_val
383 :
384 1 : integer :: ii
385 :
386 1 : do ii = table%num_children, 1, -1
387 1 : if (.not. associated(table%children(ii)%node)) cycle
388 0 : select type (child => table%children(ii)%node)
389 : type is (hsd_table)
390 0 : if (allocated(child%name)) then
391 0 : if (child%name == sibling_name) then
392 0 : child%attrib = attrib_val
393 1 : return
394 : end if
395 : end if
396 : type is (hsd_value)
397 1 : if (allocated(child%name)) then
398 1 : if (child%name == sibling_name) then
399 1 : child%attrib = attrib_val
400 1 : return
401 : end if
402 : end if
403 : end select
404 : end do
405 :
406 1 : end subroutine apply_deferred_attrib
407 :
408 : !> Parse a JSON string (including surrounding quotes).
409 2308 : subroutine parse_json_string(src, src_len, pos, val, error, fname)
410 : character(len=*), intent(in) :: src
411 : integer, intent(in) :: src_len
412 : integer, intent(inout) :: pos
413 : character(len=:), allocatable, intent(out) :: val
414 : type(hsd_error_t), allocatable, intent(out), optional :: error
415 : character(len=*), intent(in) :: fname
416 :
417 2308 : integer :: start_pos
418 :
419 : ! Skip opening quote
420 2308 : pos = pos + 1
421 2308 : start_pos = pos
422 :
423 682302 : do while (pos <= src_len)
424 682302 : if (src(pos:pos) == '"') then
425 2308 : val = json_unescape_string(src(start_pos:pos - 1))
426 2308 : pos = pos + 1 ! skip closing quote
427 2308 : return
428 679994 : else if (src(pos:pos) == "\") then
429 89 : pos = pos + 2 ! skip escape sequence
430 : else
431 679905 : pos = pos + 1
432 : end if
433 : end do
434 :
435 0 : call make_error(error, "Unterminated string", fname, pos)
436 :
437 2309 : end subroutine parse_json_string
438 :
439 : !> Parse a JSON number and add as integer or real value.
440 1108 : subroutine parse_number_value(src, src_len, pos, table, name, &
441 : & error, fname)
442 : character(len=*), intent(in) :: src
443 : integer, intent(in) :: src_len
444 : integer, intent(inout) :: pos
445 : type(hsd_table), intent(inout) :: table
446 : character(len=*), intent(in) :: name
447 : type(hsd_error_t), allocatable, intent(out), optional :: error
448 : character(len=*), intent(in) :: fname
449 :
450 1108 : integer :: start_pos
451 1108 : type(hsd_value), allocatable :: child_value
452 :
453 1108 : start_pos = pos
454 :
455 : ! Optional minus
456 1108 : if (pos <= src_len .and. src(pos:pos) == "-") pos = pos + 1
457 :
458 : ! Integer part
459 1108 : if (pos > src_len) then
460 0 : call make_error(error, "Expected number", fname, pos)
461 0 : return
462 : end if
463 :
464 1108 : if (src(pos:pos) == "0") then
465 18 : pos = pos + 1
466 1090 : else if (src(pos:pos) >= "1" .and. src(pos:pos) <= "9") then
467 4173 : do while (pos <= src_len .and. src(pos:pos) >= "0" .and. src(pos:pos) <= "9")
468 3083 : pos = pos + 1
469 : end do
470 : else
471 0 : call make_error(error, "Invalid number", fname, pos)
472 0 : return
473 : end if
474 :
475 : ! Optional fraction
476 1108 : if (pos <= src_len .and. src(pos:pos) == ".") then
477 1068 : pos = pos + 1
478 2368 : do while (pos <= src_len .and. src(pos:pos) >= "0" .and. src(pos:pos) <= "9")
479 1300 : pos = pos + 1
480 : end do
481 : end if
482 :
483 : ! Optional exponent
484 1108 : if (pos <= src_len .and. (src(pos:pos) == "e" .or. src(pos:pos) == "E")) then
485 4 : pos = pos + 1
486 4 : if (pos <= src_len .and. (src(pos:pos) == "+" .or. src(pos:pos) == "-")) then
487 4 : pos = pos + 1
488 : end if
489 8 : do while (pos <= src_len .and. src(pos:pos) >= "0" .and. src(pos:pos) <= "9")
490 4 : pos = pos + 1
491 : end do
492 : end if
493 :
494 1108 : allocate(child_value)
495 1108 : call new_value(child_value, name=name)
496 :
497 : ! Store as string for hsd_get compatibility (HSD values are text)
498 1108 : call child_value%set_string(src(start_pos:pos - 1))
499 :
500 1108 : call table%add_child(child_value)
501 :
502 3416 : end subroutine parse_number_value
503 :
504 : !> Check whether a JSON array's first element is an object.
505 : !> Does not advance pos.
506 35 : function array_contains_objects(src, src_len, pos) result(is_obj_array)
507 : character(len=*), intent(in) :: src
508 : integer, intent(in) :: src_len, pos
509 : logical :: is_obj_array
510 :
511 35 : integer :: peek
512 :
513 35 : is_obj_array = .false.
514 35 : peek = pos + 1 ! skip '['
515 :
516 : ! Skip whitespace
517 42 : do while (peek <= src_len)
518 42 : select case (iachar(src(peek:peek)))
519 : case (32, 9, 10, 13)
520 42 : peek = peek + 1
521 : case default
522 42 : exit
523 : end select
524 : end do
525 :
526 35 : if (peek <= src_len .and. src(peek:peek) == "{") then
527 2 : is_obj_array = .true.
528 : end if
529 :
530 1143 : end function array_contains_objects
531 :
532 : !> Parse a JSON array of objects into multiple same-named hsd_table children.
533 : !> On entry, pos is at '['. On exit, pos is after ']'.
534 2 : recursive subroutine parse_object_array(src, src_len, pos, table, name, &
535 : & error, fname)
536 : character(len=*), intent(in) :: src
537 : integer, intent(in) :: src_len
538 : integer, intent(inout) :: pos
539 : type(hsd_table), intent(inout) :: table
540 : character(len=*), intent(in) :: name
541 : type(hsd_error_t), allocatable, intent(out), optional :: error
542 : character(len=*), intent(in) :: fname
543 :
544 2 : type(hsd_table), allocatable :: child_table
545 :
546 : ! Skip '['
547 2 : pos = pos + 1
548 2 : call skip_ws(src, src_len, pos)
549 :
550 : ! Empty array
551 2 : if (pos <= src_len .and. src(pos:pos) == "]") then
552 0 : pos = pos + 1
553 0 : return
554 : end if
555 :
556 8 : do
557 4 : call skip_ws(src, src_len, pos)
558 4 : if (pos > src_len) then
559 0 : call make_error(error, "Unexpected end of input in array", fname, pos)
560 0 : return
561 : end if
562 :
563 4 : if (src(pos:pos) /= "{") then
564 0 : call make_error(error, "Expected '{' in array of objects", fname, pos)
565 0 : return
566 : end if
567 :
568 4 : allocate(child_table)
569 4 : call new_table(child_table, name=name)
570 4 : call parse_object_members(src, src_len, pos, child_table, error, fname)
571 4 : if (allocated(error)) return
572 4 : call table%add_child(child_table)
573 76 : deallocate(child_table)
574 :
575 4 : call skip_ws(src, src_len, pos)
576 4 : if (pos > src_len) then
577 0 : call make_error(error, "Unexpected end of input in array", fname, pos)
578 0 : return
579 : end if
580 :
581 4 : if (src(pos:pos) == "]") then
582 2 : pos = pos + 1
583 2 : return
584 2 : else if (src(pos:pos) == ",") then
585 2 : pos = pos + 1
586 : else
587 0 : call make_error(error, "Expected ',' or ']' in array", fname, pos)
588 0 : return
589 : end if
590 : end do
591 :
592 39 : end subroutine parse_object_array
593 :
594 : !> Parse a JSON array to a space-separated string.
595 : !> Nested arrays produce newline-separated rows.
596 1459 : recursive subroutine parse_array_to_string(src, src_len, pos, str_val, &
597 : & error, fname)
598 : character(len=*), intent(in) :: src
599 : integer, intent(in) :: src_len
600 : integer, intent(inout) :: pos
601 : character(len=:), allocatable, intent(out) :: str_val
602 : type(hsd_error_t), allocatable, intent(out), optional :: error
603 : character(len=*), intent(in) :: fname
604 :
605 82 : character(len=:), allocatable :: elem_str, sub_str
606 82 : logical :: first
607 :
608 : ! Skip '['
609 82 : pos = pos + 1
610 82 : call skip_ws(src, src_len, pos)
611 :
612 82 : str_val = ""
613 82 : first = .true.
614 :
615 : ! Empty array
616 82 : if (pos <= src_len .and. src(pos:pos) == "]") then
617 0 : pos = pos + 1
618 0 : return
619 : end if
620 :
621 185 : do
622 267 : call skip_ws(src, src_len, pos)
623 267 : if (pos > src_len) then
624 0 : call make_error(error, "Unexpected end of input in array", fname, pos)
625 0 : return
626 : end if
627 :
628 534 : if (src(pos:pos) == "[") then
629 : ! Nested array → newline-separated row
630 49 : call parse_array_to_string(src, src_len, pos, sub_str, error, fname)
631 49 : if (allocated(error)) return
632 49 : elem_str = sub_str
633 49 : if (first) then
634 20 : str_val = elem_str
635 : else
636 29 : str_val = str_val // new_line("a") // elem_str
637 : end if
638 : else
639 : ! Scalar element
640 218 : call parse_scalar_to_string(src, src_len, pos, elem_str, error, fname)
641 218 : if (allocated(error)) return
642 218 : if (first) then
643 62 : str_val = elem_str
644 : else
645 156 : str_val = str_val // " " // elem_str
646 : end if
647 : end if
648 267 : first = .false.
649 :
650 267 : call skip_ws(src, src_len, pos)
651 267 : if (pos > src_len) then
652 0 : call make_error(error, "Unexpected end of input in array", fname, pos)
653 0 : return
654 : end if
655 :
656 267 : if (src(pos:pos) == "]") then
657 82 : pos = pos + 1
658 82 : return
659 185 : else if (src(pos:pos) == ",") then
660 185 : pos = pos + 1
661 : else
662 0 : call make_error(error, "Expected ',' or ']' in array", fname, pos)
663 0 : return
664 : end if
665 : end do
666 :
667 164 : end subroutine parse_array_to_string
668 :
669 : !> Parse a scalar JSON value to its string representation.
670 218 : subroutine parse_scalar_to_string(src, src_len, pos, str_val, error, fname)
671 : character(len=*), intent(in) :: src
672 : integer, intent(in) :: src_len
673 : integer, intent(inout) :: pos
674 : character(len=:), allocatable, intent(out) :: str_val
675 : type(hsd_error_t), allocatable, intent(out), optional :: error
676 : character(len=*), intent(in) :: fname
677 :
678 218 : integer :: start_pos
679 :
680 0 : if (pos > src_len) then
681 0 : call make_error(error, "Unexpected end of input", fname, pos)
682 0 : return
683 : end if
684 :
685 218 : select case (src(pos:pos))
686 : case ('"')
687 8 : call parse_json_string(src, src_len, pos, str_val, error, fname)
688 : case ("t")
689 0 : if (pos + 3 <= src_len .and. src(pos:pos + 3) == "true") then
690 0 : str_val = "true"
691 0 : pos = pos + 4
692 : else
693 0 : call make_error(error, "Invalid literal", fname, pos)
694 : end if
695 : case ("f")
696 0 : if (pos + 4 <= src_len .and. src(pos:pos + 4) == "false") then
697 0 : str_val = "false"
698 0 : pos = pos + 5
699 : else
700 0 : call make_error(error, "Invalid literal", fname, pos)
701 : end if
702 : case ("n")
703 0 : if (pos + 3 <= src_len .and. src(pos:pos + 3) == "null") then
704 0 : str_val = ""
705 0 : pos = pos + 4
706 : else
707 0 : call make_error(error, "Invalid literal", fname, pos)
708 : end if
709 : case default
710 : ! Number: grab the raw text
711 210 : start_pos = pos
712 210 : if (pos <= src_len .and. src(pos:pos) == "-") pos = pos + 1
713 630 : do while (pos <= src_len .and. &
714 420 : & (src(pos:pos) >= "0" .and. src(pos:pos) <= "9"))
715 210 : pos = pos + 1
716 : end do
717 210 : if (pos <= src_len .and. src(pos:pos) == ".") then
718 142 : pos = pos + 1
719 1672 : do while (pos <= src_len .and. &
720 907 : & (src(pos:pos) >= "0" .and. src(pos:pos) <= "9"))
721 765 : pos = pos + 1
722 : end do
723 : end if
724 840 : if (pos <= src_len .and. &
725 840 : & (src(pos:pos) == "e" .or. src(pos:pos) == "E")) then
726 0 : pos = pos + 1
727 0 : if (pos <= src_len .and. &
728 0 : & (src(pos:pos) == "+" .or. src(pos:pos) == "-")) pos = pos + 1
729 0 : do while (pos <= src_len .and. &
730 0 : & (src(pos:pos) >= "0" .and. src(pos:pos) <= "9"))
731 0 : pos = pos + 1
732 : end do
733 : end if
734 436 : if (pos > start_pos) then
735 210 : str_val = src(start_pos:pos - 1)
736 : else
737 0 : call make_error(error, "Expected value", fname, pos)
738 : end if
739 : end select
740 :
741 218 : end subroutine parse_scalar_to_string
742 :
743 : !> Skip over a JSON value (used to discard unknown constructs).
744 0 : recursive subroutine skip_json_value(src, src_len, pos, error, fname)
745 : character(len=*), intent(in) :: src
746 : integer, intent(in) :: src_len
747 : integer, intent(inout) :: pos
748 : type(hsd_error_t), allocatable, intent(out), optional :: error
749 : character(len=*), intent(in) :: fname
750 :
751 0 : character(len=:), allocatable :: dummy
752 :
753 0 : if (pos > src_len) return
754 :
755 0 : select case (src(pos:pos))
756 : case ('"')
757 0 : call parse_json_string(src, src_len, pos, dummy, error, fname)
758 : case ("{")
759 0 : call skip_json_object(src, src_len, pos, error, fname)
760 : case ("[")
761 0 : call skip_json_array(src, src_len, pos, error, fname)
762 : case default
763 : ! Number or literal
764 0 : do while (pos <= src_len .and. &
765 0 : & src(pos:pos) /= "," .and. src(pos:pos) /= "}" .and. &
766 0 : & src(pos:pos) /= "]" .and. src(pos:pos) /= " " .and. &
767 0 : & iachar(src(pos:pos)) /= 10 .and. iachar(src(pos:pos)) /= 13 .and. &
768 0 : & iachar(src(pos:pos)) /= 9)
769 0 : pos = pos + 1
770 : end do
771 : end select
772 :
773 218 : end subroutine skip_json_value
774 :
775 : !> Skip a JSON object.
776 0 : recursive subroutine skip_json_object(src, src_len, pos, error, fname)
777 : character(len=*), intent(in) :: src
778 : integer, intent(in) :: src_len
779 : integer, intent(inout) :: pos
780 : type(hsd_error_t), allocatable, intent(out), optional :: error
781 : character(len=*), intent(in) :: fname
782 :
783 0 : character(len=:), allocatable :: dummy
784 :
785 0 : pos = pos + 1 ! skip '{'
786 0 : call skip_ws(src, src_len, pos)
787 0 : if (pos <= src_len .and. src(pos:pos) == "}") then
788 0 : pos = pos + 1
789 0 : return
790 : end if
791 :
792 0 : do
793 : ! Skip key
794 0 : if (pos <= src_len .and. src(pos:pos) == '"') then
795 0 : call parse_json_string(src, src_len, pos, dummy, error, fname)
796 0 : if (allocated(error)) return
797 : end if
798 0 : call skip_ws(src, src_len, pos)
799 0 : if (pos <= src_len .and. src(pos:pos) == ":") pos = pos + 1
800 0 : call skip_ws(src, src_len, pos)
801 0 : call skip_json_value(src, src_len, pos, error, fname)
802 0 : if (allocated(error)) return
803 0 : call skip_ws(src, src_len, pos)
804 0 : if (pos > src_len) return
805 0 : if (src(pos:pos) == "}") then
806 0 : pos = pos + 1
807 0 : return
808 0 : else if (src(pos:pos) == ",") then
809 0 : pos = pos + 1
810 0 : call skip_ws(src, src_len, pos)
811 : end if
812 : end do
813 :
814 0 : end subroutine skip_json_object
815 :
816 : !> Skip a JSON array.
817 0 : recursive subroutine skip_json_array(src, src_len, pos, error, fname)
818 : character(len=*), intent(in) :: src
819 : integer, intent(in) :: src_len
820 : integer, intent(inout) :: pos
821 : type(hsd_error_t), allocatable, intent(out), optional :: error
822 : character(len=*), intent(in) :: fname
823 :
824 0 : pos = pos + 1 ! skip '['
825 0 : call skip_ws(src, src_len, pos)
826 0 : if (pos <= src_len .and. src(pos:pos) == "]") then
827 0 : pos = pos + 1
828 0 : return
829 : end if
830 :
831 0 : do
832 0 : call skip_json_value(src, src_len, pos, error, fname)
833 0 : if (allocated(error)) return
834 0 : call skip_ws(src, src_len, pos)
835 0 : if (pos > src_len) return
836 0 : if (src(pos:pos) == "]") then
837 0 : pos = pos + 1
838 0 : return
839 0 : else if (src(pos:pos) == ",") then
840 0 : pos = pos + 1
841 0 : call skip_ws(src, src_len, pos)
842 : end if
843 : end do
844 :
845 0 : end subroutine skip_json_array
846 :
847 : ! ─── Utility routines ───
848 :
849 : !> Skip whitespace (space, tab, newline, CR).
850 8742 : subroutine skip_ws(src, src_len, pos)
851 : character(len=*), intent(in) :: src
852 : integer, intent(in) :: src_len
853 : integer, intent(inout) :: pos
854 :
855 54357 : do while (pos <= src_len)
856 54356 : select case (iachar(src(pos:pos)))
857 : case (32, 9, 10, 13) ! space, tab, LF, CR
858 45615 : pos = pos + 1
859 : case default
860 54356 : return
861 : end select
862 : end do
863 :
864 8742 : end subroutine skip_ws
865 :
866 : !> Create a parse error.
867 0 : subroutine make_error(error, msg, fname, pos)
868 : type(hsd_error_t), allocatable, intent(out), optional :: error
869 : character(len=*), intent(in) :: msg, fname
870 : integer, intent(in) :: pos
871 :
872 : character(len=20) :: pos_str
873 :
874 0 : if (.not. present(error)) return
875 :
876 0 : write(pos_str, "(i0)") pos
877 0 : allocate(error)
878 0 : error%code = HSD_STAT_SYNTAX_ERROR
879 0 : error%message = trim(fname) // " pos " // trim(pos_str) // ": " // msg
880 :
881 8742 : end subroutine make_error
882 :
883 : ! ─── Complex-value detection ───
884 :
885 : !> Check whether a table represents a complex number: exactly 2 children
886 : !> named "re" and "im", both numeric string values.
887 539 : function is_complex_object(table) result(is_cpx)
888 : type(hsd_table), intent(in) :: table
889 : logical :: is_cpx
890 :
891 : class(hsd_node), pointer :: re_node, im_node
892 :
893 539 : is_cpx = .false.
894 534 : if (table%num_children /= 2) return
895 :
896 87 : call table%get_child_by_name("re", re_node)
897 87 : if (.not. associated(re_node)) return
898 5 : call table%get_child_by_name("im", im_node)
899 5 : if (.not. associated(im_node)) return
900 :
901 : select type (re_node)
902 : type is (hsd_value)
903 5 : select type (im_node)
904 : type is (hsd_value)
905 5 : is_cpx = .true.
906 : end select
907 : end select
908 :
909 539 : end function is_complex_object
910 :
911 : !> Extract a complex value from a table with "re" and "im" children.
912 5 : function complex_from_table(table) result(val)
913 : type(hsd_table), intent(in) :: table
914 : complex(dp) :: val
915 :
916 : class(hsd_node), pointer :: re_node, im_node
917 5 : real(dp) :: re_part, im_part
918 5 : integer :: ios
919 :
920 5 : re_part = 0.0_dp
921 5 : im_part = 0.0_dp
922 :
923 5 : call table%get_child_by_name("re", re_node)
924 5 : call table%get_child_by_name("im", im_node)
925 :
926 : select type (re_node)
927 : type is (hsd_value)
928 5 : if (allocated(re_node%string_value)) then
929 5 : read(re_node%string_value, *, iostat=ios) re_part
930 : end if
931 : end select
932 :
933 : select type (im_node)
934 : type is (hsd_value)
935 5 : if (allocated(im_node%string_value)) then
936 5 : read(im_node%string_value, *, iostat=ios) im_part
937 : end if
938 : end select
939 :
940 5 : val = cmplx(re_part, im_part, dp)
941 :
942 544 : end function complex_from_table
943 :
944 267 : end module hsd_data_json_parser
|
