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).
!!
!! @par Processing Pipeline
!! Source files are processed in several stages:
!!
!! 1. Input acquisition from files, units, or stdin
!! 2. C-style continuation handling (`\`, `\\`)
!! 3. Fortran continuation handling (`&`)
!! 4. C-style block comment removal
!! 5. Directive recognition and execution
!! 6. Conditional compilation evaluation
!! 7. Macro expansion
!! 8. Emission to the output stream
!!
!! Include files recursively invoke the same processing pipeline.
!!
!! @par Parser State
!! The parser maintains module-level state describing:
!! - current source file,
!! - line continuation status,
!! - comment state,
!! - deferred reprocessing buffers,
!! - interactive mode output state.
!!
!! This state is reset at the beginning of each top-level preprocessing run.
!!
!! The parser coordinates several specialized subsystems:
!!
!! - @ref group_define     for macro definition directives,
!! - @ref group_include    for include processing,
!! - @ref group_macro      for macro expansion,
!! - @ref group_conditional for conditional compilation,
!! - @ref group_for        for non-standard loop directives,
!! - @ref group_diagnostics for reporting.
!!
!! @par fpx Extensions
!! In addition to standard preprocessing facilities, fpx provides:
!! - `#for` / `#endfor`
!! - `${NAME}` macro insertion
!! - implicit continuation support
!! - interactive REPL mode
!! - enhanced diagnostics
!! @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)
    !!
    !! @section preprocess_overloads Overloads
    !!
    !! @code{.f90}preprocess(character(*))@endcode
    !! Preprocess a source file and write to stdout.
    !!
    !! @code{.f90}preprocess(character(*), character(*))@endcode
    !! Preprocess a source file and write to another file.
    !!
    !! @code{.f90}preprocess(integer, integer)@endcode
    !! Preprocess an already-open input unit to an output unit.
    !!
    !! @code{.f90}preprocess(integer, character(*))@endcode
    !! Preprocess an already-open input unit to a file.
    !!
    !! @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
    !!
    !! @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
    !!
    !! @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)
    !!
    !! @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.
    !!
    !! A local copy of the global macro table is created so that
    !! preprocessing sessions remain isolated while preserving
    !! command-line definitions.
    !!
    !! @param[in] iunit Input unit
    !! @param[in] ounit Output unit
    !!
    !! @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
    !! @par Main Loop
    !! The routine repeatedly:
    !! - reads a physical line,
    !! - merges continuations,
    !! - processes directives,
    !! - performs macro expansion,
    !! - handles deferred Fortran continuation stitching,
    !! - emits output.
    !!
    !! @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
    !!
    !! @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)
    !! This routine acts as the dispatcher for all preprocessing
    !! directives and ordinary source lines.
    !!
    !! Directives are interpreted immediately, whereas ordinary
    !! lines undergo macro expansion only when the current
    !! conditional compilation state is active.
    !! @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)
    !!
    !! @see 
    !! @link fpx_macro::expand_all expand_all @endlink
    !! @link fpx_define::handle_define handle_define @endlink
    !! @link fpx_include::handle_include handle_include @endlink
    !!
    !! @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