diff options
| -rw-r--r-- | .github/workflows/CI.yml | 28 | ||||
| -rw-r--r-- | fpm/src/fpm_backend.f90 | 42 | ||||
| -rw-r--r-- | fpm/src/fpm_filesystem.f90 | 57 | ||||
| -rw-r--r-- | fpm/src/fpm_sources.f90 | 3 | ||||
| -rw-r--r-- | fpm/test/main.f90 | 94 | ||||
| -rw-r--r-- | fpm/test/testsuite.f90 | 182 | ||||
| -rw-r--r-- | test/example_packages/hello_complex/source/farewell_m.f90 | 3 | ||||
| -rw-r--r-- | test/example_packages/hello_complex/source/greet_m.f90 | 3 | ||||
| -rw-r--r-- | test/example_packages/hello_complex/source/subdir/constants.f90 | 7 |
9 files changed, 365 insertions, 54 deletions
diff --git a/.github/workflows/CI.yml b/.github/workflows/CI.yml index 4666022..0a176af 100644 --- a/.github/workflows/CI.yml +++ b/.github/workflows/CI.yml @@ -19,6 +19,21 @@ jobs: matrix: os: [ubuntu-latest, macos-latest, windows-latest] gcc_v: [9] # Version of GFortran we want to use. + include: + - os: ubuntu-latest + STACK_CACHE: "/home/runner/.stack/" + STACK_CACHE_VERSION: "" + - os: macos-latest + STACK_CACHE: | + /Users/runner/.stack/snapshots + /Users/runner/.stack/setup-exe-src + STACK_CACHE_VERSION: "v2" + - os: windows-latest + STACK_CACHE: | + C:\Users\runneradmin\AppData\Roaming\stack + C:\Users\runneradmin\AppData\Local\Programs\stack + STACK_CACHE_VERSION: "v2" + env: FC: gfortran GCC_V: ${{ matrix.gcc_v }} @@ -61,6 +76,19 @@ jobs: --slave /usr/bin/gfortran gfortran /usr/bin/gfortran-${GCC_V} \ --slave /usr/bingcov gcov /usr/bin/gcov-${GCC_V} + - name: Get Time + id: time + uses: nanzm/get-time-action@v1.0 + with: + format: 'YYYY-MM' + + - name: Setup github actions cache + id: cache + uses: actions/cache@v2 + with: + path: ${{matrix.STACK_CACHE}} + key: ${{ runner.os }}-${{ steps.time.outputs.time }}${{matrix.STACK_CACHE_VERSION}} + - name: Build Haskell fpm run: | cd bootstrap diff --git a/fpm/src/fpm_backend.f90 b/fpm/src/fpm_backend.f90 index 62fd242..65d6dae 100644 --- a/fpm/src/fpm_backend.f90 +++ b/fpm/src/fpm_backend.f90 @@ -2,7 +2,7 @@ module fpm_backend ! Implements the native fpm build backend -use fpm_environment, only: run +use fpm_environment, only: run, get_os_type, OS_WINDOWS use fpm_filesystem, only: basename, join_path, exists, mkdir use fpm_model, only: fpm_model_t, srcfile_t, FPM_UNIT_MODULE, & FPM_UNIT_SUBMODULE, FPM_UNIT_SUBPROGRAM, & @@ -109,8 +109,7 @@ recursive subroutine build_source(model,source_file,linking) end do - object_file = join_path(model%output_directory, model%package_name, & - basename(source_file%file_name,suffix=.false.)//'.o') + object_file = get_object_name(model,source_file%file_name) call run("gfortran -c " // source_file%file_name // model%fortran_compile_flags & // " -o " // object_file) @@ -120,4 +119,41 @@ recursive subroutine build_source(model,source_file,linking) end subroutine build_source + +function get_object_name(model,source_file_name) result(object_file) + ! Generate object target path from source name and model params + ! + ! src/test.f90 -> <output-dir>/<package-name>/test.o + ! src/subdir/test.f90 -> <output-dir>/<package-name>/subdir_test.o + ! + type(fpm_model_t), intent(in) :: model + character(*), intent(in) :: source_file_name + character(:), allocatable :: object_file + + integer :: i + character(1) :: filesep + + select case(get_os_type()) + case (OS_WINDOWS) + filesep = '\' + case default + filesep = '/' + end select + + ! Exclude first directory level from path + object_file = source_file_name(index(source_file_name,filesep)+1:) + + ! Convert remaining directory separators to underscores + i = index(object_file,filesep) + do while(i > 0) + object_file(i:i) = '_' + i = index(object_file,filesep) + end do + + ! Construct full target path + object_file = join_path(model%output_directory, model%package_name, & + object_file//'.o') + +end function get_object_name + end module fpm_backend diff --git a/fpm/src/fpm_filesystem.f90 b/fpm/src/fpm_filesystem.f90 index 985cde8..488a202 100644 --- a/fpm/src/fpm_filesystem.f90 +++ b/fpm/src/fpm_filesystem.f90 @@ -40,6 +40,25 @@ function basename(path,suffix) result (base) end function basename +logical function is_dir(dir) + character(*), intent(in) :: dir + integer :: stat + + select case (get_os_type()) + + case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD) + call execute_command_line("test -d " // dir , exitstat=stat) + + case (OS_WINDOWS) + call execute_command_line('cmd /c "if not exist ' // windows_path(dir) // '\ exit /B 1"', exitstat=stat) + + end select + + is_dir = (stat == 0) + +end function is_dir + + function join_path(a1,a2,a3,a4,a5) result(path) ! Construct path by joining strings with os file separator ! @@ -130,11 +149,15 @@ subroutine mkdir(dir) end subroutine mkdir -subroutine list_files(dir, files) - character(len=*), intent(in) :: dir +recursive subroutine list_files(dir, files, recurse) + character(len=*), intent(in) :: dir type(string_t), allocatable, intent(out) :: files(:) - character(len=:), allocatable :: temp_file - integer :: stat, fh + logical, intent(in), optional :: recurse + + integer :: stat, fh, i + character(:), allocatable :: temp_file + type(string_t), allocatable :: dir_files(:) + type(string_t), allocatable :: sub_dir_files(:) ! Using `inquire` / exists on directories works with gfortran, but not ifort if (.not. exists(dir)) then @@ -160,7 +183,31 @@ subroutine list_files(dir, files) open (newunit=fh, file=temp_file, status='old') files = read_lines(fh) - close (fh, status='delete') + close(fh,status="delete") + + do i=1,size(files) + files(i)%s = join_path(dir,files(i)%s) + end do + + if (present(recurse)) then + if (recurse) then + + allocate(sub_dir_files(0)) + + do i=1,size(files) + if (is_dir(files(i)%s)) then + + call list_files(files(i)%s, dir_files, recurse=.true.) + sub_dir_files = [sub_dir_files, dir_files] + + end if + end do + + files = [files, sub_dir_files] + + end if + end if + end subroutine list_files diff --git a/fpm/src/fpm_sources.f90 b/fpm/src/fpm_sources.f90 index 89e0849..ead4ed3 100644 --- a/fpm/src/fpm_sources.f90 +++ b/fpm/src/fpm_sources.f90 @@ -37,8 +37,7 @@ subroutine add_sources_from_dir(sources,directory,with_executables,error) type(srcfile_t), allocatable :: dir_sources(:) ! Scan directory for sources - call list_files(directory, file_names) - file_names = [(string_t(directory//'/'//file_names(j)%s),j=1,size(file_names))] + call list_files(directory, file_names,recurse=.true.) is_source = [(str_ends_with(lower(file_names(i)%s), ".f90") .or. & str_ends_with(lower(file_names(i)%s), ".c") .or. & diff --git a/fpm/test/main.f90 b/fpm/test/main.f90 index f9d0941..bc8ad29 100644 --- a/fpm/test/main.f90 +++ b/fpm/test/main.f90 @@ -1,36 +1,94 @@ !> Driver for unit testing program fpm_testing use, intrinsic :: iso_fortran_env, only : error_unit - use testsuite, only : run_testsuite + use testsuite, only : run_testsuite, new_testsuite, testsuite_t, & + & select_suite, run_selected use test_toml, only : collect_toml use test_manifest, only : collect_manifest use test_source_parsing, only : collect_source_parsing implicit none - integer :: stat + integer :: stat, is + character(len=:), allocatable :: suite_name, test_name + type(testsuite_t), allocatable :: testsuite(:) character(len=*), parameter :: fmt = '("#", *(1x, a))' - write(error_unit, fmt) "Testing:", "fpm_toml" - call run_testsuite(collect_toml, error_unit, stat) + stat = 0 - if (stat > 0) then - write(error_unit, '(i0, 1x, a)') stat, "tests failed!" - error stop 1 - end if + testsuite = [ & + & new_testsuite("fpm_toml", collect_toml), & + & new_testsuite("fpm_manifest", collect_manifest), & + & new_testsuite("fpm_source_parsing", collect_source_parsing) & + & ] - write(error_unit, fmt) "Testing:", "fpm_manifest" - call run_testsuite(collect_manifest, error_unit, stat) + call get_argument(1, suite_name) + call get_argument(2, test_name) - if (stat > 0) then - write(error_unit, '(i0, 1x, a)') stat, "tests failed!" - error stop 1 + if (allocated(suite_name)) then + is = select_suite(testsuite, suite_name) + if (is > 0 .and. is <= size(testsuite)) then + if (allocated(test_name)) then + write(error_unit, fmt) "Suite:", testsuite(is)%name + call run_selected(testsuite(is)%collect, test_name, error_unit, stat) + if (stat < 0) then + error stop 1 + end if + else + write(error_unit, fmt) "Testing:", testsuite(is)%name + call run_testsuite(testsuite(is)%collect, error_unit, stat) + end if + else + write(error_unit, fmt) "Available testsuites" + do is = 1, size(testsuite) + write(error_unit, fmt) "-", testsuite(is)%name + end do + error stop 1 + end if + else + do is = 1, size(testsuite) + write(error_unit, fmt) "Testing:", testsuite(is)%name + call run_testsuite(testsuite(is)%collect, error_unit, stat) + end do end if - write(error_unit, fmt) "Testing:", "fpm_sources (parsing)" - call run_testsuite(collect_source_parsing, error_unit, stat) - if (stat > 0) then - write(error_unit, '(i0, 1x, a)') stat, "tests failed!" - error stop 1 + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop 1 end if + +contains + + + !> Obtain the command line argument at a given index + subroutine get_argument(idx, arg) + + !> Index of command line argument, range [0:command_argument_count()] + integer, intent(in) :: idx + + !> Command line argument + character(len=:), allocatable, intent(out) :: arg + + integer :: length, stat + + call get_command_argument(idx, length=length, status=stat) + if (stat /= 0) then + return + endif + + allocate(character(len=length) :: arg, stat=stat) + if (stat /= 0) then + return + endif + + if (length > 0) then + call get_command_argument(idx, arg, status=stat) + if (stat /= 0) then + deallocate(arg) + return + end if + end if + + end subroutine get_argument + + end program fpm_testing diff --git a/fpm/test/testsuite.f90 b/fpm/test/testsuite.f90 index 9b69032..124d19a 100644 --- a/fpm/test/testsuite.f90 +++ b/fpm/test/testsuite.f90 @@ -4,9 +4,10 @@ module testsuite implicit none private - public :: run_testsuite, new_unittest, test_failed + public :: run_testsuite, run_selected, new_unittest, new_testsuite, test_failed + public :: select_test, select_suite public :: check_string - public :: unittest_t, error_t + public :: unittest_t, testsuite_t, error_t abstract interface @@ -48,6 +49,22 @@ module testsuite end interface + !> Collection of unit tests + type :: testsuite_t + + !> Name of the testsuite + character(len=:), allocatable :: name + + !> Entry point of the test + procedure(collect_interface), pointer, nopass :: collect => null() + + end type testsuite_t + + + character(len=*), parameter :: fmt = '("#", *(1x, a))' + character(len=*), parameter :: indent = repeat(" ", 5) // repeat(".", 3) + + contains @@ -61,42 +78,141 @@ contains integer, intent(in) :: unit !> Number of failed tests - integer, intent(out) :: stat + integer, intent(inout) :: stat type(unittest_t), allocatable :: testsuite(:) - character(len=*), parameter :: fmt = '("#", *(1x, a))' - character(len=*), parameter :: indent = repeat(" ", 5) // repeat(".", 3) - type(error_t), allocatable :: error integer :: ii - stat = 0 - call collect(testsuite) do ii = 1, size(testsuite) write(unit, '("#", 3(1x, a), 1x, "(", i0, "/", i0, ")")') & & "Starting", testsuite(ii)%name, "...", ii, size(testsuite) - call testsuite(ii)%test(error) - if (allocated(error) .neqv. testsuite(ii)%should_fail) then - if (testsuite(ii)%should_fail) then - write(unit, fmt) indent, testsuite(ii)%name, "[UNEXPECTED PASS]" - else - write(unit, fmt) indent, testsuite(ii)%name, "[FAILED]" - end if - stat = stat + 1 + call run_unittest(testsuite(ii), unit, stat) + end do + + end subroutine run_testsuite + + + !> Driver for selective testing + subroutine run_selected(collect, name, unit, stat) + + !> Collect tests + procedure(collect_interface) :: collect + + !> Name of the selected test + character(len=*), intent(in) :: name + + !> Unit for IO + integer, intent(in) :: unit + + !> Number of failed tests + integer, intent(inout) :: stat + + type(unittest_t), allocatable :: testsuite(:) + integer :: ii + + call collect(testsuite) + + ii = select_test(testsuite, name) + + if (ii > 0 .and. ii <= size(testsuite)) then + call run_unittest(testsuite(ii), unit, stat) + else + write(unit, fmt) "Available tests:" + do ii = 1, size(testsuite) + write(unit, fmt) "-", testsuite(ii)%name + end do + stat = -huge(ii) + end if + + end subroutine run_selected + + + !> Run a selected unit test + subroutine run_unittest(test, unit, stat) + + !> Unit test + type(unittest_t), intent(in) :: test + + !> Unit for IO + integer, intent(in) :: unit + + !> Number of failed tests + integer, intent(inout) :: stat + + type(error_t), allocatable :: error + + call test%test(error) + if (allocated(error) .neqv. test%should_fail) then + if (test%should_fail) then + write(unit, fmt) indent, test%name, "[UNEXPECTED PASS]" else - if (testsuite(ii)%should_fail) then - write(unit, fmt) indent, testsuite(ii)%name, "[EXPECTED FAIL]" - else - write(unit, fmt) indent, testsuite(ii)%name, "[PASSED]" - end if + write(unit, fmt) indent, test%name, "[FAILED]" end if - if (allocated(error)) then - write(unit, fmt) "Message:", error%message + stat = stat + 1 + else + if (test%should_fail) then + write(unit, fmt) indent, test%name, "[EXPECTED FAIL]" + else + write(unit, fmt) indent, test%name, "[PASSED]" + end if + end if + if (allocated(error)) then + write(unit, fmt) "Message:", error%message + end if + + end subroutine run_unittest + + + !> Select a unit test from all available tests + function select_test(tests, name) result(pos) + + !> Name identifying the test suite + character(len=*), intent(in) :: name + + !> Available unit tests + type(unittest_t) :: tests(:) + + !> Selected test suite + integer :: pos + + integer :: it + + pos = 0 + do it = 1, size(tests) + if (name == tests(it)%name) then + pos = it + exit end if end do - end subroutine run_testsuite + end function select_test + + + !> Select a test suite from all available suites + function select_suite(suites, name) result(pos) + + !> Name identifying the test suite + character(len=*), intent(in) :: name + + !> Available test suites + type(testsuite_t) :: suites(:) + + !> Selected test suite + integer :: pos + + integer :: it + + pos = 0 + do it = 1, size(suites) + if (name == suites(it)%name) then + pos = it + exit + end if + end do + + end function select_suite !> Register a new unit test @@ -121,6 +237,24 @@ contains end function new_unittest + !> Register a new testsuite + function new_testsuite(name, collect) result(self) + + !> Name of the testsuite + character(len=*), intent(in) :: name + + !> Entry point to collect tests + procedure(collect_interface) :: collect + + !> Newly registered testsuite + type(testsuite_t) :: self + + self%name = name + self%collect => collect + + end function new_testsuite + + !> Check a deferred length character variable against a reference value subroutine check_string(error, actual, expected, name) diff --git a/test/example_packages/hello_complex/source/farewell_m.f90 b/test/example_packages/hello_complex/source/farewell_m.f90 index 9fc75b9..fbc45ed 100644 --- a/test/example_packages/hello_complex/source/farewell_m.f90 +++ b/test/example_packages/hello_complex/source/farewell_m.f90 @@ -1,4 +1,5 @@ module farewell_m + use subdir_constants, only: FAREWELL_STR implicit none private @@ -8,6 +9,6 @@ contains character(len=*), intent(in) :: name character(len=:), allocatable :: greeting - greeting = "Goodbye, " // name // "!" + greeting = FAREWELL_STR // name // "!" end function make_farewell end module farewell_m diff --git a/test/example_packages/hello_complex/source/greet_m.f90 b/test/example_packages/hello_complex/source/greet_m.f90 index 2372f9a..38afd08 100644 --- a/test/example_packages/hello_complex/source/greet_m.f90 +++ b/test/example_packages/hello_complex/source/greet_m.f90 @@ -1,4 +1,5 @@ module greet_m + use subdir_constants, only: GREET_STR implicit none private @@ -8,6 +9,6 @@ contains character(len=*), intent(in) :: name character(len=:), allocatable :: greeting - greeting = "Hello, " // name // "!" + greeting = GREET_STR // name // "!" end function make_greeting end module greet_m diff --git a/test/example_packages/hello_complex/source/subdir/constants.f90 b/test/example_packages/hello_complex/source/subdir/constants.f90 new file mode 100644 index 0000000..59d6e5f --- /dev/null +++ b/test/example_packages/hello_complex/source/subdir/constants.f90 @@ -0,0 +1,7 @@ +module subdir_constants +implicit none + +character(*), parameter :: GREET_STR = 'Hello, ' +character(*), parameter :: FAREWELL_STR = 'Goodbye, ' + +end module subdir_constants |