diff --git a/.pre-commit-config.yaml b/.pre-commit-config.yaml new file mode 100644 index 0000000000..7ff2079aa5 --- /dev/null +++ b/.pre-commit-config.yaml @@ -0,0 +1,6 @@ +repos: + - repo: https://github.com/pseewald/fprettify + rev: v0.3.7 + hooks: + - id: fprettify + args: [-i4, -r] diff --git a/app/main.f90 b/app/main.f90 index c7091267fb..f294bc01c8 100644 --- a/app/main.f90 +++ b/app/main.f90 @@ -1,119 +1,119 @@ program main -use, intrinsic :: iso_fortran_env, only : error_unit, output_unit -use fpm_command_line, only: & - fpm_cmd_settings, & - fpm_new_settings, & - fpm_build_settings, & - fpm_run_settings, & - fpm_test_settings, & - fpm_install_settings, & - fpm_update_settings, & - fpm_clean_settings, & - get_command_line_settings -use fpm_error, only: error_t -use fpm_filesystem, only: exists, parent_dir, join_path -use fpm, only: cmd_build, cmd_run, cmd_clean -use fpm_cmd_install, only: cmd_install -use fpm_cmd_new, only: cmd_new -use fpm_cmd_update, only : cmd_update -use fpm_os, only: change_directory, get_current_directory - -implicit none - -class(fpm_cmd_settings), allocatable :: cmd_settings -type(error_t), allocatable :: error -character(len=:), allocatable :: pwd_start, pwd_working, working_dir, project_root - -call get_command_line_settings(cmd_settings) - -call get_current_directory(pwd_start, error) -call handle_error(error) - -call get_working_dir(cmd_settings, working_dir) -if (allocated(working_dir)) then + use, intrinsic :: iso_fortran_env, only: error_unit, output_unit + use fpm_command_line, only: & + fpm_cmd_settings, & + fpm_new_settings, & + fpm_build_settings, & + fpm_run_settings, & + fpm_test_settings, & + fpm_install_settings, & + fpm_update_settings, & + fpm_clean_settings, & + get_command_line_settings + use fpm_error, only: error_t + use fpm_filesystem, only: exists, parent_dir, join_path + use fpm, only: cmd_build, cmd_run, cmd_clean + use fpm_cmd_install, only: cmd_install + use fpm_cmd_new, only: cmd_new + use fpm_cmd_update, only: cmd_update + use fpm_os, only: change_directory, get_current_directory + + implicit none + + class(fpm_cmd_settings), allocatable :: cmd_settings + type(error_t), allocatable :: error + character(len=:), allocatable :: pwd_start, pwd_working, working_dir, project_root + + call get_command_line_settings(cmd_settings) + + call get_current_directory(pwd_start, error) + call handle_error(error) + + call get_working_dir(cmd_settings, working_dir) + if (allocated(working_dir)) then ! Change working directory if requested if (len_trim(working_dir) > 0) then - call change_directory(working_dir, error) - call handle_error(error) + call change_directory(working_dir, error) + call handle_error(error) - call get_current_directory(pwd_working, error) - call handle_error(error) - write(output_unit, '(*(a))') "fpm: Entering directory '"//pwd_working//"'" + call get_current_directory(pwd_working, error) + call handle_error(error) + write (output_unit, '(*(a))') "fpm: Entering directory '"//pwd_working//"'" else - pwd_working = pwd_start + pwd_working = pwd_start end if -else + else pwd_working = pwd_start -end if - -select type (settings => cmd_settings) -type is (fpm_new_settings) -class default - if (.not.has_manifest(pwd_working)) then - project_root = pwd_working - do while(.not.has_manifest(project_root)) - working_dir = parent_dir(project_root) - if (len(working_dir) == 0) exit - project_root = working_dir - end do - - if (has_manifest(project_root)) then - call change_directory(project_root, error) - call handle_error(error) - write(output_unit, '(*(a))') "fpm: Entering directory '"//project_root//"'" - end if + end if + + select type (settings => cmd_settings) + type is (fpm_new_settings) + class default + if (.not. has_manifest(pwd_working)) then + project_root = pwd_working + do while (.not. has_manifest(project_root)) + working_dir = parent_dir(project_root) + if (len(working_dir) == 0) exit + project_root = working_dir + end do + + if (has_manifest(project_root)) then + call change_directory(project_root, error) + call handle_error(error) + write (output_unit, '(*(a))') "fpm: Entering directory '"//project_root//"'" + end if end if -end select + end select -select type(settings=>cmd_settings) -type is (fpm_new_settings) + select type (settings => cmd_settings) + type is (fpm_new_settings) call cmd_new(settings) -type is (fpm_build_settings) + type is (fpm_build_settings) call cmd_build(settings) -type is (fpm_run_settings) - call cmd_run(settings,test=.false.) -type is (fpm_test_settings) - call cmd_run(settings,test=.true.) -type is (fpm_install_settings) + type is (fpm_run_settings) + call cmd_run(settings, test=.false.) + type is (fpm_test_settings) + call cmd_run(settings, test=.true.) + type is (fpm_install_settings) call cmd_install(settings) -type is (fpm_update_settings) + type is (fpm_update_settings) call cmd_update(settings) -type is (fpm_clean_settings) + type is (fpm_clean_settings) call cmd_clean(settings) -end select + end select -if (allocated(project_root)) then - write(output_unit, '(*(a))') "fpm: Leaving directory '"//project_root//"'" -end if + if (allocated(project_root)) then + write (output_unit, '(*(a))') "fpm: Leaving directory '"//project_root//"'" + end if -if (pwd_start /= pwd_working) then - write(output_unit, '(*(a))') "fpm: Leaving directory '"//pwd_working//"'" -end if + if (pwd_start /= pwd_working) then + write (output_unit, '(*(a))') "fpm: Leaving directory '"//pwd_working//"'" + end if contains - function has_manifest(dir) - character(len=*), intent(in) :: dir - logical :: has_manifest - - has_manifest = exists(join_path(dir, "fpm.toml")) - end function has_manifest - - subroutine handle_error(error) - type(error_t), optional, intent(in) :: error - if (present(error)) then - write(error_unit, '("[Error]", 1x, a)') error%message - stop 1 - end if - end subroutine handle_error - - !> Save access to working directory in settings, in case setting have not been allocated - subroutine get_working_dir(settings, working_dir) - class(fpm_cmd_settings), optional, intent(in) :: settings - character(len=:), allocatable, intent(out) :: working_dir - if (present(settings)) then - working_dir = settings%working_dir - end if - end subroutine get_working_dir + function has_manifest(dir) + character(len=*), intent(in) :: dir + logical :: has_manifest + + has_manifest = exists(join_path(dir, "fpm.toml")) + end function has_manifest + + subroutine handle_error(error) + type(error_t), optional, intent(in) :: error + if (present(error)) then + write (error_unit, '("[Error]", 1x, a)') error%message + stop 1 + end if + end subroutine handle_error + + !> Save access to working directory in settings, in case setting have not been allocated + subroutine get_working_dir(settings, working_dir) + class(fpm_cmd_settings), optional, intent(in) :: settings + character(len=:), allocatable, intent(out) :: working_dir + if (present(settings)) then + working_dir = settings%working_dir + end if + end subroutine get_working_dir end program main diff --git a/example_packages/app_with_c/app/main.f90 b/example_packages/app_with_c/app/main.f90 index 297352df15..6c7f2a0179 100644 --- a/example_packages/app_with_c/app/main.f90 +++ b/example_packages/app_with_c/app/main.f90 @@ -1,37 +1,37 @@ module with_c - use iso_c_binding, only: c_char, c_int, c_null_char - implicit none + use iso_c_binding, only: c_char, c_int, c_null_char + implicit none contains - function system_isdir(dirname) - ! Source (Public domain): https://github.com/urbanjost/M_system - ! - implicit none - character(len=*), intent(in) :: dirname - logical :: system_isdir + function system_isdir(dirname) + ! Source (Public domain): https://github.com/urbanjost/M_system + ! + implicit none + character(len=*), intent(in) :: dirname + logical :: system_isdir - interface - function c_isdir(dirname) bind(C, name="my_isdir") result(c_ierr) - import c_char, c_int - character(kind=c_char, len=1), intent(in) :: dirname(*) - integer(kind=c_int) :: c_ierr - end function c_isdir - end interface + interface + function c_isdir(dirname) bind(C, name="my_isdir") result(c_ierr) + import c_char, c_int + character(kind=c_char, len=1), intent(in) :: dirname(*) + integer(kind=c_int) :: c_ierr + end function c_isdir + end interface - system_isdir = c_isdir(trim(dirname)//c_null_char) == 1 + system_isdir = c_isdir(trim(dirname)//c_null_char) == 1 - end function system_isdir + end function system_isdir end module with_c program with_c_app - use with_c - implicit none + use with_c + implicit none - write (*, *) "isdir('app') = ", system_isdir('app') - write (*, *) "isdir('src') = ", system_isdir('src') - write (*, *) "isdir('test') = ", system_isdir('test') - write (*, *) "isdir('bench') = ", system_isdir('bench') + write (*, *) "isdir('app') = ", system_isdir('app') + write (*, *) "isdir('src') = ", system_isdir('src') + write (*, *) "isdir('test') = ", system_isdir('test') + write (*, *) "isdir('bench') = ", system_isdir('bench') end program with_c_app diff --git a/example_packages/app_with_submodule/app/app1/child1.f90 b/example_packages/app_with_submodule/app/app1/child1.f90 index 8f0c97247f..1bfbe46951 100644 --- a/example_packages/app_with_submodule/app/app1/child1.f90 +++ b/example_packages/app_with_submodule/app/app1/child1.f90 @@ -1,16 +1,16 @@ submodule(parent) child1 -implicit none + implicit none -interface - module function my_fun() result (b) - integer :: b + interface + module function my_fun() result(b) + integer :: b end function my_fun -end interface + end interface contains -module procedure my_sub1 - a = my_fun() -end procedure my_sub1 + module procedure my_sub1 + a = my_fun() + end procedure my_sub1 -end submodule child1 \ No newline at end of file +end submodule child1 diff --git a/example_packages/app_with_submodule/app/app1/grandchild.f90 b/example_packages/app_with_submodule/app/app1/grandchild.f90 index ad8913e641..3e19a2140d 100644 --- a/example_packages/app_with_submodule/app/app1/grandchild.f90 +++ b/example_packages/app_with_submodule/app/app1/grandchild.f90 @@ -4,7 +4,7 @@ contains module procedure my_fun - b = 1 +b = 1 end procedure my_fun -end submodule grandchild \ No newline at end of file +end submodule grandchild diff --git a/example_packages/app_with_submodule/app/app1/main1.f90 b/example_packages/app_with_submodule/app/app1/main1.f90 index bbcc3450db..7aedb7ae66 100644 --- a/example_packages/app_with_submodule/app/app1/main1.f90 +++ b/example_packages/app_with_submodule/app/app1/main1.f90 @@ -1,14 +1,14 @@ program test -use parent -implicit none + use parent + implicit none -integer :: a + integer :: a -call my_sub1(a) + call my_sub1(a) -if (a /= 1) then - write(*,*) 'FAILED: Unexpected value of a' + if (a /= 1) then + write (*, *) 'FAILED: Unexpected value of a' stop 1 -end if + end if -end program test \ No newline at end of file +end program test diff --git a/example_packages/app_with_submodule/app/app2/child2.f90 b/example_packages/app_with_submodule/app/app2/child2.f90 index 9eb4fb9225..102b1e5297 100644 --- a/example_packages/app_with_submodule/app/app2/child2.f90 +++ b/example_packages/app_with_submodule/app/app2/child2.f90 @@ -1,10 +1,10 @@ submodule(parent) child2 -implicit none + implicit none contains -module procedure my_sub1 - a = 2 -end procedure my_sub1 + module procedure my_sub1 + a = 2 + end procedure my_sub1 -end submodule child2 \ No newline at end of file +end submodule child2 diff --git a/example_packages/app_with_submodule/app/app2/main2.f90 b/example_packages/app_with_submodule/app/app2/main2.f90 index f528638900..65576b950a 100644 --- a/example_packages/app_with_submodule/app/app2/main2.f90 +++ b/example_packages/app_with_submodule/app/app2/main2.f90 @@ -1,14 +1,14 @@ program test -use parent -implicit none + use parent + implicit none -integer :: a + integer :: a -call my_sub1(a) + call my_sub1(a) -if (a /= 2) then - write(*,*) 'FAILED: Unexpected value of a' + if (a /= 2) then + write (*, *) 'FAILED: Unexpected value of a' stop 1 -end if + end if -end program test \ No newline at end of file +end program test diff --git a/example_packages/app_with_submodule/src/parent.f90 b/example_packages/app_with_submodule/src/parent.f90 index c3386eee65..cf6c0560e5 100644 --- a/example_packages/app_with_submodule/src/parent.f90 +++ b/example_packages/app_with_submodule/src/parent.f90 @@ -1,11 +1,11 @@ module parent -implicit none + implicit none -interface + interface module subroutine my_sub1(a) - integer, intent(out) :: a + integer, intent(out) :: a end subroutine my_sub1 -end interface + end interface -end module parent \ No newline at end of file +end module parent diff --git a/example_packages/auto_discovery_off/app/main.f90 b/example_packages/auto_discovery_off/app/main.f90 index 8902dc6de8..a6ae9db8c0 100644 --- a/example_packages/auto_discovery_off/app/main.f90 +++ b/example_packages/auto_discovery_off/app/main.f90 @@ -1,6 +1,6 @@ program main -implicit none + implicit none -print *, "This program should run." + print *, "This program should run." end program main diff --git a/example_packages/auto_discovery_off/app/unused.f90 b/example_packages/auto_discovery_off/app/unused.f90 index 57d8153878..2e1a7cdcfd 100644 --- a/example_packages/auto_discovery_off/app/unused.f90 +++ b/example_packages/auto_discovery_off/app/unused.f90 @@ -1,6 +1,6 @@ program unused -implicit none + implicit none -print *, "This program should NOT run." + print *, "This program should NOT run." end program unused diff --git a/example_packages/auto_discovery_off/test/my_test.f90 b/example_packages/auto_discovery_off/test/my_test.f90 index fd59f9fef4..5c07b701c3 100644 --- a/example_packages/auto_discovery_off/test/my_test.f90 +++ b/example_packages/auto_discovery_off/test/my_test.f90 @@ -1,6 +1,6 @@ program my_test -implicit none + implicit none -print *, "Test passed! That was easy!" + print *, "Test passed! That was easy!" end program my_test diff --git a/example_packages/auto_discovery_off/test/unused_test.f90 b/example_packages/auto_discovery_off/test/unused_test.f90 index 5c4261120a..351e752279 100644 --- a/example_packages/auto_discovery_off/test/unused_test.f90 +++ b/example_packages/auto_discovery_off/test/unused_test.f90 @@ -1,7 +1,7 @@ program unused_test -implicit none + implicit none -print *, "This program should NOT run." + print *, "This program should NOT run." end program unused_test diff --git a/example_packages/circular_example/src/greet_m.f90 b/example_packages/circular_example/src/greet_m.f90 index 2372f9a446..2bb3506a4c 100644 --- a/example_packages/circular_example/src/greet_m.f90 +++ b/example_packages/circular_example/src/greet_m.f90 @@ -1,13 +1,13 @@ module greet_m - implicit none - private + implicit none + private - public :: make_greeting + public :: make_greeting contains - function make_greeting(name) result(greeting) - character(len=*), intent(in) :: name - character(len=:), allocatable :: greeting + function make_greeting(name) result(greeting) + character(len=*), intent(in) :: name + character(len=:), allocatable :: greeting - greeting = "Hello, " // name // "!" - end function make_greeting + greeting = "Hello, "//name//"!" + end function make_greeting end module greet_m diff --git a/example_packages/circular_example/test/main.f90 b/example_packages/circular_example/test/main.f90 index 5b7d8030e4..c3d4678bb4 100644 --- a/example_packages/circular_example/test/main.f90 +++ b/example_packages/circular_example/test/main.f90 @@ -1,7 +1,7 @@ program run_tests - use hello_test, only: run_test + use hello_test, only: run_test - implicit none + implicit none - call run_test + call run_test end program run_tests diff --git a/example_packages/circular_test/src/hello_test.f90 b/example_packages/circular_test/src/hello_test.f90 index 5a591c6123..d7f3160fba 100644 --- a/example_packages/circular_test/src/hello_test.f90 +++ b/example_packages/circular_test/src/hello_test.f90 @@ -1,12 +1,12 @@ module hello_test - use greet_m, only: make_greeting + use greet_m, only: make_greeting - implicit none - private + implicit none + private - public :: run_test + public :: run_test contains - subroutine run_test - print *, make_greeting("from test") - end subroutine run_test + subroutine run_test + print *, make_greeting("from test") + end subroutine run_test end module hello_test diff --git a/example_packages/cpp_files/src/cpp_files.f90 b/example_packages/cpp_files/src/cpp_files.f90 index 818beb53a2..81791af4b3 100644 --- a/example_packages/cpp_files/src/cpp_files.f90 +++ b/example_packages/cpp_files/src/cpp_files.f90 @@ -6,7 +6,7 @@ module cpp_files public :: intvec_maxval interface - integer function intvec_maxval(array, n) bind(C, name = "intvec_maxval") + integer function intvec_maxval(array, n) bind(C, name="intvec_maxval") import :: c_int, c_size_t integer(c_int), intent(in) :: array(*) integer(c_size_t), intent(in), value :: n diff --git a/example_packages/cpp_files/test/check.f90 b/example_packages/cpp_files/test/check.f90 index 2e5bd1ee84..98a2ccdeb7 100644 --- a/example_packages/cpp_files/test/check.f90 +++ b/example_packages/cpp_files/test/check.f90 @@ -4,14 +4,14 @@ program check implicit none integer :: i, max_element - integer, parameter :: array(*) = [(i,i=-50,10)] - - max_element = intvec_maxval(array,size(array,1,c_size_t)) + integer, parameter :: array(*) = [(i, i=-50, 10)] + + max_element = intvec_maxval(array, size(array, 1, c_size_t)) if (max_element == maxval(array)) then - write(*,*) ' PASSED: Max element is ',max_element + write (*, *) ' PASSED: Max element is ', max_element else - write(*,*) ' (!) FAILED: Incorrect max element returned' + write (*, *) ' (!) FAILED: Incorrect max element returned' stop 1 end if diff --git a/example_packages/fortran_includes/inc/parameters.f90 b/example_packages/fortran_includes/inc/parameters.f90 index e9e1af507e..63db5bb3e4 100644 --- a/example_packages/fortran_includes/inc/parameters.f90 +++ b/example_packages/fortran_includes/inc/parameters.f90 @@ -1 +1 @@ -integer, parameter :: dp = kind(0.d0) \ No newline at end of file +integer, parameter :: dp = kind(0.d0) diff --git a/example_packages/fortran_includes/src/lib.f90 b/example_packages/fortran_includes/src/lib.f90 index a27a001e2a..5701c87ba1 100644 --- a/example_packages/fortran_includes/src/lib.f90 +++ b/example_packages/fortran_includes/src/lib.f90 @@ -3,12 +3,12 @@ module test_mod include "parameters.f90" - contains +contains subroutine test_sub(a) real(dp), intent(in) :: a - write(*,*) 'a: ', a + write (*, *) 'a: ', a end subroutine test_sub -end module test_mod \ No newline at end of file +end module test_mod diff --git a/example_packages/fpm_test_exe_issues/src/a/a_mod.f90 b/example_packages/fpm_test_exe_issues/src/a/a_mod.f90 index f5e27fbdad..af699633cc 100644 --- a/example_packages/fpm_test_exe_issues/src/a/a_mod.f90 +++ b/example_packages/fpm_test_exe_issues/src/a/a_mod.f90 @@ -1,10 +1,10 @@ module a_mod - use b_mod, only: hello_world + use b_mod, only: hello_world contains - subroutine a_mod_sub() - call hello_world() - end subroutine + subroutine a_mod_sub() + call hello_world() + end subroutine end module diff --git a/example_packages/fpm_test_exe_issues/src/b_mod.f90 b/example_packages/fpm_test_exe_issues/src/b_mod.f90 index beaa0807ed..45901be268 100644 --- a/example_packages/fpm_test_exe_issues/src/b_mod.f90 +++ b/example_packages/fpm_test_exe_issues/src/b_mod.f90 @@ -1,10 +1,10 @@ module b_mod - implicit none + implicit none contains - subroutine hello_world() - print *, "Hello world!" - end subroutine + subroutine hello_world() + print *, "Hello world!" + end subroutine end module diff --git a/example_packages/fpm_test_exe_issues/src/main.f90 b/example_packages/fpm_test_exe_issues/src/main.f90 index 9489932d0c..2f99946583 100644 --- a/example_packages/fpm_test_exe_issues/src/main.f90 +++ b/example_packages/fpm_test_exe_issues/src/main.f90 @@ -1,6 +1,6 @@ program main - use a_mod - implicit none + use a_mod + implicit none - call a_mod_sub() + call a_mod_sub() end program diff --git a/example_packages/hello_complex/apps/say_goodbye/say_goodbye.f90 b/example_packages/hello_complex/apps/say_goodbye/say_goodbye.f90 index 6966e790f6..cbef8f9351 100644 --- a/example_packages/hello_complex/apps/say_goodbye/say_goodbye.f90 +++ b/example_packages/hello_complex/apps/say_goodbye/say_goodbye.f90 @@ -1,7 +1,7 @@ program say_goodbye - use farewell_m, only: make_farewell + use farewell_m, only: make_farewell - implicit none + implicit none - print *, make_farewell("World") + print *, make_farewell("World") end program say_goodbye diff --git a/example_packages/hello_complex/apps/say_hello/say_Hello.f90 b/example_packages/hello_complex/apps/say_hello/say_Hello.f90 index cf4a7421d3..1db1ce662d 100644 --- a/example_packages/hello_complex/apps/say_hello/say_Hello.f90 +++ b/example_packages/hello_complex/apps/say_hello/say_Hello.f90 @@ -1,7 +1,7 @@ program say_Hello - use greet_m, only: make_greeting + use greet_m, only: make_greeting - implicit none + implicit none - print *, make_greeting("World") + print *, make_greeting("World") end program say_Hello diff --git a/example_packages/hello_complex/source/farewell_m.f90 b/example_packages/hello_complex/source/farewell_m.f90 index fbc45edf22..00d9c485d2 100644 --- a/example_packages/hello_complex/source/farewell_m.f90 +++ b/example_packages/hello_complex/source/farewell_m.f90 @@ -1,14 +1,14 @@ module farewell_m - use subdir_constants, only: FAREWELL_STR - implicit none - private + use subdir_constants, only: FAREWELL_STR + implicit none + private - public :: make_farewell + public :: make_farewell contains - function make_farewell(name) result(greeting) - character(len=*), intent(in) :: name - character(len=:), allocatable :: greeting + function make_farewell(name) result(greeting) + character(len=*), intent(in) :: name + character(len=:), allocatable :: greeting - greeting = FAREWELL_STR // name // "!" - end function make_farewell + greeting = FAREWELL_STR//name//"!" + end function make_farewell end module farewell_m diff --git a/example_packages/hello_complex/source/greet_m.f90 b/example_packages/hello_complex/source/greet_m.f90 index 38afd08352..05b77e43e0 100644 --- a/example_packages/hello_complex/source/greet_m.f90 +++ b/example_packages/hello_complex/source/greet_m.f90 @@ -1,14 +1,14 @@ module greet_m - use subdir_constants, only: GREET_STR - implicit none - private + use subdir_constants, only: GREET_STR + implicit none + private - public :: make_greeting + public :: make_greeting contains - function make_greeting(name) result(greeting) - character(len=*), intent(in) :: name - character(len=:), allocatable :: greeting + function make_greeting(name) result(greeting) + character(len=*), intent(in) :: name + character(len=:), allocatable :: greeting - greeting = GREET_STR // name // "!" - end function make_greeting + greeting = GREET_STR//name//"!" + end function make_greeting end module greet_m diff --git a/example_packages/hello_complex/source/subdir/constants.f90 b/example_packages/hello_complex/source/subdir/constants.f90 index 59d6e5fee6..2d2d8b201b 100644 --- a/example_packages/hello_complex/source/subdir/constants.f90 +++ b/example_packages/hello_complex/source/subdir/constants.f90 @@ -1,7 +1,7 @@ module subdir_constants -implicit none + implicit none -character(*), parameter :: GREET_STR = 'Hello, ' -character(*), parameter :: FAREWELL_STR = 'Goodbye, ' + character(*), parameter :: GREET_STR = 'Hello, ' + character(*), parameter :: FAREWELL_STR = 'Goodbye, ' end module subdir_constants diff --git a/example_packages/hello_complex/tests/farewell/farewell_test.f90 b/example_packages/hello_complex/tests/farewell/farewell_test.f90 index 0f21b18015..162153c139 100644 --- a/example_packages/hello_complex/tests/farewell/farewell_test.f90 +++ b/example_packages/hello_complex/tests/farewell/farewell_test.f90 @@ -1,18 +1,18 @@ program farewell_test - use farewell_m, only: make_farewell - use iso_fortran_env, only: error_unit, output_unit + use farewell_m, only: make_farewell + use iso_fortran_env, only: error_unit, output_unit - implicit none + implicit none - character(len=:), allocatable :: farewell + character(len=:), allocatable :: farewell - allocate(character(len=0) :: farewell) - farewell = make_farewell("World") + allocate (character(len=0) :: farewell) + farewell = make_farewell("World") - if (farewell == "Goodbye, World!") then - write(output_unit, *) "Passed" - else - write(error_unit, *) "Failed" - call exit(1) - end if + if (farewell == "Goodbye, World!") then + write (output_unit, *) "Passed" + else + write (error_unit, *) "Failed" + call exit(1) + end if end program farewell_test diff --git a/example_packages/hello_complex/tests/greet/greet_test.f90 b/example_packages/hello_complex/tests/greet/greet_test.f90 index 41fa50878e..07d28d9138 100644 --- a/example_packages/hello_complex/tests/greet/greet_test.f90 +++ b/example_packages/hello_complex/tests/greet/greet_test.f90 @@ -1,18 +1,18 @@ program greet_test - use greet_m, only: make_greeting - use iso_fortran_env, only: error_unit, output_unit + use greet_m, only: make_greeting + use iso_fortran_env, only: error_unit, output_unit - implicit none + implicit none - character(len=:), allocatable :: greeting + character(len=:), allocatable :: greeting - allocate(character(len=0) :: greeting) - greeting = make_greeting("World") + allocate (character(len=0) :: greeting) + greeting = make_greeting("World") - if (greeting == "Hello, World!") then - write(output_unit, *) "Passed" - else - write(error_unit, *) "Failed" - call exit(1) - end if + if (greeting == "Hello, World!") then + write (output_unit, *) "Passed" + else + write (error_unit, *) "Failed" + call exit(1) + end if end program greet_test diff --git a/example_packages/hello_complex_2/app/app_mod.f90 b/example_packages/hello_complex_2/app/app_mod.f90 index d69a228b6e..864fedede5 100644 --- a/example_packages/hello_complex_2/app/app_mod.f90 +++ b/example_packages/hello_complex_2/app/app_mod.f90 @@ -1,5 +1,4 @@ module app_mod -implicit none - + implicit none end module app_mod diff --git a/example_packages/hello_complex_2/app/say_goodbye.f90 b/example_packages/hello_complex_2/app/say_goodbye.f90 index db12cbf40e..b367bd9539 100644 --- a/example_packages/hello_complex_2/app/say_goodbye.f90 +++ b/example_packages/hello_complex_2/app/say_goodbye.f90 @@ -1,8 +1,8 @@ program say_goodbye - use farewell_m, only: make_farewell - use app_mod + use farewell_m, only: make_farewell + use app_mod - implicit none + implicit none - print *, make_farewell("World") + print *, make_farewell("World") end program say_goodbye diff --git a/example_packages/hello_complex_2/app/say_hello/app_extra_mod.f90 b/example_packages/hello_complex_2/app/say_hello/app_extra_mod.f90 index 5059e22f78..0e3a5933bc 100644 --- a/example_packages/hello_complex_2/app/say_hello/app_extra_mod.f90 +++ b/example_packages/hello_complex_2/app/say_hello/app_extra_mod.f90 @@ -1,6 +1,6 @@ module app_extra_mod -implicit none + implicit none -character(len=5) :: greet_object = "World" + character(len=5) :: greet_object = "World" end module app_extra_mod diff --git a/example_packages/hello_complex_2/app/say_hello/app_hello_mod.f90 b/example_packages/hello_complex_2/app/say_hello/app_hello_mod.f90 index e44edd7dd7..aa25a3eb6f 100644 --- a/example_packages/hello_complex_2/app/say_hello/app_hello_mod.f90 +++ b/example_packages/hello_complex_2/app/say_hello/app_hello_mod.f90 @@ -1,7 +1,7 @@ module app_hello_mod -use app_extra_mod, only: greet_object -implicit none + use app_extra_mod, only: greet_object + implicit none -integer :: hello_int = 42 + integer :: hello_int = 42 end module app_hello_mod diff --git a/example_packages/hello_complex_2/app/say_hello/say_Hello.f90 b/example_packages/hello_complex_2/app/say_hello/say_Hello.f90 index 3ebaebb5b4..df400e8206 100644 --- a/example_packages/hello_complex_2/app/say_hello/say_Hello.f90 +++ b/example_packages/hello_complex_2/app/say_hello/say_Hello.f90 @@ -1,8 +1,8 @@ program say_Hello - use greet_m, only: make_greeting - use app_hello_mod, only: greet_object + use greet_m, only: make_greeting + use app_hello_mod, only: greet_object - implicit none + implicit none - print *, make_greeting(greet_object) + print *, make_greeting(greet_object) end program say_Hello diff --git a/example_packages/hello_complex_2/src/farewell_m.f90 b/example_packages/hello_complex_2/src/farewell_m.f90 index 9fc75b9c23..152d0611be 100644 --- a/example_packages/hello_complex_2/src/farewell_m.f90 +++ b/example_packages/hello_complex_2/src/farewell_m.f90 @@ -1,13 +1,13 @@ module farewell_m - implicit none - private + implicit none + private - public :: make_farewell + public :: make_farewell contains - function make_farewell(name) result(greeting) - character(len=*), intent(in) :: name - character(len=:), allocatable :: greeting + function make_farewell(name) result(greeting) + character(len=*), intent(in) :: name + character(len=:), allocatable :: greeting - greeting = "Goodbye, " // name // "!" - end function make_farewell + greeting = "Goodbye, "//name//"!" + end function make_farewell end module farewell_m diff --git a/example_packages/hello_complex_2/src/greet_m.f90 b/example_packages/hello_complex_2/src/greet_m.f90 index 2372f9a446..2bb3506a4c 100644 --- a/example_packages/hello_complex_2/src/greet_m.f90 +++ b/example_packages/hello_complex_2/src/greet_m.f90 @@ -1,13 +1,13 @@ module greet_m - implicit none - private + implicit none + private - public :: make_greeting + public :: make_greeting contains - function make_greeting(name) result(greeting) - character(len=*), intent(in) :: name - character(len=:), allocatable :: greeting + function make_greeting(name) result(greeting) + character(len=*), intent(in) :: name + character(len=:), allocatable :: greeting - greeting = "Hello, " // name // "!" - end function make_greeting + greeting = "Hello, "//name//"!" + end function make_greeting end module greet_m diff --git a/example_packages/hello_complex_2/test/farewell_test.f90 b/example_packages/hello_complex_2/test/farewell_test.f90 index dbe98d6c2c..48e12dc7ba 100644 --- a/example_packages/hello_complex_2/test/farewell_test.f90 +++ b/example_packages/hello_complex_2/test/farewell_test.f90 @@ -1,19 +1,19 @@ program farewell_test - use farewell_m, only: make_farewell - use test_mod - use iso_fortran_env, only: error_unit, output_unit + use farewell_m, only: make_farewell + use test_mod + use iso_fortran_env, only: error_unit, output_unit - implicit none + implicit none - character(len=:), allocatable :: farewell + character(len=:), allocatable :: farewell - allocate(character(len=0) :: farewell) - farewell = make_farewell("World") + allocate (character(len=0) :: farewell) + farewell = make_farewell("World") - if (farewell == "Goodbye, World!") then - write(output_unit, *) "Passed" - else - write(error_unit, *) "Failed" - call exit(1) - end if + if (farewell == "Goodbye, World!") then + write (output_unit, *) "Passed" + else + write (error_unit, *) "Failed" + call exit(1) + end if end program farewell_test diff --git a/example_packages/hello_complex_2/test/greet_test.f90 b/example_packages/hello_complex_2/test/greet_test.f90 index 38e9be0710..8edeb82b3a 100644 --- a/example_packages/hello_complex_2/test/greet_test.f90 +++ b/example_packages/hello_complex_2/test/greet_test.f90 @@ -1,19 +1,19 @@ program greet_test - use greet_m, only: make_greeting - use test_mod - use iso_fortran_env, only: error_unit, output_unit + use greet_m, only: make_greeting + use test_mod + use iso_fortran_env, only: error_unit, output_unit - implicit none + implicit none - character(len=:), allocatable :: greeting + character(len=:), allocatable :: greeting - allocate(character(len=0) :: greeting) - greeting = make_greeting("World") + allocate (character(len=0) :: greeting) + greeting = make_greeting("World") - if (greeting == "Hello, World!") then - write(output_unit, *) "Passed" - else - write(error_unit, *) "Failed" - call exit(1) - end if + if (greeting == "Hello, World!") then + write (output_unit, *) "Passed" + else + write (error_unit, *) "Failed" + call exit(1) + end if end program greet_test diff --git a/example_packages/hello_complex_2/test/test_mod.f90 b/example_packages/hello_complex_2/test/test_mod.f90 index edb26263d0..e63f60e383 100644 --- a/example_packages/hello_complex_2/test/test_mod.f90 +++ b/example_packages/hello_complex_2/test/test_mod.f90 @@ -1,5 +1,4 @@ module test_mod -implicit none - + implicit none end module test_mod diff --git a/example_packages/hello_fpm/app/main.f90 b/example_packages/hello_fpm/app/main.f90 index 5df6d64636..19b01af3f0 100644 --- a/example_packages/hello_fpm/app/main.f90 +++ b/example_packages/hello_fpm/app/main.f90 @@ -1,9 +1,9 @@ program hello_fpm - use farewell_m, only: make_farewell - use greet_m, only: make_greeting + use farewell_m, only: make_farewell + use greet_m, only: make_greeting - implicit none + implicit none - print *, make_greeting("fpm") - print *, make_farewell("fpm") + print *, make_greeting("fpm") + print *, make_farewell("fpm") end program hello_fpm diff --git a/example_packages/hello_fpm_path/app/main.f90 b/example_packages/hello_fpm_path/app/main.f90 index 61303b1a69..05aa164aaf 100644 --- a/example_packages/hello_fpm_path/app/main.f90 +++ b/example_packages/hello_fpm_path/app/main.f90 @@ -1,10 +1,10 @@ program hello_fpm - use utils1_m, only: say_hello1 - use utils1_1_m, only: say_hello1_1 - use utils2_m, only: say_hello2 + use utils1_m, only: say_hello1 + use utils1_1_m, only: say_hello1_1 + use utils2_m, only: say_hello2 - call say_hello1() - call say_hello1_1() - call say_hello2() + call say_hello1() + call say_hello1_1() + call say_hello2() end program hello_fpm diff --git a/example_packages/hello_fpm_path/crate/utils1/src/say_hello.f90 b/example_packages/hello_fpm_path/crate/utils1/src/say_hello.f90 index dd7cdb881d..653eb4cde0 100644 --- a/example_packages/hello_fpm_path/crate/utils1/src/say_hello.f90 +++ b/example_packages/hello_fpm_path/crate/utils1/src/say_hello.f90 @@ -1,11 +1,11 @@ module utils1_m - implicit none - + implicit none + contains - - subroutine say_hello1() - print '(a)', "Hello, utils1." - end subroutine say_hello1 + + subroutine say_hello1() + print '(a)', "Hello, utils1." + end subroutine say_hello1 end module utils1_m diff --git a/example_packages/hello_fpm_path/crate/utils1_1/src/say_hello.f90 b/example_packages/hello_fpm_path/crate/utils1_1/src/say_hello.f90 index 59ce519457..0113bf2b64 100644 --- a/example_packages/hello_fpm_path/crate/utils1_1/src/say_hello.f90 +++ b/example_packages/hello_fpm_path/crate/utils1_1/src/say_hello.f90 @@ -1,11 +1,11 @@ module utils1_1_m - implicit none - + implicit none + contains - - subroutine say_hello1_1() - print '(a)', "Hello, utils1_1." - end subroutine say_hello1_1 + + subroutine say_hello1_1() + print '(a)', "Hello, utils1_1." + end subroutine say_hello1_1 end module utils1_1_m diff --git a/example_packages/hello_fpm_path/crate/utils2/src/say_hello.f90 b/example_packages/hello_fpm_path/crate/utils2/src/say_hello.f90 index 19772fc2b3..00a37ecbb3 100644 --- a/example_packages/hello_fpm_path/crate/utils2/src/say_hello.f90 +++ b/example_packages/hello_fpm_path/crate/utils2/src/say_hello.f90 @@ -1,11 +1,11 @@ module utils2_m - implicit none - + implicit none + contains - - subroutine say_hello2() - print '(a)', "Hello, utils2." - end subroutine say_hello2 + + subroutine say_hello2() + print '(a)', "Hello, utils2." + end subroutine say_hello2 end module utils2_m diff --git a/example_packages/hello_world/app/main.f90 b/example_packages/hello_world/app/main.f90 index d16022bcc8..f68ebc4996 100644 --- a/example_packages/hello_world/app/main.f90 +++ b/example_packages/hello_world/app/main.f90 @@ -1,3 +1,3 @@ program hello_world - print *, "Hello, World!" + print *, "Hello, World!" end program hello_world diff --git a/example_packages/link_external/app/main.f90 b/example_packages/link_external/app/main.f90 index 8df408d010..b88597fcee 100644 --- a/example_packages/link_external/app/main.f90 +++ b/example_packages/link_external/app/main.f90 @@ -1,21 +1,21 @@ program test_blas - use wrapped_gemv, only : sp, gemv - implicit none + use wrapped_gemv, only: sp, gemv + implicit none - integer :: i, j - real(sp) :: mat(4, 4), vec(4), res(4) + integer :: i, j + real(sp) :: mat(4, 4), vec(4), res(4) - do i = 1, size(vec) - vec(i) = sqrt(real(i, sp)) - end do + do i = 1, size(vec) + vec(i) = sqrt(real(i, sp)) + end do - do i = 1, size(mat, 2) - do j = 1, size(mat, 1) - mat(j, i) = sqrt(real(j * i, sp)) - end do - end do + do i = 1, size(mat, 2) + do j = 1, size(mat, 1) + mat(j, i) = sqrt(real(j*i, sp)) + end do + end do - call gemv(mat, vec, res, alpha=-1.0_sp, trans='t') + call gemv(mat, vec, res, alpha=-1.0_sp, trans='t') end program test_blas diff --git a/example_packages/link_external/src/wrapped_gemv.f90 b/example_packages/link_external/src/wrapped_gemv.f90 index 5ff1d7c152..42cd3edc60 100644 --- a/example_packages/link_external/src/wrapped_gemv.f90 +++ b/example_packages/link_external/src/wrapped_gemv.f90 @@ -13,13 +13,11 @@ module wrapped_gemv integer, parameter :: sp = selected_real_kind(6) integer, parameter :: dp = selected_real_kind(15) - interface gemv module procedure :: wrap_sgemv module procedure :: wrap_dgemv end interface gemv - interface blas_gemv subroutine sgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy) import :: sp @@ -51,10 +49,8 @@ subroutine dgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy) end subroutine dgemv end interface blas_gemv - contains - subroutine wrap_sgemv(amat, xvec, yvec, alpha, beta, trans) real(sp), intent(in) :: amat(:, :) real(sp), intent(in) :: xvec(:) @@ -88,7 +84,6 @@ subroutine wrap_sgemv(amat, xvec, yvec, alpha, beta, trans) call blas_gemv(tra, m, n, a, amat, lda, xvec, incx, b, yvec, incy) end subroutine wrap_sgemv - subroutine wrap_dgemv(amat, xvec, yvec, alpha, beta, trans) real(dp), intent(in) :: amat(:, :) real(dp), intent(in) :: xvec(:) @@ -122,5 +117,4 @@ subroutine wrap_dgemv(amat, xvec, yvec, alpha, beta, trans) call blas_gemv(tra, m, n, a, amat, lda, xvec, incx, b, yvec, incy) end subroutine wrap_dgemv - end module wrapped_gemv diff --git a/example_packages/makefile_complex/app/main.f90 b/example_packages/makefile_complex/app/main.f90 index ac9ed51d03..d5d67ea207 100644 --- a/example_packages/makefile_complex/app/main.f90 +++ b/example_packages/makefile_complex/app/main.f90 @@ -1,7 +1,7 @@ program makefile_complex - use wrapper_mod, only: do_stuff + use wrapper_mod, only: do_stuff - implicit none + implicit none - call do_stuff + call do_stuff end program makefile_complex diff --git a/example_packages/makefile_complex/src/wrapper_mod.f90 b/example_packages/makefile_complex/src/wrapper_mod.f90 index e8028b5d2f..56c5cb685b 100644 --- a/example_packages/makefile_complex/src/wrapper_mod.f90 +++ b/example_packages/makefile_complex/src/wrapper_mod.f90 @@ -1,12 +1,12 @@ module wrapper_mod - use hello_makefile, only: say_hello_from_makefile + use hello_makefile, only: say_hello_from_makefile - implicit none - private + implicit none + private - public :: do_stuff + public :: do_stuff contains - subroutine do_stuff - call say_hello_from_makefile - end subroutine do_stuff + subroutine do_stuff + call say_hello_from_makefile + end subroutine do_stuff end module wrapper_mod diff --git a/example_packages/preprocess_cpp/src/preprocess_cpp.f90 b/example_packages/preprocess_cpp/src/preprocess_cpp.f90 index d7ab5d1485..dc1d008e87 100644 --- a/example_packages/preprocess_cpp/src/preprocess_cpp.f90 +++ b/example_packages/preprocess_cpp/src/preprocess_cpp.f90 @@ -1,22 +1,22 @@ module preprocess_cpp - implicit none - private + implicit none + private - public :: say_hello + public :: say_hello contains - subroutine say_hello - print *, "Hello, preprocess_cpp!" + subroutine say_hello + print *, "Hello, preprocess_cpp!" #ifndef TESTMACRO - This breaks the build. + This breaks the build. #endif #if TESTMACRO2 != 3 - This breaks the build. + This breaks the build. #endif #if TESTMACRO3 != 1 - This breaks the build. + This breaks the build. #endif - end subroutine say_hello + end subroutine say_hello end module preprocess_cpp diff --git a/example_packages/preprocess_cpp_deps/app/main.f90 b/example_packages/preprocess_cpp_deps/app/main.f90 index adf5eee6bf..d65a538cc6 100644 --- a/example_packages/preprocess_cpp_deps/app/main.f90 +++ b/example_packages/preprocess_cpp_deps/app/main.f90 @@ -1,6 +1,6 @@ program hello_fpm - use utils, only: say_hello + use utils, only: say_hello - call say_hello() + call say_hello() end program hello_fpm diff --git a/example_packages/preprocess_cpp_deps/crate/utils/src/say_hello.f90 b/example_packages/preprocess_cpp_deps/crate/utils/src/say_hello.f90 index c5fc9f04f5..4738bb0d32 100644 --- a/example_packages/preprocess_cpp_deps/crate/utils/src/say_hello.f90 +++ b/example_packages/preprocess_cpp_deps/crate/utils/src/say_hello.f90 @@ -1,11 +1,11 @@ module utils - implicit none - + implicit none + contains - subroutine say_hello() - print '(a,1x,i0)', "Hello, X =", X - end subroutine say_hello + subroutine say_hello() + print '(a,1x,i0)', "Hello, X =", X + end subroutine say_hello end module utils diff --git a/example_packages/preprocess_hello/app/main.f90 b/example_packages/preprocess_hello/app/main.f90 index f08a5d979c..dff116c92f 100644 --- a/example_packages/preprocess_hello/app/main.f90 +++ b/example_packages/preprocess_hello/app/main.f90 @@ -1,6 +1,6 @@ program preprocess_hello - use preprocess_hello_dependency, only: say_hello + use preprocess_hello_dependency, only: say_hello - implicit none - call say_hello() + implicit none + call say_hello() end program preprocess_hello diff --git a/example_packages/preprocess_hello_dependency/src/preprocess_hello_dependency.f90 b/example_packages/preprocess_hello_dependency/src/preprocess_hello_dependency.f90 index 14b1e8708d..5516b3532d 100644 --- a/example_packages/preprocess_hello_dependency/src/preprocess_hello_dependency.f90 +++ b/example_packages/preprocess_hello_dependency/src/preprocess_hello_dependency.f90 @@ -8,7 +8,7 @@ subroutine say_hello !> If this build fails, then it implies that macros are getting passed to the dependency. #ifdef FOO - This breaks the build inside dependency. This implies that macros are getting passed to the dependeny. + This breaks the build inside dependency.This implies that macros are getting passed to the dependeny. #endif print *, "Hello, preprocess_hello_dependency!" end subroutine say_hello diff --git a/example_packages/program_with_module/app/main.f90 b/example_packages/program_with_module/app/main.f90 index 59441f0423..1ab788a3ac 100644 --- a/example_packages/program_with_module/app/main.f90 +++ b/example_packages/program_with_module/app/main.f90 @@ -1,6 +1,6 @@ module greet_m implicit none - character(*), parameter :: greeting = 'Hello, fpm!' + character(*), parameter :: greeting = 'Hello, fpm!' end module greet_m program program_with_module diff --git a/example_packages/submodule_tree_shake/app/main.f90 b/example_packages/submodule_tree_shake/app/main.f90 index 4bbd2f8c48..3aee73a0e3 100644 --- a/example_packages/submodule_tree_shake/app/main.f90 +++ b/example_packages/submodule_tree_shake/app/main.f90 @@ -1,9 +1,9 @@ -program test -use parent - -integer :: a, b - -call my_sub1(a) -call my_sub2(b) - -end program test \ No newline at end of file +program test + use parent + + integer :: a, b + + call my_sub1(a) + call my_sub2(b) + +end program test diff --git a/example_packages/submodule_tree_shake/src/child1.f90 b/example_packages/submodule_tree_shake/src/child1.f90 index 8f0c97247f..1bfbe46951 100644 --- a/example_packages/submodule_tree_shake/src/child1.f90 +++ b/example_packages/submodule_tree_shake/src/child1.f90 @@ -1,16 +1,16 @@ submodule(parent) child1 -implicit none + implicit none -interface - module function my_fun() result (b) - integer :: b + interface + module function my_fun() result(b) + integer :: b end function my_fun -end interface + end interface contains -module procedure my_sub1 - a = my_fun() -end procedure my_sub1 + module procedure my_sub1 + a = my_fun() + end procedure my_sub1 -end submodule child1 \ No newline at end of file +end submodule child1 diff --git a/example_packages/submodule_tree_shake/src/child2.f90 b/example_packages/submodule_tree_shake/src/child2.f90 index 179cc3209a..4e2e8d84b9 100644 --- a/example_packages/submodule_tree_shake/src/child2.f90 +++ b/example_packages/submodule_tree_shake/src/child2.f90 @@ -1,10 +1,10 @@ submodule(parent) child2 -implicit none + implicit none contains -module procedure my_sub2 - a = 2 -end procedure my_sub2 + module procedure my_sub2 + a = 2 + end procedure my_sub2 -end submodule child2 \ No newline at end of file +end submodule child2 diff --git a/example_packages/submodule_tree_shake/src/child_unused.f90 b/example_packages/submodule_tree_shake/src/child_unused.f90 index 2f5a45ff65..656da88094 100644 --- a/example_packages/submodule_tree_shake/src/child_unused.f90 +++ b/example_packages/submodule_tree_shake/src/child_unused.f90 @@ -1,10 +1,10 @@ submodule(parent_unused) child_unused -implicit none + implicit none contains -module procedure unused_sub - a = 1 -end procedure unused_sub + module procedure unused_sub + a = 1 + end procedure unused_sub -end submodule child_unused \ No newline at end of file +end submodule child_unused diff --git a/example_packages/submodule_tree_shake/src/grandchild.f90 b/example_packages/submodule_tree_shake/src/grandchild.f90 index 8c5aa17708..aaa4bf2b07 100644 --- a/example_packages/submodule_tree_shake/src/grandchild.f90 +++ b/example_packages/submodule_tree_shake/src/grandchild.f90 @@ -4,7 +4,7 @@ contains module procedure my_fun - b = 2 +b = 2 end procedure my_fun -end submodule grandchild \ No newline at end of file +end submodule grandchild diff --git a/example_packages/submodule_tree_shake/src/parent.f90 b/example_packages/submodule_tree_shake/src/parent.f90 index 570827cd06..7f3a1ffe57 100644 --- a/example_packages/submodule_tree_shake/src/parent.f90 +++ b/example_packages/submodule_tree_shake/src/parent.f90 @@ -1,15 +1,15 @@ module parent -implicit none + implicit none -interface + interface module subroutine my_sub1(a) - integer, intent(out) :: a + integer, intent(out) :: a end subroutine my_sub1 module subroutine my_sub2(a) - integer, intent(out) :: a + integer, intent(out) :: a end subroutine my_sub2 -end interface + end interface -end module parent \ No newline at end of file +end module parent diff --git a/example_packages/submodule_tree_shake/src/parent_unused.f90 b/example_packages/submodule_tree_shake/src/parent_unused.f90 index 73ceb24c8f..8640f635c0 100644 --- a/example_packages/submodule_tree_shake/src/parent_unused.f90 +++ b/example_packages/submodule_tree_shake/src/parent_unused.f90 @@ -1,12 +1,12 @@ module parent_unused -implicit none + implicit none -interface + interface module subroutine unused_sub(a) - integer, intent(out) :: a + integer, intent(out) :: a end subroutine unused_sub - -end interface -end module parent_unused \ No newline at end of file + end interface + +end module parent_unused diff --git a/example_packages/submodules/src/child1.f90 b/example_packages/submodules/src/child1.f90 index dbd0fa5395..59813bf451 100644 --- a/example_packages/submodules/src/child1.f90 +++ b/example_packages/submodules/src/child1.f90 @@ -1,16 +1,16 @@ submodule(parent) child1 -implicit none + implicit none -interface - module function my_fun() result (b) - integer :: b + interface + module function my_fun() result(b) + integer :: b end function my_fun -end interface + end interface contains -module procedure my_sub1 - a = 1 -end procedure my_sub1 + module procedure my_sub1 + a = 1 + end procedure my_sub1 -end submodule child1 \ No newline at end of file +end submodule child1 diff --git a/example_packages/submodules/src/child2.f90 b/example_packages/submodules/src/child2.f90 index 179cc3209a..4e2e8d84b9 100644 --- a/example_packages/submodules/src/child2.f90 +++ b/example_packages/submodules/src/child2.f90 @@ -1,10 +1,10 @@ submodule(parent) child2 -implicit none + implicit none contains -module procedure my_sub2 - a = 2 -end procedure my_sub2 + module procedure my_sub2 + a = 2 + end procedure my_sub2 -end submodule child2 \ No newline at end of file +end submodule child2 diff --git a/example_packages/submodules/src/grandchild.f90 b/example_packages/submodules/src/grandchild.f90 index 8c5aa17708..aaa4bf2b07 100644 --- a/example_packages/submodules/src/grandchild.f90 +++ b/example_packages/submodules/src/grandchild.f90 @@ -4,7 +4,7 @@ contains module procedure my_fun - b = 2 +b = 2 end procedure my_fun -end submodule grandchild \ No newline at end of file +end submodule grandchild diff --git a/example_packages/submodules/src/parent.f90 b/example_packages/submodules/src/parent.f90 index 570827cd06..7f3a1ffe57 100644 --- a/example_packages/submodules/src/parent.f90 +++ b/example_packages/submodules/src/parent.f90 @@ -1,15 +1,15 @@ module parent -implicit none + implicit none -interface + interface module subroutine my_sub1(a) - integer, intent(out) :: a + integer, intent(out) :: a end subroutine my_sub1 module subroutine my_sub2(a) - integer, intent(out) :: a + integer, intent(out) :: a end subroutine my_sub2 -end interface + end interface -end module parent \ No newline at end of file +end module parent diff --git a/example_packages/tree_shake/app/say_Hello.f90 b/example_packages/tree_shake/app/say_Hello.f90 index f620dc2aa5..ca3313668d 100644 --- a/example_packages/tree_shake/app/say_Hello.f90 +++ b/example_packages/tree_shake/app/say_Hello.f90 @@ -1,15 +1,15 @@ program say_Hello - use greet_m, only: make_greeting + use greet_m, only: make_greeting - implicit none + implicit none - interface - function external_function() result(i) - integer :: i - end function external_function - end interface + interface + function external_function() result(i) + integer :: i + end function external_function + end interface - print *, make_greeting("World") - print *, external_function() + print *, make_greeting("World") + print *, external_function() end program say_Hello diff --git a/example_packages/tree_shake/src/extra_m.f90 b/example_packages/tree_shake/src/extra_m.f90 index 772fe6b789..14fa1bbb07 100644 --- a/example_packages/tree_shake/src/extra_m.f90 +++ b/example_packages/tree_shake/src/extra_m.f90 @@ -1,15 +1,15 @@ -! This module is not used by any other sources, +! This module is not used by any other sources, ! however because it also contains an external function -! it cannot be dropped during tree-shaking/pruning +! it cannot be dropped during tree-shaking/pruning module extra_m - use subdir_constants, only: FAREWELL_STR - implicit none - private + use subdir_constants, only: FAREWELL_STR + implicit none + private - integer, parameter :: m = 0 + integer, parameter :: m = 0 end function external_function() result(i) - integer :: i - i = 1 -end function external_function \ No newline at end of file + integer :: i + i = 1 +end function external_function diff --git a/example_packages/tree_shake/src/farewell_m.f90 b/example_packages/tree_shake/src/farewell_m.f90 index 5a48ffffb9..096b0e4dbf 100644 --- a/example_packages/tree_shake/src/farewell_m.f90 +++ b/example_packages/tree_shake/src/farewell_m.f90 @@ -2,16 +2,16 @@ ! and only contains a module (no non-module subprograms), ! therefore it should be dropped during tree-shaking/pruning module farewell_m - use subdir_constants, only: FAREWELL_STR - implicit none - private + use subdir_constants, only: FAREWELL_STR + implicit none + private - public :: make_farewell + public :: make_farewell contains - function make_farewell(name) result(greeting) - character(len=*), intent(in) :: name - character(len=:), allocatable :: greeting + function make_farewell(name) result(greeting) + character(len=*), intent(in) :: name + character(len=:), allocatable :: greeting - greeting = FAREWELL_STR // name // "!" - end function make_farewell + greeting = FAREWELL_STR//name//"!" + end function make_farewell end module farewell_m diff --git a/example_packages/tree_shake/src/greet_m.f90 b/example_packages/tree_shake/src/greet_m.f90 index c2992e744e..46ddcc7c7b 100644 --- a/example_packages/tree_shake/src/greet_m.f90 +++ b/example_packages/tree_shake/src/greet_m.f90 @@ -1,16 +1,16 @@ ! This module is directly by the executables and ! hence should not be dropped during tree-shaking/pruning module greet_m - use subdir_constants, only: GREET_STR - implicit none - private + use subdir_constants, only: GREET_STR + implicit none + private - public :: make_greeting + public :: make_greeting contains - function make_greeting(name) result(greeting) - character(len=*), intent(in) :: name - character(len=:), allocatable :: greeting + function make_greeting(name) result(greeting) + character(len=*), intent(in) :: name + character(len=:), allocatable :: greeting - greeting = GREET_STR // name // "!" - end function make_greeting + greeting = GREET_STR//name//"!" + end function make_greeting end module greet_m diff --git a/example_packages/tree_shake/src/subdir/constants.f90 b/example_packages/tree_shake/src/subdir/constants.f90 index d34307bd00..904dc189ba 100644 --- a/example_packages/tree_shake/src/subdir/constants.f90 +++ b/example_packages/tree_shake/src/subdir/constants.f90 @@ -1,9 +1,9 @@ ! This module is used indirectly by the executables ! and hence should not be dropped during tree-shaking/pruning module subdir_constants -implicit none + implicit none -character(*), parameter :: GREET_STR = 'Hello, ' -character(*), parameter :: FAREWELL_STR = 'Goodbye, ' + character(*), parameter :: GREET_STR = 'Hello, ' + character(*), parameter :: FAREWELL_STR = 'Goodbye, ' end module subdir_constants diff --git a/example_packages/tree_shake/test/greet_test.f90 b/example_packages/tree_shake/test/greet_test.f90 index 41fa50878e..07d28d9138 100644 --- a/example_packages/tree_shake/test/greet_test.f90 +++ b/example_packages/tree_shake/test/greet_test.f90 @@ -1,18 +1,18 @@ program greet_test - use greet_m, only: make_greeting - use iso_fortran_env, only: error_unit, output_unit + use greet_m, only: make_greeting + use iso_fortran_env, only: error_unit, output_unit - implicit none + implicit none - character(len=:), allocatable :: greeting + character(len=:), allocatable :: greeting - allocate(character(len=0) :: greeting) - greeting = make_greeting("World") + allocate (character(len=0) :: greeting) + greeting = make_greeting("World") - if (greeting == "Hello, World!") then - write(output_unit, *) "Passed" - else - write(error_unit, *) "Failed" - call exit(1) - end if + if (greeting == "Hello, World!") then + write (output_unit, *) "Passed" + else + write (error_unit, *) "Failed" + call exit(1) + end if end program greet_test diff --git a/example_packages/version_file/app/main.f90 b/example_packages/version_file/app/main.f90 index fcf8d64ffd..d40bd644f0 100644 --- a/example_packages/version_file/app/main.f90 +++ b/example_packages/version_file/app/main.f90 @@ -3,11 +3,11 @@ program stub logical :: exists integer :: unit character(len=100) :: line - inquire(file="VERSION", exist=exists) - if (.not.exists) error stop "File VERSION does not exist." - open(file="VERSION", newunit=unit) - read(unit, '(a)') line - close(unit) + inquire (file="VERSION", exist=exists) + if (.not. exists) error stop "File VERSION does not exist." + open (file="VERSION", newunit=unit) + read (unit, '(a)') line + close (unit) print '(*(a))', "File VERSION contains '", trim(line), "'" end program stub diff --git a/example_packages/with_c/app/main.f90 b/example_packages/with_c/app/main.f90 index 4d3174b61e..e644f8b2ff 100644 --- a/example_packages/with_c/app/main.f90 +++ b/example_packages/with_c/app/main.f90 @@ -1,10 +1,10 @@ program with_c_app -use with_c -implicit none + use with_c + implicit none -write(*,*) "isdir('app') = ", system_isdir('app') -write(*,*) "isdir('src') = ", system_isdir('src') -write(*,*) "isdir('test') = ", system_isdir('test') -write(*,*) "isdir('bench') = ", system_isdir('bench') + write (*, *) "isdir('app') = ", system_isdir('app') + write (*, *) "isdir('src') = ", system_isdir('src') + write (*, *) "isdir('test') = ", system_isdir('test') + write (*, *) "isdir('bench') = ", system_isdir('bench') -end program with_c_app \ No newline at end of file +end program with_c_app diff --git a/example_packages/with_c/src/with_c.f90 b/example_packages/with_c/src/with_c.f90 index edd839e3c4..e4fec03a3c 100644 --- a/example_packages/with_c/src/with_c.f90 +++ b/example_packages/with_c/src/with_c.f90 @@ -1,26 +1,26 @@ module with_c - use iso_c_binding, only: c_char, c_int, c_null_char - implicit none + use iso_c_binding, only: c_char, c_int, c_null_char + implicit none contains - function system_isdir(dirname) - ! Source (Public domain): https://github.com/urbanjost/M_system - ! - implicit none - character(len=*),intent(in) :: dirname - logical :: system_isdir - - interface - function c_isdir(dirname) bind (C,name="my_isdir") result (c_ierr) - import c_char,c_int - character(kind=c_char,len=1),intent(in) :: dirname(*) - integer(kind=c_int) :: c_ierr - end function c_isdir - end interface - - system_isdir= c_isdir(trim(dirname)//c_null_char) == 1 - - end function system_isdir + function system_isdir(dirname) + ! Source (Public domain): https://github.com/urbanjost/M_system + ! + implicit none + character(len=*), intent(in) :: dirname + logical :: system_isdir + + interface + function c_isdir(dirname) bind(C, name="my_isdir") result(c_ierr) + import c_char, c_int + character(kind=c_char, len=1), intent(in) :: dirname(*) + integer(kind=c_int) :: c_ierr + end function c_isdir + end interface + + system_isdir = c_isdir(trim(dirname)//c_null_char) == 1 + + end function system_isdir -end module with_c \ No newline at end of file +end module with_c diff --git a/example_packages/with_examples/app/demo-prog.f90 b/example_packages/with_examples/app/demo-prog.f90 index f26e898fc8..2a86422fad 100644 --- a/example_packages/with_examples/app/demo-prog.f90 +++ b/example_packages/with_examples/app/demo-prog.f90 @@ -1,3 +1,3 @@ program demo - write(*, '(a)') "This is a simple program" + write (*, '(a)') "This is a simple program" end program demo diff --git a/example_packages/with_examples/demo/prog.f90 b/example_packages/with_examples/demo/prog.f90 index 8b3d8821b0..b89ad28498 100644 --- a/example_packages/with_examples/demo/prog.f90 +++ b/example_packages/with_examples/demo/prog.f90 @@ -1,3 +1,3 @@ program demo - write(*, '(a)') "This is a simple demo program, but not a real application" + write (*, '(a)') "This is a simple demo program, but not a real application" end program demo diff --git a/example_packages/with_makefile/src/hello_makefile.f90 b/example_packages/with_makefile/src/hello_makefile.f90 index 2d4d1a2fa0..1ed39879c6 100644 --- a/example_packages/with_makefile/src/hello_makefile.f90 +++ b/example_packages/with_makefile/src/hello_makefile.f90 @@ -1,10 +1,10 @@ module hello_makefile - implicit none - private + implicit none + private - public :: say_hello_from_makefile + public :: say_hello_from_makefile contains - subroutine say_hello_from_makefile() - print *, "Hello from Makefile library!" - end subroutine say_hello_from_makefile + subroutine say_hello_from_makefile() + print *, "Hello from Makefile library!" + end subroutine say_hello_from_makefile end module hello_makefile diff --git a/src/fpm.f90 b/src/fpm.f90 index b9c0d2a874..a3e617cfb5 100644 --- a/src/fpm.f90 +++ b/src/fpm.f90 @@ -1,39 +1,37 @@ module fpm -use fpm_strings, only: string_t, operator(.in.), glob, join, string_cat, & - lower, str_ends_with -use fpm_backend, only: build_package -use fpm_command_line, only: fpm_build_settings, fpm_new_settings, & - fpm_run_settings, fpm_install_settings, fpm_test_settings, & - fpm_clean_settings -use fpm_dependency, only : new_dependency_tree -use fpm_environment, only: get_env -use fpm_filesystem, only: is_dir, join_path, list_files, exists, & - basename, filewrite, mkdir, run, os_delete_dir -use fpm_model, only: fpm_model_t, srcfile_t, show_model, & - FPM_SCOPE_UNKNOWN, FPM_SCOPE_LIB, FPM_SCOPE_DEP, & - FPM_SCOPE_APP, FPM_SCOPE_EXAMPLE, FPM_SCOPE_TEST -use fpm_compiler, only: new_compiler, new_archiver, set_cpp_preprocessor_flags - - -use fpm_sources, only: add_executable_sources, add_sources_from_dir -use fpm_targets, only: targets_from_sources, & - resolve_target_linking, build_target_t, build_target_ptr, & - FPM_TARGET_EXECUTABLE, FPM_TARGET_ARCHIVE -use fpm_manifest, only : get_package_data, package_config_t -use fpm_error, only : error_t, fatal_error, fpm_stop -use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, & - & stdout=>output_unit, & - & stderr=>error_unit -use iso_c_binding, only: c_char, c_ptr, c_int, c_null_char, c_associated, c_f_pointer -implicit none -private -public :: cmd_build, cmd_run, cmd_clean -public :: build_model, check_modules_for_duplicates + use fpm_strings, only: string_t, operator(.in.), glob, join, string_cat, & + lower, str_ends_with + use fpm_backend, only: build_package + use fpm_command_line, only: fpm_build_settings, fpm_new_settings, & + fpm_run_settings, fpm_install_settings, fpm_test_settings, & + fpm_clean_settings + use fpm_dependency, only: new_dependency_tree + use fpm_environment, only: get_env + use fpm_filesystem, only: is_dir, join_path, list_files, exists, & + basename, filewrite, mkdir, run, os_delete_dir + use fpm_model, only: fpm_model_t, srcfile_t, show_model, & + FPM_SCOPE_UNKNOWN, FPM_SCOPE_LIB, FPM_SCOPE_DEP, & + FPM_SCOPE_APP, FPM_SCOPE_EXAMPLE, FPM_SCOPE_TEST + use fpm_compiler, only: new_compiler, new_archiver, set_cpp_preprocessor_flags + + use fpm_sources, only: add_executable_sources, add_sources_from_dir + use fpm_targets, only: targets_from_sources, & + resolve_target_linking, build_target_t, build_target_ptr, & + FPM_TARGET_EXECUTABLE, FPM_TARGET_ARCHIVE + use fpm_manifest, only: get_package_data, package_config_t + use fpm_error, only: error_t, fatal_error, fpm_stop + use, intrinsic :: iso_fortran_env, only: stdin => input_unit, & + & stdout => output_unit, & + & stderr => error_unit + use iso_c_binding, only: c_char, c_ptr, c_int, c_null_char, c_associated, c_f_pointer + implicit none + private + public :: cmd_build, cmd_run, cmd_clean + public :: build_model, check_modules_for_duplicates contains - -subroutine build_model(model, settings, package, error) + subroutine build_model(model, settings, package, error) ! Constructs a valid fpm model from command line settings and toml manifest ! type(fpm_model_t), intent(out) :: model @@ -52,17 +50,17 @@ subroutine build_model(model, settings, package, error) model%package_name = package%name - allocate(model%include_dirs(0)) - allocate(model%link_libraries(0)) - allocate(model%external_modules(0)) + allocate (model%include_dirs(0)) + allocate (model%link_libraries(0)) + allocate (model%external_modules(0)) call new_dependency_tree(model%deps, cache=join_path("build", "cache.toml")) call model%deps%add(package, error) if (allocated(error)) return ! build/ directory should now exist - if (.not.exists("build/.gitignore")) then - call filewrite(join_path("build", ".gitignore"),["*"]) + if (.not. exists("build/.gitignore")) then + call filewrite(join_path("build", ".gitignore"), ["*"]) end if call new_compiler(model%compiler, settings%compiler, settings%c_compiler, & @@ -71,13 +69,13 @@ subroutine build_model(model, settings, package, error) & echo=settings%verbose, verbose=settings%verbose) if (settings%flag == '') then - flags = model%compiler%get_default_flags(settings%profile == "release") + flags = model%compiler%get_default_flags(settings%profile == "release") else - flags = settings%flag - select case(settings%profile) - case("release", "debug") - flags = flags // model%compiler%get_default_flags(settings%profile == "release") - end select + flags = settings%flag + select case (settings%profile) + case ("release", "debug") + flags = flags//model%compiler%get_default_flags(settings%profile == "release") + end select end if cflags = trim(settings%cflag) @@ -85,75 +83,75 @@ subroutine build_model(model, settings, package, error) ldflags = trim(settings%ldflag) if (model%compiler%is_unknown()) then - write(*, '(*(a:,1x))') & - "", "Unknown compiler", model%compiler%fc, "requested!", & - "Defaults for this compiler might be incorrect" + write (*, '(*(a:,1x))') & + "", "Unknown compiler", model%compiler%fc, "requested!", & + "Defaults for this compiler might be incorrect" end if model%build_prefix = join_path("build", basename(model%compiler%fc)) model%include_tests = settings%build_tests - allocate(model%packages(model%deps%ndep)) + allocate (model%packages(model%deps%ndep)) has_cpp = .false. do i = 1, model%deps%ndep - associate(dep => model%deps%dep(i)) - manifest = join_path(dep%proj_dir, "fpm.toml") - - call get_package_data(dependency, manifest, error, & - apply_defaults=.true.) - if (allocated(error)) exit - - model%packages(i)%name = dependency%name - call package%version%to_string(version) - model%packages(i)%version = version - - if (allocated(dependency%preprocess)) then - do j = 1, size(dependency%preprocess) - if (dependency%preprocess(j)%name == "cpp") then - if (.not. has_cpp) has_cpp = .true. - if (allocated(dependency%preprocess(j)%macros)) then - model%packages(i)%macros = dependency%preprocess(j)%macros - end if - else - write(stderr, '(a)') 'Warning: Preprocessor ' // package%preprocess(i)%name // & - ' is not supported; will ignore it' - end if - end do + associate (dep => model%deps%dep(i)) + manifest = join_path(dep%proj_dir, "fpm.toml") + + call get_package_data(dependency, manifest, error, & + apply_defaults=.true.) + if (allocated(error)) exit + + model%packages(i)%name = dependency%name + call package%version%to_string(version) + model%packages(i)%version = version + + if (allocated(dependency%preprocess)) then + do j = 1, size(dependency%preprocess) + if (dependency%preprocess(j)%name == "cpp") then + if (.not. has_cpp) has_cpp = .true. + if (allocated(dependency%preprocess(j)%macros)) then + model%packages(i)%macros = dependency%preprocess(j)%macros + end if + else + write (stderr, '(a)') 'Warning: Preprocessor '//package%preprocess(i)%name// & + ' is not supported; will ignore it' end if + end do + end if - if (.not.allocated(model%packages(i)%sources)) allocate(model%packages(i)%sources(0)) - - if (allocated(dependency%library)) then - - if (allocated(dependency%library%source_dir)) then - lib_dir = join_path(dep%proj_dir, dependency%library%source_dir) - if (is_dir(lib_dir)) then - call add_sources_from_dir(model%packages(i)%sources, lib_dir, FPM_SCOPE_LIB, & - error=error) - if (allocated(error)) exit - end if - end if + if (.not. allocated(model%packages(i)%sources)) allocate (model%packages(i)%sources(0)) - if (allocated(dependency%library%include_dir)) then - do j=1,size(dependency%library%include_dir) - include_dir%s = join_path(dep%proj_dir, dependency%library%include_dir(j)%s) - if (is_dir(include_dir%s)) then - model%include_dirs = [model%include_dirs, include_dir] - end if - end do - end if + if (allocated(dependency%library)) then + if (allocated(dependency%library%source_dir)) then + lib_dir = join_path(dep%proj_dir, dependency%library%source_dir) + if (is_dir(lib_dir)) then + call add_sources_from_dir(model%packages(i)%sources, lib_dir, FPM_SCOPE_LIB, & + error=error) + if (allocated(error)) exit end if + end if + + if (allocated(dependency%library%include_dir)) then + do j = 1, size(dependency%library%include_dir) + include_dir%s = join_path(dep%proj_dir, dependency%library%include_dir(j)%s) + if (is_dir(include_dir%s)) then + model%include_dirs = [model%include_dirs, include_dir] + end if + end do + end if - if (allocated(dependency%build%link)) then - model%link_libraries = [model%link_libraries, dependency%build%link] - end if + end if - if (allocated(dependency%build%external_modules)) then - model%external_modules = [model%external_modules, dependency%build%external_modules] - end if - end associate + if (allocated(dependency%build%link)) then + model%link_libraries = [model%link_libraries, dependency%build%link] + end if + + if (allocated(dependency%build%external_modules)) then + model%external_modules = [model%external_modules, dependency%build%external_modules] + end if + end associate end do if (allocated(error)) return @@ -165,102 +163,101 @@ subroutine build_model(model, settings, package, error) ! Add sources from executable directories if (is_dir('app') .and. package%build%auto_executables) then - call add_sources_from_dir(model%packages(1)%sources,'app', FPM_SCOPE_APP, & - with_executables=.true., error=error) + call add_sources_from_dir(model%packages(1)%sources, 'app', FPM_SCOPE_APP, & + with_executables=.true., error=error) - if (allocated(error)) then - return - end if + if (allocated(error)) then + return + end if end if if (is_dir('example') .and. package%build%auto_examples) then - call add_sources_from_dir(model%packages(1)%sources,'example', FPM_SCOPE_EXAMPLE, & - with_executables=.true., error=error) + call add_sources_from_dir(model%packages(1)%sources, 'example', FPM_SCOPE_EXAMPLE, & + with_executables=.true., error=error) - if (allocated(error)) then - return - end if + if (allocated(error)) then + return + end if end if if (is_dir('test') .and. package%build%auto_tests) then - call add_sources_from_dir(model%packages(1)%sources,'test', FPM_SCOPE_TEST, & - with_executables=.true., error=error) + call add_sources_from_dir(model%packages(1)%sources, 'test', FPM_SCOPE_TEST, & + with_executables=.true., error=error) - if (allocated(error)) then - return - endif + if (allocated(error)) then + return + end if end if if (allocated(package%executable)) then - call add_executable_sources(model%packages(1)%sources, package%executable, FPM_SCOPE_APP, & - auto_discover=package%build%auto_executables, & - error=error) + call add_executable_sources(model%packages(1)%sources, package%executable, FPM_SCOPE_APP, & + auto_discover=package%build%auto_executables, & + error=error) - if (allocated(error)) then - return - end if + if (allocated(error)) then + return + end if end if if (allocated(package%example)) then - call add_executable_sources(model%packages(1)%sources, package%example, FPM_SCOPE_EXAMPLE, & - auto_discover=package%build%auto_examples, & - error=error) + call add_executable_sources(model%packages(1)%sources, package%example, FPM_SCOPE_EXAMPLE, & + auto_discover=package%build%auto_examples, & + error=error) - if (allocated(error)) then - return - end if + if (allocated(error)) then + return + end if end if if (allocated(package%test)) then - call add_executable_sources(model%packages(1)%sources, package%test, FPM_SCOPE_TEST, & - auto_discover=package%build%auto_tests, & - error=error) - - if (allocated(error)) then - return - endif + call add_executable_sources(model%packages(1)%sources, package%test, FPM_SCOPE_TEST, & + auto_discover=package%build%auto_tests, & + error=error) - endif + if (allocated(error)) then + return + end if + end if if (settings%verbose) then - write(*,*)' BUILD_NAME: ',model%build_prefix - write(*,*)' COMPILER: ',model%compiler%fc - write(*,*)' C COMPILER: ',model%compiler%cc - write(*,*)' CXX COMPILER: ',model%compiler%cxx - write(*,*)' COMPILER OPTIONS: ', model%fortran_compile_flags - write(*,*)' C COMPILER OPTIONS: ', model%c_compile_flags - write(*,*)' CXX COMPILER OPTIONS: ', model%cxx_compile_flags - write(*,*)' LINKER OPTIONS: ', model%link_flags - write(*,*)' INCLUDE DIRECTORIES: [', string_cat(model%include_dirs,','),']' - end if + write (*, *) ' BUILD_NAME: ', model%build_prefix + write (*, *) ' COMPILER: ', model%compiler%fc + write (*, *) ' C COMPILER: ', model%compiler%cc + write (*, *) ' CXX COMPILER: ', model%compiler%cxx + write (*, *) ' COMPILER OPTIONS: ', model%fortran_compile_flags + write (*, *) ' C COMPILER OPTIONS: ', model%c_compile_flags + write (*, *) ' CXX COMPILER OPTIONS: ', model%cxx_compile_flags + write (*, *) ' LINKER OPTIONS: ', model%link_flags + write (*, *) ' INCLUDE DIRECTORIES: [', string_cat(model%include_dirs, ','), ']' + end if ! Check for duplicate modules call check_modules_for_duplicates(model, duplicates_found) if (duplicates_found) then - call fpm_stop(1,'*build_model*:Error: One or more duplicate module names found.') + call fpm_stop(1, '*build_model*:Error: One or more duplicate module names found.') end if -end subroutine build_model + end subroutine build_model ! Check for duplicate modules -subroutine check_modules_for_duplicates(model, duplicates_found) + subroutine check_modules_for_duplicates(model, duplicates_found) type(fpm_model_t), intent(in) :: model integer :: maxsize - integer :: i,j,k,l,m,modi + integer :: i, j, k, l, m, modi type(string_t), allocatable :: modules(:) logical :: duplicates_found ! Initialise the size of array maxsize = 0 ! Get number of modules provided by each source file of every package - do i=1,size(model%packages) - do j=1,size(model%packages(i)%sources) + do i = 1, size(model%packages) + do j = 1, size(model%packages(i)%sources) if (allocated(model%packages(i)%sources(j)%modules_provided)) then maxsize = maxsize + size(model%packages(i)%sources(j)%modules_provided) end if end do end do ! Allocate array to contain distinct names of modules - allocate(modules(maxsize)) + allocate (modules(maxsize)) ! Initialise index to point at start of the newly allocated array modi = 1 @@ -268,13 +265,13 @@ subroutine check_modules_for_duplicates(model, duplicates_found) ! Loop through modules provided by each source file of every package ! Add it to the array if it is not already there ! Otherwise print out warning about duplicates - do k=1,size(model%packages) - do l=1,size(model%packages(k)%sources) + do k = 1, size(model%packages) + do l = 1, size(model%packages(k)%sources) if (allocated(model%packages(k)%sources(l)%modules_provided)) then - do m=1,size(model%packages(k)%sources(l)%modules_provided) - if (model%packages(k)%sources(l)%modules_provided(m)%s.in.modules(:modi-1)) then - write(stderr, *) "Warning: Module ",model%packages(k)%sources(l)%modules_provided(m)%s, & - " in ",model%packages(k)%sources(l)%file_name," is a duplicate" + do m = 1, size(model%packages(k)%sources(l)%modules_provided) + if (model%packages(k)%sources(l)%modules_provided(m)%s.in.modules(:modi - 1)) then + write (stderr, *) "Warning: Module ", model%packages(k)%sources(l)%modules_provided(m)%s, & + " in ", model%packages(k)%sources(l)%file_name, " is a duplicate" duplicates_found = .true. else modules(modi) = model%packages(k)%sources(l)%modules_provided(m) @@ -284,45 +281,45 @@ subroutine check_modules_for_duplicates(model, duplicates_found) end if end do end do -end subroutine check_modules_for_duplicates - -subroutine cmd_build(settings) -type(fpm_build_settings), intent(in) :: settings -type(package_config_t) :: package -type(fpm_model_t) :: model -type(build_target_ptr), allocatable :: targets(:) -type(error_t), allocatable :: error - -integer :: i - -call get_package_data(package, "fpm.toml", error, apply_defaults=.true.) -if (allocated(error)) then - call fpm_stop(1,'*cmd_build*:package error:'//error%message) -end if - -call build_model(model, settings, package, error) -if (allocated(error)) then - call fpm_stop(1,'*cmd_build*:model error:'//error%message) -end if - -call targets_from_sources(targets, model, settings%prune, error) -if (allocated(error)) then - call fpm_stop(1,'*cmd_build*:target error:'//error%message) -end if - -if(settings%list)then - do i=1,size(targets) - write(stderr,*) targets(i)%ptr%output_file - enddo -else if (settings%show_model) then - call show_model(model) -else - call build_package(targets,model,verbose=settings%verbose) -endif - -end subroutine cmd_build - -subroutine cmd_run(settings,test) + end subroutine check_modules_for_duplicates + + subroutine cmd_build(settings) + type(fpm_build_settings), intent(in) :: settings + type(package_config_t) :: package + type(fpm_model_t) :: model + type(build_target_ptr), allocatable :: targets(:) + type(error_t), allocatable :: error + + integer :: i + + call get_package_data(package, "fpm.toml", error, apply_defaults=.true.) + if (allocated(error)) then + call fpm_stop(1, '*cmd_build*:package error:'//error%message) + end if + + call build_model(model, settings, package, error) + if (allocated(error)) then + call fpm_stop(1, '*cmd_build*:model error:'//error%message) + end if + + call targets_from_sources(targets, model, settings%prune, error) + if (allocated(error)) then + call fpm_stop(1, '*cmd_build*:target error:'//error%message) + end if + + if (settings%list) then + do i = 1, size(targets) + write (stderr, *) targets(i)%ptr%output_file + end do + else if (settings%show_model) then + call show_model(model) + else + call build_package(targets, model, verbose=settings%verbose) + end if + + end subroutine cmd_build + + subroutine cmd_run(settings, test) class(fpm_run_settings), intent(in) :: settings logical, intent(in) :: test @@ -338,201 +335,201 @@ subroutine cmd_run(settings,test) type(srcfile_t), pointer :: exe_source integer :: run_scope integer, allocatable :: stat(:) - character(len=:),allocatable :: line + character(len=:), allocatable :: line logical :: toomany call get_package_data(package, "fpm.toml", error, apply_defaults=.true.) if (allocated(error)) then - call fpm_stop(1, '*cmd_run*:package error:'//error%message) + call fpm_stop(1, '*cmd_run*:package error:'//error%message) end if call build_model(model, settings%fpm_build_settings, package, error) if (allocated(error)) then - call fpm_stop(1, '*cmd_run*:model error:'//error%message) + call fpm_stop(1, '*cmd_run*:model error:'//error%message) end if call targets_from_sources(targets, model, settings%prune, error) if (allocated(error)) then - call fpm_stop(1, '*cmd_run*:targets error:'//error%message) + call fpm_stop(1, '*cmd_run*:targets error:'//error%message) end if if (test) then - run_scope = FPM_SCOPE_TEST + run_scope = FPM_SCOPE_TEST else - run_scope = merge(FPM_SCOPE_EXAMPLE, FPM_SCOPE_APP, settings%example) + run_scope = merge(FPM_SCOPE_EXAMPLE, FPM_SCOPE_APP, settings%example) end if ! Enumerate executable targets to run col_width = -1 found(:) = .false. - allocate(executables(0)) - do i=1,size(targets) + allocate (executables(0)) + do i = 1, size(targets) - exe_target => targets(i)%ptr - - if (exe_target%target_type == FPM_TARGET_EXECUTABLE .and. & - allocated(exe_target%dependencies)) then + exe_target => targets(i)%ptr - exe_source => exe_target%dependencies(1)%ptr%source + if (exe_target%target_type == FPM_TARGET_EXECUTABLE .and. & + allocated(exe_target%dependencies)) then - if (exe_source%unit_scope == run_scope) then + exe_source => exe_target%dependencies(1)%ptr%source - col_width = max(col_width,len(basename(exe_target%output_file))+2) + if (exe_source%unit_scope == run_scope) then - if (size(settings%name) == 0) then + col_width = max(col_width, len(basename(exe_target%output_file)) + 2) - exe_cmd%s = exe_target%output_file - executables = [executables, exe_cmd] + if (size(settings%name) == 0) then - else + exe_cmd%s = exe_target%output_file + executables = [executables, exe_cmd] - do j=1,size(settings%name) + else - if (glob(trim(exe_source%exe_name),trim(settings%name(j)))) then + do j = 1, size(settings%name) - found(j) = .true. - exe_cmd%s = exe_target%output_file - executables = [executables, exe_cmd] + if (glob(trim(exe_source%exe_name), trim(settings%name(j)))) then - end if + found(j) = .true. + exe_cmd%s = exe_target%output_file + executables = [executables, exe_cmd] - end do + end if - end if + end do - end if + end if end if + end if + end do ! Check if any apps/tests were found if (col_width < 0) then - if (test) then - call fpm_stop(0,'No tests to run') - else - call fpm_stop(0,'No executables to run') - end if + if (test) then + call fpm_stop(0, 'No tests to run') + else + call fpm_stop(0, 'No executables to run') + end if end if ! Check all names are valid ! or no name and found more than one file - toomany= size(settings%name)==0 .and. size(executables)>1 - if ( any(.not.found) & + toomany = size(settings%name) == 0 .and. size(executables) > 1 + if (any(.not. found) & & .or. & - & ( (toomany .and. .not.test) .or. (toomany .and. settings%runner /= '') ) & + & ((toomany .and. .not. test) .or. (toomany .and. settings%runner /= '')) & & .and. & - & .not.settings%list) then - line=join(settings%name) - if(line/='.')then ! do not report these special strings - if(any(.not.found))then - write(stderr,'(A)',advance="no")'*cmd_run*:specified names ' - do j=1,size(settings%name) - if (.not.found(j)) write(stderr,'(A)',advance="no") '"'//trim(settings%name(j))//'" ' - end do - write(stderr,'(A)') 'not found.' - write(stderr,*) - else if(settings%verbose)then - write(stderr,'(A)',advance="yes")'when more than one executable is available' - write(stderr,'(A)',advance="yes")' program names must be specified.' - endif - endif - - call compact_list_all() - - if(line=='.' .or. line==' ')then ! do not report these special strings - call fpm_stop(0,'') - else - call fpm_stop(1,'') - endif + & .not. settings%list) then + line = join(settings%name) + if (line /= '.') then ! do not report these special strings + if (any(.not. found)) then + write (stderr, '(A)', advance="no") '*cmd_run*:specified names ' + do j = 1, size(settings%name) + if (.not. found(j)) write (stderr, '(A)', advance="no") '"'//trim(settings%name(j))//'" ' + end do + write (stderr, '(A)') 'not found.' + write (stderr, *) + else if (settings%verbose) then + write (stderr, '(A)', advance="yes") 'when more than one executable is available' + write (stderr, '(A)', advance="yes") ' program names must be specified.' + end if + end if + + call compact_list_all() + + if (line == '.' .or. line == ' ') then ! do not report these special strings + call fpm_stop(0, '') + else + call fpm_stop(1, '') + end if end if - call build_package(targets,model,verbose=settings%verbose) + call build_package(targets, model, verbose=settings%verbose) if (settings%list) then - call compact_list() + call compact_list() else - allocate(stat(size(executables))) - do i=1,size(executables) - if (exists(executables(i)%s)) then - if(settings%runner /= ' ')then - if(.not.allocated(settings%args))then - call run(settings%runner//' '//executables(i)%s, & - echo=settings%verbose, exitstat=stat(i)) - else - call run(settings%runner//' '//executables(i)%s//" "//settings%args, & - echo=settings%verbose, exitstat=stat(i)) - endif - else - if(.not.allocated(settings%args))then - call run(executables(i)%s,echo=settings%verbose, exitstat=stat(i)) - else - call run(executables(i)%s//" "//settings%args,echo=settings%verbose, & - exitstat=stat(i)) - endif - endif + allocate (stat(size(executables))) + do i = 1, size(executables) + if (exists(executables(i)%s)) then + if (settings%runner /= ' ') then + if (.not. allocated(settings%args)) then + call run(settings%runner//' '//executables(i)%s, & + echo=settings%verbose, exitstat=stat(i)) else - call fpm_stop(1,'*cmd_run*:'//executables(i)%s//' not found') + call run(settings%runner//' '//executables(i)%s//" "//settings%args, & + echo=settings%verbose, exitstat=stat(i)) end if - end do - - if (any(stat /= 0)) then - do i=1,size(stat) - if (stat(i) /= 0) then - write(stderr,'(*(g0:,1x))') ' Execution failed for object "',basename(executables(i)%s),'"' - end if - end do - call fpm_stop(1,'*cmd_run*:stopping due to failed executions') + else + if (.not. allocated(settings%args)) then + call run(executables(i)%s, echo=settings%verbose, exitstat=stat(i)) + else + call run(executables(i)%s//" "//settings%args, echo=settings%verbose, & + exitstat=stat(i)) + end if + end if + else + call fpm_stop(1, '*cmd_run*:'//executables(i)%s//' not found') end if + end do - endif - contains + if (any(stat /= 0)) then + do i = 1, size(stat) + if (stat(i) /= 0) then + write (stderr, '(*(g0:,1x))') ' Execution failed for object "', basename(executables(i)%s), '"' + end if + end do + call fpm_stop(1, '*cmd_run*:stopping due to failed executions') + end if + + end if + contains subroutine compact_list_all() - integer, parameter :: LINE_WIDTH = 80 - integer :: i, j, nCol - j = 1 - nCol = LINE_WIDTH/col_width - write(stderr,*) 'Available names:' - do i=1,size(targets) + integer, parameter :: LINE_WIDTH = 80 + integer :: i, j, nCol + j = 1 + nCol = LINE_WIDTH/col_width + write (stderr, *) 'Available names:' + do i = 1, size(targets) - exe_target => targets(i)%ptr + exe_target => targets(i)%ptr - if (exe_target%target_type == FPM_TARGET_EXECUTABLE .and. & - allocated(exe_target%dependencies)) then + if (exe_target%target_type == FPM_TARGET_EXECUTABLE .and. & + allocated(exe_target%dependencies)) then - exe_source => exe_target%dependencies(1)%ptr%source + exe_source => exe_target%dependencies(1)%ptr%source - if (exe_source%unit_scope == run_scope) then + if (exe_source%unit_scope == run_scope) then - write(stderr,'(A)',advance=(merge("yes","no ",modulo(j,nCol)==0))) & - & [character(len=col_width) :: basename(exe_target%output_file, suffix=.false.)] - j = j + 1 + write (stderr, '(A)', advance=(merge("yes", "no ", modulo(j, nCol) == 0))) & + & [character(len=col_width) :: basename(exe_target%output_file, suffix=.false.)] + j = j + 1 - end if - end if - end do - write(stderr,*) + end if + end if + end do + write (stderr, *) end subroutine compact_list_all subroutine compact_list() - integer, parameter :: LINE_WIDTH = 80 - integer :: i, j, nCol - j = 1 - nCol = LINE_WIDTH/col_width - write(stderr,*) 'Matched names:' - do i=1,size(executables) - write(stderr,'(A)',advance=(merge("yes","no ",modulo(j,nCol)==0))) & - & [character(len=col_width) :: basename(executables(i)%s, suffix=.false.)] - j = j + 1 - enddo - write(stderr,*) + integer, parameter :: LINE_WIDTH = 80 + integer :: i, j, nCol + j = 1 + nCol = LINE_WIDTH/col_width + write (stderr, *) 'Matched names:' + do i = 1, size(executables) + write (stderr, '(A)', advance=(merge("yes", "no ", modulo(j, nCol) == 0))) & + & [character(len=col_width) :: basename(executables(i)%s, suffix=.false.)] + j = j + 1 + end do + write (stderr, *) end subroutine compact_list -end subroutine cmd_run + end subroutine cmd_run -subroutine delete_skip(unix) + subroutine delete_skip(unix) !> delete directories in the build folder, skipping dependencies logical, intent(in) :: unix character(len=:), allocatable :: dir @@ -540,37 +537,37 @@ subroutine delete_skip(unix) integer :: i call list_files('build', files, .false.) do i = 1, size(files) - if (is_dir(files(i)%s)) then - dir = files(i)%s - if (.not.str_ends_with(dir,'dependencies')) call os_delete_dir(unix, dir) - end if + if (is_dir(files(i)%s)) then + dir = files(i)%s + if (.not. str_ends_with(dir, 'dependencies')) call os_delete_dir(unix, dir) + end if end do -end subroutine delete_skip + end subroutine delete_skip -subroutine cmd_clean(settings) + subroutine cmd_clean(settings) !> fpm clean called class(fpm_clean_settings), intent(in) :: settings ! character(len=:), allocatable :: dir ! type(string_t), allocatable :: files(:) character(len=1) :: response if (is_dir('build')) then - ! remove the entire build directory - if (settings%clean_call) then - call os_delete_dir(settings%unix, 'build') - return - end if - ! remove the build directory but skip dependencies - if (settings%clean_skip) then - call delete_skip(settings%unix) - return - end if - ! prompt to remove the build directory but skip dependencies - write(stdout, '(A)', advance='no') "Delete build, excluding dependencies (y/n)? " - read(stdin, '(A1)') response - if (lower(response) == 'y') call delete_skip(settings%unix) + ! remove the entire build directory + if (settings%clean_call) then + call os_delete_dir(settings%unix, 'build') + return + end if + ! remove the build directory but skip dependencies + if (settings%clean_skip) then + call delete_skip(settings%unix) + return + end if + ! prompt to remove the build directory but skip dependencies + write (stdout, '(A)', advance='no') "Delete build, excluding dependencies (y/n)? " + read (stdin, '(A1)') response + if (lower(response) == 'y') call delete_skip(settings%unix) else - write (stdout, '(A)') "fpm: No build directory found." + write (stdout, '(A)') "fpm: No build directory found." end if -end subroutine cmd_clean + end subroutine cmd_clean end module fpm diff --git a/src/fpm/cmd/install.f90 b/src/fpm/cmd/install.f90 index f81b4dfc44..e2f68a3199 100644 --- a/src/fpm/cmd/install.f90 +++ b/src/fpm/cmd/install.f90 @@ -1,17 +1,17 @@ module fpm_cmd_install - use, intrinsic :: iso_fortran_env, only : output_unit - use fpm, only : build_model - use fpm_backend, only : build_package - use fpm_command_line, only : fpm_install_settings - use fpm_error, only : error_t, fatal_error, fpm_stop - use fpm_filesystem, only : join_path, list_files - use fpm_installer, only : installer_t, new_installer - use fpm_manifest, only : package_config_t, get_package_data - use fpm_model, only : fpm_model_t, FPM_SCOPE_APP + use, intrinsic :: iso_fortran_env, only: output_unit + use fpm, only: build_model + use fpm_backend, only: build_package + use fpm_command_line, only: fpm_install_settings + use fpm_error, only: error_t, fatal_error, fpm_stop + use fpm_filesystem, only: join_path, list_files + use fpm_installer, only: installer_t, new_installer + use fpm_manifest, only: package_config_t, get_package_data + use fpm_model, only: fpm_model_t, FPM_SCOPE_APP use fpm_targets, only: targets_from_sources, build_target_t, & build_target_ptr, FPM_TARGET_EXECUTABLE, & filter_library_targets, filter_executable_targets, filter_modules - use fpm_strings, only : string_t, resize + use fpm_strings, only: string_t, resize implicit none private @@ -42,8 +42,8 @@ subroutine cmd_install(settings) call handle_error(error) installable = (allocated(package%library) .and. package%install%library) & - .or. allocated(package%executable) - if (.not.installable) then + .or. allocated(package%executable) + if (.not. installable) then call fatal_error(error, "Project does not contain any installable targets") call handle_error(error) end if @@ -53,14 +53,14 @@ subroutine cmd_install(settings) return end if - if (.not.settings%no_rebuild) then - call build_package(targets,model,verbose=settings%verbose) + if (.not. settings%no_rebuild) then + call build_package(targets, model, verbose=settings%verbose) end if call new_installer(installer, prefix=settings%prefix, & - bindir=settings%bindir, libdir=settings%libdir, & - includedir=settings%includedir, & - verbosity=merge(2, 1, settings%verbose)) + bindir=settings%bindir, libdir=settings%libdir, & + includedir=settings%includedir, & + verbosity=merge(2, 1, settings%verbose)) if (allocated(package%library) .and. package%install%library) then call filter_library_targets(targets, list) @@ -91,7 +91,7 @@ subroutine install_info(unit, package, model, targets) character(len=:), allocatable :: lib type(string_t), allocatable :: install_target(:), temp(:) - allocate(install_target(0)) + allocate (install_target(0)) call filter_library_targets(targets, temp) install_target = [install_target, temp] @@ -101,10 +101,10 @@ subroutine install_info(unit, package, model, targets) ntargets = size(install_target) - write(unit, '("#", *(1x, g0))') & + write (unit, '("#", *(1x, g0))') & "total number of installable targets:", ntargets do ii = 1, ntargets - write(unit, '("-", *(1x, g0))') install_target(ii)%s + write (unit, '("-", *(1x, g0))') install_target(ii)%s end do end subroutine install_info @@ -146,7 +146,7 @@ elemental function is_executable_target(target_ptr) result(is_exe) type(build_target_t), intent(in) :: target_ptr logical :: is_exe is_exe = target_ptr%target_type == FPM_TARGET_EXECUTABLE .and. & - allocated(target_ptr%dependencies) + allocated(target_ptr%dependencies) if (is_exe) then is_exe = target_ptr%dependencies(1)%ptr%source%unit_scope == FPM_SCOPE_APP end if @@ -155,7 +155,7 @@ end function is_executable_target subroutine handle_error(error) type(error_t), intent(in), optional :: error if (present(error)) then - call fpm_stop(1,error%message) + call fpm_stop(1, error%message) end if end subroutine handle_error diff --git a/src/fpm/cmd/new.f90 b/src/fpm/cmd/new.f90 index bed0980553..857d1118f0 100644 --- a/src/fpm/cmd/new.f90 +++ b/src/fpm/cmd/new.f90 @@ -53,653 +53,652 @@ module fpm_cmd_new !> although some other command might provide that (and the help command should !> be the first go-to for a CLI utility). -use fpm_command_line, only : fpm_new_settings -use fpm_environment, only : OS_LINUX, OS_MACOS, OS_WINDOWS -use fpm_filesystem, only : join_path, exists, basename, mkdir, is_dir -use fpm_filesystem, only : fileopen, fileclose, filewrite, warnwrite, which, run -use fpm_strings, only : join, to_fortran_name -use fpm_error, only : fpm_stop + use fpm_command_line, only: fpm_new_settings + use fpm_environment, only: OS_LINUX, OS_MACOS, OS_WINDOWS + use fpm_filesystem, only: join_path, exists, basename, mkdir, is_dir + use fpm_filesystem, only: fileopen, fileclose, filewrite, warnwrite, which, run + use fpm_strings, only: join, to_fortran_name + use fpm_error, only: fpm_stop -use,intrinsic :: iso_fortran_env, only : stderr=>error_unit -implicit none -private -public :: cmd_new + use, intrinsic :: iso_fortran_env, only: stderr => error_unit + implicit none + private + public :: cmd_new contains -subroutine cmd_new(settings) -type(fpm_new_settings), intent(in) :: settings -integer,parameter :: tfc = selected_char_kind('DEFAULT') -character(len=:,kind=tfc),allocatable :: bname ! baeename of NAME -character(len=:,kind=tfc),allocatable :: tomlfile(:) -character(len=:,kind=tfc),allocatable :: littlefile(:) + subroutine cmd_new(settings) + type(fpm_new_settings), intent(in) :: settings + integer, parameter :: tfc = selected_char_kind('DEFAULT') + character(len=:, kind=tfc), allocatable :: bname ! baeename of NAME + character(len=:, kind=tfc), allocatable :: tomlfile(:) + character(len=:, kind=tfc), allocatable :: littlefile(:) !> TOP DIRECTORY NAME PROCESSING !> see if requested new directory already exists and process appropriately - if(exists(settings%name) .and. .not.settings%backfill )then - write(stderr,'(*(g0,1x))')& - & '',settings%name,'already exists.' - write(stderr,'(*(g0,1x))')& - & ' perhaps you wanted to add --backfill ?' - return - elseif(is_dir(settings%name) .and. settings%backfill )then - write(*,'(*(g0))')'backfilling ',settings%name - elseif(exists(settings%name) )then - write(stderr,'(*(g0,1x))')& - & '',settings%name,'already exists and is not a directory.' - return + if (exists(settings%name) .and. .not. settings%backfill) then + write (stderr, '(*(g0,1x))')& + & '', settings%name, 'already exists.' + write (stderr, '(*(g0,1x))')& + & ' perhaps you wanted to add --backfill ?' + return + elseif (is_dir(settings%name) .and. settings%backfill) then + write (*, '(*(g0))') 'backfilling ', settings%name + elseif (exists(settings%name)) then + write (stderr, '(*(g0,1x))')& + & '', settings%name, 'already exists and is not a directory.' + return else - ! make new directory - call mkdir(settings%name) - endif + ! make new directory + call mkdir(settings%name) + end if !> temporarily change to new directory as a test. NB: System dependent call run('cd '//settings%name) ! NOTE: need some system routines to handle filenames like "." ! like realpath() or getcwd(). - bname=basename(settings%name) + bname = basename(settings%name) - littlefile=[character(len=80) :: '# '//bname, 'My cool new project!'] + littlefile = [character(len=80) :: '# '//bname, 'My cool new project!'] ! create NAME/README.md call warnwrite(join_path(settings%name, 'README.md'), littlefile) ! start building NAME/fpm.toml - if(settings%with_full)then - tomlfile=[character(len=80) :: & - &' # This is your fpm(Fortran Package Manager) manifest file ',& - &' # ("fpm.toml"). It is heavily annotated to help guide you though ',& - &' # customizing a package build, although the defaults are sufficient ',& - &' # for many basic packages. ',& - &' # ',& - &' # The manifest file is not only used to provide metadata identifying ',& - &' # your project (so it can be used by others as a dependency). It can ',& - &' # specify where your library and program sources live, what the name ',& - &' # of the executable(s) will be, what files to build, dependencies on ',& - &' # other fpm packages, and what external libraries are required. ',& - &' # ',& - &' # The manifest format must conform to the TOML configuration file ',& - &' # standard. ',& - &' # ',& - &' # TOML files support flexible use of white-space and commenting of the ',& - &' # configuration data, but for clarity in this sample active directives ',& - &' # begin in column one. Inactive example directives are commented ',& - &' # out with a pound character ("#") but begin in column one as well. ',& - &' # Commentary begins with a pound character in column three. ',& - &' # ',& - &' # This file draws heavily upon the following references: ',& - &' # ',& - &' # The fpm home page at ',& - &' # https://github.com/fortran-lang/fpm ',& - &' # A complete list of keys and their attributes at ',& - &' # https://github.com/fortran-lang/fpm/blob/main/manifest-reference.md ',& - &' # examples of fpm project packaging at ',& - &' # https://github.com/fortran-lang/fpm/blob/main/PACKAGING.md ',& - &' # The Fortran TOML file interface and it''s references at ',& - &' # https://github.com/toml-f/toml-f ',& - &' # ',& - &' #----------------------- ',& - &' # project Identification ',& - &' #----------------------- ',& - &' # We begin with project metadata at the manifest root. This data is designed ',& - &' # to aid others when searching for the project in a repository and to ',& - &' # identify how and when to contact the package supporters. ',& - &' ',& - &'name = "'//bname//'"',& - &' # The project name (required) is how the project will be referred to. ',& - &' # The name is used by other packages using it as a dependency. It also ',& - &' # is used as the default name of any library built and the optional ',& - &' # default executable built from app/main.f90. It must conform to the rules ',& - &' # for a Fortran variable name. ',& - &' ',& - &'version = "0.1.0" ',& - &' # The project version number is a string. A recommended scheme for ',& - &' # specifying versions is the Semantic Versioning scheme. ',& - &' ',& - &'license = "license" ',& - &' # Licensing information specified using SPDX identifiers is preferred ',& - &' # (eg. "Apache-2.0 OR MIT" or "LGPL-3.0-or-later"). ',& - &' ',& - &'maintainer = "jane.doe@example.com" ',& - &' # Information on the project maintainer and means to reach out to them. ',& - &' ',& - &'author = "Jane Doe" ',& - &' # Information on the project author. ',& - &' ',& - &'copyright = "Copyright 2020 Jane Doe" ',& - &' # A statement clarifying the Copyright status of the project. ',& + if (settings%with_full) then + tomlfile = [character(len=80) :: & + &' # This is your fpm(Fortran Package Manager) manifest file ',& + &' # ("fpm.toml"). It is heavily annotated to help guide you though ',& + &' # customizing a package build, although the defaults are sufficient ',& + &' # for many basic packages. ',& + &' # ',& + &' # The manifest file is not only used to provide metadata identifying ',& + &' # your project (so it can be used by others as a dependency). It can ',& + &' # specify where your library and program sources live, what the name ',& + &' # of the executable(s) will be, what files to build, dependencies on ',& + &' # other fpm packages, and what external libraries are required. ',& + &' # ',& + &' # The manifest format must conform to the TOML configuration file ',& + &' # standard. ',& + &' # ',& + &' # TOML files support flexible use of white-space and commenting of the ',& + &' # configuration data, but for clarity in this sample active directives ',& + &' # begin in column one. Inactive example directives are commented ',& + &' # out with a pound character ("#") but begin in column one as well. ',& + &' # Commentary begins with a pound character in column three. ',& + &' # ',& + &' # This file draws heavily upon the following references: ',& + &' # ',& + &' # The fpm home page at ',& + &' # https://github.com/fortran-lang/fpm ',& + &' # A complete list of keys and their attributes at ',& + &' # https://github.com/fortran-lang/fpm/blob/main/manifest-reference.md ',& + &' # examples of fpm project packaging at ',& + &' # https://github.com/fortran-lang/fpm/blob/main/PACKAGING.md ',& + &' # The Fortran TOML file interface and it''s references at ',& + &' # https://github.com/toml-f/toml-f ',& + &' # ',& + &' #----------------------- ',& + &' # project Identification ',& + &' #----------------------- ',& + &' # We begin with project metadata at the manifest root. This data is designed ',& + &' # to aid others when searching for the project in a repository and to ',& + &' # identify how and when to contact the package supporters. ',& + &' ',& + &'name = "'//bname//'"',& + &' # The project name (required) is how the project will be referred to. ',& + &' # The name is used by other packages using it as a dependency. It also ',& + &' # is used as the default name of any library built and the optional ',& + &' # default executable built from app/main.f90. It must conform to the rules ',& + &' # for a Fortran variable name. ',& + &' ',& + &'version = "0.1.0" ',& + &' # The project version number is a string. A recommended scheme for ',& + &' # specifying versions is the Semantic Versioning scheme. ',& + &' ',& + &'license = "license" ',& + &' # Licensing information specified using SPDX identifiers is preferred ',& + &' # (eg. "Apache-2.0 OR MIT" or "LGPL-3.0-or-later"). ',& + &' ',& + &'maintainer = "jane.doe@example.com" ',& + &' # Information on the project maintainer and means to reach out to them. ',& + &' ',& + &'author = "Jane Doe" ',& + &' # Information on the project author. ',& + &' ',& + &'copyright = "Copyright 2020 Jane Doe" ',& + &' # A statement clarifying the Copyright status of the project. ',& + &' ',& + &'#description = "A short project summary in plain text" ',& + &' # The description provides a short summary on the project. It should be ',& + &' # plain text and not use any markup formatting. ',& + &' ',& + &'#categories = ["fortran", "graphics"] ',& + &' # Categories associated with the project. Listing only one is preferred. ',& + &' ',& + &'#keywords = ["hdf5", "mpi"] ',& + &' # The keywords field is an array of strings describing the project. ',& + &' ',& + &'#homepage = "https://stdlib.fortran-lang.org" ',& + &' # URL to the webpage of the project. ',& + &' ',& + &' # ----------------------------------------- ',& + &' # We are done with identifying the project. ',& + &' # ----------------------------------------- ',& + &' # ',& + &' # Now lets start describing how the project should be built. ',& + &' # ',& + &' # Note tables would go here but we will not be talking about them (much)!!',& + &' # ',& + &' # Tables are a way to explicitly specify large numbers of programs in ',& + &' # a compact format instead of individual per-program entries in the ',& + &' # [[executable]], [[test]], and [[example]] sections to follow but ',& + &' # will not be discussed further except for the following notes: ',& + &' # ',& + &' # + Tables must appear (here) before any sections are declared. Once a ',& + &' # section is specified in a TOML file everything afterwards must be ',& + &' # values for that section or the beginning of a new section. A simple ',& + &' # example looks like: ',& + &' ',& + &'#executable = [ ',& + &'# { name = "a-prog" }, ',& + &'# { name = "app-tool", source-dir = "tool" }, ',& + &'# { name = "fpm-man", source-dir = "tool", main="fman.f90" } ',& + &'#] ',& + &' ',& + &' # This would be in lieue of the [[executable]] section found later in this ',& + &' # configuration file. ',& + &' # + See the reference documents (at the beginning of this document) ',& + &' # for more information on tables if you have long lists of programs ',& + &' # to build and are not simply depending on auto-detection. ',& + &' # ',& + &' # Now lets begin the TOML sections (lines beginning with "[") ... ',& + &' # ',& + &' ',& + &'[install] # Options for the "install" subcommand ',& + &' ',& + &' # When you run the "install" subcommand only executables are installed by ',& + &' # default on the local system. Library projects that will be used outside of ',& + &' # "fpm" can set the "library" boolean to also allow installing the module ',& + &' # files and library archive. Without this being set to "true" an "install" ',& + &' # subcommand ignores parameters that specify library installation. ',& + &' ',& + &'library = false ',& + &' ',& + &'[build] # General Build Options ',& + &' ',& + &' ### Automatic target discovery ',& + &' # ',& + &' # Normally fpm recursively searches the app/, example/, and test/ directories ',& + &' # for program sources and builds them. To disable this automatic discovery of ',& + &' # program targets set the following to "false": ',& + &' ',& + &'#auto-executables = true ',& + &'#auto-examples = true ',& + &'#auto-tests = true ',& + &' ',& + &' ### Package-level External Library Links ',& + &' # ',& + &' # To declare link-time dependencies on external libraries a list of ',& + &' # native libraries can be specified with the "link" entry. You may ',& + &' # have one library name or a list of strings in case several ',& + &' # libraries should be linked. This list of library dependencies is ',& + &' # exported to dependent packages. You may have to alter your library ',& + &' # search-path to ensure the libraries can be accessed. Typically, ',& + &' # this is done with the LD_LIBRARY_PATH environment variable on ULS ',& + &' # (Unix-Like Systems). You only specify the core name of the library ',& + &' # (as is typical with most programming environments, where you ',& + &' # would specify "-lz" on your load command to link against the zlib ',& + &' # compression library even though the library file would typically be ',& + &' # a file called "libz.a" "or libz.so"). So to link against that library ',& + &' # you would specify: ',& + &' ',& + &'#link = "z" ',& + &' ',& + &' # Note that in some cases the order of the libraries matters: ',& + &' ',& + &'#link = ["blas", "lapack"] ',& + &''] + end if + + if (settings%with_bare) then + elseif (settings%with_lib) then + call mkdir(join_path(settings%name, 'src')) + ! create next section of fpm.toml + if (settings%with_full) then + tomlfile = [character(len=80) :: tomlfile, & + &'[library] ',& &' ',& - &'#description = "A short project summary in plain text" ',& - &' # The description provides a short summary on the project. It should be ',& - &' # plain text and not use any markup formatting. ',& + &' # You can change the name of the directory to search for your library ',& + &' # source from the default of "src/". Library targets are exported ',& + &' # and usable by other projects. ',& &' ',& - &'#categories = ["fortran", "graphics"] ',& - &' # Categories associated with the project. Listing only one is preferred. ',& + &'source-dir="src" ',& &' ',& - &'#keywords = ["hdf5", "mpi"] ',& - &' # The keywords field is an array of strings describing the project. ',& + &' # this can be a list: ',& &' ',& - &'#homepage = "https://stdlib.fortran-lang.org" ',& - &' # URL to the webpage of the project. ',& + &'#source-dir=["src", "src2"] ',& &' ',& - &' # ----------------------------------------- ',& - &' # We are done with identifying the project. ',& - &' # ----------------------------------------- ',& - &' # ',& - &' # Now lets start describing how the project should be built. ',& - &' # ',& - &' # Note tables would go here but we will not be talking about them (much)!!' ,& + &' # More complex libraries may organize their modules in subdirectories. ',& + &' # For modules in a top-level directory fpm requires (but does not ',& + &' # enforce) that: ',& &' # ',& - &' # Tables are a way to explicitly specify large numbers of programs in ',& - &' # a compact format instead of individual per-program entries in the ',& - &' # [[executable]], [[test]], and [[example]] sections to follow but ',& - &' # will not be discussed further except for the following notes: ',& + &' # + The module has the same name as the source file. This is important. ',& + &' # + There should be only one module per file. ',& &' # ',& - &' # + Tables must appear (here) before any sections are declared. Once a ',& - &' # section is specified in a TOML file everything afterwards must be ',& - &' # values for that section or the beginning of a new section. A simple ',& - &' # example looks like: ',& - &' ',& - &'#executable = [ ',& - &'# { name = "a-prog" }, ',& - &'# { name = "app-tool", source-dir = "tool" }, ',& - &'# { name = "fpm-man", source-dir = "tool", main="fman.f90" } ',& - &'#] ',& - &' ',& - &' # This would be in lieue of the [[executable]] section found later in this ',& - &' # configuration file. ',& - &' # + See the reference documents (at the beginning of this document) ',& - &' # for more information on tables if you have long lists of programs ',& - &' # to build and are not simply depending on auto-detection. ',& + &' # These two requirements simplify the build process for fpm. As Fortran ',& + &' # compilers emit module files (.mod) with the same name as the module ',& + &' # itself (but not the source file, .f90), naming the module the same ',& + &' # as the source file allows fpm to: ',& &' # ',& - &' # Now lets begin the TOML sections (lines beginning with "[") ... ',& + &' # + Uniquely and exactly map a source file (.f90) to its object (.o) ',& + &' # and module (.mod) files. ',& + &' # + Avoid conflicts with modules of the same name that could appear ',& + &' # in dependency packages. ',& &' # ',& - &' ',& - &'[install] # Options for the "install" subcommand ',& - &' ',& - &' # When you run the "install" subcommand only executables are installed by ',& - &' # default on the local system. Library projects that will be used outside of ',& - &' # "fpm" can set the "library" boolean to also allow installing the module ',& - &' # files and library archive. Without this being set to "true" an "install" ',& - &' # subcommand ignores parameters that specify library installation. ',& - &' ',& - &'library = false ',& - &' ',& - &'[build] # General Build Options ',& - &' ',& - &' ### Automatic target discovery ',& + &' ### Multi-level library source ',& + &' # You can place your module source files in any number of levels of ',& + &' # subdirectories inside your source directory, but there are certain naming ',& + &' # conventions to be followed -- module names must contain the path components ',& + &' # of the directory that its source file is in. ',& &' # ',& - &' # Normally fpm recursively searches the app/, example/, and test/ directories ',& - &' # for program sources and builds them. To disable this automatic discovery of ',& - &' # program targets set the following to "false": ',& - &' ',& - &'#auto-executables = true ',& - &'#auto-examples = true ',& - &'#auto-tests = true ',& - &' ',& - &' ### Package-level External Library Links ',& - &' # ',& - &' # To declare link-time dependencies on external libraries a list of ',& - &' # native libraries can be specified with the "link" entry. You may ',& - &' # have one library name or a list of strings in case several ',& - &' # libraries should be linked. This list of library dependencies is ',& - &' # exported to dependent packages. You may have to alter your library ',& - &' # search-path to ensure the libraries can be accessed. Typically, ',& - &' # this is done with the LD_LIBRARY_PATH environment variable on ULS ',& - &' # (Unix-Like Systems). You only specify the core name of the library ',& - &' # (as is typical with most programming environments, where you ',& - &' # would specify "-lz" on your load command to link against the zlib ',& - &' # compression library even though the library file would typically be ',& - &' # a file called "libz.a" "or libz.so"). So to link against that library ',& - &' # you would specify: ',& - &' ',& - &'#link = "z" ',& - &' ',& - &' # Note that in some cases the order of the libraries matters: ',& - &' ',& - &'#link = ["blas", "lapack"] ',& + &' # This rule applies generally to any number of nested directories and ',& + &' # modules. For example, src/a/b/c/d.f90 must define a module called a_b_c_d. ',& + &' # Again, this is not enforced but may be required in future releases. ',& &''] - endif - - if(settings%with_bare)then - elseif(settings%with_lib)then - call mkdir(join_path(settings%name,'src') ) - ! create next section of fpm.toml - if(settings%with_full)then - tomlfile=[character(len=80) :: tomlfile, & - &'[library] ',& - &' ',& - &' # You can change the name of the directory to search for your library ',& - &' # source from the default of "src/". Library targets are exported ',& - &' # and usable by other projects. ',& - &' ',& - &'source-dir="src" ',& - &' ',& - &' # this can be a list: ',& - &' ',& - &'#source-dir=["src", "src2"] ',& - &' ',& - &' # More complex libraries may organize their modules in subdirectories. ',& - &' # For modules in a top-level directory fpm requires (but does not ',& - &' # enforce) that: ',& - &' # ',& - &' # + The module has the same name as the source file. This is important. ',& - &' # + There should be only one module per file. ',& - &' # ',& - &' # These two requirements simplify the build process for fpm. As Fortran ',& - &' # compilers emit module files (.mod) with the same name as the module ',& - &' # itself (but not the source file, .f90), naming the module the same ',& - &' # as the source file allows fpm to: ',& - &' # ',& - &' # + Uniquely and exactly map a source file (.f90) to its object (.o) ',& - &' # and module (.mod) files. ',& - &' # + Avoid conflicts with modules of the same name that could appear ',& - &' # in dependency packages. ',& - &' # ',& - &' ### Multi-level library source ',& - &' # You can place your module source files in any number of levels of ',& - &' # subdirectories inside your source directory, but there are certain naming ',& - &' # conventions to be followed -- module names must contain the path components ',& - &' # of the directory that its source file is in. ',& - &' # ',& - &' # This rule applies generally to any number of nested directories and ',& - &' # modules. For example, src/a/b/c/d.f90 must define a module called a_b_c_d. ',& - &' # Again, this is not enforced but may be required in future releases. ',& - &''] - endif - ! create placeholder module src/bname.f90 - littlefile=[character(len=80) :: & - &'module '//to_fortran_name(bname), & - &' implicit none', & - &' private', & - &'', & - &' public :: say_hello', & - &'contains', & - &' subroutine say_hello', & - &' print *, "Hello, '//bname//'!"', & - &' end subroutine say_hello', & - &'end module '//to_fortran_name(bname)] - ! create NAME/src/NAME.f90 - call warnwrite(join_path(settings%name, 'src', bname//'.f90'),& - & littlefile) - endif + end if + ! create placeholder module src/bname.f90 + littlefile = [character(len=80) :: & + &'module '//to_fortran_name(bname), & + &' implicit none', & + &' private', & + &'', & + &' public :: say_hello', & + &'contains', & + &' subroutine say_hello', & + &' print *, "Hello, '//bname//'!"', & + &' end subroutine say_hello', & + &'end module '//to_fortran_name(bname)] + ! create NAME/src/NAME.f90 + call warnwrite(join_path(settings%name, 'src', bname//'.f90'),& + & littlefile) + end if - if(settings%with_full)then - tomlfile=[character(len=80) :: tomlfile ,& - &'[dependencies] ',& - &' ',& - &' # Inevitably, you will want to be able to include other packages in ',& - &' # a project. Fpm makes this incredibly simple, by taking care of ',& - &' # fetching and compiling your dependencies for you. You just tell it ',& - &' # what your dependencies names are, and where to find them. ',& - &' # ',& - &' # If you are going to distribute your package only place dependencies ',& - &' # here someone using your package as a remote dependency needs built. ',& - &' # You can define dependencies just for developer executables in the ',& - &' # next section, or even for specific executables as we will see below ',& - &' # (Then fpm will still fetch and compile it when building your ',& - &' # developer executables, but users of your library will not have to). ',& - &' # ',& - &' ## GLOBAL DEPENDENCIES (exported with your project) ',& - &' # ',& - &' # Typically, dependencies are defined by specifying the project''s ',& - &' # git repository. ',& + if (settings%with_full) then + tomlfile = [character(len=80) :: tomlfile,& + &'[dependencies] ',& + &' ',& + &' # Inevitably, you will want to be able to include other packages in ',& + &' # a project. Fpm makes this incredibly simple, by taking care of ',& + &' # fetching and compiling your dependencies for you. You just tell it ',& + &' # what your dependencies names are, and where to find them. ',& + &' # ',& + &' # If you are going to distribute your package only place dependencies ',& + &' # here someone using your package as a remote dependency needs built. ',& + &' # You can define dependencies just for developer executables in the ',& + &' # next section, or even for specific executables as we will see below ',& + &' # (Then fpm will still fetch and compile it when building your ',& + &' # developer executables, but users of your library will not have to). ',& + &' # ',& + &' ## GLOBAL DEPENDENCIES (exported with your project) ',& + &' # ',& + &' # Typically, dependencies are defined by specifying the project''s ',& + &' # git repository. ',& + &' # ',& + &' # You can be specific about which version of a dependency you would ',& + &' # like. By default the latest default branch is used. You can ',& + &' # optionally specify a branch, a tag or a commit value. ',& + &' # ',& + &' # So here are several alternates for specifying a remote dependency (you ',& + &' # can have at most one of "branch", "rev" or "tag" present): ',& + &' ',& + &'#stdlib = { git = "https://github.com/LKedward/stdlib-fpm.git" } ',& + &'#stdlib = {git="https://github.com/LKedward/stdlib-fpm.git",branch = "master" },',& + &'#stdlib = {git="https://github.com/LKedward/stdlib-fpm.git", tag = "v0.1.0" }, ',& + &'#stdlib = {git="https://github.com/LKedward/stdlib-fpm.git", rev = "5a9b7a8" }. ',& + &' ',& + &' # There may be multiple packages listed: ',& + &' ',& + &'#M_strings = { git = "https://github.com/urbanjost/M_strings.git" } ',& + &'#M_time = { git = "https://github.com/urbanjost/M_time.git" } ',& + &' ',& + &' # ',& + &' # You can even specify the local path to another project if it is in ',& + &' # a sub-folder (If for example you have got another fpm package **in ',& + &' # the same repository**) like this: ',& + &' ',& + &'#M_strings = { path = "M_strings" } ',& + &' ',& + &' # This tells fpm that we depend on a crate called M_strings which is found ',& + &' # in the M_strings folder (relative to the fpm.toml it’s written in). ',& + &' # ',& + &' # For a more verbose layout use normal tables rather than inline tables ',& + &' # to specify dependencies: ',& + &' ',& + &'#[dependencies.toml-f] ',& + &'#git = "https://github.com/toml-f/toml-f" ',& + &'#rev = "2f5eaba864ff630ba0c3791126a3f811b6e437f3" ',& + &' ',& + &' # Now you can use any modules from these libraries anywhere in your ',& + &' # code -- whether is in your library source or a program source. ',& + &' ',& + &'[dev-dependencies] ',& + &' ',& + &' ## Dependencies Only for Development ',& + &' # ',& + &' # You can specify dependencies your library or application does not ',& + &' # depend on in a similar way. The difference is that these will not ',& + &' # be exported as part of your project to those using it as a remote ',& + &' # dependency. ',& + &' # ',& + &' # Currently, like a global dependency it will still be available for ',& + &' # all codes. It is up to the developer to ensure that nothing except ',& + &' # developer test programs rely upon it. ',& + &' ',& + &'#M_msg = { git = "https://github.com/urbanjost/M_msg.git" } ',& + &'#M_verify = { git = "https://github.com/urbanjost/M_verify.git" } ',& + &''] + end if + if (settings%with_bare) then + elseif (settings%with_executable) then + ! create next section of fpm.toml + call mkdir(join_path(settings%name, 'app')) + ! create NAME/app or stop + if (settings%with_full) then + tomlfile = [character(len=80) :: tomlfile, & + &' #----------------------------------- ',& + &' ## Application-specific declarations ',& + &' #----------------------------------- ',& + &' # Now lets begin entries for the TOML tables (lines beginning with "[[") ',& + &' # that describe the program sources -- applications, tests, and examples. ',& &' # ',& - &' # You can be specific about which version of a dependency you would ',& - &' # like. By default the latest default branch is used. You can ',& - &' # optionally specify a branch, a tag or a commit value. ',& + &' # First we will configuration individual applications run with "fpm run". ',& &' # ',& - &' # So here are several alternates for specifying a remote dependency (you ',& - &' # can have at most one of "branch", "rev" or "tag" present): ',& - &' ',& - &'#stdlib = { git = "https://github.com/LKedward/stdlib-fpm.git" } ',& - &'#stdlib = {git="https://github.com/LKedward/stdlib-fpm.git",branch = "master" },',& - &'#stdlib = {git="https://github.com/LKedward/stdlib-fpm.git", tag = "v0.1.0" }, ',& - &'#stdlib = {git="https://github.com/LKedward/stdlib-fpm.git", rev = "5a9b7a8" }. ',& - &' ',& - &' # There may be multiple packages listed: ',& - &' ',& - &'#M_strings = { git = "https://github.com/urbanjost/M_strings.git" } ',& - &'#M_time = { git = "https://github.com/urbanjost/M_time.git" } ',& - &' ',& - &' # ',& - &' # You can even specify the local path to another project if it is in ',& - &' # a sub-folder (If for example you have got another fpm package **in ',& - &' # the same repository**) like this: ',& - &' ',& - &'#M_strings = { path = "M_strings" } ',& - &' ',& - &' # This tells fpm that we depend on a crate called M_strings which is found ',& - &' # in the M_strings folder (relative to the fpm.toml it’s written in). ',& - &' # ',& - &' # For a more verbose layout use normal tables rather than inline tables ',& - &' # to specify dependencies: ',& - &' ',& - &'#[dependencies.toml-f] ',& - &'#git = "https://github.com/toml-f/toml-f" ',& - &'#rev = "2f5eaba864ff630ba0c3791126a3f811b6e437f3" ',& - &' ',& - &' # Now you can use any modules from these libraries anywhere in your ',& - &' # code -- whether is in your library source or a program source. ',& - &' ',& - &'[dev-dependencies] ',& - &' ',& - &' ## Dependencies Only for Development ',& + &' # + the "name" entry for the executable to be built must always ',& + &' # be specified. The name must satisfy the rules for a Fortran ',& + &' # variable name. This will be the name of the binary installed by ',& + &' # the "install" subcommand and used on the "run" subcommand. ',& + &' # + The source directory for each executable can be adjusted by the ',& + &' # "source-dir" entry. ',& + &' # + The basename of the source file containing the program body can ',& + &' # be specified with the "main" entry. ',& + &' # + Executables can also specify their own external package and ',& + &' # library link dependencies. ',& &' # ',& - &' # You can specify dependencies your library or application does not ',& - &' # depend on in a similar way. The difference is that these will not ',& - &' # be exported as part of your project to those using it as a remote ',& - &' # dependency. ',& + &' # Currently, like a global dependency any external package dependency ',& + &' # will be available for all codes. It is up to the developer to ensure ',& + &' # that nothing except the application programs specified rely upon it. ',& &' # ',& - &' # Currently, like a global dependency it will still be available for ',& - &' # all codes. It is up to the developer to ensure that nothing except ',& - &' # developer test programs rely upon it. ',& - &' ',& - &'#M_msg = { git = "https://github.com/urbanjost/M_msg.git" } ',& - &'#M_verify = { git = "https://github.com/urbanjost/M_verify.git" } ',& + &' # Note if your application needs to use a module internally, but you do not ',& + &' # intend to build it as a library to be used in other projects, you can ',& + &' # include the module in your program source file or directory as well. ',& + &' ',& + &'[[executable]] ',& + &'name="'//bname//'"',& + &'source-dir="app" ',& + &'main="main.f90" ',& + &' ',& + &' # You may repeat this pattern to define additional applications. For instance,',& + &' # the following sample illustrates all accepted options, where "link" and ',& + &' # "executable.dependencies" keys are the same as the global external library ',& + &' # links and package dependencies described previously except they apply ',& + &' # only to this executable: ',& + &' ',& + &'#[[ executable ]] ',& + &'#name = "app-name" ',& + &'#source-dir = "prog" ',& + &'#main = "program.f90" ',& + &'#link = "z" ',& + &'#[executable.dependencies] ',& + &'#M_CLI = { git = "https://github.com/urbanjost/M_CLI.git" } ',& + &'#helloff = { git = "https://gitlab.com/everythingfunctional/helloff.git" } ',& + &'#M_path = { git = "https://github.com/urbanjost/M_path.git" } ',& &''] - endif - if(settings%with_bare)then - elseif(settings%with_executable)then - ! create next section of fpm.toml - call mkdir(join_path(settings%name, 'app')) - ! create NAME/app or stop - if(settings%with_full)then - tomlfile=[character(len=80) :: tomlfile, & - &' #----------------------------------- ',& - &' ## Application-specific declarations ',& - &' #----------------------------------- ',& - &' # Now lets begin entries for the TOML tables (lines beginning with "[[") ',& - &' # that describe the program sources -- applications, tests, and examples. ',& - &' # ',& - &' # First we will configuration individual applications run with "fpm run". ',& - &' # ',& - &' # + the "name" entry for the executable to be built must always ',& - &' # be specified. The name must satisfy the rules for a Fortran ',& - &' # variable name. This will be the name of the binary installed by ',& - &' # the "install" subcommand and used on the "run" subcommand. ',& - &' # + The source directory for each executable can be adjusted by the ',& - &' # "source-dir" entry. ',& - &' # + The basename of the source file containing the program body can ',& - &' # be specified with the "main" entry. ',& - &' # + Executables can also specify their own external package and ',& - &' # library link dependencies. ',& - &' # ',& - &' # Currently, like a global dependency any external package dependency ',& - &' # will be available for all codes. It is up to the developer to ensure ',& - &' # that nothing except the application programs specified rely upon it. ',& - &' # ',& - &' # Note if your application needs to use a module internally, but you do not ',& - &' # intend to build it as a library to be used in other projects, you can ',& - &' # include the module in your program source file or directory as well. ',& - &' ',& - &'[[executable]] ',& - &'name="'//bname//'"',& - &'source-dir="app" ',& - &'main="main.f90" ',& - &' ',& - &' # You may repeat this pattern to define additional applications. For instance,',& - &' # the following sample illustrates all accepted options, where "link" and ',& - &' # "executable.dependencies" keys are the same as the global external library ',& - &' # links and package dependencies described previously except they apply ',& - &' # only to this executable: ',& - &' ',& - &'#[[ executable ]] ',& - &'#name = "app-name" ',& - &'#source-dir = "prog" ',& - &'#main = "program.f90" ',& - &'#link = "z" ',& - &'#[executable.dependencies] ',& - &'#M_CLI = { git = "https://github.com/urbanjost/M_CLI.git" } ',& - &'#helloff = { git = "https://gitlab.com/everythingfunctional/helloff.git" } ',& - &'#M_path = { git = "https://github.com/urbanjost/M_path.git" } ',& - &''] - endif + end if - if(exists(bname//'/src/'))then - littlefile=[character(len=80) :: & - &'program main', & - &' use '//to_fortran_name(bname)//', only: say_hello', & - &' implicit none', & - &'', & - &' call say_hello()', & - &'end program main'] - else - littlefile=[character(len=80) :: & - &'program main', & - &' implicit none', & - &'', & - &' print *, "hello from project '//bname//'"', & - &'end program main'] - endif - call warnwrite(join_path(settings%name, 'app/main.f90'), littlefile) - endif + if (exists(bname//'/src/')) then + littlefile = [character(len=80) :: & + &'program main', & + &' use '//to_fortran_name(bname)//', only: say_hello', & + &' implicit none', & + &'', & + &' call say_hello()', & + &'end program main'] + else + littlefile = [character(len=80) :: & + &'program main', & + &' implicit none', & + &'', & + &' print *, "hello from project '//bname//'"', & + &'end program main'] + end if + call warnwrite(join_path(settings%name, 'app/main.f90'), littlefile) + end if - if(settings%with_bare)then - elseif(settings%with_test)then + if (settings%with_bare) then + elseif (settings%with_test) then - ! create NAME/test or stop - call mkdir(join_path(settings%name, 'test')) - ! create next section of fpm.toml - if(settings%with_full)then - tomlfile=[character(len=80) :: tomlfile ,& - &'[[test]] ',& - &' ',& - &' # The same declarations can be made for test programs, which are ',& - &' # executed with the "fpm test" command and are not build when your ',& - &' # package is used as a dependency by other packages. These are ',& - &' # typically unit tests of the package only used during package ',& - &' # development. ',& - &' ',& - &'name="runTests" ',& - &'source-dir="test" ',& - &'main="check.f90" ',& - &' ',& - &' # you may repeat this pattern to add additional explicit test program ',& - &' # parameters. The following example contains a sample of all accepted ',& - &' # options. ',& - &' ',& - &'#[[ test ]] ',& - &'#name = "tester" ',& - &'#source-dir="test" ',& - &'#main="tester.f90" ',& - &'#link = ["blas", "lapack"] ',& - &'#[test.dependencies] ',& - &'#M_CLI2 = { git = "https://github.com/urbanjost/M_CLI2.git" } ',& - &'#M_io = { git = "https://github.com/urbanjost/M_io.git" } ',& - &'#M_system= { git = "https://github.com/urbanjost/M_system.git" } ',& - &''] - endif + ! create NAME/test or stop + call mkdir(join_path(settings%name, 'test')) + ! create next section of fpm.toml + if (settings%with_full) then + tomlfile = [character(len=80) :: tomlfile,& + &'[[test]] ',& + &' ',& + &' # The same declarations can be made for test programs, which are ',& + &' # executed with the "fpm test" command and are not build when your ',& + &' # package is used as a dependency by other packages. These are ',& + &' # typically unit tests of the package only used during package ',& + &' # development. ',& + &' ',& + &'name="runTests" ',& + &'source-dir="test" ',& + &'main="check.f90" ',& + &' ',& + &' # you may repeat this pattern to add additional explicit test program ',& + &' # parameters. The following example contains a sample of all accepted ',& + &' # options. ',& + &' ',& + &'#[[ test ]] ',& + &'#name = "tester" ',& + &'#source-dir="test" ',& + &'#main="tester.f90" ',& + &'#link = ["blas", "lapack"] ',& + &'#[test.dependencies] ',& + &'#M_CLI2 = { git = "https://github.com/urbanjost/M_CLI2.git" } ',& + &'#M_io = { git = "https://github.com/urbanjost/M_io.git" } ',& + &'#M_system= { git = "https://github.com/urbanjost/M_system.git" } ',& + &''] + end if - littlefile=[character(len=80) :: & - &'program check', & - &'implicit none', & - &'', & - &'print *, "Put some tests in here!"', & - &'end program check'] - ! create NAME/test/check.f90 - call warnwrite(join_path(settings%name, 'test/check.f90'), littlefile) - endif + littlefile = [character(len=80) :: & + &'program check', & + &'implicit none', & + &'', & + &'print *, "Put some tests in here!"', & + &'end program check'] + ! create NAME/test/check.f90 + call warnwrite(join_path(settings%name, 'test/check.f90'), littlefile) + end if - if(settings%with_bare)then - elseif(settings%with_example)then + if (settings%with_bare) then + elseif (settings%with_example) then - ! create NAME/example or stop - call mkdir(join_path(settings%name, 'example')) - ! create next section of fpm.toml - if(settings%with_full)then - tomlfile=[character(len=80) :: tomlfile, & - &'[[example]] ',& - &' ',& - &' # Example applications for a project are defined here. ',& - &' # These are run via "fpm run --example NAME" and like the ',& - &' # test applications, are not built when this package is used as a ',& - &' # dependency by other packages. ',& - &' ',& - &'name="demo" ',& - &'source-dir="example" ',& - &'main="demo.f90" ',& - &' ',& - &' # ',& - &' # you may add additional programs to the example table. The following ',& - &' # example contains a sample of all accepted options ',& - &' ',& - &'#[[ example ]] ',& - &'#name = "example-tool" ',& - &'#source-dir="example" ',& - &'#main="tool.f90" ',& - &'#link = "z" ',& - &'#[example.dependencies] ',& - &'#M_kracken95 = { git = "https://github.com/urbanjost/M_kracken95.git" } ',& - &'#datetime = {git = "https://github.com/wavebitscientific/datetime-fortran.git" }',& - &''] - endif + ! create NAME/example or stop + call mkdir(join_path(settings%name, 'example')) + ! create next section of fpm.toml + if (settings%with_full) then + tomlfile = [character(len=80) :: tomlfile, & + &'[[example]] ',& + &' ',& + &' # Example applications for a project are defined here. ',& + &' # These are run via "fpm run --example NAME" and like the ',& + &' # test applications, are not built when this package is used as a ',& + &' # dependency by other packages. ',& + &' ',& + &'name="demo" ',& + &'source-dir="example" ',& + &'main="demo.f90" ',& + &' ',& + &' # ',& + &' # you may add additional programs to the example table. The following ',& + &' # example contains a sample of all accepted options ',& + &' ',& + &'#[[ example ]] ',& + &'#name = "example-tool" ',& + &'#source-dir="example" ',& + &'#main="tool.f90" ',& + &'#link = "z" ',& + &'#[example.dependencies] ',& + &'#M_kracken95 = { git = "https://github.com/urbanjost/M_kracken95.git" } ',& + &'#datetime = {git = "https://github.com/wavebitscientific/datetime-fortran.git" }',& + &''] + end if - littlefile=[character(len=80) :: & - &'program demo', & - &'implicit none', & - &'', & - &'print *, "Put some examples in here!"', & - &'end program demo'] - ! create NAME/example/demo.f90 - call warnwrite(join_path(settings%name, 'example/demo.f90'), littlefile) - endif + littlefile = [character(len=80) :: & + &'program demo', & + &'implicit none', & + &'', & + &'print *, "Put some examples in here!"', & + &'end program demo'] + ! create NAME/example/demo.f90 + call warnwrite(join_path(settings%name, 'example/demo.f90'), littlefile) + end if ! now that built it write NAME/fpm.toml - if( allocated(tomlfile) )then - call validate_toml_data(tomlfile) - call warnwrite(join_path(settings%name, 'fpm.toml'), tomlfile) + if (allocated(tomlfile)) then + call validate_toml_data(tomlfile) + call warnwrite(join_path(settings%name, 'fpm.toml'), tomlfile) else - call create_verified_basic_manifest(join_path(settings%name, 'fpm.toml')) - endif + call create_verified_basic_manifest(join_path(settings%name, 'fpm.toml')) + end if ! assumes git(1) is installed and in path - if(which('git')/='')then - call run('git init ' // settings%name) - endif -contains + if (which('git') /= '') then + call run('git init '//settings%name) + end if + contains -function git_metadata(what) result(returned) + function git_metadata(what) result(returned) !> get metadata values such as email address and git name from git(1) or return appropriate default - use fpm_filesystem, only : get_temp_filename, getline - character(len=*), intent(in) :: what ! keyword designating what git metatdata to query - character(len=:), allocatable :: returned ! value to return for requested keyword - character(len=:), allocatable :: command - character(len=:), allocatable :: temp_filename - character(len=:), allocatable :: iomsg - character(len=:), allocatable :: temp_value - integer :: stat, unit - temp_filename = get_temp_filename() - ! for known keywords set default value for RETURNED and associated git(1) command for query - select case(what) - case('uname') - returned = "Jane Doe" - command = "git config --get user.name > " // temp_filename - case('email') - returned = "jane.doe@example.com" - command = "git config --get user.email > " // temp_filename - case default - write(stderr,'(*(g0,1x))')& - & ' *git_metadata* unknown metadata name ',trim(what) - returned='' - return - end select - ! Execute command if git(1) is in command path - if(which('git')/='')then - call run(command, exitstat=stat) - if (stat /= 0) then ! If command failed just return default + use fpm_filesystem, only: get_temp_filename, getline + character(len=*), intent(in) :: what ! keyword designating what git metatdata to query + character(len=:), allocatable :: returned ! value to return for requested keyword + character(len=:), allocatable :: command + character(len=:), allocatable :: temp_filename + character(len=:), allocatable :: iomsg + character(len=:), allocatable :: temp_value + integer :: stat, unit + temp_filename = get_temp_filename() + ! for known keywords set default value for RETURNED and associated git(1) command for query + select case (what) + case ('uname') + returned = "Jane Doe" + command = "git config --get user.name > "//temp_filename + case ('email') + returned = "jane.doe@example.com" + command = "git config --get user.email > "//temp_filename + case default + write (stderr, '(*(g0,1x))')& + & ' *git_metadata* unknown metadata name ', trim(what) + returned = '' return - else ! Command did not return an error so try to read expected output file - open(file=temp_filename, newunit=unit,iostat=stat) - if(stat == 0)then - ! Read file into a scratch variable until status of doing so is checked - call getline(unit, temp_value, stat, iomsg) - if (stat == 0 .and. temp_value /= '') then + end select + ! Execute command if git(1) is in command path + if (which('git') /= '') then + call run(command, exitstat=stat) + if (stat /= 0) then ! If command failed just return default + return + else ! Command did not return an error so try to read expected output file + open (file=temp_filename, newunit=unit, iostat=stat) + if (stat == 0) then + ! Read file into a scratch variable until status of doing so is checked + call getline(unit, temp_value, stat, iomsg) + if (stat == 0 .and. temp_value /= '') then ! Return output from successful command - returned=temp_value - endif - endif - ! Always do the CLOSE because a failed open has unpredictable results. - ! Add IOSTAT so a failed close does not cause program to stop - close(unit, status="delete",iostat=stat) - endif - endif -end function git_metadata + returned = temp_value + end if + end if + ! Always do the CLOSE because a failed open has unpredictable results. + ! Add IOSTAT so a failed close does not cause program to stop + close (unit, status="delete", iostat=stat) + end if + end if + end function git_metadata -subroutine create_verified_basic_manifest(filename) + subroutine create_verified_basic_manifest(filename) !> create a basic but verified default manifest file -use fpm_toml, only : toml_table, toml_serializer, set_value -use fpm_manifest_package, only : package_config_t, new_package -use fpm_error, only : error_t -implicit none -character(len=*),intent(in) :: filename - type(toml_table) :: table - type(toml_serializer) :: ser - type(package_config_t) :: package - type(error_t), allocatable :: error - integer :: lun - character(len=8) :: date + use fpm_toml, only: toml_table, toml_serializer, set_value + use fpm_manifest_package, only: package_config_t, new_package + use fpm_error, only: error_t + implicit none + character(len=*), intent(in) :: filename + type(toml_table) :: table + type(toml_serializer) :: ser + type(package_config_t) :: package + type(error_t), allocatable :: error + integer :: lun + character(len=8) :: date - if(exists(filename))then - write(stderr,'(*(g0,1x))')' ',filename,& - & 'already exists. Not overwriting' - return - endif - !> get date to put into metadata in manifest file "fpm.toml" - call date_and_time(DATE=date) - table = toml_table() - ser = toml_serializer() - call fileopen(filename,lun) ! fileopen stops on error - - call set_value(table, "name", BNAME) - call set_value(table, "version", "0.1.0") - call set_value(table, "license", "license") - call set_value(table, "author", git_metadata('uname')) - call set_value(table, "maintainer", git_metadata('email')) - call set_value(table, "copyright", 'Copyright '//date(1:4)//', '//git_metadata('uname')) - ! continue building of manifest - ! ... - call new_package(package, table, error=error) - if (allocated(error)) call fpm_stop( 3,'') - if(settings%verbose)then - call table%accept(ser) - endif - ser%unit=lun - call table%accept(ser) - call fileclose(lun) ! fileopen stops on error + if (exists(filename)) then + write (stderr, '(*(g0,1x))') ' ', filename,& + & 'already exists. Not overwriting' + return + end if + !> get date to put into metadata in manifest file "fpm.toml" + call date_and_time(DATE=date) + table = toml_table() + ser = toml_serializer() + call fileopen(filename, lun) ! fileopen stops on error -end subroutine create_verified_basic_manifest + call set_value(table, "name", BNAME) + call set_value(table, "version", "0.1.0") + call set_value(table, "license", "license") + call set_value(table, "author", git_metadata('uname')) + call set_value(table, "maintainer", git_metadata('email')) + call set_value(table, "copyright", 'Copyright '//date(1:4)//', '//git_metadata('uname')) + ! continue building of manifest + ! ... + call new_package(package, table, error=error) + if (allocated(error)) call fpm_stop(3, '') + if (settings%verbose) then + call table%accept(ser) + end if + ser%unit = lun + call table%accept(ser) + call fileclose(lun) ! fileopen stops on error + end subroutine create_verified_basic_manifest -subroutine validate_toml_data(input) + subroutine validate_toml_data(input) !> verify a string array is a valid fpm.toml file ! -use tomlf, only : toml_parse -use fpm_toml, only : toml_table, toml_serializer -implicit none -character(kind=tfc,len=:),intent(in),allocatable :: input(:) -character(len=1), parameter :: nl = new_line('a') -type(toml_table), allocatable :: table -character(kind=tfc, len=:), allocatable :: joined_string -type(toml_serializer) :: ser + use tomlf, only: toml_parse + use fpm_toml, only: toml_table, toml_serializer + implicit none + character(kind=tfc, len=:), intent(in), allocatable :: input(:) + character(len=1), parameter :: nl = new_line('a') + type(toml_table), allocatable :: table + character(kind=tfc, len=:), allocatable :: joined_string + type(toml_serializer) :: ser ! you have to add a newline character by using the intrinsic ! function `new_line("a")` to get the lines processed correctly. -joined_string = join(input,right=nl) + joined_string = join(input, right=nl) -if (allocated(table)) deallocate(table) -call toml_parse(table, joined_string) -if (allocated(table)) then - if(settings%verbose)then - ! If the TOML file is successfully parsed the table will be allocated and - ! can be written to the standard output by passing the `toml_serializer` - ! as visitor to the table. - call table%accept(ser) - endif - call table%destroy -endif + if (allocated(table)) deallocate (table) + call toml_parse(table, joined_string) + if (allocated(table)) then + if (settings%verbose) then + ! If the TOML file is successfully parsed the table will be allocated and + ! can be written to the standard output by passing the `toml_serializer` + ! as visitor to the table. + call table%accept(ser) + end if + call table%destroy + end if -end subroutine validate_toml_data + end subroutine validate_toml_data -end subroutine cmd_new + end subroutine cmd_new end module fpm_cmd_new diff --git a/src/fpm/cmd/update.f90 b/src/fpm/cmd/update.f90 index a9918bf7ac..d26f6bdf87 100644 --- a/src/fpm/cmd/update.f90 +++ b/src/fpm/cmd/update.f90 @@ -1,9 +1,9 @@ module fpm_cmd_update - use fpm_command_line, only : fpm_update_settings - use fpm_dependency, only : dependency_tree_t, new_dependency_tree - use fpm_error, only : error_t, fpm_stop - use fpm_filesystem, only : exists, mkdir, join_path, delete_file, filewrite - use fpm_manifest, only : package_config_t, get_package_data + use fpm_command_line, only: fpm_update_settings + use fpm_dependency, only: dependency_tree_t, new_dependency_tree + use fpm_error, only: error_t, fpm_stop + use fpm_filesystem, only: exists, mkdir, join_path, delete_file, filewrite + use fpm_manifest, only: package_config_t, get_package_data implicit none private public :: cmd_update @@ -24,9 +24,9 @@ subroutine cmd_update(settings) call get_package_data(package, "fpm.toml", error, apply_defaults=.true.) call handle_error(error) - if (.not.exists("build")) then + if (.not. exists("build")) then call mkdir("build") - call filewrite(join_path("build", ".gitignore"),["*"]) + call filewrite(join_path("build", ".gitignore"), ["*"]) end if cache = join_path("build", "cache.toml") @@ -35,7 +35,7 @@ subroutine cmd_update(settings) end if call new_dependency_tree(deps, cache=cache, & - verbosity=merge(2, 1, settings%verbose)) + verbosity=merge(2, 1, settings%verbose)) call deps%add(package, error) call handle_error(error) diff --git a/src/fpm/dependency.f90 b/src/fpm/dependency.f90 index bd85b6f014..80aefde2f3 100644 --- a/src/fpm/dependency.f90 +++ b/src/fpm/dependency.f90 @@ -55,17 +55,17 @@ !> !> Currenly ignored. First come, first serve. module fpm_dependency - use, intrinsic :: iso_fortran_env, only : output_unit - use fpm_environment, only : get_os_type, OS_WINDOWS - use fpm_error, only : error_t, fatal_error - use fpm_filesystem, only : exists, join_path, mkdir, canon_path, windows_path - use fpm_git, only : git_target_revision, git_target_default, git_revision - use fpm_manifest, only : package_config_t, dependency_config_t, & - get_package_data - use fpm_strings, only : string_t, operator(.in.) - use fpm_toml, only : toml_table, toml_key, toml_error, toml_serializer, & - toml_parse, get_value, set_value, add_table - use fpm_versioning, only : version_t, new_version, char + use, intrinsic :: iso_fortran_env, only: output_unit + use fpm_environment, only: get_os_type, OS_WINDOWS + use fpm_error, only: error_t, fatal_error + use fpm_filesystem, only: exists, join_path, mkdir, canon_path, windows_path + use fpm_git, only: git_target_revision, git_target_default, git_revision + use fpm_manifest, only: package_config_t, dependency_config_t, & + get_package_data + use fpm_strings, only: string_t, operator(.in.) + use fpm_toml, only: toml_table, toml_key, toml_error, toml_serializer, & + toml_parse, get_value, set_value, add_table + use fpm_versioning, only: version_t, new_version, char implicit none private @@ -73,13 +73,11 @@ module fpm_dependency public :: dependency_node_t, new_dependency_node public :: resize - !> Overloaded reallocation interface interface resize module procedure :: resize_dependency_node end interface resize - !> Dependency node in the projects dependency tree type, extends(dependency_config_t) :: dependency_node_t !> Actual version of this dependency @@ -97,7 +95,6 @@ module fpm_dependency procedure :: register end type dependency_node_t - !> Respresentation of a projects dependencies !> !> The dependencies are stored in a simple array for now, this can be replaced @@ -239,7 +236,7 @@ subroutine add_project(self, package, error) if (allocated(error)) return end if - if (.not.exists(self%dep_dir)) then + if (.not. exists(self%dep_dir)) then call mkdir(self%dep_dir) end if @@ -260,9 +257,9 @@ subroutine add_project(self, package, error) if (allocated(error)) return ! Now decent into the dependency tree, level for level - do while(.not.self%finished()) - call self%resolve(root, error) - if (allocated(error)) exit + do while (.not. self%finished()) + call self%resolve(root, error) + if (allocated(error)) exit end do if (allocated(error)) return @@ -395,10 +392,10 @@ subroutine update_dependency(self, name, error) return end if - associate(dep => self%dep(id)) + associate (dep => self%dep(id)) if (allocated(dep%git) .and. dep%update) then if (self%verbosity > 1) then - write(self%unit, out_fmt) "Update:", dep%name + write (self%unit, out_fmt) "Update:", dep%name end if proj_dir = join_path(self%dep_dir, dep%name) call dep%git%checkout(proj_dir, error) @@ -409,7 +406,7 @@ subroutine update_dependency(self, name, error) dep%update = .false. ! Now decent into the dependency tree, level for level - do while(.not.self%finished()) + do while (.not. self%finished()) call self%resolve(root, error) if (allocated(error)) exit end do @@ -464,7 +461,7 @@ subroutine resolve_dependency(self, dependency, root, error) proj_dir = join_path(root, dependency%path) else if (allocated(dependency%git)) then proj_dir = join_path(self%dep_dir, dependency%name) - fetch = .not.exists(proj_dir) + fetch = .not. exists(proj_dir) if (fetch) then call dependency%git%checkout(proj_dir, error) if (allocated(error)) return @@ -486,7 +483,7 @@ subroutine resolve_dependency(self, dependency, root, error) if (allocated(error)) return if (self%verbosity > 1) then - write(self%unit, out_fmt) & + write (self%unit, out_fmt) & "Dep:", dependency%name, "version", char(dependency%version), & "at", dependency%proj_dir end if @@ -567,12 +564,12 @@ subroutine register(self, package, root, fetch, revision, error) self%version = package%version self%proj_dir = root - if (allocated(self%git).and.present(revision)) then + if (allocated(self%git) .and. present(revision)) then self%revision = revision - if (.not.fetch) then + if (.not. fetch) then ! git object is HEAD always allows an update - update = .not.allocated(self%git%object) - if (.not.update) then + update = .not. allocated(self%git%object) + if (.not. update) then ! allow update in case the revision does not match the requested object update = revision /= self%git%object end if @@ -596,12 +593,12 @@ subroutine load_from_file(self, file, error) integer :: unit logical :: exist - inquire(file=file, exist=exist) - if (.not.exist) return + inquire (file=file, exist=exist) + if (.not. exist) return - open(file=file, newunit=unit) + open (file=file, newunit=unit) call self%load(unit, error) - close(unit) + close (unit) end subroutine load_from_file !> Read dependency tree from file @@ -619,7 +616,7 @@ subroutine load_from_unit(self, unit, error) call toml_parse(table, unit, parse_error) if (allocated(parse_error)) then - allocate(error) + allocate (error) call move_alloc(parse_error%message, error%message) return end if @@ -660,9 +657,9 @@ subroutine load_from_toml(self, table, error) call get_value(ptr, "git", url) call get_value(ptr, "obj", obj) call get_value(ptr, "rev", rev) - if (.not.allocated(proj_dir)) cycle + if (.not. allocated(proj_dir)) cycle self%ndep = self%ndep + 1 - associate(dep => self%dep(self%ndep)) + associate (dep => self%dep(self%ndep)) dep%name = list(ii)%key if (unix) then dep%proj_dir = proj_dir @@ -671,7 +668,7 @@ subroutine load_from_toml(self, table, error) end if dep%done = .false. if (allocated(version)) then - if (.not.allocated(dep%version)) allocate(dep%version) + if (.not. allocated(dep%version)) allocate (dep%version) call new_version(dep%version, version, error) if (allocated(error)) exit end if @@ -709,9 +706,9 @@ subroutine dump_to_file(self, file, error) integer :: unit - open(file=file, newunit=unit) + open (file=file, newunit=unit) call self%dump(unit, error) - close(unit) + close (unit) if (allocated(error)) return end subroutine dump_to_file @@ -751,9 +748,9 @@ subroutine dump_to_toml(self, table, error) character(len=:), allocatable :: proj_dir do ii = 1, self%ndep - associate(dep => self%dep(ii)) + associate (dep => self%dep(ii)) call add_table(table, dep%name, ptr) - if (.not.associated(ptr)) then + if (.not. associated(ptr)) then call fatal_error(error, "Cannot create entry for "//dep%name) exit end if @@ -801,12 +798,12 @@ pure subroutine resize_dependency_node(var, n) new_size = this_size + this_size/2 + 1 end if - allocate(var(new_size)) + allocate (var(new_size)) if (allocated(tmp)) then this_size = min(size(tmp, 1), size(var, 1)) var(:this_size) = tmp(:this_size) - deallocate(tmp) + deallocate (tmp) end if end subroutine resize_dependency_node diff --git a/src/fpm/error.f90 b/src/fpm/error.f90 index 59cf5d4a99..ecc9e9c86a 100644 --- a/src/fpm/error.f90 +++ b/src/fpm/error.f90 @@ -1,179 +1,176 @@ !> Implementation of basic error handling. module fpm_error - use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, stderr=>error_unit - use fpm_strings, only : is_fortran_name, to_fortran_name - implicit none - private + use, intrinsic :: iso_fortran_env, only: stdin => input_unit, stdout => output_unit, stderr => error_unit + use fpm_strings, only: is_fortran_name, to_fortran_name + implicit none + private - public :: error_t - public :: fatal_error, syntax_error, file_not_found_error - public :: file_parse_error - public :: bad_name_error - public :: fpm_stop + public :: error_t + public :: fatal_error, syntax_error, file_not_found_error + public :: file_parse_error + public :: bad_name_error + public :: fpm_stop + !> Data type defining an error + type :: error_t - !> Data type defining an error - type :: error_t + !> Error message + character(len=:), allocatable :: message - !> Error message - character(len=:), allocatable :: message - - end type error_t + end type error_t contains - !> Generic fatal runtime error - subroutine fatal_error(error, message) - - !> Instance of the error data - type(error_t), allocatable, intent(out) :: error + !> Generic fatal runtime error + subroutine fatal_error(error, message) - !> Error message - character(len=*), intent(in) :: message + !> Instance of the error data + type(error_t), allocatable, intent(out) :: error - allocate(error) - error%message = message + !> Error message + character(len=*), intent(in) :: message - end subroutine fatal_error + allocate (error) + error%message = message - subroutine syntax_error(error, message) + end subroutine fatal_error - !> Instance of the error data - type(error_t), allocatable, intent(out) :: error + subroutine syntax_error(error, message) - !> Error message - character(len=*), intent(in) :: message + !> Instance of the error data + type(error_t), allocatable, intent(out) :: error - allocate(error) - error%message = message + !> Error message + character(len=*), intent(in) :: message - end subroutine syntax_error + allocate (error) + error%message = message - function bad_name_error(error, label,name) + end subroutine syntax_error - !> Instance of the error data - type(error_t), allocatable, intent(out) :: error + function bad_name_error(error, label, name) - !> Error message label to add to message - character(len=*), intent(in) :: label + !> Instance of the error data + type(error_t), allocatable, intent(out) :: error - !> name value to check - character(len=*), intent(in) :: name + !> Error message label to add to message + character(len=*), intent(in) :: label - logical :: bad_name_error + !> name value to check + character(len=*), intent(in) :: name - if(.not.is_fortran_name(to_fortran_name(name)))then - bad_name_error=.true. - allocate(error) - error%message = 'manifest file syntax error: '//label//' name must be composed only of & - &alphanumerics, "-" and "_" and start with a letter ::'//name - else - bad_name_error=.false. - endif + logical :: bad_name_error - end function bad_name_error + if (.not. is_fortran_name(to_fortran_name(name))) then + bad_name_error = .true. + allocate (error) + error%message = 'manifest file syntax error: '//label//' name must be composed only of & + &alphanumerics, "-" and "_" and start with a letter ::'//name + else + bad_name_error = .false. + end if + end function bad_name_error - !> Error created when a file is missing or not found - subroutine file_not_found_error(error, file_name) + !> Error created when a file is missing or not found + subroutine file_not_found_error(error, file_name) - !> Instance of the error data - type(error_t), allocatable, intent(out) :: error + !> Instance of the error data + type(error_t), allocatable, intent(out) :: error - !> Name of the missing file - character(len=*), intent(in) :: file_name + !> Name of the missing file + character(len=*), intent(in) :: file_name - allocate(error) - error%message = "'"//file_name//"' could not be found, check if the file exists" + allocate (error) + error%message = "'"//file_name//"' could not be found, check if the file exists" - end subroutine file_not_found_error + end subroutine file_not_found_error + !> Error created when file parsing fails + subroutine file_parse_error(error, file_name, message, line_num, & + line_string, line_col) - !> Error created when file parsing fails - subroutine file_parse_error(error, file_name, message, line_num, & - line_string, line_col) + !> Instance of the error data + type(error_t), allocatable, intent(out) :: error - !> Instance of the error data - type(error_t), allocatable, intent(out) :: error + !> Name of file + character(len=*), intent(in) :: file_name - !> Name of file - character(len=*), intent(in) :: file_name + !> Parse error message + character(len=*), intent(in) :: message - !> Parse error message - character(len=*), intent(in) :: message + !> Line number of parse error + integer, intent(in), optional :: line_num - !> Line number of parse error - integer, intent(in), optional :: line_num + !> Line context string + character(len=*), intent(in), optional :: line_string - !> Line context string - character(len=*), intent(in), optional :: line_string + !> Line context column + integer, intent(in), optional :: line_col - !> Line context column - integer, intent(in), optional :: line_col + character(50) :: temp_string - character(50) :: temp_string + allocate (error) + error%message = 'Parse error: '//message//new_line('a') - allocate(error) - error%message = 'Parse error: '//message//new_line('a') + error%message = error%message//file_name - error%message = error%message//file_name + if (present(line_num)) then - if (present(line_num)) then + write (temp_string, '(I0)') line_num - write(temp_string,'(I0)') line_num + error%message = error%message//':'//trim(temp_string) - error%message = error%message//':'//trim(temp_string) + end if - end if + if (present(line_col)) then - if (present(line_col)) then + if (line_col > 0) then - if (line_col > 0) then + write (temp_string, '(I0)') line_col + error%message = error%message//':'//trim(temp_string) - write(temp_string,'(I0)') line_col - error%message = error%message//':'//trim(temp_string) + end if - end if + end if - end if + if (present(line_string)) then - if (present(line_string)) then + error%message = error%message//new_line('a') + error%message = error%message//' | '//line_string - error%message = error%message//new_line('a') - error%message = error%message//' | '//line_string + if (present(line_col)) then - if (present(line_col)) then + if (line_col > 0) then - if (line_col > 0) then + error%message = error%message//new_line('a') + error%message = error%message//' | '//repeat(' ', line_col - 1)//'^' - error%message = error%message//new_line('a') - error%message = error%message//' | '//repeat(' ',line_col-1)//'^' - - end if + end if - end if + end if - end if + end if - end subroutine file_parse_error + end subroutine file_parse_error - subroutine fpm_stop(value,message) + subroutine fpm_stop(value, message) ! TODO: if verbose mode, call ERROR STOP instead of STOP ! TODO: if M_escape is used, add color ! to work with older compilers might need a case statement for values - !> value to use on STOP - integer, intent(in) :: value - !> Error message - character(len=*), intent(in) :: message - if(message/='')then - if(value>0)then - write(stderr,'("",a)')trim(message) - else - write(stderr,'(" ",a)')trim(message) - endif - endif - stop value - end subroutine fpm_stop + !> value to use on STOP + integer, intent(in) :: value + !> Error message + character(len=*), intent(in) :: message + if (message /= '') then + if (value > 0) then + write (stderr, '("",a)') trim(message) + else + write (stderr, '(" ",a)') trim(message) + end if + end if + stop value + end subroutine fpm_stop end module fpm_error diff --git a/src/fpm/git.f90 b/src/fpm/git.f90 index 46dcca3afa..51793108cd 100644 --- a/src/fpm/git.f90 +++ b/src/fpm/git.f90 @@ -1,265 +1,254 @@ !> Implementation for interacting with git repositories. module fpm_git - use fpm_error, only: error_t, fatal_error - use fpm_filesystem, only : get_temp_filename, getline, join_path - implicit none + use fpm_error, only: error_t, fatal_error + use fpm_filesystem, only: get_temp_filename, getline, join_path + implicit none - public :: git_target_t - public :: git_target_default, git_target_branch, git_target_tag, & - & git_target_revision - public :: git_revision + public :: git_target_t + public :: git_target_default, git_target_branch, git_target_tag, & + & git_target_revision + public :: git_revision + !> Possible git target + type :: enum_descriptor - !> Possible git target - type :: enum_descriptor - - !> Default target - integer :: default = 200 - - !> Branch in git repository - integer :: branch = 201 - - !> Tag in git repository - integer :: tag = 202 + !> Default target + integer :: default = 200 - !> Commit hash - integer :: revision = 203 + !> Branch in git repository + integer :: branch = 201 - end type enum_descriptor + !> Tag in git repository + integer :: tag = 202 - !> Actual enumerator for descriptors - type(enum_descriptor), parameter :: git_descriptor = enum_descriptor() + !> Commit hash + integer :: revision = 203 + end type enum_descriptor - !> Description of an git target - type :: git_target_t + !> Actual enumerator for descriptors + type(enum_descriptor), parameter :: git_descriptor = enum_descriptor() - !> Kind of the git target - integer, private :: descriptor = git_descriptor%default + !> Description of an git target + type :: git_target_t - !> Target URL of the git repository - character(len=:), allocatable :: url + !> Kind of the git target + integer, private :: descriptor = git_descriptor%default - !> Additional descriptor of the git object - character(len=:), allocatable :: object + !> Target URL of the git repository + character(len=:), allocatable :: url - contains + !> Additional descriptor of the git object + character(len=:), allocatable :: object - !> Fetch and checkout in local directory - procedure :: checkout + contains - !> Show information on instance - procedure :: info + !> Fetch and checkout in local directory + procedure :: checkout - end type git_target_t + !> Show information on instance + procedure :: info + end type git_target_t contains + !> Default target + function git_target_default(url) result(self) - !> Default target - function git_target_default(url) result(self) - - !> Target URL of the git repository - character(len=*), intent(in) :: url - - !> New git target - type(git_target_t) :: self - - self%descriptor = git_descriptor%default - self%url = url - - end function git_target_default - - - !> Target a branch in the git repository - function git_target_branch(url, branch) result(self) - - !> Target URL of the git repository - character(len=*), intent(in) :: url - - !> Name of the branch of interest - character(len=*), intent(in) :: branch - - !> New git target - type(git_target_t) :: self + !> Target URL of the git repository + character(len=*), intent(in) :: url - self%descriptor = git_descriptor%branch - self%url = url - self%object = branch + !> New git target + type(git_target_t) :: self - end function git_target_branch + self%descriptor = git_descriptor%default + self%url = url + end function git_target_default - !> Target a specific git revision - function git_target_revision(url, sha1) result(self) + !> Target a branch in the git repository + function git_target_branch(url, branch) result(self) - !> Target URL of the git repository - character(len=*), intent(in) :: url + !> Target URL of the git repository + character(len=*), intent(in) :: url - !> Commit hash of interest - character(len=*), intent(in) :: sha1 + !> Name of the branch of interest + character(len=*), intent(in) :: branch - !> New git target - type(git_target_t) :: self + !> New git target + type(git_target_t) :: self - self%descriptor = git_descriptor%revision - self%url = url - self%object = sha1 + self%descriptor = git_descriptor%branch + self%url = url + self%object = branch - end function git_target_revision + end function git_target_branch + !> Target a specific git revision + function git_target_revision(url, sha1) result(self) - !> Target a git tag - function git_target_tag(url, tag) result(self) + !> Target URL of the git repository + character(len=*), intent(in) :: url - !> Target URL of the git repository - character(len=*), intent(in) :: url + !> Commit hash of interest + character(len=*), intent(in) :: sha1 - !> Tag name of interest - character(len=*), intent(in) :: tag + !> New git target + type(git_target_t) :: self - !> New git target - type(git_target_t) :: self + self%descriptor = git_descriptor%revision + self%url = url + self%object = sha1 - self%descriptor = git_descriptor%tag - self%url = url - self%object = tag + end function git_target_revision - end function git_target_tag + !> Target a git tag + function git_target_tag(url, tag) result(self) + !> Target URL of the git repository + character(len=*), intent(in) :: url - subroutine checkout(self, local_path, error) + !> Tag name of interest + character(len=*), intent(in) :: tag - !> Instance of the git target - class(git_target_t), intent(in) :: self + !> New git target + type(git_target_t) :: self - !> Local path to checkout in - character(*), intent(in) :: local_path + self%descriptor = git_descriptor%tag + self%url = url + self%object = tag - !> Error - type(error_t), allocatable, intent(out) :: error + end function git_target_tag - integer :: stat - character(len=:), allocatable :: object, workdir + subroutine checkout(self, local_path, error) - if (allocated(self%object)) then - object = self%object - else - object = 'HEAD' - end if - workdir = "--work-tree="//local_path//" --git-dir="//join_path(local_path, ".git") + !> Instance of the git target + class(git_target_t), intent(in) :: self - call execute_command_line("git init "//local_path, exitstat=stat) + !> Local path to checkout in + character(*), intent(in) :: local_path - if (stat /= 0) then - call fatal_error(error,'Error while initiating git repository for remote dependency') - return - end if + !> Error + type(error_t), allocatable, intent(out) :: error - call execute_command_line("git "//workdir//" fetch --depth=1 "// & - self%url//" "//object, exitstat=stat) + integer :: stat + character(len=:), allocatable :: object, workdir - if (stat /= 0) then - call fatal_error(error,'Error while fetching git repository for remote dependency') - return - end if + if (allocated(self%object)) then + object = self%object + else + object = 'HEAD' + end if + workdir = "--work-tree="//local_path//" --git-dir="//join_path(local_path, ".git") - call execute_command_line("git "//workdir//" checkout -qf FETCH_HEAD", exitstat=stat) + call execute_command_line("git init "//local_path, exitstat=stat) - if (stat /= 0) then - call fatal_error(error,'Error while checking out git repository for remote dependency') - return - end if + if (stat /= 0) then + call fatal_error(error, 'Error while initiating git repository for remote dependency') + return + end if - end subroutine checkout + call execute_command_line("git "//workdir//" fetch --depth=1 "// & + self%url//" "//object, exitstat=stat) + if (stat /= 0) then + call fatal_error(error, 'Error while fetching git repository for remote dependency') + return + end if - subroutine git_revision(local_path, object, error) + call execute_command_line("git "//workdir//" checkout -qf FETCH_HEAD", exitstat=stat) - !> Local path to checkout in - character(*), intent(in) :: local_path + if (stat /= 0) then + call fatal_error(error, 'Error while checking out git repository for remote dependency') + return + end if - !> Git object reference - character(len=:), allocatable, intent(out) :: object + end subroutine checkout - !> Error - type(error_t), allocatable, intent(out) :: error + subroutine git_revision(local_path, object, error) - integer :: stat, unit, istart, iend - character(len=:), allocatable :: temp_file, line, iomsg, workdir - character(len=*), parameter :: hexdigits = '0123456789abcdef' + !> Local path to checkout in + character(*), intent(in) :: local_path - workdir = "--work-tree="//local_path//" --git-dir="//join_path(local_path, ".git") - allocate(temp_file, source=get_temp_filename()) - line = "git "//workdir//" log -n 1 > "//temp_file - call execute_command_line(line, exitstat=stat) + !> Git object reference + character(len=:), allocatable, intent(out) :: object - if (stat /= 0) then - call fatal_error(error, "Error while retrieving commit information") - return - end if + !> Error + type(error_t), allocatable, intent(out) :: error - open(file=temp_file, newunit=unit) - call getline(unit, line, stat, iomsg) + integer :: stat, unit, istart, iend + character(len=:), allocatable :: temp_file, line, iomsg, workdir + character(len=*), parameter :: hexdigits = '0123456789abcdef' - if (stat /= 0) then - call fatal_error(error, iomsg) - return - end if - close(unit, status="delete") + workdir = "--work-tree="//local_path//" --git-dir="//join_path(local_path, ".git") + allocate (temp_file, source=get_temp_filename()) + line = "git "//workdir//" log -n 1 > "//temp_file + call execute_command_line(line, exitstat=stat) - ! Tokenize: - ! commit 0123456789abcdef (HEAD, ...) - istart = scan(line, ' ') + 1 - iend = verify(line(istart:), hexdigits) + istart - 1 - if (iend < istart) iend = len(line) - object = line(istart:iend) + if (stat /= 0) then + call fatal_error(error, "Error while retrieving commit information") + return + end if - end subroutine git_revision + open (file=temp_file, newunit=unit) + call getline(unit, line, stat, iomsg) + if (stat /= 0) then + call fatal_error(error, iomsg) + return + end if + close (unit, status="delete") - !> Show information on git target - subroutine info(self, unit, verbosity) + ! Tokenize: + ! commit 0123456789abcdef (HEAD, ...) + istart = scan(line, ' ') + 1 + iend = verify(line(istart:), hexdigits) + istart - 1 + if (iend < istart) iend = len(line) + object = line(istart:iend) - !> Instance of the git target - class(git_target_t), intent(in) :: self + end subroutine git_revision - !> Unit for IO - integer, intent(in) :: unit + !> Show information on git target + subroutine info(self, unit, verbosity) - !> Verbosity of the printout - integer, intent(in), optional :: verbosity + !> Instance of the git target + class(git_target_t), intent(in) :: self - integer :: pr - character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)' + !> Unit for IO + integer, intent(in) :: unit - if (present(verbosity)) then - pr = verbosity - else - pr = 1 - end if + !> Verbosity of the printout + integer, intent(in), optional :: verbosity - if (pr < 1) return + integer :: pr + character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)' - write(unit, fmt) "Git target" - if (allocated(self%url)) then - write(unit, fmt) "- URL", self%url - end if - if (allocated(self%object)) then - select case(self%descriptor) - case default - write(unit, fmt) "- object", self%object - case(git_descriptor%tag) - write(unit, fmt) "- tag", self%object - case(git_descriptor%branch) - write(unit, fmt) "- branch", self%object - case(git_descriptor%revision) - write(unit, fmt) "- sha1", self%object - end select - end if + if (present(verbosity)) then + pr = verbosity + else + pr = 1 + end if + + if (pr < 1) return - end subroutine info + write (unit, fmt) "Git target" + if (allocated(self%url)) then + write (unit, fmt) "- URL", self%url + end if + if (allocated(self%object)) then + select case (self%descriptor) + case default + write (unit, fmt) "- object", self%object + case (git_descriptor%tag) + write (unit, fmt) "- tag", self%object + case (git_descriptor%branch) + write (unit, fmt) "- branch", self%object + case (git_descriptor%revision) + write (unit, fmt) "- sha1", self%object + end select + end if + end subroutine info end module fpm_git diff --git a/src/fpm/installer.f90 b/src/fpm/installer.f90 index 4e138d10e3..e4441a6f84 100644 --- a/src/fpm/installer.f90 +++ b/src/fpm/installer.f90 @@ -4,17 +4,16 @@ !> in the installation prefix, a generic install command allows to install !> to any directory within the prefix. module fpm_installer - use, intrinsic :: iso_fortran_env, only : output_unit - use fpm_environment, only : get_os_type, os_is_unix - use fpm_error, only : error_t, fatal_error - use fpm_filesystem, only : join_path, mkdir, exists, unix_path, windows_path, & - env_variable + use, intrinsic :: iso_fortran_env, only: output_unit + use fpm_environment, only: get_os_type, os_is_unix + use fpm_error, only: error_t, fatal_error + use fpm_filesystem, only: join_path, mkdir, exists, unix_path, windows_path, & + env_variable implicit none private public :: installer_t, new_installer - !> Declaration of the installer type type :: installer_t !> Path to installation directory @@ -77,12 +76,11 @@ module fpm_installer !> Move command on Windows platforms character(len=*), parameter :: default_move_win = "move" - contains !> Create a new instance of an installer subroutine new_installer(self, prefix, bindir, libdir, includedir, verbosity, & - copy, move) + copy, move) !> Instance of the installer type(installer_t), intent(out) :: self !> Path to installation directory @@ -191,12 +189,12 @@ subroutine install_executable(self, executable, error) type(error_t), allocatable, intent(out) :: error integer :: ll - if (.not.os_is_unix(self%os)) then - ll = len(executable) - if (executable(max(1, ll-3):ll) /= ".exe") then - call self%install(executable//".exe", self%bindir, error) - return - end if + if (.not. os_is_unix(self%os)) then + ll = len(executable) + if (executable(max(1, ll - 3):ll) /= ".exe") then + call self%install(executable//".exe", self%bindir, error) + return + end if end if call self%install(executable, self%bindir, error) @@ -251,10 +249,10 @@ subroutine install(self, source, destination, error) if (self%verbosity > 0) then if (exists(install_dest)) then - write(self%unit, '("# Update:", 1x, a, 1x, "->", 1x, a)') & + write (self%unit, '("# Update:", 1x, a, 1x, "->", 1x, a)') & source, install_dest else - write(self%unit, '("# Install:", 1x, a, 1x, "->", 1x, a)') & + write (self%unit, '("# Install:", 1x, a, 1x, "->", 1x, a)') & source, install_dest end if end if @@ -278,11 +276,11 @@ subroutine make_dir(self, dir, error) !> Error handling type(error_t), allocatable, intent(out) :: error - if (.not.exists(dir)) then - if (self%verbosity > 1) then - write(self%unit, '("# Dir:", 1x, a)') dir - end if - call mkdir(dir) + if (.not. exists(dir)) then + if (self%verbosity > 1) then + write (self%unit, '("# Dir:", 1x, a)') dir + end if + call mkdir(dir) end if end subroutine make_dir @@ -297,7 +295,7 @@ subroutine run(self, command, error) integer :: stat if (self%verbosity > 1) then - write(self%unit, '("# Run:", 1x, a)') command + write (self%unit, '("# Run:", 1x, a)') command end if call execute_command_line(command, exitstat=stat) diff --git a/src/fpm/manifest.f90 b/src/fpm/manifest.f90 index 3bc2e0bf87..145b05f012 100644 --- a/src/fpm/manifest.f90 +++ b/src/fpm/manifest.f90 @@ -7,179 +7,173 @@ !> Additionally, the required data types for users of this module are reexported !> to hide the actual implementation details. module fpm_manifest - use fpm_manifest_build, only: build_config_t - use fpm_manifest_example, only : example_config_t - use fpm_manifest_executable, only : executable_config_t - use fpm_manifest_dependency, only : dependency_config_t - use fpm_manifest_library, only : library_config_t - use fpm_mainfest_preprocess, only : preprocess_config_t - use fpm_manifest_package, only : package_config_t, new_package - use fpm_error, only : error_t, fatal_error - use fpm_toml, only : toml_table, read_package_file - use fpm_manifest_test, only : test_config_t - use fpm_filesystem, only: join_path, exists, dirname, is_dir - use fpm_strings, only: string_t - implicit none - private - - public :: get_package_data, default_executable, default_library, default_test - public :: default_example - public :: package_config_t, dependency_config_t, preprocess_config_t - + use fpm_manifest_build, only: build_config_t + use fpm_manifest_example, only: example_config_t + use fpm_manifest_executable, only: executable_config_t + use fpm_manifest_dependency, only: dependency_config_t + use fpm_manifest_library, only: library_config_t + use fpm_mainfest_preprocess, only: preprocess_config_t + use fpm_manifest_package, only: package_config_t, new_package + use fpm_error, only: error_t, fatal_error + use fpm_toml, only: toml_table, read_package_file + use fpm_manifest_test, only: test_config_t + use fpm_filesystem, only: join_path, exists, dirname, is_dir + use fpm_strings, only: string_t + implicit none + private + + public :: get_package_data, default_executable, default_library, default_test + public :: default_example + public :: package_config_t, dependency_config_t, preprocess_config_t contains + !> Populate library in case we find the default src directory + subroutine default_library(self) - !> Populate library in case we find the default src directory - subroutine default_library(self) - - !> Instance of the library meta data - type(library_config_t), intent(out) :: self - - self%source_dir = "src" - self%include_dir = [string_t("include")] + !> Instance of the library meta data + type(library_config_t), intent(out) :: self - end subroutine default_library + self%source_dir = "src" + self%include_dir = [string_t("include")] + end subroutine default_library - !> Populate executable in case we find the default app directory - subroutine default_executable(self, name) + !> Populate executable in case we find the default app directory + subroutine default_executable(self, name) - !> Instance of the executable meta data - type(executable_config_t), intent(out) :: self + !> Instance of the executable meta data + type(executable_config_t), intent(out) :: self - !> Name of the package - character(len=*), intent(in) :: name + !> Name of the package + character(len=*), intent(in) :: name - self%name = name - self%source_dir = "app" - self%main = "main.f90" + self%name = name + self%source_dir = "app" + self%main = "main.f90" - end subroutine default_executable + end subroutine default_executable - !> Populate test in case we find the default example/ directory - subroutine default_example(self, name) + !> Populate test in case we find the default example/ directory + subroutine default_example(self, name) - !> Instance of the executable meta data - type(example_config_t), intent(out) :: self + !> Instance of the executable meta data + type(example_config_t), intent(out) :: self - !> Name of the package - character(len=*), intent(in) :: name + !> Name of the package + character(len=*), intent(in) :: name - self%name = name // "-demo" - self%source_dir = "example" - self%main = "main.f90" + self%name = name//"-demo" + self%source_dir = "example" + self%main = "main.f90" - end subroutine default_example + end subroutine default_example - !> Populate test in case we find the default test/ directory - subroutine default_test(self, name) + !> Populate test in case we find the default test/ directory + subroutine default_test(self, name) - !> Instance of the executable meta data - type(test_config_t), intent(out) :: self + !> Instance of the executable meta data + type(test_config_t), intent(out) :: self - !> Name of the package - character(len=*), intent(in) :: name + !> Name of the package + character(len=*), intent(in) :: name - self%name = name // "-test" - self%source_dir = "test" - self%main = "main.f90" + self%name = name//"-test" + self%source_dir = "test" + self%main = "main.f90" - end subroutine default_test + end subroutine default_test + !> Obtain package meta data from a configuation file + subroutine get_package_data(package, file, error, apply_defaults) - !> Obtain package meta data from a configuation file - subroutine get_package_data(package, file, error, apply_defaults) + !> Parsed package meta data + type(package_config_t), intent(out) :: package - !> Parsed package meta data - type(package_config_t), intent(out) :: package + !> Name of the package configuration file + character(len=*), intent(in) :: file - !> Name of the package configuration file - character(len=*), intent(in) :: file + !> Error status of the operation + type(error_t), allocatable, intent(out) :: error - !> Error status of the operation - type(error_t), allocatable, intent(out) :: error + !> Apply package defaults (uses file system operations) + logical, intent(in), optional :: apply_defaults - !> Apply package defaults (uses file system operations) - logical, intent(in), optional :: apply_defaults + type(toml_table), allocatable :: table + character(len=:), allocatable :: root - type(toml_table), allocatable :: table - character(len=:), allocatable :: root + call read_package_file(table, file, error) + if (allocated(error)) return - call read_package_file(table, file, error) - if (allocated(error)) return + if (.not. allocated(table)) then + call fatal_error(error, "Unclassified error while reading: '"//file//"'") + return + end if - if (.not.allocated(table)) then - call fatal_error(error, "Unclassified error while reading: '"//file//"'") - return - end if + call new_package(package, table, dirname(file), error) + if (allocated(error)) return - call new_package(package, table, dirname(file), error) + if (present(apply_defaults)) then + if (apply_defaults) then + root = dirname(file) + if (len_trim(root) == 0) root = "." + call package_defaults(package, root, error) if (allocated(error)) return - - if (present(apply_defaults)) then - if (apply_defaults) then - root = dirname(file) - if (len_trim(root) == 0) root = "." - call package_defaults(package, root, error) - if (allocated(error)) return - end if - end if - - end subroutine get_package_data - - - !> Apply package defaults - subroutine package_defaults(package, root, error) - - !> Parsed package meta data - type(package_config_t), intent(inout) :: package - - !> Current working directory - character(len=*), intent(in) :: root - - !> Error status of the operation - type(error_t), allocatable, intent(out) :: error - - ! Populate library in case we find the default src directory - if (.not.allocated(package%library) .and. & - & (is_dir(join_path(root, "src")) .or. & - & is_dir(join_path(root, "include")))) then - - allocate(package%library) - call default_library(package%library) - end if - - ! Populate executable in case we find the default app - if (.not.allocated(package%executable) .and. & - & exists(join_path(root, "app", "main.f90"))) then - allocate(package%executable(1)) - call default_executable(package%executable(1), package%name) - end if - - ! Populate example in case we find the default example directory - if (.not.allocated(package%example) .and. & - & exists(join_path(root, "example", "main.f90"))) then - allocate(package%example(1)) - call default_example(package%example(1), package%name) - endif - - ! Populate test in case we find the default test directory - if (.not.allocated(package%test) .and. & - & exists(join_path(root, "test", "main.f90"))) then - allocate(package%test(1)) - call default_test(package%test(1), package%name) - endif - - if (.not.(allocated(package%library) & - & .or. allocated(package%executable) & - & .or. allocated(package%example) & - & .or. allocated(package%test))) then - call fatal_error(error, "Neither library nor executable found, there is nothing to do") - return - end if - - end subroutine package_defaults - + end if + end if + + end subroutine get_package_data + + !> Apply package defaults + subroutine package_defaults(package, root, error) + + !> Parsed package meta data + type(package_config_t), intent(inout) :: package + + !> Current working directory + character(len=*), intent(in) :: root + + !> Error status of the operation + type(error_t), allocatable, intent(out) :: error + + ! Populate library in case we find the default src directory + if (.not. allocated(package%library) .and. & + & (is_dir(join_path(root, "src")) .or. & + & is_dir(join_path(root, "include")))) then + + allocate (package%library) + call default_library(package%library) + end if + + ! Populate executable in case we find the default app + if (.not. allocated(package%executable) .and. & + & exists(join_path(root, "app", "main.f90"))) then + allocate (package%executable(1)) + call default_executable(package%executable(1), package%name) + end if + + ! Populate example in case we find the default example directory + if (.not. allocated(package%example) .and. & + & exists(join_path(root, "example", "main.f90"))) then + allocate (package%example(1)) + call default_example(package%example(1), package%name) + end if + + ! Populate test in case we find the default test directory + if (.not. allocated(package%test) .and. & + & exists(join_path(root, "test", "main.f90"))) then + allocate (package%test(1)) + call default_test(package%test(1), package%name) + end if + + if (.not. (allocated(package%library) & + & .or. allocated(package%executable) & + & .or. allocated(package%example) & + & .or. allocated(package%test))) then + call fatal_error(error, "Neither library nor executable found, there is nothing to do") + return + end if + + end subroutine package_defaults end module fpm_manifest diff --git a/src/fpm/manifest/build.f90 b/src/fpm/manifest/build.f90 index b24cf431b6..20c2b04101 100644 --- a/src/fpm/manifest/build.f90 +++ b/src/fpm/manifest/build.f90 @@ -10,165 +10,159 @@ !>link = ["lib"] !>``` module fpm_manifest_build - use fpm_error, only : error_t, syntax_error, fatal_error - use fpm_strings, only : string_t - use fpm_toml, only : toml_table, toml_key, toml_stat, get_value, get_list - implicit none - private + use fpm_error, only: error_t, syntax_error, fatal_error + use fpm_strings, only: string_t + use fpm_toml, only: toml_table, toml_key, toml_stat, get_value, get_list + implicit none + private - public :: build_config_t, new_build_config + public :: build_config_t, new_build_config + !> Configuration data for build + type :: build_config_t - !> Configuration data for build - type :: build_config_t + !> Automatic discovery of executables + logical :: auto_executables - !> Automatic discovery of executables - logical :: auto_executables + !> Automatic discovery of examples + logical :: auto_examples - !> Automatic discovery of examples - logical :: auto_examples + !> Automatic discovery of tests + logical :: auto_tests - !> Automatic discovery of tests - logical :: auto_tests + !> Libraries to link against + type(string_t), allocatable :: link(:) - !> Libraries to link against - type(string_t), allocatable :: link(:) + !> External modules to use + type(string_t), allocatable :: external_modules(:) - !> External modules to use - type(string_t), allocatable :: external_modules(:) + contains - contains - - !> Print information on this instance - procedure :: info - - end type build_config_t + !> Print information on this instance + procedure :: info + end type build_config_t contains + !> Construct a new build configuration from a TOML data structure + subroutine new_build_config(self, table, error) - !> Construct a new build configuration from a TOML data structure - subroutine new_build_config(self, table, error) - - !> Instance of the build configuration - type(build_config_t), intent(out) :: self - - !> Instance of the TOML data structure - type(toml_table), intent(inout) :: table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: stat + !> Instance of the build configuration + type(build_config_t), intent(out) :: self - call check(table, error) - if (allocated(error)) return + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table - call get_value(table, "auto-executables", self%auto_executables, .true., stat=stat) + !> Error handling + type(error_t), allocatable, intent(out) :: error - if (stat /= toml_stat%success) then - call fatal_error(error,"Error while reading value for 'auto-executables' in fpm.toml, expecting logical") - return - end if + integer :: stat - call get_value(table, "auto-tests", self%auto_tests, .true., stat=stat) + call check(table, error) + if (allocated(error)) return - if (stat /= toml_stat%success) then - call fatal_error(error,"Error while reading value for 'auto-tests' in fpm.toml, expecting logical") - return - end if + call get_value(table, "auto-executables", self%auto_executables, .true., stat=stat) - call get_value(table, "auto-examples", self%auto_examples, .true., stat=stat) + if (stat /= toml_stat%success) then + call fatal_error(error, "Error while reading value for 'auto-executables' in fpm.toml, expecting logical") + return + end if - if (stat /= toml_stat%success) then - call fatal_error(error,"Error while reading value for 'auto-examples' in fpm.toml, expecting logical") - return - end if + call get_value(table, "auto-tests", self%auto_tests, .true., stat=stat) + if (stat /= toml_stat%success) then + call fatal_error(error, "Error while reading value for 'auto-tests' in fpm.toml, expecting logical") + return + end if - call get_list(table, "link", self%link, error) - if (allocated(error)) return + call get_value(table, "auto-examples", self%auto_examples, .true., stat=stat) - call get_list(table, "external-modules", self%external_modules, error) - if (allocated(error)) return + if (stat /= toml_stat%success) then + call fatal_error(error, "Error while reading value for 'auto-examples' in fpm.toml, expecting logical") + return + end if - end subroutine new_build_config + call get_list(table, "link", self%link, error) + if (allocated(error)) return + call get_list(table, "external-modules", self%external_modules, error) + if (allocated(error)) return - !> Check local schema for allowed entries - subroutine check(table, error) + end subroutine new_build_config - !> Instance of the TOML data structure - type(toml_table), intent(inout) :: table + !> Check local schema for allowed entries + subroutine check(table, error) - !> Error handling - type(error_t), allocatable, intent(out) :: error + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table - type(toml_key), allocatable :: list(:) - integer :: ikey + !> Error handling + type(error_t), allocatable, intent(out) :: error - call table%get_keys(list) + type(toml_key), allocatable :: list(:) + integer :: ikey - ! table can be empty - if (size(list) < 1) return + call table%get_keys(list) - do ikey = 1, size(list) - select case(list(ikey)%key) + ! table can be empty + if (size(list) < 1) return - case("auto-executables", "auto-examples", "auto-tests", "link", "external-modules") - continue + do ikey = 1, size(list) + select case (list(ikey)%key) - case default - call syntax_error(error, "Key "//list(ikey)%key//" is not allowed in [build]") - exit + case ("auto-executables", "auto-examples", "auto-tests", "link", "external-modules") + continue - end select - end do + case default + call syntax_error(error, "Key "//list(ikey)%key//" is not allowed in [build]") + exit - end subroutine check + end select + end do + end subroutine check - !> Write information on build configuration instance - subroutine info(self, unit, verbosity) + !> Write information on build configuration instance + subroutine info(self, unit, verbosity) - !> Instance of the build configuration - class(build_config_t), intent(in) :: self + !> Instance of the build configuration + class(build_config_t), intent(in) :: self - !> Unit for IO - integer, intent(in) :: unit + !> Unit for IO + integer, intent(in) :: unit - !> Verbosity of the printout - integer, intent(in), optional :: verbosity + !> Verbosity of the printout + integer, intent(in), optional :: verbosity - integer :: pr, ilink, imod - character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)' + integer :: pr, ilink, imod + character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)' - if (present(verbosity)) then - pr = verbosity - else - pr = 1 - end if + if (present(verbosity)) then + pr = verbosity + else + pr = 1 + end if - if (pr < 1) return + if (pr < 1) return - write(unit, fmt) "Build configuration" - write(unit, fmt) " - auto-discovery (apps) ", merge("enabled ", "disabled", self%auto_executables) - write(unit, fmt) " - auto-discovery (examples) ", merge("enabled ", "disabled", self%auto_examples) - write(unit, fmt) " - auto-discovery (tests) ", merge("enabled ", "disabled", self%auto_tests) - if (allocated(self%link)) then - write(unit, fmt) " - link against" - do ilink = 1, size(self%link) - write(unit, fmt) " - " // self%link(ilink)%s - end do - end if - if (allocated(self%external_modules)) then - write(unit, fmt) " - external modules" - do imod = 1, size(self%external_modules) - write(unit, fmt) " - " // self%external_modules(imod)%s - end do - end if + write (unit, fmt) "Build configuration" + write (unit, fmt) " - auto-discovery (apps) ", merge("enabled ", "disabled", self%auto_executables) + write (unit, fmt) " - auto-discovery (examples) ", merge("enabled ", "disabled", self%auto_examples) + write (unit, fmt) " - auto-discovery (tests) ", merge("enabled ", "disabled", self%auto_tests) + if (allocated(self%link)) then + write (unit, fmt) " - link against" + do ilink = 1, size(self%link) + write (unit, fmt) " - "//self%link(ilink)%s + end do + end if + if (allocated(self%external_modules)) then + write (unit, fmt) " - external modules" + do imod = 1, size(self%external_modules) + write (unit, fmt) " - "//self%external_modules(imod)%s + end do + end if - end subroutine info + end subroutine info end module fpm_manifest_build diff --git a/src/fpm/manifest/dependency.f90 b/src/fpm/manifest/dependency.f90 index 00f136472f..8b2abb6014 100644 --- a/src/fpm/manifest/dependency.f90 +++ b/src/fpm/manifest/dependency.f90 @@ -23,248 +23,241 @@ !> Resolving a dependency will result in obtaining a new package configuration !> data for the respective project. module fpm_manifest_dependency - use fpm_error, only : error_t, syntax_error - use fpm_git, only : git_target_t, git_target_tag, git_target_branch, & - & git_target_revision, git_target_default - use fpm_toml, only : toml_table, toml_key, toml_stat, get_value - use fpm_filesystem, only: windows_path - use fpm_environment, only: get_os_type, OS_WINDOWS - implicit none - private + use fpm_error, only: error_t, syntax_error + use fpm_git, only: git_target_t, git_target_tag, git_target_branch, & + & git_target_revision, git_target_default + use fpm_toml, only: toml_table, toml_key, toml_stat, get_value + use fpm_filesystem, only: windows_path + use fpm_environment, only: get_os_type, OS_WINDOWS + implicit none + private - public :: dependency_config_t, new_dependency, new_dependencies + public :: dependency_config_t, new_dependency, new_dependencies + !> Configuration meta data for a dependency + type :: dependency_config_t - !> Configuration meta data for a dependency - type :: dependency_config_t + !> Name of the dependency + character(len=:), allocatable :: name - !> Name of the dependency - character(len=:), allocatable :: name + !> Local target + character(len=:), allocatable :: path - !> Local target - character(len=:), allocatable :: path + !> Git descriptor + type(git_target_t), allocatable :: git - !> Git descriptor - type(git_target_t), allocatable :: git + contains - contains - - !> Print information on this instance - procedure :: info - - end type dependency_config_t + !> Print information on this instance + procedure :: info + end type dependency_config_t contains + !> Construct a new dependency configuration from a TOML data structure + subroutine new_dependency(self, table, root, error) - !> Construct a new dependency configuration from a TOML data structure - subroutine new_dependency(self, table, root, error) + !> Instance of the dependency configuration + type(dependency_config_t), intent(out) :: self - !> Instance of the dependency configuration - type(dependency_config_t), intent(out) :: self + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table - !> Instance of the TOML data structure - type(toml_table), intent(inout) :: table + !> Root directory of the manifest + character(*), intent(in), optional :: root - !> Root directory of the manifest - character(*), intent(in), optional :: root + !> Error handling + type(error_t), allocatable, intent(out) :: error - !> Error handling - type(error_t), allocatable, intent(out) :: error + character(len=:), allocatable :: url, obj - character(len=:), allocatable :: url, obj + call check(table, error) + if (allocated(error)) return - call check(table, error) - if (allocated(error)) return + call table%get_key(self%name) - call table%get_key(self%name) + call get_value(table, "path", url) + if (allocated(url)) then + if (get_os_type() == OS_WINDOWS) url = windows_path(url) + if (present(root)) url = root//url ! Relative to the fpm.toml it’s written in + call move_alloc(url, self%path) + else + call get_value(table, "git", url) - call get_value(table, "path", url) - if (allocated(url)) then - if (get_os_type() == OS_WINDOWS) url = windows_path(url) - if (present(root)) url = root//url ! Relative to the fpm.toml it’s written in - call move_alloc(url, self%path) - else - call get_value(table, "git", url) + call get_value(table, "tag", obj) + if (allocated(obj)) then + self%git = git_target_tag(url, obj) + end if - call get_value(table, "tag", obj) - if (allocated(obj)) then - self%git = git_target_tag(url, obj) - end if + if (.not. allocated(self%git)) then + call get_value(table, "branch", obj) + if (allocated(obj)) then + self%git = git_target_branch(url, obj) + end if + end if - if (.not.allocated(self%git)) then - call get_value(table, "branch", obj) - if (allocated(obj)) then - self%git = git_target_branch(url, obj) - end if - end if + if (.not. allocated(self%git)) then + call get_value(table, "rev", obj) + if (allocated(obj)) then + self%git = git_target_revision(url, obj) + end if + end if - if (.not.allocated(self%git)) then - call get_value(table, "rev", obj) - if (allocated(obj)) then - self%git = git_target_revision(url, obj) - end if - end if + if (.not. allocated(self%git)) then + self%git = git_target_default(url) + end if - if (.not.allocated(self%git)) then - self%git = git_target_default(url) - end if + end if - end if + end subroutine new_dependency - end subroutine new_dependency + !> Check local schema for allowed entries + subroutine check(table, error) + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table - !> Check local schema for allowed entries - subroutine check(table, error) + !> Error handling + type(error_t), allocatable, intent(out) :: error - !> Instance of the TOML data structure - type(toml_table), intent(inout) :: table + character(len=:), allocatable :: name, url + type(toml_key), allocatable :: list(:) + logical :: url_present, git_target_present, has_path + integer :: ikey - !> Error handling - type(error_t), allocatable, intent(out) :: error + has_path = .false. + url_present = .false. + git_target_present = .false. - character(len=:), allocatable :: name, url - type(toml_key), allocatable :: list(:) - logical :: url_present, git_target_present, has_path - integer :: ikey + call table%get_key(name) + call table%get_keys(list) - has_path = .false. - url_present = .false. - git_target_present = .false. + if (size(list) < 1) then + call syntax_error(error, "Dependency "//name//" does not provide sufficient entries") + return + end if - call table%get_key(name) - call table%get_keys(list) + do ikey = 1, size(list) + select case (list(ikey)%key) + case default + call syntax_error(error, "Key "//list(ikey)%key//" is not allowed in dependency "//name) + exit - if (size(list) < 1) then - call syntax_error(error, "Dependency "//name//" does not provide sufficient entries") - return + case ("git") + if (url_present) then + call syntax_error(error, "Dependency "//name//" cannot have both git and path entries") + exit end if + call get_value(table, "git", url) + if (.not. allocated(url)) then + call syntax_error(error, "Dependency "//name//" has invalid git source") + exit + end if + url_present = .true. - do ikey = 1, size(list) - select case(list(ikey)%key) - case default - call syntax_error(error, "Key "//list(ikey)%key//" is not allowed in dependency "//name) - exit - - case("git") - if (url_present) then - call syntax_error(error, "Dependency "//name//" cannot have both git and path entries") - exit - end if - call get_value(table, "git", url) - if (.not.allocated(url)) then - call syntax_error(error, "Dependency "//name//" has invalid git source") - exit - end if - url_present = .true. - - case("path") - if (url_present) then - call syntax_error(error, "Dependency "//name//" cannot have both git and path entries") - exit - end if - url_present = .true. - has_path = .true. - - case("branch", "rev", "tag") - if (git_target_present) then - call syntax_error(error, "Dependency "//name//" can only have one of branch, rev or tag present") - exit - end if - git_target_present = .true. - - end select - end do - if (allocated(error)) return - - if (.not.url_present) then - call syntax_error(error, "Dependency "//name//" does not provide a method to actually retrieve itself") - return + case ("path") + if (url_present) then + call syntax_error(error, "Dependency "//name//" cannot have both git and path entries") + exit end if + url_present = .true. + has_path = .true. - if (has_path .and. git_target_present) then - call syntax_error(error, "Dependency "//name//" uses a local path, therefore no git identifiers are allowed") + case ("branch", "rev", "tag") + if (git_target_present) then + call syntax_error(error, "Dependency "//name//" can only have one of branch, rev or tag present") + exit end if + git_target_present = .true. - end subroutine check + end select + end do + if (allocated(error)) return + if (.not. url_present) then + call syntax_error(error, "Dependency "//name//" does not provide a method to actually retrieve itself") + return + end if - !> Construct new dependency array from a TOML data structure - subroutine new_dependencies(deps, table, root, error) + if (has_path .and. git_target_present) then + call syntax_error(error, "Dependency "//name//" uses a local path, therefore no git identifiers are allowed") + end if - !> Instance of the dependency configuration - type(dependency_config_t), allocatable, intent(out) :: deps(:) + end subroutine check - !> Instance of the TOML data structure - type(toml_table), intent(inout) :: table + !> Construct new dependency array from a TOML data structure + subroutine new_dependencies(deps, table, root, error) - !> Root directory of the manifest - character(*), intent(in), optional :: root + !> Instance of the dependency configuration + type(dependency_config_t), allocatable, intent(out) :: deps(:) - !> Error handling - type(error_t), allocatable, intent(out) :: error + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table - type(toml_table), pointer :: node - type(toml_key), allocatable :: list(:) - integer :: idep, stat + !> Root directory of the manifest + character(*), intent(in), optional :: root - call table%get_keys(list) - ! An empty table is okay - if (size(list) < 1) return + !> Error handling + type(error_t), allocatable, intent(out) :: error - allocate(deps(size(list))) - do idep = 1, size(list) - call get_value(table, list(idep)%key, node, stat=stat) - if (stat /= toml_stat%success) then - call syntax_error(error, "Dependency "//list(idep)%key//" must be a table entry") - exit - end if - call new_dependency(deps(idep), node, root, error) - if (allocated(error)) exit - end do + type(toml_table), pointer :: node + type(toml_key), allocatable :: list(:) + integer :: idep, stat - end subroutine new_dependencies + call table%get_keys(list) + ! An empty table is okay + if (size(list) < 1) return + allocate (deps(size(list))) + do idep = 1, size(list) + call get_value(table, list(idep)%key, node, stat=stat) + if (stat /= toml_stat%success) then + call syntax_error(error, "Dependency "//list(idep)%key//" must be a table entry") + exit + end if + call new_dependency(deps(idep), node, root, error) + if (allocated(error)) exit + end do - !> Write information on instance - subroutine info(self, unit, verbosity) + end subroutine new_dependencies - !> Instance of the dependency configuration - class(dependency_config_t), intent(in) :: self + !> Write information on instance + subroutine info(self, unit, verbosity) - !> Unit for IO - integer, intent(in) :: unit + !> Instance of the dependency configuration + class(dependency_config_t), intent(in) :: self - !> Verbosity of the printout - integer, intent(in), optional :: verbosity + !> Unit for IO + integer, intent(in) :: unit - integer :: pr - character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)' + !> Verbosity of the printout + integer, intent(in), optional :: verbosity - if (present(verbosity)) then - pr = verbosity - else - pr = 1 - end if + integer :: pr + character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)' - write(unit, fmt) "Dependency" - if (allocated(self%name)) then - write(unit, fmt) "- name", self%name - end if + if (present(verbosity)) then + pr = verbosity + else + pr = 1 + end if - if (allocated(self%git)) then - write(unit, fmt) "- kind", "git" - call self%git%info(unit, pr - 1) - end if + write (unit, fmt) "Dependency" + if (allocated(self%name)) then + write (unit, fmt) "- name", self%name + end if - if (allocated(self%path)) then - write(unit, fmt) "- kind", "local" - write(unit, fmt) "- path", self%path - end if + if (allocated(self%git)) then + write (unit, fmt) "- kind", "git" + call self%git%info(unit, pr - 1) + end if - end subroutine info + if (allocated(self%path)) then + write (unit, fmt) "- kind", "local" + write (unit, fmt) "- path", self%path + end if + end subroutine info end module fpm_manifest_dependency diff --git a/src/fpm/manifest/example.f90 b/src/fpm/manifest/example.f90 index 89523747c1..111e8e737c 100644 --- a/src/fpm/manifest/example.f90 +++ b/src/fpm/manifest/example.f90 @@ -15,164 +15,158 @@ !>[example.dependencies] !>``` module fpm_manifest_example - use fpm_manifest_dependency, only : dependency_config_t, new_dependencies - use fpm_manifest_executable, only : executable_config_t - use fpm_error, only : error_t, syntax_error, bad_name_error - use fpm_toml, only : toml_table, toml_key, toml_stat, get_value, get_list - implicit none - private + use fpm_manifest_dependency, only: dependency_config_t, new_dependencies + use fpm_manifest_executable, only: executable_config_t + use fpm_error, only: error_t, syntax_error, bad_name_error + use fpm_toml, only: toml_table, toml_key, toml_stat, get_value, get_list + implicit none + private - public :: example_config_t, new_example + public :: example_config_t, new_example + !> Configuation meta data for an example + type, extends(executable_config_t) :: example_config_t - !> Configuation meta data for an example - type, extends(executable_config_t) :: example_config_t + contains - contains - - !> Print information on this instance - procedure :: info - - end type example_config_t + !> Print information on this instance + procedure :: info + end type example_config_t contains + !> Construct a new example configuration from a TOML data structure + subroutine new_example(self, table, error) - !> Construct a new example configuration from a TOML data structure - subroutine new_example(self, table, error) - - !> Instance of the example configuration - type(example_config_t), intent(out) :: self - - !> Instance of the TOML data structure - type(toml_table), intent(inout) :: table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table), pointer :: child - - call check(table, error) - if (allocated(error)) return - - call get_value(table, "name", self%name) - if (.not.allocated(self%name)) then - call syntax_error(error, "Could not retrieve example name") - return - end if - if (bad_name_error(error,'example',self%name))then - return - endif - call get_value(table, "source-dir", self%source_dir, "example") - call get_value(table, "main", self%main, "main.f90") - - call get_value(table, "dependencies", child, requested=.false.) - if (associated(child)) then - call new_dependencies(self%dependency, child, error=error) - if (allocated(error)) return - end if + !> Instance of the example configuration + type(example_config_t), intent(out) :: self - call get_list(table, "link", self%link, error) - if (allocated(error)) return + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table - end subroutine new_example + !> Error handling + type(error_t), allocatable, intent(out) :: error + type(toml_table), pointer :: child - !> Check local schema for allowed entries - subroutine check(table, error) + call check(table, error) + if (allocated(error)) return - !> Instance of the TOML data structure - type(toml_table), intent(inout) :: table + call get_value(table, "name", self%name) + if (.not. allocated(self%name)) then + call syntax_error(error, "Could not retrieve example name") + return + end if + if (bad_name_error(error, 'example', self%name)) then + return + end if + call get_value(table, "source-dir", self%source_dir, "example") + call get_value(table, "main", self%main, "main.f90") - !> Error handling - type(error_t), allocatable, intent(out) :: error + call get_value(table, "dependencies", child, requested=.false.) + if (associated(child)) then + call new_dependencies(self%dependency, child, error=error) + if (allocated(error)) return + end if - type(toml_key), allocatable :: list(:) - logical :: name_present - integer :: ikey + call get_list(table, "link", self%link, error) + if (allocated(error)) return - name_present = .false. + end subroutine new_example - call table%get_keys(list) + !> Check local schema for allowed entries + subroutine check(table, error) - if (size(list) < 1) then - call syntax_error(error, "Example section does not provide sufficient entries") - return - end if + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table - do ikey = 1, size(list) - select case(list(ikey)%key) - case default - call syntax_error(error, "Key "//list(ikey)%key//" is not allowed in example entry") - exit + !> Error handling + type(error_t), allocatable, intent(out) :: error - case("name") - name_present = .true. + type(toml_key), allocatable :: list(:) + logical :: name_present + integer :: ikey - case("source-dir", "main", "dependencies", "link") - continue + name_present = .false. - end select - end do - if (allocated(error)) return + call table%get_keys(list) - if (.not.name_present) then - call syntax_error(error, "Example name is not provided, please add a name entry") - end if + if (size(list) < 1) then + call syntax_error(error, "Example section does not provide sufficient entries") + return + end if - end subroutine check + do ikey = 1, size(list) + select case (list(ikey)%key) + case default + call syntax_error(error, "Key "//list(ikey)%key//" is not allowed in example entry") + exit + case ("name") + name_present = .true. - !> Write information on instance - subroutine info(self, unit, verbosity) + case ("source-dir", "main", "dependencies", "link") + continue - !> Instance of the example configuration - class(example_config_t), intent(in) :: self + end select + end do + if (allocated(error)) return - !> Unit for IO - integer, intent(in) :: unit + if (.not. name_present) then + call syntax_error(error, "Example name is not provided, please add a name entry") + end if - !> Verbosity of the printout - integer, intent(in), optional :: verbosity + end subroutine check - integer :: pr, ii - character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)', & - & fmti = '("#", 1x, a, t30, i0)' + !> Write information on instance + subroutine info(self, unit, verbosity) - if (present(verbosity)) then - pr = verbosity - else - pr = 1 - end if + !> Instance of the example configuration + class(example_config_t), intent(in) :: self - if (pr < 1) return + !> Unit for IO + integer, intent(in) :: unit - write(unit, fmt) "Example target" - if (allocated(self%name)) then - write(unit, fmt) "- name", self%name - end if - if (allocated(self%source_dir)) then - if (self%source_dir /= "example" .or. pr > 2) then - write(unit, fmt) "- source directory", self%source_dir - end if - end if - if (allocated(self%main)) then - if (self%main /= "main.f90" .or. pr > 2) then - write(unit, fmt) "- example source", self%main - end if - end if + !> Verbosity of the printout + integer, intent(in), optional :: verbosity - if (allocated(self%dependency)) then - if (size(self%dependency) > 1 .or. pr > 2) then - write(unit, fmti) "- dependencies", size(self%dependency) - end if - do ii = 1, size(self%dependency) - call self%dependency(ii)%info(unit, pr - 1) - end do - end if + integer :: pr, ii + character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)', & + & fmti = '("#", 1x, a, t30, i0)' - end subroutine info + if (present(verbosity)) then + pr = verbosity + else + pr = 1 + end if + + if (pr < 1) return + + write (unit, fmt) "Example target" + if (allocated(self%name)) then + write (unit, fmt) "- name", self%name + end if + if (allocated(self%source_dir)) then + if (self%source_dir /= "example" .or. pr > 2) then + write (unit, fmt) "- source directory", self%source_dir + end if + end if + if (allocated(self%main)) then + if (self%main /= "main.f90" .or. pr > 2) then + write (unit, fmt) "- example source", self%main + end if + end if + + if (allocated(self%dependency)) then + if (size(self%dependency) > 1 .or. pr > 2) then + write (unit, fmti) "- dependencies", size(self%dependency) + end if + do ii = 1, size(self%dependency) + call self%dependency(ii)%info(unit, pr - 1) + end do + end if + end subroutine info end module fpm_manifest_example diff --git a/src/fpm/manifest/executable.f90 b/src/fpm/manifest/executable.f90 index 66bb0f2cb2..a65f2f9a99 100644 --- a/src/fpm/manifest/executable.f90 +++ b/src/fpm/manifest/executable.f90 @@ -11,179 +11,173 @@ !>[executable.dependencies] !>``` module fpm_manifest_executable - use fpm_manifest_dependency, only : dependency_config_t, new_dependencies - use fpm_error, only : error_t, syntax_error, bad_name_error - use fpm_strings, only : string_t - use fpm_toml, only : toml_table, toml_key, toml_stat, get_value, get_list - implicit none - private + use fpm_manifest_dependency, only: dependency_config_t, new_dependencies + use fpm_error, only: error_t, syntax_error, bad_name_error + use fpm_strings, only: string_t + use fpm_toml, only: toml_table, toml_key, toml_stat, get_value, get_list + implicit none + private - public :: executable_config_t, new_executable + public :: executable_config_t, new_executable + !> Configuation meta data for an executable + type :: executable_config_t - !> Configuation meta data for an executable - type :: executable_config_t + !> Name of the resulting executable + character(len=:), allocatable :: name - !> Name of the resulting executable - character(len=:), allocatable :: name + !> Source directory for collecting the executable + character(len=:), allocatable :: source_dir - !> Source directory for collecting the executable - character(len=:), allocatable :: source_dir + !> Name of the source file declaring the main program + character(len=:), allocatable :: main - !> Name of the source file declaring the main program - character(len=:), allocatable :: main + !> Dependency meta data for this executable + type(dependency_config_t), allocatable :: dependency(:) - !> Dependency meta data for this executable - type(dependency_config_t), allocatable :: dependency(:) + !> Libraries to link against + type(string_t), allocatable :: link(:) - !> Libraries to link against - type(string_t), allocatable :: link(:) + contains - contains - - !> Print information on this instance - procedure :: info - - end type executable_config_t + !> Print information on this instance + procedure :: info + end type executable_config_t contains + !> Construct a new executable configuration from a TOML data structure + subroutine new_executable(self, table, error) - !> Construct a new executable configuration from a TOML data structure - subroutine new_executable(self, table, error) - - !> Instance of the executable configuration - type(executable_config_t), intent(out) :: self - - !> Instance of the TOML data structure - type(toml_table), intent(inout) :: table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table), pointer :: child - - call check(table, error) - if (allocated(error)) return - - call get_value(table, "name", self%name) - if (.not.allocated(self%name)) then - call syntax_error(error, "Could not retrieve executable name") - return - end if - if (bad_name_error(error,'executable',self%name))then - return - endif - call get_value(table, "source-dir", self%source_dir, "app") - call get_value(table, "main", self%main, "main.f90") - - call get_value(table, "dependencies", child, requested=.false.) - if (associated(child)) then - call new_dependencies(self%dependency, child, error=error) - if (allocated(error)) return - end if + !> Instance of the executable configuration + type(executable_config_t), intent(out) :: self - call get_list(table, "link", self%link, error) - if (allocated(error)) return + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table - end subroutine new_executable + !> Error handling + type(error_t), allocatable, intent(out) :: error + type(toml_table), pointer :: child - !> Check local schema for allowed entries - subroutine check(table, error) + call check(table, error) + if (allocated(error)) return - !> Instance of the TOML data structure - type(toml_table), intent(inout) :: table + call get_value(table, "name", self%name) + if (.not. allocated(self%name)) then + call syntax_error(error, "Could not retrieve executable name") + return + end if + if (bad_name_error(error, 'executable', self%name)) then + return + end if + call get_value(table, "source-dir", self%source_dir, "app") + call get_value(table, "main", self%main, "main.f90") - !> Error handling - type(error_t), allocatable, intent(out) :: error + call get_value(table, "dependencies", child, requested=.false.) + if (associated(child)) then + call new_dependencies(self%dependency, child, error=error) + if (allocated(error)) return + end if - type(toml_key), allocatable :: list(:) - logical :: name_present - integer :: ikey + call get_list(table, "link", self%link, error) + if (allocated(error)) return - name_present = .false. + end subroutine new_executable - call table%get_keys(list) + !> Check local schema for allowed entries + subroutine check(table, error) - if (size(list) < 1) then - call syntax_error(error, "Executable section does not provide sufficient entries") - return - end if + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table - do ikey = 1, size(list) - select case(list(ikey)%key) - case default - call syntax_error(error, "Key "//list(ikey)%key//" is not allowed as executable entry") - exit + !> Error handling + type(error_t), allocatable, intent(out) :: error - case("name") - name_present = .true. + type(toml_key), allocatable :: list(:) + logical :: name_present + integer :: ikey - case("source-dir", "main", "dependencies", "link") - continue + name_present = .false. - end select - end do - if (allocated(error)) return + call table%get_keys(list) - if (.not.name_present) then - call syntax_error(error, "Executable name is not provided, please add a name entry") - end if + if (size(list) < 1) then + call syntax_error(error, "Executable section does not provide sufficient entries") + return + end if - end subroutine check + do ikey = 1, size(list) + select case (list(ikey)%key) + case default + call syntax_error(error, "Key "//list(ikey)%key//" is not allowed as executable entry") + exit + case ("name") + name_present = .true. - !> Write information on instance - subroutine info(self, unit, verbosity) + case ("source-dir", "main", "dependencies", "link") + continue - !> Instance of the executable configuration - class(executable_config_t), intent(in) :: self + end select + end do + if (allocated(error)) return - !> Unit for IO - integer, intent(in) :: unit + if (.not. name_present) then + call syntax_error(error, "Executable name is not provided, please add a name entry") + end if - !> Verbosity of the printout - integer, intent(in), optional :: verbosity + end subroutine check - integer :: pr, ii - character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)', & - & fmti = '("#", 1x, a, t30, i0)' + !> Write information on instance + subroutine info(self, unit, verbosity) - if (present(verbosity)) then - pr = verbosity - else - pr = 1 - end if + !> Instance of the executable configuration + class(executable_config_t), intent(in) :: self - if (pr < 1) return + !> Unit for IO + integer, intent(in) :: unit - write(unit, fmt) "Executable target" - if (allocated(self%name)) then - write(unit, fmt) "- name", self%name - end if - if (allocated(self%source_dir)) then - if (self%source_dir /= "app" .or. pr > 2) then - write(unit, fmt) "- source directory", self%source_dir - end if - end if - if (allocated(self%main)) then - if (self%main /= "main.f90" .or. pr > 2) then - write(unit, fmt) "- program source", self%main - end if - end if + !> Verbosity of the printout + integer, intent(in), optional :: verbosity - if (allocated(self%dependency)) then - if (size(self%dependency) > 1 .or. pr > 2) then - write(unit, fmti) "- dependencies", size(self%dependency) - end if - do ii = 1, size(self%dependency) - call self%dependency(ii)%info(unit, pr - 1) - end do - end if + integer :: pr, ii + character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)', & + & fmti = '("#", 1x, a, t30, i0)' - end subroutine info + if (present(verbosity)) then + pr = verbosity + else + pr = 1 + end if + + if (pr < 1) return + + write (unit, fmt) "Executable target" + if (allocated(self%name)) then + write (unit, fmt) "- name", self%name + end if + if (allocated(self%source_dir)) then + if (self%source_dir /= "app" .or. pr > 2) then + write (unit, fmt) "- source directory", self%source_dir + end if + end if + if (allocated(self%main)) then + if (self%main /= "main.f90" .or. pr > 2) then + write (unit, fmt) "- program source", self%main + end if + end if + + if (allocated(self%dependency)) then + if (size(self%dependency) > 1 .or. pr > 2) then + write (unit, fmti) "- dependencies", size(self%dependency) + end if + do ii = 1, size(self%dependency) + call self%dependency(ii)%info(unit, pr - 1) + end do + end if + end subroutine info end module fpm_manifest_executable diff --git a/src/fpm/manifest/install.f90 b/src/fpm/manifest/install.f90 index 6175873937..865e72abc0 100644 --- a/src/fpm/manifest/install.f90 +++ b/src/fpm/manifest/install.f90 @@ -6,8 +6,8 @@ !>library = bool !>``` module fpm_manifest_install - use fpm_error, only : error_t, fatal_error, syntax_error - use fpm_toml, only : toml_table, toml_key, toml_stat, get_value + use fpm_error, only: error_t, fatal_error, syntax_error + use fpm_toml, only: toml_table, toml_key, toml_stat, get_value implicit none private @@ -47,7 +47,6 @@ subroutine new_install_config(self, table, error) end subroutine new_install_config - !> Check local schema for allowed entries subroutine check(table, error) @@ -64,11 +63,11 @@ subroutine check(table, error) if (size(list) < 1) return do ikey = 1, size(list) - select case(list(ikey)%key) + select case (list(ikey)%key) case default call syntax_error(error, "Key "//list(ikey)%key//" is not allowed in install table") exit - case("library") + case ("library") continue end select end do @@ -99,8 +98,8 @@ subroutine info(self, unit, verbosity) if (pr < 1) return - write(unit, fmt) "Install configuration" - write(unit, fmt) " - library install", & + write (unit, fmt) "Install configuration" + write (unit, fmt) " - library install", & & trim(merge("enabled ", "disabled", self%library)) end subroutine info diff --git a/src/fpm/manifest/library.f90 b/src/fpm/manifest/library.f90 index 68ccc203ef..d781aa7225 100644 --- a/src/fpm/manifest/library.f90 +++ b/src/fpm/manifest/library.f90 @@ -9,134 +9,128 @@ !>build-script = "file" !>``` module fpm_manifest_library - use fpm_error, only : error_t, syntax_error - use fpm_strings, only: string_t, string_cat - use fpm_toml, only : toml_table, toml_key, toml_stat, get_value, get_list - implicit none - private + use fpm_error, only: error_t, syntax_error + use fpm_strings, only: string_t, string_cat + use fpm_toml, only: toml_table, toml_key, toml_stat, get_value, get_list + implicit none + private - public :: library_config_t, new_library + public :: library_config_t, new_library + !> Configuration meta data for a library + type :: library_config_t - !> Configuration meta data for a library - type :: library_config_t + !> Source path prefix + character(len=:), allocatable :: source_dir - !> Source path prefix - character(len=:), allocatable :: source_dir + !> Include path prefix + type(string_t), allocatable :: include_dir(:) - !> Include path prefix - type(string_t), allocatable :: include_dir(:) + !> Alternative build script to be invoked + character(len=:), allocatable :: build_script - !> Alternative build script to be invoked - character(len=:), allocatable :: build_script + contains - contains - - !> Print information on this instance - procedure :: info - - end type library_config_t + !> Print information on this instance + procedure :: info + end type library_config_t contains + !> Construct a new library configuration from a TOML data structure + subroutine new_library(self, table, error) - !> Construct a new library configuration from a TOML data structure - subroutine new_library(self, table, error) - - !> Instance of the library configuration - type(library_config_t), intent(out) :: self - - !> Instance of the TOML data structure - type(toml_table), intent(inout) :: table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - call check(table, error) - if (allocated(error)) return + !> Instance of the library configuration + type(library_config_t), intent(out) :: self - call get_value(table, "source-dir", self%source_dir, "src") - call get_value(table, "build-script", self%build_script) + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table - call get_list(table, "include-dir", self%include_dir, error) - if (allocated(error)) return + !> Error handling + type(error_t), allocatable, intent(out) :: error - ! Set default value of include-dir if not found in manifest - if (.not.allocated(self%include_dir)) then - self%include_dir = [string_t("include")] - end if + call check(table, error) + if (allocated(error)) return - end subroutine new_library + call get_value(table, "source-dir", self%source_dir, "src") + call get_value(table, "build-script", self%build_script) + call get_list(table, "include-dir", self%include_dir, error) + if (allocated(error)) return - !> Check local schema for allowed entries - subroutine check(table, error) + ! Set default value of include-dir if not found in manifest + if (.not. allocated(self%include_dir)) then + self%include_dir = [string_t("include")] + end if - !> Instance of the TOML data structure - type(toml_table), intent(inout) :: table + end subroutine new_library - !> Error handling - type(error_t), allocatable, intent(out) :: error + !> Check local schema for allowed entries + subroutine check(table, error) - type(toml_key), allocatable :: list(:) - integer :: ikey + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table - call table%get_keys(list) + !> Error handling + type(error_t), allocatable, intent(out) :: error - ! table can be empty - if (size(list) < 1) return + type(toml_key), allocatable :: list(:) + integer :: ikey - do ikey = 1, size(list) - select case(list(ikey)%key) - case default - call syntax_error(error, "Key "//list(ikey)%key//" is not allowed in library") - exit + call table%get_keys(list) - case("source-dir", "include-dir", "build-script") - continue + ! table can be empty + if (size(list) < 1) return - end select - end do + do ikey = 1, size(list) + select case (list(ikey)%key) + case default + call syntax_error(error, "Key "//list(ikey)%key//" is not allowed in library") + exit - end subroutine check + case ("source-dir", "include-dir", "build-script") + continue + end select + end do - !> Write information on instance - subroutine info(self, unit, verbosity) + end subroutine check - !> Instance of the library configuration - class(library_config_t), intent(in) :: self + !> Write information on instance + subroutine info(self, unit, verbosity) - !> Unit for IO - integer, intent(in) :: unit + !> Instance of the library configuration + class(library_config_t), intent(in) :: self - !> Verbosity of the printout - integer, intent(in), optional :: verbosity + !> Unit for IO + integer, intent(in) :: unit - integer :: pr - character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)' + !> Verbosity of the printout + integer, intent(in), optional :: verbosity - if (present(verbosity)) then - pr = verbosity - else - pr = 1 - end if + integer :: pr + character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)' - if (pr < 1) return + if (present(verbosity)) then + pr = verbosity + else + pr = 1 + end if - write(unit, fmt) "Library target" - if (allocated(self%source_dir)) then - write(unit, fmt) "- source directory", self%source_dir - end if - if (allocated(self%include_dir)) then - write(unit, fmt) "- include directory", string_cat(self%include_dir,",") - end if - if (allocated(self%build_script)) then - write(unit, fmt) "- custom build", self%build_script - end if + if (pr < 1) return - end subroutine info + write (unit, fmt) "Library target" + if (allocated(self%source_dir)) then + write (unit, fmt) "- source directory", self%source_dir + end if + if (allocated(self%include_dir)) then + write (unit, fmt) "- include directory", string_cat(self%include_dir, ",") + end if + if (allocated(self%build_script)) then + write (unit, fmt) "- custom build", self%build_script + end if + end subroutine info end module fpm_manifest_library diff --git a/src/fpm/manifest/package.f90 b/src/fpm/manifest/package.f90 index de124a0b3e..67f464227e 100644 --- a/src/fpm/manifest/package.f90 +++ b/src/fpm/manifest/package.f90 @@ -33,463 +33,454 @@ !>[extra] !>``` module fpm_manifest_package - use fpm_manifest_build, only: build_config_t, new_build_config - use fpm_manifest_dependency, only : dependency_config_t, new_dependencies - use fpm_manifest_profile, only : profile_config_t, new_profiles, get_default_profiles - use fpm_manifest_example, only : example_config_t, new_example - use fpm_manifest_executable, only : executable_config_t, new_executable - use fpm_manifest_library, only : library_config_t, new_library - use fpm_manifest_install, only: install_config_t, new_install_config - use fpm_manifest_test, only : test_config_t, new_test - use fpm_mainfest_preprocess, only : preprocess_config_t, new_preprocessors - use fpm_filesystem, only : exists, getline, join_path - use fpm_error, only : error_t, fatal_error, syntax_error, bad_name_error - use fpm_toml, only : toml_table, toml_array, toml_key, toml_stat, get_value, & - & len - use fpm_versioning, only : version_t, new_version - use fpm_filesystem, only: join_path - implicit none - private + use fpm_manifest_build, only: build_config_t, new_build_config + use fpm_manifest_dependency, only: dependency_config_t, new_dependencies + use fpm_manifest_profile, only: profile_config_t, new_profiles, get_default_profiles + use fpm_manifest_example, only: example_config_t, new_example + use fpm_manifest_executable, only: executable_config_t, new_executable + use fpm_manifest_library, only: library_config_t, new_library + use fpm_manifest_install, only: install_config_t, new_install_config + use fpm_manifest_test, only: test_config_t, new_test + use fpm_mainfest_preprocess, only: preprocess_config_t, new_preprocessors + use fpm_filesystem, only: exists, getline, join_path + use fpm_error, only: error_t, fatal_error, syntax_error, bad_name_error + use fpm_toml, only: toml_table, toml_array, toml_key, toml_stat, get_value, & + & len + use fpm_versioning, only: version_t, new_version + use fpm_filesystem, only: join_path + implicit none + private - public :: package_config_t, new_package + public :: package_config_t, new_package + interface unique_programs + module procedure :: unique_programs1 + module procedure :: unique_programs2 + end interface unique_programs - interface unique_programs - module procedure :: unique_programs1 - module procedure :: unique_programs2 - end interface unique_programs + !> Package meta data + type :: package_config_t + !> Name of the package + character(len=:), allocatable :: name - !> Package meta data - type :: package_config_t + !> Package version + type(version_t) :: version - !> Name of the package - character(len=:), allocatable :: name + !> Build configuration data + type(build_config_t) :: build - !> Package version - type(version_t) :: version + !> Installation configuration data + type(install_config_t) :: install - !> Build configuration data - type(build_config_t) :: build + !> Library meta data + type(library_config_t), allocatable :: library - !> Installation configuration data - type(install_config_t) :: install + !> Executable meta data + type(executable_config_t), allocatable :: executable(:) - !> Library meta data - type(library_config_t), allocatable :: library + !> Dependency meta data + type(dependency_config_t), allocatable :: dependency(:) - !> Executable meta data - type(executable_config_t), allocatable :: executable(:) + !> Development dependency meta data + type(dependency_config_t), allocatable :: dev_dependency(:) - !> Dependency meta data - type(dependency_config_t), allocatable :: dependency(:) + !> Profiles meta data + type(profile_config_t), allocatable :: profiles(:) - !> Development dependency meta data - type(dependency_config_t), allocatable :: dev_dependency(:) + !> Example meta data + type(example_config_t), allocatable :: example(:) - !> Profiles meta data - type(profile_config_t), allocatable :: profiles(:) + !> Test meta data + type(test_config_t), allocatable :: test(:) - !> Example meta data - type(example_config_t), allocatable :: example(:) + !> Preprocess meta data + type(preprocess_config_t), allocatable :: preprocess(:) - !> Test meta data - type(test_config_t), allocatable :: test(:) + contains - !> Preprocess meta data - type(preprocess_config_t), allocatable :: preprocess(:) - - contains - - !> Print information on this instance - procedure :: info - - end type package_config_t + !> Print information on this instance + procedure :: info + end type package_config_t contains - - !> Construct a new package configuration from a TOML data structure - subroutine new_package(self, table, root, error) - - !> Instance of the package configuration - type(package_config_t), intent(out) :: self - - !> Instance of the TOML data structure - type(toml_table), intent(inout) :: table - - !> Root directory of the manifest - character(len=*), intent(in), optional :: root - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - ! Backspace (8), tabulator (9), newline (10), formfeed (12) and carriage - ! return (13) are invalid in package names - character(len=*), parameter :: invalid_chars = & - achar(8) // achar(9) // achar(10) // achar(12) // achar(13) - type(toml_table), pointer :: child, node - type(toml_array), pointer :: children - character(len=:), allocatable :: version, version_file - integer :: ii, nn, stat, io - - call check(table, error) - if (allocated(error)) return - - call get_value(table, "name", self%name) - if (.not.allocated(self%name)) then - call syntax_error(error, "Could not retrieve package name") - return + !> Construct a new package configuration from a TOML data structure + subroutine new_package(self, table, root, error) + + !> Instance of the package configuration + type(package_config_t), intent(out) :: self + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Root directory of the manifest + character(len=*), intent(in), optional :: root + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + ! Backspace (8), tabulator (9), newline (10), formfeed (12) and carriage + ! return (13) are invalid in package names + character(len=*), parameter :: invalid_chars = & + achar(8)//achar(9)//achar(10)//achar(12)//achar(13) + type(toml_table), pointer :: child, node + type(toml_array), pointer :: children + character(len=:), allocatable :: version, version_file + integer :: ii, nn, stat, io + + call check(table, error) + if (allocated(error)) return + + call get_value(table, "name", self%name) + if (.not. allocated(self%name)) then + call syntax_error(error, "Could not retrieve package name") + return + end if + if (bad_name_error(error, 'package', self%name)) then + return + end if + + if (len(self%name) <= 0) then + call syntax_error(error, "Package name must be a non-empty string") + return + end if + + ii = scan(self%name, invalid_chars) + if (ii > 0) then + call syntax_error(error, "Package name contains invalid characters") + return + end if + + call get_value(table, "build", child, requested=.true., stat=stat) + if (stat /= toml_stat%success) then + call fatal_error(error, "Type mismatch for build entry, must be a table") + return + end if + call new_build_config(self%build, child, error) + if (allocated(error)) return + + call get_value(table, "install", child, requested=.true., stat=stat) + if (stat /= toml_stat%success) then + call fatal_error(error, "Type mismatch for install entry, must be a table") + return + end if + call new_install_config(self%install, child, error) + if (allocated(error)) return + + call get_value(table, "version", version, "0") + call new_version(self%version, version, error) + if (allocated(error) .and. present(root)) then + version_file = join_path(root, version) + if (exists(version_file)) then + deallocate (error) + open (file=version_file, newunit=io, iostat=stat) + if (stat == 0) then + call getline(io, version, iostat=stat) end if - if (bad_name_error(error,'package',self%name))then - return - endif - - if (len(self%name) <= 0) then - call syntax_error(error, "Package name must be a non-empty string") - return + if (stat == 0) then + close (io, iostat=stat) end if - - ii = scan(self%name, invalid_chars) - if (ii > 0) then - call syntax_error(error, "Package name contains invalid characters") - return + if (stat == 0) then + call new_version(self%version, version, error) + else + call fatal_error(error, "Reading version number from file '" & + & //version_file//"' failed") end if - - call get_value(table, "build", child, requested=.true., stat=stat) + end if + end if + if (allocated(error)) return + + call get_value(table, "dependencies", child, requested=.false.) + if (associated(child)) then + call new_dependencies(self%dependency, child, root, error) + if (allocated(error)) return + end if + + call get_value(table, "dev-dependencies", child, requested=.false.) + if (associated(child)) then + call new_dependencies(self%dev_dependency, child, root, error) + if (allocated(error)) return + end if + + call get_value(table, "library", child, requested=.false.) + if (associated(child)) then + allocate (self%library) + call new_library(self%library, child, error) + if (allocated(error)) return + end if + + call get_value(table, "profiles", child, requested=.false.) + if (associated(child)) then + call new_profiles(self%profiles, child, error) + if (allocated(error)) return + else + self%profiles = get_default_profiles(error) + if (allocated(error)) return + end if + + call get_value(table, "executable", children, requested=.false.) + if (associated(children)) then + nn = len(children) + allocate (self%executable(nn)) + do ii = 1, nn + call get_value(children, ii, node, stat=stat) if (stat /= toml_stat%success) then - call fatal_error(error, "Type mismatch for build entry, must be a table") - return + call fatal_error(error, "Could not retrieve executable from array entry") + exit end if - call new_build_config(self%build, child, error) - if (allocated(error)) return - - call get_value(table, "install", child, requested=.true., stat=stat) + call new_executable(self%executable(ii), node, error) + if (allocated(error)) exit + end do + if (allocated(error)) return + + call unique_programs(self%executable, error) + if (allocated(error)) return + end if + + call get_value(table, "example", children, requested=.false.) + if (associated(children)) then + nn = len(children) + allocate (self%example(nn)) + do ii = 1, nn + call get_value(children, ii, node, stat=stat) if (stat /= toml_stat%success) then - call fatal_error(error, "Type mismatch for install entry, must be a table") - return + call fatal_error(error, "Could not retrieve example from array entry") + exit end if - call new_install_config(self%install, child, error) - if (allocated(error)) return - - call get_value(table, "version", version, "0") - call new_version(self%version, version, error) - if (allocated(error) .and. present(root)) then - version_file = join_path(root, version) - if (exists(version_file)) then - deallocate(error) - open(file=version_file, newunit=io, iostat=stat) - if (stat == 0) then - call getline(io, version, iostat=stat) - end if - if (stat == 0) then - close(io, iostat=stat) - end if - if (stat == 0) then - call new_version(self%version, version, error) - else - call fatal_error(error, "Reading version number from file '" & - & //version_file//"' failed") - end if - end if - end if - if (allocated(error)) return - - call get_value(table, "dependencies", child, requested=.false.) - if (associated(child)) then - call new_dependencies(self%dependency, child, root, error) - if (allocated(error)) return - end if - - call get_value(table, "dev-dependencies", child, requested=.false.) - if (associated(child)) then - call new_dependencies(self%dev_dependency, child, root, error) - if (allocated(error)) return - end if - - call get_value(table, "library", child, requested=.false.) - if (associated(child)) then - allocate(self%library) - call new_library(self%library, child, error) - if (allocated(error)) return - end if - - call get_value(table, "profiles", child, requested=.false.) - if (associated(child)) then - call new_profiles(self%profiles, child, error) - if (allocated(error)) return - else - self%profiles = get_default_profiles(error) - if (allocated(error)) return - end if - - call get_value(table, "executable", children, requested=.false.) - if (associated(children)) then - nn = len(children) - allocate(self%executable(nn)) - do ii = 1, nn - call get_value(children, ii, node, stat=stat) - if (stat /= toml_stat%success) then - call fatal_error(error, "Could not retrieve executable from array entry") - exit - end if - call new_executable(self%executable(ii), node, error) - if (allocated(error)) exit - end do - if (allocated(error)) return - - call unique_programs(self%executable, error) - if (allocated(error)) return - end if - - call get_value(table, "example", children, requested=.false.) - if (associated(children)) then - nn = len(children) - allocate(self%example(nn)) - do ii = 1, nn - call get_value(children, ii, node, stat=stat) - if (stat /= toml_stat%success) then - call fatal_error(error, "Could not retrieve example from array entry") - exit - end if - call new_example(self%example(ii), node, error) - if (allocated(error)) exit - end do - if (allocated(error)) return - - call unique_programs(self%example, error) - if (allocated(error)) return - - if (allocated(self%executable)) then - call unique_programs(self%executable, self%example, error) - if (allocated(error)) return - end if - end if - - call get_value(table, "test", children, requested=.false.) - if (associated(children)) then - nn = len(children) - allocate(self%test(nn)) - do ii = 1, nn - call get_value(children, ii, node, stat=stat) - if (stat /= toml_stat%success) then - call fatal_error(error, "Could not retrieve test from array entry") - exit - end if - call new_test(self%test(ii), node, error) - if (allocated(error)) exit - end do - if (allocated(error)) return - - call unique_programs(self%test, error) - if (allocated(error)) return - end if - - call get_value(table, "preprocess", child, requested=.false.) - if (associated(child)) then - call new_preprocessors(self%preprocess, child, error) - if (allocated(error)) return - end if - end subroutine new_package - - - !> Check local schema for allowed entries - subroutine check(table, error) - - !> Instance of the TOML data structure - type(toml_table), intent(inout) :: table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_key), allocatable :: list(:) - logical :: name_present - integer :: ikey + call new_example(self%example(ii), node, error) + if (allocated(error)) exit + end do + if (allocated(error)) return - name_present = .false. + call unique_programs(self%example, error) + if (allocated(error)) return - call table%get_keys(list) - - if (size(list) < 1) then - call syntax_error(error, "Package file is empty") - return - end if - - do ikey = 1, size(list) - select case(list(ikey)%key) - case default - call syntax_error(error, "Key "//list(ikey)%key//" is not allowed in package file") - exit - - case("name") - name_present = .true. - - case("version", "license", "author", "maintainer", "copyright", & - & "description", "keywords", "categories", "homepage", "build", & - & "dependencies", "dev-dependencies", "profiles", "test", "executable", & - & "example", "library", "install", "extra", "preprocess") - continue - - end select - end do + if (allocated(self%executable)) then + call unique_programs(self%executable, self%example, error) if (allocated(error)) return - - if (.not.name_present) then - call syntax_error(error, "Package name is not provided, please add a name entry") + end if + end if + + call get_value(table, "test", children, requested=.false.) + if (associated(children)) then + nn = len(children) + allocate (self%test(nn)) + do ii = 1, nn + call get_value(children, ii, node, stat=stat) + if (stat /= toml_stat%success) then + call fatal_error(error, "Could not retrieve test from array entry") + exit end if + call new_test(self%test(ii), node, error) + if (allocated(error)) exit + end do + if (allocated(error)) return - end subroutine check - - - !> Write information on instance - subroutine info(self, unit, verbosity) - - !> Instance of the package configuration - class(package_config_t), intent(in) :: self + call unique_programs(self%test, error) + if (allocated(error)) return + end if - !> Unit for IO - integer, intent(in) :: unit + call get_value(table, "preprocess", child, requested=.false.) + if (associated(child)) then + call new_preprocessors(self%preprocess, child, error) + if (allocated(error)) return + end if + end subroutine new_package + + !> Check local schema for allowed entries + subroutine check(table, error) - !> Verbosity of the printout - integer, intent(in), optional :: verbosity - - integer :: pr, ii - character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)', & - & fmti = '("#", 1x, a, t30, i0)' - - if (present(verbosity)) then - pr = verbosity - else - pr = 1 - end if - - if (pr < 1) return - - write(unit, fmt) "Package" - if (allocated(self%name)) then - write(unit, fmt) "- name", self%name + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_key), allocatable :: list(:) + logical :: name_present + integer :: ikey + + name_present = .false. + + call table%get_keys(list) + + if (size(list) < 1) then + call syntax_error(error, "Package file is empty") + return + end if + + do ikey = 1, size(list) + select case (list(ikey)%key) + case default + call syntax_error(error, "Key "//list(ikey)%key//" is not allowed in package file") + exit + + case ("name") + name_present = .true. + + case ("version", "license", "author", "maintainer", "copyright", & + & "description", "keywords", "categories", "homepage", "build", & + & "dependencies", "dev-dependencies", "profiles", "test", "executable", & + & "example", "library", "install", "extra", "preprocess") + continue + + end select + end do + if (allocated(error)) return + + if (.not. name_present) then + call syntax_error(error, "Package name is not provided, please add a name entry") + end if + + end subroutine check + + !> Write information on instance + subroutine info(self, unit, verbosity) + + !> Instance of the package configuration + class(package_config_t), intent(in) :: self + + !> Unit for IO + integer, intent(in) :: unit + + !> Verbosity of the printout + integer, intent(in), optional :: verbosity + + integer :: pr, ii + character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)', & + & fmti = '("#", 1x, a, t30, i0)' + + if (present(verbosity)) then + pr = verbosity + else + pr = 1 + end if + + if (pr < 1) return + + write (unit, fmt) "Package" + if (allocated(self%name)) then + write (unit, fmt) "- name", self%name + end if + + call self%build%info(unit, pr - 1) + + call self%install%info(unit, pr - 1) + + if (allocated(self%library)) then + write (unit, fmt) "- target", "archive" + call self%library%info(unit, pr - 1) + end if + + if (allocated(self%executable)) then + if (size(self%executable) > 1 .or. pr > 2) then + write (unit, fmti) "- executables", size(self%executable) + end if + do ii = 1, size(self%executable) + call self%executable(ii)%info(unit, pr - 1) + end do + end if + + if (allocated(self%dependency)) then + if (size(self%dependency) > 1 .or. pr > 2) then + write (unit, fmti) "- dependencies", size(self%dependency) + end if + do ii = 1, size(self%dependency) + call self%dependency(ii)%info(unit, pr - 1) + end do + end if + + if (allocated(self%example)) then + if (size(self%example) > 1 .or. pr > 2) then + write (unit, fmti) "- examples", size(self%example) + end if + do ii = 1, size(self%example) + call self%example(ii)%info(unit, pr - 1) + end do + end if + + if (allocated(self%test)) then + if (size(self%test) > 1 .or. pr > 2) then + write (unit, fmti) "- tests", size(self%test) + end if + do ii = 1, size(self%test) + call self%test(ii)%info(unit, pr - 1) + end do + end if + + if (allocated(self%dev_dependency)) then + if (size(self%dev_dependency) > 1 .or. pr > 2) then + write (unit, fmti) "- development deps.", size(self%dev_dependency) + end if + do ii = 1, size(self%dev_dependency) + call self%dev_dependency(ii)%info(unit, pr - 1) + end do + end if + + if (allocated(self%profiles)) then + if (size(self%profiles) > 1 .or. pr > 2) then + write (unit, fmti) "- profiles", size(self%profiles) + end if + do ii = 1, size(self%profiles) + call self%profiles(ii)%info(unit, pr - 1) + end do + end if + + end subroutine info + + !> Check whether or not the names in a set of executables are unique + subroutine unique_programs1(executable, error) + + !> Array of executables + class(executable_config_t), intent(in) :: executable(:) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: i, j + + do i = 1, size(executable) + do j = 1, i - 1 + if (executable(i)%name == executable(j)%name) then + call fatal_error(error, "The program named '"// & + executable(j)%name//"' is duplicated. "// & + "Unique program names are required.") + exit end if + end do + end do + if (allocated(error)) return - call self%build%info(unit, pr - 1) + end subroutine unique_programs1 - call self%install%info(unit, pr - 1) + !> Check whether or not the names in a set of executables are unique + subroutine unique_programs2(executable_i, executable_j, error) - if (allocated(self%library)) then - write(unit, fmt) "- target", "archive" - call self%library%info(unit, pr - 1) - end if + !> Array of executables + class(executable_config_t), intent(in) :: executable_i(:) - if (allocated(self%executable)) then - if (size(self%executable) > 1 .or. pr > 2) then - write(unit, fmti) "- executables", size(self%executable) - end if - do ii = 1, size(self%executable) - call self%executable(ii)%info(unit, pr - 1) - end do - end if - - if (allocated(self%dependency)) then - if (size(self%dependency) > 1 .or. pr > 2) then - write(unit, fmti) "- dependencies", size(self%dependency) - end if - do ii = 1, size(self%dependency) - call self%dependency(ii)%info(unit, pr - 1) - end do - end if + !> Array of executables + class(executable_config_t), intent(in) :: executable_j(:) - if (allocated(self%example)) then - if (size(self%example) > 1 .or. pr > 2) then - write(unit, fmti) "- examples", size(self%example) - end if - do ii = 1, size(self%example) - call self%example(ii)%info(unit, pr - 1) - end do - end if + !> Error handling + type(error_t), allocatable, intent(out) :: error - if (allocated(self%test)) then - if (size(self%test) > 1 .or. pr > 2) then - write(unit, fmti) "- tests", size(self%test) - end if - do ii = 1, size(self%test) - call self%test(ii)%info(unit, pr - 1) - end do - end if + integer :: i, j - if (allocated(self%dev_dependency)) then - if (size(self%dev_dependency) > 1 .or. pr > 2) then - write(unit, fmti) "- development deps.", size(self%dev_dependency) - end if - do ii = 1, size(self%dev_dependency) - call self%dev_dependency(ii)%info(unit, pr - 1) - end do - end if - - if (allocated(self%profiles)) then - if (size(self%profiles) > 1 .or. pr > 2) then - write(unit, fmti) "- profiles", size(self%profiles) - end if - do ii = 1, size(self%profiles) - call self%profiles(ii)%info(unit, pr - 1) - end do + do i = 1, size(executable_i) + do j = 1, size(executable_j) + if (executable_i(i)%name == executable_j(j)%name) then + call fatal_error(error, "The program named '"// & + executable_j(j)%name//"' is duplicated. "// & + "Unique program names are required.") + exit end if + end do + end do + if (allocated(error)) return - end subroutine info - - - !> Check whether or not the names in a set of executables are unique - subroutine unique_programs1(executable, error) - - !> Array of executables - class(executable_config_t), intent(in) :: executable(:) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: i, j - - do i = 1, size(executable) - do j = 1, i - 1 - if (executable(i)%name == executable(j)%name) then - call fatal_error(error, "The program named '"//& - executable(j)%name//"' is duplicated. "//& - "Unique program names are required.") - exit - end if - end do - end do - if (allocated(error)) return - - end subroutine unique_programs1 - - - !> Check whether or not the names in a set of executables are unique - subroutine unique_programs2(executable_i, executable_j, error) - - !> Array of executables - class(executable_config_t), intent(in) :: executable_i(:) - - !> Array of executables - class(executable_config_t), intent(in) :: executable_j(:) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: i, j - - do i = 1, size(executable_i) - do j = 1, size(executable_j) - if (executable_i(i)%name == executable_j(j)%name) then - call fatal_error(error, "The program named '"//& - executable_j(j)%name//"' is duplicated. "//& - "Unique program names are required.") - exit - end if - end do - end do - if (allocated(error)) return - - end subroutine unique_programs2 - + end subroutine unique_programs2 end module fpm_manifest_package diff --git a/src/fpm/manifest/preprocess.f90 b/src/fpm/manifest/preprocess.f90 index 6132d97210..a808409b95 100644 --- a/src/fpm/manifest/preprocess.f90 +++ b/src/fpm/manifest/preprocess.f90 @@ -11,184 +11,184 @@ !> ``` module fpm_mainfest_preprocess - use fpm_error, only : error_t, syntax_error - use fpm_strings, only : string_t - use fpm_toml, only : toml_table, toml_key, toml_stat, get_value, get_list - implicit none - private + use fpm_error, only: error_t, syntax_error + use fpm_strings, only: string_t + use fpm_toml, only: toml_table, toml_key, toml_stat, get_value, get_list + implicit none + private - public :: preprocess_config_t, new_preprocess_config, new_preprocessors + public :: preprocess_config_t, new_preprocess_config, new_preprocessors - !> Configuration meta data for a preprocessor - type :: preprocess_config_t + !> Configuration meta data for a preprocessor + type :: preprocess_config_t - !> Name of the preprocessor - character(len=:), allocatable :: name + !> Name of the preprocessor + character(len=:), allocatable :: name - !> Suffixes of the files to be preprocessed - type(string_t), allocatable :: suffixes(:) + !> Suffixes of the files to be preprocessed + type(string_t), allocatable :: suffixes(:) - !> Directories to search for files to be preprocessed - type(string_t), allocatable :: directories(:) + !> Directories to search for files to be preprocessed + type(string_t), allocatable :: directories(:) - !> Macros to be defined for the preprocessor - type(string_t), allocatable :: macros(:) + !> Macros to be defined for the preprocessor + type(string_t), allocatable :: macros(:) - contains + contains - !> Print information on this instance - procedure :: info + !> Print information on this instance + procedure :: info - end type preprocess_config_t + end type preprocess_config_t contains - !> Construct a new preprocess configuration from TOML data structure - subroutine new_preprocess_config(self, table, error) + !> Construct a new preprocess configuration from TOML data structure + subroutine new_preprocess_config(self, table, error) - !> Instance of the preprocess configuration - type(preprocess_config_t), intent(out) :: self + !> Instance of the preprocess configuration + type(preprocess_config_t), intent(out) :: self - !> Instance of the TOML data structure. - type(toml_table), intent(inout) :: table + !> Instance of the TOML data structure. + type(toml_table), intent(inout) :: table - !> Error handling - type(error_t), allocatable, intent(out) :: error + !> Error handling + type(error_t), allocatable, intent(out) :: error - call check(table, error) - if (allocated(error)) return + call check(table, error) + if (allocated(error)) return - call table%get_key(self%name) + call table%get_key(self%name) - call get_list(table, "suffixes", self%suffixes, error) - if (allocated(error)) return + call get_list(table, "suffixes", self%suffixes, error) + if (allocated(error)) return - call get_list(table, "directories", self%directories, error) - if (allocated(error)) return + call get_list(table, "directories", self%directories, error) + if (allocated(error)) return - call get_list(table, "macros", self%macros, error) - if (allocated(error)) return + call get_list(table, "macros", self%macros, error) + if (allocated(error)) return - end subroutine new_preprocess_config + end subroutine new_preprocess_config - !> Check local schema for allowed entries - subroutine check(table, error) + !> Check local schema for allowed entries + subroutine check(table, error) - !> Instance of the TOML data structure. - type(toml_table), intent(inout) :: table + !> Instance of the TOML data structure. + type(toml_table), intent(inout) :: table - !> Error handling - type(error_t), allocatable, intent(inout) :: error + !> Error handling + type(error_t), allocatable, intent(inout) :: error - character(len=:), allocatable :: name - type(toml_key), allocatable :: list(:) - logical :: suffixes_present, directories_present, macros_present - integer :: ikey + character(len=:), allocatable :: name + type(toml_key), allocatable :: list(:) + logical :: suffixes_present, directories_present, macros_present + integer :: ikey - suffixes_present = .false. - directories_present = .false. - macros_present = .false. + suffixes_present = .false. + directories_present = .false. + macros_present = .false. - call table%get_key(name) - call table%get_keys(list) + call table%get_key(name) + call table%get_keys(list) - do ikey = 1, size(list) - select case(list(ikey)%key) - case default - call syntax_error(error, "Key " // list(ikey)%key // "is not allowed in preprocessor"//name) - exit - case("suffixes") - suffixes_present = .true. - case("directories") - directories_present = .true. - case("macros") - macros_present = .true. - end select - end do - end subroutine check + do ikey = 1, size(list) + select case (list(ikey)%key) + case default + call syntax_error(error, "Key "//list(ikey)%key//"is not allowed in preprocessor"//name) + exit + case ("suffixes") + suffixes_present = .true. + case ("directories") + directories_present = .true. + case ("macros") + macros_present = .true. + end select + end do + end subroutine check - !> Construct new preprocess array from a TOML data structure. - subroutine new_preprocessors(preprocessors, table, error) + !> Construct new preprocess array from a TOML data structure. + subroutine new_preprocessors(preprocessors, table, error) - !> Instance of the preprocess configuration - type(preprocess_config_t), allocatable, intent(out) :: preprocessors(:) + !> Instance of the preprocess configuration + type(preprocess_config_t), allocatable, intent(out) :: preprocessors(:) - !> Instance of the TOML data structure - type(toml_table), intent(inout) :: table + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table - !> Error handling - type(error_t), allocatable, intent(out) :: error + !> Error handling + type(error_t), allocatable, intent(out) :: error - type(toml_table), pointer :: node - type(toml_key), allocatable :: list(:) - integer :: iprep, stat + type(toml_table), pointer :: node + type(toml_key), allocatable :: list(:) + integer :: iprep, stat - call table%get_keys(list) + call table%get_keys(list) - ! An empty table is not allowed - if (size(list) == 0) then - call syntax_error(error, "No preprocessors defined") - end if + ! An empty table is not allowed + if (size(list) == 0) then + call syntax_error(error, "No preprocessors defined") + end if - allocate(preprocessors(size(list))) - do iprep = 1, size(list) - call get_value(table, list(iprep)%key, node, stat=stat) - if (stat /= toml_stat%success) then - call syntax_error(error, "Preprocessor "//list(iprep)%key//" must be a table entry") - exit - end if - call new_preprocess_config(preprocessors(iprep), node, error) - if (allocated(error)) exit - end do + allocate (preprocessors(size(list))) + do iprep = 1, size(list) + call get_value(table, list(iprep)%key, node, stat=stat) + if (stat /= toml_stat%success) then + call syntax_error(error, "Preprocessor "//list(iprep)%key//" must be a table entry") + exit + end if + call new_preprocess_config(preprocessors(iprep), node, error) + if (allocated(error)) exit + end do - end subroutine new_preprocessors + end subroutine new_preprocessors - !> Write information on this instance - subroutine info(self, unit, verbosity) + !> Write information on this instance + subroutine info(self, unit, verbosity) - !> Instance of the preprocess configuration - class(preprocess_config_t), intent(in) :: self + !> Instance of the preprocess configuration + class(preprocess_config_t), intent(in) :: self - !> Unit for IO - integer, intent(in) :: unit + !> Unit for IO + integer, intent(in) :: unit - !> Verbosity of the printout - integer, intent(in), optional :: verbosity + !> Verbosity of the printout + integer, intent(in), optional :: verbosity - integer :: pr, ilink - character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)' + integer :: pr, ilink + character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)' - if (present(verbosity)) then - pr = verbosity - else - pr = 1 - end if + if (present(verbosity)) then + pr = verbosity + else + pr = 1 + end if - if (pr < 1) return + if (pr < 1) return - write(unit, fmt) "Preprocessor" - if (allocated(self%name)) then - write(unit, fmt) "- name", self%name - end if - if (allocated(self%suffixes)) then - write(unit, fmt) " - suffixes" - do ilink = 1, size(self%suffixes) - write(unit, fmt) " - " // self%suffixes(ilink)%s - end do - end if - if (allocated(self%directories)) then - write(unit, fmt) " - directories" - do ilink = 1, size(self%directories) - write(unit, fmt) " - " // self%directories(ilink)%s - end do - end if - if (allocated(self%macros)) then - write(unit, fmt) " - macros" - do ilink = 1, size(self%macros) - write(unit, fmt) " - " // self%macros(ilink)%s - end do - end if + write (unit, fmt) "Preprocessor" + if (allocated(self%name)) then + write (unit, fmt) "- name", self%name + end if + if (allocated(self%suffixes)) then + write (unit, fmt) " - suffixes" + do ilink = 1, size(self%suffixes) + write (unit, fmt) " - "//self%suffixes(ilink)%s + end do + end if + if (allocated(self%directories)) then + write (unit, fmt) " - directories" + do ilink = 1, size(self%directories) + write (unit, fmt) " - "//self%directories(ilink)%s + end do + end if + if (allocated(self%macros)) then + write (unit, fmt) " - macros" + do ilink = 1, size(self%macros) + write (unit, fmt) " - "//self%macros(ilink)%s + end do + end if - end subroutine info + end subroutine info end module fpm_mainfest_preprocess diff --git a/src/fpm/manifest/profiles.f90 b/src/fpm/manifest/profiles.f90 index 2e84f0c6e9..1ceed7e30b 100644 --- a/src/fpm/manifest/profiles.f90 +++ b/src/fpm/manifest/profiles.f90 @@ -42,916 +42,915 @@ !>``` !> module fpm_manifest_profile - use fpm_error, only : error_t, syntax_error, fatal_error, fpm_stop - use fpm_toml, only : toml_table, toml_key, toml_stat, get_value - use fpm_strings, only: lower - use fpm_environment, only: get_os_type, OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_WINDOWS, & + use fpm_error, only: error_t, syntax_error, fatal_error, fpm_stop + use fpm_toml, only: toml_table, toml_key, toml_stat, get_value + use fpm_strings, only: lower + use fpm_environment, only: get_os_type, OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_WINDOWS, & OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD - use fpm_filesystem, only: join_path - implicit none - public :: profile_config_t, new_profile, new_profiles, get_default_profiles, & - & info_profile, find_profile, DEFAULT_COMPILER + use fpm_filesystem, only: join_path + implicit none + public :: profile_config_t, new_profile, new_profiles, get_default_profiles, & + & info_profile, find_profile, DEFAULT_COMPILER - !> Name of the default compiler - character(len=*), parameter :: DEFAULT_COMPILER = 'gfortran' - integer, parameter :: OS_ALL = -1 - character(len=:), allocatable :: path + !> Name of the default compiler + character(len=*), parameter :: DEFAULT_COMPILER = 'gfortran' + integer, parameter :: OS_ALL = -1 + character(len=:), allocatable :: path - !> Type storing file name - file scope compiler flags pairs - type :: file_scope_flag + !> Type storing file name - file scope compiler flags pairs + type :: file_scope_flag - !> Name of the file - character(len=:), allocatable :: file_name + !> Name of the file + character(len=:), allocatable :: file_name - !> File scope flags - character(len=:), allocatable :: flags + !> File scope flags + character(len=:), allocatable :: flags - end type file_scope_flag + end type file_scope_flag - !> Configuration meta data for a profile - type :: profile_config_t - !> Name of the profile - character(len=:), allocatable :: profile_name + !> Configuration meta data for a profile + type :: profile_config_t + !> Name of the profile + character(len=:), allocatable :: profile_name - !> Name of the compiler - character(len=:), allocatable :: compiler + !> Name of the compiler + character(len=:), allocatable :: compiler - !> Value repesenting OS - integer :: os_type - - !> Fortran compiler flags - character(len=:), allocatable :: flags + !> Value repesenting OS + integer :: os_type - !> C compiler flags - character(len=:), allocatable :: c_flags + !> Fortran compiler flags + character(len=:), allocatable :: flags - !> C++ compiler flags - character(len=:), allocatable :: cxx_flags + !> C compiler flags + character(len=:), allocatable :: c_flags - !> Link time compiler flags - character(len=:), allocatable :: link_time_flags + !> C++ compiler flags + character(len=:), allocatable :: cxx_flags + + !> Link time compiler flags + character(len=:), allocatable :: link_time_flags + + !> File scope flags + type(file_scope_flag), allocatable :: file_scope_flags(:) - !> File scope flags - type(file_scope_flag), allocatable :: file_scope_flags(:) + !> Is this profile one of the built-in ones? + logical :: is_built_in - !> Is this profile one of the built-in ones? - logical :: is_built_in + contains + + !> Print information on this instance + procedure :: info - contains + end type profile_config_t + +contains + + !> Construct a new profile configuration from a TOML data structure + function new_profile(profile_name, compiler, os_type, flags, c_flags, cxx_flags, & + link_time_flags, file_scope_flags, is_built_in) & + & result(profile) + + !> Name of the profile + character(len=*), intent(in) :: profile_name - !> Print information on this instance - procedure :: info + !> Name of the compiler + character(len=*), intent(in) :: compiler - end type profile_config_t + !> Type of the OS + integer, intent(in) :: os_type - contains + !> Fortran compiler flags + character(len=*), optional, intent(in) :: flags + + !> C compiler flags + character(len=*), optional, intent(in) :: c_flags + + !> C++ compiler flags + character(len=*), optional, intent(in) :: cxx_flags + + !> Link time compiler flags + character(len=*), optional, intent(in) :: link_time_flags + + !> File scope flags + type(file_scope_flag), optional, intent(in) :: file_scope_flags(:) + + !> Is this profile one of the built-in ones? + logical, optional, intent(in) :: is_built_in - !> Construct a new profile configuration from a TOML data structure - function new_profile(profile_name, compiler, os_type, flags, c_flags, cxx_flags, & - link_time_flags, file_scope_flags, is_built_in) & - & result(profile) - - !> Name of the profile - character(len=*), intent(in) :: profile_name - - !> Name of the compiler - character(len=*), intent(in) :: compiler - - !> Type of the OS - integer, intent(in) :: os_type - - !> Fortran compiler flags - character(len=*), optional, intent(in) :: flags + type(profile_config_t) :: profile - !> C compiler flags - character(len=*), optional, intent(in) :: c_flags - - !> C++ compiler flags - character(len=*), optional, intent(in) :: cxx_flags - - !> Link time compiler flags - character(len=*), optional, intent(in) :: link_time_flags - - !> File scope flags - type(file_scope_flag), optional, intent(in) :: file_scope_flags(:) - - !> Is this profile one of the built-in ones? - logical, optional, intent(in) :: is_built_in - - type(profile_config_t) :: profile - - profile%profile_name = profile_name - profile%compiler = compiler - profile%os_type = os_type - if (present(flags)) then - profile%flags = flags + profile%profile_name = profile_name + profile%compiler = compiler + profile%os_type = os_type + if (present(flags)) then + profile%flags = flags + else + profile%flags = "" + end if + if (present(c_flags)) then + profile%c_flags = c_flags + else + profile%c_flags = "" + end if + if (present(cxx_flags)) then + profile%cxx_flags = cxx_flags + else + profile%cxx_flags = "" + end if + if (present(link_time_flags)) then + profile%link_time_flags = link_time_flags + else + profile%link_time_flags = "" + end if + if (present(file_scope_flags)) then + profile%file_scope_flags = file_scope_flags + end if + if (present(is_built_in)) then + profile%is_built_in = is_built_in + else + profile%is_built_in = .false. + end if + + end function new_profile + + !> Check if compiler name is a valid compiler name + subroutine validate_compiler_name(compiler_name, is_valid) + + !> Name of a compiler + character(len=:), allocatable, intent(in) :: compiler_name + + !> Boolean value of whether compiler_name is valid or not + logical, intent(out) :: is_valid + select case (compiler_name) + case ("gfortran", "ifort", "ifx", "pgfortran", "nvfortran", "flang", "caf", & + & "f95", "lfortran", "lfc", "nagfor", "crayftn", "xlf90", "ftn95") + is_valid = .true. + case default + is_valid = .false. + end select + end subroutine validate_compiler_name + + !> Check if os_name is a valid name of a supported OS + subroutine validate_os_name(os_name, is_valid) + + !> Name of an operating system + character(len=:), allocatable, intent(in) :: os_name + + !> Boolean value of whether os_name is valid or not + logical, intent(out) :: is_valid + + select case (os_name) + case ("linux", "macos", "windows", "cygwin", "solaris", "freebsd", & + & "openbsd", "unknown") + is_valid = .true. + case default + is_valid = .false. + end select + + end subroutine validate_os_name + + !> Match os_type enum to a lowercase string with name of OS + subroutine match_os_type(os_name, os_type) + + !> Name of operating system + character(len=:), allocatable, intent(in) :: os_name + + !> Enum representing type of OS + integer, intent(out) :: os_type + + select case (os_name) + case ("linux"); os_type = OS_LINUX + case ("macos"); os_type = OS_WINDOWS + case ("cygwin"); os_type = OS_CYGWIN + case ("solaris"); os_type = OS_SOLARIS + case ("freebsd"); os_type = OS_FREEBSD + case ("openbsd"); os_type = OS_OPENBSD + case ("all"); os_type = OS_ALL + case default; os_type = OS_UNKNOWN + end select + + end subroutine match_os_type + + subroutine validate_profile_table(profile_name, compiler_name, key_list, table, error, os_valid) + + !> Name of profile + character(len=:), allocatable, intent(in) :: profile_name + + !> Name of compiler + character(len=:), allocatable, intent(in) :: compiler_name + + !> List of keys in the table + type(toml_key), allocatable, intent(in) :: key_list(:) + + !> Table containing OS tables + type(toml_table), pointer, intent(in) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Was called with valid operating system + logical, intent(in) :: os_valid + + character(len=:), allocatable :: flags, c_flags, cxx_flags, link_time_flags, key_name, file_name, file_flags, err_message + type(toml_table), pointer :: files + type(toml_key), allocatable :: file_list(:) + integer :: ikey, ifile, stat + logical :: is_valid + + if (size(key_list) .ge. 1) then + do ikey = 1, size(key_list) + key_name = key_list(ikey)%key + if (key_name .eq. 'flags') then + call get_value(table, 'flags', flags, stat=stat) + if (stat /= toml_stat%success) then + call syntax_error(error, "flags has to be a key-value pair") + return + end if + else if (key_name .eq. 'c-flags') then + call get_value(table, 'c-flags', c_flags, stat=stat) + if (stat /= toml_stat%success) then + call syntax_error(error, "c-flags has to be a key-value pair") + return + end if + else if (key_name .eq. 'cxx-flags') then + call get_value(table, 'cxx-flags', cxx_flags, stat=stat) + if (stat /= toml_stat%success) then + call syntax_error(error, "cxx-flags has to be a key-value pair") + return + end if + else if (key_name .eq. 'link-time-flags') then + call get_value(table, 'link-time-flags', link_time_flags, stat=stat) + if (stat /= toml_stat%success) then + call syntax_error(error, "link-time-flags has to be a key-value pair") + return + end if + else if (key_name .eq. 'files') then + call get_value(table, 'files', files, stat=stat) + if (stat /= toml_stat%success) then + call syntax_error(error, "files has to be a table") + return + end if + call files%get_keys(file_list) + do ifile = 1, size(file_list) + file_name = file_list(ifile)%key + call get_value(files, file_name, file_flags, stat=stat) + if (stat /= toml_stat%success) then + call syntax_error(error, "file scope flags has to be a key-value pair") + return + end if + end do + else if (.not. os_valid) then + call validate_os_name(key_name, is_valid) + err_message = "Unexpected key "//key_name//" found in profile table "//profile_name//" "//compiler_name//"." + if (.not. is_valid) call syntax_error(error, err_message) else - profile%flags = "" + err_message = "Unexpected key "//key_name//" found in profile table "//profile_name//" "//compiler_name//"." + call syntax_error(error, err_message) end if - if (present(c_flags)) then - profile%c_flags = c_flags - else - profile%c_flags = "" + end do + end if + + if (allocated(error)) return + + end subroutine validate_profile_table + + !> Look for flags, c-flags, link-time-flags key-val pairs + !> and files table in a given table and create new profiles + subroutine get_flags(profile_name, compiler_name, os_type, key_list, table, profiles, profindex, os_valid) + + !> Name of profile + character(len=:), allocatable, intent(in) :: profile_name + + !> Name of compiler + character(len=:), allocatable, intent(in) :: compiler_name + + !> OS type + integer, intent(in) :: os_type + + !> List of keys in the table + type(toml_key), allocatable, intent(in) :: key_list(:) + + !> Table containing OS tables + type(toml_table), pointer, intent(in) :: table + + !> List of profiles + type(profile_config_t), allocatable, intent(inout) :: profiles(:) + + !> Index in the list of profiles + integer, intent(inout) :: profindex + + !> Was called with valid operating system + logical, intent(in) :: os_valid + + character(len=:), allocatable :: flags, c_flags, cxx_flags, link_time_flags, key_name, file_name, file_flags, err_message + type(toml_table), pointer :: files + type(toml_key), allocatable :: file_list(:) + type(file_scope_flag), allocatable :: file_scope_flags(:) + integer :: ikey, ifile, stat + logical :: is_valid + + call get_value(table, 'flags', flags) + call get_value(table, 'c-flags', c_flags) + call get_value(table, 'cxx-flags', cxx_flags) + call get_value(table, 'link-time-flags', link_time_flags) + call get_value(table, 'files', files) + if (associated(files)) then + call files%get_keys(file_list) + allocate (file_scope_flags(size(file_list))) + do ifile = 1, size(file_list) + file_name = file_list(ifile)%key + call get_value(files, file_name, file_flags) + associate (cur_file => file_scope_flags(ifile)) + if (.not. (path .eq. "")) file_name = join_path(path, file_name) + cur_file%file_name = file_name + cur_file%flags = file_flags + end associate + end do + end if + + profiles(profindex) = new_profile(profile_name, compiler_name, os_type, & + & flags, c_flags, cxx_flags, link_time_flags, file_scope_flags) + profindex = profindex + 1 + end subroutine get_flags + + !> Traverse operating system tables to obtain number of profiles + subroutine traverse_oss_for_size(profile_name, compiler_name, os_list, table, profiles_size, error) + + !> Name of profile + character(len=:), allocatable, intent(in) :: profile_name + + !> Name of compiler + character(len=:), allocatable, intent(in) :: compiler_name + + !> List of OSs in table with profile name and compiler name given + type(toml_key), allocatable, intent(in) :: os_list(:) + + !> Table containing OS tables + type(toml_table), pointer, intent(in) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Number of profiles in list of profiles + integer, intent(inout) :: profiles_size + + type(toml_key), allocatable :: key_list(:) + character(len=:), allocatable :: os_name, l_os_name + type(toml_table), pointer :: os_node + integer :: ios, stat + logical :: is_valid, key_val_added, is_key_val + + if (size(os_list) < 1) return + key_val_added = .false. + do ios = 1, size(os_list) + os_name = os_list(ios)%key + call validate_os_name(os_name, is_valid) + if (is_valid) then + call get_value(table, os_name, os_node, stat=stat) + if (stat /= toml_stat%success) then + call syntax_error(error, "os "//os_name//" has to be a table") + return end if - if (present(cxx_flags)) then - profile%cxx_flags = cxx_flags - else - profile%cxx_flags = "" + call os_node%get_keys(key_list) + profiles_size = profiles_size + 1 + call validate_profile_table(profile_name, compiler_name, key_list, os_node, error, .true.) + else + ! Not lowercase OS name + l_os_name = lower(os_name) + call validate_os_name(l_os_name, is_valid) + if (is_valid) then + call fatal_error(error, '*traverse_oss*:Error: Name of the operating system must be a lowercase string.') end if - if (present(link_time_flags)) then - profile%link_time_flags = link_time_flags - else - profile%link_time_flags = "" + if (allocated(error)) return + + ! Missing OS name + is_key_val = .false. + os_name = os_list(ios)%key + call get_value(table, os_name, os_node, stat=stat) + if (stat /= toml_stat%success) then + is_key_val = .true. end if - if (present(file_scope_flags)) then - profile%file_scope_flags = file_scope_flags + os_node => table + if (is_key_val .and. .not. key_val_added) then + key_val_added = .true. + is_key_val = .false. + profiles_size = profiles_size + 1 + else if (.not. is_key_val) then + profiles_size = profiles_size + 1 end if - if (present(is_built_in)) then - profile%is_built_in = is_built_in - else - profile%is_built_in = .false. + call validate_profile_table(profile_name, compiler_name, os_list, os_node, error, .false.) + end if + end do + end subroutine traverse_oss_for_size + + !> Traverse operating system tables to obtain profiles + subroutine traverse_oss(profile_name, compiler_name, os_list, table, profiles, profindex, error) + + !> Name of profile + character(len=:), allocatable, intent(in) :: profile_name + + !> Name of compiler + character(len=:), allocatable, intent(in) :: compiler_name + + !> List of OSs in table with profile name and compiler name given + type(toml_key), allocatable, intent(in) :: os_list(:) + + !> Table containing OS tables + type(toml_table), pointer, intent(in) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> List of profiles + type(profile_config_t), allocatable, intent(inout) :: profiles(:) + + !> Index in the list of profiles + integer, intent(inout) :: profindex + + type(toml_key), allocatable :: key_list(:) + character(len=:), allocatable :: os_name, l_os_name + type(toml_table), pointer :: os_node + integer :: ios, stat, os_type + logical :: is_valid, is_key_val + + if (size(os_list) < 1) return + do ios = 1, size(os_list) + os_name = os_list(ios)%key + call validate_os_name(os_name, is_valid) + if (is_valid) then + call get_value(table, os_name, os_node, stat=stat) + if (stat /= toml_stat%success) then + call syntax_error(error, "os "//os_name//" has to be a table") + return end if - - end function new_profile - - !> Check if compiler name is a valid compiler name - subroutine validate_compiler_name(compiler_name, is_valid) - - !> Name of a compiler - character(len=:), allocatable, intent(in) :: compiler_name - - !> Boolean value of whether compiler_name is valid or not - logical, intent(out) :: is_valid - select case(compiler_name) - case("gfortran", "ifort", "ifx", "pgfortran", "nvfortran", "flang", "caf", & - & "f95", "lfortran", "lfc", "nagfor", "crayftn", "xlf90", "ftn95") - is_valid = .true. - case default - is_valid = .false. - end select - end subroutine validate_compiler_name - - !> Check if os_name is a valid name of a supported OS - subroutine validate_os_name(os_name, is_valid) - - !> Name of an operating system - character(len=:), allocatable, intent(in) :: os_name - - !> Boolean value of whether os_name is valid or not - logical, intent(out) :: is_valid - - select case (os_name) - case ("linux", "macos", "windows", "cygwin", "solaris", "freebsd", & - & "openbsd", "unknown") - is_valid = .true. - case default - is_valid = .false. - end select - - end subroutine validate_os_name - - !> Match os_type enum to a lowercase string with name of OS - subroutine match_os_type(os_name, os_type) - - !> Name of operating system - character(len=:), allocatable, intent(in) :: os_name - - !> Enum representing type of OS - integer, intent(out) :: os_type - - select case (os_name) - case ("linux"); os_type = OS_LINUX - case ("macos"); os_type = OS_WINDOWS - case ("cygwin"); os_type = OS_CYGWIN - case ("solaris"); os_type = OS_SOLARIS - case ("freebsd"); os_type = OS_FREEBSD - case ("openbsd"); os_type = OS_OPENBSD - case ("all"); os_type = OS_ALL - case default; os_type = OS_UNKNOWN - end select - - end subroutine match_os_type - - subroutine validate_profile_table(profile_name, compiler_name, key_list, table, error, os_valid) - - !> Name of profile - character(len=:), allocatable, intent(in) :: profile_name - - !> Name of compiler - character(len=:), allocatable, intent(in) :: compiler_name - - !> List of keys in the table - type(toml_key), allocatable, intent(in) :: key_list(:) - - !> Table containing OS tables - type(toml_table), pointer, intent(in) :: table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - !> Was called with valid operating system - logical, intent(in) :: os_valid - - character(len=:), allocatable :: flags, c_flags, cxx_flags, link_time_flags, key_name, file_name, file_flags, err_message - type(toml_table), pointer :: files - type(toml_key), allocatable :: file_list(:) - integer :: ikey, ifile, stat - logical :: is_valid - - if (size(key_list).ge.1) then - do ikey=1,size(key_list) - key_name = key_list(ikey)%key - if (key_name.eq.'flags') then - call get_value(table, 'flags', flags, stat=stat) - if (stat /= toml_stat%success) then - call syntax_error(error, "flags has to be a key-value pair") - return - end if - else if (key_name.eq.'c-flags') then - call get_value(table, 'c-flags', c_flags, stat=stat) - if (stat /= toml_stat%success) then - call syntax_error(error, "c-flags has to be a key-value pair") - return - end if - else if (key_name.eq.'cxx-flags') then - call get_value(table, 'cxx-flags', cxx_flags, stat=stat) - if (stat /= toml_stat%success) then - call syntax_error(error, "cxx-flags has to be a key-value pair") - return - end if - else if (key_name.eq.'link-time-flags') then - call get_value(table, 'link-time-flags', link_time_flags, stat=stat) - if (stat /= toml_stat%success) then - call syntax_error(error, "link-time-flags has to be a key-value pair") - return - end if - else if (key_name.eq.'files') then - call get_value(table, 'files', files, stat=stat) - if (stat /= toml_stat%success) then - call syntax_error(error, "files has to be a table") - return - end if - call files%get_keys(file_list) - do ifile=1,size(file_list) - file_name = file_list(ifile)%key - call get_value(files, file_name, file_flags, stat=stat) - if (stat /= toml_stat%success) then - call syntax_error(error, "file scope flags has to be a key-value pair") - return - end if - end do - else if (.not. os_valid) then - call validate_os_name(key_name, is_valid) - err_message = "Unexpected key " // key_name // " found in profile table "//profile_name//" "//compiler_name//"." - if (.not. is_valid) call syntax_error(error, err_message) - else - err_message = "Unexpected key " // key_name // " found in profile table "//profile_name//" "//compiler_name//"." - call syntax_error(error, err_message) - end if - end do + call os_node%get_keys(key_list) + call match_os_type(os_name, os_type) + call get_flags(profile_name, compiler_name, os_type, key_list, os_node, profiles, profindex, .true.) + else + ! Not lowercase OS name + l_os_name = lower(os_name) + call validate_os_name(l_os_name, is_valid) + if (is_valid) then + call fatal_error(error, '*traverse_oss*:Error: Name of the operating system must be a lowercase string.') end if - if (allocated(error)) return - end subroutine validate_profile_table - - !> Look for flags, c-flags, link-time-flags key-val pairs - !> and files table in a given table and create new profiles - subroutine get_flags(profile_name, compiler_name, os_type, key_list, table, profiles, profindex, os_valid) - - !> Name of profile - character(len=:), allocatable, intent(in) :: profile_name - - !> Name of compiler - character(len=:), allocatable, intent(in) :: compiler_name - - !> OS type - integer, intent(in) :: os_type - - !> List of keys in the table - type(toml_key), allocatable, intent(in) :: key_list(:) - - !> Table containing OS tables - type(toml_table), pointer, intent(in) :: table - - !> List of profiles - type(profile_config_t), allocatable, intent(inout) :: profiles(:) - - !> Index in the list of profiles - integer, intent(inout) :: profindex - - !> Was called with valid operating system - logical, intent(in) :: os_valid - - character(len=:), allocatable :: flags, c_flags, cxx_flags, link_time_flags, key_name, file_name, file_flags, err_message - type(toml_table), pointer :: files - type(toml_key), allocatable :: file_list(:) - type(file_scope_flag), allocatable :: file_scope_flags(:) - integer :: ikey, ifile, stat - logical :: is_valid - - call get_value(table, 'flags', flags) - call get_value(table, 'c-flags', c_flags) - call get_value(table, 'cxx-flags', cxx_flags) - call get_value(table, 'link-time-flags', link_time_flags) - call get_value(table, 'files', files) - if (associated(files)) then - call files%get_keys(file_list) - allocate(file_scope_flags(size(file_list))) - do ifile=1,size(file_list) - file_name = file_list(ifile)%key - call get_value(files, file_name, file_flags) - associate(cur_file=>file_scope_flags(ifile)) - if (.not.(path.eq."")) file_name = join_path(path, file_name) - cur_file%file_name = file_name - cur_file%flags = file_flags - end associate - end do + ! Missing OS name + is_key_val = .false. + os_name = os_list(ios)%key + call get_value(table, os_name, os_node, stat=stat) + if (stat /= toml_stat%success) then + is_key_val = .true. end if - - profiles(profindex) = new_profile(profile_name, compiler_name, os_type, & - & flags, c_flags, cxx_flags, link_time_flags, file_scope_flags) - profindex = profindex + 1 - end subroutine get_flags - - !> Traverse operating system tables to obtain number of profiles - subroutine traverse_oss_for_size(profile_name, compiler_name, os_list, table, profiles_size, error) - - !> Name of profile - character(len=:), allocatable, intent(in) :: profile_name - - !> Name of compiler - character(len=:), allocatable, intent(in) :: compiler_name - - !> List of OSs in table with profile name and compiler name given - type(toml_key), allocatable, intent(in) :: os_list(:) - - !> Table containing OS tables - type(toml_table), pointer, intent(in) :: table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - !> Number of profiles in list of profiles - integer, intent(inout) :: profiles_size - - type(toml_key), allocatable :: key_list(:) - character(len=:), allocatable :: os_name, l_os_name - type(toml_table), pointer :: os_node - integer :: ios, stat - logical :: is_valid, key_val_added, is_key_val - - if (size(os_list)<1) return - key_val_added = .false. - do ios = 1, size(os_list) - os_name = os_list(ios)%key - call validate_os_name(os_name, is_valid) - if (is_valid) then - call get_value(table, os_name, os_node, stat=stat) - if (stat /= toml_stat%success) then - call syntax_error(error, "os "//os_name//" has to be a table") - return - end if - call os_node%get_keys(key_list) - profiles_size = profiles_size + 1 - call validate_profile_table(profile_name, compiler_name, key_list, os_node, error, .true.) - else - ! Not lowercase OS name - l_os_name = lower(os_name) - call validate_os_name(l_os_name, is_valid) - if (is_valid) then - call fatal_error(error,'*traverse_oss*:Error: Name of the operating system must be a lowercase string.') - end if - if (allocated(error)) return - - ! Missing OS name - is_key_val = .false. - os_name = os_list(ios)%key - call get_value(table, os_name, os_node, stat=stat) - if (stat /= toml_stat%success) then - is_key_val = .true. - end if - os_node=>table - if (is_key_val.and..not.key_val_added) then - key_val_added = .true. - is_key_val = .false. - profiles_size = profiles_size + 1 - else if (.not.is_key_val) then - profiles_size = profiles_size + 1 - end if - call validate_profile_table(profile_name, compiler_name, os_list, os_node, error, .false.) - end if - end do - end subroutine traverse_oss_for_size - - - !> Traverse operating system tables to obtain profiles - subroutine traverse_oss(profile_name, compiler_name, os_list, table, profiles, profindex, error) - - !> Name of profile - character(len=:), allocatable, intent(in) :: profile_name - - !> Name of compiler - character(len=:), allocatable, intent(in) :: compiler_name - - !> List of OSs in table with profile name and compiler name given - type(toml_key), allocatable, intent(in) :: os_list(:) - - !> Table containing OS tables - type(toml_table), pointer, intent(in) :: table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - !> List of profiles - type(profile_config_t), allocatable, intent(inout) :: profiles(:) - - !> Index in the list of profiles - integer, intent(inout) :: profindex - - type(toml_key), allocatable :: key_list(:) - character(len=:), allocatable :: os_name, l_os_name - type(toml_table), pointer :: os_node - integer :: ios, stat, os_type - logical :: is_valid, is_key_val - - if (size(os_list)<1) return - do ios = 1, size(os_list) - os_name = os_list(ios)%key - call validate_os_name(os_name, is_valid) - if (is_valid) then - call get_value(table, os_name, os_node, stat=stat) - if (stat /= toml_stat%success) then - call syntax_error(error, "os "//os_name//" has to be a table") - return - end if - call os_node%get_keys(key_list) - call match_os_type(os_name, os_type) - call get_flags(profile_name, compiler_name, os_type, key_list, os_node, profiles, profindex, .true.) - else - ! Not lowercase OS name - l_os_name = lower(os_name) - call validate_os_name(l_os_name, is_valid) - if (is_valid) then - call fatal_error(error,'*traverse_oss*:Error: Name of the operating system must be a lowercase string.') - end if - if (allocated(error)) return - - ! Missing OS name - is_key_val = .false. - os_name = os_list(ios)%key - call get_value(table, os_name, os_node, stat=stat) - if (stat /= toml_stat%success) then - is_key_val = .true. - end if - os_node=>table - os_type = OS_ALL - call get_flags(profile_name, compiler_name, os_type, os_list, os_node, profiles, profindex, .false.) - end if - end do - end subroutine traverse_oss - - !> Traverse compiler tables - subroutine traverse_compilers(profile_name, comp_list, table, error, profiles_size, profiles, profindex) - - !> Name of profile - character(len=:), allocatable, intent(in) :: profile_name - - !> List of OSs in table with profile name given - type(toml_key), allocatable, intent(in) :: comp_list(:) - - !> Table containing compiler tables - type(toml_table), pointer, intent(in) :: table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - !> Number of profiles in list of profiles - integer, intent(inout), optional :: profiles_size - - !> List of profiles - type(profile_config_t), allocatable, intent(inout), optional :: profiles(:) - - !> Index in the list of profiles - integer, intent(inout), optional :: profindex - - character(len=:), allocatable :: compiler_name - type(toml_table), pointer :: comp_node - type(toml_key), allocatable :: os_list(:) - integer :: icomp, stat - logical :: is_valid - - if (size(comp_list)<1) return - do icomp = 1, size(comp_list) - call validate_compiler_name(comp_list(icomp)%key, is_valid) - if (is_valid) then - compiler_name = comp_list(icomp)%key - call get_value(table, compiler_name, comp_node, stat=stat) - if (stat /= toml_stat%success) then - call syntax_error(error, "Compiler "//comp_list(icomp)%key//" must be a table entry") - exit - end if - call comp_node%get_keys(os_list) - if (present(profiles_size)) then - call traverse_oss_for_size(profile_name, compiler_name, os_list, comp_node, profiles_size, error) - if (allocated(error)) return - else - if (.not.(present(profiles).and.present(profindex))) then - call fatal_error(error, "Both profiles and profindex have to be present") - return - end if - call traverse_oss(profile_name, compiler_name, os_list, comp_node, & - & profiles, profindex, error) - if (allocated(error)) return - end if - else - call fatal_error(error,'*traverse_compilers*:Error: Compiler name not specified or invalid.') + os_node => table + os_type = OS_ALL + call get_flags(profile_name, compiler_name, os_type, os_list, os_node, profiles, profindex, .false.) + end if + end do + end subroutine traverse_oss + + !> Traverse compiler tables + subroutine traverse_compilers(profile_name, comp_list, table, error, profiles_size, profiles, profindex) + + !> Name of profile + character(len=:), allocatable, intent(in) :: profile_name + + !> List of OSs in table with profile name given + type(toml_key), allocatable, intent(in) :: comp_list(:) + + !> Table containing compiler tables + type(toml_table), pointer, intent(in) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Number of profiles in list of profiles + integer, intent(inout), optional :: profiles_size + + !> List of profiles + type(profile_config_t), allocatable, intent(inout), optional :: profiles(:) + + !> Index in the list of profiles + integer, intent(inout), optional :: profindex + + character(len=:), allocatable :: compiler_name + type(toml_table), pointer :: comp_node + type(toml_key), allocatable :: os_list(:) + integer :: icomp, stat + logical :: is_valid + + if (size(comp_list) < 1) return + do icomp = 1, size(comp_list) + call validate_compiler_name(comp_list(icomp)%key, is_valid) + if (is_valid) then + compiler_name = comp_list(icomp)%key + call get_value(table, compiler_name, comp_node, stat=stat) + if (stat /= toml_stat%success) then + call syntax_error(error, "Compiler "//comp_list(icomp)%key//" must be a table entry") + exit + end if + call comp_node%get_keys(os_list) + if (present(profiles_size)) then + call traverse_oss_for_size(profile_name, compiler_name, os_list, comp_node, profiles_size, error) + if (allocated(error)) return + else + if (.not. (present(profiles) .and. present(profindex))) then + call fatal_error(error, "Both profiles and profindex have to be present") + return end if - end do - end subroutine traverse_compilers - - !> Construct new profiles array from a TOML data structure - subroutine new_profiles(profiles, table, error) - - !> Instance of the dependency configuration - type(profile_config_t), allocatable, intent(out) :: profiles(:) - - !> Instance of the TOML data structure - type(toml_table), target, intent(inout) :: table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table), pointer :: prof_node - type(toml_key), allocatable :: prof_list(:) - type(toml_key), allocatable :: comp_list(:) - type(toml_key), allocatable :: os_list(:) - character(len=:), allocatable :: profile_name, compiler_name - integer :: profiles_size, iprof, stat, profindex - logical :: is_valid - type(profile_config_t), allocatable :: default_profiles(:) - - path = '' - - default_profiles = get_default_profiles(error) + call traverse_oss(profile_name, compiler_name, os_list, comp_node, & + & profiles, profindex, error) + if (allocated(error)) return + end if + else + call fatal_error(error, '*traverse_compilers*:Error: Compiler name not specified or invalid.') + end if + end do + end subroutine traverse_compilers + + !> Construct new profiles array from a TOML data structure + subroutine new_profiles(profiles, table, error) + + !> Instance of the dependency configuration + type(profile_config_t), allocatable, intent(out) :: profiles(:) + + !> Instance of the TOML data structure + type(toml_table), target, intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table), pointer :: prof_node + type(toml_key), allocatable :: prof_list(:) + type(toml_key), allocatable :: comp_list(:) + type(toml_key), allocatable :: os_list(:) + character(len=:), allocatable :: profile_name, compiler_name + integer :: profiles_size, iprof, stat, profindex + logical :: is_valid + type(profile_config_t), allocatable :: default_profiles(:) + + path = '' + + default_profiles = get_default_profiles(error) + if (allocated(error)) return + call table%get_keys(prof_list) + + if (size(prof_list) < 1) return + + profiles_size = 0 + + do iprof = 1, size(prof_list) + profile_name = prof_list(iprof)%key + call validate_compiler_name(profile_name, is_valid) + if (is_valid) then + profile_name = "all" + comp_list = prof_list(iprof:iprof) + prof_node => table + call traverse_compilers(profile_name, comp_list, prof_node, error, profiles_size=profiles_size) if (allocated(error)) return - call table%get_keys(prof_list) - - if (size(prof_list) < 1) return - - profiles_size = 0 - - do iprof = 1, size(prof_list) - profile_name = prof_list(iprof)%key - call validate_compiler_name(profile_name, is_valid) - if (is_valid) then - profile_name = "all" - comp_list = prof_list(iprof:iprof) - prof_node=>table - call traverse_compilers(profile_name, comp_list, prof_node, error, profiles_size=profiles_size) - if (allocated(error)) return - else - call validate_os_name(profile_name, is_valid) - if (is_valid) then - os_list = prof_list(iprof:iprof) - profile_name = 'all' - compiler_name = DEFAULT_COMPILER - call traverse_oss_for_size(profile_name, compiler_name, os_list, table, profiles_size, error) - if (allocated(error)) return - else - call get_value(table, profile_name, prof_node, stat=stat) - if (stat /= toml_stat%success) then - call syntax_error(error, "Profile "//prof_list(iprof)%key//" must be a table entry") - exit - end if - call prof_node%get_keys(comp_list) - call traverse_compilers(profile_name, comp_list, prof_node, error, profiles_size=profiles_size) - if (allocated(error)) return - end if + else + call validate_os_name(profile_name, is_valid) + if (is_valid) then + os_list = prof_list(iprof:iprof) + profile_name = 'all' + compiler_name = DEFAULT_COMPILER + call traverse_oss_for_size(profile_name, compiler_name, os_list, table, profiles_size, error) + if (allocated(error)) return + else + call get_value(table, profile_name, prof_node, stat=stat) + if (stat /= toml_stat%success) then + call syntax_error(error, "Profile "//prof_list(iprof)%key//" must be a table entry") + exit end if - end do - - profiles_size = profiles_size + size(default_profiles) - allocate(profiles(profiles_size)) - - do profindex=1, size(default_profiles) - profiles(profindex) = default_profiles(profindex) - end do - - do iprof = 1, size(prof_list) - profile_name = prof_list(iprof)%key - call validate_compiler_name(profile_name, is_valid) - if (is_valid) then - profile_name = "all" - comp_list = prof_list(iprof:iprof) - prof_node=>table - call traverse_compilers(profile_name, comp_list, prof_node, error, profiles=profiles, profindex=profindex) - if (allocated(error)) return - else - call validate_os_name(profile_name, is_valid) - if (is_valid) then - os_list = prof_list(iprof:iprof) - profile_name = 'all' - compiler_name = DEFAULT_COMPILER - prof_node=>table - call traverse_oss(profile_name, compiler_name, os_list, prof_node, profiles, profindex, error) - if (allocated(error)) return - else - call get_value(table, profile_name, prof_node, stat=stat) - call prof_node%get_keys(comp_list) - call traverse_compilers(profile_name, comp_list, prof_node, error, profiles=profiles, profindex=profindex) - if (allocated(error)) return - end if + call prof_node%get_keys(comp_list) + call traverse_compilers(profile_name, comp_list, prof_node, error, profiles_size=profiles_size) + if (allocated(error)) return + end if + end if + end do + + profiles_size = profiles_size + size(default_profiles) + allocate (profiles(profiles_size)) + + do profindex = 1, size(default_profiles) + profiles(profindex) = default_profiles(profindex) + end do + + do iprof = 1, size(prof_list) + profile_name = prof_list(iprof)%key + call validate_compiler_name(profile_name, is_valid) + if (is_valid) then + profile_name = "all" + comp_list = prof_list(iprof:iprof) + prof_node => table + call traverse_compilers(profile_name, comp_list, prof_node, error, profiles=profiles, profindex=profindex) + if (allocated(error)) return + else + call validate_os_name(profile_name, is_valid) + if (is_valid) then + os_list = prof_list(iprof:iprof) + profile_name = 'all' + compiler_name = DEFAULT_COMPILER + prof_node => table + call traverse_oss(profile_name, compiler_name, os_list, prof_node, profiles, profindex, error) + if (allocated(error)) return + else + call get_value(table, profile_name, prof_node, stat=stat) + call prof_node%get_keys(comp_list) + call traverse_compilers(profile_name, comp_list, prof_node, error, profiles=profiles, profindex=profindex) + if (allocated(error)) return + end if + end if + end do + + ! Apply profiles with profile name 'all' to matching profiles + do iprof = 1, size(profiles) + if (profiles(iprof)%profile_name .eq. 'all') then + do profindex = 1, size(profiles) + if (.not. (profiles(profindex)%profile_name .eq. 'all') & + & .and. (profiles(profindex)%compiler .eq. profiles(iprof)%compiler) & + & .and. (profiles(profindex)%os_type .eq. profiles(iprof)%os_type)) then + profiles(profindex)%flags = profiles(profindex)%flags// & + & " "//profiles(iprof)%flags + profiles(profindex)%c_flags = profiles(profindex)%c_flags// & + & " "//profiles(iprof)%c_flags + profiles(profindex)%cxx_flags = profiles(profindex)%cxx_flags// & + & " "//profiles(iprof)%cxx_flags + profiles(profindex)%link_time_flags = profiles(profindex)%link_time_flags// & + & " "//profiles(iprof)%link_time_flags end if end do - - ! Apply profiles with profile name 'all' to matching profiles - do iprof = 1,size(profiles) - if (profiles(iprof)%profile_name.eq.'all') then - do profindex = 1,size(profiles) - if (.not.(profiles(profindex)%profile_name.eq.'all') & - & .and.(profiles(profindex)%compiler.eq.profiles(iprof)%compiler) & - & .and.(profiles(profindex)%os_type.eq.profiles(iprof)%os_type)) then - profiles(profindex)%flags=profiles(profindex)%flags// & - & " "//profiles(iprof)%flags - profiles(profindex)%c_flags=profiles(profindex)%c_flags// & - & " "//profiles(iprof)%c_flags - profiles(profindex)%cxx_flags=profiles(profindex)%cxx_flags// & - & " "//profiles(iprof)%cxx_flags - profiles(profindex)%link_time_flags=profiles(profindex)%link_time_flags// & - & " "//profiles(iprof)%link_time_flags - end if - end do + end if + end do + end subroutine new_profiles + + !> Construct an array of built-in profiles + function get_default_profiles(error) result(default_profiles) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(profile_config_t), allocatable :: default_profiles(:) + + default_profiles = [ & + & new_profile('release', & + & 'caf', & + & OS_ALL, & + & flags=' -O3 -Wimplicit-interface -fPIC -fmax-errors=1 -funroll-loops', & + & is_built_in=.true.), & + & new_profile('release', & + & 'gfortran', & + & OS_ALL, & + & flags=' -O3 -Wimplicit-interface -fPIC -fmax-errors=1 -funroll-loops -fcoarray=single', & + & is_built_in=.true.), & + & new_profile('release', & + & 'f95', & + & OS_ALL, & + & flags=' -O3 -Wimplicit-interface -fPIC -fmax-errors=1 -ffast-math -funroll-loops', & + & is_built_in=.true.), & + & new_profile('release', & + & 'nvfortran', & + & OS_ALL, & + & flags=' -Mbackslash', & + & is_built_in=.true.), & + & new_profile('release', & + & 'ifort', & + & OS_ALL, & + & flags=' -fp-model precise -pc64 -align all -error-limit 1 -reentrancy& + & threaded -nogen-interfaces -assume byterecl', & + & is_built_in=.true.), & + & new_profile('release', & + & 'ifort', & + & OS_WINDOWS, & + & flags=' /fp:precise /align:all /error-limit:1 /reentrancy:threaded& + & /nogen-interfaces /assume:byterecl', & + & is_built_in=.true.), & + & new_profile('release', & + & 'ifx', & + & OS_ALL, & + & flags=' -fp-model=precise -pc64 -align all -error-limit 1 -reentrancy& + & threaded -nogen-interfaces -assume byterecl', & + & is_built_in=.true.), & + & new_profile('release', & + & 'ifx', & + & OS_WINDOWS, & + & flags=' /fp:precise /align:all /error-limit:1 /reentrancy:threaded& + & /nogen-interfaces /assume:byterecl', & + & is_built_in=.true.), & + & new_profile('release', & + &'nagfor', & + & OS_ALL, & + & flags=' -O4 -coarray=single -PIC', & + & is_built_in=.true.), & + & new_profile('release', & + &'lfortran', & + & OS_ALL, & + & flags=' flag_lfortran_opt', & + & is_built_in=.true.), & + & new_profile('debug', & + & 'caf', & + & OS_ALL, & + & flags=' -Wall -Wextra -Wimplicit-interface -fPIC -fmax-errors=1 -g -fcheck=bounds& + & -fcheck=array-temps -fbacktrace', & + & is_built_in=.true.), & + & new_profile('debug', & + & 'gfortran', & + & OS_ALL, & + & flags=' -Wall -Wextra -Wimplicit-interface -fPIC -fmax-errors=1 -g -fcheck=bounds& + & -fcheck=array-temps -fbacktrace -fcoarray=single', & + & is_built_in=.true.), & + & new_profile('debug', & + & 'f95', & + & OS_ALL, & + & flags=' -Wall -Wextra -Wimplicit-interface -fPIC -fmax-errors=1 -g -fcheck=bounds& + & -fcheck=array-temps -Wno-maybe-uninitialized -Wno-uninitialized -fbacktrace', & + & is_built_in=.true.), & + & new_profile('debug', & + & 'nvfortran', & + & OS_ALL, & + & flags=' -Minform=inform -Mbackslash -g -Mbounds -Mchkptr -Mchkstk -traceback', & + & is_built_in=.true.), & + & new_profile('debug', & + & 'ifort', & + & OS_ALL, & + & flags=' -warn all -check all -error-limit 1 -O0 -g -assume byterecl -traceback', & + & is_built_in=.true.), & + & new_profile('debug', & + & 'ifort', & + & OS_WINDOWS, & + & flags=' /warn:all /check:all /error-limit:1& + & /Od /Z7 /assume:byterecl /traceback', & + & is_built_in=.true.), & + & new_profile('debug', & + & 'ifx', & + & OS_ALL, & + & flags=' -warn all -check all -error-limit 1 -O0 -g -assume byterecl -traceback', & + & is_built_in=.true.), & + & new_profile('debug', & + & 'ifx', & + & OS_WINDOWS, & + & flags=' /warn:all /check:all /error-limit:1 /Od /Z7 /assume:byterecl', & + & is_built_in=.true.), & + & new_profile('debug', & + & 'ifx', & + & OS_WINDOWS, & + & flags=' /warn:all /check:all /error-limit:1 /Od /Z7 /assume:byterecl', & + & is_built_in=.true.), & + & new_profile('debug', & + & 'lfortran', & + & OS_ALL, & + & flags='', & + & is_built_in=.true.) & + &] + end function get_default_profiles + + !> Write information on instance + subroutine info(self, unit, verbosity) + + !> Instance of the profile configuration + class(profile_config_t), intent(in) :: self + + !> Unit for IO + integer, intent(in) :: unit + + !> Verbosity of the printout + integer, intent(in), optional :: verbosity + + integer :: pr + character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)' + + if (present(verbosity)) then + pr = verbosity + else + pr = 1 + end if + + write (unit, fmt) "Profile" + if (allocated(self%profile_name)) then + write (unit, fmt) "- profile name", self%profile_name + end if + + if (allocated(self%compiler)) then + write (unit, fmt) "- compiler", self%compiler + end if + + write (unit, fmt) "- os", self%os_type + + if (allocated(self%flags)) then + write (unit, fmt) "- compiler flags", self%flags + end if + + end subroutine info + + !> Print a representation of profile_config_t + function info_profile(profile) result(s) + + !> Profile to be represented + type(profile_config_t), intent(in) :: profile + + !> String representation of given profile + character(:), allocatable :: s + + integer :: i + + s = "profile_config_t(" + s = s//'profile_name="'//profile%profile_name//'"' + s = s//', compiler="'//profile%compiler//'"' + s = s//", os_type=" + select case (profile%os_type) + case (OS_UNKNOWN) + s = s//"OS_UNKNOWN" + case (OS_LINUX) + s = s//"OS_LINUX" + case (OS_MACOS) + s = s//"OS_MACOS" + case (OS_WINDOWS) + s = s//"OS_WINDOWS" + case (OS_CYGWIN) + s = s//"OS_CYGWIN" + case (OS_SOLARIS) + s = s//"OS_SOLARIS" + case (OS_FREEBSD) + s = s//"OS_FREEBSD" + case (OS_OPENBSD) + s = s//"OS_OPENBSD" + case (OS_ALL) + s = s//"OS_ALL" + case default + s = s//"INVALID" + end select + if (allocated(profile%flags)) s = s//', flags="'//profile%flags//'"' + if (allocated(profile%c_flags)) s = s//', c_flags="'//profile%c_flags//'"' + if (allocated(profile%cxx_flags)) s = s//', cxx_flags="'//profile%cxx_flags//'"' + if (allocated(profile%link_time_flags)) s = s//', link_time_flags="'//profile%link_time_flags//'"' + if (allocated(profile%file_scope_flags)) then + do i = 1, size(profile%file_scope_flags) + s = s//', flags for '//profile%file_scope_flags(i)%file_name// & + & ' ="'//profile%file_scope_flags(i)%flags//'"' + end do + end if + s = s//")" + + end function info_profile + + !> Look for profile with given configuration in array profiles + subroutine find_profile(profiles, profile_name, compiler, os_type, found_matching, chosen_profile) + + !> Array of profiles + type(profile_config_t), allocatable, intent(in) :: profiles(:) + + !> Name of profile + character(:), allocatable, intent(in) :: profile_name + + !> Name of compiler + character(:), allocatable, intent(in) :: compiler + + !> Type of operating system (enum) + integer, intent(in) :: os_type + + !> Boolean value containing true if matching profile was found + logical, intent(out) :: found_matching + + !> Last matching profile in the profiles array + type(profile_config_t), intent(out) :: chosen_profile + + character(:), allocatable :: curr_profile_name + character(:), allocatable :: curr_compiler + integer :: curr_os + integer :: i, priority, curr_priority + + found_matching = .false. + if (size(profiles) < 1) return + ! Try to find profile with matching OS type + do i = 1, size(profiles) + curr_profile_name = profiles(i)%profile_name + curr_compiler = profiles(i)%compiler + curr_os = profiles(i)%os_type + if (curr_profile_name .eq. profile_name) then + if (curr_compiler .eq. compiler) then + if (curr_os .eq. os_type) then + chosen_profile = profiles(i) + found_matching = .true. end if - end do - end subroutine new_profiles - - !> Construct an array of built-in profiles - function get_default_profiles(error) result(default_profiles) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(profile_config_t), allocatable :: default_profiles(:) - - default_profiles = [ & - & new_profile('release', & - & 'caf', & - & OS_ALL, & - & flags=' -O3 -Wimplicit-interface -fPIC -fmax-errors=1 -funroll-loops', & - & is_built_in=.true.), & - & new_profile('release', & - & 'gfortran', & - & OS_ALL, & - & flags=' -O3 -Wimplicit-interface -fPIC -fmax-errors=1 -funroll-loops -fcoarray=single', & - & is_built_in=.true.), & - & new_profile('release', & - & 'f95', & - & OS_ALL, & - & flags=' -O3 -Wimplicit-interface -fPIC -fmax-errors=1 -ffast-math -funroll-loops', & - & is_built_in=.true.), & - & new_profile('release', & - & 'nvfortran', & - & OS_ALL, & - & flags = ' -Mbackslash', & - & is_built_in=.true.), & - & new_profile('release', & - & 'ifort', & - & OS_ALL, & - & flags = ' -fp-model precise -pc64 -align all -error-limit 1 -reentrancy& - & threaded -nogen-interfaces -assume byterecl', & - & is_built_in=.true.), & - & new_profile('release', & - & 'ifort', & - & OS_WINDOWS, & - & flags = ' /fp:precise /align:all /error-limit:1 /reentrancy:threaded& - & /nogen-interfaces /assume:byterecl', & - & is_built_in=.true.), & - & new_profile('release', & - & 'ifx', & - & OS_ALL, & - & flags = ' -fp-model=precise -pc64 -align all -error-limit 1 -reentrancy& - & threaded -nogen-interfaces -assume byterecl', & - & is_built_in=.true.), & - & new_profile('release', & - & 'ifx', & - & OS_WINDOWS, & - & flags = ' /fp:precise /align:all /error-limit:1 /reentrancy:threaded& - & /nogen-interfaces /assume:byterecl', & - & is_built_in=.true.), & - & new_profile('release', & - &'nagfor', & - & OS_ALL, & - & flags = ' -O4 -coarray=single -PIC', & - & is_built_in=.true.), & - & new_profile('release', & - &'lfortran', & - & OS_ALL, & - & flags = ' flag_lfortran_opt', & - & is_built_in=.true.), & - & new_profile('debug', & - & 'caf', & - & OS_ALL, & - & flags = ' -Wall -Wextra -Wimplicit-interface -fPIC -fmax-errors=1 -g -fcheck=bounds& - & -fcheck=array-temps -fbacktrace', & - & is_built_in=.true.), & - & new_profile('debug', & - & 'gfortran', & - & OS_ALL, & - & flags = ' -Wall -Wextra -Wimplicit-interface -fPIC -fmax-errors=1 -g -fcheck=bounds& - & -fcheck=array-temps -fbacktrace -fcoarray=single', & - & is_built_in=.true.), & - & new_profile('debug', & - & 'f95', & - & OS_ALL, & - & flags = ' -Wall -Wextra -Wimplicit-interface -fPIC -fmax-errors=1 -g -fcheck=bounds& - & -fcheck=array-temps -Wno-maybe-uninitialized -Wno-uninitialized -fbacktrace', & - & is_built_in=.true.), & - & new_profile('debug', & - & 'nvfortran', & - & OS_ALL, & - & flags = ' -Minform=inform -Mbackslash -g -Mbounds -Mchkptr -Mchkstk -traceback', & - & is_built_in=.true.), & - & new_profile('debug', & - & 'ifort', & - & OS_ALL, & - & flags = ' -warn all -check all -error-limit 1 -O0 -g -assume byterecl -traceback', & - & is_built_in=.true.), & - & new_profile('debug', & - & 'ifort', & - & OS_WINDOWS, & - & flags = ' /warn:all /check:all /error-limit:1& - & /Od /Z7 /assume:byterecl /traceback', & - & is_built_in=.true.), & - & new_profile('debug', & - & 'ifx', & - & OS_ALL, & - & flags = ' -warn all -check all -error-limit 1 -O0 -g -assume byterecl -traceback', & - & is_built_in=.true.), & - & new_profile('debug', & - & 'ifx', & - & OS_WINDOWS, & - & flags = ' /warn:all /check:all /error-limit:1 /Od /Z7 /assume:byterecl', & - & is_built_in=.true.), & - & new_profile('debug', & - & 'ifx', & - & OS_WINDOWS, & - & flags = ' /warn:all /check:all /error-limit:1 /Od /Z7 /assume:byterecl', & - & is_built_in=.true.), & - & new_profile('debug', & - & 'lfortran', & - & OS_ALL, & - & flags = '', & - & is_built_in=.true.) & - &] - end function get_default_profiles - - !> Write information on instance - subroutine info(self, unit, verbosity) - - !> Instance of the profile configuration - class(profile_config_t), intent(in) :: self - - !> Unit for IO - integer, intent(in) :: unit - - !> Verbosity of the printout - integer, intent(in), optional :: verbosity - - integer :: pr - character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)' - - if (present(verbosity)) then - pr = verbosity - else - pr = 1 - end if - - write(unit, fmt) "Profile" - if (allocated(self%profile_name)) then - write(unit, fmt) "- profile name", self%profile_name - end if - - if (allocated(self%compiler)) then - write(unit, fmt) "- compiler", self%compiler - end if - - write(unit, fmt) "- os", self%os_type - - if (allocated(self%flags)) then - write(unit, fmt) "- compiler flags", self%flags - end if - - end subroutine info - - !> Print a representation of profile_config_t - function info_profile(profile) result(s) - - !> Profile to be represented - type(profile_config_t), intent(in) :: profile - - !> String representation of given profile - character(:), allocatable :: s - - integer :: i - - s = "profile_config_t(" - s = s // 'profile_name="' // profile%profile_name // '"' - s = s // ', compiler="' // profile%compiler // '"' - s = s // ", os_type=" - select case(profile%os_type) - case (OS_UNKNOWN) - s = s // "OS_UNKNOWN" - case (OS_LINUX) - s = s // "OS_LINUX" - case (OS_MACOS) - s = s // "OS_MACOS" - case (OS_WINDOWS) - s = s // "OS_WINDOWS" - case (OS_CYGWIN) - s = s // "OS_CYGWIN" - case (OS_SOLARIS) - s = s // "OS_SOLARIS" - case (OS_FREEBSD) - s = s // "OS_FREEBSD" - case (OS_OPENBSD) - s = s // "OS_OPENBSD" - case (OS_ALL) - s = s // "OS_ALL" - case default - s = s // "INVALID" - end select - if (allocated(profile%flags)) s = s // ', flags="' // profile%flags // '"' - if (allocated(profile%c_flags)) s = s // ', c_flags="' // profile%c_flags // '"' - if (allocated(profile%cxx_flags)) s = s // ', cxx_flags="' // profile%cxx_flags // '"' - if (allocated(profile%link_time_flags)) s = s // ', link_time_flags="' // profile%link_time_flags // '"' - if (allocated(profile%file_scope_flags)) then - do i=1,size(profile%file_scope_flags) - s = s // ', flags for '//profile%file_scope_flags(i)%file_name// & - & ' ="' // profile%file_scope_flags(i)%flags // '"' - end do end if - s = s // ")" - - end function info_profile - - !> Look for profile with given configuration in array profiles - subroutine find_profile(profiles, profile_name, compiler, os_type, found_matching, chosen_profile) - - !> Array of profiles - type(profile_config_t), allocatable, intent(in) :: profiles(:) - - !> Name of profile - character(:), allocatable, intent(in) :: profile_name - - !> Name of compiler - character(:), allocatable, intent(in) :: compiler - - !> Type of operating system (enum) - integer, intent(in) :: os_type - - !> Boolean value containing true if matching profile was found - logical, intent(out) :: found_matching - - !> Last matching profile in the profiles array - type(profile_config_t), intent(out) :: chosen_profile - - character(:), allocatable :: curr_profile_name - character(:), allocatable :: curr_compiler - integer :: curr_os - integer :: i, priority, curr_priority - - found_matching = .false. - if (size(profiles) < 1) return - ! Try to find profile with matching OS type - do i=1,size(profiles) - curr_profile_name = profiles(i)%profile_name - curr_compiler = profiles(i)%compiler - curr_os = profiles(i)%os_type - if (curr_profile_name.eq.profile_name) then - if (curr_compiler.eq.compiler) then - if (curr_os.eq.os_type) then - chosen_profile = profiles(i) - found_matching = .true. - end if + end if + end do + ! Try to find profile with OS type 'all' + if (.not. found_matching) then + do i = 1, size(profiles) + curr_profile_name = profiles(i)%profile_name + curr_compiler = profiles(i)%compiler + curr_os = profiles(i)%os_type + if (curr_profile_name .eq. profile_name) then + if (curr_compiler .eq. compiler) then + if (curr_os .eq. OS_ALL) then + chosen_profile = profiles(i) + found_matching = .true. end if end if - end do - ! Try to find profile with OS type 'all' - if (.not. found_matching) then - do i=1,size(profiles) - curr_profile_name = profiles(i)%profile_name - curr_compiler = profiles(i)%compiler - curr_os = profiles(i)%os_type - if (curr_profile_name.eq.profile_name) then - if (curr_compiler.eq.compiler) then - if (curr_os.eq.OS_ALL) then - chosen_profile = profiles(i) - found_matching = .true. - end if - end if - end if - end do end if - end subroutine find_profile + end do + end if + end subroutine find_profile end module fpm_manifest_profile diff --git a/src/fpm/manifest/test.f90 b/src/fpm/manifest/test.f90 index c82212ebea..0b694a77aa 100644 --- a/src/fpm/manifest/test.f90 +++ b/src/fpm/manifest/test.f90 @@ -15,164 +15,158 @@ !>[test.dependencies] !>``` module fpm_manifest_test - use fpm_manifest_dependency, only : dependency_config_t, new_dependencies - use fpm_manifest_executable, only : executable_config_t - use fpm_error, only : error_t, syntax_error, bad_name_error - use fpm_toml, only : toml_table, toml_key, toml_stat, get_value, get_list - implicit none - private + use fpm_manifest_dependency, only: dependency_config_t, new_dependencies + use fpm_manifest_executable, only: executable_config_t + use fpm_error, only: error_t, syntax_error, bad_name_error + use fpm_toml, only: toml_table, toml_key, toml_stat, get_value, get_list + implicit none + private - public :: test_config_t, new_test + public :: test_config_t, new_test + !> Configuation meta data for an test + type, extends(executable_config_t) :: test_config_t - !> Configuation meta data for an test - type, extends(executable_config_t) :: test_config_t + contains - contains - - !> Print information on this instance - procedure :: info - - end type test_config_t + !> Print information on this instance + procedure :: info + end type test_config_t contains + !> Construct a new test configuration from a TOML data structure + subroutine new_test(self, table, error) - !> Construct a new test configuration from a TOML data structure - subroutine new_test(self, table, error) - - !> Instance of the test configuration - type(test_config_t), intent(out) :: self - - !> Instance of the TOML data structure - type(toml_table), intent(inout) :: table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table), pointer :: child - - call check(table, error) - if (allocated(error)) return - - call get_value(table, "name", self%name) - if (.not.allocated(self%name)) then - call syntax_error(error, "Could not retrieve test name") - return - end if - if (bad_name_error(error,'test',self%name))then - return - endif - call get_value(table, "source-dir", self%source_dir, "test") - call get_value(table, "main", self%main, "main.f90") - - call get_value(table, "dependencies", child, requested=.false.) - if (associated(child)) then - call new_dependencies(self%dependency, child, error=error) - if (allocated(error)) return - end if + !> Instance of the test configuration + type(test_config_t), intent(out) :: self - call get_list(table, "link", self%link, error) - if (allocated(error)) return + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table - end subroutine new_test + !> Error handling + type(error_t), allocatable, intent(out) :: error + type(toml_table), pointer :: child - !> Check local schema for allowed entries - subroutine check(table, error) + call check(table, error) + if (allocated(error)) return - !> Instance of the TOML data structure - type(toml_table), intent(inout) :: table + call get_value(table, "name", self%name) + if (.not. allocated(self%name)) then + call syntax_error(error, "Could not retrieve test name") + return + end if + if (bad_name_error(error, 'test', self%name)) then + return + end if + call get_value(table, "source-dir", self%source_dir, "test") + call get_value(table, "main", self%main, "main.f90") - !> Error handling - type(error_t), allocatable, intent(out) :: error + call get_value(table, "dependencies", child, requested=.false.) + if (associated(child)) then + call new_dependencies(self%dependency, child, error=error) + if (allocated(error)) return + end if - type(toml_key), allocatable :: list(:) - logical :: name_present - integer :: ikey + call get_list(table, "link", self%link, error) + if (allocated(error)) return - name_present = .false. + end subroutine new_test - call table%get_keys(list) + !> Check local schema for allowed entries + subroutine check(table, error) - if (size(list) < 1) then - call syntax_error(error, "Test section does not provide sufficient entries") - return - end if + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table - do ikey = 1, size(list) - select case(list(ikey)%key) - case default - call syntax_error(error, "Key "//list(ikey)%key//" is not allowed in test entry") - exit + !> Error handling + type(error_t), allocatable, intent(out) :: error - case("name") - name_present = .true. + type(toml_key), allocatable :: list(:) + logical :: name_present + integer :: ikey - case("source-dir", "main", "dependencies", "link") - continue + name_present = .false. - end select - end do - if (allocated(error)) return + call table%get_keys(list) - if (.not.name_present) then - call syntax_error(error, "Test name is not provided, please add a name entry") - end if + if (size(list) < 1) then + call syntax_error(error, "Test section does not provide sufficient entries") + return + end if - end subroutine check + do ikey = 1, size(list) + select case (list(ikey)%key) + case default + call syntax_error(error, "Key "//list(ikey)%key//" is not allowed in test entry") + exit + case ("name") + name_present = .true. - !> Write information on instance - subroutine info(self, unit, verbosity) + case ("source-dir", "main", "dependencies", "link") + continue - !> Instance of the test configuration - class(test_config_t), intent(in) :: self + end select + end do + if (allocated(error)) return - !> Unit for IO - integer, intent(in) :: unit + if (.not. name_present) then + call syntax_error(error, "Test name is not provided, please add a name entry") + end if - !> Verbosity of the printout - integer, intent(in), optional :: verbosity + end subroutine check - integer :: pr, ii - character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)', & - & fmti = '("#", 1x, a, t30, i0)' + !> Write information on instance + subroutine info(self, unit, verbosity) - if (present(verbosity)) then - pr = verbosity - else - pr = 1 - end if + !> Instance of the test configuration + class(test_config_t), intent(in) :: self - if (pr < 1) return + !> Unit for IO + integer, intent(in) :: unit - write(unit, fmt) "Test target" - if (allocated(self%name)) then - write(unit, fmt) "- name", self%name - end if - if (allocated(self%source_dir)) then - if (self%source_dir /= "test" .or. pr > 2) then - write(unit, fmt) "- source directory", self%source_dir - end if - end if - if (allocated(self%main)) then - if (self%main /= "main.f90" .or. pr > 2) then - write(unit, fmt) "- test source", self%main - end if - end if + !> Verbosity of the printout + integer, intent(in), optional :: verbosity - if (allocated(self%dependency)) then - if (size(self%dependency) > 1 .or. pr > 2) then - write(unit, fmti) "- dependencies", size(self%dependency) - end if - do ii = 1, size(self%dependency) - call self%dependency(ii)%info(unit, pr - 1) - end do - end if + integer :: pr, ii + character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)', & + & fmti = '("#", 1x, a, t30, i0)' - end subroutine info + if (present(verbosity)) then + pr = verbosity + else + pr = 1 + end if + + if (pr < 1) return + + write (unit, fmt) "Test target" + if (allocated(self%name)) then + write (unit, fmt) "- name", self%name + end if + if (allocated(self%source_dir)) then + if (self%source_dir /= "test" .or. pr > 2) then + write (unit, fmt) "- source directory", self%source_dir + end if + end if + if (allocated(self%main)) then + if (self%main /= "main.f90" .or. pr > 2) then + write (unit, fmt) "- test source", self%main + end if + end if + + if (allocated(self%dependency)) then + if (size(self%dependency) > 1 .or. pr > 2) then + write (unit, fmti) "- dependencies", size(self%dependency) + end if + do ii = 1, size(self%dependency) + call self%dependency(ii)%info(unit, pr - 1) + end do + end if + end subroutine info end module fpm_manifest_test diff --git a/src/fpm/toml.f90 b/src/fpm/toml.f90 index 3b05229e66..59e0f91eb4 100644 --- a/src/fpm/toml.f90 +++ b/src/fpm/toml.f90 @@ -13,103 +13,99 @@ !> For more details on the library used see the !> [TOML-Fortran](https://toml-f.github.io/toml-f) developer pages. module fpm_toml - use fpm_error, only : error_t, fatal_error, file_not_found_error - use fpm_strings, only : string_t - use tomlf, only : toml_table, toml_array, toml_key, toml_stat, get_value, & - & set_value, toml_parse, toml_error, new_table, add_table, add_array, & - & toml_serializer, len - implicit none - private + use fpm_error, only: error_t, fatal_error, file_not_found_error + use fpm_strings, only: string_t + use tomlf, only: toml_table, toml_array, toml_key, toml_stat, get_value, & + & set_value, toml_parse, toml_error, new_table, add_table, add_array, & + & toml_serializer, len + implicit none + private + + public :: read_package_file + public :: toml_table, toml_array, toml_key, toml_stat, get_value, set_value, get_list + public :: new_table, add_table, add_array, len + public :: toml_error, toml_serializer, toml_parse - public :: read_package_file - public :: toml_table, toml_array, toml_key, toml_stat, get_value, set_value, get_list - public :: new_table, add_table, add_array, len - public :: toml_error, toml_serializer, toml_parse +contains + !> Process the configuration file to a TOML data structure + subroutine read_package_file(table, manifest, error) -contains + !> TOML data structure + type(toml_table), allocatable, intent(out) :: table + !> Name of the package configuration file + character(len=*), intent(in) :: manifest - !> Process the configuration file to a TOML data structure - subroutine read_package_file(table, manifest, error) + !> Error status of the operation + type(error_t), allocatable, intent(out) :: error - !> TOML data structure - type(toml_table), allocatable, intent(out) :: table + type(toml_error), allocatable :: parse_error + integer :: unit + logical :: exist - !> Name of the package configuration file - character(len=*), intent(in) :: manifest + inquire (file=manifest, exist=exist) - !> Error status of the operation - type(error_t), allocatable, intent(out) :: error + if (.not. exist) then + call file_not_found_error(error, manifest) + return + end if - type(toml_error), allocatable :: parse_error - integer :: unit - logical :: exist + open (file=manifest, newunit=unit) + call toml_parse(table, unit, parse_error) + close (unit) - inquire(file=manifest, exist=exist) + if (allocated(parse_error)) then + allocate (error) + call move_alloc(parse_error%message, error%message) + return + end if - if (.not.exist) then - call file_not_found_error(error, manifest) - return - end if + end subroutine read_package_file - open(file=manifest, newunit=unit) - call toml_parse(table, unit, parse_error) - close(unit) + subroutine get_list(table, key, list, error) - if (allocated(parse_error)) then - allocate(error) - call move_alloc(parse_error%message, error%message) - return - end if + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table - end subroutine read_package_file - - - subroutine get_list(table, key, list, error) - - !> Instance of the TOML data structure - type(toml_table), intent(inout) :: table - - !> Key to read from - character(len=*), intent(in) :: key - - !> List of strings to read - type(string_t), allocatable, intent(out) :: list(:) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: stat, ilist, nlist - type(toml_array), pointer :: children - character(len=:), allocatable :: str - - call get_value(table, key, children, requested=.false.) - if (associated(children)) then - nlist = len(children) - allocate(list(nlist)) - do ilist = 1, nlist - call get_value(children, ilist, str, stat=stat) - if (stat /= toml_stat%success) then - call fatal_error(error, "Entry in "//key//" field cannot be read") - exit - end if - call move_alloc(str, list(ilist)%s) - end do - if (allocated(error)) return - else - call get_value(table, key, str, stat=stat) - if (stat /= toml_stat%success) then - call fatal_error(error, "Entry in "//key//" field cannot be read") - return - end if - if (allocated(str)) then - allocate(list(1)) - call move_alloc(str, list(1)%s) - end if - end if + !> Key to read from + character(len=*), intent(in) :: key + + !> List of strings to read + type(string_t), allocatable, intent(out) :: list(:) - end subroutine get_list + !> Error handling + type(error_t), allocatable, intent(out) :: error + integer :: stat, ilist, nlist + type(toml_array), pointer :: children + character(len=:), allocatable :: str + + call get_value(table, key, children, requested=.false.) + if (associated(children)) then + nlist = len(children) + allocate (list(nlist)) + do ilist = 1, nlist + call get_value(children, ilist, str, stat=stat) + if (stat /= toml_stat%success) then + call fatal_error(error, "Entry in "//key//" field cannot be read") + exit + end if + call move_alloc(str, list(ilist)%s) + end do + if (allocated(error)) return + else + call get_value(table, key, str, stat=stat) + if (stat /= toml_stat%success) then + call fatal_error(error, "Entry in "//key//" field cannot be read") + return + end if + if (allocated(str)) then + allocate (list(1)) + call move_alloc(str, list(1)%s) + end if + end if + + end subroutine get_list end module fpm_toml diff --git a/src/fpm/versioning.f90 b/src/fpm/versioning.f90 index da362eeee4..e424d16cf1 100644 --- a/src/fpm/versioning.f90 +++ b/src/fpm/versioning.f90 @@ -1,411 +1,392 @@ !> Implementation of versioning data for comparing packages module fpm_versioning - use fpm_error, only : error_t, syntax_error - implicit none - private - - public :: version_t, new_version, char - - - type :: version_t - private - - !> Version numbers found - integer, allocatable :: num(:) + use fpm_error, only: error_t, syntax_error + implicit none + private - contains + public :: version_t, new_version, char - generic :: operator(==) => equals - procedure, private :: equals - - generic :: operator(/=) => not_equals - procedure, private :: not_equals + type :: version_t + private - generic :: operator(>) => greater - procedure, private :: greater + !> Version numbers found + integer, allocatable :: num(:) - generic :: operator(<) => less - procedure, private :: less + contains - generic :: operator(>=) => greater_equals - procedure, private :: greater_equals + generic :: operator(==) => equals + procedure, private :: equals - generic :: operator(<=) => less_equals - procedure, private :: less_equals + generic :: operator(/=) => not_equals + procedure, private :: not_equals - !> Compare a version against a version constraint (x.x.0 <= v < x.x.HUGE) - generic :: operator(.match.) => match - procedure, private :: match + generic :: operator(>) => greater + procedure, private :: greater - !> Create a printable string from a version data type - procedure :: to_string + generic :: operator(<) => less + procedure, private :: less - end type version_t + generic :: operator(>=) => greater_equals + procedure, private :: greater_equals + generic :: operator(<=) => less_equals + procedure, private :: less_equals - !> Arbitrary internal limit of the version parser - integer, parameter :: max_limit = 3 + !> Compare a version against a version constraint (x.x.0 <= v < x.x.HUGE) + generic :: operator(.match.) => match + procedure, private :: match + !> Create a printable string from a version data type + procedure :: to_string - interface char - module procedure :: as_string - end interface char + end type version_t + !> Arbitrary internal limit of the version parser + integer, parameter :: max_limit = 3 - interface new_version - module procedure :: new_version_from_string - module procedure :: new_version_from_int - end interface new_version + interface char + module procedure :: as_string + end interface char + interface new_version + module procedure :: new_version_from_string + module procedure :: new_version_from_int + end interface new_version contains + !> Create a new version from a string + subroutine new_version_from_int(self, num) - !> Create a new version from a string - subroutine new_version_from_int(self, num) - - !> Instance of the versioning data - type(version_t), intent(out) :: self - - !> Subversion numbers to define version data - integer, intent(in) :: num(:) - - self%num = num - - end subroutine new_version_from_int - - - !> Create a new version from a string - subroutine new_version_from_string(self, string, error) - - !> Instance of the versioning data - type(version_t), intent(out) :: self - - !> String describing the version information - character(len=*), intent(in) :: string - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: istart, iend, stat, nn - integer :: num(max_limit) - logical :: is_number - - nn = 0 - iend = 0 - istart = 0 - is_number = .false. - - do while(iend < len(string)) - call next(string, istart, iend, is_number, error) - if (allocated(error)) exit - if (is_number) then - if (nn >= max_limit) then - call token_error(error, string, istart, iend, & - & "Too many subversions found") - exit - end if - nn = nn + 1 - read(string(istart:iend), *, iostat=stat) num(nn) - if (stat /= 0) then - call token_error(error, string, istart, iend, & - & "Failed to parse version number") - exit - end if - end if - end do - if (allocated(error)) return - if (.not.is_number) then - call token_error(error, string, istart, iend, & - & "Expected version number, but no characters are left") - return - end if - - call new_version(self, num(:nn)) - - end subroutine new_version_from_string + !> Instance of the versioning data + type(version_t), intent(out) :: self + !> Subversion numbers to define version data + integer, intent(in) :: num(:) - !> Tokenize a version string - subroutine next(string, istart, iend, is_number, error) + self%num = num - !> String describing the version information - character(len=*), intent(in) :: string + end subroutine new_version_from_int - !> Start of last token, start of next token on exit - integer, intent(inout) :: istart + !> Create a new version from a string + subroutine new_version_from_string(self, string, error) - !> End of last token on entry, end of next token on exit - integer, intent(inout) :: iend + !> Instance of the versioning data + type(version_t), intent(out) :: self - !> Token produced is a number - logical, intent(inout) :: is_number + !> String describing the version information + character(len=*), intent(in) :: string - !> Error handling - type(error_t), allocatable, intent(out) :: error + !> Error handling + type(error_t), allocatable, intent(out) :: error - integer :: ii, nn - logical :: was_number - character :: tok + integer :: istart, iend, stat, nn + integer :: num(max_limit) + logical :: is_number - was_number = is_number - nn = len(string) + nn = 0 + iend = 0 + istart = 0 + is_number = .false. - if (iend >= nn) then - istart = nn - iend = nn - return + do while (iend < len(string)) + call next(string, istart, iend, is_number, error) + if (allocated(error)) exit + if (is_number) then + if (nn >= max_limit) then + call token_error(error, string, istart, iend, & + & "Too many subversions found") + exit end if - - ii = min(iend + 1, nn) - tok = string(ii:ii) - - is_number = tok /= '.' - if (is_number .eqv. was_number) then - call token_error(error, string, istart, ii, & - & "Unexpected token found") - return + nn = nn + 1 + read (string(istart:iend), *, iostat=stat) num(nn) + if (stat /= 0) then + call token_error(error, string, istart, iend, & + & "Failed to parse version number") + exit end if + end if + end do + if (allocated(error)) return + if (.not. is_number) then + call token_error(error, string, istart, iend, & + & "Expected version number, but no characters are left") + return + end if - if (.not.is_number) then - is_number = .false. - istart = ii - iend = ii - return - end if + call new_version(self, num(:nn)) - istart = ii - do ii = min(iend + 1, nn), nn - tok = string(ii:ii) - select case(tok) - case default - call token_error(error, string, istart, ii, & - & "Invalid character in version number") - exit - case('.') - exit - case('0', '1', '2', '3', '4', '5', '6', '7', '8', '9') - iend = ii - cycle - end select - end do + end subroutine new_version_from_string - end subroutine next + !> Tokenize a version string + subroutine next(string, istart, iend, is_number, error) + !> String describing the version information + character(len=*), intent(in) :: string - !> Create an error on an invalid token, provide some visual context as well - subroutine token_error(error, string, istart, iend, message) + !> Start of last token, start of next token on exit + integer, intent(inout) :: istart - !> Error handling - type(error_t), allocatable, intent(out) :: error + !> End of last token on entry, end of next token on exit + integer, intent(inout) :: iend + + !> Token produced is a number + logical, intent(inout) :: is_number + + !> Error handling + type(error_t), allocatable, intent(out) :: error - !> String describing the version information - character(len=*), intent(in) :: string + integer :: ii, nn + logical :: was_number + character :: tok - !> Start of last token, start of next token on exit - integer, intent(in) :: istart + was_number = is_number + nn = len(string) - !> End of last token on entry, end of next token on exit - integer, intent(in) :: iend + if (iend >= nn) then + istart = nn + iend = nn + return + end if - !> Error message - character(len=*), intent(in) :: message + ii = min(iend + 1, nn) + tok = string(ii:ii) - character(len=*), parameter :: nl = new_line('a') + is_number = tok /= '.' + if (is_number .eqv. was_number) then + call token_error(error, string, istart, ii, & + & "Unexpected token found") + return + end if - allocate(error) - error%message = message // nl // " | " // string // nl // & - & " |" // repeat('-', istart) // repeat('^', iend - istart + 1) + if (.not. is_number) then + is_number = .false. + istart = ii + iend = ii + return + end if - end subroutine token_error + istart = ii + do ii = min(iend + 1, nn), nn + tok = string(ii:ii) + select case (tok) + case default + call token_error(error, string, istart, ii, & + & "Invalid character in version number") + exit + case ('.') + exit + case ('0', '1', '2', '3', '4', '5', '6', '7', '8', '9') + iend = ii + cycle + end select + end do + end subroutine next - subroutine to_string(self, string) + !> Create an error on an invalid token, provide some visual context as well + subroutine token_error(error, string, istart, iend, message) - !> Version number - class(version_t), intent(in) :: self + !> Error handling + type(error_t), allocatable, intent(out) :: error - !> Character representation of the version - character(len=:), allocatable, intent(out) :: string + !> String describing the version information + character(len=*), intent(in) :: string - integer, parameter :: buffersize = 64 - character(len=buffersize) :: buffer - integer :: ii + !> Start of last token, start of next token on exit + integer, intent(in) :: istart - do ii = 1, size(self%num) - if (allocated(string)) then - write(buffer, '(".", i0)') self%num(ii) - string = string // trim(buffer) - else - write(buffer, '(i0)') self%num(ii) - string = trim(buffer) - end if - end do + !> End of last token on entry, end of next token on exit + integer, intent(in) :: iend - if (.not.allocated(string)) then - string = '0' - end if + !> Error message + character(len=*), intent(in) :: message - end subroutine to_string + character(len=*), parameter :: nl = new_line('a') + allocate (error) + error%message = message//nl//" | "//string//nl// & + & " |"//repeat('-', istart)//repeat('^', iend - istart + 1) - function as_string(self) result(string) + end subroutine token_error - !> Version number - class(version_t), intent(in) :: self + subroutine to_string(self, string) - !> Character representation of the version - character(len=:), allocatable :: string + !> Version number + class(version_t), intent(in) :: self - call self%to_string(string) + !> Character representation of the version + character(len=:), allocatable, intent(out) :: string - end function as_string + integer, parameter :: buffersize = 64 + character(len=buffersize) :: buffer + integer :: ii + do ii = 1, size(self%num) + if (allocated(string)) then + write (buffer, '(".", i0)') self%num(ii) + string = string//trim(buffer) + else + write (buffer, '(i0)') self%num(ii) + string = trim(buffer) + end if + end do - !> Check to version numbers for equality - elemental function equals(lhs, rhs) result(is_equal) + if (.not. allocated(string)) then + string = '0' + end if - !> First version number - class(version_t), intent(in) :: lhs + end subroutine to_string - !> Second version number - class(version_t), intent(in) :: rhs + function as_string(self) result(string) - !> Version match - logical :: is_equal + !> Version number + class(version_t), intent(in) :: self - is_equal = .not.(lhs > rhs) - if (is_equal) then - is_equal = .not.(rhs > lhs) - end if + !> Character representation of the version + character(len=:), allocatable :: string - end function equals + call self%to_string(string) + end function as_string - !> Check two versions for inequality - elemental function not_equals(lhs, rhs) result(not_equal) + !> Check to version numbers for equality + elemental function equals(lhs, rhs) result(is_equal) - !> First version number - class(version_t), intent(in) :: lhs + !> First version number + class(version_t), intent(in) :: lhs - !> Second version number - class(version_t), intent(in) :: rhs + !> Second version number + class(version_t), intent(in) :: rhs - !> Version mismatch - logical :: not_equal + !> Version match + logical :: is_equal - not_equal = lhs > rhs - if (.not.not_equal) then - not_equal = rhs > lhs - end if + is_equal = .not. (lhs > rhs) + if (is_equal) then + is_equal = .not. (rhs > lhs) + end if - end function not_equals + end function equals + !> Check two versions for inequality + elemental function not_equals(lhs, rhs) result(not_equal) - !> Relative comparison of two versions - elemental function greater(lhs, rhs) result(is_greater) + !> First version number + class(version_t), intent(in) :: lhs - !> First version number - class(version_t), intent(in) :: lhs + !> Second version number + class(version_t), intent(in) :: rhs - !> Second version number - class(version_t), intent(in) :: rhs + !> Version mismatch + logical :: not_equal - !> First version is greater - logical :: is_greater + not_equal = lhs > rhs + if (.not. not_equal) then + not_equal = rhs > lhs + end if - integer :: ii + end function not_equals - do ii = 1, min(size(lhs%num), size(rhs%num)) - is_greater = lhs%num(ii) > rhs%num(ii) - if (is_greater) exit - end do - if (is_greater) return + !> Relative comparison of two versions + elemental function greater(lhs, rhs) result(is_greater) - is_greater = size(lhs%num) > size(rhs%num) - if (is_greater) then - do ii = size(rhs%num) + 1, size(lhs%num) - is_greater = lhs%num(ii) > 0 - if (is_greater) exit - end do - end if + !> First version number + class(version_t), intent(in) :: lhs - end function greater + !> Second version number + class(version_t), intent(in) :: rhs + !> First version is greater + logical :: is_greater - !> Relative comparison of two versions - elemental function less(lhs, rhs) result(is_less) + integer :: ii - !> First version number - class(version_t), intent(in) :: lhs + do ii = 1, min(size(lhs%num), size(rhs%num)) + is_greater = lhs%num(ii) > rhs%num(ii) + if (is_greater) exit + end do + if (is_greater) return - !> Second version number - class(version_t), intent(in) :: rhs + is_greater = size(lhs%num) > size(rhs%num) + if (is_greater) then + do ii = size(rhs%num) + 1, size(lhs%num) + is_greater = lhs%num(ii) > 0 + if (is_greater) exit + end do + end if - !> First version is less - logical :: is_less + end function greater - is_less = rhs > lhs + !> Relative comparison of two versions + elemental function less(lhs, rhs) result(is_less) - end function less + !> First version number + class(version_t), intent(in) :: lhs + !> Second version number + class(version_t), intent(in) :: rhs - !> Relative comparison of two versions - elemental function greater_equals(lhs, rhs) result(is_greater_equal) + !> First version is less + logical :: is_less - !> First version number - class(version_t), intent(in) :: lhs + is_less = rhs > lhs - !> Second version number - class(version_t), intent(in) :: rhs + end function less - !> First version is greater or equal - logical :: is_greater_equal + !> Relative comparison of two versions + elemental function greater_equals(lhs, rhs) result(is_greater_equal) - is_greater_equal = .not. (rhs > lhs) + !> First version number + class(version_t), intent(in) :: lhs - end function greater_equals + !> Second version number + class(version_t), intent(in) :: rhs + !> First version is greater or equal + logical :: is_greater_equal - !> Relative comparison of two versions - elemental function less_equals(lhs, rhs) result(is_less_equal) + is_greater_equal = .not. (rhs > lhs) - !> First version number - class(version_t), intent(in) :: lhs + end function greater_equals - !> Second version number - class(version_t), intent(in) :: rhs + !> Relative comparison of two versions + elemental function less_equals(lhs, rhs) result(is_less_equal) - !> First version is less or equal - logical :: is_less_equal + !> First version number + class(version_t), intent(in) :: lhs - is_less_equal = .not. (lhs > rhs) + !> Second version number + class(version_t), intent(in) :: rhs - end function less_equals + !> First version is less or equal + logical :: is_less_equal + is_less_equal = .not. (lhs > rhs) - !> Try to match first version against second version - elemental function match(lhs, rhs) + end function less_equals - !> First version number - class(version_t), intent(in) :: lhs + !> Try to match first version against second version + elemental function match(lhs, rhs) - !> Second version number - class(version_t), intent(in) :: rhs + !> First version number + class(version_t), intent(in) :: lhs - !> Version match following semantic versioning rules - logical :: match + !> Second version number + class(version_t), intent(in) :: rhs - type(version_t) :: tmp + !> Version match following semantic versioning rules + logical :: match - match = .not.(rhs > lhs) - if (match) then - tmp%num = rhs%num - tmp%num(size(tmp%num)) = tmp%num(size(tmp%num)) + 1 - match = tmp > lhs - end if + type(version_t) :: tmp - end function match + match = .not. (rhs > lhs) + if (match) then + tmp%num = rhs%num + tmp%num(size(tmp%num)) = tmp%num(size(tmp%num)) + 1 + match = tmp > lhs + end if + end function match end module fpm_versioning diff --git a/src/fpm_backend.F90 b/src/fpm_backend.F90 index 94a60abf9c..2fa4bb8dbf 100644 --- a/src/fpm_backend.F90 +++ b/src/fpm_backend.F90 @@ -27,33 +27,33 @@ !> 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_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.) -use fpm_targets, only: build_target_t, build_target_ptr, FPM_TARGET_OBJECT, & - FPM_TARGET_C_OBJECT, FPM_TARGET_ARCHIVE, FPM_TARGET_EXECUTABLE, & - FPM_TARGET_CPP_OBJECT -use fpm_backend_output -implicit none - -private -public :: build_package, sort_target, schedule_targets + use, intrinsic :: iso_fortran_env, only: stdin => input_unit, stdout => output_unit, stderr => error_unit + use fpm_error, only: fpm_stop + 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.) + use fpm_targets, only: build_target_t, build_target_ptr, FPM_TARGET_OBJECT, & + FPM_TARGET_C_OBJECT, FPM_TARGET_ARCHIVE, FPM_TARGET_EXECUTABLE, & + FPM_TARGET_CPP_OBJECT + use fpm_backend_output + implicit none + + private + public :: build_package, sort_target, schedule_targets #ifndef FPM_BOOTSTRAP -interface - function c_isatty() bind(C, name = 'c_isatty') - use, intrinsic :: iso_c_binding, only: c_int - integer(c_int) :: c_isatty + interface + function c_isatty() bind(C, name='c_isatty') + use, intrinsic :: iso_c_binding, only: c_int + integer(c_int) :: c_isatty end function -end interface + end interface #endif contains !> Top-level routine to build package described by `model` -subroutine build_package(targets,model,verbose) + subroutine build_package(targets, model, verbose) type(build_target_ptr), intent(inout) :: targets(:) type(fpm_model_t), intent(in) :: model logical, intent(in) :: verbose @@ -69,23 +69,23 @@ subroutine build_package(targets,model,verbose) logical :: plain_output ! Need to make output directory for include (mod) files - allocate(build_dirs(0)) + allocate (build_dirs(0)) do i = 1, size(targets) - associate(target => targets(i)%ptr) - if (target%output_dir .in. build_dirs) cycle - temp%s = target%output_dir - build_dirs = [build_dirs, temp] - end associate + associate (target => targets(i)%ptr) + if (target%output_dir.in.build_dirs) cycle + temp%s = target%output_dir + build_dirs = [build_dirs, temp] + end associate end do do i = 1, size(build_dirs) - call mkdir(build_dirs(i)%s,verbose) + call mkdir(build_dirs(i)%s, verbose) end do ! Perform depth-first topological sort of targets - do i=1,size(targets) + do i = 1, size(targets) - call sort_target(targets(i)%ptr) + call sort_target(targets(i)%ptr) end do @@ -93,72 +93,71 @@ 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 - write(stderr, '(a)') 'Project is up to date' - return + if (.not. verbose .and. size(queue) < 1) then + write (stderr, '(a)') 'Project is up to date' + return end if ! Initialise build status flags - allocate(stat(size(queue))) + allocate (stat(size(queue))) stat(:) = 0 build_failed = .false. ! Set output mode #ifndef FPM_BOOTSTRAP - plain_output = (.not.(c_isatty()==1)) .or. verbose + plain_output = (.not. (c_isatty() == 1)) .or. verbose #else plain_output = .true. #endif - progress = build_progress_t(queue,plain_output) + progress = build_progress_t(queue, plain_output) ! Loop over parallel schedule regions - do i=1,size(schedule_ptr)-1 + do i = 1, size(schedule_ptr) - 1 + + ! Build targets in schedule region i + !$omp parallel do default(shared) private(skip_current) schedule(dynamic,1) + do j = schedule_ptr(i), (schedule_ptr(i + 1) - 1) - ! Build targets in schedule region i - !$omp parallel do default(shared) private(skip_current) schedule(dynamic,1) - do j=schedule_ptr(i),(schedule_ptr(i+1)-1) + ! Check if build already failed + !$omp atomic read + skip_current = build_failed - ! Check if build already failed - !$omp atomic read - skip_current = build_failed + if (.not. skip_current) then + call progress%compiling_status(j) + call build_target(model, queue(j)%ptr, verbose, stat(j)) + call progress%completed_status(j, stat(j)) + end if - if (.not.skip_current) then - call progress%compiling_status(j) - call build_target(model,queue(j)%ptr,verbose,stat(j)) - call progress%completed_status(j,stat(j)) - end if + ! Set global flag if this target failed to build + if (stat(j) /= 0) then + !$omp atomic write + build_failed = .true. + end if - ! Set global flag if this target failed to build - if (stat(j) /= 0) then - !$omp atomic write - build_failed = .true. - end if + end do + ! Check if this schedule region failed: exit with message if failed + if (build_failed) then + write (*, *) + do j = 1, size(stat) + if (stat(j) /= 0) Then + call print_build_log(queue(j)%ptr) + end if end do - - ! Check if this schedule region failed: exit with message if failed - if (build_failed) then - write(*,*) - do j=1,size(stat) - if (stat(j) /= 0) Then - call print_build_log(queue(j)%ptr) - end if - end do - do j=1,size(stat) - if (stat(j) /= 0) then - write(stderr,'(*(g0:,1x))') ' Compilation failed for object "',basename(queue(j)%ptr%output_file),'"' - end if - end do - call fpm_stop(1,'stopping due to failed compilation') - end if + do j = 1, size(stat) + if (stat(j) /= 0) then + write (stderr, '(*(g0:,1x))') ' Compilation failed for object "', basename(queue(j)%ptr%output_file), '"' + end if + end do + call fpm_stop(1, 'stopping due to failed compilation') + end if end do call progress%success() -end subroutine build_package - + end subroutine build_package !> Topologically sort a target for scheduling by !> recursing over its dependencies. @@ -172,85 +171,84 @@ 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) type(build_target_t), intent(inout), target :: target integer :: i, fh, stat ! Check if target has already been processed (as a dependency) if (target%sorted .or. target%skip) then - return + return end if ! Check for a circular dependency ! (If target has been touched but not processed) if (target%touched) then - call fpm_stop(1,'(!) Circular dependency found with: '//target%output_file) + call fpm_stop(1, '(!) Circular dependency found with: '//target%output_file) else - target%touched = .true. ! Set touched flag + target%touched = .true. ! Set touched flag end if ! 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 + if (.not. allocated(target%digest_cached) .and. & + exists(target%output_file) .and. & + exists(target%output_file//'.digest')) then - allocate(target%digest_cached) - open(newunit=fh,file=target%output_file//'.digest',status='old') - read(fh,*,iostat=stat) target%digest_cached - close(fh) + 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 + if (stat /= 0) then ! Cached digest is not recognized + deallocate (target%digest_cached) + end if end if if (allocated(target%source)) then - ! 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 + ! 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 elseif (exists(target%output_file)) then - ! Skip if target is not source-based and already exists - target%skip = .true. + ! Skip if target is not source-based and already exists + target%skip = .true. end if ! Loop over target dependencies target%schedule = 1 - do i=1,size(target%dependencies) + do i = 1, size(target%dependencies) - ! Sort dependency - call sort_target(target%dependencies(i)%ptr) + ! Sort dependency + call sort_target(target%dependencies(i)%ptr) - if (.not.target%dependencies(i)%ptr%skip) then + if (.not. target%dependencies(i)%ptr%skip) then - ! Can't skip target if any dependency is not skipped - target%skip = .false. + ! 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) + ! Set target schedule after all of its dependencies + target%schedule = max(target%schedule, target%dependencies(i)%ptr%schedule + 1) - end if + end if end do ! Mark flag as processed: either sorted or skipped - target%sorted = .not.target%skip - -end subroutine sort_target + 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) + 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(:) @@ -260,47 +258,46 @@ subroutine schedule_targets(queue, schedule_ptr, targets) n_schedule = 0 ! Number of schedule regions n_sorted = 0 ! Total number of targets to build - do i=1,size(targets) + 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) + 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)) + 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 i = 1, n_schedule - do j=1,size(targets) + do j = 1, size(targets) - if (targets(j)%ptr%sorted) then - if (targets(j)%ptr%schedule == i) then + 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 + queue(n_sorted)%ptr => targets(j)%ptr + n_sorted = n_sorted + 1 + end if + end if - end do + end do - schedule_ptr(i+1) = n_sorted + schedule_ptr(i + 1) = n_sorted end do -end subroutine schedule_targets - + 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,verbose,stat) + subroutine build_target(model, target, verbose, stat) type(fpm_model_t), intent(in) :: model type(build_target_t), intent(in), target :: target logical, intent(in) :: verbose @@ -309,47 +306,46 @@ subroutine build_target(model,target,verbose,stat) integer :: fh !$omp critical - if (.not.exists(dirname(target%output_file))) then - call mkdir(dirname(target%output_file),verbose) + if (.not. exists(dirname(target%output_file))) then + call mkdir(dirname(target%output_file), verbose) end if !$omp end critical - select case(target%target_type) + select case (target%target_type) case (FPM_TARGET_OBJECT) - call model%compiler%compile_fortran(target%source%file_name, target%output_file, & - & target%compile_flags, target%output_log_file, stat) + call model%compiler%compile_fortran(target%source%file_name, target%output_file, & + & target%compile_flags, target%output_log_file, stat) 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) + call model%compiler%compile_c(target%source%file_name, target%output_file, & + & target%compile_flags, target%output_log_file, stat) 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) + call model%compiler%compile_cpp(target%source%file_name, target%output_file, & + & target%compile_flags, target%output_log_file, stat) case (FPM_TARGET_EXECUTABLE) - call model%compiler%link(target%output_file, & - & target%compile_flags//" "//target%link_flags, target%output_log_file, stat) + call model%compiler%link(target%output_file, & + & target%compile_flags//" "//target%link_flags, target%output_log_file, stat) case (FPM_TARGET_ARCHIVE) - call model%archiver%make_archive(target%output_file, target%link_objects, & - & target%output_log_file, stat) + call model%archiver%make_archive(target%output_file, target%link_objects, & + & target%output_log_file, stat) end select if (stat == 0 .and. allocated(target%source)) then - open(newunit=fh,file=target%output_file//'.digest',status='unknown') - write(fh,*) target%source%digest - close(fh) + open (newunit=fh, file=target%output_file//'.digest', status='unknown') + write (fh, *) target%source%digest + close (fh) end if -end subroutine build_target - + end subroutine build_target !> Read and print the build log for target !> -subroutine print_build_log(target) + subroutine print_build_log(target) type(build_target_t), intent(in), target :: target integer :: fh, ios @@ -357,20 +353,20 @@ subroutine print_build_log(target) if (exists(target%output_log_file)) then - open(newunit=fh,file=target%output_log_file,status='old') - do - call getline(fh, line, ios) - if (ios /= 0) exit - write(*,'(A)') trim(line) - end do - close(fh) + open (newunit=fh, file=target%output_log_file, status='old') + do + call getline(fh, line, ios) + if (ios /= 0) exit + write (*, '(A)') trim(line) + end do + close (fh) else - write(stderr,'(*(g0:,1x))') ' Unable to find build log "',basename(target%output_log_file),'"' + write (stderr, '(*(g0:,1x))') ' Unable to find build log "', basename(target%output_log_file), '"' end if -end subroutine print_build_log + end subroutine print_build_log end module fpm_backend diff --git a/src/fpm_backend_console.f90 b/src/fpm_backend_console.f90 index ffeb108207..d1554358e2 100644 --- a/src/fpm_backend_console.f90 +++ b/src/fpm_backend_console.f90 @@ -1,113 +1,113 @@ -!># Build Backend Console -!> This module provides a lightweight implementation for printing to the console -!> and updating previously-printed console lines. It used by `[[fpm_backend_output]]` -!> for pretty-printing build status and progress. -!> -!> @note The implementation for updating previous lines relies on no other output -!> going to `stdout`/`stderr` except through the `console_t` object provided. -!> -!> @note All write statements to `stdout` are enclosed within OpenMP `critical` regions -!> -module fpm_backend_console -use iso_fortran_env, only: stdout=>output_unit -implicit none - -private -public :: console_t -public :: LINE_RESET -public :: COLOR_RED, COLOR_GREEN, COLOR_YELLOW, COLOR_RESET - -character(len=*), parameter :: ESC = char(27) -!> Escape code for erasing current line -character(len=*), parameter :: LINE_RESET = ESC//"[2K"//ESC//"[1G" -!> Escape code for moving up one line -character(len=*), parameter :: LINE_UP = ESC//"[1A" -!> Escape code for moving down one line -character(len=*), parameter :: LINE_DOWN = ESC//"[1B" -!> Escape code for red foreground color -character(len=*), parameter :: COLOR_RED = ESC//"[31m" -!> Escape code for green foreground color -character(len=*), parameter :: COLOR_GREEN = ESC//"[32m" -!> Escape code for yellow foreground color -character(len=*), parameter :: COLOR_YELLOW = ESC//"[93m" -!> Escape code to reset foreground color -character(len=*), parameter :: COLOR_RESET = ESC//"[0m" - -!> Console object -type console_t - !> Number of lines printed - integer :: n_line = 1 - -contains - !> Write a single line to the console - procedure :: write_line => console_write_line - !> Update a previously-written console line - procedure :: update_line => console_update_line -end type console_t - -contains - -!> Write a single line to the standard output -subroutine console_write_line(console,str,line,advance) - !> Console object - class(console_t), intent(inout) :: console - !> String to write - character(*), intent(in) :: str - !> Integer needed to later update console line - integer, intent(out), optional :: line - !> Advancing output (print newline?) - logical, intent(in), optional :: advance - - character(3) :: adv - - adv = "yes" - if (present(advance)) then - if (.not.advance) then - adv = "no" - end if - end if - - !$omp critical - - if (present(line)) then - line = console%n_line - end if - - write(stdout,'(A)',advance=trim(adv)) LINE_RESET//str - - if (adv=="yes") then - console%n_line = console%n_line + 1 - end if - - !$omp end critical - -end subroutine console_write_line - -!> Overwrite a previously-written line in standard output -subroutine console_update_line(console,line_no,str) - !> Console object - class(console_t), intent(in) :: console - !> Integer output from `[[console_write_line]]` - integer, intent(in) :: line_no - !> New string to overwrite line - character(*), intent(in) :: str - - integer :: n - - !$omp critical - - n = console%n_line - line_no - - ! Step back to line - write(stdout,'(A)',advance="no") repeat(LINE_UP,n)//LINE_RESET - - write(stdout,'(A)',advance="no") str - - ! Step forward to end - write(stdout,'(A)',advance="no") repeat(LINE_DOWN,n)//LINE_RESET - - !$omp end critical - -end subroutine console_update_line - -end module fpm_backend_console \ No newline at end of file +!># Build Backend Console +!> This module provides a lightweight implementation for printing to the console +!> and updating previously-printed console lines. It used by `[[fpm_backend_output]]` +!> for pretty-printing build status and progress. +!> +!> @note The implementation for updating previous lines relies on no other output +!> going to `stdout`/`stderr` except through the `console_t` object provided. +!> +!> @note All write statements to `stdout` are enclosed within OpenMP `critical` regions +!> +module fpm_backend_console + use iso_fortran_env, only: stdout => output_unit + implicit none + + private + public :: console_t + public :: LINE_RESET + public :: COLOR_RED, COLOR_GREEN, COLOR_YELLOW, COLOR_RESET + + character(len=*), parameter :: ESC = char(27) +!> Escape code for erasing current line + character(len=*), parameter :: LINE_RESET = ESC//"[2K"//ESC//"[1G" +!> Escape code for moving up one line + character(len=*), parameter :: LINE_UP = ESC//"[1A" +!> Escape code for moving down one line + character(len=*), parameter :: LINE_DOWN = ESC//"[1B" +!> Escape code for red foreground color + character(len=*), parameter :: COLOR_RED = ESC//"[31m" +!> Escape code for green foreground color + character(len=*), parameter :: COLOR_GREEN = ESC//"[32m" +!> Escape code for yellow foreground color + character(len=*), parameter :: COLOR_YELLOW = ESC//"[93m" +!> Escape code to reset foreground color + character(len=*), parameter :: COLOR_RESET = ESC//"[0m" + +!> Console object + type console_t + !> Number of lines printed + integer :: n_line = 1 + + contains + !> Write a single line to the console + procedure :: write_line => console_write_line + !> Update a previously-written console line + procedure :: update_line => console_update_line + end type console_t + +contains + +!> Write a single line to the standard output + subroutine console_write_line(console, str, line, advance) + !> Console object + class(console_t), intent(inout) :: console + !> String to write + character(*), intent(in) :: str + !> Integer needed to later update console line + integer, intent(out), optional :: line + !> Advancing output (print newline?) + logical, intent(in), optional :: advance + + character(3) :: adv + + adv = "yes" + if (present(advance)) then + if (.not. advance) then + adv = "no" + end if + end if + + !$omp critical + + if (present(line)) then + line = console%n_line + end if + + write (stdout, '(A)', advance=trim(adv)) LINE_RESET//str + + if (adv == "yes") then + console%n_line = console%n_line + 1 + end if + + !$omp end critical + + end subroutine console_write_line + +!> Overwrite a previously-written line in standard output + subroutine console_update_line(console, line_no, str) + !> Console object + class(console_t), intent(in) :: console + !> Integer output from `[[console_write_line]]` + integer, intent(in) :: line_no + !> New string to overwrite line + character(*), intent(in) :: str + + integer :: n + + !$omp critical + + n = console%n_line - line_no + + ! Step back to line + write (stdout, '(A)', advance="no") repeat(LINE_UP, n)//LINE_RESET + + write (stdout, '(A)', advance="no") str + + ! Step forward to end + write (stdout, '(A)', advance="no") repeat(LINE_DOWN, n)//LINE_RESET + + !$omp end critical + + end subroutine console_update_line + +end module fpm_backend_console diff --git a/src/fpm_backend_output.f90 b/src/fpm_backend_output.f90 index 9b4e6bdd46..90e4f655cf 100644 --- a/src/fpm_backend_output.f90 +++ b/src/fpm_backend_output.f90 @@ -1,178 +1,178 @@ -!># 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 + 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 diff --git a/src/fpm_command_line.f90 b/src/fpm_command_line.f90 index 659acd1950..fdcc21f8e3 100644 --- a/src/fpm_command_line.f90 +++ b/src/fpm_command_line.f90 @@ -23,480 +23,477 @@ !> ``fpm-help`` and ``fpm --list`` help pages below to make sure the help output !> is complete and consistent as well. module fpm_command_line -use fpm_environment, only : get_os_type, get_env, os_is_unix, & + use fpm_environment, only: get_os_type, get_env, os_is_unix, & OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_WINDOWS, & OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD -use M_CLI2, only : set_args, lget, sget, unnamed, remaining, specified -use M_CLI2, only : get_subcommand, CLI_RESPONSE_FILE -use fpm_strings, only : lower, split, to_fortran_name, is_fortran_name -use fpm_filesystem, only : basename, canon_path, which, run -use fpm_environment, only : get_command_arguments_quoted -use fpm_error, only : fpm_stop, error_t -use fpm_os, only : get_current_directory -use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, & - & stdout=>output_unit, & - & stderr=>error_unit - -implicit none - -private -public :: fpm_cmd_settings, & - fpm_build_settings, & - fpm_install_settings, & - fpm_new_settings, & - fpm_run_settings, & - fpm_test_settings, & - fpm_update_settings, & - fpm_clean_settings, & - get_command_line_settings - -type, abstract :: fpm_cmd_settings + use M_CLI2, only: set_args, lget, sget, unnamed, remaining, specified + use M_CLI2, only: get_subcommand, CLI_RESPONSE_FILE + use fpm_strings, only: lower, split, to_fortran_name, is_fortran_name + use fpm_filesystem, only: basename, canon_path, which, run + use fpm_environment, only: get_command_arguments_quoted + use fpm_error, only: fpm_stop, error_t + use fpm_os, only: get_current_directory + use, intrinsic :: iso_fortran_env, only: stdin => input_unit, & + & stdout => output_unit, & + & stderr => error_unit + + implicit none + + private + public :: fpm_cmd_settings, & + fpm_build_settings, & + fpm_install_settings, & + fpm_new_settings, & + fpm_run_settings, & + fpm_test_settings, & + fpm_update_settings, & + fpm_clean_settings, & + get_command_line_settings + + type, abstract :: fpm_cmd_settings character(len=:), allocatable :: working_dir - logical :: verbose=.true. -end type - -integer,parameter :: ibug=4096 -type, extends(fpm_cmd_settings) :: fpm_new_settings - character(len=:),allocatable :: name - logical :: with_executable=.false. - logical :: with_test=.false. - logical :: with_lib=.true. - logical :: with_example=.false. - logical :: with_full=.false. - logical :: with_bare=.false. - logical :: backfill=.true. -end type - -type, extends(fpm_cmd_settings) :: fpm_build_settings - logical :: list=.false. - logical :: show_model=.false. - logical :: build_tests=.false. - logical :: prune=.true. - character(len=:),allocatable :: compiler - character(len=:),allocatable :: c_compiler - character(len=:),allocatable :: cxx_compiler - character(len=:),allocatable :: archiver - character(len=:),allocatable :: profile - character(len=:),allocatable :: flag - character(len=:),allocatable :: cflag - character(len=:),allocatable :: cxxflag - character(len=:),allocatable :: ldflag -end type - -type, extends(fpm_build_settings) :: fpm_run_settings - character(len=ibug),allocatable :: name(:) - character(len=:),allocatable :: args - character(len=:),allocatable :: runner + logical :: verbose = .true. + end type + + integer, parameter :: ibug = 4096 + type, extends(fpm_cmd_settings) :: fpm_new_settings + character(len=:), allocatable :: name + logical :: with_executable = .false. + logical :: with_test = .false. + logical :: with_lib = .true. + logical :: with_example = .false. + logical :: with_full = .false. + logical :: with_bare = .false. + logical :: backfill = .true. + end type + + type, extends(fpm_cmd_settings) :: fpm_build_settings + logical :: list = .false. + logical :: show_model = .false. + logical :: build_tests = .false. + logical :: prune = .true. + character(len=:), allocatable :: compiler + character(len=:), allocatable :: c_compiler + character(len=:), allocatable :: cxx_compiler + character(len=:), allocatable :: archiver + character(len=:), allocatable :: profile + character(len=:), allocatable :: flag + character(len=:), allocatable :: cflag + character(len=:), allocatable :: cxxflag + character(len=:), allocatable :: ldflag + end type + + type, extends(fpm_build_settings) :: fpm_run_settings + character(len=ibug), allocatable :: name(:) + character(len=:), allocatable :: args + character(len=:), allocatable :: runner logical :: example -end type + end type -type, extends(fpm_run_settings) :: fpm_test_settings -end type + type, extends(fpm_run_settings) :: fpm_test_settings + end type -type, extends(fpm_build_settings) :: fpm_install_settings + type, extends(fpm_build_settings) :: fpm_install_settings character(len=:), allocatable :: prefix character(len=:), allocatable :: bindir character(len=:), allocatable :: libdir character(len=:), allocatable :: includedir logical :: no_rebuild -end type + end type !> Settings for interacting and updating with project dependencies -type, extends(fpm_cmd_settings) :: fpm_update_settings - character(len=ibug),allocatable :: name(:) + type, extends(fpm_cmd_settings) :: fpm_update_settings + character(len=ibug), allocatable :: name(:) logical :: fetch_only logical :: clean -end type + end type -type, extends(fpm_cmd_settings) :: fpm_clean_settings + type, extends(fpm_cmd_settings) :: fpm_clean_settings logical :: unix character(len=:), allocatable :: calling_dir ! directory clean called from - logical :: clean_skip=.false. - logical :: clean_call=.false. -end type - -character(len=:),allocatable :: name -character(len=:),allocatable :: os_type -character(len=ibug),allocatable :: names(:) -character(len=:),allocatable :: tnames(:) - -character(len=:), allocatable :: version_text(:) -character(len=:), allocatable :: help_new(:), help_fpm(:), help_run(:), & - & help_test(:), help_build(:), help_usage(:), help_runner(:), & - & help_text(:), help_install(:), help_help(:), help_update(:), & - & help_list(:), help_list_dash(:), help_list_nodash(:), & - & help_clean(:) -character(len=20),parameter :: manual(*)=[ character(len=20) ::& -& ' ', 'fpm', 'new', 'build', 'run', 'clean', & -& 'test', 'runner', 'install', 'update', 'list', 'help', 'version' ] - -character(len=:), allocatable :: val_runner, val_compiler, val_flag, val_cflag, val_cxxflag, val_ldflag, & - val_profile + logical :: clean_skip = .false. + logical :: clean_call = .false. + end type + + character(len=:), allocatable :: name + character(len=:), allocatable :: os_type + character(len=ibug), allocatable :: names(:) + character(len=:), allocatable :: tnames(:) + + character(len=:), allocatable :: version_text(:) + character(len=:), allocatable :: help_new(:), help_fpm(:), help_run(:), & + & help_test(:), help_build(:), help_usage(:), help_runner(:), & + & help_text(:), help_install(:), help_help(:), help_update(:), & + & help_list(:), help_list_dash(:), help_list_nodash(:), & + & help_clean(:) + character(len=20), parameter :: manual(*) = [character(len=20) ::& + & ' ', 'fpm', 'new', 'build', 'run', 'clean', & + & 'test', 'runner', 'install', 'update', 'list', 'help', 'version'] + + character(len=:), allocatable :: val_runner, val_compiler, val_flag, val_cflag, val_cxxflag, val_ldflag, & + val_profile ! '12345678901234567890123456789012345678901234567890123456789012345678901234567890',& -character(len=80), parameter :: help_text_build_common(*) = [character(len=80) :: & - ' --profile PROF Selects the compilation profile for the build. ',& - ' Currently available profiles are "release" for ',& - ' high optimization and "debug" for full debug options. ',& - ' If --flag is not specified the "debug" flags are the ',& - ' default. ',& - ' --no-prune Disable tree-shaking/pruning of unused module dependencies '& - ] + character(len=80), parameter :: help_text_build_common(*) = [character(len=80) :: & + ' --profile PROF Selects the compilation profile for the build. ', & + ' Currently available profiles are "release" for ', & + ' high optimization and "debug" for full debug options. ', & + ' If --flag is not specified the "debug" flags are the ', & + ' default. ', & + ' --no-prune Disable tree-shaking/pruning of unused module dependencies ' & + ] ! '12345678901234567890123456789012345678901234567890123456789012345678901234567890',& -character(len=80), parameter :: help_text_compiler(*) = [character(len=80) :: & - ' --compiler NAME Specify a compiler name. The default is "gfortran" ',& - ' unless set by the environment variable FPM_FC. ',& - ' --c-compiler NAME Specify the C compiler name. Automatically determined by ',& - ' default unless set by the environment variable FPM_CC. ',& - ' --cxx-compiler NAME Specify the C++ compiler name. Automatically determined by',& - ' default unless set by the environment variable FPM_CXX. ',& - ' --archiver NAME Specify the archiver name. Automatically determined by ',& - ' default unless set by the environment variable FPM_AR. '& - ] + character(len=80), parameter :: help_text_compiler(*) = [character(len=80) :: & + ' --compiler NAME Specify a compiler name. The default is "gfortran" ', & + ' unless set by the environment variable FPM_FC. ', & + ' --c-compiler NAME Specify the C compiler name. Automatically determined by ', & + ' default unless set by the environment variable FPM_CC. ', & + ' --cxx-compiler NAME Specify the C++ compiler name. Automatically determined by', & + ' default unless set by the environment variable FPM_CXX. ', & + ' --archiver NAME Specify the archiver name. Automatically determined by ', & + ' default unless set by the environment variable FPM_AR. ' & + ] ! '12345678901234567890123456789012345678901234567890123456789012345678901234567890',& -character(len=80), parameter :: help_text_flag(*) = [character(len=80) :: & - ' --flag FFLAGS selects compile arguments for the build, the default value is',& - ' set by the FPM_FFLAGS environment variable. These are added ',& - ' to the profile options if --profile is specified, else these ',& - ' these options override the defaults. Note object and .mod ',& - ' directory locations are always built in. ',& - ' --c-flag CFLAGS selects compile arguments specific for C source in the build.',& - ' The default value is set by the FPM_CFLAGS environment ',& - ' variable. ',& - ' --cxx-flag CFLAGS selects compile arguments specific for C++ source in the ',& - ' build. The default value is set by the FPM_CXXFLAGS ',& - ' environment variable. ',& - ' --link-flag LDFLAGS select arguments passed to the linker for the build. The ',& - ' default value is set by the FPM_LDFLAGS environment variable.'& - ] - - -character(len=80), parameter :: help_text_environment(*) = [character(len=80) :: & - 'ENVIRONMENT VARIABLES',& - ' FPM_FC sets the path to the Fortran compiler used for the build,', & - ' will be overwritten by --compiler command line option', & - '', & - ' FPM_FFLAGS sets the arguments for the Fortran compiler', & - ' will be overwritten by --flag command line option', & - '', & - ' FPM_CC sets the path to the C compiler used for the build,', & - ' will be overwritten by --c-compiler command line option', & - '', & - ' FPM_CFLAGS sets the arguments for the C compiler', & - ' will be overwritten by --c-flag command line option', & - '', & - ' FPM_CXX sets the path to the C++ compiler used for the build,', & - ' will be overwritten by --cxx-compiler command line option', & - '', & - ' FPM_CXXFLAGS sets the arguments for the C++ compiler', & - ' will be overwritten by --cxx-flag command line option', & - '', & - ' FPM_AR sets the path to the archiver used for the build,', & - ' will be overwritten by --archiver command line option', & - '', & - ' FPM_LDFLAGS sets additional link arguments for creating executables', & - ' will be overwritten by --link-flag command line option' & - ] + character(len=80), parameter :: help_text_flag(*) = [character(len=80) :: & + ' --flag FFLAGS selects compile arguments for the build, the default value is', & + ' set by the FPM_FFLAGS environment variable. These are added ', & + ' to the profile options if --profile is specified, else these ', & + ' these options override the defaults. Note object and .mod ', & + ' directory locations are always built in. ', & + ' --c-flag CFLAGS selects compile arguments specific for C source in the build.', & + ' The default value is set by the FPM_CFLAGS environment ', & + ' variable. ', & + ' --cxx-flag CFLAGS selects compile arguments specific for C++ source in the ', & + ' build. The default value is set by the FPM_CXXFLAGS ', & + ' environment variable. ', & + ' --link-flag LDFLAGS select arguments passed to the linker for the build. The ', & + ' default value is set by the FPM_LDFLAGS environment variable.' & + ] + + character(len=80), parameter :: help_text_environment(*) = [character(len=80) :: & + 'ENVIRONMENT VARIABLES', & + ' FPM_FC sets the path to the Fortran compiler used for the build,', & + ' will be overwritten by --compiler command line option', & + '', & + ' FPM_FFLAGS sets the arguments for the Fortran compiler', & + ' will be overwritten by --flag command line option', & + '', & + ' FPM_CC sets the path to the C compiler used for the build,', & + ' will be overwritten by --c-compiler command line option', & + '', & + ' FPM_CFLAGS sets the arguments for the C compiler', & + ' will be overwritten by --c-flag command line option', & + '', & + ' FPM_CXX sets the path to the C++ compiler used for the build,', & + ' will be overwritten by --cxx-compiler command line option', & + '', & + ' FPM_CXXFLAGS sets the arguments for the C++ compiler', & + ' will be overwritten by --cxx-flag command line option', & + '', & + ' FPM_AR sets the path to the archiver used for the build,', & + ' will be overwritten by --archiver command line option', & + '', & + ' FPM_LDFLAGS sets additional link arguments for creating executables', & + ' will be overwritten by --link-flag command line option' & + ] contains - subroutine get_command_line_settings(cmd_settings) - class(fpm_cmd_settings), allocatable, intent(out) :: cmd_settings - - integer, parameter :: widest = 256 - character(len=4096) :: cmdarg - integer :: i - integer :: os - logical :: unix - type(fpm_install_settings), allocatable :: install_settings - character(len=:), allocatable :: common_args, compiler_args, run_args, working_dir, & - & c_compiler, cxx_compiler, archiver - - character(len=*), parameter :: fc_env = "FC", cc_env = "CC", ar_env = "AR", & - & fflags_env = "FFLAGS", cflags_env = "CFLAGS", cxxflags_env = "CXXFLAGS", ldflags_env = "LDFLAGS", & - & fc_default = "gfortran", cc_default = " ", ar_default = " ", flags_default = " ", & - & cxx_env = "CXX", cxx_default = " " - type(error_t), allocatable :: error - - call set_help() - os = get_os_type() - ! text for --version switch, - select case (os) - case (OS_LINUX); os_type = "OS Type: Linux" - case (OS_MACOS); os_type = "OS Type: macOS" - case (OS_WINDOWS); os_type = "OS Type: Windows" - case (OS_CYGWIN); os_type = "OS Type: Cygwin" - case (OS_SOLARIS); os_type = "OS Type: Solaris" - case (OS_FREEBSD); os_type = "OS Type: FreeBSD" - case (OS_OPENBSD); os_type = "OS Type: OpenBSD" - case (OS_UNKNOWN); os_type = "OS Type: Unknown" - case default ; os_type = "OS Type: UNKNOWN" - end select - unix = os_is_unix(os) - version_text = [character(len=80) :: & - & 'Version: 0.7.0, alpha', & - & 'Program: fpm(1)', & - & 'Description: A Fortran package manager and build system', & - & 'Home Page: https://github.com/fortran-lang/fpm', & - & 'License: MIT', & - & os_type] - ! find the subcommand name by looking for first word on command - ! not starting with dash - CLI_RESPONSE_FILE=.true. - cmdarg = get_subcommand() - - common_args = & - ' --directory:C " "' // & - ' --verbose F' - - run_args = & - ' --target " "' // & - ' --list F' // & - ' --runner " "' - - compiler_args = & - ' --profile " "' // & - ' --no-prune F' // & - ' --compiler "'//get_fpm_env(fc_env, fc_default)//'"' // & - ' --c-compiler "'//get_fpm_env(cc_env, cc_default)//'"' // & - ' --cxx-compiler "'//get_fpm_env(cxx_env, cxx_default)//'"' // & - ' --archiver "'//get_fpm_env(ar_env, ar_default)//'"' // & - ' --flag:: "'//get_fpm_env(fflags_env, flags_default)//'"' // & - ' --c-flag:: "'//get_fpm_env(cflags_env, flags_default)//'"' // & - ' --cxx-flag:: "'//get_fpm_env(cxxflags_env, flags_default)//'"' // & - ' --link-flag:: "'//get_fpm_env(ldflags_env, flags_default)//'"' - - ! now set subcommand-specific help text and process commandline - ! arguments. Then call subcommand routine - select case(trim(cmdarg)) - - case('run') - call set_args(common_args // compiler_args // run_args //'& - & --all F & - & --example F& - & --',help_run,version_text) - - call check_build_vals() - - if( size(unnamed) > 1 )then - names=unnamed(2:) - else - names=[character(len=len(names)) :: ] - endif - - - if(specified('target') )then - call split(sget('target'),tnames,delimiters=' ,:') - names=[character(len=max(len(names),len(tnames))) :: names,tnames] - endif - - ! convert --all to '*' - if(lget('all'))then - names=[character(len=max(len(names),1)) :: names,'*' ] - endif - - ! convert special string '..' to equivalent (shorter) '*' - ! to allow for a string that does not require shift-key and quoting - do i=1,size(names) - if(names(i)=='..')names(i)='*' - enddo - - c_compiler = sget('c-compiler') - cxx_compiler = sget('cxx-compiler') - archiver = sget('archiver') - allocate(fpm_run_settings :: cmd_settings) - val_runner=sget('runner') - if(specified('runner') .and. val_runner=='')val_runner='echo' - cmd_settings=fpm_run_settings(& - & args=remaining,& - & profile=val_profile,& - & prune=.not.lget('no-prune'), & - & compiler=val_compiler, & - & c_compiler=c_compiler, & - & cxx_compiler=cxx_compiler, & - & archiver=archiver, & - & flag=val_flag, & - & cflag=val_cflag, & - & cxxflag=val_cxxflag, & - & ldflag=val_ldflag, & - & example=lget('example'), & - & list=lget('list'),& - & build_tests=.false.,& - & name=names,& - & runner=val_runner,& - & verbose=lget('verbose') ) - - case('build') - call set_args(common_args // compiler_args //'& - & --list F & - & --show-model F & - & --tests F & - & --',help_build,version_text) - - call check_build_vals() - - c_compiler = sget('c-compiler') - cxx_compiler = sget('cxx-compiler') - archiver = sget('archiver') - allocate( fpm_build_settings :: cmd_settings ) - cmd_settings=fpm_build_settings( & - & profile=val_profile,& - & prune=.not.lget('no-prune'), & - & compiler=val_compiler, & - & c_compiler=c_compiler, & - & cxx_compiler=cxx_compiler, & - & archiver=archiver, & - & flag=val_flag, & - & cflag=val_cflag, & - & cxxflag=val_cxxflag, & - & ldflag=val_ldflag, & - & list=lget('list'),& - & show_model=lget('show-model'),& - & build_tests=lget('tests'),& - & verbose=lget('verbose') ) - - case('new') - call set_args(common_args // '& - & --src F & - & --lib F & - & --app F & - & --test F & - & --example F & - & --backfill F & - & --full F & - & --bare F', & - & help_new, version_text) - select case(size(unnamed)) - case(1) - if(lget('backfill'))then - name='.' - else - write(stderr,'(*(7x,g0,/))') & - & ' fpm new NAME [[--lib|--src] [--app] [--test] [--example]]|[--full|--bare] [--backfill]' - call fpm_stop(1,'directory name required') - endif - case(2) - name=trim(unnamed(2)) - case default - write(stderr,'(7x,g0)') & - & ' fpm new NAME [[--lib|--src] [--app] [--test] [--example]]| [--full|--bare] [--backfill]' - call fpm_stop(2,'only one directory name allowed') - end select - !*! canon_path is not converting ".", etc. - if(name=='.')then - call get_current_directory(name, error) - if (allocated(error)) then - write(stderr, '("[Error]", 1x, a)') error%message - stop 1 - endif - endif - name=canon_path(name) - if( .not.is_fortran_name(to_fortran_name(basename(name))) )then - write(stderr,'(g0)') [ character(len=72) :: & - & ' the fpm project name must be made of up to 63 ASCII letters,', & - & ' numbers, underscores, or hyphens, and start with a letter.'] - call fpm_stop(4,' ') - endif - - - allocate(fpm_new_settings :: cmd_settings) - if (any( specified([character(len=10) :: 'src','lib','app','test','example','bare'])) & - & .and.lget('full') )then - write(stderr,'(*(a))')& - &' --full and any of [--src|--lib,--app,--test,--example,--bare]', & - &' are mutually exclusive.' - call fpm_stop(5,' ') - elseif (any( specified([character(len=10) :: 'src','lib','app','test','example','full'])) & - & .and.lget('bare') )then - write(stderr,'(*(a))')& - &' --bare and any of [--src|--lib,--app,--test,--example,--full]', & - &' are mutually exclusive.' - call fpm_stop(3,' ') - elseif (any( specified([character(len=10) :: 'src','lib','app','test','example']) ) )then - cmd_settings=fpm_new_settings(& - & backfill=lget('backfill'), & - & name=name, & - & with_executable=lget('app'), & - & with_lib=any([lget('lib'),lget('src')]), & - & with_test=lget('test'), & - & with_example=lget('example'), & - & verbose=lget('verbose') ) - else ! default if no specific directories are requested - cmd_settings=fpm_new_settings(& - & backfill=lget('backfill') , & - & name=name, & - & with_executable=.true., & - & with_lib=.true., & - & with_test=.true., & - & with_example=lget('full'), & - & with_full=lget('full'), & - & with_bare=lget('bare'), & - & verbose=lget('verbose') ) - endif - - case('help','manual') - call set_args(common_args, help_help,version_text) - if(size(unnamed)<2)then - if(unnamed(1)=='help')then - unnamed=[' ', 'fpm'] - else - unnamed=manual - endif - elseif(unnamed(2)=='manual')then - unnamed=manual - endif - allocate(character(len=widest) :: help_text(0)) - do i=2,size(unnamed) - select case(unnamed(i)) - case(' ' ) - case('fpm ' ) - help_text=[character(len=widest) :: help_text, help_fpm] - case('new ' ) - help_text=[character(len=widest) :: help_text, help_new] - case('build ' ) - help_text=[character(len=widest) :: help_text, help_build] - case('install' ) - help_text=[character(len=widest) :: help_text, help_install] - case('run ' ) - help_text=[character(len=widest) :: help_text, help_run] - case('test ' ) - help_text=[character(len=widest) :: help_text, help_test] - case('runner' ) - help_text=[character(len=widest) :: help_text, help_runner] - case('list ' ) - help_text=[character(len=widest) :: help_text, help_list] - case('update ' ) - help_text=[character(len=widest) :: help_text, help_update] - case('help ' ) - help_text=[character(len=widest) :: help_text, help_help] - case('version' ) - help_text=[character(len=widest) :: help_text, version_text] - case('clean' ) - help_text=[character(len=widest) :: help_text, help_clean] - case default - help_text=[character(len=widest) :: help_text, & - & ' unknown help topic "'//trim(unnamed(i))//'"'] + subroutine get_command_line_settings(cmd_settings) + class(fpm_cmd_settings), allocatable, intent(out) :: cmd_settings + + integer, parameter :: widest = 256 + character(len=4096) :: cmdarg + integer :: i + integer :: os + logical :: unix + type(fpm_install_settings), allocatable :: install_settings + character(len=:), allocatable :: common_args, compiler_args, run_args, working_dir, & + & c_compiler, cxx_compiler, archiver + + character(len=*), parameter :: fc_env = "FC", cc_env = "CC", ar_env = "AR", & + & fflags_env = "FFLAGS", cflags_env = "CFLAGS", cxxflags_env = "CXXFLAGS", ldflags_env = "LDFLAGS", & + & fc_default = "gfortran", cc_default = " ", ar_default = " ", flags_default = " ", & + & cxx_env = "CXX", cxx_default = " " + type(error_t), allocatable :: error + + call set_help() + os = get_os_type() + ! text for --version switch, + select case (os) + case (OS_LINUX); os_type = "OS Type: Linux" + case (OS_MACOS); os_type = "OS Type: macOS" + case (OS_WINDOWS); os_type = "OS Type: Windows" + case (OS_CYGWIN); os_type = "OS Type: Cygwin" + case (OS_SOLARIS); os_type = "OS Type: Solaris" + case (OS_FREEBSD); os_type = "OS Type: FreeBSD" + case (OS_OPENBSD); os_type = "OS Type: OpenBSD" + case (OS_UNKNOWN); os_type = "OS Type: Unknown" + case default; os_type = "OS Type: UNKNOWN" + end select + unix = os_is_unix(os) + version_text = [character(len=80) :: & + & 'Version: 0.7.0, alpha', & + & 'Program: fpm(1)', & + & 'Description: A Fortran package manager and build system', & + & 'Home Page: https://github.com/fortran-lang/fpm', & + & 'License: MIT', & + & os_type] + ! find the subcommand name by looking for first word on command + ! not starting with dash + CLI_RESPONSE_FILE = .true. + cmdarg = get_subcommand() + + common_args = & + ' --directory:C " "'// & + ' --verbose F' + + run_args = & + ' --target " "'// & + ' --list F'// & + ' --runner " "' + + compiler_args = & + ' --profile " "'// & + ' --no-prune F'// & + ' --compiler "'//get_fpm_env(fc_env, fc_default)//'"'// & + ' --c-compiler "'//get_fpm_env(cc_env, cc_default)//'"'// & + ' --cxx-compiler "'//get_fpm_env(cxx_env, cxx_default)//'"'// & + ' --archiver "'//get_fpm_env(ar_env, ar_default)//'"'// & + ' --flag:: "'//get_fpm_env(fflags_env, flags_default)//'"'// & + ' --c-flag:: "'//get_fpm_env(cflags_env, flags_default)//'"'// & + ' --cxx-flag:: "'//get_fpm_env(cxxflags_env, flags_default)//'"'// & + ' --link-flag:: "'//get_fpm_env(ldflags_env, flags_default)//'"' + + ! now set subcommand-specific help text and process commandline + ! arguments. Then call subcommand routine + select case (trim(cmdarg)) + + case ('run') + call set_args(common_args//compiler_args//run_args//'& + & --all F & + & --example F& + & --', help_run, version_text) + + call check_build_vals() + + if (size(unnamed) > 1) then + names = unnamed(2:) + else + names = [character(len=len(names)) ::] + end if + + if (specified('target')) then + call split(sget('target'), tnames, delimiters=' ,:') + names = [character(len=max(len(names), len(tnames))) :: names, tnames] + end if + + ! convert --all to '*' + if (lget('all')) then + names = [character(len=max(len(names), 1)) :: names, '*'] + end if + + ! convert special string '..' to equivalent (shorter) '*' + ! to allow for a string that does not require shift-key and quoting + do i = 1, size(names) + if (names(i) == '..') names(i) = '*' + end do + + c_compiler = sget('c-compiler') + cxx_compiler = sget('cxx-compiler') + archiver = sget('archiver') + allocate (fpm_run_settings :: cmd_settings) + val_runner = sget('runner') + if (specified('runner') .and. val_runner == '') val_runner = 'echo' + cmd_settings = fpm_run_settings(& + & args=remaining,& + & profile=val_profile,& + & prune=.not. lget('no-prune'), & + & compiler=val_compiler, & + & c_compiler=c_compiler, & + & cxx_compiler=cxx_compiler, & + & archiver=archiver, & + & flag=val_flag, & + & cflag=val_cflag, & + & cxxflag=val_cxxflag, & + & ldflag=val_ldflag, & + & example=lget('example'), & + & list=lget('list'),& + & build_tests=.false.,& + & name=names,& + & runner=val_runner,& + & verbose=lget('verbose')) + + case ('build') + call set_args(common_args//compiler_args//'& + & --list F & + & --show-model F & + & --tests F & + & --', help_build, version_text) + + call check_build_vals() + + c_compiler = sget('c-compiler') + cxx_compiler = sget('cxx-compiler') + archiver = sget('archiver') + allocate (fpm_build_settings :: cmd_settings) + cmd_settings = fpm_build_settings( & + & profile=val_profile,& + & prune=.not. lget('no-prune'), & + & compiler=val_compiler, & + & c_compiler=c_compiler, & + & cxx_compiler=cxx_compiler, & + & archiver=archiver, & + & flag=val_flag, & + & cflag=val_cflag, & + & cxxflag=val_cxxflag, & + & ldflag=val_ldflag, & + & list=lget('list'),& + & show_model=lget('show-model'),& + & build_tests=lget('tests'),& + & verbose=lget('verbose')) + + case ('new') + call set_args(common_args//'& + & --src F & + & --lib F & + & --app F & + & --test F & + & --example F & + & --backfill F & + & --full F & + & --bare F', & + & help_new, version_text) + select case (size(unnamed)) + case (1) + if (lget('backfill')) then + name = '.' + else + write (stderr, '(*(7x,g0,/))') & + & ' fpm new NAME [[--lib|--src] [--app] [--test] [--example]]|[--full|--bare] [--backfill]' + call fpm_stop(1, 'directory name required') + end if + case (2) + name = trim(unnamed(2)) + case default + write (stderr, '(7x,g0)') & + & ' fpm new NAME [[--lib|--src] [--app] [--test] [--example]]| [--full|--bare] [--backfill]' + call fpm_stop(2, 'only one directory name allowed') + end select + !*! canon_path is not converting ".", etc. + if (name == '.') then + call get_current_directory(name, error) + if (allocated(error)) then + write (stderr, '("[Error]", 1x, a)') error%message + stop 1 + end if + end if + name = canon_path(name) + if (.not. is_fortran_name(to_fortran_name(basename(name)))) then + write (stderr, '(g0)') [character(len=72) :: & + & ' the fpm project name must be made of up to 63 ASCII letters,', & + & ' numbers, underscores, or hyphens, and start with a letter.'] + call fpm_stop(4, ' ') + end if + + allocate (fpm_new_settings :: cmd_settings) + if (any(specified([character(len=10) :: 'src', 'lib', 'app', 'test', 'example', 'bare'])) & + & .and. lget('full')) then + write (stderr, '(*(a))')& + &' --full and any of [--src|--lib,--app,--test,--example,--bare]', & + &' are mutually exclusive.' + call fpm_stop(5, ' ') + elseif (any(specified([character(len=10) :: 'src', 'lib', 'app', 'test', 'example', 'full'])) & + & .and. lget('bare')) then + write (stderr, '(*(a))')& + &' --bare and any of [--src|--lib,--app,--test,--example,--full]', & + &' are mutually exclusive.' + call fpm_stop(3, ' ') + elseif (any(specified([character(len=10) :: 'src', 'lib', 'app', 'test', 'example']))) then + cmd_settings = fpm_new_settings(& + & backfill=lget('backfill'), & + & name=name, & + & with_executable=lget('app'), & + & with_lib=any([lget('lib'), lget('src')]), & + & with_test=lget('test'), & + & with_example=lget('example'), & + & verbose=lget('verbose')) + else ! default if no specific directories are requested + cmd_settings = fpm_new_settings(& + & backfill=lget('backfill'), & + & name=name, & + & with_executable=.true., & + & with_lib=.true., & + & with_test=.true., & + & with_example=lget('full'), & + & with_full=lget('full'), & + & with_bare=lget('bare'), & + & verbose=lget('verbose')) + end if + + case ('help', 'manual') + call set_args(common_args, help_help, version_text) + if (size(unnamed) < 2) then + if (unnamed(1) == 'help') then + unnamed = [' ', 'fpm'] + else + unnamed = manual + end if + elseif (unnamed(2) == 'manual') then + unnamed = manual + end if + allocate (character(len=widest) :: help_text(0)) + do i = 2, size(unnamed) + select case (unnamed(i)) + case (' ') + case ('fpm ') + help_text = [character(len=widest) :: help_text, help_fpm] + case ('new ') + help_text = [character(len=widest) :: help_text, help_new] + case ('build ') + help_text = [character(len=widest) :: help_text, help_build] + case ('install') + help_text = [character(len=widest) :: help_text, help_install] + case ('run ') + help_text = [character(len=widest) :: help_text, help_run] + case ('test ') + help_text = [character(len=widest) :: help_text, help_test] + case ('runner') + help_text = [character(len=widest) :: help_text, help_runner] + case ('list ') + help_text = [character(len=widest) :: help_text, help_list] + case ('update ') + help_text = [character(len=widest) :: help_text, help_update] + case ('help ') + help_text = [character(len=widest) :: help_text, help_help] + case ('version') + help_text = [character(len=widest) :: help_text, version_text] + case ('clean') + help_text = [character(len=widest) :: help_text, help_clean] + case default + help_text = [character(len=widest) :: help_text, & + & ' unknown help topic "'//trim(unnamed(i))//'"'] !!& ' unknown help topic "'//trim(unnamed(i)).'not found in:',manual] - end select - enddo - call printhelp(help_text) - - case('install') - call set_args(common_args // compiler_args // '& - & --no-rebuild F --prefix " " & - & --list F & - & --libdir "lib" --bindir "bin" --includedir "include"', & - help_install, version_text) - - call check_build_vals() - - c_compiler = sget('c-compiler') - cxx_compiler = sget('cxx-compiler') - archiver = sget('archiver') - allocate(install_settings, source=fpm_install_settings(& + end select + end do + call printhelp(help_text) + + case ('install') + call set_args(common_args//compiler_args//'& + & --no-rebuild F --prefix " " & + & --list F & + & --libdir "lib" --bindir "bin" --includedir "include"', & + help_install, version_text) + + call check_build_vals() + + c_compiler = sget('c-compiler') + cxx_compiler = sget('cxx-compiler') + archiver = sget('archiver') + allocate (install_settings, source=fpm_install_settings( & list=lget('list'), & - profile=val_profile,& - prune=.not.lget('no-prune'), & + profile=val_profile, & + prune=.not. lget('no-prune'), & compiler=val_compiler, & c_compiler=c_compiler, & cxx_compiler=cxx_compiler, & @@ -507,819 +504,818 @@ subroutine get_command_line_settings(cmd_settings) ldflag=val_ldflag, & no_rebuild=lget('no-rebuild'), & verbose=lget('verbose'))) - call get_char_arg(install_settings%prefix, 'prefix') - call get_char_arg(install_settings%libdir, 'libdir') - call get_char_arg(install_settings%bindir, 'bindir') - call get_char_arg(install_settings%includedir, 'includedir') - call move_alloc(install_settings, cmd_settings) - - case('list') - call set_args(common_args // '& - & --list F& - &', help_list, version_text) - if(lget('list'))then - help_text = [character(widest) :: help_list_nodash, help_list_dash] - else - help_text = help_list_nodash - endif - call printhelp(help_text) - - case('test') - call set_args(common_args // compiler_args // run_args // ' --', & - help_test,version_text) - - call check_build_vals() - - if( size(unnamed) > 1 )then - names=unnamed(2:) - else - names=[character(len=len(names)) :: ] - endif - - if(specified('target') )then - call split(sget('target'),tnames,delimiters=' ,:') - names=[character(len=max(len(names),len(tnames))) :: names,tnames] - endif - - ! convert special string '..' to equivalent (shorter) '*' - ! to allow for a string that does not require shift-key and quoting - do i=1,size(names) - if(names(i)=='..')names(i)='*' - enddo - - c_compiler = sget('c-compiler') - cxx_compiler = sget('cxx-compiler') - archiver = sget('archiver') - allocate(fpm_test_settings :: cmd_settings) - val_runner=sget('runner') - if(specified('runner') .and. val_runner=='')val_runner='echo' - cmd_settings=fpm_test_settings(& - & args=remaining, & - & profile=val_profile, & - & prune=.not.lget('no-prune'), & - & compiler=val_compiler, & - & c_compiler=c_compiler, & - & cxx_compiler=cxx_compiler, & - & archiver=archiver, & - & flag=val_flag, & - & cflag=val_cflag, & - & cxxflag=val_cxxflag, & - & ldflag=val_ldflag, & - & example=.false., & - & list=lget('list'), & - & build_tests=.true., & - & name=names, & - & runner=val_runner, & - & verbose=lget('verbose') ) - - case('update') - call set_args(common_args // ' --fetch-only F --clean F', & - help_update, version_text) - - if( size(unnamed) > 1 )then - names=unnamed(2:) - else - names=[character(len=len(names)) :: ] - endif - - allocate(fpm_update_settings :: cmd_settings) - cmd_settings=fpm_update_settings(name=names, & - fetch_only=lget('fetch-only'), verbose=lget('verbose'), & - clean=lget('clean')) - - case('clean') - call set_args(common_args // & - & ' --skip' // & - & ' --all', & - help_clean, version_text) - allocate(fpm_clean_settings :: cmd_settings) - call get_current_directory(working_dir, error) - cmd_settings=fpm_clean_settings( & - & unix=unix, & - & calling_dir=working_dir, & - & clean_skip=lget('skip'), & - clean_call=lget('all')) - - case default - - if(cmdarg.ne.''.and.which('fpm-'//cmdarg).ne.'')then - call run('fpm-'//trim(cmdarg)//' '// get_command_arguments_quoted(),.false.) - stop - else - call set_args('& - & --list F& - &', help_fpm, version_text) - ! Note: will not get here if --version or --usage or --help - ! is present on commandline - if(lget('list'))then - help_text = help_list_dash - elseif(len_trim(cmdarg)==0)then - write(stdout,'(*(a))')'Fortran Package Manager:' - write(stdout,'(*(a))')' ' - help_text = [character(widest) :: help_list_nodash, help_usage] - else - write(stderr,'(*(a))')' unknown subcommand [', & - & trim(cmdarg), ']' - help_text = [character(widest) :: help_list_dash, help_usage] - endif - call printhelp(help_text) - endif + call get_char_arg(install_settings%prefix, 'prefix') + call get_char_arg(install_settings%libdir, 'libdir') + call get_char_arg(install_settings%bindir, 'bindir') + call get_char_arg(install_settings%includedir, 'includedir') + call move_alloc(install_settings, cmd_settings) + + case ('list') + call set_args(common_args//'& + & --list F& + &', help_list, version_text) + if (lget('list')) then + help_text = [character(widest) :: help_list_nodash, help_list_dash] + else + help_text = help_list_nodash + end if + call printhelp(help_text) + + case ('test') + call set_args(common_args//compiler_args//run_args//' --', & + help_test, version_text) + + call check_build_vals() + + if (size(unnamed) > 1) then + names = unnamed(2:) + else + names = [character(len=len(names)) ::] + end if + + if (specified('target')) then + call split(sget('target'), tnames, delimiters=' ,:') + names = [character(len=max(len(names), len(tnames))) :: names, tnames] + end if + + ! convert special string '..' to equivalent (shorter) '*' + ! to allow for a string that does not require shift-key and quoting + do i = 1, size(names) + if (names(i) == '..') names(i) = '*' + end do + + c_compiler = sget('c-compiler') + cxx_compiler = sget('cxx-compiler') + archiver = sget('archiver') + allocate (fpm_test_settings :: cmd_settings) + val_runner = sget('runner') + if (specified('runner') .and. val_runner == '') val_runner = 'echo' + cmd_settings = fpm_test_settings(& + & args=remaining, & + & profile=val_profile, & + & prune=.not. lget('no-prune'), & + & compiler=val_compiler, & + & c_compiler=c_compiler, & + & cxx_compiler=cxx_compiler, & + & archiver=archiver, & + & flag=val_flag, & + & cflag=val_cflag, & + & cxxflag=val_cxxflag, & + & ldflag=val_ldflag, & + & example=.false., & + & list=lget('list'), & + & build_tests=.true., & + & name=names, & + & runner=val_runner, & + & verbose=lget('verbose')) + + case ('update') + call set_args(common_args//' --fetch-only F --clean F', & + help_update, version_text) + + if (size(unnamed) > 1) then + names = unnamed(2:) + else + names = [character(len=len(names)) ::] + end if + + allocate (fpm_update_settings :: cmd_settings) + cmd_settings = fpm_update_settings(name=names, & + fetch_only=lget('fetch-only'), verbose=lget('verbose'), & + clean=lget('clean')) + + case ('clean') + call set_args(common_args// & + & ' --skip'// & + & ' --all', & + help_clean, version_text) + allocate (fpm_clean_settings :: cmd_settings) + call get_current_directory(working_dir, error) + cmd_settings = fpm_clean_settings( & + & unix=unix, & + & calling_dir=working_dir, & + & clean_skip=lget('skip'), & + clean_call=lget('all')) + + case default + + if (cmdarg .ne. '' .and. which('fpm-'//cmdarg) .ne. '') then + call run('fpm-'//trim(cmdarg)//' '//get_command_arguments_quoted(), .false.) + stop + else + call set_args('& + & --list F& + &', help_fpm, version_text) + ! Note: will not get here if --version or --usage or --help + ! is present on commandline + if (lget('list')) then + help_text = help_list_dash + elseif (len_trim(cmdarg) == 0) then + write (stdout, '(*(a))') 'Fortran Package Manager:' + write (stdout, '(*(a))') ' ' + help_text = [character(widest) :: help_list_nodash, help_usage] + else + write (stderr, '(*(a))') ' unknown subcommand [', & + & trim(cmdarg), ']' + help_text = [character(widest) :: help_list_dash, help_usage] + end if + call printhelp(help_text) + end if - end select + end select - if (allocated(cmd_settings)) then - working_dir = sget("directory") - call move_alloc(working_dir, cmd_settings%working_dir) - end if + if (allocated(cmd_settings)) then + working_dir = sget("directory") + call move_alloc(working_dir, cmd_settings%working_dir) + end if - contains + contains subroutine check_build_vals() - character(len=:), allocatable :: flags + character(len=:), allocatable :: flags - val_compiler=sget('compiler') - if(val_compiler=='') then - val_compiler='gfortran' - endif + val_compiler = sget('compiler') + if (val_compiler == '') then + val_compiler = 'gfortran' + end if - val_flag = " " // sget('flag') - val_cflag = " " // sget('c-flag') - val_cxxflag = " "// sget('cxx-flag') - val_ldflag = " " // sget('link-flag') - val_profile = sget('profile') + val_flag = " "//sget('flag') + val_cflag = " "//sget('c-flag') + val_cxxflag = " "//sget('cxx-flag') + val_ldflag = " "//sget('link-flag') + val_profile = sget('profile') end subroutine check_build_vals !> Print help text and stop subroutine printhelp(lines) - character(len=:),intent(in),allocatable :: lines(:) - integer :: iii,ii - if(allocated(lines))then - ii=size(lines) - if(ii > 0 .and. len(lines)> 0) then - write(stdout,'(g0)')(trim(lines(iii)), iii=1, ii) - else - write(stdout,'(a)')' *printhelp* output requested is empty' - endif - endif - stop + character(len=:), intent(in), allocatable :: lines(:) + integer :: iii, ii + if (allocated(lines)) then + ii = size(lines) + if (ii > 0 .and. len(lines) > 0) then + write (stdout, '(g0)') (trim(lines(iii)), iii=1, ii) + else + write (stdout, '(a)') ' *printhelp* output requested is empty' + end if + end if + stop end subroutine printhelp - end subroutine get_command_line_settings - - subroutine set_help() - help_list_nodash=[character(len=80) :: & - 'USAGE: fpm [ SUBCOMMAND [SUBCOMMAND_OPTIONS] ]|[--list|--help|--version]', & - ' where SUBCOMMAND is commonly new|build|run|test ', & - ' ', & - ' subcommand may be one of ', & - ' ', & - ' build Compile the package placing results in the "build" directory', & - ' help Display help ', & - ' list Display this list of subcommand descriptions ', & - ' new Create a new Fortran package directory with sample files ', & - ' run Run the local package application programs ', & - ' test Run the test programs ', & - ' update Update and manage project dependencies ', & - ' install Install project ', & - ' clean Delete the build ', & - ' ', & - ' Enter "fpm --list" for a brief list of subcommand options. Enter ', & - ' "fpm --help" or "fpm SUBCOMMAND --help" for detailed descriptions. ', & - ' '] - help_list_dash = [character(len=80) :: & - ' ', & - ' build [--compiler COMPILER_NAME] [--profile PROF] [--flag FFLAGS] [--list] ', & - ' [--tests] [--no-prune] ', & - ' help [NAME(s)] ', & - ' new NAME [[--lib|--src] [--app] [--test] [--example]]| ', & - ' [--full|--bare][--backfill] ', & - ' update [NAME(s)] [--fetch-only] [--clean] [--verbose] ', & - ' list [--list] ', & - ' run [[--target] NAME(s) [--example] [--profile PROF] [--flag FFLAGS] [--all] ', & - ' [--runner "CMD"] [--compiler COMPILER_NAME] [--list] [-- ARGS] ', & - ' test [[--target] NAME(s)] [--profile PROF] [--flag FFLAGS] [--runner "CMD"] ', & - ' [--list] [--compiler COMPILER_NAME] [-- ARGS] ', & - ' install [--profile PROF] [--flag FFLAGS] [--no-rebuild] [--prefix PATH] ', & - ' [options] ', & - ' clean [--skip] [--all] ', & - ' '] - help_usage=[character(len=80) :: & - '' ] - help_runner=[character(len=80) :: & - 'NAME ', & - ' --runner(1) - a shared option for specifying an application to launch ', & - ' executables. ', & - ' ', & - 'SYNOPSIS ', & - ' fpm run|test --runner CMD ... -- SUFFIX_OPTIONS ', & - ' ', & - 'DESCRIPTION ', & - ' The --runner option allows specifying a program to launch ', & - ' executables selected via the fpm(1) subcommands "run" and "test". This ', & - ' gives easy recourse to utilities such as debuggers and other tools ', & - ' that wrap other executables. ', & - ' ', & - ' These external commands are not part of fpm(1) itself as they vary ', & - ' from platform to platform or require independent installation. ', & - ' ', & - 'OPTION ', & - ' --runner ''CMD'' quoted command used to launch the fpm(1) executables. ', & - ' Available for both the "run" and "test" subcommands. ', & - ' If the keyword is specified without a value the default command ', & - ' is "echo". ', & - ' -- SUFFIX_OPTIONS additional options to suffix the command CMD and executable ', & - ' file names with. ', & - 'EXAMPLES ', & - ' Use cases for ''fpm run|test --runner "CMD"'' include employing ', & - ' the following common GNU/Linux and Unix commands: ', & - ' ', & - ' INTERROGATE ', & - ' + nm - list symbols from object files ', & - ' + size - list section sizes and total size. ', & - ' + ldd - print shared object dependencies ', & - ' + ls - list directory contents ', & - ' + stat - display file or file system status ', & - ' + file - determine file type ', & - ' PERFORMANCE AND DEBUGGING ', & - ' + gdb - The GNU Debugger ', & - ' + valgrind - a suite of tools for debugging and profiling ', & - ' + time - time a simple command or give resource usage ', & - ' + timeout - run a command with a time limit ', & - ' COPY ', & - ' + install - copy files and set attributes ', & - ' + tar - an archiving utility ', & - ' ALTER ', & - ' + rm - remove files or directories ', & - ' + chmod - change permissions of a file ', & - ' + strip - remove unnecessary information from strippable files ', & - ' ', & - ' For example ', & - ' ', & - ' fpm test --runner gdb ', & - ' fpm run --runner "tar cvfz $HOME/bundle.tgz" ', & - ' fpm run --runner ldd ', & - ' fpm run --runner strip ', & - ' fpm run --runner ''cp -t /usr/local/bin'' ', & - ' ', & - ' # options after executable name can be specified after the -- option ', & - ' fpm --runner cp run -- /usr/local/bin/ ', & - ' # generates commands of the form "cp $FILENAME /usr/local/bin/" ', & - ' ', & - ' # bash(1) alias example: ', & - ' alias fpm-install=\ ', & - ' "fpm run --profile release --runner ''install -vbp -m 0711 -t ~/.local/bin''" ', & - ' fpm-install ', & - '' ] - help_fpm=[character(len=80) :: & - 'NAME ', & - ' fpm(1) - A Fortran package manager and build system ', & - ' ', & - 'SYNOPSIS ', & - ' fpm SUBCOMMAND [SUBCOMMAND_OPTIONS] ', & - ' ', & - ' fpm --help|--version|--list ', & - ' ', & - 'DESCRIPTION ', & - ' fpm(1) is a package manager that helps you create Fortran projects ', & - ' from source -- it automatically determines dependencies! ', & - ' ', & - ' Most significantly fpm(1) lets you draw upon other fpm(1) packages ', & - ' in distributed git(1) repositories as if the packages were a basic ', & - ' part of your default programming environment, as well as letting ', & - ' you share your projects with others in a similar manner. ', & - ' ', & - ' All output goes into the directory "build/" which can generally be ', & - ' removed and rebuilt if required. Note that if external packages are ', & - ' being used you need network connectivity to rebuild from scratch. ', & - ' ', & - 'SUBCOMMANDS ', & - ' Valid fpm(1) subcommands are: ', & - ' ', & - ' + build Compile the packages into the "build/" directory. ', & - ' + new Create a new Fortran package directory with sample files. ', & - ' + update Update the project dependencies. ', & - ' + run Run the local package binaries. Defaults to all binaries ', & - ' for that release. ', & - ' + test Run the tests. ', & - ' + help Alternate to the --help switch for displaying help text. ', & - ' + list Display brief descriptions of all subcommands. ', & - ' + install Install project. ', & - ' + clean Delete directories in the "build/" directory, except ', & - ' dependencies. Prompts for confirmation to delete. ', & - ' ', & - ' Their syntax is ', & - ' ', & - ' build [--profile PROF] [--flag FFLAGS] [--list] [--compiler COMPILER_NAME] ', & - ' [--tests] [--no-prune] ', & - ' new NAME [[--lib|--src] [--app] [--test] [--example]]| ', & - ' [--full|--bare][--backfill] ', & - ' update [NAME(s)] [--fetch-only] [--clean] ', & - ' run [[--target] NAME(s)] [--profile PROF] [--flag FFLAGS] [--list] [--all] ', & - ' [--example] [--runner "CMD"] [--compiler COMPILER_NAME] ', & - ' [--no-prune] [-- ARGS] ', & - ' test [[--target] NAME(s)] [--profile PROF] [--flag FFLAGS] [--list] ', & - ' [--runner "CMD"] [--compiler COMPILER_NAME] [--no-prune] [-- ARGS] ', & - ' help [NAME(s)] ', & - ' list [--list] ', & - ' install [--profile PROF] [--flag FFLAGS] [--no-rebuild] [--prefix PATH] ', & - ' [options] ', & - ' clean [--skip] [--all] ', & - ' ', & - 'SUBCOMMAND OPTIONS ', & - ' -C, --directory PATH', & - ' Change working directory to PATH before running any command', & - help_text_build_common, & - help_text_compiler, & - help_text_flag, & - ' --list List candidates instead of building or running them. On ', & - ' the fpm(1) command this shows a brief list of subcommands.', & - ' --runner CMD Provides a command to prefix program execution paths. ', & - ' -- ARGS Arguments to pass to executables. ', & - ' --skip Delete directories in the build/ directory without ', & - ' prompting, but skip dependencies. ', & - ' --all Delete directories in the build/ directory without ', & - ' prompting, including dependencies. ', & - ' ', & - 'VALID FOR ALL SUBCOMMANDS ', & - ' --help Show help text and exit ', & - ' --verbose Display additional information when available ', & - ' --version Show version information and exit. ', & - ' ', & - '@file ', & - ' You may replace the default options for the fpm(1) command from a ', & - ' file if your first options begin with @file. Initial options will ', & - ' then be read from the "response file" "file.rsp" in the current ', & - ' directory. ', & - ' ', & - ' If "file" does not exist or cannot be read, then an error occurs and', & - ' the program stops. Each line of the file is prefixed with "options" ', & - ' and interpreted as a separate argument. The file itself may not ', & - ' contain @file arguments. That is, it is not processed recursively. ', & - ' ', & - ' For more information on response files see ', & - ' ', & - ' https://urbanjost.github.io/M_CLI2/set_args.3m_cli2.html ', & - ' ', & - ' The basic functionality described here will remain the same, but ', & - ' other features described at the above reference may change. ', & - ' ', & - ' An example file: ', & - ' ', & - ' # my build options ', & - ' options build ', & - ' options --compiler gfortran ', & - ' options --flag "-pg -static -pthread -Wunreachable-code -Wunused ', & - ' -Wuninitialized -g -O -fbacktrace -fdump-core -fno-underscoring ', & - ' -frecord-marker=4 -L/usr/X11R6/lib -L/usr/X11R6/lib64 -lX11" ', & - ' ', & - ' Note --flag would have to be on one line as response files do not ', & - ' (currently) allow for continued lines or multiple specifications of ', & - ' the same option. ', & - ' ', & - help_text_environment, & - ' ', & - 'EXAMPLES ', & - ' sample commands: ', & - ' ', & - ' fpm new mypackage --app --test ', & - ' fpm build ', & - ' fpm test ', & - ' fpm run ', & - ' fpm run --example ', & - ' fpm new --help ', & - ' fpm run myprogram --profile release -- -x 10 -y 20 --title "my title" ', & - ' fpm install --prefix ~/.local ', & - ' fpm clean --all ', & - ' ', & - 'SEE ALSO ', & - ' ', & - ' + The fpm(1) home page is at https://github.com/fortran-lang/fpm ', & - ' + Registered fpm(1) packages are at https://fortran-lang.org/packages ', & - ' + The fpm(1) TOML file format is described at ', & - ' https://fpm.fortran-lang.org/en/spec/manifest.html ', & - ''] - help_list=[character(len=80) :: & - 'NAME ', & - ' list(1) - list summary of fpm(1) subcommands ', & - ' ', & - 'SYNOPSIS ', & - ' fpm list [-list] ', & - ' ', & - ' fpm list --help|--version ', & - ' ', & - 'DESCRIPTION ', & - ' Display a short description for each fpm(1) subcommand. ', & - ' ', & - 'OPTIONS ', & - ' --list display a list of command options as well. This is the ', & - ' same output as generated by "fpm --list". ', & - ' ', & - 'EXAMPLES ', & - ' display a short list of fpm(1) subcommands ', & - ' ', & - ' fpm list ', & - ' fpm --list ', & - '' ] - help_run=[character(len=80) :: & - 'NAME ', & - ' run(1) - the fpm(1) subcommand to run project applications ', & - ' ', & - 'SYNOPSIS ', & - ' fpm run [[--target] NAME(s) [--profile PROF] [--flag FFLAGS]', & - ' [--compiler COMPILER_NAME] [--runner "CMD"] [--example]', & - ' [--list] [--all] [-- ARGS]', & - ' ', & - ' fpm run --help|--version ', & - ' ', & - 'DESCRIPTION ', & - ' Run the applications in your fpm(1) package. By default applications ', & - ' in /app or specified as "executable" in your "fpm.toml" manifest are ', & - ' used. Alternatively demonstration programs in example/ or specified in', & - ' the "example" section in "fpm.toml" can be executed. The applications ', & - ' are automatically rebuilt before being run if they are out of date. ', & - ' ', & - 'OPTIONS ', & - ' --target NAME(s) list of application names to execute. No name is ', & - ' required if only one target exists. If no name is ', & - ' supplied and more than one candidate exists or a ', & - ' name has no match a list is produced and fpm(1) ', & - ' exits. ', & - ' ', & - ' Basic "globbing" is supported where "?" represents ', & - ' any single character and "*" represents any string. ', & - ' Note The glob string normally needs quoted to ', & - ' the special characters from shell expansion. ', & - ' --all Run all examples or applications. An alias for --target ''*''. ', & - ' --example Run example programs instead of applications. ', & - help_text_build_common, & - help_text_compiler, & - help_text_flag, & - ' --runner CMD A command to prefix the program execution paths with. ', & - ' see "fpm help runner" for further details. ', & - ' --list list basenames of candidates instead of running them. Note ', & - ' out-of-date candidates will still be rebuilt before being ', & - ' listed. ', & - ' -- ARGS optional arguments to pass to the program(s). The same ', & - ' arguments are passed to all program names specified. ', & - ' ', & - help_text_environment, & - ' ', & - 'EXAMPLES ', & - ' fpm(1) - run or display project applications: ', & - ' ', & - ' fpm run # run a target when only one exists or list targets ', & - ' fpm run --list # list basename of all targets, running nothing. ', & - ' fpm run "demo*" --list # list target basenames starting with "demo*".', & - ' fpm run "psi*" --runner # list target pathnames starting with "psi*".', & - ' fpm run --all # run all targets, no matter how many there are. ', & - ' ', & - ' # run default program built or to be built with the compiler command ', & - ' # "f90". If more than one app exists a list displays and target names', & - ' # are required. ', & - ' fpm run --compiler f90 ', & - ' ', & - ' # run example programs instead of the application programs. ', & - ' fpm run --example "*" ', & - ' ', & - ' # run a specific program and pass arguments to the command ', & - ' fpm run myprog -- -x 10 -y 20 --title "my title line" ', & - ' ', & - ' # run production version of two applications ', & - ' fpm run --target prg1,prg2 --profile release ', & - ' ', & - ' # install executables in directory (assuming install(1) exists) ', & - ' fpm run --runner ''install -b -m 0711 -p -t /usr/local/bin'' ', & - '' ] - help_build=[character(len=80) :: & - 'NAME ', & - ' build(1) - the fpm(1) subcommand to build a project ', & - ' ', & - 'SYNOPSIS ', & - ' fpm build [--profile PROF] [--flag FFLAGS] [--compiler COMPILER_NAME] ', & - ' [--list] [--tests] ', & - ' ', & - ' fpm build --help|--version ', & - ' ', & - 'DESCRIPTION ', & - ' The "fpm build" command ', & - ' o Fetches any dependencies ', & - ' o Scans your sources ', & - ' o Builds them in the proper order ', & - ' ', & - ' The Fortran source files are assumed by default to be in ', & - ' o src/ for modules and procedure source ', & - ' o app/ main program(s) for applications ', & - ' o test/ main program(s) and support files for project tests ', & - ' o example/ main program(s) for example programs ', & - ' Changed or new files found are rebuilt. The results are placed in ', & - ' the build/ directory. ', & - ' ', & - ' Non-default pathnames and remote dependencies are used if ', & - ' specified in the "fpm.toml" file. ', & - ' ', & - 'OPTIONS ', & - help_text_build_common,& - help_text_compiler, & - help_text_flag, & - ' --list list candidates instead of building or running them ', & - ' --tests build all tests (otherwise only if needed) ', & - ' --show-model show the model and exit (do not build) ', & - ' --help print this help and exit ', & - ' --version print program version information and exit ', & - ' ', & - help_text_environment, & - ' ', & - 'EXAMPLES ', & - ' Sample commands: ', & - ' ', & - ' fpm build # build with debug options ', & - ' fpm build --profile release # build with high optimization ', & - '' ] - - help_help=[character(len=80) :: & - 'NAME ', & - ' help(1) - the fpm(1) subcommand to display help ', & - ' ', & - 'SYNOPSIS ', & - ' fpm help [fpm] [new] [build] [run] [test] [help] [version] [manual] ', & - ' [runner] ', & - ' ', & - 'DESCRIPTION ', & - ' The "fpm help" command is an alternative to the --help parameter ', & - ' on the fpm(1) command and its subcommands. ', & - ' ', & - 'OPTIONS ', & - ' NAME(s) A list of topic names to display. All the subcommands ', & - ' have their own page (new, build, run, test, ...). ', & - ' ', & - ' The special name "manual" displays all the fpm(1) ', & - ' built-in documentation. ', & - ' ', & - ' The default is to display help for the fpm(1) command ', & - ' itself. ', & - ' ', & - 'EXAMPLES ', & - ' Sample usage: ', & - ' ', & - ' fpm help # general fpm(1) command help ', & - ' fpm help version # show program version ', & - ' fpm help new # display help for "new" subcommand ', & - ' fpm help manual # All fpm(1) built-in documentation ', & - ' ', & - '' ] - help_new=[character(len=80) :: & - 'NAME ', & - ' new(1) - the fpm(1) subcommand to initialize a new project ', & - 'SYNOPSIS ', & - ' fpm new NAME [[--lib|--src] [--app] [--test] [--example]]| ', & - ' [--full|--bare][--backfill] ', & - ' fpm new --help|--version ', & - ' ', & - 'DESCRIPTION ', & - ' "fpm new" creates and populates a new programming project directory. ', & - ' It ', & - ' o creates a directory with the specified name ', & - ' o runs the command "git init" in that directory ', & - ' o populates the directory with the default project directories ', & - ' o adds sample Fortran source files ', & - ' ', & - ' The default file structure (that will be automatically scanned) is ', & - ' ', & - ' NAME/ ', & - ' fpm.toml ', & - ' src/ ', & - ' NAME.f90 ', & - ' app/ ', & - ' main.f90 ', & - ' test/ ', & - ' check.f90 ', & - ' example/ ', & - ' demo.f90 ', & - ' ', & - ' Using this file structure is highly encouraged, particularly for ', & - ' small packages primarily intended to be used as dependencies. ', & - ' ', & - ' If you find this restrictive and need to customize the package ', & - ' structure you will find using the --full switch creates a ', & - ' heavily annotated manifest file with references to documentation ', & - ' to aid in constructing complex package structures. ', & - ' ', & - ' Remember to update the information in the sample "fpm.toml" ', & - ' file with your name and e-mail address. ', & - ' ', & - 'OPTIONS ', & - ' NAME the name of the project directory to create. The name ', & - ' must be made of up to 63 ASCII letters, digits, underscores, ', & - ' or hyphens, and start with a letter. ', & - ' ', & - ' The default is to create the src/, app/, and test/ directories. ', & - ' If any of the following options are specified then only the ', & - ' selected subdirectories are generated: ', & - ' ', & - ' --lib,--src create directory src/ and a placeholder module ', & - ' named "NAME.f90" for use with subcommand "build". ', & - ' --app create directory app/ and a placeholder main ', & - ' program for use with subcommand "run". ', & - ' --test create directory test/ and a placeholder program ', & - ' for use with the subcommand "test". Note that sans ', & - ' "--lib" it really does not have anything to test. ', & - ' --example create directory example/ and a placeholder program ', & - ' for use with the subcommand "run --example". ', & - ' It is only created by default if "--full is" specified. ', & - ' ', & - ' So the default is equivalent to ',& - ' ', & - ' fpm NAME --lib --app --test ', & - ' ', & - ' --backfill By default the directory must not exist. If this ', & - ' option is present the directory may pre-exist and ', & - ' only subdirectories and files that do not ', & - ' already exist will be created. For example, if you ', & - ' previously entered "fpm new myname --lib" entering ', & - ' "fpm new myname -full --backfill" will create any missing', & - ' app/, example/, and test/ directories and programs. ', & - ' ', & - ' --full By default a minimal manifest file ("fpm.toml") is ', & - ' created that depends on auto-discovery. With this ', & - ' option a much more extensive manifest sample is written ', & - ' and the example/ directory is created and populated. ', & - ' It is designed to facilitate creating projects that ', & - ' depend extensively on non-default build options. ', & - ' ', & - ' --bare A minimal manifest file ("fpm.toml") is created and ', & - ' "README.md" file is created but no directories or ', & - ' sample Fortran are generated. ', & - ' ', & - ' --help print this help and exit ', & - ' --version print program version information and exit ', & - ' ', & - 'EXAMPLES ', & - ' Sample use ', & - ' ', & - ' fpm new myproject # create new project directory and seed it ', & - ' cd myproject # Enter the new directory ', & - ' # and run commands such as ', & - ' fpm build ', & - ' fpm run # run lone example application program ', & - ' fpm test # run example test program(s) ', & - ' fpm run --example # run lone example program ', & - ' ', & - ' fpm new A --full # create example/ and an annotated fpm.toml as well', & - ' fpm new A --bare # create no directories ', & - ' create any missing files in current directory ', & - ' fpm new --full --backfill ', & - '' ] - help_test=[character(len=80) :: & - 'NAME ', & - ' test(1) - the fpm(1) subcommand to run project tests ', & - ' ', & - 'SYNOPSIS ', & - ' fpm test [[--target] NAME(s)] [--profile PROF] [--flag FFLAGS]', & - ' [--compiler COMPILER_NAME ] [--runner "CMD"] [--list][-- ARGS]', & - ' ', & - ' fpm test --help|--version ', & - ' ', & - 'DESCRIPTION ', & - ' Run applications you have built to test your project. ', & - ' ', & - 'OPTIONS ', & - ' --target NAME(s) optional list of specific test names to execute. ', & - ' The default is to run all the tests in test/ ', & - ' or the tests listed in the "fpm.toml" file. ', & - ' ', & - ' Basic "globbing" is supported where "?" represents ', & - ' any single character and "*" represents any string. ', & - ' Note The glob string normally needs quoted to ', & - ' protect the special characters from shell expansion.', & - help_text_build_common,& - help_text_compiler, & - help_text_flag, & - ' --runner CMD A command to prefix the program execution paths with. ', & - ' see "fpm help runner" for further details. ', & - ' --list list candidate basenames instead of running them. Note they', & - ' --list will still be built if not currently up to date. ', & - ' -- ARGS optional arguments to pass to the test program(s). ', & - ' The same arguments are passed to all test names ', & - ' specified. ', & - ' ', & - help_text_environment, & - ' ', & - 'EXAMPLES ', & - 'run tests ', & - ' ', & - ' # run default tests in /test or as specified in "fpm.toml" ', & - ' fpm test ', & - ' ', & - ' # run using compiler command "f90" ', & - ' fpm test --compiler f90 ', & - ' ', & - ' # run a specific test and pass arguments to the command ', & - ' fpm test mytest -- -x 10 -y 20 --title "my title line" ', & - ' ', & - ' fpm test tst1 tst2 --profile PROF # run production version of two tests', & - '' ] - help_update=[character(len=80) :: & - 'NAME', & - ' update(1) - manage project dependencies', & - '', & - 'SYNOPSIS', & - ' fpm update [--fetch-only] [--clean] [--verbose] [NAME(s)]', & - '', & - 'DESCRIPTION', & - ' Manage and update project dependencies. If no dependency names are', & - ' provided all the dependencies are updated automatically.', & - '', & - 'OPTIONS', & - ' --fetch-only Only fetch dependencies, do not update existing projects', & - ' --clean Do not use previous dependency cache', & - ' --verbose Show additional printout', & - '', & - 'SEE ALSO', & - ' The fpm(1) home page at https://github.com/fortran-lang/fpm', & - '' ] - help_install=[character(len=80) :: & - 'NAME', & - ' install(1) - install fpm projects', & - '', & - 'SYNOPSIS', & - ' fpm install [--profile PROF] [--flag FFLAGS] [--list] [--no-rebuild]', & - ' [--prefix DIR] [--bindir DIR] [--libdir DIR] [--includedir DIR]', & - ' [--verbose]', & - '', & - 'DESCRIPTION', & - ' Subcommand to install fpm projects. Running install will export the', & - ' current project to the selected prefix, this will by default install all', & - ' executables (tests and examples are excluded) which are part of the projects.', & - ' Libraries and module files are only installed for projects requiring the', & - ' installation of those components in the package manifest.', & - '', & - 'OPTIONS', & - ' --list list all installable targets for this project,', & - ' but do not install any of them', & - help_text_build_common,& - help_text_flag, & - ' --no-rebuild do not rebuild project before installation', & - ' --prefix DIR path to installation directory (requires write access),', & - ' the default prefix on Unix systems is $HOME/.local', & - ' and %APPDATA%\local on Windows', & - ' --bindir DIR subdirectory to place executables in (default: bin)', & - ' --libdir DIR subdirectory to place libraries and archives in', & - ' (default: lib)', & - ' --includedir DIR subdirectory to place headers and module files in', & - ' (default: include)', & - ' --verbose print more information', & - '', & - help_text_environment, & - '', & - 'EXAMPLES', & - ' 1. Install release version of project:', & - '', & - ' fpm install --profile release', & - '', & - ' 2. Install the project without rebuilding the executables:', & - '', & - ' fpm install --no-rebuild', & - '', & - ' 3. Install executables to a custom prefix into the exe directory:', & - '', & - ' fpm install --prefix $PWD --bindir exe', & - '' ] - help_clean=[character(len=80) :: & - 'NAME', & - ' clean(1) - delete the build', & - '', & - 'SYNOPSIS', & - ' fpm clean', & - '', & - 'DESCRIPTION', & - ' Prompts the user to confirm deletion of the build. If affirmative,', & - ' directories in the build/ directory are deleted, except dependencies.', & - '', & - 'OPTIONS', & - ' --skip delete the build without prompting but skip dependencies.', & - ' --all delete the build without prompting including dependencies.', & - '' ] - end subroutine set_help - - subroutine get_char_arg(var, arg) - character(len=:), allocatable, intent(out) :: var - character(len=*), intent(in) :: arg - var = sget(arg) - if (len_trim(var) == 0) deallocate(var) - end subroutine get_char_arg - - - !> Get an environment variable for fpm, this routine ensures that every variable - !> used by fpm is prefixed with FPM_. - function get_fpm_env(env, default) result(val) - character(len=*), intent(in) :: env - character(len=*), intent(in) :: default - character(len=:), allocatable :: val - - character(len=*), parameter :: fpm_prefix = "FPM_" - - val = get_env(fpm_prefix//env, default) - end function get_fpm_env + end subroutine get_command_line_settings + + subroutine set_help() + help_list_nodash = [character(len=80) :: & + 'USAGE: fpm [ SUBCOMMAND [SUBCOMMAND_OPTIONS] ]|[--list|--help|--version]', & + ' where SUBCOMMAND is commonly new|build|run|test ', & + ' ', & + ' subcommand may be one of ', & + ' ', & + ' build Compile the package placing results in the "build" directory', & + ' help Display help ', & + ' list Display this list of subcommand descriptions ', & + ' new Create a new Fortran package directory with sample files ', & + ' run Run the local package application programs ', & + ' test Run the test programs ', & + ' update Update and manage project dependencies ', & + ' install Install project ', & + ' clean Delete the build ', & + ' ', & + ' Enter "fpm --list" for a brief list of subcommand options. Enter ', & + ' "fpm --help" or "fpm SUBCOMMAND --help" for detailed descriptions. ', & + ' '] + help_list_dash = [character(len=80) :: & + ' ', & + ' build [--compiler COMPILER_NAME] [--profile PROF] [--flag FFLAGS] [--list] ', & + ' [--tests] [--no-prune] ', & + ' help [NAME(s)] ', & + ' new NAME [[--lib|--src] [--app] [--test] [--example]]| ', & + ' [--full|--bare][--backfill] ', & + ' update [NAME(s)] [--fetch-only] [--clean] [--verbose] ', & + ' list [--list] ', & + ' run [[--target] NAME(s) [--example] [--profile PROF] [--flag FFLAGS] [--all] ', & + ' [--runner "CMD"] [--compiler COMPILER_NAME] [--list] [-- ARGS] ', & + ' test [[--target] NAME(s)] [--profile PROF] [--flag FFLAGS] [--runner "CMD"] ', & + ' [--list] [--compiler COMPILER_NAME] [-- ARGS] ', & + ' install [--profile PROF] [--flag FFLAGS] [--no-rebuild] [--prefix PATH] ', & + ' [options] ', & + ' clean [--skip] [--all] ', & + ' '] + help_usage = [character(len=80) :: & + ''] + help_runner = [character(len=80) :: & + 'NAME ', & + ' --runner(1) - a shared option for specifying an application to launch ', & + ' executables. ', & + ' ', & + 'SYNOPSIS ', & + ' fpm run|test --runner CMD ... -- SUFFIX_OPTIONS ', & + ' ', & + 'DESCRIPTION ', & + ' The --runner option allows specifying a program to launch ', & + ' executables selected via the fpm(1) subcommands "run" and "test". This ', & + ' gives easy recourse to utilities such as debuggers and other tools ', & + ' that wrap other executables. ', & + ' ', & + ' These external commands are not part of fpm(1) itself as they vary ', & + ' from platform to platform or require independent installation. ', & + ' ', & + 'OPTION ', & + ' --runner ''CMD'' quoted command used to launch the fpm(1) executables. ', & + ' Available for both the "run" and "test" subcommands. ', & + ' If the keyword is specified without a value the default command ', & + ' is "echo". ', & + ' -- SUFFIX_OPTIONS additional options to suffix the command CMD and executable ', & + ' file names with. ', & + 'EXAMPLES ', & + ' Use cases for ''fpm run|test --runner "CMD"'' include employing ', & + ' the following common GNU/Linux and Unix commands: ', & + ' ', & + ' INTERROGATE ', & + ' + nm - list symbols from object files ', & + ' + size - list section sizes and total size. ', & + ' + ldd - print shared object dependencies ', & + ' + ls - list directory contents ', & + ' + stat - display file or file system status ', & + ' + file - determine file type ', & + ' PERFORMANCE AND DEBUGGING ', & + ' + gdb - The GNU Debugger ', & + ' + valgrind - a suite of tools for debugging and profiling ', & + ' + time - time a simple command or give resource usage ', & + ' + timeout - run a command with a time limit ', & + ' COPY ', & + ' + install - copy files and set attributes ', & + ' + tar - an archiving utility ', & + ' ALTER ', & + ' + rm - remove files or directories ', & + ' + chmod - change permissions of a file ', & + ' + strip - remove unnecessary information from strippable files ', & + ' ', & + ' For example ', & + ' ', & + ' fpm test --runner gdb ', & + ' fpm run --runner "tar cvfz $HOME/bundle.tgz" ', & + ' fpm run --runner ldd ', & + ' fpm run --runner strip ', & + ' fpm run --runner ''cp -t /usr/local/bin'' ', & + ' ', & + ' # options after executable name can be specified after the -- option ', & + ' fpm --runner cp run -- /usr/local/bin/ ', & + ' # generates commands of the form "cp $FILENAME /usr/local/bin/" ', & + ' ', & + ' # bash(1) alias example: ', & + ' alias fpm-install=\ ', & + ' "fpm run --profile release --runner ''install -vbp -m 0711 -t ~/.local/bin''" ', & + ' fpm-install ', & + ''] + help_fpm = [character(len=80) :: & + 'NAME ', & + ' fpm(1) - A Fortran package manager and build system ', & + ' ', & + 'SYNOPSIS ', & + ' fpm SUBCOMMAND [SUBCOMMAND_OPTIONS] ', & + ' ', & + ' fpm --help|--version|--list ', & + ' ', & + 'DESCRIPTION ', & + ' fpm(1) is a package manager that helps you create Fortran projects ', & + ' from source -- it automatically determines dependencies! ', & + ' ', & + ' Most significantly fpm(1) lets you draw upon other fpm(1) packages ', & + ' in distributed git(1) repositories as if the packages were a basic ', & + ' part of your default programming environment, as well as letting ', & + ' you share your projects with others in a similar manner. ', & + ' ', & + ' All output goes into the directory "build/" which can generally be ', & + ' removed and rebuilt if required. Note that if external packages are ', & + ' being used you need network connectivity to rebuild from scratch. ', & + ' ', & + 'SUBCOMMANDS ', & + ' Valid fpm(1) subcommands are: ', & + ' ', & + ' + build Compile the packages into the "build/" directory. ', & + ' + new Create a new Fortran package directory with sample files. ', & + ' + update Update the project dependencies. ', & + ' + run Run the local package binaries. Defaults to all binaries ', & + ' for that release. ', & + ' + test Run the tests. ', & + ' + help Alternate to the --help switch for displaying help text. ', & + ' + list Display brief descriptions of all subcommands. ', & + ' + install Install project. ', & + ' + clean Delete directories in the "build/" directory, except ', & + ' dependencies. Prompts for confirmation to delete. ', & + ' ', & + ' Their syntax is ', & + ' ', & + ' build [--profile PROF] [--flag FFLAGS] [--list] [--compiler COMPILER_NAME] ', & + ' [--tests] [--no-prune] ', & + ' new NAME [[--lib|--src] [--app] [--test] [--example]]| ', & + ' [--full|--bare][--backfill] ', & + ' update [NAME(s)] [--fetch-only] [--clean] ', & + ' run [[--target] NAME(s)] [--profile PROF] [--flag FFLAGS] [--list] [--all] ', & + ' [--example] [--runner "CMD"] [--compiler COMPILER_NAME] ', & + ' [--no-prune] [-- ARGS] ', & + ' test [[--target] NAME(s)] [--profile PROF] [--flag FFLAGS] [--list] ', & + ' [--runner "CMD"] [--compiler COMPILER_NAME] [--no-prune] [-- ARGS] ', & + ' help [NAME(s)] ', & + ' list [--list] ', & + ' install [--profile PROF] [--flag FFLAGS] [--no-rebuild] [--prefix PATH] ', & + ' [options] ', & + ' clean [--skip] [--all] ', & + ' ', & + 'SUBCOMMAND OPTIONS ', & + ' -C, --directory PATH', & + ' Change working directory to PATH before running any command', & + help_text_build_common, & + help_text_compiler, & + help_text_flag, & + ' --list List candidates instead of building or running them. On ', & + ' the fpm(1) command this shows a brief list of subcommands.', & + ' --runner CMD Provides a command to prefix program execution paths. ', & + ' -- ARGS Arguments to pass to executables. ', & + ' --skip Delete directories in the build/ directory without ', & + ' prompting, but skip dependencies. ', & + ' --all Delete directories in the build/ directory without ', & + ' prompting, including dependencies. ', & + ' ', & + 'VALID FOR ALL SUBCOMMANDS ', & + ' --help Show help text and exit ', & + ' --verbose Display additional information when available ', & + ' --version Show version information and exit. ', & + ' ', & + '@file ', & + ' You may replace the default options for the fpm(1) command from a ', & + ' file if your first options begin with @file. Initial options will ', & + ' then be read from the "response file" "file.rsp" in the current ', & + ' directory. ', & + ' ', & + ' If "file" does not exist or cannot be read, then an error occurs and', & + ' the program stops. Each line of the file is prefixed with "options" ', & + ' and interpreted as a separate argument. The file itself may not ', & + ' contain @file arguments. That is, it is not processed recursively. ', & + ' ', & + ' For more information on response files see ', & + ' ', & + ' https://urbanjost.github.io/M_CLI2/set_args.3m_cli2.html ', & + ' ', & + ' The basic functionality described here will remain the same, but ', & + ' other features described at the above reference may change. ', & + ' ', & + ' An example file: ', & + ' ', & + ' # my build options ', & + ' options build ', & + ' options --compiler gfortran ', & + ' options --flag "-pg -static -pthread -Wunreachable-code -Wunused ', & + ' -Wuninitialized -g -O -fbacktrace -fdump-core -fno-underscoring ', & + ' -frecord-marker=4 -L/usr/X11R6/lib -L/usr/X11R6/lib64 -lX11" ', & + ' ', & + ' Note --flag would have to be on one line as response files do not ', & + ' (currently) allow for continued lines or multiple specifications of ', & + ' the same option. ', & + ' ', & + help_text_environment, & + ' ', & + 'EXAMPLES ', & + ' sample commands: ', & + ' ', & + ' fpm new mypackage --app --test ', & + ' fpm build ', & + ' fpm test ', & + ' fpm run ', & + ' fpm run --example ', & + ' fpm new --help ', & + ' fpm run myprogram --profile release -- -x 10 -y 20 --title "my title" ', & + ' fpm install --prefix ~/.local ', & + ' fpm clean --all ', & + ' ', & + 'SEE ALSO ', & + ' ', & + ' + The fpm(1) home page is at https://github.com/fortran-lang/fpm ', & + ' + Registered fpm(1) packages are at https://fortran-lang.org/packages ', & + ' + The fpm(1) TOML file format is described at ', & + ' https://fpm.fortran-lang.org/en/spec/manifest.html ', & + ''] + help_list = [character(len=80) :: & + 'NAME ', & + ' list(1) - list summary of fpm(1) subcommands ', & + ' ', & + 'SYNOPSIS ', & + ' fpm list [-list] ', & + ' ', & + ' fpm list --help|--version ', & + ' ', & + 'DESCRIPTION ', & + ' Display a short description for each fpm(1) subcommand. ', & + ' ', & + 'OPTIONS ', & + ' --list display a list of command options as well. This is the ', & + ' same output as generated by "fpm --list". ', & + ' ', & + 'EXAMPLES ', & + ' display a short list of fpm(1) subcommands ', & + ' ', & + ' fpm list ', & + ' fpm --list ', & + ''] + help_run = [character(len=80) :: & + 'NAME ', & + ' run(1) - the fpm(1) subcommand to run project applications ', & + ' ', & + 'SYNOPSIS ', & + ' fpm run [[--target] NAME(s) [--profile PROF] [--flag FFLAGS]', & + ' [--compiler COMPILER_NAME] [--runner "CMD"] [--example]', & + ' [--list] [--all] [-- ARGS]', & + ' ', & + ' fpm run --help|--version ', & + ' ', & + 'DESCRIPTION ', & + ' Run the applications in your fpm(1) package. By default applications ', & + ' in /app or specified as "executable" in your "fpm.toml" manifest are ', & + ' used. Alternatively demonstration programs in example/ or specified in', & + ' the "example" section in "fpm.toml" can be executed. The applications ', & + ' are automatically rebuilt before being run if they are out of date. ', & + ' ', & + 'OPTIONS ', & + ' --target NAME(s) list of application names to execute. No name is ', & + ' required if only one target exists. If no name is ', & + ' supplied and more than one candidate exists or a ', & + ' name has no match a list is produced and fpm(1) ', & + ' exits. ', & + ' ', & + ' Basic "globbing" is supported where "?" represents ', & + ' any single character and "*" represents any string. ', & + ' Note The glob string normally needs quoted to ', & + ' the special characters from shell expansion. ', & + ' --all Run all examples or applications. An alias for --target ''*''. ', & + ' --example Run example programs instead of applications. ', & + help_text_build_common, & + help_text_compiler, & + help_text_flag, & + ' --runner CMD A command to prefix the program execution paths with. ', & + ' see "fpm help runner" for further details. ', & + ' --list list basenames of candidates instead of running them. Note ', & + ' out-of-date candidates will still be rebuilt before being ', & + ' listed. ', & + ' -- ARGS optional arguments to pass to the program(s). The same ', & + ' arguments are passed to all program names specified. ', & + ' ', & + help_text_environment, & + ' ', & + 'EXAMPLES ', & + ' fpm(1) - run or display project applications: ', & + ' ', & + ' fpm run # run a target when only one exists or list targets ', & + ' fpm run --list # list basename of all targets, running nothing. ', & + ' fpm run "demo*" --list # list target basenames starting with "demo*".', & + ' fpm run "psi*" --runner # list target pathnames starting with "psi*".', & + ' fpm run --all # run all targets, no matter how many there are. ', & + ' ', & + ' # run default program built or to be built with the compiler command ', & + ' # "f90". If more than one app exists a list displays and target names', & + ' # are required. ', & + ' fpm run --compiler f90 ', & + ' ', & + ' # run example programs instead of the application programs. ', & + ' fpm run --example "*" ', & + ' ', & + ' # run a specific program and pass arguments to the command ', & + ' fpm run myprog -- -x 10 -y 20 --title "my title line" ', & + ' ', & + ' # run production version of two applications ', & + ' fpm run --target prg1,prg2 --profile release ', & + ' ', & + ' # install executables in directory (assuming install(1) exists) ', & + ' fpm run --runner ''install -b -m 0711 -p -t /usr/local/bin'' ', & + ''] + help_build = [character(len=80) :: & + 'NAME ', & + ' build(1) - the fpm(1) subcommand to build a project ', & + ' ', & + 'SYNOPSIS ', & + ' fpm build [--profile PROF] [--flag FFLAGS] [--compiler COMPILER_NAME] ', & + ' [--list] [--tests] ', & + ' ', & + ' fpm build --help|--version ', & + ' ', & + 'DESCRIPTION ', & + ' The "fpm build" command ', & + ' o Fetches any dependencies ', & + ' o Scans your sources ', & + ' o Builds them in the proper order ', & + ' ', & + ' The Fortran source files are assumed by default to be in ', & + ' o src/ for modules and procedure source ', & + ' o app/ main program(s) for applications ', & + ' o test/ main program(s) and support files for project tests ', & + ' o example/ main program(s) for example programs ', & + ' Changed or new files found are rebuilt. The results are placed in ', & + ' the build/ directory. ', & + ' ', & + ' Non-default pathnames and remote dependencies are used if ', & + ' specified in the "fpm.toml" file. ', & + ' ', & + 'OPTIONS ', & + help_text_build_common, & + help_text_compiler, & + help_text_flag, & + ' --list list candidates instead of building or running them ', & + ' --tests build all tests (otherwise only if needed) ', & + ' --show-model show the model and exit (do not build) ', & + ' --help print this help and exit ', & + ' --version print program version information and exit ', & + ' ', & + help_text_environment, & + ' ', & + 'EXAMPLES ', & + ' Sample commands: ', & + ' ', & + ' fpm build # build with debug options ', & + ' fpm build --profile release # build with high optimization ', & + ''] + + help_help = [character(len=80) :: & + 'NAME ', & + ' help(1) - the fpm(1) subcommand to display help ', & + ' ', & + 'SYNOPSIS ', & + ' fpm help [fpm] [new] [build] [run] [test] [help] [version] [manual] ', & + ' [runner] ', & + ' ', & + 'DESCRIPTION ', & + ' The "fpm help" command is an alternative to the --help parameter ', & + ' on the fpm(1) command and its subcommands. ', & + ' ', & + 'OPTIONS ', & + ' NAME(s) A list of topic names to display. All the subcommands ', & + ' have their own page (new, build, run, test, ...). ', & + ' ', & + ' The special name "manual" displays all the fpm(1) ', & + ' built-in documentation. ', & + ' ', & + ' The default is to display help for the fpm(1) command ', & + ' itself. ', & + ' ', & + 'EXAMPLES ', & + ' Sample usage: ', & + ' ', & + ' fpm help # general fpm(1) command help ', & + ' fpm help version # show program version ', & + ' fpm help new # display help for "new" subcommand ', & + ' fpm help manual # All fpm(1) built-in documentation ', & + ' ', & + ''] + help_new = [character(len=80) :: & + 'NAME ', & + ' new(1) - the fpm(1) subcommand to initialize a new project ', & + 'SYNOPSIS ', & + ' fpm new NAME [[--lib|--src] [--app] [--test] [--example]]| ', & + ' [--full|--bare][--backfill] ', & + ' fpm new --help|--version ', & + ' ', & + 'DESCRIPTION ', & + ' "fpm new" creates and populates a new programming project directory. ', & + ' It ', & + ' o creates a directory with the specified name ', & + ' o runs the command "git init" in that directory ', & + ' o populates the directory with the default project directories ', & + ' o adds sample Fortran source files ', & + ' ', & + ' The default file structure (that will be automatically scanned) is ', & + ' ', & + ' NAME/ ', & + ' fpm.toml ', & + ' src/ ', & + ' NAME.f90 ', & + ' app/ ', & + ' main.f90 ', & + ' test/ ', & + ' check.f90 ', & + ' example/ ', & + ' demo.f90 ', & + ' ', & + ' Using this file structure is highly encouraged, particularly for ', & + ' small packages primarily intended to be used as dependencies. ', & + ' ', & + ' If you find this restrictive and need to customize the package ', & + ' structure you will find using the --full switch creates a ', & + ' heavily annotated manifest file with references to documentation ', & + ' to aid in constructing complex package structures. ', & + ' ', & + ' Remember to update the information in the sample "fpm.toml" ', & + ' file with your name and e-mail address. ', & + ' ', & + 'OPTIONS ', & + ' NAME the name of the project directory to create. The name ', & + ' must be made of up to 63 ASCII letters, digits, underscores, ', & + ' or hyphens, and start with a letter. ', & + ' ', & + ' The default is to create the src/, app/, and test/ directories. ', & + ' If any of the following options are specified then only the ', & + ' selected subdirectories are generated: ', & + ' ', & + ' --lib,--src create directory src/ and a placeholder module ', & + ' named "NAME.f90" for use with subcommand "build". ', & + ' --app create directory app/ and a placeholder main ', & + ' program for use with subcommand "run". ', & + ' --test create directory test/ and a placeholder program ', & + ' for use with the subcommand "test". Note that sans ', & + ' "--lib" it really does not have anything to test. ', & + ' --example create directory example/ and a placeholder program ', & + ' for use with the subcommand "run --example". ', & + ' It is only created by default if "--full is" specified. ', & + ' ', & + ' So the default is equivalent to ', & + ' ', & + ' fpm NAME --lib --app --test ', & + ' ', & + ' --backfill By default the directory must not exist. If this ', & + ' option is present the directory may pre-exist and ', & + ' only subdirectories and files that do not ', & + ' already exist will be created. For example, if you ', & + ' previously entered "fpm new myname --lib" entering ', & + ' "fpm new myname -full --backfill" will create any missing', & + ' app/, example/, and test/ directories and programs. ', & + ' ', & + ' --full By default a minimal manifest file ("fpm.toml") is ', & + ' created that depends on auto-discovery. With this ', & + ' option a much more extensive manifest sample is written ', & + ' and the example/ directory is created and populated. ', & + ' It is designed to facilitate creating projects that ', & + ' depend extensively on non-default build options. ', & + ' ', & + ' --bare A minimal manifest file ("fpm.toml") is created and ', & + ' "README.md" file is created but no directories or ', & + ' sample Fortran are generated. ', & + ' ', & + ' --help print this help and exit ', & + ' --version print program version information and exit ', & + ' ', & + 'EXAMPLES ', & + ' Sample use ', & + ' ', & + ' fpm new myproject # create new project directory and seed it ', & + ' cd myproject # Enter the new directory ', & + ' # and run commands such as ', & + ' fpm build ', & + ' fpm run # run lone example application program ', & + ' fpm test # run example test program(s) ', & + ' fpm run --example # run lone example program ', & + ' ', & + ' fpm new A --full # create example/ and an annotated fpm.toml as well', & + ' fpm new A --bare # create no directories ', & + ' create any missing files in current directory ', & + ' fpm new --full --backfill ', & + ''] + help_test = [character(len=80) :: & + 'NAME ', & + ' test(1) - the fpm(1) subcommand to run project tests ', & + ' ', & + 'SYNOPSIS ', & + ' fpm test [[--target] NAME(s)] [--profile PROF] [--flag FFLAGS]', & + ' [--compiler COMPILER_NAME ] [--runner "CMD"] [--list][-- ARGS]', & + ' ', & + ' fpm test --help|--version ', & + ' ', & + 'DESCRIPTION ', & + ' Run applications you have built to test your project. ', & + ' ', & + 'OPTIONS ', & + ' --target NAME(s) optional list of specific test names to execute. ', & + ' The default is to run all the tests in test/ ', & + ' or the tests listed in the "fpm.toml" file. ', & + ' ', & + ' Basic "globbing" is supported where "?" represents ', & + ' any single character and "*" represents any string. ', & + ' Note The glob string normally needs quoted to ', & + ' protect the special characters from shell expansion.', & + help_text_build_common, & + help_text_compiler, & + help_text_flag, & + ' --runner CMD A command to prefix the program execution paths with. ', & + ' see "fpm help runner" for further details. ', & + ' --list list candidate basenames instead of running them. Note they', & + ' --list will still be built if not currently up to date. ', & + ' -- ARGS optional arguments to pass to the test program(s). ', & + ' The same arguments are passed to all test names ', & + ' specified. ', & + ' ', & + help_text_environment, & + ' ', & + 'EXAMPLES ', & + 'run tests ', & + ' ', & + ' # run default tests in /test or as specified in "fpm.toml" ', & + ' fpm test ', & + ' ', & + ' # run using compiler command "f90" ', & + ' fpm test --compiler f90 ', & + ' ', & + ' # run a specific test and pass arguments to the command ', & + ' fpm test mytest -- -x 10 -y 20 --title "my title line" ', & + ' ', & + ' fpm test tst1 tst2 --profile PROF # run production version of two tests', & + ''] + help_update = [character(len=80) :: & + 'NAME', & + ' update(1) - manage project dependencies', & + '', & + 'SYNOPSIS', & + ' fpm update [--fetch-only] [--clean] [--verbose] [NAME(s)]', & + '', & + 'DESCRIPTION', & + ' Manage and update project dependencies. If no dependency names are', & + ' provided all the dependencies are updated automatically.', & + '', & + 'OPTIONS', & + ' --fetch-only Only fetch dependencies, do not update existing projects', & + ' --clean Do not use previous dependency cache', & + ' --verbose Show additional printout', & + '', & + 'SEE ALSO', & + ' The fpm(1) home page at https://github.com/fortran-lang/fpm', & + ''] + help_install = [character(len=80) :: & + 'NAME', & + ' install(1) - install fpm projects', & + '', & + 'SYNOPSIS', & + ' fpm install [--profile PROF] [--flag FFLAGS] [--list] [--no-rebuild]', & + ' [--prefix DIR] [--bindir DIR] [--libdir DIR] [--includedir DIR]', & + ' [--verbose]', & + '', & + 'DESCRIPTION', & + ' Subcommand to install fpm projects. Running install will export the', & + ' current project to the selected prefix, this will by default install all', & + ' executables (tests and examples are excluded) which are part of the projects.', & + ' Libraries and module files are only installed for projects requiring the', & + ' installation of those components in the package manifest.', & + '', & + 'OPTIONS', & + ' --list list all installable targets for this project,', & + ' but do not install any of them', & + help_text_build_common, & + help_text_flag, & + ' --no-rebuild do not rebuild project before installation', & + ' --prefix DIR path to installation directory (requires write access),', & + ' the default prefix on Unix systems is $HOME/.local', & + ' and %APPDATA%\local on Windows', & + ' --bindir DIR subdirectory to place executables in (default: bin)', & + ' --libdir DIR subdirectory to place libraries and archives in', & + ' (default: lib)', & + ' --includedir DIR subdirectory to place headers and module files in', & + ' (default: include)', & + ' --verbose print more information', & + '', & + help_text_environment, & + '', & + 'EXAMPLES', & + ' 1. Install release version of project:', & + '', & + ' fpm install --profile release', & + '', & + ' 2. Install the project without rebuilding the executables:', & + '', & + ' fpm install --no-rebuild', & + '', & + ' 3. Install executables to a custom prefix into the exe directory:', & + '', & + ' fpm install --prefix $PWD --bindir exe', & + ''] + help_clean = [character(len=80) :: & + 'NAME', & + ' clean(1) - delete the build', & + '', & + 'SYNOPSIS', & + ' fpm clean', & + '', & + 'DESCRIPTION', & + ' Prompts the user to confirm deletion of the build. If affirmative,', & + ' directories in the build/ directory are deleted, except dependencies.', & + '', & + 'OPTIONS', & + ' --skip delete the build without prompting but skip dependencies.', & + ' --all delete the build without prompting including dependencies.', & + ''] + end subroutine set_help + + subroutine get_char_arg(var, arg) + character(len=:), allocatable, intent(out) :: var + character(len=*), intent(in) :: arg + var = sget(arg) + if (len_trim(var) == 0) deallocate (var) + end subroutine get_char_arg + + !> Get an environment variable for fpm, this routine ensures that every variable + !> used by fpm is prefixed with FPM_. + function get_fpm_env(env, default) result(val) + character(len=*), intent(in) :: env + character(len=*), intent(in) :: default + character(len=:), allocatable :: val + + character(len=*), parameter :: fpm_prefix = "FPM_" + + val = get_env(fpm_prefix//env, default) + end function get_fpm_env end module fpm_command_line diff --git a/src/fpm_compiler.f90 b/src/fpm_compiler.f90 index f6c02e9845..dfd6253869 100644 --- a/src/fpm_compiler.f90 +++ b/src/fpm_compiler.f90 @@ -26,55 +26,54 @@ ! Open64 ? ? -module -I -mp discontinued ! Unisys ? ? ? ? ? discontinued module fpm_compiler -use,intrinsic :: iso_fortran_env, only: stderr=>error_unit -use fpm_environment, only: & - get_env, & - get_os_type, & - OS_LINUX, & - OS_MACOS, & - OS_WINDOWS, & - OS_CYGWIN, & - OS_SOLARIS, & - OS_FREEBSD, & - OS_OPENBSD, & - 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_manifest, only : package_config_t -use fpm_error, only: error_t -implicit none -public :: compiler_t, new_compiler, archiver_t, new_archiver, get_macros -public :: debug - -enum, bind(C) + use, intrinsic :: iso_fortran_env, only: stderr => error_unit + use fpm_environment, only: & + get_env, & + get_os_type, & + OS_LINUX, & + OS_MACOS, & + OS_WINDOWS, & + OS_CYGWIN, & + OS_SOLARIS, & + OS_FREEBSD, & + OS_OPENBSD, & + 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_manifest, only: package_config_t + use fpm_error, only: error_t + implicit none + public :: compiler_t, new_compiler, archiver_t, new_archiver, get_macros + public :: debug + + enum, bind(C) enumerator :: & - id_unknown, & - id_gcc, & - id_f95, & - id_caf, & - id_intel_classic_nix, & - id_intel_classic_mac, & - id_intel_classic_windows, & - id_intel_llvm_nix, & - id_intel_llvm_windows, & - id_intel_llvm_unknown, & - id_pgi, & - id_nvhpc, & - id_nag, & - id_flang, & - id_flang_new, & - id_f18, & - id_ibmxl, & - id_cray, & - id_lahey, & - id_lfortran -end enum -integer, parameter :: compiler_enum = kind(id_unknown) - + id_unknown, & + id_gcc, & + id_f95, & + id_caf, & + id_intel_classic_nix, & + id_intel_classic_mac, & + id_intel_classic_windows, & + id_intel_llvm_nix, & + id_intel_llvm_windows, & + id_intel_llvm_unknown, & + id_pgi, & + id_nvhpc, & + id_nag, & + id_flang, & + id_flang_new, & + id_f18, & + id_ibmxl, & + id_cray, & + id_lahey, & + id_lfortran + end enum + integer, parameter :: compiler_enum = kind(id_unknown) !> Definition of compiler object -type :: compiler_t + type :: compiler_t !> Identifier of the compiler integer(compiler_enum) :: id = id_unknown !> Path to the Fortran compiler @@ -87,7 +86,7 @@ module fpm_compiler logical :: echo = .true. !> Verbose output of command logical :: verbose = .true. -contains + contains !> Get default compiler flags procedure :: get_default_flags !> Get flag for module output directories @@ -106,11 +105,10 @@ module fpm_compiler procedure :: is_unknown !> Enumerate libraries, based on compiler and platform procedure :: enumerate_libraries -end type compiler_t - + end type compiler_t !> Definition of archiver object -type :: archiver_t + type :: archiver_t !> Path to archiver character(len=:), allocatable :: ar !> Use response files to pass arguments @@ -119,19 +117,18 @@ module fpm_compiler logical :: echo = .true. !> Verbose output of command logical :: verbose = .true. -contains + contains !> Create static archive procedure :: make_archive -end type archiver_t - + end type archiver_t !> Create debug printout -interface debug + interface debug module procedure :: debug_compiler module procedure :: debug_archiver -end interface debug + end interface debug -character(*), parameter :: & + character(*), parameter :: & flag_gnu_coarray = " -fcoarray=single", & flag_gnu_backtrace = " -fbacktrace", & flag_gnu_opt = " -O3 -funroll-loops", & @@ -142,17 +139,17 @@ module fpm_compiler flag_gnu_limit = " -fmax-errors=1", & flag_gnu_external = " -Wimplicit-interface" -character(*), parameter :: & + character(*), parameter :: & flag_pgi_backslash = " -Mbackslash", & flag_pgi_traceback = " -traceback", & flag_pgi_debug = " -g", & flag_pgi_check = " -Mbounds -Mchkptr -Mchkstk", & flag_pgi_warn = " -Minform=inform" -character(*), parameter :: & + character(*), parameter :: & flag_ibmxl_backslash = " -qnoescape" -character(*), parameter :: & + character(*), parameter :: & flag_intel_backtrace = " -traceback", & flag_intel_warn = " -warn all", & flag_intel_check = " -check all", & @@ -164,7 +161,7 @@ module fpm_compiler flag_intel_nogen = " -nogen-interfaces", & flag_intel_byterecl = " -assume byterecl" -character(*), parameter :: & + character(*), parameter :: & flag_intel_backtrace_win = " /traceback", & flag_intel_warn_win = " /warn:all", & flag_intel_check_win = " /check:all", & @@ -176,7 +173,7 @@ module fpm_compiler flag_intel_nogen_win = " /nogen-interfaces", & flag_intel_byterecl_win = " /assume:byterecl" -character(*), parameter :: & + character(*), parameter :: & flag_nag_coarray = " -coarray=single", & flag_nag_pic = " -PIC", & flag_nag_check = " -C", & @@ -184,242 +181,239 @@ module fpm_compiler flag_nag_opt = " -O4", & flag_nag_backtrace = " -gline" -character(*), parameter :: & + character(*), parameter :: & flag_lfortran_opt = " --fast" - contains - -function get_default_flags(self, release) result(flags) + function get_default_flags(self, release) result(flags) class(compiler_t), intent(in) :: self logical, intent(in) :: release character(len=:), allocatable :: flags if (release) then - call get_release_compile_flags(self%id, flags) + call get_release_compile_flags(self%id, flags) else - call get_debug_compile_flags(self%id, flags) + call get_debug_compile_flags(self%id, flags) end if -end function get_default_flags + end function get_default_flags -subroutine get_release_compile_flags(id, flags) + subroutine get_release_compile_flags(id, flags) integer(compiler_enum), intent(in) :: id character(len=:), allocatable, intent(out) :: flags - - select case(id) + select case (id) case default - flags = "" - case(id_caf) - flags = & - flag_gnu_opt//& - flag_gnu_external//& - flag_gnu_pic//& - flag_gnu_limit - - case(id_gcc) - flags = & - flag_gnu_opt//& - flag_gnu_external//& - flag_gnu_pic//& - flag_gnu_limit//& - flag_gnu_coarray - - case(id_f95) - flags = & - flag_gnu_opt//& - flag_gnu_external//& - flag_gnu_pic//& - flag_gnu_limit - - case(id_nvhpc) - flags = & - flag_pgi_backslash - - case(id_ibmxl) - flags = & - flag_ibmxl_backslash - - case(id_intel_classic_nix) - flags = & - flag_intel_fp//& - flag_intel_align//& - flag_intel_limit//& - flag_intel_pthread//& - flag_intel_nogen//& - flag_intel_byterecl - - case(id_intel_classic_mac) - flags = & - flag_intel_fp//& - flag_intel_align//& - flag_intel_limit//& - flag_intel_pthread//& - flag_intel_nogen//& - flag_intel_byterecl - - case(id_intel_classic_windows) - flags = & - & flag_intel_fp_win//& - flag_intel_align_win//& - flag_intel_limit_win//& - flag_intel_pthread_win//& - flag_intel_nogen_win//& - flag_intel_byterecl_win - - case(id_intel_llvm_nix) - flags = & - flag_intel_fp//& - flag_intel_align//& - flag_intel_limit//& - flag_intel_pthread//& - flag_intel_nogen//& - flag_intel_byterecl - - case(id_intel_llvm_windows) - flags = & - flag_intel_fp_win//& - flag_intel_align_win//& - flag_intel_limit_win//& - flag_intel_pthread_win//& - flag_intel_nogen_win//& - flag_intel_byterecl_win - - case(id_nag) - flags = & - flag_nag_opt//& - flag_nag_coarray//& - flag_nag_pic - - case(id_lfortran) - flags = & - flag_lfortran_opt + flags = "" + case (id_caf) + flags = & + flag_gnu_opt// & + flag_gnu_external// & + flag_gnu_pic// & + flag_gnu_limit + + case (id_gcc) + flags = & + flag_gnu_opt// & + flag_gnu_external// & + flag_gnu_pic// & + flag_gnu_limit// & + flag_gnu_coarray + + case (id_f95) + flags = & + flag_gnu_opt// & + flag_gnu_external// & + flag_gnu_pic// & + flag_gnu_limit + + case (id_nvhpc) + flags = & + flag_pgi_backslash + + case (id_ibmxl) + flags = & + flag_ibmxl_backslash + + case (id_intel_classic_nix) + flags = & + flag_intel_fp// & + flag_intel_align// & + flag_intel_limit// & + flag_intel_pthread// & + flag_intel_nogen// & + flag_intel_byterecl + + case (id_intel_classic_mac) + flags = & + flag_intel_fp// & + flag_intel_align// & + flag_intel_limit// & + flag_intel_pthread// & + flag_intel_nogen// & + flag_intel_byterecl + + case (id_intel_classic_windows) + flags = & + & flag_intel_fp_win// & + flag_intel_align_win// & + flag_intel_limit_win// & + flag_intel_pthread_win// & + flag_intel_nogen_win// & + flag_intel_byterecl_win + + case (id_intel_llvm_nix) + flags = & + flag_intel_fp// & + flag_intel_align// & + flag_intel_limit// & + flag_intel_pthread// & + flag_intel_nogen// & + flag_intel_byterecl + + case (id_intel_llvm_windows) + flags = & + flag_intel_fp_win// & + flag_intel_align_win// & + flag_intel_limit_win// & + flag_intel_pthread_win// & + flag_intel_nogen_win// & + flag_intel_byterecl_win + + case (id_nag) + flags = & + flag_nag_opt// & + flag_nag_coarray// & + flag_nag_pic + + case (id_lfortran) + flags = & + flag_lfortran_opt end select -end subroutine get_release_compile_flags + end subroutine get_release_compile_flags -subroutine get_debug_compile_flags(id, flags) + subroutine get_debug_compile_flags(id, flags) integer(compiler_enum), intent(in) :: id character(len=:), allocatable, intent(out) :: flags - select case(id) + select case (id) case default - flags = "" - case(id_caf) - flags = & - flag_gnu_warn//& - flag_gnu_pic//& - flag_gnu_limit//& - flag_gnu_debug//& - flag_gnu_check//& - flag_gnu_backtrace - case(id_gcc) - flags = & - flag_gnu_warn//& - flag_gnu_pic//& - flag_gnu_limit//& - flag_gnu_debug//& - flag_gnu_check//& - flag_gnu_backtrace//& - flag_gnu_coarray - case(id_f95) - flags = & - flag_gnu_warn//& - flag_gnu_pic//& - flag_gnu_limit//& - flag_gnu_debug//& - flag_gnu_check//& - ' -Wno-maybe-uninitialized -Wno-uninitialized'//& - flag_gnu_backtrace - case(id_nvhpc) - flags = & - flag_pgi_warn//& - flag_pgi_backslash//& - flag_pgi_check//& - flag_pgi_traceback - case(id_ibmxl) - flags = & - flag_ibmxl_backslash - case(id_intel_classic_nix) - flags = & - flag_intel_warn//& - flag_intel_check//& - flag_intel_limit//& - flag_intel_debug//& - flag_intel_byterecl//& - flag_intel_backtrace - case(id_intel_classic_mac) - flags = & - flag_intel_warn//& - flag_intel_check//& - flag_intel_limit//& - flag_intel_debug//& - flag_intel_byterecl//& - flag_intel_backtrace - case(id_intel_classic_windows) - flags = & - flag_intel_warn_win//& - flag_intel_check_win//& - flag_intel_limit_win//& - flag_intel_debug_win//& - flag_intel_byterecl_win//& - flag_intel_backtrace_win - case(id_intel_llvm_nix) - flags = & - flag_intel_warn//& - flag_intel_check//& - flag_intel_limit//& - flag_intel_debug//& - flag_intel_byterecl//& - flag_intel_backtrace - case(id_intel_llvm_windows) - flags = & - flag_intel_warn_win//& - flag_intel_check_win//& - flag_intel_limit_win//& - flag_intel_debug_win//& - flag_intel_byterecl_win - case(id_nag) - flags = & - flag_nag_debug//& - flag_nag_check//& - flag_nag_backtrace//& - flag_nag_coarray//& - flag_nag_pic - - case(id_lfortran) - flags = "" + flags = "" + case (id_caf) + flags = & + flag_gnu_warn// & + flag_gnu_pic// & + flag_gnu_limit// & + flag_gnu_debug// & + flag_gnu_check// & + flag_gnu_backtrace + case (id_gcc) + flags = & + flag_gnu_warn// & + flag_gnu_pic// & + flag_gnu_limit// & + flag_gnu_debug// & + flag_gnu_check// & + flag_gnu_backtrace// & + flag_gnu_coarray + case (id_f95) + flags = & + flag_gnu_warn// & + flag_gnu_pic// & + flag_gnu_limit// & + flag_gnu_debug// & + flag_gnu_check// & + ' -Wno-maybe-uninitialized -Wno-uninitialized'// & + flag_gnu_backtrace + case (id_nvhpc) + flags = & + flag_pgi_warn// & + flag_pgi_backslash// & + flag_pgi_check// & + flag_pgi_traceback + case (id_ibmxl) + flags = & + flag_ibmxl_backslash + case (id_intel_classic_nix) + flags = & + flag_intel_warn// & + flag_intel_check// & + flag_intel_limit// & + flag_intel_debug// & + flag_intel_byterecl// & + flag_intel_backtrace + case (id_intel_classic_mac) + flags = & + flag_intel_warn// & + flag_intel_check// & + flag_intel_limit// & + flag_intel_debug// & + flag_intel_byterecl// & + flag_intel_backtrace + case (id_intel_classic_windows) + flags = & + flag_intel_warn_win// & + flag_intel_check_win// & + flag_intel_limit_win// & + flag_intel_debug_win// & + flag_intel_byterecl_win// & + flag_intel_backtrace_win + case (id_intel_llvm_nix) + flags = & + flag_intel_warn// & + flag_intel_check// & + flag_intel_limit// & + flag_intel_debug// & + flag_intel_byterecl// & + flag_intel_backtrace + case (id_intel_llvm_windows) + flags = & + flag_intel_warn_win// & + flag_intel_check_win// & + flag_intel_limit_win// & + flag_intel_debug_win// & + flag_intel_byterecl_win + case (id_nag) + flags = & + flag_nag_debug// & + flag_nag_check// & + flag_nag_backtrace// & + flag_nag_coarray// & + flag_nag_pic + + case (id_lfortran) + flags = "" end select -end subroutine get_debug_compile_flags + end subroutine get_debug_compile_flags -pure subroutine set_cpp_preprocessor_flags(id, flags) + pure subroutine set_cpp_preprocessor_flags(id, flags) integer(compiler_enum), intent(in) :: id character(len=:), allocatable, intent(inout) :: flags character(len=:), allocatable :: flag_cpp_preprocessor !> Modify the flag_cpp_preprocessor on the basis of the compiler. - select case(id) + select case (id) case default - flag_cpp_preprocessor = "" - case(id_caf, id_gcc, id_f95, id_nvhpc) - flag_cpp_preprocessor = "-cpp" - case(id_intel_classic_windows, id_intel_llvm_windows) - flag_cpp_preprocessor = "/fpp" - case(id_intel_classic_nix, id_intel_classic_mac, id_intel_llvm_nix, id_nag) - flag_cpp_preprocessor = "-fpp" - case(id_lfortran) - flag_cpp_preprocessor = "--cpp" + flag_cpp_preprocessor = "" + case (id_caf, id_gcc, id_f95, id_nvhpc) + flag_cpp_preprocessor = "-cpp" + case (id_intel_classic_windows, id_intel_llvm_windows) + flag_cpp_preprocessor = "/fpp" + case (id_intel_classic_nix, id_intel_classic_mac, id_intel_llvm_nix, id_nag) + flag_cpp_preprocessor = "-fpp" + case (id_lfortran) + flag_cpp_preprocessor = "--cpp" end select - flags = flag_cpp_preprocessor// flags + flags = flag_cpp_preprocessor//flags -end subroutine set_cpp_preprocessor_flags + end subroutine set_cpp_preprocessor_flags -!> This function will parse and read the macros list and +!> This function will parse and read the macros list and !> return them as defined flags. -function get_macros(id, macros_list, version) result(macros) + function get_macros(id, macros_list, version) result(macros) integer(compiler_enum), intent(in) :: id character(len=:), allocatable, intent(in) :: version type(string_t), allocatable, intent(in) :: macros_list(:) @@ -427,189 +421,186 @@ function get_macros(id, macros_list, version) result(macros) character(len=:), allocatable :: macros character(len=:), allocatable :: macro_definition_symbol character(:), allocatable :: valued_macros(:) - integer :: i - if (.not.allocated(macros_list)) then - macros = "" - return + if (.not. allocated(macros_list)) then + macros = "" + return end if !> Set macro defintion symbol on the basis of compiler used - select case(id) + select case (id) case default - macro_definition_symbol = " -D" + macro_definition_symbol = " -D" case (id_intel_classic_windows, id_intel_llvm_windows) - macro_definition_symbol = " /D" + macro_definition_symbol = " /D" end select !> Check if macros are not allocated. - if (.not.allocated(macros)) then - macros="" + if (.not. allocated(macros)) then + macros = "" end if do i = 1, size(macros_list) - - !> Split the macro name and value. - call split(macros_list(i)%s, valued_macros, delimiters="=") - - if (size(valued_macros) > 1) then - !> Check if the value of macro starts with '{' character. - if (str_begins_with_str(trim(valued_macros(size(valued_macros))), "{")) then - - !> Check if the value of macro ends with '}' character. - if (str_ends_with(trim(valued_macros(size(valued_macros))), "}")) then - - !> Check if the string contains "version" as substring. - if (index(valued_macros(size(valued_macros)), "version") /= 0) then - - !> These conditions are placed in order to ensure proper spacing between the macros. - macros = macros//macro_definition_symbol//trim(valued_macros(1))//'='//version - cycle - end if - end if - end if + + !> Split the macro name and value. + call split(macros_list(i)%s, valued_macros, delimiters="=") + + if (size(valued_macros) > 1) then + !> Check if the value of macro starts with '{' character. + if (str_begins_with_str(trim(valued_macros(size(valued_macros))), "{")) then + + !> Check if the value of macro ends with '}' character. + if (str_ends_with(trim(valued_macros(size(valued_macros))), "}")) then + + !> Check if the string contains "version" as substring. + if (index(valued_macros(size(valued_macros)), "version") /= 0) then + + !> These conditions are placed in order to ensure proper spacing between the macros. + macros = macros//macro_definition_symbol//trim(valued_macros(1))//'='//version + cycle + end if + end if end if - - macros = macros//macro_definition_symbol//macros_list(i)%s + end if + + macros = macros//macro_definition_symbol//macros_list(i)%s end do -end function get_macros + end function get_macros -function get_include_flag(self, path) result(flags) + function get_include_flag(self, path) result(flags) class(compiler_t), intent(in) :: self character(len=*), intent(in) :: path character(len=:), allocatable :: flags - select case(self%id) + select case (self%id) case default - flags = "-I "//path + flags = "-I "//path - case(id_caf, id_gcc, id_f95, id_cray, id_nvhpc, id_pgi, & + case (id_caf, id_gcc, id_f95, id_cray, id_nvhpc, id_pgi, & & id_flang, id_flang_new, id_f18, & & id_intel_classic_nix, id_intel_classic_mac, & & id_intel_llvm_nix, id_lahey, id_nag, id_ibmxl, & & id_lfortran) - flags = "-I "//path + flags = "-I "//path - case(id_intel_classic_windows, id_intel_llvm_windows) - flags = "/I"//path + case (id_intel_classic_windows, id_intel_llvm_windows) + flags = "/I"//path end select -end function get_include_flag + end function get_include_flag -function get_module_flag(self, path) result(flags) + function get_module_flag(self, path) result(flags) class(compiler_t), intent(in) :: self character(len=*), intent(in) :: path character(len=:), allocatable :: flags - select case(self%id) + select case (self%id) case default - flags = "-module "//path + flags = "-module "//path - case(id_caf, id_gcc, id_f95, id_cray, id_lfortran) - flags = "-J "//path + case (id_caf, id_gcc, id_f95, id_cray, id_lfortran) + flags = "-J "//path - case(id_nvhpc, id_pgi, id_flang) - flags = "-module "//path + case (id_nvhpc, id_pgi, id_flang) + flags = "-module "//path - case(id_flang_new, id_f18) - flags = "-module-dir "//path + case (id_flang_new, id_f18) + flags = "-module-dir "//path - case(id_intel_classic_nix, id_intel_classic_mac, & + case (id_intel_classic_nix, id_intel_classic_mac, & & id_intel_llvm_nix) - flags = "-module "//path + flags = "-module "//path - case(id_intel_classic_windows, id_intel_llvm_windows) - flags = "/module:"//path + case (id_intel_classic_windows, id_intel_llvm_windows) + flags = "/module:"//path - case(id_lahey) - flags = "-M "//path + case (id_lahey) + flags = "-M "//path - case(id_nag) - flags = "-mdir "//path + case (id_nag) + flags = "-mdir "//path - case(id_ibmxl) - flags = "-qmoddir "//path + case (id_ibmxl) + flags = "-qmoddir "//path end select -end function get_module_flag - + end function get_module_flag -subroutine get_default_c_compiler(f_compiler, c_compiler) + subroutine get_default_c_compiler(f_compiler, c_compiler) character(len=*), intent(in) :: f_compiler character(len=:), allocatable, intent(out) :: c_compiler integer(compiler_enum) :: id id = get_compiler_id(f_compiler) - select case(id) + select case (id) - case(id_intel_classic_nix, id_intel_classic_mac, id_intel_classic_windows) - c_compiler = 'icc' + case (id_intel_classic_nix, id_intel_classic_mac, id_intel_classic_windows) + c_compiler = 'icc' - case(id_intel_llvm_nix,id_intel_llvm_windows) - c_compiler = 'icx' + case (id_intel_llvm_nix, id_intel_llvm_windows) + c_compiler = 'icx' - case(id_flang, id_flang_new, id_f18) - c_compiler='clang' + case (id_flang, id_flang_new, id_f18) + c_compiler = 'clang' - case(id_ibmxl) - c_compiler='xlc' + case (id_ibmxl) + c_compiler = 'xlc' - case(id_lfortran) - c_compiler = 'cc' + case (id_lfortran) + c_compiler = 'cc' - case(id_gcc) - c_compiler = 'gcc' + case (id_gcc) + c_compiler = 'gcc' case default - ! Fall-back to using Fortran compiler - c_compiler = f_compiler + ! Fall-back to using Fortran compiler + c_compiler = f_compiler end select -end subroutine get_default_c_compiler + end subroutine get_default_c_compiler !> Get C++ Compiler. -subroutine get_default_cxx_compiler(f_compiler, cxx_compiler) + subroutine get_default_cxx_compiler(f_compiler, cxx_compiler) character(len=*), intent(in) :: f_compiler character(len=:), allocatable, intent(out) :: cxx_compiler integer(compiler_enum) :: id id = get_compiler_id(f_compiler) - select case(id) + select case (id) - case(id_intel_classic_nix, id_intel_classic_mac, id_intel_classic_windows) - cxx_compiler = 'icpc' + case (id_intel_classic_nix, id_intel_classic_mac, id_intel_classic_windows) + cxx_compiler = 'icpc' - case(id_intel_llvm_nix,id_intel_llvm_windows) - cxx_compiler = 'icpx' + case (id_intel_llvm_nix, id_intel_llvm_windows) + cxx_compiler = 'icpx' - case(id_flang, id_flang_new, id_f18) - cxx_compiler='clang++' + case (id_flang, id_flang_new, id_f18) + cxx_compiler = 'clang++' - case(id_ibmxl) - cxx_compiler='xlc++' + case (id_ibmxl) + cxx_compiler = 'xlc++' - case(id_lfortran) - cxx_compiler = 'cc' + case (id_lfortran) + cxx_compiler = 'cc' - case(id_gcc) - cxx_compiler = 'g++' + case (id_gcc) + cxx_compiler = 'g++' case default - ! Fall-back to using Fortran compiler - cxx_compiler = f_compiler + ! Fall-back to using Fortran compiler + cxx_compiler = f_compiler end select -end subroutine get_default_cxx_compiler - + end subroutine get_default_cxx_compiler -function get_compiler_id(compiler) result(id) + function get_compiler_id(compiler) result(id) character(len=*), intent(in) :: compiler integer(kind=compiler_enum) :: id @@ -620,150 +611,149 @@ function get_compiler_id(compiler) result(id) if (check_compiler(compiler, "mpifort") & & .or. check_compiler(compiler, "mpif90") & & .or. check_compiler(compiler, "mpif77")) then - output = get_temp_filename() - call run(compiler//" -show > "//output//" 2>&1", & - & echo=.false., exitstat=stat) - if (stat == 0) then - open(file=output, newunit=io, iostat=stat) - if (stat == 0) call getline(io, full_command, stat) - close(io, iostat=stat) - - ! If we get a command from the wrapper, we will try to identify it - call split(full_command, full_command_parts, delimiters=' ') - if(size(full_command_parts) > 0)then - command = trim(full_command_parts(1)) - endif - if (allocated(command)) then - id = get_id(command) - if (id /= id_unknown) return - end if + output = get_temp_filename() + call run(compiler//" -show > "//output//" 2>&1", & + & echo=.false., exitstat=stat) + if (stat == 0) then + open (file=output, newunit=io, iostat=stat) + if (stat == 0) call getline(io, full_command, stat) + close (io, iostat=stat) + + ! If we get a command from the wrapper, we will try to identify it + call split(full_command, full_command_parts, delimiters=' ') + if (size(full_command_parts) > 0) then + command = trim(full_command_parts(1)) + end if + if (allocated(command)) then + id = get_id(command) + if (id /= id_unknown) return end if + end if end if id = get_id(compiler) -end function get_compiler_id + end function get_compiler_id -function get_id(compiler) result(id) + function get_id(compiler) result(id) character(len=*), intent(in) :: compiler integer(kind=compiler_enum) :: id integer :: stat if (check_compiler(compiler, "gfortran")) then - id = id_gcc - return + id = id_gcc + return end if if (check_compiler(compiler, "f95")) then - id = id_f95 - return + id = id_f95 + return end if if (check_compiler(compiler, "caf")) then - id = id_caf - return + id = id_caf + return end if if (check_compiler(compiler, "ifort")) then - select case (get_os_type()) - case default - id = id_intel_classic_nix - case (OS_MACOS) - id = id_intel_classic_mac - case (OS_WINDOWS, OS_CYGWIN) - id = id_intel_classic_windows - end select - return + select case (get_os_type()) + case default + id = id_intel_classic_nix + case (OS_MACOS) + id = id_intel_classic_mac + case (OS_WINDOWS, OS_CYGWIN) + id = id_intel_classic_windows + end select + return end if if (check_compiler(compiler, "ifx")) then - select case (get_os_type()) - case default - id = id_intel_llvm_nix - case (OS_WINDOWS, OS_CYGWIN) - id = id_intel_llvm_windows - end select - return + select case (get_os_type()) + case default + id = id_intel_llvm_nix + case (OS_WINDOWS, OS_CYGWIN) + id = id_intel_llvm_windows + end select + return end if if (check_compiler(compiler, "nvfortran")) then - id = id_nvhpc - return + id = id_nvhpc + return end if if (check_compiler(compiler, "pgfortran") & & .or. check_compiler(compiler, "pgf90") & & .or. check_compiler(compiler, "pgf95")) then - id = id_pgi - return + id = id_pgi + return end if if (check_compiler(compiler, "nagfor")) then - id = id_nag - return + id = id_nag + return end if if (check_compiler(compiler, "flang-new")) then - id = id_flang_new - return + id = id_flang_new + return end if if (check_compiler(compiler, "f18")) then - id = id_f18 - return + id = id_f18 + return end if if (check_compiler(compiler, "flang")) then - id = id_flang - return + id = id_flang + return end if if (check_compiler(compiler, "xlf90")) then - id = id_ibmxl - return + id = id_ibmxl + return end if if (check_compiler(compiler, "crayftn")) then - id = id_cray - return + id = id_cray + return end if if (check_compiler(compiler, "lfc")) then - id = id_lahey - return + id = id_lahey + return end if if (check_compiler(compiler, "lfortran")) then - id = id_lfortran - return + id = id_lfortran + return end if id = id_unknown -end function get_id + end function get_id -function check_compiler(compiler, expected) result(match) + function check_compiler(compiler, expected) result(match) character(len=*), intent(in) :: compiler character(len=*), intent(in) :: expected logical :: match match = compiler == expected if (.not. match) then - match = index(basename(compiler), expected) > 0 + match = index(basename(compiler), expected) > 0 end if -end function check_compiler - + end function check_compiler -pure function is_unknown(self) + pure function is_unknown(self) class(compiler_t), intent(in) :: self logical :: is_unknown is_unknown = self%id == id_unknown -end function is_unknown + end function is_unknown !> !> Enumerate libraries, based on compiler and platform !> -function enumerate_libraries(self, prefix, libs) result(r) + function enumerate_libraries(self, prefix, libs) result(r) class(compiler_t), intent(in) :: self character(len=*), intent(in) :: prefix type(string_t), intent(in) :: libs(:) @@ -771,15 +761,14 @@ function enumerate_libraries(self, prefix, libs) result(r) if (self%id == id_intel_classic_windows .or. & self%id == id_intel_llvm_windows) then - r = prefix // " " // string_cat(libs,".lib ")//".lib" + r = prefix//" "//string_cat(libs, ".lib ")//".lib" else - r = prefix // " -l" // string_cat(libs," -l") + r = prefix//" -l"//string_cat(libs, " -l") end if -end function enumerate_libraries - + end function enumerate_libraries !> Create new compiler instance -subroutine new_compiler(self, fc, cc, cxx, echo, verbose) + subroutine new_compiler(self, fc, cc, cxx, echo, verbose) !> New instance of the compiler type(compiler_t), intent(out) :: self !> Fortran compiler name or path @@ -794,7 +783,7 @@ subroutine new_compiler(self, fc, cc, cxx, echo, verbose) logical, intent(in) :: verbose self%id = get_compiler_id(fc) - + self%echo = echo self%verbose = verbose self%fc = fc @@ -809,11 +798,10 @@ subroutine new_compiler(self, fc, cc, cxx, echo, verbose) else call get_default_cxx_compiler(self%fc, self%cxx) end if -end subroutine new_compiler - + end subroutine new_compiler !> Create new archiver instance -subroutine new_archiver(self, ar, echo, verbose) + subroutine new_archiver(self, ar, echo, verbose) !> New instance of the archiver type(archiver_t), intent(out) :: self !> User provided archiver command @@ -857,11 +845,10 @@ subroutine new_archiver(self, ar, echo, verbose) self%use_response_file = os_type == OS_WINDOWS self%echo = echo self%verbose = verbose -end subroutine new_archiver - + 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) !> Instance of the compiler object class(compiler_t), intent(in) :: self !> Source file input @@ -875,13 +862,12 @@ subroutine compile_fortran(self, input, output, args, log_file, stat) !> Status flag integer, intent(out) :: stat - call run(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) -end subroutine compile_fortran - + 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) !> Instance of the compiler object class(compiler_t), intent(in) :: self !> Source file input @@ -895,12 +881,12 @@ subroutine compile_c(self, input, output, args, log_file, stat) !> Status flag integer, intent(out) :: stat - call run(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) -end subroutine compile_c + 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) !> Instance of the compiler object class(compiler_t), intent(in) :: self !> Source file input @@ -914,12 +900,12 @@ subroutine compile_cpp(self, input, output, args, log_file, stat) !> Status flag integer, intent(out) :: stat - call run(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) -end subroutine compile_cpp + end subroutine compile_cpp !> Link an executable -subroutine link(self, output, args, log_file, stat) + subroutine link(self, output, args, log_file, stat) !> Instance of the compiler object class(compiler_t), intent(in) :: self !> Output file of object @@ -931,16 +917,15 @@ subroutine link(self, output, args, log_file, stat) !> Status flag integer, intent(out) :: stat - call run(self%fc // " " // args // " -o " // output, echo=self%echo, & + call run(self%fc//" "//args//" -o "//output, echo=self%echo, & & verbose=self%verbose, redirect=log_file, exitstat=stat) -end subroutine link - + end subroutine link !> Create an archive !> @todo An OMP critical section is added for Windows OS, !> which may be related to a bug in Mingw64-openmp and is expected to be resolved in the future, !> see issue #707 and #708. -subroutine make_archive(self, output, args, log_file, stat) + subroutine make_archive(self, output, args, log_file, stat) !> Instance of the archiver object class(archiver_t), intent(in) :: self !> Name of the archive to generate @@ -953,57 +938,53 @@ subroutine make_archive(self, output, args, log_file, stat) integer, intent(out) :: stat if (self%use_response_file) then - !$omp critical - call write_response_file(output//".resp" , args) - call run(self%ar // output // " @" // output//".resp", echo=self%echo, & - & verbose=self%verbose, redirect=log_file, exitstat=stat) - call delete_file(output//".resp") - !$omp end critical + !$omp critical + call write_response_file(output//".resp", args) + call run(self%ar//output//" @"//output//".resp", echo=self%echo, & + & verbose=self%verbose, redirect=log_file, exitstat=stat) + call delete_file(output//".resp") + !$omp end critical else - call run(self%ar // output // " " // string_cat(args, " "), & - & echo=self%echo, verbose=self%verbose, redirect=log_file, exitstat=stat) + call run(self%ar//output//" "//string_cat(args, " "), & + & echo=self%echo, verbose=self%verbose, redirect=log_file, exitstat=stat) end if -end subroutine make_archive - + end subroutine make_archive !> Response files allow to read command line options from files. !> Whitespace is used to separate the arguments, we will use newlines !> as separator to create readable response files which can be inspected !> in case of errors. -subroutine write_response_file(name, argv) + subroutine write_response_file(name, argv) character(len=*), intent(in) :: name type(string_t), intent(in) :: argv(:) integer :: iarg, io - open(file=name, newunit=io) + open (file=name, newunit=io) do iarg = 1, size(argv) - write(io, '(a)') unix_path(argv(iarg)%s) + write (io, '(a)') unix_path(argv(iarg)%s) end do - close(io) -end subroutine write_response_file - + close (io) + end subroutine write_response_file !> String representation of a compiler object -pure function debug_compiler(self) result(repr) + pure function debug_compiler(self) result(repr) !> Instance of the compiler object type(compiler_t), intent(in) :: self !> Representation as string character(len=:), allocatable :: repr repr = 'fc="'//self%fc//'", cc="'//self%cc//'"' -end function debug_compiler - + end function debug_compiler !> String representation of an archiver object -pure function debug_archiver(self) result(repr) + pure function debug_archiver(self) result(repr) !> Instance of the archiver object type(archiver_t), intent(in) :: self !> Representation as string character(len=:), allocatable :: repr repr = 'ar="'//self%ar//'"' -end function debug_archiver - + end function debug_archiver end module fpm_compiler diff --git a/src/fpm_environment.f90 b/src/fpm_environment.f90 index b797d74997..9f627e3c4d 100644 --- a/src/fpm_environment.f90 +++ b/src/fpm_environment.f90 @@ -3,29 +3,29 @@ !! * [get_os_type] -- Determine the OS type !! * [get_env] -- return the value of an environment variable module fpm_environment - use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, & - & stdout=>output_unit, & - & stderr=>error_unit - use fpm_error, only : fpm_stop - implicit none - private - public :: get_os_type - public :: os_is_unix - public :: get_env - public :: get_command_arguments_quoted - public :: separator + use, intrinsic :: iso_fortran_env, only: stdin => input_unit, & + & stdout => output_unit, & + & stderr => error_unit + use fpm_error, only: fpm_stop + implicit none + private + public :: get_os_type + public :: os_is_unix + public :: get_env + public :: get_command_arguments_quoted + public :: separator - integer, parameter, public :: OS_UNKNOWN = 0 - integer, parameter, public :: OS_LINUX = 1 - integer, parameter, public :: OS_MACOS = 2 - integer, parameter, public :: OS_WINDOWS = 3 - integer, parameter, public :: OS_CYGWIN = 4 - integer, parameter, public :: OS_SOLARIS = 5 - integer, parameter, public :: OS_FREEBSD = 6 - integer, parameter, public :: OS_OPENBSD = 7 + integer, parameter, public :: OS_UNKNOWN = 0 + integer, parameter, public :: OS_LINUX = 1 + integer, parameter, public :: OS_MACOS = 2 + integer, parameter, public :: OS_WINDOWS = 3 + integer, parameter, public :: OS_CYGWIN = 4 + integer, parameter, public :: OS_SOLARIS = 5 + integer, parameter, public :: OS_FREEBSD = 6 + integer, parameter, public :: OS_OPENBSD = 7 contains - !> Determine the OS type - integer function get_os_type() result(r) + !> Determine the OS type + integer function get_os_type() result(r) !! !! Returns one of OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_WINDOWS, OS_CYGWIN, !! OS_SOLARIS, OS_FREEBSD, OS_OPENBSD. @@ -36,199 +36,199 @@ integer function get_os_type() result(r) !! found on specific system types only. !! !! Returns OS_UNKNOWN if the operating system cannot be determined. - character(len=32) :: val - integer :: length, rc - logical :: file_exists - logical, save :: first_run = .true. - integer, save :: ret = OS_UNKNOWN - !omp threadprivate(ret, first_run) + character(len=32) :: val + integer :: length, rc + logical :: file_exists + logical, save :: first_run = .true. + integer, save :: ret = OS_UNKNOWN + !omp threadprivate(ret, first_run) - if (.not. first_run) then - r = ret - return - end if + if (.not. first_run) then + r = ret + return + end if - first_run = .false. - r = OS_UNKNOWN + first_run = .false. + r = OS_UNKNOWN - ! Check environment variable `OSTYPE`. - call get_environment_variable('OSTYPE', val, length, rc) + ! Check environment variable `OSTYPE`. + call get_environment_variable('OSTYPE', val, length, rc) - if (rc == 0 .and. length > 0) then - ! Linux - if (index(val, 'linux') > 0) then - r = OS_LINUX - ret = r - return - end if + if (rc == 0 .and. length > 0) then + ! Linux + if (index(val, 'linux') > 0) then + r = OS_LINUX + ret = r + return + end if - ! macOS - if (index(val, 'darwin') > 0) then - r = OS_MACOS - ret = r - return - end if + ! macOS + if (index(val, 'darwin') > 0) then + r = OS_MACOS + ret = r + return + end if - ! Windows, MSYS, MinGW, Git Bash - if (index(val, 'win') > 0 .or. index(val, 'msys') > 0) then - r = OS_WINDOWS - ret = r - return - end if + ! Windows, MSYS, MinGW, Git Bash + if (index(val, 'win') > 0 .or. index(val, 'msys') > 0) then + r = OS_WINDOWS + ret = r + return + end if - ! Cygwin - if (index(val, 'cygwin') > 0) then - r = OS_CYGWIN - ret = r - return - end if + ! Cygwin + if (index(val, 'cygwin') > 0) then + r = OS_CYGWIN + ret = r + return + end if - ! Solaris, OpenIndiana, ... - if (index(val, 'SunOS') > 0 .or. index(val, 'solaris') > 0) then - r = OS_SOLARIS - ret = r - return - end if + ! Solaris, OpenIndiana, ... + if (index(val, 'SunOS') > 0 .or. index(val, 'solaris') > 0) then + r = OS_SOLARIS + ret = r + return + end if - ! FreeBSD - if (index(val, 'FreeBSD') > 0 .or. index(val, 'freebsd') > 0) then - r = OS_FREEBSD - ret = r - return - end if + ! FreeBSD + if (index(val, 'FreeBSD') > 0 .or. index(val, 'freebsd') > 0) then + r = OS_FREEBSD + ret = r + return + end if - ! OpenBSD - if (index(val, 'OpenBSD') > 0 .or. index(val, 'openbsd') > 0) then - r = OS_OPENBSD - ret = r - return - end if - end if + ! OpenBSD + if (index(val, 'OpenBSD') > 0 .or. index(val, 'openbsd') > 0) then + r = OS_OPENBSD + ret = r + return + end if + end if - ! Check environment variable `OS`. - call get_environment_variable('OS', val, length, rc) + ! Check environment variable `OS`. + call get_environment_variable('OS', val, length, rc) - if (rc == 0 .and. length > 0 .and. index(val, 'Windows_NT') > 0) then - r = OS_WINDOWS - ret = r - return - end if + if (rc == 0 .and. length > 0 .and. index(val, 'Windows_NT') > 0) then + r = OS_WINDOWS + ret = r + return + end if - ! Linux - inquire (file='/etc/os-release', exist=file_exists) + ! Linux + inquire (file='/etc/os-release', exist=file_exists) - if (file_exists) then - r = OS_LINUX - ret = r - return - end if + if (file_exists) then + r = OS_LINUX + ret = r + return + end if - ! macOS - inquire (file='/usr/bin/sw_vers', exist=file_exists) + ! macOS + inquire (file='/usr/bin/sw_vers', exist=file_exists) - if (file_exists) then - r = OS_MACOS - ret = r - return - end if + if (file_exists) then + r = OS_MACOS + ret = r + return + end if - ! FreeBSD - inquire (file='/bin/freebsd-version', exist=file_exists) + ! FreeBSD + inquire (file='/bin/freebsd-version', exist=file_exists) - if (file_exists) then - r = OS_FREEBSD - ret = r - return - end if - end function get_os_type + if (file_exists) then + r = OS_FREEBSD + ret = r + return + end if + end function get_os_type - !> Compare the output of [[get_os_type]] or the optional + !> Compare the output of [[get_os_type]] or the optional !! passed INTEGER value to the value for OS_WINDOWS !! and return .TRUE. if they match and .FALSE. otherwise - logical function os_is_unix(os) result(unix) - integer, intent(in), optional :: os - integer :: build_os - if (present(os)) then - build_os = os - else - build_os = get_os_type() - end if - unix = build_os /= OS_WINDOWS - end function os_is_unix + logical function os_is_unix(os) result(unix) + integer, intent(in), optional :: os + integer :: build_os + if (present(os)) then + build_os = os + else + build_os = get_os_type() + end if + unix = build_os /= OS_WINDOWS + end function os_is_unix - !> get named environment variable value. It it is blank or + !> get named environment variable value. It it is blank or !! not set return the optional default value - function get_env(NAME,DEFAULT) result(VALUE) + function get_env(NAME, DEFAULT) result(VALUE) implicit none !> name of environment variable to get the value of - character(len=*),intent(in) :: NAME + character(len=*), intent(in) :: NAME !> default value to return if the requested value is undefined or blank - character(len=*),intent(in),optional :: DEFAULT + character(len=*), intent(in), optional :: DEFAULT !> the returned value - character(len=:),allocatable :: VALUE + character(len=:), allocatable :: VALUE integer :: howbig integer :: stat integer :: length - ! get length required to hold value - length=0 - if(NAME/='')then - call get_environment_variable(NAME, length=howbig,status=stat,trim_name=.true.) - select case (stat) - case (1) - !*!print *, NAME, " is not defined in the environment. Strange..." - VALUE='' - case (2) - !*!print *, "This processor doesn't support environment variables. Boooh!" - VALUE='' - case default - ! make string to hold value of sufficient size - allocate(character(len=max(howbig,1)) :: VALUE) - ! get value - call get_environment_variable(NAME,VALUE,status=stat,trim_name=.true.) - if(stat/=0)VALUE='' - end select - else - VALUE='' - endif - if(VALUE==''.and.present(DEFAULT))VALUE=DEFAULT - end function get_env + ! get length required to hold value + length = 0 + if (NAME /= '') then + call get_environment_variable(NAME, length=howbig, status=stat, trim_name=.true.) + select case (stat) + case (1) + !*!print *, NAME, " is not defined in the environment. Strange..." + VALUE = '' + case (2) + !*!print *, "This processor doesn't support environment variables. Boooh!" + VALUE = '' + case default + ! make string to hold value of sufficient size + allocate (character(len=max(howbig, 1)) :: VALUE) + ! get value + call get_environment_variable(NAME, VALUE, status=stat, trim_name=.true.) + if (stat /= 0) VALUE = '' + end select + else + VALUE = '' + end if + if (VALUE == '' .and. present(DEFAULT)) VALUE = DEFAULT + end function get_env - function get_command_arguments_quoted() result(args) - character(len=:),allocatable :: args - character(len=:),allocatable :: arg + function get_command_arguments_quoted() result(args) + character(len=:), allocatable :: args + character(len=:), allocatable :: arg character(len=1) :: quote integer :: ilength, istatus, i - ilength=0 - args='' - quote=merge('"',"'",separator()=='\') - do i=2,command_argument_count() ! look at all arguments after subcommand - call get_command_argument(number=i,length=ilength,status=istatus) - if(istatus /= 0) then - write(stderr,'(*(g0,1x))')'*get_command_arguments_stack* error obtaining argument ',i - exit - else - if(allocated(arg))deallocate(arg) - allocate(character(len=ilength) :: arg) - call get_command_argument(number=i,value=arg,length=ilength,status=istatus) - if(istatus /= 0) then - write(stderr,'(*(g0,1x))')'*get_command_arguments_stack* error obtaining argument ',i - exit - elseif(ilength>0)then - if(index(arg//' ','-')/=1)then - args=args//quote//arg//quote//' ' - elseif(index(arg,' ')/=0)then - args=args//quote//arg//quote//' ' - else - args=args//arg//' ' - endif - else - args=args//repeat(quote,2)//' ' - endif - endif - enddo - end function get_command_arguments_quoted + ilength = 0 + args = '' + quote = merge('"', "'", separator() == '\') + do i = 2, command_argument_count() ! look at all arguments after subcommand + call get_command_argument(number=i, length=ilength, status=istatus) + if (istatus /= 0) then + write (stderr, '(*(g0,1x))') '*get_command_arguments_stack* error obtaining argument ', i + exit + else + if (allocated(arg)) deallocate (arg) + allocate (character(len=ilength) :: arg) + call get_command_argument(number=i, value=arg, length=ilength, status=istatus) + if (istatus /= 0) then + write (stderr, '(*(g0,1x))') '*get_command_arguments_stack* error obtaining argument ', i + exit + elseif (ilength > 0) then + if (index(arg//' ', '-') /= 1) then + args = args//quote//arg//quote//' ' + elseif (index(arg, ' ') /= 0) then + args = args//quote//arg//quote//' ' + else + args = args//arg//' ' + end if + else + args = args//repeat(quote, 2)//' ' + end if + end if + end do + end function get_command_arguments_quoted -function separator() result(sep) + function separator() result(sep) !> !!##NAME !! separator(3f) - [M_io:ENVIRONMENT] try to determine pathname directory separator character @@ -263,59 +263,59 @@ function separator() result(sep) !! end program demo_separator ! use the pathname returned as arg0 to determine pathname separator -implicit none -character(len=:),allocatable :: arg0 -integer :: arg0_length -integer :: istat -logical :: existing -character(len=1) :: sep + implicit none + character(len=:), allocatable :: arg0 + integer :: arg0_length + integer :: istat + logical :: existing + character(len=1) :: sep !*ifort_bug*!character(len=1),save :: sep_cache=' ' -character(len=4096) :: name -character(len=:),allocatable :: fname + character(len=4096) :: name + character(len=:), allocatable :: fname - !*ifort_bug*! if(sep_cache/=' ')then ! use cached value. NOTE: A parallel code might theoretically use multiple OS - !*ifort_bug*! sep=sep_cache - !*ifort_bug*! return - !*ifort_bug*! endif + !*ifort_bug*! if(sep_cache/=' ')then ! use cached value. NOTE: A parallel code might theoretically use multiple OS + !*ifort_bug*! sep=sep_cache + !*ifort_bug*! return + !*ifort_bug*! endif - arg0_length=0 - name=' ' - call get_command_argument(0,length=arg0_length,status=istat) - if(allocated(arg0))deallocate(arg0) - allocate(character(len=arg0_length) :: arg0) - call get_command_argument(0,arg0,status=istat) - ! check argument name - if(index(arg0,'\')/=0)then - sep='\' - elseif(index(arg0,'/')/=0)then - sep='/' - else + arg0_length = 0 + name = ' ' + call get_command_argument(0, length=arg0_length, status=istat) + if (allocated(arg0)) deallocate (arg0) + allocate (character(len=arg0_length) :: arg0) + call get_command_argument(0, arg0, status=istat) + ! check argument name + if (index(arg0, '\') /= 0) then + sep = '\' + elseif (index(arg0, '/') /= 0) then + sep = '/' + else ! try name returned by INQUIRE(3f) - existing=.false. - name=' ' - inquire(file=arg0,iostat=istat,exist=existing,name=name) - if(index(name,'\')/=0)then - sep='\' - elseif(index(name,'/')/=0)then - sep='/' + existing = .false. + name = ' ' + inquire (file=arg0, iostat=istat, exist=existing, name=name) + if (index(name, '\') /= 0) then + sep = '\' + elseif (index(name, '/') /= 0) then + sep = '/' else - ! well, try some common syntax and assume in current directory - fname='.\'//arg0 - inquire(file=fname,iostat=istat,exist=existing) - if(existing)then - sep='\' - else - fname='./'//arg0 - inquire(file=fname,iostat=istat,exist=existing) - if(existing)then - sep='/' - else ! check environment variable PATH - sep=merge('\','/',index(get_env('PATH'),'\')/=0) - !*!write(*,*)'unknown system directory path separator' - endif - endif - endif - endif - !*ifort_bug*!sep_cache=sep -end function separator + ! well, try some common syntax and assume in current directory + fname = '.\'//arg0 + inquire (file=fname, iostat=istat, exist=existing) + if (existing) then + sep = '\' + else + fname = './'//arg0 + inquire (file=fname, iostat=istat, exist=existing) + if (existing) then + sep = '/' + else ! check environment variable PATH + sep = merge('\', '/', index(get_env('PATH'), '\') /= 0) + !*!write(*,*)'unknown system directory path separator' + end if + end if + end if + end if + !*ifort_bug*!sep_cache=sep + end function separator end module fpm_environment diff --git a/src/fpm_filesystem.F90 b/src/fpm_filesystem.F90 index e60b2df1f7..28bd789ae0 100644 --- a/src/fpm_filesystem.F90 +++ b/src/fpm_filesystem.F90 @@ -1,87 +1,85 @@ !> This module contains general routines for interacting with the file system !! module fpm_filesystem - use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, stderr=>error_unit - use fpm_environment, only: get_os_type, & - OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_WINDOWS, & - OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD - use fpm_environment, only: separator, get_env, os_is_unix - use fpm_strings, only: f_string, replace, string_t, split, notabs, str_begins_with_str - use iso_c_binding, only: c_char, c_ptr, c_int, c_null_char, c_associated, c_f_pointer - use fpm_error, only : fpm_stop - implicit none - private - public :: basename, canon_path, dirname, is_dir, join_path, number_of_rows, list_files, env_variable, & + use, intrinsic :: iso_fortran_env, only: stdin => input_unit, stdout => output_unit, stderr => error_unit + use fpm_environment, only: get_os_type, & + OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_WINDOWS, & + OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD + use fpm_environment, only: separator, get_env, os_is_unix + use fpm_strings, only: f_string, replace, string_t, split, notabs, str_begins_with_str + use iso_c_binding, only: c_char, c_ptr, c_int, c_null_char, c_associated, c_f_pointer + use fpm_error, only: fpm_stop + implicit none + private + public :: basename, canon_path, dirname, is_dir, join_path, number_of_rows, list_files, env_variable, & mkdir, exists, get_temp_filename, windows_path, unix_path, getline, delete_file - public :: fileopen, fileclose, filewrite, warnwrite, parent_dir - public :: is_hidden_file - public :: read_lines, read_lines_expanded - public :: which, run, LINE_BUFFER_LEN - public :: os_delete_dir + public :: fileopen, fileclose, filewrite, warnwrite, parent_dir + public :: is_hidden_file + public :: read_lines, read_lines_expanded + public :: which, run, LINE_BUFFER_LEN + public :: os_delete_dir - integer, parameter :: LINE_BUFFER_LEN = 1000 + integer, parameter :: LINE_BUFFER_LEN = 1000 #ifndef FPM_BOOTSTRAP - interface - function c_opendir(dir) result(r) bind(c, name="c_opendir") - import c_char, c_ptr - character(kind=c_char), intent(in) :: dir(*) - type(c_ptr) :: r - end function c_opendir - - function c_readdir(dir) result(r) bind(c, name="c_readdir") - import c_ptr - type(c_ptr), intent(in), value :: dir - type(c_ptr) :: r - end function c_readdir - - function c_closedir(dir) result(r) bind(c, name="closedir") - import c_ptr, c_int - type(c_ptr), intent(in), value :: dir - integer(kind=c_int) :: r - end function c_closedir - - function c_get_d_name(dir) result(r) bind(c, name="get_d_name") - import c_ptr - type(c_ptr), intent(in), value :: dir - type(c_ptr) :: r - end function c_get_d_name - - function c_is_dir(path) result(r) bind(c, name="c_is_dir") - import c_char, c_int - character(kind=c_char), intent(in) :: path(*) - integer(kind=c_int) :: r - end function c_is_dir - end interface + interface + function c_opendir(dir) result(r) bind(c, name="c_opendir") + import c_char, c_ptr + character(kind=c_char), intent(in) :: dir(*) + type(c_ptr) :: r + end function c_opendir + + function c_readdir(dir) result(r) bind(c, name="c_readdir") + import c_ptr + type(c_ptr), intent(in), value :: dir + type(c_ptr) :: r + end function c_readdir + + function c_closedir(dir) result(r) bind(c, name="closedir") + import c_ptr, c_int + type(c_ptr), intent(in), value :: dir + integer(kind=c_int) :: r + end function c_closedir + + function c_get_d_name(dir) result(r) bind(c, name="get_d_name") + import c_ptr + type(c_ptr), intent(in), value :: dir + type(c_ptr) :: r + end function c_get_d_name + + function c_is_dir(path) result(r) bind(c, name="c_is_dir") + import c_char, c_int + character(kind=c_char), intent(in) :: path(*) + integer(kind=c_int) :: r + end function c_is_dir + end interface #endif contains - !> return value of environment variable -subroutine env_variable(var, name) - character(len=:), allocatable, intent(out) :: var - character(len=*), intent(in) :: name - integer :: length, stat + subroutine env_variable(var, name) + character(len=:), allocatable, intent(out) :: var + character(len=*), intent(in) :: name + integer :: length, stat - call get_environment_variable(name, length=length, status=stat) - if (stat /= 0) return + call get_environment_variable(name, length=length, status=stat) + if (stat /= 0) return - allocate(character(len=length) :: var) + allocate (character(len=length) :: var) - if (length > 0) then + if (length > 0) then call get_environment_variable(name, var, status=stat) if (stat /= 0) then - deallocate(var) - return + deallocate (var) + return end if - end if - -end subroutine env_variable + end if + end subroutine env_variable !> Extract filename from path with/without suffix -function basename(path,suffix) result (base) + function basename(path, suffix) result(base) character(*), intent(In) :: path logical, intent(in), optional :: suffix @@ -90,27 +88,26 @@ function basename(path,suffix) result (base) character(:), allocatable :: file_parts(:) logical :: with_suffix - if (.not.present(suffix)) then - with_suffix = .true. + if (.not. present(suffix)) then + with_suffix = .true. else - with_suffix = suffix + with_suffix = suffix end if - call split(path,file_parts,delimiters='\/') - if(size(file_parts)>0)then - base = trim(file_parts(size(file_parts))) + call split(path, file_parts, delimiters='\/') + if (size(file_parts) > 0) then + base = trim(file_parts(size(file_parts))) else - base = '' - endif - if(.not.with_suffix)then - call split(base,file_parts,delimiters='.') - if(size(file_parts)>=2)then - base = trim(file_parts(size(file_parts)-1)) - endif - endif - -end function basename + base = '' + end if + if (.not. with_suffix) then + call split(base, file_parts, delimiters='.') + if (size(file_parts) >= 2) then + base = trim(file_parts(size(file_parts) - 1)) + end if + end if + end function basename !> Canonicalize path for comparison !! * Handles path string redundancies @@ -119,7 +116,7 @@ end function basename !! To be replaced by realpath/_fullname in stdlib_os !! !! FIXME: Lot's of ugly hacks following here -function canon_path(path) + function canon_path(path) character(len=*), intent(in) :: path character(len=:), allocatable :: canon_path character(len=:), allocatable :: nixpath @@ -134,135 +131,133 @@ function canon_path(path) iend = 0 absolute = nixpath(1:1) == "/" if (absolute) then - canon_path = "/" + canon_path = "/" else - canon_path = "" - end if - - do while(iend < len(nixpath)) - call next(nixpath, istart, iend, is_path) - if (is_path) then - select case(nixpath(istart:iend)) - case(".", "") ! always drop empty paths - case("..") - if (nn > 0) then - last = scan(canon_path(:len(canon_path)-1), "/", back=.true.) - canon_path = canon_path(:last) - nn = nn - 1 - else - if (.not. absolute) then - canon_path = canon_path // nixpath(istart:iend) // "/" - end if - end if - case default - nn = nn + 1 - canon_path = canon_path // nixpath(istart:iend) // "/" - end select - end if + canon_path = "" + end if + + do while (iend < len(nixpath)) + call next(nixpath, istart, iend, is_path) + if (is_path) then + select case (nixpath(istart:iend)) + case (".", "") ! always drop empty paths + case ("..") + if (nn > 0) then + last = scan(canon_path(:len(canon_path) - 1), "/", back=.true.) + canon_path = canon_path(:last) + nn = nn - 1 + else + if (.not. absolute) then + canon_path = canon_path//nixpath(istart:iend)//"/" + end if + end if + case default + nn = nn + 1 + canon_path = canon_path//nixpath(istart:iend)//"/" + end select + end if end do if (len(canon_path) == 0) canon_path = "." if (len(canon_path) > 1 .and. canon_path(len(canon_path):) == "/") then - canon_path = canon_path(:len(canon_path)-1) + canon_path = canon_path(:len(canon_path) - 1) end if -contains + contains subroutine next(string, istart, iend, is_path) - character(len=*), intent(in) :: string - integer, intent(inout) :: istart - integer, intent(inout) :: iend - logical, intent(inout) :: is_path + character(len=*), intent(in) :: string + integer, intent(inout) :: istart + integer, intent(inout) :: iend + logical, intent(inout) :: is_path - integer :: ii, nn - character :: tok + integer :: ii, nn + character :: tok - nn = len(string) + nn = len(string) - if (iend >= nn) then - istart = nn - iend = nn - return - end if - - ii = min(iend + 1, nn) - tok = string(ii:ii) + if (iend >= nn) then + istart = nn + iend = nn + return + end if - is_path = tok /= '/' + ii = min(iend + 1, nn) + tok = string(ii:ii) - if (.not.is_path) then - is_path = .false. - istart = ii - iend = ii - return - end if + is_path = tok /= '/' + if (.not. is_path) then + is_path = .false. istart = ii - do ii = min(iend + 1, nn), nn - tok = string(ii:ii) - select case(tok) - case('/') - exit - case default - iend = ii - cycle - end select - end do + iend = ii + return + end if - end subroutine next -end function canon_path + istart = ii + do ii = min(iend + 1, nn), nn + tok = string(ii:ii) + select case (tok) + case ('/') + exit + case default + iend = ii + cycle + end select + end do + end subroutine next + end function canon_path !> Extract dirname from path -function dirname(path) result (dir) + function dirname(path) result(dir) character(*), intent(in) :: path character(:), allocatable :: dir - dir = path(1:scan(path,'/\',back=.true.)) + dir = path(1:scan(path, '/\', back=.true.)) -end function dirname + end function dirname !> Extract dirname from path -function parent_dir(path) result (dir) + function parent_dir(path) result(dir) character(*), intent(in) :: path character(:), allocatable :: dir - dir = path(1:scan(path,'/\',back=.true.)-1) - -end function parent_dir + dir = path(1:scan(path, '/\', back=.true.) - 1) + end function parent_dir !> test if a name matches an existing directory path -logical function is_dir(dir) + 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, OS_OPENBSD) - call execute_command_line("test -d " // dir , exitstat=stat) + 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) + 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 + end function is_dir !> test if a file is hidden -logical function is_hidden_file(file_basename) result(r) + logical function is_hidden_file(file_basename) result(r) character(*), intent(in) :: file_basename if (len(file_basename) <= 2) then - r = .false. + r = .false. else - r = str_begins_with_str(file_basename, '.') + r = str_begins_with_str(file_basename, '.') end if -end function is_hidden_file + end function is_hidden_file !> Construct path by joining strings with os file separator -function join_path(a1,a2,a3,a4,a5) result(path) + function join_path(a1, a2, a3, a4, a5) result(path) character(len=*), intent(in) :: a1, a2 character(len=*), intent(in), optional :: a3, a4, a5 @@ -273,62 +268,61 @@ function join_path(a1,a2,a3,a4,a5) result(path) !$omp threadprivate(has_cache, cache) if (has_cache) then - filesep = cache + filesep = cache else - select case (get_os_type()) - case default - filesep = '/' - case (OS_WINDOWS) - filesep = '\' - end select + select case (get_os_type()) + case default + filesep = '/' + case (OS_WINDOWS) + filesep = '\' + end select - cache = filesep - has_cache = .true. + cache = filesep + has_cache = .true. end if if (a1 == "") then - path = a2 + path = a2 else - path = a1 // filesep // a2 + path = a1//filesep//a2 end if if (present(a3)) then - path = path // filesep // a3 + path = path//filesep//a3 else - return + return end if if (present(a4)) then - path = path // filesep // a4 + path = path//filesep//a4 else - return + return end if if (present(a5)) then - path = path // filesep // a5 + path = path//filesep//a5 else - return + return end if -end function join_path - + end function join_path !> Determine number or rows in a file given a LUN -integer function number_of_rows(s) result(nrows) - integer,intent(in)::s + integer function number_of_rows(s) result(nrows) + integer, intent(in)::s integer :: ios - rewind(s) + rewind (s) nrows = 0 do - read(s, *, iostat=ios) - if (ios /= 0) exit - nrows = nrows + 1 + read (s, *, iostat=ios) + if (ios /= 0) exit + nrows = nrows + 1 end do - rewind(s) -end function number_of_rows + rewind (s) + end function number_of_rows !> read lines into an array of TYPE(STRING_T) variables expanding tabs -function read_lines_expanded(fh) result(lines) + function read_lines_expanded(fh) result(lines) integer, intent(in) :: fh type(string_t), allocatable :: lines(:) @@ -336,68 +330,68 @@ function read_lines_expanded(fh) result(lines) integer :: ilen character(LINE_BUFFER_LEN) :: line_buffer_read, line_buffer_expanded - allocate(lines(number_of_rows(fh))) + allocate (lines(number_of_rows(fh))) do i = 1, size(lines) - read(fh, '(A)') line_buffer_read - call notabs(line_buffer_read, line_buffer_expanded, ilen) - lines(i)%s = trim(line_buffer_expanded) + read (fh, '(A)') line_buffer_read + call notabs(line_buffer_read, line_buffer_expanded, ilen) + lines(i)%s = trim(line_buffer_expanded) end do -end function read_lines_expanded + end function read_lines_expanded !> read lines into an array of TYPE(STRING_T) variables -function read_lines(fh) result(lines) + function read_lines(fh) result(lines) integer, intent(in) :: fh type(string_t), allocatable :: lines(:) integer :: i character(LINE_BUFFER_LEN) :: line_buffer - allocate(lines(number_of_rows(fh))) + allocate (lines(number_of_rows(fh))) do i = 1, size(lines) - read(fh, '(A)') line_buffer - lines(i)%s = trim(line_buffer) + read (fh, '(A)') line_buffer + lines(i)%s = trim(line_buffer) end do -end function read_lines + end function read_lines !> Create a directory. Create subdirectories as needed -subroutine mkdir(dir, echo) + subroutine mkdir(dir, echo) character(len=*), intent(in) :: dir logical, intent(in), optional :: echo integer :: stat logical :: echo_local - if(present(echo))then - echo_local=echo - else - echo_local=.true. + if (present(echo)) then + echo_local = echo + else + echo_local = .true. end if if (is_dir(dir)) return select case (get_os_type()) - case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD) - call execute_command_line('mkdir -p ' // dir, exitstat=stat) + case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD) + call execute_command_line('mkdir -p '//dir, exitstat=stat) - if (echo_local) then - write (*, *) '+ mkdir -p ' // dir - end if + if (echo_local) then + write (*, *) '+ mkdir -p '//dir + end if - case (OS_WINDOWS) - call execute_command_line("mkdir " // windows_path(dir), exitstat=stat) + case (OS_WINDOWS) + call execute_command_line("mkdir "//windows_path(dir), exitstat=stat) - if (echo_local) then - write (*, *) '+ mkdir ' // windows_path(dir) - end if + if (echo_local) then + write (*, *) '+ mkdir '//windows_path(dir) + end if end select if (stat /= 0) then - call fpm_stop(1, '*mkdir*:directory creation failed') + call fpm_stop(1, '*mkdir*:directory creation failed') end if -end subroutine mkdir + end subroutine mkdir #ifndef FPM_BOOTSTRAP !> Get file & directory names in directory `dir` using iso_c_binding. @@ -405,7 +399,7 @@ end subroutine mkdir !! - File/directory names return are relative to cwd, ie. preprended with `dir` !! - Includes files starting with `.` except current directory and parent directory !! -recursive subroutine list_files(dir, files, recurse) + recursive subroutine list_files(dir, files, recurse) character(len=*), intent(in) :: dir type(string_t), allocatable, intent(out) :: files(:) logical, intent(in), optional :: recurse @@ -416,75 +410,75 @@ recursive subroutine list_files(dir, files, recurse) type(c_ptr) :: dir_handle type(c_ptr) :: dir_entry_c - character(len=:,kind=c_char), allocatable :: fortran_name + character(len=:, kind=c_char), allocatable :: fortran_name character(len=:), allocatable :: string_fortran integer, parameter :: N_MAX = 256 type(string_t) :: files_tmp(N_MAX) integer(kind=c_int) :: r if (c_is_dir(dir(1:len_trim(dir))//c_null_char) == 0) then - allocate (files(0)) - return + allocate (files(0)) + return end if dir_handle = c_opendir(dir(1:len_trim(dir))//c_null_char) if (.not. c_associated(dir_handle)) then - print *, 'c_opendir() failed' - error stop + print *, 'c_opendir() failed' + error stop end if i = 0 - allocate(files(0)) + allocate (files(0)) do - dir_entry_c = c_readdir(dir_handle) - if (.not. c_associated(dir_entry_c)) then - exit - else - string_fortran = f_string(c_get_d_name(dir_entry_c)) - - if ((string_fortran == '.' .or. string_fortran == '..')) then - cycle - end if + dir_entry_c = c_readdir(dir_handle) + if (.not. c_associated(dir_entry_c)) then + exit + else + string_fortran = f_string(c_get_d_name(dir_entry_c)) - i = i + 1 + if ((string_fortran == '.' .or. string_fortran == '..')) then + cycle + end if - if (i > N_MAX) then - files = [files, files_tmp] - i = 1 - end if + i = i + 1 - files_tmp(i)%s = join_path(dir, string_fortran) + if (i > N_MAX) then + files = [files, files_tmp] + i = 1 end if + + files_tmp(i)%s = join_path(dir, string_fortran) + end if end do r = c_closedir(dir_handle) if (r /= 0) then - print *, 'c_closedir() failed' - error stop + print *, 'c_closedir() failed' + error stop end if if (i > 0) then - files = [files, files_tmp(1:i)] + files = [files, files_tmp(1:i)] end if if (present(recurse)) then - if (recurse) then + if (recurse) then - allocate(sub_dir_files(0)) + allocate (sub_dir_files(0)) - do i=1,size(files) - if (c_is_dir(files(i)%s//c_null_char) /= 0) then - call list_files(files(i)%s, dir_files, recurse=.true.) - sub_dir_files = [sub_dir_files, dir_files] - end if - end do + do i = 1, size(files) + if (c_is_dir(files(i)%s//c_null_char) /= 0) 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 + files = [files, sub_dir_files] + end if end if -end subroutine list_files + end subroutine list_files #else !> Get file & directory names in directory `dir`. @@ -492,7 +486,7 @@ end subroutine list_files !! - File/directory names return are relative to cwd, ie. preprended with `dir` !! - Includes files starting with `.` except current directory and parent directory !! -recursive subroutine list_files(dir, files, recurse) + recursive subroutine list_files(dir, files, recurse) character(len=*), intent(in) :: dir type(string_t), allocatable, intent(out) :: files(:) logical, intent(in), optional :: recurse @@ -503,70 +497,68 @@ recursive subroutine list_files(dir, files, recurse) type(string_t), allocatable :: sub_dir_files(:) if (.not. is_dir(dir)) then - allocate (files(0)) - return + allocate (files(0)) + return end if allocate (temp_file, source=get_temp_filename()) select case (get_os_type()) - case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD) - call execute_command_line('ls -A ' // dir // ' > ' // temp_file, & - exitstat=stat) - case (OS_WINDOWS) - call execute_command_line('dir /b ' // windows_path(dir) // ' > ' // temp_file, & - exitstat=stat) + case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD) + call execute_command_line('ls -A '//dir//' > '//temp_file, & + exitstat=stat) + case (OS_WINDOWS) + call execute_command_line('dir /b '//windows_path(dir)//' > '//temp_file, & + exitstat=stat) end select if (stat /= 0) then - call fpm_stop(2,'*list_files*:directory listing failed') + call fpm_stop(2, '*list_files*:directory listing failed') end if 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) + do i = 1, size(files) + files(i)%s = join_path(dir, files(i)%s) end do if (present(recurse)) then - if (recurse) then + if (recurse) then - allocate(sub_dir_files(0)) + allocate (sub_dir_files(0)) - do i=1,size(files) - if (is_dir(files(i)%s)) then + 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] + call list_files(files(i)%s, dir_files, recurse=.true.) + sub_dir_files = [sub_dir_files, dir_files] - end if - end do + end if + end do - files = [files, sub_dir_files] + files = [files, sub_dir_files] - end if + end if end if -end subroutine list_files + end subroutine list_files #endif - !> test if pathname already exists -logical function exists(filename) result(r) + logical function exists(filename) result(r) character(len=*), intent(in) :: filename - inquire(file=filename, exist=r) -end function - + inquire (file=filename, exist=r) + end function !> Get a unused temporary filename !! Calls posix 'tempnam' - not recommended, but !! we have no security concerns for this application !! and use here is temporary. !! Works with MinGW -function get_temp_filename() result(tempfile) + function get_temp_filename() result(tempfile) ! use iso_c_binding, only: c_ptr, C_NULL_PTR, c_f_pointer character(:), allocatable :: tempfile @@ -576,32 +568,31 @@ function get_temp_filename() result(tempfile) interface - function c_tempnam(dir,pfx) result(tmp) bind(c,name="tempnam") - import - type(c_ptr), intent(in), value :: dir - type(c_ptr), intent(in), value :: pfx - type(c_ptr) :: tmp - end function c_tempnam + function c_tempnam(dir, pfx) result(tmp) bind(c, name="tempnam") + import + type(c_ptr), intent(in), value :: dir + type(c_ptr), intent(in), value :: pfx + type(c_ptr) :: tmp + end function c_tempnam - subroutine c_free(ptr) BIND(C,name="free") - import - type(c_ptr), value :: ptr - end subroutine c_free + subroutine c_free(ptr) BIND(C, name="free") + import + type(c_ptr), value :: ptr + end subroutine c_free end interface c_tempfile_ptr = c_tempnam(C_NULL_PTR, C_NULL_PTR) - call c_f_pointer(c_tempfile_ptr,c_tempfile,[LINE_BUFFER_LEN]) + call c_f_pointer(c_tempfile_ptr, c_tempfile, [LINE_BUFFER_LEN]) tempfile = f_string(c_tempfile) call c_free(c_tempfile_ptr) -end function get_temp_filename - + end function get_temp_filename !> Replace file system separators for windows -function windows_path(path) result(winpath) + function windows_path(path) result(winpath) character(*), intent(in) :: path character(:), allocatable :: winpath @@ -610,17 +601,16 @@ function windows_path(path) result(winpath) winpath = path - idx = index(winpath,'/') - do while(idx > 0) - winpath(idx:idx) = '\' - idx = index(winpath,'/') + idx = index(winpath, '/') + do while (idx > 0) + winpath(idx:idx) = '\' + idx = index(winpath, '/') end do -end function windows_path - + end function windows_path !> Replace file system separators for unix -function unix_path(path) result(nixpath) + function unix_path(path) result(nixpath) character(*), intent(in) :: path character(:), allocatable :: nixpath @@ -629,17 +619,16 @@ function unix_path(path) result(nixpath) nixpath = path - idx = index(nixpath,'\') - do while(idx > 0) - nixpath(idx:idx) = '/' - idx = index(nixpath,'\') + idx = index(nixpath, '\') + do while (idx > 0) + nixpath(idx:idx) = '/' + idx = index(nixpath, '\') end do -end function unix_path - + end function unix_path !> read a line of arbitrary length into a CHARACTER variable from the specified LUN -subroutine getline(unit, line, iostat, iomsg) + subroutine getline(unit, line, iostat, iomsg) !> Formatted IO unit integer, intent(in) :: unit @@ -658,132 +647,131 @@ subroutine getline(unit, line, iostat, iomsg) integer :: size integer :: stat - allocate(character(len=0) :: line) + allocate (character(len=0) :: line) do - read(unit, '(a)', advance='no', iostat=stat, iomsg=msg, size=size) & - & buffer - if (stat > 0) exit - line = line // buffer(:size) - if (stat < 0) then - if (is_iostat_eor(stat)) then - stat = 0 - end if - exit + read (unit, '(a)', advance='no', iostat=stat, iomsg=msg, size=size) & + & buffer + if (stat > 0) exit + line = line//buffer(:size) + if (stat < 0) then + if (is_iostat_eor(stat)) then + stat = 0 end if + exit + end if end do if (stat /= 0) then - if (present(iomsg)) iomsg = trim(msg) + if (present(iomsg)) iomsg = trim(msg) end if iostat = stat -end subroutine getline - + end subroutine getline !> delete a file by filename -subroutine delete_file(file) + subroutine delete_file(file) character(len=*), intent(in) :: file logical :: exist integer :: unit - inquire(file=file, exist=exist) + inquire (file=file, exist=exist) if (exist) then - open(file=file, newunit=unit) - close(unit, status="delete") + open (file=file, newunit=unit) + close (unit, status="delete") end if -end subroutine delete_file + end subroutine delete_file !> write trimmed character data to a file if it does not exist -subroutine warnwrite(fname,data) -character(len=*),intent(in) :: fname -character(len=*),intent(in) :: data(:) + subroutine warnwrite(fname, data) + character(len=*), intent(in) :: fname + character(len=*), intent(in) :: data(:) - if(.not.exists(fname))then - call filewrite(fname,data) + if (.not. exists(fname)) then + call filewrite(fname, data) else - write(stderr,'(*(g0,1x))')' ',fname,& - & 'already exists. Not overwriting' - endif + write (stderr, '(*(g0,1x))') ' ', fname,& + & 'already exists. Not overwriting' + end if -end subroutine warnwrite + end subroutine warnwrite !> procedure to open filename as a sequential "text" file -subroutine fileopen(filename,lun,ier) - -character(len=*),intent(in) :: filename -integer,intent(out) :: lun -integer,intent(out),optional :: ier -integer :: ios -character(len=256) :: message - - message=' ' - ios=0 - if(filename/=' ')then - open(file=filename, & - & newunit=lun, & - & form='formatted', & ! FORM = FORMATTED | UNFORMATTED - & access='sequential', & ! ACCESS = SEQUENTIAL| DIRECT | STREAM - & action='write', & ! ACTION = READ|WRITE| READWRITE - & position='rewind', & ! POSITION= ASIS | REWIND | APPEND - & status='new', & ! STATUS = NEW| REPLACE| OLD| SCRATCH| UNKNOWN - & iostat=ios, & - & iomsg=message) + subroutine fileopen(filename, lun, ier) + + character(len=*), intent(in) :: filename + integer, intent(out) :: lun + integer, intent(out), optional :: ier + integer :: ios + character(len=256) :: message + + message = ' ' + ios = 0 + if (filename /= ' ') then + open (file=filename, & + & newunit=lun, & + & form='formatted', & ! FORM = FORMATTED | UNFORMATTED + & access='sequential', & ! ACCESS = SEQUENTIAL| DIRECT | STREAM + & action='write', & ! ACTION = READ|WRITE| READWRITE + & position='rewind', & ! POSITION= ASIS | REWIND | APPEND + & status='new', & ! STATUS = NEW| REPLACE| OLD| SCRATCH| UNKNOWN + & iostat=ios, & + & iomsg=message) else - lun=stdout - ios=0 - endif - if(ios/=0)then - lun=-1 - if(present(ier))then - ier=ios - else - call fpm_stop(3,'*fileopen*:'//filename//':'//trim(message)) - endif - endif + lun = stdout + ios = 0 + end if + if (ios /= 0) then + lun = -1 + if (present(ier)) then + ier = ios + else + call fpm_stop(3, '*fileopen*:'//filename//':'//trim(message)) + end if + end if -end subroutine fileopen + end subroutine fileopen !> simple close of a LUN. On error show message and stop (by default) -subroutine fileclose(lun,ier) -integer,intent(in) :: lun -integer,intent(out),optional :: ier -character(len=256) :: message -integer :: ios - if(lun/=-1)then - close(unit=lun,iostat=ios,iomsg=message) - if(ios/=0)then - if(present(ier))then - ier=ios - else - call fpm_stop(4,'*fileclose*:'//trim(message)) - endif - endif - endif -end subroutine fileclose + subroutine fileclose(lun, ier) + integer, intent(in) :: lun + integer, intent(out), optional :: ier + character(len=256) :: message + integer :: ios + if (lun /= -1) then + close (unit=lun, iostat=ios, iomsg=message) + if (ios /= 0) then + if (present(ier)) then + ier = ios + else + call fpm_stop(4, '*fileclose*:'//trim(message)) + end if + end if + end if + end subroutine fileclose !> procedure to write filedata to file filename -subroutine filewrite(filename,filedata) - -character(len=*),intent(in) :: filename -character(len=*),intent(in) :: filedata(:) -integer :: lun, i, ios -character(len=256) :: message - call fileopen(filename,lun) - if(lun/=-1)then ! program currently stops on error on open, but might - ! want it to continue so -1 (unallowed LUN) indicates error - ! write file - do i=1,size(filedata) - write(lun,'(a)',iostat=ios,iomsg=message)trim(filedata(i)) - if(ios/=0)then - call fpm_stop(5,'*filewrite*:'//filename//':'//trim(message)) - endif - enddo - endif + subroutine filewrite(filename, filedata) + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: filedata(:) + integer :: lun, i, ios + character(len=256) :: message + call fileopen(filename, lun) + if (lun /= -1) then ! program currently stops on error on open, but might + ! want it to continue so -1 (unallowed LUN) indicates error + ! write file + do i = 1, size(filedata) + write (lun, '(a)', iostat=ios, iomsg=message) trim(filedata(i)) + if (ios /= 0) then + call fpm_stop(5, '*filewrite*:'//filename//':'//trim(message)) + end if + end do + end if ! close file call fileclose(lun) -end subroutine filewrite + end subroutine filewrite -function which(command) result(pathname) + function which(command) result(pathname) !> !!##NAME !! which(3f) - [M_io:ENVIRONMENT] given a command name find the pathname by searching @@ -826,48 +814,48 @@ function which(command) result(pathname) !!##LICENSE !! Public Domain -character(len=*),intent(in) :: command -character(len=:),allocatable :: pathname, checkon, paths(:), exts(:) -integer :: i, j - pathname='' - call split(get_env('PATH'),paths,delimiters=merge(';',':',separator()=='\')) - SEARCH: do i=1,size(paths) - checkon=trim(join_path(trim(paths(i)),command)) - select case(separator()) - case('/') - if(exists(checkon))then - pathname=checkon - exit SEARCH - endif - case('\') - if(exists(checkon))then - pathname=checkon - exit SEARCH - endif - if(exists(checkon//'.bat'))then - pathname=checkon//'.bat' - exit SEARCH - endif - if(exists(checkon//'.exe'))then - pathname=checkon//'.exe' + character(len=*), intent(in) :: command + character(len=:), allocatable :: pathname, checkon, paths(:), exts(:) + integer :: i, j + pathname = '' + call split(get_env('PATH'), paths, delimiters=merge(';', ':', separator() == '\')) + SEARCH: do i = 1, size(paths) + checkon = trim(join_path(trim(paths(i)), command)) + select case (separator()) + case ('/') + if (exists(checkon)) then + pathname = checkon + exit SEARCH + end if + case ('\') + if (exists(checkon)) then + pathname = checkon + exit SEARCH + end if + if (exists(checkon//'.bat')) then + pathname = checkon//'.bat' + exit SEARCH + end if + if (exists(checkon//'.exe')) then + pathname = checkon//'.exe' + exit SEARCH + end if + call split(get_env('PATHEXT'), exts, delimiters=';') + do j = 1, size(exts) + if (exists(checkon//'.'//trim(exts(j)))) then + pathname = checkon//'.'//trim(exts(j)) exit SEARCH - endif - call split(get_env('PATHEXT'),exts,delimiters=';') - do j=1,size(exts) - if(exists(checkon//'.'//trim(exts(j))))then - pathname=checkon//'.'//trim(exts(j)) - exit SEARCH - endif - enddo + end if + end do end select - enddo SEARCH -end function which + end do SEARCH + end function which !> echo command string and pass it to the system for execution -subroutine run(cmd,echo,exitstat,verbose,redirect) + subroutine run(cmd, echo, exitstat, verbose, redirect) character(len=*), intent(in) :: cmd - logical,intent(in),optional :: echo - integer, intent(out),optional :: exitstat + logical, intent(in), optional :: echo + integer, intent(out), optional :: exitstat logical, intent(in), optional :: verbose character(*), intent(in), optional :: redirect @@ -876,91 +864,90 @@ subroutine run(cmd,echo,exitstat,verbose,redirect) character(:), allocatable :: line integer :: stat, fh, ios - - if(present(echo))then - echo_local=echo + if (present(echo)) then + echo_local = echo else - echo_local=.true. + echo_local = .true. end if - if(present(verbose))then - verbose_local=verbose + if (present(verbose)) then + verbose_local = verbose else - verbose_local=.true. + verbose_local = .true. end if if (present(redirect)) then - redirect_str = ">"//redirect//" 2>&1" + redirect_str = ">"//redirect//" 2>&1" else - if(verbose_local)then - ! No redirection but verbose output - redirect_str = "" + if (verbose_local) then + ! No redirection but verbose output + redirect_str = "" + else + ! No redirection and non-verbose output + if (os_is_unix()) then + redirect_str = ">/dev/null 2>&1" else - ! No redirection and non-verbose output - if (os_is_unix()) then - redirect_str = ">/dev/null 2>&1" - else - redirect_str = ">NUL 2>&1" - end if + redirect_str = ">NUL 2>&1" end if + end if end if - if(echo_local) print *, '+ ', cmd + if (echo_local) print *, '+ ', cmd call execute_command_line(cmd//redirect_str, exitstat=stat) - if (verbose_local.and.present(redirect)) then + if (verbose_local .and. present(redirect)) then - open(newunit=fh,file=redirect,status='old') - do - call getline(fh, line, ios) - if (ios /= 0) exit - write(*,'(A)') trim(line) - end do - close(fh) + open (newunit=fh, file=redirect, status='old') + do + call getline(fh, line, ios) + if (ios /= 0) exit + write (*, '(A)') trim(line) + end do + close (fh) end if if (present(exitstat)) then - exitstat = stat + exitstat = stat else - if (stat /= 0) then - call fpm_stop(1,'*run*:Command failed') - end if + if (stat /= 0) then + call fpm_stop(1, '*run*:Command failed') + end if end if -end subroutine run + end subroutine run !> Delete directory using system OS remove directory commands -subroutine os_delete_dir(unix, dir, echo) + subroutine os_delete_dir(unix, dir, echo) logical, intent(in) :: unix character(len=*), intent(in) :: dir logical, intent(in), optional :: echo logical :: echo_local - if(present(echo))then - echo_local=echo - else - echo_local=.true. + if (present(echo)) then + echo_local = echo + else + echo_local = .true. end if if (unix) then - call run('rm -rf ' // dir, .false.) + call run('rm -rf '//dir, .false.) - if (echo_local) then - write (*, *) '+ rm -rf ' // dir - end if + if (echo_local) then + write (*, *) '+ rm -rf '//dir + end if else - call run('rmdir /s/q ' // dir, .false.) + call run('rmdir /s/q '//dir, .false.) - if (echo_local) then - write (*, *) '+ rmdir /s/q ' // dir - end if + if (echo_local) then + write (*, *) '+ rmdir /s/q '//dir + end if end if -end subroutine os_delete_dir + end subroutine os_delete_dir end module fpm_filesystem diff --git a/src/fpm_model.f90 b/src/fpm_model.f90 index 68d8e8ecf3..3b8b0e52b8 100644 --- a/src/fpm_model.f90 +++ b/src/fpm_model.f90 @@ -35,53 +35,52 @@ !> Describes the scoping rules for using modules — controls module dependency resolution !> module fpm_model -use iso_fortran_env, only: int64 -use fpm_compiler, only: compiler_t, archiver_t, debug -use fpm_dependency, only: dependency_tree_t -use fpm_strings, only: string_t, str -implicit none + use iso_fortran_env, only: int64 + use fpm_compiler, only: compiler_t, archiver_t, debug + use fpm_dependency, only: dependency_tree_t + use fpm_strings, only: string_t, str + implicit none -private -public :: fpm_model_t, srcfile_t, show_model + private + public :: fpm_model_t, srcfile_t, show_model -public :: FPM_UNIT_UNKNOWN, FPM_UNIT_PROGRAM, FPM_UNIT_MODULE, & - FPM_UNIT_SUBMODULE, FPM_UNIT_SUBPROGRAM, FPM_UNIT_CSOURCE, & - FPM_UNIT_CHEADER, FPM_SCOPE_UNKNOWN, FPM_SCOPE_LIB, & - FPM_SCOPE_DEP, FPM_SCOPE_APP, FPM_SCOPE_EXAMPLE, FPM_SCOPE_TEST, & - FPM_UNIT_CPPSOURCE + public :: FPM_UNIT_UNKNOWN, FPM_UNIT_PROGRAM, FPM_UNIT_MODULE, & + FPM_UNIT_SUBMODULE, FPM_UNIT_SUBPROGRAM, FPM_UNIT_CSOURCE, & + FPM_UNIT_CHEADER, FPM_SCOPE_UNKNOWN, FPM_SCOPE_LIB, & + FPM_SCOPE_DEP, FPM_SCOPE_APP, FPM_SCOPE_EXAMPLE, FPM_SCOPE_TEST, & + FPM_UNIT_CPPSOURCE !> Source type unknown -integer, parameter :: FPM_UNIT_UNKNOWN = -1 + integer, parameter :: FPM_UNIT_UNKNOWN = -1 !> Source contains a fortran program -integer, parameter :: FPM_UNIT_PROGRAM = 1 + integer, parameter :: FPM_UNIT_PROGRAM = 1 !> Source **only** contains one or more fortran modules -integer, parameter :: FPM_UNIT_MODULE = 2 + integer, parameter :: FPM_UNIT_MODULE = 2 !> Source contains one or more fortran submodules -integer, parameter :: FPM_UNIT_SUBMODULE = 3 + integer, parameter :: FPM_UNIT_SUBMODULE = 3 !> Source contains one or more fortran subprogram not within modules -integer, parameter :: FPM_UNIT_SUBPROGRAM = 4 + integer, parameter :: FPM_UNIT_SUBPROGRAM = 4 !> Source type is c source file -integer, parameter :: FPM_UNIT_CSOURCE = 5 + integer, parameter :: FPM_UNIT_CSOURCE = 5 !> Source type is c header file -integer, parameter :: FPM_UNIT_CHEADER = 6 + integer, parameter :: FPM_UNIT_CHEADER = 6 !> Souce type is c++ source file. -integer, parameter :: FPM_UNIT_CPPSOURCE = 7 + integer, parameter :: FPM_UNIT_CPPSOURCE = 7 !> Source has no module-use scope -integer, parameter :: FPM_SCOPE_UNKNOWN = -1 + integer, parameter :: FPM_SCOPE_UNKNOWN = -1 !> Module-use scope is library/dependency modules only -integer, parameter :: FPM_SCOPE_LIB = 1 + integer, parameter :: FPM_SCOPE_LIB = 1 !> Module-use scope is library/dependency modules only -integer, parameter :: FPM_SCOPE_DEP = 2 + integer, parameter :: FPM_SCOPE_DEP = 2 !> Module-use scope is library/dependency and app modules -integer, parameter :: FPM_SCOPE_APP = 3 + integer, parameter :: FPM_SCOPE_APP = 3 !> Module-use scope is library/dependency and test modules -integer, parameter :: FPM_SCOPE_TEST = 4 -integer, parameter :: FPM_SCOPE_EXAMPLE = 5 - + integer, parameter :: FPM_SCOPE_TEST = 4 + integer, parameter :: FPM_SCOPE_EXAMPLE = 5 !> Type for describing a source file -type srcfile_t + type srcfile_t !> File path relative to cwd character(:), allocatable :: file_name @@ -112,11 +111,10 @@ module fpm_model !> Current hash integer(int64) :: digest -end type srcfile_t - + end type srcfile_t !> Type for describing a single package -type package_t + type package_t !> Name of package character(:), allocatable :: name @@ -130,12 +128,11 @@ module fpm_model !> Package version number. character(:), allocatable :: version -end type package_t - + end type package_t !> Type describing everything required to build !> the root package and its dependencies. -type :: fpm_model_t + type :: fpm_model_t !> Name of root package character(:), allocatable :: package_name @@ -179,178 +176,177 @@ module fpm_model !> Whether tests should be added to the build list logical :: include_tests = .true. -end type fpm_model_t + end type fpm_model_t contains - -function info_package(p) result(s) + function info_package(p) result(s) ! Returns representation of package_t type(package_t), intent(in) :: p character(:), allocatable :: s integer :: i - s = s // 'package_t(' - s = s // 'name="' // p%name //'"' - s = s // ', sources=[' + s = s//'package_t(' + s = s//'name="'//p%name//'"' + s = s//', sources=[' do i = 1, size(p%sources) - s = s // info_srcfile(p%sources(i)) - if (i < size(p%sources)) s = s // ", " + s = s//info_srcfile(p%sources(i)) + if (i < size(p%sources)) s = s//", " end do - s = s // "]" - s = s // ")" + s = s//"]" + s = s//")" -end function info_package + end function info_package -function info_srcfile(source) result(s) + function info_srcfile(source) result(s) type(srcfile_t), intent(in) :: source character(:), allocatable :: s integer :: i !type srcfile_t s = "srcfile_t(" ! character(:), allocatable :: file_name - s = s // 'file_name="' // source%file_name // '"' + s = s//'file_name="'//source%file_name//'"' ! character(:), allocatable :: exe_name - s = s // ', exe_name="' // source%exe_name // '"' + s = s//', exe_name="'//source%exe_name//'"' ! integer :: unit_scope = FPM_SCOPE_UNKNOWN - s = s // ", unit_scope=" - select case(source%unit_scope) + s = s//", unit_scope=" + select case (source%unit_scope) case (FPM_SCOPE_UNKNOWN) - s = s // "FPM_SCOPE_UNKNOWN" + s = s//"FPM_SCOPE_UNKNOWN" case (FPM_SCOPE_LIB) - s = s // "FPM_SCOPE_LIB" + s = s//"FPM_SCOPE_LIB" case (FPM_SCOPE_DEP) - s = s // "FPM_SCOPE_DEP" + s = s//"FPM_SCOPE_DEP" case (FPM_SCOPE_APP) - s = s // "FPM_SCOPE_APP" + s = s//"FPM_SCOPE_APP" case (FPM_SCOPE_TEST) - s = s // "FPM_SCOPE_TEST" + s = s//"FPM_SCOPE_TEST" case (FPM_SCOPE_EXAMPLE) - s = s // "FPM_SCOPE_EXAMPLE" + s = s//"FPM_SCOPE_EXAMPLE" case default - s = s // "INVALID" + s = s//"INVALID" end select ! type(string_t), allocatable :: modules_provided(:) - s = s // ", modules_provided=[" + s = s//", modules_provided=[" do i = 1, size(source%modules_provided) - s = s // '"' // source%modules_provided(i)%s // '"' - if (i < size(source%modules_provided)) s = s // ", " + s = s//'"'//source%modules_provided(i)%s//'"' + if (i < size(source%modules_provided)) s = s//", " end do - s = s // "]" - s = s // ", parent_modules=[" + s = s//"]" + s = s//", parent_modules=[" do i = 1, size(source%parent_modules) - s = s // '"' // source%parent_modules(i)%s // '"' - if (i < size(source%parent_modules)) s = s // ", " + s = s//'"'//source%parent_modules(i)%s//'"' + if (i < size(source%parent_modules)) s = s//", " end do - s = s // "]" + s = s//"]" ! integer :: unit_type = FPM_UNIT_UNKNOWN - s = s // ", unit_type=" - select case(source%unit_type) + s = s//", unit_type=" + select case (source%unit_type) case (FPM_UNIT_UNKNOWN) - s = s // "FPM_UNIT_UNKNOWN" + s = s//"FPM_UNIT_UNKNOWN" case (FPM_UNIT_PROGRAM) - s = s // "FPM_UNIT_PROGRAM" + s = s//"FPM_UNIT_PROGRAM" case (FPM_UNIT_MODULE) - s = s // "FPM_UNIT_MODULE" + s = s//"FPM_UNIT_MODULE" case (FPM_UNIT_SUBMODULE) - s = s // "FPM_UNIT_SUBMODULE" + s = s//"FPM_UNIT_SUBMODULE" case (FPM_UNIT_SUBPROGRAM) - s = s // "FPM_UNIT_SUBPROGRAM" + s = s//"FPM_UNIT_SUBPROGRAM" case (FPM_UNIT_CSOURCE) - s = s // "FPM_UNIT_CSOURCE" + s = s//"FPM_UNIT_CSOURCE" case (FPM_UNIT_CPPSOURCE) - s = s // "FPM_UNIT_CPPSOURCE" + s = s//"FPM_UNIT_CPPSOURCE" case (FPM_UNIT_CHEADER) - s = s // "FPM_UNIT_CHEADER" + s = s//"FPM_UNIT_CHEADER" case default - s = s // "INVALID" + s = s//"INVALID" end select ! type(string_t), allocatable :: modules_used(:) - s = s // ", modules_used=[" + s = s//", modules_used=[" do i = 1, size(source%modules_used) - s = s // '"' // source%modules_used(i)%s // '"' - if (i < size(source%modules_used)) s = s // ", " + s = s//'"'//source%modules_used(i)%s//'"' + if (i < size(source%modules_used)) s = s//", " end do - s = s // "]" + s = s//"]" ! type(string_t), allocatable :: include_dependencies(:) - s = s // ", include_dependencies=[" + s = s//", include_dependencies=[" do i = 1, size(source%include_dependencies) - s = s // '"' // source%include_dependencies(i)%s // '"' - if (i < size(source%include_dependencies)) s = s // ", " + s = s//'"'//source%include_dependencies(i)%s//'"' + if (i < size(source%include_dependencies)) s = s//", " end do - s = s // "]" + s = s//"]" ! type(string_t), allocatable :: link_libraries(:) - s = s // ", link_libraries=[" + s = s//", link_libraries=[" do i = 1, size(source%link_libraries) - s = s // '"' // source%link_libraries(i)%s // '"' - if (i < size(source%link_libraries)) s = s // ", " + s = s//'"'//source%link_libraries(i)%s//'"' + if (i < size(source%link_libraries)) s = s//", " end do - s = s // "]" + s = s//"]" ! integer(int64) :: digest - s = s // ", digest=" // str(source%digest) + s = s//", digest="//str(source%digest) !end type srcfile_t - s = s // ")" -end function info_srcfile + s = s//")" + end function info_srcfile -function info_srcfile_short(source) result(s) + function info_srcfile_short(source) result(s) ! Prints a shortened version of srcfile_t type(srcfile_t), intent(in) :: source character(:), allocatable :: s s = "srcfile_t(" - s = s // 'file_name="' // source%file_name // '"' - s = s // ", ...)" -end function info_srcfile_short + s = s//'file_name="'//source%file_name//'"' + s = s//", ...)" + end function info_srcfile_short -function info_model(model) result(s) + function info_model(model) result(s) type(fpm_model_t), intent(in) :: model character(:), allocatable :: s integer :: i !type :: fpm_model_t s = "fpm_model_t(" ! character(:), allocatable :: package_name - s = s // 'package_name="' // model%package_name // '"' + s = s//'package_name="'//model%package_name//'"' ! type(srcfile_t), allocatable :: sources(:) - s = s // ", packages=[" + s = s//", packages=[" do i = 1, size(model%packages) - s = s // info_package(model%packages(i)) - if (i < size(model%packages)) s = s // ", " + s = s//info_package(model%packages(i)) + if (i < size(model%packages)) s = s//", " end do - s = s // "]" - s = s // ', compiler=(' // debug(model%compiler) // ')' - s = s // ', archiver=(' // debug(model%archiver) // ')' + s = s//"]" + s = s//', compiler=('//debug(model%compiler)//')' + s = s//', archiver=('//debug(model%archiver)//')' ! character(:), allocatable :: fortran_compile_flags - s = s // ', fortran_compile_flags="' // model%fortran_compile_flags // '"' - s = s // ', c_compile_flags="' // model%c_compile_flags // '"' - s = s // ', cxx_compile_flags="' // model%cxx_compile_flags // '"' - s = s // ', link_flags="' // model%link_flags // '"' - s = s // ', build_prefix="' // model%build_prefix // '"' + s = s//', fortran_compile_flags="'//model%fortran_compile_flags//'"' + s = s//', c_compile_flags="'//model%c_compile_flags//'"' + s = s//', cxx_compile_flags="'//model%cxx_compile_flags//'"' + s = s//', link_flags="'//model%link_flags//'"' + s = s//', build_prefix="'//model%build_prefix//'"' ! type(string_t), allocatable :: link_libraries(:) - s = s // ", link_libraries=[" + s = s//", link_libraries=[" do i = 1, size(model%link_libraries) - s = s // '"' // model%link_libraries(i)%s // '"' - if (i < size(model%link_libraries)) s = s // ", " + s = s//'"'//model%link_libraries(i)%s//'"' + if (i < size(model%link_libraries)) s = s//", " end do - s = s // "]" + s = s//"]" ! type(string_t), allocatable :: external_modules(:) - s = s // ", external_modules=[" + s = s//", external_modules=[" do i = 1, size(model%external_modules) - s = s // '"' // model%external_modules(i)%s // '"' - if (i < size(model%external_modules)) s = s // ", " + s = s//'"'//model%external_modules(i)%s//'"' + if (i < size(model%external_modules)) s = s//", " end do - s = s // "]" + s = s//"]" ! type(dependency_tree_t) :: deps ! TODO: print `dependency_tree_t` properly, which should become part of the ! model, not imported from another file - s = s // ", deps=dependency_tree_t(...)" + s = s//", deps=dependency_tree_t(...)" !end type fpm_model_t - s = s // ")" -end function info_model + s = s//")" + end function info_model -subroutine show_model(model) + subroutine show_model(model) ! Prints a human readable representation of the Model type(fpm_model_t), intent(in) :: model print *, info_model(model) -end subroutine show_model + end subroutine show_model end module fpm_model diff --git a/src/fpm_os.F90 b/src/fpm_os.F90 index 71663fe17c..282575f395 100644 --- a/src/fpm_os.F90 +++ b/src/fpm_os.F90 @@ -1,105 +1,105 @@ module fpm_os - use, intrinsic :: iso_c_binding, only : c_char, c_int, c_null_char, c_ptr, c_associated - use fpm_error, only : error_t, fatal_error - implicit none - private - public :: change_directory, get_current_directory + use, intrinsic :: iso_c_binding, only: c_char, c_int, c_null_char, c_ptr, c_associated + use fpm_error, only: error_t, fatal_error + implicit none + private + public :: change_directory, get_current_directory #ifndef _WIN32 - character(len=*), parameter :: pwd_env = "PWD" + character(len=*), parameter :: pwd_env = "PWD" #else - character(len=*), parameter :: pwd_env = "CD" + character(len=*), parameter :: pwd_env = "CD" #endif - interface - function chdir(path) result(stat) & + interface + function chdir(path) result(stat) & #ifndef _WIN32 - bind(C, name="chdir") + bind(C, name="chdir") #else - bind(C, name="_chdir") + bind(C, name="_chdir") #endif - import :: c_char, c_int - character(kind=c_char, len=1), intent(in) :: path(*) - integer(c_int) :: stat - end function chdir + import :: c_char, c_int + character(kind=c_char, len=1), intent(in) :: path(*) + integer(c_int) :: stat + end function chdir - function getcwd(buf, bufsize) result(path) & + function getcwd(buf, bufsize) result(path) & #ifndef _WIN32 - bind(C, name="getcwd") + bind(C, name="getcwd") #else - bind(C, name="_getcwd") + bind(C, name="_getcwd") #endif - import :: c_char, c_int, c_ptr - character(kind=c_char, len=1), intent(in) :: buf(*) - integer(c_int), value, intent(in) :: bufsize - type(c_ptr) :: path - end function getcwd - end interface + import :: c_char, c_int, c_ptr + character(kind=c_char, len=1), intent(in) :: buf(*) + integer(c_int), value, intent(in) :: bufsize + type(c_ptr) :: path + end function getcwd + end interface contains - subroutine change_directory(path, error) - character(len=*), intent(in) :: path - type(error_t), allocatable, intent(out) :: error + subroutine change_directory(path, error) + character(len=*), intent(in) :: path + type(error_t), allocatable, intent(out) :: error - character(kind=c_char, len=1), allocatable :: cpath(:) - integer :: stat + character(kind=c_char, len=1), allocatable :: cpath(:) + integer :: stat - allocate(cpath(len(path)+1)) - call f_c_character(path, cpath, len(path)+1) + allocate (cpath(len(path) + 1)) + call f_c_character(path, cpath, len(path) + 1) - stat = chdir(cpath) + stat = chdir(cpath) - if (stat /= 0) then - call fatal_error(error, "Failed to change directory to '"//path//"'") - end if - end subroutine change_directory + if (stat /= 0) then + call fatal_error(error, "Failed to change directory to '"//path//"'") + end if + end subroutine change_directory - subroutine get_current_directory(path, error) - character(len=:), allocatable, intent(out) :: path - type(error_t), allocatable, intent(out) :: error + subroutine get_current_directory(path, error) + character(len=:), allocatable, intent(out) :: path + type(error_t), allocatable, intent(out) :: error - character(kind=c_char, len=1), allocatable :: cpath(:) - integer(c_int), parameter :: buffersize = 1000_c_int - type(c_ptr) :: tmp + character(kind=c_char, len=1), allocatable :: cpath(:) + integer(c_int), parameter :: buffersize = 1000_c_int + type(c_ptr) :: tmp - allocate(cpath(buffersize)) + allocate (cpath(buffersize)) - tmp = getcwd(cpath, buffersize) - if (c_associated(tmp)) then - call c_f_character(cpath, path) - else - call fatal_error(error, "Failed to retrieve current directory") - end if + tmp = getcwd(cpath, buffersize) + if (c_associated(tmp)) then + call c_f_character(cpath, path) + else + call fatal_error(error, "Failed to retrieve current directory") + end if - end subroutine get_current_directory + end subroutine get_current_directory - subroutine f_c_character(rhs, lhs, len) - character(kind=c_char), intent(out) :: lhs(*) - character(len=*), intent(in) :: rhs - integer, intent(in) :: len - integer :: length - length = min(len-1, len_trim(rhs)) + subroutine f_c_character(rhs, lhs, len) + character(kind=c_char), intent(out) :: lhs(*) + character(len=*), intent(in) :: rhs + integer, intent(in) :: len + integer :: length + length = min(len - 1, len_trim(rhs)) - lhs(1:length) = transfer(rhs(1:length), lhs(1:length)) - lhs(length+1:length+1) = c_null_char + lhs(1:length) = transfer(rhs(1:length), lhs(1:length)) + lhs(length + 1:length + 1) = c_null_char - end subroutine f_c_character + end subroutine f_c_character - subroutine c_f_character(rhs, lhs) - character(kind=c_char), intent(in) :: rhs(*) - character(len=:), allocatable, intent(out) :: lhs + subroutine c_f_character(rhs, lhs) + character(kind=c_char), intent(in) :: rhs(*) + character(len=:), allocatable, intent(out) :: lhs - integer :: ii + integer :: ii - do ii = 1, huge(ii) - 1 - if (rhs(ii) == c_null_char) then - exit - end if - end do - allocate(character(len=ii-1) :: lhs) - lhs = transfer(rhs(1:ii-1), lhs) + do ii = 1, huge(ii) - 1 + if (rhs(ii) == c_null_char) then + exit + end if + end do + allocate (character(len=ii - 1) :: lhs) + lhs = transfer(rhs(1:ii - 1), lhs) - end subroutine c_f_character + end subroutine c_f_character end module fpm_os diff --git a/src/fpm_source_parsing.f90 b/src/fpm_source_parsing.f90 index 6d22ef4a6c..cd9b8efafd 100644 --- a/src/fpm_source_parsing.f90 +++ b/src/fpm_source_parsing.f90 @@ -15,27 +15,27 @@ !> - `[[parse_c_source]]` !> module fpm_source_parsing -use fpm_error, only: error_t, file_parse_error, fatal_error, file_not_found_error -use fpm_strings, only: string_t, string_cat, len_trim, split, lower, str_ends_with, fnv_1a, is_fortran_name -use fpm_model, only: srcfile_t, & - FPM_UNIT_UNKNOWN, FPM_UNIT_PROGRAM, FPM_UNIT_MODULE, & - FPM_UNIT_SUBMODULE, FPM_UNIT_SUBPROGRAM, & - FPM_UNIT_CSOURCE, FPM_UNIT_CHEADER, FPM_SCOPE_UNKNOWN, & - FPM_SCOPE_LIB, FPM_SCOPE_DEP, FPM_SCOPE_APP, FPM_SCOPE_TEST, & - FPM_UNIT_CPPSOURCE -use fpm_filesystem, only: read_lines, read_lines_expanded, exists -implicit none - -private -public :: parse_f_source, parse_c_source - -character(15), parameter :: INTRINSIC_MODULE_NAMES(*) = & - ['iso_c_binding ', & - 'iso_fortran_env', & - 'ieee_arithmetic', & - 'ieee_exceptions', & - 'ieee_features ', & - 'omp_lib '] + use fpm_error, only: error_t, file_parse_error, fatal_error, file_not_found_error + use fpm_strings, only: string_t, string_cat, len_trim, split, lower, str_ends_with, fnv_1a, is_fortran_name + use fpm_model, only: srcfile_t, & + FPM_UNIT_UNKNOWN, FPM_UNIT_PROGRAM, FPM_UNIT_MODULE, & + FPM_UNIT_SUBMODULE, FPM_UNIT_SUBPROGRAM, & + FPM_UNIT_CSOURCE, FPM_UNIT_CHEADER, FPM_SCOPE_UNKNOWN, & + FPM_SCOPE_LIB, FPM_SCOPE_DEP, FPM_SCOPE_APP, FPM_SCOPE_TEST, & + FPM_UNIT_CPPSOURCE + use fpm_filesystem, only: read_lines, read_lines_expanded, exists + implicit none + + private + public :: parse_f_source, parse_c_source + + character(15), parameter :: INTRINSIC_MODULE_NAMES(*) = & + ['iso_c_binding ', & + 'iso_fortran_env', & + 'ieee_arithmetic', & + 'ieee_exceptions', & + 'ieee_features ', & + 'omp_lib '] contains @@ -72,7 +72,7 @@ module fpm_source_parsing !> my_module !>``` !> -function parse_f_source(f_filename,error) result(f_source) + function parse_f_source(f_filename, error) result(f_source) character(*), intent(in) :: f_filename type(srcfile_t) :: f_source type(error_t), allocatable, intent(out) :: error @@ -84,357 +84,356 @@ function parse_f_source(f_filename,error) result(f_source) character(:), allocatable :: temp_string, mod_name, string_parts(:) if (.not. exists(f_filename)) then - call file_not_found_error(error, f_filename) - return + call file_not_found_error(error, f_filename) + return end if f_source%file_name = f_filename - open(newunit=fh,file=f_filename,status='old') + open (newunit=fh, file=f_filename, status='old') file_lines = read_lines_expanded(fh) - close(fh) + close (fh) ! for efficiency in parsing make a lowercase left-adjusted copy of the file ! Need a copy because INCLUDE (and #include) file arguments are case-sensitive - file_lines_lower=file_lines - do i=1,size(file_lines_lower) - file_lines_lower(i)%s=adjustl(lower(file_lines_lower(i)%s)) - enddo + file_lines_lower = file_lines + do i = 1, size(file_lines_lower) + file_lines_lower(i)%s = adjustl(lower(file_lines_lower(i)%s)) + end do ! fnv_1a can only be applied to non-zero-length arrays if (len_trim(file_lines_lower) > 0) f_source%digest = fnv_1a(file_lines) - do pass = 1,2 - n_use = 0 - n_include = 0 - n_mod = 0 - n_parent = 0 - inside_module = .false. - inside_interface = .false. - file_loop: do i=1,size(file_lines_lower) - - ! Skip comment lines and preprocessor directives - if (index(file_lines_lower(i)%s,'!') == 1 .or. & - index(file_lines_lower(i)%s,'#') == 1 .or. & - len_trim(file_lines_lower(i)%s) < 1) then - cycle + do pass = 1, 2 + n_use = 0 + n_include = 0 + n_mod = 0 + n_parent = 0 + inside_module = .false. + inside_interface = .false. + file_loop: do i = 1, size(file_lines_lower) + + ! Skip comment lines and preprocessor directives + if (index(file_lines_lower(i)%s, '!') == 1 .or. & + index(file_lines_lower(i)%s, '#') == 1 .or. & + len_trim(file_lines_lower(i)%s) < 1) then + cycle + end if + + ! Detect exported C-API via bind(C) + if (.not. inside_interface .and. & + parse_subsequence(file_lines_lower(i)%s, 'bind', '(', 'c')) then + + do j = i, 1, -1 + + if (index(file_lines_lower(j)%s, 'function') > 0 .or. & + index(file_lines_lower(j)%s, 'subroutine') > 0) then + f_source%unit_type = FPM_UNIT_SUBPROGRAM + exit end if - ! Detect exported C-API via bind(C) - if (.not.inside_interface .and. & - parse_subsequence(file_lines_lower(i)%s,'bind','(','c')) then - - do j=i,1,-1 + if (j > 1) then - if (index(file_lines_lower(j)%s,'function') > 0 .or. & - index(file_lines_lower(j)%s,'subroutine') > 0) then - f_source%unit_type = FPM_UNIT_SUBPROGRAM - exit - end if + ic = index(file_lines_lower(j - 1)%s, '!') + if (ic < 1) then + ic = len(file_lines_lower(j - 1)%s) + end if - if (j>1) then + temp_string = trim(file_lines_lower(j - 1)%s(1:ic)) + if (index(temp_string, '&') /= len(temp_string)) then + exit + end if - ic = index(file_lines_lower(j-1)%s,'!') - if (ic < 1) then - ic = len(file_lines_lower(j-1)%s) - end if + end if - temp_string = trim(file_lines_lower(j-1)%s(1:ic)) - if (index(temp_string,'&') /= len(temp_string)) then - exit - end if + end do - end if + end if - end do + ! Skip lines that are continued: not statements + if (i > 1) then + ic = index(file_lines_lower(i - 1)%s, '!') + if (ic < 1) then + ic = len(file_lines_lower(i - 1)%s) + end if + temp_string = trim(file_lines_lower(i - 1)%s(1:ic)) + if (len(temp_string) > 0 .and. index(temp_string, '&') == len(temp_string)) then + cycle + end if + end if - end if + ! Detect beginning of interface block + if (index(file_lines_lower(i)%s, 'interface') == 1) then - ! Skip lines that are continued: not statements - if (i > 1) then - ic = index(file_lines_lower(i-1)%s,'!') - if (ic < 1) then - ic = len(file_lines_lower(i-1)%s) - end if - temp_string = trim(file_lines_lower(i-1)%s(1:ic)) - if (len(temp_string) > 0 .and. index(temp_string,'&') == len(temp_string)) then - cycle - end if - end if + inside_interface = .true. + cycle - ! Detect beginning of interface block - if (index(file_lines_lower(i)%s,'interface') == 1) then + end if - inside_interface = .true. - cycle + ! Detect end of interface block + if (parse_sequence(file_lines_lower(i)%s, 'end', 'interface')) then - end if + inside_interface = .false. + cycle - ! Detect end of interface block - if (parse_sequence(file_lines_lower(i)%s,'end','interface')) then + end if - inside_interface = .false. - cycle + ! Process 'USE' statements + if (index(file_lines_lower(i)%s, 'use ') == 1 .or. & + index(file_lines_lower(i)%s, 'use::') == 1) then + if (index(file_lines_lower(i)%s, '::') > 0) then + + temp_string = split_n(file_lines_lower(i)%s, delims=':', n=2, stat=stat) + if (stat /= 0) then + call file_parse_error(error, f_filename, & + 'unable to find used module name', i, & + file_lines_lower(i)%s, index(file_lines_lower(i)%s, '::')) + return end if - ! Process 'USE' statements - if (index(file_lines_lower(i)%s,'use ') == 1 .or. & - index(file_lines_lower(i)%s,'use::') == 1) then + mod_name = split_n(temp_string, delims=' ,', n=1, stat=stat) + if (stat /= 0) then + call file_parse_error(error, f_filename, & + 'unable to find used module name', i, & + file_lines_lower(i)%s) + return + end if - if (index(file_lines_lower(i)%s,'::') > 0) then + else - temp_string = split_n(file_lines_lower(i)%s,delims=':',n=2,stat=stat) - if (stat /= 0) then - call file_parse_error(error,f_filename, & - 'unable to find used module name',i, & - file_lines_lower(i)%s,index(file_lines_lower(i)%s,'::')) - return - end if + mod_name = split_n(file_lines_lower(i)%s, n=2, delims=' ,', stat=stat) + if (stat /= 0) then + call file_parse_error(error, f_filename, & + 'unable to find used module name', i, & + file_lines_lower(i)%s) + return + end if - mod_name = split_n(temp_string,delims=' ,',n=1,stat=stat) - if (stat /= 0) then - call file_parse_error(error,f_filename, & - 'unable to find used module name',i, & - file_lines_lower(i)%s) - return - end if + end if - else + if (.not. is_fortran_name(mod_name)) then + cycle + end if - mod_name = split_n(file_lines_lower(i)%s,n=2,delims=' ,',stat=stat) - if (stat /= 0) then - call file_parse_error(error,f_filename, & - 'unable to find used module name',i, & - file_lines_lower(i)%s) - return - end if + if (any([(index(mod_name, trim(INTRINSIC_MODULE_NAMES(j))) > 0, & + j=1, size(INTRINSIC_MODULE_NAMES))])) then + cycle + end if - end if + n_use = n_use + 1 - if (.not.is_fortran_name(mod_name)) then - cycle - end if + if (pass == 2) then - if (any([(index(mod_name,trim(INTRINSIC_MODULE_NAMES(j)))>0, & - j=1,size(INTRINSIC_MODULE_NAMES))])) then - cycle - end if + f_source%modules_used(n_use)%s = mod_name - n_use = n_use + 1 + end if - if (pass == 2) then + cycle - f_source%modules_used(n_use)%s = mod_name + end if - end if + ! Process 'INCLUDE' statements + ic = index(file_lines_lower(i)%s, 'include') + if (ic == 1) then + ic = index(lower(file_lines(i)%s), 'include') + if (index(adjustl(file_lines(i)%s(ic + 7:)), '"') == 1 .or. & + index(adjustl(file_lines(i)%s(ic + 7:)), "'") == 1) then + + n_include = n_include + 1 + + if (pass == 2) then + f_source%include_dependencies(n_include)%s = & + & split_n(file_lines(i)%s, n=2, delims="'"//'"', stat=stat) + if (stat /= 0) then + call file_parse_error(error, f_filename, & + 'unable to find include file name', i, & + file_lines(i)%s) + return + end if + end if - cycle + cycle - end if + end if + end if - ! Process 'INCLUDE' statements - ic = index(file_lines_lower(i)%s,'include') - if ( ic == 1 ) then - ic = index(lower(file_lines(i)%s),'include') - if (index(adjustl(file_lines(i)%s(ic+7:)),'"') == 1 .or. & - index(adjustl(file_lines(i)%s(ic+7:)),"'") == 1 ) then - - n_include = n_include + 1 - - if (pass == 2) then - f_source%include_dependencies(n_include)%s = & - & split_n(file_lines(i)%s,n=2,delims="'"//'"',stat=stat) - if (stat /= 0) then - call file_parse_error(error,f_filename, & - 'unable to find include file name',i, & - file_lines(i)%s) - return - end if - end if - - cycle - - end if - end if + ! Extract name of module if is module + if (index(file_lines_lower(i)%s, 'module ') == 1) then + + ! Remove any trailing comments + ic = index(file_lines_lower(i)%s, '!') - 1 + if (ic < 1) then + ic = len(file_lines_lower(i)%s) + end if + temp_string = trim(file_lines_lower(i)%s(1:ic)) + + ! R1405 module-stmt := "MODULE" module-name + ! module-stmt has two space-delimited parts only + ! (no line continuations) + call split(temp_string, string_parts, ' ') + if (size(string_parts) /= 2) then + cycle + end if + + mod_name = trim(adjustl(string_parts(2))) + if (scan(mod_name, '=(&') > 0) then + ! Ignore these cases: + ! module & + ! module =* + ! module (i) + cycle + end if + + if (.not. is_fortran_name(mod_name)) then + call file_parse_error(error, f_filename, & + 'empty or invalid name for module', i, & + file_lines_lower(i)%s, index(file_lines_lower(i)%s, mod_name)) + return + end if - ! Extract name of module if is module - if (index(file_lines_lower(i)%s,'module ') == 1) then - - ! Remove any trailing comments - ic = index(file_lines_lower(i)%s,'!')-1 - if (ic < 1) then - ic = len(file_lines_lower(i)%s) - end if - temp_string = trim(file_lines_lower(i)%s(1:ic)) - - ! R1405 module-stmt := "MODULE" module-name - ! module-stmt has two space-delimited parts only - ! (no line continuations) - call split(temp_string,string_parts,' ') - if (size(string_parts) /= 2) then - cycle - end if - - mod_name = trim(adjustl(string_parts(2))) - if (scan(mod_name,'=(&')>0 ) then - ! Ignore these cases: - ! module & - ! module =* - ! module (i) - cycle - end if - - if (.not.is_fortran_name(mod_name)) then - call file_parse_error(error,f_filename, & - 'empty or invalid name for module',i, & - file_lines_lower(i)%s, index(file_lines_lower(i)%s,mod_name)) - return - end if - - n_mod = n_mod + 1 - - if (pass == 2) then - f_source%modules_provided(n_mod) = string_t(mod_name) - end if - - if (f_source%unit_type == FPM_UNIT_UNKNOWN) then - f_source%unit_type = FPM_UNIT_MODULE - end if - - if (.not.inside_module) then - inside_module = .true. - else - ! Must have missed an end module statement (can't assume a pure module) - if (f_source%unit_type /= FPM_UNIT_PROGRAM) then - f_source%unit_type = FPM_UNIT_SUBPROGRAM - end if - end if - - cycle + n_mod = n_mod + 1 - end if + if (pass == 2) then + f_source%modules_provided(n_mod) = string_t(mod_name) + end if - ! Extract name of submodule if is submodule - if (index(file_lines_lower(i)%s,'submodule') == 1) then + if (f_source%unit_type == FPM_UNIT_UNKNOWN) then + f_source%unit_type = FPM_UNIT_MODULE + end if - mod_name = split_n(file_lines_lower(i)%s,n=3,delims='()',stat=stat) - if (stat /= 0) then - call file_parse_error(error,f_filename, & - 'unable to get submodule name',i, & - file_lines_lower(i)%s) - return - end if - if (.not.is_fortran_name(mod_name)) then - call file_parse_error(error,f_filename, & - 'empty or invalid name for submodule',i, & - file_lines_lower(i)%s, index(file_lines_lower(i)%s,mod_name)) - return - end if + if (.not. inside_module) then + inside_module = .true. + else + ! Must have missed an end module statement (can't assume a pure module) + if (f_source%unit_type /= FPM_UNIT_PROGRAM) then + f_source%unit_type = FPM_UNIT_SUBPROGRAM + end if + end if - n_mod = n_mod + 1 + cycle - temp_string = split_n(file_lines_lower(i)%s,n=2,delims='()',stat=stat) - if (stat /= 0) then - call file_parse_error(error,f_filename, & - 'unable to get submodule ancestry',i, & - file_lines_lower(i)%s) - return - end if - - if (f_source%unit_type /= FPM_UNIT_PROGRAM) then - f_source%unit_type = FPM_UNIT_SUBMODULE - end if + end if + + ! Extract name of submodule if is submodule + if (index(file_lines_lower(i)%s, 'submodule') == 1) then - n_use = n_use + 1 + mod_name = split_n(file_lines_lower(i)%s, n=3, delims='()', stat=stat) + if (stat /= 0) then + call file_parse_error(error, f_filename, & + 'unable to get submodule name', i, & + file_lines_lower(i)%s) + return + end if + if (.not. is_fortran_name(mod_name)) then + call file_parse_error(error, f_filename, & + 'empty or invalid name for submodule', i, & + file_lines_lower(i)%s, index(file_lines_lower(i)%s, mod_name)) + return + end if - inside_module = .true. + n_mod = n_mod + 1 - n_parent = n_parent + 1 + temp_string = split_n(file_lines_lower(i)%s, n=2, delims='()', stat=stat) + if (stat /= 0) then + call file_parse_error(error, f_filename, & + 'unable to get submodule ancestry', i, & + file_lines_lower(i)%s) + return + end if - if (pass == 2) then + if (f_source%unit_type /= FPM_UNIT_PROGRAM) then + f_source%unit_type = FPM_UNIT_SUBMODULE + end if - if (index(temp_string,':') > 0) then + n_use = n_use + 1 - temp_string = temp_string(index(temp_string,':')+1:) + inside_module = .true. - end if + n_parent = n_parent + 1 - if (.not.is_fortran_name(temp_string)) then - call file_parse_error(error,f_filename, & - 'empty or invalid name for submodule parent',i, & - file_lines_lower(i)%s, index(file_lines_lower(i)%s,temp_string)) - return - end if + if (pass == 2) then - f_source%modules_used(n_use)%s = temp_string - f_source%parent_modules(n_parent)%s = temp_string - f_source%modules_provided(n_mod)%s = mod_name + if (index(temp_string, ':') > 0) then - end if + temp_string = temp_string(index(temp_string, ':') + 1:) - cycle + end if + if (.not. is_fortran_name(temp_string)) then + call file_parse_error(error, f_filename, & + 'empty or invalid name for submodule parent', i, & + file_lines_lower(i)%s, index(file_lines_lower(i)%s, temp_string)) + return end if - ! Detect if contains a program - ! (no modules allowed after program def) - if (index(file_lines_lower(i)%s,'program ') == 1) then + f_source%modules_used(n_use)%s = temp_string + f_source%parent_modules(n_parent)%s = temp_string + f_source%modules_provided(n_mod)%s = mod_name - temp_string = split_n(file_lines_lower(i)%s,n=2,delims=' ',stat=stat) - if (stat == 0) then + end if - if (scan(temp_string,'=(')>0 ) then - ! Ignore: - ! program =* - ! program (i) =* - cycle - end if + cycle - end if + end if - f_source%unit_type = FPM_UNIT_PROGRAM + ! Detect if contains a program + ! (no modules allowed after program def) + if (index(file_lines_lower(i)%s, 'program ') == 1) then - cycle + temp_string = split_n(file_lines_lower(i)%s, n=2, delims=' ', stat=stat) + if (stat == 0) then + if (scan(temp_string, '=(') > 0) then + ! Ignore: + ! program =* + ! program (i) =* + cycle end if - ! Parse end module statement - ! (to check for code outside of modules) - if (parse_sequence(file_lines_lower(i)%s,'end','module') .or. & - parse_sequence(file_lines_lower(i)%s,'end','submodule')) then - - inside_module = .false. - cycle + end if - end if + f_source%unit_type = FPM_UNIT_PROGRAM - ! Any statements not yet parsed are assumed to be other code statements - if (.not.inside_module .and. f_source%unit_type /= FPM_UNIT_PROGRAM) then + cycle - f_source%unit_type = FPM_UNIT_SUBPROGRAM + end if - end if + ! Parse end module statement + ! (to check for code outside of modules) + if (parse_sequence(file_lines_lower(i)%s, 'end', 'module') .or. & + parse_sequence(file_lines_lower(i)%s, 'end', 'submodule')) then - end do file_loop + inside_module = .false. + cycle - ! If unable to parse end of module statement, then can't assume pure module - ! (there could be non-module subprograms present) - if (inside_module .and. f_source%unit_type == FPM_UNIT_MODULE) then - f_source%unit_type = FPM_UNIT_SUBPROGRAM end if - if (pass == 1) then - allocate(f_source%modules_used(n_use)) - allocate(f_source%include_dependencies(n_include)) - allocate(f_source%modules_provided(n_mod)) - allocate(f_source%parent_modules(n_parent)) + ! Any statements not yet parsed are assumed to be other code statements + if (.not. inside_module .and. f_source%unit_type /= FPM_UNIT_PROGRAM) then + + f_source%unit_type = FPM_UNIT_SUBPROGRAM + end if - end do + end do file_loop -end function parse_f_source + ! If unable to parse end of module statement, then can't assume pure module + ! (there could be non-module subprograms present) + if (inside_module .and. f_source%unit_type == FPM_UNIT_MODULE) then + f_source%unit_type = FPM_UNIT_SUBPROGRAM + end if + if (pass == 1) then + allocate (f_source%modules_used(n_use)) + allocate (f_source%include_dependencies(n_include)) + allocate (f_source%modules_provided(n_mod)) + allocate (f_source%parent_modules(n_parent)) + end if + + end do + + end function parse_f_source !> Parsing of c, cpp source files !> @@ -442,7 +441,7 @@ end function parse_f_source !> !> - `#include` preprocessor statement !> -function parse_c_source(c_filename,error) result(c_source) + function parse_c_source(c_filename, error) result(c_source) character(*), intent(in) :: c_filename type(srcfile_t) :: c_source type(error_t), allocatable, intent(out) :: error @@ -454,68 +453,68 @@ function parse_c_source(c_filename,error) result(c_source) if (str_ends_with(lower(c_filename), ".c")) then - c_source%unit_type = FPM_UNIT_CSOURCE + c_source%unit_type = FPM_UNIT_CSOURCE else if (str_ends_with(lower(c_filename), ".h")) then - c_source%unit_type = FPM_UNIT_CHEADER + c_source%unit_type = FPM_UNIT_CHEADER - else if (str_ends_with(lower(c_filename), ".cpp")) then + else if (str_ends_with(lower(c_filename), ".cpp")) then - c_source%unit_type = FPM_UNIT_CPPSOURCE + c_source%unit_type = FPM_UNIT_CPPSOURCE end if - allocate(c_source%modules_used(0)) - allocate(c_source%modules_provided(0)) - allocate(c_source%parent_modules(0)) + allocate (c_source%modules_used(0)) + allocate (c_source%modules_provided(0)) + allocate (c_source%parent_modules(0)) - open(newunit=fh,file=c_filename,status='old') + open (newunit=fh, file=c_filename, status='old') file_lines = read_lines(fh) - close(fh) + close (fh) ! Ignore empty files, returned as FPM_UNIT_UNKNOWN if (len_trim(file_lines) < 1) then - c_source%unit_type = FPM_UNIT_UNKNOWN - return + c_source%unit_type = FPM_UNIT_UNKNOWN + return end if c_source%digest = fnv_1a(file_lines) - do pass = 1,2 - n_include = 0 - file_loop: do i=1,size(file_lines) - - ! Process 'INCLUDE' statements - if (index(adjustl(lower(file_lines(i)%s)),'#include') == 1 .and. & - index(file_lines(i)%s,'"') > 0) then + do pass = 1, 2 + n_include = 0 + file_loop: do i = 1, size(file_lines) - n_include = n_include + 1 + ! Process 'INCLUDE' statements + if (index(adjustl(lower(file_lines(i)%s)), '#include') == 1 .and. & + index(file_lines(i)%s, '"') > 0) then - if (pass == 2) then + n_include = n_include + 1 - c_source%include_dependencies(n_include)%s = & - & split_n(file_lines(i)%s,n=2,delims='"',stat=stat) - if (stat /= 0) then - call file_parse_error(error,c_filename, & - 'unable to get c include file',i, & - file_lines(i)%s,index(file_lines(i)%s,'"')) - return - end if - - end if + if (pass == 2) then + c_source%include_dependencies(n_include)%s = & + & split_n(file_lines(i)%s, n=2, delims='"', stat=stat) + if (stat /= 0) then + call file_parse_error(error, c_filename, & + 'unable to get c include file', i, & + file_lines(i)%s, index(file_lines(i)%s, '"')) + return end if - end do file_loop + end if - if (pass == 1) then - allocate(c_source%include_dependencies(n_include)) end if + end do file_loop + + if (pass == 1) then + allocate (c_source%include_dependencies(n_include)) + end if + end do -end function parse_c_source + end function parse_c_source !> Split a string on one or more delimeters !> and return the nth substring if it exists @@ -526,7 +525,7 @@ end function parse_c_source !> stat = 1 on return if the index !> is not found !> -function split_n(string,delims,n,stat) result(substring) + function split_n(string, delims, n, stat) result(substring) character(*), intent(in) :: string character(*), intent(in) :: delims @@ -537,32 +536,31 @@ function split_n(string,delims,n,stat) result(substring) integer :: i character(:), allocatable :: string_parts(:) - call split(string,string_parts,delims) + call split(string, string_parts, delims) - if (n<1) then - i = size(string_parts) + n - if (i < 1) then - stat = 1 - return - end if + if (n < 1) then + i = size(string_parts) + n + if (i < 1) then + stat = 1 + return + end if else - i = n + i = n end if - if (i>size(string_parts)) then - stat = 1 - return + if (i > size(string_parts)) then + stat = 1 + return end if substring = trim(adjustl(string_parts(i))) stat = 0 -end function split_n - + end function split_n !> Parse a subsequence of blank-separated tokens within a string !> (see parse_sequence) -function parse_subsequence(string,t1,t2,t3,t4) result(found) + function parse_subsequence(string, t1, t2, t3, t4) result(found) character(*), intent(in) :: string character(*), intent(in) :: t1 character(*), intent(in), optional :: t2, t3, t4 @@ -573,29 +571,29 @@ function parse_subsequence(string,t1,t2,t3,t4) result(found) found = .false. offset = 1 - do + do - i = index(string(offset:),t1) + i = index(string(offset:), t1) - if (i == 0) return + if (i == 0) return - offset = offset + i - 1 + offset = offset + i - 1 - found = parse_sequence(string(offset:),t1,t2,t3,t4) + found = parse_sequence(string(offset:), t1, t2, t3, t4) - if (found) return + if (found) return - offset = offset + len(t1) + offset = offset + len(t1) - if (offset > len(string)) return + if (offset > len(string)) return end do -end function parse_subsequence + end function parse_subsequence !> Helper utility to parse sequences of tokens !> that may be optionally separated by zero or more spaces -function parse_sequence(string,t1,t2,t3,t4) result(found) + function parse_sequence(string, t1, t2, t3, t4) result(found) character(*), intent(in) :: string character(*), intent(in) :: t1 character(*), intent(in), optional :: t2, t3, t4 @@ -608,50 +606,50 @@ function parse_sequence(string,t1,t2,t3,t4) result(found) found = .false. pos = 1 - do token_n=1,4 + do token_n = 1, 4 - do while (pos <= n) - if (string(pos:pos) /= ' ') then - exit - end if - pos = pos + 1 - end do - - select case(token_n) - case(1) - incr = len(t1) - if (pos+incr-1>n) return - match = string(pos:pos+incr-1) == t1 - case(2) - if (.not.present(t2)) exit - incr = len(t2) - if (pos+incr-1>n) return - match = string(pos:pos+incr-1) == t2 - case(3) - if (.not.present(t3)) exit - incr = len(t3) - if (pos+incr-1>n) return - match = string(pos:pos+incr-1) == t3 - case(4) - if (.not.present(t4)) exit - incr = len(t4) - if (pos+incr-1>n) return - match = string(pos:pos+incr-1) == t4 - case default - exit - end select - - if (.not.match) then - return + do while (pos <= n) + if (string(pos:pos) /= ' ') then + exit end if + pos = pos + 1 + end do + + select case (token_n) + case (1) + incr = len(t1) + if (pos + incr - 1 > n) return + match = string(pos:pos + incr - 1) == t1 + case (2) + if (.not. present(t2)) exit + incr = len(t2) + if (pos + incr - 1 > n) return + match = string(pos:pos + incr - 1) == t2 + case (3) + if (.not. present(t3)) exit + incr = len(t3) + if (pos + incr - 1 > n) return + match = string(pos:pos + incr - 1) == t3 + case (4) + if (.not. present(t4)) exit + incr = len(t4) + if (pos + incr - 1 > n) return + match = string(pos:pos + incr - 1) == t4 + case default + exit + end select + + if (.not. match) then + return + end if - pos = pos + incr + pos = pos + incr end do found = .true. -end function parse_sequence + end function parse_sequence end module fpm_source_parsing diff --git a/src/fpm_sources.f90 b/src/fpm_sources.f90 index 68251e59e5..3256ea9895 100644 --- a/src/fpm_sources.f90 +++ b/src/fpm_sources.f90 @@ -4,52 +4,52 @@ !> `[[srcfile_t]]` objects by looking for source files in the filesystem. !> module fpm_sources -use fpm_error, only: error_t -use fpm_model, only: srcfile_t, FPM_UNIT_PROGRAM -use fpm_filesystem, only: basename, canon_path, dirname, join_path, list_files, is_hidden_file -use fpm_strings, only: lower, str_ends_with, string_t, operator(.in.) -use fpm_source_parsing, only: parse_f_source, parse_c_source -use fpm_manifest_executable, only: executable_config_t -implicit none + use fpm_error, only: error_t + use fpm_model, only: srcfile_t, FPM_UNIT_PROGRAM + use fpm_filesystem, only: basename, canon_path, dirname, join_path, list_files, is_hidden_file + use fpm_strings, only: lower, str_ends_with, string_t, operator(.in.) + use fpm_source_parsing, only: parse_f_source, parse_c_source + use fpm_manifest_executable, only: executable_config_t + implicit none -private -public :: add_sources_from_dir, add_executable_sources + private + public :: add_sources_from_dir, add_executable_sources -character(4), parameter :: fortran_suffixes(2) = [".f90", & - ".f "] -character(4), parameter :: c_suffixes(4) = [".c ", ".h ", ".cpp", ".hpp"] + character(4), parameter :: fortran_suffixes(2) = [".f90", & + ".f "] + character(4), parameter :: c_suffixes(4) = [".c ", ".h ", ".cpp", ".hpp"] contains !> Wrapper to source parsing routines. !> Selects parsing routine based on source file name extension -function parse_source(source_file_path,error) result(source) + function parse_source(source_file_path, error) result(source) character(*), intent(in) :: source_file_path type(error_t), allocatable, intent(out) :: error type(srcfile_t) :: source if (str_ends_with(lower(source_file_path), fortran_suffixes)) then - source = parse_f_source(source_file_path, error) + source = parse_f_source(source_file_path, error) - if (source%unit_type == FPM_UNIT_PROGRAM) then - source%exe_name = basename(source_file_path,suffix=.false.) - end if + if (source%unit_type == FPM_UNIT_PROGRAM) then + source%exe_name = basename(source_file_path, suffix=.false.) + end if else if (str_ends_with(lower(source_file_path), c_suffixes)) then - source = parse_c_source(source_file_path,error) + source = parse_c_source(source_file_path, error) end if if (allocated(error)) then - return + return end if -end function parse_source + end function parse_source !> Add to `sources` by looking for source files in `directory` -subroutine add_sources_from_dir(sources,directory,scope,with_executables,recurse,error) + subroutine add_sources_from_dir(sources, directory, scope, with_executables, recurse, error) !> List of `[[srcfile_t]]` objects to append to. Allocated if not allocated type(srcfile_t), allocatable, intent(inout), target :: sources(:) !> Directory in which to search for source files @@ -74,60 +74,59 @@ subroutine add_sources_from_dir(sources,directory,scope,with_executables,recurse recurse_ = .true. if (present(recurse)) recurse_ = recurse ! Scan directory for sources - call list_files(directory, file_names,recurse=recurse_) + call list_files(directory, file_names, recurse=recurse_) if (allocated(sources)) then - allocate(existing_src_files(size(sources))) - do i=1,size(sources) - existing_src_files(i)%s = canon_path(sources(i)%file_name) - end do + allocate (existing_src_files(size(sources))) + do i = 1, size(sources) + existing_src_files(i)%s = canon_path(sources(i)%file_name) + end do else - allocate(existing_src_files(0)) + allocate (existing_src_files(0)) end if - is_source = [(.not.(is_hidden_file(basename(file_names(i)%s))) .and. & - .not.(canon_path(file_names(i)%s) .in. existing_src_files) .and. & - (str_ends_with(lower(file_names(i)%s), fortran_suffixes) .or. & - str_ends_with(lower(file_names(i)%s), c_suffixes) ),i=1,size(file_names))] - src_file_names = pack(file_names,is_source) + is_source = [(.not. (is_hidden_file(basename(file_names(i)%s))) .and. & + .not. (canon_path(file_names(i)%s) .in.existing_src_files) .and. & + (str_ends_with(lower(file_names(i)%s), fortran_suffixes) .or. & + str_ends_with(lower(file_names(i)%s), c_suffixes)), i=1, size(file_names))] + src_file_names = pack(file_names, is_source) - allocate(dir_sources(size(src_file_names))) - allocate(exclude_source(size(src_file_names))) + allocate (dir_sources(size(src_file_names))) + allocate (exclude_source(size(src_file_names))) do i = 1, size(src_file_names) - dir_sources(i) = parse_source(src_file_names(i)%s,error) - if (allocated(error)) return + dir_sources(i) = parse_source(src_file_names(i)%s, error) + if (allocated(error)) return - dir_sources(i)%unit_scope = scope - allocate(dir_sources(i)%link_libraries(0)) + dir_sources(i)%unit_scope = scope + allocate (dir_sources(i)%link_libraries(0)) - ! Exclude executables unless specified otherwise - exclude_source(i) = (dir_sources(i)%unit_type == FPM_UNIT_PROGRAM) - if (dir_sources(i)%unit_type == FPM_UNIT_PROGRAM .and. & - & present(with_executables)) then - if (with_executables) then + ! Exclude executables unless specified otherwise + exclude_source(i) = (dir_sources(i)%unit_type == FPM_UNIT_PROGRAM) + if (dir_sources(i)%unit_type == FPM_UNIT_PROGRAM .and. & + & present(with_executables)) then + if (with_executables) then - exclude_source(i) = .false. + exclude_source(i) = .false. - end if end if + end if end do - if (.not.allocated(sources)) then - sources = pack(dir_sources,.not.exclude_source) + if (.not. allocated(sources)) then + sources = pack(dir_sources,.not. exclude_source) else - sources = [sources, pack(dir_sources,.not.exclude_source)] + sources = [sources, pack(dir_sources,.not. exclude_source)] end if -end subroutine add_sources_from_dir - + end subroutine add_sources_from_dir !> Add to `sources` using the executable and test entries in the manifest and !> applies any executable-specific overrides such as `executable%name`. !> Adds all sources (including modules) from each `executable%source_dir` -subroutine add_executable_sources(sources,executables,scope,auto_discover,error) + subroutine add_executable_sources(sources, executables, scope, auto_discover, error) !> List of `[[srcfile_t]]` objects to append to. Allocated if not allocated type(srcfile_t), allocatable, intent(inout), target :: sources(:) !> List of `[[executable_config_t]]` entries from manifest @@ -144,64 +143,64 @@ subroutine add_executable_sources(sources,executables,scope,auto_discover,error) type(string_t), allocatable :: exe_dirs(:) type(srcfile_t) :: exe_source - call get_executable_source_dirs(exe_dirs,executables) + call get_executable_source_dirs(exe_dirs, executables) - do i=1,size(exe_dirs) - call add_sources_from_dir(sources,exe_dirs(i)%s, scope, & - with_executables=auto_discover, recurse=.false., error=error) + do i = 1, size(exe_dirs) + call add_sources_from_dir(sources, exe_dirs(i)%s, scope, & + with_executables=auto_discover, recurse=.false., error=error) - if (allocated(error)) then - return - end if + if (allocated(error)) then + return + end if end do - exe_loop: do i=1,size(executables) + exe_loop: do i = 1, size(executables) - ! Check if executable already discovered automatically - ! and apply any overrides - do j=1,size(sources) + ! Check if executable already discovered automatically + ! and apply any overrides + do j = 1, size(sources) - if (basename(sources(j)%file_name,suffix=.true.) == executables(i)%main .and.& - canon_path(dirname(sources(j)%file_name)) == & - canon_path(executables(i)%source_dir) ) then + if (basename(sources(j)%file_name, suffix=.true.) == executables(i)%main .and. & + canon_path(dirname(sources(j)%file_name)) == & + canon_path(executables(i)%source_dir)) then - sources(j)%exe_name = executables(i)%name - if (allocated(executables(i)%link)) then - sources(j)%link_libraries = executables(i)%link - end if - sources(j)%unit_type = FPM_UNIT_PROGRAM - cycle exe_loop + sources(j)%exe_name = executables(i)%name + if (allocated(executables(i)%link)) then + sources(j)%link_libraries = executables(i)%link + end if + sources(j)%unit_type = FPM_UNIT_PROGRAM + cycle exe_loop - end if + end if - end do + end do - ! Add if not already discovered (auto_discovery off) - associate(exe => executables(i)) - exe_source = parse_source(join_path(exe%source_dir,exe%main),error) - exe_source%exe_name = exe%name - if (allocated(exe%link)) then - exe_source%link_libraries = exe%link - end if - exe_source%unit_type = FPM_UNIT_PROGRAM - exe_source%unit_scope = scope - end associate + ! Add if not already discovered (auto_discovery off) + associate (exe => executables(i)) + exe_source = parse_source(join_path(exe%source_dir, exe%main), error) + exe_source%exe_name = exe%name + if (allocated(exe%link)) then + exe_source%link_libraries = exe%link + end if + exe_source%unit_type = FPM_UNIT_PROGRAM + exe_source%unit_scope = scope + end associate - if (allocated(error)) return + if (allocated(error)) return - if (.not.allocated(sources)) then - sources = [exe_source] - else - sources = [sources, exe_source] - end if + if (.not. allocated(sources)) then + sources = [exe_source] + else + sources = [sources, exe_source] + end if end do exe_loop -end subroutine add_executable_sources + end subroutine add_executable_sources !> Build a list of unique source directories !> from executables specified in manifest -subroutine get_executable_source_dirs(exe_dirs,executables) + subroutine get_executable_source_dirs(exe_dirs, executables) type(string_t), allocatable, intent(inout) :: exe_dirs(:) class(executable_config_t), intent(in) :: executables(:) @@ -211,25 +210,25 @@ subroutine get_executable_source_dirs(exe_dirs,executables) n = 0 - do i=1,size(executables) - dirs_temp(i)%s=' ' - enddo + do i = 1, size(executables) + dirs_temp(i)%s = ' ' + end do - do i=1,size(executables) - if (.not.(executables(i)%source_dir .in. dirs_temp)) then + do i = 1, size(executables) + if (.not. (executables(i)%source_dir.in.dirs_temp)) then - n = n + 1 - dirs_temp(n)%s = executables(i)%source_dir + n = n + 1 + dirs_temp(n)%s = executables(i)%source_dir - end if + end if end do - if (.not.allocated(exe_dirs)) then - exe_dirs = dirs_temp(1:n) + if (.not. allocated(exe_dirs)) then + exe_dirs = dirs_temp(1:n) else - exe_dirs = [exe_dirs,dirs_temp(1:n)] + exe_dirs = [exe_dirs, dirs_temp(1:n)] end if -end subroutine get_executable_source_dirs + end subroutine get_executable_source_dirs end module fpm_sources diff --git a/src/fpm_strings.f90 b/src/fpm_strings.f90 index 0bb764f019..d2a3849177 100644 --- a/src/fpm_strings.f90 +++ b/src/fpm_strings.f90 @@ -31,106 +31,106 @@ !! - [[RESIZE]] increase the size of a **TYPE(STRING_T)** array by N elements !! module fpm_strings -use iso_fortran_env, only: int64 -use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, & - & stdout=>output_unit, & - & stderr=>error_unit -use iso_c_binding, only: c_char, c_ptr, c_int, c_null_char, c_associated, c_f_pointer, c_size_t -implicit none - -private -public :: f_string, lower, split, str_ends_with, string_t, str_begins_with_str -public :: to_fortran_name, is_fortran_name -public :: string_array_contains, string_cat, len_trim, operator(.in.), fnv_1a -public :: replace, resize, str, join, glob -public :: notabs - -type string_t + use iso_fortran_env, only: int64 + use, intrinsic :: iso_fortran_env, only: stdin => input_unit, & + & stdout => output_unit, & + & stderr => error_unit + use iso_c_binding, only: c_char, c_ptr, c_int, c_null_char, c_associated, c_f_pointer, c_size_t + implicit none + + private + public :: f_string, lower, split, str_ends_with, string_t, str_begins_with_str + public :: to_fortran_name, is_fortran_name + public :: string_array_contains, string_cat, len_trim, operator(.in.), fnv_1a + public :: replace, resize, str, join, glob + public :: notabs + + type string_t character(len=:), allocatable :: s -end type + end type -interface len_trim + interface len_trim module procedure :: string_len_trim -end interface len_trim + end interface len_trim -interface resize - module procedure :: resize_string -end interface + interface resize + module procedure :: resize_string + end interface -interface operator(.in.) + interface operator(.in.) module procedure string_array_contains -end interface + end interface -interface fnv_1a + interface fnv_1a procedure :: fnv_1a_char procedure :: fnv_1a_string_t -end interface fnv_1a + end interface fnv_1a -interface str_ends_with + interface str_ends_with procedure :: str_ends_with_str procedure :: str_ends_with_any -end interface str_ends_with + end interface str_ends_with -interface str + interface str module procedure str_int, str_int64, str_logical -end interface + end interface -interface string_t + interface string_t module procedure new_string_t -end interface string_t + end interface string_t -interface f_string + interface f_string module procedure f_string, f_string_cptr, f_string_cptr_n -end interface f_string + end interface f_string contains !> test if a CHARACTER string ends with a specified suffix -pure logical function str_ends_with_str(s, e) result(r) + pure logical function str_ends_with_str(s, e) result(r) character(*), intent(in) :: s, e integer :: n1, n2 - n1 = len(s)-len(e)+1 + n1 = len(s) - len(e) + 1 n2 = len(s) if (n1 < 1) then - r = .false. + r = .false. else - r = (s(n1:n2) == e) + r = (s(n1:n2) == e) end if -end function str_ends_with_str + end function str_ends_with_str !> test if a CHARACTER string ends with any of an array of suffixs -pure logical function str_ends_with_any(s, e) result(r) + pure logical function str_ends_with_any(s, e) result(r) character(*), intent(in) :: s character(*), intent(in) :: e(:) integer :: i r = .true. - do i=1,size(e) + do i = 1, size(e) - if (str_ends_with(s,trim(e(i)))) return + if (str_ends_with(s, trim(e(i)))) return end do r = .false. -end function str_ends_with_any + end function str_ends_with_any !> test if a CHARACTER string begins with a specified prefix -pure logical function str_begins_with_str(s, e) result(r) + pure logical function str_begins_with_str(s, e) result(r) character(*), intent(in) :: s, e integer :: n1, n2 n1 = 1 - n2 = 1 + len(e)-1 + n2 = 1 + len(e) - 1 if (n2 > len(s)) then - r = .false. + r = .false. else - r = (s(n1:n2) == e) + r = (s(n1:n2) == e) end if -end function str_begins_with_str + end function str_begins_with_str !> return Fortran character variable when given a C-like array of !! single characters terminated with a C_NULL_CHAR character -function f_string(c_string) + function f_string(c_string) use iso_c_binding character(len=1), intent(in) :: c_string(:) character(:), allocatable :: f_string @@ -138,48 +138,47 @@ function f_string(c_string) integer :: i, n i = 0 - do while(c_string(i+1) /= C_NULL_CHAR) + do while (c_string(i + 1) /= C_NULL_CHAR) i = i + 1 end do n = i - allocate(character(n) :: f_string) - do i=1,n + allocate (character(n) :: f_string) + do i = 1, n f_string(i:i) = c_string(i) end do -end function f_string - + end function f_string !> return Fortran character variable when given a null-terminated c_ptr -function f_string_cptr(cptr) result(s) + function f_string_cptr(cptr) result(s) type(c_ptr), intent(in), value :: cptr - character(len=:,kind=c_char), allocatable :: s + character(len=:, kind=c_char), allocatable :: s interface - function c_strlen(s) result(r) bind(c, name="strlen") - import c_size_t, c_ptr - type(c_ptr), intent(in), value :: s - integer(kind=c_size_t) :: r - end function + function c_strlen(s) result(r) bind(c, name="strlen") + import c_size_t, c_ptr + type(c_ptr), intent(in), value :: s + integer(kind=c_size_t) :: r + end function end interface s = f_string_cptr_n(cptr, c_strlen(cptr)) -end function + end function !> return Fortran character variable when given a null-terminated c_ptr and its length -function f_string_cptr_n(cptr, n) result(s) + function f_string_cptr_n(cptr, n) result(s) type(c_ptr), intent(in), value :: cptr integer(kind=c_size_t), intent(in) :: n - character(len=n,kind=c_char) :: s - character(len=n,kind=c_char), pointer :: sptr + character(len=n, kind=c_char) :: s + character(len=n, kind=c_char), pointer :: sptr call c_f_pointer(cptr, sptr) s = sptr -end function + end function !> Hash a character(*) string of default kind -pure function fnv_1a_char(input, seed) result(hash) + pure function fnv_1a_char(input, seed) result(hash) character(*), intent(in) :: input integer(int64), intent(in), optional :: seed integer(int64) :: hash @@ -189,93 +188,91 @@ pure function fnv_1a_char(input, seed) result(hash) integer(int64), parameter :: FNV_PRIME_32 = 16777619_int64 if (present(seed)) then - hash = seed + hash = seed else - hash = FNV_OFFSET_32 + hash = FNV_OFFSET_32 end if - do i=1,len(input) - hash = ieor(hash,iachar(input(i:i),int64)) * FNV_PRIME_32 + do i = 1, len(input) + hash = ieor(hash, iachar(input(i:i), int64))*FNV_PRIME_32 end do -end function fnv_1a_char - + end function fnv_1a_char !> Hash a string_t array of default kind -pure function fnv_1a_string_t(input, seed) result(hash) + 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) + hash = fnv_1a(input(1)%s, seed) - do i=2,size(input) - hash = fnv_1a(input(i)%s,hash) + do i = 2, size(input) + hash = fnv_1a(input(i)%s, hash) end do -end function fnv_1a_string_t - + end function fnv_1a_string_t - !>Author: John S. Urban + !>Author: John S. Urban !!License: Public Domain !! Changes a string to lowercase over optional specified column range -elemental pure function lower(str,begin,end) result (string) + elemental pure function lower(str, begin, end) result(string) character(*), intent(In) :: str character(len(str)) :: string - integer,intent(in),optional :: begin, end + integer, intent(in), optional :: begin, end integer :: i integer :: ibegin, iend string = str ibegin = 1 - if (present(begin))then - ibegin = max(ibegin,begin) - endif + if (present(begin)) then + ibegin = max(ibegin, begin) + end if iend = len_trim(str) - if (present(end))then - iend= min(iend,end) - endif + if (present(end)) then + iend = min(iend, end) + end if do i = ibegin, iend ! step thru each letter in the string in specified range - select case (str(i:i)) - case ('A':'Z') - string(i:i) = char(iachar(str(i:i))+32) ! change letter to miniscule - case default - end select + select case (str(i:i)) + case ('A':'Z') + string(i:i) = char(iachar(str(i:i)) + 32) ! change letter to miniscule + case default + end select end do -end function lower + end function lower !> Helper function to generate a new string_t instance !> (Required due to the allocatable component) -function new_string_t(s) result(string) + function new_string_t(s) result(string) character(*), intent(in) :: s type(string_t) :: string string%s = s -end function new_string_t + end function new_string_t !> Check if array of TYPE(STRING_T) matches a particular CHARACTER string !! -logical function string_array_contains(search_string,array) + logical function string_array_contains(search_string, array) character(*), intent(in) :: search_string type(string_t), intent(in) :: array(:) integer :: i - string_array_contains = any([(array(i)%s==search_string, & - i=1,size(array))]) + string_array_contains = any([(array(i)%s == search_string, & + i=1, size(array))]) -end function string_array_contains + end function string_array_contains !> Concatenate an array of type(string_t) into !> a single CHARACTER variable -function string_cat(strings,delim) result(cat) + function string_cat(strings, delim) result(cat) type(string_t), intent(in) :: strings(:) character(*), intent(in), optional :: delim character(:), allocatable :: cat @@ -284,61 +281,61 @@ function string_cat(strings,delim) result(cat) character(:), allocatable :: delim_str if (size(strings) < 1) then - cat = '' - return + cat = '' + return end if if (present(delim)) then - delim_str = delim + delim_str = delim else - delim_str = '' + delim_str = '' end if cat = strings(1)%s - do i=2,size(strings) + do i = 2, size(strings) - cat = cat//delim_str//strings(i)%s + cat = cat//delim_str//strings(i)%s end do -end function string_cat + end function string_cat !> Determine total trimmed length of `string_t` array -pure function string_len_trim(strings) result(n) + pure function string_len_trim(strings) result(n) type(string_t), intent(in) :: strings(:) integer :: i, n n = 0 - do i=1,size(strings) - n = n + len_trim(strings(i)%s) + do i = 1, size(strings) + n = n + len_trim(strings(i)%s) end do -end function string_len_trim + end function string_len_trim !>Author: John S. Urban !!License: Public Domain !! parse string on delimiter characters and store tokens into an allocatable array -subroutine split(input_line,array,delimiters,order,nulls) + subroutine split(input_line, array, delimiters, order, nulls) !! given a line of structure " par1 par2 par3 ... parn " store each par(n) into a separate variable in array. !! !! * by default adjacent delimiters in the input string do not create an empty string in the output array !! * no quoting of delimiters is supported - character(len=*),intent(in) :: input_line !! input string to tokenize - character(len=*),optional,intent(in) :: delimiters !! list of delimiter characters - character(len=*),optional,intent(in) :: order !! order of output array sequential|[reverse|right] - character(len=*),optional,intent(in) :: nulls !! return strings composed of delimiters or not ignore|return|ignoreend - character(len=:),allocatable,intent(out) :: array(:) !! output array of tokens + character(len=*), intent(in) :: input_line !! input string to tokenize + character(len=*), optional, intent(in) :: delimiters !! list of delimiter characters + character(len=*), optional, intent(in) :: order !! order of output array sequential|[reverse|right] + character(len=*), optional, intent(in) :: nulls !! return strings composed of delimiters or not ignore|return|ignoreend + character(len=:), allocatable, intent(out) :: array(:) !! output array of tokens integer :: n ! max number of strings INPUT_LINE could split into if all delimiter - integer,allocatable :: ibegin(:) ! positions in input string where tokens start - integer,allocatable :: iterm(:) ! positions in input string where tokens end - character(len=:),allocatable :: dlim ! string containing delimiter characters - character(len=:),allocatable :: ordr ! string containing order keyword - character(len=:),allocatable :: nlls ! string containing nulls keyword - integer :: ii,iiii ! loop parameters used to control print order + integer, allocatable :: ibegin(:) ! positions in input string where tokens start + integer, allocatable :: iterm(:) ! positions in input string where tokens end + character(len=:), allocatable :: dlim ! string containing delimiter characters + character(len=:), allocatable :: ordr ! string containing order keyword + character(len=:), allocatable :: nlls ! string containing nulls keyword + integer :: ii, iiii ! loop parameters used to control print order integer :: icount ! number of tokens found integer :: ilen ! length of input string with trailing spaces trimmed - integer :: i10,i20,i30 ! loop counters + integer :: i10, i20, i30 ! loop counters integer :: icol ! pointer into input string as it is being parsed integer :: idlim ! number of delimiter characters integer :: ifound ! where next delimiter character is found in remaining input string data @@ -348,139 +345,139 @@ subroutine split(input_line,array,delimiters,order,nulls) ! decide on value for optional DELIMITERS parameter if (present(delimiters)) then ! optional delimiter list was present - if(delimiters/='')then ! if DELIMITERS was specified and not null use it - dlim=delimiters - else ! DELIMITERS was specified on call as empty string - dlim=' '//char(9)//char(10)//char(11)//char(12)//char(13)//char(0) ! use default delimiter when not specified - endif + if (delimiters /= '') then ! if DELIMITERS was specified and not null use it + dlim = delimiters + else ! DELIMITERS was specified on call as empty string + dlim = ' '//char(9)//char(10)//char(11)//char(12)//char(13)//char(0) ! use default delimiter when not specified + end if else ! no delimiter value was specified - dlim=' '//char(9)//char(10)//char(11)//char(12)//char(13)//char(0) ! use default delimiter when not specified - endif - idlim=len(dlim) ! dlim a lot of blanks on some machines if dlim is a big string + dlim = ' '//char(9)//char(10)//char(11)//char(12)//char(13)//char(0) ! use default delimiter when not specified + end if + idlim = len(dlim) ! dlim a lot of blanks on some machines if dlim is a big string - if(present(order))then; ordr=lower(adjustl(order)); else; ordr='sequential'; endif ! decide on value for optional ORDER parameter - if(present(nulls))then; nlls=lower(adjustl(nulls)); else; nlls='ignore' ; endif ! optional parameter + if (present(order)) then; ordr = lower(adjustl(order)); else; ordr = 'sequential'; end if ! decide on value for optional ORDER parameter + if (present(nulls)) then; nlls = lower(adjustl(nulls)); else; nlls = 'ignore'; end if ! optional parameter - n=len(input_line)+1 ! max number of strings INPUT_LINE could split into if all delimiter - allocate(ibegin(n)) ! allocate enough space to hold starting location of tokens if string all tokens - allocate(iterm(n)) ! allocate enough space to hold ending location of tokens if string all tokens - ibegin(:)=1 - iterm(:)=1 + n = len(input_line) + 1 ! max number of strings INPUT_LINE could split into if all delimiter + allocate (ibegin(n)) ! allocate enough space to hold starting location of tokens if string all tokens + allocate (iterm(n)) ! allocate enough space to hold ending location of tokens if string all tokens + ibegin(:) = 1 + iterm(:) = 1 - ilen=len(input_line) ! ILEN is the column position of the last non-blank character - icount=0 ! how many tokens found - inotnull=0 ! how many tokens found not composed of delimiters - imax=0 ! length of longest token found + ilen = len(input_line) ! ILEN is the column position of the last non-blank character + icount = 0 ! how many tokens found + inotnull = 0 ! how many tokens found not composed of delimiters + imax = 0 ! length of longest token found select case (ilen) case (0) ! command was totally blank case default ! there is at least one non-delimiter in INPUT_LINE if get here - icol=1 ! initialize pointer into input line - INFINITE: do i30=1,ilen,1 ! store into each array element - ibegin(i30)=icol ! assume start new token on the character - if(index(dlim(1:idlim),input_line(icol:icol))==0)then ! if current character is not a delimiter - iterm(i30)=ilen ! initially assume no more tokens - do i10=1,idlim ! search for next delimiter - ifound=index(input_line(ibegin(i30):ilen),dlim(i10:i10)) - IF(ifound>0)then - iterm(i30)=min(iterm(i30),ifound+ibegin(i30)-2) - endif - enddo - icol=iterm(i30)+2 ! next place to look as found end of this token - inotnull=inotnull+1 ! increment count of number of tokens not composed of delimiters - else ! character is a delimiter for a null string - iterm(i30)=icol-1 ! record assumed end of string. Will be less than beginning - icol=icol+1 ! advance pointer into input string - endif - imax=max(imax,iterm(i30)-ibegin(i30)+1) - icount=i30 ! increment count of number of tokens found - if(icol>ilen)then ! no text left - exit INFINITE - endif - enddo INFINITE + icol = 1 ! initialize pointer into input line + INFINITE: do i30 = 1, ilen, 1 ! store into each array element + ibegin(i30) = icol ! assume start new token on the character + if (index(dlim(1:idlim), input_line(icol:icol)) == 0) then ! if current character is not a delimiter + iterm(i30) = ilen ! initially assume no more tokens + do i10 = 1, idlim ! search for next delimiter + ifound = index(input_line(ibegin(i30):ilen), dlim(i10:i10)) + IF (ifound > 0) then + iterm(i30) = min(iterm(i30), ifound + ibegin(i30) - 2) + end if + end do + icol = iterm(i30) + 2 ! next place to look as found end of this token + inotnull = inotnull + 1 ! increment count of number of tokens not composed of delimiters + else ! character is a delimiter for a null string + iterm(i30) = icol - 1 ! record assumed end of string. Will be less than beginning + icol = icol + 1 ! advance pointer into input string + end if + imax = max(imax, iterm(i30) - ibegin(i30) + 1) + icount = i30 ! increment count of number of tokens found + if (icol > ilen) then ! no text left + exit INFINITE + end if + end do INFINITE end select select case (trim(adjustl(nlls))) - case ('ignore','','ignoreend') - ireturn=inotnull + case ('ignore', '', 'ignoreend') + ireturn = inotnull case default - ireturn=icount + ireturn = icount end select - allocate(character(len=imax) :: array(ireturn)) ! allocate the array to return + allocate (character(len=imax) :: array(ireturn)) ! allocate the array to return !allocate(array(ireturn)) ! allocate the array to turn select case (trim(adjustl(ordr))) ! decide which order to store tokens - case ('reverse','right') ; ii=ireturn ; iiii=-1 ! last to first - case default ; ii=1 ; iiii=1 ! first to last + case ('reverse', 'right'); ii = ireturn; iiii = -1 ! last to first + case default; ii = 1; iiii = 1 ! first to last end select - do i20=1,icount ! fill the array with the tokens that were found - if(iterm(i20) Returns string with characters in charset replaced with target_char. -pure function replace(string, charset, target_char) result(res) + pure function replace(string, charset, target_char) result(res) character(*), intent(in) :: string character, intent(in) :: charset(:), target_char character(len(string)) :: res integer :: n res = string do n = 1, len(string) - if (any(string(n:n) == charset)) then - res(n:n) = target_char - end if + if (any(string(n:n) == charset)) then + res(n:n) = target_char + end if end do -end function replace + end function replace !> increase the size of a TYPE(STRING_T) array by N elements -subroutine resize_string(list, n) - !> Instance of the array to be resized - type(string_t), allocatable, intent(inout) :: list(:) - !> Dimension of the final array size - integer, intent(in), optional :: n - - type(string_t), allocatable :: tmp(:) - integer :: this_size, new_size, i - integer, parameter :: initial_size = 16 - - if (allocated(list)) then - this_size = size(list, 1) - call move_alloc(list, tmp) - else - this_size = initial_size - end if - - if (present(n)) then - new_size = n - else - new_size = this_size + this_size/2 + 1 - end if - - allocate(list(new_size)) - - if (allocated(tmp)) then - this_size = min(size(tmp, 1), size(list, 1)) - do i = 1, this_size - call move_alloc(tmp(i)%s, list(i)%s) - end do - deallocate(tmp) - end if + subroutine resize_string(list, n) + !> Instance of the array to be resized + type(string_t), allocatable, intent(inout) :: list(:) + !> Dimension of the final array size + integer, intent(in), optional :: n + + type(string_t), allocatable :: tmp(:) + integer :: this_size, new_size, i + integer, parameter :: initial_size = 16 + + if (allocated(list)) then + this_size = size(list, 1) + call move_alloc(list, tmp) + else + this_size = initial_size + end if + + if (present(n)) then + new_size = n + else + new_size = this_size + this_size/2 + 1 + end if -end subroutine resize_string + allocate (list(new_size)) + + if (allocated(tmp)) then + this_size = min(size(tmp, 1), size(list, 1)) + do i = 1, this_size + call move_alloc(tmp(i)%s, list(i)%s) + end do + deallocate (tmp) + end if + + end subroutine resize_string !>AUTHOR: John S. Urban !!LICENSE: Public Domain @@ -558,41 +555,41 @@ end subroutine resize_string !! [United];[ we];[ stand,];[ divided];[ we fall.] !! [United][ we][ stand,][ divided][ we fall.] !! >>United>> we>> stand,>> divided>> we fall. -pure function join(str,sep,trm,left,right,start,end) result (string) + pure function join(str, sep, trm, left, right, start, end) result(string) ! @(#)M_strings::join(3f): merge string array into a single CHARACTER value adding specified separators, caps, prefix and suffix -character(len=*),intent(in) :: str(:) -character(len=*),intent(in),optional :: sep, right, left, start, end -logical,intent(in),optional :: trm -character(len=:),allocatable :: sep_local, left_local, right_local -character(len=:),allocatable :: string -logical :: trm_local -integer :: i - if(present(sep))then ; sep_local=sep ; else ; sep_local='' ; endif - if(present(trm))then ; trm_local=trm ; else ; trm_local=.true. ; endif - if(present(left))then ; left_local=left ; else ; left_local='' ; endif - if(present(right))then ; right_local=right ; else ; right_local='' ; endif - string='' - if(size(str)==0)then - string=string//left_local//right_local - else - do i = 1,size(str)-1 - if(trm_local)then - string=string//left_local//trim(str(i))//right_local//sep_local - else - string=string//left_local//str(i)//right_local//sep_local - endif - enddo - if(trm_local)then - string=string//left_local//trim(str(i))//right_local + character(len=*), intent(in) :: str(:) + character(len=*), intent(in), optional :: sep, right, left, start, end + logical, intent(in), optional :: trm + character(len=:), allocatable :: sep_local, left_local, right_local + character(len=:), allocatable :: string + logical :: trm_local + integer :: i + if (present(sep)) then; sep_local = sep; else; sep_local = ''; end if + if (present(trm)) then; trm_local = trm; else; trm_local = .true.; end if + if (present(left)) then; left_local = left; else; left_local = ''; end if + if (present(right)) then; right_local = right; else; right_local = ''; end if + string = '' + if (size(str) == 0) then + string = string//left_local//right_local + else + do i = 1, size(str) - 1 + if (trm_local) then + string = string//left_local//trim(str(i))//right_local//sep_local + else + string = string//left_local//str(i)//right_local//sep_local + end if + end do + if (trm_local) then + string = string//left_local//trim(str(i))//right_local else - string=string//left_local//str(i)//right_local - endif - endif - if(present(start))string=start//string - if(present(end))string=string//end -end function join + string = string//left_local//str(i)//right_local + end if + end if + if (present(start)) string = start//string + if (present(end)) string = string//end + end function join !>##AUTHOR John S. Urban !!##LICENSE Public Domain @@ -825,185 +822,185 @@ end function join !! The article "Matching Wildcards: An Empirical Way to Tame an Algorithm" !! in Dr Dobb's Journal, By Kirk J. Krauss, October 07, 2014 !! -function glob(tame,wild) + function glob(tame, wild) ! @(#)fpm_strings::glob(3f): function compares text strings, one of which can have wildcards ('*' or '?'). -logical :: glob !! result of test -character(len=*) :: tame !! A string without wildcards to compare to the globbing expression -character(len=*) :: wild !! A (potentially) corresponding string with wildcards -character(len=len(tame)+1) :: tametext -character(len=len(wild)+1) :: wildtext -character(len=1),parameter :: NULL=char(0) -integer :: wlen -integer :: ti, wi -integer :: i -character(len=:),allocatable :: tbookmark, wbookmark + logical :: glob !! result of test + character(len=*) :: tame !! A string without wildcards to compare to the globbing expression + character(len=*) :: wild !! A (potentially) corresponding string with wildcards + character(len=len(tame) + 1) :: tametext + character(len=len(wild) + 1) :: wildtext + character(len=1), parameter :: NULL = char(0) + integer :: wlen + integer :: ti, wi + integer :: i + character(len=:), allocatable :: tbookmark, wbookmark ! These two values are set when we observe a wildcard character. They ! represent the locations, in the two strings, from which we start once we've observed it. - tametext=tame//NULL - wildtext=wild//NULL - tbookmark = NULL - wbookmark = NULL - wlen=len(wild) - wi=1 - ti=1 - do ! Walk the text strings one character at a time. - if(wildtext(wi:wi) == '*')then ! How do you match a unique text string? - do i=wi,wlen ! Easy: unique up on it! - if(wildtext(wi:wi)=='*')then - wi=wi+1 + tametext = tame//NULL + wildtext = wild//NULL + tbookmark = NULL + wbookmark = NULL + wlen = len(wild) + wi = 1 + ti = 1 + do ! Walk the text strings one character at a time. + if (wildtext(wi:wi) == '*') then ! How do you match a unique text string? + do i = wi, wlen ! Easy: unique up on it! + if (wildtext(wi:wi) == '*') then + wi = wi + 1 + else + exit + end if + end do + if (wildtext(wi:wi) == NULL) then ! "x" matches "*" + glob = .true. + return + end if + if (wildtext(wi:wi) /= '?') then + ! Fast-forward to next possible match. + do while (tametext(ti:ti) /= wildtext(wi:wi)) + ti = ti + 1 + if (tametext(ti:ti) == NULL) then + glob = .false. + return ! "x" doesn't match "*y*" + end if + end do + end if + wbookmark = wildtext(wi:) + tbookmark = tametext(ti:) + elseif (tametext(ti:ti) /= wildtext(wi:wi) .and. wildtext(wi:wi) /= '?') then + ! Got a non-match. If we've set our bookmarks, back up to one or both of them and retry. + if (wbookmark /= NULL) then + if (wildtext(wi:) /= wbookmark) then + wildtext = wbookmark; + wlen = len_trim(wbookmark) + wi = 1 + ! Don't go this far back again. + if (tametext(ti:ti) /= wildtext(wi:wi)) then + tbookmark = tbookmark(2:) + tametext = tbookmark + ti = 1 + cycle ! "xy" matches "*y" else - exit - endif - enddo - if(wildtext(wi:wi)==NULL) then ! "x" matches "*" - glob=.true. - return - endif - if(wildtext(wi:wi) /= '?') then - ! Fast-forward to next possible match. - do while (tametext(ti:ti) /= wildtext(wi:wi)) - ti=ti+1 - if (tametext(ti:ti)==NULL)then - glob=.false. - return ! "x" doesn't match "*y*" - endif - enddo - endif - wbookmark = wildtext(wi:) - tbookmark = tametext(ti:) - elseif(tametext(ti:ti) /= wildtext(wi:wi) .and. wildtext(wi:wi) /= '?') then - ! Got a non-match. If we've set our bookmarks, back up to one or both of them and retry. - if(wbookmark/=NULL) then - if(wildtext(wi:)/= wbookmark) then - wildtext = wbookmark; - wlen=len_trim(wbookmark) - wi=1 - ! Don't go this far back again. - if (tametext(ti:ti) /= wildtext(wi:wi)) then - tbookmark=tbookmark(2:) - tametext = tbookmark - ti=1 - cycle ! "xy" matches "*y" - else - wi=wi+1 - endif - endif - if (tametext(ti:ti)/=NULL) then - ti=ti+1 - cycle ! "mississippi" matches "*sip*" - endif - endif - glob=.false. - return ! "xy" doesn't match "x" - endif - ti=ti+1 - wi=wi+1 - if (tametext(ti:ti)==NULL) then ! How do you match a tame text string? - if(wildtext(wi:wi)/=NULL)then - do while (wildtext(wi:wi) == '*') ! The tame way: unique up on it! - wi=wi+1 ! "x" matches "x*" - if(wildtext(wi:wi)==NULL)exit - enddo - endif - if (wildtext(wi:wi)==NULL)then - glob=.true. - return ! "x" matches "x" - endif - glob=.false. - return ! "x" doesn't match "xy" - endif - enddo -end function glob + wi = wi + 1 + end if + end if + if (tametext(ti:ti) /= NULL) then + ti = ti + 1 + cycle ! "mississippi" matches "*sip*" + end if + end if + glob = .false. + return ! "xy" doesn't match "x" + end if + ti = ti + 1 + wi = wi + 1 + if (tametext(ti:ti) == NULL) then ! How do you match a tame text string? + if (wildtext(wi:wi) /= NULL) then + do while (wildtext(wi:wi) == '*') ! The tame way: unique up on it! + wi = wi + 1 ! "x" matches "x*" + if (wildtext(wi:wi) == NULL) exit + end do + end if + if (wildtext(wi:wi) == NULL) then + glob = .true. + return ! "x" matches "x" + end if + glob = .false. + return ! "x" doesn't match "xy" + end if + end do + end function glob !> Returns the length of the string representation of 'i' -pure integer function str_int_len(i) result(sz) -integer, intent(in) :: i -integer, parameter :: MAX_STR = 100 -character(MAX_STR) :: s + pure integer function str_int_len(i) result(sz) + integer, intent(in) :: i + integer, parameter :: MAX_STR = 100 + character(MAX_STR) :: s ! If 's' is too short (MAX_STR too small), Fortran will abort with: ! "Fortran runtime error: End of record" -write(s, '(i0)') i -sz = len_trim(s) -end function + write (s, '(i0)') i + sz = len_trim(s) + end function !> Converts integer "i" to string -pure function str_int(i) result(s) -integer, intent(in) :: i -character(len=str_int_len(i)) :: s -write(s, '(i0)') i -end function + pure function str_int(i) result(s) + integer, intent(in) :: i + character(len=str_int_len(i)) :: s + write (s, '(i0)') i + end function !> Returns the length of the string representation of 'i' -pure integer function str_int64_len(i) result(sz) -integer(int64), intent(in) :: i -integer, parameter :: MAX_STR = 100 -character(MAX_STR) :: s + pure integer function str_int64_len(i) result(sz) + integer(int64), intent(in) :: i + integer, parameter :: MAX_STR = 100 + character(MAX_STR) :: s ! If 's' is too short (MAX_STR too small), Fortran will abort with: ! "Fortran runtime error: End of record" -write(s, '(i0)') i -sz = len_trim(s) -end function + write (s, '(i0)') i + sz = len_trim(s) + end function !> Converts integer "i" to string -pure function str_int64(i) result(s) -integer(int64), intent(in) :: i -character(len=str_int64_len(i)) :: s -write(s, '(i0)') i -end function + pure function str_int64(i) result(s) + integer(int64), intent(in) :: i + character(len=str_int64_len(i)) :: s + write (s, '(i0)') i + end function !> Returns the length of the string representation of 'l' -pure integer function str_logical_len(l) result(sz) -logical, intent(in) :: l -if (l) then - sz = 6 -else - sz = 7 -end if -end function + pure integer function str_logical_len(l) result(sz) + logical, intent(in) :: l + if (l) then + sz = 6 + else + sz = 7 + end if + end function !> Converts logical "l" to string -pure function str_logical(l) result(s) -logical, intent(in) :: l -character(len=str_logical_len(l)) :: s -if (l) then - s = ".true." -else - s = ".false." -end if -end function + pure function str_logical(l) result(s) + logical, intent(in) :: l + character(len=str_logical_len(l)) :: s + if (l) then + s = ".true." + else + s = ".false." + end if + end function !> Returns string with special characters replaced with an underscore. !! For now, only a hyphen is treated as a special character, but this can be !! expanded to other characters if needed. -pure function to_fortran_name(string) result(res) + pure function to_fortran_name(string) result(res) character(*), intent(in) :: string character(len(string)) :: res character, parameter :: SPECIAL_CHARACTERS(*) = ['-'] res = replace(string, SPECIAL_CHARACTERS, '_') -end function to_fortran_name + end function to_fortran_name -function is_fortran_name(line) result (lout) + function is_fortran_name(line) result(lout) ! determine if a string is a valid Fortran name ignoring trailing spaces ! (but not leading spaces) - character(len=*),parameter :: int='0123456789' - character(len=*),parameter :: lower='abcdefghijklmnopqrstuvwxyz' - character(len=*),parameter :: upper='ABCDEFGHIJKLMNOPQRSTUVWXYZ' - character(len=*),parameter :: allowed=upper//lower//int//'_' - character(len=*),intent(in) :: line - character(len=:),allocatable :: name + character(len=*), parameter :: int = '0123456789' + character(len=*), parameter :: lower = 'abcdefghijklmnopqrstuvwxyz' + character(len=*), parameter :: upper = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' + character(len=*), parameter :: allowed = upper//lower//int//'_' + character(len=*), intent(in) :: line + character(len=:), allocatable :: name logical :: lout - name=trim(line) - if(len(name)/=0)then - lout = .true. & - & .and. verify(name(1:1), lower//upper) == 0 & - & .and. verify(name,allowed) == 0 & - & .and. len(name) <= 63 - else - lout = .false. - endif - end function is_fortran_name + name = trim(line) + if (len(name) /= 0) then + lout = .true. & + & .and. verify(name(1:1), lower//upper) == 0 & + & .and. verify(name, allowed) == 0 & + & .and. len(name) <= 63 + else + lout = .false. + end if + end function is_fortran_name !> !!### NAME !! notabs(3f) - [fpm_strings:NONALPHA] expand tab characters @@ -1066,50 +1063,50 @@ end function is_fortran_name !! !!### LICENSE !! Public Domain -elemental impure subroutine notabs(instr,outstr,ilen) + elemental impure subroutine notabs(instr, outstr, ilen) ! ident_31="@(#)fpm_strings::notabs(3f): convert tabs to spaces while maintaining columns, remove CRLF chars" -character(len=*),intent(in) :: instr ! input line to scan for tab characters -character(len=*),intent(out) :: outstr ! tab-expanded version of INSTR produced -integer,intent(out) :: ilen ! column position of last character put into output string - ! that is, ILEN holds the position of the last non-blank character in OUTSTR - -integer,parameter :: tabsize=8 ! assume a tab stop is set every 8th column -integer :: ipos ! position in OUTSTR to put next character of INSTR -integer :: lenin ! length of input string trimmed of trailing spaces -integer :: lenout ! number of characters output string can hold -integer :: istep ! counter that advances thru input string INSTR one character at a time -character(len=1) :: c ! character in input line being processed -integer :: iade ! ADE (ASCII Decimal Equivalent) of character being tested - - ipos=1 ! where to put next character in output string OUTSTR - lenin=len_trim(instr( 1:len(instr) )) ! length of INSTR trimmed of trailing spaces - lenout=len(outstr) ! number of characters output string OUTSTR can hold - outstr=" " ! this SHOULD blank-fill string, a buggy machine required a loop to set all characters - - SCAN_LINE: do istep=1,lenin ! look through input string one character at a time - c=instr(istep:istep) ! get next character - iade=ichar(c) ! get ADE of the character - EXPAND_TABS : select case (iade) ! take different actions depending on which character was found - case(9) ! test if character is a tab and move pointer out to appropriate column - ipos = ipos + (tabsize - (mod(ipos-1,tabsize))) - case(10,13) ! convert carriage-return and new-line to space ,typically to handle DOS-format files - ipos=ipos+1 - case default ! c is anything else other than a tab,newline,or return insert it in output string - if(ipos > lenout)then - write(stderr,*)"*notabs* output string overflow" - exit - else - outstr(ipos:ipos)=c - ipos=ipos+1 - endif - end select EXPAND_TABS - enddo SCAN_LINE + character(len=*), intent(in) :: instr ! input line to scan for tab characters + character(len=*), intent(out) :: outstr ! tab-expanded version of INSTR produced + integer, intent(out) :: ilen ! column position of last character put into output string + ! that is, ILEN holds the position of the last non-blank character in OUTSTR + + integer, parameter :: tabsize = 8 ! assume a tab stop is set every 8th column + integer :: ipos ! position in OUTSTR to put next character of INSTR + integer :: lenin ! length of input string trimmed of trailing spaces + integer :: lenout ! number of characters output string can hold + integer :: istep ! counter that advances thru input string INSTR one character at a time + character(len=1) :: c ! character in input line being processed + integer :: iade ! ADE (ASCII Decimal Equivalent) of character being tested + + ipos = 1 ! where to put next character in output string OUTSTR + lenin = len_trim(instr(1:len(instr))) ! length of INSTR trimmed of trailing spaces + lenout = len(outstr) ! number of characters output string OUTSTR can hold + outstr = " " ! this SHOULD blank-fill string, a buggy machine required a loop to set all characters + + SCAN_LINE: do istep = 1, lenin ! look through input string one character at a time + c = instr(istep:istep) ! get next character + iade = ichar(c) ! get ADE of the character + EXPAND_TABS:select case(iade) ! take different actions depending on which character was found + case (9) ! test if character is a tab and move pointer out to appropriate column + ipos = ipos + (tabsize - (mod(ipos - 1, tabsize))) + case (10, 13) ! convert carriage-return and new-line to space ,typically to handle DOS-format files + ipos = ipos + 1 + case default ! c is anything else other than a tab,newline,or return insert it in output string + if (ipos > lenout) then + write (stderr, *) "*notabs* output string overflow" + exit + else + outstr(ipos:ipos) = c + ipos = ipos + 1 + end if + end select EXPAND_TABS + end do SCAN_LINE - ipos=min(ipos,lenout) ! tabs or newline or return characters or last character might have gone too far - ilen=len_trim(outstr(:ipos)) ! trim trailing spaces + ipos = min(ipos, lenout) ! tabs or newline or return characters or last character might have gone too far + ilen = len_trim(outstr(:ipos)) ! trim trailing spaces -end subroutine notabs + end subroutine notabs end module fpm_strings diff --git a/src/fpm_targets.f90 b/src/fpm_targets.f90 index c01cd4ee15..9544366abd 100644 --- a/src/fpm_targets.f90 +++ b/src/fpm_targets.f90 @@ -24,50 +24,47 @@ !> Describes the type of build target — determines backend build rules !> module fpm_targets -use iso_fortran_env, only: int64 -use fpm_error, only: error_t, fatal_error, fpm_stop -use fpm_model -use fpm_environment, only: get_os_type, OS_WINDOWS, OS_MACOS -use fpm_filesystem, only: dirname, join_path, canon_path -use fpm_strings, only: string_t, operator(.in.), string_cat, fnv_1a, resize, lower, str_ends_with -use fpm_compiler, only: get_macros -implicit none - -private - -public FPM_TARGET_UNKNOWN, FPM_TARGET_EXECUTABLE, & - FPM_TARGET_ARCHIVE, FPM_TARGET_OBJECT, & - FPM_TARGET_C_OBJECT, FPM_TARGET_CPP_OBJECT -public build_target_t, build_target_ptr -public targets_from_sources, resolve_module_dependencies -public resolve_target_linking, add_target, add_dependency -public filter_library_targets, filter_executable_targets, filter_modules - - + use iso_fortran_env, only: int64 + use fpm_error, only: error_t, fatal_error, fpm_stop + use fpm_model + use fpm_environment, only: get_os_type, OS_WINDOWS, OS_MACOS + use fpm_filesystem, only: dirname, join_path, canon_path + use fpm_strings, only: string_t, operator(.in.), string_cat, fnv_1a, resize, lower, str_ends_with + use fpm_compiler, only: get_macros + implicit none + + private + + public FPM_TARGET_UNKNOWN, FPM_TARGET_EXECUTABLE, & + FPM_TARGET_ARCHIVE, FPM_TARGET_OBJECT, & + FPM_TARGET_C_OBJECT, FPM_TARGET_CPP_OBJECT + public build_target_t, build_target_ptr + public targets_from_sources, resolve_module_dependencies + public resolve_target_linking, add_target, add_dependency + public filter_library_targets, filter_executable_targets, filter_modules !> Target type is unknown (ignored) -integer, parameter :: FPM_TARGET_UNKNOWN = -1 + integer, parameter :: FPM_TARGET_UNKNOWN = -1 !> Target type is executable -integer, parameter :: FPM_TARGET_EXECUTABLE = 1 + integer, parameter :: FPM_TARGET_EXECUTABLE = 1 !> Target type is library archive -integer, parameter :: FPM_TARGET_ARCHIVE = 2 + integer, parameter :: FPM_TARGET_ARCHIVE = 2 !> Target type is compiled object -integer, parameter :: FPM_TARGET_OBJECT = 3 + integer, parameter :: FPM_TARGET_OBJECT = 3 !> Target type is c compiled object -integer, parameter :: FPM_TARGET_C_OBJECT = 4 + integer, parameter :: FPM_TARGET_C_OBJECT = 4 !> Target type is cpp compiled object -integer, parameter :: FPM_TARGET_CPP_OBJECT = 5 + integer, parameter :: FPM_TARGET_CPP_OBJECT = 5 !> Wrapper type for constructing arrays of `[[build_target_t]]` pointers -type build_target_ptr + type build_target_ptr type(build_target_t), pointer :: ptr => null() -end type build_target_ptr - + end type build_target_ptr !> Type describing a generated build target -type build_target_t + type build_target_t !> File path of build target object relative to cwd character(:), allocatable :: output_file @@ -126,13 +123,12 @@ module fpm_targets !> Version number character(:), allocatable :: version -end type build_target_t - + end type build_target_t contains !> High-level wrapper to generate build target information -subroutine targets_from_sources(targets,model,prune,error) + subroutine targets_from_sources(targets, model, prune, error) !> The generated list of build targets type(build_target_ptr), intent(out), allocatable :: targets(:) @@ -142,25 +138,24 @@ subroutine targets_from_sources(targets,model,prune,error) !> Enable tree-shaking/pruning of module dependencies logical, intent(in) :: prune - + !> Error structure type(error_t), intent(out), allocatable :: error - call build_target_list(targets,model) + call build_target_list(targets, model) call collect_exe_link_dependencies(targets) - call resolve_module_dependencies(targets,model%external_modules,error) + call resolve_module_dependencies(targets, model%external_modules, error) if (allocated(error)) return if (prune) then - call prune_build_targets(targets,root_package=model%package_name) + call prune_build_targets(targets, root_package=model%package_name) end if - call resolve_target_linking(targets,model) - -end subroutine targets_from_sources + call resolve_target_linking(targets, model) + end subroutine targets_from_sources !> Constructs a list of build targets from a list of source files !> @@ -181,7 +176,7 @@ end subroutine targets_from_sources !> is a library, then the executable target has an additional dependency on the library !> archive target. !> -subroutine build_target_list(targets,model) + subroutine build_target_list(targets, model) !> The generated list of build targets type(build_target_ptr), intent(out), allocatable :: targets(:) @@ -195,155 +190,153 @@ subroutine build_target_list(targets,model) ! Check for empty build (e.g. header-only lib) n_source = sum([(size(model%packages(j)%sources), & - j=1,size(model%packages))]) + j=1, size(model%packages))]) if (n_source < 1) then - allocate(targets(0)) - return + allocate (targets(0)) + return end if if (get_os_type() == OS_WINDOWS) then - xsuffix = '.exe' + xsuffix = '.exe' else - xsuffix = '' + xsuffix = '' end if with_lib = any([((model%packages(j)%sources(i)%unit_scope == FPM_SCOPE_LIB, & - i=1,size(model%packages(j)%sources)), & - j=1,size(model%packages))]) + i=1, size(model%packages(j)%sources)), & + j=1, size(model%packages))]) - if (with_lib) call add_target(targets,package=model%package_name,type = FPM_TARGET_ARCHIVE,& - output_name = join_path(& - model%package_name,'lib'//model%package_name//'.a')) + if (with_lib) call add_target(targets, package=model%package_name, type=FPM_TARGET_ARCHIVE, & + output_name=join_path( & + model%package_name, 'lib'//model%package_name//'.a')) - do j=1,size(model%packages) + do j = 1, size(model%packages) - associate(sources=>model%packages(j)%sources) + associate (sources => model%packages(j)%sources) - do i=1,size(sources) + do i = 1, size(sources) - if (.not. model%include_tests) then - if (sources(i)%unit_scope == FPM_SCOPE_TEST) cycle - end if + if (.not. model%include_tests) then + if (sources(i)%unit_scope == FPM_SCOPE_TEST) cycle + end if - select case (sources(i)%unit_type) - case (FPM_UNIT_MODULE,FPM_UNIT_SUBMODULE,FPM_UNIT_SUBPROGRAM,FPM_UNIT_CSOURCE) + select case (sources(i)%unit_type) + case (FPM_UNIT_MODULE, FPM_UNIT_SUBMODULE, FPM_UNIT_SUBPROGRAM, FPM_UNIT_CSOURCE) - call add_target(targets,package=model%packages(j)%name,source = sources(i), & - type = merge(FPM_TARGET_C_OBJECT,FPM_TARGET_OBJECT,& - sources(i)%unit_type==FPM_UNIT_CSOURCE), & - output_name = get_object_name(sources(i)), & - macros = model%packages(j)%macros, & - version = model%packages(j)%version) - + call add_target(targets, package=model%packages(j)%name, source=sources(i), & + type=merge(FPM_TARGET_C_OBJECT, FPM_TARGET_OBJECT, & + sources(i)%unit_type == FPM_UNIT_CSOURCE), & + output_name=get_object_name(sources(i)), & + macros=model%packages(j)%macros, & + version=model%packages(j)%version) - if (with_lib .and. sources(i)%unit_scope == FPM_SCOPE_LIB) then - ! Archive depends on object - call add_dependency(targets(1)%ptr, targets(size(targets))%ptr) - end if + if (with_lib .and. sources(i)%unit_scope == FPM_SCOPE_LIB) then + ! Archive depends on object + call add_dependency(targets(1)%ptr, targets(size(targets))%ptr) + end if - case (FPM_UNIT_CPPSOURCE) + case (FPM_UNIT_CPPSOURCE) - call add_target(targets,package=model%packages(j)%name,source = sources(i), & - type = FPM_TARGET_CPP_OBJECT, & - output_name = get_object_name(sources(i)), & - macros = model%packages(j)%macros, & - version = model%packages(j)%version) + call add_target(targets, package=model%packages(j)%name, source=sources(i), & + type=FPM_TARGET_CPP_OBJECT, & + output_name=get_object_name(sources(i)), & + macros=model%packages(j)%macros, & + version=model%packages(j)%version) - if (with_lib .and. sources(i)%unit_scope == FPM_SCOPE_LIB) then - ! Archive depends on object - call add_dependency(targets(1)%ptr, targets(size(targets))%ptr) - end if + if (with_lib .and. sources(i)%unit_scope == FPM_SCOPE_LIB) then + ! Archive depends on object + call add_dependency(targets(1)%ptr, targets(size(targets))%ptr) + end if - !> Add stdc++ as a linker flag. If not already there. - if (.not. ("stdc++" .in. model%link_libraries)) then + !> Add stdc++ as a linker flag. If not already there. + if (.not. ("stdc++".in.model%link_libraries)) then - if (get_os_type() == OS_MACOS) then - model%link_libraries = [model%link_libraries, string_t("c++")] - else - model%link_libraries = [model%link_libraries, string_t("stdc++")] - end if + if (get_os_type() == OS_MACOS) then + model%link_libraries = [model%link_libraries, string_t("c++")] + else + model%link_libraries = [model%link_libraries, string_t("stdc++")] + end if - end if + end if - case (FPM_UNIT_PROGRAM) + case (FPM_UNIT_PROGRAM) - if (str_ends_with(lower(sources(i)%file_name), [".c"])) then - exe_type = FPM_TARGET_C_OBJECT - else if (str_ends_with(lower(sources(i)%file_name), [".cpp", ".cc "])) then - exe_type = FPM_TARGET_CPP_OBJECT - else ! Default to a Fortran object - exe_type = FPM_TARGET_OBJECT - end if + if (str_ends_with(lower(sources(i)%file_name), [".c"])) then + exe_type = FPM_TARGET_C_OBJECT + else if (str_ends_with(lower(sources(i)%file_name), [".cpp", ".cc "])) then + exe_type = FPM_TARGET_CPP_OBJECT + else ! Default to a Fortran object + exe_type = FPM_TARGET_OBJECT + end if - call add_target(targets,package=model%packages(j)%name,type = exe_type,& - output_name = get_object_name(sources(i)), & - source = sources(i), & - macros = model%packages(j)%macros & - ) + call add_target(targets, package=model%packages(j)%name, type=exe_type, & + output_name=get_object_name(sources(i)), & + source=sources(i), & + macros=model%packages(j)%macros & + ) - if (sources(i)%unit_scope == FPM_SCOPE_APP) then + if (sources(i)%unit_scope == FPM_SCOPE_APP) then - exe_dir = 'app' + exe_dir = 'app' - else if (sources(i)%unit_scope == FPM_SCOPE_EXAMPLE) then + else if (sources(i)%unit_scope == FPM_SCOPE_EXAMPLE) then - exe_dir = 'example' + exe_dir = 'example' - else + else - exe_dir = 'test' + exe_dir = 'test' - end if + end if - call add_target(targets,package=model%packages(j)%name,type = FPM_TARGET_EXECUTABLE,& - link_libraries = sources(i)%link_libraries, & - output_name = join_path(exe_dir, & - sources(i)%exe_name//xsuffix)) + call add_target(targets, package=model%packages(j)%name, type=FPM_TARGET_EXECUTABLE, & + link_libraries=sources(i)%link_libraries, & + output_name=join_path(exe_dir, & + sources(i)%exe_name//xsuffix)) - ! Executable depends on object - call add_dependency(targets(size(targets))%ptr, targets(size(targets)-1)%ptr) + ! Executable depends on object + call add_dependency(targets(size(targets))%ptr, targets(size(targets) - 1)%ptr) - if (with_lib) then - ! Executable depends on library - call add_dependency(targets(size(targets))%ptr, targets(1)%ptr) - end if + if (with_lib) then + ! Executable depends on library + call add_dependency(targets(size(targets))%ptr, targets(1)%ptr) + end if - end select + end select - end do + end do - end associate + end associate end do - contains + contains function get_object_name(source) result(object_file) - ! Generate object target path from source name and model params - ! - ! - type(srcfile_t), intent(in) :: source - character(:), allocatable :: object_file - - integer :: i - character(1), parameter :: filesep = '/' - - object_file = canon_path(source%file_name) - - ! Convert any 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 + ! Generate object target path from source name and model params + ! + ! + type(srcfile_t), intent(in) :: source + character(:), allocatable :: object_file - object_file = join_path(model%package_name,object_file)//'.o' + integer :: i + character(1), parameter :: filesep = '/' - end function get_object_name + object_file = canon_path(source%file_name) -end subroutine build_target_list + ! Convert any 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 + object_file = join_path(model%package_name, object_file)//'.o' + + end function get_object_name + + end subroutine build_target_list !> Add non-library non-module dependencies for executable targets !> @@ -353,51 +346,50 @@ end subroutine build_target_list !> (Note: Fortran module dependencies are handled separately in !> `resolve_module_dependencies` and `resolve_target_linking`.) !> -subroutine collect_exe_link_dependencies(targets) + subroutine collect_exe_link_dependencies(targets) type(build_target_ptr), intent(inout) :: targets(:) integer :: i, j character(:), allocatable :: exe_source_dir ! Add non-module dependencies for executables - do j=1,size(targets) + do j = 1, size(targets) - if (targets(j)%ptr%target_type == FPM_TARGET_EXECUTABLE) then + if (targets(j)%ptr%target_type == FPM_TARGET_EXECUTABLE) then - do i=1,size(targets) + do i = 1, size(targets) - if (i == j) cycle + if (i == j) cycle - associate(exe => targets(j)%ptr, dep => targets(i)%ptr) + associate (exe => targets(j)%ptr, dep => targets(i)%ptr) - exe_source_dir = dirname(exe%dependencies(1)%ptr%source%file_name) + exe_source_dir = dirname(exe%dependencies(1)%ptr%source%file_name) - if (allocated(dep%source)) then + if (allocated(dep%source)) then - if (dep%source%unit_scope /= FPM_SCOPE_LIB .and. & - dep%source%unit_type /= FPM_UNIT_PROGRAM .and. & - dep%source%unit_type /= FPM_UNIT_MODULE .and. & - index(dirname(dep%source%file_name), exe_source_dir) == 1) then + if (dep%source%unit_scope /= FPM_SCOPE_LIB .and. & + dep%source%unit_type /= FPM_UNIT_PROGRAM .and. & + dep%source%unit_type /= FPM_UNIT_MODULE .and. & + index(dirname(dep%source%file_name), exe_source_dir) == 1) then - call add_dependency(exe, dep) + call add_dependency(exe, dep) - end if + end if - end if + end if - end associate + end associate - end do + end do - end if + end if end do -end subroutine collect_exe_link_dependencies - + end subroutine collect_exe_link_dependencies !> Allocate a new target and append to target list -subroutine add_target(targets,package,type,output_name,source,link_libraries, macros, version) + subroutine add_target(targets, package, type, output_name, source, link_libraries, macros, version) type(build_target_ptr), allocatable, intent(inout) :: targets(:) character(*), intent(in) :: package integer, intent(in) :: type @@ -410,23 +402,23 @@ subroutine add_target(targets,package,type,output_name,source,link_libraries, ma integer :: i type(build_target_t), pointer :: new_target - if (.not.allocated(targets)) allocate(targets(0)) + if (.not. allocated(targets)) allocate (targets(0)) ! Check for duplicate outputs - do i=1,size(targets) + do i = 1, size(targets) - if (targets(i)%ptr%output_name == output_name) then + if (targets(i)%ptr%output_name == output_name) then - write(*,*) 'Error while building target list: duplicate output object "',& - output_name,'"' - if (present(source)) write(*,*) ' Source file: "',source%file_name,'"' - call fpm_stop(1,' ') + write (*, *) 'Error while building target list: duplicate output object "', & + output_name, '"' + if (present(source)) write (*, *) ' Source file: "', source%file_name, '"' + call fpm_stop(1, ' ') - end if + end if end do - allocate(new_target) + allocate (new_target) new_target%target_type = type new_target%output_name = output_name new_target%package_name = package @@ -434,22 +426,20 @@ subroutine add_target(targets,package,type,output_name,source,link_libraries, ma if (present(link_libraries)) new_target%link_libraries = link_libraries if (present(macros)) new_target%macros = macros if (present(version)) new_target%version = version - allocate(new_target%dependencies(0)) + allocate (new_target%dependencies(0)) targets = [targets, build_target_ptr(new_target)] -end subroutine add_target - + end subroutine add_target !> Add pointer to dependeny in target%dependencies -subroutine add_dependency(target, dependency) + subroutine add_dependency(target, dependency) type(build_target_t), intent(inout) :: target - type(build_target_t) , intent(in), target :: dependency + type(build_target_t), intent(in), target :: dependency target%dependencies = [target%dependencies, build_target_ptr(dependency)] -end subroutine add_dependency - + end subroutine add_dependency !> Add dependencies to source-based targets (`FPM_TARGET_OBJECT`) !> based on any modules used by the corresponding source file. @@ -473,7 +463,7 @@ end subroutine add_dependency !> a source file in the package of the correct scope, then a __fatal error__ !> is returned by the procedure and model construction fails. !> -subroutine resolve_module_dependencies(targets,external_modules,error) + subroutine resolve_module_dependencies(targets, external_modules, error) type(build_target_ptr), intent(inout), target :: targets(:) type(string_t), intent(in) :: external_modules(:) type(error_t), allocatable, intent(out) :: error @@ -482,49 +472,49 @@ subroutine resolve_module_dependencies(targets,external_modules,error) integer :: i, j - do i=1,size(targets) + do i = 1, size(targets) - if (.not.allocated(targets(i)%ptr%source)) cycle + if (.not. allocated(targets(i)%ptr%source)) cycle - do j=1,size(targets(i)%ptr%source%modules_used) + do j = 1, size(targets(i)%ptr%source%modules_used) - if (targets(i)%ptr%source%modules_used(j)%s .in. targets(i)%ptr%source%modules_provided) then - ! Dependency satisfied in same file, skip - cycle - end if + if (targets(i)%ptr%source%modules_used(j)%s.in.targets(i)%ptr%source%modules_provided) then + ! Dependency satisfied in same file, skip + cycle + end if - if (targets(i)%ptr%source%modules_used(j)%s .in. external_modules) then - ! Dependency satisfied in system-installed module - cycle - end if + if (targets(i)%ptr%source%modules_used(j)%s.in.external_modules) then + ! Dependency satisfied in system-installed module + cycle + end if - if (any(targets(i)%ptr%source%unit_scope == & - [FPM_SCOPE_APP, FPM_SCOPE_EXAMPLE, FPM_SCOPE_TEST])) then - dep%ptr => & - find_module_dependency(targets,targets(i)%ptr%source%modules_used(j)%s, & - include_dir = dirname(targets(i)%ptr%source%file_name)) - else - dep%ptr => & - find_module_dependency(targets,targets(i)%ptr%source%modules_used(j)%s) - end if + if (any(targets(i)%ptr%source%unit_scope == & + [FPM_SCOPE_APP, FPM_SCOPE_EXAMPLE, FPM_SCOPE_TEST])) then + dep%ptr => & + find_module_dependency(targets, targets(i)%ptr%source%modules_used(j)%s, & + include_dir=dirname(targets(i)%ptr%source%file_name)) + else + dep%ptr => & + find_module_dependency(targets, targets(i)%ptr%source%modules_used(j)%s) + end if - if (.not.associated(dep%ptr)) then - call fatal_error(error, & - 'Unable to find source for module dependency: "' // & - targets(i)%ptr%source%modules_used(j)%s // & - '" used by "'//targets(i)%ptr%source%file_name//'"') - return - end if + if (.not. associated(dep%ptr)) then + call fatal_error(error, & + 'Unable to find source for module dependency: "'// & + targets(i)%ptr%source%modules_used(j)%s// & + '" used by "'//targets(i)%ptr%source%file_name//'"') + return + end if - call add_dependency(targets(i)%ptr, dep%ptr) + call add_dependency(targets(i)%ptr, dep%ptr) - end do + end do end do -end subroutine resolve_module_dependencies + end subroutine resolve_module_dependencies -function find_module_dependency(targets,module_name,include_dir) result(target_ptr) + function find_module_dependency(targets, module_name, include_dir) result(target_ptr) ! Find a module dependency in the library or a dependency library ! ! 'include_dir' specifies an allowable non-library search directory @@ -539,89 +529,88 @@ function find_module_dependency(targets,module_name,include_dir) result(target_p target_ptr => NULL() - do k=1,size(targets) - - if (.not.allocated(targets(k)%ptr%source)) cycle - - do l=1,size(targets(k)%ptr%source%modules_provided) - - if (module_name == targets(k)%ptr%source%modules_provided(l)%s) then - select case(targets(k)%ptr%source%unit_scope) - case (FPM_SCOPE_LIB, FPM_SCOPE_DEP) - target_ptr => targets(k)%ptr - exit - case default - if (present(include_dir)) then - if (index(dirname(targets(k)%ptr%source%file_name), include_dir) == 1) then ! source file is within the include_dir or a subdirectory - target_ptr => targets(k)%ptr - exit - end if - end if - end select + do k = 1, size(targets) + + if (.not. allocated(targets(k)%ptr%source)) cycle + + do l = 1, size(targets(k)%ptr%source%modules_provided) + + if (module_name == targets(k)%ptr%source%modules_provided(l)%s) then + select case (targets(k)%ptr%source%unit_scope) + case (FPM_SCOPE_LIB, FPM_SCOPE_DEP) + target_ptr => targets(k)%ptr + exit + case default + if (present(include_dir)) then + if (index(dirname(targets(k)%ptr%source%file_name), include_dir) == 1) then ! source file is within the include_dir or a subdirectory + target_ptr => targets(k)%ptr + exit + end if end if + end select + end if - end do + end do end do -end function find_module_dependency - + end function find_module_dependency !> Perform tree-shaking to remove unused module targets -subroutine prune_build_targets(targets, root_package) + subroutine prune_build_targets(targets, root_package) !> Build target list to prune type(build_target_ptr), intent(inout), allocatable :: targets(:) !> Name of root package - character(*), intent(in) :: root_package + character(*), intent(in) :: root_package integer :: i, j, nexec type(string_t), allocatable :: modules_used(:) logical :: exclude_target(size(targets)) logical, allocatable :: exclude_from_archive(:) - + if (size(targets) < 1) then - return + return end if nexec = 0 - allocate(modules_used(0)) + allocate (modules_used(0)) ! Enumerate modules used by executables, non-module subprograms and their dependencies - do i=1,size(targets) - - if (targets(i)%ptr%target_type == FPM_TARGET_EXECUTABLE) then + do i = 1, size(targets) - nexec = nexec + 1 - call collect_used_modules(targets(i)%ptr) + if (targets(i)%ptr%target_type == FPM_TARGET_EXECUTABLE) then - elseif (allocated(targets(i)%ptr%source)) then + nexec = nexec + 1 + call collect_used_modules(targets(i)%ptr) - if (targets(i)%ptr%source%unit_type == FPM_UNIT_SUBPROGRAM) then + elseif (allocated(targets(i)%ptr%source)) then - call collect_used_modules(targets(i)%ptr) + if (targets(i)%ptr%source%unit_type == FPM_UNIT_SUBPROGRAM) then - end if + call collect_used_modules(targets(i)%ptr) end if + end if + end do ! If there aren't any executables, then prune ! based on modules used in root package if (nexec < 1) then - - do i=1,size(targets) - - if (targets(i)%ptr%package_name == root_package .and. & - targets(i)%ptr%target_type /= FPM_TARGET_ARCHIVE) then - - call collect_used_modules(targets(i)%ptr) - - end if - - end do + + do i = 1, size(targets) + + if (targets(i)%ptr%package_name == root_package .and. & + targets(i)%ptr%target_type /= FPM_TARGET_ARCHIVE) then + + call collect_used_modules(targets(i)%ptr) + + end if + + end do end if @@ -630,149 +619,148 @@ subroutine prune_build_targets(targets, root_package) exclude_target(:) = .false. ! Exclude purely module targets if they are not used anywhere - do i=1,size(targets) - associate(target=>targets(i)%ptr) - - if (allocated(target%source)) then - if (target%source%unit_type == FPM_UNIT_MODULE) then - - exclude_target(i) = .true. - target%skip = .true. + do i = 1, size(targets) + associate (target => targets(i)%ptr) - do j=1,size(target%source%modules_provided) + if (allocated(target%source)) then + if (target%source%unit_type == FPM_UNIT_MODULE) then - if (target%source%modules_provided(j)%s .in. modules_used) then - - exclude_target(i) = .false. - target%skip = .false. + exclude_target(i) = .true. + target%skip = .true. - end if + do j = 1, size(target%source%modules_provided) - end do + if (target%source%modules_provided(j)%s.in.modules_used) then - elseif (target%source%unit_type == FPM_UNIT_SUBMODULE) then - ! Remove submodules if their parents are not used + exclude_target(i) = .false. + target%skip = .false. - exclude_target(i) = .true. - target%skip = .true. - do j=1,size(target%source%parent_modules) + end if - if (target%source%parent_modules(j)%s .in. modules_used) then - - exclude_target(i) = .false. - target%skip = .false. + end do - end if + elseif (target%source%unit_type == FPM_UNIT_SUBMODULE) then + ! Remove submodules if their parents are not used - end do + exclude_target(i) = .true. + target%skip = .true. + do j = 1, size(target%source%parent_modules) - end if - end if + if (target%source%parent_modules(j)%s.in.modules_used) then - ! (If there aren't any executables then we only prune modules from dependencies) - if (nexec < 1 .and. target%package_name == root_package) then exclude_target(i) = .false. target%skip = .false. - end if - end associate + end if + + end do + + end if + end if + + ! (If there aren't any executables then we only prune modules from dependencies) + if (nexec < 1 .and. target%package_name == root_package) then + exclude_target(i) = .false. + target%skip = .false. + end if + + end associate end do - targets = pack(targets,.not.exclude_target) + targets = pack(targets,.not. exclude_target) ! Remove unused targets from archive dependency list if (targets(1)%ptr%target_type == FPM_TARGET_ARCHIVE) then - associate(archive=>targets(1)%ptr) + associate (archive => targets(1)%ptr) - allocate(exclude_from_archive(size(archive%dependencies))) - exclude_from_archive(:) = .false. + allocate (exclude_from_archive(size(archive%dependencies))) + exclude_from_archive(:) = .false. - do i=1,size(archive%dependencies) + do i = 1, size(archive%dependencies) - if (archive%dependencies(i)%ptr%skip) then + if (archive%dependencies(i)%ptr%skip) then - exclude_from_archive(i) = .true. + exclude_from_archive(i) = .true. - end if + end if - end do + end do - archive%dependencies = pack(archive%dependencies,.not.exclude_from_archive) + archive%dependencies = pack(archive%dependencies,.not. exclude_from_archive) - end associate + end associate end if - contains + contains !> Recursively collect which modules are actually used recursive subroutine collect_used_modules(target) - type(build_target_t), intent(inout) :: target + type(build_target_t), intent(inout) :: target - integer :: j, k + integer :: j, k - if (target%touched) then - return - else - target%touched = .true. - end if + if (target%touched) then + return + else + target%touched = .true. + end if - if (allocated(target%source)) then + if (allocated(target%source)) then - ! Add modules from this target and from any of it's children submodules - do j=1,size(target%source%modules_provided) + ! Add modules from this target and from any of it's children submodules + do j = 1, size(target%source%modules_provided) - if (.not.(target%source%modules_provided(j)%s .in. modules_used)) then + if (.not. (target%source%modules_provided(j)%s.in.modules_used)) then - modules_used = [modules_used, target%source%modules_provided(j)] + modules_used = [modules_used, target%source%modules_provided(j)] - end if + end if - ! Recurse into child submodules - do k=1,size(targets) - if (allocated(targets(k)%ptr%source)) then - if (targets(k)%ptr%source%unit_type == FPM_UNIT_SUBMODULE) then - if (target%source%modules_provided(j)%s .in. targets(k)%ptr%source%parent_modules) then - call collect_used_modules(targets(k)%ptr) - end if - end if - end if - end do + ! Recurse into child submodules + do k = 1, size(targets) + if (allocated(targets(k)%ptr%source)) then + if (targets(k)%ptr%source%unit_type == FPM_UNIT_SUBMODULE) then + if (target%source%modules_provided(j)%s.in.targets(k)%ptr%source%parent_modules) then + call collect_used_modules(targets(k)%ptr) + end if + end if + end if + end do - end do - end if + end do + end if - ! Recurse into dependencies - do j=1,size(target%dependencies) + ! Recurse into dependencies + do j = 1, size(target%dependencies) - if (target%dependencies(j)%ptr%target_type /= FPM_TARGET_ARCHIVE) then - call collect_used_modules(target%dependencies(j)%ptr) - end if + if (target%dependencies(j)%ptr%target_type /= FPM_TARGET_ARCHIVE) then + call collect_used_modules(target%dependencies(j)%ptr) + end if - end do + end do end subroutine collect_used_modules !> Reset target flags after recursive search subroutine reset_target_flags(targets) - type(build_target_ptr), intent(inout) :: targets(:) + type(build_target_ptr), intent(inout) :: targets(:) - integer :: i + integer :: i - do i=1,size(targets) + do i = 1, size(targets) - targets(i)%ptr%touched = .false. + targets(i)%ptr%touched = .false. - end do + end do end subroutine reset_target_flags -end subroutine prune_build_targets - + end subroutine prune_build_targets !> Construct the linker flags string for each target !> `target%link_flags` includes non-library objects and library flags !> -subroutine resolve_target_linking(targets, model) + subroutine resolve_target_linking(targets, model) type(build_target_ptr), intent(inout), target :: targets(:) type(fpm_model_t), intent(in) :: model @@ -784,86 +772,86 @@ subroutine resolve_target_linking(targets, model) global_link_flags = "" if (allocated(model%link_libraries)) then - if (size(model%link_libraries) > 0) then - global_link_flags = model%compiler%enumerate_libraries(global_link_flags, model%link_libraries) - end if + if (size(model%link_libraries) > 0) then + global_link_flags = model%compiler%enumerate_libraries(global_link_flags, model%link_libraries) + end if end if - allocate(character(0) :: global_include_flags) + allocate (character(0) :: global_include_flags) if (allocated(model%include_dirs)) then - if (size(model%include_dirs) > 0) then - global_include_flags = global_include_flags // & - & " -I" // string_cat(model%include_dirs," -I") - end if + if (size(model%include_dirs) > 0) then + global_include_flags = global_include_flags// & + & " -I"//string_cat(model%include_dirs, " -I") + end if end if - do i=1,size(targets) + do i = 1, size(targets) - associate(target => targets(i)%ptr) - if (target%target_type /= FPM_TARGET_C_OBJECT .and. target%target_type /= FPM_TARGET_CPP_OBJECT) then - target%compile_flags = model%fortran_compile_flags - else if (target%target_type == FPM_TARGET_C_OBJECT) then - target%compile_flags = model%c_compile_flags - else if(target%target_type == FPM_TARGET_CPP_OBJECT) then - target%compile_flags = model%cxx_compile_flags - end if + associate (target => targets(i)%ptr) + if (target%target_type /= FPM_TARGET_C_OBJECT .and. target%target_type /= FPM_TARGET_CPP_OBJECT) then + target%compile_flags = model%fortran_compile_flags + else if (target%target_type == FPM_TARGET_C_OBJECT) then + target%compile_flags = model%c_compile_flags + else if (target%target_type == FPM_TARGET_CPP_OBJECT) then + target%compile_flags = model%cxx_compile_flags + end if - !> Get macros as flags. - target%compile_flags = target%compile_flags // get_macros(model%compiler%id, & - target%macros, & - target%version) - - if (len(global_include_flags) > 0) then - target%compile_flags = target%compile_flags//global_include_flags - end if - target%output_dir = get_output_dir(model%build_prefix, target%compile_flags) - 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 associate + !> Get macros as flags. + target%compile_flags = target%compile_flags//get_macros(model%compiler%id, & + target%macros, & + target%version) + + if (len(global_include_flags) > 0) then + target%compile_flags = target%compile_flags//global_include_flags + end if + target%output_dir = get_output_dir(model%build_prefix, target%compile_flags) + 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 associate end do call add_include_build_dirs(model, targets) - do i=1,size(targets) + do i = 1, size(targets) - associate(target => targets(i)%ptr) - allocate(target%link_objects(0)) + associate (target => targets(i)%ptr) + allocate (target%link_objects(0)) - if (target%target_type == FPM_TARGET_ARCHIVE) then - global_link_flags = target%output_file // global_link_flags + if (target%target_type == FPM_TARGET_ARCHIVE) then + global_link_flags = target%output_file//global_link_flags - call get_link_objects(target%link_objects,target,is_exe=.false.) + call get_link_objects(target%link_objects, target, is_exe=.false.) - allocate(character(0) :: target%link_flags) + allocate (character(0) :: target%link_flags) - else if (target%target_type == FPM_TARGET_EXECUTABLE) then + else if (target%target_type == FPM_TARGET_EXECUTABLE) then - call get_link_objects(target%link_objects,target,is_exe=.true.) + call get_link_objects(target%link_objects, target, is_exe=.true.) - local_link_flags = model%link_flags - target%link_flags = model%link_flags//" "//string_cat(target%link_objects," ") + local_link_flags = model%link_flags + target%link_flags = model%link_flags//" "//string_cat(target%link_objects, " ") - if (allocated(target%link_libraries)) then - if (size(target%link_libraries) > 0) then - target%link_flags = model%compiler%enumerate_libraries(target%link_flags, target%link_libraries) - local_link_flags = model%compiler%enumerate_libraries(local_link_flags, target%link_libraries) - end if - end if + if (allocated(target%link_libraries)) then + if (size(target%link_libraries) > 0) then + target%link_flags = model%compiler%enumerate_libraries(target%link_flags, target%link_libraries) + local_link_flags = model%compiler%enumerate_libraries(local_link_flags, target%link_libraries) + end if + end if - target%link_flags = target%link_flags//" "//global_link_flags + target%link_flags = target%link_flags//" "//global_link_flags - 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_log_file = join_path(target%output_dir, target%output_name)//'.log' + 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_log_file = join_path(target%output_dir, target%output_name)//'.log' end if - end associate + end associate end do -contains + contains !> Wrapper to build link object list !> @@ -872,47 +860,46 @@ subroutine resolve_target_linking(targets, model) !> For executables: need to recursively discover non-library !> dependency objects. (i.e. modules in same dir as program) !> - recursive subroutine get_link_objects(link_objects,target,is_exe) - type(string_t), intent(inout), allocatable :: link_objects(:) - type(build_target_t), intent(in) :: target - logical, intent(in) :: is_exe + recursive subroutine get_link_objects(link_objects, target, is_exe) + type(string_t), intent(inout), allocatable :: link_objects(:) + type(build_target_t), intent(in) :: target + logical, intent(in) :: is_exe - integer :: i - type(string_t) :: temp_str + integer :: i + type(string_t) :: temp_str - if (.not.allocated(target%dependencies)) return + if (.not. allocated(target%dependencies)) return - do i=1,size(target%dependencies) + do i = 1, size(target%dependencies) - associate(dep => target%dependencies(i)%ptr) + associate (dep => target%dependencies(i)%ptr) - if (.not.allocated(dep%source)) cycle + if (.not. allocated(dep%source)) cycle - ! Skip library dependencies for executable targets - ! since the library archive will always be linked - if (is_exe.and.(dep%source%unit_scope == FPM_SCOPE_LIB)) cycle + ! Skip library dependencies for executable targets + ! since the library archive will always be linked + if (is_exe .and. (dep%source%unit_scope == FPM_SCOPE_LIB)) cycle - ! Skip if dependency object already listed - if (dep%output_file .in. link_objects) cycle + ! Skip if dependency object already listed + if (dep%output_file.in.link_objects) cycle - ! Add dependency object file to link object list - temp_str%s = dep%output_file - link_objects = [link_objects, temp_str] + ! Add dependency object file to link object list + temp_str%s = dep%output_file + link_objects = [link_objects, temp_str] - ! For executable objects, also need to include non-library - ! dependencies from dependencies (recurse) - if (is_exe) call get_link_objects(link_objects,dep,is_exe=.true.) + ! For executable objects, also need to include non-library + ! dependencies from dependencies (recurse) + if (is_exe) call get_link_objects(link_objects, dep, is_exe=.true.) - end associate + end associate - end do + end do end subroutine get_link_objects -end subroutine resolve_target_linking + end subroutine resolve_target_linking - -subroutine add_include_build_dirs(model, targets) + subroutine add_include_build_dirs(model, targets) type(fpm_model_t), intent(in) :: model type(build_target_ptr), intent(inout), target :: targets(:) @@ -920,42 +907,40 @@ subroutine add_include_build_dirs(model, targets) type(string_t), allocatable :: build_dirs(:) type(string_t) :: temp - allocate(build_dirs(0)) + allocate (build_dirs(0)) do i = 1, size(targets) - associate(target => targets(i)%ptr) - if (target%target_type /= FPM_TARGET_OBJECT) cycle - if (target%output_dir .in. build_dirs) cycle - temp%s = target%output_dir - build_dirs = [build_dirs, temp] - end associate + associate (target => targets(i)%ptr) + if (target%target_type /= FPM_TARGET_OBJECT) cycle + if (target%output_dir.in.build_dirs) cycle + temp%s = target%output_dir + build_dirs = [build_dirs, temp] + end associate end do do i = 1, size(targets) - associate(target => targets(i)%ptr) - if (target%target_type /= FPM_TARGET_OBJECT) cycle + associate (target => targets(i)%ptr) + if (target%target_type /= FPM_TARGET_OBJECT) cycle - target%compile_flags = target%compile_flags // & - " " // model%compiler%get_module_flag(target%output_dir) // & - " -I" // string_cat(build_dirs, " -I") - end associate + target%compile_flags = target%compile_flags// & + " "//model%compiler%get_module_flag(target%output_dir)// & + " -I"//string_cat(build_dirs, " -I") + end associate end do -end subroutine add_include_build_dirs - + end subroutine add_include_build_dirs -function get_output_dir(build_prefix, args) result(path) + function get_output_dir(build_prefix, args) result(path) character(len=*), intent(in) :: build_prefix character(len=*), intent(in) :: args character(len=:), allocatable :: path character(len=16) :: build_hash - write(build_hash, '(z16.16)') fnv_1a(args) + write (build_hash, '(z16.16)') fnv_1a(args) path = build_prefix//"_"//build_hash -end function get_output_dir + end function get_output_dir - -subroutine filter_library_targets(targets, list) + subroutine filter_library_targets(targets, list) type(build_target_ptr), intent(in) :: targets(:) type(string_t), allocatable, intent(out) :: list(:) @@ -964,16 +949,16 @@ subroutine filter_library_targets(targets, list) n = 0 call resize(list) do i = 1, size(targets) - if (targets(i)%ptr%target_type == FPM_TARGET_ARCHIVE) then - if (n >= size(list)) call resize(list) - n = n + 1 - list(n)%s = targets(i)%ptr%output_file - end if + if (targets(i)%ptr%target_type == FPM_TARGET_ARCHIVE) then + if (n >= size(list)) call resize(list) + n = n + 1 + list(n)%s = targets(i)%ptr%output_file + end if end do call resize(list, n) -end subroutine filter_library_targets + end subroutine filter_library_targets -subroutine filter_executable_targets(targets, scope, list) + subroutine filter_executable_targets(targets, scope, list) type(build_target_ptr), intent(in) :: targets(:) integer, intent(in) :: scope type(string_t), allocatable, intent(out) :: list(:) @@ -983,29 +968,27 @@ subroutine filter_executable_targets(targets, scope, list) n = 0 call resize(list) do i = 1, size(targets) - if (is_executable_target(targets(i)%ptr, scope)) then - if (n >= size(list)) call resize(list) - n = n + 1 - list(n)%s = targets(i)%ptr%output_file - end if + if (is_executable_target(targets(i)%ptr, scope)) then + if (n >= size(list)) call resize(list) + n = n + 1 + list(n)%s = targets(i)%ptr%output_file + end if end do call resize(list, n) -end subroutine filter_executable_targets - + end subroutine filter_executable_targets -elemental function is_executable_target(target_ptr, scope) result(is_exe) + elemental function is_executable_target(target_ptr, scope) result(is_exe) type(build_target_t), intent(in) :: target_ptr integer, intent(in) :: scope logical :: is_exe is_exe = target_ptr%target_type == FPM_TARGET_EXECUTABLE .and. & - allocated(target_ptr%dependencies) + allocated(target_ptr%dependencies) if (is_exe) then - is_exe = target_ptr%dependencies(1)%ptr%source%unit_scope == scope + is_exe = target_ptr%dependencies(1)%ptr%source%unit_scope == scope end if -end function is_executable_target + end function is_executable_target - -subroutine filter_modules(targets, list) + subroutine filter_modules(targets, list) type(build_target_ptr), intent(in) :: targets(:) type(string_t), allocatable, intent(out) :: list(:) @@ -1014,19 +997,18 @@ subroutine filter_modules(targets, list) n = 0 call resize(list) do i = 1, size(targets) - associate(target => targets(i)%ptr) - if (.not.allocated(target%source)) cycle - if (target%source%unit_type == FPM_UNIT_SUBMODULE) cycle - if (n + size(target%source%modules_provided) >= size(list)) call resize(list) - do j = 1, size(target%source%modules_provided) - n = n + 1 - list(n)%s = join_path(target%output_dir, & - target%source%modules_provided(j)%s) - end do - end associate + associate (target => targets(i)%ptr) + if (.not. allocated(target%source)) cycle + if (target%source%unit_type == FPM_UNIT_SUBMODULE) cycle + if (n + size(target%source%modules_provided) >= size(list)) call resize(list) + do j = 1, size(target%source%modules_provided) + n = n + 1 + list(n)%s = join_path(target%output_dir, & + target%source%modules_provided(j)%s) + end do + end associate end do call resize(list, n) -end subroutine filter_modules - + end subroutine filter_modules end module fpm_targets diff --git a/test/cli_test/cli_test.f90 b/test/cli_test/cli_test.f90 index 4fa8e3acf2..2fce663d10 100644 --- a/test/cli_test/cli_test.f90 +++ b/test/cli_test/cli_test.f90 @@ -11,242 +11,237 @@ program main ! ! The program will exit with a non-zero status if any of the tests fail -use, intrinsic :: iso_fortran_env, only : compiler_version, compiler_options -implicit none + use, intrinsic :: iso_fortran_env, only: compiler_version, compiler_options + implicit none ! convenient arbitrary sizes for test ! assuming no name over 15 characters to make output have shorter lines -character(len=15),allocatable :: name(:),act_name(:) ; namelist/act_cli/act_name -integer,parameter :: max_names=10 - -character(len=:),allocatable :: command -character(len=:),allocatable :: cmd -integer :: cstat, estat -integer :: act_cstat, act_estat -integer :: i, ios -logical :: w_e,act_w_e ; namelist/act_cli/act_w_e -logical :: w_t,act_w_t ; namelist/act_cli/act_w_t -logical :: c_s,act_c_s ; namelist/act_cli/act_c_s -logical :: c_a,act_c_a ; namelist/act_cli/act_c_a - -character(len=63) :: profile,act_profile ; namelist/act_cli/act_profile -character(len=:),allocatable :: args,act_args ; namelist/act_cli/act_args -namelist/expected/cmd,cstat,estat,w_e,w_t,c_s,c_a,name,profile,args -integer :: lun -logical,allocatable :: tally(:) -logical,allocatable :: subtally(:) -character(len=256) :: message + character(len=15), allocatable :: name(:), act_name(:); namelist /act_cli/ act_name + integer, parameter :: max_names = 10 + + character(len=:), allocatable :: command + character(len=:), allocatable :: cmd + integer :: cstat, estat + integer :: act_cstat, act_estat + integer :: i, ios + logical :: w_e, act_w_e; namelist /act_cli/ act_w_e + logical :: w_t, act_w_t; namelist /act_cli/ act_w_t + logical :: c_s, act_c_s; namelist /act_cli/ act_c_s + logical :: c_a, act_c_a; namelist /act_cli/ act_c_a + + character(len=63) :: profile, act_profile; namelist /act_cli/ act_profile + character(len=:), allocatable :: args, act_args; namelist /act_cli/ act_args + namelist /expected/ cmd, cstat, estat, w_e, w_t, c_s, c_a, name, profile, args + integer :: lun + logical, allocatable :: tally(:) + logical, allocatable :: subtally(:) + character(len=256) :: message ! table of arguments to pass to program and expected non-default values for that execution in NAMELIST group format -character(len=*),parameter :: tests(*)= [ character(len=256) :: & - -'CMD="new", ESTAT=1,', & -!'CMD="new -unknown", ESTAT=2,', & -'CMD="new my_project another yet_another -test", ESTAT=2,', & -'CMD="new my_project --app", W_E=T, NAME="my_project",', & -'CMD="new my_project --app --test", W_E=T,W_T=T, NAME="my_project",', & -'CMD="new my_project --test", W_T=T, NAME="my_project",', & -'CMD="new my_project", W_E=T,W_T=T, NAME="my_project",', & - -'CMD="run", ', & -'CMD="run my_project", NAME="my_project", ', & -'CMD="run proj1 p2 project3", NAME="proj1","p2","project3", ', & -'CMD="run proj1 p2 project3 --profile debug", NAME="proj1","p2","project3",profile="debug",', & -'CMD="run proj1 p2 project3 --profile release", NAME="proj1","p2","project3",profile="release",', & -'CMD="run proj1 p2 project3 --profile release -- arg1 -x ""and a long one""", & - &NAME="proj1","p2","project3",profile="release",ARGS="""arg1"" ""-x"" ""and a long one""", ', & - -'CMD="test", ', & -'CMD="test my_project", NAME="my_project", ', & -'CMD="test proj1 p2 project3", NAME="proj1","p2","project3", ', & -'CMD="test proj1 p2 project3 --profile debug", NAME="proj1","p2","project3",profile="debug",', & -'CMD="test proj1 p2 project3 --profile release", NAME="proj1","p2","project3",profile="release",', & -'CMD="test proj1 p2 project3 --profile release -- arg1 -x ""and a long one""", & - &NAME="proj1","p2","project3",profile="release" ARGS="""arg1"" ""-x"" ""and a long one""", ', & - -'CMD="build", NAME= profile="",ARGS="",', & -'CMD="build --profile release", NAME= profile="release",ARGS="",', & - -'CMD="clean", NAME= ARGS="",', & -'CMD="clean --skip", C_S=T, NAME= ARGS="",', & -'CMD="clean --all", C_A=T, NAME= ARGS="",', & -' ' ] -character(len=256) :: readme(3) - -readme(1)='&EXPECTED' ! top and bottom line for a NAMELIST group read from TEST() used to set the expected values -readme(3)=' /' -tally=[logical ::] ! an array that tabulates the command test results as pass or fail. - -if(command_argument_count()==0)then ! assume if called with no arguments to do the tests. This means you cannot - ! have a test of no parameters. Could improve on this. - ! if called with parameters assume this is a test and call the routine to - ! parse the resulting values after calling the CLI command line parser - ! and write the NAMELIST group so it can be read and tested against the - ! expected results - write(*,*)'start tests of the CLI command line parser' - command=repeat(' ',4096) - call get_command_argument(0,command) - command=trim(command) - write(*,*)'command=',command - - do i=1,size(tests) - if(tests(i)==' ')then - open(file='_test_cli',newunit=lun,delim='quote') - close(unit=lun,status='delete') - exit - endif + character(len=*), parameter :: tests(*) = [character(len=256) :: & + 'CMD="new", ESTAT=1,', & + !'CMD="new -unknown", ESTAT=2,', & + 'CMD="new my_project another yet_another -test", ESTAT=2,', & + 'CMD="new my_project --app", W_E=T, NAME="my_project",', & + 'CMD="new my_project --app --test", W_E=T,W_T=T, NAME="my_project",', & + 'CMD="new my_project --test", W_T=T, NAME="my_project",', & + 'CMD="new my_project", W_E=T,W_T=T, NAME="my_project",', & + 'CMD="run", ', & + 'CMD="run my_project", NAME="my_project", ', & + 'CMD="run proj1 p2 project3", NAME="proj1","p2","project3", ', & + 'CMD="run proj1 p2 project3 --profile debug", NAME="proj1","p2","project3",profile="debug",', & + 'CMD="run proj1 p2 project3 --profile release", NAME="proj1","p2","project3",profile="release",', & + 'CMD="run proj1 p2 project3 --profile release -- arg1 -x ""and a long one""", & + NAME="proj1","p2","project3",profile="release",ARGS="""arg1"" ""-x"" ""and a long one""", ', & + 'CMD="test", ', & + &'CMD="test my_project", NAME="my_project", ', & + 'CMD="test proj1 p2 project3", NAME="proj1","p2","project3", ', & + 'CMD="test proj1 p2 project3 --profile debug", NAME="proj1","p2","project3",profile="debug",', & + 'CMD="test proj1 p2 project3 --profile release", NAME="proj1","p2","project3",profile="release",', & + 'CMD="test proj1 p2 project3 --profile release -- arg1 -x ""and a long one""", & + NAME="proj1","p2","project3",profile="release" ARGS="""arg1"" ""-x"" ""and a long one""", ', & + 'CMD="build", NAME= profile="",ARGS="",', & + 'CMD="build --profile release", NAME= profile="release",ARGS="",', & + &'CMD="clean", NAME= ARGS="",', & + 'CMD="clean --skip", C_S=T, NAME= ARGS="",', & + 'CMD="clean --all", C_A=T, NAME= ARGS="",', & + ' '] + character(len=256) :: readme(3) + + readme(1) = '&EXPECTED' ! top and bottom line for a NAMELIST group read from TEST() used to set the expected values + readme(3) = ' /' + tally = [logical ::] ! an array that tabulates the command test results as pass or fail. + + if (command_argument_count() == 0) then ! assume if called with no arguments to do the tests. This means you cannot + ! have a test of no parameters. Could improve on this. + ! if called with parameters assume this is a test and call the routine to + ! parse the resulting values after calling the CLI command line parser + ! and write the NAMELIST group so it can be read and tested against the + ! expected results + write (*, *) 'start tests of the CLI command line parser' + command = repeat(' ', 4096) + call get_command_argument(0, command) + command = trim(command) + write (*, *) 'command=', command + + do i = 1, size(tests) + if (tests(i) == ' ') then + open (file='_test_cli', newunit=lun, delim='quote') + close (unit=lun, status='delete') + exit + end if ! blank out name group EXPECTED - name=[(repeat(' ',len(name)),i=1,max_names)] ! the words on the command line sans the subcommand name - profile="" ! --profile PROF - w_e=.false. ! --app - w_t=.false. ! --test - c_s=.false. ! --skip - c_a=.false. ! --all - args=repeat(' ',132) ! -- ARGS - cmd=repeat(' ',132) ! the command line arguments to test - cstat=0 ! status values from EXECUTE_COMMAND_LINE() - estat=0 - readme(2)=' '//tests(i) ! select command options to test for CMD and set nondefault expected values - read(readme,nml=expected) - - write(*,'(*(g0))')'START: TEST ',i,' CMD=',trim(cmd) + name = [(repeat(' ', len(name)), i=1, max_names)] ! the words on the command line sans the subcommand name + profile = "" ! --profile PROF + w_e = .false. ! --app + w_t = .false. ! --test + c_s = .false. ! --skip + c_a = .false. ! --all + args = repeat(' ', 132) ! -- ARGS + cmd = repeat(' ', 132) ! the command line arguments to test + cstat = 0 ! status values from EXECUTE_COMMAND_LINE() + estat = 0 + readme(2) = ' '//tests(i) ! select command options to test for CMD and set nondefault expected values + read (readme, nml=expected) + + write (*, '(*(g0))') 'START: TEST ', i, ' CMD=', trim(cmd) ! call this program which will crack command line and write results to scratch file _test_cli - call execute_command_line(command//' '//trim(cmd),cmdstat=act_cstat,exitstat=act_estat) - if(cstat==act_cstat.and.estat==act_estat)then - if(estat==0)then - open(file='_test_cli',newunit=lun,delim='quote') - act_name=[(repeat(' ',len(act_name)),i=1,max_names)] - act_profile='' - act_w_e=.false. - act_w_t=.false. - act_c_s=.false. - act_c_a=.false. - act_args=repeat(' ',132) - read(lun,nml=act_cli,iostat=ios,iomsg=message) - if(ios/=0)then - write(*,'(a)')'ERROR:',trim(message) - endif - close(unit=lun) - ! compare results to expected values - subtally=[logical ::] - call test_test('NAME',all(act_name==name)) - call test_test('PROFILE',act_profile==profile) - call test_test('WITH_EXPECTED',act_w_e.eqv.w_e) - call test_test('WITH_TESTED',act_w_t.eqv.w_t) - call test_test('WITH_TEST',act_w_t.eqv.w_t) - call test_test('ARGS',act_args==args) - if(all(subtally))then - write(*,'(*(g0))')'PASSED: TEST ',i,' STATUS: expected ',cstat,' ',estat,' actual ',act_cstat,' ',act_estat,& - & ' for [',trim(cmd),']' - tally=[tally,.true.] - else - write(*,'(*(g0))')'FAILED: TEST ',i,' STATUS: expected ',cstat,' ',estat,' actual ',act_cstat,' ',act_estat,& - & ' for [',trim(cmd),']' - print '(4a)', & - 'This file was compiled by ', & - compiler_version(), & - ' using the options ', & - compiler_options() - write(*,nml=act_cli,delim='quote') - tally=[tally,.false.] - endif + call execute_command_line(command//' '//trim(cmd), cmdstat=act_cstat, exitstat=act_estat) + if (cstat == act_cstat .and. estat == act_estat) then + if (estat == 0) then + open (file='_test_cli', newunit=lun, delim='quote') + act_name = [(repeat(' ', len(act_name)), i=1, max_names)] + act_profile = '' + act_w_e = .false. + act_w_t = .false. + act_c_s = .false. + act_c_a = .false. + act_args = repeat(' ', 132) + read (lun, nml=act_cli, iostat=ios, iomsg=message) + if (ios /= 0) then + write (*, '(a)') 'ERROR:', trim(message) + end if + close (unit=lun) + ! compare results to expected values + subtally = [logical ::] + call test_test('NAME', all(act_name == name)) + call test_test('PROFILE', act_profile == profile) + call test_test('WITH_EXPECTED', act_w_e .eqv. w_e) + call test_test('WITH_TESTED', act_w_t .eqv. w_t) + call test_test('WITH_TEST', act_w_t .eqv. w_t) + call test_test('ARGS', act_args == args) + if (all(subtally)) then + write (*, '(*(g0))') 'PASSED: TEST ', i, ' STATUS: expected ', cstat, ' ', estat, ' actual ', act_cstat, ' ', act_estat,& + & ' for [', trim(cmd), ']' + tally = [tally, .true.] else - write(*,'(*(g0))')'PASSED: TEST ',i,' EXPECTED BAD STATUS: expected ',cstat,' ',estat, & - ' actual ',act_cstat,' ',act_estat,' for [',trim(cmd),']' - tally=[tally,.true.] - endif + write (*, '(*(g0))') 'FAILED: TEST ', i, ' STATUS: expected ', cstat, ' ', estat, ' actual ', act_cstat, ' ', act_estat,& + & ' for [', trim(cmd), ']' + print '(4a)', & + 'This file was compiled by ', & + compiler_version(), & + ' using the options ', & + compiler_options() + write (*, nml=act_cli, delim='quote') + tally = [tally, .false.] + end if + else + write (*, '(*(g0))') 'PASSED: TEST ', i, ' EXPECTED BAD STATUS: expected ', cstat, ' ', estat, & + ' actual ', act_cstat, ' ', act_estat, ' for [', trim(cmd), ']' + tally = [tally, .true.] + end if else - write(*,'(*(g0))')'FAILED: TEST ',i,'BAD STATUS: expected ',cstat,' ',estat,' actual ',act_cstat,' ',act_estat,& - ' for [',trim(cmd),']' - tally=[tally,.false.] - endif - enddo - ! write up total results and if anything failed exit with a non-zero status - write(*,'(*(g0))')'TALLY;',tally - if(all(tally))then - write(*,'(*(g0))')'PASSED: all ',count(tally),' tests passed ' - else - write(*,*)'FAILED: PASSED=',count(tally),' FAILED=',count(.not.tally) + write (*, '(*(g0))') 'FAILED: TEST ', i, 'BAD STATUS: expected ', cstat, ' ', estat, ' actual ', act_cstat, ' ', act_estat, & + ' for [', trim(cmd), ']' + tally = [tally, .false.] + end if + end do + ! write up total results and if anything failed exit with a non-zero status + write (*, '(*(g0))') 'TALLY;', tally + if (all(tally)) then + write (*, '(*(g0))') 'PASSED: all ', count(tally), ' tests passed ' + else + write (*, *) 'FAILED: PASSED=', count(tally), ' FAILED=', count(.not. tally) stop 4 - endif -else - ! call this program with arguments - !============================================= - debugit: block - integer :: j, ilen - character(len=256) :: big_argument - write(*,*)'arguments seen directly by program' - do j=1,command_argument_count() - call get_command_argument(number=j,value=big_argument,length=ilen) - write(*,'(*(g0))')j,'[',big_argument(:ilen),']' - enddo - end block debugit - !============================================= - call parse() -endif + end if + else + ! call this program with arguments + !============================================= + debugit: block + integer :: j, ilen + character(len=256) :: big_argument + write (*, *) 'arguments seen directly by program' + do j = 1, command_argument_count() + call get_command_argument(number=j, value=big_argument, length=ilen) + write (*, '(*(g0))') j, '[', big_argument(:ilen), ']' + end do + end block debugit + !============================================= + call parse() + end if contains -subroutine test_test(name,tst) -character(len=*) :: name -logical,intent(in) :: tst + subroutine test_test(name, tst) + character(len=*) :: name + logical, intent(in) :: tst !!write(*,'(*(g0,1x))')' SUBTEST ',name,' ',merge('PASSED','FAILED',tst) - subtally=[subtally,tst] -end subroutine test_test + subtally = [subtally, tst] + end subroutine test_test -subroutine parse() + subroutine parse() ! all the extended types for settings from the main program -use fpm_command_line, only: & - fpm_cmd_settings, & - fpm_new_settings, & - fpm_build_settings, & - fpm_run_settings, & - fpm_test_settings, & - fpm_clean_settings, & - fpm_install_settings, & - get_command_line_settings -use fpm, only: cmd_build, cmd_run, cmd_clean -use fpm_cmd_install, only: cmd_install -use fpm_cmd_new, only: cmd_new -class(fpm_cmd_settings), allocatable :: cmd_settings + use fpm_command_line, only: & + fpm_cmd_settings, & + fpm_new_settings, & + fpm_build_settings, & + fpm_run_settings, & + fpm_test_settings, & + fpm_clean_settings, & + fpm_install_settings, & + get_command_line_settings + use fpm, only: cmd_build, cmd_run, cmd_clean + use fpm_cmd_install, only: cmd_install + use fpm_cmd_new, only: cmd_new + class(fpm_cmd_settings), allocatable :: cmd_settings ! duplicates the calls as seen in the main program for fpm -call get_command_line_settings(cmd_settings) - -allocate (character(len=len(name)) :: act_name(0) ) -act_args='' -act_w_e=.false. -act_w_t=.false. -act_c_s=.false. -act_c_a=.false. -act_profile='' - -select type(settings=>cmd_settings) -type is (fpm_new_settings) - act_w_e=settings%with_executable - act_w_t=settings%with_test - act_name=[trim(settings%name)] -type is (fpm_build_settings) - act_profile=settings%profile -type is (fpm_run_settings) - act_profile=settings%profile - act_name=settings%name - act_args=settings%args -type is (fpm_test_settings) - act_profile=settings%profile - act_name=settings%name - act_args=settings%args -type is (fpm_clean_settings) - act_c_s=settings%clean_skip - act_c_a=settings%clean_call -type is (fpm_install_settings) -end select - -open(file='_test_cli',newunit=lun,delim='quote') -write(lun,nml=act_cli,delim='quote') + call get_command_line_settings(cmd_settings) + + allocate (character(len=len(name)) :: act_name(0)) + act_args = '' + act_w_e = .false. + act_w_t = .false. + act_c_s = .false. + act_c_a = .false. + act_profile = '' + + select type (settings => cmd_settings) + type is (fpm_new_settings) + act_w_e = settings%with_executable + act_w_t = settings%with_test + act_name = [trim(settings%name)] + type is (fpm_build_settings) + act_profile = settings%profile + type is (fpm_run_settings) + act_profile = settings%profile + act_name = settings%name + act_args = settings%args + type is (fpm_test_settings) + act_profile = settings%profile + act_name = settings%name + act_args = settings%args + type is (fpm_clean_settings) + act_c_s = settings%clean_skip + act_c_a = settings%clean_call + type is (fpm_install_settings) + end select + + open (file='_test_cli', newunit=lun, delim='quote') + write (lun, nml=act_cli, delim='quote') !!write(*,nml=act_cli) -close(unit=lun) + close (unit=lun) -end subroutine parse + end subroutine parse end program main diff --git a/test/fpm_test/main.f90 b/test/fpm_test/main.f90 index 0a653076d6..4c2f7dec56 100644 --- a/test/fpm_test/main.f90 +++ b/test/fpm_test/main.f90 @@ -1,106 +1,103 @@ !> Driver for unit testing program fpm_testing - use, intrinsic :: iso_fortran_env, only : error_unit - 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_filesystem, only : collect_filesystem - use test_source_parsing, only : collect_source_parsing - use test_module_dependencies, only : collect_module_dependencies - use test_package_dependencies, only : collect_package_dependencies - use test_backend, only: collect_backend - use test_installer, only : collect_installer - use test_versioning, only : collect_versioning - implicit none - integer :: stat, is - character(len=:), allocatable :: suite_name, test_name - type(testsuite_t), allocatable :: suite(:) - character(len=*), parameter :: fmt = '("#", *(1x, a))' - - stat = 0 - - suite = [ & - & new_testsuite("fpm_toml", collect_toml), & - & new_testsuite("fpm_manifest", collect_manifest), & - & new_testsuite("fpm_filesystem", collect_filesystem), & - & new_testsuite("fpm_source_parsing", collect_source_parsing), & - & new_testsuite("fpm_module_dependencies", collect_module_dependencies), & - & new_testsuite("fpm_package_dependencies", collect_package_dependencies), & - & new_testsuite("fpm_test_backend", collect_backend), & - & new_testsuite("fpm_installer", collect_installer), & - & new_testsuite("fpm_versioning", collect_versioning) & - & ] - - call get_argument(1, suite_name) - call get_argument(2, test_name) - - if (allocated(suite_name)) then - is = select_suite(suite, suite_name) - if (is > 0 .and. is <= size(suite)) then - if (allocated(test_name)) then - write(error_unit, fmt) "Suite:", suite(is)%name - call run_selected(suite(is)%collect, test_name, error_unit, stat) - if (stat < 0) then - error stop 1 - end if - else - write(error_unit, fmt) "Testing:", suite(is)%name - call run_testsuite(suite(is)%collect, error_unit, stat) - end if - else - write(error_unit, fmt) "Available testsuites" - do is = 1, size(suite) - write(error_unit, fmt) "-", suite(is)%name - end do - error stop 1 + use, intrinsic :: iso_fortran_env, only: error_unit + 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_filesystem, only: collect_filesystem + use test_source_parsing, only: collect_source_parsing + use test_module_dependencies, only: collect_module_dependencies + use test_package_dependencies, only: collect_package_dependencies + use test_backend, only: collect_backend + use test_installer, only: collect_installer + use test_versioning, only: collect_versioning + implicit none + integer :: stat, is + character(len=:), allocatable :: suite_name, test_name + type(testsuite_t), allocatable :: suite(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + suite = [ & + & new_testsuite("fpm_toml", collect_toml), & + & new_testsuite("fpm_manifest", collect_manifest), & + & new_testsuite("fpm_filesystem", collect_filesystem), & + & new_testsuite("fpm_source_parsing", collect_source_parsing), & + & new_testsuite("fpm_module_dependencies", collect_module_dependencies), & + & new_testsuite("fpm_package_dependencies", collect_package_dependencies), & + & new_testsuite("fpm_test_backend", collect_backend), & + & new_testsuite("fpm_installer", collect_installer), & + & new_testsuite("fpm_versioning", collect_versioning) & + & ] + + call get_argument(1, suite_name) + call get_argument(2, test_name) + + if (allocated(suite_name)) then + is = select_suite(suite, suite_name) + if (is > 0 .and. is <= size(suite)) then + if (allocated(test_name)) then + write (error_unit, fmt) "Suite:", suite(is)%name + call run_selected(suite(is)%collect, test_name, error_unit, stat) + if (stat < 0) then + error stop 1 end if + else + write (error_unit, fmt) "Testing:", suite(is)%name + call run_testsuite(suite(is)%collect, error_unit, stat) + end if else - do is = 1, size(suite) - write(error_unit, fmt) "Testing:", suite(is)%name - call run_testsuite(suite(is)%collect, error_unit, stat) - end do + write (error_unit, fmt) "Available testsuites" + do is = 1, size(suite) + write (error_unit, fmt) "-", suite(is)%name + end do + error stop 1 end if - - if (stat > 0) then - write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" - error stop 1 - end if - + else + do is = 1, size(suite) + write (error_unit, fmt) "Testing:", suite(is)%name + call run_testsuite(suite(is)%collect, error_unit, stat) + end do + end if + + if (stat > 0) then + 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) - !> 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 - !> Index of command line argument, range [0:command_argument_count()] - integer, intent(in) :: idx + !> Command line argument + character(len=:), allocatable, intent(out) :: arg - !> Command line argument - character(len=:), allocatable, intent(out) :: arg + integer :: length, stat - 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 + call get_command_argument(idx, length=length, status=stat) + if (stat /= 0) then + return + end if - if (length > 0) then - call get_command_argument(idx, arg, status=stat) - if (stat /= 0) then - deallocate(arg) - return - end if - end if + allocate (character(len=length) :: arg, stat=stat) + if (stat /= 0) then + return + end if - end subroutine get_argument + 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/test/fpm_test/test_backend.f90 b/test/fpm_test/test_backend.f90 index 402e8b4d0b..6c426a55c5 100644 --- a/test/fpm_test/test_backend.f90 +++ b/test/fpm_test/test_backend.f90 @@ -1,358 +1,349 @@ !> 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_targets, only: build_target_t, build_target_ptr, & - FPM_TARGET_OBJECT, FPM_TARGET_ARCHIVE, & - add_target, add_dependency - use fpm_backend, only: sort_target, schedule_targets - implicit none - private - - public :: collect_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_targets, only: build_target_t, build_target_ptr, & + FPM_TARGET_OBJECT, FPM_TARGET_ARCHIVE, & + 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) - !> Collect all exported unit tests - subroutine collect_backend(testsuite) + !> Collection of tests + type(unittest_t), allocatable, intent(out) :: 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) & + ] - 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 - end subroutine collect_backend + !> Check scheduling of objects with dependencies + subroutine test_target_sort(error) + !> Error handling + type(error_t), allocatable, intent(out) :: error - !> Check scheduling of objects with dependencies - subroutine test_target_sort(error) + type(build_target_ptr), allocatable :: targets(:) - !> Error handling - type(error_t), allocatable, intent(out) :: error + integer :: i - type(build_target_ptr), allocatable :: targets(:) + targets = new_test_package() - integer :: i + ! Perform depth-first topological sort of targets + do i = 1, size(targets) - targets = new_test_package() + call sort_target(targets(i)%ptr) - ! Perform depth-first topological sort of targets - do i=1,size(targets) + end do - call sort_target(targets(i)%ptr) + ! Check target states: all targets scheduled + do i = 1, size(targets) - end do + if (.not. targets(i)%ptr%touched) then + call test_failed(error, "Target touched flag not set") + return + end if - ! 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 (.not.targets(i)%ptr%touched) then - call test_failed(error,"Target touched 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 (.not.targets(i)%ptr%sorted) then - call test_failed(error,"Target sort flag not set") - return - end if + if (targets(i)%ptr%schedule < 0) then + call test_failed(error, "Target schedule 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 - if (targets(i)%ptr%schedule < 0) then - call test_failed(error,"Target schedule not set") - return - end if + ! Check all objects sheduled before library + do i = 2, size(targets) - end do + if (targets(i)%ptr%schedule >= targets(1)%ptr%schedule) then + call test_failed(error, "Object dependency scheduled after dependent library target") + return + end if - ! Check all objects sheduled before library - do i=2,size(targets) + end do - if (targets(i)%ptr%schedule >= targets(1)%ptr%schedule) then - call test_failed(error,"Object dependency scheduled after dependent library target") - return - end if + ! 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 do + end subroutine test_target_sort - ! 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 + !> Check incremental rebuild for existing archive + !> all object sources are unmodified: all objects should be skipped + subroutine test_target_sort_skip_all(error) - end subroutine test_target_sort + !> Error handling + type(error_t), allocatable, intent(out) :: error + type(build_target_ptr), allocatable :: targets(:) + integer :: fh, i - !> Check incremental rebuild for existing archive - !> all object sources are unmodified: all objects should be skipped - subroutine test_target_sort_skip_all(error) + targets = new_test_package() - !> Error handling - type(error_t), allocatable, intent(out) :: error + do i = 2, size(targets) - type(build_target_ptr), allocatable :: targets(:) + ! Mimick unmodified sources + allocate (targets(i)%ptr%source) + targets(i)%ptr%source%digest = i + targets(i)%ptr%digest_cached = i - integer :: fh, i + end do - targets = new_test_package() + ! Mimick archive already exists + open (newunit=fh, file=targets(1)%ptr%output_file, status="unknown") + close (fh) - do i=2,size(targets) + ! Perform depth-first topological sort of targets + do i = 1, size(targets) - ! Mimick unmodified sources - allocate(targets(i)%ptr%source) - targets(i)%ptr%source%digest = i - targets(i)%ptr%digest_cached = i + call sort_target(targets(i)%ptr) - end do + end do - ! Mimick archive already exists - open(newunit=fh,file=targets(1)%ptr%output_file,status="unknown") - close(fh) + ! Check target states: all targets skipped + do i = 1, size(targets) - ! Perform depth-first topological sort of targets - do i=1,size(targets) + if (.not. targets(i)%ptr%touched) then + call test_failed(error, "Target touched flag not set") + return + end if - call sort_target(targets(i)%ptr) + if (targets(i)%ptr%sorted) then + call test_failed(error, "Target sort flag set incorrectly") + return + end if - end do + if (.not. targets(i)%ptr%skip) then + call test_failed(error, "Target skip flag set incorrectly") + return + end if - ! Check target states: all targets skipped - do i=1,size(targets) + end do - if (.not.targets(i)%ptr%touched) then - call test_failed(error,"Target touched flag not set") - return - end if + end subroutine test_target_sort_skip_all - if (targets(i)%ptr%sorted) then - call test_failed(error,"Target sort flag set incorrectly") - return - end if + !> Check incremental rebuild for existing archive + !> all but lowest source modified: all objects should be rebuilt + subroutine test_target_sort_rebuild_all(error) - if (.not.targets(i)%ptr%skip) then - call test_failed(error,"Target skip flag set incorrectly") - return - end if + !> Error handling + type(error_t), allocatable, intent(out) :: error - end do + type(build_target_ptr), allocatable :: targets(:) - end subroutine test_target_sort_skip_all + integer :: fh, i + targets = new_test_package() - !> Check incremental rebuild for existing archive - !> all but lowest source modified: all objects should be rebuilt - subroutine test_target_sort_rebuild_all(error) + do i = 2, 3 - !> Error handling - type(error_t), allocatable, intent(out) :: error + ! Mimick unmodified sources + allocate (targets(i)%ptr%source) + targets(i)%ptr%source%digest = i + targets(i)%ptr%digest_cached = i - type(build_target_ptr), allocatable :: targets(:) + end do - integer :: fh, i + ! Mimick archive already exists + open (newunit=fh, file=targets(1)%ptr%output_file, status="unknown") + close (fh) - targets = new_test_package() + ! Perform depth-first topological sort of targets + do i = 1, size(targets) - do i=2,3 + call sort_target(targets(i)%ptr) - ! Mimick unmodified sources - allocate(targets(i)%ptr%source) - targets(i)%ptr%source%digest = i - targets(i)%ptr%digest_cached = i + end do - end do + ! Check target states: all targets scheduled + do i = 1, size(targets) - ! Mimick archive already exists - open(newunit=fh,file=targets(1)%ptr%output_file,status="unknown") - close(fh) + if (.not. targets(i)%ptr%sorted) then + call test_failed(error, "Target sort flag not set") + return + end if - ! Perform depth-first topological sort of targets - do i=1,size(targets) + if (targets(i)%ptr%skip) then + call test_failed(error, "Target skip flag set incorrectly") + return + end if - call sort_target(targets(i)%ptr) + end do - end do + end subroutine test_target_sort_rebuild_all - ! Check target states: all targets scheduled - do i=1,size(targets) + !> Check construction of target queue and schedule + subroutine test_schedule_targets(error) - if (.not.targets(i)%ptr%sorted) then - call test_failed(error,"Target sort flag not set") - return - end if + !> Error handling + type(error_t), allocatable, intent(out) :: error - if (targets(i)%ptr%skip) then - call test_failed(error,"Target skip flag set incorrectly") - return - end if + type(build_target_ptr), allocatable :: targets(:) - end do + integer :: i, j + type(build_target_ptr), allocatable :: queue(:) + integer, allocatable :: schedule_ptr(:) - end subroutine test_target_sort_rebuild_all + targets = new_test_package() + ! Perform depth-first topological sort of targets + do i = 1, size(targets) - !> Check construction of target queue and schedule - subroutine test_schedule_targets(error) + call sort_target(targets(i)%ptr) - !> Error handling - type(error_t), allocatable, intent(out) :: error + end do - type(build_target_ptr), allocatable :: targets(:) + ! Construct build schedule queue + call schedule_targets(queue, schedule_ptr, targets) - integer :: i, j - type(build_target_ptr), allocatable :: queue(:) - integer, allocatable :: schedule_ptr(:) + ! Check all targets enqueued + do i = 1, size(targets) - targets = new_test_package() + if (.not. (targets(i)%ptr.in.queue)) then - ! Perform depth-first topological sort of targets - do i=1,size(targets) + call test_failed(error, "Target not found in build queue") + return - call sort_target(targets(i)%ptr) + end if - end do + end do - ! Construct build schedule queue - call schedule_targets(queue, schedule_ptr, targets) + ! Check schedule structure + if (schedule_ptr(1) /= 1) then - ! Check all targets enqueued - do i=1,size(targets) + call test_failed(error, "schedule_ptr(1) does not point to start of the queue") + return - if (.not.(targets(i)%ptr.in.queue)) then + end if - call test_failed(error,"Target not found in build queue") - return + if (schedule_ptr(size(schedule_ptr)) /= size(queue) + 1) then - end if + call test_failed(error, "schedule_ptr(end) does not point to end of the queue") + return - end do + end if - ! Check schedule structure - if (schedule_ptr(1) /= 1) then + do i = 1, size(schedule_ptr) - 1 - call test_failed(error,"schedule_ptr(1) does not point to start of the queue") - return + do j = schedule_ptr(i), (schedule_ptr(i + 1) - 1) - end if - - if (schedule_ptr(size(schedule_ptr)) /= size(queue)+1) then + if (queue(j)%ptr%schedule /= i) then - call test_failed(error,"schedule_ptr(end) does not point to end of the queue") - return + call test_failed(error, "Target scheduled in the wrong region") + 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 do - end do + end subroutine test_schedule_targets - 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 - !> Check construction of target queue and schedule - !> when there's nothing to do (all targets skipped) - subroutine test_schedule_empty(error) + type(build_target_ptr), allocatable :: targets(:) - !> Error handling - type(error_t), allocatable, intent(out) :: error + integer :: i + type(build_target_ptr), allocatable :: queue(:) + integer, allocatable :: schedule_ptr(:) - type(build_target_ptr), allocatable :: targets(:) + targets = new_test_package() - integer :: i - type(build_target_ptr), allocatable :: queue(:) - integer, allocatable :: schedule_ptr(:) + do i = 1, size(targets) - targets = new_test_package() + targets(i)%ptr%skip = .true. - do i=1,size(targets) + end do - targets(i)%ptr%skip = .true. + ! Perform depth-first topological sort of targets + do i = 1, size(targets) - end do + call sort_target(targets(i)%ptr) - ! Perform depth-first topological sort of targets - do i=1,size(targets) + end do - call sort_target(targets(i)%ptr) + ! Construct build schedule queue + call schedule_targets(queue, schedule_ptr, targets) - 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 queue is empty + if (size(queue) > 0) then - ! Check schedule loop is not entered - do i=1,size(schedule_ptr)-1 + call test_failed(error, "Expecting an empty build queue, but not empty") + return - call test_failed(error,"Attempted to run an empty schedule") - return + end if - end do + ! Check schedule loop is not entered + do i = 1, size(schedule_ptr) - 1 - end subroutine test_schedule_empty + call test_failed(error, "Attempted to run an empty schedule") + return + end do - !> Helper to generate target objects with dependencies - function new_test_package() result(targets) + end subroutine test_schedule_empty - type(build_target_ptr), allocatable :: targets(:) - integer :: i + !> Helper to generate target objects with dependencies + function new_test_package() result(targets) - call add_target(targets,'test-package',FPM_TARGET_ARCHIVE,get_temp_filename()) + type(build_target_ptr), allocatable :: targets(:) + integer :: i - call add_target(targets,'test-package',FPM_TARGET_OBJECT,get_temp_filename()) + call add_target(targets, 'test-package', FPM_TARGET_ARCHIVE, get_temp_filename()) - call add_target(targets,'test-package',FPM_TARGET_OBJECT,get_temp_filename()) + call add_target(targets, 'test-package', FPM_TARGET_OBJECT, get_temp_filename()) - call add_target(targets,'test-package',FPM_TARGET_OBJECT,get_temp_filename()) + call add_target(targets, 'test-package', 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) + call add_target(targets, 'test-package', FPM_TARGET_OBJECT, get_temp_filename()) - ! 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) + ! 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) - do i = 1, size(targets) - targets(i)%ptr%output_file = targets(i)%ptr%output_name - end do + ! 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 + do i = 1, size(targets) + targets(i)%ptr%output_file = targets(i)%ptr%output_name + end do + end function new_test_package end module test_backend diff --git a/test/fpm_test/test_filesystem.f90 b/test/fpm_test/test_filesystem.f90 index b6b7681706..ac7c293b10 100644 --- a/test/fpm_test/test_filesystem.f90 +++ b/test/fpm_test/test_filesystem.f90 @@ -1,179 +1,172 @@ module test_filesystem - use testsuite, only : new_unittest, unittest_t, error_t, test_failed - use fpm_filesystem, only: canon_path, is_dir, mkdir, os_delete_dir, & - join_path - use fpm_environment, only: OS_WINDOWS, get_os_type, os_is_unix - implicit none - private + use testsuite, only: new_unittest, unittest_t, error_t, test_failed + use fpm_filesystem, only: canon_path, is_dir, mkdir, os_delete_dir, & + join_path + use fpm_environment, only: OS_WINDOWS, get_os_type, os_is_unix + implicit none + private - public :: collect_filesystem + public :: collect_filesystem contains + !> Collect all exported unit tests + subroutine collect_filesystem(testsuite) - !> Collect all exported unit tests - subroutine collect_filesystem(testsuite) + !> Collection of tests + type(unittest_t), allocatable, intent(out) :: testsuite(:) - !> Collection of tests - type(unittest_t), allocatable, intent(out) :: testsuite(:) + testsuite = [ & + & new_unittest("canon-path", test_canon_path), & + & new_unittest("create-delete-directory", test_mkdir_rmdir) & + ] - testsuite = [ & - & new_unittest("canon-path", test_canon_path), & - & new_unittest("create-delete-directory", test_mkdir_rmdir) & - ] + end subroutine collect_filesystem - end subroutine collect_filesystem + subroutine test_canon_path(error) + !> Error handling + type(error_t), allocatable, intent(out) :: error - subroutine test_canon_path(error) + call check_string(error, & + & canon_path("git/project/src/origin"), "git/project/src/origin") + if (allocated(error)) return - !> Error handling - type(error_t), allocatable, intent(out) :: error + call check_string(error, & + & canon_path("./project/src/origin"), "project/src/origin") + if (allocated(error)) return - call check_string(error, & - & canon_path("git/project/src/origin"), "git/project/src/origin") - if (allocated(error)) return + call check_string(error, & + & canon_path("./project/src///origin/"), "project/src/origin") + if (allocated(error)) return - call check_string(error, & - & canon_path("./project/src/origin"), "project/src/origin") - if (allocated(error)) return + call check_string(error, & + & canon_path("../project/./src/origin/"), "../project/src/origin") + if (allocated(error)) return - call check_string(error, & - & canon_path("./project/src///origin/"), "project/src/origin") - if (allocated(error)) return + call check_string(error, & + & canon_path("/project//src/origin/"), "/project/src/origin") + if (allocated(error)) return - call check_string(error, & - & canon_path("../project/./src/origin/"), "../project/src/origin") - if (allocated(error)) return + call check_string(error, & + & canon_path("/project/src/../origin/"), "/project/origin") + if (allocated(error)) return - call check_string(error, & - & canon_path("/project//src/origin/"), "/project/src/origin") - if (allocated(error)) return + call check_string(error, & + & canon_path("/project/src/../origin/.."), "/project") + if (allocated(error)) return - call check_string(error, & - & canon_path("/project/src/../origin/"), "/project/origin") - if (allocated(error)) return + call check_string(error, & + & canon_path("/project/src//../origin/."), "/project/origin") + if (allocated(error)) return - call check_string(error, & - & canon_path("/project/src/../origin/.."), "/project") - if (allocated(error)) return + call check_string(error, & + & canon_path("../project/src/./../origin/."), "../project/origin") + if (allocated(error)) return - call check_string(error, & - & canon_path("/project/src//../origin/."), "/project/origin") - if (allocated(error)) return + call check_string(error, & + & canon_path("../project/src/../../../origin/."), "../../origin") + if (allocated(error)) return - call check_string(error, & - & canon_path("../project/src/./../origin/."), "../project/origin") - if (allocated(error)) return + call check_string(error, & + & canon_path("/../.."), "/") + if (allocated(error)) return - call check_string(error, & - & canon_path("../project/src/../../../origin/."), "../../origin") - if (allocated(error)) return + call check_string(error, & + & canon_path("././././././/////a/b/.///././////.///c/../../../"), ".") + if (allocated(error)) return - call check_string(error, & - & canon_path("/../.."), "/") - if (allocated(error)) return + call check_string(error, & + & canon_path("/./././././/////a/b/.///././////.///c/../../../"), "/") + if (allocated(error)) return - call check_string(error, & - & canon_path("././././././/////a/b/.///././////.///c/../../../"), ".") - if (allocated(error)) return + end subroutine test_canon_path - call check_string(error, & - & canon_path("/./././././/////a/b/.///././////.///c/../../../"), "/") - if (allocated(error)) return + !> Check a character variable against a reference value + subroutine check_string(error, actual, expected) - end subroutine test_canon_path + !> Error handling + type(error_t), allocatable, intent(out) :: error + !> Actual string value + character(len=*), intent(in) :: actual - !> Check a character variable against a reference value - subroutine check_string(error, actual, expected) + !> Expected string value + character(len=*), intent(in) :: expected - !> Error handling - type(error_t), allocatable, intent(out) :: error + if (actual /= expected) then + call test_failed(error, & + "Character value mismatch "// & + "expected '"//expected//"' but got '"//actual//"'") + end if - !> Actual string value - character(len=*), intent(in) :: actual + end subroutine check_string - !> Expected string value - character(len=*), intent(in) :: expected + subroutine test_mkdir_rmdir(error) - if (actual /= expected) then - call test_failed(error, & - "Character value mismatch "//& - "expected '"//expected//"' but got '"//actual//"'") - end if + !> Error handling + type(error_t), allocatable, intent(out) :: error - end subroutine check_string + call check_mkdir(error, join_path("tmpdir", "subdir")) + if (allocated(error)) return + call check_rmdir(error, "tmpdir") + if (allocated(error)) return - subroutine test_mkdir_rmdir(error) + end subroutine test_mkdir_rmdir - !> Error handling - type(error_t), allocatable, intent(out) :: error + !> Create a directory and verify its existence + subroutine check_mkdir(error, path) - call check_mkdir(error, join_path("tmpdir","subdir")) - if (allocated(error)) return + !> Error handling + type(error_t), allocatable, intent(out) :: error - call check_rmdir(error, "tmpdir") - if (allocated(error)) return + !> Directory path + character(len=*), intent(in) :: path - end subroutine test_mkdir_rmdir + ! Directory shouldn't exist before it's created + if (is_dir(path)) then + call test_failed(error, & + "Directory path "//path//" already exists before its creation") + return + end if + ! Create directory + call mkdir(path) - !> Create a directory and verify its existence - subroutine check_mkdir(error, path) + ! Check that directory is indeed created + if (.not. is_dir(path)) then + call test_failed(error, & + "Directory path "//path//" cannot be created") + end if - !> Error handling - type(error_t), allocatable, intent(out) :: error + end subroutine check_mkdir - !> Directory path - character(len=*), intent(in) :: path + !> Create a directory and verify its existence + subroutine check_rmdir(error, path) - ! Directory shouldn't exist before it's created - if (is_dir(path)) then - call test_failed(error, & - "Directory path "//path//" already exists before its creation") - return - end if + !> Error handling + type(error_t), allocatable, intent(out) :: error - ! Create directory - call mkdir(path) + !> Directory path + character(len=*), intent(in) :: path - ! Check that directory is indeed created - if (.not.is_dir(path)) then - call test_failed(error, & - "Directory path "//path//" cannot be created") - end if + ! Directory should exist before it's deleted + if (.not. is_dir(path)) then + call test_failed(error, & + "Directory path "//path//" doesn't exist before its deletion") + return + end if - end subroutine check_mkdir + ! Delete directory + call os_delete_dir(os_is_unix(), path) + ! Check that directory is indeed deleted + if (is_dir(path)) then + call test_failed(error, & + "Directory path "//path//" cannot be deleted") + end if - !> Create a directory and verify its existence - subroutine check_rmdir(error, path) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - !> Directory path - character(len=*), intent(in) :: path - - ! Directory should exist before it's deleted - if (.not. is_dir(path)) then - call test_failed(error, & - "Directory path "//path//" doesn't exist before its deletion") - return - end if - - ! Delete directory - call os_delete_dir(os_is_unix(),path) - - ! Check that directory is indeed deleted - if (is_dir(path)) then - call test_failed(error, & - "Directory path "//path//" cannot be deleted") - end if - - end subroutine check_rmdir - + end subroutine check_rmdir end module test_filesystem diff --git a/test/fpm_test/test_installer.f90 b/test/fpm_test/test_installer.f90 index 1235ba5bc2..1412fddbcc 100644 --- a/test/fpm_test/test_installer.f90 +++ b/test/fpm_test/test_installer.f90 @@ -3,166 +3,165 @@ !> The tests here setup a mock environment to allow testing for Unix and Windows !> platforms at the same time. module test_installer - use testsuite, only : new_unittest, unittest_t, error_t, test_failed, & - & check_string - use fpm_environment, only : OS_WINDOWS, OS_LINUX - use fpm_filesystem, only : join_path - use fpm_installer - implicit none - private - - public :: collect_installer - - - type, extends(installer_t) :: mock_installer_t - character(len=:), allocatable :: expected_dir - character(len=:), allocatable :: expected_run - contains - procedure :: make_dir - procedure :: run - end type mock_installer_t + use testsuite, only: new_unittest, unittest_t, error_t, test_failed, & + & check_string + use fpm_environment, only: OS_WINDOWS, OS_LINUX + use fpm_filesystem, only: join_path + use fpm_installer + implicit none + private + + public :: collect_installer + + type, extends(installer_t) :: mock_installer_t + character(len=:), allocatable :: expected_dir + character(len=:), allocatable :: expected_run + contains + procedure :: make_dir + procedure :: run + end type mock_installer_t contains - !> Collect all exported unit tests - subroutine collect_installer(testsuite) - !> Collection of tests - type(unittest_t), allocatable, intent(out) :: testsuite(:) + !> Collect all exported unit tests + subroutine collect_installer(testsuite) + !> Collection of tests + type(unittest_t), allocatable, intent(out) :: testsuite(:) - testsuite = [ & - & new_unittest("install-lib", test_install_lib), & - & new_unittest("install-pkgconfig", test_install_pkgconfig), & - & new_unittest("install-sitepackages", test_install_sitepackages), & - & new_unittest("install-mod", test_install_mod), & - & new_unittest("install-exe-unix", test_install_exe_unix), & - & new_unittest("install-exe-win", test_install_exe_win)] + testsuite = [ & + & new_unittest("install-lib", test_install_lib), & + & new_unittest("install-pkgconfig", test_install_pkgconfig), & + & new_unittest("install-sitepackages", test_install_sitepackages), & + & new_unittest("install-mod", test_install_mod), & + & new_unittest("install-exe-unix", test_install_exe_unix), & + & new_unittest("install-exe-win", test_install_exe_win)] - end subroutine collect_installer + end subroutine collect_installer - subroutine test_install_exe_unix(error) - !> Error handling - type(error_t), allocatable, intent(out) :: error + subroutine test_install_exe_unix(error) + !> Error handling + type(error_t), allocatable, intent(out) :: error - type(mock_installer_t) :: mock - type(installer_t) :: installer + type(mock_installer_t) :: mock + type(installer_t) :: installer - call new_installer(installer, prefix="PREFIX", verbosity=0, copy="mock") - mock%installer_t = installer - mock%os = OS_LINUX - mock%expected_dir = "PREFIX/bin" - mock%expected_run = 'mock "name" "'//mock%expected_dir//'"' + call new_installer(installer, prefix="PREFIX", verbosity=0, copy="mock") + mock%installer_t = installer + mock%os = OS_LINUX + mock%expected_dir = "PREFIX/bin" + mock%expected_run = 'mock "name" "'//mock%expected_dir//'"' - call mock%install_executable("name", error) + call mock%install_executable("name", error) - end subroutine test_install_exe_unix + end subroutine test_install_exe_unix - subroutine test_install_exe_win(error) - !> Error handling - type(error_t), allocatable, intent(out) :: error + subroutine test_install_exe_win(error) + !> Error handling + type(error_t), allocatable, intent(out) :: error - type(mock_installer_t) :: mock - type(installer_t) :: installer + type(mock_installer_t) :: mock + type(installer_t) :: installer - call new_installer(installer, prefix="PREFIX", verbosity=0, copy="mock") - mock%installer_t = installer - mock%os = OS_WINDOWS - mock%expected_dir = "PREFIX\bin" - mock%expected_run = 'mock "name.exe" "'//mock%expected_dir//'"' + call new_installer(installer, prefix="PREFIX", verbosity=0, copy="mock") + mock%installer_t = installer + mock%os = OS_WINDOWS + mock%expected_dir = "PREFIX\bin" + mock%expected_run = 'mock "name.exe" "'//mock%expected_dir//'"' - call mock%install_executable("name", error) + call mock%install_executable("name", error) - end subroutine test_install_exe_win + end subroutine test_install_exe_win - subroutine test_install_lib(error) - !> Error handling - type(error_t), allocatable, intent(out) :: error + subroutine test_install_lib(error) + !> Error handling + type(error_t), allocatable, intent(out) :: error - type(mock_installer_t) :: mock - type(installer_t) :: installer + type(mock_installer_t) :: mock + type(installer_t) :: installer - call new_installer(installer, prefix="PREFIX", verbosity=0, copy="mock") - mock%installer_t = installer - mock%expected_dir = join_path("PREFIX", "lib") - mock%expected_run = 'mock "name" "'//join_path("PREFIX", "lib")//'"' + call new_installer(installer, prefix="PREFIX", verbosity=0, copy="mock") + mock%installer_t = installer + mock%expected_dir = join_path("PREFIX", "lib") + mock%expected_run = 'mock "name" "'//join_path("PREFIX", "lib")//'"' - call mock%install_library("name", error) + call mock%install_library("name", error) - end subroutine test_install_lib + end subroutine test_install_lib - subroutine test_install_pkgconfig(error) - !> Error handling - type(error_t), allocatable, intent(out) :: error + subroutine test_install_pkgconfig(error) + !> Error handling + type(error_t), allocatable, intent(out) :: error - type(mock_installer_t) :: mock - type(installer_t) :: installer + type(mock_installer_t) :: mock + type(installer_t) :: installer - call new_installer(installer, prefix="PREFIX", verbosity=0, copy="mock") - mock%installer_t = installer - mock%os = OS_WINDOWS - mock%expected_dir = "PREFIX\lib\pkgconfig" - mock%expected_run = 'mock "name" "'//mock%expected_dir//'"' + call new_installer(installer, prefix="PREFIX", verbosity=0, copy="mock") + mock%installer_t = installer + mock%os = OS_WINDOWS + mock%expected_dir = "PREFIX\lib\pkgconfig" + mock%expected_run = 'mock "name" "'//mock%expected_dir//'"' - call mock%install("name", "lib/pkgconfig", error) + call mock%install("name", "lib/pkgconfig", error) - end subroutine test_install_pkgconfig + end subroutine test_install_pkgconfig - subroutine test_install_sitepackages(error) - !> Error handling - type(error_t), allocatable, intent(out) :: error + subroutine test_install_sitepackages(error) + !> Error handling + type(error_t), allocatable, intent(out) :: error - type(mock_installer_t) :: mock - type(installer_t) :: installer + type(mock_installer_t) :: mock + type(installer_t) :: installer - call new_installer(installer, prefix="PREFIX", verbosity=0, copy="mock") - mock%installer_t = installer - mock%os = OS_LINUX - mock%expected_dir = "PREFIX/lib/python3.7/site-packages" - mock%expected_run = 'mock "name" "'//mock%expected_dir//'"' + call new_installer(installer, prefix="PREFIX", verbosity=0, copy="mock") + mock%installer_t = installer + mock%os = OS_LINUX + mock%expected_dir = "PREFIX/lib/python3.7/site-packages" + mock%expected_run = 'mock "name" "'//mock%expected_dir//'"' - call mock%install("name", join_path("lib", "python3.7", "site-packages"), & - error) + call mock%install("name", join_path("lib", "python3.7", "site-packages"), & + error) - end subroutine test_install_sitepackages + end subroutine test_install_sitepackages - subroutine test_install_mod(error) - !> Error handling - type(error_t), allocatable, intent(out) :: error + subroutine test_install_mod(error) + !> Error handling + type(error_t), allocatable, intent(out) :: error - type(mock_installer_t) :: mock - type(installer_t) :: installer + type(mock_installer_t) :: mock + type(installer_t) :: installer - call new_installer(installer, prefix="PREFIX", verbosity=0, copy="mock") - mock%installer_t = installer - mock%expected_dir = join_path("PREFIX", "include") - mock%expected_run = 'mock "name" "'//join_path("PREFIX", "include")//'"' + call new_installer(installer, prefix="PREFIX", verbosity=0, copy="mock") + mock%installer_t = installer + mock%expected_dir = join_path("PREFIX", "include") + mock%expected_run = 'mock "name" "'//join_path("PREFIX", "include")//'"' - call mock%install_header("name", error) + call mock%install_header("name", error) - end subroutine test_install_mod + end subroutine test_install_mod - !> Create a new directory in the prefix - subroutine make_dir(self, dir, error) - !> Instance of the installer - class(mock_installer_t), intent(inout) :: self - !> Directory to be created - character(len=*), intent(in) :: dir - !> Error handling - type(error_t), allocatable, intent(out) :: error + !> Create a new directory in the prefix + subroutine make_dir(self, dir, error) + !> Instance of the installer + class(mock_installer_t), intent(inout) :: self + !> Directory to be created + character(len=*), intent(in) :: dir + !> Error handling + type(error_t), allocatable, intent(out) :: error - call check_string(error, self%expected_dir, dir, "dir") + call check_string(error, self%expected_dir, dir, "dir") - end subroutine make_dir + end subroutine make_dir - !> Run an installation command - subroutine run(self, command, error) - !> Instance of the installer - class(mock_installer_t), intent(inout) :: self - !> Command to be launched - character(len=*), intent(in) :: command - !> Error handling - type(error_t), allocatable, intent(out) :: error + !> Run an installation command + subroutine run(self, command, error) + !> Instance of the installer + class(mock_installer_t), intent(inout) :: self + !> Command to be launched + character(len=*), intent(in) :: command + !> Error handling + type(error_t), allocatable, intent(out) :: error - call check_string(error, self%expected_run, command, "run") - end subroutine run + call check_string(error, self%expected_run, command, "run") + end subroutine run end module test_installer diff --git a/test/fpm_test/test_manifest.f90 b/test/fpm_test/test_manifest.f90 index e608e79fcf..5ad566a86c 100644 --- a/test/fpm_test/test_manifest.f90 +++ b/test/fpm_test/test_manifest.f90 @@ -1,1385 +1,1342 @@ !> Define tests for the `fpm_manifest` modules module test_manifest - use fpm_filesystem, only: get_temp_filename - use testsuite, only : new_unittest, unittest_t, error_t, test_failed, & - & check_string - use fpm_manifest - use fpm_manifest_profile, only: profile_config_t, find_profile - use fpm_strings, only: operator(.in.) - implicit none - private - - public :: collect_manifest + use fpm_filesystem, only: get_temp_filename + use testsuite, only: new_unittest, unittest_t, error_t, test_failed, & + & check_string + use fpm_manifest + use fpm_manifest_profile, only: profile_config_t, find_profile + use fpm_strings, only: operator(.in.) + implicit none + private + public :: collect_manifest contains + !> Collect all exported unit tests + subroutine collect_manifest(testsuite) + + !> Collection of tests + type(unittest_t), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + & new_unittest("valid-manifest", test_valid_manifest), & + & new_unittest("invalid-manifest", test_invalid_manifest, should_fail=.true.), & + & new_unittest("default-library", test_default_library), & + & new_unittest("default-executable", test_default_executable), & + & new_unittest("dependency-empty", test_dependency_empty, should_fail=.true.), & + & new_unittest("dependency-pathtag", test_dependency_pathtag, should_fail=.true.), & + & new_unittest("dependency-gitpath", test_dependency_gitpath, should_fail=.true.), & + & new_unittest("dependency-nourl", test_dependency_nourl, should_fail=.true.), & + & new_unittest("dependency-gitconflict", test_dependency_gitconflict, should_fail=.true.), & + & new_unittest("dependency-invalid-git", test_dependency_invalid_git, should_fail=.true.), & + & new_unittest("dependency-wrongkey", test_dependency_wrongkey, should_fail=.true.), & + & new_unittest("dependencies-empty", test_dependencies_empty), & + & new_unittest("dependencies-typeerror", test_dependencies_typeerror, should_fail=.true.), & + & new_unittest("profiles", test_profiles), & + & new_unittest("profiles-keyvalue-table", test_profiles_keyvalue_table, should_fail=.true.), & + & new_unittest("executable-empty", test_executable_empty, should_fail=.true.), & + & new_unittest("executable-typeerror", test_executable_typeerror, should_fail=.true.), & + & new_unittest("executable-noname", test_executable_noname, should_fail=.true.), & + & new_unittest("executable-wrongkey", test_executable_wrongkey, should_fail=.true.), & + & new_unittest("build-config-valid", test_build_valid), & + & new_unittest("build-config-empty", test_build_empty), & + & new_unittest("build-config-invalid-values", test_build_invalid_values, should_fail=.true.), & + & new_unittest("library-empty", test_library_empty), & + & new_unittest("library-wrongkey", test_library_wrongkey, should_fail=.true.), & + & new_unittest("package-simple", test_package_simple), & + & new_unittest("package-empty", test_package_empty, should_fail=.true.), & + & new_unittest("package-typeerror", test_package_typeerror, should_fail=.true.), & + & new_unittest("package-noname", test_package_noname, should_fail=.true.), & + & new_unittest("package-wrongexe", test_package_wrongexe, should_fail=.true.), & + & new_unittest("package-wrongtest", test_package_wrongtest, should_fail=.true.), & + & new_unittest("package-duplicate", test_package_duplicate, should_fail=.true.), & + & new_unittest("test-simple", test_test_simple), & + & new_unittest("test-empty", test_test_empty, should_fail=.true.), & + & new_unittest("test-typeerror", test_test_typeerror, should_fail=.true.), & + & new_unittest("test-noname", test_test_noname, should_fail=.true.), & + & new_unittest("test-wrongkey", test_test_wrongkey, should_fail=.true.), & + & new_unittest("link-string", test_link_string), & + & new_unittest("link-array", test_link_array), & + & new_unittest("link-error", test_invalid_link, should_fail=.true.), & + & new_unittest("example-simple", test_example_simple), & + & new_unittest("example-empty", test_example_empty, should_fail=.true.), & + & new_unittest("install-library", test_install_library), & + & new_unittest("install-empty", test_install_empty), & + & new_unittest("install-wrongkey", test_install_wrongkey, should_fail=.true.), & + & new_unittest("preprocess-empty", test_preprocess_empty), & + & new_unittest("preprocess-wrongkey", test_preprocess_wrongkey, should_fail=.true.), & + & new_unittest("preprocessors-empty", test_preprocessors_empty, should_fail=.true.), & + & new_unittest("macro-parsing", test_macro_parsing, should_fail=.false.), & + & new_unittest("macro-parsing-dependency", test_macro_parsing_dependency, should_fail=.false.)] + + end subroutine collect_manifest + + !> Try to read some unnecessary obscure and convoluted but not invalid package file + subroutine test_valid_manifest(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(package_config_t) :: package + character(len=*), parameter :: manifest = 'fpm-valid-manifest.toml' + integer :: unit + + open (file=manifest, newunit=unit) + write (unit, '(a)') & + & 'name = "example"', & + & '[build]', & + & 'auto-executables = false', & + & 'auto-tests = false', & + & '[dependencies.fpm]', & + & 'git = "https://github.com/fortran-lang/fpm"', & + & '[[executable]]', & + & 'name = "example-1" # comment', & + & 'source-dir = "prog"', & + & '[dependencies]', & + & 'toml-f.git = "git@github.com:toml-f/toml-f.git"', & + & '"toml..f" = { path = ".." }', & + & '[["executable"]]', & + & 'name = "example-2"', & + & 'source-dir = "prog"', & + & '[executable.dependencies]', & + & '[''library'']', & + & 'source-dir = """', & + & 'lib""" # comment', & + & '[preprocess]', & + & '[preprocess.cpp]', & + & 'suffixes = ["F90", "f90"]', & + & 'directories = ["src/feature1", "src/models"]', & + & 'macros = ["FOO", "BAR"]' + close (unit) + + call get_package_data(package, manifest, error) + + open (file=manifest, newunit=unit) + close (unit, status='delete') + + if (allocated(error)) return + + if (package%name /= "example") then + call test_failed(error, "Package name is "//package%name//" but should be example") + return + end if + + if (.not. allocated(package%library)) then + call test_failed(error, "library is not present in package data") + return + end if + + if (.not. allocated(package%executable)) then + call test_failed(error, "executable is not present in package data") + return + end if + + if (size(package%executable) /= 2) then + call test_failed(error, "Number of executables in package is not two") + return + end if + + if (.not. allocated(package%dependency)) then + call test_failed(error, "dependency is not present in package data") + return + end if + + if (size(package%dependency) /= 3) then + call test_failed(error, "Number of dependencies in package is not three") + return + end if + + if (allocated(package%test)) then + call test_failed(error, "test is present in package but not in package file") + return + end if + + if (.not. allocated(package%preprocess)) then + call test_failed(error, "Preprocessor is not present in package data") + return + end if + + if (size(package%preprocess) /= 1) then + call test_failed(error, "Number of preprocessors in package is not one") + return + end if + + end subroutine test_valid_manifest + + !> Try to read a valid TOML document which represent an invalid package file + subroutine test_invalid_manifest(error) - !> Collect all exported unit tests - subroutine collect_manifest(testsuite) - - !> Collection of tests - type(unittest_t), allocatable, intent(out) :: testsuite(:) - - testsuite = [ & - & new_unittest("valid-manifest", test_valid_manifest), & - & new_unittest("invalid-manifest", test_invalid_manifest, should_fail=.true.), & - & new_unittest("default-library", test_default_library), & - & new_unittest("default-executable", test_default_executable), & - & new_unittest("dependency-empty", test_dependency_empty, should_fail=.true.), & - & new_unittest("dependency-pathtag", test_dependency_pathtag, should_fail=.true.), & - & new_unittest("dependency-gitpath", test_dependency_gitpath, should_fail=.true.), & - & new_unittest("dependency-nourl", test_dependency_nourl, should_fail=.true.), & - & new_unittest("dependency-gitconflict", test_dependency_gitconflict, should_fail=.true.), & - & new_unittest("dependency-invalid-git", test_dependency_invalid_git, should_fail=.true.), & - & new_unittest("dependency-wrongkey", test_dependency_wrongkey, should_fail=.true.), & - & new_unittest("dependencies-empty", test_dependencies_empty), & - & new_unittest("dependencies-typeerror", test_dependencies_typeerror, should_fail=.true.), & - & new_unittest("profiles", test_profiles), & - & new_unittest("profiles-keyvalue-table", test_profiles_keyvalue_table, should_fail=.true.), & - & new_unittest("executable-empty", test_executable_empty, should_fail=.true.), & - & new_unittest("executable-typeerror", test_executable_typeerror, should_fail=.true.), & - & new_unittest("executable-noname", test_executable_noname, should_fail=.true.), & - & new_unittest("executable-wrongkey", test_executable_wrongkey, should_fail=.true.), & - & new_unittest("build-config-valid", test_build_valid), & - & new_unittest("build-config-empty", test_build_empty), & - & new_unittest("build-config-invalid-values", test_build_invalid_values, should_fail=.true.), & - & new_unittest("library-empty", test_library_empty), & - & new_unittest("library-wrongkey", test_library_wrongkey, should_fail=.true.), & - & new_unittest("package-simple", test_package_simple), & - & new_unittest("package-empty", test_package_empty, should_fail=.true.), & - & new_unittest("package-typeerror", test_package_typeerror, should_fail=.true.), & - & new_unittest("package-noname", test_package_noname, should_fail=.true.), & - & new_unittest("package-wrongexe", test_package_wrongexe, should_fail=.true.), & - & new_unittest("package-wrongtest", test_package_wrongtest, should_fail=.true.), & - & new_unittest("package-duplicate", test_package_duplicate, should_fail=.true.), & - & new_unittest("test-simple", test_test_simple), & - & new_unittest("test-empty", test_test_empty, should_fail=.true.), & - & new_unittest("test-typeerror", test_test_typeerror, should_fail=.true.), & - & new_unittest("test-noname", test_test_noname, should_fail=.true.), & - & new_unittest("test-wrongkey", test_test_wrongkey, should_fail=.true.), & - & new_unittest("link-string", test_link_string), & - & new_unittest("link-array", test_link_array), & - & new_unittest("link-error", test_invalid_link, should_fail=.true.), & - & new_unittest("example-simple", test_example_simple), & - & new_unittest("example-empty", test_example_empty, should_fail=.true.), & - & new_unittest("install-library", test_install_library), & - & new_unittest("install-empty", test_install_empty), & - & new_unittest("install-wrongkey", test_install_wrongkey, should_fail=.true.), & - & new_unittest("preprocess-empty", test_preprocess_empty), & - & new_unittest("preprocess-wrongkey", test_preprocess_wrongkey, should_fail=.true.), & - & new_unittest("preprocessors-empty", test_preprocessors_empty, should_fail=.true.), & - & new_unittest("macro-parsing", test_macro_parsing, should_fail=.false.), & - & new_unittest("macro-parsing-dependency", test_macro_parsing_dependency, should_fail=.false.)] - - end subroutine collect_manifest - - - !> Try to read some unnecessary obscure and convoluted but not invalid package file - subroutine test_valid_manifest(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(package_config_t) :: package - character(len=*), parameter :: manifest = 'fpm-valid-manifest.toml' - integer :: unit - - open(file=manifest, newunit=unit) - write(unit, '(a)') & - & 'name = "example"', & - & '[build]', & - & 'auto-executables = false', & - & 'auto-tests = false', & - & '[dependencies.fpm]', & - & 'git = "https://github.com/fortran-lang/fpm"', & - & '[[executable]]', & - & 'name = "example-1" # comment', & - & 'source-dir = "prog"', & - & '[dependencies]', & - & 'toml-f.git = "git@github.com:toml-f/toml-f.git"', & - & '"toml..f" = { path = ".." }', & - & '[["executable"]]', & - & 'name = "example-2"', & - & 'source-dir = "prog"', & - & '[executable.dependencies]', & - & '[''library'']', & - & 'source-dir = """', & - & 'lib""" # comment', & - & '[preprocess]', & - & '[preprocess.cpp]', & - & 'suffixes = ["F90", "f90"]', & - & 'directories = ["src/feature1", "src/models"]', & - & 'macros = ["FOO", "BAR"]' - close(unit) - - call get_package_data(package, manifest, error) - - open(file=manifest, newunit=unit) - close(unit, status='delete') - - if (allocated(error)) return - - if (package%name /= "example") then - call test_failed(error, "Package name is "//package%name//" but should be example") - return - end if - - if (.not.allocated(package%library)) then - call test_failed(error, "library is not present in package data") - return - end if - - if (.not.allocated(package%executable)) then - call test_failed(error, "executable is not present in package data") - return - end if - - if (size(package%executable) /= 2) then - call test_failed(error, "Number of executables in package is not two") - return - end if - - if (.not.allocated(package%dependency)) then - call test_failed(error, "dependency is not present in package data") - return - end if - - if (size(package%dependency) /= 3) then - call test_failed(error, "Number of dependencies in package is not three") - return - end if - - if (allocated(package%test)) then - call test_failed(error, "test is present in package but not in package file") - return - end if - - if (.not.allocated(package%preprocess)) then - call test_failed(error, "Preprocessor is not present in package data") - return - end if - - if (size(package%preprocess) /= 1) then - call test_failed(error, "Number of preprocessors in package is not one") - return - end if - - end subroutine test_valid_manifest - - - !> Try to read a valid TOML document which represent an invalid package file - subroutine test_invalid_manifest(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(package_config_t) :: package - character(len=*), parameter :: manifest = 'fpm-invalid-manifest.toml' - integer :: unit - - open(file=manifest, newunit=unit) - write(unit, '(a)') & - & '[package]', & - & 'name = "example"', & - & 'version = "0.1.0"' - close(unit) - - call get_package_data(package, manifest, error) - - open(file=manifest, newunit=unit) - close(unit, status='delete') - - end subroutine test_invalid_manifest - - - !> Create a default library - subroutine test_default_library(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(package_config_t) :: package - - allocate(package%library) - call default_library(package%library) - - call check_string(error, package%library%source_dir, "src", & - & "Default library source-dir") - if (allocated(error)) return - - if (.not.allocated(package%library%include_dir)) then - call test_failed(error,"Default include-dir list not allocated") - return - end if - - if (.not.("include".in.package%library%include_dir)) then - call test_failed(error,"'include' not in default include-dir list") - return - end if - - end subroutine test_default_library - - - !> Create a default executable - subroutine test_default_executable(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(package_config_t) :: package - character(len=*), parameter :: name = "default" - - allocate(package%executable(1)) - call default_executable(package%executable(1), name) - - call check_string(error, package%executable(1)%source_dir, "app", & - & "Default executable source-dir") - if (allocated(error)) return - - call check_string(error, package%executable(1)%name, name, & - & "Default executable name") - if (allocated(error)) return - - end subroutine test_default_executable - - - !> Dependencies cannot be created from empty tables - subroutine test_dependency_empty(error) - use fpm_manifest_dependency - use fpm_toml, only : new_table, toml_table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(dependency_config_t) :: dependency - - call new_table(table) - table%key = "example" - - call new_dependency(dependency, table, error=error) - - end subroutine test_dependency_empty - - - !> Try to create a dependency with conflicting entries - subroutine test_dependency_pathtag(error) - use fpm_manifest_dependency - use fpm_toml, only : new_table, toml_table, set_value - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - integer :: stat - type(dependency_config_t) :: dependency - - call new_table(table) - table%key = 'example' - call set_value(table, 'path', 'package', stat) - call set_value(table, 'tag', 'v20.1', stat) - - call new_dependency(dependency, table, error=error) - - end subroutine test_dependency_pathtag - - - !> Try to create a dependency with conflicting entries - subroutine test_dependency_nourl(error) - use fpm_manifest_dependency - use fpm_toml, only : new_table, toml_table, set_value - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - integer :: stat - type(dependency_config_t) :: dependency - - call new_table(table) - table%key = 'example' - call set_value(table, 'tag', 'v20.1', stat) - - call new_dependency(dependency, table, error=error) - - end subroutine test_dependency_nourl - - - !> Try to create a dependency with conflicting entries - subroutine test_dependency_gitpath(error) - use fpm_manifest_dependency - use fpm_toml, only : new_table, toml_table, set_value - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - integer :: stat - type(dependency_config_t) :: dependency - - call new_table(table) - table%key = 'example' - call set_value(table, 'path', 'package', stat) - call set_value(table, 'git', 'https://gitea.com/fortran-lang/pack', stat) - - call new_dependency(dependency, table, error=error) - - end subroutine test_dependency_gitpath - - - !> Try to create a dependency with conflicting entries - subroutine test_dependency_gitconflict(error) - use fpm_manifest_dependency - use fpm_toml, only : new_table, toml_table, set_value - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - integer :: stat - type(dependency_config_t) :: dependency - - call new_table(table) - table%key = 'example' - call set_value(table, 'git', 'https://gitea.com/fortran-lang/pack', stat) - call set_value(table, 'branch', 'latest', stat) - call set_value(table, 'tag', 'v20.1', stat) - - call new_dependency(dependency, table, error=error) - - end subroutine test_dependency_gitconflict - - - !> Try to create a git dependency with invalid source format - subroutine test_dependency_invalid_git(error) - use fpm_manifest_dependency - use fpm_toml, only : new_table, add_table, toml_table, set_value + !> Error handling + type(error_t), allocatable, intent(out) :: error - !> Error handling - type(error_t), allocatable, intent(out) :: error + type(package_config_t) :: package + character(len=*), parameter :: manifest = 'fpm-invalid-manifest.toml' + integer :: unit - type(toml_table) :: table - type(toml_table), pointer :: child - integer :: stat - type(dependency_config_t) :: dependency + open (file=manifest, newunit=unit) + write (unit, '(a)') & + & '[package]', & + & 'name = "example"', & + & 'version = "0.1.0"' + close (unit) - call new_table(table) - table%key = 'example' - call add_table(table, 'git', child) - call set_value(child, 'path', '../../package') + call get_package_data(package, manifest, error) + + open (file=manifest, newunit=unit) + close (unit, status='delete') - call new_dependency(dependency, table, error=error) + end subroutine test_invalid_manifest - end subroutine test_dependency_invalid_git + !> Create a default library + subroutine test_default_library(error) + !> Error handling + type(error_t), allocatable, intent(out) :: error - !> Try to create a dependency with conflicting entries - subroutine test_dependency_wrongkey(error) - use fpm_manifest_dependency - use fpm_toml, only : new_table, toml_table, set_value + type(package_config_t) :: package - !> Error handling - type(error_t), allocatable, intent(out) :: error + allocate (package%library) + call default_library(package%library) - type(toml_table) :: table - integer :: stat - type(dependency_config_t) :: dependency + call check_string(error, package%library%source_dir, "src", & + & "Default library source-dir") + if (allocated(error)) return - call new_table(table) - table%key = 'example' - call set_value(table, 'not-available', 'anywhere', stat) + if (.not. allocated(package%library%include_dir)) then + call test_failed(error, "Default include-dir list not allocated") + return + end if - call new_dependency(dependency, table, error=error) + if (.not. ("include".in.package%library%include_dir)) then + call test_failed(error, "'include' not in default include-dir list") + return + end if - end subroutine test_dependency_wrongkey + end subroutine test_default_library + !> Create a default executable + subroutine test_default_executable(error) - !> Dependency tables can be empty - subroutine test_dependencies_empty(error) - use fpm_manifest_dependency - use fpm_toml, only : new_table, toml_table + !> Error handling + type(error_t), allocatable, intent(out) :: error - !> Error handling - type(error_t), allocatable, intent(out) :: error + type(package_config_t) :: package + character(len=*), parameter :: name = "default" - type(toml_table) :: table - type(dependency_config_t), allocatable :: dependencies(:) + allocate (package%executable(1)) + call default_executable(package%executable(1), name) - call new_table(table) + call check_string(error, package%executable(1)%source_dir, "app", & + & "Default executable source-dir") + if (allocated(error)) return - call new_dependencies(dependencies, table, error=error) - if (allocated(error)) return + call check_string(error, package%executable(1)%name, name, & + & "Default executable name") + if (allocated(error)) return - if (allocated(dependencies)) then - call test_failed(error, "Found dependencies in empty table") - end if + end subroutine test_default_executable - end subroutine test_dependencies_empty + !> Dependencies cannot be created from empty tables + subroutine test_dependency_empty(error) + use fpm_manifest_dependency + use fpm_toml, only: new_table, toml_table + !> Error handling + type(error_t), allocatable, intent(out) :: error - !> Add a dependency as an array, which is not supported - subroutine test_dependencies_typeerror(error) - use fpm_manifest_dependency - use fpm_toml, only : new_table, add_array, toml_table, toml_array + type(toml_table) :: table + type(dependency_config_t) :: dependency - !> Error handling - type(error_t), allocatable, intent(out) :: error + call new_table(table) + table%key = "example" - type(toml_table) :: table - type(toml_array), pointer :: children - integer :: stat - type(dependency_config_t), allocatable :: dependencies(:) + call new_dependency(dependency, table, error=error) - call new_table(table) - call add_array(table, 'dep1', children, stat) + end subroutine test_dependency_empty - call new_dependencies(dependencies, table, error=error) + !> Try to create a dependency with conflicting entries + subroutine test_dependency_pathtag(error) + use fpm_manifest_dependency + use fpm_toml, only: new_table, toml_table, set_value - end subroutine test_dependencies_typeerror + !> Error handling + type(error_t), allocatable, intent(out) :: error - !> Include a table of profiles in toml, check whether they are parsed correctly and stored in package - subroutine test_profiles(error) + type(toml_table) :: table + integer :: stat + type(dependency_config_t) :: dependency - !> Error handling - type(error_t), allocatable, intent(out) :: error + call new_table(table) + table%key = 'example' + call set_value(table, 'path', 'package', stat) + call set_value(table, 'tag', 'v20.1', stat) - type(package_config_t) :: package - character(len=*), parameter :: manifest = 'fpm-profiles.toml' - integer :: unit - character(:), allocatable :: profile_name, compiler, flags - logical :: profile_found - type(profile_config_t) :: chosen_profile + call new_dependency(dependency, table, error=error) - open(file=manifest, newunit=unit) - write(unit, '(a)') & - & 'name = "example"', & - & '[profiles.release.gfortran.linux]', & - & 'flags = "1" #release.gfortran.linux', & - & '[profiles.release.gfortran]', & - & 'flags = "2" #release.gfortran.all', & - & '[profiles.gfortran.linux]', & - & 'flags = "3" #all.gfortran.linux', & - & '[profiles.gfortran]', & - & 'flags = "4" #all.gfortran.all', & - & '[profiles.release.ifort]', & - & 'flags = "5" #release.ifort.all' - close(unit) + end subroutine test_dependency_pathtag - call get_package_data(package, manifest, error) + !> Try to create a dependency with conflicting entries + subroutine test_dependency_nourl(error) + use fpm_manifest_dependency + use fpm_toml, only: new_table, toml_table, set_value - open(file=manifest, newunit=unit) - close(unit, status='delete') + !> Error handling + type(error_t), allocatable, intent(out) :: error - if (allocated(error)) return + type(toml_table) :: table + integer :: stat + type(dependency_config_t) :: dependency - profile_name = 'release' - compiler = 'gfortran' - call find_profile(package%profiles, profile_name, compiler, 1, profile_found, chosen_profile) - if (.not.(chosen_profile%flags.eq.'1 3')) then - call test_failed(error, "Failed to append flags from profiles named 'all'") - return - end if + call new_table(table) + table%key = 'example' + call set_value(table, 'tag', 'v20.1', stat) - profile_name = 'release' - compiler = 'gfortran' - call find_profile(package%profiles, profile_name, compiler, 3, profile_found, chosen_profile) - if (.not.(chosen_profile%flags.eq.'2 4')) then - call test_failed(error, "Failed to choose profile with OS 'all'") - return - end if + call new_dependency(dependency, table, error=error) - profile_name = 'publish' - compiler = 'gfortran' - call find_profile(package%profiles, profile_name, compiler, 1, profile_found, chosen_profile) - if (allocated(chosen_profile%flags)) then - call test_failed(error, "Profile named "//profile_name//" should not exist") - return - end if + end subroutine test_dependency_nourl - profile_name = 'debug' - compiler = 'ifort' - call find_profile(package%profiles, profile_name, compiler, 3, profile_found, chosen_profile) - if (.not.(chosen_profile%flags.eq.' /warn:all /check:all /error-limit:1 /Od /Z7 /assume:byterecl /traceback')) then - call test_failed(error, "Failed to load built-in profile"//flags) - return - end if + !> Try to create a dependency with conflicting entries + subroutine test_dependency_gitpath(error) + use fpm_manifest_dependency + use fpm_toml, only: new_table, toml_table, set_value - profile_name = 'release' - compiler = 'ifort' - call find_profile(package%profiles, profile_name, compiler, 1, profile_found, chosen_profile) - if (.not.(chosen_profile%flags.eq.'5')) then - call test_failed(error, "Failed to overwrite built-in profile") - return - end if - end subroutine test_profiles + !> Error handling + type(error_t), allocatable, intent(out) :: error - !> 'flags' is a key-value entry, test should fail as it is defined as a table - subroutine test_profiles_keyvalue_table(error) + type(toml_table) :: table + integer :: stat + type(dependency_config_t) :: dependency - !> Error handling - type(error_t), allocatable, intent(out) :: error + call new_table(table) + table%key = 'example' + call set_value(table, 'path', 'package', stat) + call set_value(table, 'git', 'https://gitea.com/fortran-lang/pack', stat) - type(package_config_t) :: package - character(len=*), parameter :: manifest = 'fpm-profiles-error.toml' - integer :: unit - character(:), allocatable :: profile_name, compiler, flags + call new_dependency(dependency, table, error=error) - open(file=manifest, newunit=unit) - write(unit, '(a)') & - & 'name = "example"', & - & '[profiles.linux.flags]' - close(unit) + end subroutine test_dependency_gitpath - call get_package_data(package, manifest, error) + !> Try to create a dependency with conflicting entries + subroutine test_dependency_gitconflict(error) + use fpm_manifest_dependency + use fpm_toml, only: new_table, toml_table, set_value - open(file=manifest, newunit=unit) - close(unit, status='delete') - end subroutine test_profiles_keyvalue_table + !> Error handling + type(error_t), allocatable, intent(out) :: error - !> Executables cannot be created from empty tables - subroutine test_executable_empty(error) - use fpm_manifest_executable - use fpm_toml, only : new_table, toml_table + type(toml_table) :: table + integer :: stat + type(dependency_config_t) :: dependency - !> Error handling - type(error_t), allocatable, intent(out) :: error + call new_table(table) + table%key = 'example' + call set_value(table, 'git', 'https://gitea.com/fortran-lang/pack', stat) + call set_value(table, 'branch', 'latest', stat) + call set_value(table, 'tag', 'v20.1', stat) - type(toml_table) :: table - type(executable_config_t) :: executable + call new_dependency(dependency, table, error=error) - call new_table(table) + end subroutine test_dependency_gitconflict - call new_executable(executable, table, error) + !> Try to create a git dependency with invalid source format + subroutine test_dependency_invalid_git(error) + use fpm_manifest_dependency + use fpm_toml, only: new_table, add_table, toml_table, set_value - end subroutine test_executable_empty + !> Error handling + type(error_t), allocatable, intent(out) :: error + type(toml_table) :: table + type(toml_table), pointer :: child + integer :: stat + type(dependency_config_t) :: dependency - !> Pass a wrong TOML type to the name field of the executable - subroutine test_executable_typeerror(error) - use fpm_manifest_executable - use fpm_toml, only : new_table, add_table, toml_table + call new_table(table) + table%key = 'example' + call add_table(table, 'git', child) + call set_value(child, 'path', '../../package') - !> Error handling - type(error_t), allocatable, intent(out) :: error + call new_dependency(dependency, table, error=error) - type(toml_table) :: table - type(toml_table), pointer :: child - integer :: stat - type(executable_config_t) :: executable + end subroutine test_dependency_invalid_git - call new_table(table) - call add_table(table, 'name', child, stat) + !> Try to create a dependency with conflicting entries + subroutine test_dependency_wrongkey(error) + use fpm_manifest_dependency + use fpm_toml, only: new_table, toml_table, set_value - call new_executable(executable, table, error) + !> Error handling + type(error_t), allocatable, intent(out) :: error - end subroutine test_executable_typeerror + type(toml_table) :: table + integer :: stat + type(dependency_config_t) :: dependency + call new_table(table) + table%key = 'example' + call set_value(table, 'not-available', 'anywhere', stat) - !> Pass a TOML table with insufficient entries to the executable constructor - subroutine test_executable_noname(error) - use fpm_manifest_executable - use fpm_toml, only : new_table, add_table, toml_table + call new_dependency(dependency, table, error=error) - !> Error handling - type(error_t), allocatable, intent(out) :: error + end subroutine test_dependency_wrongkey - type(toml_table) :: table - type(toml_table), pointer :: child - integer :: stat - type(executable_config_t) :: executable + !> Dependency tables can be empty + subroutine test_dependencies_empty(error) + use fpm_manifest_dependency + use fpm_toml, only: new_table, toml_table - call new_table(table) - call add_table(table, 'dependencies', child, stat) + !> Error handling + type(error_t), allocatable, intent(out) :: error - call new_executable(executable, table, error) + type(toml_table) :: table + type(dependency_config_t), allocatable :: dependencies(:) - end subroutine test_executable_noname + call new_table(table) + call new_dependencies(dependencies, table, error=error) + if (allocated(error)) return + + if (allocated(dependencies)) then + call test_failed(error, "Found dependencies in empty table") + end if + + end subroutine test_dependencies_empty + + !> Add a dependency as an array, which is not supported + subroutine test_dependencies_typeerror(error) + use fpm_manifest_dependency + use fpm_toml, only: new_table, add_array, toml_table, toml_array + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_array), pointer :: children + integer :: stat + type(dependency_config_t), allocatable :: dependencies(:) + + call new_table(table) + call add_array(table, 'dep1', children, stat) + + call new_dependencies(dependencies, table, error=error) + + end subroutine test_dependencies_typeerror + + !> Include a table of profiles in toml, check whether they are parsed correctly and stored in package + subroutine test_profiles(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(package_config_t) :: package + character(len=*), parameter :: manifest = 'fpm-profiles.toml' + integer :: unit + character(:), allocatable :: profile_name, compiler, flags + logical :: profile_found + type(profile_config_t) :: chosen_profile + + open (file=manifest, newunit=unit) + write (unit, '(a)') & + & 'name = "example"', & + & '[profiles.release.gfortran.linux]', & + & 'flags = "1" #release.gfortran.linux', & + & '[profiles.release.gfortran]', & + & 'flags = "2" #release.gfortran.all', & + & '[profiles.gfortran.linux]', & + & 'flags = "3" #all.gfortran.linux', & + & '[profiles.gfortran]', & + & 'flags = "4" #all.gfortran.all', & + & '[profiles.release.ifort]', & + & 'flags = "5" #release.ifort.all' + close (unit) + + call get_package_data(package, manifest, error) + + open (file=manifest, newunit=unit) + close (unit, status='delete') - !> Pass a TOML table with not allowed keys - subroutine test_executable_wrongkey(error) - use fpm_manifest_executable - use fpm_toml, only : new_table, add_table, toml_table + if (allocated(error)) return - !> Error handling - type(error_t), allocatable, intent(out) :: error + profile_name = 'release' + compiler = 'gfortran' + call find_profile(package%profiles, profile_name, compiler, 1, profile_found, chosen_profile) + if (.not. (chosen_profile%flags .eq. '1 3')) then + call test_failed(error, "Failed to append flags from profiles named 'all'") + return + end if - type(toml_table) :: table - type(toml_table), pointer :: child - integer :: stat - type(executable_config_t) :: executable + profile_name = 'release' + compiler = 'gfortran' + call find_profile(package%profiles, profile_name, compiler, 3, profile_found, chosen_profile) + if (.not. (chosen_profile%flags .eq. '2 4')) then + call test_failed(error, "Failed to choose profile with OS 'all'") + return + end if + + profile_name = 'publish' + compiler = 'gfortran' + call find_profile(package%profiles, profile_name, compiler, 1, profile_found, chosen_profile) + if (allocated(chosen_profile%flags)) then + call test_failed(error, "Profile named "//profile_name//" should not exist") + return + end if + + profile_name = 'debug' + compiler = 'ifort' + call find_profile(package%profiles, profile_name, compiler, 3, profile_found, chosen_profile) + if (.not. (chosen_profile%flags .eq. ' /warn:all /check:all /error-limit:1 /Od /Z7 /assume:byterecl /traceback')) then + call test_failed(error, "Failed to load built-in profile"//flags) + return + end if + + profile_name = 'release' + compiler = 'ifort' + call find_profile(package%profiles, profile_name, compiler, 1, profile_found, chosen_profile) + if (.not. (chosen_profile%flags .eq. '5')) then + call test_failed(error, "Failed to overwrite built-in profile") + return + end if + end subroutine test_profiles - call new_table(table) - call add_table(table, 'wrong-field', child, stat) + !> 'flags' is a key-value entry, test should fail as it is defined as a table + subroutine test_profiles_keyvalue_table(error) - call new_executable(executable, table, error) + !> Error handling + type(error_t), allocatable, intent(out) :: error - end subroutine test_executable_wrongkey + type(package_config_t) :: package + character(len=*), parameter :: manifest = 'fpm-profiles-error.toml' + integer :: unit + character(:), allocatable :: profile_name, compiler, flags + open (file=manifest, newunit=unit) + write (unit, '(a)') & + & 'name = "example"', & + & '[profiles.linux.flags]' + close (unit) - !> Try to read values from the [build] table - subroutine test_build_valid(error) + call get_package_data(package, manifest, error) + + open (file=manifest, newunit=unit) + close (unit, status='delete') + end subroutine test_profiles_keyvalue_table + + !> Executables cannot be created from empty tables + subroutine test_executable_empty(error) + use fpm_manifest_executable + use fpm_toml, only: new_table, toml_table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(executable_config_t) :: executable + + call new_table(table) - !> Error handling - type(error_t), allocatable, intent(out) :: error + call new_executable(executable, table, error) + + end subroutine test_executable_empty - type(package_config_t) :: package - character(:), allocatable :: temp_file - integer :: unit + !> Pass a wrong TOML type to the name field of the executable + subroutine test_executable_typeerror(error) + use fpm_manifest_executable + use fpm_toml, only: new_table, add_table, toml_table - allocate(temp_file, source=get_temp_filename()) + !> Error handling + type(error_t), allocatable, intent(out) :: error - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'name = "example"', & - & '[build]', & - & 'auto-executables = false', & - & 'auto-tests = false' - close(unit) + type(toml_table) :: table + type(toml_table), pointer :: child + integer :: stat + type(executable_config_t) :: executable - call get_package_data(package, temp_file, error) + call new_table(table) + call add_table(table, 'name', child, stat) - if (allocated(error)) return + call new_executable(executable, table, error) - if (package%build%auto_executables) then - call test_failed(error, "Wong value of 'auto-executables' read, expecting .false.") - return - end if + end subroutine test_executable_typeerror - if (package%build%auto_tests) then - call test_failed(error, "Wong value of 'auto-tests' read, expecting .false.") - return - end if + !> Pass a TOML table with insufficient entries to the executable constructor + subroutine test_executable_noname(error) + use fpm_manifest_executable + use fpm_toml, only: new_table, add_table, toml_table - end subroutine test_build_valid + !> Error handling + type(error_t), allocatable, intent(out) :: error + type(toml_table) :: table + type(toml_table), pointer :: child + integer :: stat + type(executable_config_t) :: executable - !> Try to read values from an empty [build] table - subroutine test_build_empty(error) + call new_table(table) + call add_table(table, 'dependencies', child, stat) - !> Error handling - type(error_t), allocatable, intent(out) :: error + call new_executable(executable, table, error) - type(package_config_t) :: package - character(:), allocatable :: temp_file - integer :: unit + end subroutine test_executable_noname - allocate(temp_file, source=get_temp_filename()) + !> Pass a TOML table with not allowed keys + subroutine test_executable_wrongkey(error) + use fpm_manifest_executable + use fpm_toml, only: new_table, add_table, toml_table - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'name = "example"', & - & '[build]', & - & '[library]' - close(unit) + !> Error handling + type(error_t), allocatable, intent(out) :: error - call get_package_data(package, temp_file, error) + type(toml_table) :: table + type(toml_table), pointer :: child + integer :: stat + type(executable_config_t) :: executable - if (allocated(error)) return + call new_table(table) + call add_table(table, 'wrong-field', child, stat) - if (.not.package%build%auto_executables) then - call test_failed(error, "Wong default value of 'auto-executables' read, expecting .true.") - return - end if + call new_executable(executable, table, error) - if (.not.package%build%auto_tests) then - call test_failed(error, "Wong default value of 'auto-tests' read, expecting .true.") - return - end if + end subroutine test_executable_wrongkey - end subroutine test_build_empty + !> Try to read values from the [build] table + subroutine test_build_valid(error) + !> Error handling + type(error_t), allocatable, intent(out) :: error - !> Try to read values from a [build] table with invalid values - subroutine test_build_invalid_values(error) + type(package_config_t) :: package + character(:), allocatable :: temp_file + integer :: unit - !> Error handling - type(error_t), allocatable, intent(out) :: error + allocate (temp_file, source=get_temp_filename()) - type(package_config_t) :: package - character(:), allocatable :: temp_file - integer :: unit + open (file=temp_file, newunit=unit) + write (unit, '(a)') & + & 'name = "example"', & + & '[build]', & + & 'auto-executables = false', & + & 'auto-tests = false' + close (unit) - allocate(temp_file, source=get_temp_filename()) + call get_package_data(package, temp_file, error) - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'name = "example"', & - & '[build]', & - & 'auto-executables = "false"' - close(unit) + if (allocated(error)) return - call get_package_data(package, temp_file, error) + if (package%build%auto_executables) then + call test_failed(error, "Wong value of 'auto-executables' read, expecting .false.") + return + end if - end subroutine test_build_invalid_values + if (package%build%auto_tests) then + call test_failed(error, "Wong value of 'auto-tests' read, expecting .false.") + return + end if + end subroutine test_build_valid - !> Libraries can be created from empty tables - subroutine test_library_empty(error) - use fpm_manifest_library - use fpm_toml, only : new_table, toml_table + !> Try to read values from an empty [build] table + subroutine test_build_empty(error) - !> Error handling - type(error_t), allocatable, intent(out) :: error + !> Error handling + type(error_t), allocatable, intent(out) :: error - type(toml_table) :: table - type(library_config_t) :: library + type(package_config_t) :: package + character(:), allocatable :: temp_file + integer :: unit - call new_table(table) + allocate (temp_file, source=get_temp_filename()) - call new_library(library, table, error) - if (allocated(error)) return + open (file=temp_file, newunit=unit) + write (unit, '(a)') & + & 'name = "example"', & + & '[build]', & + & '[library]' + close (unit) - call check_string(error, library%source_dir, "src", & - & "Default library source-dir") - if (allocated(error)) return + call get_package_data(package, temp_file, error) - if (.not.allocated(library%include_dir)) then - call test_failed(error,"Default include-dir list not allocated") - return - end if + if (allocated(error)) return - if (.not.("include".in.library%include_dir)) then - call test_failed(error,"'include' not in default include-dir list") - return - end if + if (.not. package%build%auto_executables) then + call test_failed(error, "Wong default value of 'auto-executables' read, expecting .true.") + return + end if - end subroutine test_library_empty + if (.not. package%build%auto_tests) then + call test_failed(error, "Wong default value of 'auto-tests' read, expecting .true.") + return + end if + end subroutine test_build_empty - !> Pass a TOML table with not allowed keys - subroutine test_library_wrongkey(error) - use fpm_manifest_library - use fpm_toml, only : new_table, add_table, toml_table + !> Try to read values from a [build] table with invalid values + subroutine test_build_invalid_values(error) - !> Error handling - type(error_t), allocatable, intent(out) :: error + !> Error handling + type(error_t), allocatable, intent(out) :: error - type(toml_table) :: table - type(toml_table), pointer :: child - integer :: stat - type(library_config_t) :: library + type(package_config_t) :: package + character(:), allocatable :: temp_file + integer :: unit - call new_table(table) - call add_table(table, 'not-allowed', child, stat) + allocate (temp_file, source=get_temp_filename()) - call new_library(library, table, error) + open (file=temp_file, newunit=unit) + write (unit, '(a)') & + & 'name = "example"', & + & '[build]', & + & 'auto-executables = "false"' + close (unit) - end subroutine test_library_wrongkey + call get_package_data(package, temp_file, error) + end subroutine test_build_invalid_values - !> Packages cannot be created from empty tables - subroutine test_package_simple(error) - use fpm_manifest_package - use fpm_toml, only : new_table, add_table, add_array, set_value, & - & toml_table, toml_array + !> Libraries can be created from empty tables + subroutine test_library_empty(error) + use fpm_manifest_library + use fpm_toml, only: new_table, toml_table - !> Error handling - type(error_t), allocatable, intent(out) :: error + !> Error handling + type(error_t), allocatable, intent(out) :: error - type(toml_table) :: table - type(toml_table), pointer :: child, child2 - type(toml_array), pointer :: children - integer :: stat - type(package_config_t) :: package + type(toml_table) :: table + type(library_config_t) :: library - call new_table(table) - call set_value(table, 'name', 'example', stat) - call set_value(table, 'license', 'MIT', stat) - call add_table(table, 'dev-dependencies', child, stat) - call add_table(child, 'pkg1', child2, stat) - call set_value(child2, 'git', 'https://github.com/fortran-lang/pkg1', stat) - call add_table(child, 'pkg2', child2) - call set_value(child2, 'git', 'https://gitlab.com/fortran-lang/pkg2', stat) - call set_value(child2, 'branch', 'devel', stat) - call add_table(child, 'pkg3', child2) - call set_value(child2, 'git', 'https://bitbucket.org/fortran-lang/pkg3', stat) - call set_value(child2, 'rev', '9fceb02d0ae598e95dc970b74767f19372d61af8', stat) - call add_table(child, 'pkg4', child2) - call set_value(child2, 'git', 'https://gitea.com/fortran-lang/pkg4', stat) - call set_value(child2, 'tag', 'v1.8.5-rc3', stat) - call add_array(table, 'test', children, stat) - call add_table(children, child, stat) - call set_value(child, 'name', 'tester', stat) + call new_table(table) - call new_package(package, table, error=error) + call new_library(library, table, error) + if (allocated(error)) return - end subroutine test_package_simple + call check_string(error, library%source_dir, "src", & + & "Default library source-dir") + if (allocated(error)) return + if (.not. allocated(library%include_dir)) then + call test_failed(error, "Default include-dir list not allocated") + return + end if - !> Packages cannot be created from empty tables - subroutine test_package_empty(error) - use fpm_manifest_package - use fpm_toml, only : new_table, toml_table + if (.not. ("include".in.library%include_dir)) then + call test_failed(error, "'include' not in default include-dir list") + return + end if - !> Error handling - type(error_t), allocatable, intent(out) :: error + end subroutine test_library_empty - type(toml_table) :: table - type(package_config_t) :: package + !> Pass a TOML table with not allowed keys + subroutine test_library_wrongkey(error) + use fpm_manifest_library + use fpm_toml, only: new_table, add_table, toml_table - call new_table(table) + !> Error handling + type(error_t), allocatable, intent(out) :: error - call new_package(package, table, error=error) + type(toml_table) :: table + type(toml_table), pointer :: child + integer :: stat + type(library_config_t) :: library - end subroutine test_package_empty + call new_table(table) + call add_table(table, 'not-allowed', child, stat) + call new_library(library, table, error) - !> Create an array in the package name, which should cause an error - subroutine test_package_typeerror(error) - use fpm_manifest_package - use fpm_toml, only : new_table, add_array, toml_table, toml_array + end subroutine test_library_wrongkey - !> Error handling - type(error_t), allocatable, intent(out) :: error + !> Packages cannot be created from empty tables + subroutine test_package_simple(error) + use fpm_manifest_package + use fpm_toml, only: new_table, add_table, add_array, set_value, & + & toml_table, toml_array - type(toml_table) :: table - type(toml_array), pointer :: child - integer :: stat - type(package_config_t) :: package + !> Error handling + type(error_t), allocatable, intent(out) :: error - call new_table(table) - call add_array(table, "name", child, stat) + type(toml_table) :: table + type(toml_table), pointer :: child, child2 + type(toml_array), pointer :: children + integer :: stat + type(package_config_t) :: package - call new_package(package, table, error=error) + call new_table(table) + call set_value(table, 'name', 'example', stat) + call set_value(table, 'license', 'MIT', stat) + call add_table(table, 'dev-dependencies', child, stat) + call add_table(child, 'pkg1', child2, stat) + call set_value(child2, 'git', 'https://github.com/fortran-lang/pkg1', stat) + call add_table(child, 'pkg2', child2) + call set_value(child2, 'git', 'https://gitlab.com/fortran-lang/pkg2', stat) + call set_value(child2, 'branch', 'devel', stat) + call add_table(child, 'pkg3', child2) + call set_value(child2, 'git', 'https://bitbucket.org/fortran-lang/pkg3', stat) + call set_value(child2, 'rev', '9fceb02d0ae598e95dc970b74767f19372d61af8', stat) + call add_table(child, 'pkg4', child2) + call set_value(child2, 'git', 'https://gitea.com/fortran-lang/pkg4', stat) + call set_value(child2, 'tag', 'v1.8.5-rc3', stat) + call add_array(table, 'test', children, stat) + call add_table(children, child, stat) + call set_value(child, 'name', 'tester', stat) - end subroutine test_package_typeerror + call new_package(package, table, error=error) + end subroutine test_package_simple - !> Try to create a new package without a name field - subroutine test_package_noname(error) - use fpm_manifest_package - use fpm_toml, only : new_table, add_table, toml_table + !> Packages cannot be created from empty tables + subroutine test_package_empty(error) + use fpm_manifest_package + use fpm_toml, only: new_table, toml_table - !> Error handling - type(error_t), allocatable, intent(out) :: error + !> Error handling + type(error_t), allocatable, intent(out) :: error - type(toml_table) :: table - type(toml_table), pointer :: child - integer :: stat - type(package_config_t) :: package + type(toml_table) :: table + type(package_config_t) :: package - call new_table(table) - call add_table(table, "library", child, stat) - call add_table(table, "dev-dependencies", child, stat) - call add_table(table, "dependencies", child, stat) + call new_table(table) - call new_package(package, table, error=error) + call new_package(package, table, error=error) - end subroutine test_package_noname + end subroutine test_package_empty + !> Create an array in the package name, which should cause an error + subroutine test_package_typeerror(error) + use fpm_manifest_package + use fpm_toml, only: new_table, add_array, toml_table, toml_array - !> Try to read executables from a mixed type array - subroutine test_package_wrongexe(error) - use fpm_manifest_package - use fpm_toml, only : new_table, set_value, add_array, toml_table, toml_array + !> Error handling + type(error_t), allocatable, intent(out) :: error - !> Error handling - type(error_t), allocatable, intent(out) :: error + type(toml_table) :: table + type(toml_array), pointer :: child + integer :: stat + type(package_config_t) :: package - type(toml_table) :: table - type(toml_array), pointer :: children, children2 - integer :: stat - type(package_config_t) :: package + call new_table(table) + call add_array(table, "name", child, stat) - call new_table(table) - call set_value(table, 'name', 'example', stat) - call add_array(table, 'executable', children, stat) - call add_array(children, children2, stat) + call new_package(package, table, error=error) - call new_package(package, table, error=error) + end subroutine test_package_typeerror - end subroutine test_package_wrongexe + !> Try to create a new package without a name field + subroutine test_package_noname(error) + use fpm_manifest_package + use fpm_toml, only: new_table, add_table, toml_table + !> Error handling + type(error_t), allocatable, intent(out) :: error - !> Try to read tests from a mixed type array - subroutine test_package_wrongtest(error) - use fpm_manifest_package - use fpm_toml, only : new_table, set_value, add_array, toml_table, toml_array + type(toml_table) :: table + type(toml_table), pointer :: child + integer :: stat + type(package_config_t) :: package - !> Error handling - type(error_t), allocatable, intent(out) :: error + call new_table(table) + call add_table(table, "library", child, stat) + call add_table(table, "dev-dependencies", child, stat) + call add_table(table, "dependencies", child, stat) - type(toml_table) :: table - type(toml_array), pointer :: children, children2 - integer :: stat - type(package_config_t) :: package + call new_package(package, table, error=error) - call new_table(table) - call set_value(table, 'name', 'example', stat) - call add_array(table, 'test', children, stat) - call add_array(children, children2, stat) + end subroutine test_package_noname - call new_package(package, table, error=error) + !> Try to read executables from a mixed type array + subroutine test_package_wrongexe(error) + use fpm_manifest_package + use fpm_toml, only: new_table, set_value, add_array, toml_table, toml_array - end subroutine test_package_wrongtest + !> Error handling + type(error_t), allocatable, intent(out) :: error + type(toml_table) :: table + type(toml_array), pointer :: children, children2 + integer :: stat + type(package_config_t) :: package - !> Try to read tests from a mixed type array - subroutine test_package_duplicate(error) - use fpm_manifest_package - use fpm_toml, only : set_value, add_table, add_array, toml_table, toml_array + call new_table(table) + call set_value(table, 'name', 'example', stat) + call add_array(table, 'executable', children, stat) + call add_array(children, children2, stat) - !> Error handling - type(error_t), allocatable, intent(out) :: error + call new_package(package, table, error=error) - type(toml_table) :: table - type(toml_table), pointer :: child - type(toml_array), pointer :: children - integer :: stat - type(package_config_t) :: package + end subroutine test_package_wrongexe - table = toml_table() - call set_value(table, 'name', 'example', stat) - call add_array(table, 'test', children, stat) - call add_table(children, child, stat) - call set_value(child, 'name', 'prog', stat) - call add_table(children, child, stat) - call set_value(child, 'name', 'prog', stat) + !> Try to read tests from a mixed type array + subroutine test_package_wrongtest(error) + use fpm_manifest_package + use fpm_toml, only: new_table, set_value, add_array, toml_table, toml_array - call new_package(package, table, error=error) + !> Error handling + type(error_t), allocatable, intent(out) :: error - end subroutine test_package_duplicate + type(toml_table) :: table + type(toml_array), pointer :: children, children2 + integer :: stat + type(package_config_t) :: package + call new_table(table) + call set_value(table, 'name', 'example', stat) + call add_array(table, 'test', children, stat) + call add_array(children, children2, stat) - !> Tests cannot be created from empty tables - subroutine test_test_simple(error) - use fpm_manifest_test - use fpm_toml, only : new_table, set_value, add_table, toml_table + call new_package(package, table, error=error) - !> Error handling - type(error_t), allocatable, intent(out) :: error + end subroutine test_package_wrongtest - type(toml_table) :: table - type(toml_table), pointer :: child - integer :: stat - type(test_config_t) :: test + !> Try to read tests from a mixed type array + subroutine test_package_duplicate(error) + use fpm_manifest_package + use fpm_toml, only: set_value, add_table, add_array, toml_table, toml_array - call new_table(table) - call set_value(table, 'name', 'example', stat) - call set_value(table, 'source-dir', 'tests', stat) - call set_value(table, 'main', 'tester.f90', stat) - call add_table(table, 'dependencies', child, stat) + !> Error handling + type(error_t), allocatable, intent(out) :: error - call new_test(test, table, error) - if (allocated(error)) return + type(toml_table) :: table + type(toml_table), pointer :: child + type(toml_array), pointer :: children + integer :: stat + type(package_config_t) :: package - call check_string(error, test%main, "tester.f90", "Test main") - if (allocated(error)) return + table = toml_table() + call set_value(table, 'name', 'example', stat) + call add_array(table, 'test', children, stat) + call add_table(children, child, stat) + call set_value(child, 'name', 'prog', stat) + call add_table(children, child, stat) + call set_value(child, 'name', 'prog', stat) - end subroutine test_test_simple + call new_package(package, table, error=error) + end subroutine test_package_duplicate - !> Tests cannot be created from empty tables - subroutine test_test_empty(error) - use fpm_manifest_test - use fpm_toml, only : new_table, toml_table + !> Tests cannot be created from empty tables + subroutine test_test_simple(error) + use fpm_manifest_test + use fpm_toml, only: new_table, set_value, add_table, toml_table - !> Error handling - type(error_t), allocatable, intent(out) :: error + !> Error handling + type(error_t), allocatable, intent(out) :: error - type(toml_table) :: table - type(test_config_t) :: test + type(toml_table) :: table + type(toml_table), pointer :: child + integer :: stat + type(test_config_t) :: test - call new_table(table) + call new_table(table) + call set_value(table, 'name', 'example', stat) + call set_value(table, 'source-dir', 'tests', stat) + call set_value(table, 'main', 'tester.f90', stat) + call add_table(table, 'dependencies', child, stat) - call new_test(test, table, error) + call new_test(test, table, error) + if (allocated(error)) return - end subroutine test_test_empty + call check_string(error, test%main, "tester.f90", "Test main") + if (allocated(error)) return + end subroutine test_test_simple - !> Pass a wrong TOML type to the name field of the test - subroutine test_test_typeerror(error) - use fpm_manifest_test - use fpm_toml, only : new_table, add_table, toml_table + !> Tests cannot be created from empty tables + subroutine test_test_empty(error) + use fpm_manifest_test + use fpm_toml, only: new_table, toml_table - !> Error handling - type(error_t), allocatable, intent(out) :: error + !> Error handling + type(error_t), allocatable, intent(out) :: error - type(toml_table) :: table - type(toml_table), pointer :: child - integer :: stat - type(test_config_t) :: test + type(toml_table) :: table + type(test_config_t) :: test - call new_table(table) - call add_table(table, 'name', child, stat) + call new_table(table) - call new_test(test, table, error) + call new_test(test, table, error) - end subroutine test_test_typeerror + end subroutine test_test_empty + !> Pass a wrong TOML type to the name field of the test + subroutine test_test_typeerror(error) + use fpm_manifest_test + use fpm_toml, only: new_table, add_table, toml_table - !> Pass a TOML table with insufficient entries to the test constructor - subroutine test_test_noname(error) - use fpm_manifest_test - use fpm_toml, only : new_table, add_table, toml_table + !> Error handling + type(error_t), allocatable, intent(out) :: error - !> Error handling - type(error_t), allocatable, intent(out) :: error + type(toml_table) :: table + type(toml_table), pointer :: child + integer :: stat + type(test_config_t) :: test - type(toml_table) :: table - type(toml_table), pointer :: child - integer :: stat - type(test_config_t) :: test + call new_table(table) + call add_table(table, 'name', child, stat) - call new_table(table) - call add_table(table, 'dependencies', child, stat) + call new_test(test, table, error) - call new_test(test, table, error) + end subroutine test_test_typeerror - end subroutine test_test_noname + !> Pass a TOML table with insufficient entries to the test constructor + subroutine test_test_noname(error) + use fpm_manifest_test + use fpm_toml, only: new_table, add_table, toml_table + !> Error handling + type(error_t), allocatable, intent(out) :: error - !> Pass a TOML table with not allowed keys - subroutine test_test_wrongkey(error) - use fpm_manifest_test - use fpm_toml, only : new_table, add_table, toml_table + type(toml_table) :: table + type(toml_table), pointer :: child + integer :: stat + type(test_config_t) :: test - !> Error handling - type(error_t), allocatable, intent(out) :: error + call new_table(table) + call add_table(table, 'dependencies', child, stat) - type(toml_table) :: table - type(toml_table), pointer :: child - integer :: stat - type(test_config_t) :: test + call new_test(test, table, error) - call new_table(table) - call add_table(table, 'not-supported', child, stat) + end subroutine test_test_noname - call new_test(test, table, error) + !> Pass a TOML table with not allowed keys + subroutine test_test_wrongkey(error) + use fpm_manifest_test + use fpm_toml, only: new_table, add_table, toml_table - end subroutine test_test_wrongkey + !> Error handling + type(error_t), allocatable, intent(out) :: error + type(toml_table) :: table + type(toml_table), pointer :: child + integer :: stat + type(test_config_t) :: test - !> Create a simple example entry - subroutine test_example_simple(error) - use fpm_manifest_example - use fpm_toml, only : new_table, set_value, add_table, toml_table + call new_table(table) + call add_table(table, 'not-supported', child, stat) - !> Error handling - type(error_t), allocatable, intent(out) :: error + call new_test(test, table, error) - type(toml_table) :: table - type(toml_table), pointer :: child - integer :: stat - type(example_config_t) :: example + end subroutine test_test_wrongkey - call new_table(table) - call set_value(table, 'name', 'example', stat) - call set_value(table, 'source-dir', 'demos', stat) - call set_value(table, 'main', 'demo.f90', stat) - call add_table(table, 'dependencies', child, stat) + !> Create a simple example entry + subroutine test_example_simple(error) + use fpm_manifest_example + use fpm_toml, only: new_table, set_value, add_table, toml_table - call new_example(example, table, error) - if (allocated(error)) return + !> Error handling + type(error_t), allocatable, intent(out) :: error - call check_string(error, example%main, "demo.f90", "Example main") - if (allocated(error)) return + type(toml_table) :: table + type(toml_table), pointer :: child + integer :: stat + type(example_config_t) :: example - end subroutine test_example_simple + call new_table(table) + call set_value(table, 'name', 'example', stat) + call set_value(table, 'source-dir', 'demos', stat) + call set_value(table, 'main', 'demo.f90', stat) + call add_table(table, 'dependencies', child, stat) + call new_example(example, table, error) + if (allocated(error)) return - !> Examples cannot be created from empty tables - subroutine test_example_empty(error) - use fpm_manifest_example - use fpm_toml, only : new_table, toml_table + call check_string(error, example%main, "demo.f90", "Example main") + if (allocated(error)) return - !> Error handling - type(error_t), allocatable, intent(out) :: error + end subroutine test_example_simple - type(toml_table) :: table - type(example_config_t) :: example + !> Examples cannot be created from empty tables + subroutine test_example_empty(error) + use fpm_manifest_example + use fpm_toml, only: new_table, toml_table - call new_table(table) + !> Error handling + type(error_t), allocatable, intent(out) :: error - call new_example(example, table, error) + type(toml_table) :: table + type(example_config_t) :: example - end subroutine test_example_empty + call new_table(table) + call new_example(example, table, error) - !> Test link options - subroutine test_link_string(error) - use fpm_manifest_build - use fpm_toml, only : set_value, toml_table + end subroutine test_example_empty - !> Error handling - type(error_t), allocatable, intent(out) :: error + !> Test link options + subroutine test_link_string(error) + use fpm_manifest_build + use fpm_toml, only: set_value, toml_table - type(toml_table) :: table - integer :: stat - type(build_config_t) :: build + !> Error handling + type(error_t), allocatable, intent(out) :: error - table = toml_table() - call set_value(table, "link", "z", stat=stat) + type(toml_table) :: table + integer :: stat + type(build_config_t) :: build - call new_build_config(build, table, error) + table = toml_table() + call set_value(table, "link", "z", stat=stat) - end subroutine test_link_string + call new_build_config(build, table, error) + end subroutine test_link_string - !> Test link options - subroutine test_link_array(error) - use fpm_manifest_build - use fpm_toml, only : add_array, set_value, toml_table, toml_array + !> Test link options + subroutine test_link_array(error) + use fpm_manifest_build + use fpm_toml, only: add_array, set_value, toml_table, toml_array - !> Error handling - type(error_t), allocatable, intent(out) :: error + !> Error handling + type(error_t), allocatable, intent(out) :: error - type(toml_table) :: table - type(toml_array), pointer :: children - integer :: stat - type(build_config_t) :: build + type(toml_table) :: table + type(toml_array), pointer :: children + integer :: stat + type(build_config_t) :: build - table = toml_table() - call add_array(table, "link", children, stat=stat) - call set_value(children, 1, "blas", stat=stat) - call set_value(children, 2, "lapack", stat=stat) + table = toml_table() + call add_array(table, "link", children, stat=stat) + call set_value(children, 1, "blas", stat=stat) + call set_value(children, 2, "lapack", stat=stat) - call new_build_config(build, table, error) + call new_build_config(build, table, error) - end subroutine test_link_array + end subroutine test_link_array + !> Test link options + subroutine test_invalid_link(error) + use fpm_manifest_build + use fpm_toml, only: add_table, toml_table - !> Test link options - subroutine test_invalid_link(error) - use fpm_manifest_build - use fpm_toml, only : add_table, toml_table + !> Error handling + type(error_t), allocatable, intent(out) :: error - !> Error handling - type(error_t), allocatable, intent(out) :: error + type(toml_table) :: table + type(toml_table), pointer :: child + integer :: stat + type(build_config_t) :: build - type(toml_table) :: table - type(toml_table), pointer :: child - integer :: stat - type(build_config_t) :: build + table = toml_table() + call add_table(table, "link", child, stat=stat) - table = toml_table() - call add_table(table, "link", child, stat=stat) + call new_build_config(build, table, error) - call new_build_config(build, table, error) + end subroutine test_invalid_link - end subroutine test_invalid_link + subroutine test_install_library(error) + use fpm_manifest_install + use fpm_toml, only: toml_table, set_value + !> Error handling + type(error_t), allocatable, intent(out) :: error - subroutine test_install_library(error) - use fpm_manifest_install - use fpm_toml, only : toml_table, set_value + type(toml_table) :: table + type(install_config_t) :: install - !> Error handling - type(error_t), allocatable, intent(out) :: error + table = toml_table() + call set_value(table, "library", .true.) - type(toml_table) :: table - type(install_config_t) :: install + call new_install_config(install, table, error) + if (allocated(error)) return - table = toml_table() - call set_value(table, "library", .true.) + if (.not. install%library) then + call test_failed(error, "Library entry should be true") + return + end if - call new_install_config(install, table, error) - if (allocated(error)) return + end subroutine test_install_library - if (.not.install%library) then - call test_failed(error, "Library entry should be true") - return - end if + subroutine test_install_empty(error) + use fpm_manifest_install + use fpm_toml, only: toml_table - end subroutine test_install_library + !> Error handling + type(error_t), allocatable, intent(out) :: error + type(toml_table) :: table + type(install_config_t) :: install - subroutine test_install_empty(error) - use fpm_manifest_install - use fpm_toml, only : toml_table + table = toml_table() - !> Error handling - type(error_t), allocatable, intent(out) :: error + call new_install_config(install, table, error) + if (allocated(error)) return - type(toml_table) :: table - type(install_config_t) :: install + if (install%library) then + call test_failed(error, "Library default should be false") + return + end if - table = toml_table() + end subroutine test_install_empty - call new_install_config(install, table, error) - if (allocated(error)) return + subroutine test_install_wrongkey(error) + use fpm_manifest_install + use fpm_toml, only: toml_table, set_value - if (install%library) then - call test_failed(error, "Library default should be false") - return - end if + !> Error handling + type(error_t), allocatable, intent(out) :: error - end subroutine test_install_empty + type(toml_table) :: table + type(install_config_t) :: install + table = toml_table() + call set_value(table, "prefix", "/some/install/path") - subroutine test_install_wrongkey(error) - use fpm_manifest_install - use fpm_toml, only : toml_table, set_value + call new_install_config(install, table, error) - !> Error handling - type(error_t), allocatable, intent(out) :: error + end subroutine test_install_wrongkey - type(toml_table) :: table - type(install_config_t) :: install + subroutine test_preprocess_empty(error) + use fpm_mainfest_preprocess + use fpm_toml, only: new_table, toml_table - table = toml_table() - call set_value(table, "prefix", "/some/install/path") + !> Error handling + type(error_t), allocatable, intent(out) :: error - call new_install_config(install, table, error) + type(toml_table) :: table + type(preprocess_config_t) :: preprocess - end subroutine test_install_wrongkey - - subroutine test_preprocess_empty(error) - use fpm_mainfest_preprocess - use fpm_toml, only : new_table, toml_table + call new_table(table) + table%key = "example" - !> Error handling - type(error_t), allocatable, intent(out) :: error + call new_preprocess_config(preprocess, table, error) - type(toml_table) :: table - type(preprocess_config_t) :: preprocess + end subroutine test_preprocess_empty - call new_table(table) - table%key = "example" + !> Pass a TOML table with not allowed keys + subroutine test_preprocess_wrongkey(error) + use fpm_mainfest_preprocess + use fpm_toml, only: new_table, add_table, toml_table - call new_preprocess_config(preprocess, table, error) + !> Error handling + type(error_t), allocatable, intent(out) :: error - end subroutine test_preprocess_empty + type(toml_table) :: table + type(toml_table), pointer :: child + integer :: stat + type(preprocess_config_t) :: preprocess - !> Pass a TOML table with not allowed keys - subroutine test_preprocess_wrongkey(error) - use fpm_mainfest_preprocess - use fpm_toml, only : new_table, add_table, toml_table + call new_table(table) + table%key = 'example' + call add_table(table, 'wrong-field', child, stat) - !> Error handling - type(error_t), allocatable, intent(out) :: error + call new_preprocess_config(preprocess, table, error) - type(toml_table) :: table - type(toml_table), pointer :: child - integer :: stat - type(preprocess_config_t) :: preprocess + end subroutine test_preprocess_wrongkey - call new_table(table) - table%key = 'example' - call add_table(table, 'wrong-field', child, stat) + !> Preprocess table cannot be empty. + subroutine test_preprocessors_empty(error) + use fpm_mainfest_preprocess + use fpm_toml, only: new_table, toml_table - call new_preprocess_config(preprocess, table, error) - - end subroutine test_preprocess_wrongkey + !> Error handling + type(error_t), allocatable, intent(out) :: error - !> Preprocess table cannot be empty. - subroutine test_preprocessors_empty(error) - use fpm_mainfest_preprocess - use fpm_toml, only : new_table, toml_table + type(toml_table) :: table + type(preprocess_config_t), allocatable :: preprocessors(:) - !> Error handling - type(error_t), allocatable, intent(out) :: error + call new_table(table) - type(toml_table) :: table - type(preprocess_config_t), allocatable :: preprocessors(:) + call new_preprocessors(preprocessors, table, error) + if (allocated(error)) return - call new_table(table) + end subroutine test_preprocessors_empty - call new_preprocessors(preprocessors, table, error) - if (allocated(error)) return + !> Test macro parsing function get_macros_from_manifest + subroutine test_macro_parsing(error) + use fpm_compiler, only: get_macros, compiler_enum - end subroutine test_preprocessors_empty + !> Error handling + type(error_t), allocatable, intent(out) :: error - !> Test macro parsing function get_macros_from_manifest - subroutine test_macro_parsing(error) - use fpm_compiler, only: get_macros, compiler_enum + character(len=:), allocatable :: flags + character(len=:), allocatable :: version - !> Error handling - type(error_t), allocatable, intent(out) :: error + type(package_config_t) :: package + character(:), allocatable :: temp_file + integer :: unit + integer(compiler_enum) :: id - character(len=:), allocatable :: flags - character(len=:), allocatable :: version + allocate (temp_file, source=get_temp_filename()) - type(package_config_t) :: package - character(:), allocatable :: temp_file - integer :: unit - integer(compiler_enum) :: id + open (file=temp_file, newunit=unit) + write (unit, '(a)') & + & 'name = "example"', & + & 'version = "0.1.0"', & + & '[preprocess]', & + & '[preprocess.cpp]', & + & 'macros = ["FOO", "BAR=2", "VERSION={version}"]' + close (unit) - allocate(temp_file, source=get_temp_filename()) + call get_package_data(package, temp_file, error) - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'name = "example"', & - & 'version = "0.1.0"', & - & '[preprocess]', & - & '[preprocess.cpp]', & - & 'macros = ["FOO", "BAR=2", "VERSION={version}"]' - close(unit) + if (allocated(error)) return - call get_package_data(package, temp_file, error) + call package%version%to_string(version) - if (allocated(error)) return + if (get_macros(id, package%preprocess(1)%macros, version) /= " -DFOO -DBAR=2 -DVERSION=0.1.0") then + call test_failed(error, "Macros were not parsed correctly") + end if - call package%version%to_string(version) + end subroutine test_macro_parsing - if (get_macros(id, package%preprocess(1)%macros, version) /= " -DFOO -DBAR=2 -DVERSION=0.1.0") then - call test_failed(error, "Macros were not parsed correctly") - end if - - end subroutine test_macro_parsing + !> Test macro parsing of the package and its dependency. + subroutine test_macro_parsing_dependency(error) + use fpm_compiler, only: get_macros, compiler_enum - !> Test macro parsing of the package and its dependency. - subroutine test_macro_parsing_dependency(error) - use fpm_compiler, only: get_macros, compiler_enum + !> Error handling + type(error_t), allocatable, intent(out) :: error - !> Error handling - type(error_t), allocatable, intent(out) :: error + character(len=:), allocatable :: macrosPackage, macrosDependency + character(len=:), allocatable :: versionPackage, versionDependency - character(len=:), allocatable :: macrosPackage, macrosDependency - character(len=:), allocatable :: versionPackage, versionDependency + type(package_config_t) :: package, dependency - type(package_config_t) :: package, dependency + character(:), allocatable :: toml_file_package + character(:), allocatable :: toml_file_dependency - character(:), allocatable :: toml_file_package - character(:), allocatable :: toml_file_dependency + integer :: unit + integer(compiler_enum) :: id - integer :: unit - integer(compiler_enum) :: id + allocate (toml_file_package, source=get_temp_filename()) + allocate (toml_file_dependency, source=get_temp_filename()) - allocate(toml_file_package, source=get_temp_filename()) - allocate(toml_file_dependency, source=get_temp_filename()) + open (file=toml_file_package, newunit=unit) + write (unit, '(a)') & + & 'name = "example"', & + & 'version = "0.1.0"', & + & '[dependencies]', & + & '[dependencies.dependency-name]', & + & 'git = "https://github.com/fortran-lang/dependency-name"', & + & '[preprocess]', & + & '[preprocess.cpp]', & + & 'macros = ["FOO", "BAR=2", "VERSION={version}"]' + close (unit) - open(file=toml_file_package, newunit=unit) - write(unit, '(a)') & - & 'name = "example"', & - & 'version = "0.1.0"', & - & '[dependencies]', & - & '[dependencies.dependency-name]', & - & 'git = "https://github.com/fortran-lang/dependency-name"', & - & '[preprocess]', & - & '[preprocess.cpp]', & - & 'macros = ["FOO", "BAR=2", "VERSION={version}"]' - close(unit) + open (file=toml_file_dependency, newunit=unit) + write (unit, '(a)') & + & 'name = "dependency-name"', & + & 'version = "0.2.0"', & + & '[preprocess]', & + & '[preprocess.cpp]', & + & 'macros = ["FOO1", "BAR2=2", "VERSION={version}"]' + close (unit) - open(file=toml_file_dependency, newunit=unit) - write(unit, '(a)') & - & 'name = "dependency-name"', & - & 'version = "0.2.0"', & - & '[preprocess]', & - & '[preprocess.cpp]', & - & 'macros = ["FOO1", "BAR2=2", "VERSION={version}"]' - close(unit) + call get_package_data(package, toml_file_package, error) - call get_package_data(package, toml_file_package, error) + if (allocated(error)) return - if (allocated(error)) return + call get_package_data(dependency, toml_file_dependency, error) - call get_package_data(dependency, toml_file_dependency, error) + if (allocated(error)) return - if (allocated(error)) return + call package%version%to_string(versionPackage) + call dependency%version%to_string(versionDependency) - call package%version%to_string(versionPackage) - call dependency%version%to_string(versionDependency) + macrosPackage = get_macros(id, package%preprocess(1)%macros, versionPackage) + macrosDependency = get_macros(id, dependency%preprocess(1)%macros, versionDependency) - macrosPackage = get_macros(id, package%preprocess(1)%macros, versionPackage) - macrosDependency = get_macros(id, dependency%preprocess(1)%macros, versionDependency) + if (macrosPackage == macrosDependency) then + call test_failed(error, "Macros of package and dependency should not be equal") + end if - if (macrosPackage == macrosDependency) then - call test_failed(error, "Macros of package and dependency should not be equal") - end if - - end subroutine test_macro_parsing_dependency + end subroutine test_macro_parsing_dependency end module test_manifest diff --git a/test/fpm_test/test_module_dependencies.f90 b/test/fpm_test/test_module_dependencies.f90 index 805cc25590..6080c6cb37 100644 --- a/test/fpm_test/test_module_dependencies.f90 +++ b/test/fpm_test/test_module_dependencies.f90 @@ -1,808 +1,791 @@ !> Define tests for the `fpm_sources` module (module dependency checking) module test_module_dependencies - use testsuite, only : new_unittest, unittest_t, error_t, test_failed - use fpm_targets, only: targets_from_sources, resolve_module_dependencies, & - resolve_target_linking, build_target_t, build_target_ptr, & - FPM_TARGET_EXECUTABLE, FPM_TARGET_OBJECT, FPM_TARGET_ARCHIVE - use fpm_model, only: fpm_model_t, srcfile_t, & - FPM_UNIT_UNKNOWN, FPM_UNIT_PROGRAM, FPM_UNIT_MODULE, & - FPM_UNIT_SUBMODULE, FPM_UNIT_SUBPROGRAM, FPM_UNIT_CSOURCE, & - FPM_UNIT_CHEADER, FPM_SCOPE_UNKNOWN, FPM_SCOPE_LIB, & - FPM_SCOPE_DEP, FPM_SCOPE_APP, FPM_SCOPE_TEST - use fpm_strings, only: string_t, operator(.in.) - use fpm, only: check_modules_for_duplicates - implicit none - private - - public :: collect_module_dependencies, operator(.in.) - - interface operator(.in.) - module procedure target_in - end interface + use testsuite, only: new_unittest, unittest_t, error_t, test_failed + use fpm_targets, only: targets_from_sources, resolve_module_dependencies, & + resolve_target_linking, build_target_t, build_target_ptr, & + FPM_TARGET_EXECUTABLE, FPM_TARGET_OBJECT, FPM_TARGET_ARCHIVE + use fpm_model, only: fpm_model_t, srcfile_t, & + FPM_UNIT_UNKNOWN, FPM_UNIT_PROGRAM, FPM_UNIT_MODULE, & + FPM_UNIT_SUBMODULE, FPM_UNIT_SUBPROGRAM, FPM_UNIT_CSOURCE, & + FPM_UNIT_CHEADER, FPM_SCOPE_UNKNOWN, FPM_SCOPE_LIB, & + FPM_SCOPE_DEP, FPM_SCOPE_APP, FPM_SCOPE_TEST + use fpm_strings, only: string_t, operator(.in.) + use fpm, only: check_modules_for_duplicates + implicit none + private + + public :: collect_module_dependencies, operator(.in.) + + interface operator(.in.) + module procedure target_in + end interface contains + !> Collect all exported unit tests + subroutine collect_module_dependencies(testsuite) + + !> Collection of tests + type(unittest_t), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + & new_unittest("library-module-use", test_library_module_use), & + & new_unittest("program-module-use", test_program_module_use), & + & new_unittest("program-with-module", test_program_with_module), & + & new_unittest("program-own-module-use", test_program_own_module_use), & + & new_unittest("missing-library-use", & + test_missing_library_use, should_fail=.true.), & + & new_unittest("missing-program-use", & + test_missing_program_use, should_fail=.true.), & + & new_unittest("invalid-library-use", & + test_invalid_library_use, should_fail=.true.), & + & new_unittest("package-with-no-duplicates", & + test_package_with_no_module_duplicates), & + & new_unittest("package-with-duplicates-in-same-source", & + test_package_module_duplicates_same_source, should_fail=.true.), & + & new_unittest("package-with-duplicates-in-one-package", & + test_package_module_duplicates_one_package, should_fail=.true.), & + & new_unittest("package-with-duplicates-in-two-packages", & + test_package_module_duplicates_two_packages, should_fail=.true.), & + & new_unittest("subdirectory-module-use", & + test_subdirectory_module_use), & + & new_unittest("invalid-subdirectory-module-use", & + test_invalid_subdirectory_module_use, should_fail=.true.), & + & new_unittest("tree-shake-module", & + test_tree_shake_module, should_fail=.false.), & + & new_unittest("tree-shake-subprogram-with-module", & + test_tree_shake_subprogram_with_module, should_fail=.false.) & + ] + + end subroutine collect_module_dependencies - !> Collect all exported unit tests - subroutine collect_module_dependencies(testsuite) - - !> Collection of tests - type(unittest_t), allocatable, intent(out) :: testsuite(:) - - testsuite = [ & - & new_unittest("library-module-use", test_library_module_use), & - & new_unittest("program-module-use", test_program_module_use), & - & new_unittest("program-with-module", test_program_with_module), & - & new_unittest("program-own-module-use", test_program_own_module_use), & - & new_unittest("missing-library-use", & - test_missing_library_use, should_fail=.true.), & - & new_unittest("missing-program-use", & - test_missing_program_use, should_fail=.true.), & - & new_unittest("invalid-library-use", & - test_invalid_library_use, should_fail=.true.), & - & new_unittest("package-with-no-duplicates", & - test_package_with_no_module_duplicates), & - & new_unittest("package-with-duplicates-in-same-source", & - test_package_module_duplicates_same_source, should_fail=.true.), & - & new_unittest("package-with-duplicates-in-one-package", & - test_package_module_duplicates_one_package, should_fail=.true.), & - & new_unittest("package-with-duplicates-in-two-packages", & - test_package_module_duplicates_two_packages, should_fail=.true.), & - & new_unittest("subdirectory-module-use", & - test_subdirectory_module_use), & - & new_unittest("invalid-subdirectory-module-use", & - test_invalid_subdirectory_module_use, should_fail=.true.), & - & new_unittest("tree-shake-module", & - test_tree_shake_module, should_fail=.false.), & - & new_unittest("tree-shake-subprogram-with-module", & - test_tree_shake_subprogram_with_module, should_fail=.false.) & - ] - - end subroutine collect_module_dependencies - - - !> Check library module using another library module - subroutine test_library_module_use(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(fpm_model_t) :: model - type(build_target_ptr), allocatable :: targets(:) - - allocate(model%external_modules(0)) - allocate(model%packages(1)) - allocate(model%packages(1)%sources(2)) - - model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_1.f90", & - scope = FPM_SCOPE_LIB, & - provides=[string_t('my_mod_1')]) - - model%packages(1)%sources(2) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_2.f90", & - scope = FPM_SCOPE_LIB, & - provides=[string_t('my_mod_2')], & - uses=[string_t('my_mod_1')]) - - call targets_from_sources(targets,model,.false.,error) - if (allocated(error)) return - - if (allocated(error)) then - return - end if - if (size(targets) /= 3) then - call test_failed(error,'Incorrect number of targets - expecting three') - return - end if + !> Check library module using another library module + subroutine test_library_module_use(error) - call check_target(targets(1)%ptr,type=FPM_TARGET_ARCHIVE,n_depends=2, & - deps = [targets(2),targets(3)], & - links = targets(2:3), error=error) + !> Error handling + type(error_t), allocatable, intent(out) :: error - if (allocated(error)) return + type(fpm_model_t) :: model + type(build_target_ptr), allocatable :: targets(:) + allocate (model%external_modules(0)) + allocate (model%packages(1)) + allocate (model%packages(1)%sources(2)) - call check_target(targets(2)%ptr,type=FPM_TARGET_OBJECT,n_depends=0, & - source=model%packages(1)%sources(1),error=error) + model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE, file_name="src/my_mod_1.f90", & + scope=FPM_SCOPE_LIB, & + provides=[string_t('my_mod_1')]) - if (allocated(error)) return + model%packages(1)%sources(2) = new_test_source(FPM_UNIT_MODULE, file_name="src/my_mod_2.f90", & + scope=FPM_SCOPE_LIB, & + provides=[string_t('my_mod_2')], & + uses=[string_t('my_mod_1')]) + call targets_from_sources(targets, model, .false., error) + if (allocated(error)) return - call check_target(targets(3)%ptr,type=FPM_TARGET_OBJECT,n_depends=1, & - deps=[targets(2)],source=model%packages(1)%sources(2),error=error) + if (allocated(error)) then + return + end if + if (size(targets) /= 3) then + call test_failed(error, 'Incorrect number of targets - expecting three') + return + end if - if (allocated(error)) return + call check_target(targets(1)%ptr, type=FPM_TARGET_ARCHIVE, n_depends=2, & + deps=[targets(2), targets(3)], & + links=targets(2:3), error=error) - end subroutine test_library_module_use + if (allocated(error)) return + call check_target(targets(2)%ptr, type=FPM_TARGET_OBJECT, n_depends=0, & + source=model%packages(1)%sources(1), error=error) - !> Check a program using a library module - !> Each program generates two targets: object file and executable - !> - subroutine test_program_module_use(error) + if (allocated(error)) return - !> Error handling - type(error_t), allocatable, intent(out) :: error + call check_target(targets(3)%ptr, type=FPM_TARGET_OBJECT, n_depends=1, & + deps=[targets(2)], source=model%packages(1)%sources(2), error=error) - call test_scope(FPM_SCOPE_APP,error) - if (allocated(error)) return + if (allocated(error)) return - call test_scope(FPM_SCOPE_TEST,error) - if (allocated(error)) return + end subroutine test_library_module_use - contains + !> Check a program using a library module + !> Each program generates two targets: object file and executable + !> + subroutine test_program_module_use(error) - subroutine test_scope(exe_scope,error) - integer, intent(in) :: exe_scope - type(error_t), allocatable, intent(out) :: error + !> Error handling + type(error_t), allocatable, intent(out) :: error - type(fpm_model_t) :: model - type(build_target_ptr), allocatable :: targets(:) - character(:), allocatable :: scope_str + call test_scope(FPM_SCOPE_APP, error) + if (allocated(error)) return - allocate(model%external_modules(0)) - allocate(model%packages(1)) - allocate(model%packages(1)%sources(2)) + call test_scope(FPM_SCOPE_TEST, error) + if (allocated(error)) return - scope_str = merge('FPM_SCOPE_APP ','FPM_SCOPE_TEST',exe_scope==FPM_SCOPE_APP)//' - ' + contains - model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_1.f90", & - scope = FPM_SCOPE_LIB, & - provides=[string_t('my_mod_1')]) + subroutine test_scope(exe_scope, error) + integer, intent(in) :: exe_scope + type(error_t), allocatable, intent(out) :: error - model%packages(1)%sources(2) = new_test_source(FPM_UNIT_PROGRAM,file_name="app/my_program.f90", & - scope=exe_scope, & - uses=[string_t('my_mod_1')]) + type(fpm_model_t) :: model + type(build_target_ptr), allocatable :: targets(:) + character(:), allocatable :: scope_str - call targets_from_sources(targets,model,.false.,error) - if (allocated(error)) return + allocate (model%external_modules(0)) + allocate (model%packages(1)) + allocate (model%packages(1)%sources(2)) - if (size(targets) /= 4) then - call test_failed(error,scope_str//'Incorrect number of targets - expecting three') - return - end if + scope_str = merge('FPM_SCOPE_APP ', 'FPM_SCOPE_TEST', exe_scope == FPM_SCOPE_APP)//' - ' - call check_target(targets(1)%ptr,type=FPM_TARGET_ARCHIVE,n_depends=1, & - deps=[targets(2)],links=[targets(2)],error=error) + model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE, file_name="src/my_mod_1.f90", & + scope=FPM_SCOPE_LIB, & + provides=[string_t('my_mod_1')]) - if (allocated(error)) return + model%packages(1)%sources(2) = new_test_source(FPM_UNIT_PROGRAM, file_name="app/my_program.f90", & + scope=exe_scope, & + uses=[string_t('my_mod_1')]) - call check_target(targets(2)%ptr,type=FPM_TARGET_OBJECT,n_depends=0, & - source=model%packages(1)%sources(1),error=error) + call targets_from_sources(targets, model, .false., error) + if (allocated(error)) return - if (allocated(error)) return + if (size(targets) /= 4) then + call test_failed(error, scope_str//'Incorrect number of targets - expecting three') + return + end if - call check_target(targets(3)%ptr,type=FPM_TARGET_OBJECT,n_depends=1, & - deps=[targets(2)],source=model%packages(1)%sources(2),error=error) + call check_target(targets(1)%ptr, type=FPM_TARGET_ARCHIVE, n_depends=1, & + deps=[targets(2)], links=[targets(2)], error=error) - if (allocated(error)) return + if (allocated(error)) return - call check_target(targets(4)%ptr,type=FPM_TARGET_EXECUTABLE,n_depends=2, & - deps=[targets(1),targets(3)], & - links=[targets(3)], error=error) + call check_target(targets(2)%ptr, type=FPM_TARGET_OBJECT, n_depends=0, & + source=model%packages(1)%sources(1), error=error) - if (allocated(error)) return + if (allocated(error)) return - end subroutine test_scope + call check_target(targets(3)%ptr, type=FPM_TARGET_OBJECT, n_depends=1, & + deps=[targets(2)], source=model%packages(1)%sources(2), error=error) - end subroutine test_program_module_use + if (allocated(error)) return + call check_target(targets(4)%ptr, type=FPM_TARGET_EXECUTABLE, n_depends=2, & + deps=[targets(1), targets(3)], & + links=[targets(3)], error=error) - !> Check program with module in single source file - !> (Resulting target should not include itself as a dependency) - subroutine test_program_with_module(error) + if (allocated(error)) return - !> Error handling - type(error_t), allocatable, intent(out) :: error + end subroutine test_scope - type(fpm_model_t) :: model - type(build_target_ptr), allocatable :: targets(:) + end subroutine test_program_module_use - allocate(model%external_modules(0)) - allocate(model%packages(1)) - allocate(model%packages(1)%sources(1)) + !> Check program with module in single source file + !> (Resulting target should not include itself as a dependency) + subroutine test_program_with_module(error) - model%packages(1)%sources(1) = new_test_source(FPM_UNIT_PROGRAM,file_name="app/my_program.f90", & - scope = FPM_SCOPE_APP, & - provides=[string_t('app_mod')], & - uses=[string_t('app_mod')]) + !> Error handling + type(error_t), allocatable, intent(out) :: error - call targets_from_sources(targets,model,.false.,error) - if (allocated(error)) return + type(fpm_model_t) :: model + type(build_target_ptr), allocatable :: targets(:) - if (size(targets) /= 2) then - write(*,*) size(targets) - call test_failed(error,'Incorrect number of targets - expecting two') - return - end if + allocate (model%external_modules(0)) + allocate (model%packages(1)) + allocate (model%packages(1)%sources(1)) - call check_target(targets(1)%ptr,type=FPM_TARGET_OBJECT,n_depends=0, & - source=model%packages(1)%sources(1),error=error) + model%packages(1)%sources(1) = new_test_source(FPM_UNIT_PROGRAM, file_name="app/my_program.f90", & + scope=FPM_SCOPE_APP, & + provides=[string_t('app_mod')], & + uses=[string_t('app_mod')]) - if (allocated(error)) return + call targets_from_sources(targets, model, .false., error) + if (allocated(error)) return - call check_target(targets(2)%ptr,type=FPM_TARGET_EXECUTABLE,n_depends=1, & - deps=[targets(1)],links=[targets(1)],error=error) + if (size(targets) /= 2) then + write (*, *) size(targets) + call test_failed(error, 'Incorrect number of targets - expecting two') + return + end if - if (allocated(error)) return + call check_target(targets(1)%ptr, type=FPM_TARGET_OBJECT, n_depends=0, & + source=model%packages(1)%sources(1), error=error) - end subroutine test_program_with_module + if (allocated(error)) return + call check_target(targets(2)%ptr, type=FPM_TARGET_EXECUTABLE, n_depends=1, & + deps=[targets(1)], links=[targets(1)], error=error) - !> Check program using modules in same directory - subroutine test_program_own_module_use(error) + if (allocated(error)) return - !> Error handling - type(error_t), allocatable, intent(out) :: error + end subroutine test_program_with_module - call test_scope(FPM_SCOPE_APP,error) - if (allocated(error)) return + !> Check program using modules in same directory + subroutine test_program_own_module_use(error) - call test_scope(FPM_SCOPE_TEST,error) - if (allocated(error)) return + !> Error handling + type(error_t), allocatable, intent(out) :: error - contains + call test_scope(FPM_SCOPE_APP, error) + if (allocated(error)) return - subroutine test_scope(exe_scope,error) - integer, intent(in) :: exe_scope - type(error_t), allocatable, intent(out) :: error + call test_scope(FPM_SCOPE_TEST, error) + if (allocated(error)) return - type(fpm_model_t) :: model - type(build_target_ptr), allocatable :: targets(:) - character(:), allocatable :: scope_str + contains - allocate(model%external_modules(0)) - allocate(model%packages(1)) - allocate(model%packages(1)%sources(3)) + subroutine test_scope(exe_scope, error) + integer, intent(in) :: exe_scope + type(error_t), allocatable, intent(out) :: error - scope_str = merge('FPM_SCOPE_APP ','FPM_SCOPE_TEST',exe_scope==FPM_SCOPE_APP)//' - ' + type(fpm_model_t) :: model + type(build_target_ptr), allocatable :: targets(:) + character(:), allocatable :: scope_str - model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="app/app_mod1.f90", & - scope = exe_scope, & - provides=[string_t('app_mod1')]) + allocate (model%external_modules(0)) + allocate (model%packages(1)) + allocate (model%packages(1)%sources(3)) - model%packages(1)%sources(2) = new_test_source(FPM_UNIT_MODULE,file_name="app/app_mod2.f90", & - scope = exe_scope, & - provides=[string_t('app_mod2')],uses=[string_t('app_mod1')]) + scope_str = merge('FPM_SCOPE_APP ', 'FPM_SCOPE_TEST', exe_scope == FPM_SCOPE_APP)//' - ' - model%packages(1)%sources(3) = new_test_source(FPM_UNIT_PROGRAM,file_name="app/my_program.f90", & - scope=exe_scope, & - uses=[string_t('app_mod2')]) + model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE, file_name="app/app_mod1.f90", & + scope=exe_scope, & + provides=[string_t('app_mod1')]) - call targets_from_sources(targets,model,.false.,error) - if (allocated(error)) return + model%packages(1)%sources(2) = new_test_source(FPM_UNIT_MODULE, file_name="app/app_mod2.f90", & + scope=exe_scope, & + provides=[string_t('app_mod2')], uses=[string_t('app_mod1')]) - if (size(targets) /= 4) then - call test_failed(error,scope_str//'Incorrect number of targets - expecting three') - return - end if + model%packages(1)%sources(3) = new_test_source(FPM_UNIT_PROGRAM, file_name="app/my_program.f90", & + scope=exe_scope, & + uses=[string_t('app_mod2')]) - call check_target(targets(1)%ptr,type=FPM_TARGET_OBJECT,n_depends=0, & - source=model%packages(1)%sources(1),error=error) + call targets_from_sources(targets, model, .false., error) + if (allocated(error)) return - if (allocated(error)) return + if (size(targets) /= 4) then + call test_failed(error, scope_str//'Incorrect number of targets - expecting three') + return + end if - call check_target(targets(2)%ptr,type=FPM_TARGET_OBJECT,n_depends=1, & - source=model%packages(1)%sources(2),deps=[targets(1)],error=error) + call check_target(targets(1)%ptr, type=FPM_TARGET_OBJECT, n_depends=0, & + source=model%packages(1)%sources(1), error=error) - if (allocated(error)) return + if (allocated(error)) return - call check_target(targets(3)%ptr,type=FPM_TARGET_OBJECT,n_depends=1, & - source=model%packages(1)%sources(3),deps=[targets(2)],error=error) + call check_target(targets(2)%ptr, type=FPM_TARGET_OBJECT, n_depends=1, & + source=model%packages(1)%sources(2), deps=[targets(1)], error=error) - if (allocated(error)) return + if (allocated(error)) return - call check_target(targets(4)%ptr,type=FPM_TARGET_EXECUTABLE,n_depends=1, & - deps=[targets(3)],links=targets(1:3), error=error) + call check_target(targets(3)%ptr, type=FPM_TARGET_OBJECT, n_depends=1, & + source=model%packages(1)%sources(3), deps=[targets(2)], error=error) - if (allocated(error)) return + if (allocated(error)) return - end subroutine test_scope - end subroutine test_program_own_module_use + call check_target(targets(4)%ptr, type=FPM_TARGET_EXECUTABLE, n_depends=1, & + deps=[targets(3)], links=targets(1:3), error=error) + if (allocated(error)) return - !> Check missing library module dependency - subroutine test_missing_library_use(error) + end subroutine test_scope + end subroutine test_program_own_module_use - !> Error handling - type(error_t), allocatable, intent(out) :: error + !> Check missing library module dependency + subroutine test_missing_library_use(error) - type(fpm_model_t) :: model - type(build_target_ptr), allocatable :: targets(:) + !> Error handling + type(error_t), allocatable, intent(out) :: error - allocate(model%external_modules(0)) - allocate(model%packages(1)) - allocate(model%packages(1)%sources(2)) + type(fpm_model_t) :: model + type(build_target_ptr), allocatable :: targets(:) - model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_1.f90", & - scope = FPM_SCOPE_LIB, & - provides=[string_t('my_mod_1')]) + allocate (model%external_modules(0)) + allocate (model%packages(1)) + allocate (model%packages(1)%sources(2)) - model%packages(1)%sources(2) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_2.f90", & - scope = FPM_SCOPE_LIB, & - provides=[string_t('my_mod_2')], & - uses=[string_t('my_mod_3')]) + model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE, file_name="src/my_mod_1.f90", & + scope=FPM_SCOPE_LIB, & + provides=[string_t('my_mod_1')]) - call targets_from_sources(targets,model,.false.,error) + model%packages(1)%sources(2) = new_test_source(FPM_UNIT_MODULE, file_name="src/my_mod_2.f90", & + scope=FPM_SCOPE_LIB, & + provides=[string_t('my_mod_2')], & + uses=[string_t('my_mod_3')]) - end subroutine test_missing_library_use + call targets_from_sources(targets, model, .false., error) + end subroutine test_missing_library_use - !> Check missing program module dependency - subroutine test_missing_program_use(error) + !> Check missing program module dependency + subroutine test_missing_program_use(error) - !> Error handling - type(error_t), allocatable, intent(out) :: error + !> Error handling + type(error_t), allocatable, intent(out) :: error - type(fpm_model_t) :: model - type(build_target_ptr), allocatable :: targets(:) + type(fpm_model_t) :: model + type(build_target_ptr), allocatable :: targets(:) - allocate(model%external_modules(0)) - allocate(model%packages(1)) - allocate(model%packages(1)%sources(2)) + allocate (model%external_modules(0)) + allocate (model%packages(1)) + allocate (model%packages(1)%sources(2)) - model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_1.f90", & - scope = FPM_SCOPE_LIB, & - provides=[string_t('my_mod_1')]) + model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE, file_name="src/my_mod_1.f90", & + scope=FPM_SCOPE_LIB, & + provides=[string_t('my_mod_1')]) - model%packages(1)%sources(2) = new_test_source(FPM_UNIT_PROGRAM,file_name="app/my_program.f90", & - scope=FPM_SCOPE_APP, & - uses=[string_t('my_mod_2')]) + model%packages(1)%sources(2) = new_test_source(FPM_UNIT_PROGRAM, file_name="app/my_program.f90", & + scope=FPM_SCOPE_APP, & + uses=[string_t('my_mod_2')]) - call targets_from_sources(targets,model,.false.,error) + call targets_from_sources(targets, model, .false., error) - end subroutine test_missing_program_use + end subroutine test_missing_program_use + !> Check library module using a non-library module + subroutine test_invalid_library_use(error) - !> Check library module using a non-library module - subroutine test_invalid_library_use(error) + !> Error handling + type(error_t), allocatable, intent(out) :: error - !> Error handling - type(error_t), allocatable, intent(out) :: error + type(fpm_model_t) :: model + type(build_target_ptr), allocatable :: targets(:) - type(fpm_model_t) :: model - type(build_target_ptr), allocatable :: targets(:) + allocate (model%external_modules(0)) + allocate (model%packages(1)) + allocate (model%packages(1)%sources(2)) - allocate(model%external_modules(0)) - allocate(model%packages(1)) - allocate(model%packages(1)%sources(2)) + model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE, file_name="app/app_mod.f90", & + scope=FPM_SCOPE_APP, & + provides=[string_t('app_mod')]) - model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="app/app_mod.f90", & - scope = FPM_SCOPE_APP, & - provides=[string_t('app_mod')]) + model%packages(1)%sources(2) = new_test_source(FPM_UNIT_MODULE, file_name="src/my_mod.f90", & + scope=FPM_SCOPE_LIB, & + provides=[string_t('my_mod')], & + uses=[string_t('app_mod')]) - model%packages(1)%sources(2) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod.f90", & - scope = FPM_SCOPE_LIB, & - provides=[string_t('my_mod')], & - uses=[string_t('app_mod')]) + call targets_from_sources(targets, model, .false., error) - call targets_from_sources(targets,model,.false.,error) + end subroutine test_invalid_library_use - end subroutine test_invalid_library_use + !> Check program using a non-library module in a sub-directory + subroutine test_subdirectory_module_use(error) + !> Error handling + type(error_t), allocatable, intent(out) :: error - !> Check program using a non-library module in a sub-directory - subroutine test_subdirectory_module_use(error) + type(fpm_model_t) :: model + type(build_target_ptr), allocatable :: targets(:) - !> Error handling - type(error_t), allocatable, intent(out) :: error + allocate (model%external_modules(0)) + allocate (model%packages(1)) + allocate (model%packages(1)%sources(2)) - type(fpm_model_t) :: model - type(build_target_ptr), allocatable :: targets(:) + model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE, file_name="app/subdir/app_mod.f90", & + scope=FPM_SCOPE_APP, & + provides=[string_t('app_mod')]) - allocate(model%external_modules(0)) - allocate(model%packages(1)) - allocate(model%packages(1)%sources(2)) + model%packages(1)%sources(2) = new_test_source(FPM_UNIT_PROGRAM, file_name="app/my_program.f90", & + scope=FPM_SCOPE_APP, & + uses=[string_t('app_mod')]) - model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="app/subdir/app_mod.f90", & - scope = FPM_SCOPE_APP, & - provides=[string_t('app_mod')]) + call targets_from_sources(targets, model, .false., error) - model%packages(1)%sources(2) = new_test_source(FPM_UNIT_PROGRAM,file_name="app/my_program.f90", & - scope=FPM_SCOPE_APP, & - uses=[string_t('app_mod')]) + end subroutine test_subdirectory_module_use - call targets_from_sources(targets,model,.false.,error) + !> Check program with no duplicate modules + subroutine test_package_with_no_module_duplicates(error) - end subroutine test_subdirectory_module_use + type(error_t), allocatable, intent(out) :: error - !> Check program with no duplicate modules - subroutine test_package_with_no_module_duplicates(error) + type(fpm_model_t) :: model + logical :: duplicates_found = .false. - type(error_t), allocatable, intent(out) :: error + allocate (model%packages(1)) + allocate (model%packages(1)%sources(2)) - type(fpm_model_t) :: model - logical :: duplicates_found = .false. + model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE, file_name="src/my_mod_1.f90", & + scope=FPM_SCOPE_LIB, provides=[string_t('my_mod_1')]) - allocate(model%packages(1)) - allocate(model%packages(1)%sources(2)) + model%packages(1)%sources(2) = new_test_source(FPM_UNIT_MODULE, file_name="src/my_mod_2.f90", & + scope=FPM_SCOPE_LIB, provides=[string_t('my_mod_2')]) - model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_1.f90", & - scope = FPM_SCOPE_LIB, provides=[string_t('my_mod_1')]) + call check_modules_for_duplicates(model, duplicates_found) + if (duplicates_found) then + call test_failed(error, 'Duplicate modules found') + return + end if + end subroutine test_package_with_no_module_duplicates - model%packages(1)%sources(2) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_2.f90", & - scope = FPM_SCOPE_LIB, provides=[string_t('my_mod_2')]) + !> Check program with duplicate modules in same source file + subroutine test_package_module_duplicates_same_source(error) - call check_modules_for_duplicates(model, duplicates_found) - if (duplicates_found) then - call test_failed(error,'Duplicate modules found') - return - end if - end subroutine test_package_with_no_module_duplicates + type(error_t), allocatable, intent(out) :: error - !> Check program with duplicate modules in same source file - subroutine test_package_module_duplicates_same_source(error) + type(fpm_model_t) :: model + logical :: duplicates_found - type(error_t), allocatable, intent(out) :: error + allocate (model%packages(1)) + allocate (model%packages(1)%sources(1)) - type(fpm_model_t) :: model - logical :: duplicates_found + model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE, file_name="src/my_mod_1.f90", & + scope=FPM_SCOPE_LIB, provides=[string_t('my_mod_1'), string_t('my_mod_1')]) - allocate(model%packages(1)) - allocate(model%packages(1)%sources(1)) + call check_modules_for_duplicates(model, duplicates_found) + if (duplicates_found) then + call test_failed(error, 'Duplicate modules found') + return + end if + end subroutine test_package_module_duplicates_same_source - model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_1.f90", & - scope = FPM_SCOPE_LIB, provides=[string_t('my_mod_1'), string_t('my_mod_1')]) + !> Check program with duplicate modules in two different source files in one package + subroutine test_package_module_duplicates_one_package(error) - call check_modules_for_duplicates(model, duplicates_found) - if (duplicates_found) then - call test_failed(error,'Duplicate modules found') - return - end if - end subroutine test_package_module_duplicates_same_source + type(error_t), allocatable, intent(out) :: error - !> Check program with duplicate modules in two different source files in one package - subroutine test_package_module_duplicates_one_package(error) + type(fpm_model_t) :: model + logical :: duplicates_found - type(error_t), allocatable, intent(out) :: error + allocate (model%packages(1)) + allocate (model%packages(1)%sources(2)) - type(fpm_model_t) :: model - logical :: duplicates_found + model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE, file_name="src/my_mod_1_a.f90", & + scope=FPM_SCOPE_LIB, provides=[string_t('my_mod_1')]) - allocate(model%packages(1)) - allocate(model%packages(1)%sources(2)) + model%packages(1)%sources(2) = new_test_source(FPM_UNIT_MODULE, file_name="src/my_mod_1_b.f90", & + scope=FPM_SCOPE_LIB, provides=[string_t('my_mod_1')]) - model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_1_a.f90", & - scope = FPM_SCOPE_LIB, provides=[string_t('my_mod_1')]) + call check_modules_for_duplicates(model, duplicates_found) + if (duplicates_found) then + call test_failed(error, 'Duplicate modules found') + return + end if + end subroutine test_package_module_duplicates_one_package - model%packages(1)%sources(2) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_1_b.f90", & - scope = FPM_SCOPE_LIB, provides=[string_t('my_mod_1')]) + !> Check program with duplicate modules in two different packages + subroutine test_package_module_duplicates_two_packages(error) - call check_modules_for_duplicates(model, duplicates_found) - if (duplicates_found) then - call test_failed(error,'Duplicate modules found') - return - end if - end subroutine test_package_module_duplicates_one_package + type(error_t), allocatable, intent(out) :: error - !> Check program with duplicate modules in two different packages - subroutine test_package_module_duplicates_two_packages(error) + type(fpm_model_t) :: model + logical :: duplicates_found - type(error_t), allocatable, intent(out) :: error + allocate (model%packages(2)) + allocate (model%packages(1)%sources(1)) + allocate (model%packages(2)%sources(1)) - type(fpm_model_t) :: model - logical :: duplicates_found + model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE, file_name="src/subdir1/my_mod_1.f90", & + scope=FPM_SCOPE_LIB, provides=[string_t('my_mod_1')]) - allocate(model%packages(2)) - allocate(model%packages(1)%sources(1)) - allocate(model%packages(2)%sources(1)) + model%packages(2)%sources(1) = new_test_source(FPM_UNIT_MODULE, file_name="src/subdir2/my_mod_1.f90", & + scope=FPM_SCOPE_LIB, provides=[string_t('my_mod_1')]) - model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="src/subdir1/my_mod_1.f90", & - scope = FPM_SCOPE_LIB, provides=[string_t('my_mod_1')]) + call check_modules_for_duplicates(model, duplicates_found) + if (duplicates_found) then + call test_failed(error, 'Duplicate modules found') + return + end if + end subroutine test_package_module_duplicates_two_packages - model%packages(2)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="src/subdir2/my_mod_1.f90", & - scope = FPM_SCOPE_LIB, provides=[string_t('my_mod_1')]) + !> Check tree-shaking of unused modules + !> Unused module should not be included in targets + subroutine test_tree_shake_module(error) - call check_modules_for_duplicates(model, duplicates_found) - if (duplicates_found) then - call test_failed(error,'Duplicate modules found') - return - end if - end subroutine test_package_module_duplicates_two_packages + !> Error handling + type(error_t), allocatable, intent(out) :: error + type(fpm_model_t) :: model + type(build_target_ptr), allocatable :: targets(:) + character(:), allocatable :: scope_str - !> Check tree-shaking of unused modules - !> Unused module should not be included in targets - subroutine test_tree_shake_module(error) + allocate (model%external_modules(0)) + allocate (model%packages(1)) + allocate (model%packages(1)%sources(4)) - !> Error handling - type(error_t), allocatable, intent(out) :: error + model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE, file_name="src/my_mod_1.f90", & + scope=FPM_SCOPE_LIB, & + provides=[string_t('my_mod_1')]) ! indirectly used - type(fpm_model_t) :: model - type(build_target_ptr), allocatable :: targets(:) - character(:), allocatable :: scope_str + model%packages(1)%sources(2) = new_test_source(FPM_UNIT_MODULE, file_name="src/my_mod_2.f90", & + scope=FPM_SCOPE_LIB, & + provides=[string_t('my_mod_2')], & + uses=[string_t('my_mod_1')]) ! directly used - allocate(model%external_modules(0)) - allocate(model%packages(1)) - allocate(model%packages(1)%sources(4)) + model%packages(1)%sources(3) = new_test_source(FPM_UNIT_MODULE, file_name="src/my_mod_3.f90", & + scope=FPM_SCOPE_LIB, & + provides=[string_t('my_mod_3')]) ! unused module - model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_1.f90", & - scope = FPM_SCOPE_LIB, & - provides=[string_t('my_mod_1')]) ! indirectly used + model%packages(1)%sources(4) = new_test_source(FPM_UNIT_PROGRAM, file_name="app/my_program.f90", & + scope=FPM_SCOPE_APP, & + uses=[string_t('my_mod_2')]) - model%packages(1)%sources(2) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_2.f90", & - scope = FPM_SCOPE_LIB, & - provides=[string_t('my_mod_2')], & - uses=[string_t('my_mod_1')]) ! directly used + call targets_from_sources(targets, model, prune=.true., error=error) + if (allocated(error)) return - model%packages(1)%sources(3) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_3.f90", & - scope = FPM_SCOPE_LIB, & - provides=[string_t('my_mod_3')]) ! unused module + if (size(targets) /= 5) then + call test_failed(error, scope_str//'Incorrect number of targets - expecting five') + return + end if - model%packages(1)%sources(4) = new_test_source(FPM_UNIT_PROGRAM,file_name="app/my_program.f90", & - scope=FPM_SCOPE_APP, & - uses=[string_t('my_mod_2')]) + call check_target(targets(1)%ptr, type=FPM_TARGET_ARCHIVE, n_depends=2, & + deps=[targets(2), targets(3)], & + links=[targets(2), targets(3)], error=error) - call targets_from_sources(targets,model,prune=.true.,error=error) - if (allocated(error)) return + if (allocated(error)) return - if (size(targets) /= 5) then - call test_failed(error,scope_str//'Incorrect number of targets - expecting five') - return - end if + call check_target(targets(2)%ptr, type=FPM_TARGET_OBJECT, n_depends=0, & + source=model%packages(1)%sources(1), error=error) - call check_target(targets(1)%ptr,type=FPM_TARGET_ARCHIVE,n_depends=2, & - deps=[targets(2),targets(3)], & - links=[targets(2),targets(3)],error=error) + if (allocated(error)) return - if (allocated(error)) return + call check_target(targets(3)%ptr, type=FPM_TARGET_OBJECT, n_depends=1, & + deps=[targets(2)], source=model%packages(1)%sources(2), error=error) - call check_target(targets(2)%ptr,type=FPM_TARGET_OBJECT,n_depends=0, & - source=model%packages(1)%sources(1),error=error) + if (allocated(error)) return - if (allocated(error)) return + call check_target(targets(4)%ptr, type=FPM_TARGET_OBJECT, n_depends=1, & + deps=[targets(3)], source=model%packages(1)%sources(4), error=error) - call check_target(targets(3)%ptr,type=FPM_TARGET_OBJECT,n_depends=1, & - deps=[targets(2)],source=model%packages(1)%sources(2),error=error) + if (allocated(error)) return - if (allocated(error)) return + call check_target(targets(5)%ptr, type=FPM_TARGET_EXECUTABLE, n_depends=2, & + deps=[targets(1), targets(4)], & + links=[targets(4)], error=error) - call check_target(targets(4)%ptr,type=FPM_TARGET_OBJECT,n_depends=1, & - deps=[targets(3)],source=model%packages(1)%sources(4),error=error) + if (allocated(error)) return - if (allocated(error)) return + end subroutine test_tree_shake_module - call check_target(targets(5)%ptr,type=FPM_TARGET_EXECUTABLE,n_depends=2, & - deps=[targets(1),targets(4)], & - links=[targets(4)], error=error) + !> Check tree-shaking of modules used via a subprogram source + !> (Subprogram type is a source containing any non-module subroutines/functions) + !> Subprograms cannot be pruned, so neither can their dependencies + subroutine test_tree_shake_subprogram_with_module(error) - if (allocated(error)) return + !> Error handling + type(error_t), allocatable, intent(out) :: error - end subroutine test_tree_shake_module + type(fpm_model_t) :: model + type(build_target_ptr), allocatable :: targets(:) + character(:), allocatable :: scope_str + allocate (model%external_modules(0)) + allocate (model%packages(1)) + allocate (model%packages(1)%sources(4)) - !> Check tree-shaking of modules used via a subprogram source - !> (Subprogram type is a source containing any non-module subroutines/functions) - !> Subprograms cannot be pruned, so neither can their dependencies - subroutine test_tree_shake_subprogram_with_module(error) + model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE, file_name="src/my_mod_1.f90", & + scope=FPM_SCOPE_LIB, & + provides=[string_t('my_mod_1')]) ! used via subprogram - !> Error handling - type(error_t), allocatable, intent(out) :: error + model%packages(1)%sources(2) = new_test_source(FPM_UNIT_SUBPROGRAM, file_name="src/my_subprogram.f90", & + scope=FPM_SCOPE_LIB, & + uses=[string_t('my_mod_1')]) ! subprogram (never pruned) - type(fpm_model_t) :: model - type(build_target_ptr), allocatable :: targets(:) - character(:), allocatable :: scope_str + model%packages(1)%sources(3) = new_test_source(FPM_UNIT_MODULE, file_name="src/my_mod_3.f90", & + scope=FPM_SCOPE_LIB, & + provides=[string_t('my_mod_3')]) ! unused module - allocate(model%external_modules(0)) - allocate(model%packages(1)) - allocate(model%packages(1)%sources(4)) + model%packages(1)%sources(4) = new_test_source(FPM_UNIT_PROGRAM, file_name="app/my_program.f90", & + scope=FPM_SCOPE_APP) - model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_1.f90", & - scope = FPM_SCOPE_LIB, & - provides=[string_t('my_mod_1')]) ! used via subprogram + call targets_from_sources(targets, model, prune=.true., error=error) + if (allocated(error)) return - model%packages(1)%sources(2) = new_test_source(FPM_UNIT_SUBPROGRAM,file_name="src/my_subprogram.f90", & - scope = FPM_SCOPE_LIB, & - uses=[string_t('my_mod_1')]) ! subprogram (never pruned) + if (size(targets) /= 5) then + call test_failed(error, scope_str//'Incorrect number of targets - expecting five') + return + end if - model%packages(1)%sources(3) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_3.f90", & - scope = FPM_SCOPE_LIB, & - provides=[string_t('my_mod_3')]) ! unused module + call check_target(targets(1)%ptr, type=FPM_TARGET_ARCHIVE, n_depends=2, & + deps=[targets(2)], & + links=[targets(2), targets(3)], error=error) - model%packages(1)%sources(4) = new_test_source(FPM_UNIT_PROGRAM,file_name="app/my_program.f90", & - scope=FPM_SCOPE_APP) + if (allocated(error)) return - call targets_from_sources(targets,model,prune=.true.,error=error) - if (allocated(error)) return + call check_target(targets(2)%ptr, type=FPM_TARGET_OBJECT, n_depends=0, & + source=model%packages(1)%sources(1), error=error) - if (size(targets) /= 5) then - call test_failed(error,scope_str//'Incorrect number of targets - expecting five') - return - end if - - call check_target(targets(1)%ptr,type=FPM_TARGET_ARCHIVE,n_depends=2, & - deps=[targets(2)], & - links=[targets(2),targets(3)],error=error) + if (allocated(error)) return - if (allocated(error)) return + call check_target(targets(3)%ptr, type=FPM_TARGET_OBJECT, n_depends=1, & + deps=[targets(2)], source=model%packages(1)%sources(2), error=error) - call check_target(targets(2)%ptr,type=FPM_TARGET_OBJECT,n_depends=0, & - source=model%packages(1)%sources(1),error=error) + if (allocated(error)) return - if (allocated(error)) return + call check_target(targets(4)%ptr, type=FPM_TARGET_OBJECT, n_depends=0, & + source=model%packages(1)%sources(4), error=error) - call check_target(targets(3)%ptr,type=FPM_TARGET_OBJECT,n_depends=1, & - deps=[targets(2)],source=model%packages(1)%sources(2),error=error) + if (allocated(error)) return - if (allocated(error)) return + call check_target(targets(5)%ptr, type=FPM_TARGET_EXECUTABLE, n_depends=2, & + deps=[targets(1), targets(4)], & + links=[targets(4)], error=error) - call check_target(targets(4)%ptr,type=FPM_TARGET_OBJECT,n_depends=0, & - source=model%packages(1)%sources(4),error=error) + if (allocated(error)) return - if (allocated(error)) return + end subroutine test_tree_shake_subprogram_with_module - call check_target(targets(5)%ptr,type=FPM_TARGET_EXECUTABLE,n_depends=2, & - deps=[targets(1),targets(4)], & - links=[targets(4)], error=error) + !> Check program using a non-library module in a differente sub-directory + subroutine test_invalid_subdirectory_module_use(error) - if (allocated(error)) return + !> Error handling + type(error_t), allocatable, intent(out) :: error - end subroutine test_tree_shake_subprogram_with_module + type(fpm_model_t) :: model + type(build_target_ptr), allocatable :: targets(:) + allocate (model%external_modules(0)) + allocate (model%packages(1)) + allocate (model%packages(1)%sources(2)) - !> Check program using a non-library module in a differente sub-directory - subroutine test_invalid_subdirectory_module_use(error) + model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE, file_name="app/diff_dir/app_mod.f90", & + scope=FPM_SCOPE_APP, & + provides=[string_t('app_mod')]) - !> Error handling - type(error_t), allocatable, intent(out) :: error + model%packages(1)%sources(2) = new_test_source(FPM_UNIT_PROGRAM, file_name="app/prog_dir/my_program.f90", & + scope=FPM_SCOPE_APP, & + uses=[string_t('app_mod')]) - type(fpm_model_t) :: model - type(build_target_ptr), allocatable :: targets(:) + call targets_from_sources(targets, model, .false., error) - allocate(model%external_modules(0)) - allocate(model%packages(1)) - allocate(model%packages(1)%sources(2)) + end subroutine test_invalid_subdirectory_module_use - model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="app/diff_dir/app_mod.f90", & - scope = FPM_SCOPE_APP, & - provides=[string_t('app_mod')]) + !> Helper to create a new srcfile_t + function new_test_source(type, file_name, scope, uses, provides) result(src) + integer, intent(in) :: type + character(*), intent(in) :: file_name + integer, intent(in) :: scope + type(string_t), intent(in), optional :: uses(:) + type(string_t), intent(in), optional :: provides(:) + type(srcfile_t) :: src - model%packages(1)%sources(2) = new_test_source(FPM_UNIT_PROGRAM,file_name="app/prog_dir/my_program.f90", & - scope=FPM_SCOPE_APP, & - uses=[string_t('app_mod')]) + src%file_name = file_name + src%unit_scope = scope + src%unit_type = type - call targets_from_sources(targets,model,.false.,error) + if (present(provides)) then + src%modules_provided = provides + else + allocate (src%modules_provided(0)) + end if - end subroutine test_invalid_subdirectory_module_use + if (present(uses)) then + src%modules_used = uses + else + allocate (src%modules_used(0)) + end if - !> Helper to create a new srcfile_t - function new_test_source(type,file_name, scope, uses, provides) result(src) - integer, intent(in) :: type - character(*), intent(in) :: file_name - integer, intent(in) :: scope - type(string_t), intent(in), optional :: uses(:) - type(string_t), intent(in), optional :: provides(:) - type(srcfile_t) :: src + allocate (src%include_dependencies(0)) - src%file_name = file_name - src%unit_scope = scope - src%unit_type = type + end function new_test_source - if (present(provides)) then - src%modules_provided = provides - else - allocate(src%modules_provided(0)) - end if + !> Helper to check an expected output target + subroutine check_target(target, type, n_depends, deps, links, source, error) + type(build_target_t), intent(in) :: target + integer, intent(in) :: type + integer, intent(in) :: n_depends + type(srcfile_t), intent(in), optional :: source + type(build_target_ptr), intent(in), optional :: deps(:) + type(build_target_ptr), intent(in), optional :: links(:) + type(error_t), intent(out), allocatable :: error - if (present(uses)) then - src%modules_used = uses - else - allocate(src%modules_used(0)) - end if + integer :: i - allocate(src%include_dependencies(0)) + if (target%target_type /= type) then + call test_failed(error, 'Unexpected target_type for target "'//target%output_file//'"') + return + end if - end function new_test_source + if (size(target%dependencies) /= n_depends) then + call test_failed(error, 'Wrong number of dependencies for target "'//target%output_file//'"') + return + end if + if (present(deps)) then - !> Helper to check an expected output target - subroutine check_target(target,type,n_depends,deps,links,source,error) - type(build_target_t), intent(in) :: target - integer, intent(in) :: type - integer, intent(in) :: n_depends - type(srcfile_t), intent(in), optional :: source - type(build_target_ptr), intent(in), optional :: deps(:) - type(build_target_ptr), intent(in), optional :: links(:) - type(error_t), intent(out), allocatable :: error - - integer :: i - - if (target%target_type /= type) then - call test_failed(error,'Unexpected target_type for target "'//target%output_file//'"') - return - end if + do i = 1, size(deps) - if (size(target%dependencies) /= n_depends) then - call test_failed(error,'Wrong number of dependencies for target "'//target%output_file//'"') - return + if (.not. (deps(i)%ptr.in.target%dependencies)) then + call test_failed(error, 'Missing dependency ('//deps(i)%ptr%output_file// & + ') for target "'//target%output_file//'"') + return end if - if (present(deps)) then + end do - do i=1,size(deps) + end if - if (.not.(deps(i)%ptr .in. target%dependencies)) then - call test_failed(error,'Missing dependency ('//deps(i)%ptr%output_file//& - ') for target "'//target%output_file//'"') - return - end if + if (present(links)) then - end do + do i = 1, size(links) + if (.not. (links(i)%ptr%output_file.in.target%link_objects)) then + call test_failed(error, 'Missing object ('//links(i)%ptr%output_file// & + ') for executable "'//target%output_file//'"') + return end if - if (present(links)) then + end do - do i=1,size(links) + if (size(links) > size(target%link_objects)) then - if (.not.(links(i)%ptr%output_file .in. target%link_objects)) then - call test_failed(error,'Missing object ('//links(i)%ptr%output_file//& - ') for executable "'//target%output_file//'"') - return - end if + call test_failed(error, 'There are missing link objects for target "' & + //target%output_file//'"') + return - end do + elseif (size(links) < size(target%link_objects)) then - if (size(links) > size(target%link_objects)) then + call test_failed(error, 'There are more link objects than expected for target "' & + //target%output_file//'"') + return - call test_failed(error,'There are missing link objects for target "'& - //target%output_file//'"') - return + end if - elseif (size(links) < size(target%link_objects)) then + end if - call test_failed(error,'There are more link objects than expected for target "'& - //target%output_file//'"') - return - - end if + if (present(source)) then + if (allocated(target%source)) then + if (target%source%file_name /= source%file_name) then + call test_failed(error, 'Incorrect source ('//target%source%file_name//') for target "'// & + target%output_file//'"'//new_line('a')//' expected "'//source%file_name//'"') + return end if - if (present(source)) then - - if (allocated(target%source)) then - if (target%source%file_name /= source%file_name) then - call test_failed(error,'Incorrect source ('//target%source%file_name//') for target "'//& - target%output_file//'"'//new_line('a')//' expected "'//source%file_name//'"') - return - end if - - else - call test_failed(error,'Expecting source for target "'//target%output_file//'" but none found') - return - end if + else + call test_failed(error, 'Expecting source for target "'//target%output_file//'" but none found') + return + end if - else - - if (allocated(target%source)) then - call test_failed(error,'Found source ('//target%source%file_name//') for target "'//& - target%output_file//'" but none expected') - return - end if - - end if + else - end subroutine check_target + if (allocated(target%source)) then + call test_failed(error, 'Found source ('//target%source%file_name//') for target "'// & + target%output_file//'" but none expected') + return + end if + end if - !> Helper to check if a build target is in a list of build_target_ptr - logical function target_in(needle,haystack) - type(build_target_t), intent(in), target :: needle - type(build_target_ptr), intent(in) :: haystack(:) + end subroutine check_target - integer :: i + !> Helper to check if a build target is in a list of build_target_ptr + logical function target_in(needle, haystack) + type(build_target_t), intent(in), target :: needle + type(build_target_ptr), intent(in) :: haystack(:) - target_in = .false. - do i=1,size(haystack) + integer :: i - if (associated(haystack(i)%ptr,needle)) then - target_in = .true. - return - end if + target_in = .false. + do i = 1, size(haystack) - end do + if (associated(haystack(i)%ptr, needle)) then + target_in = .true. + return + end if - end function target_in + end do + end function target_in end module test_module_dependencies diff --git a/test/fpm_test/test_package_dependencies.f90 b/test/fpm_test/test_package_dependencies.f90 index 26f6852a0e..cec1513618 100644 --- a/test/fpm_test/test_package_dependencies.f90 +++ b/test/fpm_test/test_package_dependencies.f90 @@ -1,237 +1,229 @@ !> Define tests for the `fpm_dependency` module module test_package_dependencies - use fpm_filesystem, only: get_temp_filename - use testsuite, only : new_unittest, unittest_t, error_t, test_failed - use fpm_dependency - use fpm_manifest - use fpm_manifest_dependency - use fpm_toml - implicit none - private - - public :: collect_package_dependencies - - type, extends(dependency_tree_t) :: mock_dependency_tree_t - contains - procedure :: resolve_dependency => resolve_dependency_once - end type mock_dependency_tree_t - + use fpm_filesystem, only: get_temp_filename + use testsuite, only: new_unittest, unittest_t, error_t, test_failed + use fpm_dependency + use fpm_manifest + use fpm_manifest_dependency + use fpm_toml + implicit none + private + + public :: collect_package_dependencies + + type, extends(dependency_tree_t) :: mock_dependency_tree_t + contains + procedure :: resolve_dependency => resolve_dependency_once + end type mock_dependency_tree_t contains - - !> Collect all exported unit tests - subroutine collect_package_dependencies(testsuite) - - !> Collection of tests - type(unittest_t), allocatable, intent(out) :: testsuite(:) - - testsuite = [ & - & new_unittest("cache-load-dump", test_cache_load_dump), & - & new_unittest("cache-dump-load", test_cache_dump_load), & - & new_unittest("status-after-load", test_status), & - & new_unittest("add-dependencies", test_add_dependencies)] - - end subroutine collect_package_dependencies - - - !> Round trip of the dependency cache from a dependency tree to a TOML document - !> to a dependency tree - subroutine test_cache_dump_load(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(dependency_tree_t) :: deps - type(dependency_config_t) :: dep - integer :: unit - - call new_dependency_tree(deps) - call resize(deps%dep, 5) - deps%ndep = 3 - dep%name = "dep1" - dep%path = "fpm-tmp1-dir" - call new_dependency_node(deps%dep(1), dep, proj_dir=dep%path) - dep%name = "dep2" - dep%path = "fpm-tmp2-dir" - call new_dependency_node(deps%dep(2), dep, proj_dir=dep%path) - dep%name = "dep3" - dep%path = "fpm-tmp3-dir" - call new_dependency_node(deps%dep(3), dep, proj_dir=dep%path) - - open(newunit=unit, status='scratch') - call deps%dump(unit, error) - if (.not.allocated(error)) then - rewind(unit) - - call new_dependency_tree(deps) - call resize(deps%dep, 2) - call deps%load(unit, error) - close(unit) - end if - if (allocated(error)) return - - if (deps%ndep /= 3) then - call test_failed(error, "Expected three dependencies in loaded cache") - return - end if - - end subroutine test_cache_dump_load - - - !> Round trip of the dependency cache from a TOML data structure to - !> a dependency tree to a TOML data structure - subroutine test_cache_load_dump(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(toml_table), pointer :: ptr - type(toml_key), allocatable :: list(:) - type(dependency_tree_t) :: deps - - table = toml_table() - call add_table(table, "dep1", ptr) - call set_value(ptr, "version", "1.1.0") - call set_value(ptr, "proj-dir", "fpm-tmp1-dir") - call add_table(table, "dep2", ptr) - call set_value(ptr, "version", "0.55.3") - call set_value(ptr, "proj-dir", "fpm-tmp2-dir") - call set_value(ptr, "git", "https://github.com/fortran-lang/dep2") - call add_table(table, "dep3", ptr) - call set_value(ptr, "version", "20.1.15") - call set_value(ptr, "proj-dir", "fpm-tmp3-dir") - call set_value(ptr, "git", "https://gitlab.com/fortran-lang/dep3") - call set_value(ptr, "rev", "c0ffee") - call add_table(table, "dep4", ptr) - call set_value(ptr, "proj-dir", "fpm-tmp4-dir") - - call new_dependency_tree(deps) - call deps%load(table, error) - if (allocated(error)) return - - if (deps%ndep /= 4) then - call test_failed(error, "Expected four dependencies in loaded cache") - return - end if - - call table%destroy - table = toml_table() - - call deps%dump(table, error) - if (allocated(error)) return - - call table%get_keys(list) - - if (size(list) /= 4) then - call test_failed(error, "Expected four dependencies in dumped cache") - return - end if - - end subroutine test_cache_load_dump - - - subroutine test_status(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(toml_table), pointer :: ptr - type(dependency_tree_t) :: deps - - table = toml_table() - call add_table(table, "dep1", ptr) - call set_value(ptr, "version", "1.1.0") - call set_value(ptr, "proj-dir", "fpm-tmp1-dir") - call add_table(table, "dep2", ptr) - call set_value(ptr, "version", "0.55.3") - call set_value(ptr, "proj-dir", "fpm-tmp2-dir") - call set_value(ptr, "git", "https://github.com/fortran-lang/dep2") - - call new_dependency_tree(deps) - call deps%load(table, error) - if (allocated(error)) return - - if (deps%finished()) then - call test_failed(error, "Newly initialized dependency tree cannot be reolved") - return - end if - - end subroutine test_status - - - subroutine test_add_dependencies(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(toml_table), pointer :: ptr - type(mock_dependency_tree_t) :: deps - type(dependency_config_t), allocatable :: nodes(:) - - table = toml_table() - call add_table(table, "sub1", ptr) - call set_value(ptr, "path", "external") - call add_table(table, "lin2", ptr) - call set_value(ptr, "git", "https://github.com/fortran-lang/lin2") - call add_table(table, "pkg3", ptr) - call set_value(ptr, "git", "https://gitlab.com/fortran-lang/pkg3") - call set_value(ptr, "rev", "c0ffee") - call add_table(table, "proj4", ptr) - call set_value(ptr, "path", "vendor") - - call new_dependencies(nodes, table, error=error) - if (allocated(error)) return - - call new_dependencies(nodes, table, root='.', error=error) - if (allocated(error)) return - - call new_dependency_tree(deps%dependency_tree_t) - call deps%add(nodes, error) - if (allocated(error)) return - - if (deps%finished()) then - call test_failed(error, "Newly added nodes cannot be already resolved") - return - end if - - if (deps%ndep /= 4) then - call test_failed(error, "Expected for dependencies in tree") - return - end if - - call deps%resolve(".", error) - if (allocated(error)) return - - if (.not.deps%finished()) then - call test_failed(error, "Mocked dependency tree must resolve in one step") - return - end if - - end subroutine test_add_dependencies - - - !> Resolve a single dependency node - subroutine resolve_dependency_once(self, dependency, root, error) - !> Mock instance of the dependency tree - class(mock_dependency_tree_t), intent(inout) :: self - !> Dependency configuration to add - type(dependency_node_t), intent(inout) :: dependency - !> Current installation prefix - character(len=*), intent(in) :: root - !> Error handling - type(error_t), allocatable, intent(out) :: error - - if (dependency%done) then - call test_failed(error, "Should only visit this node once") - return - end if - dependency%done = .true. - - end subroutine resolve_dependency_once - + !> Collect all exported unit tests + subroutine collect_package_dependencies(testsuite) + + !> Collection of tests + type(unittest_t), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + & new_unittest("cache-load-dump", test_cache_load_dump), & + & new_unittest("cache-dump-load", test_cache_dump_load), & + & new_unittest("status-after-load", test_status), & + & new_unittest("add-dependencies", test_add_dependencies)] + + end subroutine collect_package_dependencies + + !> Round trip of the dependency cache from a dependency tree to a TOML document + !> to a dependency tree + subroutine test_cache_dump_load(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(dependency_tree_t) :: deps + type(dependency_config_t) :: dep + integer :: unit + + call new_dependency_tree(deps) + call resize(deps%dep, 5) + deps%ndep = 3 + dep%name = "dep1" + dep%path = "fpm-tmp1-dir" + call new_dependency_node(deps%dep(1), dep, proj_dir=dep%path) + dep%name = "dep2" + dep%path = "fpm-tmp2-dir" + call new_dependency_node(deps%dep(2), dep, proj_dir=dep%path) + dep%name = "dep3" + dep%path = "fpm-tmp3-dir" + call new_dependency_node(deps%dep(3), dep, proj_dir=dep%path) + + open (newunit=unit, status='scratch') + call deps%dump(unit, error) + if (.not. allocated(error)) then + rewind (unit) + + call new_dependency_tree(deps) + call resize(deps%dep, 2) + call deps%load(unit, error) + close (unit) + end if + if (allocated(error)) return + + if (deps%ndep /= 3) then + call test_failed(error, "Expected three dependencies in loaded cache") + return + end if + + end subroutine test_cache_dump_load + + !> Round trip of the dependency cache from a TOML data structure to + !> a dependency tree to a TOML data structure + subroutine test_cache_load_dump(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_table), pointer :: ptr + type(toml_key), allocatable :: list(:) + type(dependency_tree_t) :: deps + + table = toml_table() + call add_table(table, "dep1", ptr) + call set_value(ptr, "version", "1.1.0") + call set_value(ptr, "proj-dir", "fpm-tmp1-dir") + call add_table(table, "dep2", ptr) + call set_value(ptr, "version", "0.55.3") + call set_value(ptr, "proj-dir", "fpm-tmp2-dir") + call set_value(ptr, "git", "https://github.com/fortran-lang/dep2") + call add_table(table, "dep3", ptr) + call set_value(ptr, "version", "20.1.15") + call set_value(ptr, "proj-dir", "fpm-tmp3-dir") + call set_value(ptr, "git", "https://gitlab.com/fortran-lang/dep3") + call set_value(ptr, "rev", "c0ffee") + call add_table(table, "dep4", ptr) + call set_value(ptr, "proj-dir", "fpm-tmp4-dir") + + call new_dependency_tree(deps) + call deps%load(table, error) + if (allocated(error)) return + + if (deps%ndep /= 4) then + call test_failed(error, "Expected four dependencies in loaded cache") + return + end if + + call table%destroy + table = toml_table() + + call deps%dump(table, error) + if (allocated(error)) return + + call table%get_keys(list) + + if (size(list) /= 4) then + call test_failed(error, "Expected four dependencies in dumped cache") + return + end if + + end subroutine test_cache_load_dump + + subroutine test_status(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_table), pointer :: ptr + type(dependency_tree_t) :: deps + + table = toml_table() + call add_table(table, "dep1", ptr) + call set_value(ptr, "version", "1.1.0") + call set_value(ptr, "proj-dir", "fpm-tmp1-dir") + call add_table(table, "dep2", ptr) + call set_value(ptr, "version", "0.55.3") + call set_value(ptr, "proj-dir", "fpm-tmp2-dir") + call set_value(ptr, "git", "https://github.com/fortran-lang/dep2") + + call new_dependency_tree(deps) + call deps%load(table, error) + if (allocated(error)) return + + if (deps%finished()) then + call test_failed(error, "Newly initialized dependency tree cannot be reolved") + return + end if + + end subroutine test_status + + subroutine test_add_dependencies(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_table), pointer :: ptr + type(mock_dependency_tree_t) :: deps + type(dependency_config_t), allocatable :: nodes(:) + + table = toml_table() + call add_table(table, "sub1", ptr) + call set_value(ptr, "path", "external") + call add_table(table, "lin2", ptr) + call set_value(ptr, "git", "https://github.com/fortran-lang/lin2") + call add_table(table, "pkg3", ptr) + call set_value(ptr, "git", "https://gitlab.com/fortran-lang/pkg3") + call set_value(ptr, "rev", "c0ffee") + call add_table(table, "proj4", ptr) + call set_value(ptr, "path", "vendor") + + call new_dependencies(nodes, table, error=error) + if (allocated(error)) return + + call new_dependencies(nodes, table, root='.', error=error) + if (allocated(error)) return + + call new_dependency_tree(deps%dependency_tree_t) + call deps%add(nodes, error) + if (allocated(error)) return + + if (deps%finished()) then + call test_failed(error, "Newly added nodes cannot be already resolved") + return + end if + + if (deps%ndep /= 4) then + call test_failed(error, "Expected for dependencies in tree") + return + end if + + call deps%resolve(".", error) + if (allocated(error)) return + + if (.not. deps%finished()) then + call test_failed(error, "Mocked dependency tree must resolve in one step") + return + end if + + end subroutine test_add_dependencies + + !> Resolve a single dependency node + subroutine resolve_dependency_once(self, dependency, root, error) + !> Mock instance of the dependency tree + class(mock_dependency_tree_t), intent(inout) :: self + !> Dependency configuration to add + type(dependency_node_t), intent(inout) :: dependency + !> Current installation prefix + character(len=*), intent(in) :: root + !> Error handling + type(error_t), allocatable, intent(out) :: error + + if (dependency%done) then + call test_failed(error, "Should only visit this node once") + return + end if + dependency%done = .true. + + end subroutine resolve_dependency_once end module test_package_dependencies diff --git a/test/fpm_test/test_source_parsing.f90 b/test/fpm_test/test_source_parsing.f90 index 73e7e6b162..26f5301614 100644 --- a/test/fpm_test/test_source_parsing.f90 +++ b/test/fpm_test/test_source_parsing.f90 @@ -1,950 +1,932 @@ !> Define tests for the `fpm_sources` module (parsing routines) module test_source_parsing - use testsuite, only : new_unittest, unittest_t, error_t, test_failed - use fpm_filesystem, only: get_temp_filename - use fpm_source_parsing, only: parse_f_source, parse_c_source - use fpm_model, only: srcfile_t, FPM_UNIT_PROGRAM, FPM_UNIT_MODULE, & - FPM_UNIT_SUBMODULE, FPM_UNIT_SUBPROGRAM, FPM_UNIT_CSOURCE, & - FPM_UNIT_CPPSOURCE - use fpm_strings, only: operator(.in.) - implicit none - private - - public :: collect_source_parsing + use testsuite, only: new_unittest, unittest_t, error_t, test_failed + use fpm_filesystem, only: get_temp_filename + use fpm_source_parsing, only: parse_f_source, parse_c_source + use fpm_model, only: srcfile_t, FPM_UNIT_PROGRAM, FPM_UNIT_MODULE, & + FPM_UNIT_SUBMODULE, FPM_UNIT_SUBPROGRAM, FPM_UNIT_CSOURCE, & + FPM_UNIT_CPPSOURCE + use fpm_strings, only: operator(.in.) + implicit none + private + + public :: collect_source_parsing contains + !> Collect all exported unit tests + subroutine collect_source_parsing(testsuite) + + !> Collection of tests + type(unittest_t), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + & new_unittest("modules-used", test_modules_used), & + & new_unittest("intrinsic-modules-used", test_intrinsic_modules_used), & + & new_unittest("include-stmt", test_include_stmt), & + & new_unittest("program", test_program), & + & new_unittest("module", test_module), & + & new_unittest("module-with-subprogram", test_module_with_subprogram), & + & new_unittest("module-with-c-api", test_module_with_c_api), & + & new_unittest("module-end-stmt", test_module_end_stmt), & + & new_unittest("program-with-module", test_program_with_module), & + & new_unittest("submodule", test_submodule), & + & new_unittest("submodule-ancestor", test_submodule_ancestor), & + & new_unittest("subprogram", test_subprogram), & + & new_unittest("csource", test_csource), & + & new_unittest("invalid-use-stmt", & + test_invalid_use_stmt, should_fail=.true.), & + & new_unittest("invalid-include-stmt", & + test_invalid_include_stmt, should_fail=.true.), & + & new_unittest("invalid-module", & + test_invalid_module, should_fail=.true.), & + & new_unittest("invalid-submodule", & + test_invalid_submodule, should_fail=.true.) & + ] + + end subroutine collect_source_parsing + + !> Check parsing of module 'USE' statements + subroutine test_modules_used(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source + + allocate (temp_file, source=get_temp_filename()) + + open (file=temp_file, newunit=unit) + write (unit, '(a)') & + & 'program test', & + & ' use module_one', & + & ' use :: module_two', & + & ' use module_three, only: a, b, c', & + & ' use :: module_four, only: a => b', & + & '! use module_not_used', & + & ' implicit none', & + & 'end program test' + close (unit) + + f_source = parse_f_source(temp_file, error) + if (allocated(error)) then + return + end if + + if (f_source%unit_type /= FPM_UNIT_PROGRAM) then + call test_failed(error, 'Wrong unit type detected - expecting FPM_UNIT_PROGRAM') + return + end if + + if (size(f_source%modules_provided) /= 0) then + call test_failed(error, 'Unexpected modules_provided - expecting zero') + return + end if + + if (size(f_source%modules_used) /= 4) then + call test_failed(error, 'Incorrect number of modules_used - expecting four') + return + end if + + if (.not. ('module_one'.in.f_source%modules_used)) then + call test_failed(error, 'Missing module in modules_used') + return + end if + + if (.not. ('module_two'.in.f_source%modules_used)) then + call test_failed(error, 'Missing module in modules_used') + return + end if + + if (.not. ('module_three'.in.f_source%modules_used)) then + call test_failed(error, 'Missing module in modules_used') + return + end if + + if (.not. ('module_four'.in.f_source%modules_used)) then + call test_failed(error, 'Missing module in modules_used') + return + end if + + if ('module_not_used'.in.f_source%modules_used) then + call test_failed(error, 'Commented module found in modules_used') + return + end if + + end subroutine test_modules_used + + !> Check that intrinsic modules are properly ignore + subroutine test_intrinsic_modules_used(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source + + allocate (temp_file, source=get_temp_filename()) + + open (file=temp_file, newunit=unit) + write (unit, '(a)') & + & 'program test', & + & ' use iso_c_binding', & + & ' use iso_fortran_env', & + & ' use ieee_arithmetic', & + & ' use ieee_exceptions', & + & ' use ieee_features', & + & ' implicit none', & + & 'end program test' + close (unit) + + f_source = parse_f_source(temp_file, error) + if (allocated(error)) then + return + end if + + if (size(f_source%modules_provided) /= 0) then + call test_failed(error, 'Unexpected modules_provided - expecting zero') + return + end if + + if (size(f_source%modules_used) /= 0) then + call test_failed(error, 'Incorrect number of modules_used - expecting zero') + return + end if + + if ('iso_c_binding'.in.f_source%modules_used) then + call test_failed(error, 'Intrinsic module found in modules_used') + return + end if + + if ('iso_fortran_env'.in.f_source%modules_used) then + call test_failed(error, 'Intrinsic module found in modules_used') + return + end if + + if ('ieee_arithmetic'.in.f_source%modules_used) then + call test_failed(error, 'Intrinsic module found in modules_used') + return + end if + + if ('ieee_exceptions'.in.f_source%modules_used) then + call test_failed(error, 'Intrinsic module found in modules_used') + return + end if + + if ('ieee_features'.in.f_source%modules_used) then + call test_failed(error, 'Intrinsic module found in modules_used') + return + end if + + end subroutine test_intrinsic_modules_used + + !> Check parsing of include statements + subroutine test_include_stmt(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source + + allocate (temp_file, source=get_temp_filename()) + + open (file=temp_file, newunit=unit) + write (unit, '(a)') & + & 'program test', & + & ' implicit none', & + & ' include "included_file.f90"', & + & ' character(*) :: include_comments', & + & ' include_comments = "some comments"', & + & ' contains ', & + & ' include"second_include.f90"', & + & 'end program test' + close (unit) + + f_source = parse_f_source(temp_file, error) + if (allocated(error)) then + return + end if + + if (size(f_source%modules_provided) /= 0) then + call test_failed(error, 'Unexpected modules_provided - expecting zero') + return + end if + + if (size(f_source%modules_used) /= 0) then + call test_failed(error, 'Incorrect number of modules_used - expecting zero') + return + end if + + if (size(f_source%include_dependencies) /= 2) then + call test_failed(error, 'Incorrect number of include_dependencies - expecting two') + return + end if + + if (.not. ('included_file.f90'.in.f_source%include_dependencies)) then + call test_failed(error, 'Missing include file in include_dependencies') + return + end if + + if (.not. ('second_include.f90'.in.f_source%include_dependencies)) then + call test_failed(error, 'Missing include file in include_dependencies') + return + end if + + end subroutine test_include_stmt + + !> Try to parse a simple fortran program + subroutine test_program(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source + + allocate (temp_file, source=get_temp_filename()) + + open (file=temp_file, newunit=unit) + write (unit, '(a)') & + & 'program my_program', & + & 'use module_one', & + & 'implicit none', & + & 'integer :: module', & + & 'module = 1', & + & 'module= 1', & + & 'module =1', & + & 'module (i) =1', & + & 'contains', & + & 'subroutine f()', & + & 'end subroutine f', & + & 'end program my_program' + close (unit) + + f_source = parse_f_source(temp_file, error) + if (allocated(error)) then + return + end if + + if (f_source%unit_type /= FPM_UNIT_PROGRAM) then + call test_failed(error, 'Wrong unit type detected - expecting FPM_UNIT_PROGRAM') + return + end if + + if (size(f_source%modules_provided) /= 0) then + call test_failed(error, 'Unexpected modules_provided - expecting zero') + return + end if + + if (size(f_source%modules_used) /= 1) then + call test_failed(error, 'Incorrect number of modules_used - expecting one') + return + end if + + if (.not. ('module_one'.in.f_source%modules_used)) then + call test_failed(error, 'Missing module in modules_used') + return + end if + + end subroutine test_program + + !> Try to parse fortran module + subroutine test_module(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source + + allocate (temp_file, source=get_temp_filename()) + + open (file=temp_file, newunit=unit) + write (unit, '(a)') & + & '#define preprocesor_line_outside', & + & 'module my_mod ! A trailing comment', & + & 'use module_one', & + & 'interface', & + & ' module subroutine f() bind(C)', & + & 'end interface', & + & 'integer :: program', & + & 'program = 1', & + & 'program= 1', & + & 'program =1', & + & 'program (i) =1', & + & 'contains', & + & 'module subroutine&', & + & ' e()', & + & ' integer, parameter :: c = 1', & + & ' integer :: & ', & + & ' bind(c)', & + & ' bind(c) = 1', & + & 'end subroutine e', & + & 'module subroutine f()', & + & 'end subroutine f', & + & 'module function g()', & + & 'end function g', & + & 'module integer function h()', & + & 'end function h', & + & 'module real function i()', & + & 'string = " &', & + & 'module name"', & + & 'string = " &', & + & 'module name !"', & + & 'end function i', & + & 'end module test', & + & '! A trailing comment outside of module' + close (unit) + + f_source = parse_f_source(temp_file, error) + if (allocated(error)) then + return + end if + + if (f_source%unit_type /= FPM_UNIT_MODULE) then + call test_failed(error, 'Wrong unit type detected - expecting FPM_UNIT_MODULE') + return + end if + + if (size(f_source%modules_provided) /= 1) then + call test_failed(error, 'Unexpected modules_provided - expecting one') + return + end if + + if (size(f_source%modules_used) /= 1) then + call test_failed(error, 'Incorrect number of modules_used - expecting one') + return + end if + + if (.not. ('my_mod'.in.f_source%modules_provided)) then + call test_failed(error, 'Missing module in modules_provided') + return + end if + + if (.not. ('module_one'.in.f_source%modules_used)) then + call test_failed(error, 'Missing module in modules_used') + return + end if + + end subroutine test_module + + !> Try to parse fortran module with subroutine outside of module + !> (this should be detected as FPM_UNIT_SUBPROGRAM not FPM_UNIT_MODULE) + subroutine test_module_with_subprogram(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source + + allocate (temp_file, source=get_temp_filename()) + + open (file=temp_file, newunit=unit) + write (unit, '(a)') & + & 'module my_mod', & + & 'contains', & + & 'module subroutine f()', & + & 'end subroutine f', & + & 'module function g()', & + & 'end function g', & + & 'end module test',& + & 'function h()', & + & 'end function' + close (unit) + + f_source = parse_f_source(temp_file, error) + if (allocated(error)) then + return + end if + + if (f_source%unit_type /= FPM_UNIT_SUBPROGRAM) then + call test_failed(error, 'Wrong unit type detected - expecting FPM_UNIT_SUBPROGRAM') + return + end if + + if (size(f_source%modules_provided) /= 1) then + call test_failed(error, 'Unexpected modules_provided - expecting one') + return + end if + + if (size(f_source%modules_used) /= 0) then + call test_failed(error, 'Incorrect number of modules_used - expecting zero') + return + end if + + end subroutine test_module_with_subprogram + + !> Try to parse fortran modules without the full end module statement + !> This should be detected as FPM_UNIT_SUBPROGRAM not FPM_UNIT_MODULE + !> because we cannot guarantee if non-module subprograms are present + subroutine test_module_end_stmt(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source + + allocate (temp_file, source=get_temp_filename()) + + open (file=temp_file, newunit=unit) + write (unit, '(a)') & + & 'module mod1', & + & 'contains', & + & 'module subroutine f()', & + & 'end subroutine f', & + & 'module function g()', & + & 'end function g', & + & 'end', & + & 'module mod2', & + & 'contains', & + & 'module subroutine f()', & + & 'end subroutine f', & + & 'module function g()', & + & 'end function g', & + & 'end module mod2' + close (unit) + + f_source = parse_f_source(temp_file, error) + if (allocated(error)) then + return + end if + + if (f_source%unit_type /= FPM_UNIT_SUBPROGRAM) then + call test_failed(error, 'Wrong unit type detected - expecting FPM_UNIT_SUBPROGRAM') + return + end if + + if (size(f_source%modules_provided) /= 2) then + call test_failed(error, 'Unexpected modules_provided - expecting two') + return + end if + + if (size(f_source%modules_used) /= 0) then + call test_failed(error, 'Incorrect number of modules_used - expecting zero') + return + end if + + if (.not. ('mod1'.in.f_source%modules_provided)) then + call test_failed(error, 'Missing module in modules_provided') + return + end if + + if (.not. ('mod2'.in.f_source%modules_provided)) then + call test_failed(error, 'Missing module in modules_provided') + return + end if + + end subroutine test_module_end_stmt + + !> Try to parse fortran module with exported C-API via bind(c) + !> (this should be detected as FPM_UNIT_SUBPROGRAM not FPM_UNIT_MODULE to prevent pruning) + subroutine test_module_with_c_api(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source + + allocate (temp_file, source=get_temp_filename()) + + open (file=temp_file, newunit=unit) + write (unit, '(a)') & + & 'module my_mod', & + & 'contains', & + & 'subroutine f() &', & + & ' bind(C)', & + & 'end subroutine f', & + & 'module function g()', & + & 'end function g', & + & 'end module test' + close (unit) + + f_source = parse_f_source(temp_file, error) + if (allocated(error)) then + return + end if + + if (f_source%unit_type /= FPM_UNIT_SUBPROGRAM) then + call test_failed(error, 'Wrong unit type detected - expecting FPM_UNIT_SUBPROGRAM') + return + end if + + if (size(f_source%modules_provided) /= 1) then + call test_failed(error, 'Unexpected modules_provided - expecting one') + return + end if + + if (size(f_source%modules_used) /= 0) then + call test_failed(error, 'Incorrect number of modules_used - expecting zero') + return + end if + + end subroutine test_module_with_c_api + + !> Try to parse combined fortran module and program + !> Check that parsed unit type is FPM_UNIT_PROGRAM + subroutine test_program_with_module(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source + + allocate (temp_file, source=get_temp_filename()) + + open (file=temp_file, newunit=unit) + write (unit, '(a)') & + & 'module my_mod', & + & 'use module_one', & + & 'interface', & + & ' module subroutine f()', & + & 'end interface', & + & 'contains', & + & 'module procedure f()', & + & 'end procedure f', & + & 'end module test', & + & 'program my_program', & + & 'use my_mod', & + & 'implicit none', & + & 'end my_program' + close (unit) + + f_source = parse_f_source(temp_file, error) + if (allocated(error)) then + return + end if + + if (f_source%unit_type /= FPM_UNIT_PROGRAM) then + call test_failed(error, 'Wrong unit type detected - expecting FPM_UNIT_PROGRAM') + return + end if + + if (size(f_source%modules_provided) /= 1) then + call test_failed(error, 'Unexpected modules_provided - expecting one') + return + end if + + if (.not. ('my_mod'.in.f_source%modules_provided)) then + call test_failed(error, 'Missing module in modules_provided') + return + end if + + if (.not. ('module_one'.in.f_source%modules_used)) then + call test_failed(error, 'Missing module in modules_used') + return + end if + + if (.not. ('my_mod'.in.f_source%modules_used)) then + call test_failed(error, 'Missing module in modules_used') + return + end if + + end subroutine test_program_with_module + + !> Try to parse fortran submodule for ancestry + subroutine test_submodule(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source + + allocate (temp_file, source=get_temp_filename()) + + open (file=temp_file, newunit=unit) + write (unit, '(a)') & + & 'submodule (parent) child', & + & 'use module_one', & + & 'end submodule test' + close (unit) + + f_source = parse_f_source(temp_file, error) + if (allocated(error)) then + return + end if + + if (f_source%unit_type /= FPM_UNIT_SUBMODULE) then + call test_failed(error, 'Wrong unit type detected - expecting FPM_UNIT_SUBMODULE') + return + end if + + if (size(f_source%modules_provided) /= 1) then + call test_failed(error, 'Unexpected modules_provided - expecting one') + return + end if + + if (size(f_source%modules_used) /= 2) then + call test_failed(error, 'Incorrect number of modules_used - expecting two') + return + end if + + if (.not. ('child'.in.f_source%modules_provided)) then + call test_failed(error, 'Missing module in modules_provided') + return + end if + + if (.not. ('module_one'.in.f_source%modules_used)) then + call test_failed(error, 'Missing module in modules_used') + return + end if + + if (.not. ('parent'.in.f_source%modules_used)) then + call test_failed(error, 'Missing parent module in modules_used') + return + end if + + end subroutine test_submodule + + !> Try to parse fortran multi-level submodule for ancestry + subroutine test_submodule_ancestor(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source + + allocate (temp_file, source=get_temp_filename()) + + open (file=temp_file, newunit=unit) + write (unit, '(a)') & + & 'submodule (ancestor:parent) child', & + & 'use module_one', & + & 'end submodule test' + close (unit) + + f_source = parse_f_source(temp_file, error) + if (allocated(error)) then + return + end if + + if (f_source%unit_type /= FPM_UNIT_SUBMODULE) then + call test_failed(error, 'Wrong unit type detected - expecting FPM_UNIT_SUBMODULE') + return + end if + + if (size(f_source%modules_provided) /= 1) then + call test_failed(error, 'Unexpected modules_provided - expecting one') + return + end if + + if (size(f_source%modules_used) /= 2) then + call test_failed(error, 'Incorrect number of modules_used - expecting two') + return + end if + + if (.not. ('child'.in.f_source%modules_provided)) then + call test_failed(error, 'Missing module in modules_provided') + return + end if + + if (.not. ('module_one'.in.f_source%modules_used)) then + call test_failed(error, 'Missing module in modules_used') + return + end if + + if (.not. ('parent'.in.f_source%modules_used)) then + call test_failed(error, 'Missing parent module in modules_used') + return + end if + + end subroutine test_submodule_ancestor + + !> Try to parse standard fortran sub-program (non-module) source + subroutine test_subprogram(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source + + allocate (temp_file, source=get_temp_filename()) + + open (file=temp_file, newunit=unit) + write (unit, '(a)') & + & 'subroutine my_sub(a)', & + & ' use module_one', & + & ' integer, intent(in) :: a', & + & 'end subroutine my_sub' + close (unit) + + f_source = parse_f_source(temp_file, error) + if (allocated(error)) then + return + end if + + if (f_source%unit_type /= FPM_UNIT_SUBPROGRAM) then + call test_failed(error, 'Wrong unit type detected - expecting FPM_UNIT_SUBPROGRAM') + return + end if + + if (size(f_source%modules_provided) /= 0) then + call test_failed(error, 'Unexpected modules_provided - expecting zero') + return + end if + + if (size(f_source%modules_used) /= 1) then + call test_failed(error, 'Incorrect number of modules_used - expecting one') + return + end if + + if (.not. ('module_one'.in.f_source%modules_used)) then + call test_failed(error, 'Missing module in modules_used') + return + end if + + end subroutine test_subprogram + + !> Try to parse standard c source for includes + subroutine test_csource(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source + + allocate (temp_file, source=get_temp_filename()) + temp_file = temp_file//'.c' + + open (file=temp_file, newunit=unit) + write (unit, '(a)') & + & '#include "proto.h"', & + & 'void c_func(int a) {', & + & ' #include "function_body.c"', & + & ' return', & + & '}' + close (unit) + + f_source = parse_c_source(temp_file, error) + if (allocated(error)) then + return + end if + + if (f_source%unit_type /= FPM_UNIT_CSOURCE) then + call test_failed(error, 'Wrong unit type detected - expecting FPM_UNIT_CSOURCE') + return + end if + + if (size(f_source%modules_provided) /= 0) then + call test_failed(error, 'Unexpected modules_provided - expecting zero') + return + end if + + if (size(f_source%modules_used) /= 0) then + call test_failed(error, 'Incorrect number of modules_used - expecting zero') + return + end if + + if (size(f_source%include_dependencies) /= 2) then + call test_failed(error, 'Incorrect number of include_dependencies - expecting two') + return + end if + + if (allocated(f_source%link_libraries)) then + call test_failed(error, 'Unexpected link_libraries - expecting unallocated') + return + end if + + if (size(f_source%parent_modules) /= 0) then + call test_failed(error, 'Incorrect number of parent_modules - expecting zero') + return + end if + + if (.not. ('proto.h'.in.f_source%include_dependencies)) then + call test_failed(error, 'Missing file in include_dependencies') + return + end if + + if (.not. ('function_body.c'.in.f_source%include_dependencies)) then + call test_failed(error, 'Missing file in include_dependencies') + return + end if + + end subroutine test_csource + + !> Try to parse fortran program with invalid use statement + subroutine test_invalid_use_stmt(error) - !> Collect all exported unit tests - subroutine collect_source_parsing(testsuite) - - !> Collection of tests - type(unittest_t), allocatable, intent(out) :: testsuite(:) - - testsuite = [ & - & new_unittest("modules-used", test_modules_used), & - & new_unittest("intrinsic-modules-used", test_intrinsic_modules_used), & - & new_unittest("include-stmt", test_include_stmt), & - & new_unittest("program", test_program), & - & new_unittest("module", test_module), & - & new_unittest("module-with-subprogram", test_module_with_subprogram), & - & new_unittest("module-with-c-api", test_module_with_c_api), & - & new_unittest("module-end-stmt", test_module_end_stmt), & - & new_unittest("program-with-module", test_program_with_module), & - & new_unittest("submodule", test_submodule), & - & new_unittest("submodule-ancestor", test_submodule_ancestor), & - & new_unittest("subprogram", test_subprogram), & - & new_unittest("csource", test_csource), & - & new_unittest("invalid-use-stmt", & - test_invalid_use_stmt, should_fail=.true.), & - & new_unittest("invalid-include-stmt", & - test_invalid_include_stmt, should_fail=.true.), & - & new_unittest("invalid-module", & - test_invalid_module, should_fail=.true.), & - & new_unittest("invalid-submodule", & - test_invalid_submodule, should_fail=.true.) & - ] - - end subroutine collect_source_parsing - - - !> Check parsing of module 'USE' statements - subroutine test_modules_used(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'program test', & - & ' use module_one', & - & ' use :: module_two', & - & ' use module_three, only: a, b, c', & - & ' use :: module_four, only: a => b', & - & '! use module_not_used', & - & ' implicit none', & - & 'end program test' - close(unit) - - f_source = parse_f_source(temp_file,error) - if (allocated(error)) then - return - end if - - if (f_source%unit_type /= FPM_UNIT_PROGRAM) then - call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_PROGRAM') - return - end if - - if (size(f_source%modules_provided) /= 0) then - call test_failed(error,'Unexpected modules_provided - expecting zero') - return - end if - - if (size(f_source%modules_used) /= 4) then - call test_failed(error,'Incorrect number of modules_used - expecting four') - return - end if - - if (.not.('module_one' .in. f_source%modules_used)) then - call test_failed(error,'Missing module in modules_used') - return - end if - - if (.not.('module_two' .in. f_source%modules_used)) then - call test_failed(error,'Missing module in modules_used') - return - end if - - if (.not.('module_three' .in. f_source%modules_used)) then - call test_failed(error,'Missing module in modules_used') - return - end if - - if (.not.('module_four' .in. f_source%modules_used)) then - call test_failed(error,'Missing module in modules_used') - return - end if - - if ('module_not_used' .in. f_source%modules_used) then - call test_failed(error,'Commented module found in modules_used') - return - end if - - end subroutine test_modules_used - - - !> Check that intrinsic modules are properly ignore - subroutine test_intrinsic_modules_used(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'program test', & - & ' use iso_c_binding', & - & ' use iso_fortran_env', & - & ' use ieee_arithmetic', & - & ' use ieee_exceptions', & - & ' use ieee_features', & - & ' implicit none', & - & 'end program test' - close(unit) - - f_source = parse_f_source(temp_file,error) - if (allocated(error)) then - return - end if - - if (size(f_source%modules_provided) /= 0) then - call test_failed(error,'Unexpected modules_provided - expecting zero') - return - end if - - if (size(f_source%modules_used) /= 0) then - call test_failed(error,'Incorrect number of modules_used - expecting zero') - return - end if - - if ('iso_c_binding' .in. f_source%modules_used) then - call test_failed(error,'Intrinsic module found in modules_used') - return - end if - - if ('iso_fortran_env' .in. f_source%modules_used) then - call test_failed(error,'Intrinsic module found in modules_used') - return - end if - - if ('ieee_arithmetic' .in. f_source%modules_used) then - call test_failed(error,'Intrinsic module found in modules_used') - return - end if - - if ('ieee_exceptions' .in. f_source%modules_used) then - call test_failed(error,'Intrinsic module found in modules_used') - return - end if - - if ('ieee_features' .in. f_source%modules_used) then - call test_failed(error,'Intrinsic module found in modules_used') - return - end if - - end subroutine test_intrinsic_modules_used - - - !> Check parsing of include statements - subroutine test_include_stmt(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'program test', & - & ' implicit none', & - & ' include "included_file.f90"', & - & ' character(*) :: include_comments', & - & ' include_comments = "some comments"', & - & ' contains ', & - & ' include"second_include.f90"', & - & 'end program test' - close(unit) - - f_source = parse_f_source(temp_file,error) - if (allocated(error)) then - return - end if - - if (size(f_source%modules_provided) /= 0) then - call test_failed(error,'Unexpected modules_provided - expecting zero') - return - end if - - if (size(f_source%modules_used) /= 0) then - call test_failed(error,'Incorrect number of modules_used - expecting zero') - return - end if - - if (size(f_source%include_dependencies) /= 2) then - call test_failed(error,'Incorrect number of include_dependencies - expecting two') - return - end if - - if (.not.('included_file.f90' .in. f_source%include_dependencies)) then - call test_failed(error,'Missing include file in include_dependencies') - return - end if - - if (.not.('second_include.f90' .in. f_source%include_dependencies)) then - call test_failed(error,'Missing include file in include_dependencies') - return - end if - - end subroutine test_include_stmt - - !> Try to parse a simple fortran program - subroutine test_program(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'program my_program', & - & 'use module_one', & - & 'implicit none', & - & 'integer :: module', & - & 'module = 1', & - & 'module= 1', & - & 'module =1', & - & 'module (i) =1', & - & 'contains', & - & 'subroutine f()', & - & 'end subroutine f', & - & 'end program my_program' - close(unit) - - f_source = parse_f_source(temp_file,error) - if (allocated(error)) then - return - end if - - if (f_source%unit_type /= FPM_UNIT_PROGRAM) then - call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_PROGRAM') - return - end if - - if (size(f_source%modules_provided) /= 0) then - call test_failed(error,'Unexpected modules_provided - expecting zero') - return - end if - - if (size(f_source%modules_used) /= 1) then - call test_failed(error,'Incorrect number of modules_used - expecting one') - return - end if - - if (.not.('module_one' .in. f_source%modules_used)) then - call test_failed(error,'Missing module in modules_used') - return - end if - - end subroutine test_program - - - !> Try to parse fortran module - subroutine test_module(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & '#define preprocesor_line_outside', & - & 'module my_mod ! A trailing comment', & - & 'use module_one', & - & 'interface', & - & ' module subroutine f() bind(C)', & - & 'end interface', & - & 'integer :: program', & - & 'program = 1', & - & 'program= 1', & - & 'program =1', & - & 'program (i) =1', & - & 'contains', & - & 'module subroutine&', & - & ' e()', & - & ' integer, parameter :: c = 1', & - & ' integer :: & ', & - & ' bind(c)', & - & ' bind(c) = 1', & - & 'end subroutine e', & - & 'module subroutine f()', & - & 'end subroutine f', & - & 'module function g()', & - & 'end function g', & - & 'module integer function h()', & - & 'end function h', & - & 'module real function i()', & - & 'string = " &', & - & 'module name"', & - & 'string = " &', & - & 'module name !"', & - & 'end function i', & - & 'end module test', & - & '! A trailing comment outside of module' - close(unit) - - f_source = parse_f_source(temp_file,error) - if (allocated(error)) then - return - end if - - if (f_source%unit_type /= FPM_UNIT_MODULE) then - call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_MODULE') - return - end if - - if (size(f_source%modules_provided) /= 1) then - call test_failed(error,'Unexpected modules_provided - expecting one') - return - end if - - if (size(f_source%modules_used) /= 1) then - call test_failed(error,'Incorrect number of modules_used - expecting one') - return - end if - - if (.not.('my_mod' .in. f_source%modules_provided)) then - call test_failed(error,'Missing module in modules_provided') - return - end if - - if (.not.('module_one' .in. f_source%modules_used)) then - call test_failed(error,'Missing module in modules_used') - return - end if - - end subroutine test_module - - - !> Try to parse fortran module with subroutine outside of module - !> (this should be detected as FPM_UNIT_SUBPROGRAM not FPM_UNIT_MODULE) - subroutine test_module_with_subprogram(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'module my_mod', & - & 'contains', & - & 'module subroutine f()', & - & 'end subroutine f', & - & 'module function g()', & - & 'end function g', & - & 'end module test',& - & 'function h()', & - & 'end function' - close(unit) - - f_source = parse_f_source(temp_file,error) - if (allocated(error)) then - return - end if - - if (f_source%unit_type /= FPM_UNIT_SUBPROGRAM) then - call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_SUBPROGRAM') - return - end if - - if (size(f_source%modules_provided) /= 1) then - call test_failed(error,'Unexpected modules_provided - expecting one') - return - end if - - if (size(f_source%modules_used) /= 0) then - call test_failed(error,'Incorrect number of modules_used - expecting zero') - return - end if - - end subroutine test_module_with_subprogram - - - !> Try to parse fortran modules without the full end module statement - !> This should be detected as FPM_UNIT_SUBPROGRAM not FPM_UNIT_MODULE - !> because we cannot guarantee if non-module subprograms are present - subroutine test_module_end_stmt(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'module mod1', & - & 'contains', & - & 'module subroutine f()', & - & 'end subroutine f', & - & 'module function g()', & - & 'end function g', & - & 'end', & - & 'module mod2', & - & 'contains', & - & 'module subroutine f()', & - & 'end subroutine f', & - & 'module function g()', & - & 'end function g', & - & 'end module mod2' - close(unit) - - f_source = parse_f_source(temp_file,error) - if (allocated(error)) then - return - end if - - if (f_source%unit_type /= FPM_UNIT_SUBPROGRAM) then - call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_SUBPROGRAM') - return - end if - - if (size(f_source%modules_provided) /= 2) then - call test_failed(error,'Unexpected modules_provided - expecting two') - return - end if - - if (size(f_source%modules_used) /= 0) then - call test_failed(error,'Incorrect number of modules_used - expecting zero') - return - end if - - if (.not.('mod1' .in. f_source%modules_provided)) then - call test_failed(error,'Missing module in modules_provided') - return - end if - - if (.not.('mod2' .in. f_source%modules_provided)) then - call test_failed(error,'Missing module in modules_provided') - return - end if - - end subroutine test_module_end_stmt - - - !> Try to parse fortran module with exported C-API via bind(c) - !> (this should be detected as FPM_UNIT_SUBPROGRAM not FPM_UNIT_MODULE to prevent pruning) - subroutine test_module_with_c_api(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'module my_mod', & - & 'contains', & - & 'subroutine f() &', & - & ' bind(C)', & - & 'end subroutine f', & - & 'module function g()', & - & 'end function g', & - & 'end module test' - close(unit) - - f_source = parse_f_source(temp_file,error) - if (allocated(error)) then - return - end if - - if (f_source%unit_type /= FPM_UNIT_SUBPROGRAM) then - call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_SUBPROGRAM') - return - end if - - if (size(f_source%modules_provided) /= 1) then - call test_failed(error,'Unexpected modules_provided - expecting one') - return - end if - - if (size(f_source%modules_used) /= 0) then - call test_failed(error,'Incorrect number of modules_used - expecting zero') - return - end if - - end subroutine test_module_with_c_api - - - !> Try to parse combined fortran module and program - !> Check that parsed unit type is FPM_UNIT_PROGRAM - subroutine test_program_with_module(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'module my_mod', & - & 'use module_one', & - & 'interface', & - & ' module subroutine f()', & - & 'end interface', & - & 'contains', & - & 'module procedure f()', & - & 'end procedure f', & - & 'end module test', & - & 'program my_program', & - & 'use my_mod', & - & 'implicit none', & - & 'end my_program' - close(unit) - - f_source = parse_f_source(temp_file,error) - if (allocated(error)) then - return - end if - - if (f_source%unit_type /= FPM_UNIT_PROGRAM) then - call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_PROGRAM') - return - end if - - if (size(f_source%modules_provided) /= 1) then - call test_failed(error,'Unexpected modules_provided - expecting one') - return - end if - - if (.not.('my_mod' .in. f_source%modules_provided)) then - call test_failed(error,'Missing module in modules_provided') - return - end if - - if (.not.('module_one' .in. f_source%modules_used)) then - call test_failed(error,'Missing module in modules_used') - return - end if - - if (.not.('my_mod' .in. f_source%modules_used)) then - call test_failed(error,'Missing module in modules_used') - return - end if - - end subroutine test_program_with_module - - - !> Try to parse fortran submodule for ancestry - subroutine test_submodule(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'submodule (parent) child', & - & 'use module_one', & - & 'end submodule test' - close(unit) - - f_source = parse_f_source(temp_file,error) - if (allocated(error)) then - return - end if - - if (f_source%unit_type /= FPM_UNIT_SUBMODULE) then - call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_SUBMODULE') - return - end if - - if (size(f_source%modules_provided) /= 1) then - call test_failed(error,'Unexpected modules_provided - expecting one') - return - end if - - if (size(f_source%modules_used) /= 2) then - call test_failed(error,'Incorrect number of modules_used - expecting two') - return - end if - - if (.not.('child' .in. f_source%modules_provided)) then - call test_failed(error,'Missing module in modules_provided') - return - end if - - if (.not.('module_one' .in. f_source%modules_used)) then - call test_failed(error,'Missing module in modules_used') - return - end if - - if (.not.('parent' .in. f_source%modules_used)) then - call test_failed(error,'Missing parent module in modules_used') - return - end if - - end subroutine test_submodule - - - !> Try to parse fortran multi-level submodule for ancestry - subroutine test_submodule_ancestor(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source + !> Error handling + type(error_t), allocatable, intent(out) :: error - allocate(temp_file, source=get_temp_filename()) + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'submodule (ancestor:parent) child', & - & 'use module_one', & - & 'end submodule test' - close(unit) + allocate (temp_file, source=get_temp_filename()) - f_source = parse_f_source(temp_file,error) - if (allocated(error)) then - return - end if + open (file=temp_file, newunit=unit) + write (unit, '(a)') & + & 'program test', & + & 'use module_one', & + & 'use :: ', & + & 'end program test' + close (unit) - if (f_source%unit_type /= FPM_UNIT_SUBMODULE) then - call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_SUBMODULE') - return - end if + f_source = parse_f_source(temp_file, error) + if (allocated(error)) then + return + end if - if (size(f_source%modules_provided) /= 1) then - call test_failed(error,'Unexpected modules_provided - expecting one') - return - end if + end subroutine test_invalid_use_stmt - if (size(f_source%modules_used) /= 2) then - call test_failed(error,'Incorrect number of modules_used - expecting two') - return - end if + !> Try to parse fortran program with invalid use statement + subroutine test_invalid_include_stmt(error) - if (.not.('child' .in. f_source%modules_provided)) then - call test_failed(error,'Missing module in modules_provided') - return - end if - - if (.not.('module_one' .in. f_source%modules_used)) then - call test_failed(error,'Missing module in modules_used') - return - end if - - if (.not.('parent' .in. f_source%modules_used)) then - call test_failed(error,'Missing parent module in modules_used') - return - end if - - end subroutine test_submodule_ancestor - - - !> Try to parse standard fortran sub-program (non-module) source - subroutine test_subprogram(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'subroutine my_sub(a)', & - & ' use module_one', & - & ' integer, intent(in) :: a', & - & 'end subroutine my_sub' - close(unit) - - f_source = parse_f_source(temp_file,error) - if (allocated(error)) then - return - end if - - if (f_source%unit_type /= FPM_UNIT_SUBPROGRAM) then - call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_SUBPROGRAM') - return - end if - - if (size(f_source%modules_provided) /= 0) then - call test_failed(error,'Unexpected modules_provided - expecting zero') - return - end if - - if (size(f_source%modules_used) /= 1) then - call test_failed(error,'Incorrect number of modules_used - expecting one') - return - end if - - if (.not.('module_one' .in. f_source%modules_used)) then - call test_failed(error,'Missing module in modules_used') - return - end if - - end subroutine test_subprogram - - - !> Try to parse standard c source for includes - subroutine test_csource(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - temp_file = temp_file//'.c' - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & '#include "proto.h"', & - & 'void c_func(int a) {', & - & ' #include "function_body.c"', & - & ' return', & - & '}' - close(unit) - - f_source = parse_c_source(temp_file,error) - if (allocated(error)) then - return - end if + !> Error handling + type(error_t), allocatable, intent(out) :: error - if (f_source%unit_type /= FPM_UNIT_CSOURCE) then - call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_CSOURCE') - return - end if + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source - if (size(f_source%modules_provided) /= 0) then - call test_failed(error,'Unexpected modules_provided - expecting zero') - return - end if + allocate (temp_file, source=get_temp_filename()) - if (size(f_source%modules_used) /= 0) then - call test_failed(error,'Incorrect number of modules_used - expecting zero') - return - end if + open (file=temp_file, newunit=unit) + write (unit, '(a)') & + & 'program test', & + & ' include "', & + & 'end program test' + close (unit) - if (size(f_source%include_dependencies) /= 2) then - call test_failed(error,'Incorrect number of include_dependencies - expecting two') - return - end if + f_source = parse_f_source(temp_file, error) + if (allocated(error)) then + return + end if - if (allocated(f_source%link_libraries)) then - call test_failed(error,'Unexpected link_libraries - expecting unallocated') - return - end if - - if (size(f_source%parent_modules) /= 0) then - call test_failed(error,'Incorrect number of parent_modules - expecting zero') - return - end if + end subroutine test_invalid_include_stmt - if (.not.('proto.h' .in. f_source%include_dependencies)) then - call test_failed(error,'Missing file in include_dependencies') - return - end if + !> Try to parse incorrect fortran module syntax + subroutine test_invalid_module(error) - if (.not.('function_body.c' .in. f_source%include_dependencies)) then - call test_failed(error,'Missing file in include_dependencies') - return - end if + !> Error handling + type(error_t), allocatable, intent(out) :: error - end subroutine test_csource + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source - !> Try to parse fortran program with invalid use statement - subroutine test_invalid_use_stmt(error) + allocate (temp_file, source=get_temp_filename()) - !> Error handling - type(error_t), allocatable, intent(out) :: error + open (file=temp_file, newunit=unit) + write (unit, '(a)') & + & 'module ::my_mod', & + & 'end module test' + close (unit) - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source + f_source = parse_f_source(temp_file, error) + if (allocated(error)) then + return + end if - allocate(temp_file, source=get_temp_filename()) + end subroutine test_invalid_module - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'program test', & - & 'use module_one', & - & 'use :: ', & - & 'end program test' - close(unit) + !> Try to parse incorrect fortran submodule syntax + subroutine test_invalid_submodule(error) - f_source = parse_f_source(temp_file,error) - if (allocated(error)) then - return - end if + !> Error handling + type(error_t), allocatable, intent(out) :: error - end subroutine test_invalid_use_stmt + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source + allocate (temp_file, source=get_temp_filename()) - !> Try to parse fortran program with invalid use statement - subroutine test_invalid_include_stmt(error) + open (file=temp_file, newunit=unit) + write (unit, '(a)') & + & 'submodule :: child', & + & 'end submodule test' + close (unit) - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'program test', & - & ' include "', & - & 'end program test' - close(unit) - - f_source = parse_f_source(temp_file,error) - if (allocated(error)) then - return - end if - - end subroutine test_invalid_include_stmt - - - !> Try to parse incorrect fortran module syntax - subroutine test_invalid_module(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'module ::my_mod', & - & 'end module test' - close(unit) - - f_source = parse_f_source(temp_file,error) - if (allocated(error)) then - return - end if - - end subroutine test_invalid_module - - - !> Try to parse incorrect fortran submodule syntax - subroutine test_invalid_submodule(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'submodule :: child', & - & 'end submodule test' - close(unit) - - f_source = parse_f_source(temp_file,error) - if (allocated(error)) then - return - end if - - write(*,*) '"',f_source%modules_used(1)%s,'"' - - end subroutine test_invalid_submodule + f_source = parse_f_source(temp_file, error) + if (allocated(error)) then + return + end if + write (*, *) '"', f_source%modules_used(1)%s, '"' + end subroutine test_invalid_submodule end module test_source_parsing diff --git a/test/fpm_test/test_toml.f90 b/test/fpm_test/test_toml.f90 index 1ffea1d651..3098df0f89 100644 --- a/test/fpm_test/test_toml.f90 +++ b/test/fpm_test/test_toml.f90 @@ -1,107 +1,101 @@ !> Define tests for the `fpm_toml` modules module test_toml - use testsuite, only : new_unittest, unittest_t, error_t - use fpm_toml - implicit none - private - - public :: collect_toml + use testsuite, only: new_unittest, unittest_t, error_t + use fpm_toml + implicit none + private + public :: collect_toml contains + !> Collect all exported unit tests + subroutine collect_toml(testsuite) - !> Collect all exported unit tests - subroutine collect_toml(testsuite) - - !> Collection of tests - type(unittest_t), allocatable, intent(out) :: testsuite(:) - - testsuite = [ & - & new_unittest("valid-toml", test_valid_toml), & - & new_unittest("invalid-toml", test_invalid_toml, should_fail=.true.), & - & new_unittest("missing-file", test_missing_file, should_fail=.true.)] - - end subroutine collect_toml - - - !> Try to read some unnecessary obscure and convoluted but not invalid package file - subroutine test_valid_toml(error) + !> Collection of tests + type(unittest_t), allocatable, intent(out) :: testsuite(:) - !> Error handling - type(error_t), allocatable, intent(out) :: error + testsuite = [ & + & new_unittest("valid-toml", test_valid_toml), & + & new_unittest("invalid-toml", test_invalid_toml, should_fail=.true.), & + & new_unittest("missing-file", test_missing_file, should_fail=.true.)] - type(toml_table), allocatable :: table - character(len=*), parameter :: manifest = 'fpm-valid-toml.toml' - integer :: unit + end subroutine collect_toml - open(file=manifest, newunit=unit) - write(unit, '(a)') & - & 'name = "example"', & - & '[dependencies.fpm]', & - & 'git = "https://github.com/fortran-lang/fpm"', & - & '[[executable]]', & - & 'name = "example-1" # comment', & - & 'source-dir = "prog"', & - & '[dependencies]', & - & 'toml-f.git = "git@github.com:toml-f/toml-f.git"', & - & '"toml..f" = { path = ".." }', & - & '[["executable"]]', & - & 'name = "example-2"', & - & 'source-dir = "prog"', & - & '[executable.dependencies]', & - & '[''library'']', & - & 'source-dir = """', & - & 'lib""" # comment' - close(unit) + !> Try to read some unnecessary obscure and convoluted but not invalid package file + subroutine test_valid_toml(error) - call read_package_file(table, manifest, error) + !> Error handling + type(error_t), allocatable, intent(out) :: error - open(file=manifest, newunit=unit) - close(unit, status='delete') + type(toml_table), allocatable :: table + character(len=*), parameter :: manifest = 'fpm-valid-toml.toml' + integer :: unit - end subroutine test_valid_toml + open (file=manifest, newunit=unit) + write (unit, '(a)') & + & 'name = "example"', & + & '[dependencies.fpm]', & + & 'git = "https://github.com/fortran-lang/fpm"', & + & '[[executable]]', & + & 'name = "example-1" # comment', & + & 'source-dir = "prog"', & + & '[dependencies]', & + & 'toml-f.git = "git@github.com:toml-f/toml-f.git"', & + & '"toml..f" = { path = ".." }', & + & '[["executable"]]', & + & 'name = "example-2"', & + & 'source-dir = "prog"', & + & '[executable.dependencies]', & + & '[''library'']', & + & 'source-dir = """', & + & 'lib""" # comment' + close (unit) + call read_package_file(table, manifest, error) - !> Try to read an invalid TOML document - subroutine test_invalid_toml(error) + open (file=manifest, newunit=unit) + close (unit, status='delete') - !> Error handling - type(error_t), allocatable, intent(out) :: error + end subroutine test_valid_toml - type(toml_table), allocatable :: table - character(len=*), parameter :: manifest = 'fpm-invalid-toml.toml' - integer :: unit + !> Try to read an invalid TOML document + subroutine test_invalid_toml(error) - open(file=manifest, newunit=unit) - write(unit, '(a)') & - & '# INVALID TOML DOC', & - & 'name = "example"', & - & 'dependencies.fpm.git = "https://github.com/fortran-lang/fpm"', & - & '[dependencies]', & - & 'toml-f.git = "git@github.com:toml-f/toml-f.git"', & - & '"toml..f" = { path = ".." }' - close(unit) + !> Error handling + type(error_t), allocatable, intent(out) :: error - call read_package_file(table, manifest, error) + type(toml_table), allocatable :: table + character(len=*), parameter :: manifest = 'fpm-invalid-toml.toml' + integer :: unit - open(file=manifest, newunit=unit) - close(unit, status='delete') + open (file=manifest, newunit=unit) + write (unit, '(a)') & + & '# INVALID TOML DOC', & + & 'name = "example"', & + & 'dependencies.fpm.git = "https://github.com/fortran-lang/fpm"', & + & '[dependencies]', & + & 'toml-f.git = "git@github.com:toml-f/toml-f.git"', & + & '"toml..f" = { path = ".." }' + close (unit) - end subroutine test_invalid_toml + call read_package_file(table, manifest, error) + open (file=manifest, newunit=unit) + close (unit, status='delete') - !> Try to read configuration from a non-existing file - subroutine test_missing_file(error) + end subroutine test_invalid_toml - !> Error handling - type(error_t), allocatable, intent(out) :: error + !> Try to read configuration from a non-existing file + subroutine test_missing_file(error) - type(toml_table), allocatable :: table + !> Error handling + type(error_t), allocatable, intent(out) :: error - call read_package_file(table, 'low+chance+of+existing.toml', error) + type(toml_table), allocatable :: table - end subroutine test_missing_file + call read_package_file(table, 'low+chance+of+existing.toml', error) + end subroutine test_missing_file end module test_toml diff --git a/test/fpm_test/test_versioning.f90 b/test/fpm_test/test_versioning.f90 index b309d1382c..41b3f49908 100644 --- a/test/fpm_test/test_versioning.f90 +++ b/test/fpm_test/test_versioning.f90 @@ -1,404 +1,390 @@ !> Test implementation of version data type module test_versioning - use testsuite, only : new_unittest, unittest_t, error_t, test_failed - use fpm_versioning - implicit none - private - - public :: collect_versioning + use testsuite, only: new_unittest, unittest_t, error_t, test_failed + use fpm_versioning + implicit none + private + public :: collect_versioning contains + !> Collect all exported unit tests + subroutine collect_versioning(testsuite) - !> Collect all exported unit tests - subroutine collect_versioning(testsuite) - - !> Collection of tests - type(unittest_t), allocatable, intent(out) :: testsuite(:) - - testsuite = [ & - & new_unittest("valid-version", test_valid_version), & - & new_unittest("valid-equals", test_valid_equals), & - & new_unittest("valid-notequals", test_valid_notequals), & - & new_unittest("valid-compare", test_valid_compare), & - & new_unittest("valid-match", test_valid_match), & - & new_unittest("valid-string", test_valid_string), & - & new_unittest("invalid-empty", test_invalid_empty, should_fail=.true.), & - & new_unittest("invalid-version1", test_invalid_version1, should_fail=.true.), & - & new_unittest("invalid-version2", test_invalid_version2, should_fail=.true.), & - & new_unittest("invalid-version3", test_invalid_version3, should_fail=.true.), & - & new_unittest("invalid-overflow", test_invalid_overflow, should_fail=.true.)] - - end subroutine collect_versioning - - - !> Read valid version strings - subroutine test_valid_version(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(version_t) :: version - - call new_version(version, "8.9.0", error) - if (allocated(error)) return - - call new_version(version, "2020.10.003", error) - - end subroutine test_valid_version - - - !> Compare versions for equality - subroutine test_valid_equals(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(version_t) :: v1, v2 - type(version_t) :: varray(4) - - call new_version(v1, [1, 2, 0]) - call new_version(v2, [1, 2]) - - if (.not. v1 == v2) then - call test_failed(error, "Version comparison failed") - return - end if - - if (.not. v2 == v1) then - call test_failed(error, "Version comparison failed") - return - end if - - call new_version(v1, [0, 9, 0]) - call new_version(v2, [0, 9]) - - if (.not. v1==v2) then - call test_failed(error, "Version comparison failed") - return - end if - - if (.not. v2==v1) then - call test_failed(error, "Version comparison failed") - return - end if - - call new_version(v1, [2020]) - call new_version(v2, [2020, 0]) - - if (.not. v1 == v2) then - call test_failed(error, "Version comparison failed") - return - end if - - if (.not. v2 == v1) then - call test_failed(error, "Version comparison failed") - return - end if - - call new_version(v1, [20, 1]) - call new_version(varray(1), [19]) - call new_version(varray(2), [18, 2]) - call new_version(varray(3), [20, 1]) - call new_version(varray(4), [1, 3, 1]) - - if (.not. any(v1 == varray)) then - call test_failed(error, "Version comparison failed") - return - end if - - end subroutine test_valid_equals - - - !> Compare versions for mismatch - subroutine test_valid_notequals(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(version_t) :: v1, v2 - type(version_t) :: varray(4) - - call new_version(v1, [2020, 3, 1]) - call new_version(v2, [2020, 3]) + !> Collection of tests + type(unittest_t), allocatable, intent(out) :: testsuite(:) - if (.not. v1 /= v2) then - call test_failed(error, "Version comparison failed") - return - end if + testsuite = [ & + & new_unittest("valid-version", test_valid_version), & + & new_unittest("valid-equals", test_valid_equals), & + & new_unittest("valid-notequals", test_valid_notequals), & + & new_unittest("valid-compare", test_valid_compare), & + & new_unittest("valid-match", test_valid_match), & + & new_unittest("valid-string", test_valid_string), & + & new_unittest("invalid-empty", test_invalid_empty, should_fail=.true.), & + & new_unittest("invalid-version1", test_invalid_version1, should_fail=.true.), & + & new_unittest("invalid-version2", test_invalid_version2, should_fail=.true.), & + & new_unittest("invalid-version3", test_invalid_version3, should_fail=.true.), & + & new_unittest("invalid-overflow", test_invalid_overflow, should_fail=.true.)] - if (.not. v2 /= v1) then - call test_failed(error, "Version comparison failed") - return - end if + end subroutine collect_versioning - call new_version(v1, [0, 9, 1]) - call new_version(v2, [0, 9]) + !> Read valid version strings + subroutine test_valid_version(error) - if (.not. v1/=v2) then - call test_failed(error, "Version comparison failed") - return - end if + !> Error handling + type(error_t), allocatable, intent(out) :: error - if (.not. v2/=v1) then - call test_failed(error, "Version comparison failed") - return - end if + type(version_t) :: version - call new_version(v1, [2020]) - call new_version(v2, [0, 2020]) + call new_version(version, "8.9.0", error) + if (allocated(error)) return - if (.not. v2 /= v1) then - call test_failed(error, "Version comparison failed") - return - end if - - if (.not. v1 /= v2) then - call test_failed(error, "Version comparison failed") - return - end if - - call new_version(v1, [20, 1]) - call new_version(varray(1), [19]) - call new_version(varray(2), [18, 2]) - call new_version(varray(3), [18, 1]) - call new_version(varray(4), [1, 3, 1]) + call new_version(version, "2020.10.003", error) - if (.not. any(v1 /= varray)) then - call test_failed(error, "Version comparison failed") - return - end if + end subroutine test_valid_version - end subroutine test_valid_notequals + !> Compare versions for equality + subroutine test_valid_equals(error) + !> Error handling + type(error_t), allocatable, intent(out) :: error - !> Relative comparison of versions - subroutine test_valid_compare(error) + type(version_t) :: v1, v2 + type(version_t) :: varray(4) - !> Error handling - type(error_t), allocatable, intent(out) :: error + call new_version(v1, [1, 2, 0]) + call new_version(v2, [1, 2]) - type(version_t) :: v1, v2 - type(version_t) :: varray(4) + if (.not. v1 == v2) then + call test_failed(error, "Version comparison failed") + return + end if - call new_version(v1, [10]) - call new_version(v2, [1]) + if (.not. v2 == v1) then + call test_failed(error, "Version comparison failed") + return + end if - if (.not. v1 > v2) then - call test_failed(error, "Version comparison failed (gt)") - return - end if + call new_version(v1, [0, 9, 0]) + call new_version(v2, [0, 9]) - if (.not. v1 >= v2) then - call test_failed(error, "Version comparison failed (ge)") - return - end if + if (.not. v1 == v2) then + call test_failed(error, "Version comparison failed") + return + end if - if (.not. v2 < v1) then - call test_failed(error, "Version comparison failed (lt)") - return - end if + if (.not. v2 == v1) then + call test_failed(error, "Version comparison failed") + return + end if - if (.not. v2 <= v1) then - call test_failed(error, "Version comparison failed (le)") - return - end if + call new_version(v1, [2020]) + call new_version(v2, [2020, 0]) - call new_version(v1, [1, 0, 8]) - call new_version(v2, [1, 0]) + if (.not. v1 == v2) then + call test_failed(error, "Version comparison failed") + return + end if - if (.not. v1 > v2) then - call test_failed(error, "Version comparison failed (gt)") - return - end if + if (.not. v2 == v1) then + call test_failed(error, "Version comparison failed") + return + end if - if (.not. v1 >= v2) then - call test_failed(error, "Version comparison failed (ge)") - return - end if + call new_version(v1, [20, 1]) + call new_version(varray(1), [19]) + call new_version(varray(2), [18, 2]) + call new_version(varray(3), [20, 1]) + call new_version(varray(4), [1, 3, 1]) - if (.not. v2 < v1) then - call test_failed(error, "Version comparison failed (lt)") - return - end if + if (.not. any(v1 == varray)) then + call test_failed(error, "Version comparison failed") + return + end if - if (.not. v2 <= v1) then - call test_failed(error, "Version comparison failed (le)") - return - end if + end subroutine test_valid_equals - call new_version(v1, [1, 2]) - call new_version(v2, [1, 2, 0]) + !> Compare versions for mismatch + subroutine test_valid_notequals(error) - if (v1 > v2) then - call test_failed(error, "Version comparison failed (gt)") - return - end if + !> Error handling + type(error_t), allocatable, intent(out) :: error - if (.not. v1 >= v2) then - call test_failed(error, "Version comparison failed (ge)") - return - end if + type(version_t) :: v1, v2 + type(version_t) :: varray(4) - if (v2 < v1) then - call test_failed(error, "Version comparison failed (lt)") - return - end if + call new_version(v1, [2020, 3, 1]) + call new_version(v2, [2020, 3]) - if (.not. v2 <= v1) then - call test_failed(error, "Version comparison failed (le)") - return - end if + if (.not. v1 /= v2) then + call test_failed(error, "Version comparison failed") + return + end if - call new_version(v1, [20, 1]) - call new_version(varray(1), [19]) - call new_version(varray(2), [18, 2]) - call new_version(varray(3), [18, 1]) - call new_version(varray(4), [1, 3, 1]) + if (.not. v2 /= v1) then + call test_failed(error, "Version comparison failed") + return + end if - if (.not. all(v1 > varray)) then - call test_failed(error, "Version comparison failed (gt)") - return - end if + call new_version(v1, [0, 9, 1]) + call new_version(v2, [0, 9]) - end subroutine test_valid_compare + if (.not. v1 /= v2) then + call test_failed(error, "Version comparison failed") + return + end if + if (.not. v2 /= v1) then + call test_failed(error, "Version comparison failed") + return + end if - !> Semantic version matching - subroutine test_valid_match(error) + call new_version(v1, [2020]) + call new_version(v2, [0, 2020]) + + if (.not. v2 /= v1) then + call test_failed(error, "Version comparison failed") + return + end if + + if (.not. v1 /= v2) then + call test_failed(error, "Version comparison failed") + return + end if + + call new_version(v1, [20, 1]) + call new_version(varray(1), [19]) + call new_version(varray(2), [18, 2]) + call new_version(varray(3), [18, 1]) + call new_version(varray(4), [1, 3, 1]) + + if (.not. any(v1 /= varray)) then + call test_failed(error, "Version comparison failed") + return + end if + + end subroutine test_valid_notequals + + !> Relative comparison of versions + subroutine test_valid_compare(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(version_t) :: v1, v2 + type(version_t) :: varray(4) + + call new_version(v1, [10]) + call new_version(v2, [1]) + + if (.not. v1 > v2) then + call test_failed(error, "Version comparison failed (gt)") + return + end if + + if (.not. v1 >= v2) then + call test_failed(error, "Version comparison failed (ge)") + return + end if + + if (.not. v2 < v1) then + call test_failed(error, "Version comparison failed (lt)") + return + end if + + if (.not. v2 <= v1) then + call test_failed(error, "Version comparison failed (le)") + return + end if + + call new_version(v1, [1, 0, 8]) + call new_version(v2, [1, 0]) + + if (.not. v1 > v2) then + call test_failed(error, "Version comparison failed (gt)") + return + end if + + if (.not. v1 >= v2) then + call test_failed(error, "Version comparison failed (ge)") + return + end if + + if (.not. v2 < v1) then + call test_failed(error, "Version comparison failed (lt)") + return + end if + + if (.not. v2 <= v1) then + call test_failed(error, "Version comparison failed (le)") + return + end if + + call new_version(v1, [1, 2]) + call new_version(v2, [1, 2, 0]) + + if (v1 > v2) then + call test_failed(error, "Version comparison failed (gt)") + return + end if - !> Error handling - type(error_t), allocatable, intent(out) :: error + if (.not. v1 >= v2) then + call test_failed(error, "Version comparison failed (ge)") + return + end if - type(version_t) :: v1, v2 + if (v2 < v1) then + call test_failed(error, "Version comparison failed (lt)") + return + end if - call new_version(v1, [1, 1, 0]) - call new_version(v2, [1]) + if (.not. v2 <= v1) then + call test_failed(error, "Version comparison failed (le)") + return + end if - if (.not. (v1 .match. v2)) then - call test_failed(error, "Version comparison failed (match)") - return - end if + call new_version(v1, [20, 1]) + call new_version(varray(1), [19]) + call new_version(varray(2), [18, 2]) + call new_version(varray(3), [18, 1]) + call new_version(varray(4), [1, 3, 1]) - if (v2 .match. v1) then - call test_failed(error, "Version comparison failed (match)") - return - end if + if (.not. all(v1 > varray)) then + call test_failed(error, "Version comparison failed (gt)") + return + end if - call new_version(v1, [0, 5, 8]) - call new_version(v2, [0, 5]) + end subroutine test_valid_compare - if (.not. (v1 .match. v2)) then - call test_failed(error, "Version comparison failed (match)") - return - end if + !> Semantic version matching + subroutine test_valid_match(error) - if (v2 .match. v1) then - call test_failed(error, "Version comparison failed (match)") - return - end if + !> Error handling + type(error_t), allocatable, intent(out) :: error - call new_version(v1, [1, 2]) - call new_version(v2, [1, 2, 0]) + type(version_t) :: v1, v2 - if (.not. (v1 .match. v2)) then - call test_failed(error, "Version comparison failed (match)") - return - end if + call new_version(v1, [1, 1, 0]) + call new_version(v2, [1]) - if (.not. (v2 .match. v1)) then - call test_failed(error, "Version comparison failed (match)") - return - end if + if (.not. (v1.match.v2)) then + call test_failed(error, "Version comparison failed (match)") + return + end if - end subroutine test_valid_match + if (v2.match.v1) then + call test_failed(error, "Version comparison failed (match)") + return + end if + call new_version(v1, [0, 5, 8]) + call new_version(v2, [0, 5]) - !> Test if version string is preserved - subroutine test_valid_string(error) + if (.not. (v1.match.v2)) then + call test_failed(error, "Version comparison failed (match)") + return + end if - !> Error handling - type(error_t), allocatable, intent(out) :: error + if (v2.match.v1) then + call test_failed(error, "Version comparison failed (match)") + return + end if - character(len=*), parameter :: str_in = "20.1.100" - character(len=:), allocatable :: str_out - type(version_t) :: version + call new_version(v1, [1, 2]) + call new_version(v2, [1, 2, 0]) - call new_version(version, str_in, error) - if (allocated(error)) return - call version%to_string(str_out) + if (.not. (v1.match.v2)) then + call test_failed(error, "Version comparison failed (match)") + return + end if - if (str_in /= str_out) then - call test_failed(error, "Expected "//str_in//" but got "//str_out) - end if + if (.not. (v2.match.v1)) then + call test_failed(error, "Version comparison failed (match)") + return + end if - end subroutine test_valid_string + end subroutine test_valid_match + !> Test if version string is preserved + subroutine test_valid_string(error) - !> Empty string does not represent a version - subroutine test_invalid_empty(error) + !> Error handling + type(error_t), allocatable, intent(out) :: error - !> Error handling - type(error_t), allocatable, intent(out) :: error + character(len=*), parameter :: str_in = "20.1.100" + character(len=:), allocatable :: str_out + type(version_t) :: version - type(version_t) :: version + call new_version(version, str_in, error) + if (allocated(error)) return + call version%to_string(str_out) - call new_version(version, "", error) + if (str_in /= str_out) then + call test_failed(error, "Expected "//str_in//" but got "//str_out) + end if - end subroutine test_invalid_empty + end subroutine test_valid_string + !> Empty string does not represent a version + subroutine test_invalid_empty(error) - !> Version is invalid with trailing dots - subroutine test_invalid_version1(error) + !> Error handling + type(error_t), allocatable, intent(out) :: error - !> Error handling - type(error_t), allocatable, intent(out) :: error + type(version_t) :: version - type(version_t) :: version + call new_version(version, "", error) - call new_version(version, "1.", error) + end subroutine test_invalid_empty - end subroutine test_invalid_version1 + !> Version is invalid with trailing dots + subroutine test_invalid_version1(error) + !> Error handling + type(error_t), allocatable, intent(out) :: error - !> Version is invalid with multiple dots - subroutine test_invalid_version2(error) + type(version_t) :: version - !> Error handling - type(error_t), allocatable, intent(out) :: error + call new_version(version, "1.", error) - type(version_t) :: version + end subroutine test_invalid_version1 - call new_version(version, "1..1", error) + !> Version is invalid with multiple dots + subroutine test_invalid_version2(error) - end subroutine test_invalid_version2 + !> Error handling + type(error_t), allocatable, intent(out) :: error + type(version_t) :: version - !> Version is invalid if it is not a version - subroutine test_invalid_version3(error) + call new_version(version, "1..1", error) - !> Error handling - type(error_t), allocatable, intent(out) :: error + end subroutine test_invalid_version2 - type(version_t) :: version + !> Version is invalid if it is not a version + subroutine test_invalid_version3(error) - call new_version(version, "one", error) + !> Error handling + type(error_t), allocatable, intent(out) :: error - end subroutine test_invalid_version3 + type(version_t) :: version + call new_version(version, "one", error) - !> Check if overflows of the internal size constraint are handled gracefully - subroutine test_invalid_overflow(error) + end subroutine test_invalid_version3 - !> Error handling - type(error_t), allocatable, intent(out) :: error + !> Check if overflows of the internal size constraint are handled gracefully + subroutine test_invalid_overflow(error) - type(version_t) :: version + !> Error handling + type(error_t), allocatable, intent(out) :: error - call new_version(version, "0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0", error) + type(version_t) :: version - end subroutine test_invalid_overflow + call new_version(version, "0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0", error) + end subroutine test_invalid_overflow end module test_versioning diff --git a/test/fpm_test/testsuite.f90 b/test/fpm_test/testsuite.f90 index 124d19a5b4..864f048e9e 100644 --- a/test/fpm_test/testsuite.f90 +++ b/test/fpm_test/testsuite.f90 @@ -1,286 +1,271 @@ !> Define some procedures to automate collecting and launching of tests module testsuite - use fpm_error, only : error_t, test_failed => fatal_error - implicit none - private + use fpm_error, only: error_t, test_failed => fatal_error + implicit none + private - public :: run_testsuite, run_selected, new_unittest, new_testsuite, test_failed - public :: select_test, select_suite - public :: check_string - public :: unittest_t, testsuite_t, error_t + public :: run_testsuite, run_selected, new_unittest, new_testsuite, test_failed + public :: select_test, select_suite + public :: check_string + public :: unittest_t, testsuite_t, error_t + abstract interface + !> Entry point for tests + subroutine test_interface(error) + import :: error_t - abstract interface - !> Entry point for tests - subroutine test_interface(error) - import :: error_t + !> Error handling + type(error_t), allocatable, intent(out) :: error - !> Error handling - type(error_t), allocatable, intent(out) :: error + end subroutine test_interface + end interface - end subroutine test_interface - end interface + !> Declaration of a unit test + type :: unittest_t + !> Name of the test + character(len=:), allocatable :: name - !> Declaration of a unit test - type :: unittest_t + !> Entry point of the test + procedure(test_interface), pointer, nopass :: test => null() - !> Name of the test - character(len=:), allocatable :: name + !> Whether test is supposed to fail + logical :: should_fail = .false. - !> Entry point of the test - procedure(test_interface), pointer, nopass :: test => null() + end type unittest_t - !> Whether test is supposed to fail - logical :: should_fail = .false. + abstract interface + !> Collect all tests + subroutine collect_interface(testsuite) + import :: unittest_t - end type unittest_t + !> Collection of tests + type(unittest_t), allocatable, intent(out) :: testsuite(:) + end subroutine collect_interface + end interface - abstract interface - !> Collect all tests - subroutine collect_interface(testsuite) - import :: unittest_t + !> Collection of unit tests + type :: testsuite_t - !> Collection of tests - type(unittest_t), allocatable, intent(out) :: testsuite(:) + !> Name of the testsuite + character(len=:), allocatable :: name - end subroutine collect_interface - end interface + !> Entry point of the test + procedure(collect_interface), pointer, nopass :: collect => null() + end type testsuite_t - !> 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) - + character(len=*), parameter :: fmt = '("#", *(1x, a))' + character(len=*), parameter :: indent = repeat(" ", 5)//repeat(".", 3) contains + !> Driver for testsuite + subroutine run_testsuite(collect, unit, stat) - !> Driver for testsuite - subroutine run_testsuite(collect, unit, stat) - - !> Collect tests - procedure(collect_interface) :: collect - - !> 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) - - do ii = 1, size(testsuite) - write(unit, '("#", 3(1x, a), 1x, "(", i0, "/", i0, ")")') & - & "Starting", testsuite(ii)%name, "...", ii, size(testsuite) - 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 - !> Collect tests - procedure(collect_interface) :: collect + !> Unit for IO + integer, intent(in) :: unit - !> Name of the selected test - character(len=*), intent(in) :: name + !> Number of failed tests + integer, intent(inout) :: stat - !> Unit for IO - integer, intent(in) :: unit + type(unittest_t), allocatable :: testsuite(:) + integer :: ii - !> Number of failed tests - integer, intent(inout) :: stat + call collect(testsuite) - type(unittest_t), allocatable :: testsuite(:) - integer :: ii + do ii = 1, size(testsuite) + write (unit, '("#", 3(1x, a), 1x, "(", i0, "/", i0, ")")') & + & "Starting", testsuite(ii)%name, "...", ii, size(testsuite) + call run_unittest(testsuite(ii), unit, stat) + end do - call collect(testsuite) + end subroutine run_testsuite - ii = select_test(testsuite, name) + !> Driver for selective testing + subroutine run_selected(collect, name, unit, stat) - 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 + !> Collect tests + procedure(collect_interface) :: collect - end subroutine run_selected + !> Name of the selected test + character(len=*), intent(in) :: name + !> Unit for IO + integer, intent(in) :: unit - !> Run a selected unit test - subroutine run_unittest(test, unit, stat) + !> Number of failed tests + integer, intent(inout) :: stat - !> Unit test - type(unittest_t), intent(in) :: test + type(unittest_t), allocatable :: testsuite(:) + integer :: ii - !> Unit for IO - integer, intent(in) :: unit + call collect(testsuite) - !> Number of failed tests - integer, intent(inout) :: stat + ii = select_test(testsuite, name) - type(error_t), allocatable :: error + 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 - 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 - write(unit, fmt) indent, test%name, "[FAILED]" - end if - 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_selected - end subroutine run_unittest + !> Run a selected unit test + subroutine run_unittest(test, unit, stat) + !> Unit test + type(unittest_t), intent(in) :: test - !> Select a unit test from all available tests - function select_test(tests, name) result(pos) + !> Unit for IO + integer, intent(in) :: unit - !> Name identifying the test suite - character(len=*), intent(in) :: name + !> Number of failed tests + integer, intent(inout) :: stat - !> Available unit tests - type(unittest_t) :: tests(:) + type(error_t), allocatable :: error - !> Selected test suite - integer :: pos + 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 + write (unit, fmt) indent, test%name, "[FAILED]" + end if + 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 - integer :: it + end subroutine run_unittest - pos = 0 - do it = 1, size(tests) - if (name == tests(it)%name) then - pos = it - exit - end if - end do + !> Select a unit test from all available tests + function select_test(tests, name) result(pos) - end function select_test + !> Name identifying the test suite + character(len=*), intent(in) :: name + !> Available unit tests + type(unittest_t) :: tests(:) - !> Select a test suite from all available suites - function select_suite(suites, name) result(pos) + !> Selected test suite + integer :: pos - !> Name identifying the test suite - character(len=*), intent(in) :: name + integer :: it - !> Available test suites - type(testsuite_t) :: suites(:) + pos = 0 + do it = 1, size(tests) + if (name == tests(it)%name) then + pos = it + exit + end if + end do - !> Selected test suite - integer :: pos + end function select_test - integer :: it + !> Select a test suite from all available suites + function select_suite(suites, name) result(pos) - pos = 0 - do it = 1, size(suites) - if (name == suites(it)%name) then - pos = it - exit - end if - end do + !> Name identifying the test suite + character(len=*), intent(in) :: name - end function select_suite + !> Available test suites + type(testsuite_t) :: suites(:) + !> Selected test suite + integer :: pos - !> Register a new unit test - function new_unittest(name, test, should_fail) result(self) + integer :: it - !> Name of the test - character(len=*), intent(in) :: name + pos = 0 + do it = 1, size(suites) + if (name == suites(it)%name) then + pos = it + exit + end if + end do - !> Entry point for the test - procedure(test_interface) :: test + end function select_suite - !> Whether test is supposed to error or not - logical, intent(in), optional :: should_fail + !> Register a new unit test + function new_unittest(name, test, should_fail) result(self) - !> Newly registered test - type(unittest_t) :: self + !> Name of the test + character(len=*), intent(in) :: name - self%name = name - self%test => test - if (present(should_fail)) self%should_fail = should_fail + !> Entry point for the test + procedure(test_interface) :: test - end function new_unittest + !> Whether test is supposed to error or not + logical, intent(in), optional :: should_fail + !> Newly registered test + type(unittest_t) :: self - !> Register a new testsuite - function new_testsuite(name, collect) result(self) + self%name = name + self%test => test + if (present(should_fail)) self%should_fail = should_fail - !> Name of the testsuite - character(len=*), intent(in) :: name + end function new_unittest - !> Entry point to collect tests - procedure(collect_interface) :: collect + !> Register a new testsuite + function new_testsuite(name, collect) result(self) - !> Newly registered testsuite - type(testsuite_t) :: self + !> Name of the testsuite + character(len=*), intent(in) :: name - self%name = name - self%collect => collect + !> Entry point to collect tests + procedure(collect_interface) :: collect - end function new_testsuite + !> Newly registered testsuite + type(testsuite_t) :: self + self%name = name + self%collect => collect - !> Check a deferred length character variable against a reference value - subroutine check_string(error, actual, expected, name) + end function new_testsuite - !> Error handling - type(error_t), allocatable, intent(out) :: error + !> Check a deferred length character variable against a reference value + subroutine check_string(error, actual, expected, name) - !> Actual string value - character(len=:), allocatable, intent(in) :: actual + !> Error handling + type(error_t), allocatable, intent(out) :: error - !> Expected string value - character(len=*), intent(in) :: expected + !> Actual string value + character(len=:), allocatable, intent(in) :: actual - !> Name of the string to check - character(len=*), intent(in) :: name + !> Expected string value + character(len=*), intent(in) :: expected - if (.not.allocated(actual)) then - call test_failed(error, name//" is not set correctly") - return - end if + !> Name of the string to check + character(len=*), intent(in) :: name - if (actual /= expected) then - call test_failed(error, name//" is "//actual// & - & " but should be "//expected) - end if + if (.not. allocated(actual)) then + call test_failed(error, name//" is not set correctly") + return + end if - end subroutine check_string + if (actual /= expected) then + call test_failed(error, name//" is "//actual// & + & " but should be "//expected) + end if + end subroutine check_string end module testsuite diff --git a/test/help_test/help_test.f90 b/test/help_test/help_test.f90 index e78a4ea788..608e240118 100644 --- a/test/help_test/help_test.f90 +++ b/test/help_test/help_test.f90 @@ -1,293 +1,292 @@ program help_test ! note hardcoded len=k1 instead of len=: in this test is a work-around a gfortran bug in old ! pre-v8.3 versions -use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, stderr=>error_unit -use fpm_filesystem, only : dirname, join_path, exists -use fpm_environment, only : get_os_type, OS_WINDOWS -implicit none -integer :: i -integer :: be, af -character(len=:),allocatable :: path -integer :: estat, cstat -integer,parameter :: k1=132 -character(len=k1) :: message -logical,allocatable :: tally(:) + use, intrinsic :: iso_fortran_env, only: stdin => input_unit, stdout => output_unit, stderr => error_unit + use fpm_filesystem, only: dirname, join_path, exists + use fpm_environment, only: get_os_type, OS_WINDOWS + implicit none + integer :: i + integer :: be, af + character(len=:), allocatable :: path + integer :: estat, cstat + integer, parameter :: k1 = 132 + character(len=k1) :: message + logical, allocatable :: tally(:) !intel-bug!character(len=:),allocatable :: book1(:), book2(:) -character(len=k1),allocatable :: book1(:), book2(:) + character(len=k1), allocatable :: book1(:), book2(:) !intel-bug!character(len=:),allocatable :: page1(:) -character(len=k1),allocatable :: page1(:) -integer :: lines -integer :: chars + character(len=k1), allocatable :: page1(:) + integer :: lines + integer :: chars ! run a variety of "fpm help" variations and verify expected files are generated -character(len=*),parameter :: cmds(*) = [character(len=80) :: & -! build manual as pieces using various help commands -! debug version -'--version ',& ! verify fpm version being used -'--help > fpm_scratch_help.txt',& -'help new >> fpm_scratch_help.txt',& -'help update >> fpm_scratch_help.txt',& -'build --help >> fpm_scratch_help.txt',& -'help run >> fpm_scratch_help.txt',& -'help test >> fpm_scratch_help.txt',& -'help runner >> fpm_scratch_help.txt',& -'help install >> fpm_scratch_help.txt',& -'help list >> fpm_scratch_help.txt',& -'help help >> fpm_scratch_help.txt',& -'help clean >> fpm_scratch_help.txt',& -'--version >> fpm_scratch_help.txt',& -! generate manual -' help manual > fpm_scratch_manual.txt'] + character(len=*), parameter :: cmds(*) = [character(len=80) :: & + ! build manual as pieces using various help commands + ! debug version + '--version ', & ! verify fpm version being used + '--help > fpm_scratch_help.txt', & + 'help new >> fpm_scratch_help.txt', & + 'help update >> fpm_scratch_help.txt', & + 'build --help >> fpm_scratch_help.txt', & + 'help run >> fpm_scratch_help.txt', & + 'help test >> fpm_scratch_help.txt', & + 'help runner >> fpm_scratch_help.txt', & + 'help install >> fpm_scratch_help.txt', & + 'help list >> fpm_scratch_help.txt', & + 'help help >> fpm_scratch_help.txt', & + 'help clean >> fpm_scratch_help.txt', & + '--version >> fpm_scratch_help.txt', & + ! generate manual + ' help manual > fpm_scratch_manual.txt'] !'fpm run >> fpm_scratch_help.txt',& !'fpm run -- --list >> fpm_scratch_help.txt',& !'fpm run -- list --list >> fpm_scratch_help.txt',& -character(len=*),parameter :: names(*)=[character(len=10) ::& - 'fpm','new','update','build','run','test','runner','install','list','help','clean'] -character(len=:), allocatable :: prog -integer :: length + character(len=*), parameter :: names(*) = [character(len=10) :: & + 'fpm', 'new', 'update', 'build', 'run', 'test', 'runner', 'install', 'list', 'help', 'clean'] + character(len=:), allocatable :: prog + integer :: length - ! FIXME: Super hacky way to get the name of the fpm executable, - ! it works better than invoking fpm again but should be replaced ASAP. - call get_command_argument(0, length=length) - allocate(character(len=length) :: prog) - call get_command_argument(0, prog) - path = dirname(prog) - if (get_os_type() == OS_WINDOWS) then - prog = join_path(path, "..", "app", "fpm.exe") - if (.not.exists(prog)) then - prog = join_path(path, "..", "..", "app", "fpm.exe") - end if - else - prog = join_path(path, "..", "app", "fpm") - if (.not.exists(prog)) then - prog = join_path(path, "..", "..", "app", "fpm") - end if - end if + ! FIXME: Super hacky way to get the name of the fpm executable, + ! it works better than invoking fpm again but should be replaced ASAP. + call get_command_argument(0, length=length) + allocate (character(len=length) :: prog) + call get_command_argument(0, prog) + path = dirname(prog) + if (get_os_type() == OS_WINDOWS) then + prog = join_path(path, "..", "app", "fpm.exe") + if (.not. exists(prog)) then + prog = join_path(path, "..", "..", "app", "fpm.exe") + end if + else + prog = join_path(path, "..", "app", "fpm") + if (.not. exists(prog)) then + prog = join_path(path, "..", "..", "app", "fpm") + end if + end if - write(*,'(g0:,1x)')'TEST help SUBCOMMAND STARTED' - if(allocated(tally))deallocate(tally) - allocate(tally(0)) - call wipe('fpm_scratch_help.txt') - call wipe('fpm_scratch_manual.txt') + write (*, '(g0:,1x)') 'TEST help SUBCOMMAND STARTED' + if (allocated(tally)) deallocate (tally) + allocate (tally(0)) + call wipe('fpm_scratch_help.txt') + call wipe('fpm_scratch_manual.txt') - ! check that output has NAME SYNOPSIS DESCRIPTION - do i=1,size(names) - write(*,*)'check '//names(i)//' for NAME SYNOPSIS DESCRIPTION' - path= prog // ' help '//names(i)//' >fpm_scratch_help.txt' - message='' - call execute_command_line(path,exitstat=estat,cmdstat=cstat,cmdmsg=message) - write(*,'(*(g0))')'CMD=',path,' EXITSTAT=',estat,' CMDSTAT=',cstat,' MESSAGE=',trim(message) - tally=[tally,all([estat==0,cstat==0])] - call swallow('fpm_scratch_help.txt',page1) - if(size(page1)<3)then - write(*,*)'help for '//names(i)//' ridiculiously small' - tally=[tally,.false.] - exit - endif + ! check that output has NAME SYNOPSIS DESCRIPTION + do i = 1, size(names) + write (*, *) 'check '//names(i)//' for NAME SYNOPSIS DESCRIPTION' + path = prog//' help '//names(i)//' >fpm_scratch_help.txt' + message = '' + call execute_command_line(path, exitstat=estat, cmdstat=cstat, cmdmsg=message) + write (*, '(*(g0))') 'CMD=', path, ' EXITSTAT=', estat, ' CMDSTAT=', cstat, ' MESSAGE=', trim(message) + tally = [tally, all([estat == 0, cstat == 0])] + call swallow('fpm_scratch_help.txt', page1) + if (size(page1) < 3) then + write (*, *) 'help for '//names(i)//' ridiculiously small' + tally = [tally, .false.] + exit + end if !!write(*,*)findloc(page1,'NAME')==1 - be=count(.not.tally) - tally=[tally,count(page1=='NAME')==1] - tally=[tally,count(page1=='SYNOPSIS')==1] - tally=[tally,count(page1=='DESCRIPTION')==1] - af=count(.not.tally) - if(be/=af)then - write(*,*)'missing expected sections in ',names(i) - write(*,*)page1(1) ! assuming at least size 1 for debugging mingw - write(*,*)count(page1=='NAME') - write(*,*)count(page1=='SYNOPSIS') - write(*,*)count(page1=='DESCRIPTION') - write(*,'(a)')page1 - endif - write(*,*)'have completed ',count(tally),' tests' - call wipe('fpm_scratch_help.txt') - enddo + be = count(.not. tally) + tally = [tally, count(page1 == 'NAME') == 1] + tally = [tally, count(page1 == 'SYNOPSIS') == 1] + tally = [tally, count(page1 == 'DESCRIPTION') == 1] + af = count(.not. tally) + if (be /= af) then + write (*, *) 'missing expected sections in ', names(i) + write (*, *) page1(1) ! assuming at least size 1 for debugging mingw + write (*, *) count(page1 == 'NAME') + write (*, *) count(page1 == 'SYNOPSIS') + write (*, *) count(page1 == 'DESCRIPTION') + write (*, '(a)') page1 + end if + write (*, *) 'have completed ', count(tally), ' tests' + call wipe('fpm_scratch_help.txt') + end do + ! execute the fpm(1) commands + do i = 1, size(cmds) + message = '' + path = prog//' '//cmds(i) + call execute_command_line(path, exitstat=estat, cmdstat=cstat, cmdmsg=message) + write (*, '(*(g0))') 'CMD=', path, ' EXITSTAT=', estat, ' CMDSTAT=', cstat, ' MESSAGE=', trim(message) + tally = [tally, all([estat == 0, cstat == 0])] + end do - ! execute the fpm(1) commands - do i=1,size(cmds) - message='' - path= prog //' '//cmds(i) - call execute_command_line(path,exitstat=estat,cmdstat=cstat,cmdmsg=message) - write(*,'(*(g0))')'CMD=',path,' EXITSTAT=',estat,' CMDSTAT=',cstat,' MESSAGE=',trim(message) - tally=[tally,all([estat==0,cstat==0])] - enddo + ! compare book written in fragments with manual + call swallow('fpm_scratch_help.txt', book1) + call swallow('fpm_scratch_manual.txt', book2) + ! get rid of lines from run() which is not on stderr at the moment + book1 = pack(book1, index(book1, ' + build/') == 0) + book2 = pack(book1, index(book2, ' + build/') == 0) + write (*, *) 'book1 ', size(book1), len(book1) + write (*, *) 'book2 ', size(book2), len(book2) + if (size(book1) /= size(book2)) then + write (*, *) 'manual and "debug" appended pages are not the same size' + tally = [tally, .false.] + else + if (all(book1 /= book2)) then + tally = [tally, .false.] + write (*, *) 'manual and "debug" appended pages are not the same' + else + write (*, *) 'manual and "debug" appended pages are the same' + tally = [tally, .true.] + end if + end if - ! compare book written in fragments with manual - call swallow('fpm_scratch_help.txt',book1) - call swallow('fpm_scratch_manual.txt',book2) - ! get rid of lines from run() which is not on stderr at the moment - book1=pack(book1,index(book1,' + build/')==0) - book2=pack(book1,index(book2,' + build/')==0) - write(*,*)'book1 ',size(book1), len(book1) - write(*,*)'book2 ',size(book2), len(book2) - if(size(book1)/=size(book2))then - write(*,*)'manual and "debug" appended pages are not the same size' - tally=[tally,.false.] - else - if(all(book1/=book2))then - tally=[tally,.false.] - write(*,*)'manual and "debug" appended pages are not the same' - else - write(*,*)'manual and "debug" appended pages are the same' - tally=[tally,.true.] - endif - endif - - ! overall size of manual - !chars=size(book2) - !lines=max(count(char(10)==book2),count(char(13)==book2)) - chars=sum(len_trim(book2)) ! SUM TRIMMED LENGTH - lines=size(book2) - if( (chars<12000) .or. (lines<350) )then - write(*,*)'"debug" manual is suspiciously small, bytes=',chars,' lines=',lines - tally=[tally,.false.] - else - write(*,*)'"debug" manual size in bytes=',chars,' lines=',lines - tally=[tally,.true.] - endif + ! overall size of manual + !chars=size(book2) + !lines=max(count(char(10)==book2),count(char(13)==book2)) + chars = sum(len_trim(book2)) ! SUM TRIMMED LENGTH + lines = size(book2) + if ((chars < 12000) .or. (lines < 350)) then + write (*, *) '"debug" manual is suspiciously small, bytes=', chars, ' lines=', lines + tally = [tally, .false.] + else + write (*, *) '"debug" manual size in bytes=', chars, ' lines=', lines + tally = [tally, .true.] + end if - write(*,'("HELP TEST TALLY=",*(g0))')tally - call wipe('fpm_scratch_help.txt') - call wipe('fpm_scratch_manual.txt') - if(all(tally))then - write(*,'(*(g0))')'PASSED: all ',count(tally),' tests passed ' - else - write(*,*)'FAILED: PASSED=',count(tally),' FAILED=',count(.not.tally) - stop 5 - endif - write(*,'(g0:,1x)')'TEST help SUBCOMMAND COMPLETE' + write (*, '("HELP TEST TALLY=",*(g0))') tally + call wipe('fpm_scratch_help.txt') + call wipe('fpm_scratch_manual.txt') + if (all(tally)) then + write (*, '(*(g0))') 'PASSED: all ', count(tally), ' tests passed ' + else + write (*, *) 'FAILED: PASSED=', count(tally), ' FAILED=', count(.not. tally) + stop 5 + end if + write (*, '(g0:,1x)') 'TEST help SUBCOMMAND COMPLETE' contains -subroutine wipe(filename) -character(len=*),intent(in) :: filename -integer :: ios -integer :: lun -character(len=k1) :: message -open(file=filename,newunit=lun,iostat=ios,iomsg=message) -if(ios==0)then - close(unit=lun,iostat=ios,status='delete',iomsg=message) - if(ios/=0)then - write(*,*)''//trim(message) - endif -else - write(*,*)''//trim(message) -endif -end subroutine wipe + subroutine wipe(filename) + character(len=*), intent(in) :: filename + integer :: ios + integer :: lun + character(len=k1) :: message + open (file=filename, newunit=lun, iostat=ios, iomsg=message) + if (ios == 0) then + close (unit=lun, iostat=ios, status='delete', iomsg=message) + if (ios /= 0) then + write (*, *) ''//trim(message) + end if + else + write (*, *) ''//trim(message) + end if + end subroutine wipe -subroutine slurp(filename,text) -implicit none + subroutine slurp(filename, text) + implicit none !$@(#) M_io::slurp(3f): allocate text array and read file filename into it -character(*),intent(in) :: filename ! filename to shlep -character(len=1),allocatable,intent(out) :: text(:) ! array to hold file -integer :: nchars, igetunit, ios -character(len=k1) :: message -character(len=4096) :: local_filename - ios=0 - nchars=0 - message='' - open(newunit=igetunit, file=trim(filename), action="read", iomsg=message,& - &form="unformatted", access="stream",status='old',iostat=ios) - local_filename=filename - if(ios==0)then ! if file was successfully opened - inquire(unit=igetunit, size=nchars) - if(nchars<=0)then - call stderr_local( '*slurp* empty file '//trim(local_filename) ) - return - endif + character(*), intent(in) :: filename ! filename to shlep + character(len=1), allocatable, intent(out) :: text(:) ! array to hold file + integer :: nchars, igetunit, ios + character(len=k1) :: message + character(len=4096) :: local_filename + ios = 0 + nchars = 0 + message = '' + open (newunit=igetunit, file=trim(filename), action="read", iomsg=message,& + &form="unformatted", access="stream", status='old', iostat=ios) + local_filename = filename + if (ios == 0) then ! if file was successfully opened + inquire (unit=igetunit, size=nchars) + if (nchars <= 0) then + call stderr_local('*slurp* empty file '//trim(local_filename)) + return + end if ! read file into text array - if(allocated(text))deallocate(text) ! make sure text array not allocated - allocate ( text(nchars) ) ! make enough storage to hold file - read(igetunit,iostat=ios,iomsg=message) text ! load input file -> text array - if(ios/=0)then - call stderr_local( '*slurp* bad read of '//trim(local_filename)//':'//trim(message) ) - endif - else + if (allocated(text)) deallocate (text) ! make sure text array not allocated + allocate (text(nchars)) ! make enough storage to hold file + read (igetunit, iostat=ios, iomsg=message) text ! load input file -> text array + if (ios /= 0) then + call stderr_local('*slurp* bad read of '//trim(local_filename)//':'//trim(message)) + end if + else call stderr_local('*slurp* '//message) - allocate ( text(0) ) ! make enough storage to hold file - endif - close(iostat=ios,unit=igetunit) ! close if opened successfully or not -end subroutine slurp + allocate (text(0)) ! make enough storage to hold file + end if + close (iostat=ios, unit=igetunit) ! close if opened successfully or not + end subroutine slurp -subroutine stderr_local(message) -character(len=*) :: message - write(*,'(a)')trim(message) ! write message to standard error -end subroutine stderr_local + subroutine stderr_local(message) + character(len=*) :: message + write (*, '(a)') trim(message) ! write message to standard error + end subroutine stderr_local -subroutine swallow(FILENAME,pageout) -implicit none -character(len=*),intent(in) :: FILENAME ! file to read + subroutine swallow(FILENAME, pageout) + implicit none + character(len=*), intent(in) :: FILENAME ! file to read !intel-bug!character(len=:),allocatable,intent(out) :: pageout(:) ! page to hold file in memory -character(len=k1),allocatable,intent(out) :: pageout(:) ! page to hold file in memory -character(len=1),allocatable :: text(:) ! array to hold file in memory + character(len=k1), allocatable, intent(out) :: pageout(:) ! page to hold file in memory + character(len=1), allocatable :: text(:) ! array to hold file in memory - call slurp(FILENAME,text) ! allocate character array and copy file into it + call slurp(FILENAME, text) ! allocate character array and copy file into it - if(.not.allocated(text))then - write(*,*)'*swallow* failed to load file '//FILENAME - else ! convert array of characters to array of lines - pageout=page(text) - deallocate(text) ! release memory - endif -end subroutine swallow + if (.not. allocated(text)) then + write (*, *) '*swallow* failed to load file '//FILENAME + else ! convert array of characters to array of lines + pageout = page(text) + deallocate (text) ! release memory + end if + end subroutine swallow -function page(array) result (table) + function page(array) result(table) !$@(#) M_strings::page(3fp): function to copy char array to page of text -character(len=1),intent(in) :: array(:) + character(len=1), intent(in) :: array(:) !intel-bug!character(len=:),allocatable :: table(:) -character(len=k1),allocatable :: table(:) -integer :: i -integer :: linelength -integer :: length -integer :: lines -integer :: linecount -integer :: position -integer :: sz + character(len=k1), allocatable :: table(:) + integer :: i + integer :: linelength + integer :: length + integer :: lines + integer :: linecount + integer :: position + integer :: sz !!character(len=1),parameter :: nl=new_line('A') -character(len=1),parameter :: nl=char(10) -character(len=1),parameter :: cr=char(13) - lines=0 - linelength=0 - length=0 - sz=size(array) - do i=1,sz - if(array(i)==nl)then - linelength=max(linelength,length) - lines=lines+1 - length=0 + character(len=1), parameter :: nl = char(10) + character(len=1), parameter :: cr = char(13) + lines = 0 + linelength = 0 + length = 0 + sz = size(array) + do i = 1, sz + if (array(i) == nl) then + linelength = max(linelength, length) + lines = lines + 1 + length = 0 else - length=length+1 - endif - enddo - if(sz>0)then - if(array(sz)/=nl)then - lines=lines+1 - endif - endif + length = length + 1 + end if + end do + if (sz > 0) then + if (array(sz) /= nl) then + lines = lines + 1 + end if + end if - if(allocated(table))deallocate(table) - !intel-bug!allocate(character(len=linelength) :: table(lines)) - allocate(character(len=k1) :: table(lines)) - table=' ' - linecount=1 - position=1 - do i=1,sz - if(array(i)==nl)then - linecount=linecount+1 - position=1 - elseif(array(i)==cr)then - elseif(linelength/=0)then - if(position>len(table))then - write(*,*)' adding character past edge of text',table(linecount),array(i) - elseif(linecount>size(table))then - write(*,*)' adding line past end of text',linecount,size(table) - else - table(linecount)(position:position)=array(i) - endif - position=position+1 - endif - enddo -end function page + if (allocated(table)) deallocate (table) + !intel-bug!allocate(character(len=linelength) :: table(lines)) + allocate (character(len=k1) :: table(lines)) + table = ' ' + linecount = 1 + position = 1 + do i = 1, sz + if (array(i) == nl) then + linecount = linecount + 1 + position = 1 + elseif (array(i) == cr) then + elseif (linelength /= 0) then + if (position > len(table)) then + write (*, *) ' adding character past edge of text', table(linecount), array(i) + elseif (linecount > size(table)) then + write (*, *) ' adding line past end of text', linecount, size(table) + else + table(linecount) (position:position) = array(i) + end if + position = position + 1 + end if + end do + end function page end program help_test diff --git a/test/new_test/new_test.f90 b/test/new_test/new_test.f90 index edf2975613..d4585aaafb 100644 --- a/test/new_test/new_test.f90 +++ b/test/new_test/new_test.f90 @@ -1,174 +1,174 @@ program new_test -use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, stderr=>error_unit -use fpm_filesystem, only : is_dir, list_files, exists, windows_path, join_path, & - dirname, run -use fpm_strings, only : string_t, operator(.in.) -use fpm_environment, only : get_os_type -use fpm_environment, only : OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD, OS_WINDOWS -implicit none -type(string_t), allocatable :: file_names(:) -integer :: i, j, k -character(len=:),allocatable :: cmdpath -character(len=:),allocatable :: path -character(len=*),parameter :: scr = 'fpm_scratch_' -character(len=*),parameter :: cmds(*) = [character(len=80) :: & -! run a variety of "fpm new" variations and verify expected files are generated -'new', & -'new name-with-hyphens', & -'new '//scr//'A', & -'new '//scr//'B --lib', & -'new '//scr//'C --app', & -'new '//scr//'D --test', & -'new '//scr//'E --lib --test ', & -'new '//scr//'F --lib --app', & -'new '//scr//'G --test --app', & -'new '//scr//'H --example', & -'new '//scr//'BB --lib', & -'new '//scr//'BB --test ', & -'new '//scr//'BB --backfill --test', & -'new '//scr//'CC --test --src --app', & -'new --version', & -'new --help'] -integer :: estat, cstat -character(len=256) :: message -character(len=:),allocatable :: directories(:) -character(len=:),allocatable :: shortdirs(:) -character(len=:),allocatable :: expected(:) -logical,allocatable :: tally(:) -logical :: IS_OS_WINDOWS -character(len=*),parameter :: dirs_to_be_removed = 'fpm_scratch_* name-with-hyphens' -character(len=:),allocatable :: rm_command - write(*,'(g0:,1x)')'TEST new SUBCOMMAND (draft):' + use, intrinsic :: iso_fortran_env, only: stdin => input_unit, stdout => output_unit, stderr => error_unit + use fpm_filesystem, only: is_dir, list_files, exists, windows_path, join_path, & + dirname, run + use fpm_strings, only: string_t, operator(.in.) + use fpm_environment, only: get_os_type + use fpm_environment, only: OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD, OS_WINDOWS + implicit none + type(string_t), allocatable :: file_names(:) + integer :: i, j, k + character(len=:), allocatable :: cmdpath + character(len=:), allocatable :: path + character(len=*), parameter :: scr = 'fpm_scratch_' + character(len=*), parameter :: cmds(*) = [character(len=80) :: & + ! run a variety of "fpm new" variations and verify expected files are generated + 'new', & + 'new name-with-hyphens', & + 'new '//scr//'A', & + 'new '//scr//'B --lib', & + 'new '//scr//'C --app', & + 'new '//scr//'D --test', & + 'new '//scr//'E --lib --test ', & + 'new '//scr//'F --lib --app', & + 'new '//scr//'G --test --app', & + 'new '//scr//'H --example', & + 'new '//scr//'BB --lib', & + 'new '//scr//'BB --test ', & + 'new '//scr//'BB --backfill --test', & + 'new '//scr//'CC --test --src --app', & + 'new --version', & + 'new --help'] + integer :: estat, cstat + character(len=256) :: message + character(len=:), allocatable :: directories(:) + character(len=:), allocatable :: shortdirs(:) + character(len=:), allocatable :: expected(:) + logical, allocatable :: tally(:) + logical :: IS_OS_WINDOWS + character(len=*), parameter :: dirs_to_be_removed = 'fpm_scratch_* name-with-hyphens' + character(len=:), allocatable :: rm_command + write (*, '(g0:,1x)') 'TEST new SUBCOMMAND (draft):' - cmdpath = get_command_path() - allocate(tally(0)) - shortdirs=[character(len=80) :: 'A','B','C','D','E','F','G','H','BB','CC'] - allocate(character(len=80) :: directories(size(shortdirs))) + cmdpath = get_command_path() + allocate (tally(0)) + shortdirs = [character(len=80) :: 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'BB', 'CC'] + allocate (character(len=80) :: directories(size(shortdirs))) !! SEE IF EXPECTED FILES ARE GENERATED !! Issues: !! o assuming fpm command is in expected path and the new version !! o DOS versus POSIX filenames - is_os_windows=.false. - select case (get_os_type()) - case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD) - call execute_command_line('rm -rf fpm_scratch_*',exitstat=estat,cmdstat=cstat,cmdmsg=message) - path=cmdpath - case (OS_WINDOWS) - path=windows_path(cmdpath) - is_os_windows=.true. - do i=1,size(directories) - call execute_command_line('rmdir /s /q fpm_scratch_'//trim(shortdirs(i)),exitstat=estat,& - cmdstat=cstat,cmdmsg=message) - end do - case default - write(*,*)'ERROR: unknown OS. Stopping test' - stop 2 - end select - do i=1,size(directories) - directories(i)=scr//trim(shortdirs(i)) - if( is_dir(trim(directories(i))) ) then - write(*,*)'ERROR:',trim( directories(i) ),' already exists' - write(*,*)' you must remove scratch directories before performing this test' - write(*,'(*(g0:,1x))')'directories:',(trim(directories(j)),j=1,size(directories)),'name-with-hyphens' - stop - endif - enddo - ! execute the fpm(1) commands - do i=1,size(cmds) - message='' - write(*,*)path//' '//cmds(i) - call execute_command_line(path//' '//cmds(i),exitstat=estat,cmdstat=cstat,cmdmsg=message) - write(*,'(*(g0))')'CMD=',trim(cmds(i)),' EXITSTAT=',estat,' CMDSTAT=',cstat,' MESSAGE=',trim(message) - enddo + is_os_windows = .false. + select case (get_os_type()) + case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD) + call execute_command_line('rm -rf fpm_scratch_*', exitstat=estat, cmdstat=cstat, cmdmsg=message) + path = cmdpath + case (OS_WINDOWS) + path = windows_path(cmdpath) + is_os_windows = .true. + do i = 1, size(directories) + call execute_command_line('rmdir /s /q fpm_scratch_'//trim(shortdirs(i)), exitstat=estat, & + cmdstat=cstat, cmdmsg=message) + end do + case default + write (*, *) 'ERROR: unknown OS. Stopping test' + stop 2 + end select + do i = 1, size(directories) + directories(i) = scr//trim(shortdirs(i)) + if (is_dir(trim(directories(i)))) then + write (*, *) 'ERROR:', trim(directories(i)), ' already exists' + write (*, *) ' you must remove scratch directories before performing this test' + write (*, '(*(g0:,1x))') 'directories:', (trim(directories(j)), j=1, size(directories)), 'name-with-hyphens' + stop + end if + end do + ! execute the fpm(1) commands + do i = 1, size(cmds) + message = '' + write (*, *) path//' '//cmds(i) + call execute_command_line(path//' '//cmds(i), exitstat=estat, cmdstat=cstat, cmdmsg=message) + write (*, '(*(g0))') 'CMD=', trim(cmds(i)), ' EXITSTAT=', estat, ' CMDSTAT=', cstat, ' MESSAGE=', trim(message) + end do - if( is_dir('name-with-hyphens') ) then - tally=[tally,.true.] + if (is_dir('name-with-hyphens')) then + tally = [tally, .true.] - else - write(*,*)'ERROR: directory name-with-hyphens/ exists' - tally=[tally,.false.] - endif + else + write (*, *) 'ERROR: directory name-with-hyphens/ exists' + tally = [tally, .false.] + end if - ! assuming hidden files in .git and .gitignore are ignored for now - TESTS: do i=1,size(directories) - ! test if expected directory exists - if( .not. is_dir(trim( directories(i))) ) then - tally=[tally,.false.] - write(*,*)'ERROR:',trim( directories(i) ),' is not a directory' - else - select case(shortdirs(i)) - case('A'); expected=[ character(len=80)::& - &'A/app','A/fpm.toml','A/README.md','A/src','A/test','A/app/main.f90','A/src/'//scr//'A.f90','A/test/check.f90'] - case('B'); expected=[ character(len=80)::& - &'B/fpm.toml','B/README.md','B/src','B/src/'//scr//'B.f90'] - case('C'); expected=[ character(len=80)::& - &'C/app','C/fpm.toml','C/README.md','C/app/main.f90'] - case('D'); expected=[ character(len=80)::& - &'D/fpm.toml','D/README.md','D/test','D/test/check.f90'] - case('E'); expected=[ character(len=80)::& - &'E/fpm.toml','E/README.md','E/src','E/test','E/src/'//scr//'E.f90','E/test/check.f90'] - case('F'); expected=[ character(len=80)::& - &'F/app','F/fpm.toml','F/README.md','F/src','F/app/main.f90','F/src/'//scr//'F.f90'] - case('G'); expected=[ character(len=80)::& - &'G/app','G/fpm.toml','G/README.md','G/test','G/app/main.f90','G/test/check.f90'] - case('H'); expected=[ character(len=80)::& - &'H/example','H/fpm.toml','H/README.md','H/example/demo.f90'] - case('BB'); expected=[ character(len=80)::& - &'BB/fpm.toml','BB/README.md','BB/src','BB/test','BB/src/'//scr//'BB.f90','BB/test/check.f90'] - case('CC'); expected=[ character(len=80)::& - &'CC/app','CC/fpm.toml','CC/README.md','CC/src','CC/test','CC/app/main.f90','CC/src/'//scr//'CC.f90','CC/test/check.f90'] - case default - write(*,*)'ERROR: internal error. unknown directory name ',trim(shortdirs(i)) - stop 4 - end select + ! assuming hidden files in .git and .gitignore are ignored for now + TESTS: do i = 1, size(directories) + ! test if expected directory exists + if (.not. is_dir(trim(directories(i)))) then + tally = [tally, .false.] + write (*, *) 'ERROR:', trim(directories(i)), ' is not a directory' + else + select case (shortdirs(i)) + case ('A'); expected = [character(len=80)::& + &'A/app', 'A/fpm.toml', 'A/README.md', 'A/src', 'A/test', 'A/app/main.f90', 'A/src/'//scr//'A.f90', 'A/test/check.f90'] + case ('B'); expected = [character(len=80)::& + &'B/fpm.toml', 'B/README.md', 'B/src', 'B/src/'//scr//'B.f90'] + case ('C'); expected = [character(len=80)::& + &'C/app', 'C/fpm.toml', 'C/README.md', 'C/app/main.f90'] + case ('D'); expected = [character(len=80)::& + &'D/fpm.toml', 'D/README.md', 'D/test', 'D/test/check.f90'] + case ('E'); expected = [character(len=80)::& + &'E/fpm.toml', 'E/README.md', 'E/src', 'E/test', 'E/src/'//scr//'E.f90', 'E/test/check.f90'] + case ('F'); expected = [character(len=80)::& + &'F/app', 'F/fpm.toml', 'F/README.md', 'F/src', 'F/app/main.f90', 'F/src/'//scr//'F.f90'] + case ('G'); expected = [character(len=80)::& + &'G/app', 'G/fpm.toml', 'G/README.md', 'G/test', 'G/app/main.f90', 'G/test/check.f90'] + case ('H'); expected = [character(len=80)::& + &'H/example', 'H/fpm.toml', 'H/README.md', 'H/example/demo.f90'] + case ('BB'); expected = [character(len=80)::& + &'BB/fpm.toml', 'BB/README.md', 'BB/src', 'BB/test', 'BB/src/'//scr//'BB.f90', 'BB/test/check.f90'] + case ('CC'); expected = [character(len=80)::& + &'CC/app', 'CC/fpm.toml', 'CC/README.md', 'CC/src', 'CC/test', 'CC/app/main.f90', 'CC/src/'//scr//'CC.f90', 'CC/test/check.f90'] + case default + write (*, *) 'ERROR: internal error. unknown directory name ', trim(shortdirs(i)) + stop 4 + end select !! MSwindows has hidden files in it !! Warning: This only looks for expected files. If there are more files than expected it does not fail - call list_files(trim(directories(i)), file_names,recurse=.true.) - - if(size(expected)/=size(file_names))then - write(*,*)'WARNING: unexpected number of files in file list=',size(file_names),' expected ',size(expected) - write(*,'("EXPECTED: ",*(g0:,","))')(scr//trim(expected(j)),j=1,size(expected)) - write(*,'("FOUND: ",*(g0:,","))')(trim(file_names(j)%s),j=1,size(file_names)) - endif + call list_files(trim(directories(i)), file_names, recurse=.true.) - do j=1,size(expected) + if (size(expected) /= size(file_names)) then + write (*, *) 'WARNING: unexpected number of files in file list=', size(file_names), ' expected ', size(expected) + write (*, '("EXPECTED: ",*(g0:,","))') (scr//trim(expected(j)), j=1, size(expected)) + write (*, '("FOUND: ",*(g0:,","))') (trim(file_names(j)%s), j=1, size(file_names)) + end if - expected(j)=scr//expected(j) - if(is_os_windows) expected(j)=windows_path(expected(j)) - if( .not.(trim(expected(j)).in.file_names) )then - tally=[tally,.false.] - write(*,'("ERROR: FOUND ",*(g0:,", "))')( trim(file_names(k)%s), k=1,size(file_names) ) - write(*,'(*(g0))')' BUT NO MATCH FOR ',expected(j) - tally=[tally,.false.] - cycle TESTS - endif - enddo - tally=[tally,.true.] - endif - enddo TESTS + do j = 1, size(expected) - ! clean up scratch files; might want an option to leave them for inspection - select case (get_os_type()) - case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD) - rm_command = 'rm -rf ' // dirs_to_be_removed - case (OS_WINDOWS) - do i=1,size(directories) - rm_command = 'rmdir /s /q fpm_scratch_'//trim(shortdirs(i)) - call execute_command_line('rmdir /s /q fpm_scratch_'//trim(shortdirs(i)),exitstat=estat,& - cmdstat=cstat,cmdmsg=message) + expected(j) = scr//expected(j) + if (is_os_windows) expected(j) = windows_path(expected(j)) + if (.not. (trim(expected(j)) .in.file_names)) then + tally = [tally, .false.] + write (*, '("ERROR: FOUND ",*(g0:,", "))') (trim(file_names(k)%s), k=1, size(file_names)) + write (*, '(*(g0))') ' BUT NO MATCH FOR ', expected(j) + tally = [tally, .false.] + cycle TESTS + end if end do - rm_command = 'rmdir /s /q name-with-hyphens' - end select - call execute_command_line(rm_command, exitstat=estat,cmdstat=cstat,cmdmsg=message) + tally = [tally, .true.] + end if + end do TESTS + + ! clean up scratch files; might want an option to leave them for inspection + select case (get_os_type()) + case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD) + rm_command = 'rm -rf '//dirs_to_be_removed + case (OS_WINDOWS) + do i = 1, size(directories) + rm_command = 'rmdir /s /q fpm_scratch_'//trim(shortdirs(i)) + call execute_command_line('rmdir /s /q fpm_scratch_'//trim(shortdirs(i)), exitstat=estat, & + cmdstat=cstat, cmdmsg=message) + end do + rm_command = 'rmdir /s /q name-with-hyphens' + end select + call execute_command_line(rm_command, exitstat=estat, cmdstat=cstat, cmdmsg=message) - write(*,'("new TEST TALLY=",*(g0))')tally - if(all(tally))then - write(*,'(*(g0))')'PASSED: all ',count(tally),' tests passed ' - else - write(*,*)'FAILED: PASSED=',count(tally),' FAILED=',count(.not.tally) - stop 5 - endif + write (*, '("new TEST TALLY=",*(g0))') tally + if (all(tally)) then + write (*, '(*(g0))') 'PASSED: all ', count(tally), ' tests passed ' + else + write (*, *) 'FAILED: PASSED=', count(tally), ' FAILED=', count(.not. tally) + stop 5 + end if contains function get_command_path() result(prog) character(len=:), allocatable :: prog @@ -179,17 +179,17 @@ function get_command_path() result(prog) ! FIXME: Super hacky way to get the name of the fpm executable, ! it works better than invoking fpm again but should be replaced ASAP. call get_command_argument(0, length=length) - allocate(character(len=length) :: prog) + allocate (character(len=length) :: prog) call get_command_argument(0, prog) path = dirname(prog) if (get_os_type() == OS_WINDOWS) then prog = join_path(path, "..", "app", "fpm.exe") - if (.not.exists(prog)) then + if (.not. exists(prog)) then prog = join_path(path, "..", "..", "app", "fpm.exe") end if else prog = join_path(path, "..", "app", "fpm") - if (.not.exists(prog)) then + if (.not. exists(prog)) then prog = join_path(path, "..", "..", "app", "fpm") end if end if