From b83d26c9d4317a0443edce511c7ec32ad61bd453 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Sat, 29 Mar 2025 15:20:23 +0100 Subject: [PATCH 01/27] toml serialization interfaces returning fpm error types --- src/fpm/toml.f90 | 53 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 53 insertions(+) diff --git a/src/fpm/toml.f90 b/src/fpm/toml.f90 index 762a408784..64baa09b69 100644 --- a/src/fpm/toml.f90 +++ b/src/fpm/toml.f90 @@ -78,6 +78,8 @@ module fpm_toml module procedure get_logical module procedure get_integer module procedure get_integer_64 + module procedure get_char + module procedure get_string end interface get_value @@ -704,6 +706,57 @@ subroutine get_integer(table, key, var, error, whereAt) end subroutine get_integer + !> Function wrapper to get a default string variable from a toml table, returning an fpm error + subroutine get_string(table, key, var, error, whereAt) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> The key + character(len=*), intent(in) :: key + + !> The variable + type(string_t), intent(inout) :: var + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Optional description + character(len=*), intent(in), optional :: whereAt + + call get_char(table, key, var%s, error, whereAt) + + end subroutine get_string + + !> Function wrapper to get a default character variable from a toml table, returning an fpm error + subroutine get_char(table, key, var, error, whereAt) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> The key + character(len=*), intent(in) :: key + + !> The variable + character(len=:), allocatable, intent(inout) :: var + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Optional description + character(len=*), intent(in), optional :: whereAt + + integer :: ierr + + call get_value(table, key, var, stat=ierr) + if (ierr/=toml_stat%success) then + call fatal_error(error,'cannot get string key <'//key//'> from TOML table') + if (present(whereAt)) error%message = whereAt//': '//error%message + return + end if + + end subroutine get_char + !> Function wrapper to get a integer(int64) variable from a toml table, returning an fpm error subroutine get_integer_64(table, key, var, error, whereAt) From fbc0bd5b909f0ac61656684fa5d6f88fdff3cbb0 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Sat, 29 Mar 2025 15:20:33 +0100 Subject: [PATCH 02/27] implement `compile_command_t` --- src/fpm_compiler.F90 | 89 +++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 87 insertions(+), 2 deletions(-) diff --git a/src/fpm_compiler.F90 b/src/fpm_compiler.F90 index 39bbe90255..608a413699 100644 --- a/src/fpm_compiler.F90 +++ b/src/fpm_compiler.F90 @@ -39,10 +39,12 @@ module fpm_compiler OS_UNKNOWN use fpm_filesystem, only: join_path, basename, get_temp_filename, delete_file, unix_path, & & getline, run -use fpm_strings, only: split, string_cat, string_t, str_ends_with, str_begins_with_str +use fpm_strings, only: split, string_cat, string_t, str_ends_with, str_begins_with_str, & + & operator(==) use fpm_manifest, only : package_config_t use fpm_error, only: error_t, fatal_error -use fpm_toml, only: serializable_t, toml_table, set_string, set_value, toml_stat, get_value +use fpm_toml, only: serializable_t, toml_table, set_string, set_value, toml_stat, get_value, & + & get_list, set_list implicit none public :: compiler_t, new_compiler, archiver_t, new_archiver, get_macros public :: debug @@ -72,6 +74,23 @@ module fpm_compiler end enum integer, parameter :: compiler_enum = kind(id_unknown) +!> 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 + + !> Serialization procedures + 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 !> Definition of compiler object type, extends(serializable_t) :: compiler_t @@ -1500,4 +1519,70 @@ logical function with_xdp(self) ('if (any(selected_real_kind(18) == [-1, selected_real_kind(33)])) stop 1; end') end function with_xdp +!> 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_string(table, "directory", self%directory, error, 'compile_command_t') + if (allocated(error)) return + call set_list(table, "arguments", self%arguments, error) + 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 get_value(table, "directory", self%directory, error, 'compile_command_t') + if (allocated(error)) return + call get_list(table, "arguments", self%arguments, error) + if (allocated(error)) return + call get_value(table, "file", self%file, error, 'compile_command_t') + if (allocated(error)) return + +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 + end module fpm_compiler From e5c1cd60a4dc367d3ec7952f3b65cb6a89a707b0 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Sat, 29 Mar 2025 15:24:48 +0100 Subject: [PATCH 03/27] move to separate module --- src/fpm_compile_commands.F90 | 96 ++++++++++++++++++++++++++++++++++++ src/fpm_compiler.F90 | 90 ++------------------------------- 2 files changed, 99 insertions(+), 87 deletions(-) create mode 100644 src/fpm_compile_commands.F90 diff --git a/src/fpm_compile_commands.F90 b/src/fpm_compile_commands.F90 new file mode 100644 index 0000000000..56c058cbef --- /dev/null +++ b/src/fpm_compile_commands.F90 @@ -0,0 +1,96 @@ +!># 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, toml_table + use fpm_strings, only: string_t, operator(==) + use fpm_error, only: error_t + 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 + + !> Serialization procedures + 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 + + + contains + + !> 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_string(table, "directory", self%directory, error, 'compile_command_t') + if (allocated(error)) return + call set_list(table, "arguments", self%arguments, error) + 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 get_value(table, "directory", self%directory, error, 'compile_command_t') + if (allocated(error)) return + call get_list(table, "arguments", self%arguments, error) + if (allocated(error)) return + call get_value(table, "file", self%file, error, 'compile_command_t') + if (allocated(error)) return + + 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 + + +end module fpm_compile_commands diff --git a/src/fpm_compiler.F90 b/src/fpm_compiler.F90 index 608a413699..319267a01b 100644 --- a/src/fpm_compiler.F90 +++ b/src/fpm_compiler.F90 @@ -39,12 +39,11 @@ module fpm_compiler OS_UNKNOWN use fpm_filesystem, only: join_path, basename, get_temp_filename, delete_file, unix_path, & & getline, run -use fpm_strings, only: split, string_cat, string_t, str_ends_with, str_begins_with_str, & - & operator(==) +use fpm_strings, only: split, string_cat, string_t, str_ends_with, str_begins_with_str use fpm_manifest, only : package_config_t use fpm_error, only: error_t, fatal_error -use fpm_toml, only: serializable_t, toml_table, set_string, set_value, toml_stat, get_value, & - & get_list, set_list +use fpm_toml, only: serializable_t, toml_table, set_string, set_value, toml_stat, get_value +use fpm_compile_commands, only: compile_command_t implicit none public :: compiler_t, new_compiler, archiver_t, new_archiver, get_macros public :: debug @@ -74,24 +73,6 @@ module fpm_compiler end enum integer, parameter :: compiler_enum = kind(id_unknown) -!> 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 - - !> Serialization procedures - 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 - !> Definition of compiler object type, extends(serializable_t) :: compiler_t !> Identifier of the compiler @@ -1519,70 +1500,5 @@ logical function with_xdp(self) ('if (any(selected_real_kind(18) == [-1, selected_real_kind(33)])) stop 1; end') end function with_xdp -!> 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_string(table, "directory", self%directory, error, 'compile_command_t') - if (allocated(error)) return - call set_list(table, "arguments", self%arguments, error) - 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 get_value(table, "directory", self%directory, error, 'compile_command_t') - if (allocated(error)) return - call get_list(table, "arguments", self%arguments, error) - if (allocated(error)) return - call get_value(table, "file", self%file, error, 'compile_command_t') - if (allocated(error)) return - -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 end module fpm_compiler From dd42e2d5a42fb6994d40247d1da644752cb84d83 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Sat, 29 Mar 2025 15:28:51 +0100 Subject: [PATCH 04/27] implement compile_command_table_t --- src/fpm_compile_commands.F90 | 88 +++++++++++++++++++++++++++++++++++- 1 file changed, 87 insertions(+), 1 deletion(-) diff --git a/src/fpm_compile_commands.F90 b/src/fpm_compile_commands.F90 index 56c058cbef..a4d0c6af94 100644 --- a/src/fpm_compile_commands.F90 +++ b/src/fpm_compile_commands.F90 @@ -16,13 +16,26 @@ module fpm_compile_commands contains - !> Serialization procedures + !> 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 + + !> 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 contains @@ -92,5 +105,78 @@ logical function compile_command_is_same(this,that) end function compile_command_is_same + !> 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 + +! call set_string(table, "directory", self%directory, error, 'compile_command_table_t') +! if (allocated(error)) return +! call set_list(table, "arguments", self%arguments, error) +! if (allocated(error)) return +! call set_string(table, "file", self%file, error, 'compile_command_table_t') +! if (allocated(error)) return + + 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 + +! call get_value(table, "directory", self%directory, error, 'compile_command_table_t') +! if (allocated(error)) return +! call get_list(table, "arguments", self%arguments, error) +! if (allocated(error)) return +! call get_value(table, "file", self%file, error, 'compile_command_table_t') +! if (allocated(error)) return + + 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 From 3c950a8ea5ea2178d8fe90f5686c577b37e3f23d Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Tue, 1 Apr 2025 20:03:01 +0200 Subject: [PATCH 05/27] dump compile_commands to toml table --- src/fpm_compile_commands.F90 | 34 +++++++++++++++++++++++++++------- 1 file changed, 27 insertions(+), 7 deletions(-) diff --git a/src/fpm_compile_commands.F90 b/src/fpm_compile_commands.F90 index a4d0c6af94..80d43c35cc 100644 --- a/src/fpm_compile_commands.F90 +++ b/src/fpm_compile_commands.F90 @@ -25,6 +25,7 @@ module fpm_compile_commands type, extends(serializable_t) :: compile_command_table_t + type(compile_command_t), allocatable :: command(:) contains @@ -116,13 +117,32 @@ subroutine cct_dump_toml(self, table, error) !> Error handling type(error_t), allocatable, intent(out) :: error - -! call set_string(table, "directory", self%directory, error, 'compile_command_table_t') -! if (allocated(error)) return -! call set_list(table, "arguments", self%arguments, error) -! if (allocated(error)) return -! call set_string(table, "file", self%file, error, 'compile_command_table_t') -! if (allocated(error)) return + + integer :: ii + type(toml_table), pointer :: ptr + character(64) :: name + + if (.not.allocated(self%command)) return + + do ii = 1, size(self%command) + associate (cmd => self%command(ii)) + + ! Set node for this command + write(name,1) ii + call add_table(table, trim(name), ptr) + if (.not. associated(ptr)) then + call fatal_error(error, "compile_command_table_t cannot create entry for "//trim(name)) + return + end if + + ! Dump node + call cmd%dump_to_toml(ptr, error) + if (allocated(error)) return + + endassociate + end do + + 1 format('compile_command_',i0) end subroutine cct_dump_toml From 58811b2ef9750c0e246e4f48ffafa36475da4d6e Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Sat, 12 Apr 2025 15:37:59 +0200 Subject: [PATCH 06/27] register a compile command --- fpm.toml | 2 +- src/fpm_compile_commands.F90 | 83 ++++++++++++++++++++++++++++++++++-- 2 files changed, 81 insertions(+), 4 deletions(-) diff --git a/fpm.toml b/fpm.toml index d6052a4359..881d0325c2 100644 --- a/fpm.toml +++ b/fpm.toml @@ -21,7 +21,7 @@ fortran-regex.tag = "1.1.2" jonquil.git = "https://github.com/toml-f/jonquil" jonquil.rev = "4fbd4cf34d577c0fd25e32667ee9e41bf231ece8" fortran-shlex.git = "https://github.com/perazz/fortran-shlex" -fortran-shlex.tag = "1.0.1" +fortran-shlex.tag = "1.2.1" [[test]] name = "cli-test" diff --git a/src/fpm_compile_commands.F90 b/src/fpm_compile_commands.F90 index 80d43c35cc..699492e481 100644 --- a/src/fpm_compile_commands.F90 +++ b/src/fpm_compile_commands.F90 @@ -1,8 +1,10 @@ !># 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, toml_table + use fpm_toml, only: serializable_t, set_string, set_list, get_value, get_list, toml_table, add_table use fpm_strings, only: string_t, operator(==) - use fpm_error, only: error_t + use fpm_error, only: error_t, syntax_error, fatal_error + use fpm_os, only: get_current_directory + use shlex_module, only: shlex_split => split implicit none !> Definition of a build command @@ -25,11 +27,14 @@ module fpm_compile_commands type, extends(serializable_t) :: compile_command_table_t - type(compile_command_t), allocatable :: command(:) contains + !> Operation + procedure :: destroy => cct_destroy + procedure :: register => cct_register + !> Serialization interface procedure :: serializable_is_same => cct_is_same procedure :: dump_to_toml => cct_dump_toml @@ -145,7 +150,79 @@ subroutine cct_dump_toml(self, table, error) 1 format('compile_command_',i0) end subroutine cct_dump_toml + + !> 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, error) + !> Instance of the serializable object + class(compile_command_table_t), intent(inout) :: self + + !> Data structure + character(len=*), intent(in) :: command + + !> 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(:) + args = shlex_split(command, join_spaced=.true., keep_quotes=.true., success=sh_success) + 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 = 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 = args(n) + + ! Fill in the compile_command_t + cmd = compile_command_t(directory = string_t(cwd), & + arguments = [(string_t(trim(args(i))), i=1,n)], & + file = string_t(source_file)) + + if (allocated(self%command)) then + self%command = [self%command, cmd] + else + allocate(self%command(1), source=cmd) + end if + + end subroutine cct_register + !> Read compile_command_table_t from toml table (no checks made at this stage) subroutine cct_load_toml(self, table, error) From 9a1d3ad804bec81a97470be95a502cc25034ccbb Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Sat, 12 Apr 2025 15:50:38 +0200 Subject: [PATCH 07/27] register compile commands into the compiler --- src/fpm_compiler.F90 | 81 ++++++++++++++++++++++++++++++++++++-------- 1 file changed, 67 insertions(+), 14 deletions(-) diff --git a/src/fpm_compiler.F90 b/src/fpm_compiler.F90 index 319267a01b..5b1f744fec 100644 --- a/src/fpm_compiler.F90 +++ b/src/fpm_compiler.F90 @@ -43,7 +43,7 @@ module fpm_compiler use fpm_manifest, only : package_config_t use fpm_error, only: error_t, fatal_error use fpm_toml, only: serializable_t, toml_table, set_string, set_value, toml_stat, get_value -use fpm_compile_commands, only: compile_command_t +use fpm_compile_commands, only: compile_command_t, compile_command_table_t implicit none public :: compiler_t, new_compiler, archiver_t, new_archiver, get_macros public :: debug @@ -1097,7 +1097,7 @@ end subroutine new_archiver !> Compile a Fortran object -subroutine compile_fortran(self, input, output, args, log_file, stat) +subroutine compile_fortran(self, input, output, args, log_file, stat, table) !> Instance of the compiler object class(compiler_t), intent(in) :: self !> Source file input @@ -1110,14 +1110,30 @@ subroutine compile_fortran(self, input, output, args, log_file, stat) character(len=*), intent(in) :: log_file !> Status flag integer, intent(out) :: stat + !> Optional compile_commands table + type(compile_command_table_t), optional, intent(inout) :: table + + character(len=:), allocatable :: command + type(error_t), allocatable :: error + + ! Set command + command = self%fc // " -c " // input // " " // args // " -o " // output - call run(self%fc // " -c " // input // " " // args // " -o " // output, & - & echo=self%echo, verbose=self%verbose, redirect=log_file, exitstat=stat) + ! Execute command + call run(command, echo=self%echo, verbose=self%verbose, redirect=log_file, exitstat=stat) + if (stat/=0) return + + ! Optionally register compile command + if (present(table)) then + call table%register(command, error) + stat = merge(-1,0,allocated(error)) + endif + end subroutine compile_fortran !> Compile a C object -subroutine compile_c(self, input, output, args, log_file, stat) +subroutine compile_c(self, input, output, args, log_file, stat, table) !> Instance of the compiler object class(compiler_t), intent(in) :: self !> Source file input @@ -1130,13 +1146,29 @@ subroutine compile_c(self, input, output, args, log_file, stat) character(len=*), intent(in) :: log_file !> Status flag integer, intent(out) :: stat + !> Optional compile_commands table + type(compile_command_table_t), optional, intent(inout) :: table + + character(len=:), allocatable :: command + type(error_t), allocatable :: error + + ! Set command + command = self%cc // " -c " // input // " " // args // " -o " // output - call run(self%cc // " -c " // input // " " // args // " -o " // output, & - & echo=self%echo, verbose=self%verbose, redirect=log_file, exitstat=stat) + ! Execute command + call run(command, echo=self%echo, verbose=self%verbose, redirect=log_file, exitstat=stat) + if (stat/=0) return + + ! Optionally register compile command + if (present(table)) then + call table%register(command, error) + stat = merge(-1,0,allocated(error)) + endif + end subroutine compile_c !> Compile a CPP object -subroutine compile_cpp(self, input, output, args, log_file, stat) +subroutine compile_cpp(self, input, output, args, log_file, stat, table) !> Instance of the compiler object class(compiler_t), intent(in) :: self !> Source file input @@ -1149,9 +1181,25 @@ subroutine compile_cpp(self, input, output, args, log_file, stat) character(len=*), intent(in) :: log_file !> Status flag integer, intent(out) :: stat + !> Optional compile_commands table + type(compile_command_table_t), optional, intent(inout) :: table + + character(len=:), allocatable :: command + type(error_t), allocatable :: error + + ! Set command + command = self%cxx // " -c " // input // " " // args // " -o " // output - call run(self%cxx // " -c " // input // " " // args // " -o " // output, & - & echo=self%echo, verbose=self%verbose, redirect=log_file, exitstat=stat) + ! Execute command + call run(command, echo=self%echo, verbose=self%verbose, redirect=log_file, exitstat=stat) + if (stat/=0) return + + ! Optionally register compile command + if (present(table)) then + call table%register(command, error) + stat = merge(-1,0,allocated(error)) + endif + end subroutine compile_cpp !> Link an executable @@ -1166,12 +1214,17 @@ subroutine link(self, output, args, log_file, stat) character(len=*), intent(in) :: log_file !> Status flag integer, intent(out) :: stat - - call run(self%fc // " " // args // " -o " // output, echo=self%echo, & - & verbose=self%verbose, redirect=log_file, exitstat=stat) + + character(len=:), allocatable :: command + + ! Set command + command = self%fc // " " // args // " -o " // output + + ! Execute command + call run(command, echo=self%echo, verbose=self%verbose, redirect=log_file, exitstat=stat) + end subroutine link - !> Create an archive !> @todo For Windows OS, use the local `delete_file_win32` in stead of `delete_file`. !> This may be related to a bug in Mingw64-openmp and is expected to be resolved in the future, From 99d067fe425e1c4b5e3c7a39082cf3a74a8108af Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Sat, 12 Apr 2025 15:54:15 +0200 Subject: [PATCH 08/27] `link` shadows a GNU intrinsic: change name --- src/fpm_compiler.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/fpm_compiler.F90 b/src/fpm_compiler.F90 index 5b1f744fec..3a9e461ab5 100644 --- a/src/fpm_compiler.F90 +++ b/src/fpm_compiler.F90 @@ -105,7 +105,7 @@ module fpm_compiler !> Compile a CPP object procedure :: compile_cpp !> Link executable - procedure :: link + procedure :: link => link_executable !> Check whether compiler is recognized procedure :: is_unknown !> Check whether this is an Intel compiler @@ -1203,7 +1203,7 @@ subroutine compile_cpp(self, input, output, args, log_file, stat, table) end subroutine compile_cpp !> Link an executable -subroutine link(self, output, args, log_file, stat) +subroutine link_executable(self, output, args, log_file, stat) !> Instance of the compiler object class(compiler_t), intent(in) :: self !> Output file of object @@ -1223,7 +1223,7 @@ subroutine link(self, output, args, log_file, stat) ! Execute command call run(command, echo=self%echo, verbose=self%verbose, redirect=log_file, exitstat=stat) -end subroutine link +end subroutine link_executable !> Create an archive !> @todo For Windows OS, use the local `delete_file_win32` in stead of `delete_file`. From b4bc385bc1c3bb154e79544b422a6a3dc939d641 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Sat, 12 Apr 2025 16:03:34 +0200 Subject: [PATCH 09/27] add `compile_commands_table_t` to the build backend --- src/fpm_backend.F90 | 12 +- src/fpm_backend_output.f90 | 361 +++++++++++++++++++------------------ 2 files changed, 190 insertions(+), 183 deletions(-) diff --git a/src/fpm_backend.F90 b/src/fpm_backend.F90 index 94a60abf9c..59dc2d4301 100644 --- a/src/fpm_backend.F90 +++ b/src/fpm_backend.F90 @@ -36,6 +36,7 @@ module fpm_backend FPM_TARGET_C_OBJECT, FPM_TARGET_ARCHIVE, FPM_TARGET_EXECUTABLE, & FPM_TARGET_CPP_OBJECT use fpm_backend_output +use fpm_compile_commands, only: compile_command_table_t implicit none private @@ -125,7 +126,7 @@ subroutine build_package(targets,model,verbose) if (.not.skip_current) then call progress%compiling_status(j) - call build_target(model,queue(j)%ptr,verbose,stat(j)) + call build_target(model,queue(j)%ptr,verbose,progress%compile_commands,stat(j)) call progress%completed_status(j,stat(j)) end if @@ -300,10 +301,11 @@ end subroutine schedule_targets !> !> If successful, also caches the source file digest to disk. !> -subroutine build_target(model,target,verbose,stat) +subroutine build_target(model,target,verbose,table,stat) type(fpm_model_t), intent(in) :: model type(build_target_t), intent(in), target :: target logical, intent(in) :: verbose + type(compile_command_table_t), intent(inout) :: table integer, intent(out) :: stat integer :: fh @@ -318,15 +320,15 @@ subroutine build_target(model,target,verbose,stat) case (FPM_TARGET_OBJECT) call model%compiler%compile_fortran(target%source%file_name, target%output_file, & - & target%compile_flags, target%output_log_file, stat) + & target%compile_flags, target%output_log_file, stat, table) case (FPM_TARGET_C_OBJECT) call model%compiler%compile_c(target%source%file_name, target%output_file, & - & target%compile_flags, target%output_log_file, stat) + & target%compile_flags, target%output_log_file, stat, table) case (FPM_TARGET_CPP_OBJECT) call model%compiler%compile_cpp(target%source%file_name, target%output_file, & - & target%compile_flags, target%output_log_file, stat) + & target%compile_flags, target%output_log_file, stat, table) case (FPM_TARGET_EXECUTABLE) call model%compiler%link(target%output_file, & diff --git a/src/fpm_backend_output.f90 b/src/fpm_backend_output.f90 index 9b4e6bdd46..39d7c6fee1 100644 --- a/src/fpm_backend_output.f90 +++ b/src/fpm_backend_output.f90 @@ -1,178 +1,183 @@ -!># Build Backend Progress Output -!> This module provides a derived type `build_progress_t` for printing build status -!> and progress messages to the console while the backend is building the package. -!> -!> The `build_progress_t` type supports two modes: `normal` and `plain` -!> where the former does 'pretty' output and the latter does not. -!> The `normal` mode is intended for typical interactive usage whereas -!> 'plain' mode is used with the `--verbose` flag or when `stdout` is not attached -!> to a terminal (e.g. when piping or redirecting `stdout`). In these cases, -!> the pretty output must be suppressed to avoid control codes being output. - -module fpm_backend_output -use iso_fortran_env, only: stdout=>output_unit -use fpm_filesystem, only: basename -use fpm_targets, only: build_target_ptr -use fpm_backend_console, only: console_t, LINE_RESET, COLOR_RED, COLOR_GREEN, COLOR_YELLOW, COLOR_RESET -implicit none - -private -public build_progress_t - -!> Build progress object -type build_progress_t - !> Console object for updating console lines - type(console_t) :: console - !> Number of completed targets - integer :: n_complete - !> Total number of targets scheduled - integer :: n_target - !> 'Plain' output (no colors or updating) - logical :: plain_mode = .true. - !> Store needed when updating previous console lines - integer, allocatable :: output_lines(:) - !> Queue of scheduled build targets - type(build_target_ptr), pointer :: target_queue(:) -contains - !> Output 'compiling' status for build target - procedure :: compiling_status => output_status_compiling - !> Output 'complete' status for build target - procedure :: completed_status => output_status_complete - !> Output finished status for whole package - procedure :: success => output_progress_success -end type build_progress_t - -!> Constructor for build_progress_t -interface build_progress_t - procedure :: new_build_progress -end interface build_progress_t - -contains - - !> Initialise a new build progress object - function new_build_progress(target_queue,plain_mode) result(progress) - !> The queue of scheduled targets - type(build_target_ptr), intent(in), target :: target_queue(:) - !> Enable 'plain' output for progress object - logical, intent(in), optional :: plain_mode - !> Progress object to initialise - type(build_progress_t) :: progress - - progress%n_target = size(target_queue,1) - progress%target_queue => target_queue - progress%plain_mode = plain_mode - progress%n_complete = 0 - - allocate(progress%output_lines(progress%n_target)) - - end function new_build_progress - - !> Output 'compiling' status for build target and overall percentage progress - subroutine output_status_compiling(progress, queue_index) - !> Progress object - class(build_progress_t), intent(inout) :: progress - !> Index of build target in the target queue - integer, intent(in) :: queue_index - - character(:), allocatable :: target_name - character(100) :: output_string - character(7) :: overall_progress - - associate(target=>progress%target_queue(queue_index)%ptr) - - if (allocated(target%source)) then - target_name = basename(target%source%file_name) - else - target_name = basename(target%output_file) - end if - - write(overall_progress,'(A,I3,A)') '[',100*progress%n_complete/progress%n_target,'%] ' - - if (progress%plain_mode) then ! Plain output - - !$omp critical - write(*,'(A7,A30)') overall_progress,target_name - !$omp end critical - - else ! Pretty output - - write(output_string,'(A,T40,A,A)') target_name, COLOR_YELLOW//'compiling...'//COLOR_RESET - - call progress%console%write_line(trim(output_string),progress%output_lines(queue_index)) - - call progress%console%write_line(overall_progress//'Compiling...',advance=.false.) - - end if - - end associate - - end subroutine output_status_compiling - - !> Output 'complete' status for build target and update overall percentage progress - subroutine output_status_complete(progress, queue_index, build_stat) - !> Progress object - class(build_progress_t), intent(inout) :: progress - !> Index of build target in the target queue - integer, intent(in) :: queue_index - !> Build status flag - integer, intent(in) :: build_stat - - character(:), allocatable :: target_name - character(100) :: output_string - character(7) :: overall_progress - - !$omp critical - progress%n_complete = progress%n_complete + 1 - !$omp end critical - - associate(target=>progress%target_queue(queue_index)%ptr) - - if (allocated(target%source)) then - target_name = basename(target%source%file_name) - else - target_name = basename(target%output_file) - end if - - if (build_stat == 0) then - write(output_string,'(A,T40,A,A)') target_name,COLOR_GREEN//'done.'//COLOR_RESET - else - write(output_string,'(A,T40,A,A)') target_name,COLOR_RED//'failed.'//COLOR_RESET - end if - - write(overall_progress,'(A,I3,A)') '[',100*progress%n_complete/progress%n_target,'%] ' - - if (progress%plain_mode) then ! Plain output - - !$omp critical - write(*,'(A7,A30,A7)') overall_progress,target_name, 'done.' - !$omp end critical - - else ! Pretty output - - call progress%console%update_line(progress%output_lines(queue_index),trim(output_string)) - - call progress%console%write_line(overall_progress//'Compiling...',advance=.false.) - - end if - - end associate - - end subroutine output_status_complete - - !> Output finished status for whole package - subroutine output_progress_success(progress) - class(build_progress_t), intent(inout) :: progress - - if (progress%plain_mode) then ! Plain output - - write(*,'(A)') '[100%] Project compiled successfully.' - - else ! Pretty output - - write(*,'(A)') LINE_RESET//COLOR_GREEN//'[100%] Project compiled successfully.'//COLOR_RESET - - end if - - end subroutine output_progress_success - -end module fpm_backend_output \ No newline at end of file +!># Build Backend Progress Output +!> This module provides a derived type `build_progress_t` for printing build status +!> and progress messages to the console while the backend is building the package. +!> +!> The `build_progress_t` type supports two modes: `normal` and `plain` +!> where the former does 'pretty' output and the latter does not. +!> The `normal` mode is intended for typical interactive usage whereas +!> 'plain' mode is used with the `--verbose` flag or when `stdout` is not attached +!> to a terminal (e.g. when piping or redirecting `stdout`). In these cases, +!> the pretty output must be suppressed to avoid control codes being output. + +module fpm_backend_output +use iso_fortran_env, only: stdout=>output_unit +use fpm_filesystem, only: basename +use fpm_targets, only: build_target_ptr +use fpm_backend_console, only: console_t, LINE_RESET, COLOR_RED, COLOR_GREEN, COLOR_YELLOW, COLOR_RESET +use fpm_compile_commands, only: compile_command_t, compile_command_table_t +implicit none + +private +public build_progress_t + +!> Build progress object +type build_progress_t + !> Console object for updating console lines + type(console_t) :: console + !> Number of completed targets + integer :: n_complete + !> Total number of targets scheduled + integer :: n_target + !> 'Plain' output (no colors or updating) + logical :: plain_mode = .true. + !> Store needed when updating previous console lines + integer, allocatable :: output_lines(:) + !> Queue of scheduled build targets + type(build_target_ptr), pointer :: target_queue(:) + !> The compile_commands.json table + type(compile_command_table_t) :: compile_commands +contains + !> Output 'compiling' status for build target + procedure :: compiling_status => output_status_compiling + !> Output 'complete' status for build target + procedure :: completed_status => output_status_complete + !> Output finished status for whole package + procedure :: success => output_progress_success +end type build_progress_t + +!> Constructor for build_progress_t +interface build_progress_t + procedure :: new_build_progress +end interface build_progress_t + +contains + + !> Initialise a new build progress object + function new_build_progress(target_queue,plain_mode) result(progress) + !> The queue of scheduled targets + type(build_target_ptr), intent(in), target :: target_queue(:) + !> Enable 'plain' output for progress object + logical, intent(in), optional :: plain_mode + !> Progress object to initialise + type(build_progress_t) :: progress + + call progress%compile_commands%destroy() + + progress%n_target = size(target_queue,1) + progress%target_queue => target_queue + progress%plain_mode = plain_mode + progress%n_complete = 0 + + allocate(progress%output_lines(progress%n_target)) + + end function new_build_progress + + !> Output 'compiling' status for build target and overall percentage progress + subroutine output_status_compiling(progress, queue_index) + !> Progress object + class(build_progress_t), intent(inout) :: progress + !> Index of build target in the target queue + integer, intent(in) :: queue_index + + character(:), allocatable :: target_name + character(100) :: output_string + character(7) :: overall_progress + + associate(target=>progress%target_queue(queue_index)%ptr) + + if (allocated(target%source)) then + target_name = basename(target%source%file_name) + else + target_name = basename(target%output_file) + end if + + write(overall_progress,'(A,I3,A)') '[',100*progress%n_complete/progress%n_target,'%] ' + + if (progress%plain_mode) then ! Plain output + + !$omp critical + write(*,'(A7,A30)') overall_progress,target_name + !$omp end critical + + else ! Pretty output + + write(output_string,'(A,T40,A,A)') target_name, COLOR_YELLOW//'compiling...'//COLOR_RESET + + call progress%console%write_line(trim(output_string),progress%output_lines(queue_index)) + + call progress%console%write_line(overall_progress//'Compiling...',advance=.false.) + + end if + + end associate + + end subroutine output_status_compiling + + !> Output 'complete' status for build target and update overall percentage progress + subroutine output_status_complete(progress, queue_index, build_stat) + !> Progress object + class(build_progress_t), intent(inout) :: progress + !> Index of build target in the target queue + integer, intent(in) :: queue_index + !> Build status flag + integer, intent(in) :: build_stat + + character(:), allocatable :: target_name + character(100) :: output_string + character(7) :: overall_progress + + !$omp critical + progress%n_complete = progress%n_complete + 1 + !$omp end critical + + associate(target=>progress%target_queue(queue_index)%ptr) + + if (allocated(target%source)) then + target_name = basename(target%source%file_name) + else + target_name = basename(target%output_file) + end if + + if (build_stat == 0) then + write(output_string,'(A,T40,A,A)') target_name,COLOR_GREEN//'done.'//COLOR_RESET + else + write(output_string,'(A,T40,A,A)') target_name,COLOR_RED//'failed.'//COLOR_RESET + end if + + write(overall_progress,'(A,I3,A)') '[',100*progress%n_complete/progress%n_target,'%] ' + + if (progress%plain_mode) then ! Plain output + + !$omp critical + write(*,'(A7,A30,A7)') overall_progress,target_name, 'done.' + !$omp end critical + + else ! Pretty output + + call progress%console%update_line(progress%output_lines(queue_index),trim(output_string)) + + call progress%console%write_line(overall_progress//'Compiling...',advance=.false.) + + end if + + end associate + + end subroutine output_status_complete + + !> Output finished status for whole package + subroutine output_progress_success(progress) + class(build_progress_t), intent(inout) :: progress + + if (progress%plain_mode) then ! Plain output + + write(*,'(A)') '[100%] Project compiled successfully.' + + else ! Pretty output + + write(*,'(A)') LINE_RESET//COLOR_GREEN//'[100%] Project compiled successfully.'//COLOR_RESET + + end if + + end subroutine output_progress_success + +end module fpm_backend_output From bffe22c0ccac075239a49ea73207429e9af9e676 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Sat, 12 Apr 2025 16:10:13 +0200 Subject: [PATCH 10/27] dump compile_commands.json at end of build --- src/fpm_backend.F90 | 5 ++++- src/fpm_backend_output.f90 | 23 ++++++++++++++++++++--- 2 files changed, 24 insertions(+), 4 deletions(-) diff --git a/src/fpm_backend.F90 b/src/fpm_backend.F90 index 59dc2d4301..94be6717d3 100644 --- a/src/fpm_backend.F90 +++ b/src/fpm_backend.F90 @@ -28,7 +28,7 @@ module fpm_backend use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, stderr=>error_unit -use fpm_error, only : fpm_stop +use fpm_error, only : fpm_stop, error_t use fpm_filesystem, only: basename, dirname, join_path, exists, mkdir, run, getline use fpm_model, only: fpm_model_t use fpm_strings, only: string_t, operator(.in.) @@ -65,6 +65,7 @@ subroutine build_package(targets,model,verbose) logical :: build_failed, skip_current type(string_t), allocatable :: build_dirs(:) type(string_t) :: temp + type(error_t), allocatable :: error type(build_progress_t) :: progress logical :: plain_output @@ -157,6 +158,8 @@ subroutine build_package(targets,model,verbose) end do call progress%success() + call progress%dump_commands(error) + if (allocated(error)) call fpm_stop(1,'error writing compile_commands.json: '//trim(error%message)) end subroutine build_package diff --git a/src/fpm_backend_output.f90 b/src/fpm_backend_output.f90 index 39d7c6fee1..055fe07d64 100644 --- a/src/fpm_backend_output.f90 +++ b/src/fpm_backend_output.f90 @@ -11,7 +11,8 @@ module fpm_backend_output use iso_fortran_env, only: stdout=>output_unit -use fpm_filesystem, only: basename +use fpm_error, only: error_t +use fpm_filesystem, only: basename,join_path use fpm_targets, only: build_target_ptr use fpm_backend_console, only: console_t, LINE_RESET, COLOR_RED, COLOR_GREEN, COLOR_YELLOW, COLOR_RESET use fpm_compile_commands, only: compile_command_t, compile_command_table_t @@ -43,6 +44,8 @@ module fpm_backend_output procedure :: completed_status => output_status_complete !> Output finished status for whole package procedure :: success => output_progress_success + !> Output 'compile_commands.json' to build/ folder + procedure :: dump_commands => output_write_compile_commands end type build_progress_t !> Constructor for build_progress_t @@ -167,7 +170,7 @@ end subroutine output_status_complete !> Output finished status for whole package subroutine output_progress_success(progress) class(build_progress_t), intent(inout) :: progress - + if (progress%plain_mode) then ! Plain output write(*,'(A)') '[100%] Project compiled successfully.' @@ -177,7 +180,21 @@ subroutine output_progress_success(progress) write(*,'(A)') LINE_RESET//COLOR_GREEN//'[100%] Project compiled successfully.'//COLOR_RESET end if - + end subroutine output_progress_success + + !> Write compile commands table + subroutine output_write_compile_commands(progress,error) + class(build_progress_t), intent(inout) :: progress + + character(:), allocatable :: path + type(error_t), allocatable :: error + + ! Write compile commands + path = join_path('build','compile_commands.json') + + call progress%compile_commands%dump(file=path, error=error, json=.true.) + + end subroutine output_write_compile_commands end module fpm_backend_output From 1be09c9866bb340e191312f7fdbfad9cd55e7b45 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Sat, 12 Apr 2025 16:13:51 +0200 Subject: [PATCH 11/27] do not join command spaces --- src/fpm_compile_commands.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/fpm_compile_commands.F90 b/src/fpm_compile_commands.F90 index 699492e481..30b69e65f8 100644 --- a/src/fpm_compile_commands.F90 +++ b/src/fpm_compile_commands.F90 @@ -186,7 +186,7 @@ subroutine cct_register(self, command, error) end if ! Tokenize the input command into args(:) - args = shlex_split(command, join_spaced=.true., keep_quotes=.true., success=sh_success) + args = shlex_split(command, join_spaced=.false., keep_quotes=.true., success=sh_success) n = size(args) if (n==0 .or. .not.sh_success) then From 15b6d799c6f5677bed23b9508f19e5693e490ceb Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Sat, 12 Apr 2025 17:08:11 +0200 Subject: [PATCH 12/27] use custom writer --- src/fpm_backend_output.f90 | 2 +- src/fpm_compile_commands.F90 | 114 ++++++++++++++++++++++++++++------- 2 files changed, 94 insertions(+), 22 deletions(-) diff --git a/src/fpm_backend_output.f90 b/src/fpm_backend_output.f90 index 055fe07d64..a9f491d980 100644 --- a/src/fpm_backend_output.f90 +++ b/src/fpm_backend_output.f90 @@ -193,7 +193,7 @@ subroutine output_write_compile_commands(progress,error) ! Write compile commands path = join_path('build','compile_commands.json') - call progress%compile_commands%dump(file=path, error=error, json=.true.) + call progress%compile_commands%write(filename=path, error=error) end subroutine output_write_compile_commands diff --git a/src/fpm_compile_commands.F90 b/src/fpm_compile_commands.F90 index 30b69e65f8..942cd5db4f 100644 --- a/src/fpm_compile_commands.F90 +++ b/src/fpm_compile_commands.F90 @@ -1,6 +1,7 @@ !># 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, toml_table, add_table + use fpm_toml, only: serializable_t, set_string, set_value, set_list, get_value, get_list, toml_table, add_table, toml_array, add_array, toml_stat + 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 @@ -34,6 +35,7 @@ module fpm_compile_commands !> Operation procedure :: destroy => cct_destroy procedure :: register => cct_register + procedure :: write => cct_write !> Serialization interface procedure :: serializable_is_same => cct_is_same @@ -110,22 +112,20 @@ logical function compile_command_is_same(this,that) compile_command_is_same = .true. end function compile_command_is_same - - !> Dump compile_command_table_t to toml table - subroutine cct_dump_toml(self, table, error) - + + !> 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_table), intent(inout) :: table + type(toml_array), intent(inout) :: array !> Error handling - type(error_t), allocatable, intent(out) :: error + type(error_t), allocatable, intent(out) :: error - integer :: ii - type(toml_table), pointer :: ptr - character(64) :: name + integer :: ii, stat + type(toml_table), pointer :: item if (.not.allocated(self%command)) return @@ -133,24 +133,96 @@ subroutine cct_dump_toml(self, table, error) associate (cmd => self%command(ii)) ! Set node for this command - write(name,1) ii - call add_table(table, trim(name), ptr) - if (.not. associated(ptr)) then - call fatal_error(error, "compile_command_table_t cannot create entry for "//trim(name)) + 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 - - ! Dump node - call cmd%dump_to_toml(ptr, error) + end if + call cmd%dump_to_toml(item, error) if (allocated(error)) return - + endassociate - end do + end do + + end subroutine cct_dump_array - 1 format('compile_command_',i0) + !> 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 + + if (.not.allocated(self%command)) return + + ! 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 + !> 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(' ',4) + write (lun, '(A)', iostat=stat, err=1) '{' + write (lun, '(A)', iostat=stat, err=1) json_serialize(array, cfg) + write (lun, '(A)', iostat=stat, err=1) '}' + + 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) From 3670ba55442ce2ad9965b9883ba9b18bf5dd2965 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Sat, 12 Apr 2025 17:37:40 +0200 Subject: [PATCH 13/27] cleanup --- src/fpm_compile_commands.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/fpm_compile_commands.F90 b/src/fpm_compile_commands.F90 index 942cd5db4f..3936921e2a 100644 --- a/src/fpm_compile_commands.F90 +++ b/src/fpm_compile_commands.F90 @@ -1,6 +1,7 @@ !># Store compiler commands in a `compile_commands.json` table module fpm_compile_commands - use fpm_toml, only: serializable_t, set_string, set_value, set_list, get_value, get_list, toml_table, add_table, toml_array, add_array, toml_stat + use fpm_toml, only: serializable_t, set_string, set_list, get_value, get_list, toml_table, add_table, & + toml_array, add_array, toml_stat 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 @@ -209,7 +210,7 @@ subroutine cct_write(self, filename, error) ! Ensure the array has no key if (allocated(array%key)) deallocate(array%key) - cfg%indent = repeat(' ',4) + cfg%indent = repeat(' ',3) write (lun, '(A)', iostat=stat, err=1) '{' write (lun, '(A)', iostat=stat, err=1) json_serialize(array, cfg) write (lun, '(A)', iostat=stat, err=1) '}' From ccdffb4d8fcf5a6e603138b2add92488c52fb5de Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Sat, 12 Apr 2025 17:42:04 +0200 Subject: [PATCH 14/27] no top-level object --- src/fpm_compile_commands.F90 | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/src/fpm_compile_commands.F90 b/src/fpm_compile_commands.F90 index 3936921e2a..60b66a30ae 100644 --- a/src/fpm_compile_commands.F90 +++ b/src/fpm_compile_commands.F90 @@ -211,10 +211,7 @@ subroutine cct_write(self, filename, error) if (allocated(array%key)) deallocate(array%key) cfg%indent = repeat(' ',3) - write (lun, '(A)', iostat=stat, err=1) '{' - write (lun, '(A)', iostat=stat, err=1) json_serialize(array, cfg) - write (lun, '(A)', iostat=stat, err=1) '}' - + write (lun, '(A)', iostat=stat, err=1) json_serialize(array, cfg) close(lun,iostat=stat) 1 if (stat/=0) then From d3854f2c68d248d5327d3727ea60ad57a1537d32 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Sat, 12 Apr 2025 17:44:18 +0200 Subject: [PATCH 15/27] ensure trimmed filenames --- src/fpm_compile_commands.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/fpm_compile_commands.F90 b/src/fpm_compile_commands.F90 index 60b66a30ae..059c22712b 100644 --- a/src/fpm_compile_commands.F90 +++ b/src/fpm_compile_commands.F90 @@ -272,13 +272,13 @@ subroutine cct_register(self, command, error) allocate(character(len=0) :: source_file) find_source_file: do i = 1, n-1 if (args(i) == "-c") then - source_file = args(i+1) + 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 = args(n) + if (len_trim(source_file)==0) source_file = trim(args(n)) ! Fill in the compile_command_t cmd = compile_command_t(directory = string_t(cwd), & From 05eb31baac03749fee8c096615a656ef17386b55 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Sat, 12 Apr 2025 17:58:54 +0200 Subject: [PATCH 16/27] implement roundtrip serialization --- src/fpm_compile_commands.F90 | 99 ++++++++++++++++++++++-------------- 1 file changed, 62 insertions(+), 37 deletions(-) diff --git a/src/fpm_compile_commands.F90 b/src/fpm_compile_commands.F90 index 059c22712b..ccf31e06f8 100644 --- a/src/fpm_compile_commands.F90 +++ b/src/fpm_compile_commands.F90 @@ -1,7 +1,7 @@ !># 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, toml_table, add_table, & - toml_array, add_array, toml_stat + toml_array, add_array, toml_stat, len 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 @@ -146,36 +146,7 @@ subroutine cct_dump_array(self, array, error) end do end subroutine cct_dump_array - - !> 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 - - if (.not.allocated(self%command)) return - - ! 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 - + !> Write compile_commands.json file. Because Jonquil does not support non-named arrays, !> create a custom json here. subroutine cct_write(self, filename, error) @@ -293,6 +264,35 @@ subroutine cct_register(self, command, error) end subroutine cct_register + !> 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 + + if (.not.allocated(self%command)) return + + ! 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) @@ -305,12 +305,37 @@ subroutine cct_load_toml(self, table, error) !> Error handling type(error_t), allocatable, intent(out) :: error -! call get_value(table, "directory", self%directory, error, 'compile_command_table_t') -! if (allocated(error)) return -! call get_list(table, "arguments", self%arguments, error) -! if (allocated(error)) return -! call get_value(table, "file", self%file, error, 'compile_command_table_t') -! if (allocated(error)) return + 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) + allocate(self%command(n)) + + do i = 1, n + call get_value(array, pos=i, ptr=elem, stat=stat) + if (stat /= toml_stat%success) 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 From a6c4483ed2261addd601109a7effe13d9cafc402 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Sun, 13 Apr 2025 12:26:29 +0200 Subject: [PATCH 17/27] test: compile_commands serialization --- test/fpm_test/test_backend.f90 | 37 +++++++++++++++++++++++++++++++++- 1 file changed, 36 insertions(+), 1 deletion(-) diff --git a/test/fpm_test/test_backend.f90 b/test/fpm_test/test_backend.f90 index 402e8b4d0b..f399682403 100644 --- a/test/fpm_test/test_backend.f90 +++ b/test/fpm_test/test_backend.f90 @@ -7,6 +7,7 @@ module test_backend FPM_TARGET_OBJECT, FPM_TARGET_ARCHIVE, & add_target, add_dependency use fpm_backend, only: sort_target, schedule_targets + use fpm_compile_commands, only: compile_command_t, compile_command_table_t implicit none private @@ -26,7 +27,8 @@ subroutine collect_backend(testsuite) & new_unittest("target-sort-skip-all", test_target_sort_skip_all), & & new_unittest("target-sort-rebuild-all", test_target_sort_rebuild_all), & & new_unittest("schedule-targets", test_schedule_targets), & - & new_unittest("schedule-targets-empty", test_schedule_empty) & + & new_unittest("schedule-targets-empty", test_schedule_empty), & + & new_unittest("serialize-compile-commands", compile_commands_roundtrip) & ] end subroutine collect_backend @@ -354,5 +356,38 @@ function new_test_package() result(targets) end function new_test_package + subroutine compile_commands_roundtrip(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(compile_command_t) :: cmd + type(compile_command_table_t) :: cc + integer :: i + + call cmd%test_serialization('compile_command: empty', error) + if (allocated(error)) return + + cmd = compile_command_t(directory = string_t("/test/dir"), & + arguments = [string_t("gfortran"), & + string_t("-c"), string_t("main.f90"), & + string_t("-o"), string_t("main.o")], & + file = string_t("main.f90")) + + call cmd%test_serialization('compile_command: non-empty', error) + if (allocated(error)) return + + call cc%test_serialization('compile_command_table: empty', error) + if (allocated(error)) return + + do i=1,10 + call cc%register(cmd,error) + if (allocated(error)) return + end do + + call cc%test_serialization('compile_command_table: non-empty', error) + if (allocated(error)) return + + end subroutine compile_commands_roundtrip end module test_backend From cfc805af14ec54790333d701716d6f1b031a1a25 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Sun, 13 Apr 2025 12:32:53 +0200 Subject: [PATCH 18/27] compile command: destroy object --- src/fpm_compile_commands.F90 | 51 +++++++++++++++++++++++++++++++----- 1 file changed, 44 insertions(+), 7 deletions(-) diff --git a/src/fpm_compile_commands.F90 b/src/fpm_compile_commands.F90 index ccf31e06f8..fef75d798b 100644 --- a/src/fpm_compile_commands.F90 +++ b/src/fpm_compile_commands.F90 @@ -20,6 +20,9 @@ module fpm_compile_commands 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 @@ -34,10 +37,14 @@ module fpm_compile_commands contains !> Operation - procedure :: destroy => cct_destroy - procedure :: register => cct_register + 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 @@ -47,6 +54,18 @@ module fpm_compile_commands end type compile_command_table_t contains + + !> 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) @@ -60,6 +79,8 @@ subroutine compile_command_dump_toml(self, table, error) !> Error handling type(error_t), allocatable, intent(out) :: error + call self%destroy() + call set_string(table, "directory", self%directory, error, 'compile_command_t') if (allocated(error)) return call set_list(table, "arguments", self%arguments, error) @@ -256,13 +277,29 @@ subroutine cct_register(self, command, error) arguments = [(string_t(trim(args(i))), i=1,n)], & file = string_t(source_file)) - if (allocated(self%command)) then - self%command = [self%command, cmd] - else - allocate(self%command(1), source=cmd) - end if + ! Add it to the structure + call cct_register_object(self, cmd, error) 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) From 18d0ce389a1f830eff94ecd24c7abdabe026cf00 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Sun, 13 Apr 2025 13:04:39 +0200 Subject: [PATCH 19/27] test serialization --- src/fpm_compile_commands.F90 | 28 ++++++++++++++-------------- test/fpm_test/test_backend.f90 | 1 + 2 files changed, 15 insertions(+), 14 deletions(-) diff --git a/src/fpm_compile_commands.F90 b/src/fpm_compile_commands.F90 index fef75d798b..12f3bde752 100644 --- a/src/fpm_compile_commands.F90 +++ b/src/fpm_compile_commands.F90 @@ -79,12 +79,10 @@ subroutine compile_command_dump_toml(self, table, error) !> Error handling type(error_t), allocatable, intent(out) :: error - call self%destroy() - - call set_string(table, "directory", self%directory, error, 'compile_command_t') - if (allocated(error)) return 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 @@ -102,12 +100,14 @@ subroutine compile_command_load_toml(self, table, error) !> Error handling type(error_t), allocatable, intent(out) :: error - call get_value(table, "directory", self%directory, error, 'compile_command_t') - if (allocated(error)) return + call self%destroy() + call get_list(table, "arguments", self%arguments, error) - if (allocated(error)) return - call get_value(table, "file", self%file, error, 'compile_command_t') - if (allocated(error)) return + 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 @@ -316,8 +316,6 @@ subroutine cct_dump_toml(self, table, error) integer :: stat, ii type(toml_array), pointer :: array - if (.not.allocated(self%command)) return - ! Create array call add_array(table, 'compile_commands', array, stat=stat) if (stat/=toml_stat%success .or. .not.associated(array)) then @@ -349,7 +347,7 @@ subroutine cct_load_toml(self, table, error) 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") @@ -357,12 +355,14 @@ subroutine cct_load_toml(self, table, error) else - n = len(array) + 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) then + 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 diff --git a/test/fpm_test/test_backend.f90 b/test/fpm_test/test_backend.f90 index f399682403..7ed87682ca 100644 --- a/test/fpm_test/test_backend.f90 +++ b/test/fpm_test/test_backend.f90 @@ -7,6 +7,7 @@ module test_backend FPM_TARGET_OBJECT, FPM_TARGET_ARCHIVE, & add_target, add_dependency use fpm_backend, only: sort_target, schedule_targets + use fpm_strings, only: string_t use fpm_compile_commands, only: compile_command_t, compile_command_table_t implicit none private From de769adfda979b2b2250da2810fb7e474692bea2 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Sun, 13 Apr 2025 13:18:13 +0200 Subject: [PATCH 20/27] compile_commands registration tests --- test/fpm_test/test_backend.f90 | 81 +++++++++++++++++++++++++++++++++- 1 file changed, 80 insertions(+), 1 deletion(-) diff --git a/test/fpm_test/test_backend.f90 b/test/fpm_test/test_backend.f90 index 7ed87682ca..5b5c8e53d2 100644 --- a/test/fpm_test/test_backend.f90 +++ b/test/fpm_test/test_backend.f90 @@ -29,7 +29,9 @@ subroutine collect_backend(testsuite) & new_unittest("target-sort-rebuild-all", test_target_sort_rebuild_all), & & new_unittest("schedule-targets", test_schedule_targets), & & new_unittest("schedule-targets-empty", test_schedule_empty), & - & new_unittest("serialize-compile-commands", compile_commands_roundtrip) & + & new_unittest("serialize-compile-commands", compile_commands_roundtrip), & + & new_unittest("compile-commands-write", compile_commands_register_from_cmd), & + & new_unittest("compile-commands-register-string", compile_commands_register_from_string) & ] end subroutine collect_backend @@ -391,4 +393,81 @@ subroutine compile_commands_roundtrip(error) end subroutine compile_commands_roundtrip + subroutine compile_commands_register_from_cmd(error) + type(error_t), allocatable, intent(out) :: error + + type(compile_command_table_t) :: table + type(compile_command_t) :: cmd + integer :: i + + cmd = compile_command_t(directory = string_t("/src"), & + arguments = [string_t("gfortran"), & + string_t("-c"), string_t("example.f90"), & + string_t("-o"), string_t("example.o")], & + file = string_t("example.f90")) + + call table%register(cmd, error) + if (allocated(error)) return + + if (.not.allocated(table%command)) then + call test_failed(error, "Command table not allocated after registration") + return + endif + + if (size(table%command) /= 1) then + call test_failed(error, "Expected one registered command") + return + endif + + if (table%command(1)%file%s /= "example.f90") then + call test_failed(error, "Registered file mismatch") + return + endif + + end subroutine compile_commands_register_from_cmd + + subroutine compile_commands_register_from_string(error) + type(error_t), allocatable, intent(out) :: error + + type(compile_command_table_t) :: table + character(len=*), parameter :: cmd_line = "gfortran -c example.f90 -o example.o" + + ! Register a raw command line string + call table%register(cmd_line, error) + if (allocated(error)) return + + if (.not.allocated(table%command)) then + call test_failed(error, "Command table not allocated after string registration") + return + end if + + if (size(table%command) /= 1) then + call test_failed(error, "Expected one registered command after string registration") + return + end if + + if (.not.allocated(table%command(1)%arguments)) then + call test_failed(error, "Command arguments not allocated") + return + end if + + if (size(table%command(1)%arguments) /= 5) then + call test_failed(error, "Wrong number of parsed arguments, should be 5") + return + end if + + if (table%command(1)%arguments(1)%s /= "gfortran") then + call test_failed(error, "Expected 'gfortran' as first argument") + return + end if + + if (table%command(1)%arguments(3)%s /= "example.f90") then + call test_failed(error, "Expected 'example.f90' as third argument") + return + end if + + end subroutine compile_commands_register_from_string + + + end module test_backend From 33fc93803f2ce3f88f54fd79487c245c87492747 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Sun, 13 Apr 2025 14:30:28 +0200 Subject: [PATCH 21/27] ifx bugfix --- src/fpm_compile_commands.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/fpm_compile_commands.F90 b/src/fpm_compile_commands.F90 index 12f3bde752..f3a3d00930 100644 --- a/src/fpm_compile_commands.F90 +++ b/src/fpm_compile_commands.F90 @@ -1,7 +1,8 @@ !># 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, toml_table, add_table, & + 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 From bdf956844c1ac0a95b0807f8f76bec33a3d3a617 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Mon, 14 Apr 2025 09:55:10 +0200 Subject: [PATCH 22/27] create `compile_commands.json` on dry run `fpm build --list` --- src/fpm.f90 | 7 +++-- src/fpm/cmd/install.f90 | 2 +- src/fpm_backend.F90 | 32 ++++++++++++-------- src/fpm_compiler.F90 | 67 ++++++++++++++++++++++++++++++++++------- 4 files changed, 80 insertions(+), 28 deletions(-) diff --git a/src/fpm.f90 b/src/fpm.f90 index 561fb4e5e9..41dac941ba 100644 --- a/src/fpm.f90 +++ b/src/fpm.f90 @@ -461,10 +461,11 @@ subroutine cmd_build(settings) do i=1,size(targets) write(stderr,*) targets(i)%ptr%output_file enddo -else if (settings%show_model) then +endif +if (settings%show_model) then call show_model(model) else - call build_package(targets,model,verbose=settings%verbose) + call build_package(targets,model,verbose=settings%verbose,dry_run=settings%list) endif end subroutine cmd_build @@ -573,7 +574,7 @@ subroutine cmd_run(settings,test) end if - call build_package(targets,model,verbose=settings%verbose) + call build_package(targets,model,verbose=settings%verbose,dry_run=settings%list) if (settings%list) then call compact_list() diff --git a/src/fpm/cmd/install.f90 b/src/fpm/cmd/install.f90 index 559cd81b55..8e6c516052 100644 --- a/src/fpm/cmd/install.f90 +++ b/src/fpm/cmd/install.f90 @@ -53,7 +53,7 @@ subroutine cmd_install(settings) end if if (.not.settings%no_rebuild) then - call build_package(targets,model,verbose=settings%verbose) + call build_package(targets,model,verbose=settings%verbose,dry_run=settings%list) end if call new_installer(installer, prefix=settings%prefix, & diff --git a/src/fpm_backend.F90 b/src/fpm_backend.F90 index 94be6717d3..e406ceb186 100644 --- a/src/fpm_backend.F90 +++ b/src/fpm_backend.F90 @@ -54,11 +54,15 @@ function c_isatty() bind(C, name = 'c_isatty') contains !> Top-level routine to build package described by `model` -subroutine build_package(targets,model,verbose) +subroutine build_package(targets,model,verbose,dry_run) type(build_target_ptr), intent(inout) :: targets(:) type(fpm_model_t), intent(in) :: model logical, intent(in) :: verbose - + + !> If dry_run, the build process is only mocked, but the list of compile_commands + !> is still created + logical, intent(in) :: dry_run + integer :: i, j type(build_target_ptr), allocatable :: queue(:) integer, allocatable :: schedule_ptr(:), stat(:) @@ -81,7 +85,7 @@ subroutine build_package(targets,model,verbose) end do do i = 1, size(build_dirs) - call mkdir(build_dirs(i)%s,verbose) + if (.not.dry_run) call mkdir(build_dirs(i)%s,verbose) end do ! Perform depth-first topological sort of targets @@ -95,14 +99,13 @@ subroutine build_package(targets,model,verbose) call schedule_targets(queue, schedule_ptr, targets) ! Check if queue is empty - if (.not.verbose .and. size(queue) < 1) then + if (.not.verbose .and. size(queue) < 1 .and. .not.dry_run) then write(stderr, '(a)') 'Project is up to date' return end if ! Initialise build status flags - allocate(stat(size(queue))) - stat(:) = 0 + allocate(stat(size(queue)),source=0) build_failed = .false. ! Set output mode @@ -126,9 +129,10 @@ subroutine build_package(targets,model,verbose) skip_current = build_failed if (.not.skip_current) then - call progress%compiling_status(j) - call build_target(model,queue(j)%ptr,verbose,progress%compile_commands,stat(j)) - call progress%completed_status(j,stat(j)) + if (.not.dry_run) call progress%compiling_status(j) + call build_target(model,queue(j)%ptr,verbose,dry_run, & + progress%compile_commands,stat(j)) + if (.not.dry_run) call progress%completed_status(j,stat(j)) end if ! Set global flag if this target failed to build @@ -157,7 +161,7 @@ subroutine build_package(targets,model,verbose) end do - call progress%success() + if (.not.dry_run) call progress%success() call progress%dump_commands(error) if (allocated(error)) call fpm_stop(1,'error writing compile_commands.json: '//trim(error%message)) @@ -304,17 +308,19 @@ end subroutine schedule_targets !> !> If successful, also caches the source file digest to disk. !> -subroutine build_target(model,target,verbose,table,stat) +subroutine build_target(model,target,verbose,dry_run,table,stat) type(fpm_model_t), intent(in) :: model type(build_target_t), intent(in), target :: target logical, intent(in) :: verbose + !> If dry_run, the build process is only mocked, but compile_commands are still created + logical, intent(in) :: dry_run type(compile_command_table_t), intent(inout) :: table integer, intent(out) :: stat integer :: fh !$omp critical - if (.not.exists(dirname(target%output_file))) then + if (.not.exists(dirname(target%output_file)) .and. .not.dry_run) then call mkdir(dirname(target%output_file),verbose) end if !$omp end critical @@ -343,7 +349,7 @@ subroutine build_target(model,target,verbose,table,stat) end select - if (stat == 0 .and. allocated(target%source)) then + if (stat == 0 .and. allocated(target%source) .and. .not.dry_run) then open(newunit=fh,file=target%output_file//'.digest',status='unknown') write(fh,*) target%source%digest close(fh) diff --git a/src/fpm_compiler.F90 b/src/fpm_compiler.F90 index 11ebe8d863..f02cf274ae 100644 --- a/src/fpm_compiler.F90 +++ b/src/fpm_compiler.F90 @@ -1104,7 +1104,7 @@ end subroutine new_archiver !> Compile a Fortran object -subroutine compile_fortran(self, input, output, args, log_file, stat, table) +subroutine compile_fortran(self, input, output, args, log_file, stat, table, dry_run) !> Instance of the compiler object class(compiler_t), intent(in) :: self !> Source file input @@ -1119,16 +1119,25 @@ subroutine compile_fortran(self, input, output, args, log_file, stat, table) integer, intent(out) :: stat !> Optional compile_commands table type(compile_command_table_t), optional, intent(inout) :: table + !> Optional mocking + logical, optional, intent(in) :: dry_run character(len=:), allocatable :: command type(error_t), allocatable :: error + logical :: mock + + ! Check if we're actually building this file + mock = .false. + if (present(dry_run)) mock = dry_run ! Set command command = self%fc // " -c " // input // " " // args // " -o " // output ! Execute command - call run(command, echo=self%echo, verbose=self%verbose, redirect=log_file, exitstat=stat) - if (stat/=0) return + if (.not.mock) then + call run(command, echo=self%echo, verbose=self%verbose, redirect=log_file, exitstat=stat) + if (stat/=0) return + endif ! Optionally register compile command if (present(table)) then @@ -1140,7 +1149,7 @@ end subroutine compile_fortran !> Compile a C object -subroutine compile_c(self, input, output, args, log_file, stat, table) +subroutine compile_c(self, input, output, args, log_file, stat, table, dry_run) !> Instance of the compiler object class(compiler_t), intent(in) :: self !> Source file input @@ -1155,16 +1164,25 @@ subroutine compile_c(self, input, output, args, log_file, stat, table) integer, intent(out) :: stat !> Optional compile_commands table type(compile_command_table_t), optional, intent(inout) :: table + !> Optional mocking + logical, optional, intent(in) :: dry_run character(len=:), allocatable :: command type(error_t), allocatable :: error + logical :: mock + + ! Check if we're actually building this file + mock = .false. + if (present(dry_run)) mock = dry_run ! Set command command = self%cc // " -c " // input // " " // args // " -o " // output ! Execute command - call run(command, echo=self%echo, verbose=self%verbose, redirect=log_file, exitstat=stat) - if (stat/=0) return + if (.not.mock) then + call run(command, echo=self%echo, verbose=self%verbose, redirect=log_file, exitstat=stat) + if (stat/=0) return + endif ! Optionally register compile command if (present(table)) then @@ -1175,7 +1193,7 @@ subroutine compile_c(self, input, output, args, log_file, stat, table) end subroutine compile_c !> Compile a CPP object -subroutine compile_cpp(self, input, output, args, log_file, stat, table) +subroutine compile_cpp(self, input, output, args, log_file, stat, table, dry_run) !> Instance of the compiler object class(compiler_t), intent(in) :: self !> Source file input @@ -1190,16 +1208,25 @@ subroutine compile_cpp(self, input, output, args, log_file, stat, table) integer, intent(out) :: stat !> Optional compile_commands table type(compile_command_table_t), optional, intent(inout) :: table + !> Optional mocking + logical, optional, intent(in) :: dry_run character(len=:), allocatable :: command type(error_t), allocatable :: error + logical :: mock + + ! Check if we're actually building this file + mock = .false. + if (present(dry_run)) mock = dry_run ! Set command command = self%cxx // " -c " // input // " " // args // " -o " // output ! Execute command - call run(command, echo=self%echo, verbose=self%verbose, redirect=log_file, exitstat=stat) - if (stat/=0) return + if (.not.mock) then + call run(command, echo=self%echo, verbose=self%verbose, redirect=log_file, exitstat=stat) + if (stat/=0) return + endif ! Optionally register compile command if (present(table)) then @@ -1210,7 +1237,7 @@ subroutine compile_cpp(self, input, output, args, log_file, stat, table) end subroutine compile_cpp !> Link an executable -subroutine link_executable(self, output, args, log_file, stat) +subroutine link_executable(self, output, args, log_file, stat, dry_run) !> Instance of the compiler object class(compiler_t), intent(in) :: self !> Output file of object @@ -1221,13 +1248,21 @@ subroutine link_executable(self, output, args, log_file, stat) character(len=*), intent(in) :: log_file !> Status flag integer, intent(out) :: stat + !> Optional mocking + logical, optional, intent(in) :: dry_run character(len=:), allocatable :: command + logical :: mock + + ! Check if we're actually linking + mock = .false. + if (present(dry_run)) mock = dry_run ! Set command command = self%fc // " " // args // " -o " // output ! Execute command + if (.not.mock) & call run(command, echo=self%echo, verbose=self%verbose, redirect=log_file, exitstat=stat) end subroutine link_executable @@ -1236,7 +1271,7 @@ end subroutine link_executable !> @todo For Windows OS, use the local `delete_file_win32` in stead of `delete_file`. !> This may be related to a bug in Mingw64-openmp and is expected to be resolved in the future, !> see issue #707, #708 and #808. -subroutine make_archive(self, output, args, log_file, stat) +subroutine make_archive(self, output, args, log_file, stat, dry_run) !> Instance of the archiver object class(archiver_t), intent(in) :: self !> Name of the archive to generate @@ -1247,6 +1282,16 @@ subroutine make_archive(self, output, args, log_file, stat) character(len=*), intent(in) :: log_file !> Status flag integer, intent(out) :: stat + !> Optional mocking + logical, optional, intent(in) :: dry_run + + logical :: mock + + ! Check if we're actually linking + mock = .false. + if (present(dry_run)) mock = dry_run + + if (mock) return if (self%use_response_file) then call write_response_file(output//".resp" , args) From d504a40af82e405fafcb904a799f6e72c429ff1e Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Mon, 14 Apr 2025 10:06:52 +0200 Subject: [PATCH 23/27] ensure no targets skipped mocking `compile_commands.json` --- src/fpm_backend.F90 | 42 +++++++++++++++++++++++++----------------- 1 file changed, 25 insertions(+), 17 deletions(-) diff --git a/src/fpm_backend.F90 b/src/fpm_backend.F90 index e406ceb186..784d140ecd 100644 --- a/src/fpm_backend.F90 +++ b/src/fpm_backend.F90 @@ -91,7 +91,7 @@ subroutine build_package(targets,model,verbose,dry_run) ! Perform depth-first topological sort of targets do i=1,size(targets) - call sort_target(targets(i)%ptr) + call sort_target(targets(i)%ptr, dry_run) end do @@ -180,15 +180,19 @@ end subroutine build_package !> If `target` is marked as sorted, `target%schedule` should be an !> integer greater than zero indicating the region for scheduling !> -recursive subroutine sort_target(target) +recursive subroutine sort_target(target, mock) type(build_target_t), intent(inout), target :: target + !> Optionally sort ALL targets if this is a dry run + logical, optional, intent(in) :: mock integer :: i, fh, stat + logical :: dry_run + + dry_run = .false. + if (present(mock)) dry_run = mock ! Check if target has already been processed (as a dependency) - if (target%sorted .or. target%skip) then - return - end if + if (target%sorted .or. target%skip) return ! Check for a circular dependency ! (If target has been touched but not processed) @@ -201,20 +205,24 @@ recursive subroutine sort_target(target) ! Load cached source file digest if present if (.not.allocated(target%digest_cached) .and. & exists(target%output_file) .and. & - exists(target%output_file//'.digest')) then + exists(target%output_file//'.digest') .and. & + (.not.dry_run)) then allocate(target%digest_cached) open(newunit=fh,file=target%output_file//'.digest',status='old') read(fh,*,iostat=stat) target%digest_cached close(fh) - if (stat /= 0) then ! Cached digest is not recognized - deallocate(target%digest_cached) - end if + ! Cached digest is not recognized + if (stat /= 0) deallocate(target%digest_cached) end if - - if (allocated(target%source)) then + + if (dry_run) then + + target%skip = .false. + + elseif (allocated(target%source)) then ! Skip if target is source-based and source file is unmodified if (allocated(target%digest_cached)) then @@ -233,7 +241,7 @@ recursive subroutine sort_target(target) do i=1,size(target%dependencies) ! Sort dependency - call sort_target(target%dependencies(i)%ptr) + call sort_target(target%dependencies(i)%ptr, dry_run) if (.not.target%dependencies(i)%ptr%skip) then @@ -329,23 +337,23 @@ subroutine build_target(model,target,verbose,dry_run,table,stat) case (FPM_TARGET_OBJECT) call model%compiler%compile_fortran(target%source%file_name, target%output_file, & - & target%compile_flags, target%output_log_file, stat, table) + & target%compile_flags, target%output_log_file, stat, table, dry_run) case (FPM_TARGET_C_OBJECT) call model%compiler%compile_c(target%source%file_name, target%output_file, & - & target%compile_flags, target%output_log_file, stat, table) + & target%compile_flags, target%output_log_file, stat, table, dry_run) case (FPM_TARGET_CPP_OBJECT) call model%compiler%compile_cpp(target%source%file_name, target%output_file, & - & target%compile_flags, target%output_log_file, stat, table) + & target%compile_flags, target%output_log_file, stat, table, dry_run) case (FPM_TARGET_EXECUTABLE) call model%compiler%link(target%output_file, & - & target%compile_flags//" "//target%link_flags, target%output_log_file, stat) + & target%compile_flags//" "//target%link_flags, target%output_log_file, stat, dry_run) case (FPM_TARGET_ARCHIVE) call model%archiver%make_archive(target%output_file, target%link_objects, & - & target%output_log_file, stat) + & target%output_log_file, stat, dry_run) end select From 36890b84f130a2e4db60c26fd1665b544e9e620a Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Mon, 14 Apr 2025 10:12:31 +0200 Subject: [PATCH 24/27] cli help --- src/fpm_command_line.f90 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/fpm_command_line.f90 b/src/fpm_command_line.f90 index 3f905deffa..a64a708103 100644 --- a/src/fpm_command_line.f90 +++ b/src/fpm_command_line.f90 @@ -1175,7 +1175,9 @@ subroutine set_help() help_text_build_common,& help_text_compiler, & help_text_flag, & - ' --list list candidates instead of building or running them ', & + ' --list list candidates instead of building or running them. ', & + ' all dependencies are downloaded, and the build sequence ', & + ' is saved to `build/compile_commands.json`. ', & ' --tests build all tests (otherwise only if needed) ', & ' --show-model show the model and exit (do not build) ', & ' --dump [FILENAME] save model representation to file. use JSON format ', & From 51fe31809f65d45f8481849e97b8a002aac23eae Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Tue, 22 Apr 2025 05:29:47 -0500 Subject: [PATCH 25/27] update fortran-shlex to 2.0.0 (mslex) --- fpm.toml | 2 +- src/fpm_compile_commands.F90 | 9 +++++++-- src/fpm_compiler.F90 | 4 ++-- 3 files changed, 10 insertions(+), 5 deletions(-) diff --git a/fpm.toml b/fpm.toml index 881d0325c2..46dd5fd593 100644 --- a/fpm.toml +++ b/fpm.toml @@ -21,7 +21,7 @@ fortran-regex.tag = "1.1.2" jonquil.git = "https://github.com/toml-f/jonquil" jonquil.rev = "4fbd4cf34d577c0fd25e32667ee9e41bf231ece8" fortran-shlex.git = "https://github.com/perazz/fortran-shlex" -fortran-shlex.tag = "1.2.1" +fortran-shlex.tag = "2.0.0" [[test]] name = "cli-test" diff --git a/src/fpm_compile_commands.F90 b/src/fpm_compile_commands.F90 index f3a3d00930..a8ff7bc1c1 100644 --- a/src/fpm_compile_commands.F90 +++ b/src/fpm_compile_commands.F90 @@ -7,7 +7,8 @@ module fpm_compile_commands 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 shlex_module, only: shlex_split => split + 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 @@ -249,7 +250,11 @@ subroutine cct_register(self, command, error) end if ! Tokenize the input command into args(:) - args = shlex_split(command, join_spaced=.false., keep_quotes=.true., success=sh_success) + if (get_os_type()==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 diff --git a/src/fpm_compiler.F90 b/src/fpm_compiler.F90 index f02cf274ae..f5ef5b840f 100644 --- a/src/fpm_compiler.F90 +++ b/src/fpm_compiler.F90 @@ -46,7 +46,7 @@ module fpm_compiler use tomlf, only: toml_table use fpm_toml, only: serializable_t, set_string, set_value, toml_stat, get_value use fpm_compile_commands, only: compile_command_t, compile_command_table_t -use shlex_module, only: shlex_split => split +use shlex_module, only: sh_split => split, ms_split implicit none public :: compiler_t, new_compiler, archiver_t, new_archiver, get_macros public :: append_clean_flags, append_clean_flags_array @@ -1693,7 +1693,7 @@ subroutine tokenize_flags(flags, flags_array) integer :: i logical :: success - flags_char_array = shlex_split(flags, join_spaced=.true., keep_quotes=.true., success=success) + flags_char_array = sh_split(flags, join_spaced=.true., keep_quotes=.true., success=success) if (.not. success) then allocate(flags_array(0)) return From fd1c6098c1d426ba8819bbd3944f6d0c30ee87d2 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Tue, 22 Apr 2025 12:43:12 +0200 Subject: [PATCH 26/27] custom OS type --- src/fpm_compile_commands.F90 | 7 +++++-- src/fpm_compiler.F90 | 6 +++--- src/fpm_targets.f90 | 2 +- 3 files changed, 9 insertions(+), 6 deletions(-) diff --git a/src/fpm_compile_commands.F90 b/src/fpm_compile_commands.F90 index a8ff7bc1c1..fa6a38c206 100644 --- a/src/fpm_compile_commands.F90 +++ b/src/fpm_compile_commands.F90 @@ -226,7 +226,7 @@ elemental subroutine cct_destroy(self) end subroutine cct_destroy !> Register a new compile command - subroutine cct_register(self, command, error) + subroutine cct_register(self, command, target_os, error) !> Instance of the serializable object class(compile_command_table_t), intent(inout) :: self @@ -234,6 +234,9 @@ subroutine cct_register(self, command, error) !> 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 @@ -250,7 +253,7 @@ subroutine cct_register(self, command, error) end if ! Tokenize the input command into args(:) - if (get_os_type()==OS_WINDOWS) then + 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) diff --git a/src/fpm_compiler.F90 b/src/fpm_compiler.F90 index f5ef5b840f..28dd1cdeda 100644 --- a/src/fpm_compiler.F90 +++ b/src/fpm_compiler.F90 @@ -1141,7 +1141,7 @@ subroutine compile_fortran(self, input, output, args, log_file, stat, table, dry ! Optionally register compile command if (present(table)) then - call table%register(command, error) + call table%register(command, get_os_type(), error) stat = merge(-1,0,allocated(error)) endif @@ -1186,7 +1186,7 @@ subroutine compile_c(self, input, output, args, log_file, stat, table, dry_run) ! Optionally register compile command if (present(table)) then - call table%register(command, error) + call table%register(command, get_os_type(), error) stat = merge(-1,0,allocated(error)) endif @@ -1230,7 +1230,7 @@ subroutine compile_cpp(self, input, output, args, log_file, stat, table, dry_run ! Optionally register compile command if (present(table)) then - call table%register(command, error) + call table%register(command, get_os_type(), error) stat = merge(-1,0,allocated(error)) endif diff --git a/src/fpm_targets.f90 b/src/fpm_targets.f90 index 38a7718aac..24b746b439 100644 --- a/src/fpm_targets.f90 +++ b/src/fpm_targets.f90 @@ -908,7 +908,7 @@ subroutine resolve_target_linking(targets, model) target%output_dir = get_output_dir(model%build_prefix, & & target%compile_flags//local_link_flags) - target%output_file = join_path(target%output_dir, target%output_name) + target%output_file = join_path(target%output_dir, target%output_name) target%output_log_file = join_path(target%output_dir, target%output_name)//'.log' end if From b80ce7c7279053a61880abdc5cdd1c2b8129432f Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Tue, 22 Apr 2025 13:01:03 +0200 Subject: [PATCH 27/27] add Windows, UNIX command tests --- test/fpm_test/test_backend.f90 | 3 +- test/fpm_test/test_compiler.f90 | 71 ++++++++++++++++++++++++++++++++- 2 files changed, 71 insertions(+), 3 deletions(-) diff --git a/test/fpm_test/test_backend.f90 b/test/fpm_test/test_backend.f90 index 5b5c8e53d2..30ca898b46 100644 --- a/test/fpm_test/test_backend.f90 +++ b/test/fpm_test/test_backend.f90 @@ -8,6 +8,7 @@ module test_backend add_target, add_dependency use fpm_backend, only: sort_target, schedule_targets use fpm_strings, only: string_t + use fpm_environment, only: OS_LINUX use fpm_compile_commands, only: compile_command_t, compile_command_table_t implicit none private @@ -433,7 +434,7 @@ subroutine compile_commands_register_from_string(error) character(len=*), parameter :: cmd_line = "gfortran -c example.f90 -o example.o" ! Register a raw command line string - call table%register(cmd_line, error) + call table%register(cmd_line, OS_LINUX, error) if (allocated(error)) return if (.not.allocated(table%command)) then diff --git a/test/fpm_test/test_compiler.f90 b/test/fpm_test/test_compiler.f90 index 8b698342d3..1472b86f4c 100644 --- a/test/fpm_test/test_compiler.f90 +++ b/test/fpm_test/test_compiler.f90 @@ -4,8 +4,9 @@ module test_compiler & check_string use fpm_environment, only : OS_WINDOWS, OS_LINUX use fpm_compiler , only : compiler_t, new_compiler, tokenize_flags - use fpm_strings , only : string_t + use fpm_strings , only : string_t, operator(==) use fpm_command_line, only: get_fpm_env + use fpm_compile_commands, only: compile_command_table_t implicit none private @@ -21,7 +22,9 @@ subroutine collect_compiler(testsuite) testsuite = [ & & new_unittest("check-fortran-source-runs", test_check_fortran_source_runs), & - & new_unittest("tokenize-flags", test_tokenize_flags)] + & new_unittest("tokenize-flags", test_tokenize_flags), & + & new_unittest("compile-commands-unix", test_register_compile_command_unix), & + & new_unittest("compile-commands-windows", test_register_compile_command_windows)] end subroutine collect_compiler @@ -127,4 +130,68 @@ subroutine test_tokenize_flags(error) end subroutine test_tokenize_flags + subroutine test_register_compile_command_unix(error) + type(error_t), allocatable, intent(out) :: error + + type(compile_command_table_t) :: table + type(string_t), allocatable :: expected(:) + integer :: i + + call table%register('gfortran -c -I/usr/include -O2 -Wall main.f90', OS_LINUX, error) + if (allocated(error)) return + + if (size(table%command) /= 1) then + call test_failed(error, "Expected 1 command registered") + return + end if + + associate(c => table%command(1)) + ! Expect these arguments in order + expected = [ string_t('gfortran'), string_t('-c'), & + string_t('-I/usr/include'), string_t('-O2'), & + string_t('-Wall'), string_t('main.f90') ] + + if (.not. c%arguments == expected) then + do i = 1, size(c%arguments) + print *, "Argument", i, ":", c%arguments(i)%s + end do + call test_failed(error, "Unix compile command arguments did not match expected tokens") + return + end if + end associate + end subroutine test_register_compile_command_unix + + subroutine test_register_compile_command_windows(error) + type(error_t), allocatable, intent(out) :: error + + type(compile_command_table_t) :: table + type(string_t), allocatable :: expected(:) + integer :: i + + call table%register('ifort /c /I"C:\Program Files\Libs" /O2 /W4 main.f90', OS_WINDOWS, error) + if (allocated(error)) return + + if (size(table%command) /= 1) then + call test_failed(error, "Expected 1 command registered") + return + end if + + associate(c => table%command(1)) + ! Expected Windows-style tokens + expected = [ string_t('ifort'), string_t('/c'), & + string_t('/IC:\Program Files\Libs'), string_t('/O2'), & + string_t('/W4'), string_t('main.f90') ] + + if (.not. c%arguments == expected) then + do i = 1, size(c%arguments) + print *, "Argument", i, ":", c%arguments(i)%s + end do + call test_failed(error, "Windows compile command arguments did not match expected tokens") + return + end if + end associate + end subroutine test_register_compile_command_windows + + + end module test_compiler