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_table and hsd_value nodes.
5 : !> Includes cycle detection for <<+ includes.
6 : module hsd_parser
7 : use hsd_constants, only: dp, hsd_max_line_length, hsd_max_include_depth, CHAR_NEWLINE
8 : use hsd_token, only: hsd_token_t, TOKEN_EOF, TOKEN_STRING, &
9 : TOKEN_LBRACE, TOKEN_RBRACE, TOKEN_EQUAL, TOKEN_LBRACKET, TOKEN_RBRACKET, &
10 : TOKEN_INCLUDE_TXT, TOKEN_INCLUDE_HSD, TOKEN_SEMICOLON, TOKEN_COMMENT, &
11 : TOKEN_TEXT, TOKEN_NEWLINE, TOKEN_WHITESPACE
12 : use hsd_lexer, only: hsd_lexer_t, new_lexer_from_file, new_lexer_from_string
13 : use hsd_types, only: hsd_node, hsd_table, hsd_value, hsd_node_ptr, &
14 : new_table, new_value, VALUE_TYPE_NONE, VALUE_TYPE_ARRAY, VALUE_TYPE_STRING
15 : use hsd_error, only: hsd_error_t, make_error, &
16 : HSD_STAT_OK, HSD_STAT_SYNTAX_ERROR, HSD_STAT_FILE_NOT_FOUND, &
17 : HSD_STAT_IO_ERROR, HSD_STAT_INCLUDE_CYCLE, HSD_STAT_INCLUDE_DEPTH, &
18 : HSD_STAT_UNCLOSED_ATTRIB
19 : implicit none (type, external)
20 : private
21 :
22 : public :: hsd_parse, hsd_parse_string
23 :
24 : !> Include stack item for cycle detection
25 : type :: include_item
26 : character(len=:), allocatable :: path
27 : end type include_item
28 :
29 : !> Parser state
30 : type :: parser_state
31 : !> Current lexer
32 : type(hsd_lexer_t) :: lexer
33 : !> Current token
34 : type(hsd_token_t) :: current_token
35 : !> Include stack for cycle detection
36 : type(include_item), allocatable :: include_stack(:)
37 : !> Current include depth
38 : integer :: include_depth = 0
39 : !> Base directory for relative includes
40 : character(len=:), allocatable :: base_dir
41 : !> Error if any occurred
42 : type(hsd_error_t), allocatable :: error
43 : contains
44 : procedure :: next_token => parser_next_token
45 : procedure :: skip_ws_comments => parser_skip_ws_comments
46 : procedure :: push_include => parser_push_include
47 : procedure :: pop_include => parser_pop_include
48 : procedure :: is_include_cycle => parser_is_cycle
49 : end type parser_state
50 :
51 : contains
52 :
53 : !> Parse an HSD file into a tree structure
54 34 : subroutine hsd_parse(filename, root, error)
55 : character(len=*), intent(in) :: filename
56 : type(hsd_table), intent(out) :: root
57 : type(hsd_error_t), allocatable, intent(out), optional :: error
58 :
59 17 : type(parser_state) :: state
60 17 : type(hsd_error_t), allocatable :: local_error
61 17 : character(len=:), allocatable :: abs_path
62 :
63 : ! Get absolute path
64 17 : abs_path = get_absolute_path(filename)
65 :
66 : ! Initialize lexer
67 17 : call new_lexer_from_file(state%lexer, abs_path, local_error)
68 17 : if (allocated(local_error)) then
69 2 : if (present(error)) call move_alloc(local_error, error)
70 2 : return
71 : end if
72 :
73 : ! Initialize parser state
74 15 : state%base_dir = get_directory(abs_path)
75 1515 : allocate(state%include_stack(hsd_max_include_depth))
76 15 : state%include_depth = 0
77 :
78 : ! Push current file onto include stack
79 15 : call state%push_include(abs_path, local_error)
80 15 : if (allocated(local_error)) then
81 0 : if (present(error)) call move_alloc(local_error, error)
82 0 : return
83 : end if
84 :
85 : ! Initialize root table
86 15 : call new_table(root)
87 :
88 : ! Get first token
89 15 : call state%next_token()
90 :
91 : ! Parse content
92 15 : call parse_content(state, root, local_error)
93 :
94 : ! Pop include stack
95 15 : call state%pop_include()
96 :
97 15 : if (allocated(local_error)) then
98 5 : if (present(error)) call move_alloc(local_error, error)
99 : end if
100 :
101 1564 : end subroutine hsd_parse
102 :
103 : !> Parse HSD from a string
104 3106 : subroutine hsd_parse_string(source, root, error, filename)
105 : character(len=*), intent(in) :: source
106 : type(hsd_table), intent(out) :: root
107 : type(hsd_error_t), allocatable, intent(out), optional :: error
108 : character(len=*), intent(in), optional :: filename
109 :
110 1553 : type(parser_state) :: state
111 1553 : type(hsd_error_t), allocatable :: local_error
112 :
113 : ! Initialize lexer from string
114 1553 : if (present(filename)) then
115 4 : call new_lexer_from_string(state%lexer, source, filename)
116 4 : state%base_dir = get_directory(filename)
117 : else
118 1549 : call new_lexer_from_string(state%lexer, source)
119 1549 : state%base_dir = "."
120 : end if
121 :
122 : ! Initialize parser state
123 156853 : allocate(state%include_stack(hsd_max_include_depth))
124 1553 : state%include_depth = 0
125 :
126 : ! Initialize root table
127 1553 : call new_table(root)
128 :
129 : ! Get first token
130 1553 : call state%next_token()
131 :
132 : ! Parse content
133 1553 : call parse_content(state, root, local_error)
134 :
135 1553 : if (allocated(local_error)) then
136 7 : if (present(error)) call move_alloc(local_error, error)
137 : end if
138 :
139 158423 : end subroutine hsd_parse_string
140 :
141 : !> Get next meaningful token (skipping whitespace)
142 86320 : subroutine parser_next_token(self)
143 : class(parser_state), intent(inout) :: self
144 86320 : call self%lexer%next_token(self%current_token)
145 1553 : end subroutine parser_next_token
146 :
147 : !> Skip whitespace and comments
148 26640 : subroutine parser_skip_ws_comments(self)
149 : class(parser_state), intent(inout) :: self
150 :
151 : do while (self%current_token%kind == TOKEN_WHITESPACE .or. &
152 46963 : self%current_token%kind == TOKEN_COMMENT .or. &
153 46963 : self%current_token%kind == TOKEN_NEWLINE)
154 20323 : call self%next_token()
155 : end do
156 :
157 86320 : end subroutine parser_skip_ws_comments
158 :
159 : !> Push file onto include stack
160 33 : subroutine parser_push_include(self, path, error)
161 : class(parser_state), intent(inout) :: self
162 : character(len=*), intent(in) :: path
163 : type(hsd_error_t), allocatable, intent(out), optional :: error
164 :
165 : ! Check for cycle
166 33 : if (self%is_include_cycle(path)) then
167 0 : if (present(error)) then
168 : call make_error(error, HSD_STAT_INCLUDE_CYCLE, &
169 : "Cyclic include detected", &
170 : self%lexer%filename, &
171 : self%current_token%line, &
172 : column=self%current_token%column, &
173 : actual=path, &
174 0 : hint="This file is already being processed in the include chain")
175 : end if
176 0 : return
177 : end if
178 :
179 : ! Check depth limit
180 33 : if (self%include_depth >= hsd_max_include_depth) then
181 0 : if (present(error)) then
182 : call make_error(error, HSD_STAT_INCLUDE_DEPTH, &
183 : "Maximum include depth exceeded", &
184 : self%lexer%filename, &
185 : self%current_token%line, &
186 : column=self%current_token%column, &
187 : actual=path, &
188 0 : hint="Reduce nesting of include directives")
189 : end if
190 0 : return
191 : end if
192 :
193 : ! Push onto stack
194 33 : self%include_depth = self%include_depth + 1
195 33 : self%include_stack(self%include_depth)%path = path
196 :
197 26673 : end subroutine parser_push_include
198 :
199 : !> Pop file from include stack
200 33 : subroutine parser_pop_include(self)
201 : class(parser_state), intent(inout) :: self
202 :
203 33 : if (self%include_depth > 0) then
204 33 : if (allocated(self%include_stack(self%include_depth)%path)) then
205 33 : deallocate(self%include_stack(self%include_depth)%path)
206 : end if
207 33 : self%include_depth = self%include_depth - 1
208 : end if
209 :
210 33 : end subroutine parser_pop_include
211 :
212 : !> Check if path would create a cycle
213 55 : function parser_is_cycle(self, path) result(is_cycle)
214 : class(parser_state), intent(in) :: self
215 : character(len=*), intent(in) :: path
216 : logical :: is_cycle
217 :
218 55 : integer :: i
219 :
220 55 : is_cycle = .false.
221 197 : do i = 1, self%include_depth
222 197 : if (allocated(self%include_stack(i)%path)) then
223 146 : if (self%include_stack(i)%path == path) then
224 4 : is_cycle = .true.
225 4 : return
226 : end if
227 : end if
228 : end do
229 :
230 88 : end function parser_is_cycle
231 :
232 : !> Parse content (multiple tags/values)
233 7995 : recursive subroutine parse_content(state, parent, error)
234 : type(parser_state), intent(inout) :: state
235 : type(hsd_table), intent(inout) :: parent
236 : type(hsd_error_t), allocatable, intent(out), optional :: error
237 :
238 7995 : type(hsd_error_t), allocatable :: local_error
239 7995 : character(len=:), allocatable :: text_buffer
240 7995 : integer :: text_start_line
241 :
242 7995 : text_buffer = ""
243 7995 : text_start_line = 0
244 :
245 28176 : do while (.not. state%current_token%is_eof())
246 26640 : call state%skip_ws_comments()
247 :
248 26640 : if (state%current_token%is_eof()) exit
249 :
250 33011 : select case (state%current_token%kind)
251 : case (TOKEN_RBRACE)
252 : ! End of current block - return to parent
253 : ! Flush any buffered text first
254 6406 : if (len_trim(text_buffer) > 0) then
255 1121 : call add_text_to_parent(parent, trim(text_buffer), text_start_line)
256 1121 : text_buffer = ""
257 : end if
258 6406 : exit
259 :
260 : case (TOKEN_TEXT)
261 : ! Could be tag name or data
262 17137 : call parse_tag_or_value(state, parent, text_buffer, text_start_line, local_error)
263 17137 : if (allocated(local_error)) then
264 5 : if (present(error)) call move_alloc(local_error, error)
265 18 : return
266 : end if
267 :
268 : case (TOKEN_STRING)
269 : ! String data
270 3012 : if (len(text_buffer) > 0) then
271 2006 : text_buffer = text_buffer // " " // state%current_token%value
272 : else
273 1006 : text_buffer = state%current_token%value
274 1006 : text_start_line = state%current_token%line
275 : end if
276 3012 : call state%next_token()
277 :
278 : case (TOKEN_INCLUDE_HSD)
279 : ! <<+ include
280 22 : call handle_hsd_include(state, parent, local_error)
281 22 : if (allocated(local_error)) then
282 9 : if (present(error)) call move_alloc(local_error, error)
283 9 : return
284 : end if
285 :
286 : case (TOKEN_INCLUDE_TXT)
287 : ! <<< include
288 5 : call handle_text_include(state, text_buffer, local_error)
289 5 : if (allocated(local_error)) then
290 4 : if (present(error)) call move_alloc(local_error, error)
291 4 : return
292 : end if
293 :
294 : case (TOKEN_NEWLINE)
295 0 : call state%next_token()
296 :
297 : case default
298 43769 : call state%next_token()
299 : end select
300 : end do
301 :
302 : ! Flush remaining text buffer
303 7977 : if (len_trim(text_buffer) > 0) then
304 15 : call add_text_to_parent(parent, trim(text_buffer), text_start_line)
305 : end if
306 :
307 8050 : end subroutine parse_content
308 :
309 : !> Parse a tag (possibly with value) or just data
310 17626 : recursive subroutine parse_tag_or_value(state, parent, text_buffer, text_start_line, error)
311 : type(parser_state), intent(inout) :: state
312 : type(hsd_table), intent(inout) :: parent
313 : character(len=:), allocatable, intent(inout) :: text_buffer
314 : integer, intent(inout) :: text_start_line
315 : type(hsd_error_t), allocatable, intent(out), optional :: error
316 :
317 17137 : character(len=:), allocatable :: tag_name, attrib
318 17137 : integer :: tag_line
319 17137 : type(hsd_token_t) :: saved_token
320 17137 : type(hsd_table) :: child_table
321 17137 : type(hsd_value) :: child_value
322 17137 : type(hsd_error_t), allocatable :: local_error
323 17137 : character(len=:), allocatable :: value_text
324 :
325 : ! Save current state
326 17137 : tag_name = trim(state%current_token%value)
327 17137 : tag_line = state%current_token%line
328 17137 : call state%next_token()
329 :
330 : ! Skip whitespace
331 17137 : do while (state%current_token%kind == TOKEN_WHITESPACE)
332 0 : call state%next_token()
333 : end do
334 :
335 : ! Check for attribute [...]
336 17137 : attrib = ""
337 17137 : if (state%current_token%kind == TOKEN_LBRACKET) then
338 1026 : call state%next_token()
339 1026 : call parse_attribute(state, attrib, local_error)
340 1026 : if (allocated(local_error)) then
341 2 : if (present(error)) call move_alloc(local_error, error)
342 2 : return
343 : end if
344 : end if
345 :
346 : ! Skip whitespace again
347 17135 : do while (state%current_token%kind == TOKEN_WHITESPACE)
348 0 : call state%next_token()
349 : end do
350 :
351 : ! Determine what follows
352 19428 : select case (state%current_token%kind)
353 : case (TOKEN_LBRACE)
354 : ! Block: Tag { ... }
355 : ! First flush text buffer
356 2293 : if (len_trim(text_buffer) > 0) then
357 0 : call add_text_to_parent(parent, trim(text_buffer), text_start_line)
358 0 : text_buffer = ""
359 : end if
360 :
361 2293 : call state%next_token() ! consume {
362 2293 : call new_table(child_table, tag_name, attrib, tag_line)
363 2293 : call parse_content(state, child_table, local_error)
364 2293 : if (allocated(local_error)) then
365 3 : if (present(error)) call move_alloc(local_error, error)
366 3 : return
367 : end if
368 :
369 : ! Expect closing brace
370 2290 : if (state%current_token%kind == TOKEN_RBRACE) then
371 2286 : call state%next_token() ! consume }
372 : end if
373 :
374 2290 : call parent%add_child(child_table)
375 :
376 : case (TOKEN_EQUAL)
377 : ! Assignment: Tag = value or Tag = ChildTag { ... }
378 : ! First flush text buffer
379 14682 : if (len_trim(text_buffer) > 0) then
380 1 : call add_text_to_parent(parent, trim(text_buffer), text_start_line)
381 1 : text_buffer = ""
382 : end if
383 :
384 14682 : call state%next_token() ! consume =
385 :
386 : ! Skip whitespace
387 14682 : do while (state%current_token%kind == TOKEN_WHITESPACE)
388 0 : call state%next_token()
389 : end do
390 :
391 : ! Check what follows =
392 29364 : if (state%current_token%kind == TOKEN_LBRACE) then
393 : ! Tag = { ... } - direct block
394 1107 : call state%next_token()
395 1107 : call new_table(child_table, tag_name, attrib, tag_line)
396 1107 : call parse_content(state, child_table, local_error)
397 1107 : if (allocated(local_error)) then
398 0 : if (present(error)) call move_alloc(local_error, error)
399 0 : return
400 : end if
401 1107 : if (state%current_token%kind == TOKEN_RBRACE) then
402 1107 : call state%next_token()
403 : end if
404 1107 : call parent%add_child(child_table)
405 :
406 13575 : else if (state%current_token%kind == TOKEN_TEXT) then
407 : ! Could be: Tag = value OR Tag = ChildTag { ... }
408 9500 : saved_token = state%current_token
409 9500 : call state%next_token()
410 :
411 : ! Skip whitespace
412 9500 : do while (state%current_token%kind == TOKEN_WHITESPACE)
413 0 : call state%next_token()
414 : end do
415 :
416 9500 : if (state%current_token%kind == TOKEN_LBRACE) then
417 : ! Tag = ChildTag { ... }
418 3011 : call state%next_token() ! consume {
419 :
420 3011 : call new_table(child_table, tag_name, attrib, tag_line)
421 :
422 : ! Create nested table with saved_token as name
423 : block
424 3011 : type(hsd_table) :: nested_table
425 3011 : call new_table(nested_table, trim(saved_token%value), "", saved_token%line)
426 3011 : call parse_content(state, nested_table, local_error)
427 3011 : if (allocated(local_error)) then
428 0 : if (present(error)) call move_alloc(local_error, error)
429 0 : return
430 : end if
431 3011 : if (state%current_token%kind == TOKEN_RBRACE) then
432 3011 : call state%next_token()
433 : end if
434 87319 : call child_table%add_child(nested_table)
435 : end block
436 :
437 3011 : call parent%add_child(child_table)
438 :
439 : else
440 : ! Tag = value (simple assignment)
441 6489 : value_text = trim(saved_token%value)
442 :
443 : ! Collect rest of line
444 : do while (state%current_token%kind /= TOKEN_NEWLINE .and. &
445 : state%current_token%kind /= TOKEN_EOF .and. &
446 : state%current_token%kind /= TOKEN_SEMICOLON .and. &
447 6499 : state%current_token%kind /= TOKEN_RBRACE .and. &
448 6499 : state%current_token%kind /= TOKEN_COMMENT)
449 10 : if (state%current_token%kind == TOKEN_TEXT .or. &
450 : state%current_token%kind == TOKEN_STRING) then
451 5 : value_text = value_text // " " // state%current_token%value
452 : end if
453 10 : call state%next_token()
454 : end do
455 :
456 : ! Handle semicolon terminator
457 6489 : if (state%current_token%kind == TOKEN_SEMICOLON) then
458 39 : call state%next_token()
459 : end if
460 :
461 6489 : call new_value(child_value, tag_name, attrib, tag_line)
462 6489 : call child_value%set_string(trim(value_text))
463 6489 : call parent%add_child(child_value)
464 : end if
465 :
466 4075 : else if (state%current_token%kind == TOKEN_STRING) then
467 : ! Tag = "string value"
468 4069 : value_text = state%current_token%value
469 4069 : call state%next_token()
470 :
471 4069 : call new_value(child_value, tag_name, attrib, tag_line)
472 4069 : call child_value%set_string(value_text)
473 4069 : call parent%add_child(child_value)
474 :
475 : else
476 : ! Empty value
477 6 : call new_value(child_value, tag_name, attrib, tag_line)
478 6 : call child_value%set_string("")
479 6 : call parent%add_child(child_value)
480 : end if
481 :
482 : case (TOKEN_NEWLINE, TOKEN_EOF, TOKEN_RBRACE, TOKEN_SEMICOLON)
483 : ! Just a tag name on its own - treat as text
484 288 : if (len(text_buffer) > 0) then
485 21 : text_buffer = text_buffer // " " // tag_name
486 : else
487 123 : text_buffer = tag_name
488 123 : text_start_line = tag_line
489 : end if
490 :
491 : case default
492 : ! Treat as part of text
493 19428 : if (len(text_buffer) > 0) then
494 7 : text_buffer = text_buffer // " " // tag_name
495 : else
496 9 : text_buffer = tag_name
497 9 : text_start_line = tag_line
498 : end if
499 : end select
500 :
501 189820 : end subroutine parse_tag_or_value
502 :
503 : !> Parse attribute content between [ and ]
504 1026 : subroutine parse_attribute(state, attrib, error)
505 : type(parser_state), intent(inout) :: state
506 : character(len=:), allocatable, intent(out) :: attrib
507 : type(hsd_error_t), allocatable, intent(out), optional :: error
508 :
509 1026 : attrib = ""
510 :
511 1049 : do while (state%current_token%kind /= TOKEN_RBRACKET .and. &
512 2075 : .not. state%current_token%is_eof())
513 1049 : if (state%current_token%kind == TOKEN_TEXT .or. &
514 : state%current_token%kind == TOKEN_STRING) then
515 1036 : if (len(attrib) > 0) then
516 12 : attrib = attrib // " " // state%current_token%value
517 : else
518 1024 : attrib = state%current_token%value
519 : end if
520 : end if
521 1049 : call state%next_token()
522 : end do
523 :
524 : ! Consume closing bracket
525 1026 : if (state%current_token%kind == TOKEN_RBRACKET) then
526 1024 : call state%next_token()
527 2 : else if (present(error)) then
528 : call make_error(error, HSD_STAT_UNCLOSED_ATTRIB, &
529 : "Unclosed attribute bracket", &
530 : state%lexer%filename, &
531 : state%current_token%line, &
532 : column=state%current_token%column, &
533 : expected="]", &
534 : actual=trim(state%current_token%value), &
535 2 : hint="Add closing ']' to complete the attribute")
536 : end if
537 :
538 1026 : end subroutine parse_attribute
539 :
540 : !> Handle <<+ HSD include
541 22 : recursive subroutine handle_hsd_include(state, parent, error)
542 : type(parser_state), intent(inout) :: state
543 : type(hsd_table), intent(inout) :: parent
544 : type(hsd_error_t), allocatable, intent(out), optional :: error
545 :
546 22 : character(len=:), allocatable :: include_path, abs_path
547 22 : type(parser_state) :: include_state
548 22 : type(hsd_error_t), allocatable :: local_error
549 :
550 : ! Get the include filename
551 22 : include_path = trim(state%current_token%value)
552 22 : call state%next_token()
553 :
554 : ! Resolve relative path
555 22 : abs_path = resolve_path(state%base_dir, include_path)
556 :
557 : ! Check for cycle
558 22 : if (state%is_include_cycle(abs_path)) then
559 4 : if (present(error)) then
560 : call make_error(error, HSD_STAT_INCLUDE_CYCLE, &
561 : "Cyclic include detected in HSD include", &
562 : state%lexer%filename, &
563 : state%current_token%line, &
564 : column=state%current_token%column, &
565 : actual=abs_path, &
566 4 : hint="This file is already being processed in the include chain")
567 : end if
568 4 : return
569 : end if
570 :
571 : ! Push onto include stack
572 18 : call state%push_include(abs_path, local_error)
573 18 : if (allocated(local_error)) then
574 0 : if (present(error)) call move_alloc(local_error, error)
575 0 : return
576 : end if
577 :
578 : ! Create new lexer for included file
579 18 : call new_lexer_from_file(include_state%lexer, abs_path, local_error)
580 18 : if (allocated(local_error)) then
581 2 : call state%pop_include()
582 2 : if (present(error)) call move_alloc(local_error, error)
583 2 : return
584 : end if
585 :
586 : ! Copy include stack
587 3232 : include_state%include_stack = state%include_stack
588 16 : include_state%include_depth = state%include_depth
589 16 : include_state%base_dir = get_directory(abs_path)
590 :
591 : ! Parse included file
592 16 : call include_state%next_token()
593 16 : call parse_content(include_state, parent, local_error)
594 :
595 : ! Pop from stack
596 16 : call state%pop_include()
597 :
598 16 : if (allocated(local_error)) then
599 3 : if (present(error)) call move_alloc(local_error, error)
600 : end if
601 :
602 2664 : end subroutine handle_hsd_include
603 :
604 : !> Handle <<< text include
605 5 : subroutine handle_text_include(state, text_buffer, error)
606 : type(parser_state), intent(inout) :: state
607 : character(len=:), allocatable, intent(inout) :: text_buffer
608 : type(hsd_error_t), allocatable, intent(out), optional :: error
609 :
610 5 : character(len=:), allocatable :: include_path, abs_path
611 5 : character(len=:), allocatable :: file_content
612 5 : integer :: unit_num, io_stat, file_size
613 5 : logical :: file_exists
614 :
615 : ! Get the include filename
616 5 : include_path = trim(state%current_token%value)
617 5 : call state%next_token()
618 :
619 : ! Resolve relative path
620 5 : abs_path = resolve_path(state%base_dir, include_path)
621 :
622 : ! Check file exists
623 5 : inquire(file=abs_path, exist=file_exists)
624 5 : if (.not. file_exists) then
625 4 : if (present(error)) then
626 : call make_error(error, HSD_STAT_FILE_NOT_FOUND, &
627 : "Text include file not found", &
628 : state%lexer%filename, &
629 : state%current_token%line, &
630 : column=state%current_token%column, &
631 : expected="readable file", &
632 : actual=abs_path, &
633 4 : hint="Check that the file path is correct and the file exists")
634 : end if
635 4 : return
636 : end if
637 :
638 : ! Read file content
639 1 : inquire(file=abs_path, size=file_size)
640 1 : allocate(character(len=file_size) :: file_content)
641 :
642 : open(newunit=unit_num, file=abs_path, status='old', action='read', &
643 1 : access='stream', form='unformatted', iostat=io_stat)
644 1 : if (io_stat /= 0) then
645 0 : if (present(error)) 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 : end if
654 0 : return
655 : end if
656 :
657 1 : read(unit_num, iostat=io_stat) file_content
658 1 : close(unit_num)
659 :
660 : ! Append to text buffer
661 1 : if (len(text_buffer) > 0) then
662 0 : text_buffer = text_buffer // CHAR_NEWLINE // file_content
663 : else
664 1 : text_buffer = file_content
665 : end if
666 :
667 5 : end subroutine handle_text_include
668 :
669 : !> Add text content to parent as a value node
670 1137 : subroutine add_text_to_parent(parent, text, line)
671 : type(hsd_table), intent(inout) :: parent
672 : character(len=*), intent(in) :: text
673 : integer, intent(in) :: line
674 :
675 1137 : type(hsd_value) :: val
676 :
677 1137 : call new_value(val, "", "", line)
678 1137 : call val%set_raw(text)
679 1137 : call parent%add_child(val)
680 :
681 1142 : end subroutine add_text_to_parent
682 :
683 : !> Get directory part of a path
684 35 : pure function get_directory(path) result(dir)
685 : character(len=*), intent(in) :: path
686 : character(len=:), allocatable :: dir
687 :
688 35 : integer :: last_sep
689 :
690 35 : last_sep = index(path, "/", back=.true.)
691 35 : if (last_sep > 0) then
692 31 : dir = path(1:last_sep-1)
693 : else
694 4 : dir = "."
695 : end if
696 :
697 1137 : end function get_directory
698 :
699 : !> Resolve a relative path against a base directory
700 27 : pure function resolve_path(base_dir, rel_path) result(abs_path)
701 : character(len=*), intent(in) :: base_dir
702 : character(len=*), intent(in) :: rel_path
703 : character(len=:), allocatable :: abs_path
704 :
705 : ! If already absolute, return as-is
706 27 : if (len(rel_path) > 0) then
707 24 : if (rel_path(1:1) == "/") then
708 9 : abs_path = rel_path
709 9 : return
710 : end if
711 : end if
712 :
713 : ! Combine with base directory
714 18 : if (base_dir == "." .or. len_trim(base_dir) == 0) then
715 3 : abs_path = rel_path
716 : else
717 15 : abs_path = trim(base_dir) // "/" // trim(rel_path)
718 : end if
719 :
720 62 : end function resolve_path
721 :
722 : !> Get absolute path (simplified - just returns input for now)
723 17 : function get_absolute_path(path) result(abs_path)
724 : character(len=*), intent(in) :: path
725 : character(len=:), allocatable :: abs_path
726 :
727 17 : logical :: file_exists
728 :
729 17 : if (len(path) > 0) then
730 17 : if (path(1:1) == "/") then
731 16 : abs_path = path
732 16 : return
733 : end if
734 : end if
735 :
736 : ! Check if file already exists at the given relative path
737 1 : inquire(file=path, exist=file_exists)
738 1 : if (file_exists) then
739 1 : abs_path = path
740 1 : return
741 : end if
742 :
743 : ! File doesn't exist at relative path - use current directory as base
744 : ! (will fail later when trying to read, but provides better error context)
745 0 : abs_path = "./" // path
746 :
747 44 : end function get_absolute_path
748 :
749 2068 : end module hsd_parser
|
