From d9dc9f2ae5f196c15a7d35cddabc805c40ff86ce Mon Sep 17 00:00:00 2001 From: Sebastian Ehlert <28669218+awvwgk@users.noreply.github.com> Date: Wed, 31 Mar 2021 16:13:58 +0200 Subject: Phase out Haskell fpm (#420) - remove bootstrap directory from repository - remove stack-build from CI workflow - move Fortran fpm to project root - adjust install script and bootstrap instructions --- .github/workflows/CI.yml | 143 +-- .gitignore | 4 +- README.md | 48 +- app/main.f90 | 37 + bootstrap/Setup.hs | 2 - bootstrap/app/Main.hs | 8 - bootstrap/package.yaml | 72 -- bootstrap/src/Build.hs | 239 ---- bootstrap/src/BuildModel.hs | 411 ------- bootstrap/src/Fpm.hs | 1227 -------------------- bootstrap/stack.yaml | 74 -- bootstrap/stack.yaml.lock | 43 - bootstrap/test/Spec.hs | 103 -- bootstrap/test/example_packages | 1 - .../unit_test/ModuleSourceConstructionTest.hs | 83 -- bootstrap/unit_test/ModuleToCompileInfoTest.hs | 73 -- .../unit_test/ProgramSourceConstructionTest.hs | 69 -- bootstrap/unit_test/ProgramToCompileInfoTest.hs | 71 -- .../unit_test/SubmoduleSourceConstructionTest.hs | 79 -- bootstrap/unit_test/SubmoduleToCompileInfoTest.hs | 78 -- bootstrap/unit_test/Trimmer.hs | 1 - docs.md | 6 +- fpm.toml | 35 + fpm/.gitignore | 1 - fpm/README.md | 4 - fpm/app/main.f90 | 37 - fpm/fpm.toml | 35 - fpm/src/fpm.f90 | 467 -------- fpm/src/fpm/cmd/install.f90 | 176 --- fpm/src/fpm/cmd/new.f90 | 652 ----------- fpm/src/fpm/cmd/update.f90 | 68 -- fpm/src/fpm/dependency.f90 | 821 ------------- fpm/src/fpm/error.f90 | 128 -- fpm/src/fpm/git.f90 | 263 ----- fpm/src/fpm/installer.f90 | 284 ----- fpm/src/fpm/manifest.f90 | 184 --- fpm/src/fpm/manifest/build.f90 | 162 --- fpm/src/fpm/manifest/dependency.f90 | 248 ---- fpm/src/fpm/manifest/example.f90 | 175 --- fpm/src/fpm/manifest/executable.f90 | 186 --- fpm/src/fpm/manifest/install.f90 | 108 -- fpm/src/fpm/manifest/library.f90 | 142 --- fpm/src/fpm/manifest/package.f90 | 435 ------- fpm/src/fpm/manifest/test.f90 | 175 --- fpm/src/fpm/toml.f90 | 120 -- fpm/src/fpm/versioning.f90 | 412 ------- fpm/src/fpm_backend.f90 | 262 ----- fpm/src/fpm_command_line.f90 | 1140 ------------------ fpm/src/fpm_compiler.f90 | 333 ------ fpm/src/fpm_environment.f90 | 185 --- fpm/src/fpm_filesystem.f90 | 612 ---------- fpm/src/fpm_model.f90 | 293 ----- fpm/src/fpm_source_parsing.f90 | 480 -------- fpm/src/fpm_sources.f90 | 220 ---- fpm/src/fpm_strings.f90 | 924 --------------- fpm/src/fpm_targets.f90 | 553 --------- fpm/test/cli_test/cli_test.f90 | 236 ---- fpm/test/fpm_test/main.f90 | 106 -- fpm/test/fpm_test/test_backend.f90 | 353 ------ fpm/test/fpm_test/test_filesystem.f90 | 106 -- fpm/test/fpm_test/test_installer.f90 | 168 --- fpm/test/fpm_test/test_manifest.f90 | 1085 ----------------- fpm/test/fpm_test/test_module_dependencies.f90 | 666 ----------- fpm/test/fpm_test/test_package_dependencies.f90 | 240 ---- fpm/test/fpm_test/test_source_parsing.f90 | 758 ------------ fpm/test/fpm_test/test_toml.f90 | 107 -- fpm/test/fpm_test/test_versioning.f90 | 405 ------- fpm/test/fpm_test/testsuite.f90 | 286 ----- fpm/test/help_test/help_test.f90 | 292 ----- fpm/test/new_test/new_test.f90 | 187 --- install.sh | 100 +- manifest-reference.md | 21 - src/fpm.f90 | 467 ++++++++ src/fpm/cmd/install.f90 | 176 +++ src/fpm/cmd/new.f90 | 652 +++++++++++ src/fpm/cmd/update.f90 | 68 ++ src/fpm/dependency.f90 | 821 +++++++++++++ src/fpm/error.f90 | 128 ++ src/fpm/git.f90 | 263 +++++ src/fpm/installer.f90 | 284 +++++ src/fpm/manifest.f90 | 184 +++ src/fpm/manifest/build.f90 | 162 +++ src/fpm/manifest/dependency.f90 | 248 ++++ src/fpm/manifest/example.f90 | 175 +++ src/fpm/manifest/executable.f90 | 186 +++ src/fpm/manifest/install.f90 | 108 ++ src/fpm/manifest/library.f90 | 142 +++ src/fpm/manifest/package.f90 | 435 +++++++ src/fpm/manifest/test.f90 | 175 +++ src/fpm/toml.f90 | 120 ++ src/fpm/versioning.f90 | 412 +++++++ src/fpm_backend.f90 | 262 +++++ src/fpm_command_line.f90 | 1140 ++++++++++++++++++ src/fpm_compiler.f90 | 333 ++++++ src/fpm_environment.f90 | 185 +++ src/fpm_filesystem.f90 | 612 ++++++++++ src/fpm_model.f90 | 293 +++++ src/fpm_source_parsing.f90 | 480 ++++++++ src/fpm_sources.f90 | 220 ++++ src/fpm_strings.f90 | 924 +++++++++++++++ src/fpm_targets.f90 | 553 +++++++++ test/cli_test/cli_test.f90 | 236 ++++ test/fpm_test/main.f90 | 106 ++ test/fpm_test/test_backend.f90 | 353 ++++++ test/fpm_test/test_filesystem.f90 | 106 ++ test/fpm_test/test_installer.f90 | 168 +++ test/fpm_test/test_manifest.f90 | 1085 +++++++++++++++++ test/fpm_test/test_module_dependencies.f90 | 666 +++++++++++ test/fpm_test/test_package_dependencies.f90 | 240 ++++ test/fpm_test/test_source_parsing.f90 | 758 ++++++++++++ test/fpm_test/test_toml.f90 | 107 ++ test/fpm_test/test_versioning.f90 | 405 +++++++ test/fpm_test/testsuite.f90 | 286 +++++ test/help_test/help_test.f90 | 292 +++++ test/new_test/new_test.f90 | 187 +++ 115 files changed, 15314 insertions(+), 18197 deletions(-) create mode 100644 app/main.f90 delete mode 100644 bootstrap/Setup.hs delete mode 100644 bootstrap/app/Main.hs delete mode 100644 bootstrap/package.yaml delete mode 100644 bootstrap/src/Build.hs delete mode 100644 bootstrap/src/BuildModel.hs delete mode 100644 bootstrap/src/Fpm.hs delete mode 100644 bootstrap/stack.yaml delete mode 100644 bootstrap/stack.yaml.lock delete mode 100644 bootstrap/test/Spec.hs delete mode 120000 bootstrap/test/example_packages delete mode 100644 bootstrap/unit_test/ModuleSourceConstructionTest.hs delete mode 100644 bootstrap/unit_test/ModuleToCompileInfoTest.hs delete mode 100644 bootstrap/unit_test/ProgramSourceConstructionTest.hs delete mode 100644 bootstrap/unit_test/ProgramToCompileInfoTest.hs delete mode 100644 bootstrap/unit_test/SubmoduleSourceConstructionTest.hs delete mode 100644 bootstrap/unit_test/SubmoduleToCompileInfoTest.hs delete mode 100644 bootstrap/unit_test/Trimmer.hs create mode 100644 fpm.toml delete mode 100644 fpm/.gitignore delete mode 100644 fpm/README.md delete mode 100644 fpm/app/main.f90 delete mode 100644 fpm/fpm.toml delete mode 100644 fpm/src/fpm.f90 delete mode 100644 fpm/src/fpm/cmd/install.f90 delete mode 100644 fpm/src/fpm/cmd/new.f90 delete mode 100644 fpm/src/fpm/cmd/update.f90 delete mode 100644 fpm/src/fpm/dependency.f90 delete mode 100644 fpm/src/fpm/error.f90 delete mode 100644 fpm/src/fpm/git.f90 delete mode 100644 fpm/src/fpm/installer.f90 delete mode 100644 fpm/src/fpm/manifest.f90 delete mode 100644 fpm/src/fpm/manifest/build.f90 delete mode 100644 fpm/src/fpm/manifest/dependency.f90 delete mode 100644 fpm/src/fpm/manifest/example.f90 delete mode 100644 fpm/src/fpm/manifest/executable.f90 delete mode 100644 fpm/src/fpm/manifest/install.f90 delete mode 100644 fpm/src/fpm/manifest/library.f90 delete mode 100644 fpm/src/fpm/manifest/package.f90 delete mode 100644 fpm/src/fpm/manifest/test.f90 delete mode 100644 fpm/src/fpm/toml.f90 delete mode 100644 fpm/src/fpm/versioning.f90 delete mode 100644 fpm/src/fpm_backend.f90 delete mode 100644 fpm/src/fpm_command_line.f90 delete mode 100644 fpm/src/fpm_compiler.f90 delete mode 100644 fpm/src/fpm_environment.f90 delete mode 100644 fpm/src/fpm_filesystem.f90 delete mode 100644 fpm/src/fpm_model.f90 delete mode 100644 fpm/src/fpm_source_parsing.f90 delete mode 100644 fpm/src/fpm_sources.f90 delete mode 100644 fpm/src/fpm_strings.f90 delete mode 100644 fpm/src/fpm_targets.f90 delete mode 100644 fpm/test/cli_test/cli_test.f90 delete mode 100644 fpm/test/fpm_test/main.f90 delete mode 100644 fpm/test/fpm_test/test_backend.f90 delete mode 100644 fpm/test/fpm_test/test_filesystem.f90 delete mode 100644 fpm/test/fpm_test/test_installer.f90 delete mode 100644 fpm/test/fpm_test/test_manifest.f90 delete mode 100644 fpm/test/fpm_test/test_module_dependencies.f90 delete mode 100644 fpm/test/fpm_test/test_package_dependencies.f90 delete mode 100644 fpm/test/fpm_test/test_source_parsing.f90 delete mode 100644 fpm/test/fpm_test/test_toml.f90 delete mode 100644 fpm/test/fpm_test/test_versioning.f90 delete mode 100644 fpm/test/fpm_test/testsuite.f90 delete mode 100644 fpm/test/help_test/help_test.f90 delete mode 100644 fpm/test/new_test/new_test.f90 create mode 100644 src/fpm.f90 create mode 100644 src/fpm/cmd/install.f90 create mode 100644 src/fpm/cmd/new.f90 create mode 100644 src/fpm/cmd/update.f90 create mode 100644 src/fpm/dependency.f90 create mode 100644 src/fpm/error.f90 create mode 100644 src/fpm/git.f90 create mode 100644 src/fpm/installer.f90 create mode 100644 src/fpm/manifest.f90 create mode 100644 src/fpm/manifest/build.f90 create mode 100644 src/fpm/manifest/dependency.f90 create mode 100644 src/fpm/manifest/example.f90 create mode 100644 src/fpm/manifest/executable.f90 create mode 100644 src/fpm/manifest/install.f90 create mode 100644 src/fpm/manifest/library.f90 create mode 100644 src/fpm/manifest/package.f90 create mode 100644 src/fpm/manifest/test.f90 create mode 100644 src/fpm/toml.f90 create mode 100644 src/fpm/versioning.f90 create mode 100644 src/fpm_backend.f90 create mode 100644 src/fpm_command_line.f90 create mode 100644 src/fpm_compiler.f90 create mode 100644 src/fpm_environment.f90 create mode 100644 src/fpm_filesystem.f90 create mode 100644 src/fpm_model.f90 create mode 100644 src/fpm_source_parsing.f90 create mode 100644 src/fpm_sources.f90 create mode 100644 src/fpm_strings.f90 create mode 100644 src/fpm_targets.f90 create mode 100644 test/cli_test/cli_test.f90 create mode 100644 test/fpm_test/main.f90 create mode 100644 test/fpm_test/test_backend.f90 create mode 100644 test/fpm_test/test_filesystem.f90 create mode 100644 test/fpm_test/test_installer.f90 create mode 100644 test/fpm_test/test_manifest.f90 create mode 100644 test/fpm_test/test_module_dependencies.f90 create mode 100644 test/fpm_test/test_package_dependencies.f90 create mode 100644 test/fpm_test/test_source_parsing.f90 create mode 100644 test/fpm_test/test_toml.f90 create mode 100644 test/fpm_test/test_versioning.f90 create mode 100644 test/fpm_test/testsuite.f90 create mode 100644 test/help_test/help_test.f90 create mode 100644 test/new_test/new_test.f90 diff --git a/.github/workflows/CI.yml b/.github/workflows/CI.yml index 9fc7918..8aabcf5 100644 --- a/.github/workflows/CI.yml +++ b/.github/workflows/CI.yml @@ -13,138 +13,8 @@ env: HOMEBREW_NO_BOTTLE_SOURCE_FALLBACK: "ON" HOMEBREW_NO_GITHUB_API: "ON" HOMEBREW_NO_INSTALL_CLEANUP: "ON" - RUST_BACKTRACE: "full" # Make Rust print full backtrace on error jobs: - stack-build: - runs-on: ${{ matrix.os }} - strategy: - fail-fast: false - matrix: - os: [ubuntu-latest, macos-latest, windows-latest] - gcc_v: [9] # Version of GFortran we want to use. - include: - - os: ubuntu-latest - STACK_CACHE: "/home/runner/.stack/" - STACK_CACHE_VERSION: "" - TEST_SCRIPT: ci/run_tests.sh - GET_VERSION_CMD: echo ${{ github.ref }} | cut -dv -f2 - CHECK_VERSION_CMD: grep $(cat fpm_version) - RELEASE_CMD: "cp -- fpm-$(cat fpm_version)-linux-x86_64" - BOOTSTRAP_RELEASE_CMD: cp /home/runner/.local/bin/fpm fpm-haskell-$(cat fpm_version)-linux-x86_64 - HASH_CMD: ls fpm-*|xargs -i{} sh -c 'sha256sum $1 > $1.sha256' -- {} - RELEASE_FLAGS: --flag --static --flag -g --flag -fbacktrace --flag -O3 - - - os: macos-latest - STACK_CACHE: | - /Users/runner/.stack/snapshots - /Users/runner/.stack/setup-exe-src - STACK_CACHE_VERSION: "v2" - TEST_SCRIPT: ci/run_tests.sh - GET_VERSION_CMD: echo ${{ github.ref }} | cut -dv -f2 - CHECK_VERSION_CMD: grep $(cat fpm_version) - RELEASE_CMD: "cp -- fpm-$(cat fpm_version)-macos-x86_64" - BOOTSTRAP_RELEASE_CMD: cp /Users/runner/.local/bin/fpm fpm-haskell-$(cat fpm_version)-macos-x86_64 - HASH_CMD: ls fpm-*|xargs -I{} sh -c 'shasum -a 256 $1 > $1.sha256' -- {} - RELEASE_FLAGS: --flag -g --flag -fbacktrace --flag -O3 - - - os: windows-latest - STACK_CACHE: | - C:\Users\runneradmin\AppData\Roaming\stack - C:\Users\runneradmin\AppData\Local\Programs\stack - STACK_CACHE_VERSION: "v2" - TEST_SCRIPT: ci\run_tests.bat - GET_VERSION_CMD: ("${{ github.ref }}" -Split "v")[1] - CHECK_VERSION_CMD: Select-String -Pattern Version | Where-Object { if ($_ -like -join("*",(Get-Content fpm_version),"*")) {echo $_} else {Throw} } - RELEASE_CMD: copy -- (-join("fpm-",(Get-Content fpm_version),"-windows-x86_64.exe")) - BOOTSTRAP_RELEASE_CMD: copy C:\Users\runneradmin\AppData\Roaming\local\bin\fpm.exe (-join("fpm-haskell-",(Get-Content fpm_version),"-windows-x86_64.exe")) - HASH_CMD: Get-ChildItem -File -Filter "fpm-*" | Foreach-Object {echo (Get-FileHash -Algorithm SHA256 $PSItem | Select-Object hash | Format-Table -HideTableHeaders | Out-String) > (-join($PSItem,".sha256"))} - RELEASE_FLAGS: --flag --static --flag -g --flag -fbacktrace --flag -O3 - - env: - FC: gfortran - GCC_V: ${{ matrix.gcc_v }} - - steps: - - name: Checkout code - uses: actions/checkout@v1 - - - name: Install GFortran macOS - if: contains(matrix.os, 'macos') - run: | - ln -s /usr/local/bin/gfortran-${GCC_V} /usr/local/bin/gfortran - which gfortran-${GCC_V} - which gfortran - - - name: Install GFortran Linux - if: contains(matrix.os, 'ubuntu') - run: | - sudo update-alternatives --install /usr/bin/gcc gcc /usr/bin/gcc-${GCC_V} 100 \ - --slave /usr/bin/gfortran gfortran /usr/bin/gfortran-${GCC_V} \ - --slave /usr/bingcov gcov /usr/bin/gcov-${GCC_V} - - - name: Get Time - id: time - uses: nanzm/get-time-action@v1.0 - with: - format: 'YYYY-MM' - - - name: Setup github actions cache - id: cache - uses: actions/cache@v2 - with: - path: ${{matrix.STACK_CACHE}} - key: ${{ runner.os }}-${{ steps.time.outputs.time }}${{matrix.STACK_CACHE_VERSION}} - - - name: Build Haskell fpm - run: | - stack build - stack install - working-directory: bootstrap - - - name: put fpm to PATH (macOS) - if: contains(matrix.os, 'macos') - run: | - cp /Users/runner/.local/bin/fpm /usr/local/bin - - - name: put fpm to PATH (Windows) - if: contains(matrix.os, 'windows') - run: | - copy "C:\Users\runneradmin\AppData\Roaming\local\bin\fpm.exe" "C:\Program Files\Git\usr\bin" - - - name: put fpm to PATH (Linux) - if: contains(matrix.os, 'ubuntu') - run: | - sudo cp /home/runner/.local/bin/fpm /usr/local/bin - - - name: Run tests on Haskell fpm - run: | - stack test - working-directory: bootstrap - - # ----- Upload binaries if creating a release ----- - - name: Check that fpm --version matches release tag - if: github.event_name == 'release' - run: | - ${{ matrix.GET_VERSION_CMD }} > fpm_version - working-directory: fpm - - - name: Stage release files for upload - if: github.event_name == 'release' - run: | - ${{ matrix.BOOTSTRAP_RELEASE_CMD }} - ${{ matrix.HASH_CMD }} - working-directory: fpm - - - name: Upload assets - if: github.event_name == 'release' - uses: svenstaro/upload-release-action@v2 - with: - repo_token: ${{ secrets.GITHUB_TOKEN }} - file: fpm/fpm-* - file_glob: true - tag: ${{ github.ref }} - overwrite: true build: runs-on: ${{ matrix.os }} @@ -208,7 +78,6 @@ jobs: shell: bash run: | ${{ env.BOOTSTRAP }} build - working-directory: fpm - name: Run Fortran fpm (bootstrap) shell: bash @@ -216,19 +85,16 @@ jobs: ${{ env.BOOTSTRAP }} run ${{ env.BOOTSTRAP }} run -- --version ${{ env.BOOTSTRAP }} run -- --help - working-directory: fpm - name: Test Fortran fpm (bootstrap) shell: bash run: | ${{ env.BOOTSTRAP }} test - working-directory: fpm - name: Install Fortran fpm (bootstrap) shell: bash run: | ${{ env.BOOTSTRAP }} install - working-directory: fpm # Phase 2: Bootstrap fpm with itself - name: Replace bootstrapping version @@ -237,7 +103,6 @@ jobs: ${{ env.BOOTSTRAP }} run --runner cp -- fpm-debug${{ matrix.exe }} rm -v ${{ env.BOOTSTRAP }} echo "FPM=$PWD/fpm-debug" | cat >> $GITHUB_ENV - working-directory: fpm - name: Get version (normal) if: github.event_name != 'release' @@ -266,7 +131,6 @@ jobs: shell: bash run: | ${{ env.FPM }} build ${{ matrix.release-flags }} - working-directory: fpm - name: Run Fortran fpm shell: bash @@ -274,19 +138,16 @@ jobs: ${{ env.FPM }} run ${{ matrix.release-flags }} ${{ env.FPM }} run ${{ matrix.release-flags }} -- --version ${{ env.FPM }} run ${{ matrix.release-flags }} -- --help - working-directory: fpm - name: Test Fortran fpm shell: bash run: | ${{ env.FPM }} test ${{ matrix.release-flags }} - working-directory: fpm - name: Install Fortran fpm shell: bash run: | ${{ env.FPM }} install ${{ matrix.release-flags }} - working-directory: fpm - name: Package release version shell: bash @@ -294,7 +155,6 @@ jobs: ${{ env.FPM }} run ${{ matrix.release-flags }} --runner cp -- ${{ env.EXE }} rm -v ${{ env.FPM }} echo "FPM_RELEASE=$PWD/${{ env.EXE }}" | cat >> $GITHUB_ENV - working-directory: fpm env: EXE: fpm-${{ env.VERSION }}-${{ matrix.os-arch }}${{ matrix.exe }} @@ -308,14 +168,13 @@ jobs: shell: bash run: | ${{ matrix.sha256sum }} ${{ env.FPM_RELEASE }} > ${{ env.FPM_RELEASE }}.sha256 - working-directory: fpm - name: Upload assets if: github.event_name == 'release' uses: svenstaro/upload-release-action@v2 with: repo_token: ${{ secrets.GITHUB_TOKEN }} - file: fpm/fpm-* + file: fpm-* file_glob: true tag: ${{ github.ref }} overwrite: true diff --git a/.gitignore b/.gitignore index fe86e64..a007fea 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1 @@ -.stack-work/ -fpm.cabal -*~ +build/* diff --git a/README.md b/README.md index 04ab6ad..d4e9002 100644 --- a/README.md +++ b/README.md @@ -18,7 +18,10 @@ matures and we enter production, we will aim to stay backwards compatible. Please follow the [issues](https://github.com/fortran-lang/fpm/issues) to contribute and/or stay up to date with the development. Before opening a bug report or a feature suggestion, please read our -[Contributor Guide](CONTRIBUTING.md). You can also discuss your ideas and queries with the community in [fpm discussions](https://github.com/fortran-lang/fpm/discussions), or more broadly on [Fortran-Lang Discourse](https://fortran-lang.discourse.group/) +[Contributor Guide](CONTRIBUTING.md). You can also discuss your ideas and +queries with the community in +[fpm discussions](https://github.com/fortran-lang/fpm/discussions), +or more broadly on [Fortran-Lang Discourse](https://fortran-lang.discourse.group/). Fortran Package Manager is not to be confused with [Jordan Sissel's fpm](https://github.com/jordansissel/fpm), a more general, @@ -71,8 +74,8 @@ with the following contents and initialized as a git repository. * `README.md` – with your project’s name * `.gitignore` * `src/project_name.f90` – with a simple hello world subroutine -* `app/main.f90` (if `--with-executable` flag used) – a program that calls the subroutine -* `test/main.f90` (if `--with-test` flag used) – an empty test program +* `app/main.f90` (if `--app` flag used) – a program that calls the subroutine +* `test/main.f90` (if `--test` flag used) – an empty test program ### Building your Fortran project with fpm @@ -81,6 +84,7 @@ with the following contents and initialized as a git repository. * `fpm build` – build your library, executables and tests * `fpm run` – run executables * `fpm test` – run tests +* `fpm install` - installs the executables locally The command `fpm run` can optionally accept the name of the specific executable to run, as can `fpm test`; like `fpm run specific_executable`. Command line @@ -94,36 +98,24 @@ the [manifest reference](manifest-reference.md). ### Bootstrapping instructions This guide explains the process of building *fpm* on a platform for the first time. -If your platform and architecture are already supported, download the binary from the [release page](https://github.com/fortran-lang/fpm/releases) instead. +To build *fpm* without a prior *fpm* version a single source file version is available +at each release. -#### Download this repository +To build manually using the single source distribution use -```bash -$ git clone https://github.com/fortran-lang/fpm -$ cd fpm/ ``` - -#### Build a bootstrap version of fpm - -You can use the install script to bootstrap and install *fpm*: - -```bash -$ ./install.sh +mkdir _tmp +curl -LJ https://github.com/fortran-lang/fpm/releases/download/v0.2.0/fpm-0.2.0.f90 > _tmp/fpm.f90 +gfortran -J _tmp _tmp/fpm.f90 -o _tmp/fpm +_tmp/fpm install --flag "-g -fbacktrace -O3" +rm -r _tmp ``` -By default, the above command installs `fpm` to `${HOME}/.local/bin/`. -To specify an alternative destination use the `--prefix=` flag, for example: +To automatically bootstrap using this appoach run the install script -```bash -$ ./install.sh --prefix=/usr/local ``` - -which will install *fpm* to `/usr/local/bin`. - -To test that everything is working as expected you can now build *fpm* -with itself and run the tests with: - -```bash -$ cd fpm -$ fpm test +./install.sh ``` + +You can set your Fortran compiler and the compiler flags with the ``FC`` and ``FFLAGS`` +environment variables. diff --git a/app/main.f90 b/app/main.f90 new file mode 100644 index 0000000..7476df6 --- /dev/null +++ b/app/main.f90 @@ -0,0 +1,37 @@ +program main +use fpm_command_line, only: & + fpm_cmd_settings, & + fpm_new_settings, & + fpm_build_settings, & + fpm_run_settings, & + fpm_test_settings, & + fpm_install_settings, & + fpm_update_settings, & + get_command_line_settings +use fpm, only: cmd_build, cmd_run +use fpm_cmd_install, only: cmd_install +use fpm_cmd_new, only: cmd_new +use fpm_cmd_update, only : cmd_update + +implicit none + +class(fpm_cmd_settings), allocatable :: cmd_settings + +call get_command_line_settings(cmd_settings) + +select type(settings=>cmd_settings) +type is (fpm_new_settings) + call cmd_new(settings) +type is (fpm_build_settings) + call cmd_build(settings) +type is (fpm_run_settings) + call cmd_run(settings,test=.false.) +type is (fpm_test_settings) + call cmd_run(settings,test=.true.) +type is (fpm_install_settings) + call cmd_install(settings) +type is (fpm_update_settings) + call cmd_update(settings) +end select + +end program main diff --git a/bootstrap/Setup.hs b/bootstrap/Setup.hs deleted file mode 100644 index 9a994af..0000000 --- a/bootstrap/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/bootstrap/app/Main.hs b/bootstrap/app/Main.hs deleted file mode 100644 index 4897901..0000000 --- a/bootstrap/app/Main.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Main where - -import Fpm ( getArguments - , start - ) - -main :: IO () -main = getArguments >>= start diff --git a/bootstrap/package.yaml b/bootstrap/package.yaml deleted file mode 100644 index 1f5d0fd..0000000 --- a/bootstrap/package.yaml +++ /dev/null @@ -1,72 +0,0 @@ -name: fpm -version: 0.1.0.0 -github: "githubuser/fpm" -license: BSD3 -author: "Author name here" -maintainer: "example@example.com" -copyright: "2020 Author name here" - -extra-source-files: -- ../README.md -- ../ChangeLog.md - -# Metadata used when publishing your package -# synopsis: Short description of your package -# category: Web - -# To avoid duplicated efforts in documentation and dealing with the -# complications of embedding Haddock markup inside cabal files, it is -# common to point users to the README.md file. -description: Please see the README on GitHub at - -dependencies: -- base >= 4.7 && < 5 -- containers -- directory -- extra -- filepath -- hashable -- MissingH -- optparse-applicative -- process -- shake -- split -- text -- tomland >= 1.0 - - -library: - source-dirs: src - -executables: - fpm: - main: Main.hs - source-dirs: app - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - dependencies: - - fpm - -tests: - fpm-test: - main: Spec.hs - source-dirs: test - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - dependencies: - - fpm - fpm-unittest: - main: Trimmer.hs - source-dirs: unit_test - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - dependencies: - - fpm - - hedge - - hedge-trimmer diff --git a/bootstrap/src/Build.hs b/bootstrap/src/Build.hs deleted file mode 100644 index 724a1c6..0000000 --- a/bootstrap/src/Build.hs +++ /dev/null @@ -1,239 +0,0 @@ -{-# LANGUAGE MultiWayIf #-} -module Build - ( CompilerSettings(..) - , buildLibrary - , buildProgram - , buildWithScript - ) -where - -import BuildModel ( AvailableModule(..) - , CompileTimeInfo(..) - , RawSource(..) - , Source(..) - , constructCompileTimeInfo - , getAllObjectFiles - , getAvailableModules - , getSourceFileName - , processRawSource - ) -import Data.List ( intercalate - , isSuffixOf - ) -import Data.List.Utils ( replace ) -import Development.Shake ( FilePattern - , Change(ChangeModtimeAndDigest) - , cmd - , getDirectoryFilesIO - , liftIO - , need - , progressSimple - , shake - , shakeChange - , shakeColor - , shakeFiles - , shakeOptions - , shakeProgress - , shakeThreads - , want - , () - , (%>) - , (&?>) - ) -import Development.Shake.FilePath ( exe - , splitDirectories - , () - , (<.>) - ) -import System.Environment ( setEnv ) -import System.FilePath ( takeBaseName ) -import System.Process ( system ) -import System.Directory ( createDirectoryIfMissing - , makeAbsolute - , withCurrentDirectory - ) - -data CompilerSettings = CompilerSettings { - compilerSettingsCompiler :: FilePath - , compilerSettingsFlags :: [String] - , compilerSettingsModuleFlag :: String - , compilerSettingsIncludeFlag :: String -} - -buildProgram - :: FilePath - -> [FilePath] - -> [FilePattern] - -> FilePath - -> CompilerSettings - -> String - -> FilePath - -> [FilePath] - -> IO () -buildProgram programDirectory' libraryDirectories sourceExtensions buildDirectory' (CompilerSettings { compilerSettingsCompiler = compiler, compilerSettingsFlags = flags, compilerSettingsModuleFlag = moduleFlag, compilerSettingsIncludeFlag = includeFlag }) programName programSource archives - = do - libraryModules <- findAvailableModules libraryDirectories - let programDirectory = foldl1 () (splitDirectories programDirectory') - let buildDirectory = foldl1 () (splitDirectories buildDirectory') - let includeFlags = (includeFlag ++ buildDirectory) : map (includeFlag ++) libraryDirectories - sourceFiles <- getDirectoriesFiles [programDirectory] sourceExtensions - rawSources <- mapM sourceFileToRawSource sourceFiles - let sources' = map processRawSource rawSources - let isThisProgramOrNotProgram p@(Program{}) = - programSourceFileName p == programDirectory programSource - isThisProgramOrNotProgram _ = True - let sources = filter isThisProgramOrNotProgram sources' - let availableModules = (getAvailableModules sources buildDirectory) ++ libraryModules - let compileTimeInfo = map - (\s -> constructCompileTimeInfo s availableModules buildDirectory) - sources - let objectFiles = getAllObjectFiles buildDirectory sources - shake shakeOptions { shakeFiles = buildDirectory - , shakeChange = ChangeModtimeAndDigest - , shakeColor = True - , shakeThreads = 0 - , shakeProgress = progressSimple - } - $ do - let infoToRule cti = - let obj = compileTimeInfoObjectFileProduced cti - other = compileTimeInfoOtherFilesProduced cti - directDependencies = compileTimeInfoDirectDependencies cti - sourceFile = compileTimeInfoSourceFileName cti - fileMatcher f = - let realf = foldl1 () (splitDirectories f) - in if realf == obj || realf `elem` other - then Just (obj : other) - else Nothing - in fileMatcher &?> \(objectFile : _) -> do - need (sourceFile : directDependencies) - cmd compiler - ["-c", moduleFlag, buildDirectory] - includeFlags - flags - ["-o", objectFile, sourceFile] - want [buildDirectory programName <.> exe] - buildDirectory programName <.> exe %> \executable -> do - need objectFiles - need archives - cmd compiler objectFiles archives ["-o", executable] flags - mapM_ infoToRule compileTimeInfo - -buildLibrary - :: FilePath - -> [FilePattern] - -> FilePath - -> CompilerSettings - -> String - -> [FilePath] - -> IO (FilePath) -buildLibrary libraryDirectory sourceExtensions buildDirectory (CompilerSettings { compilerSettingsCompiler = compiler, compilerSettingsFlags = flags, compilerSettingsModuleFlag = moduleFlag, compilerSettingsIncludeFlag = includeFlag }) libraryName otherLibraryDirectories - = do - otherModules <- findAvailableModules otherLibraryDirectories - let includeFlags = (includeFlag ++ buildDirectory) : map (includeFlag ++) otherLibraryDirectories - sourceFiles <- getDirectoriesFiles [libraryDirectory] sourceExtensions - rawSources <- mapM sourceFileToRawSource sourceFiles - let sources = map processRawSource rawSources - let availableModules = (getAvailableModules sources buildDirectory) ++ otherModules - let compileTimeInfo = map - (\s -> constructCompileTimeInfo s availableModules buildDirectory) - sources - let objectFiles = getAllObjectFiles buildDirectory sources - let archiveFile = buildDirectory "lib" ++ libraryName <.> "a" - shake shakeOptions { shakeFiles = buildDirectory - , shakeChange = ChangeModtimeAndDigest - , shakeColor = True - , shakeThreads = 0 - , shakeProgress = progressSimple - } - $ do - let infoToRule cti = - let obj = compileTimeInfoObjectFileProduced cti - other = compileTimeInfoOtherFilesProduced cti - directDependencies = compileTimeInfoDirectDependencies cti - sourceFile = compileTimeInfoSourceFileName cti - fileMatcher f = - let realf = foldl1 () (splitDirectories f) - in if realf == obj || realf `elem` other - then Just (obj : other) - else Nothing - in fileMatcher &?> \(objectFile : _) -> do - need (sourceFile : directDependencies) - cmd compiler - ["-c", moduleFlag, buildDirectory] - includeFlags - flags - ["-o", objectFile, sourceFile] - want [archiveFile] - archiveFile %> \a -> do - need objectFiles - cmd "ar" ["rs"] a objectFiles - mapM_ infoToRule compileTimeInfo - return archiveFile - -buildWithScript - :: String - -> FilePath - -> FilePath - -> CompilerSettings - -> String - -> [FilePath] - -> IO (FilePath) -buildWithScript script projectDirectory buildDirectory (CompilerSettings { compilerSettingsCompiler = compiler, compilerSettingsFlags = flags, compilerSettingsModuleFlag = moduleFlag, compilerSettingsIncludeFlag = includeFlag }) libraryName otherLibraryDirectories - = do - absoluteBuildDirectory <- makeAbsolute buildDirectory - createDirectoryIfMissing True absoluteBuildDirectory - absoluteLibraryDirectories <- mapM makeAbsolute otherLibraryDirectories - setEnv "FC" compiler - setEnv "FFLAGS" (intercalate " " flags) - setEnv "FINCLUDEFLAG" includeFlag - setEnv "FMODUELFLAG" moduleFlag - setEnv "BUILD_DIR" $ unWindowsPath absoluteBuildDirectory - setEnv "INCLUDE_DIRS" - (intercalate " " (map unWindowsPath absoluteLibraryDirectories)) - let archiveFile = - (unWindowsPath absoluteBuildDirectory) - ++ "/lib" - ++ libraryName - <.> "a" - withCurrentDirectory - projectDirectory - if - | isMakefile script -> system - ("make -f " ++ script ++ " " ++ archiveFile) - | otherwise -> system (script ++ " " ++ archiveFile) - return archiveFile - --- A little wrapper around getDirectoryFiles so we can get files from multiple directories -getDirectoriesFiles :: [FilePath] -> [FilePattern] -> IO [FilePath] -getDirectoriesFiles dirs exts = getDirectoryFilesIO "" newPatterns - where - newPatterns = concatMap appendExts dirs - appendExts dir = map ((dir "*") ++) exts - -sourceFileToRawSource :: FilePath -> IO RawSource -sourceFileToRawSource sourceFile = do - contents <- readFile sourceFile - return $ RawSource sourceFile contents - -isMakefile :: String -> Bool -isMakefile script | script == "Makefile" = True - | script == "makefile" = True - | ".mk" `isSuffixOf` script = True - | otherwise = False - -unWindowsPath :: String -> String -unWindowsPath = changeSeparators . removeDriveLetter - -removeDriveLetter :: String -> String -removeDriveLetter path | ':' `elem` path = (tail . dropWhile (/= ':')) path - | otherwise = path - -changeSeparators :: String -> String -changeSeparators = replace "\\" "/" - -findAvailableModules :: [FilePath] -> IO [AvailableModule] -findAvailableModules directories = do - moduleFiles <- getDirectoriesFiles directories ["*.mod"] - let availableModules = map (\mf -> AvailableModule { availableModuleName = takeBaseName mf, availableModuleFile = mf }) moduleFiles - return availableModules diff --git a/bootstrap/src/BuildModel.hs b/bootstrap/src/BuildModel.hs deleted file mode 100644 index 4ca5959..0000000 --- a/bootstrap/src/BuildModel.hs +++ /dev/null @@ -1,411 +0,0 @@ -module BuildModel where - -import Control.Applicative ( (<|>) ) -import Control.Monad ( when ) -import Data.Char ( isAsciiLower - , isDigit - , toLower - ) -import Data.Maybe ( fromMaybe - , mapMaybe - ) -import Data.List ( intercalate ) -import System.FilePath ( () - , (<.>) - , splitDirectories - ) -import Text.ParserCombinators.ReadP ( ReadP - , char - , eof - , many - , many1 - , option - , readP_to_S - , satisfy - , skipSpaces - , string - ) - -data LineContents = - ProgramDeclaration - | ModuleDeclaration String - | ModuleUsed String - | ModuleSubprogramDeclaration - | SubmoduleDeclaration String String String - | Other - -data RawSource = RawSource { - rawSourceFilename :: FilePath - , rawSourceContents :: String -} - -data Source = - Program - { programSourceFileName :: FilePath - , programObjectFileName :: FilePath -> FilePath - , programModulesUsed :: [String] - } - | Module - { moduleSourceFileName :: FilePath - , moduleObjectFileName :: FilePath -> FilePath - , moduleModulesUsed :: [String] - , moduleName :: String - , moduleProducesSmod :: Bool - } - | Submodule - { submoduleSourceFileName :: FilePath - , submoduleObjectFileName :: FilePath -> FilePath - , submoduleModulesUsed :: [String] - , submoduleBaseModuleName :: String - , submoduleParentName :: String - , submoduleName :: String - } - -data CompileTimeInfo = CompileTimeInfo { - compileTimeInfoSourceFileName :: FilePath - , compileTimeInfoObjectFileProduced :: FilePath - , compileTimeInfoOtherFilesProduced :: [FilePath] - , compileTimeInfoDirectDependencies :: [FilePath] -} - -data AvailableModule = AvailableModule { - availableModuleName :: String - , availableModuleFile :: FilePath -} - -processRawSource :: RawSource -> Source -processRawSource rawSource = - let - sourceFileName = rawSourceFilename rawSource - parsedContents = parseContents rawSource - objectFileName = - \bd -> bd (pathSeparatorsToUnderscores sourceFileName) <.> "o" - modulesUsed = getModulesUsed parsedContents - in - if hasProgramDeclaration parsedContents - then Program { programSourceFileName = sourceFileName - , programObjectFileName = objectFileName - , programModulesUsed = modulesUsed - } - else if hasModuleDeclaration parsedContents - then Module - { moduleSourceFileName = sourceFileName - , moduleObjectFileName = objectFileName - , moduleModulesUsed = modulesUsed - , moduleName = getModuleName parsedContents - , moduleProducesSmod = hasModuleSubprogramDeclaration parsedContents - } - else if hasSubmoduleDeclaration parsedContents - then Submodule - { submoduleSourceFileName = sourceFileName - , submoduleObjectFileName = objectFileName - , submoduleModulesUsed = modulesUsed - , submoduleBaseModuleName = getSubmoduleBaseModuleName - parsedContents - , submoduleParentName = getSubmoduleParentName parsedContents - , submoduleName = getSubmoduleName parsedContents - } - else undefined - -getAvailableModules :: [Source] -> FilePath -> [AvailableModule] -getAvailableModules sources buildDirectory = mapMaybe maybeModule sources - where - maybeModule m@(Module{}) = - let mName = moduleName m - modFile = buildDirectory mName <.> "mod" - in Just $ AvailableModule { availableModuleName = mName, availableModuleFile = modFile } - maybeModule _ = Nothing - -getAllObjectFiles :: FilePath -> [Source] -> [FilePath] -getAllObjectFiles buildDirectory sources = map getObjectFile sources - where - getObjectFile p@(Program{} ) = (programObjectFileName p) buildDirectory - getObjectFile m@(Module{} ) = (moduleObjectFileName m) buildDirectory - getObjectFile s@(Submodule{}) = (submoduleObjectFileName s) buildDirectory - -getSourceFileName :: Source -> FilePath -getSourceFileName p@(Program{} ) = programSourceFileName p -getSourceFileName m@(Module{} ) = moduleSourceFileName m -getSourceFileName s@(Submodule{}) = submoduleSourceFileName s - -constructCompileTimeInfo :: Source -> [AvailableModule] -> FilePath -> CompileTimeInfo -constructCompileTimeInfo p@(Program{}) availableModules buildDirectory = - CompileTimeInfo - { compileTimeInfoSourceFileName = programSourceFileName p - , compileTimeInfoObjectFileProduced = (programObjectFileName p) - buildDirectory - , compileTimeInfoOtherFilesProduced = [] - , compileTimeInfoDirectDependencies = map - (\am -> availableModuleFile am) - (filter (\am -> (availableModuleName am) `elem` (programModulesUsed p)) availableModules) - } -constructCompileTimeInfo m@(Module{}) availableModules buildDirectory = - CompileTimeInfo - { compileTimeInfoSourceFileName = moduleSourceFileName m - , compileTimeInfoObjectFileProduced = (moduleObjectFileName m) - buildDirectory - , compileTimeInfoOtherFilesProduced = - (buildDirectory moduleName m <.> "mod") : if moduleProducesSmod m - then [buildDirectory moduleName m <.> "smod"] - else [] - , compileTimeInfoDirectDependencies = map - (\am -> availableModuleFile am) - (filter (\am -> (availableModuleName am) `elem` (moduleModulesUsed m)) availableModules) - } -constructCompileTimeInfo s@(Submodule{}) availableModules buildDirectory = - CompileTimeInfo - { compileTimeInfoSourceFileName = submoduleSourceFileName s - , compileTimeInfoObjectFileProduced = (submoduleObjectFileName s) - buildDirectory - , compileTimeInfoOtherFilesProduced = [ buildDirectory - submoduleBaseModuleName s - ++ "@" - ++ submoduleName s - <.> "smod" - ] - , compileTimeInfoDirectDependencies = - (buildDirectory submoduleParentName s <.> "smod") - : (map (\am -> availableModuleFile am) - (filter (\am -> (availableModuleName am) `elem` (submoduleModulesUsed s)) availableModules) - ) - } - -pathSeparatorsToUnderscores :: FilePath -> FilePath -pathSeparatorsToUnderscores fileName = - intercalate "_" (splitDirectories fileName) - -parseContents :: RawSource -> [LineContents] -parseContents rawSource = - let fileLines = lines $ rawSourceContents rawSource - in map parseFortranLine fileLines - -hasProgramDeclaration :: [LineContents] -> Bool -hasProgramDeclaration parsedContents = case filter f parsedContents of - x : _ -> True - _ -> False - where - f lc = case lc of - ProgramDeclaration -> True - _ -> False - -hasModuleDeclaration :: [LineContents] -> Bool -hasModuleDeclaration parsedContents = case filter f parsedContents of - x : _ -> True - _ -> False - where - f lc = case lc of - ModuleDeclaration{} -> True - _ -> False - -hasSubmoduleDeclaration :: [LineContents] -> Bool -hasSubmoduleDeclaration parsedContents = case filter f parsedContents of - x : _ -> True - _ -> False - where - f lc = case lc of - SubmoduleDeclaration{} -> True - _ -> False - -hasModuleSubprogramDeclaration :: [LineContents] -> Bool -hasModuleSubprogramDeclaration parsedContents = case filter f parsedContents of - x : _ -> True - _ -> False - where - f lc = case lc of - ModuleSubprogramDeclaration -> True - _ -> False - -getModulesUsed :: [LineContents] -> [String] -getModulesUsed = mapMaybe contentToMaybeModuleName - where - contentToMaybeModuleName content = case content of - ModuleUsed moduleName -> Just moduleName - _ -> Nothing - -getModuleName :: [LineContents] -> String -getModuleName pc = head $ mapMaybe contentToMaybeModuleName pc - where - contentToMaybeModuleName content = case content of - ModuleDeclaration moduleName -> Just moduleName - _ -> Nothing - -getSubmoduleBaseModuleName :: [LineContents] -> String -getSubmoduleBaseModuleName pc = head $ mapMaybe contentToMaybeModuleName pc - where - contentToMaybeModuleName content = case content of - SubmoduleDeclaration baseModuleName submoduleParentName submoduleName -> - Just baseModuleName - _ -> Nothing - -getSubmoduleParentName :: [LineContents] -> String -getSubmoduleParentName pc = head $ mapMaybe contentToMaybeModuleName pc - where - contentToMaybeModuleName content = case content of - SubmoduleDeclaration baseModuleName submoduleParentName submoduleName -> - Just submoduleParentName - _ -> Nothing - -getSubmoduleName :: [LineContents] -> String -getSubmoduleName pc = head $ mapMaybe contentToMaybeModuleName pc - where - contentToMaybeModuleName content = case content of - SubmoduleDeclaration baseModuleName submoduleParentName submoduleName -> - Just submoduleName - _ -> Nothing - -readFileLinesIO :: FilePath -> IO [String] -readFileLinesIO file = do - contents <- readFile file - return $ lines contents - -parseFortranLine :: String -> LineContents -parseFortranLine line = - let line' = map toLower line - result = readP_to_S doFortranLineParse line' - in getResult result - where - getResult (_ : (contents, _) : _) = contents - getResult [(contents, _) ] = contents - getResult [] = Other - -doFortranLineParse :: ReadP LineContents -doFortranLineParse = option Other fortranUsefulContents - -fortranUsefulContents :: ReadP LineContents -fortranUsefulContents = - programDeclaration - <|> moduleSubprogramDeclaration - <|> moduleDeclaration - <|> submoduleDeclaration - <|> useStatement - -programDeclaration :: ReadP LineContents -programDeclaration = do - skipSpaces - _ <- string "program" - skipAtLeastOneWhiteSpace - _ <- validIdentifier - return ProgramDeclaration - -moduleDeclaration :: ReadP LineContents -moduleDeclaration = do - skipSpaces - _ <- string "module" - skipAtLeastOneWhiteSpace - moduleName <- validIdentifier - when (moduleName == "procedure") (fail "") - skipSpaceCommentOrEnd - return $ ModuleDeclaration moduleName - -submoduleDeclaration :: ReadP LineContents -submoduleDeclaration = do - skipSpaces - _ <- string "submodule" - parents <- submoduleParents - let parentName = case parents of - (baseModule : []) -> baseModule - (multiple ) -> (head multiple) ++ "@" ++ (last multiple) - skipSpaces - name <- validIdentifier - skipSpaceCommentOrEnd - return $ SubmoduleDeclaration (head parents) parentName name - -submoduleParents :: ReadP [String] -submoduleParents = do - skipSpaces - _ <- char '(' - skipSpaces - firstParent <- validIdentifier - remainingParents <- many - (do - skipSpaces - _ <- char ':' - skipSpaces - name <- validIdentifier - return name - ) - skipSpaces - _ <- char ')' - return $ firstParent : remainingParents - -useStatement :: ReadP LineContents -useStatement = do - skipSpaces - _ <- string "use" - skipAtLeastOneWhiteSpace - modName <- validIdentifier - skipSpaceCommaOrEnd - return $ ModuleUsed modName - -moduleSubprogramDeclaration :: ReadP LineContents -moduleSubprogramDeclaration = do - skipSpaces - skipProcedureQualifiers - _ <- string "module" - skipAtLeastOneWhiteSpace - _ <- string "function" <|> string "subroutine" - skipAtLeastOneWhiteSpace - return $ ModuleSubprogramDeclaration - -skipProcedureQualifiers :: ReadP () -skipProcedureQualifiers = do - many skipPossibleQualifier - return () - -skipPossibleQualifier :: ReadP () -skipPossibleQualifier = do - _ <- string "pure" <|> string "elemental" <|> string "impure" - skipAtLeastOneWhiteSpace - -skipAtLeastOneWhiteSpace :: ReadP () -skipAtLeastOneWhiteSpace = do - _ <- many1 whiteSpace - return () - -skipSpaceOrEnd :: ReadP () -skipSpaceOrEnd = eof <|> skipAtLeastOneWhiteSpace - -skipSpaceCommaOrEnd :: ReadP () -skipSpaceCommaOrEnd = eof <|> skipComma <|> skipAtLeastOneWhiteSpace - -skipSpaceCommentOrEnd :: ReadP () -skipSpaceCommentOrEnd = eof <|> skipComment <|> skipAtLeastOneWhiteSpace - -skipComma :: ReadP () -skipComma = do - _ <- char ',' - return () - -skipComment :: ReadP () -skipComment = do - _ <- char '!' - return () - -skipAnything :: ReadP () -skipAnything = do - _ <- many (satisfy (const True)) - return () - -whiteSpace :: ReadP Char -whiteSpace = satisfy (`elem` " \t") - -validIdentifier :: ReadP String -validIdentifier = do - first <- validFirstCharacter - rest <- many validIdentifierCharacter - return $ first : rest - -validFirstCharacter :: ReadP Char -validFirstCharacter = alphabet - -validIdentifierCharacter :: ReadP Char -validIdentifierCharacter = alphabet <|> digit <|> underscore - -alphabet :: ReadP Char -alphabet = satisfy isAsciiLower - -digit :: ReadP Char -digit = satisfy isDigit - -underscore :: ReadP Char -underscore = char '_' diff --git a/bootstrap/src/Fpm.hs b/bootstrap/src/Fpm.hs deleted file mode 100644 index 56e2d90..0000000 --- a/bootstrap/src/Fpm.hs +++ /dev/null @@ -1,1227 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - -module Fpm - ( Arguments(..) - , getArguments - , start - ) -where - -import Build ( CompilerSettings(..) - , buildLibrary - , buildProgram - , buildWithScript - ) -import Control.Monad.Extra ( concatMapM - , forM_ - , when - ) -import Data.Hashable ( hash ) -import Data.List ( intercalate - , isInfixOf - , isSuffixOf - , find - , nub - ) -import qualified Data.Map as Map -import qualified Data.Text.IO as TIO -import Development.Shake ( FilePattern - , () - , getDirectoryFilesIO - ) -import Development.Shake.FilePath ( () - , (<.>) - , exe - , splitDirectories - ) -import Numeric ( showHex ) -import Options.Applicative ( Parser - , (<**>) - , (<|>) - , auto - , command - , execParser - , fullDesc - , header - , help - , helper - , info - , long - , many - , metavar - , option - , optional - , progDesc - , short - , showDefault - , strArgument - , strOption - , subparser - , switch - , value - ) -import System.Directory ( createDirectory - , doesDirectoryExist - , doesFileExist - , makeAbsolute - , withCurrentDirectory - ) -import System.Exit ( ExitCode(..) - , exitWith - ) -import System.Process ( readProcess - , readProcessWithExitCode - , system - ) -import Toml ( TomlCodec - , (.=) - ) -import qualified Toml - -data Arguments = - New - { newName :: String - , newWithExecutable :: Bool - , newWithTest :: Bool - , newWithLib :: Bool - } - | Build - { buildRelease :: Bool - , buildCompiler :: FilePath - , buildFlags :: [String] - } - | Run - { runRelease :: Bool - , runExample :: Bool - , runCompiler :: FilePath - , runFlags :: [String] - , runRunner :: Maybe String - , runTarget :: Maybe String - , runArgs :: Maybe [String] - } - | Test - { testRelease :: Bool - , testCompiler :: FilePath - , testFlags :: [String] - , testRunner :: Maybe String - , testTarget :: Maybe String - , testArgs :: Maybe [String] - } - -data TomlSettings = TomlSettings { - tomlSettingsProjectName :: String - , tomlSettingsLibrary :: (Maybe Library) - , tomlSettingsExecutables :: [Executable] - , tomlSettingsExamples :: [Executable] - , tomlSettingsTests :: [Executable] - , tomlSettingsDependencies :: (Map.Map String Version) - , tomlSettingsDevDependencies :: (Map.Map String Version) -} - -data AppSettings = AppSettings { - appSettingsCompiler :: CompilerSettings - , appSettingsProjectName :: String - , appSettingsBuildPrefix :: String - , appSettingsLibrary :: (Maybe Library) - , appSettingsExecutables :: [Executable] - , appSettingsExamples :: [Executable] - , appSettingsTests :: [Executable] - , appSettingsDependencies :: (Map.Map String Version) - , appSettingsDevDependencies :: (Map.Map String Version) -} - -data Library = Library { librarySourceDir :: String, libraryBuildScript :: Maybe String } - -data Executable = Executable { - executableSourceDir :: String - , executableMainFile :: String - , executableName :: String - , executableDependencies :: (Map.Map String Version) -} deriving Show - -data Version = SimpleVersion String | GitVersion GitVersionSpec | PathVersion PathVersionSpec deriving Show - -data GitVersionSpec = GitVersionSpec { gitVersionSpecUrl :: String, gitVersionSpecRef :: Maybe GitRef } deriving Show - -data GitRef = Tag String | Branch String | Commit String deriving Show - -data PathVersionSpec = PathVersionSpec { pathVersionSpecPath :: String } deriving Show - -data DependencyTree = Dependency { - dependencyName :: String - , dependencyPath :: FilePath - , dependencySourcePath :: FilePath - , dependencyBuildScript :: Maybe String - , dependencyDependencies :: [DependencyTree] -} - -start :: Arguments -> IO () -start args = case args of - New { newName = name, newWithExecutable = withExecutable, newWithTest = withTest, newWithLib = withLib } - -> createNewProject name withExecutable withTest withLib - _ -> do - fpmContents <- TIO.readFile "fpm.toml" - let tomlSettings = Toml.decode settingsCodec fpmContents - case tomlSettings of - Left err -> print err - Right tomlSettings' -> do - appSettings <- toml2AppSettings tomlSettings' args - app args appSettings - -app :: Arguments -> AppSettings -> IO () -app args settings = case args of - Build{} -> build settings - Run { runTarget = whichOne, runArgs = runArgs, runRunner = runner, runExample = runExample } -> do - build settings - let buildPrefix = appSettingsBuildPrefix settings - let - executableNames = if runExample - then - map - (\Executable { executableSourceDir = sourceDir, executableMainFile = mainFile, executableName = name } -> - sourceDir name - ) - (appSettingsExamples settings) - else - map - (\Executable { executableSourceDir = sourceDir, executableMainFile = mainFile, executableName = name } -> - sourceDir name - ) - (appSettingsExecutables settings) - let executables = - map (buildPrefix ) $ map (flip (<.>) exe) executableNames - canonicalExecutables <- mapM makeAbsolute executables - case canonicalExecutables of - [] -> putStrLn "No Executables Found" - _ -> - let commandPrefix = case runner of - Nothing -> "" - Just r -> r ++ " " - commandSufix = case runArgs of - Nothing -> "" - Just a -> " " ++ (intercalate " " a) - in case whichOne of - Nothing -> do - exitCodes <- mapM - system - (map (\exe -> commandPrefix ++ exe ++ commandSufix) - canonicalExecutables - ) - forM_ - exitCodes - (\exitCode -> when - (case exitCode of - ExitSuccess -> False - _ -> True - ) - (exitWith exitCode) - ) - Just name -> do - case find (name `isSuffixOf`) canonicalExecutables of - Nothing -> putStrLn "Executable Not Found" - Just specified -> do - exitCode <- system - (commandPrefix ++ specified ++ commandSufix) - exitWith exitCode - Test { testTarget = whichOne, testArgs = testArgs, testRunner = runner } -> - do - build settings - let buildPrefix = appSettingsBuildPrefix settings - let - executableNames = map - (\Executable { executableSourceDir = sourceDir, executableMainFile = mainFile, executableName = name } -> - sourceDir name - ) - (appSettingsTests settings) - let executables = - map (buildPrefix ) $ map (flip (<.>) exe) executableNames - canonicalExecutables <- mapM makeAbsolute executables - case canonicalExecutables of - [] -> putStrLn "No Tests Found" - _ -> - let commandPrefix = case runner of - Nothing -> "" - Just r -> r ++ " " - commandSufix = case testArgs of - Nothing -> "" - Just a -> " " ++ (intercalate " " a) - in case whichOne of - Nothing -> do - exitCodes <- mapM - system - (map (\exe -> commandPrefix ++ exe ++ commandSufix) - canonicalExecutables - ) - forM_ - exitCodes - (\exitCode -> when - (case exitCode of - ExitSuccess -> False - _ -> True - ) - (exitWith exitCode) - ) - Just name -> do - case find (name `isSuffixOf`) canonicalExecutables of - Nothing -> putStrLn "Test Not Found" - Just specified -> do - exitCode <- system - (commandPrefix ++ specified ++ commandSufix) - exitWith exitCode - _ -> putStrLn "Shouldn't be able to get here" - -build :: AppSettings -> IO () -build settings = do - let compilerSettings = appSettingsCompiler settings - let projectName = appSettingsProjectName settings - let buildPrefix = appSettingsBuildPrefix settings - let executables = appSettingsExecutables settings - let examples = appSettingsExamples settings - let tests = appSettingsTests settings - mainDependencyTrees <- fetchDependencies (appSettingsDependencies settings) - builtDependencies <- buildDependencies buildPrefix - compilerSettings - mainDependencyTrees - (executableDepends, maybeTree) <- case appSettingsLibrary settings of - Just librarySettings -> do - let librarySourceDir' = librarySourceDir librarySettings - let thisDependencyTree = Dependency - { dependencyName = projectName - , dependencyPath = "." - , dependencySourcePath = librarySourceDir' - , dependencyBuildScript = libraryBuildScript librarySettings - , dependencyDependencies = mainDependencyTrees - } - thisArchive <- case libraryBuildScript librarySettings of - Just script -> buildWithScript script - "." - (buildPrefix projectName) - compilerSettings - projectName - (map fst builtDependencies) - Nothing -> buildLibrary librarySourceDir' - [".f90", ".f", ".F", ".F90", ".f95", ".f03"] - (buildPrefix projectName) - compilerSettings - projectName - (map fst builtDependencies) - return - $ ( (buildPrefix projectName, thisArchive) : builtDependencies - , Just thisDependencyTree - ) - Nothing -> do - return (builtDependencies, Nothing) - mapM_ - (\Executable { executableSourceDir = sourceDir, executableMainFile = mainFile, executableName = name, executableDependencies = dependencies } -> - do - localDependencies <- - fetchExecutableDependencies maybeTree dependencies - >>= buildDependencies buildPrefix compilerSettings - buildProgram - sourceDir - ((map fst executableDepends) ++ (map fst localDependencies)) - [".f90", ".f", ".F", ".F90", ".f95", ".f03"] - (buildPrefix sourceDir) - compilerSettings - name - mainFile - ((map snd executableDepends) ++ (map snd localDependencies)) - ) - executables - devDependencies <- - fetchExecutableDependencies maybeTree (appSettingsDevDependencies settings) - >>= buildDependencies buildPrefix compilerSettings - mapM_ - (\Executable { executableSourceDir = sourceDir, executableMainFile = mainFile, executableName = name, executableDependencies = dependencies } -> - do - localDependencies <- - fetchExecutableDependencies maybeTree dependencies - >>= buildDependencies buildPrefix compilerSettings - buildProgram - sourceDir - ( (map fst executableDepends) - ++ (map fst devDependencies) - ++ (map fst localDependencies) - ) - [".f90", ".f", ".F", ".F90", ".f95", ".f03"] - (buildPrefix sourceDir) - compilerSettings - name - mainFile - ( (map snd executableDepends) - ++ (map snd devDependencies) - ++ (map snd localDependencies) - ) - ) - examples - mapM_ - (\Executable { executableSourceDir = sourceDir, executableMainFile = mainFile, executableName = name, executableDependencies = dependencies } -> - do - localDependencies <- - fetchExecutableDependencies maybeTree dependencies - >>= buildDependencies buildPrefix compilerSettings - buildProgram - sourceDir - ( (map fst executableDepends) - ++ (map fst devDependencies) - ++ (map fst localDependencies) - ) - [".f90", ".f", ".F", ".F90", ".f95", ".f03"] - (buildPrefix sourceDir) - compilerSettings - name - mainFile - ( (map snd executableDepends) - ++ (map snd devDependencies) - ++ (map snd localDependencies) - ) - ) - tests - -getArguments :: IO Arguments -getArguments = execParser - (info - (arguments <**> helper) - (fullDesc <> progDesc "Work with Fortran projects" <> header - "fpm - A Fortran package manager and build system" - ) - ) - -arguments :: Parser Arguments -arguments = subparser - ( command - "new" - (info (newArguments <**> helper) - (progDesc "Create a new project in a new directory") - ) - <> command - "build" - (info (buildArguments <**> helper) (progDesc "Build the project")) - <> command - "run" - (info (runArguments <**> helper) (progDesc "Run the executable(s)")) - <> command "test" - (info (testArguments <**> helper) (progDesc "Run the test(s)")) - ) - -newArguments :: Parser Arguments -newArguments = - New - <$> strArgument - ( metavar "NAME" - <> help "Name of new project (must be a valid Fortran identifier)" - ) - <*> switch (long "app" <> help "Include an executable") - <*> switch (long "test" <> help "Include a test") - <*> switch (long "lib" <> help "Include a library") - -buildArguments :: Parser Arguments -buildArguments = - Build - <$> switch - ( long "release" - <> help "Build with optimizations instead of debugging" - ) - <*> strOption - ( long "compiler" - <> metavar "COMPILER" - <> value "gfortran" - <> help "specify the compiler to use" - <> showDefault - ) - <*> many - (strOption - ( long "flag" - <> metavar "FLAG" - <> help - "specify an addional argument to pass to the compiler (can appear multiple times)" - ) - ) - -runArguments :: Parser Arguments -runArguments = - Run - <$> switch - ( long "release" - <> help "Build with optimizations instead of debugging" - ) - <*> switch - ( long "example" - <> help "Run example programs instead of applications" - ) - <*> strOption - ( long "compiler" - <> metavar "COMPILER" - <> value "gfortran" - <> help "specify the compiler to use" - <> showDefault - ) - <*> many - (strOption - ( long "flag" - <> metavar "FLAG" - <> help - "specify an addional argument to pass to the compiler (can appear multiple times)" - ) - ) - <*> optional - (strOption - (long "runner" <> metavar "RUNNER" <> help - "specify a command to be used to run the executable(s)" - ) - ) - <*> optional - (strOption - (long "target" <> metavar "TARGET" <> help - "Name of the executable to run" - ) - ) - <*> optional - (many - (strArgument - ( metavar "ARGS" - <> help "Arguments to the executable(s) (should follow '--')" - ) - ) - ) - -testArguments :: Parser Arguments -testArguments = - Test - <$> switch - ( long "release" - <> help "Build with optimizations instead of debugging" - ) - <*> strOption - ( long "compiler" - <> metavar "COMPILER" - <> value "gfortran" - <> help "specify the compiler to use" - <> showDefault - ) - <*> many - (strOption - ( long "flag" - <> metavar "FLAG" - <> help - "specify an addional argument to pass to the compiler (can appear multiple times)" - ) - ) - <*> optional - (strOption - (long "runner" <> metavar "RUNNER" <> help - "specify a command to be used to run the test(s)" - ) - ) - <*> optional - (strOption - (long "target" <> metavar "TARGET" <> help "Name of the test to run" - ) - ) - <*> optional - (many - (strArgument - ( metavar "ARGS" - <> help "Arguments to the test(s) (should follow '--')" - ) - ) - ) - -getDirectoriesFiles :: [FilePath] -> [FilePattern] -> IO [FilePath] -getDirectoriesFiles dirs exts = getDirectoryFilesIO "" newPatterns - where - newPatterns = concatMap appendExts dirs - appendExts dir = map ((dir "*") ++) exts - -settingsCodec :: TomlCodec TomlSettings -settingsCodec = - TomlSettings - <$> Toml.string "name" - .= tomlSettingsProjectName - <*> Toml.dioptional (Toml.table libraryCodec "library") - .= tomlSettingsLibrary - <*> Toml.list executableCodec "executable" - .= tomlSettingsExecutables - <*> Toml.list executableCodec "example" - .= tomlSettingsExamples - <*> Toml.list executableCodec "test" - .= tomlSettingsTests - <*> Toml.tableMap Toml._KeyString versionCodec "dependencies" - .= tomlSettingsDependencies - <*> Toml.tableMap Toml._KeyString versionCodec "dev-dependencies" - .= tomlSettingsDevDependencies - -libraryCodec :: TomlCodec Library -libraryCodec = - Library - <$> Toml.string "source-dir" - .= librarySourceDir - <*> Toml.dioptional (Toml.string "build-script") - .= libraryBuildScript - -executableCodec :: TomlCodec Executable -executableCodec = - Executable - <$> Toml.string "source-dir" - .= executableSourceDir - <*> Toml.string "main" - .= executableMainFile - <*> Toml.string "name" - .= executableName - <*> Toml.tableMap Toml._KeyString versionCodec "dependencies" - .= executableDependencies - -matchSimpleVersion :: Version -> Maybe String -matchSimpleVersion = \case - SimpleVersion v -> Just v - _ -> Nothing - -matchGitVersion :: Version -> Maybe GitVersionSpec -matchGitVersion = \case - GitVersion v -> Just v - _ -> Nothing - -matchPathVersion :: Version -> Maybe PathVersionSpec -matchPathVersion = \case - PathVersion v -> Just v - _ -> Nothing - -matchTag :: GitRef -> Maybe String -matchTag = \case - Tag v -> Just v - _ -> Nothing - -matchBranch :: GitRef -> Maybe String -matchBranch = \case - Branch v -> Just v - _ -> Nothing - -matchCommit :: GitRef -> Maybe String -matchCommit = \case - Commit v -> Just v - _ -> Nothing - -versionCodec :: Toml.Key -> Toml.TomlCodec Version -versionCodec key = - Toml.dimatch matchSimpleVersion SimpleVersion (Toml.string key) - <|> Toml.dimatch matchGitVersion GitVersion (Toml.table gitVersionCodec key) - <|> Toml.dimatch matchPathVersion - PathVersion - (Toml.table pathVersionCodec key) - -gitVersionCodec :: Toml.TomlCodec GitVersionSpec -gitVersionCodec = - GitVersionSpec - <$> Toml.string "git" - .= gitVersionSpecUrl - <*> Toml.dioptional gitRefCodec - .= gitVersionSpecRef - -gitRefCodec :: Toml.TomlCodec GitRef -gitRefCodec = - Toml.dimatch matchTag Tag (Toml.string "tag") - <|> Toml.dimatch matchBranch Branch (Toml.string "branch") - <|> Toml.dimatch matchCommit Commit (Toml.string "rev") - -pathVersionCodec :: Toml.TomlCodec PathVersionSpec -pathVersionCodec = - PathVersionSpec <$> Toml.string "path" .= pathVersionSpecPath - -toml2AppSettings :: TomlSettings -> Arguments -> IO AppSettings -toml2AppSettings tomlSettings args = do - let release = case args of - Build { buildRelease = r } -> r - Run { runRelease = r } -> r - Test { testRelease = r } -> r - let projectName = tomlSettingsProjectName tomlSettings - let compiler = case args of - Build { buildCompiler = c } -> c - Run { runCompiler = c } -> c - Test { testCompiler = c } -> c - let specifiedFlags = case args of - Build { buildFlags = f } -> f - Run { runFlags = f } -> f - Test { testFlags = f } -> f - when (release && (length specifiedFlags > 0)) $ do - putStrLn "--release and --flag are mutually exclusive" - exitWith (ExitFailure 1) - librarySettings <- getLibrarySettings $ tomlSettingsLibrary tomlSettings - executableSettings <- getExecutableSettings - (tomlSettingsExecutables tomlSettings) - projectName - exampleSettings <- getExampleSettings $ tomlSettingsExamples tomlSettings - testSettings <- getTestSettings $ tomlSettingsTests tomlSettings - compilerSettings <- defineCompilerSettings specifiedFlags compiler release - buildPrefix <- makeBuildPrefix (compilerSettingsCompiler compilerSettings) - (compilerSettingsFlags compilerSettings) - let dependencies = tomlSettingsDependencies tomlSettings - let devDependencies = tomlSettingsDevDependencies tomlSettings - return AppSettings { appSettingsCompiler = compilerSettings - , appSettingsProjectName = projectName - , appSettingsBuildPrefix = buildPrefix - , appSettingsLibrary = librarySettings - , appSettingsExecutables = executableSettings - , appSettingsExamples = exampleSettings - , appSettingsTests = testSettings - , appSettingsDependencies = dependencies - , appSettingsDevDependencies = devDependencies - } - -defineCompilerSettings :: [String] -> FilePath -> Bool -> IO CompilerSettings -defineCompilerSettings specifiedFlags compiler release - | "gfortran" `isInfixOf` compiler - = let flags = case specifiedFlags of - [] -> if release - then - [ "-Wall" - , "-Wextra" - , "-Wimplicit-interface" - , "-fPIC" - , "-fmax-errors=1" - , "-O3" - , "-march=native" - , "-funroll-loops" - , "-fcoarray=single" - ] - else - [ "-Wall" - , "-Wextra" - , "-Wimplicit-interface" - , "-fPIC" - , "-fmax-errors=1" - , "-g" - , "-fbounds-check" - , "-fcheck-array-temporaries" - , "-fbacktrace" - , "-fcoarray=single" - ] - fs -> fs - in return $ CompilerSettings { compilerSettingsCompiler = compiler - , compilerSettingsFlags = flags - , compilerSettingsModuleFlag = "-J" - , compilerSettingsIncludeFlag = "-I" - } - | "caf" `isInfixOf` compiler - = let flags = case specifiedFlags of - [] -> if release - then - [ "-Wall" - , "-Wextra" - , "-Wimplicit-interface" - , "-fPIC" - , "-fmax-errors=1" - , "-O3" - , "-march=native" - , "-funroll-loops" - ] - else - [ "-Wall" - , "-Wextra" - , "-Wimplicit-interface" - , "-fPIC" - , "-fmax-errors=1" - , "-g" - , "-fbounds-check" - , "-fcheck-array-temporaries" - , "-fbacktrace" - ] - fs -> fs - in return $ CompilerSettings { compilerSettingsCompiler = compiler - , compilerSettingsFlags = flags - , compilerSettingsModuleFlag = "-J" - , compilerSettingsIncludeFlag = "-I" - } - | "f95" `isInfixOf` compiler - = let flags = case specifiedFlags of - [] -> if release - then - [ "-O3" - , "-Wimplicit-interface" - , "-fPIC" - , "-fmax-errors=1" - , "-funroll-loops" - ] - else - [ "-Wall" - , "-Wextra" - , "-Wimplicit-interface" - , "-fPIC" - , "-fmax-errors=1" - , "-g" - , "-fbounds-check" - , "-fcheck-array-temporaries" - , "-Wno-maybe-uninitialized" - , "-Wno-uninitialized" - , "-fbacktrace" - ] - fs -> fs - in return $ CompilerSettings { compilerSettingsCompiler = compiler - , compilerSettingsFlags = flags - , compilerSettingsModuleFlag = "-J" - , compilerSettingsIncludeFlag = "-I" - } - | "nvfortran" `isInfixOf` compiler - = let flags = case specifiedFlags of - [] -> if release - then - [ "-Mbackslash" - ] - else - [ "-Minform=inform" - , "-Mbackslash" - , "-g" - , "-Mbounds" - , "-Mchkptr" - , "-Mchkstk" - , "-traceback" - ] - fs -> fs - in return $ CompilerSettings { compilerSettingsCompiler = compiler - , compilerSettingsFlags = flags - , compilerSettingsModuleFlag = "-module" - , compilerSettingsIncludeFlag = "-I" - } - | "ifort" `isInfixOf` compiler - = let flags = case specifiedFlags of - [] -> if release - then - [ "-fp-model", "precise" - , "-pc", "64" - , "-align", "all" - , "-error-limit", "1" - , "-reentrancy", "threaded" - , "-nogen-interfaces" - , "-assume", "byterecl" - , "-assume", "nounderscore" - ] - else - [ "-warn", "all" - , "-check:all:noarg_temp_created" - , "-error-limit", "1" - , "-O0" - , "-g" - , "-assume", "byterecl" - , "-traceback" - ] - fs -> fs - in return $ CompilerSettings { compilerSettingsCompiler = compiler - , compilerSettingsFlags = flags - , compilerSettingsModuleFlag = "-module" - , compilerSettingsIncludeFlag = "-I" - } - | "ifx" `isInfixOf` compiler - = let flags = case specifiedFlags of - [] -> if release - then - [] - else - [] - fs -> fs - in return $ CompilerSettings { compilerSettingsCompiler = compiler - , compilerSettingsFlags = flags - , compilerSettingsModuleFlag = "-module" - , compilerSettingsIncludeFlag = "-I" - } - | "pgfortran" `isInfixOf` compiler || "pgf90" `isInfixOf` compiler || "pgf95" `isInfixOf` compiler - = let flags = case specifiedFlags of - [] -> if release - then - [] - else - [] - fs -> fs - in return $ CompilerSettings { compilerSettingsCompiler = compiler - , compilerSettingsFlags = flags - , compilerSettingsModuleFlag = "-module" - , compilerSettingsIncludeFlag = "-I" - } - | "flang" `isInfixOf` compiler - = let flags = case specifiedFlags of - [] -> if release - then - [] - else - [] - fs -> fs - in return $ CompilerSettings { compilerSettingsCompiler = compiler - , compilerSettingsFlags = flags - , compilerSettingsModuleFlag = "-module" - , compilerSettingsIncludeFlag = "-I" - } - | "lfc" `isInfixOf` compiler - = let flags = case specifiedFlags of - [] -> if release - then - [] - else - [] - fs -> fs - in return $ CompilerSettings { compilerSettingsCompiler = compiler - , compilerSettingsFlags = flags - , compilerSettingsModuleFlag = "-M" - , compilerSettingsIncludeFlag = "-I" - } - | "nagfor" `isInfixOf` compiler - = let flags = case specifiedFlags of - [] -> if release - then - [ "-O4" - , "-coarray=single" - , "-PIC" - ] - else - [ "-g" - , "-C=all" - , "-O0" - , "-gline" - , "-coarray=single" - , "-PIC" - ] - fs -> fs - in return $ CompilerSettings { compilerSettingsCompiler = compiler - , compilerSettingsFlags = flags - , compilerSettingsModuleFlag = "-mdir" - , compilerSettingsIncludeFlag = "-I" - } - | "crayftn" `isInfixOf` compiler - = let flags = case specifiedFlags of - [] -> if release - then - [] - else - [] - fs -> fs - in return $ CompilerSettings { compilerSettingsCompiler = compiler - , compilerSettingsFlags = flags - , compilerSettingsModuleFlag = "-J" - , compilerSettingsIncludeFlag = "-I" - } - | "xlf90" `isInfixOf` compiler - = let flags = case specifiedFlags of - [] -> if release - then - [] - else - [] - fs -> fs - in return $ CompilerSettings { compilerSettingsCompiler = compiler - , compilerSettingsFlags = flags - , compilerSettingsModuleFlag = "-qmoddir" - , compilerSettingsIncludeFlag = "-I" - } - | otherwise - = do - putStrLn $ "Sorry, compiler is currently unsupported: " ++ compiler - exitWith (ExitFailure 1) - -getLibrarySettings :: Maybe Library -> IO (Maybe Library) -getLibrarySettings maybeSettings = case maybeSettings of - Just settings -> return maybeSettings - Nothing -> do - defaultExists <- doesDirectoryExist "src" - if defaultExists - then return - (Just - (Library { librarySourceDir = "src", libraryBuildScript = Nothing }) - ) - else return Nothing - -getExecutableSettings :: [Executable] -> String -> IO [Executable] -getExecutableSettings [] projectName = do - defaultDirectoryExists <- doesDirectoryExist "app" - if defaultDirectoryExists - then do - defaultMainExists <- doesFileExist ("app" "main.f90") - if defaultMainExists - then return - [ Executable { executableSourceDir = "app" - , executableMainFile = "main.f90" - , executableName = projectName - , executableDependencies = Map.empty - } - ] - else return [] - else return [] -getExecutableSettings executables _ = return executables - -getExampleSettings :: [Executable] -> IO [Executable] -getExampleSettings [] = do - defaultDirectoryExists <- doesDirectoryExist "example" - if defaultDirectoryExists - then do - defaultMainExists <- doesFileExist ("example" "main.f90") - if defaultMainExists - then return - [ Executable { executableSourceDir = "example" - , executableMainFile = "main.f90" - , executableName = "demo" - , executableDependencies = Map.empty - } - ] - else return [] - else return [] -getExampleSettings examples = return examples - -getTestSettings :: [Executable] -> IO [Executable] -getTestSettings [] = do - defaultDirectoryExists <- doesDirectoryExist "test" - if defaultDirectoryExists - then do - defaultMainExists <- doesFileExist ("test" "main.f90") - if defaultMainExists - then return - [ Executable { executableSourceDir = "test" - , executableMainFile = "main.f90" - , executableName = "runTests" - , executableDependencies = Map.empty - } - ] - else return [] - else return [] -getTestSettings tests = return tests - -makeBuildPrefix :: FilePath -> [String] -> IO FilePath -makeBuildPrefix compiler flags = do - -- TODO Figure out what other info should be part of this - -- Probably version, and make sure to not include path to the compiler - versionInfo <- do - (exitCode, stdout, stderr) <- readProcessWithExitCode compiler - ["--version"] - [] - case exitCode of - ExitSuccess -> case stdout of - "" -> return stderr -- Guess this compiler outputs version info to stderr instead? - _ -> return stdout - _ -> do -- guess this compiler doesn't support the --version option. let's try -version - (exitCode, stdout, stderr) <- readProcessWithExitCode compiler - ["-version"] - [] - case exitCode of - ExitSuccess -> case stdout of - "" -> return stderr -- Guess this compiler outputs version info to stderr instead? - _ -> return stdout - _ -> return "" -- Don't know how to get version info, we'll let defineCompilerSettings report it as unsupported - let compilerName = last (splitDirectories compiler) - let versionHash = abs (hash versionInfo) - let flagsHash = abs (hash flags) - return - $ "build" - compilerName - ++ "_" - ++ showHex versionHash "" - ++ "_" - ++ showHex flagsHash "" - -{- - Fetching the dependencies is done on a sort of breadth first approach. All - of the dependencies are fetched before doing the transitive dependencies. - This means that the top level dependencies dictate which version is fetched. - The fetchDependency function is idempotent, so we don't have to worry about - dealing with half fetched, or adding dependencies. - TODO check for version compatibility issues --} -fetchDependencies :: Map.Map String Version -> IO [DependencyTree] -fetchDependencies dependencies = do - theseDependencies <- mapM (uncurry fetchDependency) (Map.toList dependencies) - mapM fetchTransitiveDependencies theseDependencies - where - fetchTransitiveDependencies :: (String, FilePath) -> IO DependencyTree - fetchTransitiveDependencies (name, path) = do - tomlSettings <- Toml.decodeFile settingsCodec (path "fpm.toml") - librarySettingsM <- withCurrentDirectory path - $ getLibrarySettings (tomlSettingsLibrary tomlSettings) - case librarySettingsM of - Just librarySettings -> do - newDependencies <- fetchDependencies - (tomlSettingsDependencies tomlSettings) - return $ Dependency - { dependencyName = name - , dependencyPath = path - , dependencySourcePath = path (librarySourceDir librarySettings) - , dependencyBuildScript = libraryBuildScript librarySettings - , dependencyDependencies = newDependencies - } - Nothing -> do - putStrLn $ "No library found in " ++ name - undefined - -fetchExecutableDependencies - :: (Maybe DependencyTree) -> Map.Map String Version -> IO [DependencyTree] -fetchExecutableDependencies maybeProjectTree dependencies = - case maybeProjectTree of - Just projectTree@(Dependency name _ _ _ _) -> - if name `Map.member` dependencies {- map contains this project-} - then fmap (projectTree :) - (fetchDependencies (Map.delete name dependencies)) {- fetch the other dependencies and include the project tree in the result -} - else do {- fetch all the dependencies, passing the project tree on down -} - theseDependencies <- mapM (uncurry fetchDependency) - (Map.toList dependencies) - mapM fetchTransitiveDependencies theseDependencies - Nothing -> fetchDependencies dependencies - where - fetchTransitiveDependencies :: (String, FilePath) -> IO DependencyTree - fetchTransitiveDependencies (name, path) = do - tomlSettings <- Toml.decodeFile settingsCodec (path "fpm.toml") - librarySettingsM <- withCurrentDirectory path - $ getLibrarySettings (tomlSettingsLibrary tomlSettings) - case librarySettingsM of - Just librarySettings -> do - newDependencies <- fetchExecutableDependencies - maybeProjectTree - (tomlSettingsDependencies tomlSettings) - return $ Dependency - { dependencyName = name - , dependencyPath = path - , dependencySourcePath = path (librarySourceDir librarySettings) - , dependencyBuildScript = libraryBuildScript librarySettings - , dependencyDependencies = newDependencies - } - Nothing -> do - putStrLn $ "No library found in " ++ name - undefined - -fetchDependency :: String -> Version -> IO (String, FilePath) -fetchDependency name version = do - let clonePath = "build" "dependencies" name - alreadyFetched <- doesDirectoryExist clonePath - if alreadyFetched - then return (name, clonePath) - else case version of - SimpleVersion _ -> do - putStrLn "Simple dependencies are not yet supported :(" - undefined - GitVersion versionSpec -> do - system ("git init " ++ clonePath) - case gitVersionSpecRef versionSpec of - Just ref -> do - system - ( "git -C " - ++ clonePath - ++ " fetch " - ++ gitVersionSpecUrl versionSpec - ++ " " - ++ (case ref of - Tag tag -> tag - Branch branch -> branch - Commit commit -> commit - ) - ) - Nothing -> do - system - ( "git -C " - ++ clonePath - ++ " fetch " - ++ gitVersionSpecUrl versionSpec - ) - system ("git -C " ++ clonePath ++ " checkout -qf FETCH_HEAD") - return (name, clonePath) - PathVersion versionSpec -> return (name, pathVersionSpecPath versionSpec) - -{- - Bulding the dependencies is done on a depth first basis to ensure all of - the transitive dependencies have been built before trying to build this one --} -buildDependencies - :: String -> CompilerSettings -> [DependencyTree] -> IO [(FilePath, FilePath)] -buildDependencies buildPrefix compilerSettings dependencies = do - built <- concatMapM (buildDependency buildPrefix compilerSettings) - dependencies - return $ reverse (nub (reverse built)) - -buildDependency - :: String -> CompilerSettings -> DependencyTree -> IO [(FilePath, FilePath)] -buildDependency buildPrefix compilerSettings (Dependency name path sourcePath mBuildScript dependencies) - = do - transitiveDependencies <- buildDependencies buildPrefix - compilerSettings - dependencies - let buildPath = buildPrefix name - thisArchive <- case mBuildScript of - Just script -> buildWithScript script - path - buildPath - compilerSettings - name - (map fst transitiveDependencies) - Nothing -> buildLibrary sourcePath - [".f90", ".f", ".F", ".F90", ".f95", ".f03"] - buildPath - compilerSettings - name - (map fst transitiveDependencies) - return $ (buildPath, thisArchive) : transitiveDependencies - -createNewProject :: String -> Bool -> Bool -> Bool -> IO () -createNewProject projectName withExecutable withTest withLib = do - createDirectory projectName - writeFile (projectName "fpm.toml") (templateFpmToml projectName) - writeFile (projectName "README.md") (templateReadme projectName) - writeFile (projectName ".gitignore") "build/*\n" - when withLib $ do - createDirectory (projectName "src") - writeFile (projectName "src" projectName <.> "f90") - (templateModule projectName) - when withExecutable $ do - createDirectory (projectName "app") - writeFile (projectName "app" "main.f90") - (templateProgram projectName withLib) - when withTest $ do - createDirectory (projectName "test") - writeFile (projectName "test" "main.f90") templateTest - withCurrentDirectory projectName $ do - system "git init" - return () - -templateFpmToml :: String -> String -templateFpmToml projectName = - "name = \"" - ++ projectName - ++ "\"\n" - ++ "version = \"0.1.0\"\n" - ++ "license = \"license\"\n" - ++ "author = \"Jane Doe\"\n" - ++ "maintainer = \"jane.doe@example.com\"\n" - ++ "copyright = \"2020 Jane Doe\"\n" - -templateModule :: String -> String -templateModule projectName = - "module " - ++ projectName - ++ "\n" - ++ " implicit none\n" - ++ " private\n" - ++ "\n" - ++ " public :: say_hello\n" - ++ "contains\n" - ++ " subroutine say_hello\n" - ++ " print *, \"Hello, " - ++ projectName - ++ "!\"\n" - ++ " end subroutine say_hello\n" - ++ "end module " - ++ projectName - ++ "\n" - -templateReadme :: String -> String -templateReadme projectName = - "# " ++ projectName ++ "\n" ++ "\n" ++ "My cool new project!\n" - -templateProgram :: String -> Bool -> String -templateProgram projectName withLib = - "program main\n" - ++ (if withLib then " use " ++ projectName ++ ", only: say_hello\n" else "" - ) - ++ "\n" - ++ " implicit none\n" - ++ "\n" - ++ " call say_hello\n" - ++ "end program main\n" - -templateTest :: String -templateTest = - "program main\n" - ++ " implicit none\n" - ++ "\n" - ++ " print *, \"Put some tests in here!\"\n" - ++ "end program main\n" diff --git a/bootstrap/stack.yaml b/bootstrap/stack.yaml deleted file mode 100644 index 7147c40..0000000 --- a/bootstrap/stack.yaml +++ /dev/null @@ -1,74 +0,0 @@ -# This file was automatically generated by 'stack init' -# -# Some commonly used options have been documented as comments in this file. -# For advanced use and comprehensive documentation of the format, please see: -# https://docs.haskellstack.org/en/stable/yaml_configuration/ - -# Resolver to choose a 'specific' stackage snapshot or a compiler version. -# A snapshot resolver dictates the compiler version and the set of packages -# to be used for project dependencies. For example: -# -# resolver: lts-3.5 -# resolver: nightly-2015-09-21 -# resolver: ghc-7.10.2 -# -# The location of a snapshot can be provided as a file or url. Stack assumes -# a snapshot provided as a file might change, whereas a url resource does not. -# -# resolver: ./custom-snapshot.yaml -# resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: lts-14.27 - -# User packages to be built. -# Various formats can be used as shown in the example below. -# -# packages: -# - some-directory -# - https://example.com/foo/bar/baz-0.0.2.tar.gz -# subdirs: -# - auto-update -# - wai -packages: -- . -# Dependency packages to be pulled from upstream that are not in the resolver. -# These entries can reference officially published versions as well as -# forks / in-progress versions pinned to a git hash. For example: -# -# extra-deps: -# - acme-missiles-0.3 -# - git: https://github.com/commercialhaskell/stack.git -# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# -extra-deps: -- git: https://github.com/kowainik/tomland.git - commit: 536a5e6ffb148d0dd4e4c4b120913a6744097676 -- git: https://gitlab.com/everythingfunctional/hedge.git - commit: 1c6cba3b5f8e52cf317f2421aaca13a0ddab4e92 - subdirs: - - . - - hedge-trimmer -- quickcheck-with-counterexamples-1.2 - -# Override default flag values for local packages and extra-deps -# flags: {} - -# Extra package databases containing global packages -# extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true -# -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: ">=2.1" -# -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 -# -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] -# -# Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor diff --git a/bootstrap/stack.yaml.lock b/bootstrap/stack.yaml.lock deleted file mode 100644 index 0ca18ae..0000000 --- a/bootstrap/stack.yaml.lock +++ /dev/null @@ -1,43 +0,0 @@ -# This file was autogenerated by Stack. -# You should not edit this file by hand. -# For more information, please see the documentation at: -# https://docs.haskellstack.org/en/stable/lock_files - -packages: -- completed: - name: tomland - version: 1.3.0.0 - git: https://github.com/kowainik/tomland.git - pantry-tree: - size: 5000 - sha256: 68d6f9a3e4c20cc4645374b30000017a75c4ab1c131590538edad2ea0e4a53bd - commit: 536a5e6ffb148d0dd4e4c4b120913a6744097676 - original: - git: https://github.com/kowainik/tomland.git - commit: 536a5e6ffb148d0dd4e4c4b120913a6744097676 -- completed: - subdir: hedge-trimmer - name: hedge-trimmer - version: 1.0.0.0 - git: https://gitlab.com/everythingfunctional/hedge.git - pantry-tree: - size: 226 - sha256: 19972f5b81c7627d6b66c852dfb7e0e67b3931ed4f418663c152717ce4ea267e - commit: 1c6cba3b5f8e52cf317f2421aaca13a0ddab4e92 - original: - subdir: hedge-trimmer - git: https://gitlab.com/everythingfunctional/hedge.git - commit: 1c6cba3b5f8e52cf317f2421aaca13a0ddab4e92 -- completed: - hackage: quickcheck-with-counterexamples-1.2@sha256:d322d79008602df26f5eb4e1379e5b58bf1a92604df8601e71e200cfc3e847a3,1688 - pantry-tree: - size: 724 - sha256: 0046517e3cc2adebfce19d4aad05a06dcf55ec9e572fa1c661ba9abe81386484 - original: - hackage: quickcheck-with-counterexamples-1.2 -snapshots: -- completed: - size: 524996 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/27.yaml - sha256: 7ea31a280c56bf36ff591a7397cc384d0dff622e7f9e4225b47d8980f019a0f0 - original: lts-14.27 diff --git a/bootstrap/test/Spec.hs b/bootstrap/test/Spec.hs deleted file mode 100644 index 6e9daa2..0000000 --- a/bootstrap/test/Spec.hs +++ /dev/null @@ -1,103 +0,0 @@ -import Development.Shake.FilePath ( () ) -import Fpm ( Arguments(..) - , start - ) -import System.Directory ( withCurrentDirectory ) - -example_path = "test" "example_packages" - -main :: IO () -main = do - testHelloWorld - testHelloComplex - testHelloFpm - testCircular - testWithMakefile - testMakefileComplex - testSubmodule - -testHelloWorld :: IO () -testHelloWorld = - withCurrentDirectory (example_path "hello_world") $ start $ Run - { runRelease = False - , runExample = False - , runCompiler = "gfortran" - , runFlags = [] - , runRunner = Nothing - , runTarget = Nothing - , runArgs = Nothing - } - -testHelloComplex :: IO () -testHelloComplex = - withCurrentDirectory (example_path "hello_complex") $ start $ Test - { testRelease = False - , testCompiler = "gfortran" - , testFlags = [] - , testRunner = Nothing - , testTarget = Nothing - , testArgs = Nothing - } - -testHelloFpm :: IO () -testHelloFpm = - withCurrentDirectory (example_path "hello_fpm") $ start $ Run - { runRelease = False - , runExample = False - , runCompiler = "gfortran" - , runFlags = [] - , runRunner = Nothing - , runTarget = Nothing - , runArgs = Nothing - } - -testWithExamples :: IO () -testWithExamples = - withCurrentDirectory (example_path "with_examples") $ start $ Run - { runRelease = False - , runExample = True - , runCompiler = "gfortran" - , runFlags = [] - , runRunner = Nothing - , runTarget = Nothing - , runArgs = Nothing - } - -testCircular :: IO () -testCircular = - withCurrentDirectory (example_path "circular_example") $ start $ Test - { testRelease = False - , testCompiler = "gfortran" - , testFlags = [] - , testRunner = Nothing - , testTarget = Nothing - , testArgs = Nothing - } - -testWithMakefile :: IO () -testWithMakefile = - withCurrentDirectory (example_path "with_makefile") $ start $ Build - { buildRelease = False - , buildCompiler = "gfortran" - , buildFlags = [] - } - -testMakefileComplex :: IO () -testMakefileComplex = - withCurrentDirectory (example_path "makefile_complex") $ start $ Run - { runRelease = False - , runExample = False - , runCompiler = "gfortran" - , runFlags = [] - , runRunner = Nothing - , runTarget = Nothing - , runArgs = Nothing - } - -testSubmodule :: IO () -testSubmodule = - withCurrentDirectory (example_path "submodules") $ start $ Build - { buildRelease = False - , buildCompiler = "gfortran" - , buildFlags = [] - } diff --git a/bootstrap/test/example_packages b/bootstrap/test/example_packages deleted file mode 120000 index b7c12dc..0000000 --- a/bootstrap/test/example_packages +++ /dev/null @@ -1 +0,0 @@ -../../example_packages \ No newline at end of file diff --git a/bootstrap/unit_test/ModuleSourceConstructionTest.hs b/bootstrap/unit_test/ModuleSourceConstructionTest.hs deleted file mode 100644 index b98e9d3..0000000 --- a/bootstrap/unit_test/ModuleSourceConstructionTest.hs +++ /dev/null @@ -1,83 +0,0 @@ -module ModuleSourceConstructionTest - ( test - ) -where - -import BuildModel ( RawSource(..) - , Source(..) - , processRawSource - ) -import Hedge ( Result - , Test - , assertEquals - , assertThat - , fail' - , givenInput - , then' - , whenTransformed - ) -import System.FilePath ( () ) - -test :: IO (Test ()) -test = return $ givenInput - "a module" - exampleModule - [ whenTransformed - "processed to a source" - processRawSource - [ then' "it is a Module" checkIsModule - , then' "its source file name is the same as the original" - checkModuleSourceFileName - , then' - "its object file name is the 'flattened' path of the source file with '.o' appeneded" - checkModuleObjectFileName - , then' "it knows what modules it uses directly" checkModuleModulesUsed - , then' "it knows its name" checkModuleName - , then' "it can tell that it will produce a '.smod' file" checkSmod - ] - ] - -exampleModule :: RawSource -exampleModule = RawSource moduleSourceFileName' $ unlines - [ "module some_module" - , " use module1" - , " USE MODULE2" - , " implicit none" - , " interface" - , " pure module function some_func()" - , " integer :: some_func" - , " end function" - , " end interface" - , "end module" - ] - -moduleSourceFileName' :: String -moduleSourceFileName' = "some" "file" "somewhere.f90" - -checkIsModule :: Source -> Result -checkIsModule Module{} = assertThat True -checkIsModule _ = assertThat False - -checkModuleSourceFileName :: Source -> Result -checkModuleSourceFileName m@(Module{}) = - assertEquals moduleSourceFileName' $ moduleSourceFileName m -checkModuleSourceFileName _ = fail' "wasn't a Module" - -checkModuleObjectFileName :: Source -> Result -checkModuleObjectFileName m@(Module{}) = - assertEquals ("." "some_file_somewhere.f90.o") - $ (moduleObjectFileName m) "." -checkModuleObjectFileName _ = fail' "wasn't a Module" - -checkModuleModulesUsed :: Source -> Result -checkModuleModulesUsed m@(Module{}) = - assertEquals ["module1", "module2"] $ moduleModulesUsed m -checkModuleModulesUsed _ = fail' "wasn't a Module" - -checkModuleName :: Source -> Result -checkModuleName m@(Module{}) = assertEquals "some_module" $ moduleName m -checkModuleName _ = fail' "wasn't a Module" - -checkSmod :: Source -> Result -checkSmod m@(Module{}) = assertThat $ moduleProducesSmod m -checkSmod _ = fail' "wasn't a Module" diff --git a/bootstrap/unit_test/ModuleToCompileInfoTest.hs b/bootstrap/unit_test/ModuleToCompileInfoTest.hs deleted file mode 100644 index 08cd67c..0000000 --- a/bootstrap/unit_test/ModuleToCompileInfoTest.hs +++ /dev/null @@ -1,73 +0,0 @@ -module ModuleToCompileInfoTest - ( test - ) -where - -import BuildModel ( AvailableModule(..) - , CompileTimeInfo(..) - , Source(..) - , constructCompileTimeInfo - ) -import Hedge ( Result - , Test - , assertEquals - , givenInput - , then' - , whenTransformed - ) -import System.FilePath ( () ) - -test :: IO (Test ()) -test = return $ givenInput - "a module and available modules" - (exampleModule, availableModules) - [ whenTransformed - "its compileTimeInfo is determined" - doCompileTimeTransformation - [ then' "it stil knows the original source file" checkSourceFileName - , then' "it knows what object file will be produced" checkObjectFileName - , then' "the mod and smod files are also produced" checkOtherFilesProduced - , then' "the direct dependencies are only the available modules used" - checkDirectDependencies - ] - ] - -exampleModule :: Source -exampleModule = Module - { moduleSourceFileName = moduleSourceFileName' - , moduleObjectFileName = \bd -> bd "some_file_somewhere.f90.o" - , moduleModulesUsed = ["module1", "module2", "module3"] - , moduleName = "some_module" - , moduleProducesSmod = True - } - -moduleSourceFileName' :: FilePath -moduleSourceFileName' = "some" "file" "somewhere.f90" - -availableModules :: [AvailableModule] -availableModules = [ AvailableModule {availableModuleName = "module1", availableModuleFile = "build_dir" "module1.mod"} - , AvailableModule {availableModuleName = "module3", availableModuleFile = "build_dir" "module3.mod"} - ] - -doCompileTimeTransformation :: (Source, [AvailableModule]) -> CompileTimeInfo -doCompileTimeTransformation (programSource, otherSources) = - constructCompileTimeInfo programSource otherSources "build_dir" - -checkSourceFileName :: CompileTimeInfo -> Result -checkSourceFileName cti = - assertEquals moduleSourceFileName' (compileTimeInfoSourceFileName cti) - -checkObjectFileName :: CompileTimeInfo -> Result -checkObjectFileName cti = assertEquals - ("build_dir" "some_file_somewhere.f90.o") - (compileTimeInfoObjectFileProduced cti) - -checkOtherFilesProduced :: CompileTimeInfo -> Result -checkOtherFilesProduced cti = assertEquals - ["build_dir" "some_module.mod", "build_dir" "some_module.smod"] - (compileTimeInfoOtherFilesProduced cti) - -checkDirectDependencies :: CompileTimeInfo -> Result -checkDirectDependencies cti = assertEquals - ["build_dir" "module1.mod", "build_dir" "module3.mod"] - (compileTimeInfoDirectDependencies cti) diff --git a/bootstrap/unit_test/ProgramSourceConstructionTest.hs b/bootstrap/unit_test/ProgramSourceConstructionTest.hs deleted file mode 100644 index 6369965..0000000 --- a/bootstrap/unit_test/ProgramSourceConstructionTest.hs +++ /dev/null @@ -1,69 +0,0 @@ -module ProgramSourceConstructionTest - ( test - ) -where - -import BuildModel ( RawSource(..) - , Source(..) - , processRawSource - ) -import Hedge ( Result - , Test - , assertEquals - , assertThat - , fail' - , givenInput - , then' - , whenTransformed - ) -import System.FilePath ( () ) - -test :: IO (Test ()) -test = return $ givenInput - "a program" - exampleProgram - [ whenTransformed - "processed to a source" - processRawSource - [ then' "it is a Program" checkIsProgram - , then' "its source file name is the same as the original" - checkProgramSourceFileName - , then' - "its object file name is the 'flattened' path of the source file with '.o' appended" - checkProgramObjectFileName - , then' "it knows what modules it uses directly" checkProgramModulesUsed - ] - ] - -exampleProgram :: RawSource -exampleProgram = RawSource programSourceFileName' $ unlines - [ "program some_program" - , " use module1" - , " USE MODULE2" - , " implicit none" - , " print *, \"Hello, World!\"" - , "end program" - ] - -programSourceFileName' :: String -programSourceFileName' = "some" "file" "somewhere.f90" - -checkIsProgram :: Source -> Result -checkIsProgram Program{} = assertThat True -checkIsProgram _ = assertThat False - -checkProgramSourceFileName :: Source -> Result -checkProgramSourceFileName p@(Program{}) = - assertEquals programSourceFileName' $ programSourceFileName p -checkProgramSourceFileName _ = fail' "wasn't a Program" - -checkProgramObjectFileName :: Source -> Result -checkProgramObjectFileName p@(Program{}) = - assertEquals ("." "some_file_somewhere.f90.o") - $ (programObjectFileName p) "." -checkProgramObjectFileName _ = fail' "wasn't a Program" - -checkProgramModulesUsed :: Source -> Result -checkProgramModulesUsed p@(Program{}) = - assertEquals ["module1", "module2"] $ programModulesUsed p -checkProgramModulesUsed _ = fail' "wasn't a Program" diff --git a/bootstrap/unit_test/ProgramToCompileInfoTest.hs b/bootstrap/unit_test/ProgramToCompileInfoTest.hs deleted file mode 100644 index a9ad39b..0000000 --- a/bootstrap/unit_test/ProgramToCompileInfoTest.hs +++ /dev/null @@ -1,71 +0,0 @@ -module ProgramToCompileInfoTest - ( test - ) -where - -import BuildModel ( AvailableModule(..) - , CompileTimeInfo(..) - , Source(..) - , constructCompileTimeInfo - ) -import Hedge ( Result - , Test - , assertEmpty - , assertEquals - , givenInput - , then' - , whenTransformed - ) -import System.FilePath ( () ) - -test :: IO (Test ()) -test = return $ givenInput - "a program and available modules" - (exampleProgram, availableModules) - [ whenTransformed - "its compileTimeInfo is determined" - doCompileTimeTransformation - [ then' "it still knows the original source file" checkSourceFileName - , then' "it knows what object file will be produced" checkObjectFileName - , then' "there are no other files produced" checkOtherFilesProduced - , then' "the direct dependencies are only the available modules used" - checkDirectDependencies - ] - ] - -exampleProgram :: Source -exampleProgram = Program - { programSourceFileName = programSourceFileName' - , programObjectFileName = \bd -> bd "some_file_somewhere.f90.o" - , programModulesUsed = ["module1", "module2", "module3"] - } - -programSourceFileName' :: FilePath -programSourceFileName' = "some" "file" "somewhere.f90" - -availableModules :: [AvailableModule] -availableModules = [ AvailableModule {availableModuleName = "module1", availableModuleFile = "build_dir" "module1.mod"} - , AvailableModule {availableModuleName = "module3", availableModuleFile = "build_dir" "module3.mod"} - ] - -doCompileTimeTransformation :: (Source, [AvailableModule]) -> CompileTimeInfo -doCompileTimeTransformation (programSource, otherSources) = - constructCompileTimeInfo programSource otherSources "build_dir" - -checkSourceFileName :: CompileTimeInfo -> Result -checkSourceFileName cti = - assertEquals programSourceFileName' (compileTimeInfoSourceFileName cti) - -checkObjectFileName :: CompileTimeInfo -> Result -checkObjectFileName cti = assertEquals - ("build_dir" "some_file_somewhere.f90.o") - (compileTimeInfoObjectFileProduced cti) - -checkOtherFilesProduced :: CompileTimeInfo -> Result -checkOtherFilesProduced cti = - assertEmpty (compileTimeInfoOtherFilesProduced cti) - -checkDirectDependencies :: CompileTimeInfo -> Result -checkDirectDependencies cti = assertEquals - ["build_dir" "module1.mod", "build_dir" "module3.mod"] - (compileTimeInfoDirectDependencies cti) diff --git a/bootstrap/unit_test/SubmoduleSourceConstructionTest.hs b/bootstrap/unit_test/SubmoduleSourceConstructionTest.hs deleted file mode 100644 index d07a6ed..0000000 --- a/bootstrap/unit_test/SubmoduleSourceConstructionTest.hs +++ /dev/null @@ -1,79 +0,0 @@ -module SubmoduleSourceConstructionTest - ( test - ) -where - -import BuildModel ( RawSource(..) - , Source(..) - , processRawSource - ) -import Hedge ( Result - , Test - , assertEquals - , assertThat - , fail' - , givenInput - , then' - , whenTransformed - ) -import System.FilePath ( () ) - -test :: IO (Test ()) -test = return $ givenInput - "a submodule" - exampleSubmodule - [ whenTransformed - "processed to a source" - processRawSource - [ then' "it is a Submodule" checkIsSubmodule - , then' "its source file name is the same as the original" - checkSubmoduleSourceFileName - , then' - "its object file name is the 'flattened' path of the source file with '.o' appeneded" - checkSubmoduleObjectFileName - , then' "it knows what modules it uses directly" checkSubmoduleModulesUsed - , then' "it knows its parent's name" checkSubmoduleParentName - , then' "it knows its name" checkSubmoduleName - ] - ] - -exampleSubmodule :: RawSource -exampleSubmodule = RawSource submoduleSourceFileName' $ unlines - [ "submodule (some_module:parent) child" - , " use module1" - , " USE MODULE2" - , " implicit none" - , "end submodule" - ] - -submoduleSourceFileName' :: String -submoduleSourceFileName' = "some" "file" "somewhere.f90" - -checkIsSubmodule :: Source -> Result -checkIsSubmodule Submodule{} = assertThat True -checkIsSubmodule _ = assertThat False - -checkSubmoduleSourceFileName :: Source -> Result -checkSubmoduleSourceFileName s@(Submodule{}) = - assertEquals submoduleSourceFileName' $ submoduleSourceFileName s -checkSubmoduleSourceFileName _ = fail' "wasn't a Submodule" - -checkSubmoduleObjectFileName :: Source -> Result -checkSubmoduleObjectFileName s@(Submodule{}) = - assertEquals ("." "some_file_somewhere.f90.o") - $ (submoduleObjectFileName s) "." -checkSubmoduleObjectFileName _ = fail' "wasn't a Submodule" - -checkSubmoduleModulesUsed :: Source -> Result -checkSubmoduleModulesUsed s@(Submodule{}) = - assertEquals ["module1", "module2"] $ submoduleModulesUsed s -checkSubmoduleModulesUsed _ = fail' "wasn't a Submodule" - -checkSubmoduleParentName :: Source -> Result -checkSubmoduleParentName s@(Submodule{}) = - assertEquals "some_module@parent" (submoduleParentName s) -checkSubmoduleParentName _ = fail' "wasn't a Submodule" - -checkSubmoduleName :: Source -> Result -checkSubmoduleName s@(Submodule{}) = assertEquals "child" $ submoduleName s -checkSubmoduleName _ = fail' "wasn't a Submodule" diff --git a/bootstrap/unit_test/SubmoduleToCompileInfoTest.hs b/bootstrap/unit_test/SubmoduleToCompileInfoTest.hs deleted file mode 100644 index 621b0d5..0000000 --- a/bootstrap/unit_test/SubmoduleToCompileInfoTest.hs +++ /dev/null @@ -1,78 +0,0 @@ -module SubmoduleToCompileInfoTest - ( test - ) -where - -import BuildModel ( AvailableModule(..) - , CompileTimeInfo(..) - , Source(..) - , constructCompileTimeInfo - ) -import Hedge ( Result - , Test - , assertEquals - , givenInput - , then' - , whenTransformed - ) -import System.FilePath ( () ) - -test :: IO (Test ()) -test = return $ givenInput - "a submodule and available modules" - (exampleSubmodule, availableModules) - [ whenTransformed - "its compileTimeInfo is determined" - doCompileTimeTransformation - [ then' "it still knows the original source file" checkSourceFileName - , then' "it knows what object file will be produced" checkObjectFileName - , then' "the smod file is also produced" checkOtherFilesProduced - , then' - "the direct dependencies are the parent smod and the available modules used" - checkDirectDependencies - ] - ] - -exampleSubmodule :: Source -exampleSubmodule = Submodule - { submoduleSourceFileName = submoduleSourceFileName' - , submoduleObjectFileName = \bd -> bd "some_file_somewhere.f90.o" - , submoduleModulesUsed = ["module1", "module2", "module3"] - , submoduleBaseModuleName = "base_module" - , submoduleParentName = "base_module@parent" - , submoduleName = "some_submodule" - } - -submoduleSourceFileName' :: FilePath -submoduleSourceFileName' = "some" "file" "somewhere.f90" - -availableModules :: [AvailableModule] -availableModules = [ AvailableModule {availableModuleName = "module1", availableModuleFile = "build_dir" "module1.mod"} - , AvailableModule {availableModuleName = "module3", availableModuleFile = "build_dir" "module3.mod"} - ] - -doCompileTimeTransformation :: (Source, [AvailableModule]) -> CompileTimeInfo -doCompileTimeTransformation (programSource, otherSources) = - constructCompileTimeInfo programSource otherSources "build_dir" - -checkSourceFileName :: CompileTimeInfo -> Result -checkSourceFileName cti = - assertEquals submoduleSourceFileName' (compileTimeInfoSourceFileName cti) - -checkObjectFileName :: CompileTimeInfo -> Result -checkObjectFileName cti = assertEquals - ("build_dir" "some_file_somewhere.f90.o") - (compileTimeInfoObjectFileProduced cti) - -checkOtherFilesProduced :: CompileTimeInfo -> Result -checkOtherFilesProduced cti = assertEquals - ["build_dir" "base_module@some_submodule.smod"] - (compileTimeInfoOtherFilesProduced cti) - -checkDirectDependencies :: CompileTimeInfo -> Result -checkDirectDependencies cti = assertEquals - [ "build_dir" "base_module@parent.smod" - , "build_dir" "module1.mod" - , "build_dir" "module3.mod" - ] - (compileTimeInfoDirectDependencies cti) diff --git a/bootstrap/unit_test/Trimmer.hs b/bootstrap/unit_test/Trimmer.hs deleted file mode 100644 index 4e0f91d..0000000 --- a/bootstrap/unit_test/Trimmer.hs +++ /dev/null @@ -1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF hedge-trimmer #-} diff --git a/docs.md b/docs.md index 2ffa611..218367c 100644 --- a/docs.md +++ b/docs.md @@ -9,12 +9,12 @@ author_email: fortran-lang@groups.io github: https://github.com/fortran-lang twitter: https://twitter.com/fortranlang website: https://fortran-lang.org -src_dir: ./fpm/src +src_dir: ./src + ./app output_dir: ./fpm-doc page_dir: ./doc media_dir: ./doc/media -exclude_dir: ./bootstrap - ./archive +exclude_dir: ./example_packages ./test display: public protected diff --git a/fpm.toml b/fpm.toml new file mode 100644 index 0000000..4bd2d96 --- /dev/null +++ b/fpm.toml @@ -0,0 +1,35 @@ +name = "fpm" +version = "0.2.0" +license = "MIT" +author = "fpm maintainers" +maintainer = "" +copyright = "2020 fpm contributors" + +[dependencies] +[dependencies.toml-f] +git = "https://github.com/toml-f/toml-f" +rev = "2f5eaba864ff630ba0c3791126a3f811b6e437f3" + +[dependencies.M_CLI2] +git = "https://github.com/urbanjost/M_CLI2.git" +rev = "e59fb2bfcf36199f1af506f937b3849180454a0f" + +[[test]] +name = "cli-test" +source-dir = "test/cli_test" +main = "cli_test.f90" + +[[test]] +name = "new-test" +source-dir = "test/new_test" +main = "new_test.f90" + +[[test]] +name = "fpm-test" +source-dir = "test/fpm_test" +main = "main.f90" + +[[test]] +name = "help-test" +source-dir = "test/help_test" +main = "help_test.f90" diff --git a/fpm/.gitignore b/fpm/.gitignore deleted file mode 100644 index a007fea..0000000 --- a/fpm/.gitignore +++ /dev/null @@ -1 +0,0 @@ -build/* diff --git a/fpm/README.md b/fpm/README.md deleted file mode 100644 index d993787..0000000 --- a/fpm/README.md +++ /dev/null @@ -1,4 +0,0 @@ -# Fortran Package Manager - -This is the Fortran Package Manager, implemented in Fortran as an fpm package. -Use fpm to build it. diff --git a/fpm/app/main.f90 b/fpm/app/main.f90 deleted file mode 100644 index 7476df6..0000000 --- a/fpm/app/main.f90 +++ /dev/null @@ -1,37 +0,0 @@ -program main -use fpm_command_line, only: & - fpm_cmd_settings, & - fpm_new_settings, & - fpm_build_settings, & - fpm_run_settings, & - fpm_test_settings, & - fpm_install_settings, & - fpm_update_settings, & - get_command_line_settings -use fpm, only: cmd_build, cmd_run -use fpm_cmd_install, only: cmd_install -use fpm_cmd_new, only: cmd_new -use fpm_cmd_update, only : cmd_update - -implicit none - -class(fpm_cmd_settings), allocatable :: cmd_settings - -call get_command_line_settings(cmd_settings) - -select type(settings=>cmd_settings) -type is (fpm_new_settings) - call cmd_new(settings) -type is (fpm_build_settings) - call cmd_build(settings) -type is (fpm_run_settings) - call cmd_run(settings,test=.false.) -type is (fpm_test_settings) - call cmd_run(settings,test=.true.) -type is (fpm_install_settings) - call cmd_install(settings) -type is (fpm_update_settings) - call cmd_update(settings) -end select - -end program main diff --git a/fpm/fpm.toml b/fpm/fpm.toml deleted file mode 100644 index 4bd2d96..0000000 --- a/fpm/fpm.toml +++ /dev/null @@ -1,35 +0,0 @@ -name = "fpm" -version = "0.2.0" -license = "MIT" -author = "fpm maintainers" -maintainer = "" -copyright = "2020 fpm contributors" - -[dependencies] -[dependencies.toml-f] -git = "https://github.com/toml-f/toml-f" -rev = "2f5eaba864ff630ba0c3791126a3f811b6e437f3" - -[dependencies.M_CLI2] -git = "https://github.com/urbanjost/M_CLI2.git" -rev = "e59fb2bfcf36199f1af506f937b3849180454a0f" - -[[test]] -name = "cli-test" -source-dir = "test/cli_test" -main = "cli_test.f90" - -[[test]] -name = "new-test" -source-dir = "test/new_test" -main = "new_test.f90" - -[[test]] -name = "fpm-test" -source-dir = "test/fpm_test" -main = "main.f90" - -[[test]] -name = "help-test" -source-dir = "test/help_test" -main = "help_test.f90" diff --git a/fpm/src/fpm.f90 b/fpm/src/fpm.f90 deleted file mode 100644 index 31b68ff..0000000 --- a/fpm/src/fpm.f90 +++ /dev/null @@ -1,467 +0,0 @@ -module fpm -use fpm_strings, only: string_t, operator(.in.), glob, join, string_cat -use fpm_backend, only: build_package -use fpm_command_line, only: fpm_build_settings, fpm_new_settings, & - fpm_run_settings, fpm_install_settings, fpm_test_settings -use fpm_dependency, only : new_dependency_tree -use fpm_environment, only: run -use fpm_filesystem, only: is_dir, join_path, number_of_rows, list_files, exists, basename -use fpm_model, only: fpm_model_t, srcfile_t, show_model, & - FPM_SCOPE_UNKNOWN, FPM_SCOPE_LIB, FPM_SCOPE_DEP, & - FPM_SCOPE_APP, FPM_SCOPE_EXAMPLE, FPM_SCOPE_TEST -use fpm_compiler, only: get_module_flags, is_unknown_compiler - - -use fpm_sources, only: add_executable_sources, add_sources_from_dir -use fpm_targets, only: targets_from_sources, resolve_module_dependencies, & - resolve_target_linking, build_target_t, build_target_ptr, & - FPM_TARGET_EXECUTABLE, FPM_TARGET_ARCHIVE -use fpm_manifest, only : get_package_data, package_config_t -use fpm_error, only : error_t, fatal_error -use fpm_manifest_test, only : test_config_t -use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, & - & stdout=>output_unit, & - & stderr=>error_unit -use fpm_manifest_dependency, only: dependency_config_t -use, intrinsic :: iso_fortran_env, only: error_unit -implicit none -private -public :: cmd_build, cmd_run -public :: build_model, check_modules_for_duplicates - -contains - - -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_config_t), intent(in) :: package - type(error_t), allocatable, intent(out) :: error - - integer :: i, j - type(package_config_t) :: dependency - character(len=:), allocatable :: manifest, lib_dir - - logical :: duplicates_found = .false. - type(string_t) :: include_dir - - model%package_name = package%name - - allocate(model%include_dirs(0)) - allocate(model%link_libraries(0)) - - call new_dependency_tree(model%deps, cache=join_path("build", "cache.toml")) - call model%deps%add(package, error) - if (allocated(error)) return - - if(settings%compiler.eq.'')then - model%fortran_compiler = 'gfortran' - else - model%fortran_compiler = settings%compiler - endif - - if (is_unknown_compiler(model%fortran_compiler)) then - write(*, '(*(a:,1x))') & - "", "Unknown compiler", model%fortran_compiler, "requested!", & - "Defaults for this compiler might be incorrect" - end if - model%output_directory = join_path('build',basename(model%fortran_compiler)//'_'//settings%build_name) - - call get_module_flags(model%fortran_compiler, & - & join_path(model%output_directory,model%package_name), & - & model%fortran_compile_flags) - model%fortran_compile_flags = settings%flag // model%fortran_compile_flags - - allocate(model%packages(model%deps%ndep)) - - ! Add sources from executable directories - if (is_dir('app') .and. package%build%auto_executables) then - call add_sources_from_dir(model%packages(1)%sources,'app', FPM_SCOPE_APP, & - with_executables=.true., error=error) - - if (allocated(error)) then - return - end if - - end if - if (is_dir('example') .and. package%build%auto_examples) then - call add_sources_from_dir(model%packages(1)%sources,'example', FPM_SCOPE_EXAMPLE, & - with_executables=.true., error=error) - - if (allocated(error)) then - return - end if - - end if - if (is_dir('test') .and. package%build%auto_tests) then - call add_sources_from_dir(model%packages(1)%sources,'test', FPM_SCOPE_TEST, & - with_executables=.true., error=error) - - if (allocated(error)) then - return - endif - - end if - if (allocated(package%executable)) then - call add_executable_sources(model%packages(1)%sources, package%executable, FPM_SCOPE_APP, & - auto_discover=package%build%auto_executables, & - error=error) - - if (allocated(error)) then - return - end if - - end if - if (allocated(package%example)) then - call add_executable_sources(model%packages(1)%sources, package%example, FPM_SCOPE_EXAMPLE, & - auto_discover=package%build%auto_examples, & - error=error) - - if (allocated(error)) then - return - end if - - end if - if (allocated(package%test)) then - call add_executable_sources(model%packages(1)%sources, package%test, FPM_SCOPE_TEST, & - auto_discover=package%build%auto_tests, & - error=error) - - if (allocated(error)) then - return - endif - - endif - - do i = 1, model%deps%ndep - associate(dep => model%deps%dep(i)) - manifest = join_path(dep%proj_dir, "fpm.toml") - - call get_package_data(dependency, manifest, error, & - apply_defaults=.true.) - if (allocated(error)) exit - - model%packages(i)%name = dependency%name - if (.not.allocated(model%packages(i)%sources)) allocate(model%packages(i)%sources(0)) - - if (allocated(dependency%library)) then - - if (allocated(dependency%library%source_dir)) then - lib_dir = join_path(dep%proj_dir, dependency%library%source_dir) - if (is_dir(lib_dir)) then - call add_sources_from_dir(model%packages(i)%sources, lib_dir, FPM_SCOPE_LIB, & - error=error) - if (allocated(error)) exit - end if - end if - - if (allocated(dependency%library%include_dir)) then - do j=1,size(dependency%library%include_dir) - include_dir%s = join_path(dep%proj_dir, dependency%library%include_dir(j)%s) - if (is_dir(include_dir%s)) then - model%include_dirs = [model%include_dirs, include_dir] - end if - end do - end if - - end if - - if (allocated(dependency%build%link)) then - model%link_libraries = [model%link_libraries, dependency%build%link] - end if - end associate - end do - if (allocated(error)) return - - if (settings%verbose) then - write(*,*)' BUILD_NAME: ',settings%build_name - write(*,*)' COMPILER: ',settings%compiler - write(*,*)' COMPILER OPTIONS: ', model%fortran_compile_flags - write(*,*)' INCLUDE DIRECTORIES: [', string_cat(model%include_dirs,','),']' - end if - - ! Check for duplicate modules - call check_modules_for_duplicates(model, duplicates_found) - if (duplicates_found) then - error stop 'Error: One or more duplicate module names found.' - end if -end subroutine build_model - -! Check for duplicate modules -subroutine check_modules_for_duplicates(model, duplicates_found) - type(fpm_model_t), intent(in) :: model - integer :: maxsize - integer :: i,j,k,l,m,modi - type(string_t), allocatable :: modules(:) - logical :: duplicates_found - ! Initialise the size of array - maxsize = 0 - ! Get number of modules provided by each source file of every package - do i=1,size(model%packages) - do j=1,size(model%packages(i)%sources) - if (allocated(model%packages(i)%sources(j)%modules_provided)) then - maxsize = maxsize + size(model%packages(i)%sources(j)%modules_provided) - end if - end do - end do - ! Allocate array to contain distinct names of modules - allocate(modules(maxsize)) - - ! Initialise index to point at start of the newly allocated array - modi = 1 - - ! Loop through modules provided by each source file of every package - ! Add it to the array if it is not already there - ! Otherwise print out warning about duplicates - do k=1,size(model%packages) - do l=1,size(model%packages(k)%sources) - if (allocated(model%packages(k)%sources(l)%modules_provided)) then - do m=1,size(model%packages(k)%sources(l)%modules_provided) - if (model%packages(k)%sources(l)%modules_provided(m)%s.in.modules(:modi-1)) then - write(error_unit, *) "Warning: Module ",model%packages(k)%sources(l)%modules_provided(m)%s, & - " in ",model%packages(k)%sources(l)%file_name," is a duplicate" - duplicates_found = .true. - else - modules(modi) = model%packages(k)%sources(l)%modules_provided(m) - modi = modi + 1 - end if - end do - end if - end do - end do -end subroutine check_modules_for_duplicates - -subroutine cmd_build(settings) -type(fpm_build_settings), intent(in) :: settings -type(package_config_t) :: package -type(fpm_model_t) :: model -type(build_target_ptr), allocatable :: targets(:) -type(error_t), allocatable :: error - -integer :: i - -call get_package_data(package, "fpm.toml", error, apply_defaults=.true.) -if (allocated(error)) then - print '(a)', error%message - error stop 1 -end if - -call build_model(model, settings, package, error) -if (allocated(error)) then - print '(a)', error%message - error stop 1 -end if - -call targets_from_sources(targets,model,error) -if (allocated(error)) then - print '(a)', error%message - error stop 1 -end if - -if(settings%list)then - do i=1,size(targets) - write(stderr,*) targets(i)%ptr%output_file - enddo -else if (settings%show_model) then - call show_model(model) -else - call build_package(targets,model) -endif - -end subroutine - -subroutine cmd_run(settings,test) - class(fpm_run_settings), intent(in) :: settings - logical, intent(in) :: test - - integer :: i, j, col_width - logical :: found(size(settings%name)) - type(error_t), allocatable :: error - type(package_config_t) :: package - type(fpm_model_t) :: model - type(build_target_ptr), allocatable :: targets(:) - type(string_t) :: exe_cmd - type(string_t), allocatable :: executables(:) - type(build_target_t), pointer :: exe_target - type(srcfile_t), pointer :: exe_source - integer :: run_scope - character(len=:),allocatable :: line - logical :: toomany - - call get_package_data(package, "fpm.toml", error, apply_defaults=.true.) - if (allocated(error)) then - print '(a)', error%message - error stop 1 - end if - - call build_model(model, settings%fpm_build_settings, package, error) - if (allocated(error)) then - print '(a)', error%message - error stop 1 - end if - - call targets_from_sources(targets,model,error) - if (allocated(error)) then - print '(a)', error%message - error stop 1 - end if - - if (test) then - run_scope = FPM_SCOPE_TEST - else - run_scope = merge(FPM_SCOPE_EXAMPLE, FPM_SCOPE_APP, settings%example) - end if - - ! Enumerate executable targets to run - col_width = -1 - found(:) = .false. - allocate(executables(0)) - do i=1,size(targets) - - exe_target => targets(i)%ptr - - if (exe_target%target_type == FPM_TARGET_EXECUTABLE .and. & - allocated(exe_target%dependencies)) then - - exe_source => exe_target%dependencies(1)%ptr%source - - if (exe_source%unit_scope == run_scope) then - - col_width = max(col_width,len(basename(exe_target%output_file))+2) - - if (size(settings%name) == 0) then - - exe_cmd%s = exe_target%output_file - executables = [executables, exe_cmd] - - else - - do j=1,size(settings%name) - - if (glob(trim(exe_source%exe_name),trim(settings%name(j)))) then - - found(j) = .true. - exe_cmd%s = exe_target%output_file - executables = [executables, exe_cmd] - - end if - - end do - - end if - - end if - - end if - - end do - - ! Check if any apps/tests were found - if (col_width < 0) then - if (test) then - write(stderr,*) 'No tests to run' - else - write(stderr,*) 'No executables to run' - end if - stop - end if - - ! Check all names are valid - ! or no name and found more than one file - toomany= size(settings%name).eq.0 .and. size(executables).gt.1 - if ( any(.not.found) & - & .or. & - & ( (toomany .and. .not.test) .or. (toomany .and. settings%runner .ne. '') ) & - & .and. & - & .not.settings%list) then - line=join(settings%name) - if(line.ne.'.')then ! do not report these special strings - if(any(.not.found))then - write(stderr,'(A)',advance="no")'fpm::run specified names ' - do j=1,size(settings%name) - if (.not.found(j)) write(stderr,'(A)',advance="no") '"'//trim(settings%name(j))//'" ' - end do - write(stderr,'(A)') 'not found.' - write(stderr,*) - else if(settings%verbose)then - write(stderr,'(A)',advance="yes")'when more than one executable is available' - write(stderr,'(A)',advance="yes")' program names must be specified.' - endif - endif - - call compact_list_all() - - if(line.eq.'.' .or. line.eq.' ')then ! do not report these special strings - stop - else - stop 1 - endif - - end if - - call build_package(targets,model) - - if (settings%list) then - call compact_list() - else - - do i=1,size(executables) - if (exists(executables(i)%s)) then - if(settings%runner .ne. ' ')then - call run(settings%runner//' '//executables(i)%s//" "//settings%args,echo=settings%verbose) - else - call run(executables(i)%s//" "//settings%args,echo=settings%verbose) - endif - else - write(stderr,*)'fpm::run',executables(i)%s,' not found' - stop 1 - end if - end do - endif - contains - subroutine compact_list_all() - integer, parameter :: LINE_WIDTH = 80 - integer :: i, j, nCol - j = 1 - nCol = LINE_WIDTH/col_width - write(stderr,*) 'Available names:' - do i=1,size(targets) - - exe_target => targets(i)%ptr - - if (exe_target%target_type == FPM_TARGET_EXECUTABLE .and. & - allocated(exe_target%dependencies)) then - - exe_source => exe_target%dependencies(1)%ptr%source - - if (exe_source%unit_scope == run_scope) then - - write(stderr,'(A)',advance=(merge("yes","no ",modulo(j,nCol)==0))) & - & [character(len=col_width) :: basename(exe_target%output_file)] - j = j + 1 - - end if - end if - end do - write(stderr,*) - end subroutine compact_list_all - - subroutine compact_list() - integer, parameter :: LINE_WIDTH = 80 - integer :: i, j, nCol - j = 1 - nCol = LINE_WIDTH/col_width - write(stderr,*) 'Matched names:' - do i=1,size(executables) - write(stderr,'(A)',advance=(merge("yes","no ",modulo(j,nCol)==0))) & - & [character(len=col_width) :: basename(executables(i)%s)] - j = j + 1 - enddo - write(stderr,*) - end subroutine compact_list - -end subroutine cmd_run - -end module fpm diff --git a/fpm/src/fpm/cmd/install.f90 b/fpm/src/fpm/cmd/install.f90 deleted file mode 100644 index db7a9f8..0000000 --- a/fpm/src/fpm/cmd/install.f90 +++ /dev/null @@ -1,176 +0,0 @@ -module fpm_cmd_install - use, intrinsic :: iso_fortran_env, only : output_unit - use fpm, only : build_model - use fpm_backend, only : build_package - use fpm_command_line, only : fpm_install_settings - use fpm_error, only : error_t, fatal_error - use fpm_filesystem, only : join_path, list_files - use fpm_installer, only : installer_t, new_installer - use fpm_manifest, only : package_config_t, get_package_data - use fpm_model, only : fpm_model_t, FPM_SCOPE_APP - use fpm_targets, only: targets_from_sources, build_target_t, & - build_target_ptr, FPM_TARGET_EXECUTABLE - use fpm_strings, only : string_t, resize - implicit none - private - - public :: cmd_install - -contains - - !> Entry point for the fpm-install subcommand - subroutine cmd_install(settings) - !> Representation of the command line settings - type(fpm_install_settings), intent(in) :: settings - type(package_config_t) :: package - type(error_t), allocatable :: error - type(fpm_model_t) :: model - type(build_target_ptr), allocatable :: targets(:) - type(installer_t) :: installer - character(len=:), allocatable :: lib, exe, dir - logical :: installable - - call get_package_data(package, "fpm.toml", error, apply_defaults=.true.) - call handle_error(error) - - call build_model(model, settings%fpm_build_settings, package, error) - call handle_error(error) - - call targets_from_sources(targets,model,error) - call handle_error(error) - - installable = (allocated(package%library) .and. package%install%library) & - .or. allocated(package%executable) - if (.not.installable) then - call fatal_error(error, "Project does not contain any installable targets") - call handle_error(error) - end if - - if (settings%list) then - call install_info(output_unit, package, model, targets) - return - end if - - if (.not.settings%no_rebuild) then - call build_package(targets,model) - end if - - call new_installer(installer, prefix=settings%prefix, & - bindir=settings%bindir, libdir=settings%libdir, & - includedir=settings%includedir, & - verbosity=merge(2, 1, settings%verbose)) - - if (allocated(package%library) .and. package%install%library) then - dir = join_path(model%output_directory, model%package_name) - lib = "lib"//model%package_name//".a" - call installer%install_library(join_path(dir, lib), error) - call handle_error(error) - - call install_module_files(installer, dir, error) - call handle_error(error) - end if - - if (allocated(package%executable)) then - call install_executables(installer, targets, error) - call handle_error(error) - end if - - end subroutine cmd_install - - subroutine install_info(unit, package, model, targets) - integer, intent(in) :: unit - type(package_config_t), intent(in) :: package - type(fpm_model_t), intent(in) :: model - type(build_target_ptr), intent(in) :: targets(:) - - integer :: ii, ntargets - character(len=:), allocatable :: lib - type(string_t), allocatable :: install_target(:) - - call resize(install_target) - - ntargets = 0 - if (allocated(package%library) .and. package%install%library) then - ntargets = ntargets + 1 - lib = join_path(model%output_directory, model%package_name, & - "lib"//model%package_name//".a") - install_target(ntargets)%s = lib - end if - do ii = 1, size(targets) - if (is_executable_target(targets(ii)%ptr)) then - if (ntargets >= size(install_target)) call resize(install_target) - ntargets = ntargets + 1 - install_target(ntargets)%s = targets(ii)%ptr%output_file - end if - end do - - write(unit, '("#", *(1x, g0))') & - "total number of installable targets:", ntargets - do ii = 1, ntargets - write(unit, '("-", *(1x, g0))') install_target(ii)%s - end do - - end subroutine install_info - - subroutine install_module_files(installer, dir, error) - type(installer_t), intent(inout) :: installer - character(len=*), intent(in) :: dir - type(error_t), allocatable, intent(out) :: error - type(string_t), allocatable :: modules(:) - integer :: ii - - call list_files(dir, modules, recurse=.false.) - - do ii = 1, size(modules) - if (is_module_file(modules(ii)%s)) then - call installer%install_header(modules(ii)%s, error) - if (allocated(error)) exit - end if - end do - if (allocated(error)) return - - end subroutine install_module_files - - subroutine install_executables(installer, targets, error) - type(installer_t), intent(inout) :: installer - type(build_target_ptr), intent(in) :: targets(:) - type(error_t), allocatable, intent(out) :: error - integer :: ii - - do ii = 1, size(targets) - if (is_executable_target(targets(ii)%ptr)) then - call installer%install_executable(targets(ii)%ptr%output_file, error) - if (allocated(error)) exit - end if - end do - if (allocated(error)) return - - end subroutine install_executables - - elemental function is_executable_target(target_ptr) result(is_exe) - type(build_target_t), intent(in) :: target_ptr - logical :: is_exe - is_exe = target_ptr%target_type == FPM_TARGET_EXECUTABLE .and. & - allocated(target_ptr%dependencies) - if (is_exe) then - is_exe = target_ptr%dependencies(1)%ptr%source%unit_scope == FPM_SCOPE_APP - end if - end function is_executable_target - - elemental function is_module_file(name) result(is_mod) - character(len=*), intent(in) :: name - logical :: is_mod - integer :: ll - ll = len(name) - is_mod = name(max(1, ll-3):ll) == ".mod" - end function is_module_file - - subroutine handle_error(error) - type(error_t), intent(in), optional :: error - if (present(error)) then - print '("[Error]", 1x, a)', error%message - error stop 1 - end if - end subroutine handle_error - -end module fpm_cmd_install diff --git a/fpm/src/fpm/cmd/new.f90 b/fpm/src/fpm/cmd/new.f90 deleted file mode 100644 index 5149bea..0000000 --- a/fpm/src/fpm/cmd/new.f90 +++ /dev/null @@ -1,652 +0,0 @@ -module fpm_cmd_new -!># Definition of the "new" subcommand -!> -!> A type of the general command base class [[fpm_cmd_settings]] -!> was created for the "new" subcommand ==> type [[fpm_new_settings]]. -!> This procedure read the values that were set on the command line -!> from this type to decide what actions to take. -!> -!> It is virtually self-contained and so independant of the rest of the -!> application that it could function as a separate program. -!> -!> The "new" subcommand options currently consist of a SINGLE top -!> directory name to create that must have a name that is an -!> allowable Fortran variable name. That should have been ensured -!> by the command line processing before this procedure is called. -!> So basically this routine has already had the options vetted and -!> just needs to conditionally create a few files. -!> -!> As described in the documentation it will selectively -!> create the subdirectories app/, test/, src/, and example/ -!> and populate them with sample files. -!> -!> It also needs to create an initial manifest file "fpm.toml". -!> -!> It then calls the system command "git init". -!> -!> It should test for file existence and not overwrite existing -!> files and inform the user if there were conflicts. -!> -!> Any changes should be reflected in the documentation in -!> [[fpm_command_line.f90]] -!> -!> FUTURE -!> A filename like "." would need system commands or a standard routine -!> like realpath(3c) to process properly. -!> -!> Perhaps allow more than one name on a single command. It is an arbitrary -!> restriction based on a concensus preference, not a required limitation. -!> -!> Initially the name of the directory is used as the module name in the -!> src file so it must be an allowable Fortran variable name. If there are -!> complaints about it it might be changed. Handling unicode at this point -!> might be problematic as not all current compilers handle it. Other -!> utilities like content trackers (ie. git) or repositories like github -!> might also have issues with alternative names or names with spaces, etc. -!> So for the time being it seems prudent to encourage simple ASCII top directory -!> names (similiar to the primary programming language Fortran itself). -!> -!> Should be able to create or pull more complicated initial examples -!> based on various templates. It should place or mention other relevant -!> documents such as a description of the manifest file format in user hands; -!> or how to access registered packages and local packages, -!> although some other command might provide that (and the help command should -!> be the first go-to for a CLI utility). - -use fpm_command_line, only : fpm_new_settings -use fpm_environment, only : run, OS_LINUX, OS_MACOS, OS_WINDOWS -use fpm_filesystem, only : join_path, exists, basename, mkdir, is_dir, to_fortran_name -use fpm_filesystem, only : fileopen, fileclose, filewrite, warnwrite -use fpm_strings, only : join -use,intrinsic :: iso_fortran_env, only : stderr=>error_unit -implicit none -private -public :: cmd_new - -contains - -subroutine cmd_new(settings) -type(fpm_new_settings), intent(in) :: settings -integer,parameter :: tfc = selected_char_kind('DEFAULT') -character(len=:,kind=tfc),allocatable :: bname ! baeename of NAME -character(len=:,kind=tfc),allocatable :: tomlfile(:) -character(len=:,kind=tfc),allocatable :: littlefile(:) - - !> TOP DIRECTORY NAME PROCESSING - !> see if requested new directory already exists and process appropriately - if(exists(settings%name) .and. .not.settings%backfill )then - write(stderr,'(*(g0,1x))')& - & '',settings%name,'already exists.' - write(stderr,'(*(g0,1x))')& - & ' perhaps you wanted to add --backfill ?' - return - elseif(is_dir(settings%name) .and. settings%backfill )then - write(*,'(*(g0))')'backfilling ',settings%name - elseif(exists(settings%name) )then - write(stderr,'(*(g0,1x))')& - & '',settings%name,'already exists and is not a directory.' - return - else - ! make new directory - call mkdir(settings%name) - endif - - !> temporarily change to new directory as a test. NB: System dependent - call run('cd '//settings%name) - ! NOTE: need some system routines to handle filenames like "." - ! like realpath() or getcwd(). - bname=basename(settings%name) - - ! create NAME/.gitignore file - call warnwrite(join_path(settings%name, '.gitignore'), ['build/*']) - - littlefile=[character(len=80) :: '# '//bname, 'My cool new project!'] - - ! create NAME/README.md - call warnwrite(join_path(settings%name, 'README.md'), littlefile) - - ! start building NAME/fpm.toml - if(settings%with_full)then - tomlfile=[character(len=80) :: & - &' # This is your fpm(Fortran Package Manager) manifest file ',& - &' # ("fpm.toml"). It is heavily annotated to help guide you though ',& - &' # customizing a package build, although the defaults are sufficient ',& - &' # for many basic packages. ',& - &' # ',& - &' # The manifest file is not only used to provide metadata identifying ',& - &' # your project (so it can be used by others as a dependency). It can ',& - &' # specify where your library and program sources live, what the name ',& - &' # of the executable(s) will be, what files to build, dependencies on ',& - &' # other fpm packages, and what external libraries are required. ',& - &' # ',& - &' # The manifest format must conform to the TOML configuration file ',& - &' # standard. ',& - &' # ',& - &' # TOML files support flexible use of white-space and commenting of the ',& - &' # configuration data, but for clarity in this sample active directives ',& - &' # begin in column one. Inactive example directives are commented ',& - &' # out with a pound character ("#") but begin in column one as well. ',& - &' # Commentary begins with a pound character in column three. ',& - &' # ',& - &' # This file draws heavily upon the following references: ',& - &' # ',& - &' # The fpm home page at ',& - &' # https://github.com/fortran-lang/fpm ',& - &' # A complete list of keys and their attributes at ',& - &' # https://github.com/fortran-lang/fpm/blob/master/manifest-reference.md ',& - &' # examples of fpm project packaging at ',& - &' # https://github.com/fortran-lang/fpm/blob/master/PACKAGING.md ',& - &' # The Fortran TOML file interface and it''s references at ',& - &' # https://github.com/toml-f/toml-f ',& - &' # ',& - &' #----------------------- ',& - &' # project Identification ',& - &' #----------------------- ',& - &' # We begin with project metadata at the manifest root. This data is designed ',& - &' # to aid others when searching for the project in a repository and to ',& - &' # identify how and when to contact the package supporters. ',& - &' ',& - &'name = "'//bname//'"',& - &' # The project name (required) is how the project will be referred to. ',& - &' # The name is used by other packages using it as a dependency. It also ',& - &' # is used as the default name of any library built and the optional ',& - &' # default executable built from app/main.f90. It must conform to the rules ',& - &' # for a Fortran variable name. ',& - &' ',& - &'version = "0.1.0" ',& - &' # The project version number is a string. A recommended scheme for ',& - &' # specifying versions is the Semantic Versioning scheme. ',& - &' ',& - &'license = "license" ',& - &' # Licensing information specified using SPDX identifiers is preferred ',& - &' # (eg. "Apache-2.0 OR MIT" or "LGPL-3.0-or-later"). ',& - &' ',& - &'maintainer = "jane.doe@example.com" ',& - &' # Information on the project maintainer and means to reach out to them. ',& - &' ',& - &'author = "Jane Doe" ',& - &' # Information on the project author. ',& - &' ',& - &'copyright = "Copyright 2020 Jane Doe" ',& - &' # A statement clarifying the Copyright status of the project. ',& - &' ',& - &'#description = "A short project summary in plain text" ',& - &' # The description provides a short summary on the project. It should be ',& - &' # plain text and not use any markup formatting. ',& - &' ',& - &'#categories = ["fortran", "graphics"] ',& - &' # Categories associated with the project. Listing only one is preferred. ',& - &' ',& - &'#keywords = ["hdf5", "mpi"] ',& - &' # The keywords field is an array of strings describing the project. ',& - &' ',& - &'#homepage = "https://stdlib.fortran-lang.org" ',& - &' # URL to the webpage of the project. ',& - &' ',& - &' # ----------------------------------------- ',& - &' # We are done with identifying the project. ',& - &' # ----------------------------------------- ',& - &' # ',& - &' # Now lets start describing how the project should be built. ',& - &' # ',& - &' # Note tables would go here but we will not be talking about them (much)!!' ,& - &' # ',& - &' # Tables are a way to explicitly specify large numbers of programs in ',& - &' # a compact format instead of individual per-program entries in the ',& - &' # [[executable]], [[test]], and [[example]] sections to follow but ',& - &' # will not be discussed further except for the following notes: ',& - &' # ',& - &' # + Tables must appear (here) before any sections are declared. Once a ',& - &' # section is specified in a TOML file everything afterwards must be ',& - &' # values for that section or the beginning of a new section. A simple ',& - &' # example looks like: ',& - &' ',& - &'#executable = [ ',& - &'# { name = "a-prog" }, ',& - &'# { name = "app-tool", source-dir = "tool" }, ',& - &'# { name = "fpm-man", source-dir = "tool", main="fman.f90" } ',& - &'#] ',& - &' ',& - &' # This would be in lieue of the [[executable]] section found later in this ',& - &' # configuration file. ',& - &' # + See the reference documents (at the beginning of this document) ',& - &' # for more information on tables if you have long lists of programs ',& - &' # to build and are not simply depending on auto-detection. ',& - &' # ',& - &' # Now lets begin the TOML sections (lines beginning with "[") ... ',& - &' # ',& - &' ',& - &'[install] # Options for the "install" subcommand ',& - &' ',& - &' # When you run the "install" subcommand only executables are installed by ',& - &' # default on the local system. Library projects that will be used outside of ',& - &' # "fpm" can set the "library" boolean to also allow installing the module ',& - &' # files and library archive. Without this being set to "true" an "install" ',& - &' # subcommand ignores parameters that specify library installation. ',& - &' ',& - &'library = false ',& - &' ',& - &'[build] # General Build Options ',& - &' ',& - &' ### Automatic target discovery ',& - &' # ',& - &' # Normally fpm recursively searches the app/, example/, and test/ directories ',& - &' # for program sources and builds them. To disable this automatic discovery of ',& - &' # program targets set the following to "false": ',& - &' ',& - &'#auto-executables = true ',& - &'#auto-examples = true ',& - &'#auto-tests = true ',& - &' ',& - &' ### Package-level External Library Links ',& - &' # ',& - &' # To declare link-time dependencies on external libraries a list of ',& - &' # native libraries can be specified with the "link" entry. You may ',& - &' # have one library name or a list of strings in case several ',& - &' # libraries should be linked. This list of library dependencies is ',& - &' # exported to dependent packages. You may have to alter your library ',& - &' # search-path to ensure the libraries can be accessed. Typically, ',& - &' # this is done with the LD_LIBRARY_PATH environment variable on ULS ',& - &' # (Unix-Like Systems). You only specify the core name of the library ',& - &' # (as is typical with most programming environments, where you ',& - &' # would specify "-lz" on your load command to link against the zlib ',& - &' # compression library even though the library file would typically be ',& - &' # a file called "libz.a" "or libz.so"). So to link against that library ',& - &' # you would specify: ',& - &' ',& - &'#link = "z" ',& - &' ',& - &' # Note that in some cases the order of the libraries matters: ',& - &' ',& - &'#link = ["blas", "lapack"] ',& - &''] - endif - - if(settings%with_bare)then - elseif(settings%with_lib)then - call mkdir(join_path(settings%name,'src') ) - ! create next section of fpm.toml - if(settings%with_full)then - tomlfile=[character(len=80) :: tomlfile, & - &'[library] ',& - &' ',& - &' # You can change the name of the directory to search for your library ',& - &' # source from the default of "src/". Library targets are exported ',& - &' # and usable by other projects. ',& - &' ',& - &'source-dir="src" ',& - &' ',& - &' # this can be a list: ',& - &' ',& - &'#source-dir=["src", "src2"] ',& - &' ',& - &' # More complex libraries may organize their modules in subdirectories. ',& - &' # For modules in a top-level directory fpm requires (but does not ',& - &' # enforce) that: ',& - &' # ',& - &' # + The module has the same name as the source file. This is important. ',& - &' # + There should be only one module per file. ',& - &' # ',& - &' # These two requirements simplify the build process for fpm. As Fortran ',& - &' # compilers emit module files (.mod) with the same name as the module ',& - &' # itself (but not the source file, .f90), naming the module the same ',& - &' # as the source file allows fpm to: ',& - &' # ',& - &' # + Uniquely and exactly map a source file (.f90) to its object (.o) ',& - &' # and module (.mod) files. ',& - &' # + Avoid conflicts with modules of the same name that could appear ',& - &' # in dependency packages. ',& - &' # ',& - &' ### Multi-level library source ',& - &' # You can place your module source files in any number of levels of ',& - &' # subdirectories inside your source directory, but there are certain naming ',& - &' # conventions to be followed -- module names must contain the path components ',& - &' # of the directory that its source file is in. ',& - &' # ',& - &' # This rule applies generally to any number of nested directories and ',& - &' # modules. For example, src/a/b/c/d.f90 must define a module called a_b_c_d. ',& - &' # Again, this is not enforced but may be required in future releases. ',& - &''] - endif - ! create placeholder module src/bname.f90 - littlefile=[character(len=80) :: & - &'module '//to_fortran_name(bname), & - &' implicit none', & - &' private', & - &'', & - &' public :: say_hello', & - &'contains', & - &' subroutine say_hello', & - &' print *, "Hello, '//bname//'!"', & - &' end subroutine say_hello', & - &'end module '//to_fortran_name(bname)] - ! create NAME/src/NAME.f90 - call warnwrite(join_path(settings%name, 'src', bname//'.f90'),& - & littlefile) - endif - - if(settings%with_full)then - tomlfile=[character(len=80) :: tomlfile ,& - &'[dependencies] ',& - &' ',& - &' # Inevitably, you will want to be able to include other packages in ',& - &' # a project. Fpm makes this incredibly simple, by taking care of ',& - &' # fetching and compiling your dependencies for you. You just tell it ',& - &' # what your dependencies names are, and where to find them. ',& - &' # ',& - &' # If you are going to distribute your package only place dependencies ',& - &' # here someone using your package as a remote dependency needs built. ',& - &' # You can define dependencies just for developer executables in the ',& - &' # next section, or even for specific executables as we will see below ',& - &' # (Then fpm will still fetch and compile it when building your ',& - &' # developer executables, but users of your library will not have to). ',& - &' # ',& - &' ## GLOBAL DEPENDENCIES (exported with your project) ',& - &' # ',& - &' # Typically, dependencies are defined by specifying the project''s ',& - &' # git repository. ',& - &' # ',& - &' # You can be specific about which version of a dependency you would ',& - &' # like. By default the latest master master branch is used. You can ',& - &' # optionally specify a branch, a tag or a commit value. ',& - &' # ',& - &' # So here are several alternates for specifying a remote dependency (you ',& - &' # can have at most one of "branch", "rev" or "tag" present): ',& - &' ',& - &'#stdlib = { git = "https://github.com/LKedward/stdlib-fpm.git" } ',& - &'#stdlib = {git="https://github.com/LKedward/stdlib-fpm.git",branch = "master" },',& - &'#stdlib = {git="https://github.com/LKedward/stdlib-fpm.git", tag = "v0.1.0" }, ',& - &'#stdlib = {git="https://github.com/LKedward/stdlib-fpm.git", rev = "5a9b7a8" }. ',& - &' ',& - &' # There may be multiple packages listed: ',& - &' ',& - &'#M_strings = { git = "https://github.com/urbanjost/M_strings.git" } ',& - &'#M_time = { git = "https://github.com/urbanjost/M_time.git" } ',& - &' ',& - &' # ',& - &' # You can even specify the local path to another project if it is in ',& - &' # a sub-folder (If for example you have got another fpm package **in ',& - &' # the same repository**) like this: ',& - &' ',& - &'#M_strings = { path = "M_strings" } ',& - &' ',& - &' # If you specify paths outside of your repository (ie. paths with a ',& - &' # slash in them) things will not work for your users! ',& - &' # ',& - &' # For a more verbose layout use normal tables rather than inline tables ',& - &' # to specify dependencies: ',& - &' ',& - &'#[dependencies.toml-f] ',& - &'#git = "https://github.com/toml-f/toml-f" ',& - &'#rev = "2f5eaba864ff630ba0c3791126a3f811b6e437f3" ',& - &' ',& - &' # Now you can use any modules from these libraries anywhere in your ',& - &' # code -- whether is in your library source or a program source. ',& - &' ',& - &'[dev-dependencies] ',& - &' ',& - &' ## Dependencies Only for Development ',& - &' # ',& - &' # You can specify dependencies your library or application does not ',& - &' # depend on in a similar way. The difference is that these will not ',& - &' # be exported as part of your project to those using it as a remote ',& - &' # dependency. ',& - &' # ',& - &' # Currently, like a global dependency it will still be available for ',& - &' # all codes. It is up to the developer to ensure that nothing except ',& - &' # developer test programs rely upon it. ',& - &' ',& - &'#M_msg = { git = "https://github.com/urbanjost/M_msg.git" } ',& - &'#M_verify = { git = "https://github.com/urbanjost/M_verify.git" } ',& - &''] - endif - if(settings%with_bare)then - elseif(settings%with_executable)then - ! create next section of fpm.toml - call mkdir(join_path(settings%name, 'app')) - ! create NAME/app or stop - if(settings%with_full)then - tomlfile=[character(len=80) :: tomlfile, & - &' #----------------------------------- ',& - &' ## Application-specific declarations ',& - &' #----------------------------------- ',& - &' # Now lets begin entries for the TOML tables (lines beginning with "[[") ',& - &' # that describe the program sources -- applications, tests, and examples. ',& - &' # ',& - &' # First we will configuration individual applications run with "fpm run". ',& - &' # ',& - &' # + the "name" entry for the executable to be built must always ',& - &' # be specified. The name must satisfy the rules for a Fortran ',& - &' # variable name. This will be the name of the binary installed by ',& - &' # the "install" subcommand and used on the "run" subcommand. ',& - &' # + The source directory for each executable can be adjusted by the ',& - &' # "source-dir" entry. ',& - &' # + The basename of the source file containing the program body can ',& - &' # be specified with the "main" entry. ',& - &' # + Executables can also specify their own external package and ',& - &' # library link dependencies. ',& - &' # ',& - &' # Currently, like a global dependency any external package dependency ',& - &' # will be available for all codes. It is up to the developer to ensure ',& - &' # that nothing except the application programs specified rely upon it. ',& - &' # ',& - &' # Note if your application needs to use a module internally, but you do not ',& - &' # intend to build it as a library to be used in other projects, you can ',& - &' # include the module in your program source file or directory as well. ',& - &' ',& - &'[[executable]] ',& - &'name="'//bname//'"',& - &'source-dir="app" ',& - &'main="main.f90" ',& - &' ',& - &' # You may repeat this pattern to define additional applications. For instance,',& - &' # the following sample illustrates all accepted options, where "link" and ',& - &' # "executable.dependencies" keys are the same as the global external library ',& - &' # links and package dependencies described previously except they apply ',& - &' # only to this executable: ',& - &' ',& - &'#[[ executable ]] ',& - &'#name = "app-name" ',& - &'#source-dir = "prog" ',& - &'#main = "program.f90" ',& - &'#link = "z" ',& - &'#[executable.dependencies] ',& - &'#M_CLI = { git = "https://github.com/urbanjost/M_CLI.git" } ',& - &'#helloff = { git = "https://gitlab.com/everythingfunctional/helloff.git" } ',& - &'#M_path = { git = "https://github.com/urbanjost/M_path.git" } ',& - &''] - endif - - if(exists(bname//'/src/'))then - littlefile=[character(len=80) :: & - &'program main', & - &' use '//to_fortran_name(bname)//', only: say_hello', & - &' implicit none', & - &'', & - &' call say_hello()', & - &'end program main'] - else - littlefile=[character(len=80) :: & - &'program main', & - &' implicit none', & - &'', & - &' print *, "hello from project '//bname//'"', & - &'end program main'] - endif - call warnwrite(join_path(settings%name, 'app/main.f90'), littlefile) - endif - - if(settings%with_bare)then - elseif(settings%with_test)then - - ! create NAME/test or stop - call mkdir(join_path(settings%name, 'test')) - ! create next section of fpm.toml - if(settings%with_full)then - tomlfile=[character(len=80) :: tomlfile ,& - &'[[test]] ',& - &' ',& - &' # The same declarations can be made for test programs, which are ',& - &' # executed with the "fpm test" command and are not build when your ',& - &' # package is used as a dependency by other packages. These are ',& - &' # typically unit tests of the package only used during package ',& - &' # development. ',& - &' ',& - &'name="runTests" ',& - &'source-dir="test" ',& - &'main="check.f90" ',& - &' ',& - &' # you may repeat this pattern to add additional explicit test program ',& - &' # parameters. The following example contains a sample of all accepted ',& - &' # options. ',& - &' ',& - &'#[[ test ]] ',& - &'#name = "tester" ',& - &'#source-dir="test" ',& - &'#main="tester.f90" ',& - &'#link = ["blas", "lapack"] ',& - &'#[test.dependencies] ',& - &'#M_CLI2 = { git = "https://github.com/urbanjost/M_CLI2.git" } ',& - &'#M_io = { git = "https://github.com/urbanjost/M_io.git" } ',& - &'#M_system= { git = "https://github.com/urbanjost/M_system.git" } ',& - &''] - endif - - littlefile=[character(len=80) :: & - &'program check', & - &'implicit none', & - &'', & - &'print *, "Put some tests in here!"', & - &'end program check'] - ! create NAME/test/check.f90 - call warnwrite(join_path(settings%name, 'test/check.f90'), littlefile) - endif - - if(settings%with_bare)then - elseif(settings%with_example)then - - ! create NAME/example or stop - call mkdir(join_path(settings%name, 'example')) - ! create next section of fpm.toml - if(settings%with_full)then - tomlfile=[character(len=80) :: tomlfile, & - &'[[example]] ',& - &' ',& - &' # Example applications for a project are defined here. ',& - &' # These are run via "fpm run --example NAME" and like the ',& - &' # test applications, are not built when this package is used as a ',& - &' # dependency by other packages. ',& - &' ',& - &'name="demo" ',& - &'source-dir="example" ',& - &'main="demo.f90" ',& - &' ',& - &' # ',& - &' # you may add additional programs to the example table. The following ',& - &' # example contains a sample of all accepted options ',& - &' ',& - &'#[[ example ]] ',& - &'#name = "example-tool" ',& - &'#source-dir="example" ',& - &'#main="tool.f90" ',& - &'#link = "z" ',& - &'#[example.dependencies] ',& - &'#M_kracken95 = { git = "https://github.com/urbanjost/M_kracken95.git" } ',& - &'#datetime = {git = "https://github.com/wavebitscientific/datetime-fortran.git" }',& - &''] - endif - - littlefile=[character(len=80) :: & - &'program demo', & - &'implicit none', & - &'', & - &'print *, "Put some examples in here!"', & - &'end program demo'] - ! create NAME/example/demo.f90 - call warnwrite(join_path(settings%name, 'example/demo.f90'), littlefile) - endif - - ! now that built it write NAME/fpm.toml - if( allocated(tomlfile) )then - call validate_toml_data(tomlfile) - call warnwrite(join_path(settings%name, 'fpm.toml'), tomlfile) - else - call create_verified_basic_manifest(join_path(settings%name, 'fpm.toml')) - endif - ! assumes git(1) is installed and in path - call run('git init ' // settings%name) -contains - -subroutine create_verified_basic_manifest(filename) -!> create a basic but verified default manifest file -use fpm_toml, only : toml_table, toml_serializer, set_value -use fpm_manifest_package, only : package_config_t, new_package -use fpm_error, only : error_t -implicit none -character(len=*),intent(in) :: filename - type(toml_table) :: table - type(toml_serializer) :: ser - type(package_config_t) :: package - type(error_t), allocatable :: error - integer :: lun - character(len=8) :: date - - !> get date to put into metadata in manifest file "fpm.toml" - call date_and_time(DATE=date) - table = toml_table() - ser = toml_serializer() - call fileopen(filename,lun) ! fileopen stops on error - - call set_value(table, "name", BNAME) - call set_value(table, "version", "0.1.0") - call set_value(table, "license", "license") - call set_value(table, "author", "Jane Doe") - call set_value(table, "maintainer", "jane.doe@example.com") - call set_value(table, "copyright", 'Copyright '//date(1:4)//', Jane Doe') - ! continue building of manifest - ! ... - call new_package(package, table, error) - if (allocated(error)) stop 3 - if(settings%verbose)then - call table%accept(ser) - endif - ser%unit=lun - call table%accept(ser) - call fileclose(lun) ! fileopen stops on error - -end subroutine create_verified_basic_manifest - - -subroutine validate_toml_data(input) -!> verify a string array is a valid fpm.toml file -! -use tomlf, only : toml_parse -use fpm_toml, only : toml_table, toml_serializer -implicit none -character(kind=tfc,len=:),intent(in),allocatable :: input(:) -character(len=1), parameter :: nl = new_line('a') -type(toml_table), allocatable :: table -character(kind=tfc, len=:), allocatable :: joined_string -type(toml_serializer) :: ser - -! you have to add a newline character by using the intrinsic -! function `new_line("a")` to get the lines processed correctly. -joined_string = join(input,right=nl) - -if (allocated(table)) deallocate(table) -call toml_parse(table, joined_string) -if (allocated(table)) then - if(settings%verbose)then - ! If the TOML file is successfully parsed the table will be allocated and - ! can be written to the standard output by passing the `toml_serializer` - ! as visitor to the table. - call table%accept(ser) - endif - call table%destroy -endif - -end subroutine validate_toml_data - -end subroutine cmd_new - -end module fpm_cmd_new diff --git a/fpm/src/fpm/cmd/update.f90 b/fpm/src/fpm/cmd/update.f90 deleted file mode 100644 index d7cc549..0000000 --- a/fpm/src/fpm/cmd/update.f90 +++ /dev/null @@ -1,68 +0,0 @@ -module fpm_cmd_update - use fpm_command_line, only : fpm_update_settings - use fpm_dependency, only : dependency_tree_t, new_dependency_tree - use fpm_error, only : error_t - use fpm_filesystem, only : exists, mkdir, join_path, delete_file - use fpm_manifest, only : package_config_t, get_package_data - implicit none - private - public :: cmd_update - -contains - - !> Entry point for the update subcommand - subroutine cmd_update(settings) - !> Representation of the command line arguments - type(fpm_update_settings), intent(in) :: settings - type(package_config_t) :: package - type(dependency_tree_t) :: deps - type(error_t), allocatable :: error - - integer :: ii - character(len=:), allocatable :: cache - - call get_package_data(package, "fpm.toml", error, apply_defaults=.true.) - call handle_error(error) - - if (.not.exists("build")) then - call mkdir("build") - end if - - cache = join_path("build", "cache.toml") - if (settings%clean) then - call delete_file(cache) - end if - - call new_dependency_tree(deps, cache=cache, & - verbosity=merge(2, 1, settings%verbose)) - - call deps%add(package, error) - call handle_error(error) - - if (settings%fetch_only) return - - if (size(settings%name) == 0) then - do ii = 1, deps%ndep - call deps%update(deps%dep(ii)%name, error) - call handle_error(error) - end do - else - do ii = 1, size(settings%name) - call deps%update(trim(settings%name(ii)), error) - call handle_error(error) - end do - end if - - end subroutine cmd_update - - !> Error handling for this command - subroutine handle_error(error) - !> Potential error - type(error_t), intent(in), optional :: error - if (present(error)) then - print '(a)', error%message - error stop 1 - end if - end subroutine handle_error - -end module fpm_cmd_update diff --git a/fpm/src/fpm/dependency.f90 b/fpm/src/fpm/dependency.f90 deleted file mode 100644 index 144ffbe..0000000 --- a/fpm/src/fpm/dependency.f90 +++ /dev/null @@ -1,821 +0,0 @@ -!> # Dependency management -!> -!> ## Fetching dependencies and creating a dependency tree -!> -!> Dependencies on the top-level can be specified from: -!> -!> - `package%dependencies` -!> - `package%dev_dependencies` -!> - `package%executable(:)%dependencies` -!> - `package%test(:)%dependencies` -!> -!> Each dependency is fetched in some way and provides a path to its package -!> manifest. -!> The `package%dependencies` of the dependencies are resolved recursively. -!> -!> To initialize the dependency tree all dependencies are recursively fetched -!> and stored in a flat data structure to avoid retrieving a package twice. -!> The data structure used to store this information should describe the current -!> status of the dependency tree. Important information are: -!> -!> - name of the package -!> - version of the package -!> - path to the package root -!> -!> Additionally, for version controlled dependencies the following should be -!> stored along with the package: -!> -!> - the upstream url -!> - the current checked out revision -!> -!> Fetching a remote (version controlled) dependency turns it for our purpose -!> into a local path dependency which is handled by the same means. -!> -!> ## Updating dependencies -!> -!> For a given dependency tree all top-level dependencies can be updated. -!> We have two cases to consider, a remote dependency and a local dependency, -!> again, remote dependencies turn into local dependencies by fetching. -!> Therefore we will update remote dependencies by simply refetching them. -!> -!> For remote dependencies we have to refetch if the revision in the manifest -!> changes or the upstream HEAD has changed (for branches _and_ tags). -!> -!> @Note For our purpose a tag is just a fancy branch name. Tags can be delete and -!> modified afterwards, therefore they do not differ too much from branches -!> from our perspective. -!> -!> For the latter case we only know if we actually fetch from the upstream URL. -!> -!> In case of local (and fetched remote) dependencies we have to read the package -!> manifest and compare its dependencies against our dependency tree, any change -!> requires updating the respective dependencies as well. -!> -!> ## Handling dependency compatibilties -!> -!> Currenly ignored. First come, first serve. -module fpm_dependency - use, intrinsic :: iso_fortran_env, only : output_unit - use fpm_environment, only : get_os_type, OS_WINDOWS - use fpm_error, only : error_t, fatal_error - use fpm_filesystem, only : exists, join_path, mkdir, canon_path, windows_path - use fpm_git, only : git_target_revision, git_target_default, git_revision - use fpm_manifest, only : package_config_t, dependency_config_t, & - get_package_data - use fpm_strings, only : string_t, operator(.in.) - use fpm_toml, only : toml_table, toml_key, toml_error, toml_serializer, & - toml_parse, get_value, set_value, add_table - use fpm_versioning, only : version_t, new_version, char - implicit none - private - - public :: dependency_tree_t, new_dependency_tree - public :: dependency_node_t, new_dependency_node - public :: resize - - - !> Overloaded reallocation interface - interface resize - module procedure :: resize_dependency_node - end interface resize - - - !> Dependency node in the projects dependency tree - type, extends(dependency_config_t) :: dependency_node_t - !> Actual version of this dependency - type(version_t), allocatable :: version - !> Installation prefix of this dependencies - character(len=:), allocatable :: proj_dir - !> Checked out revision of the version control system - character(len=:), allocatable :: revision - !> Dependency is handled - logical :: done = .false. - !> Dependency should be updated - logical :: update = .false. - contains - !> Update dependency from project manifest - procedure :: register - end type dependency_node_t - - - !> Respresentation of a projects dependencies - !> - !> The dependencies are stored in a simple array for now, this can be replaced - !> with a binary-search tree or a hash table in the future. - type :: dependency_tree_t - !> Unit for IO - integer :: unit = output_unit - !> Verbosity of printout - integer :: verbosity = 1 - !> Installation prefix for dependencies - character(len=:), allocatable :: dep_dir - !> Number of currently registered dependencies - integer :: ndep = 0 - !> Flattend list of all dependencies - type(dependency_node_t), allocatable :: dep(:) - !> Cache file - character(len=:), allocatable :: cache - contains - !> Overload procedure to add new dependencies to the tree - generic :: add => add_project, add_project_dependencies, add_dependencies, & - add_dependency - !> Main entry point to add a project - procedure, private :: add_project - !> Add a project and its dependencies to the dependency tree - procedure, private :: add_project_dependencies - !> Add a list of dependencies to the dependency tree - procedure, private :: add_dependencies - !> Add a single dependency to the dependency tree - procedure, private :: add_dependency - !> Resolve dependencies - generic :: resolve => resolve_dependencies, resolve_dependency - !> Resolve dependencies - procedure, private :: resolve_dependencies - !> Resolve dependencies - procedure, private :: resolve_dependency - !> Find a dependency in the tree - generic :: find => find_dependency, find_name - !> Find a dependency from an dependency configuration - procedure, private :: find_dependency - !> Find a dependency by its name - procedure, private :: find_name - !> Depedendncy resolution finished - procedure :: finished - !> Reading of dependency tree - generic :: load => load_from_file, load_from_unit, load_from_toml - !> Read dependency tree from file - procedure, private :: load_from_file - !> Read dependency tree from formatted unit - procedure, private :: load_from_unit - !> Read dependency tree from TOML data structure - procedure, private :: load_from_toml - !> Writing of dependency tree - generic :: dump => dump_to_file, dump_to_unit, dump_to_toml - !> Write dependency tree to file - procedure, private :: dump_to_file - !> Write dependency tree to formatted unit - procedure, private :: dump_to_unit - !> Write dependency tree to TOML data structure - procedure, private :: dump_to_toml - !> Update dependency tree - generic :: update => update_dependency - !> Update a list of dependencies - procedure, private :: update_dependency - end type dependency_tree_t - - !> Common output format for writing to the command line - character(len=*), parameter :: out_fmt = '("#", *(1x, g0))' - -contains - - !> Create a new dependency tree - subroutine new_dependency_tree(self, verbosity, cache) - !> Instance of the dependency tree - type(dependency_tree_t), intent(out) :: self - !> Verbosity of printout - integer, intent(in), optional :: verbosity - !> Name of the cache file - character(len=*), intent(in), optional :: cache - - call resize(self%dep) - self%dep_dir = join_path("build", "dependencies") - - if (present(verbosity)) then - self%verbosity = verbosity - end if - - if (present(cache)) then - self%cache = cache - end if - - end subroutine new_dependency_tree - - !> Create a new dependency node from a configuration - pure subroutine new_dependency_node(self, dependency, version, proj_dir, update) - !> Instance of the dependency node - type(dependency_node_t), intent(out) :: self - !> Dependency configuration data - type(dependency_config_t), intent(in) :: dependency - !> Version of the dependency - type(version_t), intent(in), optional :: version - !> Installation prefix of the dependency - character(len=*), intent(in), optional :: proj_dir - !> Dependency should be updated - logical, intent(in), optional :: update - - self%dependency_config_t = dependency - - if (present(version)) then - self%version = version - end if - - if (present(proj_dir)) then - self%proj_dir = proj_dir - end if - - if (present(update)) then - self%update = update - end if - - end subroutine new_dependency_node - - !> Add project dependencies, each depth level after each other. - !> - !> We implement this algorithm in an interative rather than a recursive fashion - !> as a choice of design. - subroutine add_project(self, package, error) - !> Instance of the dependency tree - class(dependency_tree_t), intent(inout) :: self - !> Project configuration to add - type(package_config_t), intent(in) :: package - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(dependency_config_t) :: dependency - character(len=:), allocatable :: root - logical :: main - - if (allocated(self%cache)) then - call self%load(self%cache, error) - if (allocated(error)) return - end if - - if (.not.exists(self%dep_dir)) then - call mkdir(self%dep_dir) - end if - - root = "." - - ! Create this project as the first dependency node (depth 0) - dependency%name = package%name - dependency%path = root - call self%add(dependency, error) - if (allocated(error)) return - - ! Resolve the root project - call self%resolve(root, error) - if (allocated(error)) return - - ! Add the root project dependencies (depth 1) - call self%add(package, root, .true., error) - if (allocated(error)) return - - ! Now decent into the dependency tree, level for level - do while(.not.self%finished()) - call self%resolve(root, error) - if (allocated(error)) exit - end do - if (allocated(error)) return - - if (allocated(self%cache)) then - call self%dump(self%cache, error) - if (allocated(error)) return - end if - - end subroutine add_project - - !> Add a project and its dependencies to the dependency tree - recursive subroutine add_project_dependencies(self, package, root, main, error) - !> Instance of the dependency tree - class(dependency_tree_t), intent(inout) :: self - !> Project configuration to add - type(package_config_t), intent(in) :: package - !> Current project root directory - character(len=*), intent(in) :: root - !> Is the main project - logical, intent(in) :: main - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: ii - - if (allocated(package%dependency)) then - call self%add(package%dependency, error) - if (allocated(error)) return - end if - - if (main) then - if (allocated(package%dev_dependency)) then - call self%add(package%dev_dependency, error) - if (allocated(error)) return - end if - - if (allocated(package%executable)) then - do ii = 1, size(package%executable) - if (allocated(package%executable(ii)%dependency)) then - call self%add(package%executable(ii)%dependency, error) - if (allocated(error)) exit - end if - end do - if (allocated(error)) return - end if - - if (allocated(package%example)) then - do ii = 1, size(package%example) - if (allocated(package%example(ii)%dependency)) then - call self%add(package%example(ii)%dependency, error) - if (allocated(error)) exit - end if - end do - if (allocated(error)) return - end if - - if (allocated(package%test)) then - do ii = 1, size(package%test) - if (allocated(package%test(ii)%dependency)) then - call self%add(package%test(ii)%dependency, error) - if (allocated(error)) exit - end if - end do - if (allocated(error)) return - end if - end if - - end subroutine add_project_dependencies - - !> Add a list of dependencies to the dependency tree - subroutine add_dependencies(self, dependency, error) - !> Instance of the dependency tree - class(dependency_tree_t), intent(inout) :: self - !> Dependency configuration to add - type(dependency_config_t), intent(in) :: dependency(:) - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: ii, ndep - - ndep = size(self%dep) - if (ndep < size(dependency) + self%ndep) then - call resize(self%dep, ndep + ndep/2 + size(dependency)) - end if - - do ii = 1, size(dependency) - call self%add(dependency(ii), error) - if (allocated(error)) exit - end do - if (allocated(error)) return - - end subroutine add_dependencies - - !> Add a single dependency to the dependency tree - pure subroutine add_dependency(self, dependency, error) - !> Instance of the dependency tree - class(dependency_tree_t), intent(inout) :: self - !> Dependency configuration to add - type(dependency_config_t), intent(in) :: dependency - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: id - - id = self%find(dependency) - if (id == 0) then - self%ndep = self%ndep + 1 - call new_dependency_node(self%dep(self%ndep), dependency) - end if - - end subroutine add_dependency - - !> Update dependency tree - subroutine update_dependency(self, name, error) - !> Instance of the dependency tree - class(dependency_tree_t), intent(inout) :: self - !> Name of the dependency to update - character(len=*), intent(in) :: name - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: id - type(package_config_t) :: package - character(len=:), allocatable :: manifest, proj_dir, revision, root - - id = self%find(name) - root = "." - - if (id <= 0) then - call fatal_error(error, "Cannot update dependency '"//name//"'") - return - end if - - associate(dep => self%dep(id)) - if (allocated(dep%git) .and. dep%update) then - if (self%verbosity > 1) then - write(self%unit, out_fmt) "Update:", dep%name - end if - proj_dir = join_path(self%dep_dir, dep%name) - call dep%git%checkout(proj_dir, error) - if (allocated(error)) return - - ! Unset dependency and remove updatable attribute - dep%done = .false. - dep%update = .false. - - ! Now decent into the dependency tree, level for level - do while(.not.self%finished()) - call self%resolve(root, error) - if (allocated(error)) exit - end do - if (allocated(error)) return - end if - end associate - - end subroutine update_dependency - - !> Resolve all dependencies in the tree - subroutine resolve_dependencies(self, root, error) - !> Instance of the dependency tree - class(dependency_tree_t), intent(inout) :: self - !> Current installation prefix - character(len=*), intent(in) :: root - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: ii - - do ii = 1, self%ndep - call self%resolve(self%dep(ii), root, error) - if (allocated(error)) exit - end do - - if (allocated(error)) return - - end subroutine resolve_dependencies - - !> Resolve a single dependency node - subroutine resolve_dependency(self, dependency, root, error) - !> Instance of the dependency tree - class(dependency_tree_t), intent(inout) :: self - !> Dependency configuration to add - type(dependency_node_t), intent(inout) :: dependency - !> Current installation prefix - character(len=*), intent(in) :: root - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(package_config_t) :: package - character(len=:), allocatable :: manifest, proj_dir, revision - logical :: fetch - - if (dependency%done) return - - fetch = .false. - if (allocated(dependency%proj_dir)) then - proj_dir = dependency%proj_dir - else - if (allocated(dependency%path)) then - proj_dir = join_path(root, dependency%path) - else if (allocated(dependency%git)) then - proj_dir = join_path(self%dep_dir, dependency%name) - fetch = .not.exists(proj_dir) - if (fetch) then - call dependency%git%checkout(proj_dir, error) - if (allocated(error)) return - end if - - end if - end if - - if (allocated(dependency%git)) then - call git_revision(proj_dir, revision, error) - if (allocated(error)) return - end if - - manifest = join_path(proj_dir, "fpm.toml") - call get_package_data(package, manifest, error) - if (allocated(error)) return - - call dependency%register(package, proj_dir, fetch, revision, error) - if (allocated(error)) return - - if (self%verbosity > 1) then - write(self%unit, out_fmt) & - "Dep:", dependency%name, "version", char(dependency%version), & - "at", dependency%proj_dir - end if - - call self%add(package, proj_dir, .false., error) - if (allocated(error)) return - - end subroutine resolve_dependency - - !> Find a dependency in the dependency tree - pure function find_dependency(self, dependency) result(pos) - !> Instance of the dependency tree - class(dependency_tree_t), intent(in) :: self - !> Dependency configuration to add - class(dependency_config_t), intent(in) :: dependency - !> Index of the dependency - integer :: pos - - integer :: ii - - pos = self%find(dependency%name) - - end function find_dependency - - !> Find a dependency in the dependency tree - pure function find_name(self, name) result(pos) - !> Instance of the dependency tree - class(dependency_tree_t), intent(in) :: self - !> Dependency configuration to add - character(len=*), intent(in) :: name - !> Index of the dependency - integer :: pos - - integer :: ii - - pos = 0 - do ii = 1, self%ndep - if (name == self%dep(ii)%name) then - pos = ii - exit - end if - end do - - end function find_name - - !> Check if we are done with the dependency resolution - pure function finished(self) - !> Instance of the dependency tree - class(dependency_tree_t), intent(in) :: self - !> All dependencies are updated - logical :: finished - integer :: ii - - finished = all(self%dep(:self%ndep)%done) - - end function finished - - !> Update dependency from project manifest - subroutine register(self, package, root, fetch, revision, error) - !> Instance of the dependency node - class(dependency_node_t), intent(inout) :: self - !> Package configuration data - type(package_config_t), intent(in) :: package - !> Project has been fetched - logical, intent(in) :: fetch - !> Root directory of the project - character(len=*), intent(in) :: root - !> Git revision of the project - character(len=*), intent(in), optional :: revision - !> Error handling - type(error_t), allocatable, intent(out) :: error - - character(len=:), allocatable :: url - logical :: update - - update = .false. - if (self%name /= package%name) then - call fatal_error(error, "Dependency name '"//package%name// & - & "' found, but expected '"//self%name//"' instead") - end if - - self%version = package%version - self%proj_dir = root - - if (allocated(self%git).and.present(revision)) then - self%revision = revision - if (.not.fetch) then - ! git object is HEAD always allows an update - update = .not.allocated(self%git%object) - if (.not.update) then - ! allow update in case the revision does not match the requested object - update = revision /= self%git%object - end if - end if - end if - - self%update = update - self%done = .true. - - end subroutine register - - !> Read dependency tree from file - subroutine load_from_file(self, file, error) - !> Instance of the dependency tree - class(dependency_tree_t), intent(inout) :: self - !> File name - character(len=*), intent(in) :: file - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - logical :: exist - - inquire(file=file, exist=exist) - if (.not.exist) return - - open(file=file, newunit=unit) - call self%load(unit, error) - close(unit) - end subroutine load_from_file - - !> Read dependency tree from file - subroutine load_from_unit(self, unit, error) - !> Instance of the dependency tree - class(dependency_tree_t), intent(inout) :: self - !> File name - integer, intent(in) :: unit - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_error), allocatable :: parse_error - type(toml_table), allocatable :: table - - call toml_parse(table, unit, parse_error) - - if (allocated(parse_error)) then - allocate(error) - call move_alloc(parse_error%message, error%message) - return - end if - - call self%load(table, error) - if (allocated(error)) return - - end subroutine load_from_unit - - !> Read dependency tree from TOML data structure - subroutine load_from_toml(self, table, error) - !> Instance of the dependency tree - class(dependency_tree_t), intent(inout) :: self - !> Data structure - type(toml_table), intent(inout) :: table - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: ndep, ii - logical :: unix - character(len=:), allocatable :: version, url, obj, rev, proj_dir - type(toml_key), allocatable :: list(:) - type(toml_table), pointer :: ptr - type(dependency_config_t) :: dep - - call table%get_keys(list) - - ndep = size(self%dep) - if (ndep < size(list) + self%ndep) then - call resize(self%dep, ndep + ndep/2 + size(list)) - end if - - unix = get_os_type() /= OS_WINDOWS - - do ii = 1, size(list) - call get_value(table, list(ii)%key, ptr) - call get_value(ptr, "version", version) - call get_value(ptr, "proj-dir", proj_dir) - call get_value(ptr, "git", url) - call get_value(ptr, "obj", obj) - call get_value(ptr, "rev", rev) - if (.not.allocated(proj_dir)) cycle - self%ndep = self%ndep + 1 - associate(dep => self%dep(self%ndep)) - dep%name = list(ii)%key - if (unix) then - dep%proj_dir = proj_dir - else - dep%proj_dir = windows_path(proj_dir) - end if - dep%done = .false. - if (allocated(version)) then - if (.not.allocated(dep%version)) allocate(dep%version) - call new_version(dep%version, version, error) - if (allocated(error)) exit - end if - if (allocated(version)) then - call new_version(dep%version, version, error) - if (allocated(error)) exit - end if - if (allocated(url)) then - if (allocated(obj)) then - dep%git = git_target_revision(url, obj) - else - dep%git = git_target_default(url) - end if - if (allocated(rev)) then - dep%revision = rev - end if - else - dep%path = proj_dir - end if - end associate - end do - if (allocated(error)) return - - self%ndep = size(list) - end subroutine load_from_toml - - !> Write dependency tree to file - subroutine dump_to_file(self, file, error) - !> Instance of the dependency tree - class(dependency_tree_t), intent(inout) :: self - !> File name - character(len=*), intent(in) :: file - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - - open(file=file, newunit=unit) - call self%dump(unit, error) - close(unit) - if (allocated(error)) return - - end subroutine dump_to_file - - !> Write dependency tree to file - subroutine dump_to_unit(self, unit, error) - !> Instance of the dependency tree - class(dependency_tree_t), intent(inout) :: self - !> Formatted unit - integer, intent(in) :: unit - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(toml_serializer) :: ser - - table = toml_table() - ser = toml_serializer(unit) - - call self%dump(table, error) - - call table%accept(ser) - - end subroutine dump_to_unit - - !> Write dependency tree to TOML datastructure - subroutine dump_to_toml(self, table, error) - !> Instance of the dependency tree - class(dependency_tree_t), intent(inout) :: self - !> Data structure - type(toml_table), intent(inout) :: table - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: ii - type(toml_table), pointer :: ptr - character(len=:), allocatable :: proj_dir - - do ii = 1, self%ndep - associate(dep => self%dep(ii)) - call add_table(table, dep%name, ptr) - if (.not.associated(ptr)) then - call fatal_error(error, "Cannot create entry for "//dep%name) - exit - end if - if (allocated(dep%version)) then - call set_value(ptr, "version", char(dep%version)) - end if - proj_dir = canon_path(dep%proj_dir) - call set_value(ptr, "proj-dir", proj_dir) - if (allocated(dep%git)) then - call set_value(ptr, "git", dep%git%url) - if (allocated(dep%git%object)) then - call set_value(ptr, "obj", dep%git%object) - end if - if (allocated(dep%revision)) then - call set_value(ptr, "rev", dep%revision) - end if - end if - end associate - end do - if (allocated(error)) return - - end subroutine dump_to_toml - - !> Reallocate a list of dependencies - pure subroutine resize_dependency_node(var, n) - !> Instance of the array to be resized - type(dependency_node_t), allocatable, intent(inout) :: var(:) - !> Dimension of the final array size - integer, intent(in), optional :: n - - type(dependency_node_t), allocatable :: tmp(:) - integer :: this_size, new_size - integer, parameter :: initial_size = 16 - - if (allocated(var)) then - this_size = size(var, 1) - call move_alloc(var, tmp) - else - this_size = initial_size - end if - - if (present(n)) then - new_size = n - else - new_size = this_size + this_size/2 + 1 - end if - - allocate(var(new_size)) - - if (allocated(tmp)) then - this_size = min(size(tmp, 1), size(var, 1)) - var(:this_size) = tmp(:this_size) - deallocate(tmp) - end if - - end subroutine resize_dependency_node - -end module fpm_dependency diff --git a/fpm/src/fpm/error.f90 b/fpm/src/fpm/error.f90 deleted file mode 100644 index e69ff1e..0000000 --- a/fpm/src/fpm/error.f90 +++ /dev/null @@ -1,128 +0,0 @@ -!> Implementation of basic error handling. -module fpm_error - implicit none - private - - public :: error_t - public :: fatal_error, syntax_error, file_not_found_error - public :: file_parse_error - - - !> Data type defining an error - type :: error_t - - !> Error message - character(len=:), allocatable :: message - - end type error_t - - - !> Alias syntax errors to fatal errors for now - interface syntax_error - module procedure :: fatal_error - end interface syntax_error - - -contains - - - !> Generic fatal runtime error - subroutine fatal_error(error, message) - - !> Instance of the error data - type(error_t), allocatable, intent(out) :: error - - !> Error message - character(len=*), intent(in) :: message - - allocate(error) - error%message = message - - end subroutine fatal_error - - - !> Error created when a file is missing or not found - subroutine file_not_found_error(error, file_name) - - !> Instance of the error data - type(error_t), allocatable, intent(out) :: error - - !> Name of the missing file - character(len=*), intent(in) :: file_name - - allocate(error) - error%message = "'"//file_name//"' could not be found, check if the file exists" - - 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/git.f90 b/fpm/src/fpm/git.f90 deleted file mode 100644 index 08e27b2..0000000 --- a/fpm/src/fpm/git.f90 +++ /dev/null @@ -1,263 +0,0 @@ -!> Implementation for interacting with git repositories. -module fpm_git - use fpm_error, only: error_t, fatal_error - use fpm_filesystem, only : get_temp_filename, getline - implicit none - - public :: git_target_t - public :: git_target_default, git_target_branch, git_target_tag, & - & git_target_revision - public :: git_revision - - - !> Possible git target - type :: enum_descriptor - - !> Default target - integer :: default = 200 - - !> Branch in git repository - integer :: branch = 201 - - !> Tag in git repository - integer :: tag = 202 - - !> Commit hash - integer :: revision = 203 - - end type enum_descriptor - - !> Actual enumerator for descriptors - type(enum_descriptor), parameter :: git_descriptor = enum_descriptor() - - - !> Description of an git target - type :: git_target_t - - !> Kind of the git target - integer, private :: descriptor = git_descriptor%default - - !> Target URL of the git repository - character(len=:), allocatable :: url - - !> Additional descriptor of the git object - character(len=:), allocatable :: object - - contains - - !> Fetch and checkout in local directory - procedure :: checkout - - !> Show information on instance - procedure :: info - - end type git_target_t - - -contains - - - !> Default target - function git_target_default(url) result(self) - - !> Target URL of the git repository - character(len=*), intent(in) :: url - - !> New git target - type(git_target_t) :: self - - self%descriptor = git_descriptor%default - self%url = url - - end function git_target_default - - - !> Target a branch in the git repository - function git_target_branch(url, branch) result(self) - - !> Target URL of the git repository - character(len=*), intent(in) :: url - - !> Name of the branch of interest - character(len=*), intent(in) :: branch - - !> New git target - type(git_target_t) :: self - - self%descriptor = git_descriptor%branch - self%url = url - self%object = branch - - end function git_target_branch - - - !> Target a specific git revision - function git_target_revision(url, sha1) result(self) - - !> Target URL of the git repository - character(len=*), intent(in) :: url - - !> Commit hash of interest - character(len=*), intent(in) :: sha1 - - !> New git target - type(git_target_t) :: self - - self%descriptor = git_descriptor%revision - self%url = url - self%object = sha1 - - end function git_target_revision - - - !> Target a git tag - function git_target_tag(url, tag) result(self) - - !> Target URL of the git repository - character(len=*), intent(in) :: url - - !> Tag name of interest - character(len=*), intent(in) :: tag - - !> New git target - type(git_target_t) :: self - - self%descriptor = git_descriptor%tag - self%url = url - self%object = tag - - end function git_target_tag - - - subroutine checkout(self, local_path, error) - - !> Instance of the git target - class(git_target_t), intent(in) :: self - - !> Local path to checkout in - character(*), intent(in) :: local_path - - !> Error - type(error_t), allocatable, intent(out) :: error - - integer :: stat - character(len=:), allocatable :: object - - if (allocated(self%object)) then - object = self%object - else - object = 'HEAD' - end if - - call execute_command_line("git init "//local_path, exitstat=stat) - - if (stat /= 0) then - call fatal_error(error,'Error while initiating git repository for remote dependency') - return - end if - - call execute_command_line("git -C "//local_path//" fetch --depth=1 "// & - self%url//" "//object, exitstat=stat) - - if (stat /= 0) then - call fatal_error(error,'Error while fetching git repository for remote dependency') - return - end if - - call execute_command_line("git -C "//local_path//" checkout -qf FETCH_HEAD", exitstat=stat) - - if (stat /= 0) then - call fatal_error(error,'Error while checking out git repository for remote dependency') - return - end if - - end subroutine checkout - - - subroutine git_revision(local_path, object, error) - - !> Local path to checkout in - character(*), intent(in) :: local_path - - !> Git object reference - character(len=:), allocatable, intent(out) :: object - - !> Error - type(error_t), allocatable, intent(out) :: error - - integer :: stat, unit, istart, iend - character(len=:), allocatable :: temp_file, line, iomsg - character(len=*), parameter :: hexdigits = '0123456789abcdef' - - allocate(temp_file, source=get_temp_filename()) - line = "git -C "//local_path//" log -n 1 > "//temp_file - call execute_command_line(line, exitstat=stat) - - if (stat /= 0) then - call fatal_error(error, "Error while retrieving commit information") - return - end if - - open(file=temp_file, newunit=unit) - call getline(unit, line, stat, iomsg) - - if (stat /= 0) then - call fatal_error(error, iomsg) - return - end if - close(unit, status="delete") - - ! Tokenize: - ! commit 0123456789abcdef (HEAD, ...) - istart = scan(line, ' ') + 1 - iend = verify(line(istart:), hexdigits) + istart - 1 - if (iend < istart) iend = len(line) - object = line(istart:iend) - - end subroutine git_revision - - - !> Show information on git target - subroutine info(self, unit, verbosity) - - !> Instance of the git target - class(git_target_t), intent(in) :: self - - !> Unit for IO - integer, intent(in) :: unit - - !> Verbosity of the printout - integer, intent(in), optional :: verbosity - - integer :: pr - character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)' - - if (present(verbosity)) then - pr = verbosity - else - pr = 1 - end if - - if (pr < 1) return - - write(unit, fmt) "Git target" - if (allocated(self%url)) then - write(unit, fmt) "- URL", self%url - end if - if (allocated(self%object)) then - select case(self%descriptor) - case default - write(unit, fmt) "- object", self%object - case(git_descriptor%tag) - write(unit, fmt) "- tag", self%object - case(git_descriptor%branch) - write(unit, fmt) "- branch", self%object - case(git_descriptor%revision) - write(unit, fmt) "- sha1", self%object - end select - end if - - end subroutine info - - -end module fpm_git diff --git a/fpm/src/fpm/installer.f90 b/fpm/src/fpm/installer.f90 deleted file mode 100644 index d01bd27..0000000 --- a/fpm/src/fpm/installer.f90 +++ /dev/null @@ -1,284 +0,0 @@ -!> Implementation of an installer object. -!> -!> The installer provides a way to install objects to their respective directories -!> in the installation prefix, a generic install command allows to install -!> to any directory within the prefix. -module fpm_installer - use, intrinsic :: iso_fortran_env, only : output_unit - use fpm_environment, only : get_os_type, os_is_unix - use fpm_error, only : error_t, fatal_error - use fpm_filesystem, only : join_path, mkdir, exists, unix_path, windows_path, & - env_variable - implicit none - private - - public :: installer_t, new_installer - - - !> Declaration of the installer type - type :: installer_t - !> Path to installation directory - character(len=:), allocatable :: prefix - !> Binary dir relative to the installation prefix - character(len=:), allocatable :: bindir - !> Library directory relative to the installation prefix - character(len=:), allocatable :: libdir - !> Include directory relative to the installation prefix - character(len=:), allocatable :: includedir - !> Output unit for informative printout - integer :: unit = output_unit - !> Verbosity of the installer - integer :: verbosity = 1 - !> Command to copy objects into the installation prefix - character(len=:), allocatable :: copy - !> Cached operating system - integer :: os - contains - !> Install an executable in its correct subdirectory - procedure :: install_executable - !> Install a library in its correct subdirectory - procedure :: install_library - !> Install a header/module in its correct subdirectory - procedure :: install_header - !> Install a generic file into a subdirectory in the installation prefix - procedure :: install - !> Run an installation command, type-bound for unit testing purposes - procedure :: run - !> Create a new directory in the prefix, type-bound for unit testing purposes - procedure :: make_dir - end type installer_t - - !> Default name of the binary subdirectory - character(len=*), parameter :: default_bindir = "bin" - - !> Default name of the library subdirectory - character(len=*), parameter :: default_libdir = "lib" - - !> Default name of the include subdirectory - character(len=*), parameter :: default_includedir = "include" - - !> Default name of the installation prefix on Unix platforms - character(len=*), parameter :: default_prefix_unix = "/usr/local" - - !> Default name of the installation prefix on Windows platforms - character(len=*), parameter :: default_prefix_win = "C:\" - - !> Copy command on Unix platforms - character(len=*), parameter :: default_copy_unix = "cp" - - !> Copy command on Windows platforms - character(len=*), parameter :: default_copy_win = "copy" - -contains - - !> Create a new instance of an installer - subroutine new_installer(self, prefix, bindir, libdir, includedir, verbosity, & - copy) - !> Instance of the installer - type(installer_t), intent(out) :: self - !> Path to installation directory - character(len=*), intent(in), optional :: prefix - !> Binary dir relative to the installation prefix - character(len=*), intent(in), optional :: bindir - !> Library directory relative to the installation prefix - character(len=*), intent(in), optional :: libdir - !> Include directory relative to the installation prefix - character(len=*), intent(in), optional :: includedir - !> Verbosity of the installer - integer, intent(in), optional :: verbosity - !> Copy command - character(len=*), intent(in), optional :: copy - - self%os = get_os_type() - - if (present(copy)) then - self%copy = copy - else - if (os_is_unix(self%os)) then - self%copy = default_copy_unix - else - self%copy = default_copy_win - end if - end if - - if (present(includedir)) then - self%includedir = includedir - else - self%includedir = default_includedir - end if - - if (present(prefix)) then - self%prefix = prefix - else - call set_default_prefix(self%prefix, self%os) - end if - - if (present(bindir)) then - self%bindir = bindir - else - self%bindir = default_bindir - end if - - if (present(libdir)) then - self%libdir = libdir - else - self%libdir = default_libdir - end if - - if (present(verbosity)) then - self%verbosity = verbosity - else - self%verbosity = 1 - end if - - end subroutine new_installer - - !> Set the default prefix for the installation - subroutine set_default_prefix(prefix, os) - !> Installation prefix - character(len=:), allocatable :: prefix - !> Platform identifier - integer, intent(in), optional :: os - - character(len=:), allocatable :: home - - if (os_is_unix(os)) then - call env_variable(home, "HOME") - if (allocated(home)) then - prefix = join_path(home, ".local") - else - prefix = default_prefix_unix - end if - else - call env_variable(home, "APPDATA") - if (allocated(home)) then - prefix = join_path(home, "local") - else - prefix = default_prefix_win - end if - end if - - end subroutine set_default_prefix - - !> Install an executable in its correct subdirectory - subroutine install_executable(self, executable, error) - !> Instance of the installer - class(installer_t), intent(inout) :: self - !> Path to the executable - character(len=*), intent(in) :: executable - !> Error handling - type(error_t), allocatable, intent(out) :: error - integer :: ll - - if (.not.os_is_unix(self%os)) then - ll = len(executable) - if (executable(max(1, ll-3):ll) /= ".exe") then - call self%install(executable//".exe", self%bindir, error) - return - end if - end if - - call self%install(executable, self%bindir, error) - - end subroutine install_executable - - !> Install a library in its correct subdirectory - subroutine install_library(self, library, error) - !> Instance of the installer - class(installer_t), intent(inout) :: self - !> Path to the library - character(len=*), intent(in) :: library - !> Error handling - type(error_t), allocatable, intent(out) :: error - - call self%install(library, self%libdir, error) - end subroutine install_library - - !> Install a header/module in its correct subdirectory - subroutine install_header(self, header, error) - !> Instance of the installer - class(installer_t), intent(inout) :: self - !> Path to the header - character(len=*), intent(in) :: header - !> Error handling - type(error_t), allocatable, intent(out) :: error - - call self%install(header, self%includedir, error) - end subroutine install_header - - !> Install a generic file into a subdirectory in the installation prefix - subroutine install(self, source, destination, error) - !> Instance of the installer - class(installer_t), intent(inout) :: self - !> Path to the original file - character(len=*), intent(in) :: source - !> Path to the destination inside the prefix - character(len=*), intent(in) :: destination - !> Error handling - type(error_t), allocatable, intent(out) :: error - - character(len=:), allocatable :: install_dest - - install_dest = join_path(self%prefix, destination) - if (os_is_unix(self%os)) then - install_dest = unix_path(install_dest) - else - install_dest = windows_path(install_dest) - end if - call self%make_dir(install_dest, error) - if (allocated(error)) return - - if (self%verbosity > 0) then - if (exists(install_dest)) then - write(self%unit, '("# Update:", 1x, a, 1x, "->", 1x, a)') & - source, install_dest - else - write(self%unit, '("# Install:", 1x, a, 1x, "->", 1x, a)') & - source, install_dest - end if - end if - - call self%run(self%copy//' "'//source//'" "'//install_dest//'"', error) - if (allocated(error)) return - - end subroutine install - - !> Create a new directory in the prefix - subroutine make_dir(self, dir, error) - !> Instance of the installer - class(installer_t), intent(inout) :: self - !> Directory to be created - character(len=*), intent(in) :: dir - !> Error handling - type(error_t), allocatable, intent(out) :: error - - if (.not.exists(dir)) then - if (self%verbosity > 1) then - write(self%unit, '("# Dir:", 1x, a)') dir - end if - call mkdir(dir) - end if - end subroutine make_dir - - !> Run an installation command - subroutine run(self, command, error) - !> Instance of the installer - class(installer_t), intent(inout) :: self - !> Command to be launched - character(len=*), intent(in) :: command - !> Error handling - type(error_t), allocatable, intent(out) :: error - integer :: stat - - if (self%verbosity > 1) then - write(self%unit, '("# Run:", 1x, a)') command - end if - call execute_command_line(command, exitstat=stat) - - if (stat /= 0) then - call fatal_error(error, "Failed in command: '"//command//"'") - return - end if - end subroutine run - -end module fpm_installer diff --git a/fpm/src/fpm/manifest.f90 b/fpm/src/fpm/manifest.f90 deleted file mode 100644 index 4170b91..0000000 --- a/fpm/src/fpm/manifest.f90 +++ /dev/null @@ -1,184 +0,0 @@ -!> Package configuration data. -!> -!> This module provides the necessary procedure to translate a TOML document -!> to the corresponding Fortran type, while verifying it with respect to -!> its schema. -!> -!> Additionally, the required data types for users of this module are reexported -!> to hide the actual implementation details. -module fpm_manifest - use fpm_manifest_build, only: build_config_t - use fpm_manifest_example, only : example_config_t - use fpm_manifest_executable, only : executable_config_t - use fpm_manifest_dependency, only : dependency_config_t - use fpm_manifest_library, only : library_config_t - use fpm_manifest_package, only : package_config_t, new_package - use fpm_error, only : error_t, fatal_error, file_not_found_error - use fpm_toml, only : toml_table, read_package_file - use fpm_manifest_test, only : test_config_t - use fpm_filesystem, only: join_path, exists, dirname, is_dir - use fpm_strings, only: string_t - implicit none - private - - public :: get_package_data, default_executable, default_library, default_test - public :: default_example - public :: package_config_t, dependency_config_t - - -contains - - - !> Populate library in case we find the default src directory - subroutine default_library(self) - - !> Instance of the library meta data - type(library_config_t), intent(out) :: self - - self%source_dir = "src" - self%include_dir = [string_t("include")] - - end subroutine default_library - - - !> Populate executable in case we find the default app directory - subroutine default_executable(self, name) - - !> Instance of the executable meta data - type(executable_config_t), intent(out) :: self - - !> Name of the package - character(len=*), intent(in) :: name - - self%name = name - self%source_dir = "app" - self%main = "main.f90" - - end subroutine default_executable - - !> Populate test in case we find the default example/ directory - subroutine default_example(self, name) - - !> Instance of the executable meta data - type(example_config_t), intent(out) :: self - - !> Name of the package - character(len=*), intent(in) :: name - - self%name = name // "-demo" - self%source_dir = "example" - self%main = "main.f90" - - end subroutine default_example - - !> Populate test in case we find the default test/ directory - subroutine default_test(self, name) - - !> Instance of the executable meta data - type(test_config_t), intent(out) :: self - - !> Name of the package - character(len=*), intent(in) :: name - - self%name = name // "-test" - self%source_dir = "test" - self%main = "main.f90" - - end subroutine default_test - - - !> Obtain package meta data from a configuation file - subroutine get_package_data(package, file, error, apply_defaults) - - !> Parsed package meta data - type(package_config_t), intent(out) :: package - - !> Name of the package configuration file - character(len=*), intent(in) :: file - - !> Error status of the operation - type(error_t), allocatable, intent(out) :: error - - !> Apply package defaults (uses file system operations) - logical, intent(in), optional :: apply_defaults - - type(toml_table), allocatable :: table - character(len=:), allocatable :: root - - call read_package_file(table, file, error) - if (allocated(error)) return - - if (.not.allocated(table)) then - call fatal_error(error, "Unclassified error while reading: '"//file//"'") - return - end if - - call new_package(package, table, error) - if (allocated(error)) return - - if (present(apply_defaults)) then - if (apply_defaults) then - root = dirname(file) - if (len_trim(root) == 0) root = "." - call package_defaults(package, root, error) - if (allocated(error)) return - end if - end if - - end subroutine get_package_data - - - !> Apply package defaults - subroutine package_defaults(package, root, error) - - !> Parsed package meta data - type(package_config_t), intent(inout) :: package - - !> Current working directory - character(len=*), intent(in) :: root - - !> Error status of the operation - type(error_t), allocatable, intent(out) :: error - - ! Populate library in case we find the default src directory - if (.not.allocated(package%library) .and. & - & (is_dir(join_path(root, "src")) .or. & - & is_dir(join_path(root, "include")))) then - - allocate(package%library) - call default_library(package%library) - end if - - ! Populate executable in case we find the default app - if (.not.allocated(package%executable) .and. & - & exists(join_path(root, "app", "main.f90"))) then - allocate(package%executable(1)) - call default_executable(package%executable(1), package%name) - end if - - ! Populate example in case we find the default example directory - if (.not.allocated(package%example) .and. & - & exists(join_path(root, "example", "main.f90"))) then - allocate(package%example(1)) - call default_example(package%example(1), package%name) - endif - - ! Populate test in case we find the default test directory - if (.not.allocated(package%test) .and. & - & exists(join_path(root, "test", "main.f90"))) then - allocate(package%test(1)) - call default_test(package%test(1), package%name) - endif - - if (.not.(allocated(package%library) & - & .or. allocated(package%executable) & - & .or. allocated(package%example) & - & .or. allocated(package%test))) then - call fatal_error(error, "Neither library nor executable found, there is nothing to do") - return - end if - - end subroutine package_defaults - - -end module fpm_manifest diff --git a/fpm/src/fpm/manifest/build.f90 b/fpm/src/fpm/manifest/build.f90 deleted file mode 100644 index d96974f..0000000 --- a/fpm/src/fpm/manifest/build.f90 +++ /dev/null @@ -1,162 +0,0 @@ -!> Implementation of the build configuration data. -!> -!> A build table can currently have the following fields -!> -!>```toml -!>[build] -!>auto-executables = bool -!>auto-examples = bool -!>auto-tests = bool -!>link = ["lib"] -!>``` -module fpm_manifest_build - use fpm_error, only : error_t, syntax_error, fatal_error - use fpm_strings, only : string_t - use fpm_toml, only : toml_table, toml_key, toml_stat, get_value - implicit none - private - - public :: build_config_t, new_build_config - - - !> Configuration data for build - type :: build_config_t - - !> Automatic discovery of executables - logical :: auto_executables - - !> Automatic discovery of examples - logical :: auto_examples - - !> Automatic discovery of tests - logical :: auto_tests - - !> Libraries to link against - type(string_t), allocatable :: link(:) - - contains - - !> Print information on this instance - procedure :: info - - end type build_config_t - - -contains - - - !> Construct a new build configuration from a TOML data structure - subroutine new_build_config(self, table, error) - - !> Instance of the build configuration - type(build_config_t), intent(out) :: self - - !> Instance of the TOML data structure - type(toml_table), intent(inout) :: table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: stat - - call check(table, error) - if (allocated(error)) return - - call get_value(table, "auto-executables", self%auto_executables, .true., stat=stat) - - if (stat /= toml_stat%success) then - call fatal_error(error,"Error while reading value for 'auto-executables' in fpm.toml, expecting logical") - return - end if - - call get_value(table, "auto-tests", self%auto_tests, .true., stat=stat) - - if (stat /= toml_stat%success) then - call fatal_error(error,"Error while reading value for 'auto-tests' in fpm.toml, expecting logical") - return - end if - - call get_value(table, "auto-examples", self%auto_examples, .true., stat=stat) - - if (stat /= toml_stat%success) then - call fatal_error(error,"Error while reading value for 'auto-examples' in fpm.toml, expecting logical") - return - end if - - - call get_value(table, "link", self%link, error) - if (allocated(error)) return - - end subroutine new_build_config - - - !> Check local schema for allowed entries - subroutine check(table, error) - - !> Instance of the TOML data structure - type(toml_table), intent(inout) :: table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_key), allocatable :: list(:) - integer :: ikey - - call table%get_keys(list) - - ! table can be empty - if (size(list) < 1) return - - do ikey = 1, size(list) - select case(list(ikey)%key) - - case("auto-executables", "auto-examples", "auto-tests", "link") - continue - - case default - call syntax_error(error, "Key "//list(ikey)%key//" is not allowed in [build]") - exit - - end select - end do - - end subroutine check - - - !> Write information on build configuration instance - subroutine info(self, unit, verbosity) - - !> Instance of the build configuration - class(build_config_t), intent(in) :: self - - !> Unit for IO - integer, intent(in) :: unit - - !> Verbosity of the printout - integer, intent(in), optional :: verbosity - - integer :: pr, ilink - character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)' - - if (present(verbosity)) then - pr = verbosity - else - pr = 1 - end if - - if (pr < 1) return - - write(unit, fmt) "Build configuration" - write(unit, fmt) " - auto-discovery (apps) ", merge("enabled ", "disabled", self%auto_executables) - write(unit, fmt) " - auto-discovery (examples) ", merge("enabled ", "disabled", self%auto_examples) - write(unit, fmt) " - auto-discovery (tests) ", merge("enabled ", "disabled", self%auto_tests) - if (allocated(self%link)) then - write(unit, fmt) " - link against" - do ilink = 1, size(self%link) - write(unit, fmt) " - " // self%link(ilink)%s - end do - end if - - end subroutine info - -end module fpm_manifest_build diff --git a/fpm/src/fpm/manifest/dependency.f90 b/fpm/src/fpm/manifest/dependency.f90 deleted file mode 100644 index 26b76ee..0000000 --- a/fpm/src/fpm/manifest/dependency.f90 +++ /dev/null @@ -1,248 +0,0 @@ -!> Implementation of the meta data for dependencies. -!> -!> A dependency table can currently have the following fields -!> -!>```toml -!>[dependencies] -!>"dep1" = { git = "url" } -!>"dep2" = { git = "url", branch = "name" } -!>"dep3" = { git = "url", tag = "name" } -!>"dep4" = { git = "url", rev = "sha1" } -!>"dep0" = { path = "path" } -!>``` -!> -!> To reduce the amount of boilerplate code this module provides two constructors -!> for dependency types, one basic for an actual dependency (inline) table -!> and another to collect all dependency objects from a dependencies table, -!> which is handling the allocation of the objects and is forwarding the -!> individual dependency tables to their respective constructors. -!> The usual entry point should be the constructor for the super table. -!> -!> This objects contains a target to retrieve required `fpm` projects to -!> build the target declaring the dependency. -!> Resolving a dependency will result in obtaining a new package configuration -!> data for the respective project. -module fpm_manifest_dependency - use fpm_error, only : error_t, syntax_error - use fpm_git, only : git_target_t, git_target_tag, git_target_branch, & - & git_target_revision, git_target_default - use fpm_toml, only : toml_table, toml_key, toml_stat, get_value - implicit none - private - - public :: dependency_config_t, new_dependency, new_dependencies - - - !> Configuration meta data for a dependency - type :: dependency_config_t - - !> Name of the dependency - character(len=:), allocatable :: name - - !> Local target - character(len=:), allocatable :: path - - !> Git descriptor - type(git_target_t), allocatable :: git - - contains - - !> Print information on this instance - procedure :: info - - end type dependency_config_t - - -contains - - - !> Construct a new dependency configuration from a TOML data structure - subroutine new_dependency(self, table, error) - - !> Instance of the dependency configuration - type(dependency_config_t), intent(out) :: self - - !> Instance of the TOML data structure - type(toml_table), intent(inout) :: table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - character(len=:), allocatable :: url, obj - - call check(table, error) - if (allocated(error)) return - - call table%get_key(self%name) - - call get_value(table, "path", url) - if (allocated(url)) then - call move_alloc(url, self%path) - else - call get_value(table, "git", url) - - call get_value(table, "tag", obj) - if (allocated(obj)) then - self%git = git_target_tag(url, obj) - end if - - if (.not.allocated(self%git)) then - call get_value(table, "branch", obj) - if (allocated(obj)) then - self%git = git_target_branch(url, obj) - end if - end if - - if (.not.allocated(self%git)) then - call get_value(table, "rev", obj) - if (allocated(obj)) then - self%git = git_target_revision(url, obj) - end if - end if - - if (.not.allocated(self%git)) then - self%git = git_target_default(url) - end if - - end if - - end subroutine new_dependency - - - !> Check local schema for allowed entries - subroutine check(table, error) - - !> Instance of the TOML data structure - type(toml_table), intent(inout) :: table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - character(len=:), allocatable :: name - type(toml_key), allocatable :: list(:) - logical :: url_present, git_target_present, has_path - integer :: ikey - - has_path = .false. - url_present = .false. - git_target_present = .false. - - call table%get_key(name) - call table%get_keys(list) - - if (size(list) < 1) then - call syntax_error(error, "Dependency "//name//" does not provide sufficient entries") - return - end if - - do ikey = 1, size(list) - select case(list(ikey)%key) - case default - call syntax_error(error, "Key "//list(ikey)%key//" is not allowed in dependency "//name) - exit - - case("git", "path") - if (url_present) then - call syntax_error(error, "Dependency "//name//" cannot have both git and path entries") - exit - end if - url_present = .true. - has_path = list(ikey)%key == 'path' - - case("branch", "rev", "tag") - if (git_target_present) then - call syntax_error(error, "Dependency "//name//" can only have one of branch, rev or tag present") - exit - end if - git_target_present = .true. - - end select - end do - if (allocated(error)) return - - if (.not.url_present) then - call syntax_error(error, "Dependency "//name//" does not provide a method to actually retrieve itself") - return - end if - - 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 - - end subroutine check - - - !> Construct new dependency array from a TOML data structure - subroutine new_dependencies(deps, table, error) - - !> Instance of the dependency configuration - type(dependency_config_t), allocatable, intent(out) :: deps(:) - - !> Instance of the TOML data structure - type(toml_table), intent(inout) :: table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table), pointer :: node - type(toml_key), allocatable :: list(:) - integer :: idep, stat - - call table%get_keys(list) - ! An empty table is okay - if (size(list) < 1) return - - allocate(deps(size(list))) - do idep = 1, size(list) - call get_value(table, list(idep)%key, node, stat=stat) - if (stat /= toml_stat%success) then - call syntax_error(error, "Dependency "//list(idep)%key//" must be a table entry") - exit - end if - call new_dependency(deps(idep), node, error) - if (allocated(error)) exit - end do - - end subroutine new_dependencies - - - !> Write information on instance - subroutine info(self, unit, verbosity) - - !> Instance of the dependency configuration - class(dependency_config_t), intent(in) :: self - - !> Unit for IO - integer, intent(in) :: unit - - !> Verbosity of the printout - integer, intent(in), optional :: verbosity - - integer :: pr - character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)' - - if (present(verbosity)) then - pr = verbosity - else - pr = 1 - end if - - write(unit, fmt) "Dependency" - if (allocated(self%name)) then - write(unit, fmt) "- name", self%name - end if - - if (allocated(self%git)) then - write(unit, fmt) "- kind", "git" - call self%git%info(unit, pr - 1) - end if - - if (allocated(self%path)) then - write(unit, fmt) "- kind", "local" - write(unit, fmt) "- path", self%path - end if - - end subroutine info - - -end module fpm_manifest_dependency diff --git a/fpm/src/fpm/manifest/example.f90 b/fpm/src/fpm/manifest/example.f90 deleted file mode 100644 index fc2a0af..0000000 --- a/fpm/src/fpm/manifest/example.f90 +++ /dev/null @@ -1,175 +0,0 @@ -!> Implementation of the meta data for an example. -!> -!> The example data structure is effectively a decorated version of an executable -!> and shares most of its properties, except for the defaults and can be -!> handled under most circumstances just like any other executable. -!> -!> A example table can currently have the following fields -!> -!>```toml -!>[[ example ]] -!>name = "string" -!>source-dir = "path" -!>main = "file" -!>link = ["lib"] -!>[example.dependencies] -!>``` -module fpm_manifest_example - use fpm_manifest_dependency, only : dependency_config_t, new_dependencies - use fpm_manifest_executable, only : executable_config_t - use fpm_error, only : error_t, syntax_error - use fpm_toml, only : toml_table, toml_key, toml_stat, get_value - implicit none - private - - public :: example_config_t, new_example - - - !> Configuation meta data for an example - type, extends(executable_config_t) :: example_config_t - - contains - - !> Print information on this instance - procedure :: info - - end type example_config_t - - -contains - - - !> Construct a new example configuration from a TOML data structure - subroutine new_example(self, table, error) - - !> Instance of the example configuration - type(example_config_t), intent(out) :: self - - !> Instance of the TOML data structure - type(toml_table), intent(inout) :: table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table), pointer :: child - - call check(table, error) - if (allocated(error)) return - - call get_value(table, "name", self%name) - if (.not.allocated(self%name)) then - call syntax_error(error, "Could not retrieve example name") - return - end if - call get_value(table, "source-dir", self%source_dir, "example") - call get_value(table, "main", self%main, "main.f90") - - call get_value(table, "dependencies", child, requested=.false.) - if (associated(child)) then - call new_dependencies(self%dependency, child, error) - if (allocated(error)) return - end if - - call get_value(table, "link", self%link, error) - if (allocated(error)) return - - end subroutine new_example - - - !> Check local schema for allowed entries - subroutine check(table, error) - - !> Instance of the TOML data structure - type(toml_table), intent(inout) :: table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_key), allocatable :: list(:) - logical :: name_present - integer :: ikey - - name_present = .false. - - call table%get_keys(list) - - if (size(list) < 1) then - call syntax_error(error, "Example section does not provide sufficient entries") - return - end if - - do ikey = 1, size(list) - select case(list(ikey)%key) - case default - call syntax_error(error, "Key "//list(ikey)%key//" is not allowed in example entry") - exit - - case("name") - name_present = .true. - - case("source-dir", "main", "dependencies", "link") - continue - - end select - end do - if (allocated(error)) return - - if (.not.name_present) then - call syntax_error(error, "Example name is not provided, please add a name entry") - end if - - end subroutine check - - - !> Write information on instance - subroutine info(self, unit, verbosity) - - !> Instance of the example configuration - class(example_config_t), intent(in) :: self - - !> Unit for IO - integer, intent(in) :: unit - - !> Verbosity of the printout - integer, intent(in), optional :: verbosity - - integer :: pr, ii - character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)', & - & fmti = '("#", 1x, a, t30, i0)' - - if (present(verbosity)) then - pr = verbosity - else - pr = 1 - end if - - if (pr < 1) return - - write(unit, fmt) "Example target" - if (allocated(self%name)) then - write(unit, fmt) "- name", self%name - end if - if (allocated(self%source_dir)) then - if (self%source_dir /= "example" .or. pr > 2) then - write(unit, fmt) "- source directory", self%source_dir - end if - end if - if (allocated(self%main)) then - if (self%main /= "main.f90" .or. pr > 2) then - write(unit, fmt) "- example source", self%main - end if - end if - - if (allocated(self%dependency)) then - if (size(self%dependency) > 1 .or. pr > 2) then - write(unit, fmti) "- dependencies", size(self%dependency) - end if - do ii = 1, size(self%dependency) - call self%dependency(ii)%info(unit, pr - 1) - end do - end if - - end subroutine info - - -end module fpm_manifest_example diff --git a/fpm/src/fpm/manifest/executable.f90 b/fpm/src/fpm/manifest/executable.f90 deleted file mode 100644 index be02974..0000000 --- a/fpm/src/fpm/manifest/executable.f90 +++ /dev/null @@ -1,186 +0,0 @@ -!> Implementation of the meta data for an executables. -!> -!> An executable table can currently have the following fields -!> -!>```toml -!>[[ executable ]] -!>name = "string" -!>source-dir = "path" -!>main = "file" -!>link = ["lib"] -!>[executable.dependencies] -!>``` -module fpm_manifest_executable - use fpm_manifest_dependency, only : dependency_config_t, new_dependencies - use fpm_error, only : error_t, syntax_error - use fpm_strings, only : string_t - use fpm_toml, only : toml_table, toml_key, toml_stat, get_value - implicit none - private - - public :: executable_config_t, new_executable - - - !> Configuation meta data for an executable - type :: executable_config_t - - !> Name of the resulting executable - character(len=:), allocatable :: name - - !> Source directory for collecting the executable - character(len=:), allocatable :: source_dir - - !> Name of the source file declaring the main program - character(len=:), allocatable :: main - - !> Dependency meta data for this executable - type(dependency_config_t), allocatable :: dependency(:) - - !> Libraries to link against - type(string_t), allocatable :: link(:) - - contains - - !> Print information on this instance - procedure :: info - - end type executable_config_t - - -contains - - - !> Construct a new executable configuration from a TOML data structure - subroutine new_executable(self, table, error) - - !> Instance of the executable configuration - type(executable_config_t), intent(out) :: self - - !> Instance of the TOML data structure - type(toml_table), intent(inout) :: table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table), pointer :: child - - call check(table, error) - if (allocated(error)) return - - call get_value(table, "name", self%name) - if (.not.allocated(self%name)) then - call syntax_error(error, "Could not retrieve executable name") - return - end if - call get_value(table, "source-dir", self%source_dir, "app") - call get_value(table, "main", self%main, "main.f90") - - call get_value(table, "dependencies", child, requested=.false.) - if (associated(child)) then - call new_dependencies(self%dependency, child, error) - if (allocated(error)) return - end if - - call get_value(table, "link", self%link, error) - if (allocated(error)) return - - end subroutine new_executable - - - !> Check local schema for allowed entries - subroutine check(table, error) - - !> Instance of the TOML data structure - type(toml_table), intent(inout) :: table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_key), allocatable :: list(:) - logical :: name_present - integer :: ikey - - name_present = .false. - - call table%get_keys(list) - - if (size(list) < 1) then - call syntax_error(error, "Executable section does not provide sufficient entries") - return - end if - - do ikey = 1, size(list) - select case(list(ikey)%key) - case default - call syntax_error(error, "Key "//list(ikey)%key//" is not allowed as executable entry") - exit - - case("name") - name_present = .true. - - case("source-dir", "main", "dependencies", "link") - continue - - 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") - end if - - end subroutine check - - - !> Write information on instance - subroutine info(self, unit, verbosity) - - !> Instance of the executable configuration - class(executable_config_t), intent(in) :: self - - !> Unit for IO - integer, intent(in) :: unit - - !> Verbosity of the printout - integer, intent(in), optional :: verbosity - - integer :: pr, ii - character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)', & - & fmti = '("#", 1x, a, t30, i0)' - - if (present(verbosity)) then - pr = verbosity - else - pr = 1 - end if - - if (pr < 1) return - - write(unit, fmt) "Executable target" - if (allocated(self%name)) then - write(unit, fmt) "- name", self%name - end if - if (allocated(self%source_dir)) then - if (self%source_dir /= "app" .or. pr > 2) then - write(unit, fmt) "- source directory", self%source_dir - end if - end if - if (allocated(self%main)) then - if (self%main /= "main.f90" .or. pr > 2) then - write(unit, fmt) "- program source", self%main - end if - end if - - if (allocated(self%dependency)) then - if (size(self%dependency) > 1 .or. pr > 2) then - write(unit, fmti) "- dependencies", size(self%dependency) - end if - do ii = 1, size(self%dependency) - call self%dependency(ii)%info(unit, pr - 1) - end do - end if - - end subroutine info - - -end module fpm_manifest_executable diff --git a/fpm/src/fpm/manifest/install.f90 b/fpm/src/fpm/manifest/install.f90 deleted file mode 100644 index 6175873..0000000 --- a/fpm/src/fpm/manifest/install.f90 +++ /dev/null @@ -1,108 +0,0 @@ -!> Implementation of the installation configuration. -!> -!> An install table can currently have the following fields -!> -!>```toml -!>library = bool -!>``` -module fpm_manifest_install - use fpm_error, only : error_t, fatal_error, syntax_error - use fpm_toml, only : toml_table, toml_key, toml_stat, get_value - implicit none - private - - public :: install_config_t, new_install_config - - !> Configuration data for installation - type :: install_config_t - - !> Install library with this project - logical :: library - - contains - - !> Print information on this instance - procedure :: info - - end type install_config_t - -contains - - !> Create a new installation configuration from a TOML data structure - subroutine new_install_config(self, table, error) - - !> Instance of the install configuration - type(install_config_t), intent(out) :: self - - !> Instance of the TOML data structure - type(toml_table), intent(inout) :: table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - call check(table, error) - if (allocated(error)) return - - call get_value(table, "library", self%library, .false.) - - end subroutine new_install_config - - - !> Check local schema for allowed entries - subroutine check(table, error) - - !> Instance of the TOML data structure - type(toml_table), intent(inout) :: table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_key), allocatable :: list(:) - integer :: ikey - - call table%get_keys(list) - if (size(list) < 1) return - - do ikey = 1, size(list) - select case(list(ikey)%key) - case default - call syntax_error(error, "Key "//list(ikey)%key//" is not allowed in install table") - exit - case("library") - continue - end select - end do - if (allocated(error)) return - - end subroutine check - - !> Write information on install configuration instance - subroutine info(self, unit, verbosity) - - !> Instance of the build configuration - class(install_config_t), intent(in) :: self - - !> Unit for IO - integer, intent(in) :: unit - - !> Verbosity of the printout - integer, intent(in), optional :: verbosity - - integer :: pr - character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)' - - if (present(verbosity)) then - pr = verbosity - else - pr = 1 - end if - - if (pr < 1) return - - write(unit, fmt) "Install configuration" - write(unit, fmt) " - library install", & - & trim(merge("enabled ", "disabled", self%library)) - - end subroutine info - -end module fpm_manifest_install diff --git a/fpm/src/fpm/manifest/library.f90 b/fpm/src/fpm/manifest/library.f90 deleted file mode 100644 index c8ce049..0000000 --- a/fpm/src/fpm/manifest/library.f90 +++ /dev/null @@ -1,142 +0,0 @@ -!> Implementation of the meta data for libraries. -!> -!> A library table can currently have the following fields -!> -!>```toml -!>[library] -!>source-dir = "path" -!>include-dir = ["path1","path2"] -!>build-script = "file" -!>``` -module fpm_manifest_library - use fpm_error, only : error_t, syntax_error - use fpm_strings, only: string_t, string_cat - use fpm_toml, only : toml_table, toml_key, toml_stat, get_value - implicit none - private - - public :: library_config_t, new_library - - - !> Configuration meta data for a library - type :: library_config_t - - !> Source path prefix - character(len=:), allocatable :: source_dir - - !> Include path prefix - type(string_t), allocatable :: include_dir(:) - - !> Alternative build script to be invoked - character(len=:), allocatable :: build_script - - contains - - !> Print information on this instance - procedure :: info - - end type library_config_t - - -contains - - - !> Construct a new library configuration from a TOML data structure - subroutine new_library(self, table, error) - - !> Instance of the library configuration - type(library_config_t), intent(out) :: self - - !> Instance of the TOML data structure - type(toml_table), intent(inout) :: table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - call check(table, error) - if (allocated(error)) return - - call get_value(table, "source-dir", self%source_dir, "src") - call get_value(table, "build-script", self%build_script) - - call get_value(table, "include-dir", self%include_dir, error) - if (allocated(error)) return - - ! Set default value of include-dir if not found in manifest - if (.not.allocated(self%include_dir)) then - self%include_dir = [string_t("include")] - end if - - end subroutine new_library - - - !> Check local schema for allowed entries - subroutine check(table, error) - - !> Instance of the TOML data structure - type(toml_table), intent(inout) :: table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_key), allocatable :: list(:) - integer :: ikey - - call table%get_keys(list) - - ! table can be empty - if (size(list) < 1) return - - do ikey = 1, size(list) - select case(list(ikey)%key) - case default - call syntax_error(error, "Key "//list(ikey)%key//" is not allowed in library") - exit - - case("source-dir", "include-dir", "build-script") - continue - - end select - end do - - end subroutine check - - - !> Write information on instance - subroutine info(self, unit, verbosity) - - !> Instance of the library configuration - class(library_config_t), intent(in) :: self - - !> Unit for IO - integer, intent(in) :: unit - - !> Verbosity of the printout - integer, intent(in), optional :: verbosity - - integer :: pr - character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)' - - if (present(verbosity)) then - pr = verbosity - else - pr = 1 - end if - - if (pr < 1) return - - write(unit, fmt) "Library target" - if (allocated(self%source_dir)) then - write(unit, fmt) "- source directory", self%source_dir - end if - if (allocated(self%include_dir)) then - write(unit, fmt) "- include directory", string_cat(self%include_dir,",") - end if - if (allocated(self%build_script)) then - write(unit, fmt) "- custom build", self%build_script - end if - - end subroutine info - - -end module fpm_manifest_library diff --git a/fpm/src/fpm/manifest/package.f90 b/fpm/src/fpm/manifest/package.f90 deleted file mode 100644 index bbaa51d..0000000 --- a/fpm/src/fpm/manifest/package.f90 +++ /dev/null @@ -1,435 +0,0 @@ -!> Define the package data containing the meta data from the configuration file. -!> -!> The package data defines a Fortran type corresponding to the respective -!> TOML document, after creating it from a package file no more interaction -!> with the TOML document is required. -!> -!> Every configuration type provides it custom constructor (prefixed with `new_`) -!> and knows how to deserialize itself from a TOML document. -!> To ensure we find no untracked content in the package file all keywords are -!> checked and possible entries have to be explicitly allowed in the `check` -!> function. -!> If entries are mutally exclusive or interdependent inside the current table -!> the `check` function is required to enforce this schema on the data structure. -!> -!> The package file root allows the following keywords -!> -!>```toml -!>name = "string" -!>version = "string" -!>license = "string" -!>author = "string" -!>maintainer = "string" -!>copyright = "string" -!>[library] -!>[dependencies] -!>[dev-dependencies] -!>[build] -!>[install] -!>[[ executable ]] -!>[[ example ]] -!>[[ test ]] -!>``` -module fpm_manifest_package - use fpm_manifest_build, only: build_config_t, new_build_config - use fpm_manifest_dependency, only : dependency_config_t, new_dependencies - use fpm_manifest_example, only : example_config_t, new_example - use fpm_manifest_executable, only : executable_config_t, new_executable - use fpm_manifest_library, only : library_config_t, new_library - use fpm_manifest_install, only: install_config_t, new_install_config - use fpm_manifest_test, only : test_config_t, new_test - use fpm_error, only : error_t, fatal_error, syntax_error - use fpm_toml, only : toml_table, toml_array, toml_key, toml_stat, get_value, & - & len - use fpm_versioning, only : version_t, new_version - implicit none - private - - public :: package_config_t, new_package - - - interface unique_programs - module procedure :: unique_programs1 - module procedure :: unique_programs2 - end interface unique_programs - - - !> Package meta data - type :: package_config_t - - !> Name of the package - character(len=:), allocatable :: name - - !> Package version - type(version_t) :: version - - !> Build configuration data - type(build_config_t) :: build - - !> Installation configuration data - type(install_config_t) :: install - - !> Library meta data - type(library_config_t), allocatable :: library - - !> Executable meta data - type(executable_config_t), allocatable :: executable(:) - - !> Dependency meta data - type(dependency_config_t), allocatable :: dependency(:) - - !> Development dependency meta data - type(dependency_config_t), allocatable :: dev_dependency(:) - - !> Example meta data - type(example_config_t), allocatable :: example(:) - - !> Test meta data - type(test_config_t), allocatable :: test(:) - - contains - - !> Print information on this instance - procedure :: info - - end type package_config_t - - -contains - - - !> Construct a new package configuration from a TOML data structure - subroutine new_package(self, table, error) - - !> Instance of the package configuration - type(package_config_t), intent(out) :: self - - !> Instance of the TOML data structure - type(toml_table), intent(inout) :: table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - ! Backspace (8), tabulator (9), newline (10), formfeed (12) and carriage - ! return (13) are invalid in package names - character(len=*), parameter :: invalid_chars = & - achar(8) // achar(9) // achar(10) // achar(12) // achar(13) - type(toml_table), pointer :: child, node - type(toml_array), pointer :: children - character(len=:), allocatable :: version - integer :: ii, nn, stat - - call check(table, error) - if (allocated(error)) return - - call get_value(table, "name", self%name) - if (.not.allocated(self%name)) then - call syntax_error(error, "Could not retrieve package name") - return - end if - - if (len(self%name) <= 0) then - call syntax_error(error, "Package name must be a non-empty string") - return - end if - - ii = scan(self%name, invalid_chars) - if (ii > 0) then - call syntax_error(error, "Package name contains invalid characters") - return - end if - - call get_value(table, "build", child, requested=.true., stat=stat) - if (stat /= toml_stat%success) then - call fatal_error(error, "Type mismatch for build entry, must be a table") - return - end if - call new_build_config(self%build, child, error) - if (allocated(error)) return - - call get_value(table, "install", child, requested=.true., stat=stat) - if (stat /= toml_stat%success) then - call fatal_error(error, "Type mismatch for install entry, must be a table") - return - end if - call new_install_config(self%install, child, error) - if (allocated(error)) return - - call get_value(table, "version", version, "0") - call new_version(self%version, version, error) - if (allocated(error)) return - - call get_value(table, "dependencies", child, requested=.false.) - if (associated(child)) then - call new_dependencies(self%dependency, child, error) - if (allocated(error)) return - end if - - call get_value(table, "dev-dependencies", child, requested=.false.) - if (associated(child)) then - call new_dependencies(self%dev_dependency, child, error) - if (allocated(error)) return - end if - - call get_value(table, "library", child, requested=.false.) - if (associated(child)) then - allocate(self%library) - call new_library(self%library, child, error) - if (allocated(error)) return - end if - - call get_value(table, "executable", children, requested=.false.) - if (associated(children)) then - nn = len(children) - allocate(self%executable(nn)) - do ii = 1, nn - call get_value(children, ii, node, stat=stat) - if (stat /= toml_stat%success) then - call fatal_error(error, "Could not retrieve executable from array entry") - exit - end if - call new_executable(self%executable(ii), node, error) - if (allocated(error)) exit - end do - if (allocated(error)) return - - call unique_programs(self%executable, error) - if (allocated(error)) return - end if - - call get_value(table, "example", children, requested=.false.) - if (associated(children)) then - nn = len(children) - allocate(self%example(nn)) - do ii = 1, nn - call get_value(children, ii, node, stat=stat) - if (stat /= toml_stat%success) then - call fatal_error(error, "Could not retrieve example from array entry") - exit - end if - call new_example(self%example(ii), node, error) - if (allocated(error)) exit - end do - if (allocated(error)) return - - call unique_programs(self%example, error) - if (allocated(error)) return - - if (allocated(self%executable)) then - call unique_programs(self%executable, self%example, error) - if (allocated(error)) return - end if - end if - - call get_value(table, "test", children, requested=.false.) - if (associated(children)) then - nn = len(children) - allocate(self%test(nn)) - do ii = 1, nn - call get_value(children, ii, node, stat=stat) - if (stat /= toml_stat%success) then - call fatal_error(error, "Could not retrieve test from array entry") - exit - end if - call new_test(self%test(ii), node, error) - if (allocated(error)) exit - end do - if (allocated(error)) return - - call unique_programs(self%test, error) - if (allocated(error)) return - end if - - end subroutine new_package - - - !> Check local schema for allowed entries - subroutine check(table, error) - - !> Instance of the TOML data structure - type(toml_table), intent(inout) :: table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_key), allocatable :: list(:) - logical :: name_present - integer :: ikey - - name_present = .false. - - call table%get_keys(list) - - if (size(list) < 1) then - call syntax_error(error, "Package file is empty") - return - end if - - do ikey = 1, size(list) - select case(list(ikey)%key) - case default - call syntax_error(error, "Key "//list(ikey)%key//" is not allowed in package file") - exit - - case("name") - name_present = .true. - - case("version", "license", "author", "maintainer", "copyright", & - & "description", "keywords", "categories", "homepage", "build", & - & "dependencies", "dev-dependencies", "test", "executable", & - & "example", "library", "install") - continue - - end select - end do - if (allocated(error)) return - - if (.not.name_present) then - call syntax_error(error, "Package name is not provided, please add a name entry") - end if - - end subroutine check - - - !> Write information on instance - subroutine info(self, unit, verbosity) - - !> Instance of the package configuration - class(package_config_t), intent(in) :: self - - !> Unit for IO - integer, intent(in) :: unit - - !> Verbosity of the printout - integer, intent(in), optional :: verbosity - - integer :: pr, ii - character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)', & - & fmti = '("#", 1x, a, t30, i0)' - - if (present(verbosity)) then - pr = verbosity - else - pr = 1 - end if - - if (pr < 1) return - - write(unit, fmt) "Package" - if (allocated(self%name)) then - write(unit, fmt) "- name", self%name - end if - - call self%build%info(unit, pr - 1) - - call self%install%info(unit, pr - 1) - - if (allocated(self%library)) then - write(unit, fmt) "- target", "archive" - call self%library%info(unit, pr - 1) - end if - - if (allocated(self%executable)) then - if (size(self%executable) > 1 .or. pr > 2) then - write(unit, fmti) "- executables", size(self%executable) - end if - do ii = 1, size(self%executable) - call self%executable(ii)%info(unit, pr - 1) - end do - end if - - if (allocated(self%dependency)) then - if (size(self%dependency) > 1 .or. pr > 2) then - write(unit, fmti) "- dependencies", size(self%dependency) - end if - do ii = 1, size(self%dependency) - call self%dependency(ii)%info(unit, pr - 1) - end do - end if - - if (allocated(self%example)) then - if (size(self%example) > 1 .or. pr > 2) then - write(unit, fmti) "- examples", size(self%example) - end if - do ii = 1, size(self%example) - call self%example(ii)%info(unit, pr - 1) - end do - end if - - if (allocated(self%test)) then - if (size(self%test) > 1 .or. pr > 2) then - write(unit, fmti) "- tests", size(self%test) - end if - do ii = 1, size(self%test) - call self%test(ii)%info(unit, pr - 1) - end do - end if - - if (allocated(self%dev_dependency)) then - if (size(self%dev_dependency) > 1 .or. pr > 2) then - write(unit, fmti) "- development deps.", size(self%dev_dependency) - end if - do ii = 1, size(self%dev_dependency) - call self%dev_dependency(ii)%info(unit, pr - 1) - end do - end if - - end subroutine info - - - !> Check whether or not the names in a set of executables are unique - subroutine unique_programs1(executable, error) - - !> Array of executables - class(executable_config_t), intent(in) :: executable(:) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: i, j - - do i = 1, size(executable) - do j = 1, i - 1 - if (executable(i)%name == executable(j)%name) then - call fatal_error(error, "The program named '"//& - executable(j)%name//"' is duplicated. "//& - "Unique program names are required.") - exit - end if - end do - end do - if (allocated(error)) return - - end subroutine unique_programs1 - - - !> Check whether or not the names in a set of executables are unique - subroutine unique_programs2(executable_i, executable_j, error) - - !> Array of executables - class(executable_config_t), intent(in) :: executable_i(:) - - !> Array of executables - class(executable_config_t), intent(in) :: executable_j(:) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: i, j - - do i = 1, size(executable_i) - do j = 1, size(executable_j) - if (executable_i(i)%name == executable_j(j)%name) then - call fatal_error(error, "The program named '"//& - executable_j(j)%name//"' is duplicated. "//& - "Unique program names are required.") - exit - end if - end do - end do - if (allocated(error)) return - - end subroutine unique_programs2 - - -end module fpm_manifest_package diff --git a/fpm/src/fpm/manifest/test.f90 b/fpm/src/fpm/manifest/test.f90 deleted file mode 100644 index bcacbd8..0000000 --- a/fpm/src/fpm/manifest/test.f90 +++ /dev/null @@ -1,175 +0,0 @@ -!> Implementation of the meta data for a test. -!> -!> The test data structure is effectively a decorated version of an executable -!> and shares most of its properties, except for the defaults and can be -!> handled under most circumstances just like any other executable. -!> -!> A test table can currently have the following fields -!> -!>```toml -!>[[ test ]] -!>name = "string" -!>source-dir = "path" -!>main = "file" -!>link = ["lib"] -!>[test.dependencies] -!>``` -module fpm_manifest_test - use fpm_manifest_dependency, only : dependency_config_t, new_dependencies - use fpm_manifest_executable, only : executable_config_t - use fpm_error, only : error_t, syntax_error - use fpm_toml, only : toml_table, toml_key, toml_stat, get_value - implicit none - private - - public :: test_config_t, new_test - - - !> Configuation meta data for an test - type, extends(executable_config_t) :: test_config_t - - contains - - !> Print information on this instance - procedure :: info - - end type test_config_t - - -contains - - - !> Construct a new test configuration from a TOML data structure - subroutine new_test(self, table, error) - - !> Instance of the test configuration - type(test_config_t), intent(out) :: self - - !> Instance of the TOML data structure - type(toml_table), intent(inout) :: table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table), pointer :: child - - call check(table, error) - if (allocated(error)) return - - call get_value(table, "name", self%name) - if (.not.allocated(self%name)) then - call syntax_error(error, "Could not retrieve test name") - return - end if - call get_value(table, "source-dir", self%source_dir, "test") - call get_value(table, "main", self%main, "main.f90") - - call get_value(table, "dependencies", child, requested=.false.) - if (associated(child)) then - call new_dependencies(self%dependency, child, error) - if (allocated(error)) return - end if - - call get_value(table, "link", self%link, error) - if (allocated(error)) return - - end subroutine new_test - - - !> Check local schema for allowed entries - subroutine check(table, error) - - !> Instance of the TOML data structure - type(toml_table), intent(inout) :: table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_key), allocatable :: list(:) - logical :: name_present - integer :: ikey - - name_present = .false. - - call table%get_keys(list) - - if (size(list) < 1) then - call syntax_error(error, "Test section does not provide sufficient entries") - return - end if - - do ikey = 1, size(list) - select case(list(ikey)%key) - case default - call syntax_error(error, "Key "//list(ikey)%key//" is not allowed in test entry") - exit - - case("name") - name_present = .true. - - case("source-dir", "main", "dependencies", "link") - continue - - 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") - end if - - end subroutine check - - - !> Write information on instance - subroutine info(self, unit, verbosity) - - !> Instance of the test configuration - class(test_config_t), intent(in) :: self - - !> Unit for IO - integer, intent(in) :: unit - - !> Verbosity of the printout - integer, intent(in), optional :: verbosity - - integer :: pr, ii - character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)', & - & fmti = '("#", 1x, a, t30, i0)' - - if (present(verbosity)) then - pr = verbosity - else - pr = 1 - end if - - if (pr < 1) return - - write(unit, fmt) "Test target" - if (allocated(self%name)) then - write(unit, fmt) "- name", self%name - end if - if (allocated(self%source_dir)) then - if (self%source_dir /= "test" .or. pr > 2) then - write(unit, fmt) "- source directory", self%source_dir - end if - end if - if (allocated(self%main)) then - if (self%main /= "main.f90" .or. pr > 2) then - write(unit, fmt) "- test source", self%main - end if - end if - - if (allocated(self%dependency)) then - if (size(self%dependency) > 1 .or. pr > 2) then - write(unit, fmti) "- dependencies", size(self%dependency) - end if - do ii = 1, size(self%dependency) - call self%dependency(ii)%info(unit, pr - 1) - end do - end if - - end subroutine info - - -end module fpm_manifest_test diff --git a/fpm/src/fpm/toml.f90 b/fpm/src/fpm/toml.f90 deleted file mode 100644 index dbaafcb..0000000 --- a/fpm/src/fpm/toml.f90 +++ /dev/null @@ -1,120 +0,0 @@ -!># Interface to TOML processing library -!> -!> This module acts as a proxy to the `toml-f` public Fortran API and allows -!> to selectively expose components from the library to `fpm`. -!> The interaction with `toml-f` data types outside of this module should be -!> limited to tables, arrays and key-lists, most of the necessary interactions -!> are implemented in the building interface with the `get_value` and `set_value` -!> procedures. -!> -!> This module allows to implement features necessary for `fpm`, which are -!> not yet available in upstream `toml-f`. -!> -!> For more details on the library used see the -!> [TOML-Fortran](https://toml-f.github.io/toml-f) developer pages. -module fpm_toml - use fpm_error, only : error_t, fatal_error, file_not_found_error - use fpm_strings, only : string_t - use tomlf, only : toml_table, toml_array, toml_key, toml_stat, get_value, & - & set_value, toml_parse, toml_error, new_table, add_table, add_array, & - & toml_serializer, len - implicit none - private - - public :: read_package_file - public :: toml_table, toml_array, toml_key, toml_stat, get_value, set_value - public :: new_table, add_table, add_array, len - public :: toml_error, toml_serializer, toml_parse - - - interface get_value - module procedure :: get_child_value_string_list - end interface get_value - - -contains - - - !> Process the configuration file to a TOML data structure - subroutine read_package_file(table, manifest, error) - - !> TOML data structure - type(toml_table), allocatable, intent(out) :: table - - !> Name of the package configuration file - character(len=*), intent(in) :: manifest - - !> Error status of the operation - type(error_t), allocatable, intent(out) :: error - - type(toml_error), allocatable :: parse_error - integer :: unit - logical :: exist - - inquire(file=manifest, exist=exist) - - if (.not.exist) then - call file_not_found_error(error, manifest) - return - end if - - open(file=manifest, newunit=unit) - call toml_parse(table, unit, parse_error) - close(unit) - - if (allocated(parse_error)) then - allocate(error) - call move_alloc(parse_error%message, error%message) - return - end if - - end subroutine read_package_file - - - subroutine get_child_value_string_list(table, key, list, error) - - !> Instance of the TOML data structure - type(toml_table), intent(inout) :: table - - !> Key to read from - character(len=*), intent(in) :: key - - !> List of strings to read - type(string_t), allocatable, intent(out) :: list(:) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: stat, ilist, nlist - type(toml_array), pointer :: children - character(len=:), allocatable :: str - - call get_value(table, key, children, requested=.false.) - if (associated(children)) then - nlist = len(children) - allocate(list(nlist)) - do ilist = 1, nlist - call get_value(children, ilist, str, stat=stat) - if (stat /= toml_stat%success) then - call fatal_error(error, "Entry in "//key//" field cannot be read") - exit - end if - call move_alloc(str, list(ilist)%s) - end do - if (allocated(error)) return - else - call get_value(table, key, str, stat=stat) - if (stat /= toml_stat%success) then - call fatal_error(error, "Entry in "//key//" field cannot be read") - return - end if - if (allocated(str)) then - allocate(list(1)) - call move_alloc(str, list(1)%s) - end if - end if - - end subroutine get_child_value_string_list - - -end module fpm_toml diff --git a/fpm/src/fpm/versioning.f90 b/fpm/src/fpm/versioning.f90 deleted file mode 100644 index b24fc3c..0000000 --- a/fpm/src/fpm/versioning.f90 +++ /dev/null @@ -1,412 +0,0 @@ -!> Implementation of versioning data for comparing packages -module fpm_versioning - use fpm_error, only : error_t, syntax_error - implicit none - private - - public :: version_t, new_version, char - - - type :: version_t - private - - !> Version numbers found - integer, allocatable :: num(:) - - contains - - generic :: operator(==) => equals - procedure, private :: equals - - generic :: operator(/=) => not_equals - procedure, private :: not_equals - - generic :: operator(>) => greater - procedure, private :: greater - - generic :: operator(<) => less - procedure, private :: less - - generic :: operator(>=) => greater_equals - procedure, private :: greater_equals - - generic :: operator(<=) => less_equals - procedure, private :: less_equals - - !> Compare a version against a version constraint (x.x.0 <= v < x.x.HUGE) - generic :: operator(.match.) => match - procedure, private :: match - - !> Create a printable string from a version data type - procedure :: to_string - - end type version_t - - - !> Arbitrary internal limit of the version parser - integer, parameter :: max_limit = 3 - - - interface char - module procedure :: as_string - end interface char - - - interface new_version - module procedure :: new_version_from_string - module procedure :: new_version_from_int - end interface new_version - - -contains - - - !> Create a new version from a string - subroutine new_version_from_int(self, num) - - !> Instance of the versioning data - type(version_t), intent(out) :: self - - !> Subversion numbers to define version data - integer, intent(in) :: num(:) - - self%num = num - - end subroutine new_version_from_int - - - !> Create a new version from a string - subroutine new_version_from_string(self, string, error) - - !> Instance of the versioning data - type(version_t), intent(out) :: self - - !> String describing the version information - character(len=*), intent(in) :: string - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - character :: tok - integer :: ii, istart, iend, stat, nn - integer :: num(max_limit) - logical :: is_number - - nn = 0 - iend = 0 - istart = 0 - is_number = .false. - - do while(iend < len(string)) - call next(string, istart, iend, is_number, error) - if (allocated(error)) exit - if (is_number) then - if (nn >= max_limit) then - call token_error(error, string, istart, iend, & - & "Too many subversions found") - exit - end if - nn = nn + 1 - read(string(istart:iend), *, iostat=stat) num(nn) - if (stat /= 0) then - call token_error(error, string, istart, iend, & - & "Failed to parse version number") - exit - end if - end if - end do - if (allocated(error)) return - if (.not.is_number) then - call token_error(error, string, istart, iend, & - & "Expected version number, but no characters are left") - return - end if - - call new_version(self, num(:nn)) - - end subroutine new_version_from_string - - - !> Tokenize a version string - subroutine next(string, istart, iend, is_number, error) - - !> String describing the version information - character(len=*), intent(in) :: string - - !> Start of last token, start of next token on exit - integer, intent(inout) :: istart - - !> End of last token on entry, end of next token on exit - integer, intent(inout) :: iend - - !> Token produced is a number - logical, intent(inout) :: is_number - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: ii, nn - logical :: was_number - character :: tok, last - - was_number = is_number - nn = len(string) - - if (iend >= nn) then - istart = nn - iend = nn - return - end if - - ii = min(iend + 1, nn) - tok = string(ii:ii) - - is_number = tok /= '.' - if (is_number .eqv. was_number) then - call token_error(error, string, istart, ii, & - & "Unexpected token found") - return - end if - - if (.not.is_number) then - is_number = .false. - istart = ii - iend = ii - return - end if - - istart = ii - do ii = min(iend + 1, nn), nn - tok = string(ii:ii) - select case(tok) - case default - call token_error(error, string, istart, ii, & - & "Invalid character in version number") - exit - case('.') - exit - case('0', '1', '2', '3', '4', '5', '6', '7', '8', '9') - iend = ii - cycle - end select - end do - - end subroutine next - - - !> Create an error on an invalid token, provide some visual context as well - subroutine token_error(error, string, istart, iend, message) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - !> String describing the version information - character(len=*), intent(in) :: string - - !> Start of last token, start of next token on exit - integer, intent(in) :: istart - - !> End of last token on entry, end of next token on exit - integer, intent(in) :: iend - - !> Error message - character(len=*), intent(in) :: message - - character(len=*), parameter :: nl = new_line('a') - - allocate(error) - error%message = message // nl // " | " // string // nl // & - & " |" // repeat('-', istart) // repeat('^', iend - istart + 1) - - end subroutine token_error - - - subroutine to_string(self, string) - - !> Version number - class(version_t), intent(in) :: self - - !> Character representation of the version - character(len=:), allocatable, intent(out) :: string - - integer, parameter :: buffersize = 64 - character(len=buffersize) :: buffer - integer :: ii - - do ii = 1, size(self%num) - if (allocated(string)) then - write(buffer, '(".", i0)') self%num(ii) - string = string // trim(buffer) - else - write(buffer, '(i0)') self%num(ii) - string = trim(buffer) - end if - end do - - if (.not.allocated(string)) then - string = '0' - end if - - end subroutine to_string - - - function as_string(self) result(string) - - !> Version number - class(version_t), intent(in) :: self - - !> Character representation of the version - character(len=:), allocatable :: string - - call self%to_string(string) - - end function as_string - - - !> Check to version numbers for equality - elemental function equals(lhs, rhs) result(is_equal) - - !> First version number - class(version_t), intent(in) :: lhs - - !> Second version number - class(version_t), intent(in) :: rhs - - !> Version match - logical :: is_equal - - is_equal = .not.(lhs > rhs) - if (is_equal) then - is_equal = .not.(rhs > lhs) - end if - - end function equals - - - !> Check two versions for inequality - elemental function not_equals(lhs, rhs) result(not_equal) - - !> First version number - class(version_t), intent(in) :: lhs - - !> Second version number - class(version_t), intent(in) :: rhs - - !> Version mismatch - logical :: not_equal - - not_equal = lhs > rhs - if (.not.not_equal) then - not_equal = rhs > lhs - end if - - end function not_equals - - - !> Relative comparison of two versions - elemental function greater(lhs, rhs) result(is_greater) - - !> First version number - class(version_t), intent(in) :: lhs - - !> Second version number - class(version_t), intent(in) :: rhs - - !> First version is greater - logical :: is_greater - - integer :: ii - - do ii = 1, min(size(lhs%num), size(rhs%num)) - is_greater = lhs%num(ii) > rhs%num(ii) - if (is_greater) exit - end do - if (is_greater) return - - is_greater = size(lhs%num) > size(rhs%num) - if (is_greater) then - do ii = size(rhs%num) + 1, size(lhs%num) - is_greater = lhs%num(ii) > 0 - if (is_greater) exit - end do - end if - - end function greater - - - !> Relative comparison of two versions - elemental function less(lhs, rhs) result(is_less) - - !> First version number - class(version_t), intent(in) :: lhs - - !> Second version number - class(version_t), intent(in) :: rhs - - !> First version is less - logical :: is_less - - is_less = rhs > lhs - - end function less - - - !> Relative comparison of two versions - elemental function greater_equals(lhs, rhs) result(is_greater_equal) - - !> First version number - class(version_t), intent(in) :: lhs - - !> Second version number - class(version_t), intent(in) :: rhs - - !> First version is greater or equal - logical :: is_greater_equal - - is_greater_equal = .not. (rhs > lhs) - - end function greater_equals - - - !> Relative comparison of two versions - elemental function less_equals(lhs, rhs) result(is_less_equal) - - !> First version number - class(version_t), intent(in) :: lhs - - !> Second version number - class(version_t), intent(in) :: rhs - - !> First version is less or equal - logical :: is_less_equal - - is_less_equal = .not. (lhs > rhs) - - end function less_equals - - - !> Try to match first version against second version - elemental function match(lhs, rhs) - - !> First version number - class(version_t), intent(in) :: lhs - - !> Second version number - class(version_t), intent(in) :: rhs - - !> Version match following semantic versioning rules - logical :: match - - type(version_t) :: tmp - - match = .not.(rhs > lhs) - if (match) then - tmp%num = rhs%num - tmp%num(size(tmp%num)) = tmp%num(size(tmp%num)) + 1 - match = tmp > lhs - end if - - end function match - - -end module fpm_versioning diff --git a/fpm/src/fpm_backend.f90 b/fpm/src/fpm_backend.f90 deleted file mode 100644 index 74cef61..0000000 --- a/fpm/src/fpm_backend.f90 +++ /dev/null @@ -1,262 +0,0 @@ -!># Build backend -!> Uses a list of `[[build_target_ptr]]` and a valid `[[fpm_model]]` instance -!> to schedule and execute the compilation and linking of package targets. -!> -!> The package build process (`[[build_package]]`) comprises three steps: -!> -!> 1. __Target sorting:__ topological sort of the target dependency graph (`[[sort_target]]`) -!> 2. __Target scheduling:__ group targets into schedule regions based on the sorting (`[[schedule_targets]]`) -!> 3. __Target building:__ generate targets by compilation or linking -!> -!> @note If compiled with OpenMP, targets will be build in parallel where possible. -!> -!>### Incremental compilation -!> The backend process supports *incremental* compilation whereby targets are not -!> re-compiled if their corresponding dependencies have not been modified. -!> -!> - Source-based targets (*i.e.* objects) are not re-compiled if the corresponding source -!> file is unmodified AND all of the target dependencies are not marked for re-compilation -!> -!> - Link targets (*i.e.* executables and libraries) are not re-compiled if the -!> target output file already exists AND all of the target dependencies are not marked for -!> re-compilation -!> -!> Source file modification is determined by a file digest (hash) which is calculated during -!> the source parsing phase ([[fpm_source_parsing]]) and cached to disk after a target is -!> successfully generated. -!> -module fpm_backend - -use fpm_environment, only: run -use fpm_filesystem, only: dirname, join_path, exists, mkdir -use fpm_model, only: fpm_model_t -use fpm_targets, only: build_target_t, build_target_ptr, & - FPM_TARGET_OBJECT, FPM_TARGET_ARCHIVE, FPM_TARGET_EXECUTABLE - -use fpm_strings, only: string_cat - -implicit none - -private -public :: build_package, sort_target, schedule_targets - -contains - -!> Top-level routine to build package described by `model` -subroutine build_package(targets,model) - type(build_target_ptr), intent(inout) :: targets(:) - type(fpm_model_t), intent(in) :: model - - integer :: i, j - type(build_target_ptr), allocatable :: queue(:) - integer, allocatable :: schedule_ptr(:) - - ! Need to make output directory for include (mod) files - if (.not.exists(join_path(model%output_directory,model%package_name))) then - call mkdir(join_path(model%output_directory,model%package_name)) - end if - - ! Perform depth-first topological sort of targets - do i=1,size(targets) - - call sort_target(targets(i)%ptr) - - end do - - ! Construct build schedule queue - call schedule_targets(queue, schedule_ptr, targets) - - ! Loop over parallel schedule regions - do i=1,size(schedule_ptr)-1 - - ! Build targets in schedule region i - !$omp parallel do default(shared) schedule(dynamic,1) - do j=schedule_ptr(i),(schedule_ptr(i+1)-1) - - call build_target(model,queue(j)%ptr) - - end do - - end do - -end subroutine build_package - - -!> Topologically sort a target for scheduling by -!> recursing over its dependencies. -!> -!> Checks disk-cached source hashes to determine if objects are -!> up-to-date. Up-to-date sources are tagged as skipped. -!> -!> On completion, `target` should either be marked as -!> sorted (`target%sorted=.true.`) or skipped (`target%skip=.true.`) -!> -!> If `target` is marked as sorted, `target%schedule` should be an -!> integer greater than zero indicating the region for scheduling -!> -recursive subroutine sort_target(target) - type(build_target_t), intent(inout), target :: target - - integer :: i, j, fh, stat - type(build_target_t), pointer :: exe_obj - - ! Check if target has already been processed (as a dependency) - if (target%sorted .or. target%skip) then - return - end if - - ! Check for a circular dependency - ! (If target has been touched but not processed) - if (target%touched) then - write(*,*) '(!) Circular dependency found with: ',target%output_file - stop - else - target%touched = .true. ! Set touched flag - end if - - ! Load cached source file digest if present - if (.not.allocated(target%digest_cached) .and. & - exists(target%output_file) .and. & - exists(target%output_file//'.digest')) then - - allocate(target%digest_cached) - open(newunit=fh,file=target%output_file//'.digest',status='old') - read(fh,*,iostat=stat) target%digest_cached - close(fh) - - if (stat /= 0) then ! Cached digest is not recognized - deallocate(target%digest_cached) - end if - - end if - - if (allocated(target%source)) then - - ! Skip if target is source-based and source file is unmodified - if (allocated(target%digest_cached)) then - if (target%digest_cached == target%source%digest) target%skip = .true. - end if - - elseif (exists(target%output_file)) then - - ! Skip if target is not source-based and already exists - target%skip = .true. - - end if - - ! Loop over target dependencies - target%schedule = 1 - do i=1,size(target%dependencies) - - ! Sort dependency - call sort_target(target%dependencies(i)%ptr) - - if (.not.target%dependencies(i)%ptr%skip) then - - ! Can't skip target if any dependency is not skipped - target%skip = .false. - - ! Set target schedule after all of its dependencies - target%schedule = max(target%schedule,target%dependencies(i)%ptr%schedule+1) - - end if - - end do - - ! Mark flag as processed: either sorted or skipped - target%sorted = .not.target%skip - -end subroutine sort_target - - -!> Construct a build schedule from the sorted targets. -!> -!> The schedule is broken into regions, described by `schedule_ptr`, -!> where targets in each region can be compiled in parallel. -!> -subroutine schedule_targets(queue, schedule_ptr, targets) - type(build_target_ptr), allocatable, intent(out) :: queue(:) - integer, allocatable :: schedule_ptr(:) - type(build_target_ptr), intent(in) :: targets(:) - - integer :: i, j - integer :: n_schedule, n_sorted - - n_schedule = 0 ! Number of schedule regions - n_sorted = 0 ! Total number of targets to build - do i=1,size(targets) - - if (targets(i)%ptr%sorted) then - n_sorted = n_sorted + 1 - end if - n_schedule = max(n_schedule, targets(i)%ptr%schedule) - - end do - - allocate(queue(n_sorted)) - allocate(schedule_ptr(n_schedule+1)) - - ! Construct the target queue and schedule region pointer - n_sorted = 1 - schedule_ptr(n_sorted) = 1 - do i=1,n_schedule - - do j=1,size(targets) - - if (targets(j)%ptr%sorted) then - if (targets(j)%ptr%schedule == i) then - - queue(n_sorted)%ptr => targets(j)%ptr - n_sorted = n_sorted + 1 - end if - end if - - end do - - schedule_ptr(i+1) = n_sorted - - end do - -end subroutine schedule_targets - - -!> Call compile/link command for a single target. -!> -!> If successful, also caches the source file digest to disk. -!> -subroutine build_target(model,target) - type(fpm_model_t), intent(in) :: model - type(build_target_t), intent(in), target :: target - - integer :: ilib, fh - character(:), allocatable :: link_flags - - if (.not.exists(dirname(target%output_file))) then - call mkdir(dirname(target%output_file)) - end if - - select case(target%target_type) - - case (FPM_TARGET_OBJECT) - call run(model%fortran_compiler//" -c " // target%source%file_name // target%compile_flags & - // " -o " // target%output_file) - - case (FPM_TARGET_EXECUTABLE) - - call run(model%fortran_compiler// " " // target%compile_flags & - //" "//target%link_flags// " -o " // target%output_file) - - case (FPM_TARGET_ARCHIVE) - call run("ar -rs " // target%output_file // " " // string_cat(target%link_objects," ")) - - end select - - if (allocated(target%source)) then - open(newunit=fh,file=target%output_file//'.digest',status='unknown') - write(fh,*) target%source%digest - close(fh) - end if - -end subroutine build_target - -end module fpm_backend diff --git a/fpm/src/fpm_command_line.f90 b/fpm/src/fpm_command_line.f90 deleted file mode 100644 index 9e9a572..0000000 --- a/fpm/src/fpm_command_line.f90 +++ /dev/null @@ -1,1140 +0,0 @@ -!># Definition of the command line interface -!> -!> This module uses [M_CLI2](https://github.com/urbanjost/M_CLI2) to define -!> the command line interface. -!> To define a command line interface create a new command settings type -!> from the [[fpm_cmd_settings]] base class or the respective parent command -!> settings. -!> -!> The subcommand is selected by the first non-option argument in the command -!> line. In the subcase block the actual command line is defined and transferred -!> to an instance of the [[fpm_cmd_settings]], the actual type is used by the -!> *fpm* main program to determine which command entry point is chosen. -!> -!> To add a new subcommand add a new case to select construct and specify the -!> wanted command line and the expected default values. -!> Some of the following points also apply if you add a new option or argument -!> to an existing *fpm* subcommand. -!> At this point you should create a help page for the new command in a simple -!> catman-like format as well in the ``set_help`` procedure. -!> Make sure to register new subcommands in the ``fpm-manual`` command by adding -!> them to the manual character array and in the help/manual case as well. -!> You should add the new command to the synopsis section of the ``fpm-list``, -!> ``fpm-help`` and ``fpm --list`` help pages below to make sure the help output -!> is complete and consistent as well. -module fpm_command_line -use fpm_environment, only : get_os_type, get_env, & - OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_WINDOWS, & - OS_CYGWIN, OS_SOLARIS, OS_FREEBSD -use M_CLI2, only : set_args, lget, sget, unnamed, remaining, specified -use fpm_strings, only : lower, split, fnv_1a -use fpm_filesystem, only : basename, canon_path, to_fortran_name -use fpm_compiler, only : get_default_compile_flags -use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, & - & stdout=>output_unit, & - & stderr=>error_unit -implicit none - -private -public :: fpm_cmd_settings, & - fpm_build_settings, & - fpm_install_settings, & - fpm_new_settings, & - fpm_run_settings, & - fpm_test_settings, & - fpm_update_settings, & - get_command_line_settings - -type, abstract :: fpm_cmd_settings - logical :: verbose=.true. -end type - -integer,parameter :: ibug=4096 -type, extends(fpm_cmd_settings) :: fpm_new_settings - character(len=:),allocatable :: name - logical :: with_executable=.false. - logical :: with_test=.false. - logical :: with_lib=.true. - logical :: with_example=.false. - logical :: with_full=.false. - logical :: with_bare=.false. - logical :: backfill=.true. -end type - -type, extends(fpm_cmd_settings) :: fpm_build_settings - logical :: list=.false. - logical :: show_model=.false. - character(len=:),allocatable :: compiler - character(len=:),allocatable :: profile - character(len=:),allocatable :: build_name - character(len=:),allocatable :: flag -end type - -type, extends(fpm_build_settings) :: fpm_run_settings - character(len=ibug),allocatable :: name(:) - character(len=:),allocatable :: args - character(len=:),allocatable :: runner - logical :: example -end type - -type, extends(fpm_run_settings) :: fpm_test_settings -end type - -type, extends(fpm_build_settings) :: fpm_install_settings - character(len=:), allocatable :: prefix - character(len=:), allocatable :: bindir - character(len=:), allocatable :: libdir - character(len=:), allocatable :: includedir - logical :: no_rebuild -end type - -!> Settings for interacting and updating with project dependencies -type, extends(fpm_cmd_settings) :: fpm_update_settings - character(len=ibug),allocatable :: name(:) - logical :: fetch_only - logical :: clean -end type - -character(len=:),allocatable :: name -character(len=:),allocatable :: os_type -character(len=ibug),allocatable :: names(:) -character(len=:),allocatable :: tnames(:) - -character(len=:), allocatable :: version_text(:) -character(len=:), allocatable :: help_new(:), help_fpm(:), help_run(:), & - & help_test(:), help_build(:), help_usage(:), help_runner(:), & - & help_text(:), help_install(:), help_help(:), help_update(:), & - & help_list(:), help_list_dash(:), help_list_nodash(:) -character(len=20),parameter :: manual(*)=[ character(len=20) ::& -& ' ', 'fpm', 'new', 'build', 'run', & -& 'test', 'runner', 'install', 'update', 'list', 'help', 'version' ] - -character(len=:), allocatable :: val_runner, val_build, val_compiler, val_flag, val_profile - -contains - subroutine get_command_line_settings(cmd_settings) - class(fpm_cmd_settings), allocatable, intent(out) :: cmd_settings - - character(len=4096) :: cmdarg - integer :: i - integer :: widest - type(fpm_install_settings), allocatable :: install_settings - - call set_help() - ! text for --version switch, - select case (get_os_type()) - case (OS_LINUX); os_type = "OS Type: Linux" - case (OS_MACOS); os_type = "OS Type: macOS" - case (OS_WINDOWS); os_type = "OS Type: Windows" - case (OS_CYGWIN); os_type = "OS Type: Cygwin" - case (OS_SOLARIS); os_type = "OS Type: Solaris" - case (OS_FREEBSD); os_type = "OS Type: FreeBSD" - case (OS_UNKNOWN); os_type = "OS Type: Unknown" - case default ; os_type = "OS Type: UNKNOWN" - end select - version_text = [character(len=80) :: & - & 'Version: 0.2.0, alpha', & - & 'Program: fpm(1)', & - & 'Description: A Fortran package manager and build system', & - & 'Home Page: https://github.com/fortran-lang/fpm', & - & 'License: MIT', & - & os_type] - ! find the subcommand name by looking for first word on command - ! not starting with dash - cmdarg=' ' - do i = 1, command_argument_count() - call get_command_argument(i, cmdarg) - if(adjustl(cmdarg(1:1)) .ne. '-')exit - enddo - - ! now set subcommand-specific help text and process commandline - ! arguments. Then call subcommand routine - select case(trim(cmdarg)) - - case('run') - call set_args('& - & --target " " & - & --list F & - & --all F & - & --profile " "& - & --example F& - & --runner " " & - & --compiler "'//get_env('FPM_COMPILER','gfortran')//'" & - & --flag:: " "& - & --verbose F& - & --',help_run,version_text) - - call check_build_vals() - - if( size(unnamed) .gt. 1 )then - names=unnamed(2:) - else - names=[character(len=len(names)) :: ] - endif - - - if(specified('target') )then - call split(sget('target'),tnames,delimiters=' ,:') - names=[character(len=max(len(names),len(tnames))) :: names,tnames] - endif - - ! convert --all to '*' - if(lget('all'))then - names=[character(len=max(len(names),1)) :: names,'*' ] - endif - - ! convert special string '..' to equivalent (shorter) '*' - ! to allow for a string that does not require shift-key and quoting - do i=1,size(names) - if(names(i).eq.'..')names(i)='*' - enddo - - allocate(fpm_run_settings :: cmd_settings) - val_runner=sget('runner') - if(specified('runner') .and. val_runner.eq.'')val_runner='echo' - cmd_settings=fpm_run_settings(& - & args=remaining,& - & build_name=val_build,& - & profile=val_profile,& - & compiler=val_compiler, & - & flag=val_flag, & - & example=lget('example'), & - & list=lget('list'),& - & name=names,& - & runner=val_runner,& - & verbose=lget('verbose') ) - - case('build') - call set_args( '& - & --profile " " & - & --list F & - & --show-model F & - & --compiler "'//get_env('FPM_COMPILER','gfortran')//'" & - & --flag:: " "& - & --verbose F& - & --',help_build,version_text) - - call check_build_vals() - - allocate( fpm_build_settings :: cmd_settings ) - cmd_settings=fpm_build_settings( & - & build_name=val_build,& - & profile=val_profile,& - & compiler=val_compiler, & - & flag=val_flag, & - & list=lget('list'),& - & show_model=lget('show-model'),& - & verbose=lget('verbose') ) - - case('new') - call set_args('& - & --src F & - & --lib F & - & --app F & - & --test F & - & --example F & - & --backfill F & - & --full F & - & --bare F & - & --verbose:V F',& - & help_new, version_text) - select case(size(unnamed)) - case(1) - write(stderr,'(*(g0,/))')' directory name required' - write(stderr,'(*(7x,g0,/))') & - & ' fpm new NAME [[--lib|--src] [--app] [--test] [--example]]|[--full|--bare] [--backfill]' - stop 1 - case(2) - name=trim(unnamed(2)) - case default - write(stderr,'(g0)')' only one directory name allowed' - write(stderr,'(7x,g0)') & - & ' fpm new NAME [[--lib|--src] [--app] [--test] [--example]]| [--full|--bare] [--backfill]' - stop 2 - end select - !*! canon_path is not converting ".", etc. - name=canon_path(name) - if( .not.is_fortran_name(to_fortran_name(basename(name))) )then - write(stderr,'(g0)') [ character(len=72) :: & - & ' the fpm project name must be made of up to 63 ASCII letters,', & - & ' numbers, underscores, or hyphens, and start with a letter.'] - stop 4 - endif - - allocate(fpm_new_settings :: cmd_settings) - if (any( specified([character(len=10) :: 'src','lib','app','test','example','bare'])) & - & .and.lget('full') )then - write(stderr,'(*(a))')& - &' --full and any of [--src|--lib,--app,--test,--example,--bare]', & - &' are mutually exclusive.' - stop 5 - elseif (any( specified([character(len=10) :: 'src','lib','app','test','example','full'])) & - & .and.lget('bare') )then - write(stderr,'(*(a))')& - &' --bare and any of [--src|--lib,--app,--test,--example,--full]', & - &' are mutually exclusive.' - stop 3 - elseif (any( specified([character(len=10) :: 'src','lib','app','test','example']) ) )then - cmd_settings=fpm_new_settings(& - & backfill=lget('backfill'), & - & name=name, & - & with_executable=lget('app'), & - & with_lib=any([lget('lib'),lget('src')]), & - & with_test=lget('test'), & - & with_example=lget('example'), & - & verbose=lget('verbose') ) - else ! default if no specific directories are requested - cmd_settings=fpm_new_settings(& - & backfill=lget('backfill') , & - & name=name, & - & with_executable=.true., & - & with_lib=.true., & - & with_test=.true., & - & with_example=lget('full'), & - & with_full=lget('full'), & - & with_bare=lget('bare'), & - & verbose=lget('verbose') ) - endif - - case('help','manual') - call set_args('& - & --verbose F & - & ',help_help,version_text) - if(size(unnamed).lt.2)then - if(unnamed(1).eq.'help')then - unnamed=[' ', 'fpm'] - else - unnamed=manual - endif - elseif(unnamed(2).eq.'manual')then - unnamed=manual - endif - widest=256 - allocate(character(len=widest) :: help_text(0)) - do i=2,size(unnamed) - select case(unnamed(i)) - case(' ' ) - case('fpm ' ) - help_text=[character(len=widest) :: help_text, help_fpm] - case('new ' ) - help_text=[character(len=widest) :: help_text, help_new] - case('build ' ) - help_text=[character(len=widest) :: help_text, help_build] - case('install' ) - help_text=[character(len=widest) :: help_text, help_install] - case('run ' ) - help_text=[character(len=widest) :: help_text, help_run] - case('test ' ) - help_text=[character(len=widest) :: help_text, help_test] - case('runner' ) - help_text=[character(len=widest) :: help_text, help_runner] - case('list ' ) - help_text=[character(len=widest) :: help_text, help_list] - case('update ' ) - help_text=[character(len=widest) :: help_text, help_update] - case('help ' ) - help_text=[character(len=widest) :: help_text, help_help] - case('version' ) - help_text=[character(len=widest) :: help_text, version_text] - case default - help_text=[character(len=widest) :: help_text, & - & ' unknown help topic "'//trim(unnamed(i))//'"'] - !!& ' unknown help topic "'//trim(unnamed(i)).'not found in:',manual] - end select - enddo - call printhelp(help_text) - - case('install') - call set_args('--profile " " --no-rebuild F --verbose F --prefix " " & - & --list F & - & --compiler "'//get_env('FPM_COMPILER','gfortran')//'" & - & --flag:: " "& - & --libdir "lib" --bindir "bin" --includedir "include"', & - help_install, version_text) - - call check_build_vals() - - allocate(install_settings) - install_settings = fpm_install_settings(& - list=lget('list'), & - build_name=val_build, & - profile=val_profile,& - compiler=val_compiler, & - flag=val_flag, & - no_rebuild=lget('no-rebuild'), & - verbose=lget('verbose')) - call get_char_arg(install_settings%prefix, 'prefix') - call get_char_arg(install_settings%libdir, 'libdir') - call get_char_arg(install_settings%bindir, 'bindir') - call get_char_arg(install_settings%includedir, 'includedir') - call move_alloc(install_settings, cmd_settings) - - case('list') - call set_args('& - & --list F& - & --verbose F& - &', help_list, version_text) - call printhelp(help_list_nodash) - if(lget('list'))then - call printhelp(help_list_dash) - endif - case('test') - call set_args('& - & --target " " & - & --list F& - & --profile " "& - & --runner " " & - & --compiler "'//get_env('FPM_COMPILER','gfortran')//'" & - & --flag:: " "& - & --verbose F& - & --',help_test,version_text) - - call check_build_vals() - - if( size(unnamed) .gt. 1 )then - names=unnamed(2:) - else - names=[character(len=len(names)) :: ] - endif - - if(specified('target') )then - call split(sget('target'),tnames,delimiters=' ,:') - names=[character(len=max(len(names),len(tnames))) :: names,tnames] - endif - - ! convert special string '..' to equivalent (shorter) '*' - ! to allow for a string that does not require shift-key and quoting - do i=1,size(names) - if(names(i).eq.'..')names(i)='*' - enddo - - allocate(fpm_test_settings :: cmd_settings) - val_runner=sget('runner') - if(specified('runner') .and. val_runner.eq.'')val_runner='echo' - cmd_settings=fpm_test_settings(& - & args=remaining, & - & build_name=val_build, & - & profile=val_profile, & - & compiler=val_compiler, & - & flag=val_flag, & - & example=.false., & - & list=lget('list'), & - & name=names, & - & runner=val_runner, & - & verbose=lget('verbose') ) - - case('update') - call set_args('--fetch-only F --verbose F --clean F', & - help_update, version_text) - - if( size(unnamed) .gt. 1 )then - names=unnamed(2:) - else - names=[character(len=len(names)) :: ] - endif - - allocate(fpm_update_settings :: cmd_settings) - cmd_settings=fpm_update_settings(name=names, & - fetch_only=lget('fetch-only'), verbose=lget('verbose'), & - clean=lget('clean')) - - case default - - call set_args('& - & --list F& - & --verbose F& - &', help_fpm, version_text) - ! Note: will not get here if --version or --usage or --help - ! is present on commandline - help_text=help_usage - if(lget('list'))then - help_text=help_list_dash - elseif(len_trim(cmdarg).eq.0)then - write(stdout,'(*(a))')'Fortran Package Manager:' - write(stdout,'(*(a))')' ' - call printhelp(help_list_nodash) - else - write(stderr,'(*(a))')' unknown subcommand [', & - & trim(cmdarg), ']' - call printhelp(help_list_dash) - endif - call printhelp(help_text) - - end select - contains - - subroutine check_build_vals() - character(len=:), allocatable :: flags - - val_compiler=sget('compiler') - if(val_compiler.eq.'') then - val_compiler='gfortran' - endif - - val_flag = " " // sget('flag') - val_profile = sget('profile') - if (val_flag == '') then - call get_default_compile_flags(val_compiler, val_profile == "release", val_flag) - else - select case(val_profile) - case("release", "debug") - call get_default_compile_flags(val_compiler, val_profile == "release", flags) - val_flag = flags // val_flag - end select - end if - allocate(character(len=16) :: val_build) - write(val_build, '(z16.16)') fnv_1a(val_flag) - - end subroutine check_build_vals - - subroutine printhelp(lines) - character(len=:),intent(in),allocatable :: lines(:) - integer :: iii,ii - if(allocated(lines))then - ii=size(lines) - if(ii .gt. 0 .and. len(lines).gt. 0) then - write(stdout,'(g0)')(trim(lines(iii)), iii=1, ii) - else - write(stdout,'(a)')' *printhelp* output requested is empty' - endif - endif - end subroutine printhelp - - end subroutine get_command_line_settings - - function is_fortran_name(line) result (lout) - ! determine if a string is a valid Fortran name ignoring trailing spaces - ! (but not leading spaces) - character(len=*),parameter :: int='0123456789' - character(len=*),parameter :: lower='abcdefghijklmnopqrstuvwxyz' - character(len=*),parameter :: upper='ABCDEFGHIJKLMNOPQRSTUVWXYZ' - character(len=*),parameter :: allowed=upper//lower//int//'_' - character(len=*),intent(in) :: line - character(len=:),allocatable :: name - logical :: lout - name=trim(line) - if(len(name).ne.0)then - lout = .true. & - & .and. verify(name(1:1), lower//upper) == 0 & - & .and. verify(name,allowed) == 0 & - & .and. len(name) <= 63 - else - lout = .false. - endif - end function is_fortran_name - - subroutine set_help() - help_list_nodash=[character(len=80) :: & - 'USAGE: fpm [ SUBCOMMAND [SUBCOMMAND_OPTIONS] ]|[--list|--help|--version]', & - ' where SUBCOMMAND is commonly new|build|run|test ', & - ' ', & - ' subcommand may be one of ', & - ' ', & - ' build Compile the package placing results in the "build" directory', & - ' help Display help ', & - ' list Display this list of subcommand descriptions ', & - ' new Create a new Fortran package directory with sample files ', & - ' run Run the local package application programs ', & - ' test Run the test programs ', & - ' update Update and manage project dependencies ', & - ' install Install project ', & - ' ', & - ' Enter "fpm --list" for a brief list of subcommand options. Enter ', & - ' "fpm --help" or "fpm SUBCOMMAND --help" for detailed descriptions. ', & - ' '] - help_list_dash = [character(len=80) :: & - ' ', & - ' build [--compiler COMPILER_NAME] [--profile PROF] [--flag FFLAGS] [--list] ', & - ' help [NAME(s)] ', & - ' new NAME [[--lib|--src] [--app] [--test] [--example]]| ', & - ' [--full|--bare][--backfill] ', & - ' update [NAME(s)] [--fetch-only] [--clean] [--verbose] ', & - ' list [--list] ', & - ' run [[--target] NAME(s) [--example] [--profile PROF] [--flag FFLAGS] [--all] ', & - ' [--runner "CMD"] [--compiler COMPILER_NAME] [--list] [-- ARGS] ', & - ' test [[--target] NAME(s)] [--profile PROF] [--flag FFLAGS] [--runner "CMD"] [--list]', & - ' [--compiler COMPILER_NAME] [-- ARGS] ', & - ' install [--profile PROF] [--flag FFLAGS] [--no-rebuild] [--prefix PATH] [options] ', & - ' '] - help_usage=[character(len=80) :: & - '' ] - help_runner=[character(len=80) :: & - 'NAME ', & - ' --runner(1) - a shared option for specifying an application to launch ', & - ' executables. ', & - ' ', & - 'SYNOPSIS ', & - ' fpm run|test --runner CMD ... -- SUFFIX_OPTIONS ', & - ' ', & - 'DESCRIPTION ', & - ' The --runner option allows specifying a program to launch ', & - ' executables selected via the fpm(1) subcommands "run" and "test". This ', & - ' gives easy recourse to utilities such as debuggers and other tools ', & - ' that wrap other executables. ', & - ' ', & - ' These external commands are not part of fpm(1) itself as they vary ', & - ' from platform to platform or require independent installation. ', & - ' ', & - 'OPTION ', & - ' --runner ''CMD'' quoted command used to launch the fpm(1) executables. ', & - ' Available for both the "run" and "test" subcommands. ', & - ' If the keyword is specified without a value the default command ', & - ' is "echo". ', & - ' -- SUFFIX_OPTIONS additional options to suffix the command CMD and executable ', & - ' file names with. ', & - 'EXAMPLES ', & - ' Use cases for ''fpm run|test --runner "CMD"'' include employing ', & - ' the following common GNU/Linux and Unix commands: ', & - ' ', & - ' INTERROGATE ', & - ' + nm - list symbols from object files ', & - ' + size - list section sizes and total size. ', & - ' + ldd - print shared object dependencies ', & - ' + ls - list directory contents ', & - ' + stat - display file or file system status ', & - ' + file - determine file type ', & - ' PERFORMANCE AND DEBUGGING ', & - ' + gdb - The GNU Debugger ', & - ' + valgrind - a suite of tools for debugging and profiling ', & - ' + time - time a simple command or give resource usage ', & - ' + timeout - run a command with a time limit ', & - ' COPY ', & - ' + install - copy files and set attributes ', & - ' + tar - an archiving utility ', & - ' ALTER ', & - ' + rm - remove files or directories ', & - ' + chmod - change permissions of a file ', & - ' + strip - remove unnecessary information from strippable files ', & - ' ', & - ' For example ', & - ' ', & - ' fpm test --runner gdb ', & - ' fpm run --runner "tar cvfz $HOME/bundle.tgz" ', & - ' fpm run --runner ldd ', & - ' fpm run --runner strip ', & - ' fpm run --runner ''cp -t /usr/local/bin'' ', & - ' ', & - ' # options after executable name can be specified after the -- option ', & - ' fpm --runner cp run -- /usr/local/bin/ ', & - ' # generates commands of the form "cp $FILENAME /usr/local/bin/" ', & - ' ', & - ' # bash(1) alias example: ', & - ' alias fpm-install=\ ', & - ' "fpm run --profile release --runner ''install -vbp -m 0711 -t ~/.local/bin''" ', & - ' fpm-install ', & - '' ] - help_fpm=[character(len=80) :: & - 'NAME ', & - ' fpm(1) - A Fortran package manager and build system ', & - ' ', & - 'SYNOPSIS ', & - ' fpm SUBCOMMAND [SUBCOMMAND_OPTIONS] ', & - ' ', & - ' fpm --help|--version|--list ', & - ' ', & - 'DESCRIPTION ', & - ' fpm(1) is a package manager that helps you create Fortran projects ', & - ' from source -- it automatically determines dependencies! ', & - ' ', & - ' Most significantly fpm(1) lets you draw upon other fpm(1) packages ', & - ' in distributed git(1) repositories as if the packages were a basic ', & - ' part of your default programming environment, as well as letting ', & - ' you share your projects with others in a similar manner. ', & - ' ', & - ' All output goes into the directory "build/" which can generally be ', & - ' removed and rebuilt if required. Note that if external packages are ', & - ' being used you need network connectivity to rebuild from scratch. ', & - ' ', & - 'SUBCOMMANDS ', & - ' Valid fpm(1) subcommands are: ', & - ' ', & - ' + build Compile the packages into the "build/" directory. ', & - ' + new Create a new Fortran package directory with sample files. ', & - ' + update Update the project dependencies. ', & - ' + run Run the local package binaries. defaults to all binaries for ', & - ' that release. ', & - ' + test Run the tests. ', & - ' + help Alternate method for displaying subcommand help. ', & - ' + list Display brief descriptions of all subcommands. ', & - ' + install Install project ', & - ' ', & - ' Their syntax is ', & - ' ', & - ' build [--profile PROF] [--flag FFLAGS] [--list] [--compiler COMPILER_NAME]', & - ' new NAME [[--lib|--src] [--app] [--test] [--example]]| ', & - ' [--full|--bare][--backfill] ', & - ' update [NAME(s)] [--fetch-only] [--clean] ', & - ' run [[--target] NAME(s)] [--profile PROF] [--flag FFLAGS] [--list] [--example]', & - ' [--all] [--runner "CMD"] [--compiler COMPILER_NAME] [-- ARGS] ', & - ' test [[--target] NAME(s)] [--profile PROF] [--flag FFLAGS] [--list] ', & - ' [--runner "CMD"] [--compiler COMPILER_NAME] [-- ARGS] ', & - ' help [NAME(s)] ', & - ' list [--list] ', & - ' install [--profile PROF] [--flag FFLAGS] [--no-rebuild] [--prefix PATH] [options]', & - ' ', & - 'SUBCOMMAND OPTIONS ', & - ' --profile PROF selects the compilation profile for the build.',& - ' Currently available profiles are "release" for',& - ' high optimization and "debug" for full debug options.',& - ' If --flag is not specified the "debug" flags are the',& - ' default. ',& - ' --flag FFLAGS selects compile arguments for the build. These are',& - ' added to the profile options if --profile is specified,',& - ' else these options override the defaults.',& - ' Note object and .mod directory locations are always',& - ' built in.',& - ' --list List candidates instead of building or running them. On ', & - ' the fpm(1) command this shows a brief list of subcommands.', & - ' --runner CMD Provides a command to prefix program execution paths. ', & - ' --compiler COMPILER_NAME Compiler name. The environment variable ', & - ' FPM_COMPILER sets the default. ', & - ' -- ARGS Arguments to pass to executables. ', & - ' ', & - 'VALID FOR ALL SUBCOMMANDS ', & - ' --help Show help text and exit ', & - ' --verbose Display additional information when available ', & - ' --version Show version information and exit. ', & - ' ', & - 'EXAMPLES ', & - ' sample commands: ', & - ' ', & - ' fpm new mypackage --app --test ', & - ' fpm build ', & - ' fpm test ', & - ' fpm run ', & - ' fpm run --example ', & - ' fpm new --help ', & - ' fpm run myprogram --profile release -- -x 10 -y 20 --title "my title"', & - ' fpm install --prefix ~/.local ', & - ' ', & - 'SEE ALSO ', & - ' ', & - ' + The fpm(1) home page is at https://github.com/fortran-lang/fpm ', & - ' + Registered fpm(1) packages are at https://fortran-lang.org/packages ', & - ' + The fpm(1) TOML file format is described at ', & - ' https://github.com/fortran-lang/fpm/blob/master/manifest-reference.md ', & - ''] - help_list=[character(len=80) :: & - 'NAME ', & - ' list(1) - list summary of fpm(1) subcommands ', & - ' ', & - 'SYNOPSIS ', & - ' fpm list [-list] ', & - ' ', & - ' fpm list --help|--version ', & - ' ', & - 'DESCRIPTION ', & - ' Display a short description for each fpm(1) subcommand. ', & - ' ', & - 'OPTIONS ', & - ' --list display a list of command options as well. This is the ', & - ' same output as generated by "fpm --list". ', & - ' ', & - 'EXAMPLES ', & - ' display a short list of fpm(1) subcommands ', & - ' ', & - ' fpm list ', & - ' fpm --list ', & - '' ] - help_run=[character(len=80) :: & - 'NAME ', & - ' run(1) - the fpm(1) subcommand to run project applications ', & - ' ', & - 'SYNOPSIS ', & - ' fpm run [[--target] NAME(s) [--profile PROF] [--flag FFLAGS]', & - ' [--compiler COMPILER_NAME] [--runner "CMD"] [--example]', & - ' [--list] [--all] [-- ARGS]', & - ' ', & - ' fpm run --help|--version ', & - ' ', & - 'DESCRIPTION ', & - ' Run the applications in your fpm(1) package. By default applications ', & - ' in /app or specified as "executable" in your "fpm.toml" manifest are ', & - ' used. Alternatively demonstration programs in example/ or specified in', & - ' the "example" section in "fpm.toml" can be executed. The applications ', & - ' are automatically rebuilt before being run if they are out of date. ', & - ' ', & - 'OPTIONS ', & - ' --target NAME(s) list of application names to execute. No name is ', & - ' required if only one target exists. If no name is ', & - ' supplied and more than one candidate exists or a ', & - ' name has no match a list is produced and fpm(1) ', & - ' exits. ', & - ' ', & - ' Basic "globbing" is supported where "?" represents ', & - ' any single character and "*" represents any string. ', & - ' Note The glob string normally needs quoted to ', & - ' the special characters from shell expansion. ', & - ' --all Run all examples or applications. An alias for --target ''*''. ', & - ' --example Run example programs instead of applications. ', & - ' --profile PROF selects the compilation profile for the build.',& - ' Currently available profiles are "release" for',& - ' high optimization and "debug" for full debug options.',& - ' If --flag is not specified the "debug" flags are the',& - ' default. ',& - ' --flag FFLAGS selects compile arguments for the build. These are',& - ' added to the profile options if --profile is specified,',& - ' else these options override the defaults.',& - ' Note object and .mod directory locations are always',& - ' built in.',& - ' --compiler COMPILER_NAME Specify a compiler name. The default is ', & - ' "gfortran" unless set by the environment ', & - ' variable FPM_COMPILER. ', & - ' --runner CMD A command to prefix the program execution paths with. ', & - ' see "fpm help runner" for further details. ', & - ' --list list pathname of candidates instead of running them. Note ', & - ' out-of-date candidates will still be rebuilt before being ', & - ' listed. ', & - ' -- ARGS optional arguments to pass to the program(s). The same ', & - ' arguments are passed to all program names specified. ', & - ' ', & - 'EXAMPLES ', & - ' fpm(1) - run or display project applications: ', & - ' ', & - ' fpm run # run a target when only one exists or list targets ', & - ' fpm run --list # list all targets, running nothing. ', & - ' fpm run --all # run all targets, no matter how many there are. ', & - ' ', & - ' # run default program built or to be built with the compiler command ', & - ' # "f90". If more than one app exists a list displays and target names', & - ' # are required. ', & - ' fpm run --compiler f90 ', & - ' ', & - ' # run example programs instead of the application programs. ', & - ' fpm run --example ''*'' ', & - ' ', & - ' # run a specific program and pass arguments to the command ', & - ' fpm run myprog -- -x 10 -y 20 --title "my title line" ', & - ' ', & - ' # run production version of two applications ', & - ' fpm run --target prg1,prg2 --profile release ', & - ' ', & - ' # install executables in directory (assuming install(1) exists) ', & - ' fpm run --runner ''install -b -m 0711 -p -t /usr/local/bin'' ', & - '' ] - help_build=[character(len=80) :: & - 'NAME ', & - ' build(1) - the fpm(1) subcommand to build a project ', & - ' ', & - 'SYNOPSIS ', & - ' fpm build [--profile PROF] [--flag FFLAGS] [--compiler COMPILER_NAME] [-list]', & - ' ', & - ' fpm build --help|--version ', & - ' ', & - 'DESCRIPTION ', & - ' The "fpm build" command ', & - ' o Fetches any dependencies ', & - ' o Scans your sources ', & - ' o Builds them in the proper order ', & - ' ', & - ' The Fortran source files are assumed by default to be in ', & - ' o src/ for modules and procedure source ', & - ' o app/ main program(s) for applications ', & - ' o test/ main program(s) and support files for project tests ', & - ' o example/ main program(s) for example programs ', & - ' Changed or new files found are rebuilt. The results are placed in ', & - ' the build/ directory. ', & - ' ', & - ' Non-default pathnames and remote dependencies are used if ', & - ' specified in the "fpm.toml" file. ', & - ' ', & - 'OPTIONS ', & - ' --profile PROF selects the compilation profile for the build.',& - ' Currently available profiles are "release" for',& - ' high optimization and "debug" for full debug options.',& - ' If --flag is not specified the "debug" flags are the',& - ' default. ',& - ' --flag FFLAGS selects compile arguments for the build. These are',& - ' added to the profile options if --profile is specified,',& - ' else these options override the defaults.',& - ' Note object and .mod directory locations are always',& - ' built in.',& - ' --compiler COMPILER_NAME Specify a compiler name. The default is ', & - ' "gfortran" unless set by the environment ', & - ' variable FPM_COMPILER. ', & - ' --list list candidates instead of building or running them ', & - ' --show-model show the model and exit (do not build) ', & - ' --help print this help and exit ', & - ' --version print program version information and exit ', & - ' ', & - 'EXAMPLES ', & - ' Sample commands: ', & - ' ', & - ' fpm build # build with debug options ', & - ' fpm build --profile release # build with high optimization ', & - '' ] - - help_help=[character(len=80) :: & - 'NAME ', & - ' help(1) - the fpm(1) subcommand to display help ', & - ' ', & - 'SYNOPSIS ', & - ' fpm help [fpm] [new] [build] [run] [test] [help] [version] [manual] ', & - ' [runner] ', & - ' ', & - 'DESCRIPTION ', & - ' The "fpm help" command is an alternative to the --help parameter ', & - ' on the fpm(1) command and its subcommands. ', & - ' ', & - 'OPTIONS ', & - ' NAME(s) A list of topic names to display. All the subcommands ', & - ' have their own page (new, build, run, test, ...). ', & - ' ', & - ' The special name "manual" displays all the fpm(1) ', & - ' built-in documentation. ', & - ' ', & - ' The default is to display help for the fpm(1) command ', & - ' itself. ', & - ' ', & - 'EXAMPLES ', & - ' Sample usage: ', & - ' ', & - ' fpm help # general fpm(1) command help ', & - ' fpm help version # show program version ', & - ' fpm help new # display help for "new" subcommand ', & - ' fpm help manual # All fpm(1) built-in documentation ', & - ' ', & - '' ] - help_new=[character(len=80) :: & - 'NAME ', & - ' new(1) - the fpm(1) subcommand to initialize a new project ', & - 'SYNOPSIS ', & - ' fpm new NAME [[--lib|--src] [--app] [--test] [--example]]| ', & - ' [--full|--bare][--backfill] ', & - ' fpm new --help|--version ', & - ' ', & - 'DESCRIPTION ', & - ' "fpm new" creates and populates a new programming project directory. ', & - ' It ', & - ' o creates a directory with the specified name ', & - ' o runs the command "git init" in that directory ', & - ' o populates the directory with the default project directories ', & - ' o adds sample Fortran source files ', & - ' o adds a ".gitignore" file for ignoring the build/ directory ', & - ' (where fpm-generated output will be placed) ', & - ' ', & - ' The default file structure (that will be automatically scanned) is ', & - ' ', & - ' NAME/ ', & - ' fpm.toml ', & - ' .gitignore ', & - ' src/ ', & - ' NAME.f90 ', & - ' app/ ', & - ' main.f90 ', & - ' test/ ', & - ' check.f90 ', & - ' example/ ', & - ' demo.f90 ', & - ' ', & - ' Using this file structure is highly encouraged, particularly for ', & - ' small packages primarily intended to be used as dependencies. ', & - ' ', & - ' If you find this restrictive and need to customize the package ', & - ' structure you will find using the --full switch creates a ', & - ' heavily annotated manifest file with references to documentation ', & - ' to aid in constructing complex package structures. ', & - ' ', & - ' Remember to update the information in the sample "fpm.toml" ', & - ' file with your name and e-mail address. ', & - ' ', & - 'OPTIONS ', & - ' NAME the name of the project directory to create. The name ', & - ' must be made of up to 63 ASCII letters, digits, underscores, ', & - ' or hyphens, and start with a letter. ', & - ' ', & - ' The default is to create the src/, app/, and test/ directories. ', & - ' If any of the following options are specified then only the ', & - ' selected subdirectories are generated: ', & - ' ', & - ' --lib,--src create directory src/ and a placeholder module ', & - ' named "NAME.f90" for use with subcommand "build". ', & - ' --app create directory app/ and a placeholder main ', & - ' program for use with subcommand "run". ', & - ' --test create directory test/ and a placeholder program ', & - ' for use with the subcommand "test". Note that sans ', & - ' "--lib" it really does not have anything to test. ', & - ' --example create directory example/ and a placeholder program ', & - ' for use with the subcommand "run --example". ', & - ' It is only created by default if "--full is" specified. ', & - ' ', & - ' So the default is equivalent to ',& - ' ', & - ' fpm NAME --lib --app --test ', & - ' ', & - ' --backfill By default the directory must not exist. If this ', & - ' option is present the directory may pre-exist and ', & - ' only subdirectories and files that do not ', & - ' already exist will be created. For example, if you ', & - ' previously entered "fpm new myname --lib" entering ', & - ' "fpm new myname -full --backfill" will create any missing', & - ' app/, example/, and test/ directories and programs. ', & - ' ', & - ' --full By default a minimal manifest file ("fpm.toml") is ', & - ' created that depends on auto-discovery. With this ', & - ' option a much more extensive manifest sample is written ', & - ' and the example/ directory is created and populated. ', & - ' It is designed to facilitate creating projects that ', & - ' depend extensively on non-default build options. ', & - ' ', & - ' --bare A minimal manifest file ("fpm.toml") is created and ', & - ' a ".gitignore" and "README.md" file is created but no ', & - ' directories or sample Fortran is generated. ', & - ' ', & - ' --help print this help and exit ', & - ' --version print program version information and exit ', & - ' ', & - 'EXAMPLES ', & - ' Sample use ', & - ' ', & - ' fpm new myproject # create new project directory and seed it ', & - ' cd myproject # Enter the new directory ', & - ' # and run commands such as ', & - ' fpm build ', & - ' fpm run # run lone example application program ', & - ' fpm test # run example test program(s) ', & - ' fpm run --example # run lone example program ', & - ' ', & - ' fpm new A --full # create example/ and an annotated fpm.toml as well', & - ' fpm new A --bare # create no directories ', & - ' create any missing files in current directory ', & - ' fpm new `pwd` --full --backfill ', & - '' ] - help_test=[character(len=80) :: & - 'NAME ', & - ' test(1) - the fpm(1) subcommand to run project tests ', & - ' ', & - 'SYNOPSIS ', & - ' fpm test [[--target] NAME(s)] [--profile PROF] [--flag FFLAGS]', & - ' [--compiler COMPILER_NAME ] [--runner "CMD"] [--list][-- ARGS]', & - ' ', & - ' fpm test --help|--version ', & - ' ', & - 'DESCRIPTION ', & - ' Run applications you have built to test your project. ', & - ' ', & - 'OPTIONS ', & - ' --target NAME(s) optional list of specific test names to execute. ', & - ' The default is to run all the tests in test/ ', & - ' or the tests listed in the "fpm.toml" file. ', & - ' ', & - ' Basic "globbing" is supported where "?" represents ', & - ' any single character and "*" represents any string. ', & - ' Note The glob string normally needs quoted to ', & - ' protect the special characters from shell expansion.', & - ' --profile PROF selects the compilation profile for the build.',& - ' Currently available profiles are "release" for',& - ' high optimization and "debug" for full debug options.',& - ' If --flag is not specified the "debug" flags are the',& - ' default. ',& - ' --flag FFLAGS selects compile arguments for the build. These are',& - ' added to the profile options if --profile is specified,',& - ' else these options override the defaults.',& - ' Note object and .mod directory locations are always',& - ' built in.',& - ' --compiler COMPILER_NAME Specify a compiler name. The default is ', & - ' "gfortran" unless set by the environment ', & - ' variable FPM_COMPILER. ', & - ' --runner CMD A command to prefix the program execution paths with. ', & - ' see "fpm help runner" for further details. ', & - ' --list list candidates instead of building or running them ', & - ' -- ARGS optional arguments to pass to the test program(s). ', & - ' The same arguments are passed to all test names ', & - ' specified. ', & - ' ', & - 'EXAMPLES ', & - 'run tests ', & - ' ', & - ' # run default tests in /test or as specified in "fpm.toml" ', & - ' fpm test ', & - ' ', & - ' # run using compiler command "f90" ', & - ' fpm test --compiler f90 ', & - ' ', & - ' # run a specific test and pass arguments to the command ', & - ' fpm test mytest -- -x 10 -y 20 --title "my title line" ', & - ' ', & - ' fpm test tst1 tst2 --profile PROF # run production version of two tests', & - '' ] - help_update=[character(len=80) :: & - 'NAME', & - ' update(1) - manage project dependencies', & - '', & - 'SYNOPSIS', & - ' fpm update [--fetch-only] [--clean] [--verbose] [NAME(s)]', & - '', & - 'DESCRIPTION', & - ' Manage and update project dependencies. If no dependency names are', & - ' provided all the dependencies are updated automatically.', & - '', & - 'OPTIONS', & - ' --fetch-only Only fetch dependencies, do not update existing projects', & - ' --clean Do not use previous dependency cache', & - ' --verbose Show additional printout', & - '', & - 'SEE ALSO', & - ' The fpm(1) home page at https://github.com/fortran-lang/fpm', & - '' ] - help_install=[character(len=80) :: & - 'NAME', & - ' install(1) - install fpm projects', & - '', & - 'SYNOPSIS', & - ' fpm install [--profile PROF] [--flag FFLAGS] [--list] [--no-rebuild]', & - ' [--prefix DIR] [--bindir DIR] [--libdir DIR] [--includedir DIR]', & - ' [--verbose]', & - '', & - 'DESCRIPTION', & - ' Subcommand to install fpm projects. Running install will export the', & - ' current project to the selected prefix, this will by default install all', & - ' executables (tests and examples are excluded) which are part of the projects.', & - ' Libraries and module files are only installed for projects requiring the', & - ' installation of those components in the package manifest.', & - '', & - 'OPTIONS', & - ' --list list all installable targets for this project,', & - ' but do not install any of them', & - ' --profile PROF selects the compilation profile for the build.',& - ' Currently available profiles are "release" for',& - ' high optimization and "debug" for full debug options.',& - ' If --flag is not specified the "debug" flags are the',& - ' default. ',& - ' --flag FFLAGS selects compile arguments for the build. These are',& - ' added to the profile options if --profile is specified,',& - ' else these options override the defaults.',& - ' Note object and .mod directory locations are always',& - ' built in.',& - ' --no-rebuild do not rebuild project before installation', & - ' --prefix DIR path to installation directory (requires write access),', & - ' the default prefix on Unix systems is $HOME/.local', & - ' and %APPDATA%\local on Windows', & - ' --bindir DIR subdirectory to place executables in (default: bin)', & - ' --libdir DIR subdirectory to place libraries and archives in', & - ' (default: lib)', & - ' --includedir DIR subdirectory to place headers and module files in', & - ' (default: include)', & - ' --verbose print more information', & - '', & - 'EXAMPLES', & - ' 1. Install release version of project:', & - '', & - ' fpm install --profile release', & - '', & - ' 2. Install the project without rebuilding the executables:', & - '', & - ' fpm install --no-rebuild', & - '', & - ' 3. Install executables to a custom prefix into the exe directory:', & - '', & - ' fpm install --prefix $PWD --bindir exe', & - '' ] - end subroutine set_help - - subroutine get_char_arg(var, arg) - character(len=:), allocatable, intent(out) :: var - character(len=*), intent(in) :: arg - var = sget(arg) - if (len_trim(var) == 0) deallocate(var) - end subroutine get_char_arg - -end module fpm_command_line diff --git a/fpm/src/fpm_compiler.f90 b/fpm/src/fpm_compiler.f90 deleted file mode 100644 index 51cda20..0000000 --- a/fpm/src/fpm_compiler.f90 +++ /dev/null @@ -1,333 +0,0 @@ -!># Define compiler command options -!! -!! This module defines compiler options to use for the debug and release builds. - -! vendor Fortran C Module output Module include OpenMP Free for OSS -! compiler compiler directory directory -! Gnu gfortran gcc -J -I -fopenmp X -! Intel ifort icc -module -I -qopenmp X -! Intel(Windows) ifort icc /module:path /I /Qopenmp X -! Intel oneAPI ifx icx -module -I -qopenmp X -! PGI pgfortran pgcc -module -I -mp X -! NVIDIA nvfortran nvc -module -I -mp X -! LLVM flang flang clang -module -I -mp X -! LFortran lfortran --- ? ? ? X -! Lahey/Futjitsu lfc ? -M -I -openmp ? -! NAG nagfor ? -mdir -I -openmp x -! Cray crayftn craycc -J -I -homp ? -! IBM xlf90 ? -qmoddir -I -qsmp X -! Oracle/Sun ? ? -moddir= -M -xopenmp ? -! Silverfrost FTN95 ftn95 ? ? /MOD_PATH ? ? -! Elbrus ? lcc -J -I -fopenmp ? -! Hewlett Packard ? ? ? ? ? discontinued -! Watcom ? ? ? ? ? discontinued -! PathScale ? ? -module -I -mp discontinued -! G95 ? ? -fmod= -I -fopenmp discontinued -! Open64 ? ? -module -I -mp discontinued -! Unisys ? ? ? ? ? discontinued -module fpm_compiler -use fpm_model, only: fpm_model_t -use fpm_filesystem, only: join_path, basename -implicit none -public :: is_unknown_compiler -public :: get_module_flags -public :: get_default_compile_flags -public :: get_debug_compile_flags -public :: get_release_compile_flags - -enum, bind(C) - enumerator :: & - id_unknown, & - id_gcc, & - id_f95, & - id_caf, & - id_intel_classic, & - id_intel_llvm, & - id_pgi, & - id_nvhpc, & - id_nag, & - id_flang, & - id_ibmxl, & - id_cray, & - id_lahey, & - id_lfortran -end enum -integer, parameter :: compiler_enum = kind(id_unknown) - -contains - -subroutine get_default_compile_flags(compiler, release, flags) - character(len=*), intent(in) :: compiler - logical, intent(in) :: release - character(len=:), allocatable, intent(out) :: flags - integer :: id - - id = get_compiler_id(compiler) - if (release) then - call get_release_compile_flags(id, flags) - else - call get_debug_compile_flags(id, flags) - end if - -end subroutine get_default_compile_flags - -subroutine get_release_compile_flags(id, flags) - integer(compiler_enum), intent(in) :: id - character(len=:), allocatable, intent(out) :: flags - - select case(id) - case default - flags = "" - - case(id_caf) - flags='& - & -O3& - & -Wimplicit-interface& - & -fPIC& - & -fmax-errors=1& - & -funroll-loops& - &' - case(id_gcc) - flags='& - & -O3& - & -Wimplicit-interface& - & -fPIC& - & -fmax-errors=1& - & -funroll-loops& - & -fcoarray=single& - &' - case(id_f95) - flags='& - & -O3& - & -Wimplicit-interface& - & -fPIC& - & -fmax-errors=1& - & -ffast-math& - & -funroll-loops& - &' - case(id_nvhpc) - flags = '& - & -Mbackslash& - &' - case(id_intel_classic) - flags = '& - & -fp-model precise& - & -pc 64& - & -align all& - & -error-limit 1& - & -reentrancy threaded& - & -nogen-interfaces& - & -assume byterecl& - &' - case(id_nag) - flags = ' & - & -O4& - & -coarray=single& - & -PIC& - &' - end select -end subroutine get_release_compile_flags - -subroutine get_debug_compile_flags(id, flags) - integer(compiler_enum), intent(in) :: id - character(len=:), allocatable, intent(out) :: flags - - select case(id) - case default - flags = "" - - case(id_caf) - flags = '& - & -Wall& - & -Wextra& - & -Wimplicit-interface& - & -fPIC -fmax-errors=1& - & -g& - & -fcheck=bounds& - & -fcheck=array-temps& - & -fbacktrace& - &' - - case(id_gcc) - flags = '& - & -Wall& - & -Wextra& - & -Wimplicit-interface& - & -fPIC -fmax-errors=1& - & -g& - & -fcheck=bounds& - & -fcheck=array-temps& - & -fbacktrace& - & -fcoarray=single& - &' - - case(id_f95) - flags = '& - & -Wall& - & -Wextra& - & -Wimplicit-interface& - & -fPIC -fmax-errors=1& - & -g& - & -fcheck=bounds& - & -fcheck=array-temps& - & -Wno-maybe-uninitialized -Wno-uninitialized& - & -fbacktrace& - &' - - case(id_nvhpc) - flags = '& - & -Minform=inform& - & -Mbackslash& - & -g& - & -Mbounds& - & -Mchkptr& - & -Mchkstk& - & -traceback& - &' - - case(id_intel_classic) - flags = '& - & -warn all& - & -check:all:noarg_temp_created& - & -error-limit 1& - & -O0& - & -g& - & -assume byterecl& - & -traceback& - &' - - case(id_nag) - flags = '& - & -g& - & -C=all& - & -O0& - & -gline& - & -coarray=single& - & -PIC& - &' - end select -end subroutine get_debug_compile_flags - -subroutine get_module_flags(compiler, modpath, flags) - character(len=*), intent(in) :: compiler - character(len=*), intent(in) :: modpath - character(len=:), allocatable, intent(out) :: flags - integer(compiler_enum) :: id - - id = get_compiler_id(compiler) - - select case(id) - case default - flags=' -module '//modpath//' -I '//modpath - - case(id_caf, id_gcc, id_f95, id_cray) - flags=' -J '//modpath//' -I '//modpath - - case(id_intel_classic, id_intel_llvm, id_nvhpc, id_pgi, id_flang) - flags=' -module '//modpath//' -I '//modpath - - case(id_lahey) - flags=' -M '//modpath//' -I '//modpath - - case(id_nag) - flags=' -mdir '//modpath//' -I '//modpath ! - - case(id_ibmxl) - flags=' -qmoddir '//modpath//' -I '//modpath - - end select - -end subroutine get_module_flags - -function get_compiler_id(compiler) result(id) - character(len=*), intent(in) :: compiler - integer(kind=compiler_enum) :: id - - if (check_compiler(compiler, "gfortran")) then - id = id_gcc - return - end if - - if (check_compiler(compiler, "f95")) then - id = id_f95 - return - end if - - if (check_compiler(compiler, "caf")) then - id = id_caf - return - end if - - if (check_compiler(compiler, "ifort")) then - id = id_intel_classic - return - end if - - if (check_compiler(compiler, "ifx")) then - id = id_intel_llvm - return - end if - - if (check_compiler(compiler, "nvfortran")) then - id = id_nvhpc - return - end if - - if (check_compiler(compiler, "pgfortran") & - & .or. check_compiler(compiler, "pgf90") & - & .or. check_compiler(compiler, "pgf95")) then - id = id_pgi - return - end if - - if (check_compiler(compiler, "nagfor")) then - id = id_nag - return - end if - - if (check_compiler(compiler, "flang")) then - id = id_flang - return - end if - - if (check_compiler(compiler, "xlf90")) then - id = id_ibmxl - return - end if - - if (check_compiler(compiler, "crayftn")) then - id = id_cray - return - end if - - if (check_compiler(compiler, "lfc")) then - id = id_lahey - return - end if - - if (check_compiler(compiler, "lfort")) then - id = id_lfortran - return - end if - - id = id_unknown - -end function get_compiler_id - -function check_compiler(compiler, expected) result(match) - character(len=*), intent(in) :: compiler - character(len=*), intent(in) :: expected - logical :: match - match = compiler == expected - if (.not. match) then - match = index(basename(compiler), expected) > 0 - end if -end function check_compiler - -function is_unknown_compiler(compiler) result(is_unknown) - character(len=*), intent(in) :: compiler - logical :: is_unknown - is_unknown = get_compiler_id(compiler) == id_unknown -end function is_unknown_compiler - -end module fpm_compiler diff --git a/fpm/src/fpm_environment.f90 b/fpm/src/fpm_environment.f90 deleted file mode 100644 index 0408ec4..0000000 --- a/fpm/src/fpm_environment.f90 +++ /dev/null @@ -1,185 +0,0 @@ -!> This module contains procedures that interact with the programming environment. -!! -!! * [get_os_type] -- Determine the OS type -!! * [get_env] -- return the value of an environment variable -module fpm_environment - implicit none - private - public :: get_os_type - public :: os_is_unix - public :: run - public :: get_env - - integer, parameter, public :: OS_UNKNOWN = 0 - integer, parameter, public :: OS_LINUX = 1 - integer, parameter, public :: OS_MACOS = 2 - integer, parameter, public :: OS_WINDOWS = 3 - integer, parameter, public :: OS_CYGWIN = 4 - integer, parameter, public :: OS_SOLARIS = 5 - integer, parameter, public :: OS_FREEBSD = 6 -contains - !> Determine the OS type - integer function get_os_type() result(r) - !! - !! Returns one of OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_WINDOWS, OS_CYGWIN, - !! OS_SOLARIS, OS_FREEBSD. - !! - !! At first, the environment variable `OS` is checked, which is usually - !! found on Windows. Then, `OSTYPE` is read in and compared with common - !! names. If this fails too, check the existence of files that can be - !! found on specific system types only. - !! - !! Returns OS_UNKNOWN if the operating system cannot be determined. - character(len=32) :: val - integer :: length, rc - logical :: file_exists - - r = OS_UNKNOWN - - ! Check environment variable `OS`. - call get_environment_variable('OS', val, length, rc) - - if (rc == 0 .and. length > 0 .and. index(val, 'Windows_NT') > 0) then - r = OS_WINDOWS - return - end if - - ! Check environment variable `OSTYPE`. - call get_environment_variable('OSTYPE', val, length, rc) - - if (rc == 0 .and. length > 0) then - ! Linux - if (index(val, 'linux') > 0) then - r = OS_LINUX - return - end if - - ! macOS - if (index(val, 'darwin') > 0) then - r = OS_MACOS - return - end if - - ! Windows, MSYS, MinGW, Git Bash - if (index(val, 'win') > 0 .or. index(val, 'msys') > 0) then - r = OS_WINDOWS - return - end if - - ! Cygwin - if (index(val, 'cygwin') > 0) then - r = OS_CYGWIN - return - end if - - ! Solaris, OpenIndiana, ... - if (index(val, 'SunOS') > 0 .or. index(val, 'solaris') > 0) then - r = OS_SOLARIS - return - end if - - ! FreeBSD - if (index(val, 'FreeBSD') > 0 .or. index(val, 'freebsd') > 0) then - r = OS_FREEBSD - return - end if - end if - - ! Linux - inquire (file='/etc/os-release', exist=file_exists) - - if (file_exists) then - r = OS_LINUX - return - end if - - ! macOS - inquire (file='/usr/bin/sw_vers', exist=file_exists) - - if (file_exists) then - r = OS_MACOS - return - end if - - ! FreeBSD - inquire (file='/bin/freebsd-version', exist=file_exists) - - if (file_exists) then - r = OS_FREEBSD - return - end if - end function get_os_type - - !> Compare the output of [[get_os_type]] or the optional - !! passed INTEGER value to the value for OS_WINDOWS - !! and return .TRUE. if they match and .FALSE. otherwise - logical function os_is_unix(os) result(unix) - integer, intent(in), optional :: os - integer :: build_os - if (present(os)) then - build_os = os - else - build_os = get_os_type() - end if - unix = os /= OS_WINDOWS - end function os_is_unix - - !> echo command string and pass it to the system for execution - subroutine run(cmd,echo) - character(len=*), intent(in) :: cmd - logical,intent(in),optional :: echo - logical :: echo_local - integer :: stat - - if(present(echo))then - echo_local=echo - else - echo_local=.true. - endif - if(echo_local) print *, '+ ', cmd - - call execute_command_line(cmd, exitstat=stat) - if (stat /= 0) then - print *, 'Command failed' - error stop - end if - end subroutine run - - !> get named environment variable value. It it is blank or - !! not set return the optional default value - function get_env(NAME,DEFAULT) result(VALUE) - implicit none - !> name of environment variable to get the value of - character(len=*),intent(in) :: NAME - !> default value to return if the requested value is undefined or blank - character(len=*),intent(in),optional :: DEFAULT - !> the returned value - character(len=:),allocatable :: VALUE - integer :: howbig - integer :: stat - integer :: length - ! get length required to hold value - length=0 - if(NAME.ne.'')then - call get_environment_variable(NAME, length=howbig,status=stat,trim_name=.true.) - select case (stat) - case (1) - !*!print *, NAME, " is not defined in the environment. Strange..." - VALUE='' - case (2) - !*!print *, "This processor doesn't support environment variables. Boooh!" - VALUE='' - case default - ! make string to hold value of sufficient size - allocate(character(len=max(howbig,1)) :: VALUE) - ! get value - call get_environment_variable(NAME,VALUE,status=stat,trim_name=.true.) - if(stat.ne.0)VALUE='' - end select - else - VALUE='' - endif - if(VALUE.eq.''.and.present(DEFAULT))VALUE=DEFAULT - end function get_env - -end module fpm_environment diff --git a/fpm/src/fpm_filesystem.f90 b/fpm/src/fpm_filesystem.f90 deleted file mode 100644 index 6acd383..0000000 --- a/fpm/src/fpm_filesystem.f90 +++ /dev/null @@ -1,612 +0,0 @@ -!> This module contains general routines for interacting with the file system -!! -module fpm_filesystem -use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, stderr=>error_unit - use fpm_environment, only: get_os_type, & - OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_WINDOWS, & - OS_CYGWIN, OS_SOLARIS, OS_FREEBSD - use fpm_strings, only: f_string, replace, string_t, split - implicit none - private - public :: basename, canon_path, dirname, is_dir, join_path, number_of_rows, read_lines, list_files, env_variable, & - mkdir, exists, get_temp_filename, windows_path, unix_path, getline, delete_file, to_fortran_name - public :: fileopen, fileclose, filewrite, warnwrite - - integer, parameter :: LINE_BUFFER_LEN = 1000 - -contains - - -!> return value of environment variable -subroutine env_variable(var, name) - character(len=:), allocatable, intent(out) :: var - character(len=*), intent(in) :: name - integer :: length, stat - - call get_environment_variable(name, length=length, status=stat) - if (stat /= 0) return - - allocate(character(len=length) :: var) - - if (length > 0) then - call get_environment_variable(name, var, status=stat) - if (stat /= 0) then - deallocate(var) - return - end if - end if - -end subroutine env_variable - - -!> Extract filename from path with/without suffix -function basename(path,suffix) result (base) - - 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='\/') - if(size(file_parts).gt.0)then - base = trim(file_parts(size(file_parts))) - else - base = '' - endif - else - call split(path,file_parts,delimiters='\/.') - if(size(file_parts).ge.2)then - base = trim(file_parts(size(file_parts)-1)) - else - base = '' - endif - end if - -end function basename - - -!> Canonicalize path for comparison -!! * Handles path string redundancies -!! * Does not test existence of path -!! -!! To be replaced by realpath/_fullname in stdlib_os -!! -!! FIXME: Lot's of ugly hacks following here -function canon_path(path) - character(len=*), intent(in) :: path - character(len=:), allocatable :: canon_path - character(len=:), allocatable :: nixpath - - integer :: ii, istart, iend, stat, nn, last - logical :: is_path, absolute - - nixpath = unix_path(path) - - istart = 0 - nn = 0 - iend = 0 - absolute = nixpath(1:1) == "/" - if (absolute) then - canon_path = "/" - else - canon_path = "" - end if - - do while(iend < len(nixpath)) - call next(nixpath, istart, iend, is_path) - if (is_path) then - select case(nixpath(istart:iend)) - case(".", "") ! always drop empty paths - case("..") - if (nn > 0) then - last = scan(canon_path(:len(canon_path)-1), "/", back=.true.) - canon_path = canon_path(:last) - nn = nn - 1 - else - if (.not. absolute) then - canon_path = canon_path // nixpath(istart:iend) // "/" - end if - end if - case default - nn = nn + 1 - canon_path = canon_path // nixpath(istart:iend) // "/" - end select - end if - end do - - if (len(canon_path) == 0) canon_path = "." - if (len(canon_path) > 1 .and. canon_path(len(canon_path):) == "/") then - canon_path = canon_path(:len(canon_path)-1) - end if - -contains - - subroutine next(string, istart, iend, is_path) - character(len=*), intent(in) :: string - integer, intent(inout) :: istart - integer, intent(inout) :: iend - logical, intent(inout) :: is_path - - integer :: ii, nn - character :: tok, last - - nn = len(string) - - if (iend >= nn) then - istart = nn - iend = nn - return - end if - - ii = min(iend + 1, nn) - tok = string(ii:ii) - - is_path = tok /= '/' - - if (.not.is_path) then - is_path = .false. - istart = ii - iend = ii - return - end if - - istart = ii - do ii = min(iend + 1, nn), nn - tok = string(ii:ii) - select case(tok) - case('/') - exit - case default - iend = ii - cycle - end select - end do - - end subroutine next -end function canon_path - - -!> Extract dirname from path -function dirname(path) result (dir) - character(*), intent(in) :: path - character(:), allocatable :: dir - - dir = path(1:scan(path,'/\',back=.true.)) - -end function dirname - - -!> test if a name matches an existing directory path -logical function is_dir(dir) - character(*), intent(in) :: dir - integer :: stat - - select case (get_os_type()) - - case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD) - call execute_command_line("test -d " // dir , exitstat=stat) - - case (OS_WINDOWS) - call execute_command_line('cmd /c "if not exist ' // windows_path(dir) // '\ exit /B 1"', exitstat=stat) - - end select - - is_dir = (stat == 0) - -end function is_dir - - -!> Construct path by joining strings with os file separator -function join_path(a1,a2,a3,a4,a5) result(path) - - character(len=*), intent(in) :: a1, a2 - character(len=*), intent(in), optional :: a3, a4, a5 - character(len=:), allocatable :: path - character(len=1) :: filesep - - select case (get_os_type()) - case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD) - 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 - - -!> Determine number or rows in a file given a LUN -integer function number_of_rows(s) result(nrows) - 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 - - -!> read lines into an array of TYPE(STRING_T) variables -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 - -!> Create a directory. Create subdirectories as needed -subroutine mkdir(dir) - character(len=*), intent(in) :: dir - integer :: stat - - if (is_dir(dir)) return - - select case (get_os_type()) - case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD) - call execute_command_line('mkdir -p ' // dir, exitstat=stat) - write (*, '(" + ",2a)') 'mkdir -p ' // dir - - case (OS_WINDOWS) - call execute_command_line("mkdir " // windows_path(dir), exitstat=stat) - write (*, '(" + ",2a)') 'mkdir ' // windows_path(dir) - end select - - if (stat /= 0) then - print *, 'execute_command_line() failed' - error stop - end if -end subroutine mkdir - - -!> Get file & directory names in directory `dir`. -!! -!! - File/directory names return are relative to cwd, ie. preprended with `dir` -!! - Includes files starting with `.` except current directory and parent directory -!! -recursive subroutine list_files(dir, files, recurse) - character(len=*), intent(in) :: dir - type(string_t), allocatable, intent(out) :: files(:) - logical, intent(in), optional :: recurse - - integer :: stat, fh, i - character(:), allocatable :: temp_file - type(string_t), allocatable :: dir_files(:) - type(string_t), allocatable :: sub_dir_files(:) - - if (.not. is_dir(dir)) then - allocate (files(0)) - return - end if - - allocate (temp_file, source=get_temp_filename()) - - select case (get_os_type()) - case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD) - call execute_command_line('ls -A ' // dir // ' > ' // temp_file, & - exitstat=stat) - case (OS_WINDOWS) - call execute_command_line('dir /b ' // windows_path(dir) // ' > ' // temp_file, & - exitstat=stat) - end select - - if (stat /= 0) then - 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") - - do i=1,size(files) - files(i)%s = join_path(dir,files(i)%s) - end do - - if (present(recurse)) then - if (recurse) then - - allocate(sub_dir_files(0)) - - do i=1,size(files) - if (is_dir(files(i)%s)) then - - call list_files(files(i)%s, dir_files, recurse=.true.) - sub_dir_files = [sub_dir_files, dir_files] - - end if - end do - - files = [files, sub_dir_files] - - end if - end if - -end subroutine list_files - - -!> test if pathname already exists -logical function exists(filename) result(r) - character(len=*), intent(in) :: filename - inquire(file=filename, exist=r) -end function - - -!> Get a unused temporary filename -!! Calls posix 'tempnam' - not recommended, but -!! we have no security concerns for this application -!! and use here is temporary. -!! Works with MinGW -function get_temp_filename() result(tempfile) - ! - 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 - - -!> Replace file system separators for windows -function windows_path(path) result(winpath) - - 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 - - -!> Replace file system separators for unix -function unix_path(path) result(nixpath) - - character(*), intent(in) :: path - character(:), allocatable :: nixpath - - integer :: idx - - nixpath = path - - idx = index(nixpath,'\') - do while(idx > 0) - nixpath(idx:idx) = '/' - idx = index(nixpath,'\') - end do - -end function unix_path - - -!> read a line of arbitrary length into a CHARACTER variable from the specified LUN -subroutine getline(unit, line, iostat, iomsg) - - !> Formatted IO unit - integer, intent(in) :: unit - - !> Line to read - character(len=:), allocatable, intent(out) :: line - - !> Status of operation - integer, intent(out) :: iostat - - !> Error message - character(len=:), allocatable, optional :: iomsg - - character(len=LINE_BUFFER_LEN) :: buffer - character(len=LINE_BUFFER_LEN) :: msg - integer :: size - integer :: stat - - allocate(character(len=0) :: line) - do - read(unit, '(a)', advance='no', iostat=stat, iomsg=msg, size=size) & - & buffer - if (stat > 0) exit - line = line // buffer(:size) - if (stat < 0) then - if (is_iostat_eor(stat)) then - stat = 0 - end if - exit - end if - end do - - if (stat /= 0) then - if (present(iomsg)) iomsg = trim(msg) - end if - iostat = stat - -end subroutine getline - - -!> delete a file by filename -subroutine delete_file(file) - character(len=*), intent(in) :: file - logical :: exist - integer :: unit - inquire(file=file, exist=exist) - if (exist) then - open(file=file, newunit=unit) - close(unit, status="delete") - end if -end subroutine delete_file - -!> write trimmed character data to a file if it does not exist -subroutine warnwrite(fname,data) -character(len=*),intent(in) :: fname -character(len=*),intent(in) :: data(:) - - if(.not.exists(fname))then - call filewrite(fname,data) - else - write(stderr,'(*(g0,1x))')' ',fname,& - & 'already exists. Not overwriting' - endif - -end subroutine warnwrite - -!> procedure to open filename as a sequential "text" file -subroutine fileopen(filename,lun,ier) - -character(len=*),intent(in) :: filename -integer,intent(out) :: lun -integer,intent(out),optional :: ier -integer :: ios -character(len=256) :: message - - message=' ' - ios=0 - if(filename.ne.' ')then - open(file=filename, & - & newunit=lun, & - & form='formatted', & ! FORM = FORMATTED | UNFORMATTED - & access='sequential', & ! ACCESS = SEQUENTIAL| DIRECT | STREAM - & action='write', & ! ACTION = READ|WRITE| READWRITE - & position='rewind', & ! POSITION= ASIS | REWIND | APPEND - & status='new', & ! STATUS = NEW| REPLACE| OLD| SCRATCH| UNKNOWN - & iostat=ios, & - & iomsg=message) - else - lun=stdout - ios=0 - endif - if(ios.ne.0)then - write(stderr,'(*(a:,1x))')& - & ' *filewrite*:',filename,trim(message) - lun=-1 - if(present(ier))then - ier=ios - else - stop 1 - endif - endif - -end subroutine fileopen - -!> simple close of a LUN. On error show message and stop (by default) -subroutine fileclose(lun,ier) -integer,intent(in) :: lun -integer,intent(out),optional :: ier -character(len=256) :: message -integer :: ios - if(lun.ne.-1)then - close(unit=lun,iostat=ios,iomsg=message) - if(ios.ne.0)then - write(stderr,'(*(a:,1x))')' *filewrite*:',trim(message) - if(present(ier))then - ier=ios - else - stop 2 - endif - endif - endif -end subroutine fileclose - -!> procedure to write filedata to file filename -subroutine filewrite(filename,filedata) - -character(len=*),intent(in) :: filename -character(len=*),intent(in) :: filedata(:) -integer :: lun, i, ios -character(len=256) :: message - call fileopen(filename,lun) - if(lun.ne.-1)then ! program currently stops on error on open, but might - ! want it to continue so -1 (unallowed LUN) indicates error - ! write file - do i=1,size(filedata) - write(lun,'(a)',iostat=ios,iomsg=message)trim(filedata(i)) - if(ios.ne.0)then - write(stderr,'(*(a:,1x))')& - & ' *filewrite*:',filename,trim(message) - stop 4 - endif - enddo - endif - ! close file - call fileclose(lun) - -end subroutine filewrite - -!> Returns string with special characters replaced with an underscore. -!! For now, only a hyphen is treated as a special character, but this can be -!! expanded to other characters if needed. -pure function to_fortran_name(string) result(res) - character(*), intent(in) :: string - character(len(string)) :: res - character, parameter :: SPECIAL_CHARACTERS(*) = ['-'] - res = replace(string, SPECIAL_CHARACTERS, '_') -end function to_fortran_name - -end module fpm_filesystem diff --git a/fpm/src/fpm_model.f90 b/fpm/src/fpm_model.f90 deleted file mode 100644 index bfb0115..0000000 --- a/fpm/src/fpm_model.f90 +++ /dev/null @@ -1,293 +0,0 @@ -!># The fpm package model -!> -!> Defines the fpm model data types which encapsulate all information -!> required to correctly build a package and its dependencies. -!> -!> The process (see `[[build_model(subroutine)]]`) for generating a valid `[[fpm_model]]` involves -!> source files discovery ([[fpm_sources]]) and parsing ([[fpm_source_parsing]]). -!> -!> Once a valid `[[fpm_model]]` has been constructed, it may be passed to `[[fpm_targets:targets_from_sources]]` to -!> generate a list of build targets for the backend. -!> -!>### Enumerations -!> -!> __Source type:__ `FPM_UNIT_*` -!> Describes the type of source file — determines build target generation -!> -!> __Source scope:__ `FPM_SCOPE_*` -!> Describes the scoping rules for using modules — controls module dependency resolution -!> -module fpm_model -use iso_fortran_env, only: int64 -use fpm_strings, only: string_t, str -use fpm_dependency, only: dependency_tree_t -implicit none - -private -public :: fpm_model_t, srcfile_t, show_model - -public :: FPM_UNIT_UNKNOWN, FPM_UNIT_PROGRAM, FPM_UNIT_MODULE, & - FPM_UNIT_SUBMODULE, FPM_UNIT_SUBPROGRAM, FPM_UNIT_CSOURCE, & - FPM_UNIT_CHEADER, FPM_SCOPE_UNKNOWN, FPM_SCOPE_LIB, & - FPM_SCOPE_DEP, FPM_SCOPE_APP, FPM_SCOPE_EXAMPLE, FPM_SCOPE_TEST - -!> Source type unknown -integer, parameter :: FPM_UNIT_UNKNOWN = -1 -!> Source type is fortran program -integer, parameter :: FPM_UNIT_PROGRAM = 1 -!> Source type is fortran module -integer, parameter :: FPM_UNIT_MODULE = 2 -!> Source type is fortran submodule -integer, parameter :: FPM_UNIT_SUBMODULE = 3 -!> Source type is fortran subprogram -integer, parameter :: FPM_UNIT_SUBPROGRAM = 4 -!> Source type is c source file -integer, parameter :: FPM_UNIT_CSOURCE = 5 -!> Source type is c header file -integer, parameter :: FPM_UNIT_CHEADER = 6 - - -!> Source has no module-use scope -integer, parameter :: FPM_SCOPE_UNKNOWN = -1 -!> Module-use scope is library/dependency modules only -integer, parameter :: FPM_SCOPE_LIB = 1 -!> Module-use scope is library/dependency modules only -integer, parameter :: FPM_SCOPE_DEP = 2 -!> Module-use scope is library/dependency and app modules -integer, parameter :: FPM_SCOPE_APP = 3 -!> Module-use scope is library/dependency and test modules -integer, parameter :: FPM_SCOPE_TEST = 4 -integer, parameter :: FPM_SCOPE_EXAMPLE = 5 - - -!> Type for describing a source file -type srcfile_t - !> File path relative to cwd - character(:), allocatable :: file_name - - !> Name of executable for FPM_UNIT_PROGRAM - character(:), allocatable :: exe_name - - !> Target module-use scope - integer :: unit_scope = FPM_SCOPE_UNKNOWN - - !> Modules provided by this source file (lowerstring) - type(string_t), allocatable :: modules_provided(:) - - !> Type of source unit - integer :: unit_type = FPM_UNIT_UNKNOWN - - !> Modules USEd by this source file (lowerstring) - type(string_t), allocatable :: modules_used(:) - - !> Files INCLUDEd by this source file - type(string_t), allocatable :: include_dependencies(:) - - !> Native libraries to link against - type(string_t), allocatable :: link_libraries(:) - - !> Current hash - integer(int64) :: digest - -end type srcfile_t - - -!> Type for describing a single package -type package_t - - !> Name of package - character(:), allocatable :: name - - !> Array of sources - type(srcfile_t), allocatable :: sources(:) - -end type package_t - - -!> Type describing everything required to build -!> the root package and its dependencies. -type :: fpm_model_t - - !> Name of root package - character(:), allocatable :: package_name - - !> Array of packages (including the root package) - type(package_t), allocatable :: packages(:) - - !> Command line name to invoke fortran compiler - character(:), allocatable :: fortran_compiler - - !> Command line flags passed to fortran for compilation - character(:), allocatable :: fortran_compile_flags - - !> Base directory for build - character(:), allocatable :: output_directory - - !> Include directories - type(string_t), allocatable :: include_dirs(:) - - !> Native libraries to link against - type(string_t), allocatable :: link_libraries(:) - - !> Project dependencies - type(dependency_tree_t) :: deps - -end type fpm_model_t - -contains - - -function info_package(p) result(s) - ! Returns representation of package_t - type(package_t), intent(in) :: p - character(:), allocatable :: s - - integer :: i - - s = s // 'package_t(' - s = s // 'name="' // p%name //'"' - s = s // ', sources=[' - do i = 1, size(p%sources) - s = s // info_srcfile(p%sources(i)) - if (i < size(p%sources)) s = s // ", " - end do - s = s // "]" - s = s // ")" - -end function info_package - -function info_srcfile(source) result(s) - type(srcfile_t), intent(in) :: source - character(:), allocatable :: s - integer :: i - !type srcfile_t - s = "srcfile_t(" - ! character(:), allocatable :: file_name - s = s // 'file_name="' // source%file_name // '"' - ! character(:), allocatable :: exe_name - s = s // ', exe_name="' // source%exe_name // '"' - ! integer :: unit_scope = FPM_SCOPE_UNKNOWN - s = s // ", unit_scope=" - select case(source%unit_scope) - case (FPM_SCOPE_UNKNOWN) - s = s // "FPM_SCOPE_UNKNOWN" - case (FPM_SCOPE_LIB) - s = s // "FPM_SCOPE_LIB" - case (FPM_SCOPE_DEP) - s = s // "FPM_SCOPE_DEP" - case (FPM_SCOPE_APP) - s = s // "FPM_SCOPE_APP" - case (FPM_SCOPE_TEST) - s = s // "FPM_SCOPE_TEST" - case (FPM_SCOPE_EXAMPLE) - s = s // "FPM_SCOPE_EXAMPLE" - case default - s = s // "INVALID" - end select - ! type(string_t), allocatable :: modules_provided(:) - s = s // ", modules_provided=[" - do i = 1, size(source%modules_provided) - s = s // '"' // source%modules_provided(i)%s // '"' - if (i < size(source%modules_provided)) s = s // ", " - end do - s = s // "]" - ! integer :: unit_type = FPM_UNIT_UNKNOWN - s = s // ", unit_type=" - select case(source%unit_type) - case (FPM_UNIT_UNKNOWN) - s = s // "FPM_UNIT_UNKNOWN" - case (FPM_UNIT_PROGRAM) - s = s // "FPM_UNIT_PROGRAM" - case (FPM_UNIT_MODULE) - s = s // "FPM_UNIT_MODULE" - case (FPM_UNIT_SUBMODULE) - s = s // "FPM_UNIT_SUBMODULE" - case (FPM_UNIT_SUBPROGRAM) - s = s // "FPM_UNIT_SUBPROGRAM" - case (FPM_UNIT_CSOURCE) - s = s // "FPM_UNIT_CSOURCE" - case (FPM_UNIT_CHEADER) - s = s // "FPM_UNIT_CHEADER" - case default - s = s // "INVALID" - end select - ! type(string_t), allocatable :: modules_used(:) - s = s // ", modules_used=[" - do i = 1, size(source%modules_used) - s = s // '"' // source%modules_used(i)%s // '"' - if (i < size(source%modules_used)) s = s // ", " - end do - s = s // "]" - ! type(string_t), allocatable :: include_dependencies(:) - s = s // ", include_dependencies=[" - do i = 1, size(source%include_dependencies) - s = s // '"' // source%include_dependencies(i)%s // '"' - if (i < size(source%include_dependencies)) s = s // ", " - end do - s = s // "]" - ! type(string_t), allocatable :: link_libraries(:) - s = s // ", link_libraries=[" - do i = 1, size(source%link_libraries) - s = s // '"' // source%link_libraries(i)%s // '"' - if (i < size(source%link_libraries)) s = s // ", " - end do - s = s // "]" - ! integer(int64) :: digest - s = s // ", digest=" // str(source%digest) - !end type srcfile_t - s = s // ")" -end function info_srcfile - -function info_srcfile_short(source) result(s) - ! Prints a shortened version of srcfile_t - type(srcfile_t), intent(in) :: source - character(:), allocatable :: s - integer :: i - s = "srcfile_t(" - s = s // 'file_name="' // source%file_name // '"' - s = s // ", ...)" -end function info_srcfile_short - -function info_model(model) result(s) - type(fpm_model_t), intent(in) :: model - character(:), allocatable :: s - integer :: i - !type :: fpm_model_t - s = "fpm_model_t(" - ! character(:), allocatable :: package_name - s = s // 'package_name="' // model%package_name // '"' - ! type(srcfile_t), allocatable :: sources(:) - s = s // ", packages=[" - do i = 1, size(model%packages) - s = s // info_package(model%packages(i)) - if (i < size(model%packages)) s = s // ", " - end do - s = s // "]" - ! character(:), allocatable :: fortran_compiler - s = s // ', fortran_compiler="' // model%fortran_compiler // '"' - ! character(:), allocatable :: fortran_compile_flags - s = s // ', fortran_compile_flags="' // model%fortran_compile_flags // '"' - ! character(:), allocatable :: output_directory - s = s // ', output_directory="' // model%output_directory // '"' - ! type(string_t), allocatable :: link_libraries(:) - s = s // ", link_libraries=[" - do i = 1, size(model%link_libraries) - s = s // '"' // model%link_libraries(i)%s // '"' - if (i < size(model%link_libraries)) s = s // ", " - end do - s = s // "]" - ! type(dependency_tree_t) :: deps - ! TODO: print `dependency_tree_t` properly, which should become part of the - ! model, not imported from another file - s = s // ", deps=dependency_tree_t(...)" - !end type fpm_model_t - s = s // ")" -end function info_model - -subroutine show_model(model) - ! Prints a human readable representation of the Model - type(fpm_model_t), intent(in) :: model - print *, info_model(model) -end subroutine show_model - -end module fpm_model diff --git a/fpm/src/fpm_source_parsing.f90 b/fpm/src/fpm_source_parsing.f90 deleted file mode 100644 index dd9a4c5..0000000 --- a/fpm/src/fpm_source_parsing.f90 +++ /dev/null @@ -1,480 +0,0 @@ -!># Parsing of package source files -!> -!> This module exposes two functions, `[[parse_f_source]]` and `[[parse_c_source]]`, -!> which perform a rudimentary parsing of fortran and c source files -!> in order to extract information required for module dependency tracking. -!> -!> Both functions additionally calculate and store a file digest (hash) which -!> is used by the backend ([[fpm_backend]]) to skip compilation of unmodified sources. -!> -!> Both functions return an instance of the [[srcfile_t]] type. -!> -!> For more information, please read the documentation for each function: -!> -!> - `[[parse_f_source]]` -!> - `[[parse_c_source]]` -!> -module fpm_source_parsing -use fpm_error, only: error_t, file_parse_error, fatal_error -use fpm_strings, only: string_t, string_cat, len_trim, split, lower, str_ends_with, fnv_1a -use fpm_model, only: srcfile_t, & - FPM_UNIT_UNKNOWN, FPM_UNIT_PROGRAM, FPM_UNIT_MODULE, & - FPM_UNIT_SUBMODULE, FPM_UNIT_SUBPROGRAM, & - FPM_UNIT_CSOURCE, FPM_UNIT_CHEADER, FPM_SCOPE_UNKNOWN, & - FPM_SCOPE_LIB, FPM_SCOPE_DEP, FPM_SCOPE_APP, FPM_SCOPE_TEST -use fpm_filesystem, only: read_lines -implicit none - -private -public :: parse_f_source, parse_c_source - -character(15), parameter :: INTRINSIC_MODULE_NAMES(*) = & - ['iso_c_binding ', & - 'iso_fortran_env', & - 'ieee_arithmetic', & - 'ieee_exceptions', & - 'ieee_features ', & - 'omp_lib '] - -contains - -!> Parsing of free-form fortran source files -!> -!> The following statements are recognised and parsed: -!> -!> - `Module`/`submodule`/`program` declaration -!> - Module `use` statement -!> - `include` statement -!> -!> @note Intrinsic modules used by sources are not listed in -!> the `modules_used` field of source objects. -!> -!> @note Submodules are treated as normal modules which `use` their -!> corresponding parent modules. -!> -!>### Parsing limitations -!> -!> __Statements must not continued onto another line -!> except for an `only:` list in the `use` statement.__ -!> -!> This is supported: -!> -!>```fortran -!> use my_module, only: & -!> my_var, my_function, my_subroutine -!>``` -!> -!> This is __NOT supported:__ -!> -!>```fortran -!> use & -!> my_module -!>``` -!> -function parse_f_source(f_filename,error) result(f_source) - character(*), intent(in) :: f_filename - type(srcfile_t) :: f_source - type(error_t), allocatable, intent(out) :: error - - 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) - - ! Ignore empty files, returned as FPM_UNIT_UNKNOW - if (len_trim(file_lines) < 1) return - - f_source%digest = fnv_1a(file_lines) - - 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 - ic = index(adjustl(lower(file_lines(i)%s)),'include') - if ( ic == 1 ) then - ic = index(lower(file_lines(i)%s),'include') - if (index(adjustl(file_lines(i)%s(ic+7:)),'"') == 1 .or. & - index(adjustl(file_lines(i)%s(ic+7:)),"'") == 1 ) then - - - n_include = n_include + 1 - - if (pass == 2) then - f_source%include_dependencies(n_include)%s = & - & split_n(file_lines(i)%s,n=2,delims="'"//'"',stat=stat) - if (stat /= 0) then - call file_parse_error(error,f_filename, & - 'unable to find include file name',i, & - file_lines(i)%s) - return - end if - end if - 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' .or. & - scan(mod_name,'=(')>0 ) then - ! Ignore these cases: - ! module procedure * - ! module function * - ! module subroutine * - ! module =* - ! module (i) - 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, index(file_lines(i)%s,mod_name)) - return - end if - - n_mod = n_mod + 1 - - if (pass == 2) then - f_source%modules_provided(n_mod) = string_t(mod_name) - end if - - 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 - - mod_name = split_n(file_lines(i)%s,n=3,delims='()',stat=stat) - if (stat /= 0) then - call file_parse_error(error,f_filename, & - 'unable to get submodule name',i, & - file_lines(i)%s) - return - end if - if (.not.validate_name(mod_name)) then - call file_parse_error(error,f_filename, & - 'empty or invalid name for submodule',i, & - file_lines(i)%s, index(file_lines(i)%s,mod_name)) - return - end if - - n_mod = n_mod + 1 - - 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 - - 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 - - f_source%modules_used(n_use)%s = lower(temp_string) - - f_source%modules_provided(n_mod)%s = lower(mod_name) - - end if - - end if - - ! Detect if contains a program - ! (no modules allowed after program def) - if (index(adjustl(lower(file_lines(i)%s)),'program ') == 1) then - - temp_string = lower(split_n(file_lines(i)%s,n=2,delims=' ',stat=stat)) - if (stat == 0) then - - if (scan(temp_string,'=(')>0 ) then - ! Ignore: - ! program =* - ! program (i) =* - cycle - end if - - end if - - 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 - - -!> Parsing of c source files -!> -!> The following statements are recognised and parsed: -!> -!> - `#include` preprocessor statement -!> -function parse_c_source(c_filename,error) result(c_source) - character(*), intent(in) :: c_filename - type(srcfile_t) :: c_source - type(error_t), allocatable, intent(out) :: error - - 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) - - ! Ignore empty files, returned as FPM_UNIT_UNKNOW - if (len_trim(file_lines) < 1) then - c_source%unit_type = FPM_UNIT_UNKNOWN - return - end if - - c_source%digest = fnv_1a(file_lines) - - do pass = 1,2 - n_include = 0 - file_loop: do i=1,size(file_lines) - - ! Process 'INCLUDE' statements - if (index(adjustl(lower(file_lines(i)%s)),'#include') == 1 .and. & - index(file_lines(i)%s,'"') > 0) then - - 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 - -!> 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 -!> -function split_n(string,delims,n,stat) result(substring) - - 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(adjustl(string_parts(i))) - stat = 0 - -end function split_n - -end module fpm_source_parsing diff --git a/fpm/src/fpm_sources.f90 b/fpm/src/fpm_sources.f90 deleted file mode 100644 index c781535..0000000 --- a/fpm/src/fpm_sources.f90 +++ /dev/null @@ -1,220 +0,0 @@ -!># Discovery of sources -!> -!> This module implements subroutines for building a list of -!> `[[srcfile_t]]` objects by looking for source files in the filesystem. -!> -module fpm_sources -use fpm_error, only: error_t -use fpm_model, only: srcfile_t, FPM_UNIT_PROGRAM -use fpm_filesystem, only: basename, canon_path, dirname, join_path, list_files -use fpm_strings, only: lower, str_ends_with, string_t, operator(.in.) -use fpm_source_parsing, only: parse_f_source, parse_c_source -use fpm_manifest_executable, only: executable_config_t -implicit none - -private -public :: add_sources_from_dir, add_executable_sources - -character(4), parameter :: fortran_suffixes(2) = [".f90", & - ".f "] - -contains - -!> Wrapper to source parsing routines. -!> Selects parsing routine based on source file name extension -function parse_source(source_file_path,error) result(source) - character(*), intent(in) :: source_file_path - type(error_t), allocatable, intent(out) :: error - type(srcfile_t) :: source - - if (str_ends_with(lower(source_file_path), fortran_suffixes)) then - - source = parse_f_source(source_file_path, error) - - if (source%unit_type == FPM_UNIT_PROGRAM) then - source%exe_name = basename(source_file_path,suffix=.false.) - end if - - else if (str_ends_with(lower(source_file_path), [".c", ".h"])) then - - source = parse_c_source(source_file_path,error) - - end if - - if (allocated(error)) then - return - end if - -end function parse_source - -!> Add to `sources` by looking for source files in `directory` -subroutine add_sources_from_dir(sources,directory,scope,with_executables,recurse,error) - !> List of `[[srcfile_t]]` objects to append to. Allocated if not allocated - type(srcfile_t), allocatable, intent(inout), target :: sources(:) - !> Directory in which to search for source files - character(*), intent(in) :: directory - !> Scope to apply to the discovered sources, see [[fpm_model]] for enumeration - integer, intent(in) :: scope - !> Executable sources (fortran `program`s) are ignored unless `with_executables=.true.` - logical, intent(in), optional :: with_executables - !> Whether to recursively search subdirectories, default is `.true.` - logical, intent(in), optional :: recurse - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: i - logical, allocatable :: is_source(:), exclude_source(:) - type(string_t), allocatable :: file_names(:) - type(string_t), allocatable :: src_file_names(:) - type(string_t), allocatable :: existing_src_files(:) - type(srcfile_t), allocatable :: dir_sources(:) - - ! Scan directory for sources - call list_files(directory, file_names,recurse=merge(recurse,.true.,present(recurse))) - - if (allocated(sources)) then - allocate(existing_src_files(size(sources))) - do i=1,size(sources) - existing_src_files(i)%s = canon_path(sources(i)%file_name) - end do - else - allocate(existing_src_files(0)) - end if - - is_source = [(.not.(canon_path(file_names(i)%s) .in. existing_src_files) .and. & - (str_ends_with(lower(file_names(i)%s), fortran_suffixes) .or. & - str_ends_with(lower(file_names(i)%s),[".c",".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) - - dir_sources(i) = parse_source(src_file_names(i)%s,error) - if (allocated(error)) return - - dir_sources(i)%unit_scope = scope - - ! 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. - - 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 - - -!> Add to `sources` using the executable and test entries in the manifest and -!> applies any executable-specific overrides such as `executable%name`. -!> Adds all sources (including modules) from each `executable%source_dir` -subroutine add_executable_sources(sources,executables,scope,auto_discover,error) - !> List of `[[srcfile_t]]` objects to append to. Allocated if not allocated - type(srcfile_t), allocatable, intent(inout), target :: sources(:) - !> List of `[[executable_config_t]]` entries from manifest - class(executable_config_t), intent(in) :: executables(:) - !> Scope to apply to the discovered sources: either `FPM_SCOPE_APP` or `FPM_SCOPE_TEST`, see [[fpm_model]] - integer, intent(in) :: scope - !> If `.false.` only executables and tests specified in the manifest are added to `sources` - logical, intent(in) :: auto_discover - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: i, j - - type(string_t), allocatable :: exe_dirs(:) - type(srcfile_t) :: exe_source - - call get_executable_source_dirs(exe_dirs,executables) - - do i=1,size(exe_dirs) - call add_sources_from_dir(sources,exe_dirs(i)%s, scope, & - with_executables=auto_discover, recurse=.false., error=error) - - if (allocated(error)) then - return - end if - end do - - exe_loop: do i=1,size(executables) - - ! Check if executable already discovered automatically - ! and apply any overrides - do j=1,size(sources) - - if (basename(sources(j)%file_name,suffix=.true.) == executables(i)%main .and.& - canon_path(dirname(sources(j)%file_name)) == & - canon_path(executables(i)%source_dir) ) then - - sources(j)%exe_name = executables(i)%name - if (allocated(executables(i)%link)) then - sources(j)%link_libraries = executables(i)%link - end if - cycle exe_loop - - end if - - end do - - ! Add if not already discovered (auto_discovery off) - exe_source = parse_source(join_path(executables(i)%source_dir,executables(i)%main),error) - exe_source%exe_name = executables(i)%name - if (allocated(executables(i)%link)) then - exe_source%link_libraries = executables(i)%link - end if - exe_source%unit_scope = scope - - if (allocated(error)) return - - if (.not.allocated(sources)) then - sources = [exe_source] - else - sources = [sources, exe_source] - end if - - end do exe_loop - -end subroutine add_executable_sources - -!> Build a list of unique source directories -!> from executables specified in manifest -subroutine get_executable_source_dirs(exe_dirs,executables) - type(string_t), allocatable, intent(inout) :: exe_dirs(:) - class(executable_config_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 - -end module fpm_sources diff --git a/fpm/src/fpm_strings.f90 b/fpm/src/fpm_strings.f90 deleted file mode 100644 index 3d7d7b1..0000000 --- a/fpm/src/fpm_strings.f90 +++ /dev/null @@ -1,924 +0,0 @@ -!> This module defines general procedures for **string operations** for both CHARACTER and -!! TYPE(STRING_T) variables -! -!>## general routines for performing __string operations__ -!! -!!### Types -!! - **TYPE(STRING_T)** define a type to contain strings of variable length -!!### Type Conversions -!! - [[F_STRING]] return Fortran **CHARACTER** variable when given a C-like array of -!! single characters terminated with a C_NULL_CHAR **CHARACTER** -!! - [[STR]] Converts **INTEGER** or** LOGICAL** to **CHARACTER** string -!!### Case -!! - [[LOWER]] Changes a string to lowercase over optional specified column range -!!### Parsing and joining -!! - [[SPLIT]] parse string on delimiter characters and store tokens into an allocatable array -!! - [[STRING_CAT]] Concatenate an array of **type(string_t)** into a single **CHARACTER** variable -!! - [[JOIN]] append an array of **CHARACTER** variables into a single **CHARACTER** variable -!!### Testing -!! - [[STR_ENDS_WITH]] test if a **CHARACTER** string or array ends with a specified suffix -!! - [[STRING_ARRAY_CONTAINS]] Check if array of **TYPE(STRING_T)** matches a particular **CHARACTER** string -!! - **OPERATOR(.IN.)** Check if array of **TYPE(STRING_T)** matches a particular **CHARACTER** string -!! - [[GLOB]] function compares text strings, one of which can have wildcards ('*' or '?'). -!!### Miscellaneous -!! - [[LEN_TRIM]] Determine total trimmed length of **STRING_T** array -!! - [[FNV_1A]] Hash a **CHARACTER(*)** string of default kind or a **TYPE(STRING_T)** array -!! - [[REPLACE]] Returns string with characters in charset replaced with target_char. -!! - [[RESIZE]] increase the size of a **TYPE(STRING_T)** array by N elements -!! - -module fpm_strings -use iso_fortran_env, only: int64 -implicit none - -private -public :: f_string, lower, split, str_ends_with, string_t -public :: string_array_contains, string_cat, len_trim, operator(.in.), fnv_1a -public :: replace, resize, str, join, glob - -type string_t - character(len=:), allocatable :: s -end type - -interface len_trim - module procedure :: string_len_trim -end interface len_trim - -interface resize - module procedure :: resize_string -end interface - -interface operator(.in.) - module procedure string_array_contains -end interface - -interface fnv_1a - procedure :: fnv_1a_char - procedure :: fnv_1a_string_t -end interface fnv_1a - -interface str_ends_with - procedure :: str_ends_with_str - procedure :: str_ends_with_any -end interface str_ends_with - -interface str - module procedure str_int, str_int64, str_logical -end interface - -interface string_t - module procedure new_string_t -end interface string_t - -contains - -!> test if a CHARACTER string ends with a specified suffix -pure logical function str_ends_with_str(s, e) result(r) - character(*), intent(in) :: s, e - integer :: n1, n2 - n1 = len(s)-len(e)+1 - n2 = len(s) - if (n1 < 1) then - r = .false. - else - r = (s(n1:n2) == e) - end if -end function str_ends_with_str - -!> test if a CHARACTER string ends with any of an array of suffixs -pure logical function str_ends_with_any(s, e) result(r) - character(*), intent(in) :: s - character(*), intent(in) :: e(:) - - integer :: i - - r = .true. - do i=1,size(e) - - if (str_ends_with(s,trim(e(i)))) return - - end do - r = .false. - -end function str_ends_with_any - -!> return Fortran character variable when given a C-like array of -!! single characters terminated with a C_NULL_CHAR character -function f_string(c_string) - 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 - - -!> Hash a character(*) string of default kind -pure function fnv_1a_char(input, seed) result(hash) - character(*), intent(in) :: input - integer(int64), intent(in), optional :: seed - integer(int64) :: hash - - integer :: i - integer(int64), parameter :: FNV_OFFSET_32 = 2166136261_int64 - integer(int64), parameter :: FNV_PRIME_32 = 16777619_int64 - - if (present(seed)) then - hash = seed - else - hash = FNV_OFFSET_32 - end if - - do i=1,len(input) - hash = ieor(hash,iachar(input(i:i),int64)) * FNV_PRIME_32 - end do - -end function fnv_1a_char - - -!> Hash a string_t array of default kind -pure function fnv_1a_string_t(input, seed) result(hash) - type(string_t), intent(in) :: input(:) - integer(int64), intent(in), optional :: seed - integer(int64) :: hash - - integer :: i - - hash = fnv_1a(input(1)%s,seed) - - do i=2,size(input) - hash = fnv_1a(input(i)%s,hash) - end do - -end function fnv_1a_string_t - - - !>Author: John S. Urban - !!License: Public Domain - !! Changes a string to lowercase over optional specified column range -elemental pure function lower(str,begin,end) result (string) - - 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 - -!> Helper function to generate a new string_t instance -!> (Required due to the allocatable component) -function new_string_t(s) result(string) - character(*), intent(in) :: s - type(string_t) :: string - - string%s = s - -end function new_string_t - -!> Check if array of TYPE(STRING_T) matches a particular CHARACTER string -!! -logical function string_array_contains(search_string,array) - 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 - -!> Concatenate an array of type(string_t) into -!> a single CHARACTER variable -function string_cat(strings,delim) result(cat) - type(string_t), intent(in) :: strings(:) - character(*), intent(in), optional :: delim - character(:), allocatable :: cat - - integer :: i - character(:), allocatable :: delim_str - - if (size(strings) < 1) then - cat = '' - return - end if - - if (present(delim)) then - delim_str = delim - else - delim_str = '' - end if - - cat = strings(1)%s - do i=2,size(strings) - - cat = cat//delim_str//strings(i)%s - - end do - -end function string_cat - -!> Determine total trimmed length of `string_t` array -pure function string_len_trim(strings) result(n) - type(string_t), intent(in) :: strings(:) - integer :: i, n - - n = 0 - do i=1,size(strings) - n = n + len_trim(strings(i)%s) - end do - -end function string_len_trim - -!>Author: John S. Urban -!!License: Public Domain -!! parse string on delimiter characters and store tokens into an allocatable array -subroutine split(input_line,array,delimiters,order,nulls) - !! given a line of structure " par1 par2 par3 ... parn " store each par(n) into a separate variable in array. - !! - !! * by default adjacent delimiters in the input string do not create an empty string in the output array - !! * no quoting of delimiters is supported - character(len=*),intent(in) :: input_line !! input string to tokenize - character(len=*),optional,intent(in) :: delimiters !! list of delimiter characters - character(len=*),optional,intent(in) :: order !! order of output array sequential|[reverse|right] - character(len=*),optional,intent(in) :: nulls !! return strings composed of delimiters or not ignore|return|ignoreend - character(len=:),allocatable,intent(out) :: array(:) !! output array of tokens - - 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 - -!> Returns string with characters in charset replaced with target_char. -pure function replace(string, charset, target_char) result(res) - character(*), intent(in) :: string - character, intent(in) :: charset(:), target_char - character(len(string)) :: res - integer :: n - res = string - do n = 1, len(string) - if (any(string(n:n) == charset)) then - res(n:n) = target_char - end if - end do -end function replace - -!> increase the size of a TYPE(STRING_T) array by N elements -subroutine resize_string(list, n) - !> Instance of the array to be resized - type(string_t), allocatable, intent(inout) :: list(:) - !> Dimension of the final array size - integer, intent(in), optional :: n - - type(string_t), allocatable :: tmp(:) - integer :: this_size, new_size, i - integer, parameter :: initial_size = 16 - - if (allocated(list)) then - this_size = size(list, 1) - call move_alloc(list, tmp) - else - this_size = initial_size - end if - - if (present(n)) then - new_size = n - else - new_size = this_size + this_size/2 + 1 - end if - - allocate(list(new_size)) - - if (allocated(tmp)) then - this_size = min(size(tmp, 1), size(list, 1)) - do i = 1, this_size - call move_alloc(tmp(i)%s, list(i)%s) - end do - deallocate(tmp) - end if - -end subroutine resize_string - -!>AUTHOR: John S. Urban -!!LICENSE: Public Domain -!> -!!##NAME -!! join(3f) - [M_strings:EDITING] append CHARACTER variable array into -!! a single CHARACTER variable with specified separator -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! pure function join(str,sep,trm,left,right,start,end) result (string) -!! -!! character(len=*),intent(in) :: str(:) -!! character(len=*),intent(in),optional :: sep -!! logical,intent(in),optional :: trm -!! character(len=*),intent(in),optional :: right -!! character(len=*),intent(in),optional :: left -!! character(len=*),intent(in),optional :: start -!! character(len=*),intent(in),optional :: end -!! character(len=:),allocatable :: string -!! -!!##DESCRIPTION -!! JOIN(3f) appends the elements of a CHARACTER array into a single -!! CHARACTER variable, with elements 1 to N joined from left to right. -!! By default each element is trimmed of trailing spaces and the -!! default separator is a null string. -!! -!!##OPTIONS -!! STR(:) array of CHARACTER variables to be joined -!! SEP separator string to place between each variable. defaults -!! to a null string. -!! LEFT string to place at left of each element -!! RIGHT string to place at right of each element -!! START prefix string -!! END suffix string -!! TRM option to trim each element of STR of trailing -!! spaces. Defaults to .TRUE. -!! -!!##RESULT -!! STRING CHARACTER variable composed of all of the elements of STR() -!! appended together with the optional separator SEP placed -!! between the elements. -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_join -!! use M_strings, only: join -!! implicit none -!! character(len=:),allocatable :: s(:) -!! character(len=:),allocatable :: out -!! integer :: i -!! s=[character(len=10) :: 'United',' we',' stand,', & -!! & ' divided',' we fall.'] -!! out=join(s) -!! write(*,'(a)') out -!! write(*,'(a)') join(s,trm=.false.) -!! write(*,'(a)') (join(s,trm=.false.,sep='|'),i=1,3) -!! write(*,'(a)') join(s,sep='<>') -!! write(*,'(a)') join(s,sep=';',left='[',right=']') -!! write(*,'(a)') join(s,left='[',right=']') -!! write(*,'(a)') join(s,left='>>') -!! end program demo_join -!! -!! Expected output: -!! -!! United we stand, divided we fall. -!! United we stand, divided we fall. -!! United | we | stand, | divided | we fall. -!! United | we | stand, | divided | we fall. -!! United | we | stand, | divided | we fall. -!! United<> we<> stand,<> divided<> we fall. -!! [United];[ we];[ stand,];[ divided];[ we fall.] -!! [United][ we][ stand,][ divided][ we fall.] -!! >>United>> we>> stand,>> divided>> we fall. -pure function join(str,sep,trm,left,right,start,end) result (string) - -! @(#)M_strings::join(3f): merge string array into a single CHARACTER value adding specified separators, caps, prefix and suffix - -character(len=*),intent(in) :: str(:) -character(len=*),intent(in),optional :: sep, right, left, start, end -logical,intent(in),optional :: trm -character(len=:),allocatable :: sep_local, left_local, right_local -character(len=:),allocatable :: string -logical :: trm_local -integer :: i - if(present(sep))then ; sep_local=sep ; else ; sep_local='' ; endif - if(present(trm))then ; trm_local=trm ; else ; trm_local=.true. ; endif - if(present(left))then ; left_local=left ; else ; left_local='' ; endif - if(present(right))then ; right_local=right ; else ; right_local='' ; endif - string='' - if(size(str).eq.0)then - string=string//left_local//right_local - else - do i = 1,size(str)-1 - if(trm_local)then - string=string//left_local//trim(str(i))//right_local//sep_local - else - string=string//left_local//str(i)//right_local//sep_local - endif - enddo - if(trm_local)then - string=string//left_local//trim(str(i))//right_local - else - string=string//left_local//str(i)//right_local - endif - endif - if(present(start))string=start//string - if(present(end))string=string//end -end function join - -!>##AUTHOR John S. Urban -!!##LICENSE Public Domain -!!## NAME -!! glob(3f) - [fpm_strings:COMPARE] compare given string for match to -!! pattern which may contain wildcard characters -!! (LICENSE:PD) -!! -!!## SYNOPSIS -!! -!! logical function glob(string, pattern ) -!! -!! character(len=*),intent(in) :: string -!! character(len=*),intent(in) :: pattern -!! -!!## DESCRIPTION -!! glob(3f) compares given STRING for match to PATTERN which may -!! contain wildcard characters. -!! -!! In this version to get a match the entire string must be described -!! by PATTERN. Trailing whitespace is significant, so trim the input -!! string to have trailing whitespace ignored. -!! -!!## OPTIONS -!! string the input string to test to see if it contains the pattern. -!! pattern the following simple globbing options are available -!! -!! o "?" matching any one character -!! o "*" matching zero or more characters. -!! Do NOT use adjacent asterisks. -!! o Both strings may have trailing spaces which -!! are ignored. -!! o There is no escape character, so matching strings with -!! literal question mark and asterisk is problematic. -!! -!!## EXAMPLES -!! -!! Example program -!! -!! program demo_glob -!! implicit none -!! ! This main() routine passes a bunch of test strings -!! ! into the above code. In performance comparison mode, -!! ! it does that over and over. Otherwise, it does it just -!! ! once. Either way, it outputs a passed/failed result. -!! ! -!! integer :: nReps -!! logical :: allpassed -!! integer :: i -!! allpassed = .true. -!! -!! nReps = 10000 -!! ! Can choose as many repetitions as you're expecting -!! ! in the real world. -!! nReps = 1 -!! -!! do i=1,nReps -!! ! Cases with repeating character sequences. -!! allpassed=allpassed .and. test("a*abab", "a*b", .true.) -!! !!cycle -!! allpassed=allpassed .and. test("ab", "*?", .true.) -!! allpassed=allpassed .and. test("abc", "*?", .true.) -!! allpassed=allpassed .and. test("abcccd", "*ccd", .true.) -!! allpassed=allpassed .and. test("bLah", "bLaH", .false.) -!! allpassed=allpassed .and. test("mississippi", "*sip*", .true.) -!! allpassed=allpassed .and. & -!! & test("xxxx*zzzzzzzzy*f", "xxx*zzy*f", .true.) -!! allpassed=allpassed .and. & -!! & test("xxxx*zzzzzzzzy*f", "xxxx*zzy*fffff", .false.) -!! allpassed=allpassed .and. & -!! & test("mississipissippi", "*issip*ss*", .true.) -!! allpassed=allpassed .and. & -!! & test("xxxxzzzzzzzzyf", "xxxx*zzy*fffff", .false.) -!! allpassed=allpassed .and. & -!! & test("xxxxzzzzzzzzyf", "xxxx*zzy*f", .true.) -!! allpassed=allpassed .and. test("xyxyxyzyxyz", "xy*z*xyz", .true.) -!! allpassed=allpassed .and. test("xyxyxyxyz", "xy*xyz", .true.) -!! allpassed=allpassed .and. test("mississippi", "mi*sip*", .true.) -!! allpassed=allpassed .and. test("ababac", "*abac*", .true.) -!! allpassed=allpassed .and. test("aaazz", "a*zz*", .true.) -!! allpassed=allpassed .and. test("a12b12", "*12*23", .false.) -!! allpassed=allpassed .and. test("a12b12", "a12b", .false.) -!! allpassed=allpassed .and. test("a12b12", "*12*12*", .true.) -!! -!! ! Additional cases where the '*' char appears in the tame string. -!! allpassed=allpassed .and. test("*", "*", .true.) -!! allpassed=allpassed .and. test("a*r", "a*", .true.) -!! allpassed=allpassed .and. test("a*ar", "a*aar", .false.) -!! -!! ! More double wildcard scenarios. -!! allpassed=allpassed .and. test("XYXYXYZYXYz", "XY*Z*XYz", .true.) -!! allpassed=allpassed .and. test("missisSIPpi", "*SIP*", .true.) -!! allpassed=allpassed .and. test("mississipPI", "*issip*PI", .true.) -!! allpassed=allpassed .and. test("xyxyxyxyz", "xy*xyz", .true.) -!! allpassed=allpassed .and. test("miSsissippi", "mi*sip*", .true.) -!! allpassed=allpassed .and. test("miSsissippi", "mi*Sip*", .false.) -!! allpassed=allpassed .and. test("abAbac", "*Abac*", .true.) -!! allpassed=allpassed .and. test("aAazz", "a*zz*", .true.) -!! allpassed=allpassed .and. test("A12b12", "*12*23", .false.) -!! allpassed=allpassed .and. test("a12B12", "*12*12*", .true.) -!! allpassed=allpassed .and. test("oWn", "*oWn*", .true.) -!! -!! ! Completely tame (no wildcards) cases. -!! allpassed=allpassed .and. test("bLah", "bLah", .true.) -!! -!! ! Simple mixed wildcard tests suggested by IBMer Marlin Deckert. -!! allpassed=allpassed .and. test("a", "*?", .true.) -!! -!! ! More mixed wildcard tests including coverage for false positives. -!! allpassed=allpassed .and. test("a", "??", .false.) -!! allpassed=allpassed .and. test("ab", "?*?", .true.) -!! allpassed=allpassed .and. test("ab", "*?*?*", .true.) -!! allpassed=allpassed .and. test("abc", "?**?*?", .true.) -!! allpassed=allpassed .and. test("abc", "?**?*&?", .false.) -!! allpassed=allpassed .and. test("abcd", "?b*??", .true.) -!! allpassed=allpassed .and. test("abcd", "?a*??", .false.) -!! allpassed=allpassed .and. test("abcd", "?**?c?", .true.) -!! allpassed=allpassed .and. test("abcd", "?**?d?", .false.) -!! allpassed=allpassed .and. test("abcde", "?*b*?*d*?", .true.) -!! -!! ! Single-character-match cases. -!! allpassed=allpassed .and. test("bLah", "bL?h", .true.) -!! allpassed=allpassed .and. test("bLaaa", "bLa?", .false.) -!! allpassed=allpassed .and. test("bLah", "bLa?", .true.) -!! allpassed=allpassed .and. test("bLaH", "?Lah", .false.) -!! allpassed=allpassed .and. test("bLaH", "?LaH", .true.) -!! -!! ! Many-wildcard scenarios. -!! allpassed=allpassed .and. test(& -!! &"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa& -!! &aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaab",& -!! &"a*a*a*a*a*a*aa*aaa*a*a*b",& -!! &.true.) -!! allpassed=allpassed .and. test(& -!! &"abababababababababababababababababababaacacacacacacac& -!! &adaeafagahaiajakalaaaaaaaaaaaaaaaaaffafagaagggagaaaaaaaab",& -!! &"*a*b*ba*ca*a*aa*aaa*fa*ga*b*",& -!! &.true.) -!! allpassed=allpassed .and. test(& -!! &"abababababababababababababababababababaacacacacacaca& -!! &cadaeafagahaiajakalaaaaaaaaaaaaaaaaaffafagaagggagaaaaaaaab",& -!! &"*a*b*ba*ca*a*x*aaa*fa*ga*b*",& -!! &.false.) -!! allpassed=allpassed .and. test(& -!! &"abababababababababababababababababababaacacacacacacacad& -!! &aeafagahaiajakalaaaaaaaaaaaaaaaaaffafagaagggagaaaaaaaab",& -!! &"*a*b*ba*ca*aaaa*fa*ga*gggg*b*",& -!! &.false.) -!! allpassed=allpassed .and. test(& -!! &"abababababababababababababababababababaacacacacacacacad& -!! &aeafagahaiajakalaaaaaaaaaaaaaaaaaffafagaagggagaaaaaaaab",& -!! &"*a*b*ba*ca*aaaa*fa*ga*ggg*b*",& -!! &.true.) -!! allpassed=allpassed .and. test("aaabbaabbaab", "*aabbaa*a*", .true.) -!! allpassed=allpassed .and. & -!! test("a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*",& -!! &"a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*", .true.) -!! allpassed=allpassed .and. test("aaaaaaaaaaaaaaaaa",& -!! &"*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*", .true.) -!! allpassed=allpassed .and. test("aaaaaaaaaaaaaaaa",& -!! &"*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*", .false.) -!! allpassed=allpassed .and. test(& -!! &"abc*abcd*abcde*abcdef*abcdefg*abcdefgh*abcdefghi*abcdefghij& -!! &*abcdefghijk*abcdefghijkl*abcdefghijklm*abcdefghijklmn",& -!! & "abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abc& -!! &*abc*abc*abc*",& -!! &.false.) -!! allpassed=allpassed .and. test(& -!! &"abc*abcd*abcde*abcdef*abcdefg*abcdefgh*abcdefghi*abcdefghij& -!! &*abcdefghijk*abcdefghijkl*abcdefghijklm*abcdefghijklmn",& -!! &"abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*",& -!! &.true.) -!! allpassed=allpassed .and. test("abc*abcd*abcd*abc*abcd",& -!! &"abc*abc*abc*abc*abc", .false.) -!! allpassed=allpassed .and. test( "abc*abcd*abcd*abc*abcd*abcd& -!! &*abc*abcd*abc*abc*abcd", & -!! &"abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abcd",& -!! &.true.) -!! allpassed=allpassed .and. test("abc",& -!! &"********a********b********c********", .true.) -!! allpassed=allpassed .and.& -!! &test("********a********b********c********", "abc", .false.) -!! allpassed=allpassed .and. & -!! &test("abc", "********a********b********b********", .false.) -!! allpassed=allpassed .and. test("*abc*", "***a*b*c***", .true.) -!! -!! ! A case-insensitive algorithm test. -!! ! allpassed=allpassed .and. test("mississippi", "*issip*PI", .true.) -!! enddo -!! -!! if (allpassed)then -!! write(*,'(a)')"Passed",nReps -!! else -!! write(*,'(a)')"Failed" -!! endif -!! contains -!! ! This is a test program for wildcard matching routines. -!! ! It can be used either to test a single routine for correctness, -!! ! or to compare the timings of two (or more) different wildcard -!! ! matching routines. -!! ! -!! function test(tame, wild, bExpectedResult) result(bpassed) -!! use fpm_strings, only : glob -!! character(len=*) :: tame -!! character(len=*) :: wild -!! logical :: bExpectedResult -!! logical :: bResult -!! logical :: bPassed -!! bResult = .true. ! We'll do "&=" cumulative checking. -!! bPassed = .false. ! Assume the worst. -!! write(*,*)repeat('=',79) -!! bResult = glob(tame, wild) ! Call a wildcard matching routine. -!! -!! ! To assist correctness checking, output the two strings in any -!! ! failing scenarios. -!! if (bExpectedResult .eqv. bResult) then -!! bPassed = .true. -!! if(nReps == 1) write(*,*)"Passed match on ",tame," vs. ", wild -!! else -!! if(nReps == 1) write(*,*)"Failed match on ",tame," vs. ", wild -!! endif -!! -!! end function test -!! end program demo_glob -!! -!! Expected output -!! -!! -!!## REFERENCE -!! The article "Matching Wildcards: An Empirical Way to Tame an Algorithm" -!! in Dr Dobb's Journal, By Kirk J. Krauss, October 07, 2014 -!! -function glob(tame,wild) - -! @(#)fpm_strings::glob(3f): function compares text strings, one of which can have wildcards ('*' or '?'). - -logical :: glob !! result of test -character(len=*) :: tame !! A string without wildcards to compare to the globbing expression -character(len=*) :: wild !! A (potentially) corresponding string with wildcards -character(len=len(tame)+1) :: tametext -character(len=len(wild)+1) :: wildtext -character(len=1),parameter :: NULL=char(0) -integer :: wlen -integer :: ti, wi -integer :: i -character(len=:),allocatable :: tbookmark, wbookmark -! These two values are set when we observe a wildcard character. They -! represent the locations, in the two strings, from which we start once we've observed it. - tametext=tame//NULL - wildtext=wild//NULL - tbookmark = NULL - wbookmark = NULL - wlen=len(wild) - wi=1 - ti=1 - do ! Walk the text strings one character at a time. - if(wildtext(wi:wi) == '*')then ! How do you match a unique text string? - do i=wi,wlen ! Easy: unique up on it! - if(wildtext(wi:wi).eq.'*')then - wi=wi+1 - else - exit - endif - enddo - if(wildtext(wi:wi).eq.NULL) then ! "x" matches "*" - glob=.true. - return - endif - if(wildtext(wi:wi) .ne. '?') then - ! Fast-forward to next possible match. - do while (tametext(ti:ti) .ne. wildtext(wi:wi)) - ti=ti+1 - if (tametext(ti:ti).eq.NULL)then - glob=.false. - return ! "x" doesn't match "*y*" - endif - enddo - endif - wbookmark = wildtext(wi:) - tbookmark = tametext(ti:) - elseif(tametext(ti:ti) .ne. wildtext(wi:wi) .and. wildtext(wi:wi) .ne. '?') then - ! Got a non-match. If we've set our bookmarks, back up to one or both of them and retry. - if(wbookmark.ne.NULL) then - if(wildtext(wi:).ne. wbookmark) then - wildtext = wbookmark; - wlen=len_trim(wbookmark) - wi=1 - ! Don't go this far back again. - if (tametext(ti:ti) .ne. wildtext(wi:wi)) then - tbookmark=tbookmark(2:) - tametext = tbookmark - ti=1 - cycle ! "xy" matches "*y" - else - wi=wi+1 - endif - endif - if (tametext(ti:ti).ne.NULL) then - ti=ti+1 - cycle ! "mississippi" matches "*sip*" - endif - endif - glob=.false. - return ! "xy" doesn't match "x" - endif - ti=ti+1 - wi=wi+1 - if (tametext(ti:ti).eq.NULL) then ! How do you match a tame text string? - if(wildtext(wi:wi).ne.NULL)then - do while (wildtext(wi:wi) == '*') ! The tame way: unique up on it! - wi=wi+1 ! "x" matches "x*" - if(wildtext(wi:wi).eq.NULL)exit - enddo - endif - if (wildtext(wi:wi).eq.NULL)then - glob=.true. - return ! "x" matches "x" - endif - glob=.false. - return ! "x" doesn't match "xy" - endif - enddo -end function glob - -!> Returns the length of the string representation of 'i' -pure integer function str_int_len(i) result(sz) -integer, intent(in) :: i -integer, parameter :: MAX_STR = 100 -character(MAX_STR) :: s -! If 's' is too short (MAX_STR too small), Fortran will abort with: -! "Fortran runtime error: End of record" -write(s, '(i0)') i -sz = len_trim(s) -end function - -!> Converts integer "i" to string -pure function str_int(i) result(s) -integer, intent(in) :: i -character(len=str_int_len(i)) :: s -write(s, '(i0)') i -end function - -!> Returns the length of the string representation of 'i' -pure integer function str_int64_len(i) result(sz) -integer(int64), intent(in) :: i -integer, parameter :: MAX_STR = 100 -character(MAX_STR) :: s -! If 's' is too short (MAX_STR too small), Fortran will abort with: -! "Fortran runtime error: End of record" -write(s, '(i0)') i -sz = len_trim(s) -end function - -!> Converts integer "i" to string -pure function str_int64(i) result(s) -integer(int64), intent(in) :: i -character(len=str_int64_len(i)) :: s -write(s, '(i0)') i -end function - -!> Returns the length of the string representation of 'l' -pure integer function str_logical_len(l) result(sz) -logical, intent(in) :: l -if (l) then - sz = 6 -else - sz = 7 -end if -end function - -!> Converts logical "l" to string -pure function str_logical(l) result(s) -logical, intent(in) :: l -character(len=str_logical_len(l)) :: s -if (l) then - s = ".true." -else - s = ".false." -end if -end function - -end module fpm_strings diff --git a/fpm/src/fpm_targets.f90 b/fpm/src/fpm_targets.f90 deleted file mode 100644 index 02bb600..0000000 --- a/fpm/src/fpm_targets.f90 +++ /dev/null @@ -1,553 +0,0 @@ -!># Build target handling -!> -!> This module handles the construction of the build target list -!> from the sources list (`[[targets_from_sources]]`), the -!> resolution of module-dependencies between build targets -!> (`[[resolve_module_dependencies]]`), and the enumeration of -!> objects required for link targets (`[[resolve_target_linking]]`). -!> -!> A build target (`[[build_target_t]]`) is a file to be generated -!> by the backend (compilation and linking). -!> -!> @note The current implementation is ignorant to the existence of -!> module files (`.mod`,`.smod`). Dependencies arising from modules -!> are based on the corresponding object files (`.o`) only. -!> -!> For more information, please read the documentation for the procedures: -!> -!> - `[[build_target_list]]` -!> - `[[resolve_module_dependencies]]` -!> -!>### Enumerations -!> -!> __Target type:__ `FPM_TARGET_*` -!> Describes the type of build target — determines backend build rules -!> -module fpm_targets -use iso_fortran_env, only: int64 -use fpm_error, only: error_t, fatal_error -use fpm_model -use fpm_environment, only: get_os_type, OS_WINDOWS -use fpm_filesystem, only: dirname, join_path, canon_path -use fpm_strings, only: string_t, operator(.in.), string_cat -implicit none - -private - -public FPM_TARGET_UNKNOWN, FPM_TARGET_EXECUTABLE, & - FPM_TARGET_ARCHIVE, FPM_TARGET_OBJECT -public build_target_t, build_target_ptr -public targets_from_sources, resolve_module_dependencies -public resolve_target_linking, add_target, add_dependency - - - -!> Target type is unknown (ignored) -integer, parameter :: FPM_TARGET_UNKNOWN = -1 -!> Target type is executable -integer, parameter :: FPM_TARGET_EXECUTABLE = 1 -!> Target type is library archive -integer, parameter :: FPM_TARGET_ARCHIVE = 2 -!> Target type is compiled object -integer, parameter :: FPM_TARGET_OBJECT = 3 - - -!> Wrapper type for constructing arrays of `[[build_target_t]]` pointers -type build_target_ptr - - type(build_target_t), pointer :: ptr => null() - -end type build_target_ptr - - -!> Type describing a generated build target -type build_target_t - - !> File path of build target object relative to cwd - character(:), allocatable :: output_file - - !> Primary source for this build target - type(srcfile_t), allocatable :: source - - !> Resolved build dependencies - type(build_target_ptr), allocatable :: dependencies(:) - - !> Target type - integer :: target_type = FPM_TARGET_UNKNOWN - - !> Native libraries to link against - type(string_t), allocatable :: link_libraries(:) - - !> Objects needed to link this target - type(string_t), allocatable :: link_objects(:) - - !> Link flags for this build target - character(:), allocatable :: link_flags - - !> Compile flags for this build target - character(:), allocatable :: compile_flags - - !> Flag set when first visited to check for circular dependencies - logical :: touched = .false. - - !> Flag set if build target is sorted for building - logical :: sorted = .false. - - !> Flag set if build target will be skipped (not built) - logical :: skip = .false. - - !> Targets in the same schedule group are guaranteed to be independent - integer :: schedule = -1 - - !> Previous source file hash - integer(int64), allocatable :: digest_cached - -end type build_target_t - - -contains - -!> High-level wrapper to generate build target information -subroutine targets_from_sources(targets,model,error) - - !> The generated list of build targets - type(build_target_ptr), intent(out), allocatable :: targets(:) - - !> The package model from which to construct the target list - type(fpm_model_t), intent(inout), target :: model - - !> Error structure - type(error_t), intent(out), allocatable :: error - - call build_target_list(targets,model) - - call resolve_module_dependencies(targets,error) - if (allocated(error)) return - - call resolve_target_linking(targets,model) - -end subroutine targets_from_sources - - -!> Constructs a list of build targets from a list of source files -!> -!>### Source-target mapping -!> -!> One compiled object target (`FPM_TARGET_OBJECT`) is generated for each -!> non-executable source file (`FPM_UNIT_MODULE`,`FPM_UNIT_SUBMODULE`, -!> `FPM_UNIT_SUBPROGRAM`,`FPM_UNIT_CSOURCE`). -!> -!> If any source file has scope `FPM_SCOPE_LIB` (*i.e.* there are library sources) -!> then the first target in the target list will be a library archive target -!> (`FPM_TARGET_ARCHIVE`). The archive target will have a dependency on every -!> compiled object target corresponding to a library source file. -!> -!> One compiled object target (`FPM_TARGET_OBJECT`) and one executable target (`FPM_TARGET_EXECUTABLE`) is -!> generated for each exectuable source file (`FPM_UNIT_PROGRAM`). The exectuble target -!> always has a dependency on the corresponding compiled object target. If there -!> is a library, then the executable target has an additional dependency on the library -!> archive target. -!> -subroutine build_target_list(targets,model) - - !> The generated list of build targets - type(build_target_ptr), intent(out), allocatable :: targets(:) - - !> The package model from which to construct the target list - type(fpm_model_t), intent(inout), target :: model - - integer :: i, j, n_source - character(:), allocatable :: xsuffix, exe_dir - type(build_target_t), pointer :: dep - logical :: with_lib - - ! Check for empty build (e.g. header-only lib) - n_source = sum([(size(model%packages(j)%sources), & - j=1,size(model%packages))]) - - if (n_source < 1) then - allocate(targets(0)) - return - end if - - if (get_os_type() == OS_WINDOWS) then - xsuffix = '.exe' - else - xsuffix = '' - end if - - with_lib = any([((model%packages(j)%sources(i)%unit_scope == FPM_SCOPE_LIB, & - i=1,size(model%packages(j)%sources)), & - j=1,size(model%packages))]) - - if (with_lib) call add_target(targets,type = FPM_TARGET_ARCHIVE,& - output_file = join_path(model%output_directory,& - model%package_name,'lib'//model%package_name//'.a')) - - do j=1,size(model%packages) - - associate(sources=>model%packages(j)%sources) - - do i=1,size(sources) - - select case (sources(i)%unit_type) - case (FPM_UNIT_MODULE,FPM_UNIT_SUBMODULE,FPM_UNIT_SUBPROGRAM,FPM_UNIT_CSOURCE) - - call add_target(targets,source = sources(i), & - type = FPM_TARGET_OBJECT,& - output_file = get_object_name(sources(i))) - - if (with_lib .and. sources(i)%unit_scope == FPM_SCOPE_LIB) then - ! Archive depends on object - call add_dependency(targets(1)%ptr, targets(size(targets))%ptr) - end if - - case (FPM_UNIT_PROGRAM) - - call add_target(targets,type = FPM_TARGET_OBJECT,& - output_file = get_object_name(sources(i)), & - source = sources(i) & - ) - - if (sources(i)%unit_scope == FPM_SCOPE_APP) then - - exe_dir = 'app' - - else if (sources(i)%unit_scope == FPM_SCOPE_EXAMPLE) then - - exe_dir = 'example' - - else - - exe_dir = 'test' - - end if - - call add_target(targets,type = FPM_TARGET_EXECUTABLE,& - link_libraries = sources(i)%link_libraries, & - output_file = join_path(model%output_directory,exe_dir, & - sources(i)%exe_name//xsuffix)) - - ! Executable depends on object - call add_dependency(targets(size(targets))%ptr, targets(size(targets)-1)%ptr) - - if (with_lib) then - ! Executable depends on library - call add_dependency(targets(size(targets))%ptr, targets(1)%ptr) - end if - - end select - - end do - - end associate - - end do - - contains - - function get_object_name(source) result(object_file) - ! Generate object target path from source name and model params - ! - ! - type(srcfile_t), intent(in) :: source - character(:), allocatable :: object_file - - integer :: i - character(1), parameter :: filesep = '/' - character(:), allocatable :: dir - - object_file = canon_path(source%file_name) - - ! Convert any remaining directory separators to underscores - i = index(object_file,filesep) - do while(i > 0) - object_file(i:i) = '_' - i = index(object_file,filesep) - end do - - object_file = join_path(model%output_directory,model%package_name,object_file)//'.o' - - end function get_object_name - -end subroutine build_target_list - - -!> Allocate a new target and append to target list -subroutine add_target(targets,type,output_file,source,link_libraries) - type(build_target_ptr), allocatable, intent(inout) :: targets(:) - integer, intent(in) :: type - character(*), intent(in) :: output_file - type(srcfile_t), intent(in), optional :: source - type(string_t), intent(in), optional :: link_libraries(:) - - integer :: i - type(build_target_ptr), allocatable :: temp(:) - type(build_target_t), pointer :: new_target - - if (.not.allocated(targets)) allocate(targets(0)) - - ! Check for duplicate outputs - do i=1,size(targets) - - if (targets(i)%ptr%output_file == output_file) then - - write(*,*) 'Error while building target list: duplicate output object "',& - output_file,'"' - if (present(source)) write(*,*) ' Source file: "',source%file_name,'"' - stop 1 - - end if - - end do - - allocate(new_target) - new_target%target_type = type - new_target%output_file = output_file - if (present(source)) new_target%source = source - if (present(link_libraries)) new_target%link_libraries = link_libraries - allocate(new_target%dependencies(0)) - - targets = [targets, build_target_ptr(new_target)] - -end subroutine add_target - - -!> Add pointer to dependeny in target%dependencies -subroutine add_dependency(target, dependency) - type(build_target_t), intent(inout) :: target - type(build_target_t) , intent(in), target :: dependency - - target%dependencies = [target%dependencies, build_target_ptr(dependency)] - -end subroutine add_dependency - - -!> Add dependencies to source-based targets (`FPM_TARGET_OBJECT`) -!> based on any modules used by the corresponding source file. -!> -!>### Source file scoping -!> -!> Source files are assigned a scope of either `FPM_SCOPE_LIB`, -!> `FPM_SCOPE_APP` or `FPM_SCOPE_TEST`. The scope controls which -!> modules may be used by the source file: -!> -!> - Library sources (`FPM_SCOPE_LIB`) may only use modules -!> also with library scope. This includes library modules -!> from dependencies. -!> -!> - Executable sources (`FPM_SCOPE_APP`,`FPM_SCOPE_TEST`) may use -!> library modules (including dependencies) as well as any modules -!> corresponding to source files in the same directory or a -!> subdirectory of the executable source file. -!> -!> @warning If a module used by a source file cannot be resolved to -!> a source file in the package of the correct scope, then a __fatal error__ -!> is returned by the procedure and model construction fails. -!> -subroutine resolve_module_dependencies(targets,error) - type(build_target_ptr), intent(inout), target :: targets(:) - type(error_t), allocatable, intent(out) :: error - - type(build_target_ptr) :: dep - - integer :: i, j - - do i=1,size(targets) - - if (.not.allocated(targets(i)%ptr%source)) cycle - - do j=1,size(targets(i)%ptr%source%modules_used) - - if (targets(i)%ptr%source%modules_used(j)%s .in. targets(i)%ptr%source%modules_provided) then - ! Dependency satisfied in same file, skip - cycle - end if - - if (any(targets(i)%ptr%source%unit_scope == & - [FPM_SCOPE_APP, FPM_SCOPE_EXAMPLE, FPM_SCOPE_TEST])) then - dep%ptr => & - find_module_dependency(targets,targets(i)%ptr%source%modules_used(j)%s, & - include_dir = dirname(targets(i)%ptr%source%file_name)) - else - dep%ptr => & - find_module_dependency(targets,targets(i)%ptr%source%modules_used(j)%s) - end if - - if (.not.associated(dep%ptr)) then - call fatal_error(error, & - 'Unable to find source for module dependency: "' // & - targets(i)%ptr%source%modules_used(j)%s // & - '" used by "'//targets(i)%ptr%source%file_name//'"') - return - end if - - call add_dependency(targets(i)%ptr, dep%ptr) - - end do - - end do - -end subroutine resolve_module_dependencies - -function find_module_dependency(targets,module_name,include_dir) result(target_ptr) - ! Find a module dependency in the library or a dependency library - ! - ! 'include_dir' specifies an allowable non-library search directory - ! (Used for executable dependencies) - ! - type(build_target_ptr), intent(in), target :: targets(:) - character(*), intent(in) :: module_name - character(*), intent(in), optional :: include_dir - type(build_target_t), pointer :: target_ptr - - integer :: k, l - - target_ptr => NULL() - - do k=1,size(targets) - - if (.not.allocated(targets(k)%ptr%source)) cycle - - do l=1,size(targets(k)%ptr%source%modules_provided) - - if (module_name == targets(k)%ptr%source%modules_provided(l)%s) then - select case(targets(k)%ptr%source%unit_scope) - case (FPM_SCOPE_LIB, FPM_SCOPE_DEP) - target_ptr => targets(k)%ptr - exit - case default - if (present(include_dir)) then - if (index(dirname(targets(k)%ptr%source%file_name), include_dir) == 1) then ! source file is within the include_dir or a subdirectory - target_ptr => targets(k)%ptr - exit - end if - end if - end select - end if - - end do - - end do - -end function find_module_dependency - - -!> Construct the linker flags string for each target -!> `target%link_flags` includes non-library objects and library flags -!> -subroutine resolve_target_linking(targets, model) - type(build_target_ptr), intent(inout), target :: targets(:) - type(fpm_model_t), intent(in) :: model - - integer :: i - character(:), allocatable :: global_link_flags - character(:), allocatable :: global_compile_flags - - if (size(targets) == 0) return - - if (targets(1)%ptr%target_type == FPM_TARGET_ARCHIVE) then - global_link_flags = targets(1)%ptr%output_file - else - allocate(character(0) :: global_link_flags) - end if - - global_compile_flags = model%fortran_compile_flags - - if (allocated(model%link_libraries)) then - if (size(model%link_libraries) > 0) then - global_link_flags = global_link_flags // " -l" // string_cat(model%link_libraries," -l") - end if - end if - - if (allocated(model%include_dirs)) then - if (size(model%include_dirs) > 0) then - global_compile_flags = global_compile_flags // & - & " -I" // string_cat(model%include_dirs," -I") - end if - end if - - do i=1,size(targets) - - associate(target => targets(i)%ptr) - - target%compile_flags = global_compile_flags - - allocate(target%link_objects(0)) - - if (target%target_type == FPM_TARGET_ARCHIVE) then - - call get_link_objects(target%link_objects,target,is_exe=.false.) - - allocate(character(0) :: target%link_flags) - - else if (target%target_type == FPM_TARGET_EXECUTABLE) then - - call get_link_objects(target%link_objects,target,is_exe=.true.) - - target%link_flags = string_cat(target%link_objects," ") - - if (allocated(target%link_libraries)) then - if (size(target%link_libraries) > 0) then - target%link_flags = target%link_flags // " -l" // string_cat(target%link_libraries," -l") - end if - end if - - target%link_flags = target%link_flags//" "//global_link_flags - - end if - - end associate - - end do - -contains - - !> Wrapper to build link object list - !> - !> For libraries: just list dependency objects of lib target - !> - !> For executables: need to recursively discover non-library - !> dependency objects. (i.e. modules in same dir as program) - !> - recursive subroutine get_link_objects(link_objects,target,is_exe) - type(string_t), intent(inout), allocatable :: link_objects(:) - type(build_target_t), intent(in) :: target - logical, intent(in) :: is_exe - - integer :: i - type(string_t) :: temp_str - - if (.not.allocated(target%dependencies)) return - - do i=1,size(target%dependencies) - - associate(dep => target%dependencies(i)%ptr) - - if (.not.allocated(dep%source)) cycle - - ! Skip library dependencies for executable targets - ! since the library archive will always be linked - if (is_exe.and.(dep%source%unit_scope == FPM_SCOPE_LIB)) cycle - - ! Skip if dependency object already listed - if (dep%output_file .in. link_objects) cycle - - ! Add dependency object file to link object list - temp_str%s = dep%output_file - link_objects = [link_objects, temp_str] - - ! For executable objects, also need to include non-library - ! dependencies from dependencies (recurse) - if (is_exe) call get_link_objects(link_objects,dep,is_exe=.true.) - - end associate - - end do - - end subroutine get_link_objects - -end subroutine resolve_target_linking - - -end module fpm_targets diff --git a/fpm/test/cli_test/cli_test.f90 b/fpm/test/cli_test/cli_test.f90 deleted file mode 100644 index d979f1a..0000000 --- a/fpm/test/cli_test/cli_test.f90 +++ /dev/null @@ -1,236 +0,0 @@ -program main - -! for each set of command options, call this command recursively which will print the resulting parameters with a -! given test command CMD from the TEST() array. -! -! Then read the expected values as a NAMELIST group from the test array and compare the expected -! results with the actual results. -! -! the PARSE() subroutine is a copy of the app/main.f90 program except it creates and writes a NAMELIST file instead -! of actually calling the subcommands. -! -! The program will exit with a non-zero status if any of the tests fail - -use, intrinsic :: iso_fortran_env, only : compiler_version, compiler_options -implicit none - -! convenient arbitrary sizes for test - -! assuming no name over 15 characters to make output have shorter lines -character(len=15),allocatable :: name(:),act_name(:) ; namelist/act_cli/act_name -integer,parameter :: max_names=10 - -character(len=:),allocatable :: command -character(len=:),allocatable :: cmd -integer :: cstat, estat -integer :: act_cstat, act_estat -integer :: i, ios -logical :: w_e,act_w_e ; namelist/act_cli/act_w_e -logical :: w_t,act_w_t ; namelist/act_cli/act_w_t - -character(len=63) :: profile,act_profile ; namelist/act_cli/act_profile -character(len=:),allocatable :: args,act_args ; namelist/act_cli/act_args -namelist/expected/cmd,cstat,estat,w_e,w_t,name,profile,args -integer :: lun -logical,allocatable :: tally(:) -logical,allocatable :: subtally(:) -character(len=256) :: message - -! table of arguments to pass to program and expected non-default values for that execution in NAMELIST group format -character(len=*),parameter :: tests(*)= [ character(len=256) :: & - -'CMD="new", ESTAT=1,', & -!'CMD="new -unknown", ESTAT=2,', & -'CMD="new my_project another yet_another -test", ESTAT=2,', & -'CMD="new my_project --app", W_E=T, NAME="my_project",', & -'CMD="new my_project --app --test", W_E=T,W_T=T, NAME="my_project",', & -'CMD="new my_project --test", W_T=T, NAME="my_project",', & -'CMD="new my_project", W_E=T,W_T=T, NAME="my_project",', & - -'CMD="run", ', & -'CMD="run my_project", NAME="my_project", ', & -'CMD="run proj1 p2 project3", NAME="proj1","p2","project3", ', & -'CMD="run proj1 p2 project3 --profile debug", NAME="proj1","p2","project3",profile="debug",', & -'CMD="run proj1 p2 project3 --profile release", NAME="proj1","p2","project3",profile="release",', & -'CMD="run proj1 p2 project3 --profile release -- arg1 -x ""and a long one""", & - &NAME="proj1","p2","project3",profile="release",ARGS="""arg1"" -x ""and a long one""", ', & - -'CMD="test", ', & -'CMD="test my_project", NAME="my_project", ', & -'CMD="test proj1 p2 project3", NAME="proj1","p2","project3", ', & -'CMD="test proj1 p2 project3 --profile debug", NAME="proj1","p2","project3",profile="debug",', & -'CMD="test proj1 p2 project3 --profile release", NAME="proj1","p2","project3",profile="release",', & -'CMD="test proj1 p2 project3 --profile release -- arg1 -x ""and a long one""", & - &NAME="proj1","p2","project3",profile="release" ARGS="""arg1"" -x ""and a long one""", ', & - -'CMD="build", NAME= profile="",ARGS="",', & -'CMD="build --profile release", NAME= profile="release",ARGS="",', & -' ' ] -character(len=256) :: readme(3) - -readme(1)='&EXPECTED' ! top and bottom line for a NAMELIST group read from TEST() used to set the expected values -readme(3)=' /' -tally=[logical ::] ! an array that tabulates the command test results as pass or fail. - -if(command_argument_count().eq.0)then ! assume if called with no arguments to do the tests. This means you cannot - ! have a test of no parameters. Could improve on this. - ! if called with parameters assume this is a test and call the routine to - ! parse the resulting values after calling the CLI command line parser - ! and write the NAMELIST group so it can be read and tested against the - ! expected results - write(*,*)'start tests of the CLI command line parser' - command=repeat(' ',4096) - call get_command_argument(0,command) - command=trim(command) - write(*,*)'command=',command - - do i=1,size(tests) - if(tests(i).eq.' ')then - open(file='_test_cli',newunit=lun,delim='quote') - close(unit=lun,status='delete') - exit - endif - ! blank out name group EXPECTED - name=[(repeat(' ',len(name)),i=1,max_names)] ! the words on the command line sans the subcommand name - profile="" ! --profile PROF - w_e=.false. ! --app - w_t=.false. ! --test - args=repeat(' ',132) ! -- ARGS - cmd=repeat(' ',132) ! the command line arguments to test - cstat=0 ! status values from EXECUTE_COMMAND_LINE() - estat=0 - readme(2)=' '//tests(i) ! select command options to test for CMD and set nondefault expected values - read(readme,nml=expected) - - write(*,'(*(g0))')'START: TEST ',i,' CMD=',trim(cmd) - ! call this program which will crack command line and write results to scratch file _test_cli - call execute_command_line(command//' '//trim(cmd),cmdstat=act_cstat,exitstat=act_estat) - if(cstat.eq.act_cstat.and.estat.eq.act_estat)then - if(estat.eq.0)then - open(file='_test_cli',newunit=lun,delim='quote') - act_name=[(repeat(' ',len(act_name)),i=1,max_names)] - act_profile='' - act_w_e=.false. - act_w_t=.false. - act_args=repeat(' ',132) - read(lun,nml=act_cli,iostat=ios,iomsg=message) - if(ios.ne.0)then - write(*,'(a)')'ERROR:',trim(message) - endif - close(unit=lun) - ! compare results to expected values - subtally=[logical ::] - call test_test('NAME',all(act_name.eq.name)) - call test_test('PROFILE',act_profile.eq.profile) - call test_test('WITH_EXPECTED',act_w_e.eqv.w_e) - call test_test('WITH_TESTED',act_w_t.eqv.w_t) - call test_test('WITH_TEST',act_w_t.eqv.w_t) - call test_test('ARGS',act_args.eq.args) - if(all(subtally))then - write(*,'(*(g0))')'PASSED: TEST ',i,' STATUS: expected ',cstat,' ',estat,' actual ',act_cstat,' ',act_estat,& - & ' for [',trim(cmd),']' - tally=[tally,.true.] - else - write(*,'(*(g0))')'FAILED: TEST ',i,' STATUS: expected ',cstat,' ',estat,' actual ',act_cstat,' ',act_estat,& - & ' for [',trim(cmd),']' - print '(4a)', & - 'This file was compiled by ', & - compiler_version(), & - ' using the options ', & - compiler_options() - write(*,nml=act_cli,delim='quote') - tally=[tally,.false.] - endif - else - write(*,'(*(g0))')'PASSED: TEST ',i,' EXPECTED BAD STATUS: expected ',cstat,' ',estat, & - ' actual ',act_cstat,' ',act_estat,' for [',trim(cmd),']' - tally=[tally,.true.] - endif - else - write(*,'(*(g0))')'FAILED: TEST ',i,'BAD STATUS: expected ',cstat,' ',estat,' actual ',act_cstat,' ',act_estat,& - ' for [',trim(cmd),']' - tally=[tally,.false.] - endif - enddo - ! write up total results and if anything failed exit with a non-zero status - write(*,'(*(g0))')'TALLY;',tally - if(all(tally))then - write(*,'(*(g0))')'PASSED: all ',count(tally),' tests passed ' - else - write(*,*)'FAILED: PASSED=',count(tally),' FAILED=',count(.not.tally) - stop 4 - endif -else - ! call this program with arguments - !============================================= - debugit: block - integer :: j, ilen - character(len=256) :: big_argument - write(*,*)'arguments seen directly by program' - do j=1,command_argument_count() - call get_command_argument(number=j,value=big_argument,length=ilen) - write(*,'(*(g0))')j,'[',big_argument(:ilen),']' - enddo - end block debugit - !============================================= - call parse() -endif - -contains - -subroutine test_test(name,tst) -character(len=*) :: name -logical,intent(in) :: tst - !!write(*,'(*(g0,1x))')' SUBTEST ',name,' ',merge('PASSED','FAILED',tst) - subtally=[subtally,tst] -end subroutine test_test - -subroutine parse() -! all the extended types for settings from the main program -use fpm_command_line, only: & - fpm_cmd_settings, & - fpm_new_settings, & - fpm_build_settings, & - fpm_run_settings, & - fpm_test_settings, & - fpm_install_settings, & - get_command_line_settings -use fpm, only: cmd_build, cmd_run -use fpm_cmd_install, only: cmd_install -use fpm_cmd_new, only: cmd_new -class(fpm_cmd_settings), allocatable :: cmd_settings -! duplicates the calls as seen in the main program for fpm -call get_command_line_settings(cmd_settings) - -allocate (character(len=len(name)) :: act_name(0) ) -act_args='' -act_w_e=.false. -act_w_t=.false. -act_profile='' - -select type(settings=>cmd_settings) -type is (fpm_new_settings) - act_w_e=settings%with_executable - act_w_t=settings%with_test - act_name=[trim(settings%name)] -type is (fpm_build_settings) - act_profile=settings%profile -type is (fpm_run_settings) - act_profile=settings%profile - act_name=settings%name - act_args=settings%args -type is (fpm_test_settings) - act_profile=settings%profile - act_name=settings%name - act_args=settings%args -type is (fpm_install_settings) -end select - -open(file='_test_cli',newunit=lun,delim='quote') -write(lun,nml=act_cli,delim='quote') -!!write(*,nml=act_cli) -close(unit=lun) - -end subroutine parse - -end program main diff --git a/fpm/test/fpm_test/main.f90 b/fpm/test/fpm_test/main.f90 deleted file mode 100644 index 0a65307..0000000 --- a/fpm/test/fpm_test/main.f90 +++ /dev/null @@ -1,106 +0,0 @@ -!> Driver for unit testing -program fpm_testing - use, intrinsic :: iso_fortran_env, only : error_unit - use testsuite, only : run_testsuite, new_testsuite, testsuite_t, & - & select_suite, run_selected - use test_toml, only : collect_toml - use test_manifest, only : collect_manifest - use test_filesystem, only : collect_filesystem - use test_source_parsing, only : collect_source_parsing - use test_module_dependencies, only : collect_module_dependencies - use test_package_dependencies, only : collect_package_dependencies - use test_backend, only: collect_backend - use test_installer, only : collect_installer - use test_versioning, only : collect_versioning - implicit none - integer :: stat, is - character(len=:), allocatable :: suite_name, test_name - type(testsuite_t), allocatable :: suite(:) - character(len=*), parameter :: fmt = '("#", *(1x, a))' - - stat = 0 - - suite = [ & - & new_testsuite("fpm_toml", collect_toml), & - & new_testsuite("fpm_manifest", collect_manifest), & - & new_testsuite("fpm_filesystem", collect_filesystem), & - & new_testsuite("fpm_source_parsing", collect_source_parsing), & - & new_testsuite("fpm_module_dependencies", collect_module_dependencies), & - & new_testsuite("fpm_package_dependencies", collect_package_dependencies), & - & new_testsuite("fpm_test_backend", collect_backend), & - & new_testsuite("fpm_installer", collect_installer), & - & new_testsuite("fpm_versioning", collect_versioning) & - & ] - - call get_argument(1, suite_name) - call get_argument(2, test_name) - - if (allocated(suite_name)) then - is = select_suite(suite, suite_name) - if (is > 0 .and. is <= size(suite)) then - if (allocated(test_name)) then - write(error_unit, fmt) "Suite:", suite(is)%name - call run_selected(suite(is)%collect, test_name, error_unit, stat) - if (stat < 0) then - error stop 1 - end if - else - write(error_unit, fmt) "Testing:", suite(is)%name - call run_testsuite(suite(is)%collect, error_unit, stat) - end if - else - write(error_unit, fmt) "Available testsuites" - do is = 1, size(suite) - write(error_unit, fmt) "-", suite(is)%name - end do - error stop 1 - end if - else - do is = 1, size(suite) - write(error_unit, fmt) "Testing:", suite(is)%name - call run_testsuite(suite(is)%collect, error_unit, stat) - end do - end if - - if (stat > 0) then - write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" - error stop 1 - end if - - -contains - - - !> Obtain the command line argument at a given index - subroutine get_argument(idx, arg) - - !> Index of command line argument, range [0:command_argument_count()] - integer, intent(in) :: idx - - !> Command line argument - character(len=:), allocatable, intent(out) :: arg - - integer :: length, stat - - call get_command_argument(idx, length=length, status=stat) - if (stat /= 0) then - return - endif - - allocate(character(len=length) :: arg, stat=stat) - if (stat /= 0) then - return - endif - - if (length > 0) then - call get_command_argument(idx, arg, status=stat) - if (stat /= 0) then - deallocate(arg) - return - end if - end if - - end subroutine get_argument - - -end program fpm_testing diff --git a/fpm/test/fpm_test/test_backend.f90 b/fpm/test/fpm_test/test_backend.f90 deleted file mode 100644 index 662e470..0000000 --- a/fpm/test/fpm_test/test_backend.f90 +++ /dev/null @@ -1,353 +0,0 @@ -!> Define tests for the `fpm_backend` module (build scheduling) -module test_backend - use testsuite, only : new_unittest, unittest_t, error_t, test_failed - use test_module_dependencies, only: operator(.in.) - use fpm_filesystem, only: exists, mkdir, get_temp_filename - use fpm_targets, only: build_target_t, build_target_ptr, & - FPM_TARGET_OBJECT, FPM_TARGET_ARCHIVE, & - add_target, add_dependency - use fpm_backend, only: sort_target, schedule_targets - implicit none - private - - public :: collect_backend - -contains - - - !> Collect all exported unit tests - subroutine collect_backend(testsuite) - - !> Collection of tests - type(unittest_t), allocatable, intent(out) :: testsuite(:) - - testsuite = [ & - & new_unittest("target-sort", test_target_sort), & - & new_unittest("target-sort-skip-all", test_target_sort_skip_all), & - & new_unittest("target-sort-rebuild-all", test_target_sort_rebuild_all), & - & new_unittest("schedule-targets", test_schedule_targets), & - & new_unittest("schedule-targets-empty", test_schedule_empty) & - ] - - end subroutine collect_backend - - - !> Check scheduling of objects with dependencies - subroutine test_target_sort(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(build_target_ptr), allocatable :: targets(:) - - integer :: i - - targets = new_test_package() - - ! Perform depth-first topological sort of targets - do i=1,size(targets) - - call sort_target(targets(i)%ptr) - - end do - - ! Check target states: all targets scheduled - do i=1,size(targets) - - if (.not.targets(i)%ptr%touched) then - call test_failed(error,"Target touched flag not set") - return - end if - - if (.not.targets(i)%ptr%sorted) then - call test_failed(error,"Target sort flag not set") - return - end if - - if (targets(i)%ptr%skip) then - call test_failed(error,"Target skip flag set incorrectly") - return - end if - - if (targets(i)%ptr%schedule < 0) then - call test_failed(error,"Target schedule not set") - return - end if - - end do - - ! Check all objects sheduled before library - do i=2,size(targets) - - if (targets(i)%ptr%schedule >= targets(1)%ptr%schedule) then - call test_failed(error,"Object dependency scheduled after dependent library target") - return - end if - - end do - - ! Check target 4 schedule before targets 2 & 3 - do i=2,3 - if (targets(4)%ptr%schedule >= targets(i)%ptr%schedule) then - call test_failed(error,"Object dependency scheduled after dependent object target") - return - end if - end do - - end subroutine test_target_sort - - - - !> Check incremental rebuild for existing archive - !> all object sources are unmodified: all objects should be skipped - subroutine test_target_sort_skip_all(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(build_target_ptr), allocatable :: targets(:) - - integer :: fh, i - - targets = new_test_package() - - do i=2,size(targets) - - ! Mimick unmodified sources - allocate(targets(i)%ptr%source) - targets(i)%ptr%source%digest = i - targets(i)%ptr%digest_cached = i - - end do - - ! Mimick archive already exists - open(newunit=fh,file=targets(1)%ptr%output_file,status="unknown") - close(fh) - - ! Perform depth-first topological sort of targets - do i=1,size(targets) - - call sort_target(targets(i)%ptr) - - end do - - ! Check target states: all targets skipped - do i=1,size(targets) - - if (.not.targets(i)%ptr%touched) then - call test_failed(error,"Target touched flag not set") - return - end if - - if (targets(i)%ptr%sorted) then - call test_failed(error,"Target sort flag set incorrectly") - return - end if - - if (.not.targets(i)%ptr%skip) then - call test_failed(error,"Target skip flag set incorrectly") - return - end if - - end do - - end subroutine test_target_sort_skip_all - - - !> Check incremental rebuild for existing archive - !> all but lowest source modified: all objects should be rebuilt - subroutine test_target_sort_rebuild_all(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(build_target_ptr), allocatable :: targets(:) - - integer :: fh, i - - targets = new_test_package() - - do i=2,3 - - ! Mimick unmodified sources - allocate(targets(i)%ptr%source) - targets(i)%ptr%source%digest = i - targets(i)%ptr%digest_cached = i - - end do - - ! Mimick archive already exists - open(newunit=fh,file=targets(1)%ptr%output_file,status="unknown") - close(fh) - - ! Perform depth-first topological sort of targets - do i=1,size(targets) - - call sort_target(targets(i)%ptr) - - end do - - ! Check target states: all targets scheduled - do i=1,size(targets) - - if (.not.targets(i)%ptr%sorted) then - call test_failed(error,"Target sort flag not set") - return - end if - - if (targets(i)%ptr%skip) then - call test_failed(error,"Target skip flag set incorrectly") - return - end if - - end do - - end subroutine test_target_sort_rebuild_all - - - !> Check construction of target queue and schedule - subroutine test_schedule_targets(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(build_target_ptr), allocatable :: targets(:) - - integer :: i, j - type(build_target_ptr), allocatable :: queue(:) - integer, allocatable :: schedule_ptr(:) - - targets = new_test_package() - - ! Perform depth-first topological sort of targets - do i=1,size(targets) - - call sort_target(targets(i)%ptr) - - end do - - ! Construct build schedule queue - call schedule_targets(queue, schedule_ptr, targets) - - ! Check all targets enqueued - do i=1,size(targets) - - if (.not.(targets(i)%ptr.in.queue)) then - - call test_failed(error,"Target not found in build queue") - return - - end if - - end do - - ! Check schedule structure - if (schedule_ptr(1) /= 1) then - - call test_failed(error,"schedule_ptr(1) does not point to start of the queue") - return - - end if - - if (schedule_ptr(size(schedule_ptr)) /= size(queue)+1) then - - call test_failed(error,"schedule_ptr(end) does not point to end of the queue") - return - - end if - - do i=1,size(schedule_ptr)-1 - - do j=schedule_ptr(i),(schedule_ptr(i+1)-1) - - if (queue(j)%ptr%schedule /= i) then - - call test_failed(error,"Target scheduled in the wrong region") - return - - end if - - end do - - end do - - end subroutine test_schedule_targets - - - !> Check construction of target queue and schedule - !> when there's nothing to do (all targets skipped) - subroutine test_schedule_empty(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(build_target_ptr), allocatable :: targets(:) - - integer :: i - type(build_target_ptr), allocatable :: queue(:) - integer, allocatable :: schedule_ptr(:) - - targets = new_test_package() - - do i=1,size(targets) - - targets(i)%ptr%skip = .true. - - end do - - ! Perform depth-first topological sort of targets - do i=1,size(targets) - - call sort_target(targets(i)%ptr) - - end do - - ! Construct build schedule queue - call schedule_targets(queue, schedule_ptr, targets) - - ! Check queue is empty - if (size(queue) > 0) then - - call test_failed(error,"Expecting an empty build queue, but not empty") - return - - end if - - ! Check schedule loop is not entered - do i=1,size(schedule_ptr)-1 - - call test_failed(error,"Attempted to run an empty schedule") - return - - end do - - end subroutine test_schedule_empty - - - !> Helper to generate target objects with dependencies - function new_test_package() result(targets) - - type(build_target_ptr), allocatable :: targets(:) - - call add_target(targets,FPM_TARGET_ARCHIVE,get_temp_filename()) - - call add_target(targets,FPM_TARGET_OBJECT,get_temp_filename()) - - call add_target(targets,FPM_TARGET_OBJECT,get_temp_filename()) - - call add_target(targets,FPM_TARGET_OBJECT,get_temp_filename()) - - ! Library depends on all objects - call add_dependency(targets(1)%ptr,targets(2)%ptr) - call add_dependency(targets(1)%ptr,targets(3)%ptr) - call add_dependency(targets(1)%ptr,targets(4)%ptr) - - ! Inter-object dependency - ! targets 2 & 3 depend on target 4 - call add_dependency(targets(2)%ptr,targets(4)%ptr) - call add_dependency(targets(3)%ptr,targets(4)%ptr) - - end function new_test_package - - -end module test_backend \ No newline at end of file diff --git a/fpm/test/fpm_test/test_filesystem.f90 b/fpm/test/fpm_test/test_filesystem.f90 deleted file mode 100644 index 5a7e18a..0000000 --- a/fpm/test/fpm_test/test_filesystem.f90 +++ /dev/null @@ -1,106 +0,0 @@ -module test_filesystem - use testsuite, only : new_unittest, unittest_t, error_t, test_failed - use fpm_filesystem, only: canon_path - implicit none - private - - public :: collect_filesystem - -contains - - - !> Collect all exported unit tests - subroutine collect_filesystem(testsuite) - - !> Collection of tests - type(unittest_t), allocatable, intent(out) :: testsuite(:) - - testsuite = [ & - & new_unittest("canon-path", test_canon_path) & - ] - - end subroutine collect_filesystem - - - subroutine test_canon_path(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - call check_string(error, & - & canon_path("git/project/src/origin"), "git/project/src/origin") - if (allocated(error)) return - - call check_string(error, & - & canon_path("./project/src/origin"), "project/src/origin") - if (allocated(error)) return - - call check_string(error, & - & canon_path("./project/src///origin/"), "project/src/origin") - if (allocated(error)) return - - call check_string(error, & - & canon_path("../project/./src/origin/"), "../project/src/origin") - if (allocated(error)) return - - call check_string(error, & - & canon_path("/project//src/origin/"), "/project/src/origin") - if (allocated(error)) return - - call check_string(error, & - & canon_path("/project/src/../origin/"), "/project/origin") - if (allocated(error)) return - - call check_string(error, & - & canon_path("/project/src/../origin/.."), "/project") - if (allocated(error)) return - - call check_string(error, & - & canon_path("/project/src//../origin/."), "/project/origin") - if (allocated(error)) return - - call check_string(error, & - & canon_path("../project/src/./../origin/."), "../project/origin") - if (allocated(error)) return - - call check_string(error, & - & canon_path("../project/src/../../../origin/."), "../../origin") - if (allocated(error)) return - - call check_string(error, & - & canon_path("/../.."), "/") - if (allocated(error)) return - - call check_string(error, & - & canon_path("././././././/////a/b/.///././////.///c/../../../"), ".") - if (allocated(error)) return - - call check_string(error, & - & canon_path("/./././././/////a/b/.///././////.///c/../../../"), "/") - if (allocated(error)) return - - end subroutine test_canon_path - - - !> Check a character variable against a reference value - subroutine check_string(error, actual, expected) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - !> Actual string value - character(len=*), intent(in) :: actual - - !> Expected string value - character(len=*), intent(in) :: expected - - if (actual /= expected) then - call test_failed(error, & - "Character value missmatch "//& - "expected '"//expected//"' but got '"//actual//"'") - end if - - end subroutine check_string - - -end module test_filesystem diff --git a/fpm/test/fpm_test/test_installer.f90 b/fpm/test/fpm_test/test_installer.f90 deleted file mode 100644 index 1235ba5..0000000 --- a/fpm/test/fpm_test/test_installer.f90 +++ /dev/null @@ -1,168 +0,0 @@ -!> Define tests for the `fpm_installer` module -!> -!> The tests here setup a mock environment to allow testing for Unix and Windows -!> platforms at the same time. -module test_installer - use testsuite, only : new_unittest, unittest_t, error_t, test_failed, & - & check_string - use fpm_environment, only : OS_WINDOWS, OS_LINUX - use fpm_filesystem, only : join_path - use fpm_installer - implicit none - private - - public :: collect_installer - - - type, extends(installer_t) :: mock_installer_t - character(len=:), allocatable :: expected_dir - character(len=:), allocatable :: expected_run - contains - procedure :: make_dir - procedure :: run - end type mock_installer_t - -contains - - !> Collect all exported unit tests - subroutine collect_installer(testsuite) - !> Collection of tests - type(unittest_t), allocatable, intent(out) :: testsuite(:) - - testsuite = [ & - & new_unittest("install-lib", test_install_lib), & - & new_unittest("install-pkgconfig", test_install_pkgconfig), & - & new_unittest("install-sitepackages", test_install_sitepackages), & - & new_unittest("install-mod", test_install_mod), & - & new_unittest("install-exe-unix", test_install_exe_unix), & - & new_unittest("install-exe-win", test_install_exe_win)] - - end subroutine collect_installer - - subroutine test_install_exe_unix(error) - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(mock_installer_t) :: mock - type(installer_t) :: installer - - call new_installer(installer, prefix="PREFIX", verbosity=0, copy="mock") - mock%installer_t = installer - mock%os = OS_LINUX - mock%expected_dir = "PREFIX/bin" - mock%expected_run = 'mock "name" "'//mock%expected_dir//'"' - - call mock%install_executable("name", error) - - end subroutine test_install_exe_unix - - subroutine test_install_exe_win(error) - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(mock_installer_t) :: mock - type(installer_t) :: installer - - call new_installer(installer, prefix="PREFIX", verbosity=0, copy="mock") - mock%installer_t = installer - mock%os = OS_WINDOWS - mock%expected_dir = "PREFIX\bin" - mock%expected_run = 'mock "name.exe" "'//mock%expected_dir//'"' - - call mock%install_executable("name", error) - - end subroutine test_install_exe_win - - subroutine test_install_lib(error) - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(mock_installer_t) :: mock - type(installer_t) :: installer - - call new_installer(installer, prefix="PREFIX", verbosity=0, copy="mock") - mock%installer_t = installer - mock%expected_dir = join_path("PREFIX", "lib") - mock%expected_run = 'mock "name" "'//join_path("PREFIX", "lib")//'"' - - call mock%install_library("name", error) - - end subroutine test_install_lib - - subroutine test_install_pkgconfig(error) - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(mock_installer_t) :: mock - type(installer_t) :: installer - - call new_installer(installer, prefix="PREFIX", verbosity=0, copy="mock") - mock%installer_t = installer - mock%os = OS_WINDOWS - mock%expected_dir = "PREFIX\lib\pkgconfig" - mock%expected_run = 'mock "name" "'//mock%expected_dir//'"' - - call mock%install("name", "lib/pkgconfig", error) - - end subroutine test_install_pkgconfig - - subroutine test_install_sitepackages(error) - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(mock_installer_t) :: mock - type(installer_t) :: installer - - call new_installer(installer, prefix="PREFIX", verbosity=0, copy="mock") - mock%installer_t = installer - mock%os = OS_LINUX - mock%expected_dir = "PREFIX/lib/python3.7/site-packages" - mock%expected_run = 'mock "name" "'//mock%expected_dir//'"' - - call mock%install("name", join_path("lib", "python3.7", "site-packages"), & - error) - - end subroutine test_install_sitepackages - - subroutine test_install_mod(error) - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(mock_installer_t) :: mock - type(installer_t) :: installer - - call new_installer(installer, prefix="PREFIX", verbosity=0, copy="mock") - mock%installer_t = installer - mock%expected_dir = join_path("PREFIX", "include") - mock%expected_run = 'mock "name" "'//join_path("PREFIX", "include")//'"' - - call mock%install_header("name", error) - - end subroutine test_install_mod - - !> Create a new directory in the prefix - subroutine make_dir(self, dir, error) - !> Instance of the installer - class(mock_installer_t), intent(inout) :: self - !> Directory to be created - character(len=*), intent(in) :: dir - !> Error handling - type(error_t), allocatable, intent(out) :: error - - call check_string(error, self%expected_dir, dir, "dir") - - end subroutine make_dir - - !> Run an installation command - subroutine run(self, command, error) - !> Instance of the installer - class(mock_installer_t), intent(inout) :: self - !> Command to be launched - character(len=*), intent(in) :: command - !> Error handling - type(error_t), allocatable, intent(out) :: error - - call check_string(error, self%expected_run, command, "run") - end subroutine run - -end module test_installer diff --git a/fpm/test/fpm_test/test_manifest.f90 b/fpm/test/fpm_test/test_manifest.f90 deleted file mode 100644 index 94e5e07..0000000 --- a/fpm/test/fpm_test/test_manifest.f90 +++ /dev/null @@ -1,1085 +0,0 @@ -!> Define tests for the `fpm_manifest` modules -module test_manifest - use fpm_filesystem, only: get_temp_filename - use testsuite, only : new_unittest, unittest_t, error_t, test_failed, & - & check_string - use fpm_manifest - use fpm_strings, only: operator(.in.) - implicit none - private - - public :: collect_manifest - - -contains - - - !> Collect all exported unit tests - subroutine collect_manifest(testsuite) - - !> Collection of tests - type(unittest_t), allocatable, intent(out) :: testsuite(:) - - testsuite = [ & - & new_unittest("valid-manifest", test_valid_manifest), & - & new_unittest("invalid-manifest", test_invalid_manifest, should_fail=.true.), & - & new_unittest("default-library", test_default_library), & - & new_unittest("default-executable", test_default_executable), & - & new_unittest("dependency-empty", test_dependency_empty, should_fail=.true.), & - & new_unittest("dependency-pathtag", test_dependency_pathtag, should_fail=.true.), & - & new_unittest("dependency-gitpath", test_dependency_gitpath, should_fail=.true.), & - & new_unittest("dependency-nourl", test_dependency_nourl, should_fail=.true.), & - & new_unittest("dependency-gitconflict", test_dependency_gitconflict, should_fail=.true.), & - & new_unittest("dependency-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("build-config-valid", test_build_valid), & - & new_unittest("build-config-empty", test_build_empty), & - & new_unittest("build-config-invalid-values", test_build_invalid_values, should_fail=.true.), & - & new_unittest("library-empty", test_library_empty), & - & new_unittest("library-wrongkey", test_library_wrongkey, should_fail=.true.), & - & new_unittest("package-simple", test_package_simple), & - & new_unittest("package-empty", test_package_empty, should_fail=.true.), & - & new_unittest("package-typeerror", test_package_typeerror, should_fail=.true.), & - & new_unittest("package-noname", test_package_noname, should_fail=.true.), & - & new_unittest("package-wrongexe", test_package_wrongexe, should_fail=.true.), & - & new_unittest("package-wrongtest", test_package_wrongtest, should_fail=.true.), & - & new_unittest("package-duplicate", test_package_duplicate, should_fail=.true.), & - & new_unittest("test-simple", test_test_simple), & - & new_unittest("test-empty", test_test_empty, should_fail=.true.), & - & new_unittest("test-typeerror", test_test_typeerror, should_fail=.true.), & - & new_unittest("test-noname", test_test_noname, should_fail=.true.), & - & new_unittest("test-wrongkey", test_test_wrongkey, should_fail=.true.), & - & new_unittest("link-string", test_link_string), & - & new_unittest("link-array", test_link_array), & - & new_unittest("link-error", test_invalid_link, should_fail=.true.), & - & new_unittest("example-simple", test_example_simple), & - & new_unittest("example-empty", test_example_empty, should_fail=.true.), & - & new_unittest("install-library", test_install_library), & - & new_unittest("install-empty", test_install_empty), & - & new_unittest("install-wrongkey", test_install_wrongkey, should_fail=.true.)] - - end subroutine collect_manifest - - - !> Try to read some unnecessary obscure and convoluted but not invalid package file - subroutine test_valid_manifest(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(package_config_t) :: package - character(len=*), parameter :: manifest = 'fpm-valid-manifest.toml' - integer :: unit - - open(file=manifest, newunit=unit) - write(unit, '(a)') & - & 'name = "example"', & - & '[build]', & - & 'auto-executables = false', & - & 'auto-tests = false', & - & '[dependencies.fpm]', & - & 'git = "https://github.com/fortran-lang/fpm"', & - & '[[executable]]', & - & 'name = "example-#1" # comment', & - & 'source-dir = "prog"', & - & '[dependencies]', & - & 'toml-f.git = "git@github.com:toml-f/toml-f.git"', & - & '"toml..f" = { path = ".." }', & - & '[["executable"]]', & - & 'name = "example-#2"', & - & 'source-dir = "prog"', & - & '[executable.dependencies]', & - & '[''library'']', & - & 'source-dir = """', & - & 'lib""" # comment' - close(unit) - - call get_package_data(package, manifest, error) - - open(file=manifest, newunit=unit) - close(unit, status='delete') - - if (allocated(error)) return - - if (package%name /= "example") then - call test_failed(error, "Package name is "//package%name//" but should be example") - return - end if - - if (.not.allocated(package%library)) then - call test_failed(error, "library is not present in package data") - return - end if - - if (.not.allocated(package%executable)) then - call test_failed(error, "executable is not present in package data") - return - end if - - if (size(package%executable) /= 2) then - call test_failed(error, "Number of executables in package is not two") - return - end if - - if (.not.allocated(package%dependency)) then - call test_failed(error, "dependency is not present in package data") - return - end if - - if (size(package%dependency) /= 3) then - call test_failed(error, "Number of dependencies in package is not three") - return - end if - - if (allocated(package%test)) then - call test_failed(error, "test is present in package but not in package file") - return - end if - - end subroutine test_valid_manifest - - - !> Try to read a valid TOML document which represent an invalid package file - subroutine test_invalid_manifest(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(package_config_t) :: package - character(len=*), parameter :: manifest = 'fpm-invalid-manifest.toml' - integer :: unit - - open(file=manifest, newunit=unit) - write(unit, '(a)') & - & '[package]', & - & 'name = "example"', & - & 'version = "0.1.0"' - close(unit) - - call get_package_data(package, manifest, error) - - open(file=manifest, newunit=unit) - close(unit, status='delete') - - end subroutine test_invalid_manifest - - - !> Create a default library - subroutine test_default_library(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(package_config_t) :: package - - allocate(package%library) - call default_library(package%library) - - call check_string(error, package%library%source_dir, "src", & - & "Default library source-dir") - if (allocated(error)) return - - if (.not.allocated(package%library%include_dir)) then - call test_failed(error,"Default include-dir list not allocated") - return - end if - - if (.not.("include".in.package%library%include_dir)) then - call test_failed(error,"'include' not in default include-dir list") - return - end if - - end subroutine test_default_library - - - !> Create a default executable - subroutine test_default_executable(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(package_config_t) :: package - character(len=*), parameter :: name = "default" - - allocate(package%executable(1)) - call default_executable(package%executable(1), name) - - call check_string(error, package%executable(1)%source_dir, "app", & - & "Default executable source-dir") - if (allocated(error)) return - - call check_string(error, package%executable(1)%name, name, & - & "Default executable name") - if (allocated(error)) return - - end subroutine test_default_executable - - - !> Dependencies cannot be created from empty tables - subroutine test_dependency_empty(error) - use fpm_manifest_dependency - use fpm_toml, only : new_table, toml_table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(dependency_config_t) :: dependency - - call new_table(table) - table%key = "example" - - call new_dependency(dependency, table, error) - - end subroutine test_dependency_empty - - - !> Try to create a dependency with conflicting entries - subroutine test_dependency_pathtag(error) - use fpm_manifest_dependency - use fpm_toml, only : new_table, toml_table, set_value - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - integer :: stat - type(dependency_config_t) :: dependency - - call new_table(table) - table%key = 'example' - call set_value(table, 'path', '"package"', stat) - call set_value(table, 'tag', '"v20.1"', stat) - - call new_dependency(dependency, table, error) - - end subroutine test_dependency_pathtag - - - !> Try to create a dependency with conflicting entries - subroutine test_dependency_nourl(error) - use fpm_manifest_dependency - use fpm_toml, only : new_table, toml_table, set_value - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - integer :: stat - type(dependency_config_t) :: dependency - - call new_table(table) - table%key = 'example' - call set_value(table, 'tag', '"v20.1"', stat) - - call new_dependency(dependency, table, error) - - end subroutine test_dependency_nourl - - - !> Try to create a dependency with conflicting entries - subroutine test_dependency_gitpath(error) - use fpm_manifest_dependency - use fpm_toml, only : new_table, toml_table, set_value - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - integer :: stat - type(dependency_config_t) :: dependency - - call new_table(table) - table%key = 'example' - call set_value(table, 'path', '"package"', stat) - call set_value(table, 'git', '"https://gitea.com/fortran-lang/pack"', stat) - - call new_dependency(dependency, table, error) - - end subroutine test_dependency_gitpath - - - !> Try to create a dependency with conflicting entries - subroutine test_dependency_gitconflict(error) - use fpm_manifest_dependency - use fpm_toml, only : new_table, toml_table, set_value - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - integer :: stat - type(dependency_config_t) :: dependency - - call new_table(table) - table%key = 'example' - call set_value(table, 'git', '"https://gitea.com/fortran-lang/pack"', stat) - call set_value(table, 'branch', '"latest"', stat) - call set_value(table, 'tag', '"v20.1"', stat) - - call new_dependency(dependency, table, error) - - 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_config_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 - use fpm_toml, only : new_table, toml_table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(dependency_config_t), allocatable :: dependencies(:) - - call new_table(table) - - call new_dependencies(dependencies, table, error) - if (allocated(error)) return - - if (allocated(dependencies)) then - call test_failed(error, "Found dependencies in empty table") - end if - - end subroutine test_dependencies_empty - - - !> Add a dependency as an array, which is not supported - subroutine test_dependencies_typeerror(error) - use fpm_manifest_dependency - use fpm_toml, only : new_table, add_array, toml_table, toml_array - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(toml_array), pointer :: children - integer :: stat - type(dependency_config_t), allocatable :: dependencies(:) - - call new_table(table) - call add_array(table, 'dep1', children, stat) - - call new_dependencies(dependencies, table, error) - - end subroutine test_dependencies_typeerror - - - !> Executables cannot be created from empty tables - subroutine test_executable_empty(error) - use fpm_manifest_executable - use fpm_toml, only : new_table, toml_table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(executable_config_t) :: executable - - call new_table(table) - - call new_executable(executable, table, error) - - 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_config_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_config_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_config_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 - - - !> Try to read values from the [build] table - subroutine test_build_valid(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(package_config_t) :: package - character(:), allocatable :: temp_file - integer :: unit - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'name = "example"', & - & '[build]', & - & 'auto-executables = false', & - & 'auto-tests = false' - close(unit) - - call get_package_data(package, temp_file, error) - - if (allocated(error)) return - - if (package%build%auto_executables) then - call test_failed(error, "Wong value of 'auto-executables' read, expecting .false.") - return - end if - - if (package%build%auto_tests) then - call test_failed(error, "Wong value of 'auto-tests' read, expecting .false.") - return - end if - - end subroutine test_build_valid - - - !> Try to read values from an empty [build] table - subroutine test_build_empty(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(package_config_t) :: package - character(:), allocatable :: temp_file - integer :: unit - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'name = "example"', & - & '[build]', & - & '[library]' - close(unit) - - call get_package_data(package, temp_file, error) - - if (allocated(error)) return - - if (.not.package%build%auto_executables) then - call test_failed(error, "Wong default value of 'auto-executables' read, expecting .true.") - return - end if - - if (.not.package%build%auto_tests) then - call test_failed(error, "Wong default value of 'auto-tests' read, expecting .true.") - return - end if - - end subroutine test_build_empty - - - !> Try to read values from a [build] table with invalid values - subroutine test_build_invalid_values(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(package_config_t) :: package - character(:), allocatable :: temp_file - integer :: unit - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'name = "example"', & - & '[build]', & - & 'auto-executables = "false"' - close(unit) - - call get_package_data(package, temp_file, error) - - end subroutine test_build_invalid_values - - - !> Libraries can be created from empty tables - subroutine test_library_empty(error) - use fpm_manifest_library - use fpm_toml, only : new_table, toml_table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(library_config_t) :: library - - call new_table(table) - - call new_library(library, table, error) - if (allocated(error)) return - - call check_string(error, library%source_dir, "src", & - & "Default library source-dir") - if (allocated(error)) return - - if (.not.allocated(library%include_dir)) then - call test_failed(error,"Default include-dir list not allocated") - return - end if - - if (.not.("include".in.library%include_dir)) then - call test_failed(error,"'include' not in default include-dir list") - return - end if - - 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_config_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_config_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 - use fpm_toml, only : new_table, toml_table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(package_config_t) :: package - - call new_table(table) - - call new_package(package, table, error) - - 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_config_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_config_t) :: package - - call new_table(table) - call add_table(table, "library", child, stat) - call add_table(table, "dev-dependencies", child, stat) - call add_table(table, "dependencies", child, stat) - - call new_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_config_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_config_t) :: package - - call new_table(table) - call set_value(table, 'name', '"example"', stat) - call add_array(table, 'test', children, stat) - call add_array(children, children2, stat) - - call new_package(package, table, error) - - end subroutine test_package_wrongtest - - - !> Try to read tests from a mixed type array - subroutine test_package_duplicate(error) - use fpm_manifest_package - use fpm_toml, only : set_value, add_table, add_array, toml_table, toml_array - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(toml_table), pointer :: child - type(toml_array), pointer :: children - integer :: stat - type(package_config_t) :: package - - table = toml_table() - call set_value(table, 'name', '"example"', stat) - call add_array(table, 'test', children, stat) - call add_table(children, child, stat) - call set_value(child, 'name', '"prog"', stat) - call add_table(children, child, stat) - call set_value(child, 'name', '"prog"', stat) - - call new_package(package, table, error) - - end subroutine test_package_duplicate - - - !> 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_config_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 - use fpm_toml, only : new_table, toml_table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(test_config_t) :: test - - call new_table(table) - - call new_test(test, table, error) - - 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_config_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_config_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_config_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 - - - !> Create a simple example entry - subroutine test_example_simple(error) - use fpm_manifest_example - use fpm_toml, only : new_table, set_value, add_table, toml_table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(toml_table), pointer :: child - integer :: stat - type(example_config_t) :: example - - call new_table(table) - call set_value(table, 'name', '"example"', stat) - call set_value(table, 'source-dir', '"demos"', stat) - call set_value(table, 'main', '"demo.f90"', stat) - call add_table(table, 'dependencies', child, stat) - - call new_example(example, table, error) - if (allocated(error)) return - - call check_string(error, example%main, "demo.f90", "Example main") - if (allocated(error)) return - - end subroutine test_example_simple - - - !> Examples cannot be created from empty tables - subroutine test_example_empty(error) - use fpm_manifest_example - use fpm_toml, only : new_table, toml_table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(example_config_t) :: example - - call new_table(table) - - call new_example(example, table, error) - - end subroutine test_example_empty - - - !> Test link options - subroutine test_link_string(error) - use fpm_manifest_build - use fpm_toml, only : set_value, toml_table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - integer :: stat - type(build_config_t) :: build - - table = toml_table() - call set_value(table, "link", "z", stat=stat) - - call new_build_config(build, table, error) - - end subroutine test_link_string - - - !> Test link options - subroutine test_link_array(error) - use fpm_manifest_build - use fpm_toml, only : add_array, set_value, toml_table, toml_array - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(toml_array), pointer :: children - integer :: stat - type(build_config_t) :: build - - table = toml_table() - call add_array(table, "link", children, stat=stat) - call set_value(children, 1, "blas", stat=stat) - call set_value(children, 2, "lapack", stat=stat) - - call new_build_config(build, table, error) - - end subroutine test_link_array - - - !> Test link options - subroutine test_invalid_link(error) - use fpm_manifest_build - use fpm_toml, only : add_table, toml_table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(toml_table), pointer :: child - integer :: stat - type(build_config_t) :: build - - table = toml_table() - call add_table(table, "link", child, stat=stat) - - call new_build_config(build, table, error) - - end subroutine test_invalid_link - - - subroutine test_install_library(error) - use fpm_manifest_install - use fpm_toml, only : toml_table, set_value - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(install_config_t) :: install - - table = toml_table() - call set_value(table, "library", .true.) - - call new_install_config(install, table, error) - if (allocated(error)) return - - if (.not.install%library) then - call test_failed(error, "Library entry should be true") - return - end if - - end subroutine test_install_library - - - subroutine test_install_empty(error) - use fpm_manifest_install - use fpm_toml, only : toml_table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(install_config_t) :: install - - table = toml_table() - - call new_install_config(install, table, error) - if (allocated(error)) return - - if (install%library) then - call test_failed(error, "Library default should be false") - return - end if - - end subroutine test_install_empty - - - subroutine test_install_wrongkey(error) - use fpm_manifest_install - use fpm_toml, only : toml_table, set_value - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(install_config_t) :: install - - table = toml_table() - call set_value(table, "prefix", "/some/install/path") - - call new_install_config(install, table, error) - - end subroutine test_install_wrongkey - - -end module test_manifest diff --git a/fpm/test/fpm_test/test_module_dependencies.f90 b/fpm/test/fpm_test/test_module_dependencies.f90 deleted file mode 100644 index f193646..0000000 --- a/fpm/test/fpm_test/test_module_dependencies.f90 +++ /dev/null @@ -1,666 +0,0 @@ -!> Define tests for the `fpm_sources` module (module dependency checking) -module test_module_dependencies - use testsuite, only : new_unittest, unittest_t, error_t, test_failed - use fpm_targets, only: targets_from_sources, resolve_module_dependencies, & - resolve_target_linking, build_target_t, build_target_ptr, & - FPM_TARGET_EXECUTABLE, FPM_TARGET_OBJECT, FPM_TARGET_ARCHIVE - use fpm_model, only: fpm_model_t, srcfile_t, & - FPM_UNIT_UNKNOWN, FPM_UNIT_PROGRAM, FPM_UNIT_MODULE, & - FPM_UNIT_SUBMODULE, FPM_UNIT_SUBPROGRAM, FPM_UNIT_CSOURCE, & - FPM_UNIT_CHEADER, FPM_SCOPE_UNKNOWN, FPM_SCOPE_LIB, & - FPM_SCOPE_DEP, FPM_SCOPE_APP, FPM_SCOPE_TEST - use fpm_strings, only: string_t, operator(.in.) - use fpm, only: check_modules_for_duplicates - implicit none - private - - public :: collect_module_dependencies, operator(.in.) - - interface operator(.in.) - module procedure target_in - end interface - -contains - - - !> Collect all exported unit tests - subroutine collect_module_dependencies(testsuite) - - !> Collection of tests - type(unittest_t), allocatable, intent(out) :: testsuite(:) - - testsuite = [ & - & new_unittest("library-module-use", test_library_module_use), & - & new_unittest("program-module-use", test_program_module_use), & - & new_unittest("program-with-module", test_program_with_module), & - & new_unittest("program-own-module-use", test_program_own_module_use), & - & new_unittest("missing-library-use", & - test_missing_library_use, should_fail=.true.), & - & new_unittest("missing-program-use", & - test_missing_program_use, should_fail=.true.), & - & new_unittest("invalid-library-use", & - test_invalid_library_use, should_fail=.true.), & - & new_unittest("package-with-no-duplicates", & - test_package_with_no_module_duplicates), & - & new_unittest("package-with-duplicates-in-same-source", & - test_package_module_duplicates_same_source, should_fail=.true.), & - & new_unittest("package-with-duplicates-in-one-package", & - test_package_module_duplicates_one_package, should_fail=.true.), & - & new_unittest("package-with-duplicates-in-two-packages", & - test_package_module_duplicates_two_packages, should_fail=.true.), & - & new_unittest("subdirectory-module-use", & - test_subdirectory_module_use), & - & new_unittest("invalid-subdirectory-module-use", & - test_invalid_subdirectory_module_use, should_fail=.true.) & - ] - - end subroutine collect_module_dependencies - - - !> Check library module using another library module - subroutine test_library_module_use(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(fpm_model_t) :: model - type(build_target_ptr), allocatable :: targets(:) - - model%output_directory = '' - allocate(model%packages(1)) - allocate(model%packages(1)%sources(2)) - - model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_1.f90", & - scope = FPM_SCOPE_LIB, & - provides=[string_t('my_mod_1')]) - - model%packages(1)%sources(2) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_2.f90", & - scope = FPM_SCOPE_LIB, & - provides=[string_t('my_mod_2')], & - uses=[string_t('my_mod_1')]) - - call targets_from_sources(targets,model,error) - if (allocated(error)) return - - if (allocated(error)) then - return - end if - if (size(targets) /= 3) then - call test_failed(error,'Incorrect number of targets - expecting three') - return - end if - - call check_target(targets(1)%ptr,type=FPM_TARGET_ARCHIVE,n_depends=2, & - deps = [targets(2),targets(3)], & - links = targets(2:3), error=error) - - if (allocated(error)) return - - - call check_target(targets(2)%ptr,type=FPM_TARGET_OBJECT,n_depends=0, & - source=model%packages(1)%sources(1),error=error) - - if (allocated(error)) return - - - call check_target(targets(3)%ptr,type=FPM_TARGET_OBJECT,n_depends=1, & - deps=[targets(2)],source=model%packages(1)%sources(2),error=error) - - if (allocated(error)) return - - end subroutine test_library_module_use - - - !> Check a program using a library module - !> Each program generates two targets: object file and executable - !> - subroutine test_program_module_use(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - call test_scope(FPM_SCOPE_APP,error) - if (allocated(error)) return - - call test_scope(FPM_SCOPE_TEST,error) - if (allocated(error)) return - - contains - - subroutine test_scope(exe_scope,error) - integer, intent(in) :: exe_scope - type(error_t), allocatable, intent(out) :: error - - integer :: i - type(fpm_model_t) :: model - type(build_target_ptr), allocatable :: targets(:) - character(:), allocatable :: scope_str - - model%output_directory = '' - allocate(model%packages(1)) - allocate(model%packages(1)%sources(2)) - - scope_str = merge('FPM_SCOPE_APP ','FPM_SCOPE_TEST',exe_scope==FPM_SCOPE_APP)//' - ' - - model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_1.f90", & - scope = FPM_SCOPE_LIB, & - provides=[string_t('my_mod_1')]) - - model%packages(1)%sources(2) = new_test_source(FPM_UNIT_PROGRAM,file_name="app/my_program.f90", & - scope=exe_scope, & - uses=[string_t('my_mod_1')]) - - call targets_from_sources(targets,model,error) - if (allocated(error)) return - - if (size(targets) /= 4) then - call test_failed(error,scope_str//'Incorrect number of targets - expecting three') - return - end if - - call check_target(targets(1)%ptr,type=FPM_TARGET_ARCHIVE,n_depends=1, & - deps=[targets(2)],links=[targets(2)],error=error) - - if (allocated(error)) return - - call check_target(targets(2)%ptr,type=FPM_TARGET_OBJECT,n_depends=0, & - source=model%packages(1)%sources(1),error=error) - - if (allocated(error)) return - - call check_target(targets(3)%ptr,type=FPM_TARGET_OBJECT,n_depends=1, & - deps=[targets(2)],source=model%packages(1)%sources(2),error=error) - - if (allocated(error)) return - - call check_target(targets(4)%ptr,type=FPM_TARGET_EXECUTABLE,n_depends=2, & - deps=[targets(1),targets(3)], & - links=[targets(3)], error=error) - - if (allocated(error)) return - - end subroutine test_scope - - end subroutine test_program_module_use - - - !> Check program with module in single source file - !> (Resulting target should not include itself as a dependency) - subroutine test_program_with_module(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: i - type(fpm_model_t) :: model - type(build_target_ptr), allocatable :: targets(:) - - model%output_directory = '' - allocate(model%packages(1)) - allocate(model%packages(1)%sources(1)) - - model%packages(1)%sources(1) = new_test_source(FPM_UNIT_PROGRAM,file_name="app/my_program.f90", & - scope = FPM_SCOPE_APP, & - provides=[string_t('app_mod')], & - uses=[string_t('app_mod')]) - - call targets_from_sources(targets,model,error) - if (allocated(error)) return - - if (size(targets) /= 2) then - write(*,*) size(targets) - call test_failed(error,'Incorrect number of targets - expecting two') - return - end if - - call check_target(targets(1)%ptr,type=FPM_TARGET_OBJECT,n_depends=0, & - source=model%packages(1)%sources(1),error=error) - - if (allocated(error)) return - - call check_target(targets(2)%ptr,type=FPM_TARGET_EXECUTABLE,n_depends=1, & - deps=[targets(1)],links=[targets(1)],error=error) - - if (allocated(error)) return - - end subroutine test_program_with_module - - - !> Check program using modules in same directory - subroutine test_program_own_module_use(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - call test_scope(FPM_SCOPE_APP,error) - if (allocated(error)) return - - call test_scope(FPM_SCOPE_TEST,error) - if (allocated(error)) return - - contains - - subroutine test_scope(exe_scope,error) - integer, intent(in) :: exe_scope - type(error_t), allocatable, intent(out) :: error - - type(fpm_model_t) :: model - type(build_target_ptr), allocatable :: targets(:) - character(:), allocatable :: scope_str - - model%output_directory = '' - allocate(model%packages(1)) - allocate(model%packages(1)%sources(3)) - - scope_str = merge('FPM_SCOPE_APP ','FPM_SCOPE_TEST',exe_scope==FPM_SCOPE_APP)//' - ' - - model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="app/app_mod1.f90", & - scope = exe_scope, & - provides=[string_t('app_mod1')]) - - model%packages(1)%sources(2) = new_test_source(FPM_UNIT_MODULE,file_name="app/app_mod2.f90", & - scope = exe_scope, & - provides=[string_t('app_mod2')],uses=[string_t('app_mod1')]) - - model%packages(1)%sources(3) = new_test_source(FPM_UNIT_PROGRAM,file_name="app/my_program.f90", & - scope=exe_scope, & - uses=[string_t('app_mod2')]) - - call targets_from_sources(targets,model,error) - if (allocated(error)) return - - if (size(targets) /= 4) then - call test_failed(error,scope_str//'Incorrect number of targets - expecting three') - return - end if - - call check_target(targets(1)%ptr,type=FPM_TARGET_OBJECT,n_depends=0, & - source=model%packages(1)%sources(1),error=error) - - if (allocated(error)) return - - call check_target(targets(2)%ptr,type=FPM_TARGET_OBJECT,n_depends=1, & - source=model%packages(1)%sources(2),deps=[targets(1)],error=error) - - if (allocated(error)) return - - call check_target(targets(3)%ptr,type=FPM_TARGET_OBJECT,n_depends=1, & - source=model%packages(1)%sources(3),deps=[targets(2)],error=error) - - if (allocated(error)) return - - call check_target(targets(4)%ptr,type=FPM_TARGET_EXECUTABLE,n_depends=1, & - deps=[targets(3)],links=targets(1:3), error=error) - - if (allocated(error)) return - - end subroutine test_scope - end subroutine test_program_own_module_use - - - !> Check missing library module dependency - subroutine test_missing_library_use(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(fpm_model_t) :: model - type(build_target_ptr), allocatable :: targets(:) - - model%output_directory = '' - allocate(model%packages(1)) - allocate(model%packages(1)%sources(2)) - - model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_1.f90", & - scope = FPM_SCOPE_LIB, & - provides=[string_t('my_mod_1')]) - - model%packages(1)%sources(2) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_2.f90", & - scope = FPM_SCOPE_LIB, & - provides=[string_t('my_mod_2')], & - uses=[string_t('my_mod_3')]) - - call targets_from_sources(targets,model,error) - - end subroutine test_missing_library_use - - - !> Check missing program module dependency - subroutine test_missing_program_use(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(fpm_model_t) :: model - type(build_target_ptr), allocatable :: targets(:) - - model%output_directory = '' - allocate(model%packages(1)) - allocate(model%packages(1)%sources(2)) - - model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_1.f90", & - scope = FPM_SCOPE_LIB, & - provides=[string_t('my_mod_1')]) - - model%packages(1)%sources(2) = new_test_source(FPM_UNIT_PROGRAM,file_name="app/my_program.f90", & - scope=FPM_SCOPE_APP, & - uses=[string_t('my_mod_2')]) - - call targets_from_sources(targets,model,error) - - end subroutine test_missing_program_use - - - !> Check library module using a non-library module - subroutine test_invalid_library_use(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(fpm_model_t) :: model - type(build_target_ptr), allocatable :: targets(:) - - model%output_directory = '' - allocate(model%packages(1)) - allocate(model%packages(1)%sources(2)) - - model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="app/app_mod.f90", & - scope = FPM_SCOPE_APP, & - provides=[string_t('app_mod')]) - - model%packages(1)%sources(2) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod.f90", & - scope = FPM_SCOPE_LIB, & - provides=[string_t('my_mod')], & - uses=[string_t('app_mod')]) - - call targets_from_sources(targets,model,error) - - end subroutine test_invalid_library_use - - - !> Check program using a non-library module in a sub-directory - subroutine test_subdirectory_module_use(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(fpm_model_t) :: model - type(build_target_ptr), allocatable :: targets(:) - - model%output_directory = '' - allocate(model%packages(1)) - allocate(model%packages(1)%sources(2)) - - model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="app/subdir/app_mod.f90", & - scope = FPM_SCOPE_APP, & - provides=[string_t('app_mod')]) - - model%packages(1)%sources(2) = new_test_source(FPM_UNIT_PROGRAM,file_name="app/my_program.f90", & - scope=FPM_SCOPE_APP, & - uses=[string_t('app_mod')]) - - call targets_from_sources(targets,model,error) - - end subroutine test_subdirectory_module_use - - !> Check program with no duplicate modules - subroutine test_package_with_no_module_duplicates(error) - - type(error_t), allocatable, intent(out) :: error - - type(fpm_model_t) :: model - logical :: duplicates_found = .false. - - allocate(model%packages(1)) - allocate(model%packages(1)%sources(2)) - - model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_1.f90", & - scope = FPM_SCOPE_LIB, provides=[string_t('my_mod_1')]) - - model%packages(1)%sources(2) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_2.f90", & - scope = FPM_SCOPE_LIB, provides=[string_t('my_mod_2')]) - - call check_modules_for_duplicates(model, duplicates_found) - if (duplicates_found) then - call test_failed(error,'Duplicate modules found') - return - end if - end subroutine test_package_with_no_module_duplicates - - !> Check program with duplicate modules in same source file - subroutine test_package_module_duplicates_same_source(error) - - type(error_t), allocatable, intent(out) :: error - - type(fpm_model_t) :: model - logical :: duplicates_found - - allocate(model%packages(1)) - allocate(model%packages(1)%sources(1)) - - model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_1.f90", & - scope = FPM_SCOPE_LIB, provides=[string_t('my_mod_1'), string_t('my_mod_1')]) - - call check_modules_for_duplicates(model, duplicates_found) - if (duplicates_found) then - call test_failed(error,'Duplicate modules found') - return - end if - end subroutine test_package_module_duplicates_same_source - - !> Check program with duplicate modules in two different source files in one package - subroutine test_package_module_duplicates_one_package(error) - - type(error_t), allocatable, intent(out) :: error - - type(fpm_model_t) :: model - logical :: duplicates_found - - allocate(model%packages(1)) - allocate(model%packages(1)%sources(2)) - - model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_1_a.f90", & - scope = FPM_SCOPE_LIB, provides=[string_t('my_mod_1')]) - - model%packages(1)%sources(2) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_1_b.f90", & - scope = FPM_SCOPE_LIB, provides=[string_t('my_mod_1')]) - - call check_modules_for_duplicates(model, duplicates_found) - if (duplicates_found) then - call test_failed(error,'Duplicate modules found') - return - end if - end subroutine test_package_module_duplicates_one_package - - !> Check program with duplicate modules in two different packages - subroutine test_package_module_duplicates_two_packages(error) - - type(error_t), allocatable, intent(out) :: error - - type(fpm_model_t) :: model - logical :: duplicates_found - - allocate(model%packages(2)) - allocate(model%packages(1)%sources(1)) - allocate(model%packages(2)%sources(1)) - - model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="src/subdir1/my_mod_1.f90", & - scope = FPM_SCOPE_LIB, provides=[string_t('my_mod_1')]) - - model%packages(2)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="src/subdir2/my_mod_1.f90", & - scope = FPM_SCOPE_LIB, provides=[string_t('my_mod_1')]) - - call check_modules_for_duplicates(model, duplicates_found) - if (duplicates_found) then - call test_failed(error,'Duplicate modules found') - return - end if - end subroutine test_package_module_duplicates_two_packages - - !> Check program using a non-library module in a differente sub-directory - subroutine test_invalid_subdirectory_module_use(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(fpm_model_t) :: model - type(build_target_ptr), allocatable :: targets(:) - - model%output_directory = '' - allocate(model%packages(1)) - allocate(model%packages(1)%sources(2)) - - model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="app/diff_dir/app_mod.f90", & - scope = FPM_SCOPE_APP, & - provides=[string_t('app_mod')]) - - model%packages(1)%sources(2) = new_test_source(FPM_UNIT_PROGRAM,file_name="app/prog_dir/my_program.f90", & - scope=FPM_SCOPE_APP, & - uses=[string_t('app_mod')]) - - call targets_from_sources(targets,model,error) - - end subroutine test_invalid_subdirectory_module_use - - !> Helper to create a new srcfile_t - function new_test_source(type,file_name, scope, uses, provides) result(src) - integer, intent(in) :: type - character(*), intent(in) :: file_name - integer, intent(in) :: scope - type(string_t), intent(in), optional :: uses(:) - type(string_t), intent(in), optional :: provides(:) - type(srcfile_t) :: src - - src%file_name = file_name - src%unit_scope = scope - src%unit_type = type - - if (present(provides)) then - src%modules_provided = provides - else - allocate(src%modules_provided(0)) - end if - - if (present(uses)) then - src%modules_used = uses - else - allocate(src%modules_used(0)) - end if - - allocate(src%include_dependencies(0)) - - end function new_test_source - - - !> Helper to check an expected output target - subroutine check_target(target,type,n_depends,deps,links,source,error) - type(build_target_t), intent(in) :: target - integer, intent(in) :: type - integer, intent(in) :: n_depends - type(srcfile_t), intent(in), optional :: source - type(build_target_ptr), intent(in), optional :: deps(:) - type(build_target_ptr), intent(in), optional :: links(:) - type(error_t), intent(out), allocatable :: error - - integer :: i - - if (target%target_type /= type) then - call test_failed(error,'Unexpected target_type for target "'//target%output_file//'"') - return - end if - - if (size(target%dependencies) /= n_depends) then - call test_failed(error,'Wrong number of dependencies for target "'//target%output_file//'"') - return - end if - - if (present(deps)) then - - do i=1,size(deps) - - if (.not.(deps(i)%ptr .in. target%dependencies)) then - call test_failed(error,'Missing dependency ('//deps(i)%ptr%output_file//& - ') for target "'//target%output_file//'"') - return - end if - - end do - - end if - - if (present(links)) then - - do i=1,size(links) - - if (.not.(links(i)%ptr%output_file .in. target%link_objects)) then - call test_failed(error,'Missing object ('//links(i)%ptr%output_file//& - ') for executable "'//target%output_file//'"') - return - end if - - end do - - if (size(links) > size(target%link_objects)) then - - call test_failed(error,'There are missing link objects for target "'& - //target%output_file//'"') - return - - elseif (size(links) < size(target%link_objects)) then - - call test_failed(error,'There are more link objects than expected for target "'& - //target%output_file//'"') - return - - end if - - end if - - if (present(source)) then - - if (allocated(target%source)) then - if (target%source%file_name /= source%file_name) then - call test_failed(error,'Incorrect source ('//target%source%file_name//') for target "'//& - target%output_file//'"'//new_line('a')//' expected "'//source%file_name//'"') - return - end if - - else - call test_failed(error,'Expecting source for target "'//target%output_file//'" but none found') - return - end if - - else - - if (allocated(target%source)) then - call test_failed(error,'Found source ('//target%source%file_name//') for target "'//& - target%output_file//'" but none expected') - return - end if - - end if - - end subroutine check_target - - - !> Helper to check if a build target is in a list of build_target_ptr - logical function target_in(needle,haystack) - type(build_target_t), intent(in), target :: needle - type(build_target_ptr), intent(in) :: haystack(:) - - integer :: i - - target_in = .false. - do i=1,size(haystack) - - if (associated(haystack(i)%ptr,needle)) then - target_in = .true. - return - end if - - end do - - end function target_in - - -end module test_module_dependencies diff --git a/fpm/test/fpm_test/test_package_dependencies.f90 b/fpm/test/fpm_test/test_package_dependencies.f90 deleted file mode 100644 index b70ac13..0000000 --- a/fpm/test/fpm_test/test_package_dependencies.f90 +++ /dev/null @@ -1,240 +0,0 @@ -!> Define tests for the `fpm_dependency` module -module test_package_dependencies - use fpm_filesystem, only: get_temp_filename - use testsuite, only : new_unittest, unittest_t, error_t, test_failed - use fpm_dependency - use fpm_manifest - use fpm_manifest_dependency - use fpm_toml - implicit none - private - - public :: collect_package_dependencies - - type, extends(dependency_tree_t) :: mock_dependency_tree_t - contains - procedure :: resolve_dependency => resolve_dependency_once - end type mock_dependency_tree_t - - -contains - - - !> Collect all exported unit tests - subroutine collect_package_dependencies(testsuite) - - !> Collection of tests - type(unittest_t), allocatable, intent(out) :: testsuite(:) - - testsuite = [ & - & new_unittest("cache-load-dump", test_cache_load_dump), & - & new_unittest("cache-dump-load", test_cache_dump_load), & - & new_unittest("status-after-load", test_status), & - & new_unittest("add-dependencies", test_add_dependencies)] - - end subroutine collect_package_dependencies - - - !> Round trip of the dependency cache from a dependency tree to a TOML document - !> to a dependency tree - subroutine test_cache_dump_load(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(dependency_tree_t) :: deps - type(dependency_config_t) :: dep - integer :: unit - - call new_dependency_tree(deps) - call resize(deps%dep, 5) - deps%ndep = 3 - dep%name = "dep1" - dep%path = "fpm-tmp1-dir" - call new_dependency_node(deps%dep(1), dep, proj_dir=dep%path) - dep%name = "dep2" - dep%path = "fpm-tmp2-dir" - call new_dependency_node(deps%dep(2), dep, proj_dir=dep%path) - dep%name = "dep3" - dep%path = "fpm-tmp3-dir" - call new_dependency_node(deps%dep(3), dep, proj_dir=dep%path) - - open(newunit=unit, status='scratch') - call deps%dump(unit, error) - if (.not.allocated(error)) then - rewind(unit) - - call new_dependency_tree(deps) - call resize(deps%dep, 2) - call deps%load(unit, error) - close(unit) - end if - if (allocated(error)) return - - if (deps%ndep /= 3) then - call test_failed(error, "Expected three dependencies in loaded cache") - return - end if - - end subroutine test_cache_dump_load - - - !> Round trip of the dependency cache from a TOML data structure to - !> a dependency tree to a TOML data structure - subroutine test_cache_load_dump(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(toml_table), pointer :: ptr - type(toml_key), allocatable :: list(:) - type(dependency_tree_t) :: deps - - table = toml_table() - call add_table(table, "dep1", ptr) - call set_value(ptr, "version", "1.1.0") - call set_value(ptr, "proj-dir", "fpm-tmp1-dir") - call add_table(table, "dep2", ptr) - call set_value(ptr, "version", "0.55.3") - call set_value(ptr, "proj-dir", "fpm-tmp2-dir") - call set_value(ptr, "git", "https://github.com/fortran-lang/dep2") - call add_table(table, "dep3", ptr) - call set_value(ptr, "version", "20.1.15") - call set_value(ptr, "proj-dir", "fpm-tmp3-dir") - call set_value(ptr, "git", "https://gitlab.com/fortran-lang/dep3") - call set_value(ptr, "rev", "c0ffee") - call add_table(table, "dep4", ptr) - call set_value(ptr, "proj-dir", "fpm-tmp4-dir") - - call new_dependency_tree(deps) - call deps%load(table, error) - if (allocated(error)) return - - if (deps%ndep /= 4) then - call test_failed(error, "Expected four dependencies in loaded cache") - return - end if - - call table%destroy - table = toml_table() - - call deps%dump(table, error) - if (allocated(error)) return - - call table%get_keys(list) - - if (size(list) /= 4) then - call test_failed(error, "Expected four dependencies in dumped cache") - return - end if - - end subroutine test_cache_load_dump - - - subroutine test_status(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(toml_table), pointer :: ptr - type(toml_key), allocatable :: list(:) - type(dependency_tree_t) :: deps - - table = toml_table() - call add_table(table, "dep1", ptr) - call set_value(ptr, "version", "1.1.0") - call set_value(ptr, "proj-dir", "fpm-tmp1-dir") - call add_table(table, "dep2", ptr) - call set_value(ptr, "version", "0.55.3") - call set_value(ptr, "proj-dir", "fpm-tmp2-dir") - call set_value(ptr, "git", "https://github.com/fortran-lang/dep2") - - call new_dependency_tree(deps) - call deps%load(table, error) - if (allocated(error)) return - - if (deps%finished()) then - call test_failed(error, "Newly initialized dependency tree cannot be reolved") - return - end if - - end subroutine test_status - - - subroutine test_add_dependencies(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(toml_table), pointer :: child, ptr - type(toml_key), allocatable :: list(:) - type(mock_dependency_tree_t) :: deps - type(dependency_config_t), allocatable :: nodes(:) - - table = toml_table() - call add_table(table, "sub1", ptr) - call set_value(ptr, "path", "external") - call add_table(table, "lin2", ptr) - call set_value(ptr, "git", "https://github.com/fortran-lang/lin2") - call add_table(table, "pkg3", ptr) - call set_value(ptr, "git", "https://gitlab.com/fortran-lang/pkg3") - call set_value(ptr, "rev", "c0ffee") - call add_table(table, "proj4", ptr) - call set_value(ptr, "path", "vendor") - - call new_dependencies(nodes, table, error) - if (allocated(error)) return - - call new_dependency_tree(deps%dependency_tree_t) - call deps%add(nodes, error) - if (allocated(error)) return - - if (deps%finished()) then - call test_failed(error, "Newly added nodes cannot be already resolved") - return - end if - - if (deps%ndep /= 4) then - call test_failed(error, "Expected for dependencies in tree") - return - end if - - call deps%resolve(".", error) - if (allocated(error)) return - - if (.not.deps%finished()) then - call test_failed(error, "Mocked dependency tree must resolve in one step") - return - end if - - end subroutine test_add_dependencies - - - !> Resolve a single dependency node - subroutine resolve_dependency_once(self, dependency, root, error) - !> Mock instance of the dependency tree - class(mock_dependency_tree_t), intent(inout) :: self - !> Dependency configuration to add - type(dependency_node_t), intent(inout) :: dependency - !> Current installation prefix - character(len=*), intent(in) :: root - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(package_config_t) :: package - character(len=:), allocatable :: manifest, proj_dir, revision - logical :: fetch - - if (dependency%done) then - call test_failed(error, "Should only visit this node once") - return - end if - dependency%done = .true. - - end subroutine resolve_dependency_once - - -end module test_package_dependencies diff --git a/fpm/test/fpm_test/test_source_parsing.f90 b/fpm/test/fpm_test/test_source_parsing.f90 deleted file mode 100644 index 79a4d7a..0000000 --- a/fpm/test/fpm_test/test_source_parsing.f90 +++ /dev/null @@ -1,758 +0,0 @@ -!> Define tests for the `fpm_sources` module (parsing routines) -module test_source_parsing - use testsuite, only : new_unittest, unittest_t, error_t, test_failed - use fpm_filesystem, only: get_temp_filename - use fpm_source_parsing, only: parse_f_source, parse_c_source - use fpm_model, only: srcfile_t, FPM_UNIT_PROGRAM, FPM_UNIT_MODULE, & - FPM_UNIT_SUBMODULE, FPM_UNIT_SUBPROGRAM, FPM_UNIT_CSOURCE - use fpm_strings, only: operator(.in.) - implicit none - private - - public :: collect_source_parsing - -contains - - - !> Collect all exported unit tests - subroutine collect_source_parsing(testsuite) - - !> Collection of tests - type(unittest_t), allocatable, intent(out) :: testsuite(:) - - testsuite = [ & - & new_unittest("modules-used", test_modules_used), & - & new_unittest("intrinsic-modules-used", test_intrinsic_modules_used), & - & new_unittest("include-stmt", test_include_stmt), & - & new_unittest("program", test_program), & - & new_unittest("module", test_module), & - & new_unittest("program-with-module", test_program_with_module), & - & new_unittest("submodule", test_submodule), & - & new_unittest("submodule-ancestor", test_submodule_ancestor), & - & new_unittest("subprogram", test_subprogram), & - & new_unittest("csource", test_csource), & - & new_unittest("invalid-use-stmt", & - test_invalid_use_stmt, should_fail=.true.), & - & new_unittest("invalid-include-stmt", & - test_invalid_include_stmt, should_fail=.true.), & - & new_unittest("invalid-module", & - test_invalid_module, should_fail=.true.), & - & new_unittest("invalid-submodule", & - test_invalid_submodule, should_fail=.true.) & - ] - - end subroutine collect_source_parsing - - - !> Check parsing of module 'USE' statements - subroutine test_modules_used(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'program test', & - & ' use module_one', & - & ' use :: module_two', & - & ' use module_three, only: a, b, c', & - & ' use :: module_four, only: a => b', & - & '! use module_not_used', & - & ' implicit none', & - & 'end program test' - close(unit) - - f_source = parse_f_source(temp_file,error) - if (allocated(error)) then - return - end if - - if (f_source%unit_type /= FPM_UNIT_PROGRAM) then - call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_PROGRAM') - return - end if - - if (size(f_source%modules_provided) /= 0) then - call test_failed(error,'Unexpected modules_provided - expecting zero') - return - end if - - if (size(f_source%modules_used) /= 4) then - call test_failed(error,'Incorrect number of modules_used - expecting four') - return - end if - - if (.not.('module_one' .in. f_source%modules_used)) then - call test_failed(error,'Missing module in modules_used') - return - end if - - if (.not.('module_two' .in. f_source%modules_used)) then - call test_failed(error,'Missing module in modules_used') - return - end if - - if (.not.('module_three' .in. f_source%modules_used)) then - call test_failed(error,'Missing module in modules_used') - return - end if - - if (.not.('module_four' .in. f_source%modules_used)) then - call test_failed(error,'Missing module in modules_used') - return - end if - - if ('module_not_used' .in. f_source%modules_used) then - call test_failed(error,'Commented module found in modules_used') - return - end if - - end subroutine test_modules_used - - - !> Check that intrinsic modules are properly ignore - subroutine test_intrinsic_modules_used(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'program test', & - & ' use iso_c_binding', & - & ' use iso_fortran_env', & - & ' use ieee_arithmetic', & - & ' use ieee_exceptions', & - & ' use ieee_features', & - & ' implicit none', & - & 'end program test' - close(unit) - - f_source = parse_f_source(temp_file,error) - if (allocated(error)) then - return - end if - - if (size(f_source%modules_provided) /= 0) then - call test_failed(error,'Unexpected modules_provided - expecting zero') - return - end if - - if (size(f_source%modules_used) /= 0) then - call test_failed(error,'Incorrect number of modules_used - expecting zero') - return - end if - - if ('iso_c_binding' .in. f_source%modules_used) then - call test_failed(error,'Intrinsic module found in modules_used') - return - end if - - if ('iso_fortran_env' .in. f_source%modules_used) then - call test_failed(error,'Intrinsic module found in modules_used') - return - end if - - if ('ieee_arithmetic' .in. f_source%modules_used) then - call test_failed(error,'Intrinsic module found in modules_used') - return - end if - - if ('ieee_exceptions' .in. f_source%modules_used) then - call test_failed(error,'Intrinsic module found in modules_used') - return - end if - - if ('ieee_features' .in. f_source%modules_used) then - call test_failed(error,'Intrinsic module found in modules_used') - return - end if - - end subroutine test_intrinsic_modules_used - - - !> Check parsing of include statements - subroutine test_include_stmt(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'program test', & - & ' implicit none', & - & ' include "included_file.f90"', & - & ' character(*) :: include_comments', & - & ' include_comments = "some comments"', & - & ' contains ', & - & ' include"second_include.f90"', & - & 'end program test' - close(unit) - - f_source = parse_f_source(temp_file,error) - if (allocated(error)) then - return - end if - - if (size(f_source%modules_provided) /= 0) then - call test_failed(error,'Unexpected modules_provided - expecting zero') - return - end if - - if (size(f_source%modules_used) /= 0) then - call test_failed(error,'Incorrect number of modules_used - expecting zero') - return - end if - - if (size(f_source%include_dependencies) /= 2) then - call test_failed(error,'Incorrect number of include_dependencies - expecting two') - return - end if - - if (.not.('included_file.f90' .in. f_source%include_dependencies)) then - call test_failed(error,'Missing include file in include_dependencies') - return - end if - - if (.not.('second_include.f90' .in. f_source%include_dependencies)) then - call test_failed(error,'Missing include file in include_dependencies') - return - end if - - end subroutine test_include_stmt - - !> Try to parse a simple fortran program - subroutine test_program(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'program my_program', & - & 'use module_one', & - & 'implicit none', & - & 'integer :: module', & - & 'module = 1', & - & 'module= 1', & - & 'module =1', & - & 'module (i) =1', & - & 'contains', & - & 'subroutine f()', & - & 'end subroutine f', & - & 'end program my_program' - close(unit) - - f_source = parse_f_source(temp_file,error) - if (allocated(error)) then - return - end if - - if (f_source%unit_type /= FPM_UNIT_PROGRAM) then - call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_PROGRAM') - return - end if - - if (size(f_source%modules_provided) /= 0) then - call test_failed(error,'Unexpected modules_provided - expecting zero') - return - end if - - if (size(f_source%modules_used) /= 1) then - call test_failed(error,'Incorrect number of modules_used - expecting one') - return - end if - - if (.not.('module_one' .in. f_source%modules_used)) then - call test_failed(error,'Missing module in modules_used') - return - end if - - end subroutine test_program - - - !> Try to parse fortran module - subroutine test_module(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'module my_mod', & - & 'use module_one', & - & 'interface', & - & ' module subroutine f()', & - & 'end interface', & - & 'integer :: program', & - & 'program = 1', & - & 'program= 1', & - & 'program =1', & - & 'program (i) =1', & - & 'contains', & - & 'module procedure f()', & - & 'end procedure f', & - & 'end module test' - close(unit) - - f_source = parse_f_source(temp_file,error) - if (allocated(error)) then - return - end if - - if (f_source%unit_type /= FPM_UNIT_MODULE) then - call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_MODULE') - return - end if - - if (size(f_source%modules_provided) /= 1) then - call test_failed(error,'Unexpected modules_provided - expecting one') - return - end if - - if (size(f_source%modules_used) /= 1) then - call test_failed(error,'Incorrect number of modules_used - expecting one') - return - end if - - if (.not.('my_mod' .in. f_source%modules_provided)) then - call test_failed(error,'Missing module in modules_provided') - return - end if - - if (.not.('module_one' .in. f_source%modules_used)) then - call test_failed(error,'Missing module in modules_used') - return - end if - - end subroutine test_module - - - !> Try to parse combined fortran module and program - !> Check that parsed unit type is FPM_UNIT_PROGRAM - subroutine test_program_with_module(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'module my_mod', & - & 'use module_one', & - & 'interface', & - & ' module subroutine f()', & - & 'end interface', & - & 'contains', & - & 'module procedure f()', & - & 'end procedure f', & - & 'end module test', & - & 'program my_program', & - & 'use my_mod', & - & 'implicit none', & - & 'end my_program' - close(unit) - - f_source = parse_f_source(temp_file,error) - if (allocated(error)) then - return - end if - - if (f_source%unit_type /= FPM_UNIT_PROGRAM) then - call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_PROGRAM') - return - end if - - if (size(f_source%modules_provided) /= 1) then - call test_failed(error,'Unexpected modules_provided - expecting one') - return - end if - - if (.not.('my_mod' .in. f_source%modules_provided)) then - call test_failed(error,'Missing module in modules_provided') - return - end if - - if (.not.('module_one' .in. f_source%modules_used)) then - call test_failed(error,'Missing module in modules_used') - return - end if - - if (.not.('my_mod' .in. f_source%modules_used)) then - call test_failed(error,'Missing module in modules_used') - return - end if - - end subroutine test_program_with_module - - - !> Try to parse fortran submodule for ancestry - subroutine test_submodule(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'submodule (parent) child', & - & 'use module_one', & - & 'end submodule test' - close(unit) - - f_source = parse_f_source(temp_file,error) - if (allocated(error)) then - return - end if - - if (f_source%unit_type /= FPM_UNIT_SUBMODULE) then - call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_SUBMODULE') - return - end if - - if (size(f_source%modules_provided) /= 1) then - call test_failed(error,'Unexpected modules_provided - expecting one') - return - end if - - if (size(f_source%modules_used) /= 2) then - call test_failed(error,'Incorrect number of modules_used - expecting two') - return - end if - - if (.not.('child' .in. f_source%modules_provided)) then - call test_failed(error,'Missing module in modules_provided') - return - end if - - if (.not.('module_one' .in. f_source%modules_used)) then - call test_failed(error,'Missing module in modules_used') - return - end if - - if (.not.('parent' .in. f_source%modules_used)) then - call test_failed(error,'Missing parent module in modules_used') - return - end if - - end subroutine test_submodule - - - !> Try to parse fortran multi-level submodule for ancestry - subroutine test_submodule_ancestor(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'submodule (ancestor:parent) child', & - & 'use module_one', & - & 'end submodule test' - close(unit) - - f_source = parse_f_source(temp_file,error) - if (allocated(error)) then - return - end if - - if (f_source%unit_type /= FPM_UNIT_SUBMODULE) then - call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_SUBMODULE') - return - end if - - if (size(f_source%modules_provided) /= 1) then - call test_failed(error,'Unexpected modules_provided - expecting one') - return - end if - - if (size(f_source%modules_used) /= 2) then - call test_failed(error,'Incorrect number of modules_used - expecting two') - return - end if - - if (.not.('child' .in. f_source%modules_provided)) then - call test_failed(error,'Missing module in modules_provided') - return - end if - - if (.not.('module_one' .in. f_source%modules_used)) then - call test_failed(error,'Missing module in modules_used') - return - end if - - if (.not.('parent' .in. f_source%modules_used)) then - call test_failed(error,'Missing parent module in modules_used') - return - end if - - end subroutine test_submodule_ancestor - - - !> Try to parse standard fortran sub-program (non-module) source - subroutine test_subprogram(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'subroutine my_sub(a)', & - & ' use module_one', & - & ' integer, intent(in) :: a', & - & 'end subroutine my_sub' - close(unit) - - f_source = parse_f_source(temp_file,error) - if (allocated(error)) then - return - end if - - if (f_source%unit_type /= FPM_UNIT_SUBPROGRAM) then - call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_SUBPROGRAM') - return - end if - - if (size(f_source%modules_provided) /= 0) then - call test_failed(error,'Unexpected modules_provided - expecting zero') - return - end if - - if (size(f_source%modules_used) /= 1) then - call test_failed(error,'Incorrect number of modules_used - expecting one') - return - end if - - if (.not.('module_one' .in. f_source%modules_used)) then - call test_failed(error,'Missing module in modules_used') - return - end if - - end subroutine test_subprogram - - - !> Try to parse standard c source for includes - subroutine test_csource(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - temp_file = temp_file//'.c' - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & '#include "proto.h"', & - & 'void c_func(int a) {', & - & ' #include "function_body.c"', & - & ' return', & - & '}' - close(unit) - - f_source = parse_c_source(temp_file,error) - if (allocated(error)) then - return - end if - - if (f_source%unit_type /= FPM_UNIT_CSOURCE) then - call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_CSOURCE') - return - end if - - if (size(f_source%modules_provided) /= 0) then - call test_failed(error,'Unexpected modules_provided - expecting zero') - return - end if - - if (size(f_source%modules_used) /= 0) then - call test_failed(error,'Incorrect number of modules_used - expecting zero') - return - end if - - if (size(f_source%include_dependencies) /= 2) then - call test_failed(error,'Incorrect number of include_dependencies - expecting two') - return - end if - - if (.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/fpm_test/test_toml.f90 b/fpm/test/fpm_test/test_toml.f90 deleted file mode 100644 index ba48307..0000000 --- a/fpm/test/fpm_test/test_toml.f90 +++ /dev/null @@ -1,107 +0,0 @@ -!> Define tests for the `fpm_toml` modules -module test_toml - use testsuite, only : new_unittest, unittest_t, error_t - use fpm_toml - implicit none - private - - public :: collect_toml - - -contains - - - !> Collect all exported unit tests - subroutine collect_toml(testsuite) - - !> Collection of tests - type(unittest_t), allocatable, intent(out) :: testsuite(:) - - testsuite = [ & - & new_unittest("valid-toml", test_valid_toml), & - & new_unittest("invalid-toml", test_invalid_toml, should_fail=.true.), & - & new_unittest("missing-file", test_missing_file, should_fail=.true.)] - - end subroutine collect_toml - - - !> Try to read some unnecessary obscure and convoluted but not invalid package file - subroutine test_valid_toml(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table), allocatable :: table - character(len=*), parameter :: manifest = 'fpm-valid-toml.toml' - integer :: unit - - open(file=manifest, newunit=unit) - write(unit, '(a)') & - & 'name = "example"', & - & '[dependencies.fpm]', & - & 'git = "https://github.com/fortran-lang/fpm"', & - & '[[executable]]', & - & 'name = "example-#1" # comment', & - & 'source-dir = "prog"', & - & '[dependencies]', & - & 'toml-f.git = "git@github.com:toml-f/toml-f.git"', & - & '"toml..f" = { path = ".." }', & - & '[["executable"]]', & - & 'name = "example-#2"', & - & 'source-dir = "prog"', & - & '[executable.dependencies]', & - & '[''library'']', & - & 'source-dir = """', & - & 'lib""" # comment' - close(unit) - - call read_package_file(table, manifest, error) - - open(file=manifest, newunit=unit) - close(unit, status='delete') - - end subroutine test_valid_toml - - - !> Try to read an invalid TOML document - subroutine test_invalid_toml(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table), allocatable :: table - character(len=*), parameter :: manifest = 'fpm-invalid-toml.toml' - integer :: unit - - open(file=manifest, newunit=unit) - write(unit, '(a)') & - & '# INVALID TOML DOC', & - & 'name = "example"', & - & 'dependencies.fpm.git = "https://github.com/fortran-lang/fpm"', & - & '[dependencies]', & - & 'toml-f.git = "git@github.com:toml-f/toml-f.git"', & - & '"toml..f" = { path = ".." }' - close(unit) - - call read_package_file(table, manifest, error) - - open(file=manifest, newunit=unit) - close(unit, status='delete') - - end subroutine test_invalid_toml - - - !> Try to read configuration from a non-existing file - subroutine test_missing_file(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table), allocatable :: table - - call read_package_file(table, 'low+chance+of+existing.toml', error) - - end subroutine test_missing_file - - -end module test_toml diff --git a/fpm/test/fpm_test/test_versioning.f90 b/fpm/test/fpm_test/test_versioning.f90 deleted file mode 100644 index f6dcb57..0000000 --- a/fpm/test/fpm_test/test_versioning.f90 +++ /dev/null @@ -1,405 +0,0 @@ -!> Test implementation of version data type -module test_versioning - use testsuite, only : new_unittest, unittest_t, error_t, test_failed - use fpm_versioning - implicit none - private - - public :: collect_versioning - - -contains - - - !> Collect all exported unit tests - subroutine collect_versioning(testsuite) - - !> Collection of tests - type(unittest_t), allocatable, intent(out) :: testsuite(:) - - testsuite = [ & - & new_unittest("valid-version", test_valid_version), & - & new_unittest("valid-equals", test_valid_equals), & - & new_unittest("valid-notequals", test_valid_notequals), & - & new_unittest("valid-compare", test_valid_compare), & - & new_unittest("valid-match", test_valid_match), & - & new_unittest("valid-string", test_valid_string), & - & new_unittest("invalid-empty", test_invalid_empty, should_fail=.true.), & - & new_unittest("invalid-version1", test_invalid_version1, should_fail=.true.), & - & new_unittest("invalid-version2", test_invalid_version2, should_fail=.true.), & - & new_unittest("invalid-version3", test_invalid_version3, should_fail=.true.), & - & new_unittest("invalid-overflow", test_invalid_overflow, should_fail=.true.)] - - end subroutine collect_versioning - - - !> Read valid version strings - subroutine test_valid_version(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(version_t) :: version - - call new_version(version, "8.9.0", error) - if (allocated(error)) return - - call new_version(version, "2020.10.003", error) - - end subroutine test_valid_version - - - !> Compare versions for equality - subroutine test_valid_equals(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(version_t) :: v1, v2 - type(version_t) :: varray(4) - - call new_version(v1, [1, 2, 0]) - call new_version(v2, [1, 2]) - - if (.not. v1 == v2) then - call test_failed(error, "Version comparison failed") - return - end if - - if (.not. v2 == v1) then - call test_failed(error, "Version comparison failed") - return - end if - - call new_version(v1, [0, 9, 0]) - call new_version(v2, [0, 9]) - - if (.not. v1.eq.v2) then - call test_failed(error, "Version comparison failed") - return - end if - - if (.not. v2.eq.v1) then - call test_failed(error, "Version comparison failed") - return - end if - - call new_version(v1, [2020]) - call new_version(v2, [2020, 0]) - - if (.not. v1 == v2) then - call test_failed(error, "Version comparison failed") - return - end if - - if (.not. v2 == v1) then - call test_failed(error, "Version comparison failed") - return - end if - - call new_version(v1, [20, 1]) - call new_version(varray(1), [19]) - call new_version(varray(2), [18, 2]) - call new_version(varray(3), [20, 1]) - call new_version(varray(4), [1, 3, 1]) - - if (.not. any(v1 == varray)) then - call test_failed(error, "Version comparison failed") - return - end if - - end subroutine test_valid_equals - - - !> Compare versions for mismatch - subroutine test_valid_notequals(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(version_t) :: v1, v2 - type(version_t) :: varray(4) - - call new_version(v1, [2020, 3, 1]) - call new_version(v2, [2020, 3]) - - if (.not. v1 /= v2) then - call test_failed(error, "Version comparison failed") - return - end if - - if (.not. v2 /= v1) then - call test_failed(error, "Version comparison failed") - return - end if - - call new_version(v1, [0, 9, 1]) - call new_version(v2, [0, 9]) - - if (.not. v1.ne.v2) then - call test_failed(error, "Version comparison failed") - return - end if - - if (.not. v2.ne.v1) then - call test_failed(error, "Version comparison failed") - return - end if - - call new_version(v1, [2020]) - call new_version(v2, [0, 2020]) - - if (.not. v2 /= v1) then - call test_failed(error, "Version comparison failed") - return - end if - - if (.not. v1 /= v2) then - call test_failed(error, "Version comparison failed") - return - end if - - call new_version(v1, [20, 1]) - call new_version(varray(1), [19]) - call new_version(varray(2), [18, 2]) - call new_version(varray(3), [18, 1]) - call new_version(varray(4), [1, 3, 1]) - - if (.not. any(v1 /= varray)) then - call test_failed(error, "Version comparison failed") - return - end if - - end subroutine test_valid_notequals - - - !> Relative comparison of versions - subroutine test_valid_compare(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(version_t) :: v1, v2 - type(version_t) :: varray(4) - - call new_version(v1, [10]) - call new_version(v2, [1]) - - if (.not. v1 > v2) then - call test_failed(error, "Version comparison failed (gt)") - return - end if - - if (.not. v1 >= v2) then - call test_failed(error, "Version comparison failed (ge)") - return - end if - - if (.not. v2 < v1) then - call test_failed(error, "Version comparison failed (lt)") - return - end if - - if (.not. v2 <= v1) then - call test_failed(error, "Version comparison failed (le)") - return - end if - - call new_version(v1, [1, 0, 8]) - call new_version(v2, [1, 0]) - - if (.not. v1 .gt. v2) then - call test_failed(error, "Version comparison failed (gt)") - return - end if - - if (.not. v1 .ge. v2) then - call test_failed(error, "Version comparison failed (ge)") - return - end if - - if (.not. v2 .lt. v1) then - call test_failed(error, "Version comparison failed (lt)") - return - end if - - if (.not. v2 .le. v1) then - call test_failed(error, "Version comparison failed (le)") - return - end if - - call new_version(v1, [1, 2]) - call new_version(v2, [1, 2, 0]) - - if (v1 > v2) then - call test_failed(error, "Version comparison failed (gt)") - return - end if - - if (.not. v1 >= v2) then - call test_failed(error, "Version comparison failed (ge)") - return - end if - - if (v2 < v1) then - call test_failed(error, "Version comparison failed (lt)") - return - end if - - if (.not. v2 <= v1) then - call test_failed(error, "Version comparison failed (le)") - return - end if - - call new_version(v1, [20, 1]) - call new_version(varray(1), [19]) - call new_version(varray(2), [18, 2]) - call new_version(varray(3), [18, 1]) - call new_version(varray(4), [1, 3, 1]) - - if (.not. all(v1 > varray)) then - call test_failed(error, "Version comparison failed (gt)") - return - end if - - end subroutine test_valid_compare - - - !> Semantic version matching - subroutine test_valid_match(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(version_t) :: v1, v2 - type(version_t) :: varray(4) - - call new_version(v1, [1, 1, 0]) - call new_version(v2, [1]) - - if (.not. (v1 .match. v2)) then - call test_failed(error, "Version comparison failed (match)") - return - end if - - if (v2 .match. v1) then - call test_failed(error, "Version comparison failed (match)") - return - end if - - call new_version(v1, [0, 5, 8]) - call new_version(v2, [0, 5]) - - if (.not. (v1 .match. v2)) then - call test_failed(error, "Version comparison failed (match)") - return - end if - - if (v2 .match. v1) then - call test_failed(error, "Version comparison failed (match)") - return - end if - - call new_version(v1, [1, 2]) - call new_version(v2, [1, 2, 0]) - - if (.not. (v1 .match. v2)) then - call test_failed(error, "Version comparison failed (match)") - return - end if - - if (.not. (v2 .match. v1)) then - call test_failed(error, "Version comparison failed (match)") - return - end if - - end subroutine test_valid_match - - - !> Test if version string is preserved - subroutine test_valid_string(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - character(len=*), parameter :: str_in = "20.1.100" - character(len=:), allocatable :: str_out - type(version_t) :: version - - call new_version(version, str_in, error) - if (allocated(error)) return - call version%to_string(str_out) - - if (str_in /= str_out) then - call test_failed(error, "Expected "//str_in//" but got "//str_out) - end if - - end subroutine test_valid_string - - - !> Empty string does not represent a version - subroutine test_invalid_empty(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(version_t) :: version - - call new_version(version, "", error) - - end subroutine test_invalid_empty - - - !> Version is invalid with trailing dots - subroutine test_invalid_version1(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(version_t) :: version - - call new_version(version, "1.", error) - - end subroutine test_invalid_version1 - - - !> Version is invalid with multiple dots - subroutine test_invalid_version2(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(version_t) :: version - - call new_version(version, "1..1", error) - - end subroutine test_invalid_version2 - - - !> Version is invalid if it is not a version - subroutine test_invalid_version3(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(version_t) :: version - - call new_version(version, "one", error) - - end subroutine test_invalid_version3 - - - !> Check if overflows of the internal size constraint are handled gracefully - subroutine test_invalid_overflow(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(version_t) :: version - - call new_version(version, "0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0", error) - - end subroutine test_invalid_overflow - - -end module test_versioning diff --git a/fpm/test/fpm_test/testsuite.f90 b/fpm/test/fpm_test/testsuite.f90 deleted file mode 100644 index 124d19a..0000000 --- a/fpm/test/fpm_test/testsuite.f90 +++ /dev/null @@ -1,286 +0,0 @@ -!> Define some procedures to automate collecting and launching of tests -module testsuite - use fpm_error, only : error_t, test_failed => fatal_error - implicit none - private - - public :: run_testsuite, run_selected, new_unittest, new_testsuite, test_failed - public :: select_test, select_suite - public :: check_string - public :: unittest_t, testsuite_t, error_t - - - abstract interface - !> Entry point for tests - subroutine test_interface(error) - import :: error_t - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - end subroutine test_interface - end interface - - - !> Declaration of a unit test - type :: unittest_t - - !> Name of the test - character(len=:), allocatable :: name - - !> Entry point of the test - procedure(test_interface), pointer, nopass :: test => null() - - !> Whether test is supposed to fail - logical :: should_fail = .false. - - end type unittest_t - - - abstract interface - !> Collect all tests - subroutine collect_interface(testsuite) - import :: unittest_t - - !> Collection of tests - type(unittest_t), allocatable, intent(out) :: testsuite(:) - - end subroutine collect_interface - end interface - - - !> Collection of unit tests - type :: testsuite_t - - !> Name of the testsuite - character(len=:), allocatable :: name - - !> Entry point of the test - procedure(collect_interface), pointer, nopass :: collect => null() - - end type testsuite_t - - - character(len=*), parameter :: fmt = '("#", *(1x, a))' - character(len=*), parameter :: indent = repeat(" ", 5) // repeat(".", 3) - - -contains - - - !> Driver for testsuite - subroutine run_testsuite(collect, unit, stat) - - !> Collect tests - procedure(collect_interface) :: collect - - !> Unit for IO - integer, intent(in) :: unit - - !> Number of failed tests - integer, intent(inout) :: stat - - type(unittest_t), allocatable :: testsuite(:) - integer :: ii - - call collect(testsuite) - - do ii = 1, size(testsuite) - write(unit, '("#", 3(1x, a), 1x, "(", i0, "/", i0, ")")') & - & "Starting", testsuite(ii)%name, "...", ii, size(testsuite) - call run_unittest(testsuite(ii), unit, stat) - end do - - end subroutine run_testsuite - - - !> Driver for selective testing - subroutine run_selected(collect, name, unit, stat) - - !> Collect tests - procedure(collect_interface) :: collect - - !> Name of the selected test - character(len=*), intent(in) :: name - - !> Unit for IO - integer, intent(in) :: unit - - !> Number of failed tests - integer, intent(inout) :: stat - - type(unittest_t), allocatable :: testsuite(:) - integer :: ii - - call collect(testsuite) - - ii = select_test(testsuite, name) - - if (ii > 0 .and. ii <= size(testsuite)) then - call run_unittest(testsuite(ii), unit, stat) - else - write(unit, fmt) "Available tests:" - do ii = 1, size(testsuite) - write(unit, fmt) "-", testsuite(ii)%name - end do - stat = -huge(ii) - end if - - end subroutine run_selected - - - !> Run a selected unit test - subroutine run_unittest(test, unit, stat) - - !> Unit test - type(unittest_t), intent(in) :: test - - !> Unit for IO - integer, intent(in) :: unit - - !> Number of failed tests - integer, intent(inout) :: stat - - type(error_t), allocatable :: error - - call test%test(error) - if (allocated(error) .neqv. test%should_fail) then - if (test%should_fail) then - write(unit, fmt) indent, test%name, "[UNEXPECTED PASS]" - else - write(unit, fmt) indent, test%name, "[FAILED]" - end if - stat = stat + 1 - else - if (test%should_fail) then - write(unit, fmt) indent, test%name, "[EXPECTED FAIL]" - else - write(unit, fmt) indent, test%name, "[PASSED]" - end if - end if - if (allocated(error)) then - write(unit, fmt) "Message:", error%message - end if - - end subroutine run_unittest - - - !> Select a unit test from all available tests - function select_test(tests, name) result(pos) - - !> Name identifying the test suite - character(len=*), intent(in) :: name - - !> Available unit tests - type(unittest_t) :: tests(:) - - !> Selected test suite - integer :: pos - - integer :: it - - pos = 0 - do it = 1, size(tests) - if (name == tests(it)%name) then - pos = it - exit - end if - end do - - end function select_test - - - !> Select a test suite from all available suites - function select_suite(suites, name) result(pos) - - !> Name identifying the test suite - character(len=*), intent(in) :: name - - !> Available test suites - type(testsuite_t) :: suites(:) - - !> Selected test suite - integer :: pos - - integer :: it - - pos = 0 - do it = 1, size(suites) - if (name == suites(it)%name) then - pos = it - exit - end if - end do - - end function select_suite - - - !> Register a new unit test - function new_unittest(name, test, should_fail) result(self) - - !> Name of the test - character(len=*), intent(in) :: name - - !> Entry point for the test - procedure(test_interface) :: test - - !> Whether test is supposed to error or not - logical, intent(in), optional :: should_fail - - !> Newly registered test - type(unittest_t) :: self - - self%name = name - self%test => test - if (present(should_fail)) self%should_fail = should_fail - - end function new_unittest - - - !> Register a new testsuite - function new_testsuite(name, collect) result(self) - - !> Name of the testsuite - character(len=*), intent(in) :: name - - !> Entry point to collect tests - procedure(collect_interface) :: collect - - !> Newly registered testsuite - type(testsuite_t) :: self - - self%name = name - self%collect => collect - - end function new_testsuite - - - !> Check a deferred length character variable against a reference value - subroutine check_string(error, actual, expected, name) - - !> 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 diff --git a/fpm/test/help_test/help_test.f90 b/fpm/test/help_test/help_test.f90 deleted file mode 100644 index 8f0c455..0000000 --- a/fpm/test/help_test/help_test.f90 +++ /dev/null @@ -1,292 +0,0 @@ -program help_test -! note hardcoded len=k1 instead of len=: in this test is a work-around a gfortran bug in old -! pre-v8.3 versions -use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, stderr=>error_unit -use fpm_filesystem, only : dirname, join_path, exists -use fpm_environment, only : get_os_type, OS_WINDOWS -implicit none -integer :: i, j -integer :: be, af -character(len=:),allocatable :: path -integer :: estat, cstat -integer,parameter :: k1=132 -character(len=k1) :: message -logical,allocatable :: tally(:) -!intel-bug!character(len=:),allocatable :: book1(:), book2(:) -character(len=k1),allocatable :: book1(:), book2(:) -!intel-bug!character(len=:),allocatable :: page1(:) -character(len=k1),allocatable :: page1(:) -integer :: lines -integer :: chars -! run a variety of "fpm help" variations and verify expected files are generated -character(len=*),parameter :: cmds(*) = [character(len=80) :: & -! build manual as pieces using various help commands -! debug version -' --version ',& ! verify fpm version being used -' --help > fpm_scratch_help.txt',& -' help new >> fpm_scratch_help.txt',& -' help update >> fpm_scratch_help.txt',& -' build --help >> fpm_scratch_help.txt',& -' help run >> fpm_scratch_help.txt',& -' help test >> fpm_scratch_help.txt',& -' help runner >> fpm_scratch_help.txt',& -' help install >> fpm_scratch_help.txt',& -' help list >> fpm_scratch_help.txt',& -' help help >> fpm_scratch_help.txt',& -' --version >> fpm_scratch_help.txt',& -! generate manual -' help manual > fpm_scratch_manual.txt'] - -!'fpm run >> fpm_scratch_help.txt',& -!'fpm run -- --list >> fpm_scratch_help.txt',& -!'fpm run -- list --list >> fpm_scratch_help.txt',& -character(len=*),parameter :: names(*)=[character(len=10) ::& - 'fpm','new','update','build','run','test','runner','install','list','help'] -character(len=:), allocatable :: prog -integer :: length - - ! FIXME: Super hacky way to get the name of the fpm executable, - ! it works better than invoking fpm again but should be replaced ASAP. - call get_command_argument(0, length=length) - allocate(character(len=length) :: prog) - call get_command_argument(0, prog) - path = dirname(prog) - if (get_os_type() == OS_WINDOWS) then - prog = join_path(path, "..", "app", "fpm.exe") - if (.not.exists(prog)) then - prog = join_path(path, "..", "..", "app", "fpm.exe") - end if - else - prog = join_path(path, "..", "app", "fpm") - if (.not.exists(prog)) then - prog = join_path(path, "..", "..", "app", "fpm") - end if - end if - - write(*,'(g0:,1x)')'TEST help SUBCOMMAND STARTED' - if(allocated(tally))deallocate(tally) - allocate(tally(0)) - call wipe('fpm_scratch_help.txt') - call wipe('fpm_scratch_manual.txt') - - ! check that output has NAME SYNOPSIS DESCRIPTION - do i=1,size(names) - write(*,*)'check '//names(i)//' for NAME SYNOPSIS DESCRIPTION' - path= prog // ' help '//names(i)//' >fpm_scratch_help.txt' - message='' - call execute_command_line(path,exitstat=estat,cmdstat=cstat,cmdmsg=message) - write(*,'(*(g0))')'CMD=',path,' EXITSTAT=',estat,' CMDSTAT=',cstat,' MESSAGE=',trim(message) - tally=[tally,all([estat.eq.0,cstat.eq.0])] - call swallow('fpm_scratch_help.txt',page1) - if(size(page1).lt.3)then - write(*,*)'help for '//names(i)//' ridiculiously small' - tally=[tally,.false.] - exit - endif - !!write(*,*)findloc(page1,'NAME').eq.1 - be=count(.not.tally) - tally=[tally,count(page1.eq.'NAME').eq.1] - tally=[tally,count(page1.eq.'SYNOPSIS').eq.1] - tally=[tally,count(page1.eq.'DESCRIPTION').eq.1] - af=count(.not.tally) - if(be.ne.af)then - write(*,*)'missing expected sections in ',names(i) - write(*,*)page1(1) ! assuming at least size 1 for debugging mingw - write(*,*)count(page1.eq.'NAME') - write(*,*)count(page1.eq.'SYNOPSIS') - write(*,*)count(page1.eq.'DESCRIPTION') - write(*,'(a)')page1 - endif - write(*,*)'have completed ',count(tally),' tests' - call wipe('fpm_scratch_help.txt') - enddo - - - ! execute the fpm(1) commands - do i=1,size(cmds) - message='' - path= prog // cmds(i) - call execute_command_line(path,exitstat=estat,cmdstat=cstat,cmdmsg=message) - write(*,'(*(g0))')'CMD=',path,' EXITSTAT=',estat,' CMDSTAT=',cstat,' MESSAGE=',trim(message) - tally=[tally,all([estat.eq.0,cstat.eq.0])] - enddo - - ! compare book written in fragments with manual - call swallow('fpm_scratch_help.txt',book1) - call swallow('fpm_scratch_manual.txt',book2) - ! get rid of lines from run() which is not on stderr at the moment - book1=pack(book1,index(book1,' + build/').eq.0) - book2=pack(book1,index(book2,' + build/').eq.0) - write(*,*)'book1 ',size(book1), len(book1) - write(*,*)'book2 ',size(book2), len(book2) - if(size(book1).ne.size(book2))then - write(*,*)'manual and "debug" appended pages are not the same size' - tally=[tally,.false.] - else - if(all(book1.ne.book2))then - tally=[tally,.false.] - write(*,*)'manual and "debug" appended pages are not the same' - else - write(*,*)'manual and "debug" appended pages are the same' - tally=[tally,.true.] - endif - endif - - ! overall size of manual - !chars=size(book2) - !lines=max(count(char(10).eq.book2),count(char(13).eq.book2)) - chars=sum(len_trim(book2)) ! SUM TRIMMED LENGTH - lines=size(book2) - if( (chars.lt.12000) .or. (lines.lt.350) )then - write(*,*)'"debug" manual is suspiciously small, bytes=',chars,' lines=',lines - tally=[tally,.false.] - else - write(*,*)'"debug" manual size in bytes=',chars,' lines=',lines - tally=[tally,.true.] - endif - - write(*,'("HELP TEST TALLY=",*(g0))')tally - call wipe('fpm_scratch_help.txt') - call wipe('fpm_scratch_manual.txt') - if(all(tally))then - write(*,'(*(g0))')'PASSED: all ',count(tally),' tests passed ' - else - write(*,*)'FAILED: PASSED=',count(tally),' FAILED=',count(.not.tally) - stop 5 - endif - write(*,'(g0:,1x)')'TEST help SUBCOMMAND COMPLETE' -contains - -subroutine wipe(filename) -character(len=*),intent(in) :: filename -integer :: ios -integer :: lun -character(len=k1) :: message -open(file=filename,newunit=lun,iostat=ios,iomsg=message) -if(ios.eq.0)then - close(unit=lun,iostat=ios,status='delete',iomsg=message) - if(ios.ne.0)then - write(*,*)''//trim(message) - endif -else - write(*,*)''//trim(message) -endif -end subroutine wipe - -subroutine slurp(filename,text) -implicit none -!$@(#) M_io::slurp(3f): allocate text array and read file filename into it -character(*),intent(in) :: filename ! filename to shlep -character(len=1),allocatable,intent(out) :: text(:) ! array to hold file -integer :: nchars, igetunit, ios -character(len=k1) :: message -character(len=4096) :: local_filename - ios=0 - nchars=0 - message='' - open(newunit=igetunit, file=trim(filename), action="read", iomsg=message,& - &form="unformatted", access="stream",status='old',iostat=ios) - local_filename=filename - if(ios.eq.0)then ! if file was successfully opened - inquire(unit=igetunit, size=nchars) - if(nchars.le.0)then - call stderr_local( '*slurp* empty file '//trim(local_filename) ) - return - endif - ! read file into text array - if(allocated(text))deallocate(text) ! make sure text array not allocated - allocate ( text(nchars) ) ! make enough storage to hold file - read(igetunit,iostat=ios,iomsg=message) text ! load input file -> text array - if(ios.ne.0)then - call stderr_local( '*slurp* bad read of '//trim(local_filename)//':'//trim(message) ) - endif - else - call stderr_local('*slurp* '//message) - allocate ( text(0) ) ! make enough storage to hold file - endif - close(iostat=ios,unit=igetunit) ! close if opened successfully or not -end subroutine slurp - -subroutine stderr_local(message) -character(len=*) :: message - write(*,'(a)')trim(message) ! write message to standard error -end subroutine stderr_local - -subroutine swallow(FILENAME,pageout) -implicit none -character(len=*),intent(in) :: FILENAME ! file to read -!intel-bug!character(len=:),allocatable,intent(out) :: pageout(:) ! page to hold file in memory -character(len=k1),allocatable,intent(out) :: pageout(:) ! page to hold file in memory -character(len=1),allocatable :: text(:) ! array to hold file in memory - - call slurp(FILENAME,text) ! allocate character array and copy file into it - - if(.not.allocated(text))then - write(*,*)'*swallow* failed to load file '//FILENAME - else ! convert array of characters to array of lines - pageout=page(text) - deallocate(text) ! release memory - endif -end subroutine swallow - -function page(array) result (table) - -!$@(#) M_strings::page(3fp): function to copy char array to page of text - -character(len=1),intent(in) :: array(:) -!intel-bug!character(len=:),allocatable :: table(:) -character(len=k1),allocatable :: table(:) -integer :: i -integer :: linelength -integer :: length -integer :: lines -integer :: linecount -integer :: position -integer :: sz -!!character(len=1),parameter :: nl=new_line('A') -character(len=1),parameter :: nl=char(10) -character(len=1),parameter :: cr=char(13) - lines=0 - linelength=0 - length=0 - sz=size(array) - do i=1,sz - if(array(i).eq.nl)then - linelength=max(linelength,length) - lines=lines+1 - length=0 - else - length=length+1 - endif - enddo - if(sz.gt.0)then - if(array(sz).ne.nl)then - lines=lines+1 - endif - endif - - if(allocated(table))deallocate(table) - !intel-bug!allocate(character(len=linelength) :: table(lines)) - allocate(character(len=k1) :: table(lines)) - table=' ' - linecount=1 - position=1 - do i=1,sz - if(array(i).eq.nl)then - linecount=linecount+1 - position=1 - elseif(array(i).eq.cr)then - elseif(linelength.ne.0)then - if(position.gt.len(table))then - write(*,*)' adding character past edge of text',table(linecount),array(i) - elseif(linecount.gt.size(table))then - write(*,*)' adding line past end of text',linecount,size(table) - else - table(linecount)(position:position)=array(i) - endif - position=position+1 - endif - enddo -end function page - -end program help_test diff --git a/fpm/test/new_test/new_test.f90 b/fpm/test/new_test/new_test.f90 deleted file mode 100644 index 3c8c453..0000000 --- a/fpm/test/new_test/new_test.f90 +++ /dev/null @@ -1,187 +0,0 @@ -program new_test -use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, stderr=>error_unit -use fpm_filesystem, only : is_dir, list_files, exists, windows_path, join_path, & - dirname -use fpm_strings, only : string_t, operator(.in.) -use fpm_environment, only : run, get_os_type -use fpm_environment, only : OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_WINDOWS -implicit none -type(string_t), allocatable :: file_names(:) -integer :: i, j, k -character(len=:),allocatable :: cmdpath -character(len=:),allocatable :: path -character(len=*),parameter :: scr = 'fpm_scratch_' -character(len=*),parameter :: cmds(*) = [character(len=80) :: & -! run a variety of "fpm new" variations and verify expected files are generated -' new', & -' new name-with-hyphens', & -' new '//scr//'A', & -' new '//scr//'B --lib', & -' new '//scr//'C --app', & -' new '//scr//'D --test', & -' new '//scr//'E --lib --test ', & -' new '//scr//'F --lib --app', & -' new '//scr//'G --test --app', & -' new '//scr//'H --example', & -' new '//scr//'BB --lib', & -' new '//scr//'BB --test ', & -' new '//scr//'BB --backfill --test', & -' new '//scr//'CC --test --src --app', & -' new --version', & -' new --help'] -integer :: estat, cstat -character(len=256) :: message -character(len=:),allocatable :: directories(:) -character(len=:),allocatable :: shortdirs(:) -character(len=:),allocatable :: expected(:) -logical,allocatable :: tally(:) -logical :: IS_OS_WINDOWS - write(*,'(g0:,1x)')'TEST new SUBCOMMAND (draft):' - - cmdpath = get_command_path() - allocate(tally(0)) - shortdirs=[character(len=80) :: 'A','B','C','D','E','F','G','H','BB','CC'] - allocate(character(len=80) :: directories(size(shortdirs))) - - !! SEE IF EXPECTED FILES ARE GENERATED - !! Issues: - !! o assuming fpm command is in expected path and the new version - !! o DOS versus POSIX filenames - is_os_windows=.false. - select case (get_os_type()) - case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD) - call execute_command_line('rm -rf fpm_scratch_*',exitstat=estat,cmdstat=cstat,cmdmsg=message) - path=cmdpath - case (OS_WINDOWS) - path=windows_path(cmdpath) - is_os_windows=.true. - call execute_command_line('rmdir fpm_scratch_* /s /q',exitstat=estat,cmdstat=cstat,cmdmsg=message) - case default - write(*,*)'ERROR: unknown OS. Stopping test' - stop 2 - end select - do i=1,size(directories) - directories(i)=scr//trim(shortdirs(i)) - if( is_dir(trim(directories(i))) ) then - write(*,*)'ERROR:',trim( directories(i) ),' already exists' - write(*,*)' you must remove scratch directories before performing this test' - write(*,'(*(g0:,1x))')'directories:',(trim(directories(j)),j=1,size(directories)),'name-with-hyphens' - stop - endif - enddo - ! execute the fpm(1) commands - do i=1,size(cmds) - message='' - write(*,*)path//' '//cmds(i) - call execute_command_line(path//' '//cmds(i),exitstat=estat,cmdstat=cstat,cmdmsg=message) - write(*,'(*(g0))')'CMD=',trim(cmds(i)),' EXITSTAT=',estat,' CMDSTAT=',cstat,' MESSAGE=',trim(message) - enddo - - if( is_dir('name-with-hyphens') ) then - tally=[tally,.true.] - - else - write(*,*)'ERROR: directory name-with-hyphens/ exists' - tally=[tally,.false.] - endif - - ! assuming hidden files in .git and .gitignore are ignored for now - TESTS: do i=1,size(directories) - ! test if expected directory exists - if( .not. is_dir(trim( directories(i))) ) then - tally=[tally,.false.] - write(*,*)'ERROR:',trim( directories(i) ),' is not a directory' - else - select case(shortdirs(i)) - case('A'); expected=[ character(len=80)::& - &'A/app','A/fpm.toml','A/README.md','A/src','A/test','A/app/main.f90','A/src/'//scr//'A.f90','A/test/check.f90'] - case('B'); expected=[ character(len=80)::& - &'B/fpm.toml','B/README.md','B/src','B/src/'//scr//'B.f90'] - case('C'); expected=[ character(len=80)::& - &'C/app','C/fpm.toml','C/README.md','C/app/main.f90'] - case('D'); expected=[ character(len=80)::& - &'D/fpm.toml','D/README.md','D/test','D/test/check.f90'] - case('E'); expected=[ character(len=80)::& - &'E/fpm.toml','E/README.md','E/src','E/test','E/src/'//scr//'E.f90','E/test/check.f90'] - case('F'); expected=[ character(len=80)::& - &'F/app','F/fpm.toml','F/README.md','F/src','F/app/main.f90','F/src/'//scr//'F.f90'] - case('G'); expected=[ character(len=80)::& - &'G/app','G/fpm.toml','G/README.md','G/test','G/app/main.f90','G/test/check.f90'] - case('H'); expected=[ character(len=80)::& - &'H/example','H/fpm.toml','H/README.md','H/example/demo.f90'] - case('BB'); expected=[ character(len=80)::& - &'BB/fpm.toml','BB/README.md','BB/src','BB/test','BB/src/'//scr//'BB.f90','BB/test/check.f90'] - case('CC'); expected=[ character(len=80)::& - &'CC/app','CC/fpm.toml','CC/README.md','CC/src','CC/test','CC/app/main.f90','CC/src/'//scr//'CC.f90','CC/test/check.f90'] - case default - write(*,*)'ERROR: internal error. unknown directory name ',trim(shortdirs(i)) - stop 4 - end select - !! MSwindows has hidden files in it - !! Warning: This only looks for expected files. If there are more files than expected it does not fail - call list_files(trim(directories(i)), file_names,recurse=.true.) - - if(size(expected).ne.size(file_names))then - write(*,*)'WARNING: unexpected number of files in file list=',size(file_names),' expected ',size(expected) - write(*,'("EXPECTED: ",*(g0:,","))')(scr//trim(expected(j)),j=1,size(expected)) - write(*,'("FOUND: ",*(g0:,","))')(trim(file_names(j)%s),j=1,size(file_names)) - endif - - do j=1,size(expected) - - expected(j)=scr//expected(j) - if(is_os_windows) expected(j)=windows_path(expected(j)) - if( .not.(trim(expected(j)).in.file_names) )then - tally=[tally,.false.] - write(*,'("ERROR: FOUND ",*(g0:,", "))')( trim(file_names(k)%s), k=1,size(file_names) ) - write(*,'(*(g0))')' BUT NO MATCH FOR ',expected(j) - tally=[tally,.false.] - cycle TESTS - endif - enddo - tally=[tally,.true.] - endif - enddo TESTS - - ! clean up scratch files; might want an option to leave them for inspection - select case (get_os_type()) - case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD) - call execute_command_line('rm -rf fpm_scratch_*',exitstat=estat,cmdstat=cstat,cmdmsg=message) - case (OS_WINDOWS) - call execute_command_line('rmdir fpm_scratch_* /s /q',exitstat=estat,cmdstat=cstat,cmdmsg=message) - end select - - write(*,'("new TEST TALLY=",*(g0))')tally - if(all(tally))then - write(*,'(*(g0))')'PASSED: all ',count(tally),' tests passed ' - else - write(*,*)'FAILED: PASSED=',count(tally),' FAILED=',count(.not.tally) - stop 5 - endif -contains - function get_command_path() result(prog) - character(len=:), allocatable :: prog - - character(len=:), allocatable :: path - integer :: length - - ! FIXME: Super hacky way to get the name of the fpm executable, - ! it works better than invoking fpm again but should be replaced ASAP. - call get_command_argument(0, length=length) - allocate(character(len=length) :: prog) - call get_command_argument(0, prog) - path = dirname(prog) - if (get_os_type() == OS_WINDOWS) then - prog = join_path(path, "..", "app", "fpm.exe") - if (.not.exists(prog)) then - prog = join_path(path, "..", "..", "app", "fpm.exe") - end if - else - prog = join_path(path, "..", "app", "fpm") - if (.not.exists(prog)) then - prog = join_path(path, "..", "..", "app", "fpm") - end if - end if - - end function -end program new_test diff --git a/install.sh b/install.sh index de2aaa8..7f3908b 100755 --- a/install.sh +++ b/install.sh @@ -7,33 +7,18 @@ usage() echo "Fortran Package Manager Bootstrap Script" echo "" echo "USAGE:" - echo "./install.sh [--help | [--prefix=PREFIX] [--update[=REF]]" - echo " [--no-openmp] [--static] [--haskell] ]" + echo "./install.sh [--help | [--prefix=PREFIX]" echo "" echo " --help Display this help text" echo " --prefix=PREFIX Install binary in 'PREFIX/bin'" echo " Default prefix='\$HOME/.local/bin'" - echo " --update[=REF] Update repository from latest release tag" - echo " or from git reference REF if specified" - echo " --no-openmp Don't build fpm with openmp support" - echo " --static Statically link fpm executable" - echo " (implies --no-openmp)" - echo " --haskell Only install Haskell fpm" echo "" - echo " '--no-openmp' and '--static' do not affect the Haskell fpm" - echo " build." + echo "FC and FFLAGS environment variables can be used to select the" + echo "Fortran compiler and the build flags." echo "" } PREFIX="$HOME/.local" -UPDATE=false -OMP=true -STATIC=false -HASKELL_ONLY=false - -STACK_BIN_PATH="$HOME/.local/bin" -REF=$(git describe --tag --abbrev=0) -RELEASE_FLAGS="--flag -g --flag -fbacktrace --flag -O3" while [ "$1" != "" ]; do PARAM=$(echo "$1" | awk -F= '{print $1}') @@ -46,22 +31,6 @@ while [ "$1" != "" ]; do --prefix) PREFIX=$VALUE ;; - --update) - UPDATE=true - if [ "$VALUE" != "" ]; then - REF=$VALUE - fi - ;; - --no-openmp) - OMP=false - ;; - --static) - STATIC=true - OMP=false - ;; - --haskell) - HASKELL_ONLY=true - ;; *) echo "ERROR: unknown parameter \"$PARAM\"" usage @@ -73,59 +42,18 @@ done set -u # error on use of undefined variable -INSTALL_PATH="$PREFIX/bin" - -if command -v stack 1> /dev/null 2>&1 ; then - echo "Found stack" -else - echo "Haskell stack not found." - echo "Installing Haskell stack" - curl -sSL https://get.haskellstack.org/ | sh - if command -v stack 1> /dev/null 2>&1 ; then - echo "Haskell stack installation successful." - else - echo "ERROR: Haskell stack installation unsuccessful." - exit 1 - fi +SOURCE_URL="https://github.com/fortran-lang/fpm/releases/download/v0.2.0/fpm-0.2.0.f90" +BOOTSTRAP_DIR="build/bootstrap" +if [ -z ${FC+x} ]; then + FC="gfortran" fi - -if [ -x "$INSTALL_PATH/fpm" ]; then - echo "Overwriting existing fpm installation in $INSTALL_PATH" +if [ -z ${FFLAGS+x} ]; then + FFLAGS="-g -fbacktrace -O3" fi -if [ "$UPDATE" = true ]; then - git checkout "$REF" - if [ $? != 0 ]; then - echo "ERROR: Unable to checkout $REF." - exit 1 - fi -fi +mkdir -p $BOOTSTRAP_DIR +curl -LJ $SOURCE_URL > $BOOTSTRAP_DIR/fpm.f90 +$FC $FFLAGS -J $BOOTSTRAP_DIR $BOOTSTRAP_DIR/fpm.f90 -o $BOOTSTRAP_DIR/fpm -cd bootstrap -stack install - -if [ "$STACK_BIN_PATH" != "$INSTALL_PATH" ]; then - mv "$STACK_BIN_PATH/fpm" "$INSTALL_PATH/" -fi - -if [ "$HASKELL_ONLY" = true ]; then - exit -fi - -if [ "$STATIC" = true ]; then - RELEASE_FLAGS="$RELEASE_FLAGS --flag -static" -fi - -if [ "$OMP" = true ]; then - RELEASE_FLAGS="$RELEASE_FLAGS --flag -fopenmp" -fi - -cd ../fpm -"$INSTALL_PATH/fpm" run $RELEASE_FLAGS --runner mv -- "$INSTALL_PATH/" - -if [ -x "$INSTALL_PATH/fpm" ]; then - echo "fpm installed successfully to $INSTALL_PATH" -else - echo "ERROR: fpm installation unsuccessful: fpm not found in $INSTALL_PATH" - exit 1 -fi +$BOOTSTRAP_DIR/fpm install --compiler "$FC" --flag "$FFLAGS" --prefix "$PREFIX" +rm -r $BOOTSTRAP_DIR diff --git a/manifest-reference.md b/manifest-reference.md index b40eef8..1a33dc1 100644 --- a/manifest-reference.md +++ b/manifest-reference.md @@ -217,27 +217,6 @@ include-dir = ["include", "third_party/include"] > *include-dir* does not currently allow using pre-built module `.mod` files -#### Custom build script - -> Supported in Bootstrap fpm only - -Projects with custom build scripts can specify those in the *build-script* entry. -The custom build script will be executed when the library build step is reached. - -*Example:* - -```toml -[library] -build-script = "build.sh" -``` - -Build scripts written in ``make`` are automatically detected and executed with ``make`` - -```toml -[library] -build-script = "Makefile" -``` - ### Executable targets diff --git a/src/fpm.f90 b/src/fpm.f90 new file mode 100644 index 0000000..31b68ff --- /dev/null +++ b/src/fpm.f90 @@ -0,0 +1,467 @@ +module fpm +use fpm_strings, only: string_t, operator(.in.), glob, join, string_cat +use fpm_backend, only: build_package +use fpm_command_line, only: fpm_build_settings, fpm_new_settings, & + fpm_run_settings, fpm_install_settings, fpm_test_settings +use fpm_dependency, only : new_dependency_tree +use fpm_environment, only: run +use fpm_filesystem, only: is_dir, join_path, number_of_rows, list_files, exists, basename +use fpm_model, only: fpm_model_t, srcfile_t, show_model, & + FPM_SCOPE_UNKNOWN, FPM_SCOPE_LIB, FPM_SCOPE_DEP, & + FPM_SCOPE_APP, FPM_SCOPE_EXAMPLE, FPM_SCOPE_TEST +use fpm_compiler, only: get_module_flags, is_unknown_compiler + + +use fpm_sources, only: add_executable_sources, add_sources_from_dir +use fpm_targets, only: targets_from_sources, resolve_module_dependencies, & + resolve_target_linking, build_target_t, build_target_ptr, & + FPM_TARGET_EXECUTABLE, FPM_TARGET_ARCHIVE +use fpm_manifest, only : get_package_data, package_config_t +use fpm_error, only : error_t, fatal_error +use fpm_manifest_test, only : test_config_t +use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, & + & stdout=>output_unit, & + & stderr=>error_unit +use fpm_manifest_dependency, only: dependency_config_t +use, intrinsic :: iso_fortran_env, only: error_unit +implicit none +private +public :: cmd_build, cmd_run +public :: build_model, check_modules_for_duplicates + +contains + + +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_config_t), intent(in) :: package + type(error_t), allocatable, intent(out) :: error + + integer :: i, j + type(package_config_t) :: dependency + character(len=:), allocatable :: manifest, lib_dir + + logical :: duplicates_found = .false. + type(string_t) :: include_dir + + model%package_name = package%name + + allocate(model%include_dirs(0)) + allocate(model%link_libraries(0)) + + call new_dependency_tree(model%deps, cache=join_path("build", "cache.toml")) + call model%deps%add(package, error) + if (allocated(error)) return + + if(settings%compiler.eq.'')then + model%fortran_compiler = 'gfortran' + else + model%fortran_compiler = settings%compiler + endif + + if (is_unknown_compiler(model%fortran_compiler)) then + write(*, '(*(a:,1x))') & + "", "Unknown compiler", model%fortran_compiler, "requested!", & + "Defaults for this compiler might be incorrect" + end if + model%output_directory = join_path('build',basename(model%fortran_compiler)//'_'//settings%build_name) + + call get_module_flags(model%fortran_compiler, & + & join_path(model%output_directory,model%package_name), & + & model%fortran_compile_flags) + model%fortran_compile_flags = settings%flag // model%fortran_compile_flags + + allocate(model%packages(model%deps%ndep)) + + ! Add sources from executable directories + if (is_dir('app') .and. package%build%auto_executables) then + call add_sources_from_dir(model%packages(1)%sources,'app', FPM_SCOPE_APP, & + with_executables=.true., error=error) + + if (allocated(error)) then + return + end if + + end if + if (is_dir('example') .and. package%build%auto_examples) then + call add_sources_from_dir(model%packages(1)%sources,'example', FPM_SCOPE_EXAMPLE, & + with_executables=.true., error=error) + + if (allocated(error)) then + return + end if + + end if + if (is_dir('test') .and. package%build%auto_tests) then + call add_sources_from_dir(model%packages(1)%sources,'test', FPM_SCOPE_TEST, & + with_executables=.true., error=error) + + if (allocated(error)) then + return + endif + + end if + if (allocated(package%executable)) then + call add_executable_sources(model%packages(1)%sources, package%executable, FPM_SCOPE_APP, & + auto_discover=package%build%auto_executables, & + error=error) + + if (allocated(error)) then + return + end if + + end if + if (allocated(package%example)) then + call add_executable_sources(model%packages(1)%sources, package%example, FPM_SCOPE_EXAMPLE, & + auto_discover=package%build%auto_examples, & + error=error) + + if (allocated(error)) then + return + end if + + end if + if (allocated(package%test)) then + call add_executable_sources(model%packages(1)%sources, package%test, FPM_SCOPE_TEST, & + auto_discover=package%build%auto_tests, & + error=error) + + if (allocated(error)) then + return + endif + + endif + + do i = 1, model%deps%ndep + associate(dep => model%deps%dep(i)) + manifest = join_path(dep%proj_dir, "fpm.toml") + + call get_package_data(dependency, manifest, error, & + apply_defaults=.true.) + if (allocated(error)) exit + + model%packages(i)%name = dependency%name + if (.not.allocated(model%packages(i)%sources)) allocate(model%packages(i)%sources(0)) + + if (allocated(dependency%library)) then + + if (allocated(dependency%library%source_dir)) then + lib_dir = join_path(dep%proj_dir, dependency%library%source_dir) + if (is_dir(lib_dir)) then + call add_sources_from_dir(model%packages(i)%sources, lib_dir, FPM_SCOPE_LIB, & + error=error) + if (allocated(error)) exit + end if + end if + + if (allocated(dependency%library%include_dir)) then + do j=1,size(dependency%library%include_dir) + include_dir%s = join_path(dep%proj_dir, dependency%library%include_dir(j)%s) + if (is_dir(include_dir%s)) then + model%include_dirs = [model%include_dirs, include_dir] + end if + end do + end if + + end if + + if (allocated(dependency%build%link)) then + model%link_libraries = [model%link_libraries, dependency%build%link] + end if + end associate + end do + if (allocated(error)) return + + if (settings%verbose) then + write(*,*)' BUILD_NAME: ',settings%build_name + write(*,*)' COMPILER: ',settings%compiler + write(*,*)' COMPILER OPTIONS: ', model%fortran_compile_flags + write(*,*)' INCLUDE DIRECTORIES: [', string_cat(model%include_dirs,','),']' + end if + + ! Check for duplicate modules + call check_modules_for_duplicates(model, duplicates_found) + if (duplicates_found) then + error stop 'Error: One or more duplicate module names found.' + end if +end subroutine build_model + +! Check for duplicate modules +subroutine check_modules_for_duplicates(model, duplicates_found) + type(fpm_model_t), intent(in) :: model + integer :: maxsize + integer :: i,j,k,l,m,modi + type(string_t), allocatable :: modules(:) + logical :: duplicates_found + ! Initialise the size of array + maxsize = 0 + ! Get number of modules provided by each source file of every package + do i=1,size(model%packages) + do j=1,size(model%packages(i)%sources) + if (allocated(model%packages(i)%sources(j)%modules_provided)) then + maxsize = maxsize + size(model%packages(i)%sources(j)%modules_provided) + end if + end do + end do + ! Allocate array to contain distinct names of modules + allocate(modules(maxsize)) + + ! Initialise index to point at start of the newly allocated array + modi = 1 + + ! Loop through modules provided by each source file of every package + ! Add it to the array if it is not already there + ! Otherwise print out warning about duplicates + do k=1,size(model%packages) + do l=1,size(model%packages(k)%sources) + if (allocated(model%packages(k)%sources(l)%modules_provided)) then + do m=1,size(model%packages(k)%sources(l)%modules_provided) + if (model%packages(k)%sources(l)%modules_provided(m)%s.in.modules(:modi-1)) then + write(error_unit, *) "Warning: Module ",model%packages(k)%sources(l)%modules_provided(m)%s, & + " in ",model%packages(k)%sources(l)%file_name," is a duplicate" + duplicates_found = .true. + else + modules(modi) = model%packages(k)%sources(l)%modules_provided(m) + modi = modi + 1 + end if + end do + end if + end do + end do +end subroutine check_modules_for_duplicates + +subroutine cmd_build(settings) +type(fpm_build_settings), intent(in) :: settings +type(package_config_t) :: package +type(fpm_model_t) :: model +type(build_target_ptr), allocatable :: targets(:) +type(error_t), allocatable :: error + +integer :: i + +call get_package_data(package, "fpm.toml", error, apply_defaults=.true.) +if (allocated(error)) then + print '(a)', error%message + error stop 1 +end if + +call build_model(model, settings, package, error) +if (allocated(error)) then + print '(a)', error%message + error stop 1 +end if + +call targets_from_sources(targets,model,error) +if (allocated(error)) then + print '(a)', error%message + error stop 1 +end if + +if(settings%list)then + do i=1,size(targets) + write(stderr,*) targets(i)%ptr%output_file + enddo +else if (settings%show_model) then + call show_model(model) +else + call build_package(targets,model) +endif + +end subroutine + +subroutine cmd_run(settings,test) + class(fpm_run_settings), intent(in) :: settings + logical, intent(in) :: test + + integer :: i, j, col_width + logical :: found(size(settings%name)) + type(error_t), allocatable :: error + type(package_config_t) :: package + type(fpm_model_t) :: model + type(build_target_ptr), allocatable :: targets(:) + type(string_t) :: exe_cmd + type(string_t), allocatable :: executables(:) + type(build_target_t), pointer :: exe_target + type(srcfile_t), pointer :: exe_source + integer :: run_scope + character(len=:),allocatable :: line + logical :: toomany + + call get_package_data(package, "fpm.toml", error, apply_defaults=.true.) + if (allocated(error)) then + print '(a)', error%message + error stop 1 + end if + + call build_model(model, settings%fpm_build_settings, package, error) + if (allocated(error)) then + print '(a)', error%message + error stop 1 + end if + + call targets_from_sources(targets,model,error) + if (allocated(error)) then + print '(a)', error%message + error stop 1 + end if + + if (test) then + run_scope = FPM_SCOPE_TEST + else + run_scope = merge(FPM_SCOPE_EXAMPLE, FPM_SCOPE_APP, settings%example) + end if + + ! Enumerate executable targets to run + col_width = -1 + found(:) = .false. + allocate(executables(0)) + do i=1,size(targets) + + exe_target => targets(i)%ptr + + if (exe_target%target_type == FPM_TARGET_EXECUTABLE .and. & + allocated(exe_target%dependencies)) then + + exe_source => exe_target%dependencies(1)%ptr%source + + if (exe_source%unit_scope == run_scope) then + + col_width = max(col_width,len(basename(exe_target%output_file))+2) + + if (size(settings%name) == 0) then + + exe_cmd%s = exe_target%output_file + executables = [executables, exe_cmd] + + else + + do j=1,size(settings%name) + + if (glob(trim(exe_source%exe_name),trim(settings%name(j)))) then + + found(j) = .true. + exe_cmd%s = exe_target%output_file + executables = [executables, exe_cmd] + + end if + + end do + + end if + + end if + + end if + + end do + + ! Check if any apps/tests were found + if (col_width < 0) then + if (test) then + write(stderr,*) 'No tests to run' + else + write(stderr,*) 'No executables to run' + end if + stop + end if + + ! Check all names are valid + ! or no name and found more than one file + toomany= size(settings%name).eq.0 .and. size(executables).gt.1 + if ( any(.not.found) & + & .or. & + & ( (toomany .and. .not.test) .or. (toomany .and. settings%runner .ne. '') ) & + & .and. & + & .not.settings%list) then + line=join(settings%name) + if(line.ne.'.')then ! do not report these special strings + if(any(.not.found))then + write(stderr,'(A)',advance="no")'fpm::run specified names ' + do j=1,size(settings%name) + if (.not.found(j)) write(stderr,'(A)',advance="no") '"'//trim(settings%name(j))//'" ' + end do + write(stderr,'(A)') 'not found.' + write(stderr,*) + else if(settings%verbose)then + write(stderr,'(A)',advance="yes")'when more than one executable is available' + write(stderr,'(A)',advance="yes")' program names must be specified.' + endif + endif + + call compact_list_all() + + if(line.eq.'.' .or. line.eq.' ')then ! do not report these special strings + stop + else + stop 1 + endif + + end if + + call build_package(targets,model) + + if (settings%list) then + call compact_list() + else + + do i=1,size(executables) + if (exists(executables(i)%s)) then + if(settings%runner .ne. ' ')then + call run(settings%runner//' '//executables(i)%s//" "//settings%args,echo=settings%verbose) + else + call run(executables(i)%s//" "//settings%args,echo=settings%verbose) + endif + else + write(stderr,*)'fpm::run',executables(i)%s,' not found' + stop 1 + end if + end do + endif + contains + subroutine compact_list_all() + integer, parameter :: LINE_WIDTH = 80 + integer :: i, j, nCol + j = 1 + nCol = LINE_WIDTH/col_width + write(stderr,*) 'Available names:' + do i=1,size(targets) + + exe_target => targets(i)%ptr + + if (exe_target%target_type == FPM_TARGET_EXECUTABLE .and. & + allocated(exe_target%dependencies)) then + + exe_source => exe_target%dependencies(1)%ptr%source + + if (exe_source%unit_scope == run_scope) then + + write(stderr,'(A)',advance=(merge("yes","no ",modulo(j,nCol)==0))) & + & [character(len=col_width) :: basename(exe_target%output_file)] + j = j + 1 + + end if + end if + end do + write(stderr,*) + end subroutine compact_list_all + + subroutine compact_list() + integer, parameter :: LINE_WIDTH = 80 + integer :: i, j, nCol + j = 1 + nCol = LINE_WIDTH/col_width + write(stderr,*) 'Matched names:' + do i=1,size(executables) + write(stderr,'(A)',advance=(merge("yes","no ",modulo(j,nCol)==0))) & + & [character(len=col_width) :: basename(executables(i)%s)] + j = j + 1 + enddo + write(stderr,*) + end subroutine compact_list + +end subroutine cmd_run + +end module fpm diff --git a/src/fpm/cmd/install.f90 b/src/fpm/cmd/install.f90 new file mode 100644 index 0000000..db7a9f8 --- /dev/null +++ b/src/fpm/cmd/install.f90 @@ -0,0 +1,176 @@ +module fpm_cmd_install + use, intrinsic :: iso_fortran_env, only : output_unit + use fpm, only : build_model + use fpm_backend, only : build_package + use fpm_command_line, only : fpm_install_settings + use fpm_error, only : error_t, fatal_error + use fpm_filesystem, only : join_path, list_files + use fpm_installer, only : installer_t, new_installer + use fpm_manifest, only : package_config_t, get_package_data + use fpm_model, only : fpm_model_t, FPM_SCOPE_APP + use fpm_targets, only: targets_from_sources, build_target_t, & + build_target_ptr, FPM_TARGET_EXECUTABLE + use fpm_strings, only : string_t, resize + implicit none + private + + public :: cmd_install + +contains + + !> Entry point for the fpm-install subcommand + subroutine cmd_install(settings) + !> Representation of the command line settings + type(fpm_install_settings), intent(in) :: settings + type(package_config_t) :: package + type(error_t), allocatable :: error + type(fpm_model_t) :: model + type(build_target_ptr), allocatable :: targets(:) + type(installer_t) :: installer + character(len=:), allocatable :: lib, exe, dir + logical :: installable + + call get_package_data(package, "fpm.toml", error, apply_defaults=.true.) + call handle_error(error) + + call build_model(model, settings%fpm_build_settings, package, error) + call handle_error(error) + + call targets_from_sources(targets,model,error) + call handle_error(error) + + installable = (allocated(package%library) .and. package%install%library) & + .or. allocated(package%executable) + if (.not.installable) then + call fatal_error(error, "Project does not contain any installable targets") + call handle_error(error) + end if + + if (settings%list) then + call install_info(output_unit, package, model, targets) + return + end if + + if (.not.settings%no_rebuild) then + call build_package(targets,model) + end if + + call new_installer(installer, prefix=settings%prefix, & + bindir=settings%bindir, libdir=settings%libdir, & + includedir=settings%includedir, & + verbosity=merge(2, 1, settings%verbose)) + + if (allocated(package%library) .and. package%install%library) then + dir = join_path(model%output_directory, model%package_name) + lib = "lib"//model%package_name//".a" + call installer%install_library(join_path(dir, lib), error) + call handle_error(error) + + call install_module_files(installer, dir, error) + call handle_error(error) + end if + + if (allocated(package%executable)) then + call install_executables(installer, targets, error) + call handle_error(error) + end if + + end subroutine cmd_install + + subroutine install_info(unit, package, model, targets) + integer, intent(in) :: unit + type(package_config_t), intent(in) :: package + type(fpm_model_t), intent(in) :: model + type(build_target_ptr), intent(in) :: targets(:) + + integer :: ii, ntargets + character(len=:), allocatable :: lib + type(string_t), allocatable :: install_target(:) + + call resize(install_target) + + ntargets = 0 + if (allocated(package%library) .and. package%install%library) then + ntargets = ntargets + 1 + lib = join_path(model%output_directory, model%package_name, & + "lib"//model%package_name//".a") + install_target(ntargets)%s = lib + end if + do ii = 1, size(targets) + if (is_executable_target(targets(ii)%ptr)) then + if (ntargets >= size(install_target)) call resize(install_target) + ntargets = ntargets + 1 + install_target(ntargets)%s = targets(ii)%ptr%output_file + end if + end do + + write(unit, '("#", *(1x, g0))') & + "total number of installable targets:", ntargets + do ii = 1, ntargets + write(unit, '("-", *(1x, g0))') install_target(ii)%s + end do + + end subroutine install_info + + subroutine install_module_files(installer, dir, error) + type(installer_t), intent(inout) :: installer + character(len=*), intent(in) :: dir + type(error_t), allocatable, intent(out) :: error + type(string_t), allocatable :: modules(:) + integer :: ii + + call list_files(dir, modules, recurse=.false.) + + do ii = 1, size(modules) + if (is_module_file(modules(ii)%s)) then + call installer%install_header(modules(ii)%s, error) + if (allocated(error)) exit + end if + end do + if (allocated(error)) return + + end subroutine install_module_files + + subroutine install_executables(installer, targets, error) + type(installer_t), intent(inout) :: installer + type(build_target_ptr), intent(in) :: targets(:) + type(error_t), allocatable, intent(out) :: error + integer :: ii + + do ii = 1, size(targets) + if (is_executable_target(targets(ii)%ptr)) then + call installer%install_executable(targets(ii)%ptr%output_file, error) + if (allocated(error)) exit + end if + end do + if (allocated(error)) return + + end subroutine install_executables + + elemental function is_executable_target(target_ptr) result(is_exe) + type(build_target_t), intent(in) :: target_ptr + logical :: is_exe + is_exe = target_ptr%target_type == FPM_TARGET_EXECUTABLE .and. & + allocated(target_ptr%dependencies) + if (is_exe) then + is_exe = target_ptr%dependencies(1)%ptr%source%unit_scope == FPM_SCOPE_APP + end if + end function is_executable_target + + elemental function is_module_file(name) result(is_mod) + character(len=*), intent(in) :: name + logical :: is_mod + integer :: ll + ll = len(name) + is_mod = name(max(1, ll-3):ll) == ".mod" + end function is_module_file + + subroutine handle_error(error) + type(error_t), intent(in), optional :: error + if (present(error)) then + print '("[Error]", 1x, a)', error%message + error stop 1 + end if + end subroutine handle_error + +end module fpm_cmd_install diff --git a/src/fpm/cmd/new.f90 b/src/fpm/cmd/new.f90 new file mode 100644 index 0000000..5149bea --- /dev/null +++ b/src/fpm/cmd/new.f90 @@ -0,0 +1,652 @@ +module fpm_cmd_new +!># Definition of the "new" subcommand +!> +!> A type of the general command base class [[fpm_cmd_settings]] +!> was created for the "new" subcommand ==> type [[fpm_new_settings]]. +!> This procedure read the values that were set on the command line +!> from this type to decide what actions to take. +!> +!> It is virtually self-contained and so independant of the rest of the +!> application that it could function as a separate program. +!> +!> The "new" subcommand options currently consist of a SINGLE top +!> directory name to create that must have a name that is an +!> allowable Fortran variable name. That should have been ensured +!> by the command line processing before this procedure is called. +!> So basically this routine has already had the options vetted and +!> just needs to conditionally create a few files. +!> +!> As described in the documentation it will selectively +!> create the subdirectories app/, test/, src/, and example/ +!> and populate them with sample files. +!> +!> It also needs to create an initial manifest file "fpm.toml". +!> +!> It then calls the system command "git init". +!> +!> It should test for file existence and not overwrite existing +!> files and inform the user if there were conflicts. +!> +!> Any changes should be reflected in the documentation in +!> [[fpm_command_line.f90]] +!> +!> FUTURE +!> A filename like "." would need system commands or a standard routine +!> like realpath(3c) to process properly. +!> +!> Perhaps allow more than one name on a single command. It is an arbitrary +!> restriction based on a concensus preference, not a required limitation. +!> +!> Initially the name of the directory is used as the module name in the +!> src file so it must be an allowable Fortran variable name. If there are +!> complaints about it it might be changed. Handling unicode at this point +!> might be problematic as not all current compilers handle it. Other +!> utilities like content trackers (ie. git) or repositories like github +!> might also have issues with alternative names or names with spaces, etc. +!> So for the time being it seems prudent to encourage simple ASCII top directory +!> names (similiar to the primary programming language Fortran itself). +!> +!> Should be able to create or pull more complicated initial examples +!> based on various templates. It should place or mention other relevant +!> documents such as a description of the manifest file format in user hands; +!> or how to access registered packages and local packages, +!> although some other command might provide that (and the help command should +!> be the first go-to for a CLI utility). + +use fpm_command_line, only : fpm_new_settings +use fpm_environment, only : run, OS_LINUX, OS_MACOS, OS_WINDOWS +use fpm_filesystem, only : join_path, exists, basename, mkdir, is_dir, to_fortran_name +use fpm_filesystem, only : fileopen, fileclose, filewrite, warnwrite +use fpm_strings, only : join +use,intrinsic :: iso_fortran_env, only : stderr=>error_unit +implicit none +private +public :: cmd_new + +contains + +subroutine cmd_new(settings) +type(fpm_new_settings), intent(in) :: settings +integer,parameter :: tfc = selected_char_kind('DEFAULT') +character(len=:,kind=tfc),allocatable :: bname ! baeename of NAME +character(len=:,kind=tfc),allocatable :: tomlfile(:) +character(len=:,kind=tfc),allocatable :: littlefile(:) + + !> TOP DIRECTORY NAME PROCESSING + !> see if requested new directory already exists and process appropriately + if(exists(settings%name) .and. .not.settings%backfill )then + write(stderr,'(*(g0,1x))')& + & '',settings%name,'already exists.' + write(stderr,'(*(g0,1x))')& + & ' perhaps you wanted to add --backfill ?' + return + elseif(is_dir(settings%name) .and. settings%backfill )then + write(*,'(*(g0))')'backfilling ',settings%name + elseif(exists(settings%name) )then + write(stderr,'(*(g0,1x))')& + & '',settings%name,'already exists and is not a directory.' + return + else + ! make new directory + call mkdir(settings%name) + endif + + !> temporarily change to new directory as a test. NB: System dependent + call run('cd '//settings%name) + ! NOTE: need some system routines to handle filenames like "." + ! like realpath() or getcwd(). + bname=basename(settings%name) + + ! create NAME/.gitignore file + call warnwrite(join_path(settings%name, '.gitignore'), ['build/*']) + + littlefile=[character(len=80) :: '# '//bname, 'My cool new project!'] + + ! create NAME/README.md + call warnwrite(join_path(settings%name, 'README.md'), littlefile) + + ! start building NAME/fpm.toml + if(settings%with_full)then + tomlfile=[character(len=80) :: & + &' # This is your fpm(Fortran Package Manager) manifest file ',& + &' # ("fpm.toml"). It is heavily annotated to help guide you though ',& + &' # customizing a package build, although the defaults are sufficient ',& + &' # for many basic packages. ',& + &' # ',& + &' # The manifest file is not only used to provide metadata identifying ',& + &' # your project (so it can be used by others as a dependency). It can ',& + &' # specify where your library and program sources live, what the name ',& + &' # of the executable(s) will be, what files to build, dependencies on ',& + &' # other fpm packages, and what external libraries are required. ',& + &' # ',& + &' # The manifest format must conform to the TOML configuration file ',& + &' # standard. ',& + &' # ',& + &' # TOML files support flexible use of white-space and commenting of the ',& + &' # configuration data, but for clarity in this sample active directives ',& + &' # begin in column one. Inactive example directives are commented ',& + &' # out with a pound character ("#") but begin in column one as well. ',& + &' # Commentary begins with a pound character in column three. ',& + &' # ',& + &' # This file draws heavily upon the following references: ',& + &' # ',& + &' # The fpm home page at ',& + &' # https://github.com/fortran-lang/fpm ',& + &' # A complete list of keys and their attributes at ',& + &' # https://github.com/fortran-lang/fpm/blob/master/manifest-reference.md ',& + &' # examples of fpm project packaging at ',& + &' # https://github.com/fortran-lang/fpm/blob/master/PACKAGING.md ',& + &' # The Fortran TOML file interface and it''s references at ',& + &' # https://github.com/toml-f/toml-f ',& + &' # ',& + &' #----------------------- ',& + &' # project Identification ',& + &' #----------------------- ',& + &' # We begin with project metadata at the manifest root. This data is designed ',& + &' # to aid others when searching for the project in a repository and to ',& + &' # identify how and when to contact the package supporters. ',& + &' ',& + &'name = "'//bname//'"',& + &' # The project name (required) is how the project will be referred to. ',& + &' # The name is used by other packages using it as a dependency. It also ',& + &' # is used as the default name of any library built and the optional ',& + &' # default executable built from app/main.f90. It must conform to the rules ',& + &' # for a Fortran variable name. ',& + &' ',& + &'version = "0.1.0" ',& + &' # The project version number is a string. A recommended scheme for ',& + &' # specifying versions is the Semantic Versioning scheme. ',& + &' ',& + &'license = "license" ',& + &' # Licensing information specified using SPDX identifiers is preferred ',& + &' # (eg. "Apache-2.0 OR MIT" or "LGPL-3.0-or-later"). ',& + &' ',& + &'maintainer = "jane.doe@example.com" ',& + &' # Information on the project maintainer and means to reach out to them. ',& + &' ',& + &'author = "Jane Doe" ',& + &' # Information on the project author. ',& + &' ',& + &'copyright = "Copyright 2020 Jane Doe" ',& + &' # A statement clarifying the Copyright status of the project. ',& + &' ',& + &'#description = "A short project summary in plain text" ',& + &' # The description provides a short summary on the project. It should be ',& + &' # plain text and not use any markup formatting. ',& + &' ',& + &'#categories = ["fortran", "graphics"] ',& + &' # Categories associated with the project. Listing only one is preferred. ',& + &' ',& + &'#keywords = ["hdf5", "mpi"] ',& + &' # The keywords field is an array of strings describing the project. ',& + &' ',& + &'#homepage = "https://stdlib.fortran-lang.org" ',& + &' # URL to the webpage of the project. ',& + &' ',& + &' # ----------------------------------------- ',& + &' # We are done with identifying the project. ',& + &' # ----------------------------------------- ',& + &' # ',& + &' # Now lets start describing how the project should be built. ',& + &' # ',& + &' # Note tables would go here but we will not be talking about them (much)!!' ,& + &' # ',& + &' # Tables are a way to explicitly specify large numbers of programs in ',& + &' # a compact format instead of individual per-program entries in the ',& + &' # [[executable]], [[test]], and [[example]] sections to follow but ',& + &' # will not be discussed further except for the following notes: ',& + &' # ',& + &' # + Tables must appear (here) before any sections are declared. Once a ',& + &' # section is specified in a TOML file everything afterwards must be ',& + &' # values for that section or the beginning of a new section. A simple ',& + &' # example looks like: ',& + &' ',& + &'#executable = [ ',& + &'# { name = "a-prog" }, ',& + &'# { name = "app-tool", source-dir = "tool" }, ',& + &'# { name = "fpm-man", source-dir = "tool", main="fman.f90" } ',& + &'#] ',& + &' ',& + &' # This would be in lieue of the [[executable]] section found later in this ',& + &' # configuration file. ',& + &' # + See the reference documents (at the beginning of this document) ',& + &' # for more information on tables if you have long lists of programs ',& + &' # to build and are not simply depending on auto-detection. ',& + &' # ',& + &' # Now lets begin the TOML sections (lines beginning with "[") ... ',& + &' # ',& + &' ',& + &'[install] # Options for the "install" subcommand ',& + &' ',& + &' # When you run the "install" subcommand only executables are installed by ',& + &' # default on the local system. Library projects that will be used outside of ',& + &' # "fpm" can set the "library" boolean to also allow installing the module ',& + &' # files and library archive. Without this being set to "true" an "install" ',& + &' # subcommand ignores parameters that specify library installation. ',& + &' ',& + &'library = false ',& + &' ',& + &'[build] # General Build Options ',& + &' ',& + &' ### Automatic target discovery ',& + &' # ',& + &' # Normally fpm recursively searches the app/, example/, and test/ directories ',& + &' # for program sources and builds them. To disable this automatic discovery of ',& + &' # program targets set the following to "false": ',& + &' ',& + &'#auto-executables = true ',& + &'#auto-examples = true ',& + &'#auto-tests = true ',& + &' ',& + &' ### Package-level External Library Links ',& + &' # ',& + &' # To declare link-time dependencies on external libraries a list of ',& + &' # native libraries can be specified with the "link" entry. You may ',& + &' # have one library name or a list of strings in case several ',& + &' # libraries should be linked. This list of library dependencies is ',& + &' # exported to dependent packages. You may have to alter your library ',& + &' # search-path to ensure the libraries can be accessed. Typically, ',& + &' # this is done with the LD_LIBRARY_PATH environment variable on ULS ',& + &' # (Unix-Like Systems). You only specify the core name of the library ',& + &' # (as is typical with most programming environments, where you ',& + &' # would specify "-lz" on your load command to link against the zlib ',& + &' # compression library even though the library file would typically be ',& + &' # a file called "libz.a" "or libz.so"). So to link against that library ',& + &' # you would specify: ',& + &' ',& + &'#link = "z" ',& + &' ',& + &' # Note that in some cases the order of the libraries matters: ',& + &' ',& + &'#link = ["blas", "lapack"] ',& + &''] + endif + + if(settings%with_bare)then + elseif(settings%with_lib)then + call mkdir(join_path(settings%name,'src') ) + ! create next section of fpm.toml + if(settings%with_full)then + tomlfile=[character(len=80) :: tomlfile, & + &'[library] ',& + &' ',& + &' # You can change the name of the directory to search for your library ',& + &' # source from the default of "src/". Library targets are exported ',& + &' # and usable by other projects. ',& + &' ',& + &'source-dir="src" ',& + &' ',& + &' # this can be a list: ',& + &' ',& + &'#source-dir=["src", "src2"] ',& + &' ',& + &' # More complex libraries may organize their modules in subdirectories. ',& + &' # For modules in a top-level directory fpm requires (but does not ',& + &' # enforce) that: ',& + &' # ',& + &' # + The module has the same name as the source file. This is important. ',& + &' # + There should be only one module per file. ',& + &' # ',& + &' # These two requirements simplify the build process for fpm. As Fortran ',& + &' # compilers emit module files (.mod) with the same name as the module ',& + &' # itself (but not the source file, .f90), naming the module the same ',& + &' # as the source file allows fpm to: ',& + &' # ',& + &' # + Uniquely and exactly map a source file (.f90) to its object (.o) ',& + &' # and module (.mod) files. ',& + &' # + Avoid conflicts with modules of the same name that could appear ',& + &' # in dependency packages. ',& + &' # ',& + &' ### Multi-level library source ',& + &' # You can place your module source files in any number of levels of ',& + &' # subdirectories inside your source directory, but there are certain naming ',& + &' # conventions to be followed -- module names must contain the path components ',& + &' # of the directory that its source file is in. ',& + &' # ',& + &' # This rule applies generally to any number of nested directories and ',& + &' # modules. For example, src/a/b/c/d.f90 must define a module called a_b_c_d. ',& + &' # Again, this is not enforced but may be required in future releases. ',& + &''] + endif + ! create placeholder module src/bname.f90 + littlefile=[character(len=80) :: & + &'module '//to_fortran_name(bname), & + &' implicit none', & + &' private', & + &'', & + &' public :: say_hello', & + &'contains', & + &' subroutine say_hello', & + &' print *, "Hello, '//bname//'!"', & + &' end subroutine say_hello', & + &'end module '//to_fortran_name(bname)] + ! create NAME/src/NAME.f90 + call warnwrite(join_path(settings%name, 'src', bname//'.f90'),& + & littlefile) + endif + + if(settings%with_full)then + tomlfile=[character(len=80) :: tomlfile ,& + &'[dependencies] ',& + &' ',& + &' # Inevitably, you will want to be able to include other packages in ',& + &' # a project. Fpm makes this incredibly simple, by taking care of ',& + &' # fetching and compiling your dependencies for you. You just tell it ',& + &' # what your dependencies names are, and where to find them. ',& + &' # ',& + &' # If you are going to distribute your package only place dependencies ',& + &' # here someone using your package as a remote dependency needs built. ',& + &' # You can define dependencies just for developer executables in the ',& + &' # next section, or even for specific executables as we will see below ',& + &' # (Then fpm will still fetch and compile it when building your ',& + &' # developer executables, but users of your library will not have to). ',& + &' # ',& + &' ## GLOBAL DEPENDENCIES (exported with your project) ',& + &' # ',& + &' # Typically, dependencies are defined by specifying the project''s ',& + &' # git repository. ',& + &' # ',& + &' # You can be specific about which version of a dependency you would ',& + &' # like. By default the latest master master branch is used. You can ',& + &' # optionally specify a branch, a tag or a commit value. ',& + &' # ',& + &' # So here are several alternates for specifying a remote dependency (you ',& + &' # can have at most one of "branch", "rev" or "tag" present): ',& + &' ',& + &'#stdlib = { git = "https://github.com/LKedward/stdlib-fpm.git" } ',& + &'#stdlib = {git="https://github.com/LKedward/stdlib-fpm.git",branch = "master" },',& + &'#stdlib = {git="https://github.com/LKedward/stdlib-fpm.git", tag = "v0.1.0" }, ',& + &'#stdlib = {git="https://github.com/LKedward/stdlib-fpm.git", rev = "5a9b7a8" }. ',& + &' ',& + &' # There may be multiple packages listed: ',& + &' ',& + &'#M_strings = { git = "https://github.com/urbanjost/M_strings.git" } ',& + &'#M_time = { git = "https://github.com/urbanjost/M_time.git" } ',& + &' ',& + &' # ',& + &' # You can even specify the local path to another project if it is in ',& + &' # a sub-folder (If for example you have got another fpm package **in ',& + &' # the same repository**) like this: ',& + &' ',& + &'#M_strings = { path = "M_strings" } ',& + &' ',& + &' # If you specify paths outside of your repository (ie. paths with a ',& + &' # slash in them) things will not work for your users! ',& + &' # ',& + &' # For a more verbose layout use normal tables rather than inline tables ',& + &' # to specify dependencies: ',& + &' ',& + &'#[dependencies.toml-f] ',& + &'#git = "https://github.com/toml-f/toml-f" ',& + &'#rev = "2f5eaba864ff630ba0c3791126a3f811b6e437f3" ',& + &' ',& + &' # Now you can use any modules from these libraries anywhere in your ',& + &' # code -- whether is in your library source or a program source. ',& + &' ',& + &'[dev-dependencies] ',& + &' ',& + &' ## Dependencies Only for Development ',& + &' # ',& + &' # You can specify dependencies your library or application does not ',& + &' # depend on in a similar way. The difference is that these will not ',& + &' # be exported as part of your project to those using it as a remote ',& + &' # dependency. ',& + &' # ',& + &' # Currently, like a global dependency it will still be available for ',& + &' # all codes. It is up to the developer to ensure that nothing except ',& + &' # developer test programs rely upon it. ',& + &' ',& + &'#M_msg = { git = "https://github.com/urbanjost/M_msg.git" } ',& + &'#M_verify = { git = "https://github.com/urbanjost/M_verify.git" } ',& + &''] + endif + if(settings%with_bare)then + elseif(settings%with_executable)then + ! create next section of fpm.toml + call mkdir(join_path(settings%name, 'app')) + ! create NAME/app or stop + if(settings%with_full)then + tomlfile=[character(len=80) :: tomlfile, & + &' #----------------------------------- ',& + &' ## Application-specific declarations ',& + &' #----------------------------------- ',& + &' # Now lets begin entries for the TOML tables (lines beginning with "[[") ',& + &' # that describe the program sources -- applications, tests, and examples. ',& + &' # ',& + &' # First we will configuration individual applications run with "fpm run". ',& + &' # ',& + &' # + the "name" entry for the executable to be built must always ',& + &' # be specified. The name must satisfy the rules for a Fortran ',& + &' # variable name. This will be the name of the binary installed by ',& + &' # the "install" subcommand and used on the "run" subcommand. ',& + &' # + The source directory for each executable can be adjusted by the ',& + &' # "source-dir" entry. ',& + &' # + The basename of the source file containing the program body can ',& + &' # be specified with the "main" entry. ',& + &' # + Executables can also specify their own external package and ',& + &' # library link dependencies. ',& + &' # ',& + &' # Currently, like a global dependency any external package dependency ',& + &' # will be available for all codes. It is up to the developer to ensure ',& + &' # that nothing except the application programs specified rely upon it. ',& + &' # ',& + &' # Note if your application needs to use a module internally, but you do not ',& + &' # intend to build it as a library to be used in other projects, you can ',& + &' # include the module in your program source file or directory as well. ',& + &' ',& + &'[[executable]] ',& + &'name="'//bname//'"',& + &'source-dir="app" ',& + &'main="main.f90" ',& + &' ',& + &' # You may repeat this pattern to define additional applications. For instance,',& + &' # the following sample illustrates all accepted options, where "link" and ',& + &' # "executable.dependencies" keys are the same as the global external library ',& + &' # links and package dependencies described previously except they apply ',& + &' # only to this executable: ',& + &' ',& + &'#[[ executable ]] ',& + &'#name = "app-name" ',& + &'#source-dir = "prog" ',& + &'#main = "program.f90" ',& + &'#link = "z" ',& + &'#[executable.dependencies] ',& + &'#M_CLI = { git = "https://github.com/urbanjost/M_CLI.git" } ',& + &'#helloff = { git = "https://gitlab.com/everythingfunctional/helloff.git" } ',& + &'#M_path = { git = "https://github.com/urbanjost/M_path.git" } ',& + &''] + endif + + if(exists(bname//'/src/'))then + littlefile=[character(len=80) :: & + &'program main', & + &' use '//to_fortran_name(bname)//', only: say_hello', & + &' implicit none', & + &'', & + &' call say_hello()', & + &'end program main'] + else + littlefile=[character(len=80) :: & + &'program main', & + &' implicit none', & + &'', & + &' print *, "hello from project '//bname//'"', & + &'end program main'] + endif + call warnwrite(join_path(settings%name, 'app/main.f90'), littlefile) + endif + + if(settings%with_bare)then + elseif(settings%with_test)then + + ! create NAME/test or stop + call mkdir(join_path(settings%name, 'test')) + ! create next section of fpm.toml + if(settings%with_full)then + tomlfile=[character(len=80) :: tomlfile ,& + &'[[test]] ',& + &' ',& + &' # The same declarations can be made for test programs, which are ',& + &' # executed with the "fpm test" command and are not build when your ',& + &' # package is used as a dependency by other packages. These are ',& + &' # typically unit tests of the package only used during package ',& + &' # development. ',& + &' ',& + &'name="runTests" ',& + &'source-dir="test" ',& + &'main="check.f90" ',& + &' ',& + &' # you may repeat this pattern to add additional explicit test program ',& + &' # parameters. The following example contains a sample of all accepted ',& + &' # options. ',& + &' ',& + &'#[[ test ]] ',& + &'#name = "tester" ',& + &'#source-dir="test" ',& + &'#main="tester.f90" ',& + &'#link = ["blas", "lapack"] ',& + &'#[test.dependencies] ',& + &'#M_CLI2 = { git = "https://github.com/urbanjost/M_CLI2.git" } ',& + &'#M_io = { git = "https://github.com/urbanjost/M_io.git" } ',& + &'#M_system= { git = "https://github.com/urbanjost/M_system.git" } ',& + &''] + endif + + littlefile=[character(len=80) :: & + &'program check', & + &'implicit none', & + &'', & + &'print *, "Put some tests in here!"', & + &'end program check'] + ! create NAME/test/check.f90 + call warnwrite(join_path(settings%name, 'test/check.f90'), littlefile) + endif + + if(settings%with_bare)then + elseif(settings%with_example)then + + ! create NAME/example or stop + call mkdir(join_path(settings%name, 'example')) + ! create next section of fpm.toml + if(settings%with_full)then + tomlfile=[character(len=80) :: tomlfile, & + &'[[example]] ',& + &' ',& + &' # Example applications for a project are defined here. ',& + &' # These are run via "fpm run --example NAME" and like the ',& + &' # test applications, are not built when this package is used as a ',& + &' # dependency by other packages. ',& + &' ',& + &'name="demo" ',& + &'source-dir="example" ',& + &'main="demo.f90" ',& + &' ',& + &' # ',& + &' # you may add additional programs to the example table. The following ',& + &' # example contains a sample of all accepted options ',& + &' ',& + &'#[[ example ]] ',& + &'#name = "example-tool" ',& + &'#source-dir="example" ',& + &'#main="tool.f90" ',& + &'#link = "z" ',& + &'#[example.dependencies] ',& + &'#M_kracken95 = { git = "https://github.com/urbanjost/M_kracken95.git" } ',& + &'#datetime = {git = "https://github.com/wavebitscientific/datetime-fortran.git" }',& + &''] + endif + + littlefile=[character(len=80) :: & + &'program demo', & + &'implicit none', & + &'', & + &'print *, "Put some examples in here!"', & + &'end program demo'] + ! create NAME/example/demo.f90 + call warnwrite(join_path(settings%name, 'example/demo.f90'), littlefile) + endif + + ! now that built it write NAME/fpm.toml + if( allocated(tomlfile) )then + call validate_toml_data(tomlfile) + call warnwrite(join_path(settings%name, 'fpm.toml'), tomlfile) + else + call create_verified_basic_manifest(join_path(settings%name, 'fpm.toml')) + endif + ! assumes git(1) is installed and in path + call run('git init ' // settings%name) +contains + +subroutine create_verified_basic_manifest(filename) +!> create a basic but verified default manifest file +use fpm_toml, only : toml_table, toml_serializer, set_value +use fpm_manifest_package, only : package_config_t, new_package +use fpm_error, only : error_t +implicit none +character(len=*),intent(in) :: filename + type(toml_table) :: table + type(toml_serializer) :: ser + type(package_config_t) :: package + type(error_t), allocatable :: error + integer :: lun + character(len=8) :: date + + !> get date to put into metadata in manifest file "fpm.toml" + call date_and_time(DATE=date) + table = toml_table() + ser = toml_serializer() + call fileopen(filename,lun) ! fileopen stops on error + + call set_value(table, "name", BNAME) + call set_value(table, "version", "0.1.0") + call set_value(table, "license", "license") + call set_value(table, "author", "Jane Doe") + call set_value(table, "maintainer", "jane.doe@example.com") + call set_value(table, "copyright", 'Copyright '//date(1:4)//', Jane Doe') + ! continue building of manifest + ! ... + call new_package(package, table, error) + if (allocated(error)) stop 3 + if(settings%verbose)then + call table%accept(ser) + endif + ser%unit=lun + call table%accept(ser) + call fileclose(lun) ! fileopen stops on error + +end subroutine create_verified_basic_manifest + + +subroutine validate_toml_data(input) +!> verify a string array is a valid fpm.toml file +! +use tomlf, only : toml_parse +use fpm_toml, only : toml_table, toml_serializer +implicit none +character(kind=tfc,len=:),intent(in),allocatable :: input(:) +character(len=1), parameter :: nl = new_line('a') +type(toml_table), allocatable :: table +character(kind=tfc, len=:), allocatable :: joined_string +type(toml_serializer) :: ser + +! you have to add a newline character by using the intrinsic +! function `new_line("a")` to get the lines processed correctly. +joined_string = join(input,right=nl) + +if (allocated(table)) deallocate(table) +call toml_parse(table, joined_string) +if (allocated(table)) then + if(settings%verbose)then + ! If the TOML file is successfully parsed the table will be allocated and + ! can be written to the standard output by passing the `toml_serializer` + ! as visitor to the table. + call table%accept(ser) + endif + call table%destroy +endif + +end subroutine validate_toml_data + +end subroutine cmd_new + +end module fpm_cmd_new diff --git a/src/fpm/cmd/update.f90 b/src/fpm/cmd/update.f90 new file mode 100644 index 0000000..d7cc549 --- /dev/null +++ b/src/fpm/cmd/update.f90 @@ -0,0 +1,68 @@ +module fpm_cmd_update + use fpm_command_line, only : fpm_update_settings + use fpm_dependency, only : dependency_tree_t, new_dependency_tree + use fpm_error, only : error_t + use fpm_filesystem, only : exists, mkdir, join_path, delete_file + use fpm_manifest, only : package_config_t, get_package_data + implicit none + private + public :: cmd_update + +contains + + !> Entry point for the update subcommand + subroutine cmd_update(settings) + !> Representation of the command line arguments + type(fpm_update_settings), intent(in) :: settings + type(package_config_t) :: package + type(dependency_tree_t) :: deps + type(error_t), allocatable :: error + + integer :: ii + character(len=:), allocatable :: cache + + call get_package_data(package, "fpm.toml", error, apply_defaults=.true.) + call handle_error(error) + + if (.not.exists("build")) then + call mkdir("build") + end if + + cache = join_path("build", "cache.toml") + if (settings%clean) then + call delete_file(cache) + end if + + call new_dependency_tree(deps, cache=cache, & + verbosity=merge(2, 1, settings%verbose)) + + call deps%add(package, error) + call handle_error(error) + + if (settings%fetch_only) return + + if (size(settings%name) == 0) then + do ii = 1, deps%ndep + call deps%update(deps%dep(ii)%name, error) + call handle_error(error) + end do + else + do ii = 1, size(settings%name) + call deps%update(trim(settings%name(ii)), error) + call handle_error(error) + end do + end if + + end subroutine cmd_update + + !> Error handling for this command + subroutine handle_error(error) + !> Potential error + type(error_t), intent(in), optional :: error + if (present(error)) then + print '(a)', error%message + error stop 1 + end if + end subroutine handle_error + +end module fpm_cmd_update diff --git a/src/fpm/dependency.f90 b/src/fpm/dependency.f90 new file mode 100644 index 0000000..144ffbe --- /dev/null +++ b/src/fpm/dependency.f90 @@ -0,0 +1,821 @@ +!> # Dependency management +!> +!> ## Fetching dependencies and creating a dependency tree +!> +!> Dependencies on the top-level can be specified from: +!> +!> - `package%dependencies` +!> - `package%dev_dependencies` +!> - `package%executable(:)%dependencies` +!> - `package%test(:)%dependencies` +!> +!> Each dependency is fetched in some way and provides a path to its package +!> manifest. +!> The `package%dependencies` of the dependencies are resolved recursively. +!> +!> To initialize the dependency tree all dependencies are recursively fetched +!> and stored in a flat data structure to avoid retrieving a package twice. +!> The data structure used to store this information should describe the current +!> status of the dependency tree. Important information are: +!> +!> - name of the package +!> - version of the package +!> - path to the package root +!> +!> Additionally, for version controlled dependencies the following should be +!> stored along with the package: +!> +!> - the upstream url +!> - the current checked out revision +!> +!> Fetching a remote (version controlled) dependency turns it for our purpose +!> into a local path dependency which is handled by the same means. +!> +!> ## Updating dependencies +!> +!> For a given dependency tree all top-level dependencies can be updated. +!> We have two cases to consider, a remote dependency and a local dependency, +!> again, remote dependencies turn into local dependencies by fetching. +!> Therefore we will update remote dependencies by simply refetching them. +!> +!> For remote dependencies we have to refetch if the revision in the manifest +!> changes or the upstream HEAD has changed (for branches _and_ tags). +!> +!> @Note For our purpose a tag is just a fancy branch name. Tags can be delete and +!> modified afterwards, therefore they do not differ too much from branches +!> from our perspective. +!> +!> For the latter case we only know if we actually fetch from the upstream URL. +!> +!> In case of local (and fetched remote) dependencies we have to read the package +!> manifest and compare its dependencies against our dependency tree, any change +!> requires updating the respective dependencies as well. +!> +!> ## Handling dependency compatibilties +!> +!> Currenly ignored. First come, first serve. +module fpm_dependency + use, intrinsic :: iso_fortran_env, only : output_unit + use fpm_environment, only : get_os_type, OS_WINDOWS + use fpm_error, only : error_t, fatal_error + use fpm_filesystem, only : exists, join_path, mkdir, canon_path, windows_path + use fpm_git, only : git_target_revision, git_target_default, git_revision + use fpm_manifest, only : package_config_t, dependency_config_t, & + get_package_data + use fpm_strings, only : string_t, operator(.in.) + use fpm_toml, only : toml_table, toml_key, toml_error, toml_serializer, & + toml_parse, get_value, set_value, add_table + use fpm_versioning, only : version_t, new_version, char + implicit none + private + + public :: dependency_tree_t, new_dependency_tree + public :: dependency_node_t, new_dependency_node + public :: resize + + + !> Overloaded reallocation interface + interface resize + module procedure :: resize_dependency_node + end interface resize + + + !> Dependency node in the projects dependency tree + type, extends(dependency_config_t) :: dependency_node_t + !> Actual version of this dependency + type(version_t), allocatable :: version + !> Installation prefix of this dependencies + character(len=:), allocatable :: proj_dir + !> Checked out revision of the version control system + character(len=:), allocatable :: revision + !> Dependency is handled + logical :: done = .false. + !> Dependency should be updated + logical :: update = .false. + contains + !> Update dependency from project manifest + procedure :: register + end type dependency_node_t + + + !> Respresentation of a projects dependencies + !> + !> The dependencies are stored in a simple array for now, this can be replaced + !> with a binary-search tree or a hash table in the future. + type :: dependency_tree_t + !> Unit for IO + integer :: unit = output_unit + !> Verbosity of printout + integer :: verbosity = 1 + !> Installation prefix for dependencies + character(len=:), allocatable :: dep_dir + !> Number of currently registered dependencies + integer :: ndep = 0 + !> Flattend list of all dependencies + type(dependency_node_t), allocatable :: dep(:) + !> Cache file + character(len=:), allocatable :: cache + contains + !> Overload procedure to add new dependencies to the tree + generic :: add => add_project, add_project_dependencies, add_dependencies, & + add_dependency + !> Main entry point to add a project + procedure, private :: add_project + !> Add a project and its dependencies to the dependency tree + procedure, private :: add_project_dependencies + !> Add a list of dependencies to the dependency tree + procedure, private :: add_dependencies + !> Add a single dependency to the dependency tree + procedure, private :: add_dependency + !> Resolve dependencies + generic :: resolve => resolve_dependencies, resolve_dependency + !> Resolve dependencies + procedure, private :: resolve_dependencies + !> Resolve dependencies + procedure, private :: resolve_dependency + !> Find a dependency in the tree + generic :: find => find_dependency, find_name + !> Find a dependency from an dependency configuration + procedure, private :: find_dependency + !> Find a dependency by its name + procedure, private :: find_name + !> Depedendncy resolution finished + procedure :: finished + !> Reading of dependency tree + generic :: load => load_from_file, load_from_unit, load_from_toml + !> Read dependency tree from file + procedure, private :: load_from_file + !> Read dependency tree from formatted unit + procedure, private :: load_from_unit + !> Read dependency tree from TOML data structure + procedure, private :: load_from_toml + !> Writing of dependency tree + generic :: dump => dump_to_file, dump_to_unit, dump_to_toml + !> Write dependency tree to file + procedure, private :: dump_to_file + !> Write dependency tree to formatted unit + procedure, private :: dump_to_unit + !> Write dependency tree to TOML data structure + procedure, private :: dump_to_toml + !> Update dependency tree + generic :: update => update_dependency + !> Update a list of dependencies + procedure, private :: update_dependency + end type dependency_tree_t + + !> Common output format for writing to the command line + character(len=*), parameter :: out_fmt = '("#", *(1x, g0))' + +contains + + !> Create a new dependency tree + subroutine new_dependency_tree(self, verbosity, cache) + !> Instance of the dependency tree + type(dependency_tree_t), intent(out) :: self + !> Verbosity of printout + integer, intent(in), optional :: verbosity + !> Name of the cache file + character(len=*), intent(in), optional :: cache + + call resize(self%dep) + self%dep_dir = join_path("build", "dependencies") + + if (present(verbosity)) then + self%verbosity = verbosity + end if + + if (present(cache)) then + self%cache = cache + end if + + end subroutine new_dependency_tree + + !> Create a new dependency node from a configuration + pure subroutine new_dependency_node(self, dependency, version, proj_dir, update) + !> Instance of the dependency node + type(dependency_node_t), intent(out) :: self + !> Dependency configuration data + type(dependency_config_t), intent(in) :: dependency + !> Version of the dependency + type(version_t), intent(in), optional :: version + !> Installation prefix of the dependency + character(len=*), intent(in), optional :: proj_dir + !> Dependency should be updated + logical, intent(in), optional :: update + + self%dependency_config_t = dependency + + if (present(version)) then + self%version = version + end if + + if (present(proj_dir)) then + self%proj_dir = proj_dir + end if + + if (present(update)) then + self%update = update + end if + + end subroutine new_dependency_node + + !> Add project dependencies, each depth level after each other. + !> + !> We implement this algorithm in an interative rather than a recursive fashion + !> as a choice of design. + subroutine add_project(self, package, error) + !> Instance of the dependency tree + class(dependency_tree_t), intent(inout) :: self + !> Project configuration to add + type(package_config_t), intent(in) :: package + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(dependency_config_t) :: dependency + character(len=:), allocatable :: root + logical :: main + + if (allocated(self%cache)) then + call self%load(self%cache, error) + if (allocated(error)) return + end if + + if (.not.exists(self%dep_dir)) then + call mkdir(self%dep_dir) + end if + + root = "." + + ! Create this project as the first dependency node (depth 0) + dependency%name = package%name + dependency%path = root + call self%add(dependency, error) + if (allocated(error)) return + + ! Resolve the root project + call self%resolve(root, error) + if (allocated(error)) return + + ! Add the root project dependencies (depth 1) + call self%add(package, root, .true., error) + if (allocated(error)) return + + ! Now decent into the dependency tree, level for level + do while(.not.self%finished()) + call self%resolve(root, error) + if (allocated(error)) exit + end do + if (allocated(error)) return + + if (allocated(self%cache)) then + call self%dump(self%cache, error) + if (allocated(error)) return + end if + + end subroutine add_project + + !> Add a project and its dependencies to the dependency tree + recursive subroutine add_project_dependencies(self, package, root, main, error) + !> Instance of the dependency tree + class(dependency_tree_t), intent(inout) :: self + !> Project configuration to add + type(package_config_t), intent(in) :: package + !> Current project root directory + character(len=*), intent(in) :: root + !> Is the main project + logical, intent(in) :: main + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: ii + + if (allocated(package%dependency)) then + call self%add(package%dependency, error) + if (allocated(error)) return + end if + + if (main) then + if (allocated(package%dev_dependency)) then + call self%add(package%dev_dependency, error) + if (allocated(error)) return + end if + + if (allocated(package%executable)) then + do ii = 1, size(package%executable) + if (allocated(package%executable(ii)%dependency)) then + call self%add(package%executable(ii)%dependency, error) + if (allocated(error)) exit + end if + end do + if (allocated(error)) return + end if + + if (allocated(package%example)) then + do ii = 1, size(package%example) + if (allocated(package%example(ii)%dependency)) then + call self%add(package%example(ii)%dependency, error) + if (allocated(error)) exit + end if + end do + if (allocated(error)) return + end if + + if (allocated(package%test)) then + do ii = 1, size(package%test) + if (allocated(package%test(ii)%dependency)) then + call self%add(package%test(ii)%dependency, error) + if (allocated(error)) exit + end if + end do + if (allocated(error)) return + end if + end if + + end subroutine add_project_dependencies + + !> Add a list of dependencies to the dependency tree + subroutine add_dependencies(self, dependency, error) + !> Instance of the dependency tree + class(dependency_tree_t), intent(inout) :: self + !> Dependency configuration to add + type(dependency_config_t), intent(in) :: dependency(:) + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: ii, ndep + + ndep = size(self%dep) + if (ndep < size(dependency) + self%ndep) then + call resize(self%dep, ndep + ndep/2 + size(dependency)) + end if + + do ii = 1, size(dependency) + call self%add(dependency(ii), error) + if (allocated(error)) exit + end do + if (allocated(error)) return + + end subroutine add_dependencies + + !> Add a single dependency to the dependency tree + pure subroutine add_dependency(self, dependency, error) + !> Instance of the dependency tree + class(dependency_tree_t), intent(inout) :: self + !> Dependency configuration to add + type(dependency_config_t), intent(in) :: dependency + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: id + + id = self%find(dependency) + if (id == 0) then + self%ndep = self%ndep + 1 + call new_dependency_node(self%dep(self%ndep), dependency) + end if + + end subroutine add_dependency + + !> Update dependency tree + subroutine update_dependency(self, name, error) + !> Instance of the dependency tree + class(dependency_tree_t), intent(inout) :: self + !> Name of the dependency to update + character(len=*), intent(in) :: name + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: id + type(package_config_t) :: package + character(len=:), allocatable :: manifest, proj_dir, revision, root + + id = self%find(name) + root = "." + + if (id <= 0) then + call fatal_error(error, "Cannot update dependency '"//name//"'") + return + end if + + associate(dep => self%dep(id)) + if (allocated(dep%git) .and. dep%update) then + if (self%verbosity > 1) then + write(self%unit, out_fmt) "Update:", dep%name + end if + proj_dir = join_path(self%dep_dir, dep%name) + call dep%git%checkout(proj_dir, error) + if (allocated(error)) return + + ! Unset dependency and remove updatable attribute + dep%done = .false. + dep%update = .false. + + ! Now decent into the dependency tree, level for level + do while(.not.self%finished()) + call self%resolve(root, error) + if (allocated(error)) exit + end do + if (allocated(error)) return + end if + end associate + + end subroutine update_dependency + + !> Resolve all dependencies in the tree + subroutine resolve_dependencies(self, root, error) + !> Instance of the dependency tree + class(dependency_tree_t), intent(inout) :: self + !> Current installation prefix + character(len=*), intent(in) :: root + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: ii + + do ii = 1, self%ndep + call self%resolve(self%dep(ii), root, error) + if (allocated(error)) exit + end do + + if (allocated(error)) return + + end subroutine resolve_dependencies + + !> Resolve a single dependency node + subroutine resolve_dependency(self, dependency, root, error) + !> Instance of the dependency tree + class(dependency_tree_t), intent(inout) :: self + !> Dependency configuration to add + type(dependency_node_t), intent(inout) :: dependency + !> Current installation prefix + character(len=*), intent(in) :: root + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(package_config_t) :: package + character(len=:), allocatable :: manifest, proj_dir, revision + logical :: fetch + + if (dependency%done) return + + fetch = .false. + if (allocated(dependency%proj_dir)) then + proj_dir = dependency%proj_dir + else + if (allocated(dependency%path)) then + proj_dir = join_path(root, dependency%path) + else if (allocated(dependency%git)) then + proj_dir = join_path(self%dep_dir, dependency%name) + fetch = .not.exists(proj_dir) + if (fetch) then + call dependency%git%checkout(proj_dir, error) + if (allocated(error)) return + end if + + end if + end if + + if (allocated(dependency%git)) then + call git_revision(proj_dir, revision, error) + if (allocated(error)) return + end if + + manifest = join_path(proj_dir, "fpm.toml") + call get_package_data(package, manifest, error) + if (allocated(error)) return + + call dependency%register(package, proj_dir, fetch, revision, error) + if (allocated(error)) return + + if (self%verbosity > 1) then + write(self%unit, out_fmt) & + "Dep:", dependency%name, "version", char(dependency%version), & + "at", dependency%proj_dir + end if + + call self%add(package, proj_dir, .false., error) + if (allocated(error)) return + + end subroutine resolve_dependency + + !> Find a dependency in the dependency tree + pure function find_dependency(self, dependency) result(pos) + !> Instance of the dependency tree + class(dependency_tree_t), intent(in) :: self + !> Dependency configuration to add + class(dependency_config_t), intent(in) :: dependency + !> Index of the dependency + integer :: pos + + integer :: ii + + pos = self%find(dependency%name) + + end function find_dependency + + !> Find a dependency in the dependency tree + pure function find_name(self, name) result(pos) + !> Instance of the dependency tree + class(dependency_tree_t), intent(in) :: self + !> Dependency configuration to add + character(len=*), intent(in) :: name + !> Index of the dependency + integer :: pos + + integer :: ii + + pos = 0 + do ii = 1, self%ndep + if (name == self%dep(ii)%name) then + pos = ii + exit + end if + end do + + end function find_name + + !> Check if we are done with the dependency resolution + pure function finished(self) + !> Instance of the dependency tree + class(dependency_tree_t), intent(in) :: self + !> All dependencies are updated + logical :: finished + integer :: ii + + finished = all(self%dep(:self%ndep)%done) + + end function finished + + !> Update dependency from project manifest + subroutine register(self, package, root, fetch, revision, error) + !> Instance of the dependency node + class(dependency_node_t), intent(inout) :: self + !> Package configuration data + type(package_config_t), intent(in) :: package + !> Project has been fetched + logical, intent(in) :: fetch + !> Root directory of the project + character(len=*), intent(in) :: root + !> Git revision of the project + character(len=*), intent(in), optional :: revision + !> Error handling + type(error_t), allocatable, intent(out) :: error + + character(len=:), allocatable :: url + logical :: update + + update = .false. + if (self%name /= package%name) then + call fatal_error(error, "Dependency name '"//package%name// & + & "' found, but expected '"//self%name//"' instead") + end if + + self%version = package%version + self%proj_dir = root + + if (allocated(self%git).and.present(revision)) then + self%revision = revision + if (.not.fetch) then + ! git object is HEAD always allows an update + update = .not.allocated(self%git%object) + if (.not.update) then + ! allow update in case the revision does not match the requested object + update = revision /= self%git%object + end if + end if + end if + + self%update = update + self%done = .true. + + end subroutine register + + !> Read dependency tree from file + subroutine load_from_file(self, file, error) + !> Instance of the dependency tree + class(dependency_tree_t), intent(inout) :: self + !> File name + character(len=*), intent(in) :: file + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + logical :: exist + + inquire(file=file, exist=exist) + if (.not.exist) return + + open(file=file, newunit=unit) + call self%load(unit, error) + close(unit) + end subroutine load_from_file + + !> Read dependency tree from file + subroutine load_from_unit(self, unit, error) + !> Instance of the dependency tree + class(dependency_tree_t), intent(inout) :: self + !> File name + integer, intent(in) :: unit + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_error), allocatable :: parse_error + type(toml_table), allocatable :: table + + call toml_parse(table, unit, parse_error) + + if (allocated(parse_error)) then + allocate(error) + call move_alloc(parse_error%message, error%message) + return + end if + + call self%load(table, error) + if (allocated(error)) return + + end subroutine load_from_unit + + !> Read dependency tree from TOML data structure + subroutine load_from_toml(self, table, error) + !> Instance of the dependency tree + class(dependency_tree_t), intent(inout) :: self + !> Data structure + type(toml_table), intent(inout) :: table + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: ndep, ii + logical :: unix + character(len=:), allocatable :: version, url, obj, rev, proj_dir + type(toml_key), allocatable :: list(:) + type(toml_table), pointer :: ptr + type(dependency_config_t) :: dep + + call table%get_keys(list) + + ndep = size(self%dep) + if (ndep < size(list) + self%ndep) then + call resize(self%dep, ndep + ndep/2 + size(list)) + end if + + unix = get_os_type() /= OS_WINDOWS + + do ii = 1, size(list) + call get_value(table, list(ii)%key, ptr) + call get_value(ptr, "version", version) + call get_value(ptr, "proj-dir", proj_dir) + call get_value(ptr, "git", url) + call get_value(ptr, "obj", obj) + call get_value(ptr, "rev", rev) + if (.not.allocated(proj_dir)) cycle + self%ndep = self%ndep + 1 + associate(dep => self%dep(self%ndep)) + dep%name = list(ii)%key + if (unix) then + dep%proj_dir = proj_dir + else + dep%proj_dir = windows_path(proj_dir) + end if + dep%done = .false. + if (allocated(version)) then + if (.not.allocated(dep%version)) allocate(dep%version) + call new_version(dep%version, version, error) + if (allocated(error)) exit + end if + if (allocated(version)) then + call new_version(dep%version, version, error) + if (allocated(error)) exit + end if + if (allocated(url)) then + if (allocated(obj)) then + dep%git = git_target_revision(url, obj) + else + dep%git = git_target_default(url) + end if + if (allocated(rev)) then + dep%revision = rev + end if + else + dep%path = proj_dir + end if + end associate + end do + if (allocated(error)) return + + self%ndep = size(list) + end subroutine load_from_toml + + !> Write dependency tree to file + subroutine dump_to_file(self, file, error) + !> Instance of the dependency tree + class(dependency_tree_t), intent(inout) :: self + !> File name + character(len=*), intent(in) :: file + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + + open(file=file, newunit=unit) + call self%dump(unit, error) + close(unit) + if (allocated(error)) return + + end subroutine dump_to_file + + !> Write dependency tree to file + subroutine dump_to_unit(self, unit, error) + !> Instance of the dependency tree + class(dependency_tree_t), intent(inout) :: self + !> Formatted unit + integer, intent(in) :: unit + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_serializer) :: ser + + table = toml_table() + ser = toml_serializer(unit) + + call self%dump(table, error) + + call table%accept(ser) + + end subroutine dump_to_unit + + !> Write dependency tree to TOML datastructure + subroutine dump_to_toml(self, table, error) + !> Instance of the dependency tree + class(dependency_tree_t), intent(inout) :: self + !> Data structure + type(toml_table), intent(inout) :: table + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: ii + type(toml_table), pointer :: ptr + character(len=:), allocatable :: proj_dir + + do ii = 1, self%ndep + associate(dep => self%dep(ii)) + call add_table(table, dep%name, ptr) + if (.not.associated(ptr)) then + call fatal_error(error, "Cannot create entry for "//dep%name) + exit + end if + if (allocated(dep%version)) then + call set_value(ptr, "version", char(dep%version)) + end if + proj_dir = canon_path(dep%proj_dir) + call set_value(ptr, "proj-dir", proj_dir) + if (allocated(dep%git)) then + call set_value(ptr, "git", dep%git%url) + if (allocated(dep%git%object)) then + call set_value(ptr, "obj", dep%git%object) + end if + if (allocated(dep%revision)) then + call set_value(ptr, "rev", dep%revision) + end if + end if + end associate + end do + if (allocated(error)) return + + end subroutine dump_to_toml + + !> Reallocate a list of dependencies + pure subroutine resize_dependency_node(var, n) + !> Instance of the array to be resized + type(dependency_node_t), allocatable, intent(inout) :: var(:) + !> Dimension of the final array size + integer, intent(in), optional :: n + + type(dependency_node_t), allocatable :: tmp(:) + integer :: this_size, new_size + integer, parameter :: initial_size = 16 + + if (allocated(var)) then + this_size = size(var, 1) + call move_alloc(var, tmp) + else + this_size = initial_size + end if + + if (present(n)) then + new_size = n + else + new_size = this_size + this_size/2 + 1 + end if + + allocate(var(new_size)) + + if (allocated(tmp)) then + this_size = min(size(tmp, 1), size(var, 1)) + var(:this_size) = tmp(:this_size) + deallocate(tmp) + end if + + end subroutine resize_dependency_node + +end module fpm_dependency diff --git a/src/fpm/error.f90 b/src/fpm/error.f90 new file mode 100644 index 0000000..e69ff1e --- /dev/null +++ b/src/fpm/error.f90 @@ -0,0 +1,128 @@ +!> Implementation of basic error handling. +module fpm_error + implicit none + private + + public :: error_t + public :: fatal_error, syntax_error, file_not_found_error + public :: file_parse_error + + + !> Data type defining an error + type :: error_t + + !> Error message + character(len=:), allocatable :: message + + end type error_t + + + !> Alias syntax errors to fatal errors for now + interface syntax_error + module procedure :: fatal_error + end interface syntax_error + + +contains + + + !> Generic fatal runtime error + subroutine fatal_error(error, message) + + !> Instance of the error data + type(error_t), allocatable, intent(out) :: error + + !> Error message + character(len=*), intent(in) :: message + + allocate(error) + error%message = message + + end subroutine fatal_error + + + !> Error created when a file is missing or not found + subroutine file_not_found_error(error, file_name) + + !> Instance of the error data + type(error_t), allocatable, intent(out) :: error + + !> Name of the missing file + character(len=*), intent(in) :: file_name + + allocate(error) + error%message = "'"//file_name//"' could not be found, check if the file exists" + + 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/src/fpm/git.f90 b/src/fpm/git.f90 new file mode 100644 index 0000000..08e27b2 --- /dev/null +++ b/src/fpm/git.f90 @@ -0,0 +1,263 @@ +!> Implementation for interacting with git repositories. +module fpm_git + use fpm_error, only: error_t, fatal_error + use fpm_filesystem, only : get_temp_filename, getline + implicit none + + public :: git_target_t + public :: git_target_default, git_target_branch, git_target_tag, & + & git_target_revision + public :: git_revision + + + !> Possible git target + type :: enum_descriptor + + !> Default target + integer :: default = 200 + + !> Branch in git repository + integer :: branch = 201 + + !> Tag in git repository + integer :: tag = 202 + + !> Commit hash + integer :: revision = 203 + + end type enum_descriptor + + !> Actual enumerator for descriptors + type(enum_descriptor), parameter :: git_descriptor = enum_descriptor() + + + !> Description of an git target + type :: git_target_t + + !> Kind of the git target + integer, private :: descriptor = git_descriptor%default + + !> Target URL of the git repository + character(len=:), allocatable :: url + + !> Additional descriptor of the git object + character(len=:), allocatable :: object + + contains + + !> Fetch and checkout in local directory + procedure :: checkout + + !> Show information on instance + procedure :: info + + end type git_target_t + + +contains + + + !> Default target + function git_target_default(url) result(self) + + !> Target URL of the git repository + character(len=*), intent(in) :: url + + !> New git target + type(git_target_t) :: self + + self%descriptor = git_descriptor%default + self%url = url + + end function git_target_default + + + !> Target a branch in the git repository + function git_target_branch(url, branch) result(self) + + !> Target URL of the git repository + character(len=*), intent(in) :: url + + !> Name of the branch of interest + character(len=*), intent(in) :: branch + + !> New git target + type(git_target_t) :: self + + self%descriptor = git_descriptor%branch + self%url = url + self%object = branch + + end function git_target_branch + + + !> Target a specific git revision + function git_target_revision(url, sha1) result(self) + + !> Target URL of the git repository + character(len=*), intent(in) :: url + + !> Commit hash of interest + character(len=*), intent(in) :: sha1 + + !> New git target + type(git_target_t) :: self + + self%descriptor = git_descriptor%revision + self%url = url + self%object = sha1 + + end function git_target_revision + + + !> Target a git tag + function git_target_tag(url, tag) result(self) + + !> Target URL of the git repository + character(len=*), intent(in) :: url + + !> Tag name of interest + character(len=*), intent(in) :: tag + + !> New git target + type(git_target_t) :: self + + self%descriptor = git_descriptor%tag + self%url = url + self%object = tag + + end function git_target_tag + + + subroutine checkout(self, local_path, error) + + !> Instance of the git target + class(git_target_t), intent(in) :: self + + !> Local path to checkout in + character(*), intent(in) :: local_path + + !> Error + type(error_t), allocatable, intent(out) :: error + + integer :: stat + character(len=:), allocatable :: object + + if (allocated(self%object)) then + object = self%object + else + object = 'HEAD' + end if + + call execute_command_line("git init "//local_path, exitstat=stat) + + if (stat /= 0) then + call fatal_error(error,'Error while initiating git repository for remote dependency') + return + end if + + call execute_command_line("git -C "//local_path//" fetch --depth=1 "// & + self%url//" "//object, exitstat=stat) + + if (stat /= 0) then + call fatal_error(error,'Error while fetching git repository for remote dependency') + return + end if + + call execute_command_line("git -C "//local_path//" checkout -qf FETCH_HEAD", exitstat=stat) + + if (stat /= 0) then + call fatal_error(error,'Error while checking out git repository for remote dependency') + return + end if + + end subroutine checkout + + + subroutine git_revision(local_path, object, error) + + !> Local path to checkout in + character(*), intent(in) :: local_path + + !> Git object reference + character(len=:), allocatable, intent(out) :: object + + !> Error + type(error_t), allocatable, intent(out) :: error + + integer :: stat, unit, istart, iend + character(len=:), allocatable :: temp_file, line, iomsg + character(len=*), parameter :: hexdigits = '0123456789abcdef' + + allocate(temp_file, source=get_temp_filename()) + line = "git -C "//local_path//" log -n 1 > "//temp_file + call execute_command_line(line, exitstat=stat) + + if (stat /= 0) then + call fatal_error(error, "Error while retrieving commit information") + return + end if + + open(file=temp_file, newunit=unit) + call getline(unit, line, stat, iomsg) + + if (stat /= 0) then + call fatal_error(error, iomsg) + return + end if + close(unit, status="delete") + + ! Tokenize: + ! commit 0123456789abcdef (HEAD, ...) + istart = scan(line, ' ') + 1 + iend = verify(line(istart:), hexdigits) + istart - 1 + if (iend < istart) iend = len(line) + object = line(istart:iend) + + end subroutine git_revision + + + !> Show information on git target + subroutine info(self, unit, verbosity) + + !> Instance of the git target + class(git_target_t), intent(in) :: self + + !> Unit for IO + integer, intent(in) :: unit + + !> Verbosity of the printout + integer, intent(in), optional :: verbosity + + integer :: pr + character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)' + + if (present(verbosity)) then + pr = verbosity + else + pr = 1 + end if + + if (pr < 1) return + + write(unit, fmt) "Git target" + if (allocated(self%url)) then + write(unit, fmt) "- URL", self%url + end if + if (allocated(self%object)) then + select case(self%descriptor) + case default + write(unit, fmt) "- object", self%object + case(git_descriptor%tag) + write(unit, fmt) "- tag", self%object + case(git_descriptor%branch) + write(unit, fmt) "- branch", self%object + case(git_descriptor%revision) + write(unit, fmt) "- sha1", self%object + end select + end if + + end subroutine info + + +end module fpm_git diff --git a/src/fpm/installer.f90 b/src/fpm/installer.f90 new file mode 100644 index 0000000..d01bd27 --- /dev/null +++ b/src/fpm/installer.f90 @@ -0,0 +1,284 @@ +!> Implementation of an installer object. +!> +!> The installer provides a way to install objects to their respective directories +!> in the installation prefix, a generic install command allows to install +!> to any directory within the prefix. +module fpm_installer + use, intrinsic :: iso_fortran_env, only : output_unit + use fpm_environment, only : get_os_type, os_is_unix + use fpm_error, only : error_t, fatal_error + use fpm_filesystem, only : join_path, mkdir, exists, unix_path, windows_path, & + env_variable + implicit none + private + + public :: installer_t, new_installer + + + !> Declaration of the installer type + type :: installer_t + !> Path to installation directory + character(len=:), allocatable :: prefix + !> Binary dir relative to the installation prefix + character(len=:), allocatable :: bindir + !> Library directory relative to the installation prefix + character(len=:), allocatable :: libdir + !> Include directory relative to the installation prefix + character(len=:), allocatable :: includedir + !> Output unit for informative printout + integer :: unit = output_unit + !> Verbosity of the installer + integer :: verbosity = 1 + !> Command to copy objects into the installation prefix + character(len=:), allocatable :: copy + !> Cached operating system + integer :: os + contains + !> Install an executable in its correct subdirectory + procedure :: install_executable + !> Install a library in its correct subdirectory + procedure :: install_library + !> Install a header/module in its correct subdirectory + procedure :: install_header + !> Install a generic file into a subdirectory in the installation prefix + procedure :: install + !> Run an installation command, type-bound for unit testing purposes + procedure :: run + !> Create a new directory in the prefix, type-bound for unit testing purposes + procedure :: make_dir + end type installer_t + + !> Default name of the binary subdirectory + character(len=*), parameter :: default_bindir = "bin" + + !> Default name of the library subdirectory + character(len=*), parameter :: default_libdir = "lib" + + !> Default name of the include subdirectory + character(len=*), parameter :: default_includedir = "include" + + !> Default name of the installation prefix on Unix platforms + character(len=*), parameter :: default_prefix_unix = "/usr/local" + + !> Default name of the installation prefix on Windows platforms + character(len=*), parameter :: default_prefix_win = "C:\" + + !> Copy command on Unix platforms + character(len=*), parameter :: default_copy_unix = "cp" + + !> Copy command on Windows platforms + character(len=*), parameter :: default_copy_win = "copy" + +contains + + !> Create a new instance of an installer + subroutine new_installer(self, prefix, bindir, libdir, includedir, verbosity, & + copy) + !> Instance of the installer + type(installer_t), intent(out) :: self + !> Path to installation directory + character(len=*), intent(in), optional :: prefix + !> Binary dir relative to the installation prefix + character(len=*), intent(in), optional :: bindir + !> Library directory relative to the installation prefix + character(len=*), intent(in), optional :: libdir + !> Include directory relative to the installation prefix + character(len=*), intent(in), optional :: includedir + !> Verbosity of the installer + integer, intent(in), optional :: verbosity + !> Copy command + character(len=*), intent(in), optional :: copy + + self%os = get_os_type() + + if (present(copy)) then + self%copy = copy + else + if (os_is_unix(self%os)) then + self%copy = default_copy_unix + else + self%copy = default_copy_win + end if + end if + + if (present(includedir)) then + self%includedir = includedir + else + self%includedir = default_includedir + end if + + if (present(prefix)) then + self%prefix = prefix + else + call set_default_prefix(self%prefix, self%os) + end if + + if (present(bindir)) then + self%bindir = bindir + else + self%bindir = default_bindir + end if + + if (present(libdir)) then + self%libdir = libdir + else + self%libdir = default_libdir + end if + + if (present(verbosity)) then + self%verbosity = verbosity + else + self%verbosity = 1 + end if + + end subroutine new_installer + + !> Set the default prefix for the installation + subroutine set_default_prefix(prefix, os) + !> Installation prefix + character(len=:), allocatable :: prefix + !> Platform identifier + integer, intent(in), optional :: os + + character(len=:), allocatable :: home + + if (os_is_unix(os)) then + call env_variable(home, "HOME") + if (allocated(home)) then + prefix = join_path(home, ".local") + else + prefix = default_prefix_unix + end if + else + call env_variable(home, "APPDATA") + if (allocated(home)) then + prefix = join_path(home, "local") + else + prefix = default_prefix_win + end if + end if + + end subroutine set_default_prefix + + !> Install an executable in its correct subdirectory + subroutine install_executable(self, executable, error) + !> Instance of the installer + class(installer_t), intent(inout) :: self + !> Path to the executable + character(len=*), intent(in) :: executable + !> Error handling + type(error_t), allocatable, intent(out) :: error + integer :: ll + + if (.not.os_is_unix(self%os)) then + ll = len(executable) + if (executable(max(1, ll-3):ll) /= ".exe") then + call self%install(executable//".exe", self%bindir, error) + return + end if + end if + + call self%install(executable, self%bindir, error) + + end subroutine install_executable + + !> Install a library in its correct subdirectory + subroutine install_library(self, library, error) + !> Instance of the installer + class(installer_t), intent(inout) :: self + !> Path to the library + character(len=*), intent(in) :: library + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call self%install(library, self%libdir, error) + end subroutine install_library + + !> Install a header/module in its correct subdirectory + subroutine install_header(self, header, error) + !> Instance of the installer + class(installer_t), intent(inout) :: self + !> Path to the header + character(len=*), intent(in) :: header + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call self%install(header, self%includedir, error) + end subroutine install_header + + !> Install a generic file into a subdirectory in the installation prefix + subroutine install(self, source, destination, error) + !> Instance of the installer + class(installer_t), intent(inout) :: self + !> Path to the original file + character(len=*), intent(in) :: source + !> Path to the destination inside the prefix + character(len=*), intent(in) :: destination + !> Error handling + type(error_t), allocatable, intent(out) :: error + + character(len=:), allocatable :: install_dest + + install_dest = join_path(self%prefix, destination) + if (os_is_unix(self%os)) then + install_dest = unix_path(install_dest) + else + install_dest = windows_path(install_dest) + end if + call self%make_dir(install_dest, error) + if (allocated(error)) return + + if (self%verbosity > 0) then + if (exists(install_dest)) then + write(self%unit, '("# Update:", 1x, a, 1x, "->", 1x, a)') & + source, install_dest + else + write(self%unit, '("# Install:", 1x, a, 1x, "->", 1x, a)') & + source, install_dest + end if + end if + + call self%run(self%copy//' "'//source//'" "'//install_dest//'"', error) + if (allocated(error)) return + + end subroutine install + + !> Create a new directory in the prefix + subroutine make_dir(self, dir, error) + !> Instance of the installer + class(installer_t), intent(inout) :: self + !> Directory to be created + character(len=*), intent(in) :: dir + !> Error handling + type(error_t), allocatable, intent(out) :: error + + if (.not.exists(dir)) then + if (self%verbosity > 1) then + write(self%unit, '("# Dir:", 1x, a)') dir + end if + call mkdir(dir) + end if + end subroutine make_dir + + !> Run an installation command + subroutine run(self, command, error) + !> Instance of the installer + class(installer_t), intent(inout) :: self + !> Command to be launched + character(len=*), intent(in) :: command + !> Error handling + type(error_t), allocatable, intent(out) :: error + integer :: stat + + if (self%verbosity > 1) then + write(self%unit, '("# Run:", 1x, a)') command + end if + call execute_command_line(command, exitstat=stat) + + if (stat /= 0) then + call fatal_error(error, "Failed in command: '"//command//"'") + return + end if + end subroutine run + +end module fpm_installer diff --git a/src/fpm/manifest.f90 b/src/fpm/manifest.f90 new file mode 100644 index 0000000..4170b91 --- /dev/null +++ b/src/fpm/manifest.f90 @@ -0,0 +1,184 @@ +!> Package configuration data. +!> +!> This module provides the necessary procedure to translate a TOML document +!> to the corresponding Fortran type, while verifying it with respect to +!> its schema. +!> +!> Additionally, the required data types for users of this module are reexported +!> to hide the actual implementation details. +module fpm_manifest + use fpm_manifest_build, only: build_config_t + use fpm_manifest_example, only : example_config_t + use fpm_manifest_executable, only : executable_config_t + use fpm_manifest_dependency, only : dependency_config_t + use fpm_manifest_library, only : library_config_t + use fpm_manifest_package, only : package_config_t, new_package + use fpm_error, only : error_t, fatal_error, file_not_found_error + use fpm_toml, only : toml_table, read_package_file + use fpm_manifest_test, only : test_config_t + use fpm_filesystem, only: join_path, exists, dirname, is_dir + use fpm_strings, only: string_t + implicit none + private + + public :: get_package_data, default_executable, default_library, default_test + public :: default_example + public :: package_config_t, dependency_config_t + + +contains + + + !> Populate library in case we find the default src directory + subroutine default_library(self) + + !> Instance of the library meta data + type(library_config_t), intent(out) :: self + + self%source_dir = "src" + self%include_dir = [string_t("include")] + + end subroutine default_library + + + !> Populate executable in case we find the default app directory + subroutine default_executable(self, name) + + !> Instance of the executable meta data + type(executable_config_t), intent(out) :: self + + !> Name of the package + character(len=*), intent(in) :: name + + self%name = name + self%source_dir = "app" + self%main = "main.f90" + + end subroutine default_executable + + !> Populate test in case we find the default example/ directory + subroutine default_example(self, name) + + !> Instance of the executable meta data + type(example_config_t), intent(out) :: self + + !> Name of the package + character(len=*), intent(in) :: name + + self%name = name // "-demo" + self%source_dir = "example" + self%main = "main.f90" + + end subroutine default_example + + !> Populate test in case we find the default test/ directory + subroutine default_test(self, name) + + !> Instance of the executable meta data + type(test_config_t), intent(out) :: self + + !> Name of the package + character(len=*), intent(in) :: name + + self%name = name // "-test" + self%source_dir = "test" + self%main = "main.f90" + + end subroutine default_test + + + !> Obtain package meta data from a configuation file + subroutine get_package_data(package, file, error, apply_defaults) + + !> Parsed package meta data + type(package_config_t), intent(out) :: package + + !> Name of the package configuration file + character(len=*), intent(in) :: file + + !> Error status of the operation + type(error_t), allocatable, intent(out) :: error + + !> Apply package defaults (uses file system operations) + logical, intent(in), optional :: apply_defaults + + type(toml_table), allocatable :: table + character(len=:), allocatable :: root + + call read_package_file(table, file, error) + if (allocated(error)) return + + if (.not.allocated(table)) then + call fatal_error(error, "Unclassified error while reading: '"//file//"'") + return + end if + + call new_package(package, table, error) + if (allocated(error)) return + + if (present(apply_defaults)) then + if (apply_defaults) then + root = dirname(file) + if (len_trim(root) == 0) root = "." + call package_defaults(package, root, error) + if (allocated(error)) return + end if + end if + + end subroutine get_package_data + + + !> Apply package defaults + subroutine package_defaults(package, root, error) + + !> Parsed package meta data + type(package_config_t), intent(inout) :: package + + !> Current working directory + character(len=*), intent(in) :: root + + !> Error status of the operation + type(error_t), allocatable, intent(out) :: error + + ! Populate library in case we find the default src directory + if (.not.allocated(package%library) .and. & + & (is_dir(join_path(root, "src")) .or. & + & is_dir(join_path(root, "include")))) then + + allocate(package%library) + call default_library(package%library) + end if + + ! Populate executable in case we find the default app + if (.not.allocated(package%executable) .and. & + & exists(join_path(root, "app", "main.f90"))) then + allocate(package%executable(1)) + call default_executable(package%executable(1), package%name) + end if + + ! Populate example in case we find the default example directory + if (.not.allocated(package%example) .and. & + & exists(join_path(root, "example", "main.f90"))) then + allocate(package%example(1)) + call default_example(package%example(1), package%name) + endif + + ! Populate test in case we find the default test directory + if (.not.allocated(package%test) .and. & + & exists(join_path(root, "test", "main.f90"))) then + allocate(package%test(1)) + call default_test(package%test(1), package%name) + endif + + if (.not.(allocated(package%library) & + & .or. allocated(package%executable) & + & .or. allocated(package%example) & + & .or. allocated(package%test))) then + call fatal_error(error, "Neither library nor executable found, there is nothing to do") + return + end if + + end subroutine package_defaults + + +end module fpm_manifest diff --git a/src/fpm/manifest/build.f90 b/src/fpm/manifest/build.f90 new file mode 100644 index 0000000..d96974f --- /dev/null +++ b/src/fpm/manifest/build.f90 @@ -0,0 +1,162 @@ +!> Implementation of the build configuration data. +!> +!> A build table can currently have the following fields +!> +!>```toml +!>[build] +!>auto-executables = bool +!>auto-examples = bool +!>auto-tests = bool +!>link = ["lib"] +!>``` +module fpm_manifest_build + use fpm_error, only : error_t, syntax_error, fatal_error + use fpm_strings, only : string_t + use fpm_toml, only : toml_table, toml_key, toml_stat, get_value + implicit none + private + + public :: build_config_t, new_build_config + + + !> Configuration data for build + type :: build_config_t + + !> Automatic discovery of executables + logical :: auto_executables + + !> Automatic discovery of examples + logical :: auto_examples + + !> Automatic discovery of tests + logical :: auto_tests + + !> Libraries to link against + type(string_t), allocatable :: link(:) + + contains + + !> Print information on this instance + procedure :: info + + end type build_config_t + + +contains + + + !> Construct a new build configuration from a TOML data structure + subroutine new_build_config(self, table, error) + + !> Instance of the build configuration + type(build_config_t), intent(out) :: self + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: stat + + call check(table, error) + if (allocated(error)) return + + call get_value(table, "auto-executables", self%auto_executables, .true., stat=stat) + + if (stat /= toml_stat%success) then + call fatal_error(error,"Error while reading value for 'auto-executables' in fpm.toml, expecting logical") + return + end if + + call get_value(table, "auto-tests", self%auto_tests, .true., stat=stat) + + if (stat /= toml_stat%success) then + call fatal_error(error,"Error while reading value for 'auto-tests' in fpm.toml, expecting logical") + return + end if + + call get_value(table, "auto-examples", self%auto_examples, .true., stat=stat) + + if (stat /= toml_stat%success) then + call fatal_error(error,"Error while reading value for 'auto-examples' in fpm.toml, expecting logical") + return + end if + + + call get_value(table, "link", self%link, error) + if (allocated(error)) return + + end subroutine new_build_config + + + !> Check local schema for allowed entries + subroutine check(table, error) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_key), allocatable :: list(:) + integer :: ikey + + call table%get_keys(list) + + ! table can be empty + if (size(list) < 1) return + + do ikey = 1, size(list) + select case(list(ikey)%key) + + case("auto-executables", "auto-examples", "auto-tests", "link") + continue + + case default + call syntax_error(error, "Key "//list(ikey)%key//" is not allowed in [build]") + exit + + end select + end do + + end subroutine check + + + !> Write information on build configuration instance + subroutine info(self, unit, verbosity) + + !> Instance of the build configuration + class(build_config_t), intent(in) :: self + + !> Unit for IO + integer, intent(in) :: unit + + !> Verbosity of the printout + integer, intent(in), optional :: verbosity + + integer :: pr, ilink + character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)' + + if (present(verbosity)) then + pr = verbosity + else + pr = 1 + end if + + if (pr < 1) return + + write(unit, fmt) "Build configuration" + write(unit, fmt) " - auto-discovery (apps) ", merge("enabled ", "disabled", self%auto_executables) + write(unit, fmt) " - auto-discovery (examples) ", merge("enabled ", "disabled", self%auto_examples) + write(unit, fmt) " - auto-discovery (tests) ", merge("enabled ", "disabled", self%auto_tests) + if (allocated(self%link)) then + write(unit, fmt) " - link against" + do ilink = 1, size(self%link) + write(unit, fmt) " - " // self%link(ilink)%s + end do + end if + + end subroutine info + +end module fpm_manifest_build diff --git a/src/fpm/manifest/dependency.f90 b/src/fpm/manifest/dependency.f90 new file mode 100644 index 0000000..26b76ee --- /dev/null +++ b/src/fpm/manifest/dependency.f90 @@ -0,0 +1,248 @@ +!> Implementation of the meta data for dependencies. +!> +!> A dependency table can currently have the following fields +!> +!>```toml +!>[dependencies] +!>"dep1" = { git = "url" } +!>"dep2" = { git = "url", branch = "name" } +!>"dep3" = { git = "url", tag = "name" } +!>"dep4" = { git = "url", rev = "sha1" } +!>"dep0" = { path = "path" } +!>``` +!> +!> To reduce the amount of boilerplate code this module provides two constructors +!> for dependency types, one basic for an actual dependency (inline) table +!> and another to collect all dependency objects from a dependencies table, +!> which is handling the allocation of the objects and is forwarding the +!> individual dependency tables to their respective constructors. +!> The usual entry point should be the constructor for the super table. +!> +!> This objects contains a target to retrieve required `fpm` projects to +!> build the target declaring the dependency. +!> Resolving a dependency will result in obtaining a new package configuration +!> data for the respective project. +module fpm_manifest_dependency + use fpm_error, only : error_t, syntax_error + use fpm_git, only : git_target_t, git_target_tag, git_target_branch, & + & git_target_revision, git_target_default + use fpm_toml, only : toml_table, toml_key, toml_stat, get_value + implicit none + private + + public :: dependency_config_t, new_dependency, new_dependencies + + + !> Configuration meta data for a dependency + type :: dependency_config_t + + !> Name of the dependency + character(len=:), allocatable :: name + + !> Local target + character(len=:), allocatable :: path + + !> Git descriptor + type(git_target_t), allocatable :: git + + contains + + !> Print information on this instance + procedure :: info + + end type dependency_config_t + + +contains + + + !> Construct a new dependency configuration from a TOML data structure + subroutine new_dependency(self, table, error) + + !> Instance of the dependency configuration + type(dependency_config_t), intent(out) :: self + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + character(len=:), allocatable :: url, obj + + call check(table, error) + if (allocated(error)) return + + call table%get_key(self%name) + + call get_value(table, "path", url) + if (allocated(url)) then + call move_alloc(url, self%path) + else + call get_value(table, "git", url) + + call get_value(table, "tag", obj) + if (allocated(obj)) then + self%git = git_target_tag(url, obj) + end if + + if (.not.allocated(self%git)) then + call get_value(table, "branch", obj) + if (allocated(obj)) then + self%git = git_target_branch(url, obj) + end if + end if + + if (.not.allocated(self%git)) then + call get_value(table, "rev", obj) + if (allocated(obj)) then + self%git = git_target_revision(url, obj) + end if + end if + + if (.not.allocated(self%git)) then + self%git = git_target_default(url) + end if + + end if + + end subroutine new_dependency + + + !> Check local schema for allowed entries + subroutine check(table, error) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + character(len=:), allocatable :: name + type(toml_key), allocatable :: list(:) + logical :: url_present, git_target_present, has_path + integer :: ikey + + has_path = .false. + url_present = .false. + git_target_present = .false. + + call table%get_key(name) + call table%get_keys(list) + + if (size(list) < 1) then + call syntax_error(error, "Dependency "//name//" does not provide sufficient entries") + return + end if + + do ikey = 1, size(list) + select case(list(ikey)%key) + case default + call syntax_error(error, "Key "//list(ikey)%key//" is not allowed in dependency "//name) + exit + + case("git", "path") + if (url_present) then + call syntax_error(error, "Dependency "//name//" cannot have both git and path entries") + exit + end if + url_present = .true. + has_path = list(ikey)%key == 'path' + + case("branch", "rev", "tag") + if (git_target_present) then + call syntax_error(error, "Dependency "//name//" can only have one of branch, rev or tag present") + exit + end if + git_target_present = .true. + + end select + end do + if (allocated(error)) return + + if (.not.url_present) then + call syntax_error(error, "Dependency "//name//" does not provide a method to actually retrieve itself") + return + end if + + 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 + + end subroutine check + + + !> Construct new dependency array from a TOML data structure + subroutine new_dependencies(deps, table, error) + + !> Instance of the dependency configuration + type(dependency_config_t), allocatable, intent(out) :: deps(:) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table), pointer :: node + type(toml_key), allocatable :: list(:) + integer :: idep, stat + + call table%get_keys(list) + ! An empty table is okay + if (size(list) < 1) return + + allocate(deps(size(list))) + do idep = 1, size(list) + call get_value(table, list(idep)%key, node, stat=stat) + if (stat /= toml_stat%success) then + call syntax_error(error, "Dependency "//list(idep)%key//" must be a table entry") + exit + end if + call new_dependency(deps(idep), node, error) + if (allocated(error)) exit + end do + + end subroutine new_dependencies + + + !> Write information on instance + subroutine info(self, unit, verbosity) + + !> Instance of the dependency configuration + class(dependency_config_t), intent(in) :: self + + !> Unit for IO + integer, intent(in) :: unit + + !> Verbosity of the printout + integer, intent(in), optional :: verbosity + + integer :: pr + character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)' + + if (present(verbosity)) then + pr = verbosity + else + pr = 1 + end if + + write(unit, fmt) "Dependency" + if (allocated(self%name)) then + write(unit, fmt) "- name", self%name + end if + + if (allocated(self%git)) then + write(unit, fmt) "- kind", "git" + call self%git%info(unit, pr - 1) + end if + + if (allocated(self%path)) then + write(unit, fmt) "- kind", "local" + write(unit, fmt) "- path", self%path + end if + + end subroutine info + + +end module fpm_manifest_dependency diff --git a/src/fpm/manifest/example.f90 b/src/fpm/manifest/example.f90 new file mode 100644 index 0000000..fc2a0af --- /dev/null +++ b/src/fpm/manifest/example.f90 @@ -0,0 +1,175 @@ +!> Implementation of the meta data for an example. +!> +!> The example data structure is effectively a decorated version of an executable +!> and shares most of its properties, except for the defaults and can be +!> handled under most circumstances just like any other executable. +!> +!> A example table can currently have the following fields +!> +!>```toml +!>[[ example ]] +!>name = "string" +!>source-dir = "path" +!>main = "file" +!>link = ["lib"] +!>[example.dependencies] +!>``` +module fpm_manifest_example + use fpm_manifest_dependency, only : dependency_config_t, new_dependencies + use fpm_manifest_executable, only : executable_config_t + use fpm_error, only : error_t, syntax_error + use fpm_toml, only : toml_table, toml_key, toml_stat, get_value + implicit none + private + + public :: example_config_t, new_example + + + !> Configuation meta data for an example + type, extends(executable_config_t) :: example_config_t + + contains + + !> Print information on this instance + procedure :: info + + end type example_config_t + + +contains + + + !> Construct a new example configuration from a TOML data structure + subroutine new_example(self, table, error) + + !> Instance of the example configuration + type(example_config_t), intent(out) :: self + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table), pointer :: child + + call check(table, error) + if (allocated(error)) return + + call get_value(table, "name", self%name) + if (.not.allocated(self%name)) then + call syntax_error(error, "Could not retrieve example name") + return + end if + call get_value(table, "source-dir", self%source_dir, "example") + call get_value(table, "main", self%main, "main.f90") + + call get_value(table, "dependencies", child, requested=.false.) + if (associated(child)) then + call new_dependencies(self%dependency, child, error) + if (allocated(error)) return + end if + + call get_value(table, "link", self%link, error) + if (allocated(error)) return + + end subroutine new_example + + + !> Check local schema for allowed entries + subroutine check(table, error) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_key), allocatable :: list(:) + logical :: name_present + integer :: ikey + + name_present = .false. + + call table%get_keys(list) + + if (size(list) < 1) then + call syntax_error(error, "Example section does not provide sufficient entries") + return + end if + + do ikey = 1, size(list) + select case(list(ikey)%key) + case default + call syntax_error(error, "Key "//list(ikey)%key//" is not allowed in example entry") + exit + + case("name") + name_present = .true. + + case("source-dir", "main", "dependencies", "link") + continue + + end select + end do + if (allocated(error)) return + + if (.not.name_present) then + call syntax_error(error, "Example name is not provided, please add a name entry") + end if + + end subroutine check + + + !> Write information on instance + subroutine info(self, unit, verbosity) + + !> Instance of the example configuration + class(example_config_t), intent(in) :: self + + !> Unit for IO + integer, intent(in) :: unit + + !> Verbosity of the printout + integer, intent(in), optional :: verbosity + + integer :: pr, ii + character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)', & + & fmti = '("#", 1x, a, t30, i0)' + + if (present(verbosity)) then + pr = verbosity + else + pr = 1 + end if + + if (pr < 1) return + + write(unit, fmt) "Example target" + if (allocated(self%name)) then + write(unit, fmt) "- name", self%name + end if + if (allocated(self%source_dir)) then + if (self%source_dir /= "example" .or. pr > 2) then + write(unit, fmt) "- source directory", self%source_dir + end if + end if + if (allocated(self%main)) then + if (self%main /= "main.f90" .or. pr > 2) then + write(unit, fmt) "- example source", self%main + end if + end if + + if (allocated(self%dependency)) then + if (size(self%dependency) > 1 .or. pr > 2) then + write(unit, fmti) "- dependencies", size(self%dependency) + end if + do ii = 1, size(self%dependency) + call self%dependency(ii)%info(unit, pr - 1) + end do + end if + + end subroutine info + + +end module fpm_manifest_example diff --git a/src/fpm/manifest/executable.f90 b/src/fpm/manifest/executable.f90 new file mode 100644 index 0000000..be02974 --- /dev/null +++ b/src/fpm/manifest/executable.f90 @@ -0,0 +1,186 @@ +!> Implementation of the meta data for an executables. +!> +!> An executable table can currently have the following fields +!> +!>```toml +!>[[ executable ]] +!>name = "string" +!>source-dir = "path" +!>main = "file" +!>link = ["lib"] +!>[executable.dependencies] +!>``` +module fpm_manifest_executable + use fpm_manifest_dependency, only : dependency_config_t, new_dependencies + use fpm_error, only : error_t, syntax_error + use fpm_strings, only : string_t + use fpm_toml, only : toml_table, toml_key, toml_stat, get_value + implicit none + private + + public :: executable_config_t, new_executable + + + !> Configuation meta data for an executable + type :: executable_config_t + + !> Name of the resulting executable + character(len=:), allocatable :: name + + !> Source directory for collecting the executable + character(len=:), allocatable :: source_dir + + !> Name of the source file declaring the main program + character(len=:), allocatable :: main + + !> Dependency meta data for this executable + type(dependency_config_t), allocatable :: dependency(:) + + !> Libraries to link against + type(string_t), allocatable :: link(:) + + contains + + !> Print information on this instance + procedure :: info + + end type executable_config_t + + +contains + + + !> Construct a new executable configuration from a TOML data structure + subroutine new_executable(self, table, error) + + !> Instance of the executable configuration + type(executable_config_t), intent(out) :: self + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table), pointer :: child + + call check(table, error) + if (allocated(error)) return + + call get_value(table, "name", self%name) + if (.not.allocated(self%name)) then + call syntax_error(error, "Could not retrieve executable name") + return + end if + call get_value(table, "source-dir", self%source_dir, "app") + call get_value(table, "main", self%main, "main.f90") + + call get_value(table, "dependencies", child, requested=.false.) + if (associated(child)) then + call new_dependencies(self%dependency, child, error) + if (allocated(error)) return + end if + + call get_value(table, "link", self%link, error) + if (allocated(error)) return + + end subroutine new_executable + + + !> Check local schema for allowed entries + subroutine check(table, error) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_key), allocatable :: list(:) + logical :: name_present + integer :: ikey + + name_present = .false. + + call table%get_keys(list) + + if (size(list) < 1) then + call syntax_error(error, "Executable section does not provide sufficient entries") + return + end if + + do ikey = 1, size(list) + select case(list(ikey)%key) + case default + call syntax_error(error, "Key "//list(ikey)%key//" is not allowed as executable entry") + exit + + case("name") + name_present = .true. + + case("source-dir", "main", "dependencies", "link") + continue + + 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") + end if + + end subroutine check + + + !> Write information on instance + subroutine info(self, unit, verbosity) + + !> Instance of the executable configuration + class(executable_config_t), intent(in) :: self + + !> Unit for IO + integer, intent(in) :: unit + + !> Verbosity of the printout + integer, intent(in), optional :: verbosity + + integer :: pr, ii + character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)', & + & fmti = '("#", 1x, a, t30, i0)' + + if (present(verbosity)) then + pr = verbosity + else + pr = 1 + end if + + if (pr < 1) return + + write(unit, fmt) "Executable target" + if (allocated(self%name)) then + write(unit, fmt) "- name", self%name + end if + if (allocated(self%source_dir)) then + if (self%source_dir /= "app" .or. pr > 2) then + write(unit, fmt) "- source directory", self%source_dir + end if + end if + if (allocated(self%main)) then + if (self%main /= "main.f90" .or. pr > 2) then + write(unit, fmt) "- program source", self%main + end if + end if + + if (allocated(self%dependency)) then + if (size(self%dependency) > 1 .or. pr > 2) then + write(unit, fmti) "- dependencies", size(self%dependency) + end if + do ii = 1, size(self%dependency) + call self%dependency(ii)%info(unit, pr - 1) + end do + end if + + end subroutine info + + +end module fpm_manifest_executable diff --git a/src/fpm/manifest/install.f90 b/src/fpm/manifest/install.f90 new file mode 100644 index 0000000..6175873 --- /dev/null +++ b/src/fpm/manifest/install.f90 @@ -0,0 +1,108 @@ +!> Implementation of the installation configuration. +!> +!> An install table can currently have the following fields +!> +!>```toml +!>library = bool +!>``` +module fpm_manifest_install + use fpm_error, only : error_t, fatal_error, syntax_error + use fpm_toml, only : toml_table, toml_key, toml_stat, get_value + implicit none + private + + public :: install_config_t, new_install_config + + !> Configuration data for installation + type :: install_config_t + + !> Install library with this project + logical :: library + + contains + + !> Print information on this instance + procedure :: info + + end type install_config_t + +contains + + !> Create a new installation configuration from a TOML data structure + subroutine new_install_config(self, table, error) + + !> Instance of the install configuration + type(install_config_t), intent(out) :: self + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call check(table, error) + if (allocated(error)) return + + call get_value(table, "library", self%library, .false.) + + end subroutine new_install_config + + + !> Check local schema for allowed entries + subroutine check(table, error) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_key), allocatable :: list(:) + integer :: ikey + + call table%get_keys(list) + if (size(list) < 1) return + + do ikey = 1, size(list) + select case(list(ikey)%key) + case default + call syntax_error(error, "Key "//list(ikey)%key//" is not allowed in install table") + exit + case("library") + continue + end select + end do + if (allocated(error)) return + + end subroutine check + + !> Write information on install configuration instance + subroutine info(self, unit, verbosity) + + !> Instance of the build configuration + class(install_config_t), intent(in) :: self + + !> Unit for IO + integer, intent(in) :: unit + + !> Verbosity of the printout + integer, intent(in), optional :: verbosity + + integer :: pr + character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)' + + if (present(verbosity)) then + pr = verbosity + else + pr = 1 + end if + + if (pr < 1) return + + write(unit, fmt) "Install configuration" + write(unit, fmt) " - library install", & + & trim(merge("enabled ", "disabled", self%library)) + + end subroutine info + +end module fpm_manifest_install diff --git a/src/fpm/manifest/library.f90 b/src/fpm/manifest/library.f90 new file mode 100644 index 0000000..c8ce049 --- /dev/null +++ b/src/fpm/manifest/library.f90 @@ -0,0 +1,142 @@ +!> Implementation of the meta data for libraries. +!> +!> A library table can currently have the following fields +!> +!>```toml +!>[library] +!>source-dir = "path" +!>include-dir = ["path1","path2"] +!>build-script = "file" +!>``` +module fpm_manifest_library + use fpm_error, only : error_t, syntax_error + use fpm_strings, only: string_t, string_cat + use fpm_toml, only : toml_table, toml_key, toml_stat, get_value + implicit none + private + + public :: library_config_t, new_library + + + !> Configuration meta data for a library + type :: library_config_t + + !> Source path prefix + character(len=:), allocatable :: source_dir + + !> Include path prefix + type(string_t), allocatable :: include_dir(:) + + !> Alternative build script to be invoked + character(len=:), allocatable :: build_script + + contains + + !> Print information on this instance + procedure :: info + + end type library_config_t + + +contains + + + !> Construct a new library configuration from a TOML data structure + subroutine new_library(self, table, error) + + !> Instance of the library configuration + type(library_config_t), intent(out) :: self + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call check(table, error) + if (allocated(error)) return + + call get_value(table, "source-dir", self%source_dir, "src") + call get_value(table, "build-script", self%build_script) + + call get_value(table, "include-dir", self%include_dir, error) + if (allocated(error)) return + + ! Set default value of include-dir if not found in manifest + if (.not.allocated(self%include_dir)) then + self%include_dir = [string_t("include")] + end if + + end subroutine new_library + + + !> Check local schema for allowed entries + subroutine check(table, error) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_key), allocatable :: list(:) + integer :: ikey + + call table%get_keys(list) + + ! table can be empty + if (size(list) < 1) return + + do ikey = 1, size(list) + select case(list(ikey)%key) + case default + call syntax_error(error, "Key "//list(ikey)%key//" is not allowed in library") + exit + + case("source-dir", "include-dir", "build-script") + continue + + end select + end do + + end subroutine check + + + !> Write information on instance + subroutine info(self, unit, verbosity) + + !> Instance of the library configuration + class(library_config_t), intent(in) :: self + + !> Unit for IO + integer, intent(in) :: unit + + !> Verbosity of the printout + integer, intent(in), optional :: verbosity + + integer :: pr + character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)' + + if (present(verbosity)) then + pr = verbosity + else + pr = 1 + end if + + if (pr < 1) return + + write(unit, fmt) "Library target" + if (allocated(self%source_dir)) then + write(unit, fmt) "- source directory", self%source_dir + end if + if (allocated(self%include_dir)) then + write(unit, fmt) "- include directory", string_cat(self%include_dir,",") + end if + if (allocated(self%build_script)) then + write(unit, fmt) "- custom build", self%build_script + end if + + end subroutine info + + +end module fpm_manifest_library diff --git a/src/fpm/manifest/package.f90 b/src/fpm/manifest/package.f90 new file mode 100644 index 0000000..bbaa51d --- /dev/null +++ b/src/fpm/manifest/package.f90 @@ -0,0 +1,435 @@ +!> Define the package data containing the meta data from the configuration file. +!> +!> The package data defines a Fortran type corresponding to the respective +!> TOML document, after creating it from a package file no more interaction +!> with the TOML document is required. +!> +!> Every configuration type provides it custom constructor (prefixed with `new_`) +!> and knows how to deserialize itself from a TOML document. +!> To ensure we find no untracked content in the package file all keywords are +!> checked and possible entries have to be explicitly allowed in the `check` +!> function. +!> If entries are mutally exclusive or interdependent inside the current table +!> the `check` function is required to enforce this schema on the data structure. +!> +!> The package file root allows the following keywords +!> +!>```toml +!>name = "string" +!>version = "string" +!>license = "string" +!>author = "string" +!>maintainer = "string" +!>copyright = "string" +!>[library] +!>[dependencies] +!>[dev-dependencies] +!>[build] +!>[install] +!>[[ executable ]] +!>[[ example ]] +!>[[ test ]] +!>``` +module fpm_manifest_package + use fpm_manifest_build, only: build_config_t, new_build_config + use fpm_manifest_dependency, only : dependency_config_t, new_dependencies + use fpm_manifest_example, only : example_config_t, new_example + use fpm_manifest_executable, only : executable_config_t, new_executable + use fpm_manifest_library, only : library_config_t, new_library + use fpm_manifest_install, only: install_config_t, new_install_config + use fpm_manifest_test, only : test_config_t, new_test + use fpm_error, only : error_t, fatal_error, syntax_error + use fpm_toml, only : toml_table, toml_array, toml_key, toml_stat, get_value, & + & len + use fpm_versioning, only : version_t, new_version + implicit none + private + + public :: package_config_t, new_package + + + interface unique_programs + module procedure :: unique_programs1 + module procedure :: unique_programs2 + end interface unique_programs + + + !> Package meta data + type :: package_config_t + + !> Name of the package + character(len=:), allocatable :: name + + !> Package version + type(version_t) :: version + + !> Build configuration data + type(build_config_t) :: build + + !> Installation configuration data + type(install_config_t) :: install + + !> Library meta data + type(library_config_t), allocatable :: library + + !> Executable meta data + type(executable_config_t), allocatable :: executable(:) + + !> Dependency meta data + type(dependency_config_t), allocatable :: dependency(:) + + !> Development dependency meta data + type(dependency_config_t), allocatable :: dev_dependency(:) + + !> Example meta data + type(example_config_t), allocatable :: example(:) + + !> Test meta data + type(test_config_t), allocatable :: test(:) + + contains + + !> Print information on this instance + procedure :: info + + end type package_config_t + + +contains + + + !> Construct a new package configuration from a TOML data structure + subroutine new_package(self, table, error) + + !> Instance of the package configuration + type(package_config_t), intent(out) :: self + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + ! Backspace (8), tabulator (9), newline (10), formfeed (12) and carriage + ! return (13) are invalid in package names + character(len=*), parameter :: invalid_chars = & + achar(8) // achar(9) // achar(10) // achar(12) // achar(13) + type(toml_table), pointer :: child, node + type(toml_array), pointer :: children + character(len=:), allocatable :: version + integer :: ii, nn, stat + + call check(table, error) + if (allocated(error)) return + + call get_value(table, "name", self%name) + if (.not.allocated(self%name)) then + call syntax_error(error, "Could not retrieve package name") + return + end if + + if (len(self%name) <= 0) then + call syntax_error(error, "Package name must be a non-empty string") + return + end if + + ii = scan(self%name, invalid_chars) + if (ii > 0) then + call syntax_error(error, "Package name contains invalid characters") + return + end if + + call get_value(table, "build", child, requested=.true., stat=stat) + if (stat /= toml_stat%success) then + call fatal_error(error, "Type mismatch for build entry, must be a table") + return + end if + call new_build_config(self%build, child, error) + if (allocated(error)) return + + call get_value(table, "install", child, requested=.true., stat=stat) + if (stat /= toml_stat%success) then + call fatal_error(error, "Type mismatch for install entry, must be a table") + return + end if + call new_install_config(self%install, child, error) + if (allocated(error)) return + + call get_value(table, "version", version, "0") + call new_version(self%version, version, error) + if (allocated(error)) return + + call get_value(table, "dependencies", child, requested=.false.) + if (associated(child)) then + call new_dependencies(self%dependency, child, error) + if (allocated(error)) return + end if + + call get_value(table, "dev-dependencies", child, requested=.false.) + if (associated(child)) then + call new_dependencies(self%dev_dependency, child, error) + if (allocated(error)) return + end if + + call get_value(table, "library", child, requested=.false.) + if (associated(child)) then + allocate(self%library) + call new_library(self%library, child, error) + if (allocated(error)) return + end if + + call get_value(table, "executable", children, requested=.false.) + if (associated(children)) then + nn = len(children) + allocate(self%executable(nn)) + do ii = 1, nn + call get_value(children, ii, node, stat=stat) + if (stat /= toml_stat%success) then + call fatal_error(error, "Could not retrieve executable from array entry") + exit + end if + call new_executable(self%executable(ii), node, error) + if (allocated(error)) exit + end do + if (allocated(error)) return + + call unique_programs(self%executable, error) + if (allocated(error)) return + end if + + call get_value(table, "example", children, requested=.false.) + if (associated(children)) then + nn = len(children) + allocate(self%example(nn)) + do ii = 1, nn + call get_value(children, ii, node, stat=stat) + if (stat /= toml_stat%success) then + call fatal_error(error, "Could not retrieve example from array entry") + exit + end if + call new_example(self%example(ii), node, error) + if (allocated(error)) exit + end do + if (allocated(error)) return + + call unique_programs(self%example, error) + if (allocated(error)) return + + if (allocated(self%executable)) then + call unique_programs(self%executable, self%example, error) + if (allocated(error)) return + end if + end if + + call get_value(table, "test", children, requested=.false.) + if (associated(children)) then + nn = len(children) + allocate(self%test(nn)) + do ii = 1, nn + call get_value(children, ii, node, stat=stat) + if (stat /= toml_stat%success) then + call fatal_error(error, "Could not retrieve test from array entry") + exit + end if + call new_test(self%test(ii), node, error) + if (allocated(error)) exit + end do + if (allocated(error)) return + + call unique_programs(self%test, error) + if (allocated(error)) return + end if + + end subroutine new_package + + + !> Check local schema for allowed entries + subroutine check(table, error) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_key), allocatable :: list(:) + logical :: name_present + integer :: ikey + + name_present = .false. + + call table%get_keys(list) + + if (size(list) < 1) then + call syntax_error(error, "Package file is empty") + return + end if + + do ikey = 1, size(list) + select case(list(ikey)%key) + case default + call syntax_error(error, "Key "//list(ikey)%key//" is not allowed in package file") + exit + + case("name") + name_present = .true. + + case("version", "license", "author", "maintainer", "copyright", & + & "description", "keywords", "categories", "homepage", "build", & + & "dependencies", "dev-dependencies", "test", "executable", & + & "example", "library", "install") + continue + + end select + end do + if (allocated(error)) return + + if (.not.name_present) then + call syntax_error(error, "Package name is not provided, please add a name entry") + end if + + end subroutine check + + + !> Write information on instance + subroutine info(self, unit, verbosity) + + !> Instance of the package configuration + class(package_config_t), intent(in) :: self + + !> Unit for IO + integer, intent(in) :: unit + + !> Verbosity of the printout + integer, intent(in), optional :: verbosity + + integer :: pr, ii + character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)', & + & fmti = '("#", 1x, a, t30, i0)' + + if (present(verbosity)) then + pr = verbosity + else + pr = 1 + end if + + if (pr < 1) return + + write(unit, fmt) "Package" + if (allocated(self%name)) then + write(unit, fmt) "- name", self%name + end if + + call self%build%info(unit, pr - 1) + + call self%install%info(unit, pr - 1) + + if (allocated(self%library)) then + write(unit, fmt) "- target", "archive" + call self%library%info(unit, pr - 1) + end if + + if (allocated(self%executable)) then + if (size(self%executable) > 1 .or. pr > 2) then + write(unit, fmti) "- executables", size(self%executable) + end if + do ii = 1, size(self%executable) + call self%executable(ii)%info(unit, pr - 1) + end do + end if + + if (allocated(self%dependency)) then + if (size(self%dependency) > 1 .or. pr > 2) then + write(unit, fmti) "- dependencies", size(self%dependency) + end if + do ii = 1, size(self%dependency) + call self%dependency(ii)%info(unit, pr - 1) + end do + end if + + if (allocated(self%example)) then + if (size(self%example) > 1 .or. pr > 2) then + write(unit, fmti) "- examples", size(self%example) + end if + do ii = 1, size(self%example) + call self%example(ii)%info(unit, pr - 1) + end do + end if + + if (allocated(self%test)) then + if (size(self%test) > 1 .or. pr > 2) then + write(unit, fmti) "- tests", size(self%test) + end if + do ii = 1, size(self%test) + call self%test(ii)%info(unit, pr - 1) + end do + end if + + if (allocated(self%dev_dependency)) then + if (size(self%dev_dependency) > 1 .or. pr > 2) then + write(unit, fmti) "- development deps.", size(self%dev_dependency) + end if + do ii = 1, size(self%dev_dependency) + call self%dev_dependency(ii)%info(unit, pr - 1) + end do + end if + + end subroutine info + + + !> Check whether or not the names in a set of executables are unique + subroutine unique_programs1(executable, error) + + !> Array of executables + class(executable_config_t), intent(in) :: executable(:) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: i, j + + do i = 1, size(executable) + do j = 1, i - 1 + if (executable(i)%name == executable(j)%name) then + call fatal_error(error, "The program named '"//& + executable(j)%name//"' is duplicated. "//& + "Unique program names are required.") + exit + end if + end do + end do + if (allocated(error)) return + + end subroutine unique_programs1 + + + !> Check whether or not the names in a set of executables are unique + subroutine unique_programs2(executable_i, executable_j, error) + + !> Array of executables + class(executable_config_t), intent(in) :: executable_i(:) + + !> Array of executables + class(executable_config_t), intent(in) :: executable_j(:) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: i, j + + do i = 1, size(executable_i) + do j = 1, size(executable_j) + if (executable_i(i)%name == executable_j(j)%name) then + call fatal_error(error, "The program named '"//& + executable_j(j)%name//"' is duplicated. "//& + "Unique program names are required.") + exit + end if + end do + end do + if (allocated(error)) return + + end subroutine unique_programs2 + + +end module fpm_manifest_package diff --git a/src/fpm/manifest/test.f90 b/src/fpm/manifest/test.f90 new file mode 100644 index 0000000..bcacbd8 --- /dev/null +++ b/src/fpm/manifest/test.f90 @@ -0,0 +1,175 @@ +!> Implementation of the meta data for a test. +!> +!> The test data structure is effectively a decorated version of an executable +!> and shares most of its properties, except for the defaults and can be +!> handled under most circumstances just like any other executable. +!> +!> A test table can currently have the following fields +!> +!>```toml +!>[[ test ]] +!>name = "string" +!>source-dir = "path" +!>main = "file" +!>link = ["lib"] +!>[test.dependencies] +!>``` +module fpm_manifest_test + use fpm_manifest_dependency, only : dependency_config_t, new_dependencies + use fpm_manifest_executable, only : executable_config_t + use fpm_error, only : error_t, syntax_error + use fpm_toml, only : toml_table, toml_key, toml_stat, get_value + implicit none + private + + public :: test_config_t, new_test + + + !> Configuation meta data for an test + type, extends(executable_config_t) :: test_config_t + + contains + + !> Print information on this instance + procedure :: info + + end type test_config_t + + +contains + + + !> Construct a new test configuration from a TOML data structure + subroutine new_test(self, table, error) + + !> Instance of the test configuration + type(test_config_t), intent(out) :: self + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table), pointer :: child + + call check(table, error) + if (allocated(error)) return + + call get_value(table, "name", self%name) + if (.not.allocated(self%name)) then + call syntax_error(error, "Could not retrieve test name") + return + end if + call get_value(table, "source-dir", self%source_dir, "test") + call get_value(table, "main", self%main, "main.f90") + + call get_value(table, "dependencies", child, requested=.false.) + if (associated(child)) then + call new_dependencies(self%dependency, child, error) + if (allocated(error)) return + end if + + call get_value(table, "link", self%link, error) + if (allocated(error)) return + + end subroutine new_test + + + !> Check local schema for allowed entries + subroutine check(table, error) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_key), allocatable :: list(:) + logical :: name_present + integer :: ikey + + name_present = .false. + + call table%get_keys(list) + + if (size(list) < 1) then + call syntax_error(error, "Test section does not provide sufficient entries") + return + end if + + do ikey = 1, size(list) + select case(list(ikey)%key) + case default + call syntax_error(error, "Key "//list(ikey)%key//" is not allowed in test entry") + exit + + case("name") + name_present = .true. + + case("source-dir", "main", "dependencies", "link") + continue + + 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") + end if + + end subroutine check + + + !> Write information on instance + subroutine info(self, unit, verbosity) + + !> Instance of the test configuration + class(test_config_t), intent(in) :: self + + !> Unit for IO + integer, intent(in) :: unit + + !> Verbosity of the printout + integer, intent(in), optional :: verbosity + + integer :: pr, ii + character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)', & + & fmti = '("#", 1x, a, t30, i0)' + + if (present(verbosity)) then + pr = verbosity + else + pr = 1 + end if + + if (pr < 1) return + + write(unit, fmt) "Test target" + if (allocated(self%name)) then + write(unit, fmt) "- name", self%name + end if + if (allocated(self%source_dir)) then + if (self%source_dir /= "test" .or. pr > 2) then + write(unit, fmt) "- source directory", self%source_dir + end if + end if + if (allocated(self%main)) then + if (self%main /= "main.f90" .or. pr > 2) then + write(unit, fmt) "- test source", self%main + end if + end if + + if (allocated(self%dependency)) then + if (size(self%dependency) > 1 .or. pr > 2) then + write(unit, fmti) "- dependencies", size(self%dependency) + end if + do ii = 1, size(self%dependency) + call self%dependency(ii)%info(unit, pr - 1) + end do + end if + + end subroutine info + + +end module fpm_manifest_test diff --git a/src/fpm/toml.f90 b/src/fpm/toml.f90 new file mode 100644 index 0000000..dbaafcb --- /dev/null +++ b/src/fpm/toml.f90 @@ -0,0 +1,120 @@ +!># Interface to TOML processing library +!> +!> This module acts as a proxy to the `toml-f` public Fortran API and allows +!> to selectively expose components from the library to `fpm`. +!> The interaction with `toml-f` data types outside of this module should be +!> limited to tables, arrays and key-lists, most of the necessary interactions +!> are implemented in the building interface with the `get_value` and `set_value` +!> procedures. +!> +!> This module allows to implement features necessary for `fpm`, which are +!> not yet available in upstream `toml-f`. +!> +!> For more details on the library used see the +!> [TOML-Fortran](https://toml-f.github.io/toml-f) developer pages. +module fpm_toml + use fpm_error, only : error_t, fatal_error, file_not_found_error + use fpm_strings, only : string_t + use tomlf, only : toml_table, toml_array, toml_key, toml_stat, get_value, & + & set_value, toml_parse, toml_error, new_table, add_table, add_array, & + & toml_serializer, len + implicit none + private + + public :: read_package_file + public :: toml_table, toml_array, toml_key, toml_stat, get_value, set_value + public :: new_table, add_table, add_array, len + public :: toml_error, toml_serializer, toml_parse + + + interface get_value + module procedure :: get_child_value_string_list + end interface get_value + + +contains + + + !> Process the configuration file to a TOML data structure + subroutine read_package_file(table, manifest, error) + + !> TOML data structure + type(toml_table), allocatable, intent(out) :: table + + !> Name of the package configuration file + character(len=*), intent(in) :: manifest + + !> Error status of the operation + type(error_t), allocatable, intent(out) :: error + + type(toml_error), allocatable :: parse_error + integer :: unit + logical :: exist + + inquire(file=manifest, exist=exist) + + if (.not.exist) then + call file_not_found_error(error, manifest) + return + end if + + open(file=manifest, newunit=unit) + call toml_parse(table, unit, parse_error) + close(unit) + + if (allocated(parse_error)) then + allocate(error) + call move_alloc(parse_error%message, error%message) + return + end if + + end subroutine read_package_file + + + subroutine get_child_value_string_list(table, key, list, error) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Key to read from + character(len=*), intent(in) :: key + + !> List of strings to read + type(string_t), allocatable, intent(out) :: list(:) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: stat, ilist, nlist + type(toml_array), pointer :: children + character(len=:), allocatable :: str + + call get_value(table, key, children, requested=.false.) + if (associated(children)) then + nlist = len(children) + allocate(list(nlist)) + do ilist = 1, nlist + call get_value(children, ilist, str, stat=stat) + if (stat /= toml_stat%success) then + call fatal_error(error, "Entry in "//key//" field cannot be read") + exit + end if + call move_alloc(str, list(ilist)%s) + end do + if (allocated(error)) return + else + call get_value(table, key, str, stat=stat) + if (stat /= toml_stat%success) then + call fatal_error(error, "Entry in "//key//" field cannot be read") + return + end if + if (allocated(str)) then + allocate(list(1)) + call move_alloc(str, list(1)%s) + end if + end if + + end subroutine get_child_value_string_list + + +end module fpm_toml diff --git a/src/fpm/versioning.f90 b/src/fpm/versioning.f90 new file mode 100644 index 0000000..b24fc3c --- /dev/null +++ b/src/fpm/versioning.f90 @@ -0,0 +1,412 @@ +!> Implementation of versioning data for comparing packages +module fpm_versioning + use fpm_error, only : error_t, syntax_error + implicit none + private + + public :: version_t, new_version, char + + + type :: version_t + private + + !> Version numbers found + integer, allocatable :: num(:) + + contains + + generic :: operator(==) => equals + procedure, private :: equals + + generic :: operator(/=) => not_equals + procedure, private :: not_equals + + generic :: operator(>) => greater + procedure, private :: greater + + generic :: operator(<) => less + procedure, private :: less + + generic :: operator(>=) => greater_equals + procedure, private :: greater_equals + + generic :: operator(<=) => less_equals + procedure, private :: less_equals + + !> Compare a version against a version constraint (x.x.0 <= v < x.x.HUGE) + generic :: operator(.match.) => match + procedure, private :: match + + !> Create a printable string from a version data type + procedure :: to_string + + end type version_t + + + !> Arbitrary internal limit of the version parser + integer, parameter :: max_limit = 3 + + + interface char + module procedure :: as_string + end interface char + + + interface new_version + module procedure :: new_version_from_string + module procedure :: new_version_from_int + end interface new_version + + +contains + + + !> Create a new version from a string + subroutine new_version_from_int(self, num) + + !> Instance of the versioning data + type(version_t), intent(out) :: self + + !> Subversion numbers to define version data + integer, intent(in) :: num(:) + + self%num = num + + end subroutine new_version_from_int + + + !> Create a new version from a string + subroutine new_version_from_string(self, string, error) + + !> Instance of the versioning data + type(version_t), intent(out) :: self + + !> String describing the version information + character(len=*), intent(in) :: string + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + character :: tok + integer :: ii, istart, iend, stat, nn + integer :: num(max_limit) + logical :: is_number + + nn = 0 + iend = 0 + istart = 0 + is_number = .false. + + do while(iend < len(string)) + call next(string, istart, iend, is_number, error) + if (allocated(error)) exit + if (is_number) then + if (nn >= max_limit) then + call token_error(error, string, istart, iend, & + & "Too many subversions found") + exit + end if + nn = nn + 1 + read(string(istart:iend), *, iostat=stat) num(nn) + if (stat /= 0) then + call token_error(error, string, istart, iend, & + & "Failed to parse version number") + exit + end if + end if + end do + if (allocated(error)) return + if (.not.is_number) then + call token_error(error, string, istart, iend, & + & "Expected version number, but no characters are left") + return + end if + + call new_version(self, num(:nn)) + + end subroutine new_version_from_string + + + !> Tokenize a version string + subroutine next(string, istart, iend, is_number, error) + + !> String describing the version information + character(len=*), intent(in) :: string + + !> Start of last token, start of next token on exit + integer, intent(inout) :: istart + + !> End of last token on entry, end of next token on exit + integer, intent(inout) :: iend + + !> Token produced is a number + logical, intent(inout) :: is_number + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: ii, nn + logical :: was_number + character :: tok, last + + was_number = is_number + nn = len(string) + + if (iend >= nn) then + istart = nn + iend = nn + return + end if + + ii = min(iend + 1, nn) + tok = string(ii:ii) + + is_number = tok /= '.' + if (is_number .eqv. was_number) then + call token_error(error, string, istart, ii, & + & "Unexpected token found") + return + end if + + if (.not.is_number) then + is_number = .false. + istart = ii + iend = ii + return + end if + + istart = ii + do ii = min(iend + 1, nn), nn + tok = string(ii:ii) + select case(tok) + case default + call token_error(error, string, istart, ii, & + & "Invalid character in version number") + exit + case('.') + exit + case('0', '1', '2', '3', '4', '5', '6', '7', '8', '9') + iend = ii + cycle + end select + end do + + end subroutine next + + + !> Create an error on an invalid token, provide some visual context as well + subroutine token_error(error, string, istart, iend, message) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> String describing the version information + character(len=*), intent(in) :: string + + !> Start of last token, start of next token on exit + integer, intent(in) :: istart + + !> End of last token on entry, end of next token on exit + integer, intent(in) :: iend + + !> Error message + character(len=*), intent(in) :: message + + character(len=*), parameter :: nl = new_line('a') + + allocate(error) + error%message = message // nl // " | " // string // nl // & + & " |" // repeat('-', istart) // repeat('^', iend - istart + 1) + + end subroutine token_error + + + subroutine to_string(self, string) + + !> Version number + class(version_t), intent(in) :: self + + !> Character representation of the version + character(len=:), allocatable, intent(out) :: string + + integer, parameter :: buffersize = 64 + character(len=buffersize) :: buffer + integer :: ii + + do ii = 1, size(self%num) + if (allocated(string)) then + write(buffer, '(".", i0)') self%num(ii) + string = string // trim(buffer) + else + write(buffer, '(i0)') self%num(ii) + string = trim(buffer) + end if + end do + + if (.not.allocated(string)) then + string = '0' + end if + + end subroutine to_string + + + function as_string(self) result(string) + + !> Version number + class(version_t), intent(in) :: self + + !> Character representation of the version + character(len=:), allocatable :: string + + call self%to_string(string) + + end function as_string + + + !> Check to version numbers for equality + elemental function equals(lhs, rhs) result(is_equal) + + !> First version number + class(version_t), intent(in) :: lhs + + !> Second version number + class(version_t), intent(in) :: rhs + + !> Version match + logical :: is_equal + + is_equal = .not.(lhs > rhs) + if (is_equal) then + is_equal = .not.(rhs > lhs) + end if + + end function equals + + + !> Check two versions for inequality + elemental function not_equals(lhs, rhs) result(not_equal) + + !> First version number + class(version_t), intent(in) :: lhs + + !> Second version number + class(version_t), intent(in) :: rhs + + !> Version mismatch + logical :: not_equal + + not_equal = lhs > rhs + if (.not.not_equal) then + not_equal = rhs > lhs + end if + + end function not_equals + + + !> Relative comparison of two versions + elemental function greater(lhs, rhs) result(is_greater) + + !> First version number + class(version_t), intent(in) :: lhs + + !> Second version number + class(version_t), intent(in) :: rhs + + !> First version is greater + logical :: is_greater + + integer :: ii + + do ii = 1, min(size(lhs%num), size(rhs%num)) + is_greater = lhs%num(ii) > rhs%num(ii) + if (is_greater) exit + end do + if (is_greater) return + + is_greater = size(lhs%num) > size(rhs%num) + if (is_greater) then + do ii = size(rhs%num) + 1, size(lhs%num) + is_greater = lhs%num(ii) > 0 + if (is_greater) exit + end do + end if + + end function greater + + + !> Relative comparison of two versions + elemental function less(lhs, rhs) result(is_less) + + !> First version number + class(version_t), intent(in) :: lhs + + !> Second version number + class(version_t), intent(in) :: rhs + + !> First version is less + logical :: is_less + + is_less = rhs > lhs + + end function less + + + !> Relative comparison of two versions + elemental function greater_equals(lhs, rhs) result(is_greater_equal) + + !> First version number + class(version_t), intent(in) :: lhs + + !> Second version number + class(version_t), intent(in) :: rhs + + !> First version is greater or equal + logical :: is_greater_equal + + is_greater_equal = .not. (rhs > lhs) + + end function greater_equals + + + !> Relative comparison of two versions + elemental function less_equals(lhs, rhs) result(is_less_equal) + + !> First version number + class(version_t), intent(in) :: lhs + + !> Second version number + class(version_t), intent(in) :: rhs + + !> First version is less or equal + logical :: is_less_equal + + is_less_equal = .not. (lhs > rhs) + + end function less_equals + + + !> Try to match first version against second version + elemental function match(lhs, rhs) + + !> First version number + class(version_t), intent(in) :: lhs + + !> Second version number + class(version_t), intent(in) :: rhs + + !> Version match following semantic versioning rules + logical :: match + + type(version_t) :: tmp + + match = .not.(rhs > lhs) + if (match) then + tmp%num = rhs%num + tmp%num(size(tmp%num)) = tmp%num(size(tmp%num)) + 1 + match = tmp > lhs + end if + + end function match + + +end module fpm_versioning diff --git a/src/fpm_backend.f90 b/src/fpm_backend.f90 new file mode 100644 index 0000000..74cef61 --- /dev/null +++ b/src/fpm_backend.f90 @@ -0,0 +1,262 @@ +!># Build backend +!> Uses a list of `[[build_target_ptr]]` and a valid `[[fpm_model]]` instance +!> to schedule and execute the compilation and linking of package targets. +!> +!> The package build process (`[[build_package]]`) comprises three steps: +!> +!> 1. __Target sorting:__ topological sort of the target dependency graph (`[[sort_target]]`) +!> 2. __Target scheduling:__ group targets into schedule regions based on the sorting (`[[schedule_targets]]`) +!> 3. __Target building:__ generate targets by compilation or linking +!> +!> @note If compiled with OpenMP, targets will be build in parallel where possible. +!> +!>### Incremental compilation +!> The backend process supports *incremental* compilation whereby targets are not +!> re-compiled if their corresponding dependencies have not been modified. +!> +!> - Source-based targets (*i.e.* objects) are not re-compiled if the corresponding source +!> file is unmodified AND all of the target dependencies are not marked for re-compilation +!> +!> - Link targets (*i.e.* executables and libraries) are not re-compiled if the +!> target output file already exists AND all of the target dependencies are not marked for +!> re-compilation +!> +!> Source file modification is determined by a file digest (hash) which is calculated during +!> the source parsing phase ([[fpm_source_parsing]]) and cached to disk after a target is +!> successfully generated. +!> +module fpm_backend + +use fpm_environment, only: run +use fpm_filesystem, only: dirname, join_path, exists, mkdir +use fpm_model, only: fpm_model_t +use fpm_targets, only: build_target_t, build_target_ptr, & + FPM_TARGET_OBJECT, FPM_TARGET_ARCHIVE, FPM_TARGET_EXECUTABLE + +use fpm_strings, only: string_cat + +implicit none + +private +public :: build_package, sort_target, schedule_targets + +contains + +!> Top-level routine to build package described by `model` +subroutine build_package(targets,model) + type(build_target_ptr), intent(inout) :: targets(:) + type(fpm_model_t), intent(in) :: model + + integer :: i, j + type(build_target_ptr), allocatable :: queue(:) + integer, allocatable :: schedule_ptr(:) + + ! Need to make output directory for include (mod) files + if (.not.exists(join_path(model%output_directory,model%package_name))) then + call mkdir(join_path(model%output_directory,model%package_name)) + end if + + ! Perform depth-first topological sort of targets + do i=1,size(targets) + + call sort_target(targets(i)%ptr) + + end do + + ! Construct build schedule queue + call schedule_targets(queue, schedule_ptr, targets) + + ! Loop over parallel schedule regions + do i=1,size(schedule_ptr)-1 + + ! Build targets in schedule region i + !$omp parallel do default(shared) schedule(dynamic,1) + do j=schedule_ptr(i),(schedule_ptr(i+1)-1) + + call build_target(model,queue(j)%ptr) + + end do + + end do + +end subroutine build_package + + +!> Topologically sort a target for scheduling by +!> recursing over its dependencies. +!> +!> Checks disk-cached source hashes to determine if objects are +!> up-to-date. Up-to-date sources are tagged as skipped. +!> +!> On completion, `target` should either be marked as +!> sorted (`target%sorted=.true.`) or skipped (`target%skip=.true.`) +!> +!> If `target` is marked as sorted, `target%schedule` should be an +!> integer greater than zero indicating the region for scheduling +!> +recursive subroutine sort_target(target) + type(build_target_t), intent(inout), target :: target + + integer :: i, j, fh, stat + type(build_target_t), pointer :: exe_obj + + ! Check if target has already been processed (as a dependency) + if (target%sorted .or. target%skip) then + return + end if + + ! Check for a circular dependency + ! (If target has been touched but not processed) + if (target%touched) then + write(*,*) '(!) Circular dependency found with: ',target%output_file + stop + else + target%touched = .true. ! Set touched flag + end if + + ! Load cached source file digest if present + if (.not.allocated(target%digest_cached) .and. & + exists(target%output_file) .and. & + exists(target%output_file//'.digest')) then + + allocate(target%digest_cached) + open(newunit=fh,file=target%output_file//'.digest',status='old') + read(fh,*,iostat=stat) target%digest_cached + close(fh) + + if (stat /= 0) then ! Cached digest is not recognized + deallocate(target%digest_cached) + end if + + end if + + if (allocated(target%source)) then + + ! Skip if target is source-based and source file is unmodified + if (allocated(target%digest_cached)) then + if (target%digest_cached == target%source%digest) target%skip = .true. + end if + + elseif (exists(target%output_file)) then + + ! Skip if target is not source-based and already exists + target%skip = .true. + + end if + + ! Loop over target dependencies + target%schedule = 1 + do i=1,size(target%dependencies) + + ! Sort dependency + call sort_target(target%dependencies(i)%ptr) + + if (.not.target%dependencies(i)%ptr%skip) then + + ! Can't skip target if any dependency is not skipped + target%skip = .false. + + ! Set target schedule after all of its dependencies + target%schedule = max(target%schedule,target%dependencies(i)%ptr%schedule+1) + + end if + + end do + + ! Mark flag as processed: either sorted or skipped + target%sorted = .not.target%skip + +end subroutine sort_target + + +!> Construct a build schedule from the sorted targets. +!> +!> The schedule is broken into regions, described by `schedule_ptr`, +!> where targets in each region can be compiled in parallel. +!> +subroutine schedule_targets(queue, schedule_ptr, targets) + type(build_target_ptr), allocatable, intent(out) :: queue(:) + integer, allocatable :: schedule_ptr(:) + type(build_target_ptr), intent(in) :: targets(:) + + integer :: i, j + integer :: n_schedule, n_sorted + + n_schedule = 0 ! Number of schedule regions + n_sorted = 0 ! Total number of targets to build + do i=1,size(targets) + + if (targets(i)%ptr%sorted) then + n_sorted = n_sorted + 1 + end if + n_schedule = max(n_schedule, targets(i)%ptr%schedule) + + end do + + allocate(queue(n_sorted)) + allocate(schedule_ptr(n_schedule+1)) + + ! Construct the target queue and schedule region pointer + n_sorted = 1 + schedule_ptr(n_sorted) = 1 + do i=1,n_schedule + + do j=1,size(targets) + + if (targets(j)%ptr%sorted) then + if (targets(j)%ptr%schedule == i) then + + queue(n_sorted)%ptr => targets(j)%ptr + n_sorted = n_sorted + 1 + end if + end if + + end do + + schedule_ptr(i+1) = n_sorted + + end do + +end subroutine schedule_targets + + +!> Call compile/link command for a single target. +!> +!> If successful, also caches the source file digest to disk. +!> +subroutine build_target(model,target) + type(fpm_model_t), intent(in) :: model + type(build_target_t), intent(in), target :: target + + integer :: ilib, fh + character(:), allocatable :: link_flags + + if (.not.exists(dirname(target%output_file))) then + call mkdir(dirname(target%output_file)) + end if + + select case(target%target_type) + + case (FPM_TARGET_OBJECT) + call run(model%fortran_compiler//" -c " // target%source%file_name // target%compile_flags & + // " -o " // target%output_file) + + case (FPM_TARGET_EXECUTABLE) + + call run(model%fortran_compiler// " " // target%compile_flags & + //" "//target%link_flags// " -o " // target%output_file) + + case (FPM_TARGET_ARCHIVE) + call run("ar -rs " // target%output_file // " " // string_cat(target%link_objects," ")) + + end select + + if (allocated(target%source)) then + open(newunit=fh,file=target%output_file//'.digest',status='unknown') + write(fh,*) target%source%digest + close(fh) + end if + +end subroutine build_target + +end module fpm_backend diff --git a/src/fpm_command_line.f90 b/src/fpm_command_line.f90 new file mode 100644 index 0000000..9e9a572 --- /dev/null +++ b/src/fpm_command_line.f90 @@ -0,0 +1,1140 @@ +!># Definition of the command line interface +!> +!> This module uses [M_CLI2](https://github.com/urbanjost/M_CLI2) to define +!> the command line interface. +!> To define a command line interface create a new command settings type +!> from the [[fpm_cmd_settings]] base class or the respective parent command +!> settings. +!> +!> The subcommand is selected by the first non-option argument in the command +!> line. In the subcase block the actual command line is defined and transferred +!> to an instance of the [[fpm_cmd_settings]], the actual type is used by the +!> *fpm* main program to determine which command entry point is chosen. +!> +!> To add a new subcommand add a new case to select construct and specify the +!> wanted command line and the expected default values. +!> Some of the following points also apply if you add a new option or argument +!> to an existing *fpm* subcommand. +!> At this point you should create a help page for the new command in a simple +!> catman-like format as well in the ``set_help`` procedure. +!> Make sure to register new subcommands in the ``fpm-manual`` command by adding +!> them to the manual character array and in the help/manual case as well. +!> You should add the new command to the synopsis section of the ``fpm-list``, +!> ``fpm-help`` and ``fpm --list`` help pages below to make sure the help output +!> is complete and consistent as well. +module fpm_command_line +use fpm_environment, only : get_os_type, get_env, & + OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_WINDOWS, & + OS_CYGWIN, OS_SOLARIS, OS_FREEBSD +use M_CLI2, only : set_args, lget, sget, unnamed, remaining, specified +use fpm_strings, only : lower, split, fnv_1a +use fpm_filesystem, only : basename, canon_path, to_fortran_name +use fpm_compiler, only : get_default_compile_flags +use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, & + & stdout=>output_unit, & + & stderr=>error_unit +implicit none + +private +public :: fpm_cmd_settings, & + fpm_build_settings, & + fpm_install_settings, & + fpm_new_settings, & + fpm_run_settings, & + fpm_test_settings, & + fpm_update_settings, & + get_command_line_settings + +type, abstract :: fpm_cmd_settings + logical :: verbose=.true. +end type + +integer,parameter :: ibug=4096 +type, extends(fpm_cmd_settings) :: fpm_new_settings + character(len=:),allocatable :: name + logical :: with_executable=.false. + logical :: with_test=.false. + logical :: with_lib=.true. + logical :: with_example=.false. + logical :: with_full=.false. + logical :: with_bare=.false. + logical :: backfill=.true. +end type + +type, extends(fpm_cmd_settings) :: fpm_build_settings + logical :: list=.false. + logical :: show_model=.false. + character(len=:),allocatable :: compiler + character(len=:),allocatable :: profile + character(len=:),allocatable :: build_name + character(len=:),allocatable :: flag +end type + +type, extends(fpm_build_settings) :: fpm_run_settings + character(len=ibug),allocatable :: name(:) + character(len=:),allocatable :: args + character(len=:),allocatable :: runner + logical :: example +end type + +type, extends(fpm_run_settings) :: fpm_test_settings +end type + +type, extends(fpm_build_settings) :: fpm_install_settings + character(len=:), allocatable :: prefix + character(len=:), allocatable :: bindir + character(len=:), allocatable :: libdir + character(len=:), allocatable :: includedir + logical :: no_rebuild +end type + +!> Settings for interacting and updating with project dependencies +type, extends(fpm_cmd_settings) :: fpm_update_settings + character(len=ibug),allocatable :: name(:) + logical :: fetch_only + logical :: clean +end type + +character(len=:),allocatable :: name +character(len=:),allocatable :: os_type +character(len=ibug),allocatable :: names(:) +character(len=:),allocatable :: tnames(:) + +character(len=:), allocatable :: version_text(:) +character(len=:), allocatable :: help_new(:), help_fpm(:), help_run(:), & + & help_test(:), help_build(:), help_usage(:), help_runner(:), & + & help_text(:), help_install(:), help_help(:), help_update(:), & + & help_list(:), help_list_dash(:), help_list_nodash(:) +character(len=20),parameter :: manual(*)=[ character(len=20) ::& +& ' ', 'fpm', 'new', 'build', 'run', & +& 'test', 'runner', 'install', 'update', 'list', 'help', 'version' ] + +character(len=:), allocatable :: val_runner, val_build, val_compiler, val_flag, val_profile + +contains + subroutine get_command_line_settings(cmd_settings) + class(fpm_cmd_settings), allocatable, intent(out) :: cmd_settings + + character(len=4096) :: cmdarg + integer :: i + integer :: widest + type(fpm_install_settings), allocatable :: install_settings + + call set_help() + ! text for --version switch, + select case (get_os_type()) + case (OS_LINUX); os_type = "OS Type: Linux" + case (OS_MACOS); os_type = "OS Type: macOS" + case (OS_WINDOWS); os_type = "OS Type: Windows" + case (OS_CYGWIN); os_type = "OS Type: Cygwin" + case (OS_SOLARIS); os_type = "OS Type: Solaris" + case (OS_FREEBSD); os_type = "OS Type: FreeBSD" + case (OS_UNKNOWN); os_type = "OS Type: Unknown" + case default ; os_type = "OS Type: UNKNOWN" + end select + version_text = [character(len=80) :: & + & 'Version: 0.2.0, alpha', & + & 'Program: fpm(1)', & + & 'Description: A Fortran package manager and build system', & + & 'Home Page: https://github.com/fortran-lang/fpm', & + & 'License: MIT', & + & os_type] + ! find the subcommand name by looking for first word on command + ! not starting with dash + cmdarg=' ' + do i = 1, command_argument_count() + call get_command_argument(i, cmdarg) + if(adjustl(cmdarg(1:1)) .ne. '-')exit + enddo + + ! now set subcommand-specific help text and process commandline + ! arguments. Then call subcommand routine + select case(trim(cmdarg)) + + case('run') + call set_args('& + & --target " " & + & --list F & + & --all F & + & --profile " "& + & --example F& + & --runner " " & + & --compiler "'//get_env('FPM_COMPILER','gfortran')//'" & + & --flag:: " "& + & --verbose F& + & --',help_run,version_text) + + call check_build_vals() + + if( size(unnamed) .gt. 1 )then + names=unnamed(2:) + else + names=[character(len=len(names)) :: ] + endif + + + if(specified('target') )then + call split(sget('target'),tnames,delimiters=' ,:') + names=[character(len=max(len(names),len(tnames))) :: names,tnames] + endif + + ! convert --all to '*' + if(lget('all'))then + names=[character(len=max(len(names),1)) :: names,'*' ] + endif + + ! convert special string '..' to equivalent (shorter) '*' + ! to allow for a string that does not require shift-key and quoting + do i=1,size(names) + if(names(i).eq.'..')names(i)='*' + enddo + + allocate(fpm_run_settings :: cmd_settings) + val_runner=sget('runner') + if(specified('runner') .and. val_runner.eq.'')val_runner='echo' + cmd_settings=fpm_run_settings(& + & args=remaining,& + & build_name=val_build,& + & profile=val_profile,& + & compiler=val_compiler, & + & flag=val_flag, & + & example=lget('example'), & + & list=lget('list'),& + & name=names,& + & runner=val_runner,& + & verbose=lget('verbose') ) + + case('build') + call set_args( '& + & --profile " " & + & --list F & + & --show-model F & + & --compiler "'//get_env('FPM_COMPILER','gfortran')//'" & + & --flag:: " "& + & --verbose F& + & --',help_build,version_text) + + call check_build_vals() + + allocate( fpm_build_settings :: cmd_settings ) + cmd_settings=fpm_build_settings( & + & build_name=val_build,& + & profile=val_profile,& + & compiler=val_compiler, & + & flag=val_flag, & + & list=lget('list'),& + & show_model=lget('show-model'),& + & verbose=lget('verbose') ) + + case('new') + call set_args('& + & --src F & + & --lib F & + & --app F & + & --test F & + & --example F & + & --backfill F & + & --full F & + & --bare F & + & --verbose:V F',& + & help_new, version_text) + select case(size(unnamed)) + case(1) + write(stderr,'(*(g0,/))')' directory name required' + write(stderr,'(*(7x,g0,/))') & + & ' fpm new NAME [[--lib|--src] [--app] [--test] [--example]]|[--full|--bare] [--backfill]' + stop 1 + case(2) + name=trim(unnamed(2)) + case default + write(stderr,'(g0)')' only one directory name allowed' + write(stderr,'(7x,g0)') & + & ' fpm new NAME [[--lib|--src] [--app] [--test] [--example]]| [--full|--bare] [--backfill]' + stop 2 + end select + !*! canon_path is not converting ".", etc. + name=canon_path(name) + if( .not.is_fortran_name(to_fortran_name(basename(name))) )then + write(stderr,'(g0)') [ character(len=72) :: & + & ' the fpm project name must be made of up to 63 ASCII letters,', & + & ' numbers, underscores, or hyphens, and start with a letter.'] + stop 4 + endif + + allocate(fpm_new_settings :: cmd_settings) + if (any( specified([character(len=10) :: 'src','lib','app','test','example','bare'])) & + & .and.lget('full') )then + write(stderr,'(*(a))')& + &' --full and any of [--src|--lib,--app,--test,--example,--bare]', & + &' are mutually exclusive.' + stop 5 + elseif (any( specified([character(len=10) :: 'src','lib','app','test','example','full'])) & + & .and.lget('bare') )then + write(stderr,'(*(a))')& + &' --bare and any of [--src|--lib,--app,--test,--example,--full]', & + &' are mutually exclusive.' + stop 3 + elseif (any( specified([character(len=10) :: 'src','lib','app','test','example']) ) )then + cmd_settings=fpm_new_settings(& + & backfill=lget('backfill'), & + & name=name, & + & with_executable=lget('app'), & + & with_lib=any([lget('lib'),lget('src')]), & + & with_test=lget('test'), & + & with_example=lget('example'), & + & verbose=lget('verbose') ) + else ! default if no specific directories are requested + cmd_settings=fpm_new_settings(& + & backfill=lget('backfill') , & + & name=name, & + & with_executable=.true., & + & with_lib=.true., & + & with_test=.true., & + & with_example=lget('full'), & + & with_full=lget('full'), & + & with_bare=lget('bare'), & + & verbose=lget('verbose') ) + endif + + case('help','manual') + call set_args('& + & --verbose F & + & ',help_help,version_text) + if(size(unnamed).lt.2)then + if(unnamed(1).eq.'help')then + unnamed=[' ', 'fpm'] + else + unnamed=manual + endif + elseif(unnamed(2).eq.'manual')then + unnamed=manual + endif + widest=256 + allocate(character(len=widest) :: help_text(0)) + do i=2,size(unnamed) + select case(unnamed(i)) + case(' ' ) + case('fpm ' ) + help_text=[character(len=widest) :: help_text, help_fpm] + case('new ' ) + help_text=[character(len=widest) :: help_text, help_new] + case('build ' ) + help_text=[character(len=widest) :: help_text, help_build] + case('install' ) + help_text=[character(len=widest) :: help_text, help_install] + case('run ' ) + help_text=[character(len=widest) :: help_text, help_run] + case('test ' ) + help_text=[character(len=widest) :: help_text, help_test] + case('runner' ) + help_text=[character(len=widest) :: help_text, help_runner] + case('list ' ) + help_text=[character(len=widest) :: help_text, help_list] + case('update ' ) + help_text=[character(len=widest) :: help_text, help_update] + case('help ' ) + help_text=[character(len=widest) :: help_text, help_help] + case('version' ) + help_text=[character(len=widest) :: help_text, version_text] + case default + help_text=[character(len=widest) :: help_text, & + & ' unknown help topic "'//trim(unnamed(i))//'"'] + !!& ' unknown help topic "'//trim(unnamed(i)).'not found in:',manual] + end select + enddo + call printhelp(help_text) + + case('install') + call set_args('--profile " " --no-rebuild F --verbose F --prefix " " & + & --list F & + & --compiler "'//get_env('FPM_COMPILER','gfortran')//'" & + & --flag:: " "& + & --libdir "lib" --bindir "bin" --includedir "include"', & + help_install, version_text) + + call check_build_vals() + + allocate(install_settings) + install_settings = fpm_install_settings(& + list=lget('list'), & + build_name=val_build, & + profile=val_profile,& + compiler=val_compiler, & + flag=val_flag, & + no_rebuild=lget('no-rebuild'), & + verbose=lget('verbose')) + call get_char_arg(install_settings%prefix, 'prefix') + call get_char_arg(install_settings%libdir, 'libdir') + call get_char_arg(install_settings%bindir, 'bindir') + call get_char_arg(install_settings%includedir, 'includedir') + call move_alloc(install_settings, cmd_settings) + + case('list') + call set_args('& + & --list F& + & --verbose F& + &', help_list, version_text) + call printhelp(help_list_nodash) + if(lget('list'))then + call printhelp(help_list_dash) + endif + case('test') + call set_args('& + & --target " " & + & --list F& + & --profile " "& + & --runner " " & + & --compiler "'//get_env('FPM_COMPILER','gfortran')//'" & + & --flag:: " "& + & --verbose F& + & --',help_test,version_text) + + call check_build_vals() + + if( size(unnamed) .gt. 1 )then + names=unnamed(2:) + else + names=[character(len=len(names)) :: ] + endif + + if(specified('target') )then + call split(sget('target'),tnames,delimiters=' ,:') + names=[character(len=max(len(names),len(tnames))) :: names,tnames] + endif + + ! convert special string '..' to equivalent (shorter) '*' + ! to allow for a string that does not require shift-key and quoting + do i=1,size(names) + if(names(i).eq.'..')names(i)='*' + enddo + + allocate(fpm_test_settings :: cmd_settings) + val_runner=sget('runner') + if(specified('runner') .and. val_runner.eq.'')val_runner='echo' + cmd_settings=fpm_test_settings(& + & args=remaining, & + & build_name=val_build, & + & profile=val_profile, & + & compiler=val_compiler, & + & flag=val_flag, & + & example=.false., & + & list=lget('list'), & + & name=names, & + & runner=val_runner, & + & verbose=lget('verbose') ) + + case('update') + call set_args('--fetch-only F --verbose F --clean F', & + help_update, version_text) + + if( size(unnamed) .gt. 1 )then + names=unnamed(2:) + else + names=[character(len=len(names)) :: ] + endif + + allocate(fpm_update_settings :: cmd_settings) + cmd_settings=fpm_update_settings(name=names, & + fetch_only=lget('fetch-only'), verbose=lget('verbose'), & + clean=lget('clean')) + + case default + + call set_args('& + & --list F& + & --verbose F& + &', help_fpm, version_text) + ! Note: will not get here if --version or --usage or --help + ! is present on commandline + help_text=help_usage + if(lget('list'))then + help_text=help_list_dash + elseif(len_trim(cmdarg).eq.0)then + write(stdout,'(*(a))')'Fortran Package Manager:' + write(stdout,'(*(a))')' ' + call printhelp(help_list_nodash) + else + write(stderr,'(*(a))')' unknown subcommand [', & + & trim(cmdarg), ']' + call printhelp(help_list_dash) + endif + call printhelp(help_text) + + end select + contains + + subroutine check_build_vals() + character(len=:), allocatable :: flags + + val_compiler=sget('compiler') + if(val_compiler.eq.'') then + val_compiler='gfortran' + endif + + val_flag = " " // sget('flag') + val_profile = sget('profile') + if (val_flag == '') then + call get_default_compile_flags(val_compiler, val_profile == "release", val_flag) + else + select case(val_profile) + case("release", "debug") + call get_default_compile_flags(val_compiler, val_profile == "release", flags) + val_flag = flags // val_flag + end select + end if + allocate(character(len=16) :: val_build) + write(val_build, '(z16.16)') fnv_1a(val_flag) + + end subroutine check_build_vals + + subroutine printhelp(lines) + character(len=:),intent(in),allocatable :: lines(:) + integer :: iii,ii + if(allocated(lines))then + ii=size(lines) + if(ii .gt. 0 .and. len(lines).gt. 0) then + write(stdout,'(g0)')(trim(lines(iii)), iii=1, ii) + else + write(stdout,'(a)')' *printhelp* output requested is empty' + endif + endif + end subroutine printhelp + + end subroutine get_command_line_settings + + function is_fortran_name(line) result (lout) + ! determine if a string is a valid Fortran name ignoring trailing spaces + ! (but not leading spaces) + character(len=*),parameter :: int='0123456789' + character(len=*),parameter :: lower='abcdefghijklmnopqrstuvwxyz' + character(len=*),parameter :: upper='ABCDEFGHIJKLMNOPQRSTUVWXYZ' + character(len=*),parameter :: allowed=upper//lower//int//'_' + character(len=*),intent(in) :: line + character(len=:),allocatable :: name + logical :: lout + name=trim(line) + if(len(name).ne.0)then + lout = .true. & + & .and. verify(name(1:1), lower//upper) == 0 & + & .and. verify(name,allowed) == 0 & + & .and. len(name) <= 63 + else + lout = .false. + endif + end function is_fortran_name + + subroutine set_help() + help_list_nodash=[character(len=80) :: & + 'USAGE: fpm [ SUBCOMMAND [SUBCOMMAND_OPTIONS] ]|[--list|--help|--version]', & + ' where SUBCOMMAND is commonly new|build|run|test ', & + ' ', & + ' subcommand may be one of ', & + ' ', & + ' build Compile the package placing results in the "build" directory', & + ' help Display help ', & + ' list Display this list of subcommand descriptions ', & + ' new Create a new Fortran package directory with sample files ', & + ' run Run the local package application programs ', & + ' test Run the test programs ', & + ' update Update and manage project dependencies ', & + ' install Install project ', & + ' ', & + ' Enter "fpm --list" for a brief list of subcommand options. Enter ', & + ' "fpm --help" or "fpm SUBCOMMAND --help" for detailed descriptions. ', & + ' '] + help_list_dash = [character(len=80) :: & + ' ', & + ' build [--compiler COMPILER_NAME] [--profile PROF] [--flag FFLAGS] [--list] ', & + ' help [NAME(s)] ', & + ' new NAME [[--lib|--src] [--app] [--test] [--example]]| ', & + ' [--full|--bare][--backfill] ', & + ' update [NAME(s)] [--fetch-only] [--clean] [--verbose] ', & + ' list [--list] ', & + ' run [[--target] NAME(s) [--example] [--profile PROF] [--flag FFLAGS] [--all] ', & + ' [--runner "CMD"] [--compiler COMPILER_NAME] [--list] [-- ARGS] ', & + ' test [[--target] NAME(s)] [--profile PROF] [--flag FFLAGS] [--runner "CMD"] [--list]', & + ' [--compiler COMPILER_NAME] [-- ARGS] ', & + ' install [--profile PROF] [--flag FFLAGS] [--no-rebuild] [--prefix PATH] [options] ', & + ' '] + help_usage=[character(len=80) :: & + '' ] + help_runner=[character(len=80) :: & + 'NAME ', & + ' --runner(1) - a shared option for specifying an application to launch ', & + ' executables. ', & + ' ', & + 'SYNOPSIS ', & + ' fpm run|test --runner CMD ... -- SUFFIX_OPTIONS ', & + ' ', & + 'DESCRIPTION ', & + ' The --runner option allows specifying a program to launch ', & + ' executables selected via the fpm(1) subcommands "run" and "test". This ', & + ' gives easy recourse to utilities such as debuggers and other tools ', & + ' that wrap other executables. ', & + ' ', & + ' These external commands are not part of fpm(1) itself as they vary ', & + ' from platform to platform or require independent installation. ', & + ' ', & + 'OPTION ', & + ' --runner ''CMD'' quoted command used to launch the fpm(1) executables. ', & + ' Available for both the "run" and "test" subcommands. ', & + ' If the keyword is specified without a value the default command ', & + ' is "echo". ', & + ' -- SUFFIX_OPTIONS additional options to suffix the command CMD and executable ', & + ' file names with. ', & + 'EXAMPLES ', & + ' Use cases for ''fpm run|test --runner "CMD"'' include employing ', & + ' the following common GNU/Linux and Unix commands: ', & + ' ', & + ' INTERROGATE ', & + ' + nm - list symbols from object files ', & + ' + size - list section sizes and total size. ', & + ' + ldd - print shared object dependencies ', & + ' + ls - list directory contents ', & + ' + stat - display file or file system status ', & + ' + file - determine file type ', & + ' PERFORMANCE AND DEBUGGING ', & + ' + gdb - The GNU Debugger ', & + ' + valgrind - a suite of tools for debugging and profiling ', & + ' + time - time a simple command or give resource usage ', & + ' + timeout - run a command with a time limit ', & + ' COPY ', & + ' + install - copy files and set attributes ', & + ' + tar - an archiving utility ', & + ' ALTER ', & + ' + rm - remove files or directories ', & + ' + chmod - change permissions of a file ', & + ' + strip - remove unnecessary information from strippable files ', & + ' ', & + ' For example ', & + ' ', & + ' fpm test --runner gdb ', & + ' fpm run --runner "tar cvfz $HOME/bundle.tgz" ', & + ' fpm run --runner ldd ', & + ' fpm run --runner strip ', & + ' fpm run --runner ''cp -t /usr/local/bin'' ', & + ' ', & + ' # options after executable name can be specified after the -- option ', & + ' fpm --runner cp run -- /usr/local/bin/ ', & + ' # generates commands of the form "cp $FILENAME /usr/local/bin/" ', & + ' ', & + ' # bash(1) alias example: ', & + ' alias fpm-install=\ ', & + ' "fpm run --profile release --runner ''install -vbp -m 0711 -t ~/.local/bin''" ', & + ' fpm-install ', & + '' ] + help_fpm=[character(len=80) :: & + 'NAME ', & + ' fpm(1) - A Fortran package manager and build system ', & + ' ', & + 'SYNOPSIS ', & + ' fpm SUBCOMMAND [SUBCOMMAND_OPTIONS] ', & + ' ', & + ' fpm --help|--version|--list ', & + ' ', & + 'DESCRIPTION ', & + ' fpm(1) is a package manager that helps you create Fortran projects ', & + ' from source -- it automatically determines dependencies! ', & + ' ', & + ' Most significantly fpm(1) lets you draw upon other fpm(1) packages ', & + ' in distributed git(1) repositories as if the packages were a basic ', & + ' part of your default programming environment, as well as letting ', & + ' you share your projects with others in a similar manner. ', & + ' ', & + ' All output goes into the directory "build/" which can generally be ', & + ' removed and rebuilt if required. Note that if external packages are ', & + ' being used you need network connectivity to rebuild from scratch. ', & + ' ', & + 'SUBCOMMANDS ', & + ' Valid fpm(1) subcommands are: ', & + ' ', & + ' + build Compile the packages into the "build/" directory. ', & + ' + new Create a new Fortran package directory with sample files. ', & + ' + update Update the project dependencies. ', & + ' + run Run the local package binaries. defaults to all binaries for ', & + ' that release. ', & + ' + test Run the tests. ', & + ' + help Alternate method for displaying subcommand help. ', & + ' + list Display brief descriptions of all subcommands. ', & + ' + install Install project ', & + ' ', & + ' Their syntax is ', & + ' ', & + ' build [--profile PROF] [--flag FFLAGS] [--list] [--compiler COMPILER_NAME]', & + ' new NAME [[--lib|--src] [--app] [--test] [--example]]| ', & + ' [--full|--bare][--backfill] ', & + ' update [NAME(s)] [--fetch-only] [--clean] ', & + ' run [[--target] NAME(s)] [--profile PROF] [--flag FFLAGS] [--list] [--example]', & + ' [--all] [--runner "CMD"] [--compiler COMPILER_NAME] [-- ARGS] ', & + ' test [[--target] NAME(s)] [--profile PROF] [--flag FFLAGS] [--list] ', & + ' [--runner "CMD"] [--compiler COMPILER_NAME] [-- ARGS] ', & + ' help [NAME(s)] ', & + ' list [--list] ', & + ' install [--profile PROF] [--flag FFLAGS] [--no-rebuild] [--prefix PATH] [options]', & + ' ', & + 'SUBCOMMAND OPTIONS ', & + ' --profile PROF selects the compilation profile for the build.',& + ' Currently available profiles are "release" for',& + ' high optimization and "debug" for full debug options.',& + ' If --flag is not specified the "debug" flags are the',& + ' default. ',& + ' --flag FFLAGS selects compile arguments for the build. These are',& + ' added to the profile options if --profile is specified,',& + ' else these options override the defaults.',& + ' Note object and .mod directory locations are always',& + ' built in.',& + ' --list List candidates instead of building or running them. On ', & + ' the fpm(1) command this shows a brief list of subcommands.', & + ' --runner CMD Provides a command to prefix program execution paths. ', & + ' --compiler COMPILER_NAME Compiler name. The environment variable ', & + ' FPM_COMPILER sets the default. ', & + ' -- ARGS Arguments to pass to executables. ', & + ' ', & + 'VALID FOR ALL SUBCOMMANDS ', & + ' --help Show help text and exit ', & + ' --verbose Display additional information when available ', & + ' --version Show version information and exit. ', & + ' ', & + 'EXAMPLES ', & + ' sample commands: ', & + ' ', & + ' fpm new mypackage --app --test ', & + ' fpm build ', & + ' fpm test ', & + ' fpm run ', & + ' fpm run --example ', & + ' fpm new --help ', & + ' fpm run myprogram --profile release -- -x 10 -y 20 --title "my title"', & + ' fpm install --prefix ~/.local ', & + ' ', & + 'SEE ALSO ', & + ' ', & + ' + The fpm(1) home page is at https://github.com/fortran-lang/fpm ', & + ' + Registered fpm(1) packages are at https://fortran-lang.org/packages ', & + ' + The fpm(1) TOML file format is described at ', & + ' https://github.com/fortran-lang/fpm/blob/master/manifest-reference.md ', & + ''] + help_list=[character(len=80) :: & + 'NAME ', & + ' list(1) - list summary of fpm(1) subcommands ', & + ' ', & + 'SYNOPSIS ', & + ' fpm list [-list] ', & + ' ', & + ' fpm list --help|--version ', & + ' ', & + 'DESCRIPTION ', & + ' Display a short description for each fpm(1) subcommand. ', & + ' ', & + 'OPTIONS ', & + ' --list display a list of command options as well. This is the ', & + ' same output as generated by "fpm --list". ', & + ' ', & + 'EXAMPLES ', & + ' display a short list of fpm(1) subcommands ', & + ' ', & + ' fpm list ', & + ' fpm --list ', & + '' ] + help_run=[character(len=80) :: & + 'NAME ', & + ' run(1) - the fpm(1) subcommand to run project applications ', & + ' ', & + 'SYNOPSIS ', & + ' fpm run [[--target] NAME(s) [--profile PROF] [--flag FFLAGS]', & + ' [--compiler COMPILER_NAME] [--runner "CMD"] [--example]', & + ' [--list] [--all] [-- ARGS]', & + ' ', & + ' fpm run --help|--version ', & + ' ', & + 'DESCRIPTION ', & + ' Run the applications in your fpm(1) package. By default applications ', & + ' in /app or specified as "executable" in your "fpm.toml" manifest are ', & + ' used. Alternatively demonstration programs in example/ or specified in', & + ' the "example" section in "fpm.toml" can be executed. The applications ', & + ' are automatically rebuilt before being run if they are out of date. ', & + ' ', & + 'OPTIONS ', & + ' --target NAME(s) list of application names to execute. No name is ', & + ' required if only one target exists. If no name is ', & + ' supplied and more than one candidate exists or a ', & + ' name has no match a list is produced and fpm(1) ', & + ' exits. ', & + ' ', & + ' Basic "globbing" is supported where "?" represents ', & + ' any single character and "*" represents any string. ', & + ' Note The glob string normally needs quoted to ', & + ' the special characters from shell expansion. ', & + ' --all Run all examples or applications. An alias for --target ''*''. ', & + ' --example Run example programs instead of applications. ', & + ' --profile PROF selects the compilation profile for the build.',& + ' Currently available profiles are "release" for',& + ' high optimization and "debug" for full debug options.',& + ' If --flag is not specified the "debug" flags are the',& + ' default. ',& + ' --flag FFLAGS selects compile arguments for the build. These are',& + ' added to the profile options if --profile is specified,',& + ' else these options override the defaults.',& + ' Note object and .mod directory locations are always',& + ' built in.',& + ' --compiler COMPILER_NAME Specify a compiler name. The default is ', & + ' "gfortran" unless set by the environment ', & + ' variable FPM_COMPILER. ', & + ' --runner CMD A command to prefix the program execution paths with. ', & + ' see "fpm help runner" for further details. ', & + ' --list list pathname of candidates instead of running them. Note ', & + ' out-of-date candidates will still be rebuilt before being ', & + ' listed. ', & + ' -- ARGS optional arguments to pass to the program(s). The same ', & + ' arguments are passed to all program names specified. ', & + ' ', & + 'EXAMPLES ', & + ' fpm(1) - run or display project applications: ', & + ' ', & + ' fpm run # run a target when only one exists or list targets ', & + ' fpm run --list # list all targets, running nothing. ', & + ' fpm run --all # run all targets, no matter how many there are. ', & + ' ', & + ' # run default program built or to be built with the compiler command ', & + ' # "f90". If more than one app exists a list displays and target names', & + ' # are required. ', & + ' fpm run --compiler f90 ', & + ' ', & + ' # run example programs instead of the application programs. ', & + ' fpm run --example ''*'' ', & + ' ', & + ' # run a specific program and pass arguments to the command ', & + ' fpm run myprog -- -x 10 -y 20 --title "my title line" ', & + ' ', & + ' # run production version of two applications ', & + ' fpm run --target prg1,prg2 --profile release ', & + ' ', & + ' # install executables in directory (assuming install(1) exists) ', & + ' fpm run --runner ''install -b -m 0711 -p -t /usr/local/bin'' ', & + '' ] + help_build=[character(len=80) :: & + 'NAME ', & + ' build(1) - the fpm(1) subcommand to build a project ', & + ' ', & + 'SYNOPSIS ', & + ' fpm build [--profile PROF] [--flag FFLAGS] [--compiler COMPILER_NAME] [-list]', & + ' ', & + ' fpm build --help|--version ', & + ' ', & + 'DESCRIPTION ', & + ' The "fpm build" command ', & + ' o Fetches any dependencies ', & + ' o Scans your sources ', & + ' o Builds them in the proper order ', & + ' ', & + ' The Fortran source files are assumed by default to be in ', & + ' o src/ for modules and procedure source ', & + ' o app/ main program(s) for applications ', & + ' o test/ main program(s) and support files for project tests ', & + ' o example/ main program(s) for example programs ', & + ' Changed or new files found are rebuilt. The results are placed in ', & + ' the build/ directory. ', & + ' ', & + ' Non-default pathnames and remote dependencies are used if ', & + ' specified in the "fpm.toml" file. ', & + ' ', & + 'OPTIONS ', & + ' --profile PROF selects the compilation profile for the build.',& + ' Currently available profiles are "release" for',& + ' high optimization and "debug" for full debug options.',& + ' If --flag is not specified the "debug" flags are the',& + ' default. ',& + ' --flag FFLAGS selects compile arguments for the build. These are',& + ' added to the profile options if --profile is specified,',& + ' else these options override the defaults.',& + ' Note object and .mod directory locations are always',& + ' built in.',& + ' --compiler COMPILER_NAME Specify a compiler name. The default is ', & + ' "gfortran" unless set by the environment ', & + ' variable FPM_COMPILER. ', & + ' --list list candidates instead of building or running them ', & + ' --show-model show the model and exit (do not build) ', & + ' --help print this help and exit ', & + ' --version print program version information and exit ', & + ' ', & + 'EXAMPLES ', & + ' Sample commands: ', & + ' ', & + ' fpm build # build with debug options ', & + ' fpm build --profile release # build with high optimization ', & + '' ] + + help_help=[character(len=80) :: & + 'NAME ', & + ' help(1) - the fpm(1) subcommand to display help ', & + ' ', & + 'SYNOPSIS ', & + ' fpm help [fpm] [new] [build] [run] [test] [help] [version] [manual] ', & + ' [runner] ', & + ' ', & + 'DESCRIPTION ', & + ' The "fpm help" command is an alternative to the --help parameter ', & + ' on the fpm(1) command and its subcommands. ', & + ' ', & + 'OPTIONS ', & + ' NAME(s) A list of topic names to display. All the subcommands ', & + ' have their own page (new, build, run, test, ...). ', & + ' ', & + ' The special name "manual" displays all the fpm(1) ', & + ' built-in documentation. ', & + ' ', & + ' The default is to display help for the fpm(1) command ', & + ' itself. ', & + ' ', & + 'EXAMPLES ', & + ' Sample usage: ', & + ' ', & + ' fpm help # general fpm(1) command help ', & + ' fpm help version # show program version ', & + ' fpm help new # display help for "new" subcommand ', & + ' fpm help manual # All fpm(1) built-in documentation ', & + ' ', & + '' ] + help_new=[character(len=80) :: & + 'NAME ', & + ' new(1) - the fpm(1) subcommand to initialize a new project ', & + 'SYNOPSIS ', & + ' fpm new NAME [[--lib|--src] [--app] [--test] [--example]]| ', & + ' [--full|--bare][--backfill] ', & + ' fpm new --help|--version ', & + ' ', & + 'DESCRIPTION ', & + ' "fpm new" creates and populates a new programming project directory. ', & + ' It ', & + ' o creates a directory with the specified name ', & + ' o runs the command "git init" in that directory ', & + ' o populates the directory with the default project directories ', & + ' o adds sample Fortran source files ', & + ' o adds a ".gitignore" file for ignoring the build/ directory ', & + ' (where fpm-generated output will be placed) ', & + ' ', & + ' The default file structure (that will be automatically scanned) is ', & + ' ', & + ' NAME/ ', & + ' fpm.toml ', & + ' .gitignore ', & + ' src/ ', & + ' NAME.f90 ', & + ' app/ ', & + ' main.f90 ', & + ' test/ ', & + ' check.f90 ', & + ' example/ ', & + ' demo.f90 ', & + ' ', & + ' Using this file structure is highly encouraged, particularly for ', & + ' small packages primarily intended to be used as dependencies. ', & + ' ', & + ' If you find this restrictive and need to customize the package ', & + ' structure you will find using the --full switch creates a ', & + ' heavily annotated manifest file with references to documentation ', & + ' to aid in constructing complex package structures. ', & + ' ', & + ' Remember to update the information in the sample "fpm.toml" ', & + ' file with your name and e-mail address. ', & + ' ', & + 'OPTIONS ', & + ' NAME the name of the project directory to create. The name ', & + ' must be made of up to 63 ASCII letters, digits, underscores, ', & + ' or hyphens, and start with a letter. ', & + ' ', & + ' The default is to create the src/, app/, and test/ directories. ', & + ' If any of the following options are specified then only the ', & + ' selected subdirectories are generated: ', & + ' ', & + ' --lib,--src create directory src/ and a placeholder module ', & + ' named "NAME.f90" for use with subcommand "build". ', & + ' --app create directory app/ and a placeholder main ', & + ' program for use with subcommand "run". ', & + ' --test create directory test/ and a placeholder program ', & + ' for use with the subcommand "test". Note that sans ', & + ' "--lib" it really does not have anything to test. ', & + ' --example create directory example/ and a placeholder program ', & + ' for use with the subcommand "run --example". ', & + ' It is only created by default if "--full is" specified. ', & + ' ', & + ' So the default is equivalent to ',& + ' ', & + ' fpm NAME --lib --app --test ', & + ' ', & + ' --backfill By default the directory must not exist. If this ', & + ' option is present the directory may pre-exist and ', & + ' only subdirectories and files that do not ', & + ' already exist will be created. For example, if you ', & + ' previously entered "fpm new myname --lib" entering ', & + ' "fpm new myname -full --backfill" will create any missing', & + ' app/, example/, and test/ directories and programs. ', & + ' ', & + ' --full By default a minimal manifest file ("fpm.toml") is ', & + ' created that depends on auto-discovery. With this ', & + ' option a much more extensive manifest sample is written ', & + ' and the example/ directory is created and populated. ', & + ' It is designed to facilitate creating projects that ', & + ' depend extensively on non-default build options. ', & + ' ', & + ' --bare A minimal manifest file ("fpm.toml") is created and ', & + ' a ".gitignore" and "README.md" file is created but no ', & + ' directories or sample Fortran is generated. ', & + ' ', & + ' --help print this help and exit ', & + ' --version print program version information and exit ', & + ' ', & + 'EXAMPLES ', & + ' Sample use ', & + ' ', & + ' fpm new myproject # create new project directory and seed it ', & + ' cd myproject # Enter the new directory ', & + ' # and run commands such as ', & + ' fpm build ', & + ' fpm run # run lone example application program ', & + ' fpm test # run example test program(s) ', & + ' fpm run --example # run lone example program ', & + ' ', & + ' fpm new A --full # create example/ and an annotated fpm.toml as well', & + ' fpm new A --bare # create no directories ', & + ' create any missing files in current directory ', & + ' fpm new `pwd` --full --backfill ', & + '' ] + help_test=[character(len=80) :: & + 'NAME ', & + ' test(1) - the fpm(1) subcommand to run project tests ', & + ' ', & + 'SYNOPSIS ', & + ' fpm test [[--target] NAME(s)] [--profile PROF] [--flag FFLAGS]', & + ' [--compiler COMPILER_NAME ] [--runner "CMD"] [--list][-- ARGS]', & + ' ', & + ' fpm test --help|--version ', & + ' ', & + 'DESCRIPTION ', & + ' Run applications you have built to test your project. ', & + ' ', & + 'OPTIONS ', & + ' --target NAME(s) optional list of specific test names to execute. ', & + ' The default is to run all the tests in test/ ', & + ' or the tests listed in the "fpm.toml" file. ', & + ' ', & + ' Basic "globbing" is supported where "?" represents ', & + ' any single character and "*" represents any string. ', & + ' Note The glob string normally needs quoted to ', & + ' protect the special characters from shell expansion.', & + ' --profile PROF selects the compilation profile for the build.',& + ' Currently available profiles are "release" for',& + ' high optimization and "debug" for full debug options.',& + ' If --flag is not specified the "debug" flags are the',& + ' default. ',& + ' --flag FFLAGS selects compile arguments for the build. These are',& + ' added to the profile options if --profile is specified,',& + ' else these options override the defaults.',& + ' Note object and .mod directory locations are always',& + ' built in.',& + ' --compiler COMPILER_NAME Specify a compiler name. The default is ', & + ' "gfortran" unless set by the environment ', & + ' variable FPM_COMPILER. ', & + ' --runner CMD A command to prefix the program execution paths with. ', & + ' see "fpm help runner" for further details. ', & + ' --list list candidates instead of building or running them ', & + ' -- ARGS optional arguments to pass to the test program(s). ', & + ' The same arguments are passed to all test names ', & + ' specified. ', & + ' ', & + 'EXAMPLES ', & + 'run tests ', & + ' ', & + ' # run default tests in /test or as specified in "fpm.toml" ', & + ' fpm test ', & + ' ', & + ' # run using compiler command "f90" ', & + ' fpm test --compiler f90 ', & + ' ', & + ' # run a specific test and pass arguments to the command ', & + ' fpm test mytest -- -x 10 -y 20 --title "my title line" ', & + ' ', & + ' fpm test tst1 tst2 --profile PROF # run production version of two tests', & + '' ] + help_update=[character(len=80) :: & + 'NAME', & + ' update(1) - manage project dependencies', & + '', & + 'SYNOPSIS', & + ' fpm update [--fetch-only] [--clean] [--verbose] [NAME(s)]', & + '', & + 'DESCRIPTION', & + ' Manage and update project dependencies. If no dependency names are', & + ' provided all the dependencies are updated automatically.', & + '', & + 'OPTIONS', & + ' --fetch-only Only fetch dependencies, do not update existing projects', & + ' --clean Do not use previous dependency cache', & + ' --verbose Show additional printout', & + '', & + 'SEE ALSO', & + ' The fpm(1) home page at https://github.com/fortran-lang/fpm', & + '' ] + help_install=[character(len=80) :: & + 'NAME', & + ' install(1) - install fpm projects', & + '', & + 'SYNOPSIS', & + ' fpm install [--profile PROF] [--flag FFLAGS] [--list] [--no-rebuild]', & + ' [--prefix DIR] [--bindir DIR] [--libdir DIR] [--includedir DIR]', & + ' [--verbose]', & + '', & + 'DESCRIPTION', & + ' Subcommand to install fpm projects. Running install will export the', & + ' current project to the selected prefix, this will by default install all', & + ' executables (tests and examples are excluded) which are part of the projects.', & + ' Libraries and module files are only installed for projects requiring the', & + ' installation of those components in the package manifest.', & + '', & + 'OPTIONS', & + ' --list list all installable targets for this project,', & + ' but do not install any of them', & + ' --profile PROF selects the compilation profile for the build.',& + ' Currently available profiles are "release" for',& + ' high optimization and "debug" for full debug options.',& + ' If --flag is not specified the "debug" flags are the',& + ' default. ',& + ' --flag FFLAGS selects compile arguments for the build. These are',& + ' added to the profile options if --profile is specified,',& + ' else these options override the defaults.',& + ' Note object and .mod directory locations are always',& + ' built in.',& + ' --no-rebuild do not rebuild project before installation', & + ' --prefix DIR path to installation directory (requires write access),', & + ' the default prefix on Unix systems is $HOME/.local', & + ' and %APPDATA%\local on Windows', & + ' --bindir DIR subdirectory to place executables in (default: bin)', & + ' --libdir DIR subdirectory to place libraries and archives in', & + ' (default: lib)', & + ' --includedir DIR subdirectory to place headers and module files in', & + ' (default: include)', & + ' --verbose print more information', & + '', & + 'EXAMPLES', & + ' 1. Install release version of project:', & + '', & + ' fpm install --profile release', & + '', & + ' 2. Install the project without rebuilding the executables:', & + '', & + ' fpm install --no-rebuild', & + '', & + ' 3. Install executables to a custom prefix into the exe directory:', & + '', & + ' fpm install --prefix $PWD --bindir exe', & + '' ] + end subroutine set_help + + subroutine get_char_arg(var, arg) + character(len=:), allocatable, intent(out) :: var + character(len=*), intent(in) :: arg + var = sget(arg) + if (len_trim(var) == 0) deallocate(var) + end subroutine get_char_arg + +end module fpm_command_line diff --git a/src/fpm_compiler.f90 b/src/fpm_compiler.f90 new file mode 100644 index 0000000..51cda20 --- /dev/null +++ b/src/fpm_compiler.f90 @@ -0,0 +1,333 @@ +!># Define compiler command options +!! +!! This module defines compiler options to use for the debug and release builds. + +! vendor Fortran C Module output Module include OpenMP Free for OSS +! compiler compiler directory directory +! Gnu gfortran gcc -J -I -fopenmp X +! Intel ifort icc -module -I -qopenmp X +! Intel(Windows) ifort icc /module:path /I /Qopenmp X +! Intel oneAPI ifx icx -module -I -qopenmp X +! PGI pgfortran pgcc -module -I -mp X +! NVIDIA nvfortran nvc -module -I -mp X +! LLVM flang flang clang -module -I -mp X +! LFortran lfortran --- ? ? ? X +! Lahey/Futjitsu lfc ? -M -I -openmp ? +! NAG nagfor ? -mdir -I -openmp x +! Cray crayftn craycc -J -I -homp ? +! IBM xlf90 ? -qmoddir -I -qsmp X +! Oracle/Sun ? ? -moddir= -M -xopenmp ? +! Silverfrost FTN95 ftn95 ? ? /MOD_PATH ? ? +! Elbrus ? lcc -J -I -fopenmp ? +! Hewlett Packard ? ? ? ? ? discontinued +! Watcom ? ? ? ? ? discontinued +! PathScale ? ? -module -I -mp discontinued +! G95 ? ? -fmod= -I -fopenmp discontinued +! Open64 ? ? -module -I -mp discontinued +! Unisys ? ? ? ? ? discontinued +module fpm_compiler +use fpm_model, only: fpm_model_t +use fpm_filesystem, only: join_path, basename +implicit none +public :: is_unknown_compiler +public :: get_module_flags +public :: get_default_compile_flags +public :: get_debug_compile_flags +public :: get_release_compile_flags + +enum, bind(C) + enumerator :: & + id_unknown, & + id_gcc, & + id_f95, & + id_caf, & + id_intel_classic, & + id_intel_llvm, & + id_pgi, & + id_nvhpc, & + id_nag, & + id_flang, & + id_ibmxl, & + id_cray, & + id_lahey, & + id_lfortran +end enum +integer, parameter :: compiler_enum = kind(id_unknown) + +contains + +subroutine get_default_compile_flags(compiler, release, flags) + character(len=*), intent(in) :: compiler + logical, intent(in) :: release + character(len=:), allocatable, intent(out) :: flags + integer :: id + + id = get_compiler_id(compiler) + if (release) then + call get_release_compile_flags(id, flags) + else + call get_debug_compile_flags(id, flags) + end if + +end subroutine get_default_compile_flags + +subroutine get_release_compile_flags(id, flags) + integer(compiler_enum), intent(in) :: id + character(len=:), allocatable, intent(out) :: flags + + select case(id) + case default + flags = "" + + case(id_caf) + flags='& + & -O3& + & -Wimplicit-interface& + & -fPIC& + & -fmax-errors=1& + & -funroll-loops& + &' + case(id_gcc) + flags='& + & -O3& + & -Wimplicit-interface& + & -fPIC& + & -fmax-errors=1& + & -funroll-loops& + & -fcoarray=single& + &' + case(id_f95) + flags='& + & -O3& + & -Wimplicit-interface& + & -fPIC& + & -fmax-errors=1& + & -ffast-math& + & -funroll-loops& + &' + case(id_nvhpc) + flags = '& + & -Mbackslash& + &' + case(id_intel_classic) + flags = '& + & -fp-model precise& + & -pc 64& + & -align all& + & -error-limit 1& + & -reentrancy threaded& + & -nogen-interfaces& + & -assume byterecl& + &' + case(id_nag) + flags = ' & + & -O4& + & -coarray=single& + & -PIC& + &' + end select +end subroutine get_release_compile_flags + +subroutine get_debug_compile_flags(id, flags) + integer(compiler_enum), intent(in) :: id + character(len=:), allocatable, intent(out) :: flags + + select case(id) + case default + flags = "" + + case(id_caf) + flags = '& + & -Wall& + & -Wextra& + & -Wimplicit-interface& + & -fPIC -fmax-errors=1& + & -g& + & -fcheck=bounds& + & -fcheck=array-temps& + & -fbacktrace& + &' + + case(id_gcc) + flags = '& + & -Wall& + & -Wextra& + & -Wimplicit-interface& + & -fPIC -fmax-errors=1& + & -g& + & -fcheck=bounds& + & -fcheck=array-temps& + & -fbacktrace& + & -fcoarray=single& + &' + + case(id_f95) + flags = '& + & -Wall& + & -Wextra& + & -Wimplicit-interface& + & -fPIC -fmax-errors=1& + & -g& + & -fcheck=bounds& + & -fcheck=array-temps& + & -Wno-maybe-uninitialized -Wno-uninitialized& + & -fbacktrace& + &' + + case(id_nvhpc) + flags = '& + & -Minform=inform& + & -Mbackslash& + & -g& + & -Mbounds& + & -Mchkptr& + & -Mchkstk& + & -traceback& + &' + + case(id_intel_classic) + flags = '& + & -warn all& + & -check:all:noarg_temp_created& + & -error-limit 1& + & -O0& + & -g& + & -assume byterecl& + & -traceback& + &' + + case(id_nag) + flags = '& + & -g& + & -C=all& + & -O0& + & -gline& + & -coarray=single& + & -PIC& + &' + end select +end subroutine get_debug_compile_flags + +subroutine get_module_flags(compiler, modpath, flags) + character(len=*), intent(in) :: compiler + character(len=*), intent(in) :: modpath + character(len=:), allocatable, intent(out) :: flags + integer(compiler_enum) :: id + + id = get_compiler_id(compiler) + + select case(id) + case default + flags=' -module '//modpath//' -I '//modpath + + case(id_caf, id_gcc, id_f95, id_cray) + flags=' -J '//modpath//' -I '//modpath + + case(id_intel_classic, id_intel_llvm, id_nvhpc, id_pgi, id_flang) + flags=' -module '//modpath//' -I '//modpath + + case(id_lahey) + flags=' -M '//modpath//' -I '//modpath + + case(id_nag) + flags=' -mdir '//modpath//' -I '//modpath ! + + case(id_ibmxl) + flags=' -qmoddir '//modpath//' -I '//modpath + + end select + +end subroutine get_module_flags + +function get_compiler_id(compiler) result(id) + character(len=*), intent(in) :: compiler + integer(kind=compiler_enum) :: id + + if (check_compiler(compiler, "gfortran")) then + id = id_gcc + return + end if + + if (check_compiler(compiler, "f95")) then + id = id_f95 + return + end if + + if (check_compiler(compiler, "caf")) then + id = id_caf + return + end if + + if (check_compiler(compiler, "ifort")) then + id = id_intel_classic + return + end if + + if (check_compiler(compiler, "ifx")) then + id = id_intel_llvm + return + end if + + if (check_compiler(compiler, "nvfortran")) then + id = id_nvhpc + return + end if + + if (check_compiler(compiler, "pgfortran") & + & .or. check_compiler(compiler, "pgf90") & + & .or. check_compiler(compiler, "pgf95")) then + id = id_pgi + return + end if + + if (check_compiler(compiler, "nagfor")) then + id = id_nag + return + end if + + if (check_compiler(compiler, "flang")) then + id = id_flang + return + end if + + if (check_compiler(compiler, "xlf90")) then + id = id_ibmxl + return + end if + + if (check_compiler(compiler, "crayftn")) then + id = id_cray + return + end if + + if (check_compiler(compiler, "lfc")) then + id = id_lahey + return + end if + + if (check_compiler(compiler, "lfort")) then + id = id_lfortran + return + end if + + id = id_unknown + +end function get_compiler_id + +function check_compiler(compiler, expected) result(match) + character(len=*), intent(in) :: compiler + character(len=*), intent(in) :: expected + logical :: match + match = compiler == expected + if (.not. match) then + match = index(basename(compiler), expected) > 0 + end if +end function check_compiler + +function is_unknown_compiler(compiler) result(is_unknown) + character(len=*), intent(in) :: compiler + logical :: is_unknown + is_unknown = get_compiler_id(compiler) == id_unknown +end function is_unknown_compiler + +end module fpm_compiler diff --git a/src/fpm_environment.f90 b/src/fpm_environment.f90 new file mode 100644 index 0000000..0408ec4 --- /dev/null +++ b/src/fpm_environment.f90 @@ -0,0 +1,185 @@ +!> This module contains procedures that interact with the programming environment. +!! +!! * [get_os_type] -- Determine the OS type +!! * [get_env] -- return the value of an environment variable +module fpm_environment + implicit none + private + public :: get_os_type + public :: os_is_unix + public :: run + public :: get_env + + integer, parameter, public :: OS_UNKNOWN = 0 + integer, parameter, public :: OS_LINUX = 1 + integer, parameter, public :: OS_MACOS = 2 + integer, parameter, public :: OS_WINDOWS = 3 + integer, parameter, public :: OS_CYGWIN = 4 + integer, parameter, public :: OS_SOLARIS = 5 + integer, parameter, public :: OS_FREEBSD = 6 +contains + !> Determine the OS type + integer function get_os_type() result(r) + !! + !! Returns one of OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_WINDOWS, OS_CYGWIN, + !! OS_SOLARIS, OS_FREEBSD. + !! + !! At first, the environment variable `OS` is checked, which is usually + !! found on Windows. Then, `OSTYPE` is read in and compared with common + !! names. If this fails too, check the existence of files that can be + !! found on specific system types only. + !! + !! Returns OS_UNKNOWN if the operating system cannot be determined. + character(len=32) :: val + integer :: length, rc + logical :: file_exists + + r = OS_UNKNOWN + + ! Check environment variable `OS`. + call get_environment_variable('OS', val, length, rc) + + if (rc == 0 .and. length > 0 .and. index(val, 'Windows_NT') > 0) then + r = OS_WINDOWS + return + end if + + ! Check environment variable `OSTYPE`. + call get_environment_variable('OSTYPE', val, length, rc) + + if (rc == 0 .and. length > 0) then + ! Linux + if (index(val, 'linux') > 0) then + r = OS_LINUX + return + end if + + ! macOS + if (index(val, 'darwin') > 0) then + r = OS_MACOS + return + end if + + ! Windows, MSYS, MinGW, Git Bash + if (index(val, 'win') > 0 .or. index(val, 'msys') > 0) then + r = OS_WINDOWS + return + end if + + ! Cygwin + if (index(val, 'cygwin') > 0) then + r = OS_CYGWIN + return + end if + + ! Solaris, OpenIndiana, ... + if (index(val, 'SunOS') > 0 .or. index(val, 'solaris') > 0) then + r = OS_SOLARIS + return + end if + + ! FreeBSD + if (index(val, 'FreeBSD') > 0 .or. index(val, 'freebsd') > 0) then + r = OS_FREEBSD + return + end if + end if + + ! Linux + inquire (file='/etc/os-release', exist=file_exists) + + if (file_exists) then + r = OS_LINUX + return + end if + + ! macOS + inquire (file='/usr/bin/sw_vers', exist=file_exists) + + if (file_exists) then + r = OS_MACOS + return + end if + + ! FreeBSD + inquire (file='/bin/freebsd-version', exist=file_exists) + + if (file_exists) then + r = OS_FREEBSD + return + end if + end function get_os_type + + !> Compare the output of [[get_os_type]] or the optional + !! passed INTEGER value to the value for OS_WINDOWS + !! and return .TRUE. if they match and .FALSE. otherwise + logical function os_is_unix(os) result(unix) + integer, intent(in), optional :: os + integer :: build_os + if (present(os)) then + build_os = os + else + build_os = get_os_type() + end if + unix = os /= OS_WINDOWS + end function os_is_unix + + !> echo command string and pass it to the system for execution + subroutine run(cmd,echo) + character(len=*), intent(in) :: cmd + logical,intent(in),optional :: echo + logical :: echo_local + integer :: stat + + if(present(echo))then + echo_local=echo + else + echo_local=.true. + endif + if(echo_local) print *, '+ ', cmd + + call execute_command_line(cmd, exitstat=stat) + if (stat /= 0) then + print *, 'Command failed' + error stop + end if + end subroutine run + + !> get named environment variable value. It it is blank or + !! not set return the optional default value + function get_env(NAME,DEFAULT) result(VALUE) + implicit none + !> name of environment variable to get the value of + character(len=*),intent(in) :: NAME + !> default value to return if the requested value is undefined or blank + character(len=*),intent(in),optional :: DEFAULT + !> the returned value + character(len=:),allocatable :: VALUE + integer :: howbig + integer :: stat + integer :: length + ! get length required to hold value + length=0 + if(NAME.ne.'')then + call get_environment_variable(NAME, length=howbig,status=stat,trim_name=.true.) + select case (stat) + case (1) + !*!print *, NAME, " is not defined in the environment. Strange..." + VALUE='' + case (2) + !*!print *, "This processor doesn't support environment variables. Boooh!" + VALUE='' + case default + ! make string to hold value of sufficient size + allocate(character(len=max(howbig,1)) :: VALUE) + ! get value + call get_environment_variable(NAME,VALUE,status=stat,trim_name=.true.) + if(stat.ne.0)VALUE='' + end select + else + VALUE='' + endif + if(VALUE.eq.''.and.present(DEFAULT))VALUE=DEFAULT + end function get_env + +end module fpm_environment diff --git a/src/fpm_filesystem.f90 b/src/fpm_filesystem.f90 new file mode 100644 index 0000000..6acd383 --- /dev/null +++ b/src/fpm_filesystem.f90 @@ -0,0 +1,612 @@ +!> This module contains general routines for interacting with the file system +!! +module fpm_filesystem +use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, stderr=>error_unit + use fpm_environment, only: get_os_type, & + OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_WINDOWS, & + OS_CYGWIN, OS_SOLARIS, OS_FREEBSD + use fpm_strings, only: f_string, replace, string_t, split + implicit none + private + public :: basename, canon_path, dirname, is_dir, join_path, number_of_rows, read_lines, list_files, env_variable, & + mkdir, exists, get_temp_filename, windows_path, unix_path, getline, delete_file, to_fortran_name + public :: fileopen, fileclose, filewrite, warnwrite + + integer, parameter :: LINE_BUFFER_LEN = 1000 + +contains + + +!> return value of environment variable +subroutine env_variable(var, name) + character(len=:), allocatable, intent(out) :: var + character(len=*), intent(in) :: name + integer :: length, stat + + call get_environment_variable(name, length=length, status=stat) + if (stat /= 0) return + + allocate(character(len=length) :: var) + + if (length > 0) then + call get_environment_variable(name, var, status=stat) + if (stat /= 0) then + deallocate(var) + return + end if + end if + +end subroutine env_variable + + +!> Extract filename from path with/without suffix +function basename(path,suffix) result (base) + + 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='\/') + if(size(file_parts).gt.0)then + base = trim(file_parts(size(file_parts))) + else + base = '' + endif + else + call split(path,file_parts,delimiters='\/.') + if(size(file_parts).ge.2)then + base = trim(file_parts(size(file_parts)-1)) + else + base = '' + endif + end if + +end function basename + + +!> Canonicalize path for comparison +!! * Handles path string redundancies +!! * Does not test existence of path +!! +!! To be replaced by realpath/_fullname in stdlib_os +!! +!! FIXME: Lot's of ugly hacks following here +function canon_path(path) + character(len=*), intent(in) :: path + character(len=:), allocatable :: canon_path + character(len=:), allocatable :: nixpath + + integer :: ii, istart, iend, stat, nn, last + logical :: is_path, absolute + + nixpath = unix_path(path) + + istart = 0 + nn = 0 + iend = 0 + absolute = nixpath(1:1) == "/" + if (absolute) then + canon_path = "/" + else + canon_path = "" + end if + + do while(iend < len(nixpath)) + call next(nixpath, istart, iend, is_path) + if (is_path) then + select case(nixpath(istart:iend)) + case(".", "") ! always drop empty paths + case("..") + if (nn > 0) then + last = scan(canon_path(:len(canon_path)-1), "/", back=.true.) + canon_path = canon_path(:last) + nn = nn - 1 + else + if (.not. absolute) then + canon_path = canon_path // nixpath(istart:iend) // "/" + end if + end if + case default + nn = nn + 1 + canon_path = canon_path // nixpath(istart:iend) // "/" + end select + end if + end do + + if (len(canon_path) == 0) canon_path = "." + if (len(canon_path) > 1 .and. canon_path(len(canon_path):) == "/") then + canon_path = canon_path(:len(canon_path)-1) + end if + +contains + + subroutine next(string, istart, iend, is_path) + character(len=*), intent(in) :: string + integer, intent(inout) :: istart + integer, intent(inout) :: iend + logical, intent(inout) :: is_path + + integer :: ii, nn + character :: tok, last + + nn = len(string) + + if (iend >= nn) then + istart = nn + iend = nn + return + end if + + ii = min(iend + 1, nn) + tok = string(ii:ii) + + is_path = tok /= '/' + + if (.not.is_path) then + is_path = .false. + istart = ii + iend = ii + return + end if + + istart = ii + do ii = min(iend + 1, nn), nn + tok = string(ii:ii) + select case(tok) + case('/') + exit + case default + iend = ii + cycle + end select + end do + + end subroutine next +end function canon_path + + +!> Extract dirname from path +function dirname(path) result (dir) + character(*), intent(in) :: path + character(:), allocatable :: dir + + dir = path(1:scan(path,'/\',back=.true.)) + +end function dirname + + +!> test if a name matches an existing directory path +logical function is_dir(dir) + character(*), intent(in) :: dir + integer :: stat + + select case (get_os_type()) + + case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD) + call execute_command_line("test -d " // dir , exitstat=stat) + + case (OS_WINDOWS) + call execute_command_line('cmd /c "if not exist ' // windows_path(dir) // '\ exit /B 1"', exitstat=stat) + + end select + + is_dir = (stat == 0) + +end function is_dir + + +!> Construct path by joining strings with os file separator +function join_path(a1,a2,a3,a4,a5) result(path) + + character(len=*), intent(in) :: a1, a2 + character(len=*), intent(in), optional :: a3, a4, a5 + character(len=:), allocatable :: path + character(len=1) :: filesep + + select case (get_os_type()) + case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD) + 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 + + +!> Determine number or rows in a file given a LUN +integer function number_of_rows(s) result(nrows) + 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 + + +!> read lines into an array of TYPE(STRING_T) variables +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 + +!> Create a directory. Create subdirectories as needed +subroutine mkdir(dir) + character(len=*), intent(in) :: dir + integer :: stat + + if (is_dir(dir)) return + + select case (get_os_type()) + case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD) + call execute_command_line('mkdir -p ' // dir, exitstat=stat) + write (*, '(" + ",2a)') 'mkdir -p ' // dir + + case (OS_WINDOWS) + call execute_command_line("mkdir " // windows_path(dir), exitstat=stat) + write (*, '(" + ",2a)') 'mkdir ' // windows_path(dir) + end select + + if (stat /= 0) then + print *, 'execute_command_line() failed' + error stop + end if +end subroutine mkdir + + +!> Get file & directory names in directory `dir`. +!! +!! - File/directory names return are relative to cwd, ie. preprended with `dir` +!! - Includes files starting with `.` except current directory and parent directory +!! +recursive subroutine list_files(dir, files, recurse) + character(len=*), intent(in) :: dir + type(string_t), allocatable, intent(out) :: files(:) + logical, intent(in), optional :: recurse + + integer :: stat, fh, i + character(:), allocatable :: temp_file + type(string_t), allocatable :: dir_files(:) + type(string_t), allocatable :: sub_dir_files(:) + + if (.not. is_dir(dir)) then + allocate (files(0)) + return + end if + + allocate (temp_file, source=get_temp_filename()) + + select case (get_os_type()) + case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD) + call execute_command_line('ls -A ' // dir // ' > ' // temp_file, & + exitstat=stat) + case (OS_WINDOWS) + call execute_command_line('dir /b ' // windows_path(dir) // ' > ' // temp_file, & + exitstat=stat) + end select + + if (stat /= 0) then + 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") + + do i=1,size(files) + files(i)%s = join_path(dir,files(i)%s) + end do + + if (present(recurse)) then + if (recurse) then + + allocate(sub_dir_files(0)) + + do i=1,size(files) + if (is_dir(files(i)%s)) then + + call list_files(files(i)%s, dir_files, recurse=.true.) + sub_dir_files = [sub_dir_files, dir_files] + + end if + end do + + files = [files, sub_dir_files] + + end if + end if + +end subroutine list_files + + +!> test if pathname already exists +logical function exists(filename) result(r) + character(len=*), intent(in) :: filename + inquire(file=filename, exist=r) +end function + + +!> Get a unused temporary filename +!! Calls posix 'tempnam' - not recommended, but +!! we have no security concerns for this application +!! and use here is temporary. +!! Works with MinGW +function get_temp_filename() result(tempfile) + ! + 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 + + +!> Replace file system separators for windows +function windows_path(path) result(winpath) + + 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 + + +!> Replace file system separators for unix +function unix_path(path) result(nixpath) + + character(*), intent(in) :: path + character(:), allocatable :: nixpath + + integer :: idx + + nixpath = path + + idx = index(nixpath,'\') + do while(idx > 0) + nixpath(idx:idx) = '/' + idx = index(nixpath,'\') + end do + +end function unix_path + + +!> read a line of arbitrary length into a CHARACTER variable from the specified LUN +subroutine getline(unit, line, iostat, iomsg) + + !> Formatted IO unit + integer, intent(in) :: unit + + !> Line to read + character(len=:), allocatable, intent(out) :: line + + !> Status of operation + integer, intent(out) :: iostat + + !> Error message + character(len=:), allocatable, optional :: iomsg + + character(len=LINE_BUFFER_LEN) :: buffer + character(len=LINE_BUFFER_LEN) :: msg + integer :: size + integer :: stat + + allocate(character(len=0) :: line) + do + read(unit, '(a)', advance='no', iostat=stat, iomsg=msg, size=size) & + & buffer + if (stat > 0) exit + line = line // buffer(:size) + if (stat < 0) then + if (is_iostat_eor(stat)) then + stat = 0 + end if + exit + end if + end do + + if (stat /= 0) then + if (present(iomsg)) iomsg = trim(msg) + end if + iostat = stat + +end subroutine getline + + +!> delete a file by filename +subroutine delete_file(file) + character(len=*), intent(in) :: file + logical :: exist + integer :: unit + inquire(file=file, exist=exist) + if (exist) then + open(file=file, newunit=unit) + close(unit, status="delete") + end if +end subroutine delete_file + +!> write trimmed character data to a file if it does not exist +subroutine warnwrite(fname,data) +character(len=*),intent(in) :: fname +character(len=*),intent(in) :: data(:) + + if(.not.exists(fname))then + call filewrite(fname,data) + else + write(stderr,'(*(g0,1x))')' ',fname,& + & 'already exists. Not overwriting' + endif + +end subroutine warnwrite + +!> procedure to open filename as a sequential "text" file +subroutine fileopen(filename,lun,ier) + +character(len=*),intent(in) :: filename +integer,intent(out) :: lun +integer,intent(out),optional :: ier +integer :: ios +character(len=256) :: message + + message=' ' + ios=0 + if(filename.ne.' ')then + open(file=filename, & + & newunit=lun, & + & form='formatted', & ! FORM = FORMATTED | UNFORMATTED + & access='sequential', & ! ACCESS = SEQUENTIAL| DIRECT | STREAM + & action='write', & ! ACTION = READ|WRITE| READWRITE + & position='rewind', & ! POSITION= ASIS | REWIND | APPEND + & status='new', & ! STATUS = NEW| REPLACE| OLD| SCRATCH| UNKNOWN + & iostat=ios, & + & iomsg=message) + else + lun=stdout + ios=0 + endif + if(ios.ne.0)then + write(stderr,'(*(a:,1x))')& + & ' *filewrite*:',filename,trim(message) + lun=-1 + if(present(ier))then + ier=ios + else + stop 1 + endif + endif + +end subroutine fileopen + +!> simple close of a LUN. On error show message and stop (by default) +subroutine fileclose(lun,ier) +integer,intent(in) :: lun +integer,intent(out),optional :: ier +character(len=256) :: message +integer :: ios + if(lun.ne.-1)then + close(unit=lun,iostat=ios,iomsg=message) + if(ios.ne.0)then + write(stderr,'(*(a:,1x))')' *filewrite*:',trim(message) + if(present(ier))then + ier=ios + else + stop 2 + endif + endif + endif +end subroutine fileclose + +!> procedure to write filedata to file filename +subroutine filewrite(filename,filedata) + +character(len=*),intent(in) :: filename +character(len=*),intent(in) :: filedata(:) +integer :: lun, i, ios +character(len=256) :: message + call fileopen(filename,lun) + if(lun.ne.-1)then ! program currently stops on error on open, but might + ! want it to continue so -1 (unallowed LUN) indicates error + ! write file + do i=1,size(filedata) + write(lun,'(a)',iostat=ios,iomsg=message)trim(filedata(i)) + if(ios.ne.0)then + write(stderr,'(*(a:,1x))')& + & ' *filewrite*:',filename,trim(message) + stop 4 + endif + enddo + endif + ! close file + call fileclose(lun) + +end subroutine filewrite + +!> Returns string with special characters replaced with an underscore. +!! For now, only a hyphen is treated as a special character, but this can be +!! expanded to other characters if needed. +pure function to_fortran_name(string) result(res) + character(*), intent(in) :: string + character(len(string)) :: res + character, parameter :: SPECIAL_CHARACTERS(*) = ['-'] + res = replace(string, SPECIAL_CHARACTERS, '_') +end function to_fortran_name + +end module fpm_filesystem diff --git a/src/fpm_model.f90 b/src/fpm_model.f90 new file mode 100644 index 0000000..bfb0115 --- /dev/null +++ b/src/fpm_model.f90 @@ -0,0 +1,293 @@ +!># The fpm package model +!> +!> Defines the fpm model data types which encapsulate all information +!> required to correctly build a package and its dependencies. +!> +!> The process (see `[[build_model(subroutine)]]`) for generating a valid `[[fpm_model]]` involves +!> source files discovery ([[fpm_sources]]) and parsing ([[fpm_source_parsing]]). +!> +!> Once a valid `[[fpm_model]]` has been constructed, it may be passed to `[[fpm_targets:targets_from_sources]]` to +!> generate a list of build targets for the backend. +!> +!>### Enumerations +!> +!> __Source type:__ `FPM_UNIT_*` +!> Describes the type of source file — determines build target generation +!> +!> __Source scope:__ `FPM_SCOPE_*` +!> Describes the scoping rules for using modules — controls module dependency resolution +!> +module fpm_model +use iso_fortran_env, only: int64 +use fpm_strings, only: string_t, str +use fpm_dependency, only: dependency_tree_t +implicit none + +private +public :: fpm_model_t, srcfile_t, show_model + +public :: FPM_UNIT_UNKNOWN, FPM_UNIT_PROGRAM, FPM_UNIT_MODULE, & + FPM_UNIT_SUBMODULE, FPM_UNIT_SUBPROGRAM, FPM_UNIT_CSOURCE, & + FPM_UNIT_CHEADER, FPM_SCOPE_UNKNOWN, FPM_SCOPE_LIB, & + FPM_SCOPE_DEP, FPM_SCOPE_APP, FPM_SCOPE_EXAMPLE, FPM_SCOPE_TEST + +!> Source type unknown +integer, parameter :: FPM_UNIT_UNKNOWN = -1 +!> Source type is fortran program +integer, parameter :: FPM_UNIT_PROGRAM = 1 +!> Source type is fortran module +integer, parameter :: FPM_UNIT_MODULE = 2 +!> Source type is fortran submodule +integer, parameter :: FPM_UNIT_SUBMODULE = 3 +!> Source type is fortran subprogram +integer, parameter :: FPM_UNIT_SUBPROGRAM = 4 +!> Source type is c source file +integer, parameter :: FPM_UNIT_CSOURCE = 5 +!> Source type is c header file +integer, parameter :: FPM_UNIT_CHEADER = 6 + + +!> Source has no module-use scope +integer, parameter :: FPM_SCOPE_UNKNOWN = -1 +!> Module-use scope is library/dependency modules only +integer, parameter :: FPM_SCOPE_LIB = 1 +!> Module-use scope is library/dependency modules only +integer, parameter :: FPM_SCOPE_DEP = 2 +!> Module-use scope is library/dependency and app modules +integer, parameter :: FPM_SCOPE_APP = 3 +!> Module-use scope is library/dependency and test modules +integer, parameter :: FPM_SCOPE_TEST = 4 +integer, parameter :: FPM_SCOPE_EXAMPLE = 5 + + +!> Type for describing a source file +type srcfile_t + !> File path relative to cwd + character(:), allocatable :: file_name + + !> Name of executable for FPM_UNIT_PROGRAM + character(:), allocatable :: exe_name + + !> Target module-use scope + integer :: unit_scope = FPM_SCOPE_UNKNOWN + + !> Modules provided by this source file (lowerstring) + type(string_t), allocatable :: modules_provided(:) + + !> Type of source unit + integer :: unit_type = FPM_UNIT_UNKNOWN + + !> Modules USEd by this source file (lowerstring) + type(string_t), allocatable :: modules_used(:) + + !> Files INCLUDEd by this source file + type(string_t), allocatable :: include_dependencies(:) + + !> Native libraries to link against + type(string_t), allocatable :: link_libraries(:) + + !> Current hash + integer(int64) :: digest + +end type srcfile_t + + +!> Type for describing a single package +type package_t + + !> Name of package + character(:), allocatable :: name + + !> Array of sources + type(srcfile_t), allocatable :: sources(:) + +end type package_t + + +!> Type describing everything required to build +!> the root package and its dependencies. +type :: fpm_model_t + + !> Name of root package + character(:), allocatable :: package_name + + !> Array of packages (including the root package) + type(package_t), allocatable :: packages(:) + + !> Command line name to invoke fortran compiler + character(:), allocatable :: fortran_compiler + + !> Command line flags passed to fortran for compilation + character(:), allocatable :: fortran_compile_flags + + !> Base directory for build + character(:), allocatable :: output_directory + + !> Include directories + type(string_t), allocatable :: include_dirs(:) + + !> Native libraries to link against + type(string_t), allocatable :: link_libraries(:) + + !> Project dependencies + type(dependency_tree_t) :: deps + +end type fpm_model_t + +contains + + +function info_package(p) result(s) + ! Returns representation of package_t + type(package_t), intent(in) :: p + character(:), allocatable :: s + + integer :: i + + s = s // 'package_t(' + s = s // 'name="' // p%name //'"' + s = s // ', sources=[' + do i = 1, size(p%sources) + s = s // info_srcfile(p%sources(i)) + if (i < size(p%sources)) s = s // ", " + end do + s = s // "]" + s = s // ")" + +end function info_package + +function info_srcfile(source) result(s) + type(srcfile_t), intent(in) :: source + character(:), allocatable :: s + integer :: i + !type srcfile_t + s = "srcfile_t(" + ! character(:), allocatable :: file_name + s = s // 'file_name="' // source%file_name // '"' + ! character(:), allocatable :: exe_name + s = s // ', exe_name="' // source%exe_name // '"' + ! integer :: unit_scope = FPM_SCOPE_UNKNOWN + s = s // ", unit_scope=" + select case(source%unit_scope) + case (FPM_SCOPE_UNKNOWN) + s = s // "FPM_SCOPE_UNKNOWN" + case (FPM_SCOPE_LIB) + s = s // "FPM_SCOPE_LIB" + case (FPM_SCOPE_DEP) + s = s // "FPM_SCOPE_DEP" + case (FPM_SCOPE_APP) + s = s // "FPM_SCOPE_APP" + case (FPM_SCOPE_TEST) + s = s // "FPM_SCOPE_TEST" + case (FPM_SCOPE_EXAMPLE) + s = s // "FPM_SCOPE_EXAMPLE" + case default + s = s // "INVALID" + end select + ! type(string_t), allocatable :: modules_provided(:) + s = s // ", modules_provided=[" + do i = 1, size(source%modules_provided) + s = s // '"' // source%modules_provided(i)%s // '"' + if (i < size(source%modules_provided)) s = s // ", " + end do + s = s // "]" + ! integer :: unit_type = FPM_UNIT_UNKNOWN + s = s // ", unit_type=" + select case(source%unit_type) + case (FPM_UNIT_UNKNOWN) + s = s // "FPM_UNIT_UNKNOWN" + case (FPM_UNIT_PROGRAM) + s = s // "FPM_UNIT_PROGRAM" + case (FPM_UNIT_MODULE) + s = s // "FPM_UNIT_MODULE" + case (FPM_UNIT_SUBMODULE) + s = s // "FPM_UNIT_SUBMODULE" + case (FPM_UNIT_SUBPROGRAM) + s = s // "FPM_UNIT_SUBPROGRAM" + case (FPM_UNIT_CSOURCE) + s = s // "FPM_UNIT_CSOURCE" + case (FPM_UNIT_CHEADER) + s = s // "FPM_UNIT_CHEADER" + case default + s = s // "INVALID" + end select + ! type(string_t), allocatable :: modules_used(:) + s = s // ", modules_used=[" + do i = 1, size(source%modules_used) + s = s // '"' // source%modules_used(i)%s // '"' + if (i < size(source%modules_used)) s = s // ", " + end do + s = s // "]" + ! type(string_t), allocatable :: include_dependencies(:) + s = s // ", include_dependencies=[" + do i = 1, size(source%include_dependencies) + s = s // '"' // source%include_dependencies(i)%s // '"' + if (i < size(source%include_dependencies)) s = s // ", " + end do + s = s // "]" + ! type(string_t), allocatable :: link_libraries(:) + s = s // ", link_libraries=[" + do i = 1, size(source%link_libraries) + s = s // '"' // source%link_libraries(i)%s // '"' + if (i < size(source%link_libraries)) s = s // ", " + end do + s = s // "]" + ! integer(int64) :: digest + s = s // ", digest=" // str(source%digest) + !end type srcfile_t + s = s // ")" +end function info_srcfile + +function info_srcfile_short(source) result(s) + ! Prints a shortened version of srcfile_t + type(srcfile_t), intent(in) :: source + character(:), allocatable :: s + integer :: i + s = "srcfile_t(" + s = s // 'file_name="' // source%file_name // '"' + s = s // ", ...)" +end function info_srcfile_short + +function info_model(model) result(s) + type(fpm_model_t), intent(in) :: model + character(:), allocatable :: s + integer :: i + !type :: fpm_model_t + s = "fpm_model_t(" + ! character(:), allocatable :: package_name + s = s // 'package_name="' // model%package_name // '"' + ! type(srcfile_t), allocatable :: sources(:) + s = s // ", packages=[" + do i = 1, size(model%packages) + s = s // info_package(model%packages(i)) + if (i < size(model%packages)) s = s // ", " + end do + s = s // "]" + ! character(:), allocatable :: fortran_compiler + s = s // ', fortran_compiler="' // model%fortran_compiler // '"' + ! character(:), allocatable :: fortran_compile_flags + s = s // ', fortran_compile_flags="' // model%fortran_compile_flags // '"' + ! character(:), allocatable :: output_directory + s = s // ', output_directory="' // model%output_directory // '"' + ! type(string_t), allocatable :: link_libraries(:) + s = s // ", link_libraries=[" + do i = 1, size(model%link_libraries) + s = s // '"' // model%link_libraries(i)%s // '"' + if (i < size(model%link_libraries)) s = s // ", " + end do + s = s // "]" + ! type(dependency_tree_t) :: deps + ! TODO: print `dependency_tree_t` properly, which should become part of the + ! model, not imported from another file + s = s // ", deps=dependency_tree_t(...)" + !end type fpm_model_t + s = s // ")" +end function info_model + +subroutine show_model(model) + ! Prints a human readable representation of the Model + type(fpm_model_t), intent(in) :: model + print *, info_model(model) +end subroutine show_model + +end module fpm_model diff --git a/src/fpm_source_parsing.f90 b/src/fpm_source_parsing.f90 new file mode 100644 index 0000000..dd9a4c5 --- /dev/null +++ b/src/fpm_source_parsing.f90 @@ -0,0 +1,480 @@ +!># Parsing of package source files +!> +!> This module exposes two functions, `[[parse_f_source]]` and `[[parse_c_source]]`, +!> which perform a rudimentary parsing of fortran and c source files +!> in order to extract information required for module dependency tracking. +!> +!> Both functions additionally calculate and store a file digest (hash) which +!> is used by the backend ([[fpm_backend]]) to skip compilation of unmodified sources. +!> +!> Both functions return an instance of the [[srcfile_t]] type. +!> +!> For more information, please read the documentation for each function: +!> +!> - `[[parse_f_source]]` +!> - `[[parse_c_source]]` +!> +module fpm_source_parsing +use fpm_error, only: error_t, file_parse_error, fatal_error +use fpm_strings, only: string_t, string_cat, len_trim, split, lower, str_ends_with, fnv_1a +use fpm_model, only: srcfile_t, & + FPM_UNIT_UNKNOWN, FPM_UNIT_PROGRAM, FPM_UNIT_MODULE, & + FPM_UNIT_SUBMODULE, FPM_UNIT_SUBPROGRAM, & + FPM_UNIT_CSOURCE, FPM_UNIT_CHEADER, FPM_SCOPE_UNKNOWN, & + FPM_SCOPE_LIB, FPM_SCOPE_DEP, FPM_SCOPE_APP, FPM_SCOPE_TEST +use fpm_filesystem, only: read_lines +implicit none + +private +public :: parse_f_source, parse_c_source + +character(15), parameter :: INTRINSIC_MODULE_NAMES(*) = & + ['iso_c_binding ', & + 'iso_fortran_env', & + 'ieee_arithmetic', & + 'ieee_exceptions', & + 'ieee_features ', & + 'omp_lib '] + +contains + +!> Parsing of free-form fortran source files +!> +!> The following statements are recognised and parsed: +!> +!> - `Module`/`submodule`/`program` declaration +!> - Module `use` statement +!> - `include` statement +!> +!> @note Intrinsic modules used by sources are not listed in +!> the `modules_used` field of source objects. +!> +!> @note Submodules are treated as normal modules which `use` their +!> corresponding parent modules. +!> +!>### Parsing limitations +!> +!> __Statements must not continued onto another line +!> except for an `only:` list in the `use` statement.__ +!> +!> This is supported: +!> +!>```fortran +!> use my_module, only: & +!> my_var, my_function, my_subroutine +!>``` +!> +!> This is __NOT supported:__ +!> +!>```fortran +!> use & +!> my_module +!>``` +!> +function parse_f_source(f_filename,error) result(f_source) + character(*), intent(in) :: f_filename + type(srcfile_t) :: f_source + type(error_t), allocatable, intent(out) :: error + + 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) + + ! Ignore empty files, returned as FPM_UNIT_UNKNOW + if (len_trim(file_lines) < 1) return + + f_source%digest = fnv_1a(file_lines) + + 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 + ic = index(adjustl(lower(file_lines(i)%s)),'include') + if ( ic == 1 ) then + ic = index(lower(file_lines(i)%s),'include') + if (index(adjustl(file_lines(i)%s(ic+7:)),'"') == 1 .or. & + index(adjustl(file_lines(i)%s(ic+7:)),"'") == 1 ) then + + + n_include = n_include + 1 + + if (pass == 2) then + f_source%include_dependencies(n_include)%s = & + & split_n(file_lines(i)%s,n=2,delims="'"//'"',stat=stat) + if (stat /= 0) then + call file_parse_error(error,f_filename, & + 'unable to find include file name',i, & + file_lines(i)%s) + return + end if + end if + 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' .or. & + scan(mod_name,'=(')>0 ) then + ! Ignore these cases: + ! module procedure * + ! module function * + ! module subroutine * + ! module =* + ! module (i) + 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, index(file_lines(i)%s,mod_name)) + return + end if + + n_mod = n_mod + 1 + + if (pass == 2) then + f_source%modules_provided(n_mod) = string_t(mod_name) + end if + + 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 + + mod_name = split_n(file_lines(i)%s,n=3,delims='()',stat=stat) + if (stat /= 0) then + call file_parse_error(error,f_filename, & + 'unable to get submodule name',i, & + file_lines(i)%s) + return + end if + if (.not.validate_name(mod_name)) then + call file_parse_error(error,f_filename, & + 'empty or invalid name for submodule',i, & + file_lines(i)%s, index(file_lines(i)%s,mod_name)) + return + end if + + n_mod = n_mod + 1 + + 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 + + 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 + + f_source%modules_used(n_use)%s = lower(temp_string) + + f_source%modules_provided(n_mod)%s = lower(mod_name) + + end if + + end if + + ! Detect if contains a program + ! (no modules allowed after program def) + if (index(adjustl(lower(file_lines(i)%s)),'program ') == 1) then + + temp_string = lower(split_n(file_lines(i)%s,n=2,delims=' ',stat=stat)) + if (stat == 0) then + + if (scan(temp_string,'=(')>0 ) then + ! Ignore: + ! program =* + ! program (i) =* + cycle + end if + + end if + + 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 + + +!> Parsing of c source files +!> +!> The following statements are recognised and parsed: +!> +!> - `#include` preprocessor statement +!> +function parse_c_source(c_filename,error) result(c_source) + character(*), intent(in) :: c_filename + type(srcfile_t) :: c_source + type(error_t), allocatable, intent(out) :: error + + 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) + + ! Ignore empty files, returned as FPM_UNIT_UNKNOW + if (len_trim(file_lines) < 1) then + c_source%unit_type = FPM_UNIT_UNKNOWN + return + end if + + c_source%digest = fnv_1a(file_lines) + + do pass = 1,2 + n_include = 0 + file_loop: do i=1,size(file_lines) + + ! Process 'INCLUDE' statements + if (index(adjustl(lower(file_lines(i)%s)),'#include') == 1 .and. & + index(file_lines(i)%s,'"') > 0) then + + 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 + +!> 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 +!> +function split_n(string,delims,n,stat) result(substring) + + 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(adjustl(string_parts(i))) + stat = 0 + +end function split_n + +end module fpm_source_parsing diff --git a/src/fpm_sources.f90 b/src/fpm_sources.f90 new file mode 100644 index 0000000..c781535 --- /dev/null +++ b/src/fpm_sources.f90 @@ -0,0 +1,220 @@ +!># Discovery of sources +!> +!> This module implements subroutines for building a list of +!> `[[srcfile_t]]` objects by looking for source files in the filesystem. +!> +module fpm_sources +use fpm_error, only: error_t +use fpm_model, only: srcfile_t, FPM_UNIT_PROGRAM +use fpm_filesystem, only: basename, canon_path, dirname, join_path, list_files +use fpm_strings, only: lower, str_ends_with, string_t, operator(.in.) +use fpm_source_parsing, only: parse_f_source, parse_c_source +use fpm_manifest_executable, only: executable_config_t +implicit none + +private +public :: add_sources_from_dir, add_executable_sources + +character(4), parameter :: fortran_suffixes(2) = [".f90", & + ".f "] + +contains + +!> Wrapper to source parsing routines. +!> Selects parsing routine based on source file name extension +function parse_source(source_file_path,error) result(source) + character(*), intent(in) :: source_file_path + type(error_t), allocatable, intent(out) :: error + type(srcfile_t) :: source + + if (str_ends_with(lower(source_file_path), fortran_suffixes)) then + + source = parse_f_source(source_file_path, error) + + if (source%unit_type == FPM_UNIT_PROGRAM) then + source%exe_name = basename(source_file_path,suffix=.false.) + end if + + else if (str_ends_with(lower(source_file_path), [".c", ".h"])) then + + source = parse_c_source(source_file_path,error) + + end if + + if (allocated(error)) then + return + end if + +end function parse_source + +!> Add to `sources` by looking for source files in `directory` +subroutine add_sources_from_dir(sources,directory,scope,with_executables,recurse,error) + !> List of `[[srcfile_t]]` objects to append to. Allocated if not allocated + type(srcfile_t), allocatable, intent(inout), target :: sources(:) + !> Directory in which to search for source files + character(*), intent(in) :: directory + !> Scope to apply to the discovered sources, see [[fpm_model]] for enumeration + integer, intent(in) :: scope + !> Executable sources (fortran `program`s) are ignored unless `with_executables=.true.` + logical, intent(in), optional :: with_executables + !> Whether to recursively search subdirectories, default is `.true.` + logical, intent(in), optional :: recurse + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: i + logical, allocatable :: is_source(:), exclude_source(:) + type(string_t), allocatable :: file_names(:) + type(string_t), allocatable :: src_file_names(:) + type(string_t), allocatable :: existing_src_files(:) + type(srcfile_t), allocatable :: dir_sources(:) + + ! Scan directory for sources + call list_files(directory, file_names,recurse=merge(recurse,.true.,present(recurse))) + + if (allocated(sources)) then + allocate(existing_src_files(size(sources))) + do i=1,size(sources) + existing_src_files(i)%s = canon_path(sources(i)%file_name) + end do + else + allocate(existing_src_files(0)) + end if + + is_source = [(.not.(canon_path(file_names(i)%s) .in. existing_src_files) .and. & + (str_ends_with(lower(file_names(i)%s), fortran_suffixes) .or. & + str_ends_with(lower(file_names(i)%s),[".c",".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) + + dir_sources(i) = parse_source(src_file_names(i)%s,error) + if (allocated(error)) return + + dir_sources(i)%unit_scope = scope + + ! 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. + + 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 + + +!> Add to `sources` using the executable and test entries in the manifest and +!> applies any executable-specific overrides such as `executable%name`. +!> Adds all sources (including modules) from each `executable%source_dir` +subroutine add_executable_sources(sources,executables,scope,auto_discover,error) + !> List of `[[srcfile_t]]` objects to append to. Allocated if not allocated + type(srcfile_t), allocatable, intent(inout), target :: sources(:) + !> List of `[[executable_config_t]]` entries from manifest + class(executable_config_t), intent(in) :: executables(:) + !> Scope to apply to the discovered sources: either `FPM_SCOPE_APP` or `FPM_SCOPE_TEST`, see [[fpm_model]] + integer, intent(in) :: scope + !> If `.false.` only executables and tests specified in the manifest are added to `sources` + logical, intent(in) :: auto_discover + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: i, j + + type(string_t), allocatable :: exe_dirs(:) + type(srcfile_t) :: exe_source + + call get_executable_source_dirs(exe_dirs,executables) + + do i=1,size(exe_dirs) + call add_sources_from_dir(sources,exe_dirs(i)%s, scope, & + with_executables=auto_discover, recurse=.false., error=error) + + if (allocated(error)) then + return + end if + end do + + exe_loop: do i=1,size(executables) + + ! Check if executable already discovered automatically + ! and apply any overrides + do j=1,size(sources) + + if (basename(sources(j)%file_name,suffix=.true.) == executables(i)%main .and.& + canon_path(dirname(sources(j)%file_name)) == & + canon_path(executables(i)%source_dir) ) then + + sources(j)%exe_name = executables(i)%name + if (allocated(executables(i)%link)) then + sources(j)%link_libraries = executables(i)%link + end if + cycle exe_loop + + end if + + end do + + ! Add if not already discovered (auto_discovery off) + exe_source = parse_source(join_path(executables(i)%source_dir,executables(i)%main),error) + exe_source%exe_name = executables(i)%name + if (allocated(executables(i)%link)) then + exe_source%link_libraries = executables(i)%link + end if + exe_source%unit_scope = scope + + if (allocated(error)) return + + if (.not.allocated(sources)) then + sources = [exe_source] + else + sources = [sources, exe_source] + end if + + end do exe_loop + +end subroutine add_executable_sources + +!> Build a list of unique source directories +!> from executables specified in manifest +subroutine get_executable_source_dirs(exe_dirs,executables) + type(string_t), allocatable, intent(inout) :: exe_dirs(:) + class(executable_config_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 + +end module fpm_sources diff --git a/src/fpm_strings.f90 b/src/fpm_strings.f90 new file mode 100644 index 0000000..3d7d7b1 --- /dev/null +++ b/src/fpm_strings.f90 @@ -0,0 +1,924 @@ +!> This module defines general procedures for **string operations** for both CHARACTER and +!! TYPE(STRING_T) variables +! +!>## general routines for performing __string operations__ +!! +!!### Types +!! - **TYPE(STRING_T)** define a type to contain strings of variable length +!!### Type Conversions +!! - [[F_STRING]] return Fortran **CHARACTER** variable when given a C-like array of +!! single characters terminated with a C_NULL_CHAR **CHARACTER** +!! - [[STR]] Converts **INTEGER** or** LOGICAL** to **CHARACTER** string +!!### Case +!! - [[LOWER]] Changes a string to lowercase over optional specified column range +!!### Parsing and joining +!! - [[SPLIT]] parse string on delimiter characters and store tokens into an allocatable array +!! - [[STRING_CAT]] Concatenate an array of **type(string_t)** into a single **CHARACTER** variable +!! - [[JOIN]] append an array of **CHARACTER** variables into a single **CHARACTER** variable +!!### Testing +!! - [[STR_ENDS_WITH]] test if a **CHARACTER** string or array ends with a specified suffix +!! - [[STRING_ARRAY_CONTAINS]] Check if array of **TYPE(STRING_T)** matches a particular **CHARACTER** string +!! - **OPERATOR(.IN.)** Check if array of **TYPE(STRING_T)** matches a particular **CHARACTER** string +!! - [[GLOB]] function compares text strings, one of which can have wildcards ('*' or '?'). +!!### Miscellaneous +!! - [[LEN_TRIM]] Determine total trimmed length of **STRING_T** array +!! - [[FNV_1A]] Hash a **CHARACTER(*)** string of default kind or a **TYPE(STRING_T)** array +!! - [[REPLACE]] Returns string with characters in charset replaced with target_char. +!! - [[RESIZE]] increase the size of a **TYPE(STRING_T)** array by N elements +!! + +module fpm_strings +use iso_fortran_env, only: int64 +implicit none + +private +public :: f_string, lower, split, str_ends_with, string_t +public :: string_array_contains, string_cat, len_trim, operator(.in.), fnv_1a +public :: replace, resize, str, join, glob + +type string_t + character(len=:), allocatable :: s +end type + +interface len_trim + module procedure :: string_len_trim +end interface len_trim + +interface resize + module procedure :: resize_string +end interface + +interface operator(.in.) + module procedure string_array_contains +end interface + +interface fnv_1a + procedure :: fnv_1a_char + procedure :: fnv_1a_string_t +end interface fnv_1a + +interface str_ends_with + procedure :: str_ends_with_str + procedure :: str_ends_with_any +end interface str_ends_with + +interface str + module procedure str_int, str_int64, str_logical +end interface + +interface string_t + module procedure new_string_t +end interface string_t + +contains + +!> test if a CHARACTER string ends with a specified suffix +pure logical function str_ends_with_str(s, e) result(r) + character(*), intent(in) :: s, e + integer :: n1, n2 + n1 = len(s)-len(e)+1 + n2 = len(s) + if (n1 < 1) then + r = .false. + else + r = (s(n1:n2) == e) + end if +end function str_ends_with_str + +!> test if a CHARACTER string ends with any of an array of suffixs +pure logical function str_ends_with_any(s, e) result(r) + character(*), intent(in) :: s + character(*), intent(in) :: e(:) + + integer :: i + + r = .true. + do i=1,size(e) + + if (str_ends_with(s,trim(e(i)))) return + + end do + r = .false. + +end function str_ends_with_any + +!> return Fortran character variable when given a C-like array of +!! single characters terminated with a C_NULL_CHAR character +function f_string(c_string) + 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 + + +!> Hash a character(*) string of default kind +pure function fnv_1a_char(input, seed) result(hash) + character(*), intent(in) :: input + integer(int64), intent(in), optional :: seed + integer(int64) :: hash + + integer :: i + integer(int64), parameter :: FNV_OFFSET_32 = 2166136261_int64 + integer(int64), parameter :: FNV_PRIME_32 = 16777619_int64 + + if (present(seed)) then + hash = seed + else + hash = FNV_OFFSET_32 + end if + + do i=1,len(input) + hash = ieor(hash,iachar(input(i:i),int64)) * FNV_PRIME_32 + end do + +end function fnv_1a_char + + +!> Hash a string_t array of default kind +pure function fnv_1a_string_t(input, seed) result(hash) + type(string_t), intent(in) :: input(:) + integer(int64), intent(in), optional :: seed + integer(int64) :: hash + + integer :: i + + hash = fnv_1a(input(1)%s,seed) + + do i=2,size(input) + hash = fnv_1a(input(i)%s,hash) + end do + +end function fnv_1a_string_t + + + !>Author: John S. Urban + !!License: Public Domain + !! Changes a string to lowercase over optional specified column range +elemental pure function lower(str,begin,end) result (string) + + 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 + +!> Helper function to generate a new string_t instance +!> (Required due to the allocatable component) +function new_string_t(s) result(string) + character(*), intent(in) :: s + type(string_t) :: string + + string%s = s + +end function new_string_t + +!> Check if array of TYPE(STRING_T) matches a particular CHARACTER string +!! +logical function string_array_contains(search_string,array) + 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 + +!> Concatenate an array of type(string_t) into +!> a single CHARACTER variable +function string_cat(strings,delim) result(cat) + type(string_t), intent(in) :: strings(:) + character(*), intent(in), optional :: delim + character(:), allocatable :: cat + + integer :: i + character(:), allocatable :: delim_str + + if (size(strings) < 1) then + cat = '' + return + end if + + if (present(delim)) then + delim_str = delim + else + delim_str = '' + end if + + cat = strings(1)%s + do i=2,size(strings) + + cat = cat//delim_str//strings(i)%s + + end do + +end function string_cat + +!> Determine total trimmed length of `string_t` array +pure function string_len_trim(strings) result(n) + type(string_t), intent(in) :: strings(:) + integer :: i, n + + n = 0 + do i=1,size(strings) + n = n + len_trim(strings(i)%s) + end do + +end function string_len_trim + +!>Author: John S. Urban +!!License: Public Domain +!! parse string on delimiter characters and store tokens into an allocatable array +subroutine split(input_line,array,delimiters,order,nulls) + !! given a line of structure " par1 par2 par3 ... parn " store each par(n) into a separate variable in array. + !! + !! * by default adjacent delimiters in the input string do not create an empty string in the output array + !! * no quoting of delimiters is supported + character(len=*),intent(in) :: input_line !! input string to tokenize + character(len=*),optional,intent(in) :: delimiters !! list of delimiter characters + character(len=*),optional,intent(in) :: order !! order of output array sequential|[reverse|right] + character(len=*),optional,intent(in) :: nulls !! return strings composed of delimiters or not ignore|return|ignoreend + character(len=:),allocatable,intent(out) :: array(:) !! output array of tokens + + 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 + +!> Returns string with characters in charset replaced with target_char. +pure function replace(string, charset, target_char) result(res) + character(*), intent(in) :: string + character, intent(in) :: charset(:), target_char + character(len(string)) :: res + integer :: n + res = string + do n = 1, len(string) + if (any(string(n:n) == charset)) then + res(n:n) = target_char + end if + end do +end function replace + +!> increase the size of a TYPE(STRING_T) array by N elements +subroutine resize_string(list, n) + !> Instance of the array to be resized + type(string_t), allocatable, intent(inout) :: list(:) + !> Dimension of the final array size + integer, intent(in), optional :: n + + type(string_t), allocatable :: tmp(:) + integer :: this_size, new_size, i + integer, parameter :: initial_size = 16 + + if (allocated(list)) then + this_size = size(list, 1) + call move_alloc(list, tmp) + else + this_size = initial_size + end if + + if (present(n)) then + new_size = n + else + new_size = this_size + this_size/2 + 1 + end if + + allocate(list(new_size)) + + if (allocated(tmp)) then + this_size = min(size(tmp, 1), size(list, 1)) + do i = 1, this_size + call move_alloc(tmp(i)%s, list(i)%s) + end do + deallocate(tmp) + end if + +end subroutine resize_string + +!>AUTHOR: John S. Urban +!!LICENSE: Public Domain +!> +!!##NAME +!! join(3f) - [M_strings:EDITING] append CHARACTER variable array into +!! a single CHARACTER variable with specified separator +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! pure function join(str,sep,trm,left,right,start,end) result (string) +!! +!! character(len=*),intent(in) :: str(:) +!! character(len=*),intent(in),optional :: sep +!! logical,intent(in),optional :: trm +!! character(len=*),intent(in),optional :: right +!! character(len=*),intent(in),optional :: left +!! character(len=*),intent(in),optional :: start +!! character(len=*),intent(in),optional :: end +!! character(len=:),allocatable :: string +!! +!!##DESCRIPTION +!! JOIN(3f) appends the elements of a CHARACTER array into a single +!! CHARACTER variable, with elements 1 to N joined from left to right. +!! By default each element is trimmed of trailing spaces and the +!! default separator is a null string. +!! +!!##OPTIONS +!! STR(:) array of CHARACTER variables to be joined +!! SEP separator string to place between each variable. defaults +!! to a null string. +!! LEFT string to place at left of each element +!! RIGHT string to place at right of each element +!! START prefix string +!! END suffix string +!! TRM option to trim each element of STR of trailing +!! spaces. Defaults to .TRUE. +!! +!!##RESULT +!! STRING CHARACTER variable composed of all of the elements of STR() +!! appended together with the optional separator SEP placed +!! between the elements. +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_join +!! use M_strings, only: join +!! implicit none +!! character(len=:),allocatable :: s(:) +!! character(len=:),allocatable :: out +!! integer :: i +!! s=[character(len=10) :: 'United',' we',' stand,', & +!! & ' divided',' we fall.'] +!! out=join(s) +!! write(*,'(a)') out +!! write(*,'(a)') join(s,trm=.false.) +!! write(*,'(a)') (join(s,trm=.false.,sep='|'),i=1,3) +!! write(*,'(a)') join(s,sep='<>') +!! write(*,'(a)') join(s,sep=';',left='[',right=']') +!! write(*,'(a)') join(s,left='[',right=']') +!! write(*,'(a)') join(s,left='>>') +!! end program demo_join +!! +!! Expected output: +!! +!! United we stand, divided we fall. +!! United we stand, divided we fall. +!! United | we | stand, | divided | we fall. +!! United | we | stand, | divided | we fall. +!! United | we | stand, | divided | we fall. +!! United<> we<> stand,<> divided<> we fall. +!! [United];[ we];[ stand,];[ divided];[ we fall.] +!! [United][ we][ stand,][ divided][ we fall.] +!! >>United>> we>> stand,>> divided>> we fall. +pure function join(str,sep,trm,left,right,start,end) result (string) + +! @(#)M_strings::join(3f): merge string array into a single CHARACTER value adding specified separators, caps, prefix and suffix + +character(len=*),intent(in) :: str(:) +character(len=*),intent(in),optional :: sep, right, left, start, end +logical,intent(in),optional :: trm +character(len=:),allocatable :: sep_local, left_local, right_local +character(len=:),allocatable :: string +logical :: trm_local +integer :: i + if(present(sep))then ; sep_local=sep ; else ; sep_local='' ; endif + if(present(trm))then ; trm_local=trm ; else ; trm_local=.true. ; endif + if(present(left))then ; left_local=left ; else ; left_local='' ; endif + if(present(right))then ; right_local=right ; else ; right_local='' ; endif + string='' + if(size(str).eq.0)then + string=string//left_local//right_local + else + do i = 1,size(str)-1 + if(trm_local)then + string=string//left_local//trim(str(i))//right_local//sep_local + else + string=string//left_local//str(i)//right_local//sep_local + endif + enddo + if(trm_local)then + string=string//left_local//trim(str(i))//right_local + else + string=string//left_local//str(i)//right_local + endif + endif + if(present(start))string=start//string + if(present(end))string=string//end +end function join + +!>##AUTHOR John S. Urban +!!##LICENSE Public Domain +!!## NAME +!! glob(3f) - [fpm_strings:COMPARE] compare given string for match to +!! pattern which may contain wildcard characters +!! (LICENSE:PD) +!! +!!## SYNOPSIS +!! +!! logical function glob(string, pattern ) +!! +!! character(len=*),intent(in) :: string +!! character(len=*),intent(in) :: pattern +!! +!!## DESCRIPTION +!! glob(3f) compares given STRING for match to PATTERN which may +!! contain wildcard characters. +!! +!! In this version to get a match the entire string must be described +!! by PATTERN. Trailing whitespace is significant, so trim the input +!! string to have trailing whitespace ignored. +!! +!!## OPTIONS +!! string the input string to test to see if it contains the pattern. +!! pattern the following simple globbing options are available +!! +!! o "?" matching any one character +!! o "*" matching zero or more characters. +!! Do NOT use adjacent asterisks. +!! o Both strings may have trailing spaces which +!! are ignored. +!! o There is no escape character, so matching strings with +!! literal question mark and asterisk is problematic. +!! +!!## EXAMPLES +!! +!! Example program +!! +!! program demo_glob +!! implicit none +!! ! This main() routine passes a bunch of test strings +!! ! into the above code. In performance comparison mode, +!! ! it does that over and over. Otherwise, it does it just +!! ! once. Either way, it outputs a passed/failed result. +!! ! +!! integer :: nReps +!! logical :: allpassed +!! integer :: i +!! allpassed = .true. +!! +!! nReps = 10000 +!! ! Can choose as many repetitions as you're expecting +!! ! in the real world. +!! nReps = 1 +!! +!! do i=1,nReps +!! ! Cases with repeating character sequences. +!! allpassed=allpassed .and. test("a*abab", "a*b", .true.) +!! !!cycle +!! allpassed=allpassed .and. test("ab", "*?", .true.) +!! allpassed=allpassed .and. test("abc", "*?", .true.) +!! allpassed=allpassed .and. test("abcccd", "*ccd", .true.) +!! allpassed=allpassed .and. test("bLah", "bLaH", .false.) +!! allpassed=allpassed .and. test("mississippi", "*sip*", .true.) +!! allpassed=allpassed .and. & +!! & test("xxxx*zzzzzzzzy*f", "xxx*zzy*f", .true.) +!! allpassed=allpassed .and. & +!! & test("xxxx*zzzzzzzzy*f", "xxxx*zzy*fffff", .false.) +!! allpassed=allpassed .and. & +!! & test("mississipissippi", "*issip*ss*", .true.) +!! allpassed=allpassed .and. & +!! & test("xxxxzzzzzzzzyf", "xxxx*zzy*fffff", .false.) +!! allpassed=allpassed .and. & +!! & test("xxxxzzzzzzzzyf", "xxxx*zzy*f", .true.) +!! allpassed=allpassed .and. test("xyxyxyzyxyz", "xy*z*xyz", .true.) +!! allpassed=allpassed .and. test("xyxyxyxyz", "xy*xyz", .true.) +!! allpassed=allpassed .and. test("mississippi", "mi*sip*", .true.) +!! allpassed=allpassed .and. test("ababac", "*abac*", .true.) +!! allpassed=allpassed .and. test("aaazz", "a*zz*", .true.) +!! allpassed=allpassed .and. test("a12b12", "*12*23", .false.) +!! allpassed=allpassed .and. test("a12b12", "a12b", .false.) +!! allpassed=allpassed .and. test("a12b12", "*12*12*", .true.) +!! +!! ! Additional cases where the '*' char appears in the tame string. +!! allpassed=allpassed .and. test("*", "*", .true.) +!! allpassed=allpassed .and. test("a*r", "a*", .true.) +!! allpassed=allpassed .and. test("a*ar", "a*aar", .false.) +!! +!! ! More double wildcard scenarios. +!! allpassed=allpassed .and. test("XYXYXYZYXYz", "XY*Z*XYz", .true.) +!! allpassed=allpassed .and. test("missisSIPpi", "*SIP*", .true.) +!! allpassed=allpassed .and. test("mississipPI", "*issip*PI", .true.) +!! allpassed=allpassed .and. test("xyxyxyxyz", "xy*xyz", .true.) +!! allpassed=allpassed .and. test("miSsissippi", "mi*sip*", .true.) +!! allpassed=allpassed .and. test("miSsissippi", "mi*Sip*", .false.) +!! allpassed=allpassed .and. test("abAbac", "*Abac*", .true.) +!! allpassed=allpassed .and. test("aAazz", "a*zz*", .true.) +!! allpassed=allpassed .and. test("A12b12", "*12*23", .false.) +!! allpassed=allpassed .and. test("a12B12", "*12*12*", .true.) +!! allpassed=allpassed .and. test("oWn", "*oWn*", .true.) +!! +!! ! Completely tame (no wildcards) cases. +!! allpassed=allpassed .and. test("bLah", "bLah", .true.) +!! +!! ! Simple mixed wildcard tests suggested by IBMer Marlin Deckert. +!! allpassed=allpassed .and. test("a", "*?", .true.) +!! +!! ! More mixed wildcard tests including coverage for false positives. +!! allpassed=allpassed .and. test("a", "??", .false.) +!! allpassed=allpassed .and. test("ab", "?*?", .true.) +!! allpassed=allpassed .and. test("ab", "*?*?*", .true.) +!! allpassed=allpassed .and. test("abc", "?**?*?", .true.) +!! allpassed=allpassed .and. test("abc", "?**?*&?", .false.) +!! allpassed=allpassed .and. test("abcd", "?b*??", .true.) +!! allpassed=allpassed .and. test("abcd", "?a*??", .false.) +!! allpassed=allpassed .and. test("abcd", "?**?c?", .true.) +!! allpassed=allpassed .and. test("abcd", "?**?d?", .false.) +!! allpassed=allpassed .and. test("abcde", "?*b*?*d*?", .true.) +!! +!! ! Single-character-match cases. +!! allpassed=allpassed .and. test("bLah", "bL?h", .true.) +!! allpassed=allpassed .and. test("bLaaa", "bLa?", .false.) +!! allpassed=allpassed .and. test("bLah", "bLa?", .true.) +!! allpassed=allpassed .and. test("bLaH", "?Lah", .false.) +!! allpassed=allpassed .and. test("bLaH", "?LaH", .true.) +!! +!! ! Many-wildcard scenarios. +!! allpassed=allpassed .and. test(& +!! &"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa& +!! &aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaab",& +!! &"a*a*a*a*a*a*aa*aaa*a*a*b",& +!! &.true.) +!! allpassed=allpassed .and. test(& +!! &"abababababababababababababababababababaacacacacacacac& +!! &adaeafagahaiajakalaaaaaaaaaaaaaaaaaffafagaagggagaaaaaaaab",& +!! &"*a*b*ba*ca*a*aa*aaa*fa*ga*b*",& +!! &.true.) +!! allpassed=allpassed .and. test(& +!! &"abababababababababababababababababababaacacacacacaca& +!! &cadaeafagahaiajakalaaaaaaaaaaaaaaaaaffafagaagggagaaaaaaaab",& +!! &"*a*b*ba*ca*a*x*aaa*fa*ga*b*",& +!! &.false.) +!! allpassed=allpassed .and. test(& +!! &"abababababababababababababababababababaacacacacacacacad& +!! &aeafagahaiajakalaaaaaaaaaaaaaaaaaffafagaagggagaaaaaaaab",& +!! &"*a*b*ba*ca*aaaa*fa*ga*gggg*b*",& +!! &.false.) +!! allpassed=allpassed .and. test(& +!! &"abababababababababababababababababababaacacacacacacacad& +!! &aeafagahaiajakalaaaaaaaaaaaaaaaaaffafagaagggagaaaaaaaab",& +!! &"*a*b*ba*ca*aaaa*fa*ga*ggg*b*",& +!! &.true.) +!! allpassed=allpassed .and. test("aaabbaabbaab", "*aabbaa*a*", .true.) +!! allpassed=allpassed .and. & +!! test("a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*",& +!! &"a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*", .true.) +!! allpassed=allpassed .and. test("aaaaaaaaaaaaaaaaa",& +!! &"*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*", .true.) +!! allpassed=allpassed .and. test("aaaaaaaaaaaaaaaa",& +!! &"*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*", .false.) +!! allpassed=allpassed .and. test(& +!! &"abc*abcd*abcde*abcdef*abcdefg*abcdefgh*abcdefghi*abcdefghij& +!! &*abcdefghijk*abcdefghijkl*abcdefghijklm*abcdefghijklmn",& +!! & "abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abc& +!! &*abc*abc*abc*",& +!! &.false.) +!! allpassed=allpassed .and. test(& +!! &"abc*abcd*abcde*abcdef*abcdefg*abcdefgh*abcdefghi*abcdefghij& +!! &*abcdefghijk*abcdefghijkl*abcdefghijklm*abcdefghijklmn",& +!! &"abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*",& +!! &.true.) +!! allpassed=allpassed .and. test("abc*abcd*abcd*abc*abcd",& +!! &"abc*abc*abc*abc*abc", .false.) +!! allpassed=allpassed .and. test( "abc*abcd*abcd*abc*abcd*abcd& +!! &*abc*abcd*abc*abc*abcd", & +!! &"abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abcd",& +!! &.true.) +!! allpassed=allpassed .and. test("abc",& +!! &"********a********b********c********", .true.) +!! allpassed=allpassed .and.& +!! &test("********a********b********c********", "abc", .false.) +!! allpassed=allpassed .and. & +!! &test("abc", "********a********b********b********", .false.) +!! allpassed=allpassed .and. test("*abc*", "***a*b*c***", .true.) +!! +!! ! A case-insensitive algorithm test. +!! ! allpassed=allpassed .and. test("mississippi", "*issip*PI", .true.) +!! enddo +!! +!! if (allpassed)then +!! write(*,'(a)')"Passed",nReps +!! else +!! write(*,'(a)')"Failed" +!! endif +!! contains +!! ! This is a test program for wildcard matching routines. +!! ! It can be used either to test a single routine for correctness, +!! ! or to compare the timings of two (or more) different wildcard +!! ! matching routines. +!! ! +!! function test(tame, wild, bExpectedResult) result(bpassed) +!! use fpm_strings, only : glob +!! character(len=*) :: tame +!! character(len=*) :: wild +!! logical :: bExpectedResult +!! logical :: bResult +!! logical :: bPassed +!! bResult = .true. ! We'll do "&=" cumulative checking. +!! bPassed = .false. ! Assume the worst. +!! write(*,*)repeat('=',79) +!! bResult = glob(tame, wild) ! Call a wildcard matching routine. +!! +!! ! To assist correctness checking, output the two strings in any +!! ! failing scenarios. +!! if (bExpectedResult .eqv. bResult) then +!! bPassed = .true. +!! if(nReps == 1) write(*,*)"Passed match on ",tame," vs. ", wild +!! else +!! if(nReps == 1) write(*,*)"Failed match on ",tame," vs. ", wild +!! endif +!! +!! end function test +!! end program demo_glob +!! +!! Expected output +!! +!! +!!## REFERENCE +!! The article "Matching Wildcards: An Empirical Way to Tame an Algorithm" +!! in Dr Dobb's Journal, By Kirk J. Krauss, October 07, 2014 +!! +function glob(tame,wild) + +! @(#)fpm_strings::glob(3f): function compares text strings, one of which can have wildcards ('*' or '?'). + +logical :: glob !! result of test +character(len=*) :: tame !! A string without wildcards to compare to the globbing expression +character(len=*) :: wild !! A (potentially) corresponding string with wildcards +character(len=len(tame)+1) :: tametext +character(len=len(wild)+1) :: wildtext +character(len=1),parameter :: NULL=char(0) +integer :: wlen +integer :: ti, wi +integer :: i +character(len=:),allocatable :: tbookmark, wbookmark +! These two values are set when we observe a wildcard character. They +! represent the locations, in the two strings, from which we start once we've observed it. + tametext=tame//NULL + wildtext=wild//NULL + tbookmark = NULL + wbookmark = NULL + wlen=len(wild) + wi=1 + ti=1 + do ! Walk the text strings one character at a time. + if(wildtext(wi:wi) == '*')then ! How do you match a unique text string? + do i=wi,wlen ! Easy: unique up on it! + if(wildtext(wi:wi).eq.'*')then + wi=wi+1 + else + exit + endif + enddo + if(wildtext(wi:wi).eq.NULL) then ! "x" matches "*" + glob=.true. + return + endif + if(wildtext(wi:wi) .ne. '?') then + ! Fast-forward to next possible match. + do while (tametext(ti:ti) .ne. wildtext(wi:wi)) + ti=ti+1 + if (tametext(ti:ti).eq.NULL)then + glob=.false. + return ! "x" doesn't match "*y*" + endif + enddo + endif + wbookmark = wildtext(wi:) + tbookmark = tametext(ti:) + elseif(tametext(ti:ti) .ne. wildtext(wi:wi) .and. wildtext(wi:wi) .ne. '?') then + ! Got a non-match. If we've set our bookmarks, back up to one or both of them and retry. + if(wbookmark.ne.NULL) then + if(wildtext(wi:).ne. wbookmark) then + wildtext = wbookmark; + wlen=len_trim(wbookmark) + wi=1 + ! Don't go this far back again. + if (tametext(ti:ti) .ne. wildtext(wi:wi)) then + tbookmark=tbookmark(2:) + tametext = tbookmark + ti=1 + cycle ! "xy" matches "*y" + else + wi=wi+1 + endif + endif + if (tametext(ti:ti).ne.NULL) then + ti=ti+1 + cycle ! "mississippi" matches "*sip*" + endif + endif + glob=.false. + return ! "xy" doesn't match "x" + endif + ti=ti+1 + wi=wi+1 + if (tametext(ti:ti).eq.NULL) then ! How do you match a tame text string? + if(wildtext(wi:wi).ne.NULL)then + do while (wildtext(wi:wi) == '*') ! The tame way: unique up on it! + wi=wi+1 ! "x" matches "x*" + if(wildtext(wi:wi).eq.NULL)exit + enddo + endif + if (wildtext(wi:wi).eq.NULL)then + glob=.true. + return ! "x" matches "x" + endif + glob=.false. + return ! "x" doesn't match "xy" + endif + enddo +end function glob + +!> Returns the length of the string representation of 'i' +pure integer function str_int_len(i) result(sz) +integer, intent(in) :: i +integer, parameter :: MAX_STR = 100 +character(MAX_STR) :: s +! If 's' is too short (MAX_STR too small), Fortran will abort with: +! "Fortran runtime error: End of record" +write(s, '(i0)') i +sz = len_trim(s) +end function + +!> Converts integer "i" to string +pure function str_int(i) result(s) +integer, intent(in) :: i +character(len=str_int_len(i)) :: s +write(s, '(i0)') i +end function + +!> Returns the length of the string representation of 'i' +pure integer function str_int64_len(i) result(sz) +integer(int64), intent(in) :: i +integer, parameter :: MAX_STR = 100 +character(MAX_STR) :: s +! If 's' is too short (MAX_STR too small), Fortran will abort with: +! "Fortran runtime error: End of record" +write(s, '(i0)') i +sz = len_trim(s) +end function + +!> Converts integer "i" to string +pure function str_int64(i) result(s) +integer(int64), intent(in) :: i +character(len=str_int64_len(i)) :: s +write(s, '(i0)') i +end function + +!> Returns the length of the string representation of 'l' +pure integer function str_logical_len(l) result(sz) +logical, intent(in) :: l +if (l) then + sz = 6 +else + sz = 7 +end if +end function + +!> Converts logical "l" to string +pure function str_logical(l) result(s) +logical, intent(in) :: l +character(len=str_logical_len(l)) :: s +if (l) then + s = ".true." +else + s = ".false." +end if +end function + +end module fpm_strings diff --git a/src/fpm_targets.f90 b/src/fpm_targets.f90 new file mode 100644 index 0000000..02bb600 --- /dev/null +++ b/src/fpm_targets.f90 @@ -0,0 +1,553 @@ +!># Build target handling +!> +!> This module handles the construction of the build target list +!> from the sources list (`[[targets_from_sources]]`), the +!> resolution of module-dependencies between build targets +!> (`[[resolve_module_dependencies]]`), and the enumeration of +!> objects required for link targets (`[[resolve_target_linking]]`). +!> +!> A build target (`[[build_target_t]]`) is a file to be generated +!> by the backend (compilation and linking). +!> +!> @note The current implementation is ignorant to the existence of +!> module files (`.mod`,`.smod`). Dependencies arising from modules +!> are based on the corresponding object files (`.o`) only. +!> +!> For more information, please read the documentation for the procedures: +!> +!> - `[[build_target_list]]` +!> - `[[resolve_module_dependencies]]` +!> +!>### Enumerations +!> +!> __Target type:__ `FPM_TARGET_*` +!> Describes the type of build target — determines backend build rules +!> +module fpm_targets +use iso_fortran_env, only: int64 +use fpm_error, only: error_t, fatal_error +use fpm_model +use fpm_environment, only: get_os_type, OS_WINDOWS +use fpm_filesystem, only: dirname, join_path, canon_path +use fpm_strings, only: string_t, operator(.in.), string_cat +implicit none + +private + +public FPM_TARGET_UNKNOWN, FPM_TARGET_EXECUTABLE, & + FPM_TARGET_ARCHIVE, FPM_TARGET_OBJECT +public build_target_t, build_target_ptr +public targets_from_sources, resolve_module_dependencies +public resolve_target_linking, add_target, add_dependency + + + +!> Target type is unknown (ignored) +integer, parameter :: FPM_TARGET_UNKNOWN = -1 +!> Target type is executable +integer, parameter :: FPM_TARGET_EXECUTABLE = 1 +!> Target type is library archive +integer, parameter :: FPM_TARGET_ARCHIVE = 2 +!> Target type is compiled object +integer, parameter :: FPM_TARGET_OBJECT = 3 + + +!> Wrapper type for constructing arrays of `[[build_target_t]]` pointers +type build_target_ptr + + type(build_target_t), pointer :: ptr => null() + +end type build_target_ptr + + +!> Type describing a generated build target +type build_target_t + + !> File path of build target object relative to cwd + character(:), allocatable :: output_file + + !> Primary source for this build target + type(srcfile_t), allocatable :: source + + !> Resolved build dependencies + type(build_target_ptr), allocatable :: dependencies(:) + + !> Target type + integer :: target_type = FPM_TARGET_UNKNOWN + + !> Native libraries to link against + type(string_t), allocatable :: link_libraries(:) + + !> Objects needed to link this target + type(string_t), allocatable :: link_objects(:) + + !> Link flags for this build target + character(:), allocatable :: link_flags + + !> Compile flags for this build target + character(:), allocatable :: compile_flags + + !> Flag set when first visited to check for circular dependencies + logical :: touched = .false. + + !> Flag set if build target is sorted for building + logical :: sorted = .false. + + !> Flag set if build target will be skipped (not built) + logical :: skip = .false. + + !> Targets in the same schedule group are guaranteed to be independent + integer :: schedule = -1 + + !> Previous source file hash + integer(int64), allocatable :: digest_cached + +end type build_target_t + + +contains + +!> High-level wrapper to generate build target information +subroutine targets_from_sources(targets,model,error) + + !> The generated list of build targets + type(build_target_ptr), intent(out), allocatable :: targets(:) + + !> The package model from which to construct the target list + type(fpm_model_t), intent(inout), target :: model + + !> Error structure + type(error_t), intent(out), allocatable :: error + + call build_target_list(targets,model) + + call resolve_module_dependencies(targets,error) + if (allocated(error)) return + + call resolve_target_linking(targets,model) + +end subroutine targets_from_sources + + +!> Constructs a list of build targets from a list of source files +!> +!>### Source-target mapping +!> +!> One compiled object target (`FPM_TARGET_OBJECT`) is generated for each +!> non-executable source file (`FPM_UNIT_MODULE`,`FPM_UNIT_SUBMODULE`, +!> `FPM_UNIT_SUBPROGRAM`,`FPM_UNIT_CSOURCE`). +!> +!> If any source file has scope `FPM_SCOPE_LIB` (*i.e.* there are library sources) +!> then the first target in the target list will be a library archive target +!> (`FPM_TARGET_ARCHIVE`). The archive target will have a dependency on every +!> compiled object target corresponding to a library source file. +!> +!> One compiled object target (`FPM_TARGET_OBJECT`) and one executable target (`FPM_TARGET_EXECUTABLE`) is +!> generated for each exectuable source file (`FPM_UNIT_PROGRAM`). The exectuble target +!> always has a dependency on the corresponding compiled object target. If there +!> is a library, then the executable target has an additional dependency on the library +!> archive target. +!> +subroutine build_target_list(targets,model) + + !> The generated list of build targets + type(build_target_ptr), intent(out), allocatable :: targets(:) + + !> The package model from which to construct the target list + type(fpm_model_t), intent(inout), target :: model + + integer :: i, j, n_source + character(:), allocatable :: xsuffix, exe_dir + type(build_target_t), pointer :: dep + logical :: with_lib + + ! Check for empty build (e.g. header-only lib) + n_source = sum([(size(model%packages(j)%sources), & + j=1,size(model%packages))]) + + if (n_source < 1) then + allocate(targets(0)) + return + end if + + if (get_os_type() == OS_WINDOWS) then + xsuffix = '.exe' + else + xsuffix = '' + end if + + with_lib = any([((model%packages(j)%sources(i)%unit_scope == FPM_SCOPE_LIB, & + i=1,size(model%packages(j)%sources)), & + j=1,size(model%packages))]) + + if (with_lib) call add_target(targets,type = FPM_TARGET_ARCHIVE,& + output_file = join_path(model%output_directory,& + model%package_name,'lib'//model%package_name//'.a')) + + do j=1,size(model%packages) + + associate(sources=>model%packages(j)%sources) + + do i=1,size(sources) + + select case (sources(i)%unit_type) + case (FPM_UNIT_MODULE,FPM_UNIT_SUBMODULE,FPM_UNIT_SUBPROGRAM,FPM_UNIT_CSOURCE) + + call add_target(targets,source = sources(i), & + type = FPM_TARGET_OBJECT,& + output_file = get_object_name(sources(i))) + + if (with_lib .and. sources(i)%unit_scope == FPM_SCOPE_LIB) then + ! Archive depends on object + call add_dependency(targets(1)%ptr, targets(size(targets))%ptr) + end if + + case (FPM_UNIT_PROGRAM) + + call add_target(targets,type = FPM_TARGET_OBJECT,& + output_file = get_object_name(sources(i)), & + source = sources(i) & + ) + + if (sources(i)%unit_scope == FPM_SCOPE_APP) then + + exe_dir = 'app' + + else if (sources(i)%unit_scope == FPM_SCOPE_EXAMPLE) then + + exe_dir = 'example' + + else + + exe_dir = 'test' + + end if + + call add_target(targets,type = FPM_TARGET_EXECUTABLE,& + link_libraries = sources(i)%link_libraries, & + output_file = join_path(model%output_directory,exe_dir, & + sources(i)%exe_name//xsuffix)) + + ! Executable depends on object + call add_dependency(targets(size(targets))%ptr, targets(size(targets)-1)%ptr) + + if (with_lib) then + ! Executable depends on library + call add_dependency(targets(size(targets))%ptr, targets(1)%ptr) + end if + + end select + + end do + + end associate + + end do + + contains + + function get_object_name(source) result(object_file) + ! Generate object target path from source name and model params + ! + ! + type(srcfile_t), intent(in) :: source + character(:), allocatable :: object_file + + integer :: i + character(1), parameter :: filesep = '/' + character(:), allocatable :: dir + + object_file = canon_path(source%file_name) + + ! Convert any remaining directory separators to underscores + i = index(object_file,filesep) + do while(i > 0) + object_file(i:i) = '_' + i = index(object_file,filesep) + end do + + object_file = join_path(model%output_directory,model%package_name,object_file)//'.o' + + end function get_object_name + +end subroutine build_target_list + + +!> Allocate a new target and append to target list +subroutine add_target(targets,type,output_file,source,link_libraries) + type(build_target_ptr), allocatable, intent(inout) :: targets(:) + integer, intent(in) :: type + character(*), intent(in) :: output_file + type(srcfile_t), intent(in), optional :: source + type(string_t), intent(in), optional :: link_libraries(:) + + integer :: i + type(build_target_ptr), allocatable :: temp(:) + type(build_target_t), pointer :: new_target + + if (.not.allocated(targets)) allocate(targets(0)) + + ! Check for duplicate outputs + do i=1,size(targets) + + if (targets(i)%ptr%output_file == output_file) then + + write(*,*) 'Error while building target list: duplicate output object "',& + output_file,'"' + if (present(source)) write(*,*) ' Source file: "',source%file_name,'"' + stop 1 + + end if + + end do + + allocate(new_target) + new_target%target_type = type + new_target%output_file = output_file + if (present(source)) new_target%source = source + if (present(link_libraries)) new_target%link_libraries = link_libraries + allocate(new_target%dependencies(0)) + + targets = [targets, build_target_ptr(new_target)] + +end subroutine add_target + + +!> Add pointer to dependeny in target%dependencies +subroutine add_dependency(target, dependency) + type(build_target_t), intent(inout) :: target + type(build_target_t) , intent(in), target :: dependency + + target%dependencies = [target%dependencies, build_target_ptr(dependency)] + +end subroutine add_dependency + + +!> Add dependencies to source-based targets (`FPM_TARGET_OBJECT`) +!> based on any modules used by the corresponding source file. +!> +!>### Source file scoping +!> +!> Source files are assigned a scope of either `FPM_SCOPE_LIB`, +!> `FPM_SCOPE_APP` or `FPM_SCOPE_TEST`. The scope controls which +!> modules may be used by the source file: +!> +!> - Library sources (`FPM_SCOPE_LIB`) may only use modules +!> also with library scope. This includes library modules +!> from dependencies. +!> +!> - Executable sources (`FPM_SCOPE_APP`,`FPM_SCOPE_TEST`) may use +!> library modules (including dependencies) as well as any modules +!> corresponding to source files in the same directory or a +!> subdirectory of the executable source file. +!> +!> @warning If a module used by a source file cannot be resolved to +!> a source file in the package of the correct scope, then a __fatal error__ +!> is returned by the procedure and model construction fails. +!> +subroutine resolve_module_dependencies(targets,error) + type(build_target_ptr), intent(inout), target :: targets(:) + type(error_t), allocatable, intent(out) :: error + + type(build_target_ptr) :: dep + + integer :: i, j + + do i=1,size(targets) + + if (.not.allocated(targets(i)%ptr%source)) cycle + + do j=1,size(targets(i)%ptr%source%modules_used) + + if (targets(i)%ptr%source%modules_used(j)%s .in. targets(i)%ptr%source%modules_provided) then + ! Dependency satisfied in same file, skip + cycle + end if + + if (any(targets(i)%ptr%source%unit_scope == & + [FPM_SCOPE_APP, FPM_SCOPE_EXAMPLE, FPM_SCOPE_TEST])) then + dep%ptr => & + find_module_dependency(targets,targets(i)%ptr%source%modules_used(j)%s, & + include_dir = dirname(targets(i)%ptr%source%file_name)) + else + dep%ptr => & + find_module_dependency(targets,targets(i)%ptr%source%modules_used(j)%s) + end if + + if (.not.associated(dep%ptr)) then + call fatal_error(error, & + 'Unable to find source for module dependency: "' // & + targets(i)%ptr%source%modules_used(j)%s // & + '" used by "'//targets(i)%ptr%source%file_name//'"') + return + end if + + call add_dependency(targets(i)%ptr, dep%ptr) + + end do + + end do + +end subroutine resolve_module_dependencies + +function find_module_dependency(targets,module_name,include_dir) result(target_ptr) + ! Find a module dependency in the library or a dependency library + ! + ! 'include_dir' specifies an allowable non-library search directory + ! (Used for executable dependencies) + ! + type(build_target_ptr), intent(in), target :: targets(:) + character(*), intent(in) :: module_name + character(*), intent(in), optional :: include_dir + type(build_target_t), pointer :: target_ptr + + integer :: k, l + + target_ptr => NULL() + + do k=1,size(targets) + + if (.not.allocated(targets(k)%ptr%source)) cycle + + do l=1,size(targets(k)%ptr%source%modules_provided) + + if (module_name == targets(k)%ptr%source%modules_provided(l)%s) then + select case(targets(k)%ptr%source%unit_scope) + case (FPM_SCOPE_LIB, FPM_SCOPE_DEP) + target_ptr => targets(k)%ptr + exit + case default + if (present(include_dir)) then + if (index(dirname(targets(k)%ptr%source%file_name), include_dir) == 1) then ! source file is within the include_dir or a subdirectory + target_ptr => targets(k)%ptr + exit + end if + end if + end select + end if + + end do + + end do + +end function find_module_dependency + + +!> Construct the linker flags string for each target +!> `target%link_flags` includes non-library objects and library flags +!> +subroutine resolve_target_linking(targets, model) + type(build_target_ptr), intent(inout), target :: targets(:) + type(fpm_model_t), intent(in) :: model + + integer :: i + character(:), allocatable :: global_link_flags + character(:), allocatable :: global_compile_flags + + if (size(targets) == 0) return + + if (targets(1)%ptr%target_type == FPM_TARGET_ARCHIVE) then + global_link_flags = targets(1)%ptr%output_file + else + allocate(character(0) :: global_link_flags) + end if + + global_compile_flags = model%fortran_compile_flags + + if (allocated(model%link_libraries)) then + if (size(model%link_libraries) > 0) then + global_link_flags = global_link_flags // " -l" // string_cat(model%link_libraries," -l") + end if + end if + + if (allocated(model%include_dirs)) then + if (size(model%include_dirs) > 0) then + global_compile_flags = global_compile_flags // & + & " -I" // string_cat(model%include_dirs," -I") + end if + end if + + do i=1,size(targets) + + associate(target => targets(i)%ptr) + + target%compile_flags = global_compile_flags + + allocate(target%link_objects(0)) + + if (target%target_type == FPM_TARGET_ARCHIVE) then + + call get_link_objects(target%link_objects,target,is_exe=.false.) + + allocate(character(0) :: target%link_flags) + + else if (target%target_type == FPM_TARGET_EXECUTABLE) then + + call get_link_objects(target%link_objects,target,is_exe=.true.) + + target%link_flags = string_cat(target%link_objects," ") + + if (allocated(target%link_libraries)) then + if (size(target%link_libraries) > 0) then + target%link_flags = target%link_flags // " -l" // string_cat(target%link_libraries," -l") + end if + end if + + target%link_flags = target%link_flags//" "//global_link_flags + + end if + + end associate + + end do + +contains + + !> Wrapper to build link object list + !> + !> For libraries: just list dependency objects of lib target + !> + !> For executables: need to recursively discover non-library + !> dependency objects. (i.e. modules in same dir as program) + !> + recursive subroutine get_link_objects(link_objects,target,is_exe) + type(string_t), intent(inout), allocatable :: link_objects(:) + type(build_target_t), intent(in) :: target + logical, intent(in) :: is_exe + + integer :: i + type(string_t) :: temp_str + + if (.not.allocated(target%dependencies)) return + + do i=1,size(target%dependencies) + + associate(dep => target%dependencies(i)%ptr) + + if (.not.allocated(dep%source)) cycle + + ! Skip library dependencies for executable targets + ! since the library archive will always be linked + if (is_exe.and.(dep%source%unit_scope == FPM_SCOPE_LIB)) cycle + + ! Skip if dependency object already listed + if (dep%output_file .in. link_objects) cycle + + ! Add dependency object file to link object list + temp_str%s = dep%output_file + link_objects = [link_objects, temp_str] + + ! For executable objects, also need to include non-library + ! dependencies from dependencies (recurse) + if (is_exe) call get_link_objects(link_objects,dep,is_exe=.true.) + + end associate + + end do + + end subroutine get_link_objects + +end subroutine resolve_target_linking + + +end module fpm_targets diff --git a/test/cli_test/cli_test.f90 b/test/cli_test/cli_test.f90 new file mode 100644 index 0000000..d979f1a --- /dev/null +++ b/test/cli_test/cli_test.f90 @@ -0,0 +1,236 @@ +program main + +! for each set of command options, call this command recursively which will print the resulting parameters with a +! given test command CMD from the TEST() array. +! +! Then read the expected values as a NAMELIST group from the test array and compare the expected +! results with the actual results. +! +! the PARSE() subroutine is a copy of the app/main.f90 program except it creates and writes a NAMELIST file instead +! of actually calling the subcommands. +! +! The program will exit with a non-zero status if any of the tests fail + +use, intrinsic :: iso_fortran_env, only : compiler_version, compiler_options +implicit none + +! convenient arbitrary sizes for test + +! assuming no name over 15 characters to make output have shorter lines +character(len=15),allocatable :: name(:),act_name(:) ; namelist/act_cli/act_name +integer,parameter :: max_names=10 + +character(len=:),allocatable :: command +character(len=:),allocatable :: cmd +integer :: cstat, estat +integer :: act_cstat, act_estat +integer :: i, ios +logical :: w_e,act_w_e ; namelist/act_cli/act_w_e +logical :: w_t,act_w_t ; namelist/act_cli/act_w_t + +character(len=63) :: profile,act_profile ; namelist/act_cli/act_profile +character(len=:),allocatable :: args,act_args ; namelist/act_cli/act_args +namelist/expected/cmd,cstat,estat,w_e,w_t,name,profile,args +integer :: lun +logical,allocatable :: tally(:) +logical,allocatable :: subtally(:) +character(len=256) :: message + +! table of arguments to pass to program and expected non-default values for that execution in NAMELIST group format +character(len=*),parameter :: tests(*)= [ character(len=256) :: & + +'CMD="new", ESTAT=1,', & +!'CMD="new -unknown", ESTAT=2,', & +'CMD="new my_project another yet_another -test", ESTAT=2,', & +'CMD="new my_project --app", W_E=T, NAME="my_project",', & +'CMD="new my_project --app --test", W_E=T,W_T=T, NAME="my_project",', & +'CMD="new my_project --test", W_T=T, NAME="my_project",', & +'CMD="new my_project", W_E=T,W_T=T, NAME="my_project",', & + +'CMD="run", ', & +'CMD="run my_project", NAME="my_project", ', & +'CMD="run proj1 p2 project3", NAME="proj1","p2","project3", ', & +'CMD="run proj1 p2 project3 --profile debug", NAME="proj1","p2","project3",profile="debug",', & +'CMD="run proj1 p2 project3 --profile release", NAME="proj1","p2","project3",profile="release",', & +'CMD="run proj1 p2 project3 --profile release -- arg1 -x ""and a long one""", & + &NAME="proj1","p2","project3",profile="release",ARGS="""arg1"" -x ""and a long one""", ', & + +'CMD="test", ', & +'CMD="test my_project", NAME="my_project", ', & +'CMD="test proj1 p2 project3", NAME="proj1","p2","project3", ', & +'CMD="test proj1 p2 project3 --profile debug", NAME="proj1","p2","project3",profile="debug",', & +'CMD="test proj1 p2 project3 --profile release", NAME="proj1","p2","project3",profile="release",', & +'CMD="test proj1 p2 project3 --profile release -- arg1 -x ""and a long one""", & + &NAME="proj1","p2","project3",profile="release" ARGS="""arg1"" -x ""and a long one""", ', & + +'CMD="build", NAME= profile="",ARGS="",', & +'CMD="build --profile release", NAME= profile="release",ARGS="",', & +' ' ] +character(len=256) :: readme(3) + +readme(1)='&EXPECTED' ! top and bottom line for a NAMELIST group read from TEST() used to set the expected values +readme(3)=' /' +tally=[logical ::] ! an array that tabulates the command test results as pass or fail. + +if(command_argument_count().eq.0)then ! assume if called with no arguments to do the tests. This means you cannot + ! have a test of no parameters. Could improve on this. + ! if called with parameters assume this is a test and call the routine to + ! parse the resulting values after calling the CLI command line parser + ! and write the NAMELIST group so it can be read and tested against the + ! expected results + write(*,*)'start tests of the CLI command line parser' + command=repeat(' ',4096) + call get_command_argument(0,command) + command=trim(command) + write(*,*)'command=',command + + do i=1,size(tests) + if(tests(i).eq.' ')then + open(file='_test_cli',newunit=lun,delim='quote') + close(unit=lun,status='delete') + exit + endif + ! blank out name group EXPECTED + name=[(repeat(' ',len(name)),i=1,max_names)] ! the words on the command line sans the subcommand name + profile="" ! --profile PROF + w_e=.false. ! --app + w_t=.false. ! --test + args=repeat(' ',132) ! -- ARGS + cmd=repeat(' ',132) ! the command line arguments to test + cstat=0 ! status values from EXECUTE_COMMAND_LINE() + estat=0 + readme(2)=' '//tests(i) ! select command options to test for CMD and set nondefault expected values + read(readme,nml=expected) + + write(*,'(*(g0))')'START: TEST ',i,' CMD=',trim(cmd) + ! call this program which will crack command line and write results to scratch file _test_cli + call execute_command_line(command//' '//trim(cmd),cmdstat=act_cstat,exitstat=act_estat) + if(cstat.eq.act_cstat.and.estat.eq.act_estat)then + if(estat.eq.0)then + open(file='_test_cli',newunit=lun,delim='quote') + act_name=[(repeat(' ',len(act_name)),i=1,max_names)] + act_profile='' + act_w_e=.false. + act_w_t=.false. + act_args=repeat(' ',132) + read(lun,nml=act_cli,iostat=ios,iomsg=message) + if(ios.ne.0)then + write(*,'(a)')'ERROR:',trim(message) + endif + close(unit=lun) + ! compare results to expected values + subtally=[logical ::] + call test_test('NAME',all(act_name.eq.name)) + call test_test('PROFILE',act_profile.eq.profile) + call test_test('WITH_EXPECTED',act_w_e.eqv.w_e) + call test_test('WITH_TESTED',act_w_t.eqv.w_t) + call test_test('WITH_TEST',act_w_t.eqv.w_t) + call test_test('ARGS',act_args.eq.args) + if(all(subtally))then + write(*,'(*(g0))')'PASSED: TEST ',i,' STATUS: expected ',cstat,' ',estat,' actual ',act_cstat,' ',act_estat,& + & ' for [',trim(cmd),']' + tally=[tally,.true.] + else + write(*,'(*(g0))')'FAILED: TEST ',i,' STATUS: expected ',cstat,' ',estat,' actual ',act_cstat,' ',act_estat,& + & ' for [',trim(cmd),']' + print '(4a)', & + 'This file was compiled by ', & + compiler_version(), & + ' using the options ', & + compiler_options() + write(*,nml=act_cli,delim='quote') + tally=[tally,.false.] + endif + else + write(*,'(*(g0))')'PASSED: TEST ',i,' EXPECTED BAD STATUS: expected ',cstat,' ',estat, & + ' actual ',act_cstat,' ',act_estat,' for [',trim(cmd),']' + tally=[tally,.true.] + endif + else + write(*,'(*(g0))')'FAILED: TEST ',i,'BAD STATUS: expected ',cstat,' ',estat,' actual ',act_cstat,' ',act_estat,& + ' for [',trim(cmd),']' + tally=[tally,.false.] + endif + enddo + ! write up total results and if anything failed exit with a non-zero status + write(*,'(*(g0))')'TALLY;',tally + if(all(tally))then + write(*,'(*(g0))')'PASSED: all ',count(tally),' tests passed ' + else + write(*,*)'FAILED: PASSED=',count(tally),' FAILED=',count(.not.tally) + stop 4 + endif +else + ! call this program with arguments + !============================================= + debugit: block + integer :: j, ilen + character(len=256) :: big_argument + write(*,*)'arguments seen directly by program' + do j=1,command_argument_count() + call get_command_argument(number=j,value=big_argument,length=ilen) + write(*,'(*(g0))')j,'[',big_argument(:ilen),']' + enddo + end block debugit + !============================================= + call parse() +endif + +contains + +subroutine test_test(name,tst) +character(len=*) :: name +logical,intent(in) :: tst + !!write(*,'(*(g0,1x))')' SUBTEST ',name,' ',merge('PASSED','FAILED',tst) + subtally=[subtally,tst] +end subroutine test_test + +subroutine parse() +! all the extended types for settings from the main program +use fpm_command_line, only: & + fpm_cmd_settings, & + fpm_new_settings, & + fpm_build_settings, & + fpm_run_settings, & + fpm_test_settings, & + fpm_install_settings, & + get_command_line_settings +use fpm, only: cmd_build, cmd_run +use fpm_cmd_install, only: cmd_install +use fpm_cmd_new, only: cmd_new +class(fpm_cmd_settings), allocatable :: cmd_settings +! duplicates the calls as seen in the main program for fpm +call get_command_line_settings(cmd_settings) + +allocate (character(len=len(name)) :: act_name(0) ) +act_args='' +act_w_e=.false. +act_w_t=.false. +act_profile='' + +select type(settings=>cmd_settings) +type is (fpm_new_settings) + act_w_e=settings%with_executable + act_w_t=settings%with_test + act_name=[trim(settings%name)] +type is (fpm_build_settings) + act_profile=settings%profile +type is (fpm_run_settings) + act_profile=settings%profile + act_name=settings%name + act_args=settings%args +type is (fpm_test_settings) + act_profile=settings%profile + act_name=settings%name + act_args=settings%args +type is (fpm_install_settings) +end select + +open(file='_test_cli',newunit=lun,delim='quote') +write(lun,nml=act_cli,delim='quote') +!!write(*,nml=act_cli) +close(unit=lun) + +end subroutine parse + +end program main diff --git a/test/fpm_test/main.f90 b/test/fpm_test/main.f90 new file mode 100644 index 0000000..0a65307 --- /dev/null +++ b/test/fpm_test/main.f90 @@ -0,0 +1,106 @@ +!> Driver for unit testing +program fpm_testing + use, intrinsic :: iso_fortran_env, only : error_unit + use testsuite, only : run_testsuite, new_testsuite, testsuite_t, & + & select_suite, run_selected + use test_toml, only : collect_toml + use test_manifest, only : collect_manifest + use test_filesystem, only : collect_filesystem + use test_source_parsing, only : collect_source_parsing + use test_module_dependencies, only : collect_module_dependencies + use test_package_dependencies, only : collect_package_dependencies + use test_backend, only: collect_backend + use test_installer, only : collect_installer + use test_versioning, only : collect_versioning + implicit none + integer :: stat, is + character(len=:), allocatable :: suite_name, test_name + type(testsuite_t), allocatable :: suite(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + suite = [ & + & new_testsuite("fpm_toml", collect_toml), & + & new_testsuite("fpm_manifest", collect_manifest), & + & new_testsuite("fpm_filesystem", collect_filesystem), & + & new_testsuite("fpm_source_parsing", collect_source_parsing), & + & new_testsuite("fpm_module_dependencies", collect_module_dependencies), & + & new_testsuite("fpm_package_dependencies", collect_package_dependencies), & + & new_testsuite("fpm_test_backend", collect_backend), & + & new_testsuite("fpm_installer", collect_installer), & + & new_testsuite("fpm_versioning", collect_versioning) & + & ] + + call get_argument(1, suite_name) + call get_argument(2, test_name) + + if (allocated(suite_name)) then + is = select_suite(suite, suite_name) + if (is > 0 .and. is <= size(suite)) then + if (allocated(test_name)) then + write(error_unit, fmt) "Suite:", suite(is)%name + call run_selected(suite(is)%collect, test_name, error_unit, stat) + if (stat < 0) then + error stop 1 + end if + else + write(error_unit, fmt) "Testing:", suite(is)%name + call run_testsuite(suite(is)%collect, error_unit, stat) + end if + else + write(error_unit, fmt) "Available testsuites" + do is = 1, size(suite) + write(error_unit, fmt) "-", suite(is)%name + end do + error stop 1 + end if + else + do is = 1, size(suite) + write(error_unit, fmt) "Testing:", suite(is)%name + call run_testsuite(suite(is)%collect, error_unit, stat) + end do + end if + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop 1 + end if + + +contains + + + !> Obtain the command line argument at a given index + subroutine get_argument(idx, arg) + + !> Index of command line argument, range [0:command_argument_count()] + integer, intent(in) :: idx + + !> Command line argument + character(len=:), allocatable, intent(out) :: arg + + integer :: length, stat + + call get_command_argument(idx, length=length, status=stat) + if (stat /= 0) then + return + endif + + allocate(character(len=length) :: arg, stat=stat) + if (stat /= 0) then + return + endif + + if (length > 0) then + call get_command_argument(idx, arg, status=stat) + if (stat /= 0) then + deallocate(arg) + return + end if + end if + + end subroutine get_argument + + +end program fpm_testing diff --git a/test/fpm_test/test_backend.f90 b/test/fpm_test/test_backend.f90 new file mode 100644 index 0000000..662e470 --- /dev/null +++ b/test/fpm_test/test_backend.f90 @@ -0,0 +1,353 @@ +!> Define tests for the `fpm_backend` module (build scheduling) +module test_backend + use testsuite, only : new_unittest, unittest_t, error_t, test_failed + use test_module_dependencies, only: operator(.in.) + use fpm_filesystem, only: exists, mkdir, get_temp_filename + use fpm_targets, only: build_target_t, build_target_ptr, & + FPM_TARGET_OBJECT, FPM_TARGET_ARCHIVE, & + add_target, add_dependency + use fpm_backend, only: sort_target, schedule_targets + implicit none + private + + public :: collect_backend + +contains + + + !> Collect all exported unit tests + subroutine collect_backend(testsuite) + + !> Collection of tests + type(unittest_t), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + & new_unittest("target-sort", test_target_sort), & + & new_unittest("target-sort-skip-all", test_target_sort_skip_all), & + & new_unittest("target-sort-rebuild-all", test_target_sort_rebuild_all), & + & new_unittest("schedule-targets", test_schedule_targets), & + & new_unittest("schedule-targets-empty", test_schedule_empty) & + ] + + end subroutine collect_backend + + + !> Check scheduling of objects with dependencies + subroutine test_target_sort(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(build_target_ptr), allocatable :: targets(:) + + integer :: i + + targets = new_test_package() + + ! Perform depth-first topological sort of targets + do i=1,size(targets) + + call sort_target(targets(i)%ptr) + + end do + + ! Check target states: all targets scheduled + do i=1,size(targets) + + if (.not.targets(i)%ptr%touched) then + call test_failed(error,"Target touched flag not set") + return + end if + + if (.not.targets(i)%ptr%sorted) then + call test_failed(error,"Target sort flag not set") + return + end if + + if (targets(i)%ptr%skip) then + call test_failed(error,"Target skip flag set incorrectly") + return + end if + + if (targets(i)%ptr%schedule < 0) then + call test_failed(error,"Target schedule not set") + return + end if + + end do + + ! Check all objects sheduled before library + do i=2,size(targets) + + if (targets(i)%ptr%schedule >= targets(1)%ptr%schedule) then + call test_failed(error,"Object dependency scheduled after dependent library target") + return + end if + + end do + + ! Check target 4 schedule before targets 2 & 3 + do i=2,3 + if (targets(4)%ptr%schedule >= targets(i)%ptr%schedule) then + call test_failed(error,"Object dependency scheduled after dependent object target") + return + end if + end do + + end subroutine test_target_sort + + + + !> Check incremental rebuild for existing archive + !> all object sources are unmodified: all objects should be skipped + subroutine test_target_sort_skip_all(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(build_target_ptr), allocatable :: targets(:) + + integer :: fh, i + + targets = new_test_package() + + do i=2,size(targets) + + ! Mimick unmodified sources + allocate(targets(i)%ptr%source) + targets(i)%ptr%source%digest = i + targets(i)%ptr%digest_cached = i + + end do + + ! Mimick archive already exists + open(newunit=fh,file=targets(1)%ptr%output_file,status="unknown") + close(fh) + + ! Perform depth-first topological sort of targets + do i=1,size(targets) + + call sort_target(targets(i)%ptr) + + end do + + ! Check target states: all targets skipped + do i=1,size(targets) + + if (.not.targets(i)%ptr%touched) then + call test_failed(error,"Target touched flag not set") + return + end if + + if (targets(i)%ptr%sorted) then + call test_failed(error,"Target sort flag set incorrectly") + return + end if + + if (.not.targets(i)%ptr%skip) then + call test_failed(error,"Target skip flag set incorrectly") + return + end if + + end do + + end subroutine test_target_sort_skip_all + + + !> Check incremental rebuild for existing archive + !> all but lowest source modified: all objects should be rebuilt + subroutine test_target_sort_rebuild_all(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(build_target_ptr), allocatable :: targets(:) + + integer :: fh, i + + targets = new_test_package() + + do i=2,3 + + ! Mimick unmodified sources + allocate(targets(i)%ptr%source) + targets(i)%ptr%source%digest = i + targets(i)%ptr%digest_cached = i + + end do + + ! Mimick archive already exists + open(newunit=fh,file=targets(1)%ptr%output_file,status="unknown") + close(fh) + + ! Perform depth-first topological sort of targets + do i=1,size(targets) + + call sort_target(targets(i)%ptr) + + end do + + ! Check target states: all targets scheduled + do i=1,size(targets) + + if (.not.targets(i)%ptr%sorted) then + call test_failed(error,"Target sort flag not set") + return + end if + + if (targets(i)%ptr%skip) then + call test_failed(error,"Target skip flag set incorrectly") + return + end if + + end do + + end subroutine test_target_sort_rebuild_all + + + !> Check construction of target queue and schedule + subroutine test_schedule_targets(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(build_target_ptr), allocatable :: targets(:) + + integer :: i, j + type(build_target_ptr), allocatable :: queue(:) + integer, allocatable :: schedule_ptr(:) + + targets = new_test_package() + + ! Perform depth-first topological sort of targets + do i=1,size(targets) + + call sort_target(targets(i)%ptr) + + end do + + ! Construct build schedule queue + call schedule_targets(queue, schedule_ptr, targets) + + ! Check all targets enqueued + do i=1,size(targets) + + if (.not.(targets(i)%ptr.in.queue)) then + + call test_failed(error,"Target not found in build queue") + return + + end if + + end do + + ! Check schedule structure + if (schedule_ptr(1) /= 1) then + + call test_failed(error,"schedule_ptr(1) does not point to start of the queue") + return + + end if + + if (schedule_ptr(size(schedule_ptr)) /= size(queue)+1) then + + call test_failed(error,"schedule_ptr(end) does not point to end of the queue") + return + + end if + + do i=1,size(schedule_ptr)-1 + + do j=schedule_ptr(i),(schedule_ptr(i+1)-1) + + if (queue(j)%ptr%schedule /= i) then + + call test_failed(error,"Target scheduled in the wrong region") + return + + end if + + end do + + end do + + end subroutine test_schedule_targets + + + !> Check construction of target queue and schedule + !> when there's nothing to do (all targets skipped) + subroutine test_schedule_empty(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(build_target_ptr), allocatable :: targets(:) + + integer :: i + type(build_target_ptr), allocatable :: queue(:) + integer, allocatable :: schedule_ptr(:) + + targets = new_test_package() + + do i=1,size(targets) + + targets(i)%ptr%skip = .true. + + end do + + ! Perform depth-first topological sort of targets + do i=1,size(targets) + + call sort_target(targets(i)%ptr) + + end do + + ! Construct build schedule queue + call schedule_targets(queue, schedule_ptr, targets) + + ! Check queue is empty + if (size(queue) > 0) then + + call test_failed(error,"Expecting an empty build queue, but not empty") + return + + end if + + ! Check schedule loop is not entered + do i=1,size(schedule_ptr)-1 + + call test_failed(error,"Attempted to run an empty schedule") + return + + end do + + end subroutine test_schedule_empty + + + !> Helper to generate target objects with dependencies + function new_test_package() result(targets) + + type(build_target_ptr), allocatable :: targets(:) + + call add_target(targets,FPM_TARGET_ARCHIVE,get_temp_filename()) + + call add_target(targets,FPM_TARGET_OBJECT,get_temp_filename()) + + call add_target(targets,FPM_TARGET_OBJECT,get_temp_filename()) + + call add_target(targets,FPM_TARGET_OBJECT,get_temp_filename()) + + ! Library depends on all objects + call add_dependency(targets(1)%ptr,targets(2)%ptr) + call add_dependency(targets(1)%ptr,targets(3)%ptr) + call add_dependency(targets(1)%ptr,targets(4)%ptr) + + ! Inter-object dependency + ! targets 2 & 3 depend on target 4 + call add_dependency(targets(2)%ptr,targets(4)%ptr) + call add_dependency(targets(3)%ptr,targets(4)%ptr) + + end function new_test_package + + +end module test_backend \ No newline at end of file diff --git a/test/fpm_test/test_filesystem.f90 b/test/fpm_test/test_filesystem.f90 new file mode 100644 index 0000000..5a7e18a --- /dev/null +++ b/test/fpm_test/test_filesystem.f90 @@ -0,0 +1,106 @@ +module test_filesystem + use testsuite, only : new_unittest, unittest_t, error_t, test_failed + use fpm_filesystem, only: canon_path + implicit none + private + + public :: collect_filesystem + +contains + + + !> Collect all exported unit tests + subroutine collect_filesystem(testsuite) + + !> Collection of tests + type(unittest_t), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + & new_unittest("canon-path", test_canon_path) & + ] + + end subroutine collect_filesystem + + + subroutine test_canon_path(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call check_string(error, & + & canon_path("git/project/src/origin"), "git/project/src/origin") + if (allocated(error)) return + + call check_string(error, & + & canon_path("./project/src/origin"), "project/src/origin") + if (allocated(error)) return + + call check_string(error, & + & canon_path("./project/src///origin/"), "project/src/origin") + if (allocated(error)) return + + call check_string(error, & + & canon_path("../project/./src/origin/"), "../project/src/origin") + if (allocated(error)) return + + call check_string(error, & + & canon_path("/project//src/origin/"), "/project/src/origin") + if (allocated(error)) return + + call check_string(error, & + & canon_path("/project/src/../origin/"), "/project/origin") + if (allocated(error)) return + + call check_string(error, & + & canon_path("/project/src/../origin/.."), "/project") + if (allocated(error)) return + + call check_string(error, & + & canon_path("/project/src//../origin/."), "/project/origin") + if (allocated(error)) return + + call check_string(error, & + & canon_path("../project/src/./../origin/."), "../project/origin") + if (allocated(error)) return + + call check_string(error, & + & canon_path("../project/src/../../../origin/."), "../../origin") + if (allocated(error)) return + + call check_string(error, & + & canon_path("/../.."), "/") + if (allocated(error)) return + + call check_string(error, & + & canon_path("././././././/////a/b/.///././////.///c/../../../"), ".") + if (allocated(error)) return + + call check_string(error, & + & canon_path("/./././././/////a/b/.///././////.///c/../../../"), "/") + if (allocated(error)) return + + end subroutine test_canon_path + + + !> Check a character variable against a reference value + subroutine check_string(error, actual, expected) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Actual string value + character(len=*), intent(in) :: actual + + !> Expected string value + character(len=*), intent(in) :: expected + + if (actual /= expected) then + call test_failed(error, & + "Character value missmatch "//& + "expected '"//expected//"' but got '"//actual//"'") + end if + + end subroutine check_string + + +end module test_filesystem diff --git a/test/fpm_test/test_installer.f90 b/test/fpm_test/test_installer.f90 new file mode 100644 index 0000000..1235ba5 --- /dev/null +++ b/test/fpm_test/test_installer.f90 @@ -0,0 +1,168 @@ +!> Define tests for the `fpm_installer` module +!> +!> The tests here setup a mock environment to allow testing for Unix and Windows +!> platforms at the same time. +module test_installer + use testsuite, only : new_unittest, unittest_t, error_t, test_failed, & + & check_string + use fpm_environment, only : OS_WINDOWS, OS_LINUX + use fpm_filesystem, only : join_path + use fpm_installer + implicit none + private + + public :: collect_installer + + + type, extends(installer_t) :: mock_installer_t + character(len=:), allocatable :: expected_dir + character(len=:), allocatable :: expected_run + contains + procedure :: make_dir + procedure :: run + end type mock_installer_t + +contains + + !> Collect all exported unit tests + subroutine collect_installer(testsuite) + !> Collection of tests + type(unittest_t), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + & new_unittest("install-lib", test_install_lib), & + & new_unittest("install-pkgconfig", test_install_pkgconfig), & + & new_unittest("install-sitepackages", test_install_sitepackages), & + & new_unittest("install-mod", test_install_mod), & + & new_unittest("install-exe-unix", test_install_exe_unix), & + & new_unittest("install-exe-win", test_install_exe_win)] + + end subroutine collect_installer + + subroutine test_install_exe_unix(error) + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(mock_installer_t) :: mock + type(installer_t) :: installer + + call new_installer(installer, prefix="PREFIX", verbosity=0, copy="mock") + mock%installer_t = installer + mock%os = OS_LINUX + mock%expected_dir = "PREFIX/bin" + mock%expected_run = 'mock "name" "'//mock%expected_dir//'"' + + call mock%install_executable("name", error) + + end subroutine test_install_exe_unix + + subroutine test_install_exe_win(error) + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(mock_installer_t) :: mock + type(installer_t) :: installer + + call new_installer(installer, prefix="PREFIX", verbosity=0, copy="mock") + mock%installer_t = installer + mock%os = OS_WINDOWS + mock%expected_dir = "PREFIX\bin" + mock%expected_run = 'mock "name.exe" "'//mock%expected_dir//'"' + + call mock%install_executable("name", error) + + end subroutine test_install_exe_win + + subroutine test_install_lib(error) + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(mock_installer_t) :: mock + type(installer_t) :: installer + + call new_installer(installer, prefix="PREFIX", verbosity=0, copy="mock") + mock%installer_t = installer + mock%expected_dir = join_path("PREFIX", "lib") + mock%expected_run = 'mock "name" "'//join_path("PREFIX", "lib")//'"' + + call mock%install_library("name", error) + + end subroutine test_install_lib + + subroutine test_install_pkgconfig(error) + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(mock_installer_t) :: mock + type(installer_t) :: installer + + call new_installer(installer, prefix="PREFIX", verbosity=0, copy="mock") + mock%installer_t = installer + mock%os = OS_WINDOWS + mock%expected_dir = "PREFIX\lib\pkgconfig" + mock%expected_run = 'mock "name" "'//mock%expected_dir//'"' + + call mock%install("name", "lib/pkgconfig", error) + + end subroutine test_install_pkgconfig + + subroutine test_install_sitepackages(error) + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(mock_installer_t) :: mock + type(installer_t) :: installer + + call new_installer(installer, prefix="PREFIX", verbosity=0, copy="mock") + mock%installer_t = installer + mock%os = OS_LINUX + mock%expected_dir = "PREFIX/lib/python3.7/site-packages" + mock%expected_run = 'mock "name" "'//mock%expected_dir//'"' + + call mock%install("name", join_path("lib", "python3.7", "site-packages"), & + error) + + end subroutine test_install_sitepackages + + subroutine test_install_mod(error) + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(mock_installer_t) :: mock + type(installer_t) :: installer + + call new_installer(installer, prefix="PREFIX", verbosity=0, copy="mock") + mock%installer_t = installer + mock%expected_dir = join_path("PREFIX", "include") + mock%expected_run = 'mock "name" "'//join_path("PREFIX", "include")//'"' + + call mock%install_header("name", error) + + end subroutine test_install_mod + + !> Create a new directory in the prefix + subroutine make_dir(self, dir, error) + !> Instance of the installer + class(mock_installer_t), intent(inout) :: self + !> Directory to be created + character(len=*), intent(in) :: dir + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call check_string(error, self%expected_dir, dir, "dir") + + end subroutine make_dir + + !> Run an installation command + subroutine run(self, command, error) + !> Instance of the installer + class(mock_installer_t), intent(inout) :: self + !> Command to be launched + character(len=*), intent(in) :: command + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call check_string(error, self%expected_run, command, "run") + end subroutine run + +end module test_installer diff --git a/test/fpm_test/test_manifest.f90 b/test/fpm_test/test_manifest.f90 new file mode 100644 index 0000000..94e5e07 --- /dev/null +++ b/test/fpm_test/test_manifest.f90 @@ -0,0 +1,1085 @@ +!> Define tests for the `fpm_manifest` modules +module test_manifest + use fpm_filesystem, only: get_temp_filename + use testsuite, only : new_unittest, unittest_t, error_t, test_failed, & + & check_string + use fpm_manifest + use fpm_strings, only: operator(.in.) + implicit none + private + + public :: collect_manifest + + +contains + + + !> Collect all exported unit tests + subroutine collect_manifest(testsuite) + + !> Collection of tests + type(unittest_t), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + & new_unittest("valid-manifest", test_valid_manifest), & + & new_unittest("invalid-manifest", test_invalid_manifest, should_fail=.true.), & + & new_unittest("default-library", test_default_library), & + & new_unittest("default-executable", test_default_executable), & + & new_unittest("dependency-empty", test_dependency_empty, should_fail=.true.), & + & new_unittest("dependency-pathtag", test_dependency_pathtag, should_fail=.true.), & + & new_unittest("dependency-gitpath", test_dependency_gitpath, should_fail=.true.), & + & new_unittest("dependency-nourl", test_dependency_nourl, should_fail=.true.), & + & new_unittest("dependency-gitconflict", test_dependency_gitconflict, should_fail=.true.), & + & new_unittest("dependency-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("build-config-valid", test_build_valid), & + & new_unittest("build-config-empty", test_build_empty), & + & new_unittest("build-config-invalid-values", test_build_invalid_values, should_fail=.true.), & + & new_unittest("library-empty", test_library_empty), & + & new_unittest("library-wrongkey", test_library_wrongkey, should_fail=.true.), & + & new_unittest("package-simple", test_package_simple), & + & new_unittest("package-empty", test_package_empty, should_fail=.true.), & + & new_unittest("package-typeerror", test_package_typeerror, should_fail=.true.), & + & new_unittest("package-noname", test_package_noname, should_fail=.true.), & + & new_unittest("package-wrongexe", test_package_wrongexe, should_fail=.true.), & + & new_unittest("package-wrongtest", test_package_wrongtest, should_fail=.true.), & + & new_unittest("package-duplicate", test_package_duplicate, should_fail=.true.), & + & new_unittest("test-simple", test_test_simple), & + & new_unittest("test-empty", test_test_empty, should_fail=.true.), & + & new_unittest("test-typeerror", test_test_typeerror, should_fail=.true.), & + & new_unittest("test-noname", test_test_noname, should_fail=.true.), & + & new_unittest("test-wrongkey", test_test_wrongkey, should_fail=.true.), & + & new_unittest("link-string", test_link_string), & + & new_unittest("link-array", test_link_array), & + & new_unittest("link-error", test_invalid_link, should_fail=.true.), & + & new_unittest("example-simple", test_example_simple), & + & new_unittest("example-empty", test_example_empty, should_fail=.true.), & + & new_unittest("install-library", test_install_library), & + & new_unittest("install-empty", test_install_empty), & + & new_unittest("install-wrongkey", test_install_wrongkey, should_fail=.true.)] + + end subroutine collect_manifest + + + !> Try to read some unnecessary obscure and convoluted but not invalid package file + subroutine test_valid_manifest(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(package_config_t) :: package + character(len=*), parameter :: manifest = 'fpm-valid-manifest.toml' + integer :: unit + + open(file=manifest, newunit=unit) + write(unit, '(a)') & + & 'name = "example"', & + & '[build]', & + & 'auto-executables = false', & + & 'auto-tests = false', & + & '[dependencies.fpm]', & + & 'git = "https://github.com/fortran-lang/fpm"', & + & '[[executable]]', & + & 'name = "example-#1" # comment', & + & 'source-dir = "prog"', & + & '[dependencies]', & + & 'toml-f.git = "git@github.com:toml-f/toml-f.git"', & + & '"toml..f" = { path = ".." }', & + & '[["executable"]]', & + & 'name = "example-#2"', & + & 'source-dir = "prog"', & + & '[executable.dependencies]', & + & '[''library'']', & + & 'source-dir = """', & + & 'lib""" # comment' + close(unit) + + call get_package_data(package, manifest, error) + + open(file=manifest, newunit=unit) + close(unit, status='delete') + + if (allocated(error)) return + + if (package%name /= "example") then + call test_failed(error, "Package name is "//package%name//" but should be example") + return + end if + + if (.not.allocated(package%library)) then + call test_failed(error, "library is not present in package data") + return + end if + + if (.not.allocated(package%executable)) then + call test_failed(error, "executable is not present in package data") + return + end if + + if (size(package%executable) /= 2) then + call test_failed(error, "Number of executables in package is not two") + return + end if + + if (.not.allocated(package%dependency)) then + call test_failed(error, "dependency is not present in package data") + return + end if + + if (size(package%dependency) /= 3) then + call test_failed(error, "Number of dependencies in package is not three") + return + end if + + if (allocated(package%test)) then + call test_failed(error, "test is present in package but not in package file") + return + end if + + end subroutine test_valid_manifest + + + !> Try to read a valid TOML document which represent an invalid package file + subroutine test_invalid_manifest(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(package_config_t) :: package + character(len=*), parameter :: manifest = 'fpm-invalid-manifest.toml' + integer :: unit + + open(file=manifest, newunit=unit) + write(unit, '(a)') & + & '[package]', & + & 'name = "example"', & + & 'version = "0.1.0"' + close(unit) + + call get_package_data(package, manifest, error) + + open(file=manifest, newunit=unit) + close(unit, status='delete') + + end subroutine test_invalid_manifest + + + !> Create a default library + subroutine test_default_library(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(package_config_t) :: package + + allocate(package%library) + call default_library(package%library) + + call check_string(error, package%library%source_dir, "src", & + & "Default library source-dir") + if (allocated(error)) return + + if (.not.allocated(package%library%include_dir)) then + call test_failed(error,"Default include-dir list not allocated") + return + end if + + if (.not.("include".in.package%library%include_dir)) then + call test_failed(error,"'include' not in default include-dir list") + return + end if + + end subroutine test_default_library + + + !> Create a default executable + subroutine test_default_executable(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(package_config_t) :: package + character(len=*), parameter :: name = "default" + + allocate(package%executable(1)) + call default_executable(package%executable(1), name) + + call check_string(error, package%executable(1)%source_dir, "app", & + & "Default executable source-dir") + if (allocated(error)) return + + call check_string(error, package%executable(1)%name, name, & + & "Default executable name") + if (allocated(error)) return + + end subroutine test_default_executable + + + !> Dependencies cannot be created from empty tables + subroutine test_dependency_empty(error) + use fpm_manifest_dependency + use fpm_toml, only : new_table, toml_table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(dependency_config_t) :: dependency + + call new_table(table) + table%key = "example" + + call new_dependency(dependency, table, error) + + end subroutine test_dependency_empty + + + !> Try to create a dependency with conflicting entries + subroutine test_dependency_pathtag(error) + use fpm_manifest_dependency + use fpm_toml, only : new_table, toml_table, set_value + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + integer :: stat + type(dependency_config_t) :: dependency + + call new_table(table) + table%key = 'example' + call set_value(table, 'path', '"package"', stat) + call set_value(table, 'tag', '"v20.1"', stat) + + call new_dependency(dependency, table, error) + + end subroutine test_dependency_pathtag + + + !> Try to create a dependency with conflicting entries + subroutine test_dependency_nourl(error) + use fpm_manifest_dependency + use fpm_toml, only : new_table, toml_table, set_value + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + integer :: stat + type(dependency_config_t) :: dependency + + call new_table(table) + table%key = 'example' + call set_value(table, 'tag', '"v20.1"', stat) + + call new_dependency(dependency, table, error) + + end subroutine test_dependency_nourl + + + !> Try to create a dependency with conflicting entries + subroutine test_dependency_gitpath(error) + use fpm_manifest_dependency + use fpm_toml, only : new_table, toml_table, set_value + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + integer :: stat + type(dependency_config_t) :: dependency + + call new_table(table) + table%key = 'example' + call set_value(table, 'path', '"package"', stat) + call set_value(table, 'git', '"https://gitea.com/fortran-lang/pack"', stat) + + call new_dependency(dependency, table, error) + + end subroutine test_dependency_gitpath + + + !> Try to create a dependency with conflicting entries + subroutine test_dependency_gitconflict(error) + use fpm_manifest_dependency + use fpm_toml, only : new_table, toml_table, set_value + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + integer :: stat + type(dependency_config_t) :: dependency + + call new_table(table) + table%key = 'example' + call set_value(table, 'git', '"https://gitea.com/fortran-lang/pack"', stat) + call set_value(table, 'branch', '"latest"', stat) + call set_value(table, 'tag', '"v20.1"', stat) + + call new_dependency(dependency, table, error) + + 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_config_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 + use fpm_toml, only : new_table, toml_table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(dependency_config_t), allocatable :: dependencies(:) + + call new_table(table) + + call new_dependencies(dependencies, table, error) + if (allocated(error)) return + + if (allocated(dependencies)) then + call test_failed(error, "Found dependencies in empty table") + end if + + end subroutine test_dependencies_empty + + + !> Add a dependency as an array, which is not supported + subroutine test_dependencies_typeerror(error) + use fpm_manifest_dependency + use fpm_toml, only : new_table, add_array, toml_table, toml_array + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_array), pointer :: children + integer :: stat + type(dependency_config_t), allocatable :: dependencies(:) + + call new_table(table) + call add_array(table, 'dep1', children, stat) + + call new_dependencies(dependencies, table, error) + + end subroutine test_dependencies_typeerror + + + !> Executables cannot be created from empty tables + subroutine test_executable_empty(error) + use fpm_manifest_executable + use fpm_toml, only : new_table, toml_table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(executable_config_t) :: executable + + call new_table(table) + + call new_executable(executable, table, error) + + 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_config_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_config_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_config_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 + + + !> Try to read values from the [build] table + subroutine test_build_valid(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(package_config_t) :: package + character(:), allocatable :: temp_file + integer :: unit + + allocate(temp_file, source=get_temp_filename()) + + open(file=temp_file, newunit=unit) + write(unit, '(a)') & + & 'name = "example"', & + & '[build]', & + & 'auto-executables = false', & + & 'auto-tests = false' + close(unit) + + call get_package_data(package, temp_file, error) + + if (allocated(error)) return + + if (package%build%auto_executables) then + call test_failed(error, "Wong value of 'auto-executables' read, expecting .false.") + return + end if + + if (package%build%auto_tests) then + call test_failed(error, "Wong value of 'auto-tests' read, expecting .false.") + return + end if + + end subroutine test_build_valid + + + !> Try to read values from an empty [build] table + subroutine test_build_empty(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(package_config_t) :: package + character(:), allocatable :: temp_file + integer :: unit + + allocate(temp_file, source=get_temp_filename()) + + open(file=temp_file, newunit=unit) + write(unit, '(a)') & + & 'name = "example"', & + & '[build]', & + & '[library]' + close(unit) + + call get_package_data(package, temp_file, error) + + if (allocated(error)) return + + if (.not.package%build%auto_executables) then + call test_failed(error, "Wong default value of 'auto-executables' read, expecting .true.") + return + end if + + if (.not.package%build%auto_tests) then + call test_failed(error, "Wong default value of 'auto-tests' read, expecting .true.") + return + end if + + end subroutine test_build_empty + + + !> Try to read values from a [build] table with invalid values + subroutine test_build_invalid_values(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(package_config_t) :: package + character(:), allocatable :: temp_file + integer :: unit + + allocate(temp_file, source=get_temp_filename()) + + open(file=temp_file, newunit=unit) + write(unit, '(a)') & + & 'name = "example"', & + & '[build]', & + & 'auto-executables = "false"' + close(unit) + + call get_package_data(package, temp_file, error) + + end subroutine test_build_invalid_values + + + !> Libraries can be created from empty tables + subroutine test_library_empty(error) + use fpm_manifest_library + use fpm_toml, only : new_table, toml_table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(library_config_t) :: library + + call new_table(table) + + call new_library(library, table, error) + if (allocated(error)) return + + call check_string(error, library%source_dir, "src", & + & "Default library source-dir") + if (allocated(error)) return + + if (.not.allocated(library%include_dir)) then + call test_failed(error,"Default include-dir list not allocated") + return + end if + + if (.not.("include".in.library%include_dir)) then + call test_failed(error,"'include' not in default include-dir list") + return + end if + + 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_config_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_config_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 + use fpm_toml, only : new_table, toml_table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(package_config_t) :: package + + call new_table(table) + + call new_package(package, table, error) + + 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_config_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_config_t) :: package + + call new_table(table) + call add_table(table, "library", child, stat) + call add_table(table, "dev-dependencies", child, stat) + call add_table(table, "dependencies", child, stat) + + call new_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_config_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_config_t) :: package + + call new_table(table) + call set_value(table, 'name', '"example"', stat) + call add_array(table, 'test', children, stat) + call add_array(children, children2, stat) + + call new_package(package, table, error) + + end subroutine test_package_wrongtest + + + !> Try to read tests from a mixed type array + subroutine test_package_duplicate(error) + use fpm_manifest_package + use fpm_toml, only : set_value, add_table, add_array, toml_table, toml_array + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_table), pointer :: child + type(toml_array), pointer :: children + integer :: stat + type(package_config_t) :: package + + table = toml_table() + call set_value(table, 'name', '"example"', stat) + call add_array(table, 'test', children, stat) + call add_table(children, child, stat) + call set_value(child, 'name', '"prog"', stat) + call add_table(children, child, stat) + call set_value(child, 'name', '"prog"', stat) + + call new_package(package, table, error) + + end subroutine test_package_duplicate + + + !> 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_config_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 + use fpm_toml, only : new_table, toml_table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(test_config_t) :: test + + call new_table(table) + + call new_test(test, table, error) + + 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_config_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_config_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_config_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 + + + !> Create a simple example entry + subroutine test_example_simple(error) + use fpm_manifest_example + use fpm_toml, only : new_table, set_value, add_table, toml_table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_table), pointer :: child + integer :: stat + type(example_config_t) :: example + + call new_table(table) + call set_value(table, 'name', '"example"', stat) + call set_value(table, 'source-dir', '"demos"', stat) + call set_value(table, 'main', '"demo.f90"', stat) + call add_table(table, 'dependencies', child, stat) + + call new_example(example, table, error) + if (allocated(error)) return + + call check_string(error, example%main, "demo.f90", "Example main") + if (allocated(error)) return + + end subroutine test_example_simple + + + !> Examples cannot be created from empty tables + subroutine test_example_empty(error) + use fpm_manifest_example + use fpm_toml, only : new_table, toml_table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(example_config_t) :: example + + call new_table(table) + + call new_example(example, table, error) + + end subroutine test_example_empty + + + !> Test link options + subroutine test_link_string(error) + use fpm_manifest_build + use fpm_toml, only : set_value, toml_table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + integer :: stat + type(build_config_t) :: build + + table = toml_table() + call set_value(table, "link", "z", stat=stat) + + call new_build_config(build, table, error) + + end subroutine test_link_string + + + !> Test link options + subroutine test_link_array(error) + use fpm_manifest_build + use fpm_toml, only : add_array, set_value, toml_table, toml_array + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_array), pointer :: children + integer :: stat + type(build_config_t) :: build + + table = toml_table() + call add_array(table, "link", children, stat=stat) + call set_value(children, 1, "blas", stat=stat) + call set_value(children, 2, "lapack", stat=stat) + + call new_build_config(build, table, error) + + end subroutine test_link_array + + + !> Test link options + subroutine test_invalid_link(error) + use fpm_manifest_build + use fpm_toml, only : add_table, toml_table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_table), pointer :: child + integer :: stat + type(build_config_t) :: build + + table = toml_table() + call add_table(table, "link", child, stat=stat) + + call new_build_config(build, table, error) + + end subroutine test_invalid_link + + + subroutine test_install_library(error) + use fpm_manifest_install + use fpm_toml, only : toml_table, set_value + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(install_config_t) :: install + + table = toml_table() + call set_value(table, "library", .true.) + + call new_install_config(install, table, error) + if (allocated(error)) return + + if (.not.install%library) then + call test_failed(error, "Library entry should be true") + return + end if + + end subroutine test_install_library + + + subroutine test_install_empty(error) + use fpm_manifest_install + use fpm_toml, only : toml_table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(install_config_t) :: install + + table = toml_table() + + call new_install_config(install, table, error) + if (allocated(error)) return + + if (install%library) then + call test_failed(error, "Library default should be false") + return + end if + + end subroutine test_install_empty + + + subroutine test_install_wrongkey(error) + use fpm_manifest_install + use fpm_toml, only : toml_table, set_value + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(install_config_t) :: install + + table = toml_table() + call set_value(table, "prefix", "/some/install/path") + + call new_install_config(install, table, error) + + end subroutine test_install_wrongkey + + +end module test_manifest diff --git a/test/fpm_test/test_module_dependencies.f90 b/test/fpm_test/test_module_dependencies.f90 new file mode 100644 index 0000000..f193646 --- /dev/null +++ b/test/fpm_test/test_module_dependencies.f90 @@ -0,0 +1,666 @@ +!> Define tests for the `fpm_sources` module (module dependency checking) +module test_module_dependencies + use testsuite, only : new_unittest, unittest_t, error_t, test_failed + use fpm_targets, only: targets_from_sources, resolve_module_dependencies, & + resolve_target_linking, build_target_t, build_target_ptr, & + FPM_TARGET_EXECUTABLE, FPM_TARGET_OBJECT, FPM_TARGET_ARCHIVE + use fpm_model, only: fpm_model_t, srcfile_t, & + FPM_UNIT_UNKNOWN, FPM_UNIT_PROGRAM, FPM_UNIT_MODULE, & + FPM_UNIT_SUBMODULE, FPM_UNIT_SUBPROGRAM, FPM_UNIT_CSOURCE, & + FPM_UNIT_CHEADER, FPM_SCOPE_UNKNOWN, FPM_SCOPE_LIB, & + FPM_SCOPE_DEP, FPM_SCOPE_APP, FPM_SCOPE_TEST + use fpm_strings, only: string_t, operator(.in.) + use fpm, only: check_modules_for_duplicates + implicit none + private + + public :: collect_module_dependencies, operator(.in.) + + interface operator(.in.) + module procedure target_in + end interface + +contains + + + !> Collect all exported unit tests + subroutine collect_module_dependencies(testsuite) + + !> Collection of tests + type(unittest_t), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + & new_unittest("library-module-use", test_library_module_use), & + & new_unittest("program-module-use", test_program_module_use), & + & new_unittest("program-with-module", test_program_with_module), & + & new_unittest("program-own-module-use", test_program_own_module_use), & + & new_unittest("missing-library-use", & + test_missing_library_use, should_fail=.true.), & + & new_unittest("missing-program-use", & + test_missing_program_use, should_fail=.true.), & + & new_unittest("invalid-library-use", & + test_invalid_library_use, should_fail=.true.), & + & new_unittest("package-with-no-duplicates", & + test_package_with_no_module_duplicates), & + & new_unittest("package-with-duplicates-in-same-source", & + test_package_module_duplicates_same_source, should_fail=.true.), & + & new_unittest("package-with-duplicates-in-one-package", & + test_package_module_duplicates_one_package, should_fail=.true.), & + & new_unittest("package-with-duplicates-in-two-packages", & + test_package_module_duplicates_two_packages, should_fail=.true.), & + & new_unittest("subdirectory-module-use", & + test_subdirectory_module_use), & + & new_unittest("invalid-subdirectory-module-use", & + test_invalid_subdirectory_module_use, should_fail=.true.) & + ] + + end subroutine collect_module_dependencies + + + !> Check library module using another library module + subroutine test_library_module_use(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(fpm_model_t) :: model + type(build_target_ptr), allocatable :: targets(:) + + model%output_directory = '' + allocate(model%packages(1)) + allocate(model%packages(1)%sources(2)) + + model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_1.f90", & + scope = FPM_SCOPE_LIB, & + provides=[string_t('my_mod_1')]) + + model%packages(1)%sources(2) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_2.f90", & + scope = FPM_SCOPE_LIB, & + provides=[string_t('my_mod_2')], & + uses=[string_t('my_mod_1')]) + + call targets_from_sources(targets,model,error) + if (allocated(error)) return + + if (allocated(error)) then + return + end if + if (size(targets) /= 3) then + call test_failed(error,'Incorrect number of targets - expecting three') + return + end if + + call check_target(targets(1)%ptr,type=FPM_TARGET_ARCHIVE,n_depends=2, & + deps = [targets(2),targets(3)], & + links = targets(2:3), error=error) + + if (allocated(error)) return + + + call check_target(targets(2)%ptr,type=FPM_TARGET_OBJECT,n_depends=0, & + source=model%packages(1)%sources(1),error=error) + + if (allocated(error)) return + + + call check_target(targets(3)%ptr,type=FPM_TARGET_OBJECT,n_depends=1, & + deps=[targets(2)],source=model%packages(1)%sources(2),error=error) + + if (allocated(error)) return + + end subroutine test_library_module_use + + + !> Check a program using a library module + !> Each program generates two targets: object file and executable + !> + subroutine test_program_module_use(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call test_scope(FPM_SCOPE_APP,error) + if (allocated(error)) return + + call test_scope(FPM_SCOPE_TEST,error) + if (allocated(error)) return + + contains + + subroutine test_scope(exe_scope,error) + integer, intent(in) :: exe_scope + type(error_t), allocatable, intent(out) :: error + + integer :: i + type(fpm_model_t) :: model + type(build_target_ptr), allocatable :: targets(:) + character(:), allocatable :: scope_str + + model%output_directory = '' + allocate(model%packages(1)) + allocate(model%packages(1)%sources(2)) + + scope_str = merge('FPM_SCOPE_APP ','FPM_SCOPE_TEST',exe_scope==FPM_SCOPE_APP)//' - ' + + model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_1.f90", & + scope = FPM_SCOPE_LIB, & + provides=[string_t('my_mod_1')]) + + model%packages(1)%sources(2) = new_test_source(FPM_UNIT_PROGRAM,file_name="app/my_program.f90", & + scope=exe_scope, & + uses=[string_t('my_mod_1')]) + + call targets_from_sources(targets,model,error) + if (allocated(error)) return + + if (size(targets) /= 4) then + call test_failed(error,scope_str//'Incorrect number of targets - expecting three') + return + end if + + call check_target(targets(1)%ptr,type=FPM_TARGET_ARCHIVE,n_depends=1, & + deps=[targets(2)],links=[targets(2)],error=error) + + if (allocated(error)) return + + call check_target(targets(2)%ptr,type=FPM_TARGET_OBJECT,n_depends=0, & + source=model%packages(1)%sources(1),error=error) + + if (allocated(error)) return + + call check_target(targets(3)%ptr,type=FPM_TARGET_OBJECT,n_depends=1, & + deps=[targets(2)],source=model%packages(1)%sources(2),error=error) + + if (allocated(error)) return + + call check_target(targets(4)%ptr,type=FPM_TARGET_EXECUTABLE,n_depends=2, & + deps=[targets(1),targets(3)], & + links=[targets(3)], error=error) + + if (allocated(error)) return + + end subroutine test_scope + + end subroutine test_program_module_use + + + !> Check program with module in single source file + !> (Resulting target should not include itself as a dependency) + subroutine test_program_with_module(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: i + type(fpm_model_t) :: model + type(build_target_ptr), allocatable :: targets(:) + + model%output_directory = '' + allocate(model%packages(1)) + allocate(model%packages(1)%sources(1)) + + model%packages(1)%sources(1) = new_test_source(FPM_UNIT_PROGRAM,file_name="app/my_program.f90", & + scope = FPM_SCOPE_APP, & + provides=[string_t('app_mod')], & + uses=[string_t('app_mod')]) + + call targets_from_sources(targets,model,error) + if (allocated(error)) return + + if (size(targets) /= 2) then + write(*,*) size(targets) + call test_failed(error,'Incorrect number of targets - expecting two') + return + end if + + call check_target(targets(1)%ptr,type=FPM_TARGET_OBJECT,n_depends=0, & + source=model%packages(1)%sources(1),error=error) + + if (allocated(error)) return + + call check_target(targets(2)%ptr,type=FPM_TARGET_EXECUTABLE,n_depends=1, & + deps=[targets(1)],links=[targets(1)],error=error) + + if (allocated(error)) return + + end subroutine test_program_with_module + + + !> Check program using modules in same directory + subroutine test_program_own_module_use(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call test_scope(FPM_SCOPE_APP,error) + if (allocated(error)) return + + call test_scope(FPM_SCOPE_TEST,error) + if (allocated(error)) return + + contains + + subroutine test_scope(exe_scope,error) + integer, intent(in) :: exe_scope + type(error_t), allocatable, intent(out) :: error + + type(fpm_model_t) :: model + type(build_target_ptr), allocatable :: targets(:) + character(:), allocatable :: scope_str + + model%output_directory = '' + allocate(model%packages(1)) + allocate(model%packages(1)%sources(3)) + + scope_str = merge('FPM_SCOPE_APP ','FPM_SCOPE_TEST',exe_scope==FPM_SCOPE_APP)//' - ' + + model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="app/app_mod1.f90", & + scope = exe_scope, & + provides=[string_t('app_mod1')]) + + model%packages(1)%sources(2) = new_test_source(FPM_UNIT_MODULE,file_name="app/app_mod2.f90", & + scope = exe_scope, & + provides=[string_t('app_mod2')],uses=[string_t('app_mod1')]) + + model%packages(1)%sources(3) = new_test_source(FPM_UNIT_PROGRAM,file_name="app/my_program.f90", & + scope=exe_scope, & + uses=[string_t('app_mod2')]) + + call targets_from_sources(targets,model,error) + if (allocated(error)) return + + if (size(targets) /= 4) then + call test_failed(error,scope_str//'Incorrect number of targets - expecting three') + return + end if + + call check_target(targets(1)%ptr,type=FPM_TARGET_OBJECT,n_depends=0, & + source=model%packages(1)%sources(1),error=error) + + if (allocated(error)) return + + call check_target(targets(2)%ptr,type=FPM_TARGET_OBJECT,n_depends=1, & + source=model%packages(1)%sources(2),deps=[targets(1)],error=error) + + if (allocated(error)) return + + call check_target(targets(3)%ptr,type=FPM_TARGET_OBJECT,n_depends=1, & + source=model%packages(1)%sources(3),deps=[targets(2)],error=error) + + if (allocated(error)) return + + call check_target(targets(4)%ptr,type=FPM_TARGET_EXECUTABLE,n_depends=1, & + deps=[targets(3)],links=targets(1:3), error=error) + + if (allocated(error)) return + + end subroutine test_scope + end subroutine test_program_own_module_use + + + !> Check missing library module dependency + subroutine test_missing_library_use(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(fpm_model_t) :: model + type(build_target_ptr), allocatable :: targets(:) + + model%output_directory = '' + allocate(model%packages(1)) + allocate(model%packages(1)%sources(2)) + + model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_1.f90", & + scope = FPM_SCOPE_LIB, & + provides=[string_t('my_mod_1')]) + + model%packages(1)%sources(2) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_2.f90", & + scope = FPM_SCOPE_LIB, & + provides=[string_t('my_mod_2')], & + uses=[string_t('my_mod_3')]) + + call targets_from_sources(targets,model,error) + + end subroutine test_missing_library_use + + + !> Check missing program module dependency + subroutine test_missing_program_use(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(fpm_model_t) :: model + type(build_target_ptr), allocatable :: targets(:) + + model%output_directory = '' + allocate(model%packages(1)) + allocate(model%packages(1)%sources(2)) + + model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_1.f90", & + scope = FPM_SCOPE_LIB, & + provides=[string_t('my_mod_1')]) + + model%packages(1)%sources(2) = new_test_source(FPM_UNIT_PROGRAM,file_name="app/my_program.f90", & + scope=FPM_SCOPE_APP, & + uses=[string_t('my_mod_2')]) + + call targets_from_sources(targets,model,error) + + end subroutine test_missing_program_use + + + !> Check library module using a non-library module + subroutine test_invalid_library_use(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(fpm_model_t) :: model + type(build_target_ptr), allocatable :: targets(:) + + model%output_directory = '' + allocate(model%packages(1)) + allocate(model%packages(1)%sources(2)) + + model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="app/app_mod.f90", & + scope = FPM_SCOPE_APP, & + provides=[string_t('app_mod')]) + + model%packages(1)%sources(2) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod.f90", & + scope = FPM_SCOPE_LIB, & + provides=[string_t('my_mod')], & + uses=[string_t('app_mod')]) + + call targets_from_sources(targets,model,error) + + end subroutine test_invalid_library_use + + + !> Check program using a non-library module in a sub-directory + subroutine test_subdirectory_module_use(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(fpm_model_t) :: model + type(build_target_ptr), allocatable :: targets(:) + + model%output_directory = '' + allocate(model%packages(1)) + allocate(model%packages(1)%sources(2)) + + model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="app/subdir/app_mod.f90", & + scope = FPM_SCOPE_APP, & + provides=[string_t('app_mod')]) + + model%packages(1)%sources(2) = new_test_source(FPM_UNIT_PROGRAM,file_name="app/my_program.f90", & + scope=FPM_SCOPE_APP, & + uses=[string_t('app_mod')]) + + call targets_from_sources(targets,model,error) + + end subroutine test_subdirectory_module_use + + !> Check program with no duplicate modules + subroutine test_package_with_no_module_duplicates(error) + + type(error_t), allocatable, intent(out) :: error + + type(fpm_model_t) :: model + logical :: duplicates_found = .false. + + allocate(model%packages(1)) + allocate(model%packages(1)%sources(2)) + + model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_1.f90", & + scope = FPM_SCOPE_LIB, provides=[string_t('my_mod_1')]) + + model%packages(1)%sources(2) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_2.f90", & + scope = FPM_SCOPE_LIB, provides=[string_t('my_mod_2')]) + + call check_modules_for_duplicates(model, duplicates_found) + if (duplicates_found) then + call test_failed(error,'Duplicate modules found') + return + end if + end subroutine test_package_with_no_module_duplicates + + !> Check program with duplicate modules in same source file + subroutine test_package_module_duplicates_same_source(error) + + type(error_t), allocatable, intent(out) :: error + + type(fpm_model_t) :: model + logical :: duplicates_found + + allocate(model%packages(1)) + allocate(model%packages(1)%sources(1)) + + model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_1.f90", & + scope = FPM_SCOPE_LIB, provides=[string_t('my_mod_1'), string_t('my_mod_1')]) + + call check_modules_for_duplicates(model, duplicates_found) + if (duplicates_found) then + call test_failed(error,'Duplicate modules found') + return + end if + end subroutine test_package_module_duplicates_same_source + + !> Check program with duplicate modules in two different source files in one package + subroutine test_package_module_duplicates_one_package(error) + + type(error_t), allocatable, intent(out) :: error + + type(fpm_model_t) :: model + logical :: duplicates_found + + allocate(model%packages(1)) + allocate(model%packages(1)%sources(2)) + + model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_1_a.f90", & + scope = FPM_SCOPE_LIB, provides=[string_t('my_mod_1')]) + + model%packages(1)%sources(2) = new_test_source(FPM_UNIT_MODULE,file_name="src/my_mod_1_b.f90", & + scope = FPM_SCOPE_LIB, provides=[string_t('my_mod_1')]) + + call check_modules_for_duplicates(model, duplicates_found) + if (duplicates_found) then + call test_failed(error,'Duplicate modules found') + return + end if + end subroutine test_package_module_duplicates_one_package + + !> Check program with duplicate modules in two different packages + subroutine test_package_module_duplicates_two_packages(error) + + type(error_t), allocatable, intent(out) :: error + + type(fpm_model_t) :: model + logical :: duplicates_found + + allocate(model%packages(2)) + allocate(model%packages(1)%sources(1)) + allocate(model%packages(2)%sources(1)) + + model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="src/subdir1/my_mod_1.f90", & + scope = FPM_SCOPE_LIB, provides=[string_t('my_mod_1')]) + + model%packages(2)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="src/subdir2/my_mod_1.f90", & + scope = FPM_SCOPE_LIB, provides=[string_t('my_mod_1')]) + + call check_modules_for_duplicates(model, duplicates_found) + if (duplicates_found) then + call test_failed(error,'Duplicate modules found') + return + end if + end subroutine test_package_module_duplicates_two_packages + + !> Check program using a non-library module in a differente sub-directory + subroutine test_invalid_subdirectory_module_use(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(fpm_model_t) :: model + type(build_target_ptr), allocatable :: targets(:) + + model%output_directory = '' + allocate(model%packages(1)) + allocate(model%packages(1)%sources(2)) + + model%packages(1)%sources(1) = new_test_source(FPM_UNIT_MODULE,file_name="app/diff_dir/app_mod.f90", & + scope = FPM_SCOPE_APP, & + provides=[string_t('app_mod')]) + + model%packages(1)%sources(2) = new_test_source(FPM_UNIT_PROGRAM,file_name="app/prog_dir/my_program.f90", & + scope=FPM_SCOPE_APP, & + uses=[string_t('app_mod')]) + + call targets_from_sources(targets,model,error) + + end subroutine test_invalid_subdirectory_module_use + + !> Helper to create a new srcfile_t + function new_test_source(type,file_name, scope, uses, provides) result(src) + integer, intent(in) :: type + character(*), intent(in) :: file_name + integer, intent(in) :: scope + type(string_t), intent(in), optional :: uses(:) + type(string_t), intent(in), optional :: provides(:) + type(srcfile_t) :: src + + src%file_name = file_name + src%unit_scope = scope + src%unit_type = type + + if (present(provides)) then + src%modules_provided = provides + else + allocate(src%modules_provided(0)) + end if + + if (present(uses)) then + src%modules_used = uses + else + allocate(src%modules_used(0)) + end if + + allocate(src%include_dependencies(0)) + + end function new_test_source + + + !> Helper to check an expected output target + subroutine check_target(target,type,n_depends,deps,links,source,error) + type(build_target_t), intent(in) :: target + integer, intent(in) :: type + integer, intent(in) :: n_depends + type(srcfile_t), intent(in), optional :: source + type(build_target_ptr), intent(in), optional :: deps(:) + type(build_target_ptr), intent(in), optional :: links(:) + type(error_t), intent(out), allocatable :: error + + integer :: i + + if (target%target_type /= type) then + call test_failed(error,'Unexpected target_type for target "'//target%output_file//'"') + return + end if + + if (size(target%dependencies) /= n_depends) then + call test_failed(error,'Wrong number of dependencies for target "'//target%output_file//'"') + return + end if + + if (present(deps)) then + + do i=1,size(deps) + + if (.not.(deps(i)%ptr .in. target%dependencies)) then + call test_failed(error,'Missing dependency ('//deps(i)%ptr%output_file//& + ') for target "'//target%output_file//'"') + return + end if + + end do + + end if + + if (present(links)) then + + do i=1,size(links) + + if (.not.(links(i)%ptr%output_file .in. target%link_objects)) then + call test_failed(error,'Missing object ('//links(i)%ptr%output_file//& + ') for executable "'//target%output_file//'"') + return + end if + + end do + + if (size(links) > size(target%link_objects)) then + + call test_failed(error,'There are missing link objects for target "'& + //target%output_file//'"') + return + + elseif (size(links) < size(target%link_objects)) then + + call test_failed(error,'There are more link objects than expected for target "'& + //target%output_file//'"') + return + + end if + + end if + + if (present(source)) then + + if (allocated(target%source)) then + if (target%source%file_name /= source%file_name) then + call test_failed(error,'Incorrect source ('//target%source%file_name//') for target "'//& + target%output_file//'"'//new_line('a')//' expected "'//source%file_name//'"') + return + end if + + else + call test_failed(error,'Expecting source for target "'//target%output_file//'" but none found') + return + end if + + else + + if (allocated(target%source)) then + call test_failed(error,'Found source ('//target%source%file_name//') for target "'//& + target%output_file//'" but none expected') + return + end if + + end if + + end subroutine check_target + + + !> Helper to check if a build target is in a list of build_target_ptr + logical function target_in(needle,haystack) + type(build_target_t), intent(in), target :: needle + type(build_target_ptr), intent(in) :: haystack(:) + + integer :: i + + target_in = .false. + do i=1,size(haystack) + + if (associated(haystack(i)%ptr,needle)) then + target_in = .true. + return + end if + + end do + + end function target_in + + +end module test_module_dependencies diff --git a/test/fpm_test/test_package_dependencies.f90 b/test/fpm_test/test_package_dependencies.f90 new file mode 100644 index 0000000..b70ac13 --- /dev/null +++ b/test/fpm_test/test_package_dependencies.f90 @@ -0,0 +1,240 @@ +!> Define tests for the `fpm_dependency` module +module test_package_dependencies + use fpm_filesystem, only: get_temp_filename + use testsuite, only : new_unittest, unittest_t, error_t, test_failed + use fpm_dependency + use fpm_manifest + use fpm_manifest_dependency + use fpm_toml + implicit none + private + + public :: collect_package_dependencies + + type, extends(dependency_tree_t) :: mock_dependency_tree_t + contains + procedure :: resolve_dependency => resolve_dependency_once + end type mock_dependency_tree_t + + +contains + + + !> Collect all exported unit tests + subroutine collect_package_dependencies(testsuite) + + !> Collection of tests + type(unittest_t), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + & new_unittest("cache-load-dump", test_cache_load_dump), & + & new_unittest("cache-dump-load", test_cache_dump_load), & + & new_unittest("status-after-load", test_status), & + & new_unittest("add-dependencies", test_add_dependencies)] + + end subroutine collect_package_dependencies + + + !> Round trip of the dependency cache from a dependency tree to a TOML document + !> to a dependency tree + subroutine test_cache_dump_load(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(dependency_tree_t) :: deps + type(dependency_config_t) :: dep + integer :: unit + + call new_dependency_tree(deps) + call resize(deps%dep, 5) + deps%ndep = 3 + dep%name = "dep1" + dep%path = "fpm-tmp1-dir" + call new_dependency_node(deps%dep(1), dep, proj_dir=dep%path) + dep%name = "dep2" + dep%path = "fpm-tmp2-dir" + call new_dependency_node(deps%dep(2), dep, proj_dir=dep%path) + dep%name = "dep3" + dep%path = "fpm-tmp3-dir" + call new_dependency_node(deps%dep(3), dep, proj_dir=dep%path) + + open(newunit=unit, status='scratch') + call deps%dump(unit, error) + if (.not.allocated(error)) then + rewind(unit) + + call new_dependency_tree(deps) + call resize(deps%dep, 2) + call deps%load(unit, error) + close(unit) + end if + if (allocated(error)) return + + if (deps%ndep /= 3) then + call test_failed(error, "Expected three dependencies in loaded cache") + return + end if + + end subroutine test_cache_dump_load + + + !> Round trip of the dependency cache from a TOML data structure to + !> a dependency tree to a TOML data structure + subroutine test_cache_load_dump(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_table), pointer :: ptr + type(toml_key), allocatable :: list(:) + type(dependency_tree_t) :: deps + + table = toml_table() + call add_table(table, "dep1", ptr) + call set_value(ptr, "version", "1.1.0") + call set_value(ptr, "proj-dir", "fpm-tmp1-dir") + call add_table(table, "dep2", ptr) + call set_value(ptr, "version", "0.55.3") + call set_value(ptr, "proj-dir", "fpm-tmp2-dir") + call set_value(ptr, "git", "https://github.com/fortran-lang/dep2") + call add_table(table, "dep3", ptr) + call set_value(ptr, "version", "20.1.15") + call set_value(ptr, "proj-dir", "fpm-tmp3-dir") + call set_value(ptr, "git", "https://gitlab.com/fortran-lang/dep3") + call set_value(ptr, "rev", "c0ffee") + call add_table(table, "dep4", ptr) + call set_value(ptr, "proj-dir", "fpm-tmp4-dir") + + call new_dependency_tree(deps) + call deps%load(table, error) + if (allocated(error)) return + + if (deps%ndep /= 4) then + call test_failed(error, "Expected four dependencies in loaded cache") + return + end if + + call table%destroy + table = toml_table() + + call deps%dump(table, error) + if (allocated(error)) return + + call table%get_keys(list) + + if (size(list) /= 4) then + call test_failed(error, "Expected four dependencies in dumped cache") + return + end if + + end subroutine test_cache_load_dump + + + subroutine test_status(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_table), pointer :: ptr + type(toml_key), allocatable :: list(:) + type(dependency_tree_t) :: deps + + table = toml_table() + call add_table(table, "dep1", ptr) + call set_value(ptr, "version", "1.1.0") + call set_value(ptr, "proj-dir", "fpm-tmp1-dir") + call add_table(table, "dep2", ptr) + call set_value(ptr, "version", "0.55.3") + call set_value(ptr, "proj-dir", "fpm-tmp2-dir") + call set_value(ptr, "git", "https://github.com/fortran-lang/dep2") + + call new_dependency_tree(deps) + call deps%load(table, error) + if (allocated(error)) return + + if (deps%finished()) then + call test_failed(error, "Newly initialized dependency tree cannot be reolved") + return + end if + + end subroutine test_status + + + subroutine test_add_dependencies(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_table), pointer :: child, ptr + type(toml_key), allocatable :: list(:) + type(mock_dependency_tree_t) :: deps + type(dependency_config_t), allocatable :: nodes(:) + + table = toml_table() + call add_table(table, "sub1", ptr) + call set_value(ptr, "path", "external") + call add_table(table, "lin2", ptr) + call set_value(ptr, "git", "https://github.com/fortran-lang/lin2") + call add_table(table, "pkg3", ptr) + call set_value(ptr, "git", "https://gitlab.com/fortran-lang/pkg3") + call set_value(ptr, "rev", "c0ffee") + call add_table(table, "proj4", ptr) + call set_value(ptr, "path", "vendor") + + call new_dependencies(nodes, table, error) + if (allocated(error)) return + + call new_dependency_tree(deps%dependency_tree_t) + call deps%add(nodes, error) + if (allocated(error)) return + + if (deps%finished()) then + call test_failed(error, "Newly added nodes cannot be already resolved") + return + end if + + if (deps%ndep /= 4) then + call test_failed(error, "Expected for dependencies in tree") + return + end if + + call deps%resolve(".", error) + if (allocated(error)) return + + if (.not.deps%finished()) then + call test_failed(error, "Mocked dependency tree must resolve in one step") + return + end if + + end subroutine test_add_dependencies + + + !> Resolve a single dependency node + subroutine resolve_dependency_once(self, dependency, root, error) + !> Mock instance of the dependency tree + class(mock_dependency_tree_t), intent(inout) :: self + !> Dependency configuration to add + type(dependency_node_t), intent(inout) :: dependency + !> Current installation prefix + character(len=*), intent(in) :: root + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(package_config_t) :: package + character(len=:), allocatable :: manifest, proj_dir, revision + logical :: fetch + + if (dependency%done) then + call test_failed(error, "Should only visit this node once") + return + end if + dependency%done = .true. + + end subroutine resolve_dependency_once + + +end module test_package_dependencies diff --git a/test/fpm_test/test_source_parsing.f90 b/test/fpm_test/test_source_parsing.f90 new file mode 100644 index 0000000..79a4d7a --- /dev/null +++ b/test/fpm_test/test_source_parsing.f90 @@ -0,0 +1,758 @@ +!> Define tests for the `fpm_sources` module (parsing routines) +module test_source_parsing + use testsuite, only : new_unittest, unittest_t, error_t, test_failed + use fpm_filesystem, only: get_temp_filename + use fpm_source_parsing, only: parse_f_source, parse_c_source + use fpm_model, only: srcfile_t, FPM_UNIT_PROGRAM, FPM_UNIT_MODULE, & + FPM_UNIT_SUBMODULE, FPM_UNIT_SUBPROGRAM, FPM_UNIT_CSOURCE + use fpm_strings, only: operator(.in.) + implicit none + private + + public :: collect_source_parsing + +contains + + + !> Collect all exported unit tests + subroutine collect_source_parsing(testsuite) + + !> Collection of tests + type(unittest_t), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + & new_unittest("modules-used", test_modules_used), & + & new_unittest("intrinsic-modules-used", test_intrinsic_modules_used), & + & new_unittest("include-stmt", test_include_stmt), & + & new_unittest("program", test_program), & + & new_unittest("module", test_module), & + & new_unittest("program-with-module", test_program_with_module), & + & new_unittest("submodule", test_submodule), & + & new_unittest("submodule-ancestor", test_submodule_ancestor), & + & new_unittest("subprogram", test_subprogram), & + & new_unittest("csource", test_csource), & + & new_unittest("invalid-use-stmt", & + test_invalid_use_stmt, should_fail=.true.), & + & new_unittest("invalid-include-stmt", & + test_invalid_include_stmt, should_fail=.true.), & + & new_unittest("invalid-module", & + test_invalid_module, should_fail=.true.), & + & new_unittest("invalid-submodule", & + test_invalid_submodule, should_fail=.true.) & + ] + + end subroutine collect_source_parsing + + + !> Check parsing of module 'USE' statements + subroutine test_modules_used(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source + + allocate(temp_file, source=get_temp_filename()) + + open(file=temp_file, newunit=unit) + write(unit, '(a)') & + & 'program test', & + & ' use module_one', & + & ' use :: module_two', & + & ' use module_three, only: a, b, c', & + & ' use :: module_four, only: a => b', & + & '! use module_not_used', & + & ' implicit none', & + & 'end program test' + close(unit) + + f_source = parse_f_source(temp_file,error) + if (allocated(error)) then + return + end if + + if (f_source%unit_type /= FPM_UNIT_PROGRAM) then + call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_PROGRAM') + return + end if + + if (size(f_source%modules_provided) /= 0) then + call test_failed(error,'Unexpected modules_provided - expecting zero') + return + end if + + if (size(f_source%modules_used) /= 4) then + call test_failed(error,'Incorrect number of modules_used - expecting four') + return + end if + + if (.not.('module_one' .in. f_source%modules_used)) then + call test_failed(error,'Missing module in modules_used') + return + end if + + if (.not.('module_two' .in. f_source%modules_used)) then + call test_failed(error,'Missing module in modules_used') + return + end if + + if (.not.('module_three' .in. f_source%modules_used)) then + call test_failed(error,'Missing module in modules_used') + return + end if + + if (.not.('module_four' .in. f_source%modules_used)) then + call test_failed(error,'Missing module in modules_used') + return + end if + + if ('module_not_used' .in. f_source%modules_used) then + call test_failed(error,'Commented module found in modules_used') + return + end if + + end subroutine test_modules_used + + + !> Check that intrinsic modules are properly ignore + subroutine test_intrinsic_modules_used(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source + + allocate(temp_file, source=get_temp_filename()) + + open(file=temp_file, newunit=unit) + write(unit, '(a)') & + & 'program test', & + & ' use iso_c_binding', & + & ' use iso_fortran_env', & + & ' use ieee_arithmetic', & + & ' use ieee_exceptions', & + & ' use ieee_features', & + & ' implicit none', & + & 'end program test' + close(unit) + + f_source = parse_f_source(temp_file,error) + if (allocated(error)) then + return + end if + + if (size(f_source%modules_provided) /= 0) then + call test_failed(error,'Unexpected modules_provided - expecting zero') + return + end if + + if (size(f_source%modules_used) /= 0) then + call test_failed(error,'Incorrect number of modules_used - expecting zero') + return + end if + + if ('iso_c_binding' .in. f_source%modules_used) then + call test_failed(error,'Intrinsic module found in modules_used') + return + end if + + if ('iso_fortran_env' .in. f_source%modules_used) then + call test_failed(error,'Intrinsic module found in modules_used') + return + end if + + if ('ieee_arithmetic' .in. f_source%modules_used) then + call test_failed(error,'Intrinsic module found in modules_used') + return + end if + + if ('ieee_exceptions' .in. f_source%modules_used) then + call test_failed(error,'Intrinsic module found in modules_used') + return + end if + + if ('ieee_features' .in. f_source%modules_used) then + call test_failed(error,'Intrinsic module found in modules_used') + return + end if + + end subroutine test_intrinsic_modules_used + + + !> Check parsing of include statements + subroutine test_include_stmt(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source + + allocate(temp_file, source=get_temp_filename()) + + open(file=temp_file, newunit=unit) + write(unit, '(a)') & + & 'program test', & + & ' implicit none', & + & ' include "included_file.f90"', & + & ' character(*) :: include_comments', & + & ' include_comments = "some comments"', & + & ' contains ', & + & ' include"second_include.f90"', & + & 'end program test' + close(unit) + + f_source = parse_f_source(temp_file,error) + if (allocated(error)) then + return + end if + + if (size(f_source%modules_provided) /= 0) then + call test_failed(error,'Unexpected modules_provided - expecting zero') + return + end if + + if (size(f_source%modules_used) /= 0) then + call test_failed(error,'Incorrect number of modules_used - expecting zero') + return + end if + + if (size(f_source%include_dependencies) /= 2) then + call test_failed(error,'Incorrect number of include_dependencies - expecting two') + return + end if + + if (.not.('included_file.f90' .in. f_source%include_dependencies)) then + call test_failed(error,'Missing include file in include_dependencies') + return + end if + + if (.not.('second_include.f90' .in. f_source%include_dependencies)) then + call test_failed(error,'Missing include file in include_dependencies') + return + end if + + end subroutine test_include_stmt + + !> Try to parse a simple fortran program + subroutine test_program(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source + + allocate(temp_file, source=get_temp_filename()) + + open(file=temp_file, newunit=unit) + write(unit, '(a)') & + & 'program my_program', & + & 'use module_one', & + & 'implicit none', & + & 'integer :: module', & + & 'module = 1', & + & 'module= 1', & + & 'module =1', & + & 'module (i) =1', & + & 'contains', & + & 'subroutine f()', & + & 'end subroutine f', & + & 'end program my_program' + close(unit) + + f_source = parse_f_source(temp_file,error) + if (allocated(error)) then + return + end if + + if (f_source%unit_type /= FPM_UNIT_PROGRAM) then + call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_PROGRAM') + return + end if + + if (size(f_source%modules_provided) /= 0) then + call test_failed(error,'Unexpected modules_provided - expecting zero') + return + end if + + if (size(f_source%modules_used) /= 1) then + call test_failed(error,'Incorrect number of modules_used - expecting one') + return + end if + + if (.not.('module_one' .in. f_source%modules_used)) then + call test_failed(error,'Missing module in modules_used') + return + end if + + end subroutine test_program + + + !> Try to parse fortran module + subroutine test_module(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source + + allocate(temp_file, source=get_temp_filename()) + + open(file=temp_file, newunit=unit) + write(unit, '(a)') & + & 'module my_mod', & + & 'use module_one', & + & 'interface', & + & ' module subroutine f()', & + & 'end interface', & + & 'integer :: program', & + & 'program = 1', & + & 'program= 1', & + & 'program =1', & + & 'program (i) =1', & + & 'contains', & + & 'module procedure f()', & + & 'end procedure f', & + & 'end module test' + close(unit) + + f_source = parse_f_source(temp_file,error) + if (allocated(error)) then + return + end if + + if (f_source%unit_type /= FPM_UNIT_MODULE) then + call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_MODULE') + return + end if + + if (size(f_source%modules_provided) /= 1) then + call test_failed(error,'Unexpected modules_provided - expecting one') + return + end if + + if (size(f_source%modules_used) /= 1) then + call test_failed(error,'Incorrect number of modules_used - expecting one') + return + end if + + if (.not.('my_mod' .in. f_source%modules_provided)) then + call test_failed(error,'Missing module in modules_provided') + return + end if + + if (.not.('module_one' .in. f_source%modules_used)) then + call test_failed(error,'Missing module in modules_used') + return + end if + + end subroutine test_module + + + !> Try to parse combined fortran module and program + !> Check that parsed unit type is FPM_UNIT_PROGRAM + subroutine test_program_with_module(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source + + allocate(temp_file, source=get_temp_filename()) + + open(file=temp_file, newunit=unit) + write(unit, '(a)') & + & 'module my_mod', & + & 'use module_one', & + & 'interface', & + & ' module subroutine f()', & + & 'end interface', & + & 'contains', & + & 'module procedure f()', & + & 'end procedure f', & + & 'end module test', & + & 'program my_program', & + & 'use my_mod', & + & 'implicit none', & + & 'end my_program' + close(unit) + + f_source = parse_f_source(temp_file,error) + if (allocated(error)) then + return + end if + + if (f_source%unit_type /= FPM_UNIT_PROGRAM) then + call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_PROGRAM') + return + end if + + if (size(f_source%modules_provided) /= 1) then + call test_failed(error,'Unexpected modules_provided - expecting one') + return + end if + + if (.not.('my_mod' .in. f_source%modules_provided)) then + call test_failed(error,'Missing module in modules_provided') + return + end if + + if (.not.('module_one' .in. f_source%modules_used)) then + call test_failed(error,'Missing module in modules_used') + return + end if + + if (.not.('my_mod' .in. f_source%modules_used)) then + call test_failed(error,'Missing module in modules_used') + return + end if + + end subroutine test_program_with_module + + + !> Try to parse fortran submodule for ancestry + subroutine test_submodule(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source + + allocate(temp_file, source=get_temp_filename()) + + open(file=temp_file, newunit=unit) + write(unit, '(a)') & + & 'submodule (parent) child', & + & 'use module_one', & + & 'end submodule test' + close(unit) + + f_source = parse_f_source(temp_file,error) + if (allocated(error)) then + return + end if + + if (f_source%unit_type /= FPM_UNIT_SUBMODULE) then + call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_SUBMODULE') + return + end if + + if (size(f_source%modules_provided) /= 1) then + call test_failed(error,'Unexpected modules_provided - expecting one') + return + end if + + if (size(f_source%modules_used) /= 2) then + call test_failed(error,'Incorrect number of modules_used - expecting two') + return + end if + + if (.not.('child' .in. f_source%modules_provided)) then + call test_failed(error,'Missing module in modules_provided') + return + end if + + if (.not.('module_one' .in. f_source%modules_used)) then + call test_failed(error,'Missing module in modules_used') + return + end if + + if (.not.('parent' .in. f_source%modules_used)) then + call test_failed(error,'Missing parent module in modules_used') + return + end if + + end subroutine test_submodule + + + !> Try to parse fortran multi-level submodule for ancestry + subroutine test_submodule_ancestor(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source + + allocate(temp_file, source=get_temp_filename()) + + open(file=temp_file, newunit=unit) + write(unit, '(a)') & + & 'submodule (ancestor:parent) child', & + & 'use module_one', & + & 'end submodule test' + close(unit) + + f_source = parse_f_source(temp_file,error) + if (allocated(error)) then + return + end if + + if (f_source%unit_type /= FPM_UNIT_SUBMODULE) then + call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_SUBMODULE') + return + end if + + if (size(f_source%modules_provided) /= 1) then + call test_failed(error,'Unexpected modules_provided - expecting one') + return + end if + + if (size(f_source%modules_used) /= 2) then + call test_failed(error,'Incorrect number of modules_used - expecting two') + return + end if + + if (.not.('child' .in. f_source%modules_provided)) then + call test_failed(error,'Missing module in modules_provided') + return + end if + + if (.not.('module_one' .in. f_source%modules_used)) then + call test_failed(error,'Missing module in modules_used') + return + end if + + if (.not.('parent' .in. f_source%modules_used)) then + call test_failed(error,'Missing parent module in modules_used') + return + end if + + end subroutine test_submodule_ancestor + + + !> Try to parse standard fortran sub-program (non-module) source + subroutine test_subprogram(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source + + allocate(temp_file, source=get_temp_filename()) + + open(file=temp_file, newunit=unit) + write(unit, '(a)') & + & 'subroutine my_sub(a)', & + & ' use module_one', & + & ' integer, intent(in) :: a', & + & 'end subroutine my_sub' + close(unit) + + f_source = parse_f_source(temp_file,error) + if (allocated(error)) then + return + end if + + if (f_source%unit_type /= FPM_UNIT_SUBPROGRAM) then + call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_SUBPROGRAM') + return + end if + + if (size(f_source%modules_provided) /= 0) then + call test_failed(error,'Unexpected modules_provided - expecting zero') + return + end if + + if (size(f_source%modules_used) /= 1) then + call test_failed(error,'Incorrect number of modules_used - expecting one') + return + end if + + if (.not.('module_one' .in. f_source%modules_used)) then + call test_failed(error,'Missing module in modules_used') + return + end if + + end subroutine test_subprogram + + + !> Try to parse standard c source for includes + subroutine test_csource(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source + + allocate(temp_file, source=get_temp_filename()) + temp_file = temp_file//'.c' + + open(file=temp_file, newunit=unit) + write(unit, '(a)') & + & '#include "proto.h"', & + & 'void c_func(int a) {', & + & ' #include "function_body.c"', & + & ' return', & + & '}' + close(unit) + + f_source = parse_c_source(temp_file,error) + if (allocated(error)) then + return + end if + + if (f_source%unit_type /= FPM_UNIT_CSOURCE) then + call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_CSOURCE') + return + end if + + if (size(f_source%modules_provided) /= 0) then + call test_failed(error,'Unexpected modules_provided - expecting zero') + return + end if + + if (size(f_source%modules_used) /= 0) then + call test_failed(error,'Incorrect number of modules_used - expecting zero') + return + end if + + if (size(f_source%include_dependencies) /= 2) then + call test_failed(error,'Incorrect number of include_dependencies - expecting two') + return + end if + + if (.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/test/fpm_test/test_toml.f90 b/test/fpm_test/test_toml.f90 new file mode 100644 index 0000000..ba48307 --- /dev/null +++ b/test/fpm_test/test_toml.f90 @@ -0,0 +1,107 @@ +!> Define tests for the `fpm_toml` modules +module test_toml + use testsuite, only : new_unittest, unittest_t, error_t + use fpm_toml + implicit none + private + + public :: collect_toml + + +contains + + + !> Collect all exported unit tests + subroutine collect_toml(testsuite) + + !> Collection of tests + type(unittest_t), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + & new_unittest("valid-toml", test_valid_toml), & + & new_unittest("invalid-toml", test_invalid_toml, should_fail=.true.), & + & new_unittest("missing-file", test_missing_file, should_fail=.true.)] + + end subroutine collect_toml + + + !> Try to read some unnecessary obscure and convoluted but not invalid package file + subroutine test_valid_toml(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table), allocatable :: table + character(len=*), parameter :: manifest = 'fpm-valid-toml.toml' + integer :: unit + + open(file=manifest, newunit=unit) + write(unit, '(a)') & + & 'name = "example"', & + & '[dependencies.fpm]', & + & 'git = "https://github.com/fortran-lang/fpm"', & + & '[[executable]]', & + & 'name = "example-#1" # comment', & + & 'source-dir = "prog"', & + & '[dependencies]', & + & 'toml-f.git = "git@github.com:toml-f/toml-f.git"', & + & '"toml..f" = { path = ".." }', & + & '[["executable"]]', & + & 'name = "example-#2"', & + & 'source-dir = "prog"', & + & '[executable.dependencies]', & + & '[''library'']', & + & 'source-dir = """', & + & 'lib""" # comment' + close(unit) + + call read_package_file(table, manifest, error) + + open(file=manifest, newunit=unit) + close(unit, status='delete') + + end subroutine test_valid_toml + + + !> Try to read an invalid TOML document + subroutine test_invalid_toml(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table), allocatable :: table + character(len=*), parameter :: manifest = 'fpm-invalid-toml.toml' + integer :: unit + + open(file=manifest, newunit=unit) + write(unit, '(a)') & + & '# INVALID TOML DOC', & + & 'name = "example"', & + & 'dependencies.fpm.git = "https://github.com/fortran-lang/fpm"', & + & '[dependencies]', & + & 'toml-f.git = "git@github.com:toml-f/toml-f.git"', & + & '"toml..f" = { path = ".." }' + close(unit) + + call read_package_file(table, manifest, error) + + open(file=manifest, newunit=unit) + close(unit, status='delete') + + end subroutine test_invalid_toml + + + !> Try to read configuration from a non-existing file + subroutine test_missing_file(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table), allocatable :: table + + call read_package_file(table, 'low+chance+of+existing.toml', error) + + end subroutine test_missing_file + + +end module test_toml diff --git a/test/fpm_test/test_versioning.f90 b/test/fpm_test/test_versioning.f90 new file mode 100644 index 0000000..f6dcb57 --- /dev/null +++ b/test/fpm_test/test_versioning.f90 @@ -0,0 +1,405 @@ +!> Test implementation of version data type +module test_versioning + use testsuite, only : new_unittest, unittest_t, error_t, test_failed + use fpm_versioning + implicit none + private + + public :: collect_versioning + + +contains + + + !> Collect all exported unit tests + subroutine collect_versioning(testsuite) + + !> Collection of tests + type(unittest_t), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + & new_unittest("valid-version", test_valid_version), & + & new_unittest("valid-equals", test_valid_equals), & + & new_unittest("valid-notequals", test_valid_notequals), & + & new_unittest("valid-compare", test_valid_compare), & + & new_unittest("valid-match", test_valid_match), & + & new_unittest("valid-string", test_valid_string), & + & new_unittest("invalid-empty", test_invalid_empty, should_fail=.true.), & + & new_unittest("invalid-version1", test_invalid_version1, should_fail=.true.), & + & new_unittest("invalid-version2", test_invalid_version2, should_fail=.true.), & + & new_unittest("invalid-version3", test_invalid_version3, should_fail=.true.), & + & new_unittest("invalid-overflow", test_invalid_overflow, should_fail=.true.)] + + end subroutine collect_versioning + + + !> Read valid version strings + subroutine test_valid_version(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(version_t) :: version + + call new_version(version, "8.9.0", error) + if (allocated(error)) return + + call new_version(version, "2020.10.003", error) + + end subroutine test_valid_version + + + !> Compare versions for equality + subroutine test_valid_equals(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(version_t) :: v1, v2 + type(version_t) :: varray(4) + + call new_version(v1, [1, 2, 0]) + call new_version(v2, [1, 2]) + + if (.not. v1 == v2) then + call test_failed(error, "Version comparison failed") + return + end if + + if (.not. v2 == v1) then + call test_failed(error, "Version comparison failed") + return + end if + + call new_version(v1, [0, 9, 0]) + call new_version(v2, [0, 9]) + + if (.not. v1.eq.v2) then + call test_failed(error, "Version comparison failed") + return + end if + + if (.not. v2.eq.v1) then + call test_failed(error, "Version comparison failed") + return + end if + + call new_version(v1, [2020]) + call new_version(v2, [2020, 0]) + + if (.not. v1 == v2) then + call test_failed(error, "Version comparison failed") + return + end if + + if (.not. v2 == v1) then + call test_failed(error, "Version comparison failed") + return + end if + + call new_version(v1, [20, 1]) + call new_version(varray(1), [19]) + call new_version(varray(2), [18, 2]) + call new_version(varray(3), [20, 1]) + call new_version(varray(4), [1, 3, 1]) + + if (.not. any(v1 == varray)) then + call test_failed(error, "Version comparison failed") + return + end if + + end subroutine test_valid_equals + + + !> Compare versions for mismatch + subroutine test_valid_notequals(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(version_t) :: v1, v2 + type(version_t) :: varray(4) + + call new_version(v1, [2020, 3, 1]) + call new_version(v2, [2020, 3]) + + if (.not. v1 /= v2) then + call test_failed(error, "Version comparison failed") + return + end if + + if (.not. v2 /= v1) then + call test_failed(error, "Version comparison failed") + return + end if + + call new_version(v1, [0, 9, 1]) + call new_version(v2, [0, 9]) + + if (.not. v1.ne.v2) then + call test_failed(error, "Version comparison failed") + return + end if + + if (.not. v2.ne.v1) then + call test_failed(error, "Version comparison failed") + return + end if + + call new_version(v1, [2020]) + call new_version(v2, [0, 2020]) + + if (.not. v2 /= v1) then + call test_failed(error, "Version comparison failed") + return + end if + + if (.not. v1 /= v2) then + call test_failed(error, "Version comparison failed") + return + end if + + call new_version(v1, [20, 1]) + call new_version(varray(1), [19]) + call new_version(varray(2), [18, 2]) + call new_version(varray(3), [18, 1]) + call new_version(varray(4), [1, 3, 1]) + + if (.not. any(v1 /= varray)) then + call test_failed(error, "Version comparison failed") + return + end if + + end subroutine test_valid_notequals + + + !> Relative comparison of versions + subroutine test_valid_compare(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(version_t) :: v1, v2 + type(version_t) :: varray(4) + + call new_version(v1, [10]) + call new_version(v2, [1]) + + if (.not. v1 > v2) then + call test_failed(error, "Version comparison failed (gt)") + return + end if + + if (.not. v1 >= v2) then + call test_failed(error, "Version comparison failed (ge)") + return + end if + + if (.not. v2 < v1) then + call test_failed(error, "Version comparison failed (lt)") + return + end if + + if (.not. v2 <= v1) then + call test_failed(error, "Version comparison failed (le)") + return + end if + + call new_version(v1, [1, 0, 8]) + call new_version(v2, [1, 0]) + + if (.not. v1 .gt. v2) then + call test_failed(error, "Version comparison failed (gt)") + return + end if + + if (.not. v1 .ge. v2) then + call test_failed(error, "Version comparison failed (ge)") + return + end if + + if (.not. v2 .lt. v1) then + call test_failed(error, "Version comparison failed (lt)") + return + end if + + if (.not. v2 .le. v1) then + call test_failed(error, "Version comparison failed (le)") + return + end if + + call new_version(v1, [1, 2]) + call new_version(v2, [1, 2, 0]) + + if (v1 > v2) then + call test_failed(error, "Version comparison failed (gt)") + return + end if + + if (.not. v1 >= v2) then + call test_failed(error, "Version comparison failed (ge)") + return + end if + + if (v2 < v1) then + call test_failed(error, "Version comparison failed (lt)") + return + end if + + if (.not. v2 <= v1) then + call test_failed(error, "Version comparison failed (le)") + return + end if + + call new_version(v1, [20, 1]) + call new_version(varray(1), [19]) + call new_version(varray(2), [18, 2]) + call new_version(varray(3), [18, 1]) + call new_version(varray(4), [1, 3, 1]) + + if (.not. all(v1 > varray)) then + call test_failed(error, "Version comparison failed (gt)") + return + end if + + end subroutine test_valid_compare + + + !> Semantic version matching + subroutine test_valid_match(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(version_t) :: v1, v2 + type(version_t) :: varray(4) + + call new_version(v1, [1, 1, 0]) + call new_version(v2, [1]) + + if (.not. (v1 .match. v2)) then + call test_failed(error, "Version comparison failed (match)") + return + end if + + if (v2 .match. v1) then + call test_failed(error, "Version comparison failed (match)") + return + end if + + call new_version(v1, [0, 5, 8]) + call new_version(v2, [0, 5]) + + if (.not. (v1 .match. v2)) then + call test_failed(error, "Version comparison failed (match)") + return + end if + + if (v2 .match. v1) then + call test_failed(error, "Version comparison failed (match)") + return + end if + + call new_version(v1, [1, 2]) + call new_version(v2, [1, 2, 0]) + + if (.not. (v1 .match. v2)) then + call test_failed(error, "Version comparison failed (match)") + return + end if + + if (.not. (v2 .match. v1)) then + call test_failed(error, "Version comparison failed (match)") + return + end if + + end subroutine test_valid_match + + + !> Test if version string is preserved + subroutine test_valid_string(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + character(len=*), parameter :: str_in = "20.1.100" + character(len=:), allocatable :: str_out + type(version_t) :: version + + call new_version(version, str_in, error) + if (allocated(error)) return + call version%to_string(str_out) + + if (str_in /= str_out) then + call test_failed(error, "Expected "//str_in//" but got "//str_out) + end if + + end subroutine test_valid_string + + + !> Empty string does not represent a version + subroutine test_invalid_empty(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(version_t) :: version + + call new_version(version, "", error) + + end subroutine test_invalid_empty + + + !> Version is invalid with trailing dots + subroutine test_invalid_version1(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(version_t) :: version + + call new_version(version, "1.", error) + + end subroutine test_invalid_version1 + + + !> Version is invalid with multiple dots + subroutine test_invalid_version2(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(version_t) :: version + + call new_version(version, "1..1", error) + + end subroutine test_invalid_version2 + + + !> Version is invalid if it is not a version + subroutine test_invalid_version3(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(version_t) :: version + + call new_version(version, "one", error) + + end subroutine test_invalid_version3 + + + !> Check if overflows of the internal size constraint are handled gracefully + subroutine test_invalid_overflow(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(version_t) :: version + + call new_version(version, "0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0", error) + + end subroutine test_invalid_overflow + + +end module test_versioning diff --git a/test/fpm_test/testsuite.f90 b/test/fpm_test/testsuite.f90 new file mode 100644 index 0000000..124d19a --- /dev/null +++ b/test/fpm_test/testsuite.f90 @@ -0,0 +1,286 @@ +!> Define some procedures to automate collecting and launching of tests +module testsuite + use fpm_error, only : error_t, test_failed => fatal_error + implicit none + private + + public :: run_testsuite, run_selected, new_unittest, new_testsuite, test_failed + public :: select_test, select_suite + public :: check_string + public :: unittest_t, testsuite_t, error_t + + + abstract interface + !> Entry point for tests + subroutine test_interface(error) + import :: error_t + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + end subroutine test_interface + end interface + + + !> Declaration of a unit test + type :: unittest_t + + !> Name of the test + character(len=:), allocatable :: name + + !> Entry point of the test + procedure(test_interface), pointer, nopass :: test => null() + + !> Whether test is supposed to fail + logical :: should_fail = .false. + + end type unittest_t + + + abstract interface + !> Collect all tests + subroutine collect_interface(testsuite) + import :: unittest_t + + !> Collection of tests + type(unittest_t), allocatable, intent(out) :: testsuite(:) + + end subroutine collect_interface + end interface + + + !> Collection of unit tests + type :: testsuite_t + + !> Name of the testsuite + character(len=:), allocatable :: name + + !> Entry point of the test + procedure(collect_interface), pointer, nopass :: collect => null() + + end type testsuite_t + + + character(len=*), parameter :: fmt = '("#", *(1x, a))' + character(len=*), parameter :: indent = repeat(" ", 5) // repeat(".", 3) + + +contains + + + !> Driver for testsuite + subroutine run_testsuite(collect, unit, stat) + + !> Collect tests + procedure(collect_interface) :: collect + + !> Unit for IO + integer, intent(in) :: unit + + !> Number of failed tests + integer, intent(inout) :: stat + + type(unittest_t), allocatable :: testsuite(:) + integer :: ii + + call collect(testsuite) + + do ii = 1, size(testsuite) + write(unit, '("#", 3(1x, a), 1x, "(", i0, "/", i0, ")")') & + & "Starting", testsuite(ii)%name, "...", ii, size(testsuite) + call run_unittest(testsuite(ii), unit, stat) + end do + + end subroutine run_testsuite + + + !> Driver for selective testing + subroutine run_selected(collect, name, unit, stat) + + !> Collect tests + procedure(collect_interface) :: collect + + !> Name of the selected test + character(len=*), intent(in) :: name + + !> Unit for IO + integer, intent(in) :: unit + + !> Number of failed tests + integer, intent(inout) :: stat + + type(unittest_t), allocatable :: testsuite(:) + integer :: ii + + call collect(testsuite) + + ii = select_test(testsuite, name) + + if (ii > 0 .and. ii <= size(testsuite)) then + call run_unittest(testsuite(ii), unit, stat) + else + write(unit, fmt) "Available tests:" + do ii = 1, size(testsuite) + write(unit, fmt) "-", testsuite(ii)%name + end do + stat = -huge(ii) + end if + + end subroutine run_selected + + + !> Run a selected unit test + subroutine run_unittest(test, unit, stat) + + !> Unit test + type(unittest_t), intent(in) :: test + + !> Unit for IO + integer, intent(in) :: unit + + !> Number of failed tests + integer, intent(inout) :: stat + + type(error_t), allocatable :: error + + call test%test(error) + if (allocated(error) .neqv. test%should_fail) then + if (test%should_fail) then + write(unit, fmt) indent, test%name, "[UNEXPECTED PASS]" + else + write(unit, fmt) indent, test%name, "[FAILED]" + end if + stat = stat + 1 + else + if (test%should_fail) then + write(unit, fmt) indent, test%name, "[EXPECTED FAIL]" + else + write(unit, fmt) indent, test%name, "[PASSED]" + end if + end if + if (allocated(error)) then + write(unit, fmt) "Message:", error%message + end if + + end subroutine run_unittest + + + !> Select a unit test from all available tests + function select_test(tests, name) result(pos) + + !> Name identifying the test suite + character(len=*), intent(in) :: name + + !> Available unit tests + type(unittest_t) :: tests(:) + + !> Selected test suite + integer :: pos + + integer :: it + + pos = 0 + do it = 1, size(tests) + if (name == tests(it)%name) then + pos = it + exit + end if + end do + + end function select_test + + + !> Select a test suite from all available suites + function select_suite(suites, name) result(pos) + + !> Name identifying the test suite + character(len=*), intent(in) :: name + + !> Available test suites + type(testsuite_t) :: suites(:) + + !> Selected test suite + integer :: pos + + integer :: it + + pos = 0 + do it = 1, size(suites) + if (name == suites(it)%name) then + pos = it + exit + end if + end do + + end function select_suite + + + !> Register a new unit test + function new_unittest(name, test, should_fail) result(self) + + !> Name of the test + character(len=*), intent(in) :: name + + !> Entry point for the test + procedure(test_interface) :: test + + !> Whether test is supposed to error or not + logical, intent(in), optional :: should_fail + + !> Newly registered test + type(unittest_t) :: self + + self%name = name + self%test => test + if (present(should_fail)) self%should_fail = should_fail + + end function new_unittest + + + !> Register a new testsuite + function new_testsuite(name, collect) result(self) + + !> Name of the testsuite + character(len=*), intent(in) :: name + + !> Entry point to collect tests + procedure(collect_interface) :: collect + + !> Newly registered testsuite + type(testsuite_t) :: self + + self%name = name + self%collect => collect + + end function new_testsuite + + + !> Check a deferred length character variable against a reference value + subroutine check_string(error, actual, expected, name) + + !> 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 diff --git a/test/help_test/help_test.f90 b/test/help_test/help_test.f90 new file mode 100644 index 0000000..8f0c455 --- /dev/null +++ b/test/help_test/help_test.f90 @@ -0,0 +1,292 @@ +program help_test +! note hardcoded len=k1 instead of len=: in this test is a work-around a gfortran bug in old +! pre-v8.3 versions +use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, stderr=>error_unit +use fpm_filesystem, only : dirname, join_path, exists +use fpm_environment, only : get_os_type, OS_WINDOWS +implicit none +integer :: i, j +integer :: be, af +character(len=:),allocatable :: path +integer :: estat, cstat +integer,parameter :: k1=132 +character(len=k1) :: message +logical,allocatable :: tally(:) +!intel-bug!character(len=:),allocatable :: book1(:), book2(:) +character(len=k1),allocatable :: book1(:), book2(:) +!intel-bug!character(len=:),allocatable :: page1(:) +character(len=k1),allocatable :: page1(:) +integer :: lines +integer :: chars +! run a variety of "fpm help" variations and verify expected files are generated +character(len=*),parameter :: cmds(*) = [character(len=80) :: & +! build manual as pieces using various help commands +! debug version +' --version ',& ! verify fpm version being used +' --help > fpm_scratch_help.txt',& +' help new >> fpm_scratch_help.txt',& +' help update >> fpm_scratch_help.txt',& +' build --help >> fpm_scratch_help.txt',& +' help run >> fpm_scratch_help.txt',& +' help test >> fpm_scratch_help.txt',& +' help runner >> fpm_scratch_help.txt',& +' help install >> fpm_scratch_help.txt',& +' help list >> fpm_scratch_help.txt',& +' help help >> fpm_scratch_help.txt',& +' --version >> fpm_scratch_help.txt',& +! generate manual +' help manual > fpm_scratch_manual.txt'] + +!'fpm run >> fpm_scratch_help.txt',& +!'fpm run -- --list >> fpm_scratch_help.txt',& +!'fpm run -- list --list >> fpm_scratch_help.txt',& +character(len=*),parameter :: names(*)=[character(len=10) ::& + 'fpm','new','update','build','run','test','runner','install','list','help'] +character(len=:), allocatable :: prog +integer :: length + + ! FIXME: Super hacky way to get the name of the fpm executable, + ! it works better than invoking fpm again but should be replaced ASAP. + call get_command_argument(0, length=length) + allocate(character(len=length) :: prog) + call get_command_argument(0, prog) + path = dirname(prog) + if (get_os_type() == OS_WINDOWS) then + prog = join_path(path, "..", "app", "fpm.exe") + if (.not.exists(prog)) then + prog = join_path(path, "..", "..", "app", "fpm.exe") + end if + else + prog = join_path(path, "..", "app", "fpm") + if (.not.exists(prog)) then + prog = join_path(path, "..", "..", "app", "fpm") + end if + end if + + write(*,'(g0:,1x)')'TEST help SUBCOMMAND STARTED' + if(allocated(tally))deallocate(tally) + allocate(tally(0)) + call wipe('fpm_scratch_help.txt') + call wipe('fpm_scratch_manual.txt') + + ! check that output has NAME SYNOPSIS DESCRIPTION + do i=1,size(names) + write(*,*)'check '//names(i)//' for NAME SYNOPSIS DESCRIPTION' + path= prog // ' help '//names(i)//' >fpm_scratch_help.txt' + message='' + call execute_command_line(path,exitstat=estat,cmdstat=cstat,cmdmsg=message) + write(*,'(*(g0))')'CMD=',path,' EXITSTAT=',estat,' CMDSTAT=',cstat,' MESSAGE=',trim(message) + tally=[tally,all([estat.eq.0,cstat.eq.0])] + call swallow('fpm_scratch_help.txt',page1) + if(size(page1).lt.3)then + write(*,*)'help for '//names(i)//' ridiculiously small' + tally=[tally,.false.] + exit + endif + !!write(*,*)findloc(page1,'NAME').eq.1 + be=count(.not.tally) + tally=[tally,count(page1.eq.'NAME').eq.1] + tally=[tally,count(page1.eq.'SYNOPSIS').eq.1] + tally=[tally,count(page1.eq.'DESCRIPTION').eq.1] + af=count(.not.tally) + if(be.ne.af)then + write(*,*)'missing expected sections in ',names(i) + write(*,*)page1(1) ! assuming at least size 1 for debugging mingw + write(*,*)count(page1.eq.'NAME') + write(*,*)count(page1.eq.'SYNOPSIS') + write(*,*)count(page1.eq.'DESCRIPTION') + write(*,'(a)')page1 + endif + write(*,*)'have completed ',count(tally),' tests' + call wipe('fpm_scratch_help.txt') + enddo + + + ! execute the fpm(1) commands + do i=1,size(cmds) + message='' + path= prog // cmds(i) + call execute_command_line(path,exitstat=estat,cmdstat=cstat,cmdmsg=message) + write(*,'(*(g0))')'CMD=',path,' EXITSTAT=',estat,' CMDSTAT=',cstat,' MESSAGE=',trim(message) + tally=[tally,all([estat.eq.0,cstat.eq.0])] + enddo + + ! compare book written in fragments with manual + call swallow('fpm_scratch_help.txt',book1) + call swallow('fpm_scratch_manual.txt',book2) + ! get rid of lines from run() which is not on stderr at the moment + book1=pack(book1,index(book1,' + build/').eq.0) + book2=pack(book1,index(book2,' + build/').eq.0) + write(*,*)'book1 ',size(book1), len(book1) + write(*,*)'book2 ',size(book2), len(book2) + if(size(book1).ne.size(book2))then + write(*,*)'manual and "debug" appended pages are not the same size' + tally=[tally,.false.] + else + if(all(book1.ne.book2))then + tally=[tally,.false.] + write(*,*)'manual and "debug" appended pages are not the same' + else + write(*,*)'manual and "debug" appended pages are the same' + tally=[tally,.true.] + endif + endif + + ! overall size of manual + !chars=size(book2) + !lines=max(count(char(10).eq.book2),count(char(13).eq.book2)) + chars=sum(len_trim(book2)) ! SUM TRIMMED LENGTH + lines=size(book2) + if( (chars.lt.12000) .or. (lines.lt.350) )then + write(*,*)'"debug" manual is suspiciously small, bytes=',chars,' lines=',lines + tally=[tally,.false.] + else + write(*,*)'"debug" manual size in bytes=',chars,' lines=',lines + tally=[tally,.true.] + endif + + write(*,'("HELP TEST TALLY=",*(g0))')tally + call wipe('fpm_scratch_help.txt') + call wipe('fpm_scratch_manual.txt') + if(all(tally))then + write(*,'(*(g0))')'PASSED: all ',count(tally),' tests passed ' + else + write(*,*)'FAILED: PASSED=',count(tally),' FAILED=',count(.not.tally) + stop 5 + endif + write(*,'(g0:,1x)')'TEST help SUBCOMMAND COMPLETE' +contains + +subroutine wipe(filename) +character(len=*),intent(in) :: filename +integer :: ios +integer :: lun +character(len=k1) :: message +open(file=filename,newunit=lun,iostat=ios,iomsg=message) +if(ios.eq.0)then + close(unit=lun,iostat=ios,status='delete',iomsg=message) + if(ios.ne.0)then + write(*,*)''//trim(message) + endif +else + write(*,*)''//trim(message) +endif +end subroutine wipe + +subroutine slurp(filename,text) +implicit none +!$@(#) M_io::slurp(3f): allocate text array and read file filename into it +character(*),intent(in) :: filename ! filename to shlep +character(len=1),allocatable,intent(out) :: text(:) ! array to hold file +integer :: nchars, igetunit, ios +character(len=k1) :: message +character(len=4096) :: local_filename + ios=0 + nchars=0 + message='' + open(newunit=igetunit, file=trim(filename), action="read", iomsg=message,& + &form="unformatted", access="stream",status='old',iostat=ios) + local_filename=filename + if(ios.eq.0)then ! if file was successfully opened + inquire(unit=igetunit, size=nchars) + if(nchars.le.0)then + call stderr_local( '*slurp* empty file '//trim(local_filename) ) + return + endif + ! read file into text array + if(allocated(text))deallocate(text) ! make sure text array not allocated + allocate ( text(nchars) ) ! make enough storage to hold file + read(igetunit,iostat=ios,iomsg=message) text ! load input file -> text array + if(ios.ne.0)then + call stderr_local( '*slurp* bad read of '//trim(local_filename)//':'//trim(message) ) + endif + else + call stderr_local('*slurp* '//message) + allocate ( text(0) ) ! make enough storage to hold file + endif + close(iostat=ios,unit=igetunit) ! close if opened successfully or not +end subroutine slurp + +subroutine stderr_local(message) +character(len=*) :: message + write(*,'(a)')trim(message) ! write message to standard error +end subroutine stderr_local + +subroutine swallow(FILENAME,pageout) +implicit none +character(len=*),intent(in) :: FILENAME ! file to read +!intel-bug!character(len=:),allocatable,intent(out) :: pageout(:) ! page to hold file in memory +character(len=k1),allocatable,intent(out) :: pageout(:) ! page to hold file in memory +character(len=1),allocatable :: text(:) ! array to hold file in memory + + call slurp(FILENAME,text) ! allocate character array and copy file into it + + if(.not.allocated(text))then + write(*,*)'*swallow* failed to load file '//FILENAME + else ! convert array of characters to array of lines + pageout=page(text) + deallocate(text) ! release memory + endif +end subroutine swallow + +function page(array) result (table) + +!$@(#) M_strings::page(3fp): function to copy char array to page of text + +character(len=1),intent(in) :: array(:) +!intel-bug!character(len=:),allocatable :: table(:) +character(len=k1),allocatable :: table(:) +integer :: i +integer :: linelength +integer :: length +integer :: lines +integer :: linecount +integer :: position +integer :: sz +!!character(len=1),parameter :: nl=new_line('A') +character(len=1),parameter :: nl=char(10) +character(len=1),parameter :: cr=char(13) + lines=0 + linelength=0 + length=0 + sz=size(array) + do i=1,sz + if(array(i).eq.nl)then + linelength=max(linelength,length) + lines=lines+1 + length=0 + else + length=length+1 + endif + enddo + if(sz.gt.0)then + if(array(sz).ne.nl)then + lines=lines+1 + endif + endif + + if(allocated(table))deallocate(table) + !intel-bug!allocate(character(len=linelength) :: table(lines)) + allocate(character(len=k1) :: table(lines)) + table=' ' + linecount=1 + position=1 + do i=1,sz + if(array(i).eq.nl)then + linecount=linecount+1 + position=1 + elseif(array(i).eq.cr)then + elseif(linelength.ne.0)then + if(position.gt.len(table))then + write(*,*)' adding character past edge of text',table(linecount),array(i) + elseif(linecount.gt.size(table))then + write(*,*)' adding line past end of text',linecount,size(table) + else + table(linecount)(position:position)=array(i) + endif + position=position+1 + endif + enddo +end function page + +end program help_test diff --git a/test/new_test/new_test.f90 b/test/new_test/new_test.f90 new file mode 100644 index 0000000..3c8c453 --- /dev/null +++ b/test/new_test/new_test.f90 @@ -0,0 +1,187 @@ +program new_test +use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, stderr=>error_unit +use fpm_filesystem, only : is_dir, list_files, exists, windows_path, join_path, & + dirname +use fpm_strings, only : string_t, operator(.in.) +use fpm_environment, only : run, get_os_type +use fpm_environment, only : OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_WINDOWS +implicit none +type(string_t), allocatable :: file_names(:) +integer :: i, j, k +character(len=:),allocatable :: cmdpath +character(len=:),allocatable :: path +character(len=*),parameter :: scr = 'fpm_scratch_' +character(len=*),parameter :: cmds(*) = [character(len=80) :: & +! run a variety of "fpm new" variations and verify expected files are generated +' new', & +' new name-with-hyphens', & +' new '//scr//'A', & +' new '//scr//'B --lib', & +' new '//scr//'C --app', & +' new '//scr//'D --test', & +' new '//scr//'E --lib --test ', & +' new '//scr//'F --lib --app', & +' new '//scr//'G --test --app', & +' new '//scr//'H --example', & +' new '//scr//'BB --lib', & +' new '//scr//'BB --test ', & +' new '//scr//'BB --backfill --test', & +' new '//scr//'CC --test --src --app', & +' new --version', & +' new --help'] +integer :: estat, cstat +character(len=256) :: message +character(len=:),allocatable :: directories(:) +character(len=:),allocatable :: shortdirs(:) +character(len=:),allocatable :: expected(:) +logical,allocatable :: tally(:) +logical :: IS_OS_WINDOWS + write(*,'(g0:,1x)')'TEST new SUBCOMMAND (draft):' + + cmdpath = get_command_path() + allocate(tally(0)) + shortdirs=[character(len=80) :: 'A','B','C','D','E','F','G','H','BB','CC'] + allocate(character(len=80) :: directories(size(shortdirs))) + + !! SEE IF EXPECTED FILES ARE GENERATED + !! Issues: + !! o assuming fpm command is in expected path and the new version + !! o DOS versus POSIX filenames + is_os_windows=.false. + select case (get_os_type()) + case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD) + call execute_command_line('rm -rf fpm_scratch_*',exitstat=estat,cmdstat=cstat,cmdmsg=message) + path=cmdpath + case (OS_WINDOWS) + path=windows_path(cmdpath) + is_os_windows=.true. + call execute_command_line('rmdir fpm_scratch_* /s /q',exitstat=estat,cmdstat=cstat,cmdmsg=message) + case default + write(*,*)'ERROR: unknown OS. Stopping test' + stop 2 + end select + do i=1,size(directories) + directories(i)=scr//trim(shortdirs(i)) + if( is_dir(trim(directories(i))) ) then + write(*,*)'ERROR:',trim( directories(i) ),' already exists' + write(*,*)' you must remove scratch directories before performing this test' + write(*,'(*(g0:,1x))')'directories:',(trim(directories(j)),j=1,size(directories)),'name-with-hyphens' + stop + endif + enddo + ! execute the fpm(1) commands + do i=1,size(cmds) + message='' + write(*,*)path//' '//cmds(i) + call execute_command_line(path//' '//cmds(i),exitstat=estat,cmdstat=cstat,cmdmsg=message) + write(*,'(*(g0))')'CMD=',trim(cmds(i)),' EXITSTAT=',estat,' CMDSTAT=',cstat,' MESSAGE=',trim(message) + enddo + + if( is_dir('name-with-hyphens') ) then + tally=[tally,.true.] + + else + write(*,*)'ERROR: directory name-with-hyphens/ exists' + tally=[tally,.false.] + endif + + ! assuming hidden files in .git and .gitignore are ignored for now + TESTS: do i=1,size(directories) + ! test if expected directory exists + if( .not. is_dir(trim( directories(i))) ) then + tally=[tally,.false.] + write(*,*)'ERROR:',trim( directories(i) ),' is not a directory' + else + select case(shortdirs(i)) + case('A'); expected=[ character(len=80)::& + &'A/app','A/fpm.toml','A/README.md','A/src','A/test','A/app/main.f90','A/src/'//scr//'A.f90','A/test/check.f90'] + case('B'); expected=[ character(len=80)::& + &'B/fpm.toml','B/README.md','B/src','B/src/'//scr//'B.f90'] + case('C'); expected=[ character(len=80)::& + &'C/app','C/fpm.toml','C/README.md','C/app/main.f90'] + case('D'); expected=[ character(len=80)::& + &'D/fpm.toml','D/README.md','D/test','D/test/check.f90'] + case('E'); expected=[ character(len=80)::& + &'E/fpm.toml','E/README.md','E/src','E/test','E/src/'//scr//'E.f90','E/test/check.f90'] + case('F'); expected=[ character(len=80)::& + &'F/app','F/fpm.toml','F/README.md','F/src','F/app/main.f90','F/src/'//scr//'F.f90'] + case('G'); expected=[ character(len=80)::& + &'G/app','G/fpm.toml','G/README.md','G/test','G/app/main.f90','G/test/check.f90'] + case('H'); expected=[ character(len=80)::& + &'H/example','H/fpm.toml','H/README.md','H/example/demo.f90'] + case('BB'); expected=[ character(len=80)::& + &'BB/fpm.toml','BB/README.md','BB/src','BB/test','BB/src/'//scr//'BB.f90','BB/test/check.f90'] + case('CC'); expected=[ character(len=80)::& + &'CC/app','CC/fpm.toml','CC/README.md','CC/src','CC/test','CC/app/main.f90','CC/src/'//scr//'CC.f90','CC/test/check.f90'] + case default + write(*,*)'ERROR: internal error. unknown directory name ',trim(shortdirs(i)) + stop 4 + end select + !! MSwindows has hidden files in it + !! Warning: This only looks for expected files. If there are more files than expected it does not fail + call list_files(trim(directories(i)), file_names,recurse=.true.) + + if(size(expected).ne.size(file_names))then + write(*,*)'WARNING: unexpected number of files in file list=',size(file_names),' expected ',size(expected) + write(*,'("EXPECTED: ",*(g0:,","))')(scr//trim(expected(j)),j=1,size(expected)) + write(*,'("FOUND: ",*(g0:,","))')(trim(file_names(j)%s),j=1,size(file_names)) + endif + + do j=1,size(expected) + + expected(j)=scr//expected(j) + if(is_os_windows) expected(j)=windows_path(expected(j)) + if( .not.(trim(expected(j)).in.file_names) )then + tally=[tally,.false.] + write(*,'("ERROR: FOUND ",*(g0:,", "))')( trim(file_names(k)%s), k=1,size(file_names) ) + write(*,'(*(g0))')' BUT NO MATCH FOR ',expected(j) + tally=[tally,.false.] + cycle TESTS + endif + enddo + tally=[tally,.true.] + endif + enddo TESTS + + ! clean up scratch files; might want an option to leave them for inspection + select case (get_os_type()) + case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD) + call execute_command_line('rm -rf fpm_scratch_*',exitstat=estat,cmdstat=cstat,cmdmsg=message) + case (OS_WINDOWS) + call execute_command_line('rmdir fpm_scratch_* /s /q',exitstat=estat,cmdstat=cstat,cmdmsg=message) + end select + + write(*,'("new TEST TALLY=",*(g0))')tally + if(all(tally))then + write(*,'(*(g0))')'PASSED: all ',count(tally),' tests passed ' + else + write(*,*)'FAILED: PASSED=',count(tally),' FAILED=',count(.not.tally) + stop 5 + endif +contains + function get_command_path() result(prog) + character(len=:), allocatable :: prog + + character(len=:), allocatable :: path + integer :: length + + ! FIXME: Super hacky way to get the name of the fpm executable, + ! it works better than invoking fpm again but should be replaced ASAP. + call get_command_argument(0, length=length) + allocate(character(len=length) :: prog) + call get_command_argument(0, prog) + path = dirname(prog) + if (get_os_type() == OS_WINDOWS) then + prog = join_path(path, "..", "app", "fpm.exe") + if (.not.exists(prog)) then + prog = join_path(path, "..", "..", "app", "fpm.exe") + end if + else + prog = join_path(path, "..", "app", "fpm") + if (.not.exists(prog)) then + prog = join_path(path, "..", "..", "app", "fpm") + end if + end if + + end function +end program new_test -- cgit v1.2.3