Loading...
Searching...
No Matches
macro.f90
Go to the documentation of this file.
1!> @file
2!! @defgroup group_macro Macro
3!! Macro management and expansion core of the fpx Fortran preprocessor
4!!
5!! This module implements a complete, standards-inspired macro system supporting:
6!! - Object-like and function-like macros
7!! - Variadic macros (`...` and `__VA_ARGS__`)
8!! - Parameter stringification (`#param`) and token pasting (`##`)
9!! - Built-in predefined macros: `__FILE__`, `__FILENAME__`, `__LINE__`, `__DATE__`, `__TIME__`, `__TIMESTAMP__`
10!! - Recursive expansion with circular dependency detection via digraph analysis
11!! - Dynamic macro table of `macro` objects with efficient addition, lookup, removal
12!! - Full support for nested macro calls and proper argument handling
13!!
14!! The design allows safe, repeated expansion while preventing infinite recursion.
15!! All operations are container-agnostic using allocatable dynamic arrays.
16!!
17!! <h2 class="groupheader">Examples</h2>
18!!
19!! 1. Define and use simple macros:
20!! @code{.f90}
21!! type(macro), allocatable :: macros(:)
22!! call add(macros, macro('PI', '3.1415926535'))
23!! call add(macros, macro('MSG(x)', 'print *, ″Hello ″, x'))
24!! print *, expand_all('area = PI * r**2', macros, 'circle.F90', 10, .false.)
25!! !> prints: area = 3.1415926535 * r**2
26!! @endcode
27!!
28!! 2. Variadic macro with stringification and pasting:
29!! @code{.f90}
30!! call add(macros, macro('DEBUG_PRINT(...)', 'print *, ″DEBUG[″, __FILE__, ″:″, __LINE__, ″]: ″, __VA_ARGS__'))
31!! print *, expand_all('DEBUG_PRINT(″value =″, x)', macros, ″test.F90″, 42, .false.)
32!! !> prints: print *, 'DEBUG[', 'test.F90', ':', 42, ']: ', 'value =', x
33!! @endcode
34!!
35!! 3. Token pasting with ##:
36!! @code{.f90}
37!! call add(macros, macro('MAKE_VAR(name,num)', 'var_name_##num'))
38!! print *, expand_all('real :: MAKE_VAR(temp,42)', macros, 'file.F90', 5, .false.)
39!! !> prints: real :: var_name_42
40!! @endcode
41module fpx_macro
42 use fpx_constants
43 use fpx_logging
44 use fpx_path
45 use fpx_graph
46 use fpx_string
47 use fpx_date
48
49 implicit none; private
50
51 public :: macro, &
52 add, &
53 get, &
54 insert, &
55 clear, &
56 remove, &
57 sizeof
58
59 public :: expand_macros, &
60 expand_all, &
62
63 !> @brief Default buffer size
64 !! @ingroup group_macro
65 integer, parameter :: buffer_size = 256
66
67 !> Derived type representing a single preprocessor macro
68 !! Extends @link fpx_string::string string @endlink with macro-specific fields: replacement value, parameters,
69 !! variadic flag, and cyclic self-reference detection.
70 !! <h2 class="groupheader">Examples</h2>
71 !! @code{.f90}
72 !! type(macro), allocatable :: macros(:)
73 !! call add(macros, macro('PI', '3.1415926535'))
74 !! @endcode
75 !! <h2 class="groupheader">Constructors</h2>
76 !! Initializes a new instance of the @ref macro class
77 !! <h3>macro(character(*), character(*))</h3>
78 !! @verbatim type(macro) function macro(character(*) name, (optional) character(*) val) @endverbatim
79 !!
80 !! @param[in] name macro name
81 !! @param[in] val (optional) value of the macro
82 !!
83 !! @b Examples
84 !! @code{.f90}
85 !! type(macro) :: m
86 !! m = macro('_WIN32')
87 !! @endcode
88 !! @return The constructed macro object.
89 !!
90 !! <h2 class="groupheader">Remarks</h2>
91 !! @ingroup group_macro
92 type, extends(string) :: macro
93 character(:), allocatable :: value !< Name of the macro
94 type(string), allocatable :: params(:) !< List of parameter for function like macros
95 logical :: is_variadic !< Indicate whether the macro is variadic or not.
96 logical :: is_cyclic !< Indicates whether the macro has cyclic dependencies or not.
97 end type
98
99 !> @brief Constructor interface for macro type
100 !!
101 !! @b Remarks
102 !! @ingroup group_macro
103 interface macro
104 !! @cond
105 module procedure :: macro_new
106 !! @endcond
107 end interface
108
109 !> Add one or more macros to a dynamic table
110 !!
111 !! @b Remarks
112 !! @ingroup group_macro
113 interface add
114 module procedure :: add_item
115 module procedure :: add_item_from_name
116 module procedure :: add_item_from_name_and_value
117 module procedure :: add_range
118 end interface
119
120 !> Remove all macros from a table
121 !!
122 !! @b Remarks
123 !! @ingroup group_macro
124 interface clear
125 module procedure :: clear_item
126 end interface
127
128 !> Retrieve a macro by index
129 !!
130 !! @b Remarks
131 !! @ingroup group_macro
132 interface get
133 module procedure :: get_item
134 end interface
135
136 !> Insert more macro to a dynamic table
137 !!
138 !! @b Remarks
139 !! @ingroup group_macro
140 interface insert
141 module procedure :: insert_item
142 end interface
143
144 !> Remove a macro at given index
145 !!
146 !! @b Remarks
147 !! @ingroup group_macro
148 interface remove
149 module procedure :: remove_item
150 end interface
151
152 !> Return current number of stored macros
153 !!
154 !! @b Remarks
155 !! @ingroup group_macro
156 interface sizeof
157 module procedure :: size_item
158 end interface
159
160contains
161
162 !> Construct a new macro object
163 !! @param[in] name Mandatory macro name
164 !! @param[in] val Optional replacement text (default: empty)
165 !! @return Initialized macro object
166 type(macro) function macro_new(name, val) result(that)
167 character(*), intent(in) :: name
168 character(*), intent(in), optional :: val
169
170 that = trim(name)
171 if (present(val)) then
172 that%value = val
173 else
174 that%value = ''
175 end if
176 allocate(that%params(0))
177 that%is_variadic = .false.
178 that%is_cyclic = that == that%value
179 end function
180
181 !> Fully expand a line including predefined macros (__FILE__, __LINE__, etc.)
182 !! First performs normal macro expansion via expand_macros(), then substitutes
183 !! standard predefined tokens with current file/line/date information.
184 !! @param[in] line Input source line
185 !! @param[in] macros Current macro table
186 !! @param[in] filepath Current source file path
187 !! @param[in] iline Current line number
188 !! @param[out] stitch Set to .true.true. if result ends with '&' (Fortran continuation)
189 !! @param[in] has_extra Has extra macros (non-standard) like __FILENAME__ and __TIMESTAMP__
190 !! @return Expanded line with all macros and predefined tokens replaced
191 !!
192 !! @b Remarks
193 !! @ingroup group_macro
194 function expand_all(line, macros, filepath, iline, stitch, has_extra) result(expanded)
195 character(*), intent(in) :: line
196 type(macro), intent(in) :: macros(:)
197 character(*), intent(in) :: filepath
198 integer, intent(in) :: iline
199 logical, intent(in) :: has_extra
200 logical, intent(out) :: stitch
201 character(:), allocatable :: expanded
202 !private
203 integer :: pos, start, sep, dot
204 type(datetime) :: date
205
206 expanded = expand_macros(line, macros, stitch)
207 date = now()
208 ! Substitute __FILENAME__
209 if (has_extra) then
210 pos = 1
211 do while (pos > 0)
212 pos = index(expanded, '__FILENAME__')
213 if (pos > 0) then
214 start = pos + len('__FILENAME__')
215 expanded = trim(expanded(:pos - 1) // '"' // filename(filepath, .true.) // '"' // trim(expanded(start:)))
216 if (verbose) print *, "Substituted __FILENAME__ with '", trim(filepath), "', expanded: '", trim(expanded), "'"
217 end if
218 end do
219 end if
220
221 ! Substitute __FILE__ (relative path to working directory)
222 pos = 1
223 do while (pos > 0)
224 pos = index(expanded, '__FILE__')
225 if (pos > 0) then
226 start = pos + len('__FILE__')
227 expanded = trim(expanded(:pos - 1) // '"' // trim(filepath) // '"' // trim(expanded(start:)))
228 if (verbose) print *, "Substituted __FILE__ with '", trim(filepath), "', expanded: '", trim(expanded), "'"
229 end if
230 end do
231
232 ! Substitute __LINE__
233 pos = 1
234 do while (pos > 0)
235 pos = index(expanded, '__LINE__')
236 if (pos > 0) then
237 if (pos > 0) then
238 start = pos + len('__LINE__')
239 expanded = trim(expanded(:pos - 1) // tostring(iline) // trim(expanded(start:)))
240 if (verbose) print *, "Substituted __LINE__ with '", iline, "', expanded: '", trim(expanded), "'"
241 end if
242 end if
243 end do
244
245 ! Substitute __DATE__
246 pos = 1
247 do while (pos > 0)
248 pos = index(expanded, '__DATE__')
249 if (pos > 0) then
250 if (pos > 0) then
251 start = pos + len('__DATE__')
252 expanded = trim(expanded(:pos - 1) // '"' // date%to_string('MMM-dd-yyyy') // '"' // trim(expanded(start:)))
253 if (verbose) print *, "Substituted __DATE__ with '", date%to_string('MMM-dd-yyyy'), "', expanded: '", trim(&
254 expanded), "'"
255 end if
256 end if
257 end do
258
259 ! Substitute __TIME__
260 pos = 1
261 do while (pos > 0)
262 pos = index(expanded, '__TIME__')
263 if (pos > 0) then
264 if (pos > 0) then
265 start = pos + len('__TIME__')
266 expanded = trim(expanded(:pos - 1) // '"' // date%to_string('HH:mm:ss') // '"' // trim(expanded(start:)))
267 if (verbose) print *, "Substituted __TIME__ with '", date%to_string('HH:mm:ss'), "', expanded: '", trim(&
268 expanded), "'"
269 end if
270 end if
271 end do
272
273 if (has_extra) then
274 ! Substitute __TIMESTAMP__
275 pos = 1
276 do while (pos > 0)
277 pos = index(expanded, '__TIMESTAMP__')
278 if (pos > 0) then
279 if (pos > 0) then
280 start = pos + len('__TIMESTAMP__')
281 expanded = trim(expanded(:pos - 1) // '"' // date%to_string('ddd MM yyyy') // ' ' // date%to_string('HH:mm:ss'&
282 &) // '"' // trim(expanded(start:)))
283 if (verbose) print *, "Substituted __TIMESTAMP__ with '", date%to_string('ddd MM yyyy') // ' ' // date%&
284 to_string('HH:mm:ss'), "', expanded: '", trim(expanded), "'"
285 end if
286 end if
287 end do
288 end if
289 end function
290
291 !> Core recursive macro expander (handles function-like, variadic, #, ##)
292 !!
293 !! Performs actual macro replacement with full support for:
294 !! - Function-like macros with argument collection
295 !! - Stringification (`#param`)
296 !! - Token pasting (`##`)
297 !! - Variadic macros and `__VA_ARGS__`, `__VA_OPT__`
298 !! - Recursion with cycle detection via digraph
299 !! - Proper handling of nested parentheses and quoted strings
300 !!
301 !! @param[in] line Input line
302 !! @param[in] macros Current macro table
303 !! @param[out] stitch .true. if final line ends with '&'
304 !! @return Line with user-defined macros expanded (predefined tokens untouched)
305 !!
306 !! @b Remarks
307 !! @ingroup group_macro
308 function expand_macros(line, macros, stitch) result(expanded)
309 character(*), intent(in) :: line
310 type(macro), intent(in) :: macros(:)
311 logical, intent(out) :: stitch
312 character(:), allocatable :: expanded
313 !private
314 integer :: imacro, paren_level
315 type(digraph) :: graph
316
317 imacro = 0; paren_level = 0
318 graph = digraph(size(macros))
319 stitch = .false.
320
321 expanded = expand_macros_internal(line, imacro, macros)
322
323 stitch = stitch .or. paren_level > 0
324 contains
325 !> @private
326 recursive function expand_macros_internal(line, imacro, macros) result(expanded)
327 character(*), intent(in) :: line
328 integer, intent(in) :: imacro
329 type(macro), intent(in) :: macros(:)
330 character(:), allocatable :: expanded
331 !private
332 character(:), allocatable :: args_str, temp, va_args
333 character(:), allocatable :: token1, token2, prefix, suffix
334 type(string) :: arg_values(max_params)
335 integer :: c, i, j, k, n, pos, start, arg_start, nargs
336 integer :: m_start, m_end, token1_start, token2_stop
337 logical :: isopened, found
338 character :: quote
339 integer, allocatable :: indexes(:)
340 logical :: exists
341
342 expanded = line
343 if (size(macros) == 0) return
344 isopened = .false.
345 if (verbose) print *, "Initial expanded: '", trim(expanded), "'"
346
347 do i = 1, size(macros)
348 n = len_trim(macros(i))
349 if (n == 0) cycle
350 c = 0
351 do while (c < len_trim(expanded))
352 c = c + 1
353 if (expanded(c:c) == '"' .or. expanded(c:c) == "'") then
354 if (.not. isopened) then
355 isopened = .true.
356 quote = expanded(c:c)
357 else
358 if (expanded(c:c) == quote) isopened = .false.
359 end if
360 end if
361 if (isopened) cycle
362 if (c + n - 1 > len_trim(expanded)) exit
363
364 found = .false.
365 if (expanded(c:c + n - 1) == macros(i)) then
366 found = .true.
367 if (len_trim(expanded(c:)) > n) then
368 found = verify(expanded(c + n:c + n), ' ()[]<>&;.,^~!/*-+\="' // "'") == 0
369 end if
370 if (found .and. c > 1) then
371 found = verify(expanded(c - 1:c - 1), ' ()[]<>&;.,^~!/*-+\="' // "'") == 0
372 end if
373 end if
374
375 if (found) then
376 pos = c
377 c = c + n - 1
378 m_start = pos
379 start = pos + n
380 if (size(macros(i)%params) > 0 .or. macros(i)%is_variadic) then
381 if (start <= len(expanded)) then
382 if (expanded(start:start) == '(') then
383 paren_level = 1
384 arg_start = start + 1
385 nargs = 0
386 j = arg_start
387 do while (j <= len(expanded) .and. paren_level > 0)
388 if (expanded(j:j) == '(') paren_level = paren_level + 1
389 if (expanded(j:j) == ')') paren_level = paren_level - 1
390 if (paren_level == 1 .and. expanded(j:j) == ',' .or. paren_level == 0) then
391 if (nargs < max_params) then
392 nargs = nargs + 1
393 arg_values(nargs) = trim(adjustl(expanded(arg_start:j - 1)))
394 arg_start = j + 1
395 end if
396 end if
397 j = j + 1
398 end do
399 m_end = j - 1
400 args_str = expanded(start:m_end)
401 if (verbose) print *, "Expanding macro: ", macros(i), ", args: ", trim(args_str)
402 temp = trim(macros(i)%value)
403
404 if (macros(i)%is_variadic) then
405 if (nargs < size(macros(i)%params)) then
406 if (verbose) print *, "Error: Too few arguments for macro ", macros(i)
407 cycle
408 end if
409 va_args = ''
410 do j = size(macros(i)%params) + 1, nargs
411 if (j > size(macros(i)%params) + 1) va_args = va_args // ', '
412 va_args = va_args // arg_values(j)
413 end do
414 if (verbose) print *, "__VA_ARGS__: '", trim(va_args), "'"
415 else if (nargs /= size(macros(i)%params)) then
416 if (verbose) print *, "Error: Incorrect number of arguments for macro ", macros(i)
417 cycle
418 end if
419
420 ! Substitute regular parameters
421 argbck :block
422 integer :: c1, h1
423 logical :: opened
424
425 opened = .false.
426 jloop: do j = 1, size(macros(i)%params)
427 c1 = 0
428 wloop: do while (c1 < len_trim(temp))
429 c1 = c1 + 1
430 if (temp(c1:c1) == '"') opened = .not. opened
431 if (opened) cycle wloop
432 if (c1 + len_trim(macros(i)%params(j)) - 1 > len(temp)) cycle wloop
433
434 if (temp(c1:c1 + len_trim(macros(i)%params(j)) - 1) == trim(macros(i)%params(j))) &
435 then
436 checkbck:block
437 integer :: cend, l
438
439 cend = c1 + len_trim(macros(i)%params(j))
440 l = len(temp)
441 if (c1 == 1 .and. cend == l + 1) then
442 exit checkbck
443 else if (c1 > 1 .and. l == cend - 1) then
444 if (verify(temp(c1 - 1:c1 - 1), ' #()[]<>&;.,!/*-+\="' // "'") /= 0) &
445 cycle wloop
446 else if (c1 <= 1 .and. cend <= l) then
447 if (verify(temp(cend:cend), ' #()[]<>&;.,!/*-+\="' // "'") /= 0) cycle &
448 wloop
449 else
450 if (verify(temp(c1 - 1:c1 - 1), ' #()[]<>&;.,!/*-+\="' // "'") /= 0 &
451 .or. verify(temp(cend:cend), ' #()[]<>$&;.,!/*-+\="' // "'") /=&
452 & 0) cycle wloop
453 end if
454 end block checkbck
455 pos = c1
456 c1 = c1 + len_trim(macros(i)%params(j)) - 1
457 start = pos + len_trim(macros(i)%params(j))
458 if (pos == 2) then
459 if (temp(pos - 1:pos - 1) == '#') then
460 temp = trim(temp(:pos - 2) // '"' // arg_values(j) // '"' // trim(temp(&
461 start:)))
462 else
463 temp = trim(temp(:pos - 1) // arg_values(j) // trim(temp(start:)))
464 end if
465 elseif (pos > 2) then
466 h1 = pos - 1
467 if (previous(temp, h1) == '#') then
468 if (h1 == 1) then
469 temp = trim(temp(:h1 - 1) // '"' // arg_values(j) // '"' // trim(&
470 temp(start:)))
471 else
472 if (temp(h1 - 1:h1 - 1) /= '#') then
473 temp = trim(temp(:h1 - 1) // '"' // arg_values(j) // '"' // &
474 trim(temp(start:)))
475 else
476 temp = trim(temp(:pos - 1) // arg_values(j) // trim(temp(start:&
477 )))
478 end if
479 end if
480 else
481 temp = trim(temp(:pos - 1) // arg_values(j) // trim(temp(start:)))
482 end if
483 else
484 temp = trim(temp(:pos - 1) // arg_values(j) // trim(temp(start:)))
485 end if
486 if (verbose) print *, "Substituted param ", j, ": '", macros(i)%params(j), &
487 "' with '", &
488 arg_values(j), "', temp: '", trim(temp), "'"
489 end if
490 end do wloop
491 end do jloop
492 end block argbck
493
494 ! Handle concatenation (##) first with immediate substitution
495 block
496 pos = 1
497 do while (pos > 0)
498 pos = index(temp, '##')
499 if (pos > 0) then
500 ! Find token1 (before ##)
501 k = pos - 1
502 if (k <= 0) then
503 if (verbose) print *, "Error: No token before ##"
504 cycle
505 end if
506
507 token1 = adjustr(temp(:k))
508 prefix = ''
509 token1_start = index(token1, ' ')
510 if (token1_start > 0) then
511 prefix = token1(:token1_start)
512 token1 = token1(token1_start + 1:)
513 end if
514
515 ! Find token2 (after ##)
516 k = pos + 2
517 if (k > len(temp)) then
518 if (verbose) print *, "Error: No token after ##"
519 cycle
520 end if
521
522 suffix = ''
523 token2 = adjustl(temp(k:))
524 token2_stop = index(token2, ' ')
525 if (token2_stop > 0) then
526 suffix = token2(token2_stop:)
527 token2 = token2(:token2_stop - 1)
528 end if
529
530 ! Concatenate, replacing the full 'token1 ## token2' pattern
531 temp = trim(prefix // trim(token1) // trim(token2) // suffix)
532 if (verbose) print *, "Concatenated '", trim(token1), "' and '", trim(token2), &
533 "' to '", trim(token1) // trim(token2), "', temp: '", trim(temp), "'"
534 end if
535 end do
536 end block
537
538 ! Substitute __VA_ARGS__
539 block
540 if (macros(i)%is_variadic) then
541 pos = 1
542 do while (pos > 0)
543 pos = index(temp, '__VA_ARGS__')
544 if (pos > 0) then
545 start = pos + len('__VA_ARGS__') - 1
546 if (start < len(temp) .and. temp(start:start) == '_' &
547 .and. temp(start + 1:start + 1) == ')') then
548 temp = trim(temp(:pos - 1) // trim(va_args) // ')')
549 else
550 temp = trim(temp(:pos - 1) // trim(va_args) // trim(temp(start + 1:)))
551 end if
552 if (verbose) print *, "Substituted __VA_ARGS__ with '", trim(va_args), &
553 "', temp: '", trim(temp), "'"
554 ! Substitute __VA_OPT__
555 pos = index(temp, '__VA_OPT__')
556 if (pos > 0) then
557 start = pos + index(temp(pos:), ')') - 1
558 if (len_trim(va_args) > 0) then
559 temp = trim(temp(:pos - 1)) // temp(pos + index(temp(pos:), '('):start &
560 - 1) // trim(temp(start + 1:))
561 else
562 temp = trim(temp(:pos - 1)) // trim(temp(start + 1:))
563 end if
564 end if
565 end if
566 end do
567 end if
568 end block
569
570 if (verbose) print *, "Before recursive call, temp: '", trim(temp), "'"
571 call graph%add_edge(imacro, i)
572 if (.not. graph%is_circular(i)) then
573 temp = expand_macros_internal(temp, i, macros) ! Only for nested macros
574 else
575 if (verbose) print *, "Circular macro detected: '", macros(i), "'"
576 cycle
577 end if
578 if (verbose) print *, "After recursive call, temp: '", trim(temp), "'"
579 if (verbose) print *, "Prefix: '", trim(expanded(:m_start - 1)), "'"
580 if (verbose) print *, "Temp: '", trim(temp), "'"
581 if (verbose) print *, "Suffix: '", trim(expanded(m_end + 1:)), "'"
582 expanded = trim(expanded(:m_start - 1) // trim(temp) // expanded(m_end + 1:))
583 if (verbose) print *, "After substitution, expanded: '", trim(expanded), "'"
584 end if
585 end if
586 else
587 temp = trim(macros(i)%value)
588 m_end = start - 1
589 call graph%add_edge(imacro, i)
590 if ((.not. graph%is_circular(i)) .and. (.not. macros(i)%is_cyclic)) then
591 expanded = trim(expanded(:m_start - 1) // trim(temp) // expanded(m_end + 1:))
592 expanded = expand_macros_internal(expanded, imacro, macros)
593 else
594 if (verbose) print *, "Circular macro detected: '", macros(i), "'"
595 cycle
596 end if
597 if (verbose) print *, "Simple macro expanded: '", trim(expanded), "'"
598 end if
599 end if
600 end do
601 end do
602 pos = index(expanded, '&')
603 if (index(expanded, '!') > pos .and. pos > 0) expanded = expanded(:pos + 1)
604 stitch = tail(expanded) == '&'
605 end function
606 end function
607
608 !> Detect whether expanding macro at index `idx` would cause a cycle
609 !! Builds a dependency graph from macro replacement texts and checks for circular paths.
610 !! Used during expansion to avoid infinite recursion.
611 !!
612 !! @b Remarks
613 !! @ingroup group_macro
614 logical function is_circular(macros, idx) result(res)
615 type(macro), intent(in) :: macros(:)
616 integer, intent(in) :: idx
617 !private
618 character(:), allocatable :: expanded
619 integer :: c, i, j, n
620 logical :: isopened, found
621 character :: quote
622 type(digraph) :: graph
623
624 res = .false.
625 if (size(macros) == 0) return
626 isopened = .false.
627
628 graph = digraph(size(macros))
629
630 do j = 1, size(macros)
631 expanded = macros(j)%value
632 do i = 1, size(macros)
633 n = len_trim(macros(i))
634 if (n == 0) cycle
635 c = 0
636 do while (c < len_trim(expanded))
637 c = c + 1
638 if (expanded(c:c) == '"' .or. expanded(c:c) == "'") then
639 if (.not. isopened) then
640 isopened = .true.
641 quote = expanded(c:c)
642 else
643 if (expanded(c:c) == quote) isopened = .false.
644 end if
645 end if
646 if (isopened) cycle
647 if (c + n - 1 > len_trim(expanded)) exit
648
649 found = .false.
650 if (expanded(c:c + n - 1) == macros(i)) then
651 found = .true.
652 if (len_trim(expanded(c:)) > n) then
653 found = verify(expanded(c + n:c + n), ' ()[]<>&;.,^~!/*-+\="' // "'") == 0
654 end if
655 end if
656
657 if (found) then
658 expanded(c:c + len_trim(macros(i)) - 1) = ' '
659 call graph%add_edge(j, i)
660 end if
661 end do
662 end do
663 end do
664
665 res = graph%is_circular(idx)
666 end function
667
668 !> Check if a macro with given name exists in table
669 !! @param[in] name Macro name to test
670 !! @param[in] macros Current macro table
671 !! @param[inout] idx Optional: returns index (1-based) if found
672 !! @return .true. if macro is defined
673 !!
674 !! @b Remarks
675 !! @ingroup group_macro
676 logical function is_defined(name, macros, idx) result(res)
677 character(*), intent(in) :: name
678 type(macro), intent(in) :: macros(:)
679 integer, intent(inout), optional :: idx
680 !private
681 integer :: i
682
683 res = .false.
684 do i = 1, size(macros)
685 if (macros(i) == trim(name)) then
686 res = .true.
687 if (present(idx)) idx = i
688 exit
689 end if
690 end do
691 end function
692
693 !> Generic conversion of polymorphic value to string
694 !! Used internally during macro argument stringification and debugging.
695 !! Supports integers, reals, logicals, characters, and complex.
696 !!
697 !! @b Remarks
698 !! @ingroup group_macro
699 function tostring(any)
700 class(*), intent(in) :: any
701 !private
702 character(:), allocatable :: tostring
703 character(4096) :: line
704
705 call print_any(any); tostring = trim(line)
706 contains
707 !> @private
708 subroutine print_any(any)
709 use, intrinsic :: iso_fortran_env, only: int8, int16, int32, int64, real32, real64, real128
710 class(*), intent(in) :: any
711
712 select type (any)
713 type is (integer(kind=int8)); write(line, '(i0)') any
714 type is (integer(kind=int16)); write(line, '(i0)') any
715 type is (integer(kind=int32)); write(line, '(i0)') any
716 type is (integer(kind=int64)); write(line, '(i0)') any
717 type is (real(kind=real32)); write(line, '(1pg0)') any
718 type is (real(kind=real64)); write(line, '(1pg0)') any
719 type is (real(kind=real128)); write(line, '(1pg0)') any
720 type is (logical); write(line, '(1l)') any
721 type is (character(*)); write(line, '(a)') any
722 type is (complex(kind=real32)); write(line, '("(",1pg0,",",1pg0,")")') any
723 type is (complex(kind=real64)); write(line, '("(",1pg0,",",1pg0,")")') any
724 type is (complex(kind=real128)); write(line, '("(",1pg0,",",1pg0,")")') any
725 end select
726 end subroutine
727 end function
728
729 !> Internal helper: grow dynamic macro array in chunks for efficiency
730 !! Adds a new macro to the allocatable array, growing in BUFFER_SIZE increments.
731 !! Also detects direct self-references (A → A) and marks both sides as cyclic.
732 !!
733 !! @b Remarks
734 subroutine add_to(vec, val, n, chunk_size, finished)
735 type(macro), allocatable, intent(inout) :: vec(:)
736 type(macro), intent(in) :: val
737 integer, intent(inout) :: n
738 integer, intent(in) :: chunk_size
739 logical, intent(in) :: finished
740 !private
741 type(macro), allocatable :: tmp(:)
742 integer :: csize, i
743
744 csize = chunk_size
745
746 if (finished) csize = 1
747 if (allocated(vec)) then
748 if (n == size(vec)) then
749 ! have to add another chunk:
750 allocate(tmp(size(vec) + csize))
751 tmp(1:size(vec)) = vec
752 call move_alloc(tmp, vec)
753 end if
754 n = n + 1
755 else
756 ! the first element:
757 allocate(vec(csize))
758 n = 1
759 end if
760
761 vec(n) = val
762 if (finished) then
763 if (allocated(tmp)) deallocate(tmp)
764 if (n /= size(vec)) then
765 allocate(tmp(n), source=vec(1:n))
766 call move_alloc(tmp, vec)
767 end if
768 end if
769
770 do i = 1, size(vec) - 1
771 if (vec(i) == vec(n)%value .and. vec(i)%value == vec(n)) then
772 vec(i)%is_cyclic = .true.
773 vec(n)%is_cyclic = .true.
774 end if
775 end do
776 end subroutine
777
778 !> Add a complete macro object to the table
779 !!
780 !! @b Remarks
781 subroutine add_item(this, arg)
782 type(macro), intent(inout), allocatable :: this(:)
783 type(macro), intent(in) :: arg
784 !private
785 integer :: count
786
787 count = size(this)
788 call add_to(this, arg, count, buffer_size, finished=.true.)
789 end subroutine
790
791 !> Add macro by name only (value = empty)
792 !!
793 !! @b Remarks
794 subroutine add_item_from_name(this, name)
795 type(macro), intent(inout), allocatable :: this(:)
796 character(*), intent(in) :: name
797 !private
798 integer :: count
799 if (.not. allocated(this)) allocate(this(0))
800 count = size(this)
801 call add_to(this, macro(name), count, buffer_size, finished=.true.)
802 end subroutine
803
804 !> Add macro with name and replacement text
805 !!
806 !! @b Remarks
807 subroutine add_item_from_name_and_value(this, name, value)
808 type(macro), intent(inout), allocatable :: this(:)
809 character(*), intent(in) :: name
810 character(*), intent(in) :: value
811 !private
812 integer :: count
813
814 if (.not. allocated(this)) allocate(this(0))
815 count = size(this)
816 call add_to(this, macro(name, value), count, buffer_size, finished=.true.)
817 end subroutine
818
819 !> Add multiple macros at once
820 !!
821 !! @b Remarks
822 subroutine add_range(this, args)
823 type(macro), intent(inout), allocatable :: this(:)
824 type(macro), intent(in) :: args(:)
825 !private
826 integer :: i, n, count
827
828 if (.not. allocated(this)) allocate(this(0))
829 n = size(args); count = size(this)
830 do i = 1, n
831 call add_to(this, args(i), count, buffer_size, finished=i == n)
832 end do
833 end subroutine
834
835 !> Remove all macros from table
836 !!
837 !! @b Remarks
838 subroutine clear_item(this)
839 type(macro), intent(inout), allocatable :: this(:)
840
841 if (allocated(this)) deallocate(this)
842 allocate(this(0))
843 end subroutine
844
845 !> Retrieve macro by 1-based index
846 !!
847 !! @b Remarks
848 function get_item(this, key) result(res)
849 type(macro), intent(inout) :: this(:)
850 integer, intent(in) :: key
851 type(macro), allocatable :: res
852 !private
853 integer :: n
854
855 n = sizeof(this)
856 if (key > 0 .and. key <= n) then
857 res = this(key)
858 end if
859 end function
860
861 !> Insert macro at specific position
862 !!
863 !! @b Remarks
864 subroutine insert_item(this, i, arg)
865 type(macro), intent(inout), allocatable :: this(:)
866 integer, intent(in) :: i
867 type(macro), intent(in) :: arg
868 !private
869 integer :: j, count
870
871 if (.not. allocated(this)) allocate(this(0))
872 count = size(this)
873 call add_to(this, arg, count, buffer_size, finished=.true.)
874
875 do j = count, i + 1, -1
876 this(j) = this(j - 1)
877 end do
878 this(i) = arg
879 end subroutine
880
881 !> Return number of defined macros
882 !!
883 !! @b Remarks
884 integer function size_item(this) result(res)
885 type(macro), intent(inout), allocatable :: this(:)
886
887 res = merge(size(this), 0, allocated(this))
888 end function
889
890 !> Remove macro at given index
891 !!
892 !! @b Remarks
893 subroutine remove_item(this, i)
894 type(macro), intent(inout), allocatable :: this(:)
895 integer, intent(in) :: i
896 !private
897 type(macro), allocatable :: tmp(:)
898 integer :: k, j, n
899
900 if (.not. allocated(this)) allocate(this(0))
901 n = size(this)
902 if (allocated(this(i)%params)) deallocate(this(i)%params)
903 if (n > 1) then
904 this(i:n - 1) = this(i + 1:n)
905 allocate(tmp(n - 1))
906 tmp = this(:n - 1)
907 deallocate(this)
908 call move_alloc(tmp, this)
909
910 this(:)%is_cyclic = .false.
911 do k = 1, size(this)
912 do j = 1, size(this)
913 if (this(k) == this(j)%value .and. this(k)%value == this(j)) then
914 this(i)%is_cyclic = .true.
915 this(j)%is_cyclic = .true.
916 end if
917 end do
918 end do
919 else
920 deallocate(this); allocate(this(0))
921 end if
922 end subroutine
923end module
character(:) function, allocatable, public expand_all(line, macros, filepath, iline, stitch, has_extra)
Fully expand a line including predefined macros (FILE, LINE, etc.) First performs normal macro expans...
Definition macro.f90:195
integer, parameter buffer_size
Default buffer size.
Definition macro.f90:65
logical function is_circular(macros, idx)
Detect whether expanding macro at index idx would cause a cycle Builds a dependency graph from macro ...
Definition macro.f90:615
character(:) function, allocatable tostring(any)
Generic conversion of polymorphic value to string Used internally during macro argument stringificati...
Definition macro.f90:700
character(:) function, allocatable, public expand_macros(line, macros, stitch)
Core recursive macro expander (handles function-like, variadic, #, ##)
Definition macro.f90:309
logical function, public is_defined(name, macros, idx)
Check if a macro with given name exists in table.
Definition macro.f90:677
Add one or more macros to a dynamic table.
Definition macro.f90:113
Remove all macros from a table.
Definition macro.f90:124
Retrieve a macro by index.
Definition macro.f90:132
Insert more macro to a dynamic table.
Definition macro.f90:140
Remove a macro at given index.
Definition macro.f90:148
Return current number of stored macros.
Definition macro.f90:156
Return the trimmed string.
Definition string.f90:146
Derived type representing a single preprocessor macro Extends string with macro-specific fields: rep...
Definition macro.f90:103
Represents text as a sequence of ASCII code units. The derived type wraps an allocatable character ar...
Definition string.f90:107