!># Store compiler commands in a `compile_commands.json` table module fpm_compile_commands use fpm_toml, only: serializable_t, set_string, set_list, get_value, get_list, add_table, & toml_array, add_array, toml_stat, len use tomlf, only: toml_table use jonquil, only: json_serialize, json_ser_config use fpm_strings, only: string_t, operator(==) use fpm_error, only: error_t, syntax_error, fatal_error use fpm_os, only: get_current_directory use fpm_environment, only: get_os_type, OS_WINDOWS use shlex_module, only: sh_split => split, ms_split implicit none !> Definition of a build command type, extends(serializable_t) :: compile_command_t type(string_t) :: directory type(string_t), allocatable :: arguments(:) type(string_t) :: file contains !> Operation procedure :: destroy => compile_command_destroy !> Serialization interface procedure :: serializable_is_same => compile_command_is_same procedure :: dump_to_toml => compile_command_dump_toml procedure :: load_from_toml => compile_command_load_toml end type compile_command_t type, extends(serializable_t) :: compile_command_table_t type(compile_command_t), allocatable :: command(:) contains !> Operation procedure :: destroy => cct_destroy procedure :: write => cct_write procedure, private :: cct_register procedure, private :: cct_register_object generic :: register => cct_register, & cct_register_object !> Serialization interface procedure :: serializable_is_same => cct_is_same procedure :: dump_to_toml => cct_dump_toml procedure :: load_from_toml => cct_load_toml end type compile_command_table_t interface compile_command_t module procedure cct_new end interface compile_command_t contains !> Override default initializer (GCC 15 bug) type(compile_command_t) function cct_new(directory,arguments,file) result(cct) character(len=*), intent(in) :: directory,file character(len=*), optional, intent(in) :: arguments(:) integer :: i,n cct%directory = string_t(trim(directory)) cct%file = string_t(trim(file)) if (present(arguments)) then n = size(arguments) else n = 0 endif allocate(cct%arguments(n)) do i=1,n cct%arguments(i) = string_t(trim(arguments(i))) end do end function cct_new !> Cleanup compile command elemental subroutine compile_command_destroy(self) !> Instance of the serializable object class(compile_command_t), intent(inout) :: self if (allocated(self%directory%s))deallocate(self%directory%s) if (allocated(self%arguments))deallocate(self%arguments) if (allocated(self%file%s))deallocate(self%file%s) end subroutine compile_command_destroy !> Dump compile_command_t to toml table subroutine compile_command_dump_toml(self, table, error) !> Instance of the serializable object class(compile_command_t), intent(inout) :: self !> Data structure type(toml_table), intent(inout) :: table !> Error handling type(error_t), allocatable, intent(out) :: error call set_list(table, "arguments", self%arguments, error) if (allocated(error)) return call set_string(table, "directory", self%directory, error, 'compile_command_t') if (allocated(error)) return call set_string(table, "file", self%file, error, 'compile_command_t') if (allocated(error)) return end subroutine compile_command_dump_toml !> Read compile_command_t from toml table (no checks made at this stage) subroutine compile_command_load_toml(self, table, error) !> Instance of the serializable object class(compile_command_t), intent(inout) :: self !> Data structure type(toml_table), intent(inout) :: table !> Error handling type(error_t), allocatable, intent(out) :: error call self%destroy() call get_list(table, "arguments", self%arguments, error) if (allocated(error)) return ! Return unallocated value if not present call get_value(table, "directory", self%directory%s) call get_value(table, "file", self%file%s) end subroutine compile_command_load_toml !> Check that two compile_command_t objects are equal logical function compile_command_is_same(this,that) class(compile_command_t), intent(in) :: this class(serializable_t), intent(in) :: that compile_command_is_same = .false. select type (other=>that) type is (compile_command_t) if (.not.this%directory==other%directory) return if (.not.this%arguments==other%arguments) return if (.not.this%file==other%file) return class default ! Not the same type return end select !> All checks passed! compile_command_is_same = .true. end function compile_command_is_same !> Dump compile_command_table_t to a toml array subroutine cct_dump_array(self, array, error) !> Instance of the serializable object class(compile_command_table_t), intent(inout) :: self !> Data structure type(toml_array), intent(inout) :: array !> Error handling type(error_t), allocatable, intent(out) :: error integer :: ii, stat type(toml_table), pointer :: item if (.not.allocated(self%command)) return do ii = 1, size(self%command) associate (cmd => self%command(ii)) ! Set node for this command call add_table(array, item, stat) if (stat /= toml_stat%success) then call fatal_error(error, "Cannot store entry in compile_command_table_t array") return end if call cmd%dump_to_toml(item, error) if (allocated(error)) return endassociate end do end subroutine cct_dump_array !> Write compile_commands.json file. Because Jonquil does not support non-named arrays, !> create a custom json here. subroutine cct_write(self, filename, error) !> Instance of the serializable object class(compile_command_table_t), intent(inout) :: self !> The file name character(*), intent(in) :: filename !> Error handling type(error_t), allocatable, intent(out) :: error type(toml_array) :: array type(json_ser_config) :: cfg integer :: stat, lun ! Init array array = toml_array() ! Dump information to the array call cct_dump_array(self, array, error) if (allocated(error)) return ! Open file and write to it open(newunit=lun,file=filename,form='formatted',action='write',status='replace',iostat=stat) if (stat/=0) then call fatal_error(error, 'cannot open file '//filename//' for writing') return end if ! Ensure the array has no key if (allocated(array%key)) deallocate(array%key) cfg%indent = repeat(' ',3) write (lun, '(A)', iostat=stat, err=1) json_serialize(array, cfg) close(lun,iostat=stat) 1 if (stat/=0) then call fatal_error(error, 'cannot close file '//filename//' after writing') return end if end subroutine cct_write !> Cleanup a compile command table elemental subroutine cct_destroy(self) !> Instance of the serializable object class(compile_command_table_t), intent(inout) :: self if (allocated(self%command)) deallocate(self%command) end subroutine cct_destroy !> Register a new compile command subroutine cct_register(self, command, target_os, error) !> Instance of the serializable object class(compile_command_table_t), intent(inout) :: self !> Data structure character(len=*), intent(in) :: command !> The target OS of the compile_commands.json (may be cross-compiling) integer, intent(in) :: target_os !> Error handling type(error_t), allocatable, intent(out) :: error ! Local variables type(compile_command_t) :: cmd character(len=:), allocatable :: args(:), cwd, source_file logical :: sh_success integer :: i,n ! Early check if (len_trim(command) <= 0) then call syntax_error(error, "compile_command_table_t trying to register an empty command") return end if ! Tokenize the input command into args(:) if (target_os==OS_WINDOWS) then args = ms_split(command, ucrt=.true., success=sh_success) else args = sh_split(command, join_spaced=.false., keep_quotes=.true., success=sh_success) end if n = size(args) if (n==0 .or. .not.sh_success) then call syntax_error(error, "compile_command_table_t failed tokenizing: <"//command//">") return end if ! Get current working directory call get_current_directory(cwd, error) if (allocated(error)) return ! Try to find the source file allocate(character(len=0) :: source_file) find_source_file: do i = 1, n-1 if (args(i) == "-c") then source_file = trim(args(i+1)) exit find_source_file end if end do find_source_file ! Fallback: use last argument if not found if (len_trim(source_file)==0) source_file = trim(args(n)) ! Fill in the compile_command_t. ! Use non-default initializer due to gcc 15 bug cmd = compile_command_t(cwd, args, source_file) ! Add it to the structure !$omp critical (command_update) call cct_register_object(self, cmd, error) !$omp end critical (command_update) end subroutine cct_register pure subroutine cct_register_object(self, command, error) !> Instance of the serializable object class(compile_command_table_t), intent(inout) :: self !> Data structure type(compile_command_t), intent(in) :: command !> Error handling type(error_t), allocatable, intent(out) :: error if (allocated(self%command)) then self%command = [self%command, command] else allocate(self%command(1), source=command) end if end subroutine cct_register_object !> Dump compile_command_table_t to toml table subroutine cct_dump_toml(self, table, error) !> Instance of the serializable object class(compile_command_table_t), intent(inout) :: self !> Data structure type(toml_table), intent(inout) :: table !> Error handling type(error_t), allocatable, intent(out) :: error integer :: stat, ii type(toml_array), pointer :: array ! Create array call add_array(table, 'compile_commands', array, stat=stat) if (stat/=toml_stat%success .or. .not.associated(array)) then call fatal_error(error,"compile_command_table_t cannot create entry") return end if ! Dump to it call cct_dump_array(self, array, error) end subroutine cct_dump_toml !> Read compile_command_table_t from toml table (no checks made at this stage) subroutine cct_load_toml(self, table, error) !> Instance of the serializable object class(compile_command_table_t), intent(inout) :: self !> Data structure type(toml_table), intent(inout) :: table !> Error handling type(error_t), allocatable, intent(out) :: error integer :: stat, i, n type(toml_array), pointer :: array type(toml_table), pointer :: elem call self%destroy() call get_value(table, key='compile_commands', ptr=array, requested=.true.,stat=stat) if (stat/=toml_stat%success .or. .not.associated(array)) then call fatal_error(error, "TOML table has no 'compile_commands' key") return else n = len(array) if (n<=0) return allocate(self%command(n)) do i = 1, n call get_value(array, pos=i, ptr=elem, stat=stat) if (stat /= toml_stat%success .or. .not.associated(elem)) then call fatal_error(error, "Entry in 'compile_commands' field cannot be read") return end if call self%command(i)%load(elem, error) if (allocated(error)) return end do end if end subroutine cct_load_toml !> Check that two compile_command_table_t objects are equal logical function cct_is_same(this,that) class(compile_command_table_t), intent(in) :: this class(serializable_t), intent(in) :: that integer :: i cct_is_same = .false. select type (other=>that) type is (compile_command_table_t) if (allocated(this%command).neqv.allocated(other%command)) return if (allocated(this%command)) then if (.not.(size (this%command) ==size (other%command))) return if (.not.(ubound(this%command,1)==ubound(other%command,1))) return if (.not.(lbound(this%command,1)==lbound(other%command,1))) return do i=lbound(this%command,1),ubound(this%command,1) if (.not.this%command(i)==other%command(i)) return end do end if class default ! Not the same type return end select !> All checks passed! cct_is_same = .true. end function cct_is_same end module fpm_compile_commands