parser.f90

Go to the documentation of this file.

!> @file
!! @defgroup group_parser Parser
!! Fortran Preprocessor (fpx) – core parsing and preprocessing module
!!
!! This module implements a full-featured, modern Fortran preprocessor supporting:
!! - C-style line continuations with `\` and `\\`
!! - Fortran-style `&` continuations
!! - `#define`, `#undef`, object-like and function-like macros with variadic support
!! - `#include` with proper path resolution and recursion guard
!! - Conditional compilation: `#if`, `#ifdef`, `#ifndef`, `#elif`, `#else`, `#endif`
!! - Non-standard `#for` directive
!! - C-style `/* ... */` comments (nestable aware)
!! - Macro expansion with argument substitution and stringification (`#`) / token-pasting (`##`)
!! - Interactive REPL mode when reading from stdin
!! - Multiple entry points for file-to-file, unit-to-unit, etc.
!! - Support ${x} for substituting macro name
!!
!! The preprocessor is designed to be standards-conforming where possible while adding
!! useful extensions (variadic macros, better diagnostics, include path handling).
!!
!! @section parser_examples Examples
!!
!! 1. Preprocess a file to stdout:
!! @code{.f90}
!!    call preprocess('input.F90')
!! @endcode
!!
!! 2. Preprocess a file and write to another file:
!! @code{.f90}
!!    call preprocess('src/main.F90', 'preprocessed/main.F90')
!! @endcode
!!
!! 3. Use in a build system with unit numbers:
!! @code{.f90}
!!    integer :: iu, ou
!!    open(newunit=iu, file='input.F90')
!!    open(newunit=ou, file='output.F90')
!!    call preprocess(iu, ou)
!!    close(iu); close(ou)
!!    ...
!! @endcode
!!
!! 4. Interactive mode (stdin to stdout):
!! @code
!!    $ ./fpx
!!     [in]  #define PI 3.1415926535
!!     [out]
!!     [in]  real :: x = PI*2
!!     [out] real :: x = 3.1415926535*2
!!     [in]  (empty line or 'quit' to exit)
!! @endcode
module fpx_parser
    use, intrinsic :: iso_fortran_env, only: stdout => output_unit, iostat_end, stdin => input_unit
    use, intrinsic :: iso_c_binding, only: c_char, c_size_t, c_ptr, c_null_ptr, c_associated, c_funloc
    use fpx_constants
    use fpx_string
    use fpx_logging
    use fpx_macro
    use fpx_conditional
    use fpx_define
    use fpx_diagnostics
    use fpx_include
    use fpx_path
    use fpx_global
    use fpx_context
    use fpx_line
    use fpx_for
 
    implicit none; private
 
    public :: preprocess,  &
            global
 
    !> Generic interface to start preprocessing from various sources/sinks
    !!
    !! Allows preprocessing:
    !! - file to stdout
    !! - file to file
    !! - unit to file
    !! - unit to unit (most flexible, used internally for #include)
    !!
    !! @b Remarks
    !! @ingroup group_parser
    interface preprocess
        module procedure :: preprocess_file
        module procedure :: preprocess_file_to_unit
        module procedure :: preprocess_unit_to_file
        module procedure :: preprocess_unit_to_unit
    end interface
 
    character(256) :: name                              !< Current source file name (without path)
    logical        :: c_continue                        !< Flags for C-style continuation
    logical        :: f_continue                        !< Flags for Fortran-style continuation
    logical        :: in_comment                        !< Internal state flags
    logical        :: reprocess                         !< Internal state flags
    logical        :: stitch                            !< Internal state flags
    character(:), allocatable :: res                    !< Accumulated result line buffers
    character(:), allocatable :: tmp                    !< Accumulated temporary line buffers
    character(MAX_LINE_LEN)   :: line                   !< Raw input line
    character(MAX_LINE_LEN)   :: continued_line         !< Raw and continued input line
    integer :: iline                                    !< Current line number position
    integer :: icontinuation                            !< Continuation position
 
contains
 
    !> Preprocess a file and write result to an optional output file (default: stdout)
    !! Opens the input file, determines the base filename for error messages,
    !! opens the output file if requested, and delegates to the unit-to-unit routine.
    !! @param[in] filepath   Path to the input source file
    !! @param[in] outputfile Optional path to the output file; if absent output goes to stdout
    !!
    !! @b Remarks
    !! @ingroup group_parser
    subroutine preprocess_file(filepath, outputfile)
        character(*), intent(in)            :: filepath
        character(*), intent(in), optional  :: outputfile
        !private
        integer :: iunit, ierr, n, ounit
        character(len=1, kind=c_char) :: buf(256)
 
        open(newunit=iunit, file=filepath, status='old', action='read', iostat=ierr)
 
        if (ierr /= 0) then
            call printf(render(diagnostic_report(level_error, &
                    message='Error opening input file: ' // trim(filepath), &
                    source=name), &
                    ''))
            return
        else
            if (c_associated(getcwd_c(buf, size(buf, kind=c_size_t)))) then
                n = findloc(buf, achar(0), 1)
                name = filepath(n + 1:)
            end if
        end if
 
        if (present(outputfile)) then
            open(newunit=ounit, file=outputfile, status='replace', action='write', iostat=ierr)
            if (ierr /= 0) then
                call printf(render(diagnostic_report(level_error, &
                        message='Error opening input file: ' // trim(outputfile), &
                        source=name), &
                        ''))
                close(iunit)
                return
            end if
        else
            ounit = stdout
        end if
 
        call preprocess(iunit, ounit)
        if (iunit /= stdin) close(iunit)
        if (ounit /= stdout) close(ounit)
    end subroutine
 
    !> Preprocess from an already-open input unit and write to a file
    !! @param[in] iunit Input unit (must already be open for reading)
    !! @param[in] ofile Output filename
    !!
    !! @b Remarks
    !! @ingroup group_parser
    subroutine preprocess_unit_to_file(iunit, ofile)
        integer, intent(in)         :: iunit
        character(*), intent(in)    :: ofile
        !private
        integer :: ierr, ounit
 
        if (iunit /= stdin) then
            inquire(unit = iunit, name=name)
        end if
 
        open(newunit=ounit, file=ofile, status='replace', action='write', iostat=ierr)
        if (ierr /= 0) then
            call printf(render(diagnostic_report(level_error, &
                    message='Error opening input file: ' // trim(ofile), &
                    source=name), &
                    ''))
            close(iunit)
            return
        end if
 
        call preprocess(iunit, ounit)
        if (iunit /= stdin) close(iunit)
        if (ounit /= stdout) close(ounit)
    end subroutine
 
    !> Preprocess a file and write to an already-open output unit
    !! @param[in] ifile Input filename
    !! @param[in] ounit Output unit (already open for writing)
    !!
    !! @b Remarks
    !! @ingroup group_parser
    subroutine preprocess_file_to_unit(ifile, ounit)
        character(*), intent(in)    :: ifile
        integer, intent(in)         :: ounit
        !private
        integer :: iunit, ierr, n
        character(len=1, kind=c_char) :: buf(256)
 
        open(newunit=iunit, file=ifile, status='old', action='read', iostat=ierr)
        if (ierr /= 0) then
            call printf(render(diagnostic_report(level_error, &
                    message='Error opening input file: ' // trim(ifile), &
                    source=name), &
                    ''))
            return
        else
            if (c_associated(getcwd_c(buf, size(buf, kind=c_size_t)))) then
                n = findloc(buf, achar(0), 1)
                name = ifile(n + 1:)
            end if
        end if
 
        call preprocess(iunit, ounit)
        if (iunit /= stdin) close(iunit)
        if (ounit /= stdout) close(ounit)
    end subroutine
 
    !> Core preprocessing routine: read from iunit, write to ounit
    !! Sets up a clean macro environment for the top-level file,
    !! resets conditional compilation state, and calls the worker routine.
    !! @param[in] iunit Input unit
    !! @param[in] ounit Output unit
    !!
    !! @b Remarks
    !! @ingroup group_parser
    subroutine preprocess_unit_to_unit(iunit, ounit)
        integer, intent(in) :: iunit
        integer, intent(in) :: ounit
        !private
        type(macro), allocatable :: macros(:)
 
        if (.not. allocated(global%macros)) allocate(global%macros(0))
        allocate(macros(size_of(global%macros)), source=global%macros)
        if (.not. allocated(global%undef)) allocate(global%undef(0))
        if (.not. allocated(global%includedir)) allocate(global%includedir(0))
 
        cond_depth = 0
        cond_stack(1)%active = .true.
        cond_stack(1)%has_met = .false.
 
        reprocess = .false.;  c_continue = .false.; f_continue = .false.
        icontinuation = 1; iline = 0
        continued_line = ''; res = ''
 
        call preprocess_unit(iunit, ounit, macros, .false.)
        deallocate(macros)
    end subroutine
 
    !> Worker routine that reads lines, handles continuations, comments and directives
    !! This is the main loop that:
    !! - reads lines with interactive prompt when iunit==stdin
    !! - handles both `\` and `&` continuations
    !! - strips or preserves comments appropriately
    !! - calls process_line() for directive processing and macro expansion
    !! - stitches lines when Fortran continuation (`&`) is active
    !! @param[in]    iunit       Input unit
    !! @param[in]    ounit       Output unit
    !! @param[inout] macros(:)   Current macro table (passed by value between include levels)
    !! @param[in]    from_include True if called recursively from #include
    !!
    !! @b Remarks
    !! @ingroup group_parser
    subroutine preprocess_unit(iunit, ounit, macros, from_include)
        integer, intent(in)                     :: iunit
        integer, intent(in)                     :: ounit
        type(macro), allocatable, intent(inout) :: macros(:)
        logical, intent(in)                     :: from_include
        !private
        integer :: ierr, n
 
        do
            if (global%interactive) write(*, '(/a)', advance='no') ' [in]  '  ! Command line prompt
            read(iunit, '(A)', iostat=ierr) line
 
            if (global%interactive) then
                if (line == '') exit
                if (lowercase(trim(adjustl(line))) == 'quit') exit
            end if
            if (ierr /= 0) then
                if (ierr == iostat_end .and. from_include) f_continue = tail(tmp) == '&'
                exit
            end if
            if (.not. from_include) iline = iline + 1
 
            if (c_continue) then
                continued_line = continued_line(:icontinuation) // trim(adjustl(line))
            else
                continued_line = trim(adjustl(line))
            end if
            n = len_trim(continued_line); if (n == 0) cycle
 
            ! Check for line continuation with '\'
            if (verify(continued_line(n:n), '\') == 0) then
                ! Check for line break with '\\'
                if (continued_line(len_trim(continued_line) - 1:len_trim(continued_line)) == '\\' .and. global%line_break) then
                    c_continue = .true.
                    continued_line = continued_line(:len_trim(continued_line) - 2) // new_line('A')  ! Strip '\\'
                    icontinuation = len_trim(continued_line)
                else
                    c_continue = .true.
                    icontinuation = len_trim(continued_line) - 1
                    continued_line = continued_line(:icontinuation)
                end if
                cycle
            else
                c_continue = .false.
 
                tmp = process_line(continued_line, ounit, name, iline, macros, stitch)
                if (len_trim(tmp) == 0) cycle
 
                in_comment = head(tmp) == '!'
 
                if (merge(head(res) == '!', in_comment, len_trim(res) > 0)) then
                    f_continue = tail(tmp) == '&'
                else
                    if (in_comment .and. f_continue) cycle
                    f_continue = .not. in_comment .and. tail(tmp) == '&'
                end if
 
                if ((.not. global%disable_continuation) .and. (f_continue .or. stitch)) then
                    reprocess = .true.
                    res = concat(res, tmp)
                else
                    if (reprocess) then
                        if (.not. in_comment .and. head(res) == '!') then
                            if (is_in_forloop()) then
                                call add_to_loop(res)
                            else
                                write(ounit, '(A)') res
                            end if
                            res = process_line(tmp, ounit, name, iline, macros, stitch)
                        else
                            res = process_line(concat(res, tmp), ounit, name, iline, macros, stitch)
                        end if
                        reprocess = .false.
                    else
                        res = trim(tmp)
                    end if
 
                    if (is_in_forloop()) then
                        call add_to_loop(res)
                    else
                        if (global%interactive) write(*, '(/a)', advance='no') ' [out] '  ! Command line prompt
                        write(ounit, '(A)') res
                    end if
                    res = ''
                end if
            end if
        end do
 
        if (cond_depth > 0) then
            call printf(render(diagnostic_report(level_error, &
                    message='Unclosed conditional block at end of file', &
                    source=name), &
                    trim(line), iline))
        else if (c_continue) then
            call printf(render(diagnostic_report(level_error, &
                    message='Unexpected character', &
                    label=label_type('Trailing new line "\"', len(trim(line)), 1), &
                    source=name), &
                    trim(line), iline))
        end if
    end subroutine
 
    !> Process a single (possibly continued) line – handles directives and macro expansion
    !! Responsibilities:
    !! - Strip or terminate C-style block comments (`/* ... */`)
    !! - Detect and delegate preprocessor directives (`#define`, `#include`, conditionals, etc.)
    !! - Perform macro expansion when the line is in an active conditional block
    !! - Return whether the next line should be stitched (for Fortran `&` continuation inside macros)
    !! @param[in]    current_line Input line (already continued and trimmed)
    !! @param[in]    ounit        Output unit (used only for diagnostics inside called routines)
    !! @param[in]    filepath     Current file name (for error messages)
    !! @param[in]    linenum      Current line number (for error messages)
    !! @param[inout] macros(:)    Macro table
    !! @param[out]   stch         Set to .true. if the expanded line ends with `&` (stitch next line)
    !! @return                    Processed line (directives removed, macros expanded)
    !!
    !! @b Remarks
    !! @ingroup group_parser
    recursive function process_line(current_line, ounit, filepath, linenum, macros, stch) result(rst)
        character(*), intent(in)                :: current_line
        integer, intent(in)                     :: ounit
        character(*), intent(inout)             :: filepath
        integer, intent(inout)                  :: linenum
        type(macro), allocatable, intent(inout) :: macros(:)
        logical, intent(out)                    :: stch
        character(:), allocatable               :: rst
        !private
        character(:), allocatable :: trimmed_line
        logical :: active
        logical, save :: l_in_comment = .false., l_in_loop = .false.
        integer :: idx, comment_start, comment_end, n
        type(context) :: ctx
 
        trimmed_line = trim(adjustl(current_line))
        rst = ''
        comment_end = index(trimmed_line, '*/')
        if (l_in_comment .and. comment_end > 0) then
            trimmed_line = trimmed_line(comment_end + 2:)
            l_in_comment = .false.
        end if
 
        if (l_in_comment) return
        comment_start = index(trimmed_line, '/*')
        if (comment_start > 0) then
            trimmed_line = trimmed_line(:comment_start - 1)
            l_in_comment = comment_end == 0
        end if
        n = len(trimmed_line); if (n == 0) return
 
        active = is_active()
        ctx = context(trimmed_line, linenum, filepath)
        if (head(trimmed_line) == '#') then
            if (len(trimmed_line) == 1) then
                return  !null directive
            else if (starts_with(lowercase(adjustl(trimmed_line(2:))), 'for')) then
                l_in_loop = .true.
                if (global%support_forloop) call handle_for(ctx, macros, 'for')
            else if (starts_with(lowercase(adjustl(trimmed_line(2:))), 'endfor')) then
                l_in_loop = .false.
                if (global%support_forloop) call handle_endfor(ctx, ounit, c_funloc(process_line), macros, 'endfor')
                l_in_loop = is_in_forloop()
            else if (l_in_loop) then
                rst = trimmed_line
            else if (starts_with(lowercase(adjustl(trimmed_line(2:))), 'define') .and. active) then
                call handle_define(ctx, macros, 'define')
            else if (starts_with(lowercase(adjustl(trimmed_line(2:))), 'undef') .and. active) then
                call handle_undef(ctx, macros, 'undef')
            else if (starts_with(lowercase(adjustl(trimmed_line(2:))), 'warning') .and. active) then
                call handle_warning(ctx, macros, 'warning')
            else if (starts_with(lowercase(adjustl(trimmed_line(2:))), 'error') .and. active) then
                call handle_error(ctx, macros, 'error')
            else if (starts_with(lowercase(adjustl(trimmed_line(2:))), 'include') .and. active) then
                call handle_include(ctx, ounit, preprocess_unit, macros, 'include')
            else if (starts_with(lowercase(adjustl(trimmed_line(2:))), 'line')) then
                call handle_line(ctx, 'line')
            else if (starts_with(lowercase(adjustl(trimmed_line(2:))), 'ifdef')) then
                call handle_ifdef(ctx, macros, 'ifdef')
            else if (starts_with(lowercase(adjustl(trimmed_line(2:))), 'ifndef')) then
                call handle_ifndef(ctx, macros, 'ifndef')
            else if (starts_with(lowercase(adjustl(trimmed_line(2:))), 'elifdef')) then
                call handle_elifdef(ctx, macros, 'elifdef')
            else if (starts_with(lowercase(adjustl(trimmed_line(2:))), 'elifndef')) then
                call handle_elifndef(ctx, macros, 'elifndef')
            else if (starts_with(lowercase(adjustl(trimmed_line(2:))), 'if')) then
                call handle_if(ctx, macros, 'if')
            else if (starts_with(lowercase(adjustl(trimmed_line(2:))), 'elif')) then
                call handle_elif(ctx, macros, 'elif')
            else if (starts_with(lowercase(adjustl(trimmed_line(2:))), 'else')) then
                call handle_else(ctx)
            else if (starts_with(lowercase(adjustl(trimmed_line(2:))), 'endif')) then
                call handle_endif(ctx)
            else if (starts_with(lowercase(adjustl(trimmed_line(2:))), 'pragma') .and. active) then
                rst = ctx%content
            else
                return
            end if
        else if (active) then
            if (.not. global%expand_macros .or. is_in_forloop()) then
                rst = trimmed_line
            else
                rst = adjustl(expand_all(ctx, macros, stch, global%extra_macros, global%implicit_continuation, &
                        global%implicit_continuation))
            end if
        end if
    end function
end module