diff options
| -rw-r--r-- | CONTRIBUTING.md | 126 | ||||
| -rw-r--r-- | README.md | 3 | ||||
| -rwxr-xr-x | ci/run_tests.bat | 21 | ||||
| -rwxr-xr-x | ci/run_tests.sh | 10 | ||||
| -rw-r--r-- | fpm/app/main.f90 | 6 | ||||
| -rw-r--r-- | fpm/fpm.toml | 2 | ||||
| -rw-r--r-- | fpm/src/fpm.f90 | 174 | ||||
| -rw-r--r-- | fpm/src/fpm/error.f90 | 70 | ||||
| -rw-r--r-- | fpm/src/fpm/manifest/dependency.f90 | 10 | ||||
| -rw-r--r-- | fpm/src/fpm/manifest/executable.f90 | 5 | ||||
| -rw-r--r-- | fpm/src/fpm/manifest/library.f90 | 2 | ||||
| -rw-r--r-- | fpm/src/fpm/manifest/package.f90 | 5 | ||||
| -rw-r--r-- | fpm/src/fpm/manifest/test.f90 | 3 | ||||
| -rw-r--r-- | fpm/src/fpm/toml.f90 | 7 | ||||
| -rw-r--r-- | fpm/src/fpm_backend.f90 | 123 | ||||
| -rw-r--r-- | fpm/src/fpm_command_line.f90 (renamed from fpm/src/command_line.f90) | 27 | ||||
| -rw-r--r-- | fpm/src/fpm_environment.f90 (renamed from fpm/src/environment.f90) | 25 | ||||
| -rw-r--r-- | fpm/src/fpm_filesystem.f90 | 234 | ||||
| -rw-r--r-- | fpm/src/fpm_model.f90 | 65 | ||||
| -rw-r--r-- | fpm/src/fpm_sources.f90 | 589 | ||||
| -rw-r--r-- | fpm/src/fpm_strings.f90 | 217 | ||||
| -rw-r--r-- | fpm/test/main.f90 | 9 | ||||
| -rw-r--r-- | fpm/test/test_manifest.f90 | 505 | ||||
| -rw-r--r-- | fpm/test/test_source_parsing.f90 | 621 | ||||
| -rw-r--r-- | fpm/test/testsuite.f90 | 34 |
25 files changed, 2717 insertions, 176 deletions
diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 index 0000000..1332278 --- /dev/null +++ b/CONTRIBUTING.md @@ -0,0 +1,126 @@ +# Contributing to the Fortran Package Manager + +Thank you for considering contributing to the Fortran Package Manager (fpm). +Please review and follow these guidelines to make the contribution process +simple and effective for all involved. +It will help communicate that you respect the time of the community +developers. +In return, the community will help address your problem, evaluate changes, and +guide you through your pull requests. + +By contributing to fpm, you certify that you own or are allowed to share the +content of your contribution under the +[fpm license](https://github.com/fortran-lang/fpm/blob/master/LICENSE). + +* [Style](#style) +* [Reporting a bug](#reporting-a-bug) +* [Suggesting a feature](#suggesting-a-feature) +* [Workflow](#workflow) +* [General guidelines](#general-guidelines) +* [For new contributors](#for-new-contributors) + +## Style + +Please follow the +[Fortran stdlib style guide](https://github.com/fortran-lang/stdlib/blob/master/STYLE_GUIDE.md) +for any Fortran code that you contribute. +This allows us to focus on substance rather than style. + +## Reporting a bug + +A bug is a _demonstrable problem_ caused by the code in this repository. +Good bug reports are extremely valuable to us—thank you! + +Before opening a bug report: + +1. Check if the issue has already been reported. + ([issues](https://github.com/fortran-lang/fpm/issues)) +2. Check if it is still an issue or it has been fixed? + Try to reproduce it with the latest version from the master branch. +3. Isolate the problem and create a minimal test case. + +A good bug report should include all information needed to reproduce the bug. +Please be as detailed as possible: + +1. Which version of fpm are you using? Please be specific. +2. What are the steps to reproduce the issue? +3. What is the expected outcome? +4. What happens instead? + +This information will help the community diagnose the issue quickly and with +minimal back-and-forth. + +## Suggesting a feature + +Before suggesting a new feature, take a moment to find out if it fits +the scope of the project, or if it has already been discussed. +It is up to you to provide a strong argument to convince the community of the +benefits of this feature. +Please provide as much detail and context as possible. +If applicable, include a mocked-up snippet of what the output or behavior would +look like with this feature implemented. +"Crazy", out-of-the-box ideas are especially welcome. +It's quite possible that we are not considering an unusually creative solution. + +## Workflow + +fpm is a community project. +There is no one single person making final decisions. +This is the workflow that we follow: + +1. Open a [new issue](https://github.com/fortran-lang/fpm/issues/new) to + describe a bug or propose a new feature. + Refer to the earlier sections on how to write a good bug report or feature + request. +2. Discuss with the community and reach majority consensus about what should be + done about the bug or feature request. + We define "majority" loosely as 80%. + This means that at least 4 of 5 people engaged in the discussion should be + able to agree on the next step. + This allows us to have the community mostly agree while not getting stuck if + one person disagrees. + At this stage, the scope of the fix/feature, its behavior, and API if + applicable should be defined. + Only when you have community concensus on these items you should proceed + to writing code and opening a PR. + __When actively working on code towards a PR, please assign yourself to the issue on github.__ + This is good collaborative practice to avoid duplicated effort and also inform others what you + are currently working on. +3. Open a new Pull Request (PR) with your contribution. + The body of the PR should at least include a bullet-point summary of the + changes, and a detailed description is encouraged. + If the PR completely addresses the issue you opened in step 1, include in + the PR description the following line: `Fixes #<issue-number>`. +4. Request reviewers to your PR. + For small bug fixes or documentation improvements, 1 to 2 reviewers is + sufficient. + For implementation of bigger features, request 3 to 4 or more reviewers. + Ideally, request reviewers that participated in step 2. +5. If your PR implements a feature that adds or changes the behavior of fpm, + your PR must also include appropriate changes to the documentation. + +This workflow can evolve and change over time as we learn how best to work +together. +If you have an idea on how to improve the workflow itself, please open an issue +and we'll discuss it. + +## General guidelines + +* A PR should implement _only one_ feature or bug fix. +* Do not commit changes to files that are irrelevant to your feature or bug fix. +* Smaller PRs are better than large PRs, and will lead to a shorter review and + merge cycle +* Add tests for your feature or bug fix to be sure that it stays functional and useful +* Be open to constructive criticism and requests for improving your code. +* Again, please follow the + [Fortran stdlib style guide](https://github.com/fortran-lang/stdlib/blob/master/STYLE_GUIDE.md). + +## For New Contributors + +If you have never created a pull request before, welcome :tada:. +You can learn how from +[this great tutorial](https://egghead.io/series/how-to-contribute-to-an-open-source-project-on-github). + +Don't know where to start? +You can start by looking through the list of +[open issues](https://github.com/fortran-lang/fpm/issues). @@ -12,6 +12,9 @@ Please follow the [issues](https://github.com/fortran-lang/fpm/issues) to contribute and/or stay up to date with the development. As the prototype matures and we enter production, we will do our best to stay backwards compatible. +To report a bug report or suggest a feature, please read our +[contributor guidelines](CONTRIBUTING.md). + ## Getting started ### Install Haskell diff --git a/ci/run_tests.bat b/ci/run_tests.bat index 33d7071..9435e0d 100755 --- a/ci/run_tests.bat +++ b/ci/run_tests.bat @@ -21,5 +21,24 @@ if errorlevel 1 exit 1 ..\..\..\fpm\build\gfortran_debug\app\fpm build if errorlevel 1 exit 1 -.\hello_world +.\build\gfortran_debug\app\hello_world if errorlevel 1 exit 1 + + +cd ..\hello_complex +if errorlevel 1 exit 1 + +..\..\..\fpm\build\gfortran_debug\app\fpm build +if errorlevel 1 exit 1 + +.\build\gfortran_debug\app\say_Hello +if errorlevel 1 exit 1 + +.\build\gfortran_debug\app\say_goodbye +if errorlevel 1 exit 1 + +.\build\gfortran_debug\test\greet_test +if errorlevel 1 exit 1 + +.\build\gfortran_debug\test\farewell_test +if errorlevel 1 exit 1
\ No newline at end of file diff --git a/ci/run_tests.sh b/ci/run_tests.sh index c740cd8..3033c2a 100755 --- a/ci/run_tests.sh +++ b/ci/run_tests.sh @@ -7,6 +7,14 @@ fpm build fpm run fpm test build/gfortran_debug/app/fpm + cd ../test/example_packages/hello_world ../../../fpm/build/gfortran_debug/app/fpm build -./hello_world +./build/gfortran_debug/app/hello_world + +cd ../hello_complex +../../../fpm/build/gfortran_debug/app/fpm build +./build/gfortran_debug/app/say_Hello +./build/gfortran_debug/app/say_goodbye +./build/gfortran_debug/test/greet_test +./build/gfortran_debug/test/farewell_test
\ No newline at end of file diff --git a/fpm/app/main.f90 b/fpm/app/main.f90 index 30abf5b..c7f9786 100644 --- a/fpm/app/main.f90 +++ b/fpm/app/main.f90 @@ -1,5 +1,5 @@ program main -use command_line, only: & +use fpm_command_line, only: & fpm_cmd_settings, & fpm_new_settings, & fpm_build_settings, & @@ -15,11 +15,11 @@ class(fpm_cmd_settings), allocatable :: cmd_settings call get_command_line_settings(cmd_settings) -select type(cmd_settings) +select type(settings=>cmd_settings) type is (fpm_new_settings) call cmd_new() type is (fpm_build_settings) - call cmd_build() + call cmd_build(settings) type is (fpm_run_settings) call cmd_run() type is (fpm_test_settings) diff --git a/fpm/fpm.toml b/fpm/fpm.toml index b39d881..d29994a 100644 --- a/fpm/fpm.toml +++ b/fpm/fpm.toml @@ -8,7 +8,7 @@ copyright = "2020 fpm contributors" [dependencies] [dependencies.toml-f] git = "https://github.com/toml-f/toml-f" -rev = "290ba87671ab593e7bd51599e1d80ea736b3cd36" +tag = "v0.2" [[test]] name = "fpm-test" diff --git a/fpm/src/fpm.f90 b/fpm/src/fpm.f90 index 9c8918b..b57a713 100644 --- a/fpm/src/fpm.f90 +++ b/fpm/src/fpm.f90 @@ -1,99 +1,83 @@ module fpm -use environment, only: get_os_type, OS_LINUX, OS_MACOS, OS_WINDOWS -use fpm_manifest, only : get_package_data, default_executable, default_library, & - & package_t + +use fpm_strings, only: string_t, str_ends_with +use fpm_backend, only: build_package +use fpm_command_line, only: fpm_build_settings +use fpm_environment, only: run, get_os_type, OS_LINUX, OS_MACOS, OS_WINDOWS +use fpm_filesystem, only: join_path, number_of_rows, list_files, exists +use fpm_model, only: srcfile_ptr, srcfile_t, fpm_model_t +use fpm_sources, only: add_executable_sources, add_sources_from_dir, & + resolve_module_dependencies +use fpm_manifest, only : get_package_data, default_executable, & + default_library, package_t use fpm_error, only : error_t implicit none private public :: cmd_build, cmd_install, cmd_new, cmd_run, cmd_test -type string_t - character(len=:), allocatable :: s -end type contains -integer function number_of_rows(s) result(nrows) -! determine number or rows -integer,intent(in)::s -integer :: ios -character(len=100) :: r -rewind(s) -nrows = 0 -do - read(s, *, iostat=ios) r - if (ios /= 0) exit - nrows = nrows + 1 -end do -rewind(s) -end function - - -subroutine list_files(dir, files) -character(len=*), intent(in) :: dir -type(string_t), allocatable, intent(out) :: files(:) -character(len=100) :: filename -integer :: stat, u, i -! Using `inquire` / exists on directories works with gfortran, but not ifort -if (.not. exists(dir)) then - allocate(files(0)) - return -end if -select case (get_os_type()) - case (OS_LINUX) - call execute_command_line("ls " // dir // " > fpm_ls.out", exitstat=stat) - case (OS_MACOS) - call execute_command_line("ls " // dir // " > fpm_ls.out", exitstat=stat) - case (OS_WINDOWS) - call execute_command_line("dir /b " // dir // " > fpm_ls.out", exitstat=stat) -end select -if (stat /= 0) then - print *, "execute_command_line() failed" - error stop -end if -open(newunit=u, file="fpm_ls.out", status="old") -allocate(files(number_of_rows(u))) -do i = 1, size(files) - read(u, *) filename - files(i)%s = trim(filename) -end do -close(u) -end subroutine +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 + type(fpm_build_settings), intent(in) :: settings + type(package_t), intent(in) :: package + type(error_t), allocatable, intent(out) :: error + + model%package_name = package%name + + ! #TODO: Choose flags and output directory based on cli settings & manifest inputs + model%fortran_compiler = 'gfortran' + model%output_directory = 'build/gfortran_debug' + model%fortran_compile_flags = ' -Wall -Wextra -Wimplicit-interface -fPIC -fmax-errors=1 -g '// & + '-fbounds-check -fcheck-array-temporaries -fbacktrace '// & + '-J'//join_path(model%output_directory,model%package_name) + model%link_flags = '' + + ! Add sources from executable directories + if (allocated(package%executable)) then + + call add_executable_sources(model%sources, package%executable, & + is_test=.false., error=error) + + if (allocated(error)) then + return + end if -subroutine run(cmd) -character(len=*), intent(in) :: cmd -integer :: stat -print *, "+ ", cmd -call execute_command_line(cmd, exitstat=stat) -if (stat /= 0) then - print *, "Command failed" - error stop -end if -end subroutine + end if + if (allocated(package%test)) then -logical function exists(filename) result(r) -character(len=*), intent(in) :: filename -inquire(file=filename, exist=r) -end function - -logical function str_ends_with(s, e) result(r) -character(*), intent(in) :: s, e -integer :: n1, n2 -n1 = len(s)-len(e)+1 -n2 = len(s) -if (n1 < 1) then - r = .false. -else - r = (s(n1:n2) == e) -end if -end function + call add_executable_sources(model%sources, package%test, & + is_test=.true., error=error) + + if (allocated(error)) then + return + end if + + end if + + if (allocated(package%library)) then -subroutine cmd_build() + call add_sources_from_dir(model%sources,package%library%source_dir, & + error=error) + + if (allocated(error)) then + return + end if + + end if + + call resolve_module_dependencies(model%sources) + +end subroutine build_model + +subroutine cmd_build(settings) +type(fpm_build_settings), intent(in) :: settings type(package_t) :: package +type(fpm_model_t) :: model type(error_t), allocatable :: error -type(string_t), allocatable :: files(:) -character(:), allocatable :: basename, linking -integer :: i, n call get_package_data(package, "fpm.toml", error) if (allocated(error)) then print '(a)', error%message @@ -102,6 +86,7 @@ end if ! Populate library in case we find the default src directory if (.not.allocated(package%library) .and. exists("src")) then + allocate(package%library) call default_library(package%library) end if @@ -116,27 +101,14 @@ if (.not.(allocated(package%library) .or. allocated(package%executable))) then error stop 1 end if -linking = "" -if (allocated(package%library)) then - call list_files(package%library%source_dir, files) - do i = 1, size(files) - if (str_ends_with(files(i)%s, ".f90")) then - n = len(files(i)%s) - basename = files(i)%s - call run("gfortran -c " // package%library%source_dir // "/" // & - & basename // " -o " // basename // ".o") - linking = linking // " " // basename // ".o" - end if - end do +call build_model(model, settings, package, error) +if (allocated(error)) then + print '(a)', error%message + error stop 1 end if -do i = 1, size(package%executable) - basename = package%executable(i)%main - call run("gfortran -c " // package%executable(i)%source_dir // "/" // & - & basename // " -o " // basename // ".o") - call run("gfortran " // basename // ".o " // linking // " -o " // & - & package%executable(i)%name) -end do +call build_package(model) + end subroutine subroutine cmd_install() diff --git a/fpm/src/fpm/error.f90 b/fpm/src/fpm/error.f90 index aebd7e4..e69ff1e 100644 --- a/fpm/src/fpm/error.f90 +++ b/fpm/src/fpm/error.f90 @@ -5,6 +5,7 @@ module fpm_error public :: error_t public :: fatal_error, syntax_error, file_not_found_error + public :: file_parse_error !> Data type defining an error @@ -55,4 +56,73 @@ contains 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) + + !> Instance of the error data + type(error_t), allocatable, intent(out) :: error + + !> Name of file + character(len=*), intent(in) :: file_name + + !> Parse error message + character(len=*), intent(in) :: message + + !> Line number of parse error + integer, intent(in), optional :: line_num + + !> Line context string + character(len=*), intent(in), optional :: line_string + + !> Line context column + integer, intent(in), optional :: line_col + + character(50) :: temp_string + + allocate(error) + error%message = 'Parse error: '//message//new_line('a') + + error%message = error%message//file_name + + if (present(line_num)) then + + write(temp_string,'(I0)') line_num + + error%message = error%message//':'//trim(temp_string) + + end if + + if (present(line_col)) then + + if (line_col > 0) then + + write(temp_string,'(I0)') line_col + error%message = error%message//':'//trim(temp_string) + + end if + + end if + + if (present(line_string)) then + + error%message = error%message//new_line('a') + error%message = error%message//' | '//line_string + + if (present(line_col)) then + + if (line_col > 0) then + + error%message = error%message//new_line('a') + error%message = error%message//' | '//repeat(' ',line_col-1)//'^' + + end if + + end if + + end if + + end subroutine file_parse_error + + end module fpm_error diff --git a/fpm/src/fpm/manifest/dependency.f90 b/fpm/src/fpm/manifest/dependency.f90 index 8a3d879..599d43a 100644 --- a/fpm/src/fpm/manifest/dependency.f90 +++ b/fpm/src/fpm/manifest/dependency.f90 @@ -94,7 +94,7 @@ contains end if if (.not.allocated(self%git)) then - call get_value(table, "revision", obj) + call get_value(table, "rev", obj) if (allocated(obj)) then self%git = git_target_revision(url, obj) end if @@ -120,9 +120,10 @@ contains character(len=:), allocatable :: name type(toml_key), allocatable :: list(:) - logical :: url_present, git_target_present + logical :: url_present, git_target_present, has_path integer :: ikey + has_path = .false. url_present = .false. git_target_present = .false. @@ -146,6 +147,7 @@ contains exit end if url_present = .true. + has_path = list(ikey)%key == 'path' case("branch", "rev", "tag") if (git_target_present) then @@ -163,7 +165,7 @@ contains return end if - if (.not.url_present .and. git_target_present) then + 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 @@ -182,7 +184,7 @@ contains !> Error handling type(error_t), allocatable, intent(out) :: error - class(toml_table), pointer :: node + type(toml_table), pointer :: node type(toml_key), allocatable :: list(:) integer :: idep, stat diff --git a/fpm/src/fpm/manifest/executable.f90 b/fpm/src/fpm/manifest/executable.f90 index f706001..6675519 100644 --- a/fpm/src/fpm/manifest/executable.f90 +++ b/fpm/src/fpm/manifest/executable.f90 @@ -57,7 +57,7 @@ contains !> Error handling type(error_t), allocatable, intent(out) :: error - class(toml_table), pointer :: child + type(toml_table), pointer :: child call check(table, error) if (allocated(error)) return @@ -104,7 +104,7 @@ contains do ikey = 1, size(list) select case(list(ikey)%key) case default - call syntax_error(error, "Key "//list(ikey)%key//" is not allowed executable entry") + call syntax_error(error, "Key "//list(ikey)%key//" is not allowed as executable entry") exit case("name") @@ -115,6 +115,7 @@ contains end select end do + if (allocated(error)) return if (.not.name_present) then call syntax_error(error, "Executable name is not provided, please add a name entry") diff --git a/fpm/src/fpm/manifest/library.f90 b/fpm/src/fpm/manifest/library.f90 index 40e5e92..7a79a2a 100644 --- a/fpm/src/fpm/manifest/library.f90 +++ b/fpm/src/fpm/manifest/library.f90 @@ -77,7 +77,7 @@ contains 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") + call syntax_error(error, "Key "//list(ikey)%key//" is not allowed in library") exit case("source-dir", "build-script") diff --git a/fpm/src/fpm/manifest/package.f90 b/fpm/src/fpm/manifest/package.f90 index 4c2c14a..dff81e5 100644 --- a/fpm/src/fpm/manifest/package.f90 +++ b/fpm/src/fpm/manifest/package.f90 @@ -85,8 +85,8 @@ contains !> Error handling type(error_t), allocatable, intent(out) :: error - class(toml_table), pointer :: child, node - class(toml_array), pointer :: children + type(toml_table), pointer :: child, node + type(toml_array), pointer :: children integer :: ii, nn, stat call check(table, error) @@ -184,6 +184,7 @@ contains name_present = .true. case("version", "license", "author", "maintainer", "copyright", & + & "description", "keywords", "categories", "homepage", & & "dependencies", "dev-dependencies", "test", "executable", & & "library") continue diff --git a/fpm/src/fpm/manifest/test.f90 b/fpm/src/fpm/manifest/test.f90 index a6c6f64..de4c847 100644 --- a/fpm/src/fpm/manifest/test.f90 +++ b/fpm/src/fpm/manifest/test.f90 @@ -50,7 +50,7 @@ contains !> Error handling type(error_t), allocatable, intent(out) :: error - class(toml_table), pointer :: child + type(toml_table), pointer :: child call check(table, error) if (allocated(error)) return @@ -108,6 +108,7 @@ contains end select end do + if (allocated(error)) return if (.not.name_present) then call syntax_error(error, "Test name is not provided, please add a name entry") diff --git a/fpm/src/fpm/toml.f90 b/fpm/src/fpm/toml.f90 index 183278d..e2445c4 100644 --- a/fpm/src/fpm/toml.f90 +++ b/fpm/src/fpm/toml.f90 @@ -14,14 +14,13 @@ module fpm_toml use fpm_error, only : error_t, fatal_error, file_not_found_error use tomlf, only : toml_table, toml_array, toml_key, toml_stat, get_value, & - & toml_parse, toml_error - use tomlf_type, only : new_table, len + & set_value, toml_parse, toml_error, new_table, add_table, add_array, len implicit none private public :: read_package_file - public :: toml_table, toml_array, toml_key, toml_stat, get_value - public :: new_table, len + public :: toml_table, toml_array, toml_key, toml_stat, get_value, set_value + public :: new_table, add_table, add_array, len contains diff --git a/fpm/src/fpm_backend.f90 b/fpm/src/fpm_backend.f90 new file mode 100644 index 0000000..62fd242 --- /dev/null +++ b/fpm/src/fpm_backend.f90 @@ -0,0 +1,123 @@ +module fpm_backend + +! Implements the native fpm build backend + +use fpm_environment, only: run +use fpm_filesystem, only: basename, join_path, exists, mkdir +use fpm_model, only: fpm_model_t, srcfile_t, FPM_UNIT_MODULE, & + FPM_UNIT_SUBMODULE, FPM_UNIT_SUBPROGRAM, & + FPM_UNIT_CSOURCE, FPM_UNIT_PROGRAM +use fpm_strings, only: split + +implicit none + +private +public :: build_package + +contains + + +subroutine build_package(model) + type(fpm_model_t), intent(inout) :: model + + integer :: i + character(:), allocatable :: base, linking, subdir + + if (.not.exists(model%output_directory)) then + call mkdir(model%output_directory) + end if + if (.not.exists(join_path(model%output_directory,model%package_name))) then + call mkdir(join_path(model%output_directory,model%package_name)) + end if + + linking = "" + do i=1,size(model%sources) + + if (model%sources(i)%unit_type == FPM_UNIT_MODULE .or. & + model%sources(i)%unit_type == FPM_UNIT_SUBMODULE .or. & + model%sources(i)%unit_type == FPM_UNIT_SUBPROGRAM .or. & + model%sources(i)%unit_type == FPM_UNIT_CSOURCE) then + + call build_source(model,model%sources(i),linking) + + end if + + end do + + if (any([(model%sources(i)%unit_type == FPM_UNIT_PROGRAM,i=1,size(model%sources))])) then + if (.not.exists(join_path(model%output_directory,'test'))) then + call mkdir(join_path(model%output_directory,'test')) + end if + if (.not.exists(join_path(model%output_directory,'app'))) then + call mkdir(join_path(model%output_directory,'app')) + end if + end if + + do i=1,size(model%sources) + + if (model%sources(i)%unit_type == FPM_UNIT_PROGRAM) then + + base = basename(model%sources(i)%file_name,suffix=.false.) + + if (model%sources(i)%is_test) then + subdir = 'test' + else + subdir = 'app' + end if + + call run("gfortran -c " // model%sources(i)%file_name // ' '//model%fortran_compile_flags & + // " -o " // join_path(model%output_directory,subdir,base) // ".o") + + call run("gfortran " // join_path(model%output_directory, subdir, base) // ".o "// & + linking //" " //model%link_flags // " -o " // & + join_path(model%output_directory,subdir,model%sources(i)%exe_name) ) + + end if + + end do + +end subroutine build_package + + + +recursive subroutine build_source(model,source_file,linking) + ! Compile Fortran source, called recursively on it dependents + ! + type(fpm_model_t), intent(in) :: model + type(srcfile_t), intent(inout) :: source_file + character(:), allocatable, intent(inout) :: linking + + integer :: i + character(:), allocatable :: object_file + + if (source_file%built) then + return + end if + + if (source_file%touched) then + write(*,*) '(!) Circular dependency found with: ',source_file%file_name + stop + else + source_file%touched = .true. + end if + + do i=1,size(source_file%file_dependencies) + + if (associated(source_file%file_dependencies(i)%ptr)) then + call build_source(model,source_file%file_dependencies(i)%ptr,linking) + end if + + end do + + object_file = join_path(model%output_directory, model%package_name, & + basename(source_file%file_name,suffix=.false.)//'.o') + + call run("gfortran -c " // source_file%file_name // model%fortran_compile_flags & + // " -o " // object_file) + linking = linking // " " // object_file + + source_file%built = .true. + +end subroutine build_source + +end module fpm_backend diff --git a/fpm/src/command_line.f90 b/fpm/src/fpm_command_line.f90 index cd78904..5e9daee 100644 --- a/fpm/src/command_line.f90 +++ b/fpm/src/fpm_command_line.f90 @@ -1,28 +1,35 @@ -module command_line - use environment, only: get_os_type, OS_LINUX, OS_MACOS, OS_WINDOWS +module fpm_command_line + use fpm_environment, only: get_os_type, OS_LINUX, OS_MACOS, OS_WINDOWS implicit none + private + public :: fpm_cmd_settings, & + fpm_build_settings, & + fpm_install_settings, & + fpm_new_settings, & + fpm_run_settings, & + fpm_test_settings, & + get_command_line_settings - type, public, abstract :: fpm_cmd_settings + type, abstract :: fpm_cmd_settings end type - type, public, extends(fpm_cmd_settings) :: fpm_new_settings + type, extends(fpm_cmd_settings) :: fpm_new_settings end type - type, public, extends(fpm_cmd_settings) :: fpm_build_settings + type, extends(fpm_cmd_settings) :: fpm_build_settings end type - type, public, extends(fpm_cmd_settings) :: fpm_run_settings + type, extends(fpm_cmd_settings) :: fpm_run_settings end type - type, public, extends(fpm_cmd_settings) :: fpm_test_settings + type, extends(fpm_cmd_settings) :: fpm_test_settings end type - type, public, extends(fpm_cmd_settings) :: fpm_install_settings + type, extends(fpm_cmd_settings) :: fpm_install_settings end type - public :: get_command_line_settings contains subroutine get_command_line_settings(cmd_settings) class(fpm_cmd_settings), allocatable, intent(out) :: cmd_settings @@ -75,4 +82,4 @@ contains print *, " run Run a binary of the local package (not implemented)" print *, " test Run the tests (not implemented)" end subroutine -end module command_line +end module fpm_command_line diff --git a/fpm/src/environment.f90 b/fpm/src/fpm_environment.f90 index 9190eb6..9ac42ac 100644 --- a/fpm/src/environment.f90 +++ b/fpm/src/fpm_environment.f90 @@ -1,12 +1,13 @@ -module environment +module fpm_environment implicit none private + public :: get_os_type, run + public :: OS_LINUX, OS_MACOS, OS_WINDOWS - integer, parameter, public :: OS_LINUX = 1 - integer, parameter, public :: OS_MACOS = 2 - integer, parameter, public :: OS_WINDOWS = 3 + integer, parameter :: OS_LINUX = 1 + integer, parameter :: OS_MACOS = 2 + integer, parameter :: OS_WINDOWS = 3 - public :: get_os_type contains integer function get_os_type() result(r) ! Determine the OS type @@ -51,4 +52,16 @@ contains r = OS_LINUX end if end function -end module + + subroutine run(cmd) + character(len=*), intent(in) :: cmd + integer :: stat + print *, "+ ", cmd + call execute_command_line(cmd, exitstat=stat) + if (stat /= 0) then + print *, "Command failed" + error stop + end if + end subroutine run + +end module fpm_environment diff --git a/fpm/src/fpm_filesystem.f90 b/fpm/src/fpm_filesystem.f90 new file mode 100644 index 0000000..d5c8e67 --- /dev/null +++ b/fpm/src/fpm_filesystem.f90 @@ -0,0 +1,234 @@ +module fpm_filesystem +use fpm_environment, only: get_os_type, OS_LINUX, OS_MACOS, OS_WINDOWS +use fpm_strings, only: f_string, string_t, split +implicit none + +private +public :: basename, join_path, number_of_rows, read_lines, list_files,& + mkdir, exists, get_temp_filename, windows_path + +integer, parameter :: LINE_BUFFER_LEN = 1000 + +contains + + +function basename(path,suffix) result (base) + ! Extract filename from path with/without suffix + ! + character(*), intent(In) :: path + logical, intent(in), optional :: suffix + character(:), allocatable :: base + + character(:), allocatable :: file_parts(:) + logical :: with_suffix + + if (.not.present(suffix)) then + with_suffix = .true. + else + with_suffix = suffix + end if + + if (with_suffix) then + call split(path,file_parts,delimiters='\/') + base = trim(file_parts(size(file_parts))) + else + call split(path,file_parts,delimiters='\/.') + base = trim(file_parts(size(file_parts)-1)) + end if + +end function basename + + +function join_path(a1,a2,a3,a4,a5) result(path) + ! Construct path by joining strings with os file separator + ! + character(*), intent(in) :: a1, a2 + character(*), intent(in), optional :: a3,a4,a5 + character(:), allocatable :: path + + character(1) :: filesep + + select case (get_os_type()) + case (OS_LINUX,OS_MACOS) + filesep = '/' + case (OS_WINDOWS) + filesep = '\' + end select + + path = a1 // filesep // a2 + + if (present(a3)) then + path = path // filesep // a3 + else + return + end if + + if (present(a4)) then + path = path // filesep // a4 + else + return + end if + + if (present(a5)) then + path = path // filesep // a5 + else + return + end if + +end function join_path + + +integer function number_of_rows(s) result(nrows) + ! determine number or rows + integer,intent(in)::s + integer :: ios + character(len=100) :: r + rewind(s) + nrows = 0 + do + read(s, '(A)', iostat=ios) r + if (ios /= 0) exit + nrows = nrows + 1 + end do + rewind(s) +end function number_of_rows + + +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))) + do i = 1, size(lines) + read(fh, '(A)') line_buffer + lines(i)%s = trim(line_buffer) + end do + +end function read_lines + +subroutine mkdir(dir) + character(*), intent(in) :: dir + + integer :: stat + + select case (get_os_type()) + case (OS_LINUX,OS_MACOS) + call execute_command_line("mkdir -p " // dir , exitstat=stat) + write(*,*) "mkdir -p " // dir + case (OS_WINDOWS) + call execute_command_line("mkdir " // windows_path(dir), exitstat=stat) + write(*,*) "mkdir " // windows_path(dir) + end select + if (stat /= 0) then + print *, "execute_command_line() failed" + error stop + end if + +end subroutine mkdir + + +subroutine list_files(dir, files) + character(len=*), intent(in) :: dir + type(string_t), allocatable, intent(out) :: files(:) + + integer :: stat, fh + character(:), allocatable :: temp_file + + ! Using `inquire` / exists on directories works with gfortran, but not ifort + if (.not. exists(dir)) then + allocate(files(0)) + return + end if + + allocate(temp_file, source = get_temp_filename() ) + + select case (get_os_type()) + case (OS_LINUX) + call execute_command_line("ls " // dir // " > "//temp_file, & + exitstat=stat) + case (OS_MACOS) + call execute_command_line("ls " // 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 + print *, "execute_command_line() failed" + error stop + end if + + open(newunit=fh, file=temp_file, status="old") + files = read_lines(fh) + close(fh,status="delete") + +end subroutine list_files + + +logical function exists(filename) result(r) + character(len=*), intent(in) :: filename + inquire(file=filename, exist=r) +end function + + +function get_temp_filename() result(tempfile) + ! 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 + ! + use iso_c_binding, only: c_ptr, C_NULL_PTR, c_f_pointer + character(:), allocatable :: tempfile + + type(c_ptr) :: c_tempfile_ptr + character(len=1), pointer :: c_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 + + 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]) + + tempfile = f_string(c_tempfile) + + call c_free(c_tempfile_ptr) + +end function get_temp_filename + + +function windows_path(path) result(winpath) + ! Replace file system separators for windows + ! + character(*), intent(in) :: path + character(:), allocatable :: winpath + + integer :: idx + + winpath = path + + idx = index(winpath,'/') + do while(idx > 0) + winpath(idx:idx) = '\' + idx = index(winpath,'/') + end do + +end function windows_path + +end module fpm_filesystem diff --git a/fpm/src/fpm_model.f90 b/fpm/src/fpm_model.f90 new file mode 100644 index 0000000..702ba6f --- /dev/null +++ b/fpm/src/fpm_model.f90 @@ -0,0 +1,65 @@ +module fpm_model +! Definition and validation of the backend model +use fpm_strings, only: string_t +implicit none + +private +public :: srcfile_ptr, srcfile_t, fpm_model_t + +public :: FPM_UNIT_UNKNOWN, FPM_UNIT_PROGRAM, FPM_UNIT_MODULE, & + FPM_UNIT_SUBMODULE, FPM_UNIT_SUBPROGRAM, FPM_UNIT_CSOURCE, & + FPM_UNIT_CHEADER + +integer, parameter :: FPM_UNIT_UNKNOWN = -1 +integer, parameter :: FPM_UNIT_PROGRAM = 1 +integer, parameter :: FPM_UNIT_MODULE = 2 +integer, parameter :: FPM_UNIT_SUBMODULE = 3 +integer, parameter :: FPM_UNIT_SUBPROGRAM = 4 +integer, parameter :: FPM_UNIT_CSOURCE = 5 +integer, parameter :: FPM_UNIT_CHEADER = 6 + +type srcfile_ptr + ! For constructing arrays of src_file pointers + type(srcfile_t), pointer :: ptr => null() +end type srcfile_ptr + +type srcfile_t + ! Type for encapsulating a source file + ! and it's metadata + character(:), allocatable :: file_name + ! File path relative to cwd + character(:), allocatable :: exe_name + ! Name of executable for FPM_UNIT_PROGRAM + logical :: is_test = .false. + ! Is executable a test? + type(string_t), allocatable :: modules_provided(:) + ! Modules provided by this source file (lowerstring) + integer :: unit_type = FPM_UNIT_UNKNOWN + ! Type of program unit + type(string_t), allocatable :: modules_used(:) + ! Modules USEd by this source file (lowerstring) + type(string_t), allocatable :: include_dependencies(:) + ! Files INCLUDEd by this source file + type(srcfile_ptr), allocatable :: file_dependencies(:) + ! Resolved source file dependencies + + logical :: built = .false. + logical :: touched = .false. +end type srcfile_t + +type :: fpm_model_t + character(:), allocatable :: package_name + ! Name of package + type(srcfile_t), allocatable :: sources(:) + ! Array of sources with module-dependencies resolved + character(:), allocatable :: fortran_compiler + ! Command line name to invoke fortran compiler + character(:), allocatable :: fortran_compile_flags + ! Command line flags passed to fortran for compilation + character(:), allocatable :: link_flags + ! Command line flags pass for linking + character(:), allocatable :: output_directory + ! Base directory for build +end type fpm_model_t + +end module fpm_model diff --git a/fpm/src/fpm_sources.f90 b/fpm/src/fpm_sources.f90 new file mode 100644 index 0000000..787efff --- /dev/null +++ b/fpm/src/fpm_sources.f90 @@ -0,0 +1,589 @@ +module fpm_sources +use fpm_error, only: error_t, file_parse_error +use fpm_model, only: srcfile_ptr, srcfile_t, fpm_model_t, & + FPM_UNIT_UNKNOWN, FPM_UNIT_PROGRAM, FPM_UNIT_MODULE, & + FPM_UNIT_SUBMODULE, FPM_UNIT_SUBPROGRAM, & + FPM_UNIT_CSOURCE, FPM_UNIT_CHEADER +use fpm_filesystem, only: basename, read_lines, list_files +use fpm_strings, only: lower, split, str_ends_with, string_t, operator(.in.) +use fpm_manifest_executable, only: executable_t +implicit none + +private +public :: add_sources_from_dir, add_executable_sources +public :: parse_f_source, parse_c_source, resolve_module_dependencies + +character(15), parameter :: INTRINSIC_MODULE_NAMES(*) = & + ['iso_c_binding ', & + 'iso_fortran_env', & + 'ieee_arithmetic', & + 'ieee_exceptions', & + 'ieee_features '] + +contains + +subroutine add_sources_from_dir(sources,directory,with_executables,error) + ! Enumerate sources in a directory + ! + type(srcfile_t), allocatable, intent(inout), target :: sources(:) + character(*), intent(in) :: directory + logical, intent(in), optional :: with_executables + type(error_t), allocatable, intent(out) :: error + + integer :: i, j + logical, allocatable :: is_source(:), exclude_source(:) + type(string_t), allocatable :: file_names(:) + type(string_t), allocatable :: src_file_names(:) + type(srcfile_t), allocatable :: dir_sources(:) + + ! Scan directory for sources + call list_files(directory, file_names) + file_names = [(string_t(directory//'/'//file_names(j)%s),j=1,size(file_names))] + + is_source = [(str_ends_with(lower(file_names(i)%s), ".f90") .or. & + str_ends_with(lower(file_names(i)%s), ".c") .or. & + str_ends_with(lower(file_names(i)%s), ".h"),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))) + + do i = 1, size(src_file_names) + + if (str_ends_with(lower(src_file_names(i)%s), ".f90")) then + + dir_sources(i) = parse_f_source(src_file_names(i)%s, error) + + if (allocated(error)) then + return + end if + + end if + + if (str_ends_with(lower(src_file_names(i)%s), ".c") .or. & + str_ends_with(lower(src_file_names(i)%s), ".h")) then + + dir_sources(i) = parse_c_source(src_file_names(i)%s,error) + + if (allocated(error)) then + return + end if + + end if + + ! 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. + dir_sources(i)%exe_name = basename(src_file_names(i)%s,suffix=.false.) + + end if + end if + + end do + + if (.not.allocated(sources)) then + sources = pack(dir_sources,.not.exclude_source) + else + sources = [sources, pack(dir_sources,.not.exclude_source)] + end if + +end subroutine add_sources_from_dir + + +subroutine add_executable_sources(sources,executables,is_test,error) + ! Add sources from executable directories specified in manifest + ! Only allow executables that are explicitly specified in manifest + ! + type(srcfile_t), allocatable, intent(inout), target :: sources(:) + class(executable_t), intent(in) :: executables(:) + logical, intent(in) :: is_test + type(error_t), allocatable, intent(out) :: error + + integer :: i, j + + type(string_t), allocatable :: exe_dirs(:) + logical, allocatable :: exclude_source(:) + type(srcfile_t), allocatable :: dir_sources(:) + + call get_executable_source_dirs(exe_dirs,executables) + + do i=1,size(exe_dirs) + + call add_sources_from_dir(dir_sources,exe_dirs(i)%s, & + with_executables=.true.,error=error) + + if (allocated(error)) then + return + end if + + end do + + allocate(exclude_source(size(dir_sources))) + + do i = 1, size(dir_sources) + + ! Only allow executables in 'executables' list + exclude_source(i) = (dir_sources(i)%unit_type == FPM_UNIT_PROGRAM) + + do j=1,size(executables) + if (basename(dir_sources(i)%file_name,suffix=.true.) == & + executables(j)%main) then + exclude_source(i) = .false. + dir_sources(i)%exe_name = executables(j)%name + dir_sources(i)%is_test = is_test + exit + end if + end do + + end do + + if (.not.allocated(sources)) then + sources = pack(dir_sources,.not.exclude_source) + else + sources = [sources, pack(dir_sources,.not.exclude_source)] + end if + +end subroutine add_executable_sources + + +subroutine get_executable_source_dirs(exe_dirs,executables) + ! Build a list of unique source directories + ! from executables specified in manifest + type(string_t), allocatable, intent(inout) :: exe_dirs(:) + class(executable_t), intent(in) :: executables(:) + + type(string_t) :: dirs_temp(size(executables)) + + integer :: i, n + + n = 0 + 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 + + end if + end do + + if (.not.allocated(exe_dirs)) then + exe_dirs = dirs_temp(1:n) + else + exe_dirs = [exe_dirs,dirs_temp(1:n)] + end if + +end subroutine get_executable_source_dirs + + +function parse_f_source(f_filename,error) result(f_source) + ! Rudimentary scan of Fortran source file and + ! extract program unit name and use/include dependencies + ! + character(*), intent(in) :: f_filename + type(srcfile_t) :: f_source + type(error_t), allocatable, intent(out) :: error + + integer :: stat + integer :: fh, n_use, n_include, n_mod, i, j, ic, pass + type(string_t), allocatable :: file_lines(:) + character(:), allocatable :: temp_string, mod_name + + f_source%file_name = f_filename + + open(newunit=fh,file=f_filename,status='old') + file_lines = read_lines(fh) + close(fh) + + do pass = 1,2 + n_use = 0 + n_include = 0 + n_mod = 0 + file_loop: do i=1,size(file_lines) + + ! Skip lines that are continued: not statements + if (i > 1) then + ic = index(file_lines(i-1)%s,'!') + if (ic < 1) then + ic = len(file_lines(i-1)%s) + end if + temp_string = trim(file_lines(i-1)%s(1:ic)) + if (len(temp_string) > 0 .and. index(temp_string,'&') == len(temp_string)) then + cycle + end if + end if + + ! Process 'USE' statements + if (index(adjustl(lower(file_lines(i)%s)),'use ') == 1 .or. & + index(adjustl(lower(file_lines(i)%s)),'use::') == 1) then + + if (index(file_lines(i)%s,'::') > 0) then + + temp_string = split_n(file_lines(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(i)%s,index(file_lines(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(i)%s) + return + end if + mod_name = lower(mod_name) + + else + + mod_name = 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 used module name',i, & + file_lines(i)%s) + return + end if + mod_name = lower(mod_name) + + end if + + if (.not.validate_name(mod_name)) then + cycle + end if + + if (any([(index(mod_name,trim(INTRINSIC_MODULE_NAMES(j)))>0, & + j=1,size(INTRINSIC_MODULE_NAMES))])) then + cycle + end if + + n_use = n_use + 1 + + if (pass == 2) then + + f_source%modules_used(n_use)%s = mod_name + + end if + + end if + + ! Process 'INCLUDE' statements + if (index(adjustl(lower(file_lines(i)%s)),'include') == 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 + + end if + + ! Extract name of module if is module + if (index(adjustl(lower(file_lines(i)%s)),'module ') == 1) then + + mod_name = lower(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 module name',i, & + file_lines(i)%s) + return + end if + + if (mod_name == 'procedure' .or. & + mod_name == 'subroutine' .or. & + mod_name == 'function') then + ! Ignore these cases + cycle + end if + + if (.not.validate_name(mod_name)) then + call file_parse_error(error,f_filename, & + 'empty or invalid name for module',i, & + file_lines(i)%s) + return + end if + + n_mod = n_mod + 1 + + if (pass == 2) then + f_source%modules_provided(n_mod) = string_t(mod_name) + end if + + f_source%unit_type = FPM_UNIT_MODULE + + end if + + ! Extract name of submodule if is submodule + if (index(adjustl(lower(file_lines(i)%s)),'submodule') == 1) then + + temp_string = split_n(file_lines(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(i)%s) + return + end if + + f_source%unit_type = FPM_UNIT_SUBMODULE + + n_use = n_use + 1 + + if (pass == 2) then + + if (index(temp_string,':') > 0) then + + temp_string = temp_string(index(temp_string,':')+1:) + + end if + + f_source%modules_used(n_use)%s = lower(temp_string) + + if (.not.validate_name(temp_string)) then + call file_parse_error(error,f_filename, & + 'empty or invalid name for submodule parent',i, & + file_lines(i)%s, index(file_lines(i)%s,temp_string)) + return + end if + + end if + + end if + + ! Detect if is program + if (f_source%unit_type == FPM_UNIT_UNKNOWN .and. & + index(adjustl(lower(file_lines(i)%s)),'program') == 1) then + + f_source%unit_type = FPM_UNIT_PROGRAM + + end if + + end do file_loop + + ! Default to subprogram unit type + if (f_source%unit_type == FPM_UNIT_UNKNOWN) 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)) + end if + + end do + + contains + + function validate_name(name) result(valid) + character(*), intent(in) :: name + logical :: valid + + integer :: i + + if (len_trim(name) < 1) then + valid = .false. + return + end if + + if (lower(name(1:1)) < 'a' .or. & + lower(name(1:1)) > 'z') then + + valid = .false. + return + end if + + do i=1,len(name) + + if (.not.( & + (name(i:i) >= '0' .and. name(i:i) <= '9').or. & + (lower(name(i:i)) >= 'a' .and. lower(name(i:i)) <= 'z').or. & + name(i:i) == '_') ) then + + valid = .false. + return + end if + + end do + + valid = .true. + return + + end function validate_name + +end function parse_f_source + + +function parse_c_source(c_filename,error) result(c_source) + ! Rudimentary scan of c source file and + ! extract include dependencies + ! + character(*), intent(in) :: c_filename + type(srcfile_t) :: c_source + type(error_t), allocatable, intent(out) :: error + + integer :: fh, n_include, i, pass, stat + type(string_t), allocatable :: file_lines(:) + + c_source%file_name = c_filename + + if (str_ends_with(lower(c_filename), ".c")) then + + c_source%unit_type = FPM_UNIT_CSOURCE + + elseif (str_ends_with(lower(c_filename), ".h")) then + + c_source%unit_type = FPM_UNIT_CHEADER + + end if + + allocate(c_source%modules_used(0)) + allocate(c_source%modules_provided(0)) + + open(newunit=fh,file=c_filename,status='old') + file_lines = read_lines(fh) + close(fh) + + 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 + + n_include = n_include + 1 + + 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 if + + 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 + + +function split_n(string,delims,n,stat) result(substring) + ! Split a string on one or more delimeters + ! and return the nth substring if it exists + ! + ! n=0 will return the last item + ! n=-1 will return the penultimate item etc. + ! + ! stat = 1 on return if the index + ! is not found + ! + character(*), intent(in) :: string + character(*), intent(in) :: delims + integer, intent(in) :: n + integer, intent(out) :: stat + character(:), allocatable :: substring + + integer :: i + character(:), allocatable :: string_parts(:) + + call split(string,string_parts,delims) + + if (n<1) then + i = size(string_parts) + n + if (i < 1) then + stat = 1 + return + end if + else + i = n + end if + + if (i>size(string_parts)) then + stat = 1 + return + end if + + substring = trim(string_parts(i)) + stat = 0 + +end function split_n + + +subroutine resolve_module_dependencies(sources) + ! After enumerating all source files: resolve file dependencies + ! by searching on module names + ! + type(srcfile_t), intent(inout), target :: sources(:) + + integer :: n_depend, i, j + + do i=1,size(sources) + + n_depend = size(sources(i)%modules_used) + + allocate(sources(i)%file_dependencies(n_depend)) + + do j=1,n_depend + + sources(i)%file_dependencies(j)%ptr => & + find_module_dependency(sources,sources(i)%modules_used(j)%s) + + if (.not.associated(sources(i)%file_dependencies(j)%ptr)) then + write(*,*) '(!) Unable to find source for module dependency: ',sources(i)%modules_used(j)%s + ! stop + end if + + end do + + end do + +end subroutine resolve_module_dependencies + +function find_module_dependency(sources,module_name) result(src_ptr) + type(srcfile_t), intent(in), target :: sources(:) + character(*), intent(in) :: module_name + type(srcfile_t), pointer :: src_ptr + + integer :: k, l + + src_ptr => NULL() + + do k=1,size(sources) + + do l=1,size(sources(k)%modules_provided) + + if (module_name == sources(k)%modules_provided(l)%s) then + src_ptr => sources(k) + exit + end if + + end do + + end do + +end function find_module_dependency + +end module fpm_sources diff --git a/fpm/src/fpm_strings.f90 b/fpm/src/fpm_strings.f90 new file mode 100644 index 0000000..a6511c9 --- /dev/null +++ b/fpm/src/fpm_strings.f90 @@ -0,0 +1,217 @@ +module fpm_strings +implicit none + +private +public :: f_string, lower, split, str_ends_with, string_t +public :: string_array_contains, operator(.in.) + +type string_t + character(len=:), allocatable :: s +end type + +interface operator(.in.) + module procedure string_array_contains +end interface + +contains + +logical function str_ends_with(s, e) result(r) + character(*), intent(in) :: s, e + integer :: n1, n2 + n1 = len(s)-len(e)+1 + n2 = len(s) + if (n1 < 1) then + r = .false. + else + r = (s(n1:n2) == e) + end if +end function str_ends_with + +function f_string(c_string) + use iso_c_binding + character(len=1), intent(in) :: c_string(:) + character(:), allocatable :: f_string + + integer :: i, n + + i = 0 + 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 + f_string(i:i) = c_string(i) + end do + +end function f_string + + +elemental pure function lower(str,begin,end) result (string) + ! Changes a string to lowercase over specified range + ! Author: John S. Urban + ! License: Public Domain + + character(*), intent(In) :: str + character(len(str)) :: string + integer,intent(in),optional :: begin, end + integer :: i + integer :: ibegin, iend + string = str + + ibegin = 1 + if (present(begin))then + ibegin = max(ibegin,begin) + endif + + iend = len_trim(str) + if (present(end))then + iend= min(iend,end) + endif + + 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 + end do + +end function lower + + +logical function string_array_contains(search_string,array) + ! Check if array of string_t contains a particular string + ! + 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))]) + +end function string_array_contains + + +subroutine split(input_line,array,delimiters,order,nulls) + ! parse string on delimiter characters and store tokens into an allocatable array" + ! Author: John S. Urban + ! License: Public Domain + + + ! given a line of structure " par1 par2 par3 ... parn " store each par(n) into a separate variable in array. + ! o by default adjacent delimiters in the input string do not create an empty string in the output array + ! o 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 + + 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 :: icount ! number of tokens found + integer :: ilen ! length of input string with trailing spaces trimmed + 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 + integer :: inotnull ! count strings not composed of delimiters + integer :: ireturn ! number of tokens returned + integer :: imax ! length of longest token + + ! decide on value for optional DELIMITERS parameter + if (present(delimiters)) then ! optional delimiter list was present + if(delimiters.ne.'')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 + 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 + + 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 + + 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 + + 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)).eq.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.gt.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.gt.ilen)then ! no text left + exit INFINITE + endif + enddo INFINITE + + end select + + select case (trim(adjustl(nlls))) + case ('ignore','','ignoreend') + ireturn=inotnull + case default + ireturn=icount + end select + 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 + end select + + do i20=1,icount ! fill the array with the tokens that were found + if(iterm(i20).lt.ibegin(i20))then + select case (trim(adjustl(nlls))) + case ('ignore','','ignoreend') + case default + array(ii)=' ' + ii=ii+iiii + end select + else + array(ii)=input_line(ibegin(i20):iterm(i20)) + ii=ii+iiii + endif + enddo +end subroutine split + + +end module fpm_strings diff --git a/fpm/test/main.f90 b/fpm/test/main.f90 index 19bcdb6..f9d0941 100644 --- a/fpm/test/main.f90 +++ b/fpm/test/main.f90 @@ -4,6 +4,7 @@ program fpm_testing use testsuite, only : run_testsuite use test_toml, only : collect_toml use test_manifest, only : collect_manifest + use test_source_parsing, only : collect_source_parsing implicit none integer :: stat character(len=*), parameter :: fmt = '("#", *(1x, a))' @@ -24,4 +25,12 @@ program fpm_testing error stop 1 end if + write(error_unit, fmt) "Testing:", "fpm_sources (parsing)" + call run_testsuite(collect_source_parsing, error_unit, stat) + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "tests failed!" + error stop 1 + end if + end program fpm_testing diff --git a/fpm/test/test_manifest.f90 b/fpm/test/test_manifest.f90 index 223b346..d2dc891 100644 --- a/fpm/test/test_manifest.f90 +++ b/fpm/test/test_manifest.f90 @@ -1,6 +1,7 @@ !> Define tests for the `fpm_manifest` modules module test_manifest - use testsuite, only : new_unittest, unittest_t, error_t, test_failed + use testsuite, only : new_unittest, unittest_t, error_t, test_failed, & + & check_string use fpm_manifest implicit none private @@ -23,11 +24,30 @@ contains & 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-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("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("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("test-empty", test_test_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("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.)] end subroutine collect_manifest @@ -143,16 +163,9 @@ contains allocate(package%library) call default_library(package%library) - if (.not.allocated(package%library%source_dir)) then - call test_failed(error, "Default library source-dir is not set") - return - end if - - if (package%library%source_dir /= "src") then - call test_failed(error, "Default library source-dir is "// & - & package%library%source_dir//" but should be src") - return - end if + call check_string(error, package%library%source_dir, "src", & + & "Default library source-dir") + if (allocated(error)) return end subroutine test_default_library @@ -169,22 +182,13 @@ contains allocate(package%executable(1)) call default_executable(package%executable(1), name) - if (.not.allocated(package%executable(1)%source_dir)) then - call test_failed(error, "Default executable source-dir is not set") - return - end if - - if (package%executable(1)%source_dir /= "app") then - call test_failed(error, "Default executable source-dir is "// & - & package%executable(1)%source_dir//" but should be app") - return - end if + call check_string(error, package%executable(1)%source_dir, "app", & + & "Default executable source-dir") + if (allocated(error)) return - if (package%executable(1)%name /= name) then - call test_failed(error, "Default executable name is "// & - & package%executable(1)%name//" but should be "//name) - return - end if + call check_string(error, package%executable(1)%name, name, & + & "Default executable name") + if (allocated(error)) return end subroutine test_default_executable @@ -208,6 +212,115 @@ contains 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_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) + + 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_t) :: dependency + + call new_table(table) + table%key = 'example' + call set_value(table, 'tag', '"v20.1"', stat) + + call new_dependency(dependency, table, 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_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) + + 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_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) + + end subroutine test_dependency_gitconflict + + + !> 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 + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + integer :: stat + type(dependency_t) :: dependency + + call new_table(table) + table%key = 'example' + call set_value(table, 'not-available', '"anywhere"', stat) + + call new_dependency(dependency, table, error) + + end subroutine test_dependency_wrongkey + + !> Dependency tables can be empty subroutine test_dependencies_empty(error) use fpm_manifest_dependency @@ -231,6 +344,27 @@ contains 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_t), allocatable :: dependencies(:) + + call new_table(table) + call add_array(table, 'dep1', children, stat) + + call new_dependencies(dependencies, table, error) + + end subroutine test_dependencies_typeerror + + !> Executables cannot be created from empty tables subroutine test_executable_empty(error) use fpm_manifest_executable @@ -249,6 +383,69 @@ contains end subroutine test_executable_empty + !> 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 + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_table), pointer :: child + integer :: stat + type(executable_t) :: executable + + call new_table(table) + call add_table(table, 'name', child, stat) + + call new_executable(executable, table, error) + + end subroutine test_executable_typeerror + + + !> 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 + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_table), pointer :: child + integer :: stat + type(executable_t) :: executable + + call new_table(table) + call add_table(table, 'dependencies', child, stat) + + call new_executable(executable, table, error) + + end subroutine test_executable_noname + + + !> 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 + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_table), pointer :: child + integer :: stat + type(executable_t) :: executable + + call new_table(table) + call add_table(table, 'wrong-field', child, stat) + + call new_executable(executable, table, error) + + end subroutine test_executable_wrongkey + + !> Libraries can be created from empty tables subroutine test_library_empty(error) use fpm_manifest_library @@ -265,20 +462,73 @@ contains call new_library(library, table, error) if (allocated(error)) return - if (.not.allocated(library%source_dir)) then - call test_failed(error, "Default library source-dir is not set") - return - end if - - if (library%source_dir /= "src") then - call test_failed(error, "Default library source-dir is "// & - & library%source_dir//" but should be src") - return - end if + call check_string(error, library%source_dir, "src", & + & "Default library source-dir") + if (allocated(error)) return end subroutine test_library_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 + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_table), pointer :: child + integer :: stat + type(library_t) :: library + + call new_table(table) + call add_table(table, 'not-allowed', child, stat) + + call new_library(library, table, error) + + end subroutine test_library_wrongkey + + + !> 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 + + !> 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_t) :: package + + 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_package(package, table, error) + + end subroutine test_package_simple + + !> Packages cannot be created from empty tables subroutine test_package_empty(error) use fpm_manifest_package @@ -297,6 +547,124 @@ contains 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 + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_array), pointer :: child + integer :: stat + type(package_t) :: package + + call new_table(table) + call add_array(table, "name", child, stat) + + call new_package(package, table, error) + + end subroutine test_package_typeerror + + + !> 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 + + type(toml_table) :: table + type(toml_table), pointer :: child + integer :: stat + type(package_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_package(package, table, error) + + end subroutine test_package_noname + + + !> 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 + + type(toml_table) :: table + type(toml_array), pointer :: children, children2 + integer :: stat + type(package_t) :: package + + 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) + + end subroutine test_package_wrongexe + + + !> 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 + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_array), pointer :: children, children2 + integer :: stat + type(package_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) + + call new_package(package, table, error) + + end subroutine test_package_wrongtest + + + !> 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 + + type(toml_table) :: table + type(toml_table), pointer :: child + integer :: stat + type(test_t) :: test + + 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) + if (allocated(error)) return + + call check_string(error, test%main, "tester.f90", "Test main") + if (allocated(error)) return + + end subroutine test_test_simple + + !> Tests cannot be created from empty tables subroutine test_test_empty(error) use fpm_manifest_test @@ -315,4 +683,67 @@ contains 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 + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_table), pointer :: child + integer :: stat + type(test_t) :: test + + call new_table(table) + call add_table(table, 'name', child, stat) + + call new_test(test, table, error) + + end subroutine test_test_typeerror + + + !> 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 + + type(toml_table) :: table + type(toml_table), pointer :: child + integer :: stat + type(test_t) :: test + + call new_table(table) + call add_table(table, 'dependencies', child, stat) + + call new_test(test, table, error) + + end subroutine test_test_noname + + + !> 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 + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_table), pointer :: child + integer :: stat + type(test_t) :: test + + call new_table(table) + call add_table(table, 'not-supported', child, stat) + + call new_test(test, table, error) + + end subroutine test_test_wrongkey + + end module test_manifest diff --git a/fpm/test/test_source_parsing.f90 b/fpm/test/test_source_parsing.f90 new file mode 100644 index 0000000..c55a206 --- /dev/null +++ b/fpm/test/test_source_parsing.f90 @@ -0,0 +1,621 @@ +!> 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_sources, 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 + 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("module", test_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"', & + & ' 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 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)') & + & 'module my_mod', & + & 'use module_one', & + & 'interface', & + & ' module subroutine f()', & + & 'end interface', & + & 'contains', & + & 'module procedure f()', & + & 'end procedure f', & + & '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_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 parent module in modules_used') + return + end if + + end subroutine test_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) /= 0) then + call test_failed(error,'Unexpected modules_provided - expecting zero') + 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.('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) /= 0) then + call test_failed(error,'Unexpected modules_provided - expecting zero') + 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.('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 (.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) + + !> 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 :: ', & + & 'end program test' + close(unit) + + f_source = parse_f_source(temp_file,error) + if (allocated(error)) then + return + end if + + end subroutine test_invalid_use_stmt + + + !> Try to parse fortran program with invalid use statement + subroutine test_invalid_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', & + & ' 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 + + write(*,*) '"',f_source%modules_used(1)%s,'"' + + 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 + + + +end module test_source_parsing diff --git a/fpm/test/testsuite.f90 b/fpm/test/testsuite.f90 index bd0d415..9b69032 100644 --- a/fpm/test/testsuite.f90 +++ b/fpm/test/testsuite.f90 @@ -5,6 +5,7 @@ module testsuite private public :: run_testsuite, new_unittest, test_failed + public :: check_string public :: unittest_t, error_t @@ -73,7 +74,8 @@ contains call collect(testsuite) do ii = 1, size(testsuite) - write(unit, '("#", *(1x, a))') "Starting", testsuite(ii)%name, "..." + write(unit, '("#", 3(1x, a), 1x, "(", i0, "/", i0, ")")') & + & "Starting", testsuite(ii)%name, "...", ii, size(testsuite) call testsuite(ii)%test(error) if (allocated(error) .neqv. testsuite(ii)%should_fail) then if (testsuite(ii)%should_fail) then @@ -90,7 +92,7 @@ contains end if end if if (allocated(error)) then - write(unit, '(a)') error%message + write(unit, fmt) "Message:", error%message end if end do @@ -119,4 +121,32 @@ contains end function new_unittest + !> Check a deferred length character variable against a reference value + subroutine check_string(error, actual, expected, name) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Actual string value + character(len=:), allocatable, intent(in) :: actual + + !> Expected string value + character(len=*), intent(in) :: expected + + !> Name of the string to check + character(len=*), intent(in) :: name + + if (.not.allocated(actual)) then + call test_failed(error, name//" is not set correctly") + return + end if + + if (actual /= expected) then + call test_failed(error, name//" is "//actual// & + & " but should be "//expected) + end if + + end subroutine check_string + + end module testsuite |