Line data Source code
1 : !> Lexer (tokenizer) for HSD files
2 : !>
3 : !> This module provides the lexer that converts a character stream into
4 : !> a sequence of tokens for the HSD parser.
5 : module hsd_lexer
6 : use hsd_constants, only: &
7 : & CHAR_TAB, CHAR_BACKSLASH, CHAR_SPACE, CHAR_NEWLINE, CHAR_LBRACE, &
8 : & CHAR_RBRACE, CHAR_LBRACKET, CHAR_RBRACKET, CHAR_EQUAL, CHAR_SEMICOLON, &
9 : & CHAR_HASH, CHAR_DQUOTE, CHAR_SQUOTE, CHAR_LESS
10 : use hsd_utils, only: to_lower, string_buffer_t
11 : use hsd_error, only: hsd_error_t, make_error, &
12 : HSD_STAT_OK, HSD_STAT_IO_ERROR, HSD_STAT_UNCLOSED_QUOTE, HSD_STAT_UNCLOSED_ATTRIB, &
13 : HSD_STAT_FILE_NOT_FOUND
14 : implicit none (type, external)
15 : private
16 :
17 : public :: hsd_lexer_t, new_lexer_from_file, new_lexer_from_string
18 : public :: hsd_token_t
19 : public :: TOKEN_INVALID, TOKEN_EOF, TOKEN_NEWLINE
20 : public :: TOKEN_LBRACE, TOKEN_RBRACE, TOKEN_LBRACKET
21 : public :: TOKEN_RBRACKET, TOKEN_EQUAL, TOKEN_SEMICOLON, TOKEN_STRING
22 : public :: TOKEN_TEXT, TOKEN_INCLUDE_TXT, TOKEN_INCLUDE_HSD
23 :
24 : !> Token kind constants
25 : !>
26 : !> TOKEN_INVALID is a sentinel value: it is never emitted by the lexer and
27 : !> serves as the error sentinel for is_valid().
28 : !> Whitespace and comments are silently consumed by the lexer and never
29 : !> represented as tokens.
30 : integer, parameter :: TOKEN_INVALID = -1
31 : integer, parameter :: TOKEN_EOF = 0
32 : integer, parameter :: TOKEN_NEWLINE = 1
33 : integer, parameter :: TOKEN_LBRACE = 2
34 : integer, parameter :: TOKEN_RBRACE = 3
35 : integer, parameter :: TOKEN_LBRACKET = 4
36 : integer, parameter :: TOKEN_RBRACKET = 5
37 : integer, parameter :: TOKEN_EQUAL = 6
38 : integer, parameter :: TOKEN_SEMICOLON = 7
39 : integer, parameter :: TOKEN_STRING = 8
40 : integer, parameter :: TOKEN_TEXT = 9
41 : integer, parameter :: TOKEN_INCLUDE_TXT = 10
42 : integer, parameter :: TOKEN_INCLUDE_HSD = 11
43 :
44 : !> Token type with position and value
45 : type :: hsd_token_t
46 : !> Kind of token
47 : integer :: kind = TOKEN_EOF
48 : !> Token value (for strings and text)
49 : character(len=:), allocatable :: value
50 : !> Line number where token starts
51 : integer :: line = 0
52 : !> Column number where token starts
53 : integer :: column = 0
54 : contains
55 : procedure :: is_eof => token_is_eof
56 : procedure :: is_valid => token_is_valid
57 : end type hsd_token_t
58 :
59 : !> Lexer state
60 : type :: hsd_lexer_t
61 : !> Source filename (for error reporting)
62 : character(len=:), allocatable :: filename
63 : !> Source content
64 : character(len=:), allocatable :: source
65 : !> Current position in source
66 : integer :: pos = 1
67 : !> Current line number (1-based)
68 : integer :: line = 1
69 : !> Current column number (1-based)
70 : integer :: column = 1
71 : !> Length of source
72 : integer :: source_len = 0
73 : !> Whether we're inside an attribute context
74 : logical :: in_attrib = .false.
75 : !> Whether we're inside a quoted string
76 : logical :: in_quote = .false.
77 : !> Quote character being used
78 : character(len=1) :: quote_char = ''
79 : contains
80 : procedure :: next_token => lexer_next_token
81 : procedure :: peek_char => lexer_peek_char
82 : procedure :: advance => lexer_advance
83 : procedure :: skip_whitespace => lexer_skip_whitespace
84 : procedure :: read_string => lexer_read_string
85 : procedure :: read_text => lexer_read_text
86 : procedure :: skip_comment => lexer_skip_comment
87 : procedure :: is_eof => lexer_is_eof
88 : end type hsd_lexer_t
89 :
90 : contains
91 :
92 : !> Check if token is eof
93 4039 : pure function token_is_eof(self) result(is_eof)
94 : class(hsd_token_t), intent(in) :: self
95 : logical :: is_eof
96 4039 : is_eof = self%kind == TOKEN_EOF
97 8078 : end function token_is_eof
98 :
99 : !> Check if token is valid (not invalid or eof)
100 1 : pure function token_is_valid(self) result(is_valid)
101 : class(hsd_token_t), intent(in) :: self
102 : logical :: is_valid
103 1 : is_valid = self%kind > TOKEN_EOF
104 4039 : end function token_is_valid
105 :
106 : !> Create a new lexer from a file
107 104 : subroutine new_lexer_from_file(lexer, filename, error)
108 : type(hsd_lexer_t), intent(out) :: lexer
109 : character(len=*), intent(in) :: filename
110 : type(hsd_error_t), allocatable, intent(out), optional :: error
111 :
112 52 : integer :: unit_num, io_stat
113 52 : integer :: file_size
114 : character(len=256) :: io_msg
115 52 : logical :: file_exists
116 :
117 : ! Check if file exists
118 52 : inquire(file=filename, exist=file_exists)
119 52 : if (.not. file_exists) then
120 4 : if (present(error)) then
121 : call make_error(error, HSD_STAT_FILE_NOT_FOUND, &
122 4 : "File not found: " // trim(filename), filename)
123 : end if
124 4 : return
125 : end if
126 :
127 : ! Get file size
128 48 : inquire(file=filename, size=file_size)
129 :
130 : ! Open and read file
131 : open(newunit=unit_num, file=filename, status='old', action='read', &
132 48 : access='stream', form='unformatted', iostat=io_stat, iomsg=io_msg)
133 48 : if (io_stat /= 0) then
134 0 : if (present(error)) then
135 0 : call make_error(error, HSD_STAT_IO_ERROR, trim(io_msg), filename)
136 : end if
137 0 : return
138 : end if
139 :
140 : ! Allocate and read content
141 48 : allocate(character(len=file_size) :: lexer%source)
142 48 : read(unit_num, iostat=io_stat) lexer%source
143 48 : close(unit_num)
144 :
145 48 : if (io_stat /= 0 .and. io_stat /= -1) then ! -1 is EOF, which is okay
146 0 : if (present(error)) then
147 0 : call make_error(error, HSD_STAT_IO_ERROR, "Error reading file", filename)
148 : end if
149 0 : return
150 : end if
151 :
152 48 : lexer%filename = filename
153 48 : lexer%source_len = len(lexer%source)
154 48 : lexer%pos = 1
155 48 : lexer%line = 1
156 48 : lexer%column = 1
157 :
158 53 : end subroutine new_lexer_from_file
159 :
160 : !> Create a new lexer from a string
161 756 : subroutine new_lexer_from_string(lexer, source, filename)
162 : type(hsd_lexer_t), intent(out) :: lexer
163 : character(len=*), intent(in) :: source
164 : character(len=*), intent(in), optional :: filename
165 :
166 378 : lexer%source = source
167 378 : lexer%source_len = len(source)
168 378 : lexer%pos = 1
169 378 : lexer%line = 1
170 378 : lexer%column = 1
171 :
172 378 : if (present(filename)) then
173 1 : lexer%filename = filename
174 : else
175 377 : lexer%filename = "<string>"
176 : end if
177 :
178 52 : end subroutine new_lexer_from_string
179 :
180 : !> Check if lexer is at end of file
181 51106 : pure function lexer_is_eof(self) result(is_eof)
182 : class(hsd_lexer_t), intent(in) :: self
183 : logical :: is_eof
184 51106 : is_eof = self%pos > self%source_len
185 378 : end function lexer_is_eof
186 :
187 : !> Peek at current character without advancing
188 50372 : pure function lexer_peek_char(self, offset) result(ch)
189 : class(hsd_lexer_t), intent(in) :: self
190 : integer, intent(in), optional :: offset
191 : character(len=1) :: ch
192 50372 : integer :: peek_pos
193 :
194 50372 : if (present(offset)) then
195 40 : peek_pos = self%pos + offset
196 : else
197 50332 : peek_pos = self%pos
198 : end if
199 :
200 50372 : if (peek_pos > 0 .and. peek_pos <= self%source_len) then
201 50372 : ch = self%source(peek_pos:peek_pos)
202 : else
203 0 : ch = char(0) ! NUL for EOF
204 : end if
205 :
206 51106 : end function lexer_peek_char
207 :
208 : !> Advance position by n characters
209 38903 : subroutine lexer_advance(self, n)
210 : class(hsd_lexer_t), intent(inout) :: self
211 : integer, intent(in), optional :: n
212 :
213 38903 : integer :: i, steps
214 : character(len=1) :: ch
215 :
216 38903 : if (present(n)) then
217 20 : steps = n
218 : else
219 38883 : steps = 1
220 : end if
221 :
222 77846 : do i = 1, steps
223 77846 : if (self%pos <= self%source_len) then
224 38943 : ch = self%source(self%pos:self%pos)
225 38943 : if (ch == CHAR_NEWLINE) then
226 1633 : self%line = self%line + 1
227 1633 : self%column = 1
228 : else
229 37310 : self%column = self%column + 1
230 : end if
231 38943 : self%pos = self%pos + 1
232 : end if
233 : end do
234 :
235 50372 : end subroutine lexer_advance
236 :
237 : !> Skip whitespace characters (not newlines)
238 6807 : subroutine lexer_skip_whitespace(self)
239 : class(hsd_lexer_t), intent(inout) :: self
240 : character(len=1) :: ch
241 :
242 10744 : do while (.not. self%is_eof())
243 10343 : ch = self%peek_char()
244 10343 : if (ch == CHAR_SPACE .or. ch == CHAR_TAB) then
245 3937 : call self%advance()
246 : else
247 6406 : exit
248 : end if
249 : end do
250 :
251 38903 : end subroutine lexer_skip_whitespace
252 :
253 : !> Read a quoted string
254 197 : subroutine lexer_read_string(self, token)
255 : class(hsd_lexer_t), intent(inout) :: self
256 : type(hsd_token_t), intent(out) :: token
257 :
258 : character(len=1) :: quote_char, ch
259 197 : type(string_buffer_t) :: buf
260 197 : integer :: start_line, start_col
261 197 : logical :: escaped
262 :
263 197 : start_line = self%line
264 197 : start_col = self%column
265 197 : quote_char = self%peek_char()
266 197 : call self%advance() ! Skip opening quote
267 :
268 197 : call buf%init()
269 197 : escaped = .false.
270 :
271 2018 : do while (.not. self%is_eof())
272 2015 : ch = self%peek_char()
273 :
274 2015 : if (escaped) then
275 : ! Handle escape sequences
276 1 : select case (ch)
277 : case ('n')
278 1 : call buf%append_char(CHAR_NEWLINE)
279 : case ('t')
280 1 : call buf%append_char(CHAR_TAB)
281 : case ('\')
282 0 : call buf%append_char(CHAR_BACKSLASH)
283 : case ('"')
284 0 : call buf%append_char(CHAR_DQUOTE)
285 : case ("'")
286 1 : call buf%append_char(CHAR_SQUOTE)
287 : case default
288 4 : call buf%append_char(ch)
289 : end select
290 4 : escaped = .false.
291 4 : call self%advance()
292 2011 : else if (ch == CHAR_BACKSLASH) then
293 4 : escaped = .true.
294 4 : call self%advance()
295 2007 : else if (ch == quote_char) then
296 194 : call self%advance() ! Skip closing quote
297 194 : exit
298 : else
299 1813 : call buf%append_char(ch)
300 1813 : call self%advance()
301 : end if
302 : end do
303 :
304 197 : token%kind = TOKEN_STRING
305 197 : token%value = buf%get_string()
306 197 : token%line = start_line
307 197 : token%column = start_col
308 :
309 7004 : end subroutine lexer_read_string
310 :
311 : !> Read unquoted text (identifier or value)
312 2505 : subroutine lexer_read_text(self, token, stop_chars)
313 : class(hsd_lexer_t), intent(inout) :: self
314 : type(hsd_token_t), intent(out) :: token
315 : character(len=*), intent(in) :: stop_chars
316 :
317 : character(len=1) :: ch
318 2505 : type(string_buffer_t) :: buf
319 2505 : integer :: start_line, start_col
320 :
321 2505 : start_line = self%line
322 2505 : start_col = self%column
323 2505 : call buf%init()
324 :
325 29020 : do while (.not. self%is_eof())
326 28816 : ch = self%peek_char()
327 :
328 : ! Note: escape handling is done in read_string_token, not here
329 :
330 : ! Check for stop characters
331 28816 : if (index(stop_chars, ch) > 0) then
332 1652 : exit
333 : end if
334 :
335 : ! Check for newline
336 27164 : if (ch == CHAR_NEWLINE .or. ch == char(13)) then
337 649 : exit
338 : end if
339 :
340 26515 : call buf%append_char(ch)
341 26515 : call self%advance()
342 : end do
343 :
344 2505 : token%kind = TOKEN_TEXT
345 2505 : token%value = buf%get_string()
346 2505 : token%line = start_line
347 2505 : token%column = start_col
348 :
349 2702 : end subroutine lexer_read_text
350 :
351 : !> Skip a comment (from # to end of line) including its trailing newline
352 65 : subroutine lexer_skip_comment(self)
353 : class(hsd_lexer_t), intent(inout) :: self
354 :
355 : character(len=1) :: ch
356 :
357 65 : call self%advance() ! Skip #
358 :
359 2537 : do while (.not. self%is_eof())
360 2535 : ch = self%peek_char()
361 2535 : if (ch == CHAR_NEWLINE) then
362 63 : call self%advance()
363 63 : exit
364 : end if
365 2472 : call self%advance()
366 : end do
367 :
368 2505 : end subroutine lexer_skip_comment
369 :
370 : !> Get the next token from the source
371 9416 : subroutine lexer_next_token(self, token, in_attrib)
372 : class(hsd_lexer_t), intent(inout) :: self
373 : type(hsd_token_t), intent(out) :: token
374 : logical, intent(in), optional :: in_attrib
375 :
376 : character(len=1) :: ch, ch2, ch3
377 : character(len=*), parameter :: general_stop = "{}[]<=""'#;"
378 : character(len=*), parameter :: attrib_stop = "]""'"
379 6722 : character(len=:), allocatable :: stop_chars
380 6722 : logical :: inside_attrib
381 :
382 6722 : if (present(in_attrib)) then
383 0 : inside_attrib = in_attrib
384 : else
385 6722 : inside_attrib = self%in_attrib
386 : end if
387 :
388 6722 : if (inside_attrib) then
389 0 : stop_chars = attrib_stop
390 : else
391 6722 : stop_chars = general_stop
392 : end if
393 :
394 65 : do
395 : ! Skip whitespace
396 6787 : call self%skip_whitespace()
397 :
398 : ! Check for EOF
399 6787 : if (self%is_eof()) then
400 401 : token%kind = TOKEN_EOF
401 401 : token%line = self%line
402 401 : token%column = self%column
403 401 : return
404 : end if
405 :
406 6386 : ch = self%peek_char()
407 :
408 : ! Handle comments silently
409 6386 : if (ch == CHAR_HASH) then
410 65 : call self%skip_comment()
411 65 : cycle
412 : end if
413 :
414 6321 : exit
415 : end do
416 :
417 : ! Single character tokens
418 1570 : select case (ch)
419 : case (CHAR_NEWLINE)
420 1570 : token%kind = TOKEN_NEWLINE
421 1570 : token%line = self%line
422 1570 : token%column = self%column
423 1570 : call self%advance()
424 1570 : return
425 :
426 : case (char(13)) ! Carriage return
427 0 : call self%advance()
428 0 : if (self%peek_char() == CHAR_NEWLINE) then
429 0 : call self%advance()
430 : end if
431 0 : token%kind = TOKEN_NEWLINE
432 0 : token%line = self%line
433 0 : token%column = self%column
434 0 : return
435 :
436 : case (CHAR_LBRACE)
437 425 : token%kind = TOKEN_LBRACE
438 425 : token%line = self%line
439 425 : token%column = self%column
440 425 : call self%advance()
441 425 : return
442 :
443 : case (CHAR_RBRACE)
444 415 : token%kind = TOKEN_RBRACE
445 415 : token%line = self%line
446 415 : token%column = self%column
447 415 : call self%advance()
448 415 : return
449 :
450 : case (CHAR_LBRACKET)
451 36 : token%kind = TOKEN_LBRACKET
452 36 : token%line = self%line
453 36 : token%column = self%column
454 36 : call self%advance()
455 36 : return
456 :
457 : case (CHAR_RBRACKET)
458 36 : token%kind = TOKEN_RBRACKET
459 36 : token%line = self%line
460 36 : token%column = self%column
461 36 : call self%advance()
462 36 : return
463 :
464 : case (CHAR_EQUAL)
465 1098 : token%kind = TOKEN_EQUAL
466 1098 : token%line = self%line
467 1098 : token%column = self%column
468 1098 : call self%advance()
469 1098 : return
470 :
471 : case (CHAR_SEMICOLON)
472 39 : token%kind = TOKEN_SEMICOLON
473 39 : token%line = self%line
474 39 : token%column = self%column
475 39 : call self%advance()
476 39 : return
477 :
478 : case (CHAR_DQUOTE, CHAR_SQUOTE)
479 180 : call self%read_string(token)
480 180 : return
481 :
482 : case (CHAR_LESS)
483 : ! Check for include directives
484 20 : ch2 = self%peek_char(1)
485 20 : ch3 = self%peek_char(2)
486 6341 : if (ch2 == CHAR_LESS .and. ch3 == CHAR_LESS) then
487 : ! <<< text include
488 8 : token%kind = TOKEN_INCLUDE_TXT
489 8 : token%line = self%line
490 8 : token%column = self%column
491 8 : call self%advance(3)
492 : ! Read the filename
493 8 : call self%skip_whitespace()
494 8 : if (self%peek_char() == CHAR_DQUOTE .or. self%peek_char() == CHAR_SQUOTE) then
495 7 : call self%read_string(token)
496 7 : token%kind = TOKEN_INCLUDE_TXT
497 : else
498 1 : call self%read_text(token, general_stop)
499 9 : token%kind = TOKEN_INCLUDE_TXT
500 : end if
501 8 : return
502 12 : else if (ch2 == CHAR_LESS .and. ch3 == '+') then
503 : ! <<+ HSD include
504 12 : token%kind = TOKEN_INCLUDE_HSD
505 12 : token%line = self%line
506 12 : token%column = self%column
507 12 : call self%advance(3)
508 : ! Read the filename
509 12 : call self%skip_whitespace()
510 12 : if (self%peek_char() == CHAR_DQUOTE .or. self%peek_char() == CHAR_SQUOTE) then
511 10 : call self%read_string(token)
512 10 : token%kind = TOKEN_INCLUDE_HSD
513 : else
514 2 : call self%read_text(token, general_stop)
515 14 : token%kind = TOKEN_INCLUDE_HSD
516 : end if
517 12 : return
518 : else
519 : ! Standalone '<' - treat as single-character text token
520 0 : token%kind = TOKEN_TEXT
521 0 : token%value = "<"
522 0 : token%line = self%line
523 0 : token%column = self%column
524 0 : call self%advance()
525 0 : return
526 : end if
527 :
528 : case default
529 : ! Fall through to read as text
530 :
531 : end select
532 :
533 : ! Default: read as text
534 2502 : call self%read_text(token, stop_chars)
535 :
536 6787 : end subroutine lexer_next_token
537 :
538 6722 : end module hsd_lexer
|
