diff options
| -rw-r--r-- | fpm/src/fpm.f90 | 19 | ||||
| -rw-r--r-- | fpm/src/fpm_backend.f90 | 235 | ||||
| -rw-r--r-- | fpm/src/fpm_model.f90 | 18 | ||||
| -rw-r--r-- | fpm/src/fpm_sources.f90 | 6 | ||||
| -rw-r--r-- | fpm/src/fpm_strings.f90 | 77 | ||||
| -rw-r--r-- | fpm/src/fpm_targets.f90 | 71 | ||||
| -rw-r--r-- | fpm/test/fpm_test/main.f90 | 2 | ||||
| -rw-r--r-- | fpm/test/fpm_test/test_backend.f90 | 353 | ||||
| -rw-r--r-- | fpm/test/fpm_test/test_module_dependencies.f90 | 2 |
9 files changed, 701 insertions, 82 deletions
diff --git a/fpm/src/fpm.f90 b/fpm/src/fpm.f90 index 5e190c8..b94d25f 100644 --- a/fpm/src/fpm.f90 +++ b/fpm/src/fpm.f90 @@ -8,10 +8,11 @@ use fpm_filesystem, only: is_dir, join_path, number_of_rows, list_files, exists, use fpm_model, only: fpm_model_t, srcfile_t, build_target_t, & FPM_SCOPE_UNKNOWN, FPM_SCOPE_LIB, & FPM_SCOPE_DEP, FPM_SCOPE_APP, FPM_SCOPE_TEST, & - FPM_TARGET_EXECUTABLE + FPM_TARGET_EXECUTABLE, FPM_TARGET_ARCHIVE use fpm_sources, only: add_executable_sources, add_sources_from_dir -use fpm_targets, only: targets_from_sources, resolve_module_dependencies +use fpm_targets, only: targets_from_sources, resolve_module_dependencies, & + resolve_target_linking use fpm_manifest, only : get_package_data, package_config_t use fpm_error, only : error_t, fatal_error use fpm_manifest_test, only : test_config_t @@ -240,8 +241,14 @@ subroutine build_model(model, settings, package, error) model%link_flags = model%link_flags // " -l" // model%link_libraries(i)%s end do + if (model%targets(1)%ptr%target_type == FPM_TARGET_ARCHIVE) then + model%library_file = model%targets(1)%ptr%output_file + end if + call resolve_module_dependencies(model%targets,error) + call resolve_target_linking(model%targets) + end subroutine build_model @@ -403,13 +410,7 @@ subroutine cmd_run(settings,test) end if - ! NB. To be replaced after incremental rebuild is implemented - if (.not.settings%list .and. & - any([(.not.exists(executables(i)%s),i=1,size(executables))])) then - - call build_package(model) - - end if + call build_package(model) do i=1,size(executables) if (settings%list) then diff --git a/fpm/src/fpm_backend.f90 b/fpm/src/fpm_backend.f90 index 3cb95d7..d0843a3 100644 --- a/fpm/src/fpm_backend.f90 +++ b/fpm/src/fpm_backend.f90 @@ -1,113 +1,202 @@ +!> Implements the native fpm build backend module fpm_backend -! Implements the native fpm build backend - -use fpm_environment, only: run, get_os_type, OS_WINDOWS -use fpm_filesystem, only: basename, dirname, join_path, exists, mkdir -use fpm_model, only: fpm_model_t, srcfile_t, build_target_t, FPM_UNIT_MODULE, & - FPM_UNIT_SUBMODULE, FPM_UNIT_SUBPROGRAM, & - FPM_UNIT_CSOURCE, FPM_UNIT_PROGRAM, & - FPM_SCOPE_TEST, FPM_TARGET_OBJECT, FPM_TARGET_ARCHIVE, FPM_TARGET_EXECUTABLE +use fpm_environment, only: run +use fpm_filesystem, only: dirname, join_path, exists, mkdir +use fpm_model, only: fpm_model_t, build_target_t, build_target_ptr, & + FPM_TARGET_OBJECT, FPM_TARGET_ARCHIVE, FPM_TARGET_EXECUTABLE -use fpm_strings, only: split +use fpm_strings, only: string_cat implicit none private -public :: build_package +public :: build_package, sort_target, schedule_targets contains - +!> Top-level routine to build package described by `model` subroutine build_package(model) type(fpm_model_t), intent(inout) :: model - integer :: i, ilib - character(:), allocatable :: base, linking, subdir, link_flags + integer :: i, j + type(build_target_ptr), allocatable :: queue(:) + integer, allocatable :: schedule_ptr(:) - if (.not.exists(model%output_directory)) then - call mkdir(model%output_directory) - end if + ! Need to make output directory for include (mod) files if (.not.exists(join_path(model%output_directory,model%package_name))) then call mkdir(join_path(model%output_directory,model%package_name)) end if - if (model%targets(1)%ptr%target_type == FPM_TARGET_ARCHIVE) then - linking = " "//model%targets(1)%ptr%output_file - else - linking = " " - end if - - linking = linking//" "//model%link_flags - + ! Perform depth-first topological sort of targets do i=1,size(model%targets) - call build_target(model,model%targets(i)%ptr,linking) + call sort_target(model%targets(i)%ptr) end do -end subroutine build_package + ! Construct build schedule queue + call schedule_targets(queue, schedule_ptr, model%targets) + ! Loop over parallel schedule regions + do i=1,size(schedule_ptr)-1 + ! Build targets in schedule region i + !$omp parallel do default(shared) + do j=schedule_ptr(i),(schedule_ptr(i+1)-1) + + call build_target(model,queue(j)%ptr) + + end do + + end do + +end subroutine build_package -recursive subroutine build_target(model,target,linking) - ! Compile Fortran source, called recursively on it dependents - ! - type(fpm_model_t), intent(in) :: model - type(build_target_t), intent(inout) :: target - character(:), allocatable, intent(in) :: linking - integer :: i, j, ilib +!> Topologically sort a target for scheduling by +!> recursing over its dependencies. +!> +!> Checks disk-cached source hashes to determine if objects are +!> up-to-date. Up-to-date sources are tagged as skipped. +!> +recursive subroutine sort_target(target) + type(build_target_t), intent(inout), target :: target + + integer :: i, j, fh, stat type(build_target_t), pointer :: exe_obj - character(:), allocatable :: objs, link_flags - if (target%built) then + ! Check if target has already been processed (as a dependency) + if (target%sorted .or. target%skip) then return end if + ! Check for a circular dependency + ! (If target has been touched but not processed) if (target%touched) then write(*,*) '(!) Circular dependency found with: ',target%output_file stop else - target%touched = .true. + target%touched = .true. ! Set touched flag end if - objs = " " + ! 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 - do i=1,size(target%dependencies) + allocate(target%digest_cached) + open(newunit=fh,file=target%output_file//'.digest',status='old') + read(fh,*,iostat=stat) target%digest_cached + close(fh) - if (associated(target%dependencies(i)%ptr)) then - call build_target(model,target%dependencies(i)%ptr,linking) + if (stat /= 0) then ! Cached digest is not recognized + deallocate(target%digest_cached) end if - if (target%target_type == FPM_TARGET_ARCHIVE ) then + end if + + if (allocated(target%source)) then - ! Construct object list for archive - objs = objs//" "//target%dependencies(i)%ptr%output_file + ! Skip if target is source-based and source file is unmodified + if (allocated(target%digest_cached)) then + if (target%digest_cached == target%source%digest) target%skip = .true. + end if - else if (target%target_type == FPM_TARGET_EXECUTABLE .and. & - target%dependencies(i)%ptr%target_type == FPM_TARGET_OBJECT) then + elseif (exists(target%output_file)) then - exe_obj => target%dependencies(i)%ptr - - ! Construct object list for executable - objs = " "//exe_obj%output_file - - ! Include non-library object dependencies - do j=1,size(exe_obj%dependencies) + ! Skip if target is not source-based and already exists + target%skip = .true. - if (allocated(exe_obj%dependencies(j)%ptr%source)) then - if (exe_obj%dependencies(j)%ptr%source%unit_scope == exe_obj%source%unit_scope) then - objs = objs//" "//exe_obj%dependencies(j)%ptr%output_file - end if - end if + end if - end do + ! Loop over target dependencies + target%schedule = 1 + do i=1,size(target%dependencies) + + ! Sort dependency + call sort_target(target%dependencies(i)%ptr) + + if (.not.target%dependencies(i)%ptr%skip) then + + ! Can't skip target if any dependency is not skipped + target%skip = .false. + + ! Set target schedule after all of its dependencies + target%schedule = max(target%schedule,target%dependencies(i)%ptr%schedule+1) end if end do + ! Mark flag as processed: either sorted or skipped + target%sorted = .not.target%skip + +end subroutine sort_target + + +!> Construct a build schedule from the sorted targets. +!> +!> The schedule is broken into regions, described by `schedule_ptr`, +!> where targets in each region can be compiled in parallel. +!> +subroutine schedule_targets(queue, schedule_ptr, targets) + type(build_target_ptr), allocatable, intent(out) :: queue(:) + integer, allocatable :: schedule_ptr(:) + type(build_target_ptr), intent(in) :: targets(:) + + integer :: i, j + integer :: n_schedule, n_sorted + + n_schedule = 0 ! Number of schedule regions + n_sorted = 0 ! Total number of targets to build + do i=1,size(targets) + + if (targets(i)%ptr%sorted) then + n_sorted = n_sorted + 1 + end if + n_schedule = max(n_schedule, targets(i)%ptr%schedule) + + end do + + allocate(queue(n_sorted)) + allocate(schedule_ptr(n_schedule+1)) + + ! Construct the target queue and schedule region pointer + n_sorted = 1 + schedule_ptr(n_sorted) = 1 + do i=1,n_schedule + + do j=1,size(targets) + + if (targets(j)%ptr%sorted) then + if (targets(j)%ptr%schedule == i) then + + queue(n_sorted)%ptr => targets(j)%ptr + n_sorted = n_sorted + 1 + end if + end if + + end do + + schedule_ptr(i+1) = n_sorted + + end do + +end subroutine schedule_targets + + +!> Call compile/link command for a single target. +!> +!> If successful, also caches the source file digest to disk. +!> +subroutine build_target(model,target) + type(fpm_model_t), intent(in) :: model + type(build_target_t), intent(in), target :: target + + integer :: ilib, fh + character(:), allocatable :: link_flags + if (.not.exists(dirname(target%output_file))) then call mkdir(dirname(target%output_file)) end if @@ -119,22 +208,34 @@ recursive subroutine build_target(model,target,linking) // " -o " // target%output_file) case (FPM_TARGET_EXECUTABLE) - link_flags = linking + + link_flags = string_cat(target%link_objects," ") + + if (allocated(model%library_file)) then + link_flags = link_flags//" "//model%library_file//" "//model%link_flags + else + link_flags = link_flags//" "//model%link_flags + end if + if (allocated(target%link_libraries)) then - do ilib = 1, size(target%link_libraries) - link_flags = link_flags // " -l" // target%link_libraries(ilib)%s - end do + if (size(target%link_libraries) > 0) then + link_flags = link_flags // " -l" // string_cat(target%link_libraries," -l") + end if end if - - call run("gfortran " // objs // model%fortran_compile_flags & - //link_flags// " -o " // target%output_file) + + call run("gfortran " // model%fortran_compile_flags & + //" "//link_flags// " -o " // target%output_file) case (FPM_TARGET_ARCHIVE) - call run("ar -rs " // target%output_file // objs) + call run("ar -rs " // target%output_file // " " // string_cat(target%link_objects," ")) end select - target%built = .true. + if (allocated(target%source)) then + open(newunit=fh,file=target%output_file//'.digest',status='unknown') + write(fh,*) target%source%digest + close(fh) + end if end subroutine build_target diff --git a/fpm/src/fpm_model.f90 b/fpm/src/fpm_model.f90 index 20f174b..031af78 100644 --- a/fpm/src/fpm_model.f90 +++ b/fpm/src/fpm_model.f90 @@ -1,5 +1,6 @@ module fpm_model ! Definition and validation of the backend model +use iso_fortran_env, only: int64 use fpm_strings, only: string_t implicit none @@ -53,6 +54,8 @@ type srcfile_t ! Files INCLUDEd by this source file type(string_t), allocatable :: link_libraries(:) ! Native libraries to link against + integer(int64) :: digest + ! Current hash end type srcfile_t type build_target_ptr @@ -70,9 +73,20 @@ type build_target_t integer :: target_type = FPM_TARGET_UNKNOWN type(string_t), allocatable :: link_libraries(:) ! Native libraries to link against + type(string_t), allocatable :: link_objects(:) + ! Objects needed to link this target - logical :: built = .false. logical :: touched = .false. + ! Flag set when first visited to check for circular dependencies + logical :: sorted = .false. + ! Flag set if build target is sorted for building + logical :: skip = .false. + ! Flag set if build target will be skipped (not built) + + integer :: schedule = -1 + ! Targets in the same schedule group are guaranteed to be independent + integer(int64), allocatable :: digest_cached + ! Previous hash end type build_target_t @@ -89,6 +103,8 @@ type :: fpm_model_t ! Command line flags passed to fortran for compilation character(:), allocatable :: link_flags ! Command line flags pass for linking + character(:), allocatable :: library_file + ! Output file for library archive character(:), allocatable :: output_directory ! Base directory for build type(string_t), allocatable :: link_libraries(:) diff --git a/fpm/src/fpm_sources.f90 b/fpm/src/fpm_sources.f90 index 5e42430..5e78d6e 100644 --- a/fpm/src/fpm_sources.f90 +++ b/fpm/src/fpm_sources.f90 @@ -7,7 +7,7 @@ use fpm_model, only: srcfile_t, fpm_model_t, & FPM_SCOPE_LIB, FPM_SCOPE_DEP, FPM_SCOPE_APP, FPM_SCOPE_TEST use fpm_filesystem, only: basename, canon_path, dirname, join_path, read_lines, list_files -use fpm_strings, only: lower, split, str_ends_with, string_t, operator(.in.) +use fpm_strings, only: lower, split, str_ends_with, string_t, operator(.in.), fnv_1a use fpm_manifest_executable, only: executable_config_t implicit none @@ -233,6 +233,8 @@ function parse_f_source(f_filename,error) result(f_source) file_lines = read_lines(fh) close(fh) + f_source%digest = fnv_1a(file_lines) + do pass = 1,2 n_use = 0 n_include = 0 @@ -512,6 +514,8 @@ function parse_c_source(c_filename,error) result(c_source) file_lines = read_lines(fh) close(fh) + c_source%digest = fnv_1a(file_lines) + do pass = 1,2 n_include = 0 file_loop: do i=1,size(file_lines) diff --git a/fpm/src/fpm_strings.f90 b/fpm/src/fpm_strings.f90 index d1f5150..8a569cd 100644 --- a/fpm/src/fpm_strings.f90 +++ b/fpm/src/fpm_strings.f90 @@ -1,9 +1,10 @@ module fpm_strings +use iso_fortran_env, only: int64 implicit none private public :: f_string, lower, split, str_ends_with, string_t -public :: string_array_contains, operator(.in.) +public :: string_array_contains, string_cat, operator(.in.), fnv_1a type string_t character(len=:), allocatable :: s @@ -13,6 +14,11 @@ interface operator(.in.) module procedure string_array_contains end interface +interface fnv_1a + procedure :: fnv_1a_char + procedure :: fnv_1a_string_t +end interface fnv_1a + contains logical function str_ends_with(s, e) result(r) @@ -48,6 +54,46 @@ function f_string(c_string) end function f_string +!> Hash a character(*) string of default kind +pure function fnv_1a_char(input, seed) result(hash) + character(*), intent(in) :: input + integer(int64), intent(in), optional :: seed + integer(int64) :: hash + + integer :: i + integer(int64), parameter :: FNV_OFFSET_32 = 2166136261_int64 + integer(int64), parameter :: FNV_PRIME_32 = 16777619_int64 + + if (present(seed)) then + hash = seed + else + hash = FNV_OFFSET_32 + end if + + do i=1,len(input) + hash = ieor(hash,iachar(input(i:i),int64)) * FNV_PRIME_32 + end do + +end function fnv_1a_char + + +!> Hash a string_t array of default kind +pure function fnv_1a_string_t(input, seed) result(hash) + type(string_t), intent(in) :: input(:) + integer(int64), intent(in), optional :: seed + integer(int64) :: hash + + integer :: i + + hash = fnv_1a(input(1)%s,seed) + + do i=2,size(input) + hash = fnv_1a(input(i)%s,hash) + end do + +end function fnv_1a_string_t + + elemental pure function lower(str,begin,end) result (string) ! Changes a string to lowercase over specified range ! Author: John S. Urban @@ -94,6 +140,35 @@ logical function string_array_contains(search_string,array) end function string_array_contains +!> Concatenate an array of type(string_t) into +!> a single character +function string_cat(strings,delim) result(cat) + type(string_t), intent(in) :: strings(:) + character(*), intent(in), optional :: delim + character(:), allocatable :: cat + + integer :: i,n + character(:), allocatable :: delim_str + + if (size(strings) < 1) then + cat = '' + return + end if + + if (present(delim)) then + delim_str = delim + else + delim_str = '' + end if + + cat = strings(1)%s + do i=2,size(strings) + + cat = cat//delim_str//strings(i)%s + + end do + +end function string_cat subroutine split(input_line,array,delimiters,order,nulls) ! parse string on delimiter characters and store tokens into an allocatable array" diff --git a/fpm/src/fpm_targets.f90 b/fpm/src/fpm_targets.f90 index c3a59fd..03996f7 100644 --- a/fpm/src/fpm_targets.f90 +++ b/fpm/src/fpm_targets.f90 @@ -13,9 +13,16 @@ subroutine targets_from_sources(model,sources) type(srcfile_t), intent(in) :: sources(:) integer :: i + character(:), allocatable :: xsuffix type(build_target_t), pointer :: dep logical :: with_lib + if (get_os_type() == OS_WINDOWS) then + xsuffix = '.exe' + else + xsuffix = '' + end if + with_lib = any([(sources(i)%unit_scope == FPM_SCOPE_LIB,i=1,size(sources))]) if (with_lib) call add_target(model%targets,type = FPM_TARGET_ARCHIVE,& @@ -46,11 +53,13 @@ subroutine targets_from_sources(model,sources) if (sources(i)%unit_scope == FPM_SCOPE_APP) then call add_target(model%targets,type = FPM_TARGET_EXECUTABLE,& link_libraries = sources(i)%link_libraries, & - output_file = join_path(model%output_directory,'app',sources(i)%exe_name)) + output_file = join_path(model%output_directory,'app', & + sources(i)%exe_name//xsuffix)) else call add_target(model%targets,type = FPM_TARGET_EXECUTABLE,& link_libraries = sources(i)%link_libraries, & - output_file = join_path(model%output_directory,'test',sources(i)%exe_name)) + output_file = join_path(model%output_directory,'test', & + sources(i)%exe_name//xsuffix)) end if @@ -249,4 +258,62 @@ function find_module_dependency(targets,module_name,include_dir) result(target_p end function find_module_dependency + +!> For link targets, enumerate any dependency objects required for linking +subroutine resolve_target_linking(targets) + type(build_target_ptr), intent(inout), target :: targets(:) + + integer :: i,j,k + type(string_t) :: link_object + + do i=1,size(targets) + + associate(target => targets(i)%ptr) + + allocate(target%link_objects(0)) + + do j=1,size(target%dependencies) + + if (target%target_type == FPM_TARGET_ARCHIVE ) then + + ! Construct object list for archive + link_object%s = target%dependencies(j)%ptr%output_file + target%link_objects = [target%link_objects, link_object] + + else if (target%target_type == FPM_TARGET_EXECUTABLE .and. & + target%dependencies(j)%ptr%target_type == FPM_TARGET_OBJECT) then + + associate(exe_obj => target%dependencies(j)%ptr) + + ! Construct object list for executable + link_object%s = exe_obj%output_file + target%link_objects = [target%link_objects, link_object] + + ! Include non-library object dependencies + do k=1,size(exe_obj%dependencies) + + if (allocated(exe_obj%dependencies(k)%ptr%source)) then + if (exe_obj%dependencies(k)%ptr%source%unit_scope == & + exe_obj%source%unit_scope) then + + link_object%s = exe_obj%dependencies(k)%ptr%output_file + target%link_objects = [target%link_objects, link_object] + + end if + end if + + end do + + end associate + + end if + + end do + end associate + + end do + +end subroutine resolve_target_linking + + end module fpm_targets diff --git a/fpm/test/fpm_test/main.f90 b/fpm/test/fpm_test/main.f90 index eb08a94..1ba5c6a 100644 --- a/fpm/test/fpm_test/main.f90 +++ b/fpm/test/fpm_test/main.f90 @@ -7,6 +7,7 @@ program fpm_testing use test_manifest, only : collect_manifest use test_source_parsing, only : collect_source_parsing use test_module_dependencies, only : collect_module_dependencies + use test_backend, only: collect_backend use test_versioning, only : collect_versioning implicit none integer :: stat, is @@ -21,6 +22,7 @@ program fpm_testing & new_testsuite("fpm_manifest", collect_manifest), & & new_testsuite("fpm_source_parsing", collect_source_parsing), & & new_testsuite("fpm_module_dependencies", collect_module_dependencies), & + & new_testsuite("fpm_test_backend", collect_backend), & & new_testsuite("fpm_versioning", collect_versioning) & & ] diff --git a/fpm/test/fpm_test/test_backend.f90 b/fpm/test/fpm_test/test_backend.f90 new file mode 100644 index 0000000..a7a3f0b --- /dev/null +++ b/fpm/test/fpm_test/test_backend.f90 @@ -0,0 +1,353 @@ +!> Define tests for the `fpm_backend` module (build scheduling) +module test_backend + use testsuite, only : new_unittest, unittest_t, error_t, test_failed + use test_module_dependencies, only: operator(.in.) + use fpm_filesystem, only: exists, mkdir, get_temp_filename + use fpm_model, only: build_target_t, build_target_ptr, & + FPM_TARGET_OBJECT, FPM_TARGET_ARCHIVE + use fpm_targets, only: add_target, add_dependency + use fpm_backend, only: sort_target, schedule_targets + implicit none + private + + public :: collect_backend + +contains + + + !> Collect all exported unit tests + subroutine collect_backend(testsuite) + + !> Collection of tests + type(unittest_t), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + & new_unittest("target-sort", test_target_sort), & + & 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) & + ] + + end subroutine collect_backend + + + !> Check scheduling of objects with dependencies + subroutine test_target_sort(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(build_target_ptr), allocatable :: targets(:) + + integer :: i + + targets = new_test_package() + + ! Perform depth-first topological sort of targets + do i=1,size(targets) + + call sort_target(targets(i)%ptr) + + end do + + ! Check target states: all targets scheduled + do i=1,size(targets) + + if (.not.targets(i)%ptr%touched) then + call test_failed(error,"Target touched flag not set") + return + end if + + if (.not.targets(i)%ptr%sorted) then + call test_failed(error,"Target sort flag not set") + return + end if + + if (targets(i)%ptr%skip) then + call test_failed(error,"Target skip flag set incorrectly") + return + end if + + if (targets(i)%ptr%schedule < 0) then + call test_failed(error,"Target schedule not set") + return + end if + + end do + + ! Check all objects sheduled before library + do i=2,size(targets) + + if (targets(i)%ptr%schedule >= targets(1)%ptr%schedule) then + call test_failed(error,"Object dependency scheduled after dependent library target") + return + end if + + end do + + ! Check target 4 schedule before targets 2 & 3 + do i=2,3 + if (targets(4)%ptr%schedule >= targets(i)%ptr%schedule) then + call test_failed(error,"Object dependency scheduled after dependent object target") + return + end if + end do + + end subroutine test_target_sort + + + + !> Check incremental rebuild for existing archive + !> all object sources are unmodified: all objects should be skipped + subroutine test_target_sort_skip_all(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(build_target_ptr), allocatable :: targets(:) + + integer :: fh, i + + targets = new_test_package() + + do i=2,size(targets) + + ! Mimick unmodified sources + allocate(targets(i)%ptr%source) + targets(i)%ptr%source%digest = i + targets(i)%ptr%digest_cached = i + + end do + + ! Mimick archive already exists + open(newunit=fh,file=targets(1)%ptr%output_file,status="unknown") + close(fh) + + ! Perform depth-first topological sort of targets + do i=1,size(targets) + + call sort_target(targets(i)%ptr) + + end do + + ! Check target states: all targets skipped + do i=1,size(targets) + + if (.not.targets(i)%ptr%touched) then + call test_failed(error,"Target touched flag not set") + return + end if + + if (targets(i)%ptr%sorted) then + call test_failed(error,"Target sort flag set incorrectly") + return + end if + + if (.not.targets(i)%ptr%skip) then + call test_failed(error,"Target skip flag set incorrectly") + return + end if + + end do + + end subroutine test_target_sort_skip_all + + + !> Check incremental rebuild for existing archive + !> all but lowest source modified: all objects should be rebuilt + subroutine test_target_sort_rebuild_all(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(build_target_ptr), allocatable :: targets(:) + + integer :: fh, i + + targets = new_test_package() + + do i=2,3 + + ! Mimick unmodified sources + allocate(targets(i)%ptr%source) + targets(i)%ptr%source%digest = i + targets(i)%ptr%digest_cached = i + + end do + + ! Mimick archive already exists + open(newunit=fh,file=targets(1)%ptr%output_file,status="unknown") + close(fh) + + ! Perform depth-first topological sort of targets + do i=1,size(targets) + + call sort_target(targets(i)%ptr) + + end do + + ! Check target states: all targets scheduled + do i=1,size(targets) + + if (.not.targets(i)%ptr%sorted) then + call test_failed(error,"Target sort flag not set") + return + end if + + if (targets(i)%ptr%skip) then + call test_failed(error,"Target skip flag set incorrectly") + return + end if + + end do + + end subroutine test_target_sort_rebuild_all + + + !> Check construction of target queue and schedule + subroutine test_schedule_targets(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(build_target_ptr), allocatable :: targets(:) + + integer :: i, j + type(build_target_ptr), allocatable :: queue(:) + integer, allocatable :: schedule_ptr(:) + + targets = new_test_package() + + ! Perform depth-first topological sort of targets + do i=1,size(targets) + + call sort_target(targets(i)%ptr) + + end do + + ! Construct build schedule queue + call schedule_targets(queue, schedule_ptr, targets) + + ! Check all targets enqueued + do i=1,size(targets) + + if (.not.(targets(i)%ptr.in.queue)) then + + call test_failed(error,"Target not found in build queue") + return + + end if + + end do + + ! Check schedule structure + if (schedule_ptr(1) /= 1) then + + call test_failed(error,"schedule_ptr(1) does not point to start of the queue") + return + + end if + + if (schedule_ptr(size(schedule_ptr)) /= size(queue)+1) then + + call test_failed(error,"schedule_ptr(end) does not point to end of the queue") + return + + end if + + do i=1,size(schedule_ptr)-1 + + do j=schedule_ptr(i),(schedule_ptr(i+1)-1) + + if (queue(j)%ptr%schedule /= i) then + + call test_failed(error,"Target scheduled in the wrong region") + return + + end if + + end do + + end do + + end subroutine test_schedule_targets + + + !> Check construction of target queue and schedule + !> when there's nothing to do (all targets skipped) + subroutine test_schedule_empty(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(build_target_ptr), allocatable :: targets(:) + + integer :: i + type(build_target_ptr), allocatable :: queue(:) + integer, allocatable :: schedule_ptr(:) + + targets = new_test_package() + + do i=1,size(targets) + + targets(i)%ptr%skip = .true. + + end do + + ! Perform depth-first topological sort of targets + do i=1,size(targets) + + call sort_target(targets(i)%ptr) + + end do + + ! Construct build schedule queue + call schedule_targets(queue, schedule_ptr, targets) + + ! Check queue is empty + if (size(queue) > 0) then + + call test_failed(error,"Expecting an empty build queue, but not empty") + return + + end if + + ! Check schedule loop is not entered + do i=1,size(schedule_ptr)-1 + + call test_failed(error,"Attempted to run an empty schedule") + return + + end do + + end subroutine test_schedule_empty + + + !> Helper to generate target objects with dependencies + function new_test_package() result(targets) + + type(build_target_ptr), allocatable :: targets(:) + + call add_target(targets,FPM_TARGET_ARCHIVE,get_temp_filename()) + + call add_target(targets,FPM_TARGET_OBJECT,get_temp_filename()) + + call add_target(targets,FPM_TARGET_OBJECT,get_temp_filename()) + + call add_target(targets,FPM_TARGET_OBJECT,get_temp_filename()) + + ! Library depends on all objects + call add_dependency(targets(1)%ptr,targets(2)%ptr) + call add_dependency(targets(1)%ptr,targets(3)%ptr) + call add_dependency(targets(1)%ptr,targets(4)%ptr) + + ! Inter-object dependency + ! targets 2 & 3 depend on target 4 + call add_dependency(targets(2)%ptr,targets(4)%ptr) + call add_dependency(targets(3)%ptr,targets(4)%ptr) + + end function new_test_package + + +end module test_backend
\ No newline at end of file diff --git a/fpm/test/fpm_test/test_module_dependencies.f90 b/fpm/test/fpm_test/test_module_dependencies.f90 index c73db30..18929ac 100644 --- a/fpm/test/fpm_test/test_module_dependencies.f90 +++ b/fpm/test/fpm_test/test_module_dependencies.f90 @@ -12,7 +12,7 @@ module test_module_dependencies implicit none private - public :: collect_module_dependencies + public :: collect_module_dependencies, operator(.in.) interface operator(.in.) module procedure target_in |