Line data Source code
1 : !> HSD Parser
2 : !>
3 : !> This module provides the main parsing functionality for HSD files.
4 : !> It converts a token stream into a tree of hsd_node_t nodes.
5 : !> Includes cycle detection for <<+ includes.
6 : module hsd_parser
7 : use hsd_constants, only: dp, hsd_max_include_depth, CHAR_NEWLINE
8 : use hsd_lexer, only: hsd_lexer_t, new_lexer_from_file, new_lexer_from_string, &
9 : hsd_token_t, TOKEN_EOF, TOKEN_STRING, &
10 : TOKEN_LBRACE, TOKEN_RBRACE, TOKEN_EQUAL, TOKEN_LBRACKET, TOKEN_RBRACKET, &
11 : TOKEN_INCLUDE_TXT, TOKEN_INCLUDE_HSD, TOKEN_SEMICOLON, &
12 : TOKEN_TEXT, TOKEN_NEWLINE
13 : use hsd_types, only: hsd_node_t, hsd_node_ptr_t, &
14 : new_table, new_value, VALUE_TYPE_NONE, VALUE_TYPE_ARRAY, &
15 : VALUE_TYPE_STRING, NODE_TYPE_TABLE, NODE_TYPE_VALUE
16 : use hsd_error, only: hsd_error_t, make_error, &
17 : HSD_STAT_OK, HSD_STAT_SYNTAX_ERROR, HSD_STAT_FILE_NOT_FOUND, &
18 : HSD_STAT_IO_ERROR, HSD_STAT_INCLUDE_CYCLE, HSD_STAT_INCLUDE_DEPTH, &
19 : HSD_STAT_UNCLOSED_ATTRIB
20 : use hsd_utils, only: to_lower
21 : implicit none (type, external)
22 : private
23 :
24 : public :: hsd_load_file, hsd_load_string
25 :
26 : !> Include stack item for cycle detection
27 : type :: include_item_t
28 : character(len=:), allocatable :: path
29 : end type include_item_t
30 :
31 : !> Parser state
32 : type :: parser_state_t
33 : !> Current lexer
34 : type(hsd_lexer_t) :: lexer
35 : !> Current token
36 : type(hsd_token_t) :: current_token
37 : !> Include stack for cycle detection
38 : type(include_item_t), allocatable :: include_stack(:)
39 : !> Current include depth
40 : integer :: include_depth = 0
41 : !> Base directory for relative includes
42 : character(len=:), allocatable :: base_dir
43 : contains
44 : procedure :: next_token => parser_next_token
45 : procedure :: push_include => parser_push_include
46 : procedure :: pop_include => parser_pop_include
47 : procedure :: is_include_cycle => parser_is_cycle
48 : end type parser_state_t
49 :
50 : contains
51 :
52 : ! ---- PUBLIC API ----
53 :
54 : !> Load HSD from a file
55 90 : subroutine hsd_load_file(filename, root, error)
56 : character(len=*), intent(in) :: filename
57 : type(hsd_node_t), intent(out) :: root
58 : type(hsd_error_t), allocatable, intent(out), optional :: error
59 :
60 45 : type(parser_state_t) :: state
61 45 : type(hsd_error_t), allocatable :: local_error
62 :
63 : ! Always initialize root so callers get a valid (empty) table even on error
64 45 : call new_table(root)
65 :
66 : ! Initialize lexer
67 45 : call new_lexer_from_file(state%lexer, filename, local_error)
68 48 : if (allocated(local_error)) then
69 3 : call handle_public_error(local_error, error)
70 3 : return
71 : end if
72 :
73 : ! Initialize parser state
74 42 : state%base_dir = get_directory(filename)
75 4242 : allocate(state%include_stack(hsd_max_include_depth))
76 42 : state%include_depth = 0
77 :
78 : ! Push current file onto include stack
79 42 : call state%push_include(filename, local_error)
80 42 : if (allocated(local_error)) then
81 0 : call handle_public_error(local_error, error)
82 0 : return
83 : end if
84 :
85 : ! Get first token and parse
86 42 : call state%next_token()
87 42 : call parse_content(state, root, local_error)
88 42 : call state%pop_include()
89 :
90 42 : call handle_public_error(local_error, error)
91 :
92 4374 : end subroutine hsd_load_file
93 :
94 : !> Load HSD from a string
95 738 : subroutine hsd_load_string(source, root, error, filename)
96 : character(len=*), intent(in) :: source
97 : type(hsd_node_t), intent(out) :: root
98 : type(hsd_error_t), allocatable, intent(out), optional :: error
99 : character(len=*), intent(in), optional :: filename
100 :
101 369 : type(parser_state_t) :: state
102 369 : type(hsd_error_t), allocatable :: local_error
103 :
104 : ! Initialize lexer from string
105 369 : if (present(filename)) then
106 1 : call new_lexer_from_string(state%lexer, source, filename)
107 1 : state%base_dir = get_directory(filename)
108 : else
109 368 : call new_lexer_from_string(state%lexer, source)
110 368 : state%base_dir = "."
111 : end if
112 :
113 : ! Initialize parser state
114 37269 : allocate(state%include_stack(hsd_max_include_depth))
115 369 : state%include_depth = 0
116 :
117 : ! Initialize root table
118 369 : call new_table(root)
119 :
120 : ! Get first token and parse
121 369 : call state%next_token()
122 369 : call parse_content(state, root, local_error)
123 :
124 369 : call handle_public_error(local_error, error)
125 :
126 37683 : end subroutine hsd_load_string
127 :
128 : !> Map internal mandatory errors to public optional ones
129 414 : subroutine handle_public_error(internal_err, public_err)
130 : type(hsd_error_t), allocatable, intent(inout) :: internal_err
131 : type(hsd_error_t), allocatable, intent(out), optional :: public_err
132 :
133 414 : if (allocated(internal_err) .and. present(public_err)) then
134 15 : call move_alloc(internal_err, public_err)
135 : end if
136 :
137 369 : end subroutine handle_public_error
138 :
139 : ! ---- PARSER STATE ----
140 :
141 : !> Advance to the next token
142 6688 : subroutine parser_next_token(self)
143 : class(parser_state_t), intent(inout) :: self
144 6688 : call self%lexer%next_token(self%current_token)
145 414 : end subroutine parser_next_token
146 :
147 : !> Push file onto include stack
148 49 : subroutine parser_push_include(self, path, error)
149 : class(parser_state_t), intent(inout) :: self
150 : character(len=*), intent(in) :: path
151 : type(hsd_error_t), allocatable, intent(out) :: error
152 :
153 : ! Check for cycle
154 49 : if (self%is_include_cycle(path)) then
155 : call make_error(error, HSD_STAT_INCLUDE_CYCLE, &
156 : "Cyclic include detected", &
157 : self%lexer%filename, &
158 : self%current_token%line, &
159 : column=self%current_token%column, &
160 : actual=path, &
161 0 : hint="This file is already being processed in the include chain")
162 0 : return
163 : end if
164 :
165 : ! Check depth limit
166 49 : if (self%include_depth >= hsd_max_include_depth) then
167 : call make_error(error, HSD_STAT_INCLUDE_DEPTH, &
168 : "Maximum include depth exceeded", &
169 : self%lexer%filename, &
170 : self%current_token%line, &
171 : column=self%current_token%column, &
172 : actual=path, &
173 0 : hint="Reduce nesting of include directives")
174 0 : return
175 : end if
176 :
177 : ! Push onto stack
178 49 : self%include_depth = self%include_depth + 1
179 49 : self%include_stack(self%include_depth)%path = path
180 :
181 6737 : end subroutine parser_push_include
182 :
183 : !> Pop file from include stack
184 49 : subroutine parser_pop_include(self)
185 : class(parser_state_t), intent(inout) :: self
186 :
187 49 : if (self%include_depth > 0) then
188 49 : if (allocated(self%include_stack(self%include_depth)%path)) then
189 49 : deallocate(self%include_stack(self%include_depth)%path)
190 : end if
191 49 : self%include_depth = self%include_depth - 1
192 : end if
193 :
194 49 : end subroutine parser_pop_include
195 :
196 : !> Check if path would create a cycle
197 60 : function parser_is_cycle(self, path) result(is_cycle)
198 : class(parser_state_t), intent(in) :: self
199 : character(len=*), intent(in) :: path
200 : logical :: is_cycle
201 :
202 60 : integer :: i
203 :
204 60 : is_cycle = .false.
205 76 : do i = 1, self%include_depth
206 76 : if (allocated(self%include_stack(i)%path)) then
207 20 : if (self%include_stack(i)%path == path) then
208 4 : is_cycle = .true.
209 4 : return
210 : end if
211 : end if
212 : end do
213 :
214 109 : end function parser_is_cycle
215 :
216 : ! ---- BUFFER HELPERS ----
217 :
218 : !> Flush buffered text into a value node on the parent.
219 2609 : subroutine flush_text_buffer(parent, buffer, start_line)
220 : type(hsd_node_t), intent(inout) :: parent
221 : character(len=:), allocatable, intent(inout) :: buffer
222 : integer, intent(in) :: start_line
223 :
224 2609 : if (len_trim(buffer) > 0) then
225 57 : call add_text_to_parent(parent, strip_trailing_nl(buffer), start_line)
226 57 : buffer = ""
227 : end if
228 :
229 60 : end subroutine flush_text_buffer
230 :
231 : !> Append text to the buffer, joining with space or newline as appropriate.
232 178 : subroutine append_text_buffer(buffer, text, start_line, current_line)
233 : character(len=:), allocatable, intent(inout) :: buffer
234 : character(len=*), intent(in) :: text
235 : integer, intent(inout) :: start_line
236 : integer, intent(in) :: current_line
237 :
238 178 : if (len(buffer) == 0) then
239 54 : buffer = text
240 54 : start_line = current_line
241 124 : else if (buffer(len(buffer):len(buffer)) == char(10)) then
242 123 : buffer = buffer // text
243 : else
244 1 : buffer = buffer // " " // text
245 : end if
246 :
247 2609 : end subroutine append_text_buffer
248 :
249 : !> Collect remaining value tokens until end-of-line / EOF / semicolon / }.
250 959 : subroutine collect_value_line(state, value_text)
251 : type(parser_state_t), intent(inout) :: state
252 : character(len=:), allocatable, intent(inout) :: value_text
253 :
254 : do while (state%current_token%kind /= TOKEN_NEWLINE .and. &
255 : state%current_token%kind /= TOKEN_EOF .and. &
256 966 : state%current_token%kind /= TOKEN_SEMICOLON .and. &
257 966 : state%current_token%kind /= TOKEN_RBRACE)
258 7 : if (state%current_token%kind == TOKEN_TEXT .or. &
259 : state%current_token%kind == TOKEN_STRING) then
260 7 : value_text = value_text // " " // state%current_token%value
261 : end if
262 7 : call state%next_token()
263 : end do
264 :
265 959 : if (state%current_token%kind == TOKEN_SEMICOLON) call state%next_token()
266 :
267 178 : end subroutine collect_value_line
268 :
269 : ! ---- PARSER CORE ----
270 :
271 : !> Parse content (multiple tags/values)
272 835 : recursive subroutine parse_content(state, parent, error)
273 : type(parser_state_t), intent(inout) :: state
274 : type(hsd_node_t), intent(inout) :: parent
275 : type(hsd_error_t), allocatable, intent(out) :: error
276 :
277 835 : character(len=:), allocatable :: text_buffer
278 835 : integer :: text_start_line
279 :
280 835 : text_buffer = ""
281 835 : text_start_line = 0
282 :
283 4767 : do while (.not. state%current_token%is_eof())
284 3965 : select case (state%current_token%kind)
285 : case (TOKEN_RBRACE)
286 : ! End of current block — flush text and exit loop
287 413 : call flush_text_buffer(parent, text_buffer, text_start_line)
288 413 : exit
289 :
290 : case (TOKEN_TEXT)
291 1560 : call parse_tag_or_value(state, parent, text_buffer, text_start_line, error)
292 1572 : if (allocated(error)) return
293 :
294 : case (TOKEN_STRING)
295 0 : call append_text_buffer(text_buffer, state%current_token%value, &
296 0 : & text_start_line, state%current_token%line)
297 0 : call state%next_token()
298 :
299 : case (TOKEN_INCLUDE_HSD)
300 11 : call handle_hsd_include(state, parent, error)
301 11 : if (allocated(error)) return
302 :
303 : case (TOKEN_INCLUDE_TXT)
304 7 : call handle_text_include(state, text_buffer, error)
305 7 : if (allocated(error)) return
306 :
307 : case (TOKEN_NEWLINE)
308 : ! Preserve newlines as content separators when buffering inline text;
309 : ! otherwise skip them (e.g. blank lines between tags).
310 1551 : if (len(text_buffer) > 0) then
311 171 : text_buffer = text_buffer // char(10)
312 : end if
313 1551 : call state%next_token()
314 :
315 : case default
316 5130 : call state%next_token()
317 : end select
318 : end do
319 :
320 : ! Flush remaining text buffer (strip trailing newlines)
321 814 : call flush_text_buffer(parent, text_buffer, text_start_line)
322 :
323 1794 : end subroutine parse_content
324 :
325 : !> Parse a tag (possibly with value) or just data
326 1560 : recursive subroutine parse_tag_or_value(state, parent, text_buffer, text_start_line, error)
327 : type(parser_state_t), intent(inout) :: state
328 : type(hsd_node_t), intent(inout) :: parent
329 : character(len=:), allocatable, intent(inout) :: text_buffer
330 : integer, intent(inout) :: text_start_line
331 : type(hsd_error_t), allocatable, intent(out) :: error
332 :
333 1560 : character(len=:), allocatable :: tag_name, attrib, original_text
334 1560 : integer :: tag_line
335 1560 : logical :: is_amendment
336 :
337 : ! Save current state — preserve original text for data fallback, lowercase for tag use
338 1560 : original_text = trim(state%current_token%value)
339 1560 : tag_name = to_lower(original_text)
340 1560 : tag_line = state%current_token%line
341 1560 : call state%next_token()
342 :
343 : ! Check for amendment prefix (+Tag means merge into existing Tag)
344 1560 : is_amendment = (len(tag_name) > 1 .and. tag_name(1:1) == "+")
345 1571 : if (is_amendment) tag_name = tag_name(2:)
346 :
347 : ! Check for attribute [...]
348 1560 : attrib = ""
349 1560 : if (state%current_token%kind == TOKEN_LBRACKET) then
350 35 : call state%next_token()
351 35 : call parse_attribute(state, attrib, error)
352 35 : if (allocated(error)) return
353 : end if
354 :
355 : ! Determine what follows
356 1857 : select case (state%current_token%kind)
357 : case (TOKEN_LBRACE)
358 : ! Block: Tag { ... } or +Tag { ... }
359 297 : call flush_text_buffer(parent, text_buffer, text_start_line)
360 297 : call state%next_token() ! consume {
361 594 : call parse_block(state, parent, tag_name, attrib, tag_line, is_amendment, error)
362 :
363 : case (TOKEN_EQUAL)
364 : ! Assignment: Tag = value or Tag = ChildTag { ... }
365 1085 : call flush_text_buffer(parent, text_buffer, text_start_line)
366 1085 : call state%next_token() ! consume =
367 2170 : call parse_assignment(state, parent, tag_name, attrib, tag_line, is_amendment, error)
368 :
369 : case (TOKEN_NEWLINE, TOKEN_EOF, TOKEN_RBRACE, TOKEN_SEMICOLON)
370 : ! Just a tag name on its own — treat as text (preserve original case)
371 356 : call append_text_buffer(text_buffer, original_text, text_start_line, tag_line)
372 :
373 : case default
374 : ! Treat as part of text (preserve original case)
375 3120 : call append_text_buffer(text_buffer, original_text, text_start_line, tag_line)
376 : end select
377 :
378 1560 : end subroutine parse_tag_or_value
379 :
380 : !> Parse a block: Tag { ... } or +Tag { ... } (amendment)
381 394 : recursive subroutine parse_block(state, parent, tag_name, attrib, tag_line, is_amendment, error)
382 : type(parser_state_t), intent(inout) :: state
383 : type(hsd_node_t), intent(inout) :: parent
384 : character(len=*), intent(in) :: tag_name, attrib
385 : integer, intent(in) :: tag_line
386 : logical, intent(in) :: is_amendment
387 : type(hsd_error_t), allocatable, intent(out) :: error
388 :
389 394 : type(hsd_node_t) :: child_table
390 : type(hsd_node_t), pointer :: target
391 :
392 793 : if (is_amendment) then
393 8 : call parse_amendment_target(state, parent, tag_name, tag_line, target, error)
394 8 : if (allocated(error)) return
395 5 : call parse_content(state, target, error)
396 : else
397 386 : call new_table(child_table, tag_name, attrib, tag_line)
398 386 : call parse_content(state, child_table, error)
399 : end if
400 :
401 391 : if (allocated(error)) return
402 388 : if (state%current_token%kind == TOKEN_RBRACE) call state%next_token()
403 388 : if (.not. is_amendment) call parent%add_child(child_table)
404 :
405 788 : end subroutine parse_block
406 :
407 : !> Parse an assignment: Tag = value, Tag = { ... }, or Tag = ChildTag { ... }
408 1085 : recursive subroutine parse_assignment(state, parent, tag_name, attrib, tag_line, &
409 : & is_amendment, error)
410 : type(parser_state_t), intent(inout) :: state
411 : type(hsd_node_t), intent(inout) :: parent
412 : character(len=*), intent(in) :: tag_name, attrib
413 : integer, intent(in) :: tag_line
414 : logical, intent(in) :: is_amendment
415 : type(hsd_error_t), allocatable, intent(out) :: error
416 :
417 1085 : type(hsd_node_t) :: child_table, child_value
418 1085 : type(hsd_token_t) :: saved_token
419 1085 : character(len=:), allocatable :: value_text, child_tag_name
420 1085 : logical :: child_is_amendment
421 : type(hsd_node_t), pointer :: existing_target
422 :
423 : ! Tag = { ... } — direct block
424 1112 : if (state%current_token%kind == TOKEN_LBRACE) then
425 27 : call state%next_token()
426 27 : call new_table(child_table, tag_name, attrib, tag_line)
427 27 : call parse_content(state, child_table, error)
428 27 : if (allocated(error)) return
429 26 : if (state%current_token%kind == TOKEN_RBRACE) call state%next_token()
430 26 : call parent%add_child(child_table)
431 26 : return
432 : end if
433 :
434 : ! Tag = TEXT ...
435 1058 : if (state%current_token%kind == TOKEN_TEXT) then
436 882 : saved_token = state%current_token
437 882 : call state%next_token()
438 :
439 : ! Tag = ChildTag { ... }
440 882 : if (state%current_token%kind == TOKEN_LBRACE) then
441 99 : call state%next_token() ! consume {
442 :
443 99 : child_tag_name = to_lower(trim(saved_token%value))
444 99 : child_is_amendment = (len(child_tag_name) > 1 .and. child_tag_name(1:1) == "+")
445 103 : if (child_is_amendment) child_tag_name = child_tag_name(2:)
446 :
447 99 : if (is_amendment) then
448 5 : call parse_amendment_target(state, parent, tag_name, tag_line, existing_target, error)
449 5 : if (allocated(error)) return
450 3 : call parse_block(state, existing_target, child_tag_name, "", &
451 6 : & saved_token%line, child_is_amendment, error)
452 : else
453 94 : call new_table(child_table, tag_name, attrib, tag_line)
454 94 : call parse_block(state, child_table, child_tag_name, "", &
455 94 : & saved_token%line, .false., error)
456 94 : if (.not. allocated(error)) call parent%add_child(child_table)
457 : end if
458 97 : return
459 : end if
460 :
461 : ! Not a block — start of a value
462 783 : value_text = trim(saved_token%value)
463 :
464 176 : else if (state%current_token%kind == TOKEN_STRING) then
465 : ! Tag = "string value"
466 172 : value_text = state%current_token%value
467 172 : call state%next_token()
468 :
469 : else
470 : ! Empty value
471 4 : value_text = ""
472 : end if
473 :
474 : ! Gather rest of line for values
475 959 : call collect_value_line(state, value_text)
476 :
477 959 : call new_value(child_value, tag_name, attrib, tag_line)
478 959 : call child_value%set_string(trim(value_text))
479 959 : call parent%add_child(child_value)
480 :
481 2170 : end subroutine parse_assignment
482 :
483 : !> Find an existing table child for amendment; error if not found or not a table.
484 13 : subroutine parse_amendment_target(state, parent, tag_name, line, target, error)
485 : type(parser_state_t), intent(in) :: state
486 : type(hsd_node_t), intent(inout) :: parent
487 : character(len=*), intent(in) :: tag_name
488 : integer, intent(in) :: line
489 : type(hsd_node_t), pointer, intent(out) :: target
490 : type(hsd_error_t), allocatable, intent(out) :: error
491 :
492 13 : nullify(target)
493 13 : call parent%get_child_by_name(tag_name, target)
494 :
495 13 : if (.not. associated(target)) then
496 : call make_error(error, HSD_STAT_SYNTAX_ERROR, &
497 : "Amendment target '" // tag_name // "' not found in parent", &
498 3 : state%lexer%filename, line)
499 10 : else if (target%node_type /= NODE_TYPE_TABLE) then
500 : call make_error(error, HSD_STAT_SYNTAX_ERROR, &
501 : "Amendment target '" // tag_name // "' is not a block", &
502 2 : state%lexer%filename, line)
503 : end if
504 :
505 26 : end subroutine parse_amendment_target
506 :
507 : !> Parse attribute content between [ and ]
508 35 : subroutine parse_attribute(state, attrib, error)
509 : type(parser_state_t), intent(inout) :: state
510 : character(len=:), allocatable, intent(out) :: attrib
511 : type(hsd_error_t), allocatable, intent(out) :: error
512 :
513 35 : attrib = ""
514 :
515 51 : do while (state%current_token%kind /= TOKEN_RBRACKET .and. &
516 86 : .not. state%current_token%is_eof())
517 51 : if (state%current_token%kind == TOKEN_TEXT .or. &
518 : state%current_token%kind == TOKEN_STRING) then
519 43 : if (len(attrib) > 0) then
520 8 : attrib = attrib // " " // state%current_token%value
521 : else
522 35 : attrib = state%current_token%value
523 : end if
524 : end if
525 51 : call state%next_token()
526 : end do
527 :
528 : ! Consume closing bracket
529 35 : if (state%current_token%kind == TOKEN_RBRACKET) then
530 35 : call state%next_token()
531 : else
532 0 : block
533 0 : character(len=:), allocatable :: actual_str
534 0 : if (allocated(state%current_token%value)) then
535 0 : actual_str = trim(state%current_token%value)
536 : else
537 0 : actual_str = "<EOF>"
538 : end if
539 : call make_error(error, HSD_STAT_UNCLOSED_ATTRIB, &
540 : "Unclosed attribute bracket", &
541 : state%lexer%filename, &
542 : state%current_token%line, &
543 : column=state%current_token%column, &
544 : expected="]", &
545 : actual=actual_str, &
546 0 : hint="Add closing ']' to complete the attribute")
547 : end block
548 : end if
549 :
550 13 : end subroutine parse_attribute
551 :
552 : ! ---- INCLUDES ----
553 :
554 : !> Handle <<+ HSD include
555 11 : recursive subroutine handle_hsd_include(state, parent, error)
556 : type(parser_state_t), intent(inout) :: state
557 : type(hsd_node_t), intent(inout) :: parent
558 : type(hsd_error_t), allocatable, intent(out) :: error
559 :
560 11 : character(len=:), allocatable :: include_path, abs_path
561 11 : type(parser_state_t) :: include_state
562 :
563 : ! Get the include filename
564 11 : include_path = trim(state%current_token%value)
565 11 : call state%next_token()
566 :
567 : ! Resolve relative path
568 11 : abs_path = resolve_path(state%base_dir, include_path)
569 :
570 : ! Check for cycle
571 11 : if (state%is_include_cycle(abs_path)) then
572 : call make_error(error, HSD_STAT_INCLUDE_CYCLE, &
573 : "Cyclic include detected in HSD include", &
574 : state%lexer%filename, &
575 : state%current_token%line, &
576 : column=state%current_token%column, &
577 : actual=abs_path, &
578 4 : hint="This file is already being processed in the include chain")
579 4 : return
580 : end if
581 :
582 : ! Push onto include stack
583 7 : call state%push_include(abs_path, error)
584 7 : if (allocated(error)) return
585 :
586 : ! Create new lexer for included file
587 7 : call new_lexer_from_file(include_state%lexer, abs_path, error)
588 7 : if (allocated(error)) then
589 1 : call state%pop_include()
590 1 : return
591 : end if
592 :
593 : ! Copy include stack
594 1212 : include_state%include_stack = state%include_stack
595 6 : include_state%include_depth = state%include_depth
596 6 : include_state%base_dir = get_directory(abs_path)
597 :
598 : ! Parse included file
599 6 : call include_state%next_token()
600 6 : call parse_content(include_state, parent, error)
601 :
602 : ! Pop from stack
603 6 : call state%pop_include()
604 :
605 652 : end subroutine handle_hsd_include
606 :
607 : !> Handle <<< text include
608 7 : subroutine handle_text_include(state, text_buffer, error)
609 : type(parser_state_t), intent(inout) :: state
610 : character(len=:), allocatable, intent(inout) :: text_buffer
611 : type(hsd_error_t), allocatable, intent(out) :: error
612 :
613 7 : character(len=:), allocatable :: include_path, abs_path
614 7 : character(len=:), allocatable :: file_content
615 7 : integer :: unit_num, io_stat, file_size
616 7 : logical :: file_exists
617 :
618 : ! Get the include filename
619 7 : include_path = trim(state%current_token%value)
620 7 : call state%next_token()
621 :
622 : ! Resolve relative path
623 7 : abs_path = resolve_path(state%base_dir, include_path)
624 :
625 : ! Check file exists
626 7 : inquire(file=abs_path, exist=file_exists)
627 7 : if (.not. file_exists) then
628 : call make_error(error, HSD_STAT_FILE_NOT_FOUND, &
629 : "Text include file not found", &
630 : state%lexer%filename, &
631 : state%current_token%line, &
632 : column=state%current_token%column, &
633 : expected="readable file", &
634 : actual=abs_path, &
635 3 : hint="Check that the file path is correct and the file exists")
636 3 : return
637 : end if
638 :
639 : ! Read file content
640 4 : inquire(file=abs_path, size=file_size)
641 4 : allocate(character(len=file_size) :: file_content)
642 :
643 : open(newunit=unit_num, file=abs_path, status='old', action='read', &
644 4 : access='stream', form='unformatted', iostat=io_stat)
645 4 : if (io_stat /= 0) then
646 : call make_error(error, HSD_STAT_IO_ERROR, &
647 : "Cannot read text include file", &
648 : state%lexer%filename, &
649 : state%current_token%line, &
650 : column=state%current_token%column, &
651 : actual=abs_path, &
652 0 : hint="Check file permissions and that the file is readable")
653 0 : return
654 : end if
655 :
656 4 : read(unit_num, iostat=io_stat) file_content
657 4 : close(unit_num)
658 :
659 : ! Strip HSD comments (# to end-of-line) from included text content.
660 : ! This matches the inline HSD text behavior where the lexer consumes
661 : ! #-comments. Without this, files included via <<< would contain
662 : ! comment lines that downstream readers (e.g. GenFormat) cannot handle.
663 4 : call strip_hsd_comments_(file_content)
664 :
665 : ! Append to text buffer
666 4 : if (len(text_buffer) > 0) then
667 1 : text_buffer = text_buffer // CHAR_NEWLINE // file_content
668 : else
669 3 : text_buffer = file_content
670 : end if
671 :
672 11 : end subroutine handle_text_include
673 :
674 : ! ---- TEXT UTILITIES ----
675 :
676 : !> Strip HSD-style comments (# to end-of-line) from text.
677 : !>
678 : !> Mimics the lexer behavior for inline HSD text: everything from an
679 : !> unquoted '#' to the next newline is removed, including the '#' itself.
680 : !> Lines that consist entirely of a comment (only whitespace before '#')
681 : !> are removed completely (including the trailing newline) so that
682 : !> downstream readers do not see spurious blank lines.
683 : !> Blank lines (containing only whitespace) are also removed to match
684 : !> the behavior of the legacy HSD parser.
685 4 : subroutine strip_hsd_comments_(text)
686 : character(len=:), allocatable, intent(inout) :: text
687 :
688 4 : character(len=:), allocatable :: buf
689 4 : integer :: i, n, out_pos, line_start, line_data_start
690 4 : logical :: in_comment, line_is_comment_only, line_is_blank
691 :
692 0 : if (.not. allocated(text)) return
693 4 : n = len(text)
694 4 : if (n == 0) return
695 :
696 4 : allocate(character(len=n) :: buf)
697 4 : out_pos = 0
698 4 : in_comment = .false.
699 4 : line_is_comment_only = .false.
700 4 : line_is_blank = .true.
701 4 : line_start = 1
702 4 : line_data_start = out_pos + 1
703 :
704 64 : do i = 1, n
705 64 : if (text(i:i) == char(10) .or. text(i:i) == char(13)) then
706 : ! End of line
707 4 : if (.not. line_is_comment_only .and. .not. line_is_blank) then
708 : ! Keep the newline
709 4 : out_pos = out_pos + 1
710 4 : buf(out_pos:out_pos) = text(i:i)
711 0 : else if (line_is_blank) then
712 : ! Blank line: remove any whitespace that was already output for this line
713 0 : out_pos = line_data_start - 1
714 : end if
715 : ! Reset for next line
716 4 : in_comment = .false.
717 4 : line_is_comment_only = .false.
718 4 : line_is_blank = .true.
719 4 : line_start = i + 1
720 4 : line_data_start = out_pos + 1
721 56 : else if (.not. in_comment .and. text(i:i) == '#') then
722 : ! Start of comment
723 0 : in_comment = .true.
724 : ! Check if only whitespace has been output for this line
725 0 : if (out_pos < line_data_start) then
726 0 : line_is_comment_only = .true.
727 : else
728 : ! Check if everything from line_data_start to out_pos is whitespace
729 0 : line_is_comment_only = .true.
730 : block
731 0 : integer :: j
732 0 : do j = line_data_start, out_pos
733 0 : if (buf(j:j) /= ' ' .and. buf(j:j) /= char(9)) then
734 0 : line_is_comment_only = .false.
735 0 : exit
736 : end if
737 : end do
738 : end block
739 0 : if (line_is_comment_only) then
740 : ! Remove whitespace before the comment
741 0 : out_pos = line_data_start - 1
742 : end if
743 : end if
744 56 : else if (.not. in_comment) then
745 56 : out_pos = out_pos + 1
746 56 : buf(out_pos:out_pos) = text(i:i)
747 56 : if (text(i:i) /= ' ' .and. text(i:i) /= char(9)) then
748 49 : line_is_blank = .false.
749 : end if
750 : end if
751 : end do
752 :
753 4 : if (out_pos > 0) then
754 4 : text = buf(1:out_pos)
755 : else
756 0 : text = ""
757 : end if
758 :
759 11 : end subroutine strip_hsd_comments_
760 :
761 : !> Strip trailing newlines (and spaces) from a string.
762 57 : pure function strip_trailing_nl(str) result(trimmed)
763 : character(len=*), intent(in) :: str
764 : character(len=:), allocatable :: trimmed
765 :
766 57 : integer :: last
767 :
768 57 : last = len(str)
769 106 : do while (last > 0)
770 212 : if (str(last:last) == char(10) .or. str(last:last) == char(13) &
771 318 : & .or. str(last:last) == ' ') then
772 49 : last = last - 1
773 : else
774 57 : exit
775 : end if
776 : end do
777 :
778 57 : if (last > 0) then
779 57 : trimmed = str(1:last)
780 : else
781 0 : trimmed = ""
782 : end if
783 :
784 4 : end function strip_trailing_nl
785 :
786 : !> Add text content to parent as a value node.
787 : !>
788 : !> Uses the name "#text" to match the legacy xmlf90 convention for inline
789 : !> text content. This allows hsd_get(table, "#text", val) to access inline
790 : !> text uniformly.
791 57 : subroutine add_text_to_parent(parent, text, line)
792 : type(hsd_node_t), intent(inout) :: parent
793 : character(len=*), intent(in) :: text
794 : integer, intent(in) :: line
795 :
796 57 : type(hsd_node_t) :: val
797 :
798 57 : call new_value(val, "#text", "", line)
799 57 : call val%set_raw(text)
800 57 : call parent%add_child(val)
801 :
802 114 : end subroutine add_text_to_parent
803 :
804 : !> Get directory part of a path
805 49 : pure function get_directory(path) result(dir)
806 : character(len=*), intent(in) :: path
807 : character(len=:), allocatable :: dir
808 :
809 49 : integer :: last_sep
810 :
811 49 : last_sep = index(path, "/", back=.true.)
812 49 : if (last_sep > 0) then
813 47 : dir = path(1:last_sep-1)
814 : else
815 2 : dir = "."
816 : end if
817 :
818 57 : end function get_directory
819 :
820 : !> Resolve a relative path against a base directory
821 18 : pure function resolve_path(base_dir, rel_path) result(abs_path)
822 : character(len=*), intent(in) :: base_dir
823 : character(len=*), intent(in) :: rel_path
824 : character(len=:), allocatable :: abs_path
825 :
826 : ! If already absolute, return as-is
827 18 : if (len(rel_path) > 0) then
828 18 : if (rel_path(1:1) == "/") then
829 16 : abs_path = rel_path
830 16 : return
831 : end if
832 : end if
833 :
834 : ! Combine with base directory
835 2 : if (base_dir == "." .or. len_trim(base_dir) == 0) then
836 0 : abs_path = rel_path
837 : else
838 2 : abs_path = trim(base_dir) // "/" // trim(rel_path)
839 : end if
840 :
841 67 : end function resolve_path
842 :
843 344 : end module hsd_parser
|
